X-Git-Url: http://repo.macrolet.net/gitweb/?a=blobdiff_plain;f=src%2Fcode%2Fparse-defmacro.lisp;h=b783de5d70fbf1fa9b7f98c801aa144535c1c84a;hb=1c7cf626e647866aec33c4a6e7e8edb26554fe3b;hp=af0c7baf13a0701ede0b732f5bd9feada2cba3d8;hpb=a208de2a9ab6a63c27f3e6c291fea9f7c4d774a1;p=sbcl.git diff --git a/src/code/parse-defmacro.lisp b/src/code/parse-defmacro.lisp index af0c7ba..b783de5 100644 --- a/src/code/parse-defmacro.lisp +++ b/src/code/parse-defmacro.lisp @@ -31,7 +31,7 @@ ;;; Return, as multiple values, a body, possibly a DECLARE form to put ;;; where this code is inserted, the documentation for the parsed ;;; body, and bounds on the number of arguments. -(defun parse-defmacro (lambda-list arg-list-name body name error-kind +(defun parse-defmacro (lambda-list arg-list-name body name context &key (anonymousp nil) (doc-string-allowed t) @@ -48,7 +48,7 @@ (*env-var* nil)) (multiple-value-bind (env-arg-used minimum maximum) (parse-defmacro-lambda-list lambda-list arg-list-name name - error-kind error-fun (not anonymousp) + context error-fun (not anonymousp) nil) (values `(let* (,@(when env-arg-used `((,*env-var* ,env-arg-name))) @@ -75,7 +75,7 @@ (defun parse-defmacro-lambda-list (possibly-dotted-lambda-list arg-list-name name - error-kind + context error-fun &optional toplevel @@ -92,6 +92,8 @@ (minimum 0) (keys ()) (key-seen nil) + (aux-seen nil) + (optional-seen nil) ;; ANSI specifies that dotted lists are "treated exactly as if the ;; parameter name that ends the list had appeared preceded by &rest." ;; We force this behavior by transforming dotted lists into ordinary @@ -105,7 +107,7 @@ (push (car in-pdll) reversed-result))) rest-name restp allow-other-keys-p env-arg-used) (when (member '&whole (rest lambda-list)) - (error "&WHOLE may only appear first in ~S lambda-list." error-kind)) + (error "&WHOLE may only appear first in ~S lambda-list." context)) (do ((rest-of-args lambda-list (cdr rest-of-args))) ((null rest-of-args)) (macrolet ((process-sublist (var sublist-name path) @@ -113,31 +115,36 @@ `(if (listp ,var) (let ((sub-list-name (gensym ,sublist-name))) (push-sub-list-binding sub-list-name ,path ,var - name error-kind error-fun) + name context error-fun) (parse-defmacro-lambda-list ,var sub-list-name name - error-kind error-fun)) - (push-let-binding ,var ,path nil))))) + context error-fun)) + (push-let-binding ,var ,path nil)))) + (normalize-singleton (var) + `(when (null (cdr ,var)) + (setf (cdr ,var) (list *default-default*))))) (let ((var (car rest-of-args))) (typecase var (list (case now-processing ((:required) (when restp - (defmacro-error "required argument after &REST/&BODY" - error-kind name)) + (defmacro-error (format nil "required argument after ~A" restp) + context name)) (process-sublist var "SUBLIST-" `(car ,path)) (setq path `(cdr ,path) minimum (1+ minimum) maximum (1+ maximum))) ((:optionals) + (normalize-singleton var) (destructuring-bind (varname &optional initform supplied-p) var (push-optional-binding varname initform supplied-p `(not (null ,path)) `(car ,path) - name error-kind error-fun)) + name context error-fun)) (setq path `(cdr ,path) maximum (1+ maximum))) ((:keywords) + (normalize-singleton var) (let* ((keyword-given (consp (car var))) (variable (if keyword-given (cadar var) @@ -151,7 +158,7 @@ ,rest-name) `(lookup-keyword ',keyword ,rest-name) - name error-kind error-fun) + name context error-fun) (push keyword keys))) ((:auxs) (push-let-binding (car var) (cadr var) nil)))) @@ -160,13 +167,25 @@ (&whole (cond ((cdr rest-of-args) (setq rest-of-args (cdr rest-of-args)) + ;; Special case for compiler-macros: if car of + ;; the form is FUNCALL skip over it for + ;; destructuring, pretending cdr of the form is + ;; the actual form. + (when (eq context 'define-compiler-macro) + (push-let-binding + arg-list-name + arg-list-name + t + `(not (and (listp ,arg-list-name) + (eq 'funcall (car ,arg-list-name)))) + `(setf ,arg-list-name (cdr ,arg-list-name)))) (process-sublist (car rest-of-args) "WHOLE-LIST-" arg-list-name)) (t - (defmacro-error "&WHOLE" error-kind name)))) + (defmacro-error "&WHOLE" context name)))) (&environment (cond (env-illegal - (error "&ENVIRONMENT is not valid with ~S." error-kind)) + (error "&ENVIRONMENT is not valid with ~S." context)) ((not toplevel) (error "&ENVIRONMENT is only valid at top level of ~ lambda-list.")) @@ -175,37 +194,55 @@ (cond ((and (cdr rest-of-args) (symbolp (cadr rest-of-args))) (setq rest-of-args (cdr rest-of-args)) (check-defmacro-arg (car rest-of-args)) - (setq *env-var* (car rest-of-args)) - (setq env-arg-used t)) + (setq *env-var* (car rest-of-args) + env-arg-used t)) (t - (defmacro-error "&ENVIRONMENT" error-kind name)))) + (defmacro-error "&ENVIRONMENT" context name)))) ((&rest &body) - (cond ((and (not restp) (cdr rest-of-args)) - (setq rest-of-args (cdr rest-of-args)) - (setq restp t) + (cond ((or key-seen aux-seen) + (error "~A after ~A in ~A" var (or key-seen aux-seen) context)) + ((and (not restp) (cdr rest-of-args)) + (setq rest-of-args (cdr rest-of-args) + restp var) (process-sublist (car rest-of-args) "REST-LIST-" path)) (t - (defmacro-error (symbol-name var) error-kind name)))) + (defmacro-error (symbol-name var) context name)))) (&optional - (setq now-processing :optionals)) + (when (or key-seen aux-seen restp) + (error "~A after ~A in ~A lambda-list." var (or key-seen aux-seen restp) context)) + (when optional-seen + (error "Multiple ~A in ~A lambda list." var context)) + (setq now-processing :optionals + optional-seen var)) (&key - (setq now-processing :keywords) - (setq rest-name (gensym "KEYWORDS-")) + (when aux-seen + (error "~A after ~A in ~A lambda-list." '&key '&aux context)) + (when key-seen + (error "Multiple ~A in ~A lambda-list." '&key context)) + (setf now-processing :keywords + rest-name (gensym "KEYWORDS-") + restp var + key-seen var) (push rest-name *ignorable-vars*) - (setq restp t) - (setq key-seen t) (push-let-binding rest-name path t)) (&allow-other-keys + (unless (eq now-processing :keywords) + (error "~A outside ~A section of lambda-list in ~A." var '&key context)) + (when allow-other-keys-p + (error "Multiple ~A in ~A lambda-list." var context)) (setq allow-other-keys-p t)) (&aux - (setq now-processing :auxs)) + (when aux-seen + (error "Multiple ~A in ~A lambda-list." '&aux context)) + (setq now-processing :auxs + aux-seen var)) ;; FIXME: Other lambda list keywords. (t (case now-processing ((:required) (when restp - (defmacro-error "required argument after &REST/&BODY" - error-kind name)) + (defmacro-error (format nil "required argument after ~A" restp) + context name)) (push-let-binding var `(car ,path) nil) (setq minimum (1+ minimum) maximum (1+ maximum) @@ -216,9 +253,11 @@ maximum (1+ maximum))) ((:keywords) (let ((key (keywordicate var))) - (push-let-binding var - `(lookup-keyword ,key ,rest-name) - nil) + (push-let-binding + var + `(lookup-keyword ,key ,rest-name) + nil + `(keyword-supplied-p ,key ,rest-name)) (push key keys))) ((:auxs) (push-let-binding var nil nil)))))) @@ -237,11 +276,11 @@ `(list-of-length-at-least-p ,path-0 ,minimum) `(proper-list-of-length-p ,path-0 ,minimum ,maximum)) ,(if (eq error-fun 'error) - `(arg-count-error ',error-kind ',name ,path-0 + `(arg-count-error ',context ',name ,path-0 ',lambda-list ,minimum ,explicit-maximum) `(,error-fun 'arg-count-error - :kind ',error-kind + :kind ',context ,@(when name `(:name ',name)) :args ,path-0 :lambda-list ',lambda-list @@ -258,7 +297,7 @@ (when ,problem (,error-fun 'defmacro-lambda-list-broken-key-list-error - :kind ',error-kind + :kind ',context ,@(when name `(:name ',name)) :problem ,problem :info ,info))) @@ -266,18 +305,18 @@ (values env-arg-used minimum explicit-maximum)))) ;;; We save space in macro definitions by calling this function. -(defun arg-count-error (error-kind name args lambda-list minimum maximum) +(defun arg-count-error (context name args lambda-list minimum maximum) (let (#-sb-xc-host (sb!debug:*stack-top-hint* (nth-value 1 (find-caller-name-and-frame)))) (error 'arg-count-error - :kind error-kind + :kind context :name name :args args :lambda-list lambda-list :minimum minimum :maximum maximum))) -(defun push-sub-list-binding (variable path object name error-kind error-fun) +(defun push-sub-list-binding (variable path object name context error-fun) (check-defmacro-arg variable) (let ((var (gensym "TEMP-"))) (push `(,variable @@ -285,7 +324,7 @@ (if (listp ,var) ,var (,error-fun 'defmacro-bogus-sublist-error - :kind ',error-kind + :kind ',context ,@(when name `(:name ',name)) :object ,var :lambda-list ',object)))) @@ -302,7 +341,7 @@ (push let-form *user-lets*)))) (defun push-optional-binding (value-var init-form supplied-var condition path - name error-kind error-fun) + name context error-fun) (unless supplied-var (setq supplied-var (gensym "SUPPLIEDP-"))) (push-let-binding supplied-var condition t) @@ -310,17 +349,17 @@ (let ((whole-thing (gensym "OPTIONAL-SUBLIST-"))) (push-sub-list-binding whole-thing `(if ,supplied-var ,path ,init-form) - value-var name error-kind error-fun) + value-var name context error-fun) (parse-defmacro-lambda-list value-var whole-thing name - error-kind error-fun))) + context error-fun))) ((symbolp value-var) (push-let-binding value-var path nil supplied-var init-form)) (t (error "illegal optional variable name: ~S" value-var)))) -(defun defmacro-error (problem kind name) +(defun defmacro-error (problem context name) (error "illegal or ill-formed ~A argument in ~A~@[ ~S~]" - problem kind name)) + problem context name)) (defun check-defmacro-arg (arg) (when (or (and *env-var* (eq arg *env-var*))