Commit 26dc3d8a authored by Jean-Claude Beaudoin's avatar Jean-Claude Beaudoin
Browse files

Make cl:deftype handle declarations correctly.

parent 0777dd08
...@@ -37,7 +37,7 @@ ...@@ -37,7 +37,7 @@
name) name)
;;; DEFTYPE macro. ;;; DEFTYPE macro.
(defmacro deftype (name lambda-list &rest body) (defmacro deftype (name lambda-list &rest decls+body)
"Syntax: (deftype name lambda-list {decl | doc}* {form}*) "Syntax: (deftype name lambda-list {decl | doc}* {form}*)
Defines a new type-specifier abbreviation in terms of an 'expansion' function Defines a new type-specifier abbreviation in terms of an 'expansion' function
(lambda lambda-list1 {DECL}* {FORM}*) (lambda lambda-list1 {DECL}* {FORM}*)
...@@ -50,8 +50,8 @@ type specifier. When the symbol NAME is used as a type specifier, the ...@@ -50,8 +50,8 @@ type specifier. When the symbol NAME is used as a type specifier, the
expansion function is called with no argument. expansion function is called with no argument.
The doc-string DOC, if supplied, is saved as a TYPE doc and can be retrieved The doc-string DOC, if supplied, is saved as a TYPE doc and can be retrieved
by (documentation 'NAME 'type)." by (documentation 'NAME 'type)."
(multiple-value-bind (body doc) (multiple-value-bind (decls body doc)
(remove-documentation body) (find-declarations decls+body)
(setf lambda-list (copy-list lambda-list)) (setf lambda-list (copy-list lambda-list))
(dolist (x '(&optional &key)) (dolist (x '(&optional &key))
(do ((l (rest (member x lambda-list)) (rest l))) (do ((l (rest (member x lambda-list)) (rest l)))
...@@ -63,10 +63,11 @@ by (documentation 'NAME 'type)." ...@@ -63,10 +63,11 @@ by (documentation 'NAME 'type)."
(let ((whole-var (gensym)) (env-var (gensym))) (let ((whole-var (gensym)) (env-var (gensym)))
`(define-when (:compile-toplevel :load-toplevel :execute) `(define-when (:compile-toplevel :load-toplevel :execute)
,@(si::expand-set-documentation name 'type doc) ,@(si::expand-set-documentation name 'type doc)
(do-deftype ',name '(DEFTYPE ,name ,lambda-list ,@body) (do-deftype ',name '(DEFTYPE ,name ,lambda-list ,@decls+body)
#'(si::LAMBDA (,whole-var ,env-var) #'(si::LAMBDA (,whole-var ,env-var)
(declare (ignorable ,env-var)) (declare (ignorable ,env-var))
(destructuring-bind ,lambda-list (if (consp ,whole-var) (cdr ,whole-var) nil) (destructuring-bind ,lambda-list (if (consp ,whole-var) (cdr ,whole-var) nil)
,@decls
(block ,name (block ,name
,@body)))))))) ,@body))))))))
......
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