1.1.13: will be tagged as "sbcl-1.1.13"

[sbcl.git] / src / code / macros.lisp

diff --git a/src/code/macros.lisp b/src/code/macros.lisp
index 27535d6..3cbc7af 100644 (file)
--- 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.
 ;;;
 ;;; 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
   #!+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.~
 
 (defun assert-prompt (name value)
   (cond ((y-or-n-p "The old value of ~S is ~S.~

@@ -63,17 +111,23 @@
 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."
 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.
   ;; 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 (sb!xc:macroexpand place env)))
+  (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)))
     (if (symbolp expanded)
         `(do ()
              ((typep ,place ',type))
           (setf ,place (check-type-error ',place ,place ',type ,type-string)))
         (let ((value (gensym)))

-          `(do ((,value ,place))
+          `(do ((,value ,place ,place))

                ((typep ,value ',type))
             (setf ,place
                   (check-type-error ',place ,value ',type ,type-string)))))))
                ((typep ,value ',type))
             (setf ,place
                   (check-type-error ',place ,value ',type ,type-string)))))))

@@ -93,18 +147,19 @@ invoked. In that case it will store into PLACE and start over."
       (:symbol name "defining ~A as a symbol-macro"))
   (sb!c:with-source-location (source-location)
     (setf (info :source-location :symbol-macro name) source-location))
       (: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)
 \f
 ;;;; DEFINE-COMPILER-MACRO
   name)
 \f
 ;;;; DEFINE-COMPILER-MACRO

@@ -113,22 +168,6 @@ invoked. In that case it will store into PLACE and start over."
   #!+sb-doc
   "Define a compiler-macro for NAME."
   (legal-fun-name-or-type-error name)
   #!+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"
   (when (and (symbolp name) (special-operator-p name))
     (error 'simple-program-error
            :format-control "cannot define a compiler-macro for a special operator: ~S"

@@ -161,22 +200,10 @@ invoked. In that case it will store into PLACE and start over."
              ;; FIXME: warn about incompatible lambda list with
              ;; respect to parent function?
              (setf (sb!xc:compiler-macro-function name) definition)
              ;; 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
              ,(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)
              name))))
   (progn
     (def (:load-toplevel :execute) #-sb-xc-host t #+sb-xc-host nil)

@@ -186,6 +213,24 @@ invoked. In that case it will store into PLACE and start over."
 
 (eval-when (#-sb-xc :compile-toplevel :load-toplevel :execute)
 
 
 (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,
 ;;; 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,

@@ -203,54 +248,84 @@ invoked. In that case it will store into PLACE and start over."
     (warn "no clauses in ~S" name))
   (let ((keyform-value (gensym))
         (clauses ())
     (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))
     (do* ((cases cases (cdr cases))

-          (case (car cases) (car cases)))
+          (case (car cases) (car cases))
+          (case-position 1 (1+ case-position)))

          ((null cases) nil)
          ((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))))
 
     (case-body-aux name keyform keyform-value clauses keys errorp proceedp
                    `(,(if multi-p 'member 'or) ,@keys))))
 

@@ -288,11 +363,7 @@ invoked. In that case it will store into PLACE and start over."
          (cond
           ,@(nreverse clauses)
           ,@(if errorp
          (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)
 ) ; EVAL-WHEN
 
 (defmacro-mundanely case (keyform &body cases)

@@ -400,17 +471,21 @@ invoked. In that case it will store into PLACE and start over."
                  ;; (see FILL-POINTER-OUTPUT-STREAM FIXME in stream.lisp),
                  ;; but it still has to be evaluated for side-effects.
                  (,element-type-var ,element-type))
                  ;; (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)))))

 \f
 ;;;; miscellaneous macros
 
 \f
 ;;;; miscellaneous macros
 

@@ -426,13 +501,8 @@ invoked. In that case it will store into PLACE and start over."
   ;; optional dispatch mechanism for the M-V-B gets increasingly
   ;; hairy.
   (if (integerp n)
   ;; 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))
         `(multiple-value-bind (,@dummy-list ,keeper) ,form
            (declare (ignore ,@dummy-list))
            ,keeper))