X-Git-Url: http://repo.macrolet.net/gitweb/?a=blobdiff_plain;f=src%2Fcode%2Feval.lisp;h=4687ebd12b7b34e0ad36be5d1fdefccd6866bada;hb=6caf3ed5713773cb423f46bf40a29f2438c97c78;hp=99fea12556644bf81ee75ef0772597663bb6e714;hpb=9a9a95003920c0dacd02b1932e0e1608fb822cc2;p=sbcl.git

diff --git a/src/code/eval.lisp b/src/code/eval.lisp
index 99fea12..4687ebd 100644
--- a/src/code/eval.lisp
+++ b/src/code/eval.lisp
@@ -11,6 +11,46 @@
 
 (in-package "SB!IMPL")
 
+(defparameter *eval-calls* 0)
+
+(defun !eval-cold-init ()
+  (setf *eval-calls* 0
+        *evaluator-mode* :compile)
+  #!+sb-eval
+  (setf sb!eval::*eval-level* -1
+        sb!eval::*eval-verbose* nil))
+
+(defvar *eval-source-context* nil)
+
+(defvar *eval-tlf-index* nil)
+(defvar *eval-source-info* nil)
+
+(defun make-eval-lambda (expr)
+  `(named-lambda
+       ;; This name is used to communicate the original context
+       ;; for the compiler, and identifies the lambda for use of
+       ;; EVAL-LAMBDA-SOURCE-LAMBDA below.
+       (eval ,(sb!c::source-form-context *eval-source-context*)) ()
+     (declare (muffle-conditions compiler-note))
+     ;; why PROGN?  So that attempts to eval free declarations
+     ;; signal errors rather than return NIL.  -- CSR, 2007-05-01
+     (progn ,expr)))
+
+(defun eval-lambda-p (form)
+  (when (and (consp form) (eq 'named-lambda (first form)))
+    (let ((name (second form)))
+      (when (and (consp name) (eq 'eval (first name)))
+        t))))
+
+(defun eval-lambda-source-lambda (eval-lambda)
+  (if (eval-lambda-p eval-lambda)
+      (destructuring-bind (named-lambda name lambda-list decl (progn expr))
+          eval-lambda
+        (declare (ignore named-lambda name lambda-list decl progn))
+        (when (and (consp expr) (member (car expr) '(lambda named-lambda)))
+          expr))
+      eval-lambda))
+
 ;;; general case of EVAL (except in that it can't handle toplevel
 ;;; EVAL-WHEN magic properly): Delegate to #'COMPILE.
 (defun %simple-eval (expr lexenv)
@@ -20,10 +60,12 @@
   ;; to be careful about not muffling warnings arising from inner
   ;; evaluations/compilations, though [e.g. the ignored variable in
   ;; (DEFUN FOO (X) 1)].  -- CSR, 2003-05-13
-  (let* (;; why PROGN?  So that attempts to eval free declarations
-         ;; signal errors rather than return NIL.  -- CSR, 2007-05-01
-         (lambda `(lambda () (progn ,expr)))
-         (fun (sb!c:compile-in-lexenv nil lambda lexenv)))
+  ;;
+  ;; As of 1.0.21.6 we muffle compiler notes lexically here, which seems
+  ;; always safe. --NS
+  (let* ((lambda (make-eval-lambda expr))
+         (fun (sb!c:compile-in-lexenv
+               nil lambda lexenv *eval-source-info* *eval-tlf-index*)))
     (funcall fun)))
 
 ;;; Handle PROGN and implicit PROGN.
@@ -93,6 +135,7 @@
 (defun simple-eval-in-lexenv (original-exp lexenv)
   (declare (optimize (safety 1)))
   ;; (aver (lexenv-simple-p lexenv))
+  (incf *eval-calls*)
   (handler-bind
       ((sb!c:compiler-error
         (lambda (c)
@@ -115,9 +158,7 @@
         (typecase exp
           (symbol
            (ecase (info :variable :kind exp)
-             (:constant
-              (values (info :variable :constant-value exp)))
-             ((:special :global)
+             ((:special :global :constant :unknown)
               (symbol-value exp))
              ;; FIXME: This special case here is a symptom of non-ANSI
              ;; weirdness in SBCL's ALIEN implementation, which could
@@ -143,6 +184,10 @@
                            (not (consp (let ((sb!c:*lexenv* lexenv))
                                          (sb!c:lexenv-find name funs)))))
                       (%coerce-name-to-fun name)
+                      ;; FIXME: This is a bit wasteful: it would be nice to call
+                      ;; COMPILE-IN-LEXENV with the lambda-form directly, but
+                      ;; getting consistent source context and muffling compiler notes
+                      ;; is easier this way.
                       (%simple-eval original-exp lexenv))))
                ((quote)
                 (unless (= n-args 1)
@@ -257,8 +302,16 @@
   #!+sb-doc
   "Evaluate the argument in a null lexical environment, returning the
    result or results."
-  (eval-in-lexenv original-exp (make-null-lexenv)))
+  (let ((*eval-source-context* original-exp)
+        (*eval-tlf-index* nil)
+        (*eval-source-info* nil))
+    (eval-in-lexenv original-exp (make-null-lexenv))))
 
+(defun eval-tlf (original-exp tlf-index &optional (lexenv (make-null-lexenv)))
+  (let ((*eval-source-context* original-exp)
+        (*eval-tlf-index* tlf-index)
+        (*eval-source-info* sb!c::*source-info*))
+    (eval-in-lexenv original-exp lexenv)))
 
 ;;; miscellaneous full function definitions of things which are
 ;;; ordinarily handled magically by the compiler
@@ -287,7 +340,7 @@
 (defun values (&rest values)
   #!+sb-doc
   "Return all arguments, in order, as values."
-  (declare (dynamic-extent values))
+  (declare (truly-dynamic-extent values))
   (values-list values))
 
 (defun values-list (list)