X-Git-Url: http://repo.macrolet.net/gitweb/?a=blobdiff_plain;f=src%2Fcompiler%2Fir1tran.lisp;h=19c2f8989602073d491e9cece39841107eebce9d;hb=f46d27c212eb12011b772cb8eefe904da4e7c778;hp=3151b25003d72d4229cb3c6afce0c2aa58d0ab6c;hpb=34dd23563d2f5cf05c72b971da0d0b065a09bf2a;p=sbcl.git

diff --git a/src/compiler/ir1tran.lisp b/src/compiler/ir1tran.lisp
index 3151b25..19c2f89 100644
--- a/src/compiler/ir1tran.lisp
+++ b/src/compiler/ir1tran.lisp
@@ -126,7 +126,7 @@
 ;;; demanded a function.
 (defun find-free-fun (name context)
   (declare (string context))
-  (declare (values global-var))
+  #+nil (declare (values global-var))
   (or (let ((old-free-fun (gethash name *free-funs*)))
 	(and (not (invalid-free-fun-p old-free-fun))
 	     old-free-fun))
@@ -172,7 +172,7 @@
 ;;; information from the global environment and enter it in
 ;;; *FREE-VARS*. If the variable is unknown, then we emit a warning.
 (defun find-free-var (name)
-  (declare (values (or leaf heap-alien-info)))
+  #+nil (declare (values (or leaf cons heap-alien-info))) ; see FIXME comment
   (unless (symbolp name)
     (compiler-error "Variable name is not a symbol: ~S." name))
   (or (gethash name *free-vars*)
@@ -185,6 +185,15 @@
 	      (case kind
 		(:alien
 		 (info :variable :alien-info name))
+                ;; FIXME: The return value in this case should really be
+                ;; of type SB!C::LEAF.  I don't feel too badly about it,
+                ;; because the MACRO idiom is scattered throughout this
+                ;; file, but it should be cleaned up so we're not
+                ;; throwing random conses around.  --njf 2002-03-23
+                (:macro
+                 (let ((expansion (info :variable :macro-expansion name))
+                       (type (type-specifier (info :variable :type name))))
+                   `(MACRO . (the ,type ,expansion))))
 		(:constant
 		 (let ((value (info :variable :constant-value name)))
 		   (make-constant :value value
@@ -204,7 +213,7 @@
 (eval-when (:compile-toplevel :load-toplevel :execute)
   ;; The EVAL-WHEN is necessary for #.(1+ LIST-TO-HASH-TABLE-THRESHOLD) 
   ;; below. -- AL 20010227
-  (defconstant list-to-hash-table-threshold 32))
+  (def!constant list-to-hash-table-threshold 32))
 (defun maybe-emit-make-load-forms (constant)
   (let ((things-processed nil)
 	(count 0))
@@ -1165,7 +1174,7 @@
   (unless (symbolp name)
     (compiler-error "The lambda variable ~S is not a symbol." name))
   (when (member name names-so-far :test #'eq)
-    (compiler-error "The variable ~S occurs more than once in the lambda-list."
+    (compiler-error "The variable ~S occurs more than once in the lambda list."
 		    name))
   (let ((kind (info :variable :kind name)))
     (when (or (keywordp name) (eq kind :constant))
@@ -1178,7 +1187,6 @@
 			      :where-from (leaf-where-from specvar)
 			      :specvar specvar)))
 	  (t
-	   (note-lexical-binding name)
 	   (make-lambda-var :%source-name name)))))
 
 ;;; Make the default keyword for a &KEY arg, checking that the keyword
@@ -1197,7 +1205,7 @@
 		   (eq (arg-info-kind info) :keyword)
 		   (eq (arg-info-key info) key))
 	  (compiler-error
-	   "The keyword ~S appears more than once in the lambda-list."
+	   "The keyword ~S appears more than once in the lambda list."
 	   key))))
     key))
 
@@ -1459,12 +1467,31 @@
 	(setf (node-lexenv bind) *lexenv*)
 	
 	(let ((cont1 (make-continuation))
-	      (cont2 (make-continuation)))
+	      (cont2 (make-continuation))
+	      (revised-body (if (policy bind
+					(or (> safety
+					       (max speed space))
+					    (= safety 3)))
+				;; (Stuffing this in at IR1 level like
+				;; this is pretty crude. And it's
+				;; particularly inefficient to execute
+				;; it on *every* LAMBDA, including
+				;; LET-converted LAMBDAs. Improvements
+				;; are welcome, but meanwhile, when
+				;; SAFETY is high, it's still arguably
+				;; an improvement over the old CMU CL
+				;; approach of doing nothing (waiting
+				;; for evolution to breed careful
+				;; users:-). -- WHN)
+				`((%detect-stack-exhaustion)
+				  ,@body)
+				body)))
 	  (continuation-starts-block cont1)
 	  (link-node-to-previous-continuation bind cont1)
 	  (use-continuation bind cont2)
-	  (ir1-convert-special-bindings cont2 result body aux-vars aux-vals
-					(svars)))
+	  (ir1-convert-special-bindings cont2 result
+					revised-body
+					aux-vars aux-vals (svars)))
 
 	(let ((block (continuation-block result)))
 	  (when block