X-Git-Url: http://repo.macrolet.net/gitweb/?a=blobdiff_plain;f=src%2Fcompiler%2Fir1tran.lisp;h=c5f7b4184d7edb1aa2a1f78b9a0697486ff09a09;hb=b0642df835dc2fca3e4cf47aff978ecdc88799d5;hp=aa346d42f0774a0f9d8f63075bc38a7298915622;hpb=650499e7ae935d53cc1e0de6fc73e10dca5be253;p=sbcl.git

diff --git a/src/compiler/ir1tran.lisp b/src/compiler/ir1tran.lisp
index aa346d4..c5f7b41 100644
--- a/src/compiler/ir1tran.lisp
+++ b/src/compiler/ir1tran.lisp
@@ -48,6 +48,11 @@
   to optimize code which uses those definitions? Setting this true
   gives non-ANSI, early-CMU-CL behavior. It can be useful for improving
   the efficiency of stable code.")
+
+;;; *ALLOW-DEBUG-CATCH-TAG* controls whether we should allow the
+;;; insertion a (CATCH ...) around code to allow the debugger RETURN
+;;; command to function.
+(defvar *allow-debug-catch-tag* t)
 
 ;;;; namespace management utilities
 
@@ -898,7 +903,7 @@
   (declare (list decl vars) (type lexenv res))
   (let ((type (compiler-specifier-type (first decl))))
     (collect ((restr nil cons)
-	      (new-vars nil cons))
+             (new-vars nil cons))
       (dolist (var-name (rest decl))
 	(let* ((bound-var (find-in-bindings vars var-name))
 	       (var (or bound-var
@@ -906,26 +911,31 @@
 			(find-free-var var-name))))
 	  (etypecase var
 	    (leaf
-	     (let* ((old-type (or (lexenv-find var type-restrictions)
-				  (leaf-type var)))
-		    (int (if (or (fun-type-p type)
-				 (fun-type-p old-type))
-			     type
-			     (type-approx-intersection2 old-type type))))
-	       (cond ((eq int *empty-type*)
-		      (unless (policy *lexenv* (= inhibit-warnings 3))
-			(compiler-warn
-			 "The type declarations ~S and ~S for ~S conflict."
-			 (type-specifier old-type) (type-specifier type)
-			 var-name)))
-		     (bound-var (setf (leaf-type bound-var) int))
-		     (t
-		      (restr (cons var int))))))
+             (flet ((process-var (var bound-var)
+                      (let* ((old-type (or (lexenv-find var type-restrictions)
+                                           (leaf-type var)))
+                             (int (if (or (fun-type-p type)
+                                          (fun-type-p old-type))
+                                      type
+                                      (type-approx-intersection2 old-type type))))
+                        (cond ((eq int *empty-type*)
+                               (unless (policy *lexenv* (= inhibit-warnings 3))
+                                 (compiler-warn
+                                  "The type declarations ~S and ~S for ~S conflict."
+                                  (type-specifier old-type) (type-specifier type)
+                                  var-name)))
+                              (bound-var (setf (leaf-type bound-var) int))
+                              (t
+                               (restr (cons var int)))))))
+               (process-var var bound-var)
+               (awhen (and (lambda-var-p var)
+                           (lambda-var-specvar var))
+                      (process-var it nil))))
 	    (cons
 	     ;; FIXME: non-ANSI weirdness
 	     (aver (eq (car var) 'MACRO))
 	     (new-vars `(,var-name . (MACRO . (the ,(first decl)
-						   ,(cdr var))))))
+                                                ,(cdr var))))))
 	    (heap-alien-info
 	     (compiler-error
 	      "~S is an alien variable, so its type can't be declared."
@@ -1432,7 +1442,8 @@
 				aux-vals
 				result
 				(source-name '.anonymous.)
-				debug-name)
+				debug-name
+                                (note-lexical-bindings t))
   (declare (list body vars aux-vars aux-vals)
 	   (type (or continuation null) result))
 
@@ -1468,7 +1479,8 @@
 		 (svars var)
 		 (new-venv (cons (leaf-source-name specvar) specvar)))
 		(t
-		 (note-lexical-binding (leaf-source-name var))
+                 (when note-lexical-bindings
+                   (note-lexical-binding (leaf-source-name var)))
 		 (new-venv (cons (leaf-source-name var) var))))))
 
       (let ((*lexenv* (make-lexenv :vars (new-venv)
@@ -1476,7 +1488,7 @@
 				   :cleanup nil)))
 	(setf (bind-lambda bind) lambda)
 	(setf (node-lexenv bind) *lexenv*)
-	
+
 	(let ((cont1 (make-continuation))
 	      (cont2 (make-continuation)))
 	  (continuation-starts-block cont1)
@@ -1517,19 +1529,27 @@
   (declare (type clambda fun) (list vars vals defaults))
   (let* ((fvars (reverse vars))
 	 (arg-vars (mapcar (lambda (var)
-			     (unless (lambda-var-specvar var)
-			       (note-lexical-binding (leaf-source-name var)))
 			     (make-lambda-var
 			      :%source-name (leaf-source-name var)
 			      :type (leaf-type var)
 			      :where-from (leaf-where-from var)
 			      :specvar (lambda-var-specvar var)))
 			   fvars))
-	 (fun (ir1-convert-lambda-body `((%funcall ,fun
-						   ,@(reverse vals)
-						   ,@defaults))
-				       arg-vars
-				       :debug-name "&OPTIONAL processor")))
+	 (fun (collect ((default-bindings)
+                        (default-vals))
+                (dolist (default defaults)
+                  (if (constantp default)
+                      (default-vals default)
+                      (let ((var (gensym)))
+                        (default-bindings `(,var ,default))
+                        (default-vals var))))
+                (ir1-convert-lambda-body `((let (,@(default-bindings))
+                                             (%funcall ,fun
+                                                       ,@(reverse vals)
+                                                       ,@(default-vals))))
+                                         arg-vars
+                                         :debug-name "&OPTIONAL processor"
+                                         :note-lexical-bindings nil))))
     (mapc (lambda (var arg-var)
 	    (when (cdr (leaf-refs arg-var))
 	      (setf (leaf-ever-used var) t)))
@@ -1698,9 +1718,10 @@
 		 `((let ,(temps)
 		     ,@(body)
 		     (%funcall ,(optional-dispatch-main-entry res)
-			       . ,(arg-vals)))) ; FIXME: What is the '.'? ,@?
+			       ,@(arg-vals))))
 		 (arg-vars)
-		 :debug-name (debug-namify "~S processing" '&more))))
+		 :debug-name (debug-namify "~S processing" '&more)
+                 :note-lexical-bindings nil)))
 	(setf (optional-dispatch-more-entry res) ep))))
 
   (values))
@@ -1960,33 +1981,65 @@
      "The lambda expression has a missing or non-list lambda list:~%  ~S"
      form))
 
-  (multiple-value-bind (vars keyp allow-other-keys aux-vars aux-vals)
-      (make-lambda-vars (cadr form))
-    (multiple-value-bind (forms decls) (parse-body (cddr form))
-      (let* ((result-cont (make-continuation))
-	     (*lexenv* (process-decls decls
-				      (append aux-vars vars)
-				      nil result-cont))
-	     (forms (if (and allow-debug-catch-tag
-			     (policy *lexenv* (> debug (max speed space))))
-			`((catch (make-symbol "SB-DEBUG-CATCH-TAG")
-			    ,@forms))
-			forms))
-	     (res (if (or (find-if #'lambda-var-arg-info vars) keyp)
-		      (ir1-convert-hairy-lambda forms vars keyp
-						allow-other-keys
-						aux-vars aux-vals result-cont
-						:source-name source-name
-						:debug-name debug-name)
-		      (ir1-convert-lambda-body forms vars
-					       :aux-vars aux-vars
-					       :aux-vals aux-vals
-					       :result result-cont
-					       :source-name source-name
-					       :debug-name debug-name))))
-	(setf (functional-inline-expansion res) form)
-	(setf (functional-arg-documentation res) (cadr form))
-	res))))
+  (let ((*allow-debug-catch-tag* (and *allow-debug-catch-tag* allow-debug-catch-tag)))
+    (multiple-value-bind (vars keyp allow-other-keys aux-vars aux-vals)
+	(make-lambda-vars (cadr form))
+      (multiple-value-bind (forms decls) (parse-body (cddr form))
+	(let* ((result-cont (make-continuation))
+	       (*lexenv* (process-decls decls
+					(append aux-vars vars)
+					nil result-cont))
+	       (forms (if (and *allow-debug-catch-tag*
+			       (policy *lexenv* (> debug (max speed space))))
+			  `((catch (make-symbol "SB-DEBUG-CATCH-TAG")
+			      ,@forms))
+			  forms))
+	       (res (if (or (find-if #'lambda-var-arg-info vars) keyp)
+			(ir1-convert-hairy-lambda forms vars keyp
+						  allow-other-keys
+						  aux-vars aux-vals result-cont
+						  :source-name source-name
+						  :debug-name debug-name)
+			(ir1-convert-lambda-body forms vars
+						 :aux-vars aux-vars
+						 :aux-vals aux-vals
+						 :result result-cont
+						 :source-name source-name
+						 :debug-name debug-name))))
+	  (setf (functional-inline-expansion res) form)
+	  (setf (functional-arg-documentation res) (cadr form))
+	  res)))))
+
+;;; helper for LAMBDA-like things, to massage them into a form
+;;; suitable for IR1-CONVERT-LAMBDA.
+;;;
+;;; KLUDGE: We cons up a &REST list here, maybe for no particularly
+;;; good reason.  It's probably lost in the noise of all the other
+;;; consing, but it's still inelegant.  And we force our called
+;;; functions to do full runtime keyword parsing, ugh.  -- CSR,
+;;; 2003-01-25
+(defun ir1-convert-lambdalike (thing &rest args
+			       &key (source-name '.anonymous.)
+			       debug-name allow-debug-catch-tag)
+  (ecase (car thing)
+    ((lambda) (apply #'ir1-convert-lambda thing args))
+    ((instance-lambda)
+     (let ((res (apply #'ir1-convert-lambda
+		       `(lambda ,@(cdr thing)) args)))
+       (setf (getf (functional-plist res) :fin-function) t)
+       res))
+    ((named-lambda)
+     (let ((name (cadr thing)))
+       (if (legal-fun-name-p name)
+	   (let ((res (apply #'ir1-convert-lambda `(lambda ,@(cddr thing))
+			     :source-name name
+			     :debug-name nil
+			     args)))
+	     (assert-global-function-definition-type name res)
+	     res)
+	   (apply #'ir1-convert-lambda `(lambda ,@(cddr thing))
+		  :debug-name name args))))
+    ((lambda-with-lexenv) (apply #'ir1-convert-inline-lambda thing args))))
 
 ;;;; defining global functions
 
@@ -1996,7 +2049,8 @@
 ;;; reflect the state at the definition site.
 (defun ir1-convert-inline-lambda (fun &key
 				      (source-name '.anonymous.)
-				      debug-name)
+				      debug-name
+				      allow-debug-catch-tag)
   (destructuring-bind (decls macros symbol-macros &rest body)
 		      (if (eq (car fun) 'lambda-with-lexenv)
 			  (cdr fun)
@@ -2013,7 +2067,8 @@
 		     :policy (lexenv-policy *lexenv*))))
       (ir1-convert-lambda `(lambda ,@body)
 			  :source-name source-name
-			  :debug-name debug-name))))
+			  :debug-name debug-name
+			  :allow-debug-catch-tag nil))))
 
 ;;; Get a DEFINED-FUN object for a function we are about to define. If
 ;;; the function has been forward referenced, then substitute for the