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

diff --git a/src/compiler/ir1tran.lisp b/src/compiler/ir1tran.lisp
index db5bf38..8a4cf1a 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)))
@@ -531,7 +536,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 +566,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)))
@@ -1201,6 +1205,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)