(defvar *eval-tlf-index* nil)
(defvar *eval-source-info* nil)
+;;;; Turns EXPR into a lambda-form we can pass to COMPILE. Returns
+;;;; a secondary value of T if we must call the resulting function
+;;;; to evaluate EXPR -- if EXPR is already a lambda form, there's
+;;;; no need.
(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))
+ (if (typep expr `(cons (member lambda named-lambda lambda-with-lexenv)))
+ (values expr nil)
+ (values `(lambda ()
+ ;; why PROGN? So that attempts to eval free declarations
+ ;; signal errors rather than return NIL. -- CSR, 2007-05-01
+ (progn ,expr))
+ t)))
;;; general case of EVAL (except in that it can't handle toplevel
;;; EVAL-WHEN magic properly): Delegate to #'COMPILE.
(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
- ;;
- ;; 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)))
+ (multiple-value-bind (lambda call) (make-eval-lambda expr)
+ (let ((fun
+ ;; This tells the compiler where the lambda comes from, in case it
+ ;; wants to report any problems.
+ (let ((sb!c::*source-form-context-alist*
+ (acons lambda *eval-source-context*
+ sb!c::*source-form-context-alist*)))
+ (handler-bind (;; Compiler notes just clutter up the REPL:
+ ;; anyone caring about performance should not
+ ;; be using EVAL.
+ (compiler-note #'muffle-warning))
+ (sb!c:compile-in-lexenv
+ nil lambda lexenv *eval-source-info* *eval-tlf-index* (not call))))))
+ (declare (function fun))
+ (if call
+ (funcall fun)
+ fun))))
;;; Handle PROGN and implicit PROGN.
(defun simple-eval-progn-body (progn-body lexenv)
(declare (optimize (safety 1)))
;; (aver (lexenv-simple-p lexenv))
(incf *eval-calls*)
- (handler-bind
- ((sb!c:compiler-error
- (lambda (c)
- (if (boundp 'sb!c::*compiler-error-bailout*)
- ;; if we're in the compiler, delegate either to a higher
- ;; authority or, if that's us, back down to the
- ;; outermost compiler handler...
- (progn
- (signal c)
- nil)
- ;; ... if we're not in the compiler, better signal the
- ;; error straight away.
- (invoke-restart 'sb!c::signal-error)))))
+ (sb!c:with-compiler-error-resignalling
(let ((exp (macroexpand original-exp lexenv)))
(handler-bind ((eval-error
- (lambda (condition)
- (error 'interpreted-program-error
- :condition (encapsulated-condition condition)
- :form exp))))
+ (lambda (condition)
+ (error 'interpreted-program-error
+ :condition (encapsulated-condition condition)
+ :form exp))))
(typecase exp
(symbol
(ecase (info :variable :kind exp)
;; with DEFINE-SYMBOL-MACRO, keeping the code walkers
;; happy.
(:alien
- (%simple-eval original-exp lexenv))))
+ (sb!alien-internals:alien-value exp))))
(list
(let ((name (first exp))
(n-args (1- (length exp))))
(destructuring-bind (definitions &rest body)
(rest exp)
(let ((lexenv
- (let ((sb!c:*lexenv* lexenv))
- (sb!c::funcall-in-macrolet-lexenv
- definitions
- (lambda (&key funs)
- (declare (ignore funs))
- sb!c:*lexenv*)
- :eval))))
+ (let ((sb!c:*lexenv* lexenv))
+ (sb!c::funcall-in-macrolet-lexenv
+ definitions
+ (lambda (&key funs)
+ (declare (ignore funs))
+ sb!c:*lexenv*)
+ :eval))))
(simple-eval-locally `(locally ,@body) lexenv))))
((symbol-macrolet)
(destructuring-bind (definitions &rest body) (rest exp)
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))
projects / sbcl.git / blobdiff