(defun pv-cache-limit-fn (nlines)
(default-limit-fn nlines))
-(defstruct (pv-table
- (:predicate pv-tablep)
- (:constructor make-pv-table-internal
- (slot-name-lists call-list)))
+(defstruct (pv-table (:predicate pv-tablep)
+ (:constructor make-pv-table-internal
+ (slot-name-lists call-list))
+ (:copier nil))
(cache nil :type (or cache null))
(pv-size 0 :type fixnum)
(slot-name-lists nil :type list)
(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))))
(setq class nil))
- (when (and class-name (not (eq class-name 't)))
+ (when (and class-name (not (eq class-name t)))
(when (or (null type)
(not (and class
(memq *the-class-structure-object*
,parameter)
,new-value))
(:boundp
- 'T)))
+ t)))
(let* ((parameter-entry (assq parameter slots))
(slot-entry (assq slot-name (cdr parameter-entry)))
(position (posq parameter-entry slots))
(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))))
- (when (and class-name (not (eq class-name 't)))
+ (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)
(let ((form (eval form)))
(let ((,index (pvref ,pv ,pv-offset)))
(setq ,value (typecase ,index
,@(when (or (null type) (eq type ':instance))
- `((fixnum (%instance-ref ,slots ,index))))
+ `((fixnum (clos-slots-ref ,slots ,index))))
,@(when (or (null type) (eq type ':class))
`((cons (cdr ,index))))
(t +slot-unbound+)))
(let ((,index (pvref ,pv ,pv-offset)))
(typecase ,index
,@(when (or (null type) (eq type ':instance))
- `((fixnum (setf (%instance-ref ,slots ,index) ,new-value))))
+ `((fixnum (setf (clos-slots-ref ,slots ,index)
+ ,new-value))))
,@(when (or (null type) (eq type ':class))
`((cons (setf (cdr ,index) ,new-value))))
(t ,default)))))))
`(instance-write-internal .pv. ,(slot-vector-symbol position)
,pv-offset ,new-value
(,(if (consp gf-name)
- (get-setf-function-name gf-name)
+ (get-setf-fun-name gf-name)
gf-name)
(instance-accessor-parameter ,parameter)
,new-value)
(let ((,index (pvref ,pv ,pv-offset)))
(typecase ,index
,@(when (or (null type) (eq type ':instance))
- `((fixnum (not (eq (%instance-ref ,slots ,index)
- +slot-unbound+)))))
+ `((fixnum (not (and ,slots
+ (eq (clos-slots-ref ,slots ,index)
+ +slot-unbound+))))))
,@(when (or (null type) (eq type ':class))
`((cons (not (eq (cdr ,index) +slot-unbound+)))))
(t ,default)))))))
(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)
(nm (car next-methods))
(nms (cdr next-methods))
(nmc (when nm
- (make-method-call :function (if (std-instance-p nm)
- (method-function nm)
- nm)
- :call-method-args (list nms)))))
+ (make-method-call
+ :function (if (std-instance-p nm)
+ (method-function nm)
+ nm)
+ :call-method-args (list nms)))))
(if restp
(let* ((rest (nthcdr nreq method-args))
(args (ldiff method-args rest)))
(intern (subseq str 5) *pcl-package*)
(car fname)))))
,@(cdr fname))))
- (set-function-name method-function name))
+ (set-fun-name method-function name))
(setf (method-function-get method-function :fast-function) fmf)
method-function))
(w-t pv-wrappers))
(dolist (arg args)
(setq w (wrapper-of arg))
- (unless (eq 't (wrapper-state w)) ; FIXME: should be INVALID-WRAPPER-P
+ (unless (eq t (wrapper-state w)) ; FIXME: should be INVALID-WRAPPER-P
(setq w (check-wrapper-validity arg)))
(setf (car w-t) w))
(setq w-t (cdr w-t))
projects / sbcl.git / blobdiff