X-Git-Url: http://repo.macrolet.net/gitweb/?a=blobdiff_plain;f=src%2Fcompiler%2Fir1tran-lambda.lisp;h=88d3429de05ae34d6700c8eebd5678519371b977;hb=6a9bbe6f36179cee92001a1f9ed5ff38be512644;hp=00b772025b3e95a3c49fbba2743270a80d2e3e96;hpb=57e21c4b62e8c1a1ee7ef59ed2abb0c864fb06bc;p=sbcl.git

diff --git a/src/compiler/ir1tran-lambda.lisp b/src/compiler/ir1tran-lambda.lisp
index 00b7720..88d3429 100644
--- a/src/compiler/ir1tran-lambda.lisp
+++ b/src/compiler/ir1tran-lambda.lisp
@@ -207,7 +207,7 @@
            (list body aux-vars aux-vals))
   (if (null aux-vars)
       (ir1-convert-progn-body start next result body)
-      (let ((fun-ctran (make-ctran))
+      (let ((ctran (make-ctran))
             (fun-lvar (make-lvar))
 	    (fun (ir1-convert-lambda-body body
  					  (list (first aux-vars))
@@ -216,8 +216,8 @@
  					  :debug-name (debug-namify
  						       "&AUX bindings ~S"
  						       aux-vars))))
-	(reference-leaf start fun-ctran fun-lvar fun)
-	(ir1-convert-combination-args fun-ctran fun-lvar next result
+	(reference-leaf start ctran fun-lvar fun)
+	(ir1-convert-combination-args fun-lvar ctran next result
 				      (list (first aux-vals)))))
   (values))
 
@@ -227,11 +227,11 @@
 ;;; the body, otherwise we do one special binding and recurse on the
 ;;; rest.
 ;;;
-;;; We make a cleanup and introduce it into the lexical environment.
-;;; If there are multiple special bindings, the cleanup for the blocks
-;;; will end up being the innermost one. We force CONT to start a
-;;; block outside of this cleanup, causing cleanup code to be emitted
-;;; when the scope is exited.
+;;; We make a cleanup and introduce it into the lexical
+;;; environment. If there are multiple special bindings, the cleanup
+;;; for the blocks will end up being the innermost one. We force NEXT
+;;; to start a block outside of this cleanup, causing cleanup code to
+;;; be emitted when the scope is exited.
 (defun ir1-convert-special-bindings
     (start next result body aux-vars aux-vals svars)
   (declare (type ctran start next) (type (or lvar null) result)
@@ -255,6 +255,25 @@
 				      (rest svars))))))
   (values))
 
+;;; FIXME: this is the interface of the CMUCL WITH-DYNAMIC-EXTENT
+;;; macro.  It is slightly confusing, in that START and BODY-START are
+;;; already-existing CTRANs (and FIXME: probably deserve a ONCE-ONLY),
+;;; whereas NEXT is a variable naming a CTRAN in the body.  -- CSR,
+;;; 2004-03-30.
+(defmacro with-dynamic-extent ((start body-start next kind) &body body)
+  (declare (ignore kind))
+  (with-unique-names (cleanup next-ctran)
+    `(progn
+      (ctran-starts-block ,body-start)
+      (let ((,cleanup (make-cleanup :kind :dynamic-extent))
+	    (,next-ctran (make-ctran))
+	    (,next (make-ctran)))
+	(ir1-convert ,start ,next-ctran nil '(%dynamic-extent-start))
+	(setf (cleanup-mess-up ,cleanup) (ctran-use ,next-ctran))
+	(let ((*lexenv* (make-lexenv :cleanup ,cleanup)))
+	  (ir1-convert ,next-ctran ,next nil '(%cleanup-point))
+	  (locally ,@body))))))
+
 ;;; Create a lambda node out of some code, returning the result. The
 ;;; bindings are specified by the list of VAR structures VARS. We deal
 ;;; with adding the names to the LEXENV-VARS for the conversion. The
@@ -267,7 +286,7 @@
 ;;; the special binding code.
 ;;;
 ;;; We ignore any ARG-INFO in the VARS, trusting that someone else is
-;;; dealing with &nonsense.
+;;; dealing with &NONSENSE, except for &REST vars with DYNAMIC-EXTENT.
 ;;;
 ;;; AUX-VARS is a list of VAR structures for variables that are to be
 ;;; sequentially bound. Each AUX-VAL is a form that is to be evaluated
@@ -291,7 +310,12 @@
                   :%source-name source-name
                   :%debug-name debug-name))
 	 (result-ctran (make-ctran))
-         (result-lvar (make-lvar)))
+         (result-lvar (make-lvar))
+	 (dx-rest nil))
+
+    (awhen (lexenv-lambda *lexenv*)
+      (push lambda (lambda-children it))
+      (setf (lambda-parent lambda) it))
 
     ;; just to check: This function should fail internal assertions if
     ;; we didn't set up a valid debug name above.
@@ -317,7 +341,12 @@
 		(t
                  (when note-lexical-bindings
                    (note-lexical-binding (leaf-source-name var)))
-		 (new-venv (cons (leaf-source-name var) var))))))
+		 (new-venv (cons (leaf-source-name var) var)))))
+	(let ((info (lambda-var-arg-info var)))
+	  (when (and info
+		     (eq (arg-info-kind info) :rest)
+		     (leaf-dynamic-extent var))
+	    (setq dx-rest t))))
 
       (let ((*lexenv* (make-lexenv :vars (new-venv)
 				   :lambda lambda
@@ -342,9 +371,14 @@
             (ctran-starts-block prebind-ctran)
             (link-node-to-previous-ctran bind prebind-ctran)
             (use-ctran bind postbind-ctran)
-            (ir1-convert-special-bindings postbind-ctran result-ctran result-lvar
-                                          body
-                                          aux-vars aux-vals (svars))))))
+	    (if dx-rest
+		(with-dynamic-extent (postbind-ctran result-ctran dx :rest)
+		  (ir1-convert-special-bindings dx result-ctran result-lvar
+						body aux-vars aux-vals
+						(svars)))
+		(ir1-convert-special-bindings postbind-ctran result-ctran
+					      result-lvar body
+					      aux-vars aux-vals (svars)))))))
 
     (link-blocks (component-head *current-component*) (node-block bind))
     (push lambda (component-new-functionals *current-component*))
@@ -510,7 +544,8 @@
       (arg-vars context-temp count-temp)
 
       (when rest
-	(arg-vals `(%listify-rest-args ,n-context ,n-count)))
+	(arg-vals `(%listify-rest-args
+		    ,n-context ,n-count ,(leaf-dynamic-extent rest))))
       (when morep
 	(arg-vals n-context)
 	(arg-vals n-count))
@@ -932,6 +967,7 @@
 				      (source-name '.anonymous.)
 				      debug-name
 				      allow-debug-catch-tag)
+  (declare (ignore allow-debug-catch-tag))
   (destructuring-bind (decls macros symbol-macros &rest body)
 		      (if (eq (car fun) 'lambda-with-lexenv)
 			  (cdr fun)