(let* ((info (layout-info
(or (info :type :compiler-layout (sb!xc:class-name class))
(class-layout class))))
- (accessor (if (listp name) (cadr name) name))
- (slot (find accessor (dd-slots info) :key #'sb!kernel:dsd-accessor))
+ (accessor-name (if (listp name) (cadr name) name))
+ (slot (find accessor-name (dd-slots info)
+ :key #'sb!kernel:dsd-accessor-name))
(type (dd-name info))
(slot-type (dsd-type slot)))
(unless slot
;;; This handles EVAL-WHEN in non-top-level forms. (EVAL-WHENs in
;;; top-level forms are picked off and handled by PROCESS-TOP-LEVEL-FORM,
-;;; so they're never seen at this level.)
+;;; so that they're never seen at this level.)
;;;
;;; ANSI "3.2.3.1 Processing of Top Level Forms" says that processing
;;; of non-top-level EVAL-WHENs is very simple:
:LOAD-TOPLEVEL, or :EXECUTE, or (deprecated) COMPILE, LOAD, or EVAL)."
(multiple-value-bind (ct lt e) (parse-eval-when-situations situations)
(declare (ignore ct lt))
- (when e
- (ir1-convert-progn-body start cont forms)))
+ (ir1-convert-progn-body start cont (and e forms)))
(values))
+;;; common logic for MACROLET and SYMBOL-MACROLET
+;;;
+;;; Call DEFINITIONIZE-FUN on each element of DEFINITIONS to find its
+;;; in-lexenv representation, stuff the results into *LEXENV*, and
+;;; call FUN (with no arguments).
+(defun %funcall-in-foomacrolet-lexenv (definitionize-fun
+ definitionize-keyword
+ definitions
+ fun)
+ (declare (type function definitionize-fun fun))
+ (declare (type (member :variables :functions) definitionize-keyword))
+ (declare (type list definitions))
+ (unless (= (length definitions)
+ (length (remove-duplicates definitions :key #'first)))
+ (compiler-style-warning "duplicate definitions in ~S" definitions))
+ (let* ((processed-definitions (mapcar definitionize-fun definitions))
+ (*lexenv* (make-lexenv definitionize-keyword processed-definitions)))
+ (funcall fun)))
+
;;; Tweak *LEXENV* to include the DEFINITIONS from a MACROLET, then
;;; call FUN (with no arguments).
;;;
;;; This is split off from the IR1 convert method so that it can be
;;; shared by the special-case top-level MACROLET processing code.
(defun funcall-in-macrolet-lexenv (definitions fun)
- (declare (type list definitions) (type function fun))
- (let* ((whole (gensym "WHOLE"))
- (environment (gensym "ENVIRONMENT"))
- (processed-definitions
- (mapcar (lambda (definition)
- (unless (list-of-length-at-least-p definition 2)
- (compiler-error
- "The list ~S is too short to be a legal ~
- local macro definition."
- definition))
- (destructuring-bind (name arglist &body body) definition
- (unless (symbolp name)
- (compiler-error
- "The local macro name ~S is not a symbol." name))
- (multiple-value-bind (body local-decls)
- (parse-defmacro arglist whole body name 'macrolet
- :environment environment)
- `(,name macro .
- ,(compile nil
- `(lambda (,whole ,environment)
- ,@local-decls
- (block ,name ,body)))))))
- definitions))
- (*lexenv* (make-lexenv :functions processed-definitions)))
- (unless (= (length definitions)
- (length (remove-duplicates definitions :key #'first)))
- (compiler-style-warning
- "duplicate macro names in MACROLET ~S" definitions))
- (funcall fun))
- (values))
+ (%funcall-in-foomacrolet-lexenv
+ (lambda (definition)
+ (unless (list-of-length-at-least-p definition 2)
+ (compiler-error
+ "The list ~S is too short to be a legal local macro definition."
+ definition))
+ (destructuring-bind (name arglist &body body) definition
+ (unless (symbolp name)
+ (compiler-error "The local macro name ~S is not a symbol." name))
+ (let ((whole (gensym "WHOLE"))
+ (environment (gensym "ENVIRONMENT")))
+ (multiple-value-bind (body local-decls)
+ (parse-defmacro arglist whole body name 'macrolet
+ :environment environment)
+ `(,name macro .
+ ,(compile nil
+ `(lambda (,whole ,environment)
+ ,@local-decls
+ (block ,name ,body))))))))
+ :functions
+ definitions
+ fun))
(def-ir1-translator macrolet ((definitions &rest body) start cont)
#!+sb-doc
(lambda ()
(ir1-translate-locally body start cont))))
-;;; Tweak *LEXENV* to include the MACROBINDINGS from a SYMBOL-MACROLET,
-;;; then call FUN (with no arguments).
-;;;
-;;; This is split off from the IR1 convert method so that it can be
-;;; shared by the special-case top-level SYMBOL-MACROLET processing code.
-(defun funcall-in-symbol-macrolet-lexenv (macrobindings fun)
- (declare (type list macrobindings) (type function fun))
- (let ((processed-macrobindings
- (mapcar (lambda (macrobinding)
- (unless (proper-list-of-length-p macrobinding 2)
- (compiler-error "malformed symbol/expansion pair: ~S"
- macrobinding))
- (destructuring-bind (name expansion) macrobinding
- (unless (symbolp name)
- (compiler-error
- "The local symbol macro name ~S is not a symbol."
- name))
- `(,name . (MACRO . ,expansion))))
- macrobindings)))
- (unless (= (length macrobindings)
- (length (remove-duplicates macrobindings :key #'first)))
- (compiler-style-warning
- "duplicate symbol macro names in SYMBOL-MACROLET ~S" macrobindings))
- (let ((*lexenv* (make-lexenv :variables processed-macrobindings)))
- (funcall fun)))
- (values))
+(defun funcall-in-symbol-macrolet-lexenv (definitions fun)
+ (%funcall-in-foomacrolet-lexenv
+ (lambda (definition)
+ (unless (proper-list-of-length-p definition 2)
+ (compiler-error "malformed symbol/expansion pair: ~S" definition))
+ (destructuring-bind (name expansion) definition
+ (unless (symbolp name)
+ (compiler-error
+ "The local symbol macro name ~S is not a symbol."
+ name))
+ `(,name . (MACRO . ,expansion))))
+ :variables
+ definitions
+ fun))
(def-ir1-translator symbol-macrolet ((macrobindings &body body) start cont)
#!+sb-doc
;;; BACKEND-TEMPLATE-NAMES to BACKEND-VOPS, and rename %PRIMITIVE to
;;; VOP or %VOP.. -- WHN 2001-06-11
;;; FIXME: Look at doing this ^, it doesn't look too hard actually.
-(def-ir1-translator %primitive ((&whole form name &rest args) start cont)
-
+(def-ir1-translator %primitive ((name &rest args) start cont)
(unless (symbolp name)
(compiler-error "The primitive name ~S is not a symbol." name))
(let* ((info (eval info)))
(%%compiler-defstruct info)
(dolist (slot (dd-slots info))
- (let ((fun (dsd-accessor slot)))
- (remhash fun *free-functions*)
+ (let ((accessor-name (dsd-accessor-name slot)))
+ (remhash accessor-name *free-functions*)
(unless (dsd-read-only slot)
- (remhash `(setf ,fun) *free-functions*))))
- (remhash (dd-predicate info) *free-functions*)
+ (remhash `(setf ,accessor-name) *free-functions*))))
+ (remhash (dd-predicate-name info) *free-functions*)
(remhash (dd-copier info) *free-functions*)
(ir1-convert start cont `(%%compiler-defstruct ',info))))
projects / sbcl.git / blobdiff