From: Daniel Kochmański Date: Tue, 18 Aug 2015 13:39:20 +0000 (+0200) Subject: deftype: use destructure directly, remove unused arg X-Git-Tag: ECL-16.0.0~1^2~26 X-Git-Url: http://git.pulsar-zone.net/?a=commitdiff_plain;h=a2ceed9cb3fb31c63af39e5cc8db185dee5d73b9;p=ecl.git deftype: use destructure directly, remove unused arg Removes ENV arg, which were ignored by using destructure directly. Signed-off-by: Daniel Kochmański --- diff --git a/src/cmp/cmpopt.lsp b/src/cmp/cmpopt.lsp index 1bddce4..1774a76 100644 --- a/src/cmp/cmpopt.lsp +++ b/src/cmp/cmpopt.lsp @@ -80,7 +80,7 @@ ;; Complex types defined with DEFTYPE. ((and (atom type) (setq function (get-sysprop type 'SI::DEFTYPE-DEFINITION))) - (expand-typep form object `',(funcall function nil nil) env)) + (expand-typep form object `',(funcall function nil) env)) ;; ;; No optimizations that take up too much space unless requested. ((not (policy-inline-type-checks)) @@ -147,7 +147,7 @@ ;; ;; Complex types with arguments. ((setf function (get-sysprop first 'SI::DEFTYPE-DEFINITION)) - (expand-typep form object `',(funcall function rest nil) env)) + (expand-typep form object `',(funcall function rest) env)) (t form)))) @@ -244,7 +244,7 @@ ;; Complex types defined with DEFTYPE. ((and (atom type) (setq first (get-sysprop type 'SI::DEFTYPE-DEFINITION))) - (expand-coerce form value `',(funcall first nil nil) env)) + (expand-coerce form value `',(funcall first nil) env)) ;; ;; CONS types are not coercible. ((and (consp type) diff --git a/src/lsp/predlib.lsp b/src/lsp/predlib.lsp index 719bca1..9590a5e 100644 --- a/src/lsp/predlib.lsp +++ b/src/lsp/predlib.lsp @@ -59,57 +59,64 @@ Builds a new function which accepts any number of arguments but always outputs N Defines a new type-specifier abbreviation in terms of an 'expansion' function - (lambda (whole env) {DECL}* {FORM}*) + (lambda (whole) {DECL}* {FORM}*) where WHOLE is identical to MACRO-LAMBDA-LIST except that all optional parameters with no default value specified in LAMBDA-LIST defaults to -the symbol '*', but not to NIL. ENV is ignored. When the type system -of ECL encounters a type specifier (NAME arg1 ... argn), it calls the -expansion function with the arguments `(ARG1 ... ARGn) NIL', and uses -the returned value instead of the original type specifier. When the -symbol NAME is used as a type specifier, the expansion function is -called with no argument. The doc-string DOC, if supplied, is saved as -a TYPE doc and can be retrieved by (documentation 'NAME 'type)." +the symbol '*', but not to NIL. When the type system of ECL encounters +a type specifier (NAME arg1 ... argn), it calls the expansion function +with the argument (ARG1 ... ARGn), and uses the returned value instead +of the original type specifier. When the symbol NAME is used as a +type specifier, the expansion function is called with no argument. +The doc-string DOC, if supplied, is saved as a TYPE doc and can be +retrieved by (documentation 'NAME 'type)." (setf lambda-list (copy-tree lambda-list)) - (labels ; add '* as default values - ((set-default (list*) - "Sets default value for optional arguments to *. Doesn't + (multiple-value-bind (decls body documentation) + (si::find-declarations body) + (labels ; add '* as default values + ((set-default (list*) + "Sets default value for optional arguments to *. Doesn't modify arguments which happen to be in lambda-list-keywords." - (when (consp list*) - (let ((variable (car list*))) - (when (and (symbolp variable) - (not (member variable lambda-list-keywords))) - (setf (car list*) `(,variable '*)))) - (set-default (cdr list*)))) - (verify-tree (elt) - "Verifies if ELT is the list containing optional arguments." - (and (consp elt) - (member (car elt) - '(&key &optional)))) - (maptree (function tree test) - "Applies FUNCTION to branches for which TEST resolves to + (when (consp list*) + (let ((variable (car list*))) + (when (and (symbolp variable) + (not (member variable lambda-list-keywords))) + (setf (car list*) `(,variable '*)))) + (set-default (cdr list*)))) + (verify-tree (elt) + "Verifies if ELT is the list containing optional arguments." + (and (consp elt) + (member (car elt) + '(&key &optional)))) + (maptree (function tree test) + "Applies FUNCTION to branches for which TEST resolves to true. MAPTREE doesn't traverse this branch further. It is correct in this context, because we can't create nested lambda-list after both &key and &optional, since it would be considered as default value or an error." - (if (funcall test tree) - (funcall function tree) - (when (consp tree) - (maptree function (car tree) test) - (maptree function (cdr tree) test))))) - (maptree #'set-default lambda-list #'verify-tree)) - (multiple-value-bind (function ppn documentation) - (si::expand-defmacro name lambda-list body nil) - (when (and (null lambda-list) - (consp body) - (null (rest body))) - (let ((form (first body))) - (when (constantp form env) - (setf function (ext:maybe-quote (ext:constant-form-value form env)))))) - `(eval-when (:compile-toplevel :load-toplevel :execute) - ,@(si::expand-set-documentation name 'type documentation) - (do-deftype ',name '(DEFTYPE ,name ,lambda-list ,@body) - ,function)))) + (if (funcall test tree) + (funcall function tree) + (when (consp tree) + (maptree function (car tree) test) + (maptree function (cdr tree) test))))) + (maptree #'set-default lambda-list #'verify-tree)) + (multiple-value-bind (ppn whole dl arg-check ignorables) + (destructure lambda-list nil) + (declare (ignore ppn)) + (let ((function `#'(ext::lambda-block ,name (,whole &aux ,@dl) + (declare (ignorable ,@ignorables)) + ,@decls ,@arg-check + ,@body))) + (when (and (null lambda-list) + (consp body) + (null (rest body))) + (let ((form (first body))) + (when (constantp form env) + (setf function (ext:maybe-quote (ext:constant-form-value form env)))))) + `(eval-when (:compile-toplevel :load-toplevel :execute) + ,@(si::expand-set-documentation name 'type documentation) + (do-deftype ',name '(DEFTYPE ,name ,lambda-list ,@body) + ,function)))))) ;;; Some DEFTYPE definitions. (deftype boolean () @@ -610,7 +617,7 @@ Returns T if X belongs to TYPE; NIL otherwise." (or (endp (cdr i)) (match-dimensions object (second i))))) (t (cond ((get-sysprop tp 'DEFTYPE-DEFINITION) - (typep object (funcall (get-sysprop tp 'DEFTYPE-DEFINITION) i nil))) + (typep object (funcall (get-sysprop tp 'DEFTYPE-DEFINITION) i))) ((consp i) (error-type-specifier type)) ((setq c (find-class type nil)) @@ -658,7 +665,7 @@ Returns T if X belongs to TYPE; NIL otherwise." ;; Loops until the car of type has no DEFTYPE definition. (cond ((symbolp type) (if (setq fd (get-sysprop type 'DEFTYPE-DEFINITION)) - (normalize-type (funcall fd nil nil)) + (normalize-type (funcall fd nil)) (values type nil))) ((clos::classp type) (values type nil)) ((atom type) @@ -666,7 +673,7 @@ Returns T if X belongs to TYPE; NIL otherwise." ((progn (setq tp (car type) i (cdr type)) (setq fd (get-sysprop tp 'DEFTYPE-DEFINITION))) - (normalize-type (funcall fd i nil))) + (normalize-type (funcall fd i))) ((and (eq tp 'INTEGER) (consp (cadr i))) (values tp (list (car i) (1- (caadr i))))) (t (values tp i)))) @@ -678,9 +685,9 @@ Returns T if X belongs to TYPE; NIL otherwise." args nil) (setf base (car type) args (cdr type))) - (let ((fn (get-sysprop base 'SI::DEFTYPE-DEFINITION))) + (let ((fn (get-sysprop base 'DEFTYPE-DEFINITION))) (if fn - (expand-deftype (funcall fn args nil)) + (expand-deftype (funcall fn args)) type)))) ;;************************************************************ @@ -1399,7 +1406,7 @@ if not possible." ((symbolp type) (let ((expander (get-sysprop type 'DEFTYPE-DEFINITION))) (cond (expander - (canonical-type (funcall expander nil nil))) + (canonical-type (funcall expander nil))) ((find-built-in-tag type)) (t (let ((class (find-class type nil))) (if class @@ -1449,7 +1456,7 @@ if not possible." (FUNCTION (canonical-type 'FUNCTION)) (t (let ((expander (get-sysprop (first type) 'DEFTYPE-DEFINITION))) (if expander - (canonical-type (funcall expander (rest type) nil)) + (canonical-type (funcall expander (rest type))) (unless (assoc (first type) *elementary-types*) (throw '+canonical-type-failure+ nil))))))) ((clos::classp type)