X-Git-Url: http://repo.macrolet.net/gitweb/?a=blobdiff_plain;f=src%2Fpcl%2Fvector.lisp;h=f4cab13a5a103cb6f4c7e5057f5eb767977049d8;hb=22aec7852f4861e5dab28cc0d619c24b62590dad;hp=a33b8917d791bbdb77f7cac207f1499327d0f7bf;hpb=a8f0175b16a00f5fc83eb8d8a718ae7fc5497514;p=sbcl.git diff --git a/src/pcl/vector.lisp b/src/pcl/vector.lisp index a33b891..f4cab13 100644 --- a/src/pcl/vector.lisp +++ b/src/pcl/vector.lisp @@ -232,8 +232,7 @@ (pv-cell (cons pv calls)) (new-cache (fill-cache cache pv-wrappers pv-cell))) (unless (eq new-cache cache) - (setf (pv-table-cache pv-table) new-cache) - (free-cache cache)) + (setf (pv-table-cache pv-table) new-cache)) pv-cell)))) (defun make-pv-type-declaration (var) @@ -388,8 +387,7 @@ slots calls) (declare (ignore required-parameters env slots calls)) - (or (and (eq (car form) 'make-instance) - (expand-make-instance-form form)) + (or ; (optimize-reader ...)? form)) (defun can-optimize-access (form required-parameters env) @@ -529,7 +527,7 @@ (position (posq parameter-entry slots)) (pv-offset-form (list 'pv-offset ''.PV-OFFSET.))) (unless parameter-entry - (error "internal error in slot optimization")) + (bug "slot optimization bewilderment: O-I-A")) (unless slot-entry (setq slot-entry (list slot-name)) (push slot-entry (cdr parameter-entry))) @@ -557,7 +555,7 @@ (position (posq parameter-entry slots)) (pv-offset-form (list 'pv-offset ''.PV-OFFSET.))) (unless parameter-entry - (error "internal error in slot optimization")) + (error "slot optimization bewilderment: O-A-C")) (unless slot-entry (setq slot-entry (list name)) (push slot-entry (cdr parameter-entry))) @@ -638,7 +636,7 @@ (standard-class-p class) (not (eq class *the-class-t*)) ; shouldn't happen, though. (let ((slotd (find-slot-definition class slot-name))) - (and slotd (classp (slot-definition-allocation slotd))))))) + (and slotd (eq :class (slot-definition-allocation slotd))))))) (defun skip-fast-slot-access-p (class-form slot-name-form type) (let ((class (and (constantp class-form) (eval class-form))) @@ -988,28 +986,34 @@ (push declaration-name *var-declarations-without-arg*)) (when arg-p (setq dname (append dname (list (pop form))))) - (dolist (var form) - (if (member var args) - ;; Quietly remove IGNORE declarations on - ;; args when a next-method is involved, to - ;; prevent compiler warnings about ignored - ;; args being read. - (unless (and calls-next-method-p - (eq (car dname) 'ignore)) - (push var outers)) - (push var inners))) - (when outers - (push `(declare (,@dname ,@outers)) outer-decls)) - (when inners - (push `(declare (,@dname ,@inners)) inner-decls))))))) + (case (car dname) + (%class (push `(declare (,@dname ,@form)) inner-decls)) + (t + (dolist (var form) + (if (member var args) + ;; Quietly remove IGNORE declarations + ;; on args when a next-method is + ;; involved, to prevent compiler + ;; warnings about ignored args being + ;; read. + (unless (and calls-next-method-p + (eq (car dname) 'ignore)) + (push var outers)) + (push var inners))) + (when outers + (push `(declare (,@dname ,@outers)) outer-decls)) + (when inners + (push + `(declare (,@dname ,@inners)) + inner-decls))))))))) (setq body (cdr body))) (values outer-decls inner-decls body))) ;;; Pull a name out of the %METHOD-NAME declaration in the function ;;; body given, or return NIL if no %METHOD-NAME declaration is found. (defun body-method-name (body) - (multiple-value-bind (documentation declarations real-body) - (extract-declarations body nil) + (multiple-value-bind (real-body declarations documentation) + (parse-body body nil) (declare (ignore documentation real-body)) (let ((name-decl (get-declaration '%method-name declarations))) (and name-decl @@ -1150,52 +1154,24 @@ (pv-table-lookup pv-table (pv-wrappers-from-pv-args pv-parameters))) (defun pv-wrappers-from-pv-args (&rest args) - (let* ((nkeys (length args)) - (pv-wrappers (make-list nkeys)) - w - (w-t pv-wrappers)) - (dolist (arg args) - (setq w (wrapper-of arg)) - (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)) - (when (= nkeys 1) (setq pv-wrappers (car pv-wrappers))) - pv-wrappers)) + (let (wrappers) + (dolist (arg args (if (cdr wrappers) (nreverse wrappers) (car wrappers))) + (let ((wrapper (wrapper-of arg))) + (push (if (invalid-wrapper-p wrapper) + (check-wrapper-validity wrapper) + wrapper) + wrappers))))) (defun pv-wrappers-from-all-args (pv-table args) - (let ((nkeys 0) - (slot-name-lists (pv-table-slot-name-lists pv-table))) - (dolist (sn slot-name-lists) - (when sn (incf nkeys))) - (let* ((pv-wrappers (make-list nkeys)) - (pv-w-t pv-wrappers)) - (dolist (sn slot-name-lists) - (when sn - (let* ((arg (car args)) - (w (wrapper-of arg))) - (unless w ; CAN-OPTIMIZE-ACCESS prevents this from happening. - (error "error in PV-WRAPPERS-FROM-ALL-ARGS")) - (setf (car pv-w-t) w) - (setq pv-w-t (cdr pv-w-t)))) - (setq args (cdr args))) - (when (= nkeys 1) (setq pv-wrappers (car pv-wrappers))) - pv-wrappers))) + (loop for snl in (pv-table-slot-name-lists pv-table) and arg in args + when snl + collect (wrapper-of arg) into wrappers + finally (return (if (cdr wrappers) wrappers (car wrappers))))) +;;; Return the subset of WRAPPERS which is used in the cache +;;; of PV-TABLE. (defun pv-wrappers-from-all-wrappers (pv-table wrappers) - (let ((nkeys 0) - (slot-name-lists (pv-table-slot-name-lists pv-table))) - (dolist (sn slot-name-lists) - (when sn (incf nkeys))) - (let* ((pv-wrappers (make-list nkeys)) - (pv-w-t pv-wrappers)) - (dolist (sn slot-name-lists) - (when sn - (let ((w (car wrappers))) - (unless w ; CAN-OPTIMIZE-ACCESS prevents this from happening. - (error "error in PV-WRAPPERS-FROM-ALL-WRAPPERS")) - (setf (car pv-w-t) w) - (setq pv-w-t (cdr pv-w-t)))) - (setq wrappers (cdr wrappers))) - (when (= nkeys 1) (setq pv-wrappers (car pv-wrappers))) - pv-wrappers))) + (loop for snl in (pv-table-slot-name-lists pv-table) and w in wrappers + when snl + collect w into result + finally (return (if (cdr result) result (car result)))))