X-Git-Url: http://repo.macrolet.net/gitweb/?a=blobdiff_plain;f=src%2Fcode%2Fmacros.lisp;h=3cbc7af50326381dd80c43efca7a4ed108c5dc28;hb=7f1e94ae961a198e00daf281eb1dc858e5b2dcc7;hp=856edead7b47fc6fffe01a94f10306aa87b87539;hpb=31f072311935e32751508ecf824905c6b58a1d95;p=sbcl.git diff --git a/src/code/macros.lisp b/src/code/macros.lisp index 856edea..3cbc7af 100644 --- a/src/code/macros.lisp +++ b/src/code/macros.lisp @@ -24,16 +24,64 @@ ;;; ;;; ASSERT-ERROR isn't defined until a later file because it uses the ;;; macro RESTART-CASE, which isn't defined until a later file. -(defmacro-mundanely assert (test-form &optional places datum &rest arguments) +(defmacro-mundanely assert (test-form &optional places datum &rest arguments + &environment env) #!+sb-doc - "Signals an error if the value of test-form is nil. Continuing from this - error using the CONTINUE restart will allow the user to alter the value of - some locations known to SETF, starting over with test-form. Returns NIL." - `(do () (,test-form) - (assert-error ',test-form ',places ,datum ,@arguments) - ,@(mapcar (lambda (place) - `(setf ,place (assert-prompt ',place ,place))) - places))) + "Signals an error if the value of TEST-FORM is NIL. Returns NIL. + + Optional DATUM and ARGUMENTS can be used to change the signaled + error condition and are interpreted as in (APPLY #'ERROR DATUM + ARGUMENTS). + + Continuing from the signaled error using the CONTINUE restart will + allow the user to alter the values of the SETFable locations + specified in PLACES and then start over with TEST-FORM. + + If TEST-FORM is of the form + + (FUNCTION ARG*) + + where FUNCTION is a function (but not a special operator like + CL:OR, CL:AND, etc.) the results of evaluating the ARGs will be + included in the error report if the assertion fails." + (collect ((bindings) (infos)) + (let ((new-test + (flet ((process-place (place) + (if (sb!xc:constantp place env) + place + (with-unique-names (temp) + (bindings `(,temp ,place)) + (infos `(list ',place ,temp)) + temp)))) + (cond + ;; TEST-FORM looks like a function call. We do not + ;; attempt this if TEST-FORM is the application of a + ;; special operator because of argument evaluation + ;; order issues. + ((and (typep test-form '(cons symbol list)) + (eq (info :function :kind (first test-form)) :function)) + (let ((name (first test-form)) + (args (mapcar #'process-place (rest test-form)))) + `(,name ,@args))) + ;; For all other cases, just evaluate TEST-FORM and do + ;; not report any details if the assertion fails. + (t + test-form))))) + ;; If TEST-FORM, potentially using values from BINDINGS, does not + ;; hold, enter a loop which reports the assertion error, + ;; potentially changes PLACES, and retries TEST-FORM. + `(tagbody + :try + (let ,(bindings) + (when ,new-test + (go :done)) + (assert-error ',test-form (list ,@(infos)) + ',places ,datum ,@arguments)) + ,@(mapcar (lambda (place) + `(setf ,place (assert-prompt ',place ,place))) + places) + (go :try) + :done)))) (defun assert-prompt (name value) (cond ((y-or-n-p "The old value of ~S is ~S.~ @@ -56,17 +104,33 @@ ;;; ;;; CHECK-TYPE-ERROR isn't defined until a later file because it uses ;;; the macro RESTART-CASE, which isn't defined until a later file. -(defmacro-mundanely check-type (place type &optional type-string) +(defmacro-mundanely check-type (place type &optional type-string + &environment env) #!+sb-doc - "Signal a restartable error of type TYPE-ERROR if the value of PLACE is - not of the specified type. If an error is signalled and the restart is - used to return, this can only return if the STORE-VALUE restart is - invoked. In that case it will store into PLACE and start over." - (let ((place-value (gensym))) - `(do ((,place-value ,place ,place)) - ((typep ,place-value ',type)) - (setf ,place - (check-type-error ',place ,place-value ',type ,type-string))))) + "Signal a restartable error of type TYPE-ERROR if the value of PLACE +is not of the specified type. If an error is signalled and the restart +is used to return, this can only return if the STORE-VALUE restart is +invoked. In that case it will store into PLACE and start over." + ;; Detect a common user-error. + (when (and (consp type) (eq 'quote (car type))) + (error 'simple-reference-error + :format-control "Quoted type specifier in ~S: ~S" + :format-arguments (list 'check-type type) + :references (list '(:ansi-cl :macro check-type)))) + ;; KLUDGE: We use a simpler form of expansion if PLACE is just a + ;; variable to work around Python's blind spot in type derivation. + ;; For more complex places getting the type derived should not + ;; matter so much anyhow. + (let ((expanded (%macroexpand place env))) + (if (symbolp expanded) + `(do () + ((typep ,place ',type)) + (setf ,place (check-type-error ',place ,place ',type ,type-string))) + (let ((value (gensym))) + `(do ((,value ,place ,place)) + ((typep ,value ',type)) + (setf ,place + (check-type-error ',place ,value ',type ,type-string))))))) ;;;; DEFINE-SYMBOL-MACRO @@ -83,18 +147,19 @@ (:symbol name "defining ~A as a symbol-macro")) (sb!c:with-source-location (source-location) (setf (info :source-location :symbol-macro name) source-location)) - (ecase (info :variable :kind name) - ((:macro :global nil) - (setf (info :variable :kind name) :macro) - (setf (info :variable :macro-expansion name) expansion)) - (:special - (error 'simple-program-error - :format-control "Symbol macro name already declared special: ~S." - :format-arguments (list name))) - (:constant - (error 'simple-program-error - :format-control "Symbol macro name already declared constant: ~S." - :format-arguments (list name)))) + (let ((kind (info :variable :kind name))) + (ecase kind + ((:macro :unknown) + (setf (info :variable :kind name) :macro) + (setf (info :variable :macro-expansion name) expansion)) + ((:special :global) + (error 'simple-program-error + :format-control "Symbol macro name already declared ~A: ~S." + :format-arguments (list kind name))) + (:constant + (error 'simple-program-error + :format-control "Symbol macro name already defined as a constant: ~S." + :format-arguments (list name))))) name) ;;;; DEFINE-COMPILER-MACRO @@ -103,22 +168,6 @@ #!+sb-doc "Define a compiler-macro for NAME." (legal-fun-name-or-type-error name) - (when (consp name) - ;; It's fairly clear that the user intends the compiler macro to - ;; expand when he does (SETF (FOO ...) X). And that's even a - ;; useful and reasonable thing to want. Unfortunately, - ;; (SETF (FOO ...) X) macroexpands into (FUNCALL (SETF FOO) X ...), - ;; and it's not at all clear that it's valid to expand a FUNCALL form, - ;; and the ANSI standard doesn't seem to say anything else which - ;; would justify us expanding the compiler macro the way the user - ;; wants. So instead we rely on 3.2.2.1.3 "When Compiler Macros Are - ;; Used" which says they never have to be used, so by ignoring such - ;; macros we're erring on the safe side. But any user who does - ;; (DEFINE-COMPILER-MACRO (SETF FOO) ...) could easily be surprised - ;; by this way of complying with a rather screwy aspect of the ANSI - ;; spec, so at least we can warn him... - (sb!c::compiler-style-warn - "defining compiler macro of (SETF ...), which will not be expanded")) (when (and (symbolp name) (special-operator-p name)) (error 'simple-program-error :format-control "cannot define a compiler-macro for a special operator: ~S" @@ -151,22 +200,10 @@ ;; FIXME: warn about incompatible lambda list with ;; respect to parent function? (setf (sb!xc:compiler-macro-function name) definition) - ;; FIXME: Add support for (SETF FDOCUMENTATION) when - ;; object is a list and type is COMPILER-MACRO. (Until - ;; then, we have to discard any compiler macro - ;; documentation for (SETF FOO).) - (unless (listp name) - (setf (fdocumentation name 'compiler-macro) doc)) ,(when set-p - `(case (widetag-of definition) - (#.sb!vm:closure-header-widetag - (setf (%simple-fun-arglist (%closure-fun definition)) - lambda-list - (%simple-fun-name (%closure-fun definition)) - debug-name)) - (#.sb!vm:simple-fun-header-widetag - (setf (%simple-fun-arglist definition) lambda-list - (%simple-fun-name definition) debug-name)))) + `(setf (%fun-doc definition) doc + (%fun-lambda-list definition) lambda-list + (%fun-name definition) debug-name)) name)))) (progn (def (:load-toplevel :execute) #-sb-xc-host t #+sb-xc-host nil) @@ -176,6 +213,24 @@ (eval-when (#-sb-xc :compile-toplevel :load-toplevel :execute) +;;; Make this a full warning during SBCL build. +(define-condition duplicate-case-key-warning (#-sb-xc-host style-warning #+sb-xc-host warning) + ((key :initarg :key + :reader case-warning-key) + (case-kind :initarg :case-kind + :reader case-warning-case-kind) + (occurrences :initarg :occurrences + :type list + :reader duplicate-case-key-warning-occurrences)) + (:report + (lambda (condition stream) + (format stream + "Duplicate key ~S in ~S form, ~ + occurring in~{~#[~; and~]~{ the ~:R clause:~%~< ~S~:>~}~^,~}." + (case-warning-key condition) + (case-warning-case-kind condition) + (duplicate-case-key-warning-occurrences condition))))) + ;;; CASE-BODY returns code for all the standard "case" macros. NAME is ;;; the macro name, and KEYFORM is the thing to case on. MULTI-P ;;; indicates whether a branch may fire off a list of keys; otherwise, @@ -193,54 +248,84 @@ (warn "no clauses in ~S" name)) (let ((keyform-value (gensym)) (clauses ()) - (keys ())) + (keys ()) + (keys-seen (make-hash-table :test #'eql))) (do* ((cases cases (cdr cases)) - (case (car cases) (car cases))) + (case (car cases) (car cases)) + (case-position 1 (1+ case-position))) ((null cases) nil) - (unless (list-of-length-at-least-p case 1) - (error "~S -- bad clause in ~S" case name)) - (destructuring-bind (keyoid &rest forms) case - (cond (;; an OTHERWISE-CLAUSE - ;; - ;; By the way... The old code here tried gave - ;; STYLE-WARNINGs for normal-clauses which looked as - ;; though they might've been intended to be - ;; otherwise-clauses. As Tony Martinez reported on - ;; sbcl-devel 2004-11-09 there are sometimes good - ;; reasons to write clauses like that; and as I noticed - ;; when trying to understand the old code so I could - ;; understand his patch, trying to guess which clauses - ;; don't have good reasons is fundamentally kind of a - ;; mess. SBCL does issue style warnings rather - ;; enthusiastically, and I have often justified that by - ;; arguing that we're doing that to detect issues which - ;; are tedious for programmers to detect for by - ;; proofreading (like small typoes in long symbol - ;; names, or duplicate function definitions in large - ;; files). This doesn't seem to be an issue like that, - ;; and I can't think of a comparably good justification - ;; for giving STYLE-WARNINGs for legal code here, so - ;; now we just hope the programmer knows what he's - ;; doing. -- WHN 2004-11-20 - (and (not errorp) ; possible only in CASE or TYPECASE, - ; not in [EC]CASE or [EC]TYPECASE - (memq keyoid '(t otherwise)) - (null (cdr cases))) - (push `(t nil ,@forms) clauses)) - ((and multi-p (listp keyoid)) - (setf keys (append keyoid keys)) - (push `((or ,@(mapcar (lambda (key) - `(,test ,keyform-value ',key)) - keyoid)) - nil - ,@forms) - clauses)) - (t - (push keyoid keys) - (push `((,test ,keyform-value ',keyoid) - nil - ,@forms) - clauses))))) + (flet ((check-clause (case-keys) + (loop for k in case-keys + for existing = (gethash k keys-seen) + do (when existing + (let ((sb!c::*current-path* + (when (boundp 'sb!c::*source-paths*) + (or (sb!c::get-source-path case) + sb!c::*current-path*)))) + (warn 'duplicate-case-key-warning + :key k + :case-kind name + :occurrences `(,existing (,case-position (,case))))))) + (let ((record (list case-position (list case)))) + (dolist (k case-keys) + (setf (gethash k keys-seen) record))))) + (unless (list-of-length-at-least-p case 1) + (error "~S -- bad clause in ~S" case name)) + (destructuring-bind (keyoid &rest forms) case + (cond (;; an OTHERWISE-CLAUSE + ;; + ;; By the way... The old code here tried gave + ;; STYLE-WARNINGs for normal-clauses which looked as + ;; though they might've been intended to be + ;; otherwise-clauses. As Tony Martinez reported on + ;; sbcl-devel 2004-11-09 there are sometimes good + ;; reasons to write clauses like that; and as I noticed + ;; when trying to understand the old code so I could + ;; understand his patch, trying to guess which clauses + ;; don't have good reasons is fundamentally kind of a + ;; mess. SBCL does issue style warnings rather + ;; enthusiastically, and I have often justified that by + ;; arguing that we're doing that to detect issues which + ;; are tedious for programmers to detect for by + ;; proofreading (like small typoes in long symbol + ;; names, or duplicate function definitions in large + ;; files). This doesn't seem to be an issue like that, + ;; and I can't think of a comparably good justification + ;; for giving STYLE-WARNINGs for legal code here, so + ;; now we just hope the programmer knows what he's + ;; doing. -- WHN 2004-11-20 + (and (not errorp) ; possible only in CASE or TYPECASE, + ; not in [EC]CASE or [EC]TYPECASE + (memq keyoid '(t otherwise)) + (null (cdr cases))) + (push `(t nil ,@forms) clauses)) + ((and multi-p (listp keyoid)) + (setf keys (append keyoid keys)) + (check-clause keyoid) + (push `((or ,@(mapcar (lambda (key) + `(,test ,keyform-value ',key)) + keyoid)) + nil + ,@forms) + clauses)) + (t + (when (and (eq name 'case) + (cdr cases) + (memq keyoid '(t otherwise))) + (error 'simple-reference-error + :format-control + "~@<~IBad ~S clause:~:@_ ~S~:@_~S allowed as the key ~ + designator only in the final otherwise-clause, not in a ~ + normal-clause. Use (~S) instead, or move the clause the ~ + correct position.~:@>" + :format-arguments (list 'case case keyoid keyoid) + :references `((:ansi-cl :macro case)))) + (push keyoid keys) + (check-clause (list keyoid)) + (push `((,test ,keyform-value ',keyoid) + nil + ,@forms) + clauses)))))) (case-body-aux name keyform keyform-value clauses keys errorp proceedp `(,(if multi-p 'member 'or) ,@keys)))) @@ -278,11 +363,7 @@ (cond ,@(nreverse clauses) ,@(if errorp - `((t (error 'case-failure - :name ',name - :datum ,keyform-value - :expected-type ',expected-type - :possibilities ',keys)))))))) + `((t (case-failure ',name ,keyform-value ',keys)))))))) ) ; EVAL-WHEN (defmacro-mundanely case (keyform &body cases) @@ -390,17 +471,21 @@ ;; (see FILL-POINTER-OUTPUT-STREAM FIXME in stream.lisp), ;; but it still has to be evaluated for side-effects. (,element-type-var ,element-type)) - (declare (ignore ,element-type-var)) - ,@decls - (unwind-protect - (progn ,@forms) - (close ,var)))) - `(let ((,var (make-string-output-stream :element-type ,element-type))) - ,@decls - (unwind-protect - (progn ,@forms) - (close ,var)) - (get-output-stream-string ,var))))) + (declare (ignore ,element-type-var)) + ,@decls + (unwind-protect + (progn ,@forms) + (close ,var)))) + `(let ((,var (make-string-output-stream + ;; CHARACTER is the default element-type of + ;; string-ouput-stream, save a few bytes when passing it + ,@(and (not (equal element-type ''character)) + `(:element-type ,element-type))))) + ,@decls + (unwind-protect + (progn ,@forms) + (close ,var)) + (get-output-stream-string ,var))))) ;;;; miscellaneous macros @@ -416,13 +501,8 @@ ;; optional dispatch mechanism for the M-V-B gets increasingly ;; hairy. (if (integerp n) - (let ((dummy-list nil) - (keeper (gensym "KEEPER-"))) - ;; We build DUMMY-LIST, a list of variables to bind to useless - ;; values, then we explicitly IGNORE those bindings and return - ;; KEEPER, the only thing we're really interested in right now. - (dotimes (i n) - (push (gensym "IGNORE-") dummy-list)) + (let ((dummy-list (make-gensym-list n)) + (keeper (sb!xc:gensym "KEEPER"))) `(multiple-value-bind (,@dummy-list ,keeper) ,form (declare (ignore ,@dummy-list)) ,keeper))