run-program: proper handling of :if-input-does-not-exist NIL.

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

diff --git a/src/code/macros.lisp b/src/code/macros.lisp
index 3da5529..935fe5b 100644 (file)
--- a/src/code/macros.lisp
+++ b/src/code/macros.lisp
@@ -63,11 +63,17 @@
 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))
     (if (symbolp expanded)
         `(do ()
              ((typep ,place ',type))

@@ -93,18 +99,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

@@ -145,22 +152,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)

@@ -170,7 +165,8 @@ 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)
 

-(define-condition duplicate-case-key-warning (style-warning)
+;;; 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
   ((key :initarg :key
         :reader case-warning-key)
    (case-kind :initarg :case-kind

@@ -216,7 +212,7 @@ invoked. In that case it will store into PLACE and start over."
                      do (when existing
                           (let ((sb!c::*current-path*
                                  (when (boundp 'sb!c::*source-paths*)
                      do (when existing
                           (let ((sb!c::*current-path*
                                  (when (boundp 'sb!c::*source-paths*)

-                                   (or (gethash case sb!c::*source-paths*)
+                                   (or (sb!c::get-source-path case)

                                        sb!c::*current-path*))))
                             (warn 'duplicate-case-key-warning
                                   :key k
                                        sb!c::*current-path*))))
                             (warn 'duplicate-case-key-warning
                                   :key k

@@ -265,6 +261,17 @@ invoked. In that case it will store into PLACE and start over."
                          ,@forms)
                        clauses))
                 (t
                          ,@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)
                  (push keyoid keys)
                  (check-clause (list keyoid))
                  (push `((,test ,keyform-value ',keyoid)

@@ -308,11 +315,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)

@@ -446,13 +449,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))