Commit cadb5956 authored by Tobias C. Rittweiler's avatar Tobias C. Rittweiler

Add :FUZE clause; docstring updates.

darcs-hash:20090926181040-f5546-24297708e9715fd502116243b072871fbade579c.gz
parent 2a786e71
......@@ -16,40 +16,48 @@
(declare (ignorable reqs opts rest keys))
`(progn
(declaim (ftype (function ,arg-typespec ,value-typespec) ,name))
(defun ,name ,lambda-list
,docstring
,@decls
;; SBCL will interpret the ftype declaration as
;; assertion and will insert type checks for us.
#-sbcl
(progn
;; CHECK-TYPE required parameters
,@(loop for req-arg in reqs
for req-type = (pop type-list)
do (assert req-type)
collect `(check-type ,req-arg ,req-type))
(locally
;;; Muffle the annoying "&OPTIONAL and &KEY found in
;;; the same lambda list" style-warning
#+sbcl (declare (sb-ext:muffle-conditions style-warning))
(defun ,name ,lambda-list
,docstring
#+sbcl (declare (sb-ext:unmuffle-conditions style-warning))
,@decls
;; SBCL will interpret the ftype declaration as
;; assertion and will insert type checks for us.
#-sbcl
(progn
;; CHECK-TYPE required parameters
,@(loop for req-arg in reqs
for req-type = (pop type-list)
do (assert req-type)
collect `(check-type ,req-arg ,req-type))
;; CHECK-TYPE optional parameters
,@(loop initially (assert (or (null opts)
(eq (pop type-list) '&optional)))
for (opt-arg . nil) in opts
for opt-type = (pop type-list)
do (assert opt-type)
collect `(check-type ,opt-arg ,opt-type))
;; CHECK-TYPE optional parameters
,@(loop initially (assert (or (null opts)
(eq (pop type-list) '&optional)))
for (opt-arg . nil) in opts
for opt-type = (pop type-list)
do (assert opt-type)
collect `(check-type ,opt-arg ,opt-type))
;; CHECK-TYPE rest parameter
,@(when rest
(assert (eq (pop type-list) '&rest))
(let ((rest-type (pop type-list)))
(assert rest-type)
`((dolist (x ,rest)
(check-type x ,rest-type)))))
;; CHECK-TYPE rest parameter
,@(when rest
(assert (eq (pop type-list) '&rest))
(let ((rest-type (pop type-list)))
(assert rest-type)
`((dolist (x ,rest)
(check-type x ,rest-type)))))
;; CHECK-TYPE key parameters
,@(loop initially (assert (or (null keys)
(eq (pop type-list) '&key)))
for ((keyword key-arg) . nil) in keys
for (nil key-type) = (find keyword type-list :key #'car)
collect `(check-type ,key-arg ,key-type)))
;; CHECK-TYPE key parameters
,@(loop initially (assert (or (null keys)
(eq (pop type-list) '&key)))
for ((keyword key-arg) . nil) in keys
for (nil key-type) = (find keyword type-list :key #'car)
collect `(check-type ,key-arg ,key-type)))
,@body)))))))
\ No newline at end of file
,@body))))))))
\ No newline at end of file
This diff is collapsed.
......@@ -186,8 +186,8 @@
Thanks to Robert Goldman for making me want to write this library.
Thanks to Stephen Compall, Ariel Badichi, David Lichteblau, Bart
Botta and David Crawford for being early adopters, providing
comments and bugfixes.
Botta, David Crawford, and Pascal Costanza for being early adopters,
providing comments and bugfixes.
"))
(pushnew :named-readtables *features*)
\ No newline at end of file
......@@ -8,7 +8,7 @@
(funcall cdr-fn (cdr entry))))
alist))
(defmacro signals-error-p (name &body body)
(defmacro signals-condition-p (name &body body)
`(handler-case (prog1 nil ,@body)
(,(second name) () t)))
......@@ -21,9 +21,6 @@
(*readtable* (find-readtable name)))
(values (read-from-string string))))
(defun empty-readtable ()
(copy-readtable *empty-readtable*))
(defun random-named-readtable ()
(let ((readtables (list-all-named-readtables)))
(nth (random (length readtables)) readtables)))
......@@ -123,13 +120,13 @@
(deftest empty.1
(null (readtable-content (empty-readtable)))
(null (readtable-content (make-readtable)))
t)
(deftest empty.2
(let ((rt (copy-readtable (find-readtable :standard))))
(readtable= (merge-readtables-into (empty-readtable) rt)
(merge-readtables-into rt (empty-readtable))))
(readtable= (merge-readtables-into (make-readtable) rt)
(merge-readtables-into rt (make-readtable))))
t)
......@@ -191,6 +188,11 @@
#(:a :b :c))
(deftest merge.4
(readtable= (merge-readtables-into (make-readtable) :standard)
(find-readtable :standard))
t)
(deftest merge.5
(let ((A+B+C+standard (merge-readtables-into (copy-named-readtable 'A+B+C)
:standard)))
(readtable= 'standard+A+B+C A+B+C+standard))
......@@ -210,39 +212,39 @@
(deftest reader-macro-conflict.1
(signals-error-p 'reader-macro-conflict
(merge-readtables-into (empty-readtable) 'A 'A-as-X))
(signals-condition-p 'reader-macro-conflict
(merge-readtables-into (make-readtable) 'A 'A-as-X))
t)
(deftest reader-macro-conflict.2
(signals-error-p 'reader-macro-conflict
(merge-readtables-into (empty-readtable) :standard :standard))
(signals-condition-p 'reader-macro-conflict
(merge-readtables-into (make-readtable) :standard :standard))
nil)
(deftest reader-macro-conflict.3
(signals-error-p 'reader-macro-conflict
(merge-readtables-into (empty-readtable) 'A+B+C 'A))
(signals-condition-p 'reader-macro-conflict
(merge-readtables-into (make-readtable) 'A+B+C 'A))
nil)
(deftest reader-macro-conflict.4
(signals-error-p 'reader-macro-conflict
(merge-readtables-into (empty-readtable) :standard 'sharp-paren))
(signals-condition-p 'reader-macro-conflict
(merge-readtables-into (make-readtable) :standard 'sharp-paren))
t)
(deftest readtable-does-not-exist.1
(signals-error-p 'readtable-does-not-exist
(signals-condition-p 'readtable-does-not-exist
(ensure-readtable 'does-not-exist))
t)
(deftest readtable-does-already-exist.1
(signals-error-p 'readtable-does-already-exist
(signals-condition-p 'readtable-does-already-exist
(make-readtable 'A))
t)
(deftest readtable-does-already-exist.2
(signals-error-p 'readtable-does-already-exist
(signals-condition-p 'readtable-does-already-exist
(make-readtable 'A))
t)
......@@ -256,4 +258,20 @@
"(A B C)")
(unregister-readtable 'does-not-exist)))
(:a B :c))
\ No newline at end of file
(:a B :c))
(deftest defreadtable.1
(unwind-protect
(signals-condition-p 'reader-macro-conflict
(eval `(defreadtable does-not-exist (:merge A A-as-X))))
(unregister-readtable 'does-not-exist))
t)
(deftest defreadtable.2
(unwind-protect
(signals-condition-p 't
(eval `(defreadtable does-not-exist (:fuze A A-as-X))))
(unregister-readtable 'does-not-exist))
nil)
Markdown is supported
0% or
You are about to add 0 people to the discussion. Proceed with caution.
Finish editing this message first!
Please register or to comment