X-Git-Url: http://repo.macrolet.net/gitweb/?a=blobdiff_plain;f=src%2Fcode%2Feval.lisp;h=d77f90f2bef886042eae3a653a83aa55f3c0f3a8;hb=f9aaac53a4a43ebae198f53079857acb2d628eb0;hp=b81bd7c9df69c232e87515ecbdd3ec20bc8b8c9f;hpb=6f095a43607506faaceedb8b22633a5770bd7f7a;p=sbcl.git

diff --git a/src/code/eval.lisp b/src/code/eval.lisp
index b81bd7c..d77f90f 100644
--- a/src/code/eval.lisp
+++ b/src/code/eval.lisp
@@ -21,8 +21,7 @@
   ;; evaluations/compilations, though [e.g. the ignored variable in
   ;; (DEFUN FOO (X) 1)].  -- CSR, 2003-05-13
   (let ((fun (sb!c:compile-in-lexenv (gensym "EVAL-TMPFUN-")
-				     `(lambda ()
-				       ,expr)
+				     `(lambda () ,expr)
 				     lexenv)))
     (funcall fun)))
 
@@ -47,6 +46,33 @@
 	(eval-in-lexenv (first i) lexenv)
 	(return (eval-in-lexenv (first i) lexenv)))))
 
+(defun eval-locally (exp lexenv &optional vars)
+  (multiple-value-bind (body decls)
+      (parse-body (rest exp) :doc-string-allowed nil)
+    (let ((lexenv
+           ;; KLUDGE: Uh, yeah.  I'm not anticipating
+           ;; winning any prizes for this code, which was
+           ;; written on a "let's get it to work" basis.
+           ;; These seem to be the variables that need
+           ;; bindings for PROCESS-DECLS to work
+           ;; (*FREE-FUNS* and *FREE-VARS* so that
+           ;; references to free functions and variables
+           ;; in the declarations can be noted;
+           ;; *UNDEFINED-WARNINGS* so that warnings about
+           ;; undefined things can be accumulated [and
+           ;; then thrown away, as it happens]). -- CSR,
+           ;; 2002-10-24
+           (let ((sb!c:*lexenv* lexenv)
+                 (sb!c::*free-funs* (make-hash-table :test 'equal))
+                 (sb!c::*free-vars* (make-hash-table :test 'eq))
+                 (sb!c::*undefined-warnings* nil))
+             ;; FIXME: VALUES declaration
+             (sb!c::process-decls decls
+                                  vars
+                                  nil
+                                  lexenv))))
+      (eval-progn-body body lexenv))))
+
 (defun eval (original-exp)
   #!+sb-doc
   "Evaluate the argument in a null lexical environment, returning the
@@ -122,13 +148,12 @@
 		       (set (first args) (eval (second args)))))
 		  (let ((symbol (first name)))
 		    (case (info :variable :kind symbol)
-		      ;; FIXME: I took out the *TOPLEVEL-AUTO-DECLARE*
-		      ;; test here, and removed the
-		      ;; *TOPLEVEL-AUTO-DECLARE* variable; the code
-		      ;; should now act as though that variable is
-		      ;; NIL. This should be tested..
 		      (:special)
-		      (t (return (%eval original-exp lexenv))))))))
+		      (t (return (%eval original-exp lexenv))))
+		    (unless (type= (info :variable :type symbol)
+				   *universal-type*)
+		      ;; let the compiler deal with type checking
+		      (return (%eval original-exp lexenv)))))))
 	     ((progn)
 	      (eval-progn-body (rest exp) lexenv))
 	     ((eval-when)
@@ -159,76 +184,37 @@
 		  (when e
 		    (eval-progn-body body lexenv)))))
 	     ((locally)
-	      (multiple-value-bind (body decls) (parse-body (rest exp) nil)
-		(let ((lexenv
-		       ;; KLUDGE: Uh, yeah.  I'm not anticipating
-		       ;; winning any prizes for this code, which was
-		       ;; written on a "let's get it to work" basis.
-		       ;; These seem to be the variables that need
-		       ;; bindings for PROCESS-DECLS to work
-		       ;; (*FREE-FUNS* and *FREE-VARS* so that
-		       ;; references to free functions and variables
-		       ;; in the declarations can be noted;
-		       ;; *UNDEFINED-WARNINGS* so that warnings about
-		       ;; undefined things can be accumulated [and
-		       ;; then thrown away, as it happens]). -- CSR,
-		       ;; 2002-10-24
-		       (let ((sb!c:*lexenv* lexenv)
-			     (sb!c::*free-funs* (make-hash-table :test 'equal))
-			     (sb!c::*free-vars* (make-hash-table :test 'eq))
-			     (sb!c::*undefined-warnings* nil))
-			 (sb!c::process-decls decls
-					      nil nil
-					      (sb!c::make-continuation)
-					      lexenv))))
-		  (eval-progn-body body lexenv))))
+	      (eval-locally exp lexenv))
 	     ((macrolet)
 	      (destructuring-bind (definitions &rest body)
 		  (rest exp)
-		;; FIXME: shared code with
-		;; FUNCALL-IN-FOOMACROLET-LEXENV
-		(declare (type list definitions))
-		(unless (= (length definitions)
-			   (length (remove-duplicates definitions
-						      :key #'first)))
-		  (style-warn "duplicate definitions in ~S" definitions))
 		(let ((lexenv
-		       (sb!c::make-lexenv
-			:default lexenv
-			:funs (mapcar
-			       (sb!c::macrolet-definitionize-fun
-				:eval
-				;; I'm not sure that this is the
-				;; correct LEXENV to be compiling
-				;; local macros in...
-				lexenv)
-			       definitions))))
-		  (eval-in-lexenv `(locally ,@body) lexenv))))
+                       (let ((sb!c:*lexenv* lexenv))
+                         (sb!c::funcall-in-macrolet-lexenv
+                          definitions
+                          (lambda (&key funs)
+                            (declare (ignore funs))
+                            sb!c:*lexenv*)
+                          :eval))))
+                  (eval-locally `(locally ,@body) lexenv))))
 	     ((symbol-macrolet)
 	      (destructuring-bind (definitions &rest body)
 		  (rest exp)
-		;; FIXME: shared code with
-		;; FUNCALL-IN-FOOMACROLET-LEXENV
-		(declare (type list definitions))
-		(unless (= (length definitions)
-			   (length (remove-duplicates definitions
-						      :key #'first)))
-		  (style-warn "duplicate definitions in ~S" definitions))
-		(let ((lexenv
-		       (sb!c::make-lexenv
-			:default lexenv
-			:vars (mapcar
-			       (sb!c::symbol-macrolet-definitionize-fun
-				:eval)
-			       definitions))))
-		  (eval-in-lexenv `(locally ,@body) lexenv))))
+                (multiple-value-bind (lexenv vars)
+                    (let ((sb!c:*lexenv* lexenv))
+                      (sb!c::funcall-in-symbol-macrolet-lexenv
+                       definitions
+                       (lambda (&key vars)
+                         (values sb!c:*lexenv* vars))
+                       :eval))
+                  (eval-locally `(locally ,@body) lexenv vars))))
 	     (t
 	      (if (and (symbolp name)
 		       (eq (info :function :kind name) :function))
 		  (collect ((args))
-			   (dolist (arg (rest exp))
-			     (args (eval-in-lexenv arg lexenv)))
-			   (apply (symbol-function name) (args)))
+                    (dolist (arg (rest exp))
+                      (args (eval-in-lexenv arg lexenv)))
+                    (apply (symbol-function name) (args)))
 		  (%eval exp lexenv))))))
 	(t
 	 exp)))))