X-Git-Url: http://repo.macrolet.net/gitweb/?a=blobdiff_plain;f=src%2Fpcl%2Fvector.lisp;h=7008ec1bb13c0c0dbc256a8f5831171adae23bed;hb=f6a2be77637d025bfded9430f02863c28f74f77a;hp=212a182964ff386a1cf360601eedf1ae1c03f29b;hpb=475c832b081651e66ad9446d4852c62086f5e740;p=sbcl.git diff --git a/src/pcl/vector.lisp b/src/pcl/vector.lisp index 212a182..7008ec1 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*) @@ -182,8 +187,8 @@ (declare (ignore call-list wrappers)) #|| (map 'vector - #'(lambda (call) - (compute-emf-from-wrappers call wrappers)) + (lambda (call) + (compute-emf-from-wrappers call wrappers)) call-list) ||# '#()) @@ -194,18 +199,18 @@ (destructuring-bind (gf-name nreq restp arg-info) call (if (eq gf-name 'make-instance) (error "should not get here") ; there is another mechanism for this. - #'(lambda (&rest args) - (if (not (eq *boot-state* 'complete)) - (apply (gdefinition gf-name) args) - (let* ((gf (gdefinition gf-name)) - (arg-info (arg-info-reader gf)) - (classes '?) - (types '?) - (emf (cache-miss-values-internal gf arg-info - wrappers classes types - 'caching))) - (update-all-pv-tables call wrappers emf) - (invoke-emf emf args)))))))) + (lambda (&rest args) + (if (not (eq *boot-state* 'complete)) + (apply (gdefinition gf-name) args) + (let* ((gf (gdefinition gf-name)) + (arg-info (arg-info-reader gf)) + (classes '?) + (types '?) + (emf (cache-miss-values-internal gf arg-info + wrappers classes types + 'caching))) + (update-all-pv-tables call wrappers emf) + (invoke-emf emf args)))))))) ||# (defun make-permutation-vector (indexes) @@ -266,20 +271,20 @@ (std-p (typep cwrapper 'wrapper)) (class-slots (and std-p (wrapper-class-slots cwrapper))) (class-slot-p-cell (list nil)) - (new-values (mapcar #'(lambda (slot-name) - (cons slot-name - (when std-p - (compute-pv-slot - slot-name cwrapper class - class-slots class-slot-p-cell)))) + (new-values (mapcar (lambda (slot-name) + (cons slot-name + (when std-p + (compute-pv-slot + slot-name cwrapper class + class-slots class-slot-p-cell)))) slot-names)) (pv-tables nil)) (dolist (slot-name slot-names) (map-pv-table-references-of slot-name - #'(lambda (pv-table pv-offset-list) - (declare (ignore pv-offset-list)) - (pushnew pv-table pv-tables)))) + (lambda (pv-table pv-offset-list) + (declare (ignore pv-offset-list)) + (pushnew pv-table pv-tables)))) (dolist (pv-table pv-tables) (let* ((cache (pv-table-cache pv-table)) (slot-name-lists (pv-table-slot-name-lists pv-table)) @@ -294,10 +299,10 @@ (incf map-index)) (incf param-index))) (when cache - (map-cache #'(lambda (wrappers pv-cell) - (setf (car pv-cell) - (update-slots-in-pv wrappers (car pv-cell) - cwrapper pv-size pv-map))) + (map-cache (lambda (wrappers pv-cell) + (setf (car pv-cell) + (update-slots-in-pv wrappers (car pv-cell) + cwrapper pv-size pv-map))) cache)))))) (defun update-slots-in-pv (wrappers pv cwrapper pv-size pv-map) @@ -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))) @@ -596,8 +601,8 @@ (non-required-args (nthcdr nreq args)) (required-args (ldiff args non-required-args)) (call-spec (list (car gf-call-form) nreq restp - (mapcar #'(lambda (form) - (optimize-gf-call-internal form slots env)) + (mapcar (lambda (form) + (optimize-gf-call-internal form slots env)) (if all-args-p args required-args)))) @@ -655,16 +660,16 @@ (defmacro instance-read-internal (pv slots pv-offset default &optional type) (unless (member type '(nil :instance :class :default)) (error "illegal type argument to ~S: ~S" 'instance-read-internal type)) - (if (eq type ':default) + (if (eq type :default) default (let* ((index (gensym)) (value index)) `(locally (declare #.*optimize-speed*) (let ((,index (pvref ,pv ,pv-offset))) (setq ,value (typecase ,index - ,@(when (or (null type) (eq type ':instance)) - `((fixnum (instance-ref ,slots ,index)))) - ,@(when (or (null type) (eq type ':class)) + ,@(when (or (null type) (eq type :instance)) + `((fixnum (clos-slots-ref ,slots ,index)))) + ,@(when (or (null type) (eq type :class)) `((cons (cdr ,index)))) (t +slot-unbound+))) (if (eq ,value +slot-unbound+) @@ -677,7 +682,7 @@ `(instance-read-internal .pv. ,(slot-vector-symbol position) ,pv-offset (accessor-slot-value ,parameter ,slot-name) ,(if (generate-fast-class-slot-access-p class slot-name) - ':class ':instance)))) + :class :instance)))) (defmacro instance-reader (pv-offset parameter position gf-name class) (declare (ignore class)) @@ -690,16 +695,16 @@ &optional type) (unless (member type '(nil :instance :class :default)) (error "illegal type argument to ~S: ~S" 'instance-write-internal type)) - (if (eq type ':default) + (if (eq type :default) default (let* ((index (gensym))) `(locally (declare #.*optimize-speed*) (let ((,index (pvref ,pv ,pv-offset))) (typecase ,index - ,@(when (or (null type) (eq type ':instance)) - `((fixnum (setf (instance-ref ,slots ,index) - ,new-value)))) - ,@(when (or (null type) (eq type ':class)) + ,@(when (or (null type) (eq type :instance)) + `((fixnum (setf (clos-slots-ref ,slots ,index) + ,new-value)))) + ,@(when (or (null type) (eq type :class)) `((cons (setf (cdr ,index) ,new-value)))) (t ,default))))))) @@ -715,7 +720,7 @@ ,pv-offset ,new-value (accessor-set-slot-value ,parameter ,slot-name ,new-value) ,(if (generate-fast-class-slot-access-p class slot-name) - ':class ':instance)))) + :class :instance)))) (defmacro instance-writer (pv-offset parameter @@ -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) @@ -737,17 +742,17 @@ &optional type) (unless (member type '(nil :instance :class :default)) (error "illegal type argument to ~S: ~S" 'instance-boundp-internal type)) - (if (eq type ':default) + (if (eq type :default) default (let* ((index (gensym))) `(locally (declare #.*optimize-speed*) (let ((,index (pvref ,pv ,pv-offset))) (typecase ,index - ,@(when (or (null type) (eq type ':instance)) + ,@(when (or (null type) (eq type :instance)) `((fixnum (not (and ,slots - (eq (instance-ref ,slots ,index) + (eq (clos-slots-ref ,slots ,index) +slot-unbound+)))))) - ,@(when (or (null type) (eq type ':class)) + ,@(when (or (null type) (eq type :class)) `((cons (not (eq (cdr ,index) +slot-unbound+))))) (t ,default))))))) @@ -757,7 +762,7 @@ `(instance-boundp-internal .pv. ,(slot-vector-symbol position) ,pv-offset (accessor-slot-boundp ,parameter ,slot-name) ,(if (generate-fast-class-slot-access-p class slot-name) - ':class ':instance)))) + :class :instance)))) ;;; This magic function has quite a job to do indeed. ;;; @@ -778,8 +783,8 @@ (defun slot-name-lists-from-slots (slots calls) (multiple-value-bind (slots calls) (mutate-slots-and-calls slots calls) (let* ((slot-name-lists - (mapcar #'(lambda (parameter-entry) - (cons nil (mapcar #'car (cdr parameter-entry)))) + (mapcar (lambda (parameter-entry) + (cons nil (mapcar #'car (cdr parameter-entry)))) slots)) (call-list (mapcar #'car calls))) @@ -787,22 +792,22 @@ (dolist (arg (cdr call)) (when (integerp arg) (setf (car (nth arg slot-name-lists)) t)))) - (setq slot-name-lists (mapcar #'(lambda (r+snl) - (when (or (car r+snl) (cdr r+snl)) - r+snl)) + (setq slot-name-lists (mapcar (lambda (r+snl) + (when (or (car r+snl) (cdr r+snl)) + r+snl)) slot-name-lists)) (let ((cvt (apply #'vector (let ((i -1)) - (mapcar #'(lambda (r+snl) - (when r+snl (incf i))) + (mapcar (lambda (r+snl) + (when r+snl (incf i))) slot-name-lists))))) - (setq call-list (mapcar #'(lambda (call) - (cons (car call) - (mapcar #'(lambda (arg) - (if (integerp arg) - (svref cvt arg) - arg)) - (cdr call)))) + (setq call-list (mapcar (lambda (call) + (cons (car call) + (mapcar (lambda (arg) + (if (integerp arg) + (svref cvt arg) + arg)) + (cdr call)))) call-list))) (values slot-name-lists call-list)))) @@ -874,25 +879,26 @@ (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) &body body) `(pv-env (,pv ,calls ,pv-table-symbol ,pv-parameters) - (let (,@(mapcar #'(lambda (slot-var p) `(,slot-var (get-slots-or-nil ,p))) - slot-vars pv-parameters)) + (let (,@(mapcar (lambda (slot-var p) `(,slot-var (get-slots-or-nil ,p))) + 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) @@ -1016,7 +1022,7 @@ (when (eq arg '&aux) (return nil)) (incf nreq)(push arg args)) (setq args (nreverse args)) - (setf (getf (getf initargs ':plist) ':arg-info) (cons nreq restp)) + (setf (getf (getf initargs :plist) :arg-info) (cons nreq restp)) (make-method-initargs-form-internal1 initargs (cddr lmf) args lmf-params restp))))) @@ -1057,28 +1063,29 @@ (defun method-function-from-fast-function (fmf) (declare (type function fmf)) (let* ((method-function nil) (pv-table nil) - (arg-info (method-function-get fmf ':arg-info)) + (arg-info (method-function-get fmf :arg-info)) (nreq (car arg-info)) (restp (cdr arg-info))) (setq method-function - #'(lambda (method-args next-methods) - (unless pv-table - (setq pv-table (method-function-pv-table fmf))) - (let* ((pv-cell (when pv-table - (get-method-function-pv-cell - method-function method-args pv-table))) - (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))))) - (if restp - (let* ((rest (nthcdr nreq method-args)) - (args (ldiff method-args rest))) - (apply fmf pv-cell nmc (nconc args (list rest)))) - (apply fmf pv-cell nmc method-args))))) + (lambda (method-args next-methods) + (unless pv-table + (setq pv-table (method-function-pv-table fmf))) + (let* ((pv-cell (when pv-table + (get-method-function-pv-cell + method-function method-args pv-table))) + (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))))) + (if restp + (let* ((rest (nthcdr nreq method-args)) + (args (ldiff method-args rest))) + (apply fmf pv-cell nmc (nconc args (list rest)))) + (apply fmf pv-cell nmc method-args))))) (let* ((fname (method-function-get fmf :name)) (name `(,(or (get (car fname) 'method-sym) (setf (get (car fname) 'method-sym) @@ -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)) @@ -1110,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))