X-Git-Url: http://repo.macrolet.net/gitweb/?a=blobdiff_plain;f=src%2Fcode%2Ffull-eval.lisp;h=ca43691e37327a7da5c45134a0f260c9fbf01acb;hb=2fcf367a1f73ad306404d2d2cbe24e9995853881;hp=56208a054bdb9997c45e532ced98c9879b2dac1c;hpb=970dd272dc84f7420252eadb4829cc193f795716;p=sbcl.git diff --git a/src/code/full-eval.lisp b/src/code/full-eval.lisp index 56208a0..ca43691 100644 --- a/src/code/full-eval.lisp +++ b/src/code/full-eval.lisp @@ -104,7 +104,8 @@ nil nil nil nil nil (sb!c::lexenv-handled-conditions old-lexenv) (sb!c::lexenv-disabled-package-locks old-lexenv) - (sb!c::lexenv-policy old-lexenv)))) + (sb!c::lexenv-policy old-lexenv) + (sb!c::lexenv-user-data old-lexenv)))) (dolist (declaration declarations) (unless (consp declaration) (ip-error "malformed declaration specifier ~S in ~S" @@ -175,7 +176,8 @@ (sb!c::internal-make-lexenv nil nil nil nil nil nil nil nil nil - sb!c::*policy*))) + sb!c::*policy* + nil))) ;;; Augment ENV with a special or lexical variable binding (declaim (inline push-var)) @@ -185,13 +187,13 @@ ;;; Augment ENV with a local function binding (declaim (inline push-fun)) -(defun push-fun (name value env) +(defun push-fun (name value calling-env body-env) (when (fboundp name) - (let ((sb!c:*lexenv* (env-native-lexenv env))) + (let ((sb!c:*lexenv* (env-native-lexenv calling-env))) (program-assert-symbol-home-package-unlocked :eval name "binding ~A as a local function"))) - (push (cons name value) (env-funs env)) - (push (cons name :bogus) (sb!c::lexenv-funs (env-native-lexenv env)))) + (push (cons name value) (env-funs body-env)) + (push (cons name :bogus) (sb!c::lexenv-funs (env-native-lexenv body-env)))) (sb!int:def!method print-object ((env env) stream) (print-unreadable-object (env stream :type t :identity t))) @@ -236,7 +238,10 @@ (cond ((eq type :constant) ;; Horrible place for this, but it works. - (ip-error "Can't bind constant symbol ~S" symbol)) + (ip-error "Can't bind constant symbol: ~S" symbol)) + ((eq type :global) + ;; Ditto... + (ip-error "Can't bind a global variable: ~S" symbol)) ((eq type :special) t) ((member symbol declared-specials :test #'eq) t) @@ -279,7 +284,8 @@ (defun parse-arguments (arguments lambda-list) (multiple-value-bind (required optional rest-p rest keyword-p keyword allow-other-keys-p aux-p aux) - (sb!int:parse-lambda-list lambda-list) + (handler-bind ((style-warning #'muffle-warning)) + (sb!int:parse-lambda-list lambda-list)) (let* ((original-arguments arguments) (arguments-present (length arguments)) (required-length (length required)) @@ -516,9 +522,7 @@ (t (values (cdr binding) :variable))) (case (sb!int:info :variable :kind symbol) (:macro (values (macroexpand-1 symbol) :expansion)) - (:alien (let ((type (sb!int:info :variable :alien-info symbol))) - (values (sb!alien::%heap-alien type) - :variable))) + (:alien (values (sb!alien-internals:alien-value symbol) :variable)) (t (values (symbol-value symbol) :variable)))))) ;;; Retrieve the function/macro binding of the symbol NAME in @@ -538,10 +542,8 @@ ;;; Return true if EXP is a lambda form. (defun lambdap (exp) - (case (car exp) ((lambda - sb!int:named-lambda - sb!kernel:instance-lambda) - t))) + (case (car exp) + ((lambda sb!int:named-lambda) t))) ;;; Split off the declarations (and the docstring, if ;;; DOC-STRING-ALLOWED is true) from the actual forms of BODY. @@ -571,7 +573,7 @@ ;;; in the environment ENV. (defun eval-lambda (exp env) (case (car exp) - ((lambda sb!kernel:instance-lambda) + ((lambda) (multiple-value-bind (body documentation declarations) (parse-lambda-headers (cddr exp) :doc-string-allowed t) (make-interpreted-function :lambda-list (second exp) @@ -681,6 +683,8 @@ (push-fun (car function-def) ;; Evaluate the function definitions in ENV. (eval-local-function-def function-def env) + ;; Do package-lock checks in ENV. + env ;; But add the bindings to the child environment. new-env)) (eval-progn body new-env))))) @@ -697,6 +701,7 @@ (dolist (function-def local-functions) (push-fun (car function-def) (eval-local-function-def function-def env) + old-env env)) ;; And then add an environment for the body of the LABELS. A ;; separate environment from the one where we added the @@ -893,7 +898,8 @@ (do ((form body (cdr form))) ((null form) nil) (when (atom (car form)) - ;; FIXME: detect duplicate tags + (when (assoc (car form) tags) + (ip-error "The tag :A appears more than once in a tagbody.")) (push (cons (car form) (cdr form)) tags) (push (cons (car form) #'go-to-tag) (env-tags env))))) ;; And then evaluate the forms in the body, starting from the @@ -1178,32 +1184,16 @@ (defun eval-in-native-environment (form lexenv) (handler-bind ((sb!impl::eval-error - (lambda (condition) - (error 'interpreted-program-error - :condition (sb!int:encapsulated-condition condition) - :form form))) - (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))))) - (handler-case - (let ((env (make-env-from-native-environment lexenv))) - (%eval form env)) - (compiler-environment-too-complex-error (condition) - (declare (ignore condition)) - ;; FIXME: this could be a really annoying warning. It should - ;; have its own class. - (sb!int:style-warn - "~@" - form lexenv) - (sb!int:simple-eval-in-lexenv form lexenv))))) + (lambda (condition) + (error 'interpreted-program-error + :condition (sb!int:encapsulated-condition condition) + :form form)))) + (sb!c:with-compiler-error-resignalling + (handler-case + (let ((env (make-env-from-native-environment lexenv))) + (%eval form env)) + (compiler-environment-too-complex-error (condition) + (declare (ignore condition)) + (sb!int:style-warn 'sb!kernel:lexical-environment-too-complex + :form form :lexenv lexenv) + (sb!int:simple-eval-in-lexenv form lexenv))))))