diff --git a/ansi-tests/pattern-match.lsp b/ansi-tests/pattern-match.lsp new file mode 100644 index 0000000000000000000000000000000000000000..f2e711ae9f5f09cd04537b95e1d0fe7700393f2b --- /dev/null +++ b/ansi-tests/pattern-match.lsp @@ -0,0 +1,68 @@ +;-*- Mode: Lisp -*- +;;;; Author: Paul Dietz +;;;; Created: Sat Dec 4 18:59:27 2004 +;;;; Contains: Macro for pattern matching on S-exprs + +(in-package :cl-test) + +(defmacro pmatch (pattern form) + (cond + ((consp pattern) + (let ((pcar (car pattern)) + (pcdr (cdr pattern)) + (v (gensym))) + (case pcar + ((:or) + `(let ((,v ,form)) (or ,@(mapcar (lambda (sub) `(pmatch ,sub ,v)) + pcdr)))) + ((:and) + `(let ((,v ,form)) (and ,@(mapcar (lambda (sub) `(pmatch ,sub ,v)) + pcdr)))) + ((:not) + (assert (eql (length pcdr) 1)) + `(not (pmatch ,(car pcdr) ,form))) + (t + `(let ((,v ,form)) + (and (pmatch ,pcar (car ,v)) + (pmatch ,pcdr (cdr ,v)))))))) + ((eql pattern '_) t) + ((null pattern) + `(null ,form)) + ((symbolp pattern) + `(eql (quote ,pattern) ,form)) + (t + `(eql ,pattern ,form)))) + +(defmacro matchcase (form &body cases) + (let* ((v (gensym)) + (cond-cases + (mapcar + #'(lambda (case) + (assert (consp case)) + (let ((pattern (car case)) + (body (cdr case))) + `((pmatch ,pattern ,v) ,@body))) + cases))) + `(let ((,v ,form)) + (cond ,@cond-cases)))) + +(defmacro matchcase* (form &body cases) + (let* ((block-name (gensym "DONE")) + (v (gensym))) + `(block ,block-name + (let ((,v ,form)) + (cond + ,@(mapcar + #'(lambda (case) + (assert (consp case)) + (let ((pat (car case)) + (forms (cdr case)) + (fail-name (gensym "FAIL"))) + `((block ,fail-name + (and (pmatch ,pat ,v) + (macrolet ((fail () '(return-from ,fail-name nil))) + (return-from ,block-name + (progn ,@forms)))))))) + cases)))))) + + diff --git a/ansi-tests/random-class-aux.lsp b/ansi-tests/random-class-aux.lsp new file mode 100644 index 0000000000000000000000000000000000000000..83e8b3f88ef13e97669a7423df743a64793fadf3 --- /dev/null +++ b/ansi-tests/random-class-aux.lsp @@ -0,0 +1,36 @@ +;-*- Mode: Lisp -*- +;;;; Author: Paul Dietz +;;;; Created: Sun Oct 10 07:14:30 2004 +;;;; Contains: Aux. functions for random tests on classes + +(in-package :cl-test) + +(defun random-class-1-fn (&key (n 10) (rep 1000)) + "Randomly break and recreate a linear chain of class definitions" + (assert (typep n '(integer 1)) (n) "N is ~A" n) + (assert (typep rep 'unsigned-byte) (rep) "REP is ~A" rep) + (let ((class-names (make-array n + :initial-contents + (loop for i from 1 to n + collect (make-symbol + (format nil "CLASS-NAME-~D" i)))))) + (unwind-protect + (let ((parents (make-array n :initial-element nil))) + ;; Create classes + (loop for name across class-names + do (eval `(defclass ,name () nil))) + (loop for i = (1+ (random (1- n))) + for name = (elt class-names i) + for parent = (elt parents i) + repeat rep + do (if parent + (progn + (setf (elt parents i) nil) + (eval `(defclass ,name () nil))) + (eval `(defclass ,name + (,(setf (elt parents i) (elt class-names (1- i)))) + nil + ))))) + (loop for name across class-names + do (setf (find-class name) nil))))) + diff --git a/ansi-tests/random-class.lsp b/ansi-tests/random-class.lsp new file mode 100644 index 0000000000000000000000000000000000000000..1453fdd222d03c80d8559212fbc90d643cb74143 --- /dev/null +++ b/ansi-tests/random-class.lsp @@ -0,0 +1,9 @@ +;-*- Mode: Lisp -*- +;;;; Author: Paul Dietz +;;;; Created: Sun Oct 10 07:13:47 2004 +;;;; Contains: Randomized tests on classes + +(in-package :cl-test) + +(compile-and-load "random-class-aux.lsp") +