X-Git-Url: http://repo.macrolet.net/gitweb/?a=blobdiff_plain;f=src%2Fcode%2Feval.lisp;h=9bd74e2563b5e5c1535389eb0cb6ede9b49bd3e4;hb=b2ad48f269cd6b9403820588d65eac526e4e32fd;hp=4c350e4be3b44de59ef77949bc3bc6605f518bba;hpb=c5df202d52732a0dea8dc3558954a729073b7970;p=sbcl.git diff --git a/src/code/eval.lisp b/src/code/eval.lisp index 4c350e4..9bd74e2 100644 --- a/src/code/eval.lisp +++ b/src/code/eval.lisp @@ -46,6 +46,33 @@ (eval-in-lexenv (first i) lexenv) (return (eval-in-lexenv (first i) lexenv))))) +(defun eval-locally (exp lexenv &key 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 @@ -67,9 +94,9 @@ (progn (signal c) nil) - ;; ... if we're not in the compiler, better signal a - ;; program error straight away. - (invoke-restart 'sb!c::signal-program-error))))) + ;; ... if we're not in the compiler, better signal the + ;; error straight away. + (invoke-restart 'sb!c::signal-error))))) (let ((exp (macroexpand original-exp lexenv))) (typecase exp (symbol @@ -101,7 +128,7 @@ (if (and (legal-fun-name-p name) (not (consp (let ((sb!c:*lexenv* lexenv)) (sb!c:lexenv-find name funs))))) - (fdefinition name) + (%coerce-name-to-fun name) (%eval original-exp lexenv)))) ((quote) (unless (= n-args 1) @@ -117,8 +144,8 @@ ((null (cddr args)) ;; We duplicate the call to SET so that the ;; correct value gets returned. - (set (first args) (eval (second args)))) - (set (first args) (eval (second args))))) + (set (first args) (eval-in-lexenv (second args) lexenv))) + (set (first args) (eval-in-lexenv (second args) lexenv)))) (let ((symbol (first name))) (case (info :variable :kind symbol) (:special) @@ -157,76 +184,36 @@ (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 ((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)))) + (destructuring-bind (definitions &rest body) (rest exp) + (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 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))))) @@ -258,6 +245,7 @@ (defun values (&rest values) #!+sb-doc "Return all arguments, in order, as values." + (declare (dynamic-extent values)) (values-list values)) (defun values-list (list)