X-Git-Url: http://repo.macrolet.net/gitweb/?a=blobdiff_plain;f=src%2Fpcl%2Fvector.lisp;h=c4555b41a5820f5ebbb65b7356f69f2a800b83de;hb=683874b497a99cd2c11b6c5d9b47e2785b1ede5f;hp=dbf5fa84b6b3190bddd7efa5bc5ab8ff4053da74;hpb=99ad0a384664dc98af26245a33f11619ec0854ad;p=sbcl.git diff --git a/src/pcl/vector.lisp b/src/pcl/vector.lisp index dbf5fa8..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,20 +420,18 @@ ;; 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* @@ -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,13 +577,15 @@ (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))) @@ -663,7 +668,7 @@ (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+))) @@ -697,7 +702,8 @@ (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))))))) @@ -726,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) @@ -743,8 +749,9 @@ (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))))))) @@ -872,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) @@ -890,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) @@ -904,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 @@ -912,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. @@ -944,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 @@ -969,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) @@ -1068,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))) @@ -1085,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)) @@ -1108,7 +1117,7 @@ (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))