X-Git-Url: http://repo.macrolet.net/gitweb/?a=blobdiff_plain;f=src%2Fpcl%2Fvector.lisp;h=02bbe2862d79366969e25ebd111ca688dcf33dfb;hb=01044af1b8d69fc3899dc0417064c1512223223d;hp=c4d7eba9d64884e2f28fde2afe97cddf38741955;hpb=9d67a20f91f72ec73847e283bcf9b2b4f74b1d25;p=sbcl.git diff --git a/src/pcl/vector.lisp b/src/pcl/vector.lisp index c4d7eba..02bbe28 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) @@ -667,8 +665,21 @@ `(locally (declare #.*optimize-speed*) (let ((,index (pvref ,pv ,pv-offset))) (setq ,value (typecase ,index + ;; FIXME: the line marked by KLUDGE below + ;; (and the analogous spot in + ;; INSTANCE-WRITE-INTERNAL) is there purely + ;; to suppress a type mismatch warning that + ;; propagates through to user code. + ;; Presumably SLOTS at this point can never + ;; actually be NIL, but the compiler seems + ;; to think it could, so we put this here + ;; to shut it up. (see also mail Rudi + ;; Schlatte sbcl-devel 2003-09-21) -- CSR, + ;; 2003-11-30 ,@(when (or (null type) (eq type :instance)) - `((fixnum (clos-slots-ref ,slots ,index)))) + `((fixnum + (and ,slots ; KLUDGE + (clos-slots-ref ,slots ,index))))) ,@(when (or (null type) (eq type :class)) `((cons (cdr ,index)))) (t +slot-unbound+))) @@ -702,8 +713,9 @@ (let ((,index (pvref ,pv ,pv-offset))) (typecase ,index ,@(when (or (null type) (eq type :instance)) - `((fixnum (setf (clos-slots-ref ,slots ,index) - ,new-value)))) + `((fixnum (and ,slots + (setf (clos-slots-ref ,slots ,index) + ,new-value))))) ,@(when (or (null type) (eq type :class)) `((cons (setf (cdr ,index) ,new-value)))) (t ,default))))))) @@ -988,20 +1000,26 @@ (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))) @@ -1009,8 +1027,8 @@ ;;; body given, or return NIL if no %METHOD-NAME declaration is found. (defun body-method-name (body) (multiple-value-bind (real-body declarations documentation) - (parse-body body nil) - (declare (ignore documentation real-body)) + (parse-body body) + (declare (ignore real-body documentation)) (let ((name-decl (get-declaration '%method-name declarations))) (and name-decl (destructuring-bind (name) name-decl @@ -1071,8 +1089,9 @@ req-args))) `(list* :fast-function - (named-lambda - ,(or (body-method-name body) '.method.) ; function name + (,(if (body-method-name body) 'named-lambda 'lambda) + ,@(when (body-method-name body) + (list (body-method-name body))) ; function name (.pv-cell. .next-method-call. ,@args+rest-arg) ; function args ;; body of the function (declare (ignorable .pv-cell. .next-method-call.)) @@ -1150,52 +1169,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)) - (when (invalid-wrapper-p w) - (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)))))