X-Git-Url: http://repo.macrolet.net/gitweb/?a=blobdiff_plain;f=src%2Fcode%2Feval.lisp;h=dc74c2cf9f03244ae0321d2ca5907e7f2e743b20;hb=3f3033a6c0ddf0af8dd1b5a17c2a4b82ea59b94f;hp=56ea38cf7a6f868eb7cbda2ac8aba8a6f9bd4f9c;hpb=0371580437ef7f3e39f0bfbb9e45264986408b19;p=sbcl.git diff --git a/src/code/eval.lisp b/src/code/eval.lisp index 56ea38c..dc74c2c 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,7 +184,11 @@ (not (consp (let ((sb!c:*lexenv* lexenv)) (sb!c:lexenv-find name funs))))) (%coerce-name-to-fun name) - (%simple-eval original-exp lexenv)))) + ;; 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) (error "wrong number of args to QUOTE:~% ~S" exp)) @@ -198,9 +243,9 @@ ;; PROGN; otherwise, the EVAL-WHEN form returns NIL. (declare (ignore ct lt)) (when e - (simple-eval-progn-body body lexenv))))) + (simple-eval-progn-body body lexenv))))) ((locally) - (simple-eval-locally exp lexenv)) + (simple-eval-locally exp lexenv)) ((macrolet) (destructuring-bind (definitions &rest body) (rest exp) @@ -212,7 +257,7 @@ (declare (ignore funs)) sb!c:*lexenv*) :eval)))) - (simple-eval-locally `(locally ,@body) lexenv)))) + (simple-eval-locally `(locally ,@body) lexenv)))) ((symbol-macrolet) (destructuring-bind (definitions &rest body) (rest exp) (multiple-value-bind (lexenv vars) @@ -230,10 +275,7 @@ else) lexenv))) ((let let*) - (destructuring-bind (definitions &rest body) (rest exp) - (if (null definitions) - (simple-eval-locally `(locally ,@body) lexenv) - (%simple-eval exp lexenv)))) + (%simple-eval exp lexenv)) (t (if (and (symbolp name) (eq (info :function :kind name) :function)) @@ -257,8 +299,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 +337,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)