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.
(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
(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)))))
;;; 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))
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))
(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))
\f
;;;; %PRIMITIVE
;;;;
(declare (ignore funs))
(process-toplevel-locally body
path
- compile-time-too))))
+ compile-time-too))
+ :compile))
((symbol-macrolet)
(funcall-in-symbol-macrolet-lexenv
magic
(process-toplevel-locally body
path
compile-time-too
- :vars vars)))))))
+ :vars vars))
+ :compile)))))
((locally)
(process-toplevel-locally (rest form) path compile-time-too))
((progn)
(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:
,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)
;;; 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"
projects / sbcl.git / commitdiff