(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 %eval (expr lexenv)
+(defun %simple-eval (expr lexenv)
;; FIXME: It might be nice to quieten the toplevel by muffling
;; warnings generated by this compilation (since we're about to
;; execute the results irrespective of the warnings). We might want
;; 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 ((fun (sb!c:compile-in-lexenv nil
- `(lambda () ,expr)
- 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.
-(defun eval-progn-body (progn-body lexenv)
+(defun simple-eval-progn-body (progn-body lexenv)
(unless (list-with-length-p progn-body)
(let ((*print-circle* t))
(error 'simple-program-error
(rest-i (rest i) (rest i)))
(nil)
(if rest-i ; if not last element of list
- (eval-in-lexenv (first i) lexenv)
- (return (eval-in-lexenv (first i) lexenv)))))
+ (simple-eval-in-lexenv (first i) lexenv)
+ (return (simple-eval-in-lexenv (first i) lexenv)))))
-(defun eval-locally (exp lexenv &key vars)
+(defun simple-eval-locally (exp lexenv &key vars)
(multiple-value-bind (body decls)
(parse-body (rest exp) :doc-string-allowed nil)
(let ((lexenv
nil
:lexenv lexenv
:context :eval))))
- (eval-progn-body body lexenv))))
-
-(defun eval (original-exp)
- #!+sb-doc
- "Evaluate the argument in a null lexical environment, returning the
- result or results."
- (eval-in-lexenv original-exp (make-null-lexenv)))
+ (simple-eval-progn-body body lexenv))))
;;;; EVAL-ERROR
;;;;
;;;; Analogous to COMPILER-ERROR, but simpler.
-(define-condition eval-error (encapsulated-condition) ())
+(define-condition eval-error (encapsulated-condition)
+ ()
+ (:report (lambda (condition stream)
+ (print-object (encapsulated-condition condition) stream))))
(defun eval-error (condition)
(signal 'eval-error :condition condition)
(bug "Unhandled EVAL-ERROR"))
;;; Pick off a few easy cases, and the various top level EVAL-WHEN
-;;; magical cases, and call %EVAL for the rest.
-(defun eval-in-lexenv (original-exp lexenv)
+;;; magical cases, and call %SIMPLE-EVAL for the rest.
+(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)
(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
;; with DEFINE-SYMBOL-MACRO, keeping the code walkers
;; happy.
(:alien
- (%eval original-exp lexenv))))
+ (%simple-eval original-exp lexenv))))
(list
(let ((name (first exp))
(n-args (1- (length exp))))
(not (consp (let ((sb!c:*lexenv* lexenv))
(sb!c:lexenv-find name funs)))))
(%coerce-name-to-fun name)
- (%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))
;; We duplicate the call to SET so that the
;; correct value gets returned.
(set (first args)
- (eval-in-lexenv (second args) lexenv)))
+ (simple-eval-in-lexenv (second args) lexenv)))
(set (first args)
- (eval-in-lexenv (second args) lexenv))))
+ (simple-eval-in-lexenv (second args) lexenv))))
(let ((symbol (first name)))
(case (info :variable :kind symbol)
(:special)
- (t (return (%eval original-exp lexenv))))
+ (t (return (%simple-eval original-exp lexenv))))
(unless (type= (info :variable :type symbol)
*universal-type*)
;; let the compiler deal with type checking
- (return (%eval original-exp lexenv)))))))
+ (return (%simple-eval original-exp lexenv)))))))
((progn)
- (eval-progn-body (rest exp) lexenv))
+ (simple-eval-progn-body (rest exp) lexenv))
((eval-when)
;; FIXME: DESTRUCTURING-BIND returns ARG-COUNT-ERROR
;; instead of PROGRAM-ERROR when there's something wrong
;; PROGN; otherwise, the EVAL-WHEN form returns NIL.
(declare (ignore ct lt))
(when e
- (eval-progn-body body lexenv)))))
+ (simple-eval-progn-body body lexenv)))))
((locally)
- (eval-locally exp lexenv))
+ (simple-eval-locally exp lexenv))
((macrolet)
(destructuring-bind (definitions &rest body)
(rest exp)
(declare (ignore funs))
sb!c:*lexenv*)
:eval))))
- (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)
(lambda (&key vars)
(values sb!c:*lexenv* vars))
:eval))
- (eval-locally `(locally ,@body) lexenv :vars vars))))
+ (simple-eval-locally `(locally ,@body) lexenv :vars vars))))
+ ((if)
+ (destructuring-bind (test then &optional else) (rest exp)
+ (eval-in-lexenv (if (eval-in-lexenv test lexenv)
+ then
+ else)
+ lexenv)))
+ ((let let*)
+ (destructuring-bind (definitions &rest body) (rest exp)
+ (if (null definitions)
+ (simple-eval-locally `(locally ,@body) lexenv)
+ (%simple-eval exp lexenv))))
(t
(if (and (symbolp name)
(eq (info :function :kind name) :function))
(dolist (arg (rest exp))
(args (eval-in-lexenv arg lexenv)))
(apply (symbol-function name) (args)))
- (%eval exp lexenv))))))
+ (%simple-eval exp lexenv))))))
(t
exp))))))
+
+(defun eval-in-lexenv (exp lexenv)
+ #!+sb-eval
+ (if (eq *evaluator-mode* :compile)
+ (simple-eval-in-lexenv exp lexenv)
+ (sb!eval:eval-in-native-environment exp lexenv))
+ #!-sb-eval
+ (simple-eval-in-lexenv exp lexenv))
+
+(defun eval (original-exp)
+ #!+sb-doc
+ "Evaluate the argument in a null lexical environment, returning the
+ result or results."
+ (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)))
\f
;;; miscellaneous full function definitions of things which are
;;; ordinarily handled magically by the compiler
(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)