X-Git-Url: http://repo.macrolet.net/gitweb/?a=blobdiff_plain;f=src%2Fpcl%2Fvector.lisp;h=c4555b41a5820f5ebbb65b7356f69f2a800b83de;hb=683874b497a99cd2c11b6c5d9b47e2785b1ede5f;hp=5a122ad2a5caa1daceeeda120a0cc3e9a4ff43c3;hpb=d5aafdd8ab6387e12bac187048ed322bc96fb79a;p=sbcl.git diff --git a/src/pcl/vector.lisp b/src/pcl/vector.lisp index 5a122ad..c4555b4 100644 --- a/src/pcl/vector.lisp +++ b/src/pcl/vector.lisp @@ -36,10 +36,10 @@ (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) @@ -160,18 +160,23 @@ (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*) @@ -415,15 +420,13 @@ ;; 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)))) @@ -520,7 +523,7 @@ ,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)) @@ -574,12 +577,14 @@ (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) @@ -727,7 +732,7 @@ `(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) @@ -874,15 +879,15 @@ (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) @@ -892,7 +897,8 @@ 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) @@ -906,7 +912,7 @@ ,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 @@ -914,11 +920,11 @@ '(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. @@ -946,20 +952,20 @@ (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 @@ -971,11 +977,11 @@ (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) @@ -1070,10 +1076,11 @@ (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))) @@ -1087,7 +1094,7 @@ (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))