X-Git-Url: http://repo.macrolet.net/gitweb/?a=blobdiff_plain;f=src%2Fcompiler%2Fir1tran.lisp;h=d7cb33b7c625c13aaaf92aba741dca8f359314cd;hb=bea5b384106a6734a4b280a76e8ebdd4d51b5323;hp=45b1de9692e2eed438bb3d7b0ec7df10d46cda26;hpb=e2470cd3c62342d574cc80a621f29d7530345817;p=sbcl.git

diff --git a/src/compiler/ir1tran.lisp b/src/compiler/ir1tran.lisp
index 45b1de9..d7cb33b 100644
--- a/src/compiler/ir1tran.lisp
+++ b/src/compiler/ir1tran.lisp
@@ -388,12 +388,12 @@
 	 (component (make-empty-component))
 	 (*current-component* component)
          (*allow-instrumenting* t))
-    (setf (component-name component) "initial component")
+    (setf (component-name component) 'initial-component)
     (setf (component-kind component) :initial)
     (let* ((forms (if for-value `(,form) `(,form nil)))
 	   (res (ir1-convert-lambda-body
 		 forms ()
-		 :debug-name (debug-namify "top level form " form))))
+		 :debug-name (debug-name 'top-level-form form))))
       (setf (functional-entry-fun res) res
 	    (functional-arg-documentation res) ()
 	    (functional-kind res) :toplevel)
@@ -516,11 +516,11 @@
                                                  form
                                                  (ir1-convert-lambda
                                                   opname
-                                                  :debug-name (debug-namify
-                                                               "LAMBDA CAR "
+                                                  :debug-name (debug-name
+                                                               'lambda-car 
                                                                opname))))))))))
     (values))
-
+  
   ;; Generate a reference to a manifest constant, creating a new leaf
   ;; if necessary. If we are producing a fasl file, make sure that
   ;; MAKE-LOAD-FORM gets used on any parts of the constant that it
@@ -1125,7 +1125,7 @@
 	(setf (lambda-var-ignorep var) t)))))
   (values))
 
-(defun process-dx-decl (names vars)
+(defun process-dx-decl (names vars fvars)
   (flet ((maybe-notify (control &rest args)
 	   (when (policy *lexenv* (> speed inhibit-warnings))
 	     (apply #'compiler-notify control args))))
@@ -1153,7 +1153,24 @@
 		  (eq (car name) 'function)
 		  (null (cddr name))
 		  (valid-function-name-p (cadr name)))
-	     (maybe-notify "ignoring DYNAMIC-EXTENT declaration for ~S" name))
+             (let* ((fname (cadr name))
+                    (bound-fun (find fname fvars
+                                     :key #'leaf-source-name
+                                     :test #'equal)))
+	       (etypecase bound-fun
+		 (leaf
+                  #!+stack-allocatable-closures
+		  (setf (leaf-dynamic-extent bound-fun) t)
+                  #!-stack-allocatable-closures
+                  (maybe-notify
+                   "ignoring DYNAMIC-EXTENT declaration on a function ~S ~
+                    (not supported on this platform)." fname))
+		 (cons
+		  (compiler-error "DYNAMIC-EXTENT on macro: ~S" fname))
+                 (null
+                  (maybe-notify
+                   "ignoring DYNAMIC-EXTENT declaration for free ~S"
+                   fname)))))
 	    (t (compiler-error "DYNAMIC-EXTENT on a weird thing: ~S" name))))
       (maybe-notify "ignoring DYNAMIC-EXTENT declarations for ~S" names))))
 
@@ -1209,12 +1226,12 @@
                        `(values ,@types)))))
           res))
        (dynamic-extent
-	(process-dx-decl (cdr spec) vars)
+	(process-dx-decl (cdr spec) vars fvars)
         res)
        ((disable-package-locks enable-package-locks)
         (make-lexenv
          :default res
-         :disabled-package-locks (process-package-lock-decl 
+         :disabled-package-locks (process-package-lock-decl
                                   spec (lexenv-disabled-package-locks res))))
        (t
         (unless (info :declaration :recognized (first spec))