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

diff --git a/src/compiler/ir1tran.lisp b/src/compiler/ir1tran.lisp
index 81b68f7..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)
@@ -1374,13 +1381,17 @@
          (setf (lambda-var-ignorep var) t)))))
   (values))
 
-(defun process-dx-decl (names vars fvars kind)
-  (let ((dx (cond ((eq 'truly-dynamic-extent kind)
-                   :truly)
-                  ((and (eq 'dynamic-extent kind)
-                        *stack-allocate-dynamic-extent*)
-                   t))))
-    (if dx
+(defun process-extent-decl (names vars fvars kind)
+  (let ((extent
+          (ecase kind
+            (truly-dynamic-extent
+             :always-dynamic)
+            (dynamic-extent
+             (when *stack-allocate-dynamic-extent*
+               :maybe-dynamic))
+            (indefinite-extent
+             :indefinite))))
+    (if extent
         (dolist (name names)
           (cond
             ((symbolp name)
@@ -1391,21 +1402,23 @@
                (etypecase var
                  (leaf
                   (if bound-var
-                      (setf (leaf-dynamic-extent var) dx)
+                      (if (and (leaf-extent var) (neq extent (leaf-extent var)))
+                          (warn "Multiple incompatible extent declarations for ~S?" name)
+                          (setf (leaf-extent var) extent))
                       (compiler-notify
-                       "Ignoring free DYNAMIC-EXTENT declaration: ~S" name)))
+                       "Ignoring free ~S declaration: ~S" kind name)))
                  (cons
-                  (compiler-error "DYNAMIC-EXTENT on symbol-macro: ~S" name))
+                  (compiler-error "~S on symbol-macro: ~S" kind name))
                  (heap-alien-info
-                  (compiler-error "DYNAMIC-EXTENT on alien-variable: ~S"
-                                  name))
+                  (compiler-error "~S on alien-variable: ~S" kind name))
                  (null
                   (compiler-style-warn
-                   "Unbound variable declared DYNAMIC-EXTENT: ~S" name)))))
+                   "Unbound variable declared ~S: ~S" kind name)))))
             ((and (consp name)
                   (eq (car name) 'function)
                   (null (cddr name))
-                  (valid-function-name-p (cadr name)))
+                  (valid-function-name-p (cadr name))
+                  (neq :indefinite extent))
              (let* ((fname (cadr name))
                     (bound-fun (find fname fvars
                                      :key #'leaf-source-name
@@ -1415,7 +1428,7 @@
                  (leaf
                   (if bound-fun
                       #!+stack-allocatable-closures
-                      (setf (leaf-dynamic-extent bound-fun) dx)
+                      (setf (leaf-extent bound-fun) extent)
                       #!-stack-allocatable-closures
                       (compiler-notify
                        "Ignoring DYNAMIC-EXTENT declaration on function ~S ~
@@ -1428,7 +1441,7 @@
                   (compiler-style-warn
                    "Unbound function declared DYNAMIC-EXTENT: ~S" name)))))
             (t
-             (compiler-error "DYNAMIC-EXTENT on a weird thing: ~S" name))))
+             (compiler-error "~S on a weird thing: ~S" kind name))))
         (when (policy *lexenv* (= speed 3))
           (compiler-notify "Ignoring DYNAMIC-EXTENT declarations: ~S" names)))))
 
@@ -1483,8 +1496,8 @@
                        (car types)
                        `(values ,@types)))))
           res))
-       ((dynamic-extent truly-dynamic-extent)
-        (process-dx-decl (cdr spec) vars fvars (first spec))
+       ((dynamic-extent truly-dynamic-extent indefinite-extent)
+        (process-extent-decl (cdr spec) vars fvars (first spec))
         res)
        ((disable-package-locks enable-package-locks)
         (make-lexenv