X-Git-Url: http://repo.macrolet.net/gitweb/?a=blobdiff_plain;f=src%2Fcode%2Fmacros.lisp;h=efd3db02fea2810ad3676102eb60e895eba199c2;hb=7e24349c17298e2959e853ea411b5f65d9f7f332;hp=b8603779fc217e827168bdc3c5c074dc0d747b84;hpb=4898ef32c639b1c7f4ee13a5ba566ce6debd03e6;p=sbcl.git

diff --git a/src/code/macros.lisp b/src/code/macros.lisp
index b860377..efd3db0 100644
--- a/src/code/macros.lisp
+++ b/src/code/macros.lisp
@@ -56,31 +56,43 @@
 ;;;
 ;;; 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."
+  ;; 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)))
+    (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
 
 (defmacro-mundanely define-symbol-macro (name expansion)
   `(eval-when (:compile-toplevel :load-toplevel :execute)
-    (sb!c::%define-symbol-macro ',name ',expansion)))
+    (sb!c::%define-symbol-macro ',name ',expansion (sb!c:source-location))))
 
-(defun sb!c::%define-symbol-macro (name expansion)
+(defun sb!c::%define-symbol-macro (name expansion source-location)
   (unless (symbolp name)
     (error 'simple-type-error :datum name :expected-type 'symbol
            :format-control "Symbol macro name is not a symbol: ~S."
            :format-arguments (list name)))
   (with-single-package-locked-error
       (: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)
@@ -101,22 +113,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"