From: Alexey Dejneka Date: Thu, 17 Jul 2003 12:00:35 +0000 (+0000) Subject: 0.8.1.37: X-Git-Url: http://repo.macrolet.net/gitweb/?a=commitdiff_plain;h=269554bcae55d7e502992ea20932f71790066483;p=sbcl.git 0.8.1.37: * Cleanup of MACROLET processing; ... fix bug 264: interpreted version of SYMBOL-MACROLET did not check for a bound SPECIAL declaration. --- diff --git a/BUGS b/BUGS index 6e31933..8163c56 100644 --- a/BUGS +++ b/BUGS @@ -1090,6 +1090,8 @@ WORKAROUND: does not signal an error. + (fixed in 0.8.1.37) + DEFUNCT CATEGORIES OF BUGS IR1-#: These labels were used for bugs related to the old IR1 interpreter. diff --git a/src/code/eval.lisp b/src/code/eval.lisp index 4c350e4..3f29e59 100644 --- a/src/code/eval.lisp +++ b/src/code/eval.lisp @@ -46,6 +46,32 @@ (eval-in-lexenv (first i) lexenv) (return (eval-in-lexenv (first i) lexenv))))) +(defun eval-locally (exp lexenv &optional vars) + (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 + vars + nil + (sb!c::make-continuation) + lexenv)))) + (eval-progn-body body lexenv)))) + (defun eval (original-exp) #!+sb-doc "Evaluate the argument in a null lexical environment, returning the @@ -157,76 +183,37 @@ (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 ((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)))) + (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)))) (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))))) diff --git a/src/compiler/ir1-translators.lisp b/src/compiler/ir1-translators.lisp index 23dfa9c..fd4aa84 100644 --- a/src/compiler/ir1-translators.lisp +++ b/src/compiler/ir1-translators.lisp @@ -261,40 +261,38 @@ ;;; shared by the special-case top level MACROLET processing code, and ;;; further split so that the special-case MACROLET processing code in ;;; EVAL can likewise make use of it. -(defmacro macrolet-definitionize-fun (context lexenv) - (flet ((make-error-form (control &rest args) +(defun macrolet-definitionize-fun (context lexenv) + (flet ((fail (control &rest args) (ecase context - (:compile `(compiler-error ,control ,@args)) - (:eval `(error 'simple-program-error - :format-control ,control - :format-arguments (list ,@args)))))) - `(lambda (definition) + (:compile (apply #'compiler-error control args)) + (:eval (error 'simple-program-error + :format-control control + :format-arguments args))))) + (lambda (definition) (unless (list-of-length-at-least-p definition 2) - ,(make-error-form - "The list ~S is too short to be a legal local macro definition." - 'definition)) + (fail "The list ~S is too short to be a legal local macro definition." + definition)) (destructuring-bind (name arglist &body body) definition - (unless (symbolp name) - ,(make-error-form "The local macro name ~S is not a symbol." 'name)) - (unless (listp arglist) - ,(make-error-form - "The local macro argument list ~S is not a list." - 'arglist)) - (with-unique-names (whole environment) - (multiple-value-bind (body local-decls) - (parse-defmacro arglist whole body name 'macrolet - :environment environment) - `(,name macro . - ,(compile-in-lexenv - nil - `(lambda (,whole ,environment) - ,@local-decls - ,body) - ,lexenv)))))))) - -(defun funcall-in-macrolet-lexenv (definitions fun) + (unless (symbolp name) + (fail "The local macro name ~S is not a symbol." name)) + (unless (listp arglist) + (fail "The local macro argument list ~S is not a list." + arglist)) + (with-unique-names (whole environment) + (multiple-value-bind (body local-decls) + (parse-defmacro arglist whole body name 'macrolet + :environment environment) + `(,name macro . + ,(compile-in-lexenv + nil + `(lambda (,whole ,environment) + ,@local-decls + ,body) + lexenv)))))))) + +(defun funcall-in-macrolet-lexenv (definitions fun context) (%funcall-in-foomacrolet-lexenv - (macrolet-definitionize-fun :compile (make-restricted-lexenv *lexenv*)) + (macrolet-definitionize-fun context (make-restricted-lexenv *lexenv*)) :funs definitions fun)) @@ -309,33 +307,31 @@ definitions (lambda (&key funs) (declare (ignore funs)) - (ir1-translate-locally body start cont)))) + (ir1-translate-locally body start cont)) + :compile)) -(defmacro symbol-macrolet-definitionize-fun (context) - (flet ((make-error-form (control &rest args) +(defun symbol-macrolet-definitionize-fun (context) + (flet ((fail (control &rest args) (ecase context - (:compile `(compiler-error ,control ,@args)) - (:eval `(error 'simple-program-error - :format-control ,control - :format-arguments (list ,@args)))))) - `(lambda (definition) + (:compile (apply #'compiler-error control args)) + (:eval (error 'simple-program-error + :format-control control + :format-arguments args))))) + (lambda (definition) (unless (proper-list-of-length-p definition 2) - ,(make-error-form "malformed symbol/expansion pair: ~S" 'definition)) - (destructuring-bind (name expansion) definition - (unless (symbolp name) - ,(make-error-form - "The local symbol macro name ~S is not a symbol." - 'name)) - (let ((kind (info :variable :kind name))) - (when (member kind '(:special :constant)) - ,(make-error-form - "Attempt to bind a ~(~A~) variable with SYMBOL-MACROLET: ~S" - 'kind 'name))) - `(,name . (MACRO . ,expansion))))))1 - -(defun funcall-in-symbol-macrolet-lexenv (definitions fun) + (fail "malformed symbol/expansion pair: ~S" definition)) + (destructuring-bind (name expansion) definition + (unless (symbolp name) + (fail "The local symbol macro name ~S is not a symbol." name)) + (let ((kind (info :variable :kind name))) + (when (member kind '(:special :constant)) + (fail "Attempt to bind a ~(~A~) variable with SYMBOL-MACROLET: ~S" + kind name))) + `(,name . (MACRO . ,expansion)))))) + +(defun funcall-in-symbol-macrolet-lexenv (definitions fun context) (%funcall-in-foomacrolet-lexenv - (symbol-macrolet-definitionize-fun :compile) + (symbol-macrolet-definitionize-fun context) :vars definitions fun)) @@ -348,7 +344,8 @@ (funcall-in-symbol-macrolet-lexenv macrobindings (lambda (&key vars) - (ir1-translate-locally body start cont :vars vars)))) + (ir1-translate-locally body start cont :vars vars)) + :compile)) ;;;; %PRIMITIVE ;;;; diff --git a/src/compiler/main.lisp b/src/compiler/main.lisp index 4e0ba72..79e0c45 100644 --- a/src/compiler/main.lisp +++ b/src/compiler/main.lisp @@ -1172,7 +1172,8 @@ (declare (ignore funs)) (process-toplevel-locally body path - compile-time-too)))) + compile-time-too)) + :compile)) ((symbol-macrolet) (funcall-in-symbol-macrolet-lexenv magic @@ -1180,7 +1181,8 @@ (process-toplevel-locally body path compile-time-too - :vars vars))))))) + :vars vars)) + :compile))))) ((locally) (process-toplevel-locally (rest form) path compile-time-too)) ((progn) diff --git a/tests/eval.impure.lisp b/tests/eval.impure.lisp index 8b0cf57..3f7aa88 100644 --- a/tests/eval.impure.lisp +++ b/tests/eval.impure.lisp @@ -18,6 +18,9 @@ (cl:in-package :cl-user) +(load "assertoid.lisp") +(use-package "ASSERTOID") + ;;; Until sbcl-0.7.9.x, EVAL was not correctly treating LOCALLY, ;;; MACROLET and SYMBOL-MACROLET, which should preserve top-levelness ;;; of their body forms: @@ -105,5 +108,13 @@ ,var)) '(1 2)))) +;;; Bug 264: SYMBOL-MACROLET did not check for a bound SPECIAL +;;; declaration +(assert (raises-error? (progv '(foo) '(1) + (eval '(symbol-macrolet ((foo 3)) + (declare (special foo)) + foo))) + error)) + ;;; success (sb-ext:quit :unix-status 104) diff --git a/version.lisp-expr b/version.lisp-expr index 94bd4f2..d1a92f9 100644 --- a/version.lisp-expr +++ b/version.lisp-expr @@ -17,4 +17,4 @@ ;;; checkins which aren't released. (And occasionally for internal ;;; versions, especially for internal versions off the main CVS ;;; branch, it gets hairier, e.g. "0.pre7.14.flaky4.13".) -"0.8.1.36" +"0.8.1.37"