Skip to content
Snippets Groups Projects
Commit 9365b190 authored by pfdietz's avatar pfdietz
Browse files

some working files that are not yet loaded

parent ce74de66
No related branches found
No related tags found
No related merge requests found
;-*- 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))))))
;-*- 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)))))
;-*- 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")
0% Loading or .
You are about to add 0 people to the discussion. Proceed with caution.
Finish editing this message first!
Please register or to comment