(unless (listp wrappers) (setq wrappers (list wrappers)))
(let* ((not-simple-p-cell (list nil))
(elements
- (gathering1 (collecting)
- (iterate ((slot-names (list-elements slot-name-lists)))
+ (let ((elements nil))
+ (dolist (slot-names slot-name-lists)
(when slot-names
(let* ((wrapper (pop wrappers))
(std-p (typep wrapper 'wrapper))
(class (wrapper-class* wrapper))
(class-slots (and std-p (wrapper-class-slots wrapper))))
(dolist (slot-name (cdr slot-names))
- (gather1
- (when std-p
- (compute-pv-slot slot-name wrapper class
- class-slots not-simple-p-cell))))))))))
+ ;; Original PCL code had this idiom. why not:
+ ;;
+ ;; (WHEN STD-P
+ ;; (PUSH ...)) ?
+ (push (when std-p
+ (compute-pv-slot slot-name wrapper class
+ class-slots not-simple-p-cell))
+ elements)))))
+ (nreverse elements))))
(if (car not-simple-p-cell)
(make-permutation-vector (cons t elements))
(or (gethash elements *pvs*)
;; against 'THE scattered through the PCL code.
(setq var (caddr var)))
(when (symbolp var)
- (let* ((rebound? (caddr (variable-declaration '%variable-rebinding
- var
- env)))
+ (let* ((rebound? (caddr (var-declaration '%variable-rebinding var env)))
(parameter-or-nil (car (memq (or rebound? var)
required-parameters))))
(when parameter-or-nil
- (let* ((class-name (caddr (variable-declaration '%class
- parameter-or-nil
- env)))
+ (let* ((class-name (caddr (var-declaration '%class
+ parameter-or-nil
+ env)))
(class (find-class class-name nil)))
(when (or (not (eq *boot-state* 'complete))
(and class (not (class-finalized-p class))))
(eq (car form) 'the))
(setq form (caddr form)))
(or (and (symbolp form)
- (let* ((rebound? (caddr (variable-declaration '%variable-rebinding
- form env)))
+ (let* ((rebound? (caddr (var-declaration '%variable-rebinding
+ form
+ env)))
(parameter-or-nil (car (assq (or rebound? form) slots))))
(when parameter-or-nil
- (let* ((class-name (caddr (variable-declaration
- 'class parameter-or-nil env))))
+ (let* ((class-name (caddr (var-declaration 'class
+ parameter-or-nil
+ env))))
(when (and class-name (not (eq class-name t)))
(position parameter-or-nil slots :key #'car))))))
(if (constantp form)
(defmacro pv-binding ((required-parameters slot-name-lists pv-table-symbol)
&body body)
- (with-gathering ((slot-vars (collecting))
- (pv-parameters (collecting)))
- (iterate ((slots (list-elements slot-name-lists))
- (required-parameter (list-elements required-parameters))
- (i (interval :from 0)))
- (when slots
- (gather required-parameter pv-parameters)
- (gather (slot-vector-symbol i) slot-vars)))
- `(pv-binding1 (.pv. .calls. ,pv-table-symbol ,pv-parameters ,slot-vars)
+ (let (slot-vars pv-parameters)
+ (loop for slots in slot-name-lists
+ for required-parameter in required-parameters
+ for i from 0
+ do (when slots
+ (push required-parameter pv-parameters)
+ (push (slot-vector-symbol i) slot-vars)))
+ `(pv-binding1 (.pv. .calls. ,pv-table-symbol
+ ,(nreverse pv-parameters) ,(nreverse slot-vars))
,@body)))
(defmacro pv-binding1 ((pv calls pv-table-symbol pv-parameters slot-vars)
slot-vars pv-parameters))
,@body)))
-;;; This gets used only when the default MAKE-METHOD-LAMBDA is overridden.
+;;; This gets used only when the default MAKE-METHOD-LAMBDA is
+;;; overridden.
(defmacro pv-env ((pv calls pv-table-symbol pv-parameters)
&rest forms)
`(let* ((.pv-table. ,pv-table-symbol)
,pv ,calls
,@forms))
-(defvar *non-variable-declarations*
+(defvar *non-var-declarations*
;; FIXME: VALUES was in this list, conditionalized with #+CMU, but I
;; don't *think* CMU CL had, or SBCL has, VALUES declarations. If
;; SBCL doesn't have 'em, VALUES should probably be removed from
'(values %method-name %method-lambda-list
optimize ftype inline notinline))
-(defvar *variable-declarations-with-argument*
+(defvar *var-declarations-with-argument*
'(%class
type))
-(defvar *variable-declarations-without-argument*
+(defvar *var-declarations-without-argument*
'(ignore
ignorable special dynamic-extent
;; FIXME: Possibly this entire list and variable could go away.
(dolist (form (cdr decl))
(when (consp form)
(let ((declaration-name (car form)))
- (if (member declaration-name *non-variable-declarations*)
+ (if (member declaration-name *non-var-declarations*)
(push `(declare ,form) outer-decls)
(let ((arg-p
(member declaration-name
- *variable-declarations-with-argument*))
+ *var-declarations-with-argument*))
(non-arg-p
(member declaration-name
- *variable-declarations-without-argument*))
+ *var-declarations-without-argument*))
(dname (list (pop form)))
(inners nil) (outers nil))
(unless (or arg-p non-arg-p)
;; FIXME: This warning, and perhaps the
- ;; various *VARIABLE-DECLARATIONS-FOO* and/or
- ;; *NON-VARIABLE-DECLARATIONS* variables,
+ ;; various *VAR-DECLARATIONS-FOO* and/or
+ ;; *NON-VAR-DECLARATIONS* variables,
;; could probably go away now that we're not
;; trying to be portable between different
;; CLTL1 hosts the way PCL was. (Note that to
(Assuming it is a variable declaration without argument)."
declaration-name 'split-declarations
declaration-name
- '*non-variable-declarations*
- '*variable-declarations-with-argument*
- '*variable-declarations-without-argument*)
+ '*non-var-declarations*
+ '*var-declarations-with-argument*
+ '*var-declarations-without-argument*)
(push declaration-name
- *variable-declarations-without-argument*))
+ *var-declarations-without-argument*))
(when arg-p
(setq dname (append dname (list (pop form)))))
(dolist (var form)