+ ;; FIXME: DESTRUCTURING-BIND returns ARG-COUNT-ERROR
+ ;; instead of PROGRAM-ERROR when there's something wrong
+ ;; with the syntax here (e.g. missing SITUATIONS). This
+ ;; could be fixed by hand-crafting clauses to catch and
+ ;; report each possibility, but it would probably be
+ ;; cleaner to write a new macro
+ ;; DESTRUCTURING-BIND-PROGRAM-SYNTAX which does
+ ;; DESTRUCTURING-BIND and promotes any mismatch to
+ ;; PROGRAM-ERROR, then to use it here and in (probably
+ ;; dozens of) other places where the same problem arises.
+ (destructuring-bind (eval-when situations &rest body) exp
+ (declare (ignore eval-when))
+ (multiple-value-bind (ct lt e)
+ (sb!c:parse-eval-when-situations situations)
+ ;; CLHS 3.8 - Special Operator EVAL-WHEN: The use of
+ ;; the situation :EXECUTE (or EVAL) controls whether
+ ;; evaluation occurs for other EVAL-WHEN forms; that
+ ;; is, those that are not top level forms, or those in
+ ;; code processed by EVAL or COMPILE. If the :EXECUTE
+ ;; situation is specified in such a form, then the
+ ;; body forms are processed as an implicit PROGN;
+ ;; otherwise, the EVAL-WHEN form returns NIL.
+ (declare (ignore ct lt))
+ (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))))
+ ((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))))
+ ((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))))