X-Git-Url: http://repo.macrolet.net/gitweb/?a=blobdiff_plain;f=src%2Fcompiler%2Fir1tran.lisp;h=b05f9c380f056e310db689fd51b9bf17edfc9cd1;hb=7f579b076a1fc54587538ead07e506e7f06f3fe8;hp=db5bf3851a148f79e4da84b608930c7447a9201d;hpb=edb7acf8d242c0398ec33924e21c85dc54bc768d;p=sbcl.git

diff --git a/src/compiler/ir1tran.lisp b/src/compiler/ir1tran.lisp
index db5bf38..b05f9c3 100644
--- a/src/compiler/ir1tran.lisp
+++ b/src/compiler/ir1tran.lisp
@@ -43,6 +43,11 @@
   (when (source-form-has-path-p form)
     (gethash form *source-paths*)))
 
+(defun ensure-source-path (form)
+  (or (get-source-path form)
+      (cons (simplify-source-path-form form)
+            *current-path*)))
+
 (defun simplify-source-path-form (form)
   (if (consp form)
       (let ((op (car form)))
@@ -315,7 +320,10 @@
                         symbol
                         number
                         character
-                        string)))
+                        string
+                        #!+sb-simd-pack
+                        #+sb-xc-host nil
+                        #-sb-xc-host sb!kernel:simd-pack)))
              (grovel (value)
                ;; Unless VALUE is an object which which obviously
                ;; can't contain other objects
@@ -531,7 +539,8 @@
 
 ;;;; IR1-CONVERT, macroexpansion and special form dispatching
 
-(declaim (ftype (sfunction (ctran ctran (or lvar null) t) (values))
+(declaim (ftype (sfunction (ctran ctran (or lvar null) t &optional t)
+                           (values))
                 ir1-convert))
 (macrolet (;; Bind *COMPILER-ERROR-BAILOUT* to a function that throws
            ;; out of the body and converts a condition signalling form
@@ -560,11 +569,9 @@
   ;; the creation using backquote of forms that contain leaf
   ;; references, without having to introduce dummy names into the
   ;; namespace.
-  (defun ir1-convert (start next result form)
+  (defun ir1-convert (start next result form &optional alias)
     (ir1-error-bailout (start next result form)
-      (let* ((*current-path* (or (get-source-path form)
-                                 (cons (simplify-source-path-form form)
-                                       *current-path*)))
+      (let* ((*current-path* (ensure-source-path (or alias form)))
              (start (instrument-coverage start nil form)))
         (cond ((atom form)
                (cond ((and (symbolp form) (not (keywordp form)))
@@ -678,6 +685,8 @@
                ;; processing our own code, though.
                #+sb-xc-host
                (warn "reading an ignored variable: ~S" name)))
+           (when (global-var-p var)
+             (check-deprecated-variable name))
            (reference-leaf start next result var name))
           (cons
            (aver (eq (car var) 'macro))
@@ -728,7 +737,11 @@
                       ;; CLHS 3.2.2.1.3 specifies that NOTINLINE
                       ;; suppresses compiler-macros.
                       (not (fun-lexically-notinline-p cmacro-fun-name)))
-                 (let ((res (careful-expand-macro cmacro-fun form t)))
+                 (let ((res (handler-case
+                                (careful-expand-macro cmacro-fun form t)
+                              (compiler-macro-keyword-problem (c)
+                                (print-compiler-message *error-output* "note: ~A" (list c))
+                                form))))
                    (cond ((eq res form)
                           (ir1-convert-common-functoid start next result form op))
                          (t
@@ -793,15 +806,16 @@
            (let (;; We rely on the printer to abbreviate FORM.
                  (*print-length* 3)
                  (*print-level* 3))
-             (format
-              nil
-              #-sb-xc-host "~@<~;during ~A of ~S. Use ~S to intercept:~%~:@>"
-              ;; longer message to avoid ambiguity "Was it the xc host
-              ;; or the cross-compiler which encountered the problem?"
-              #+sb-xc-host "~@<~;during cross-compiler ~A of ~S. Use ~S to intercept:~%~:@>"
-              (if cmacro "compiler-macroexpansion" "macroexpansion")
-              form
-              '*break-on-signals*))))
+             (format nil
+                     "~@<~A of ~S. Use ~S to intercept.~%~:@>"
+                     (cond (cmacro
+                            #-sb-xc-host "Error during compiler-macroexpansion"
+                            #+sb-xc-host "Error during XC compiler-macroexpansion")
+                           (t
+                            #-sb-xc-host "during macroexpansion"
+                            #+sb-xc-host "during XC macroexpansion"))
+                     form
+                     '*break-on-signals*))))
     (handler-bind (;; KLUDGE: CMU CL in its wisdom (version 2.4.6 for Debian
                    ;; Linux, anyway) raises a CL:WARNING condition (not a
                    ;; CL:STYLE-WARNING) for undefined symbols when converting
@@ -832,9 +846,18 @@
                                (wherestring)
                                c)
                               (muffle-warning-or-die)))
-                   (error (lambda (c)
-                            (compiler-error "~@<~A~@:_ ~A~:>"
-                                            (wherestring) c))))
+                   (error
+                     (lambda (c)
+                       (cond
+                         (cmacro
+                          ;; The spec is silent on what we should do. Signaling
+                          ;; a full warning but declining to expand seems like
+                          ;; a conservative and sane thing to do.
+                          (compiler-warn "~@<~A~@:_ ~A~:>" (wherestring) c)
+                          (return-from careful-expand-macro form))
+                         (t
+                          (compiler-error "~@<~A~@:_ ~A~:>"
+                                          (wherestring) c))))))
       (funcall sb!xc:*macroexpand-hook* fun form *lexenv*))))
 
 ;;;; conversion utilities
@@ -1201,6 +1224,9 @@
   (declare (type list names fvars)
            (type lexenv res))
   (let ((type (compiler-specifier-type spec)))
+    (unless (csubtypep type (specifier-type 'function))
+      (compiler-style-warn "ignoring declared FTYPE: ~S (not a function type)" spec)
+      (return-from process-ftype-decl res))
     (collect ((res nil cons))
       (dolist (name names)
         (when (fboundp name)
@@ -1322,13 +1348,13 @@
 ;;; like FIND-IN-BINDINGS, but looks for #'FOO in the FVARS
 (defun find-in-bindings-or-fbindings (name vars fvars)
   (declare (list vars fvars))
-  (if (consp name)
-      (destructuring-bind (wot fn-name) name
-        (unless (eq wot 'function)
-          (compiler-error "The function or variable name ~S is unrecognizable."
-                          name))
-        (find fn-name fvars :key #'leaf-source-name :test #'equal))
-      (find-in-bindings vars name)))
+  (typecase name
+    (atom
+     (find-in-bindings vars name))
+    ((cons (eql function) (cons * null))
+     (find (cadr name) fvars :key #'leaf-source-name :test #'equal))
+    (t
+     (compiler-error "Malformed function or variable name ~S." name))))
 
 ;;; Process an ignore/ignorable declaration, checking for various losing
 ;;; conditions.