X-Git-Url: http://repo.macrolet.net/gitweb/?a=blobdiff_plain;f=src%2Fpcl%2Fvector.lisp;h=d0092210b19f4a21d6e13513019fafb976e255ee;hb=1ca4f69009204caee2484161e6eb89fa6c5fd3f6;hp=869e86ea10d97a5e7c79a1c2cc2f7b4fcb48247d;hpb=781a775a71a1051bb2a4836575ec233486d9088e;p=sbcl.git diff --git a/src/pcl/vector.lisp b/src/pcl/vector.lisp index 869e86e..d009221 100644 --- a/src/pcl/vector.lisp +++ b/src/pcl/vector.lisp @@ -57,7 +57,7 @@ ;;; ...and one lock to rule them. Spinlock because for certain (rare) ;;; cases this lock might be grabbed in the course of method dispatch -;;; -- and mostly this is already under the *big-compiler-lock*. +;;; -- and mostly this is already under the *world-lock* (defvar *pv-lock* (sb-thread::make-spinlock :name "pv table index lock")) @@ -81,7 +81,7 @@ (%intern-pv-table (mapcar #'intern-slot-names slot-name-lists))))) (defun optimize-slot-value-by-class-p (class slot-name type) - (or (not (eq *boot-state* 'complete)) + (or (not (eq **boot-state** 'complete)) (let ((slotd (find-slot-definition class slot-name))) (and slotd (slot-accessor-std-p slotd type))))) @@ -146,7 +146,7 @@ (slot-boundp 'boundp))) (var (extract-the var-form)) (slot-name (constant-form-value slot-name-form env))) - (when (symbolp var) + (when (and (symbolp var) (not (var-special-p var env))) (let* ((rebound? (caddr (var-declaration '%variable-rebinding var env))) (parameter-or-nil (car (memq (or rebound? var) required-parameters)))) @@ -155,7 +155,7 @@ parameter-or-nil env))) (class (find-class class-name nil))) - (when (or (not (eq *boot-state* 'complete)) + (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))) @@ -255,7 +255,7 @@ new-value &optional safep) (let ((class (if (consp sparameter) (cdr sparameter) *the-class-t*)) (parameter (if (consp sparameter) (car sparameter) sparameter))) - (if (and (eq *boot-state* 'complete) + (if (and (eq **boot-state** 'complete) (classp class) (memq *the-class-structure-object* (class-precedence-list class))) (let ((slotd (find-slot-definition class slot-name))) @@ -301,7 +301,7 @@ (let ((class (and (constantp class-form) (constant-form-value class-form))) (slot-name (and (constantp slot-name-form) (constant-form-value slot-name-form)))) - (and (eq *boot-state* 'complete) + (and (eq **boot-state** 'complete) (standard-class-p class) (not (eq class *the-class-t*)) ; shouldn't happen, though. (let ((slotd (find-slot-definition class slot-name))) @@ -311,7 +311,7 @@ (let ((class (and (constantp class-form) (constant-form-value class-form))) (slot-name (and (constantp slot-name-form) (constant-form-value slot-name-form)))) - (and (eq *boot-state* 'complete) + (and (eq **boot-state** 'complete) (standard-class-p class) (not (eq class *the-class-t*)) ; shouldn't happen, though. ;; FIXME: Is this really right? "Don't skip if there is @@ -550,104 +550,47 @@ (declare ,(make-pv-type-declaration '.pv.)) ,@forms))) -(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 - ;; this list. - '(values - %method-name - %method-lambda-list - optimize - ftype - muffle-conditions - inline - notinline)) - -(defvar *var-declarations-with-arg* - '(%class - type)) - -(defvar *var-declarations-without-arg* - '(ignore - ignorable special dynamic-extent - ;; FIXME: Possibly this entire list and variable could go away. - ;; If not, certainly we should remove all these built-in typenames - ;; from the list, and replace them with a test for "is it a type - ;; name?" (CLTL1 allowed only built-in type names as declarations, - ;; but ANSI CL allows any type name as a declaration.) - array atom base-char bignum bit bit-vector character compiled-function - complex cons double-float extended-char - fixnum float function hash-table integer - keyword list long-float nil null number package pathname random-state ratio - rational readtable sequence short-float signed-byte simple-array - simple-bit-vector simple-string simple-vector single-float standard-char - stream string symbol t unsigned-byte vector)) - (defun split-declarations (body args maybe-reads-params-p) (let ((inner-decls nil) (outer-decls nil) decl) - (loop (when (null body) (return nil)) - (setq decl (car body)) - (unless (and (consp decl) - (eq (car decl) 'declare)) - (return nil)) - (dolist (form (cdr decl)) - (when (consp form) - (let ((declaration-name (car form))) - (if (member declaration-name *non-var-declarations*) - (push `(declare ,form) outer-decls) - (let ((arg-p - (member declaration-name - *var-declarations-with-arg*)) - (non-arg-p - (member declaration-name - *var-declarations-without-arg*)) - (dname (list (pop form))) - (inners nil) (outers nil)) - (unless (or arg-p non-arg-p) - ;; FIXME: This warning, and perhaps the - ;; 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 - ;; do this right, we need to be able to handle - ;; user-defined (DECLAIM (DECLARATION FOO)) - ;; stuff.) - (warn "The declaration ~S is not understood by ~S.~@ - Please put ~S on one of the lists ~S,~%~S, or~%~S.~@ - (Assuming it is a variable declaration without argument)." - declaration-name 'split-declarations - declaration-name - '*non-var-declarations* - '*var-declarations-with-arg* - '*var-declarations-without-arg*) - (push declaration-name *var-declarations-without-arg*)) - (when arg-p - (setq dname (append dname (list (pop form))))) - (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 maybe-reads-params-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))) + (loop + (when (null body) + (return nil)) + (setq decl (car body)) + (unless (and (consp decl) (eq (car decl) 'declare)) + (return nil)) + (dolist (form (cdr decl)) + (when (consp form) + (let* ((name (car form))) + (cond ((eq '%class name) + (push `(declare ,form) inner-decls)) + ((or (member name '(ignore ignorable special dynamic-extent type)) + (info :type :kind name)) + (let* ((inners nil) + (outers nil) + (tail (cdr form)) + (head (if (eq 'type name) + (list name (pop tail)) + (list name)))) + (dolist (var tail) + (if (member var args :test #'eq) + ;; Quietly remove IGNORE declarations on + ;; args when a next-method is involved, to + ;; prevent compiler warnings about ignored + ;; args being read. + (unless (and (eq 'ignore name) maybe-reads-params-p) + (push var outers)) + (push var inners))) + (when outers + (push `(declare (,@head ,@outers)) outer-decls)) + (when inners + (push `(declare (,@head ,@inners)) inner-decls)))) + (t + ;; All other declarations are not variable declarations, + ;; so they become outer declarations. + (push `(declare ,form) outer-decls)))))) + (setq body (cdr body))) (values outer-decls inner-decls body))) ;;; Pull a name out of the %METHOD-NAME declaration in the function @@ -709,7 +652,7 @@ ;; Given a valid lambda list, extract the parameter names. (loop for x in lambda-list with res = nil - do (unless (member x lambda-list-keywords) + do (unless (member x lambda-list-keywords :test #'eq) (if (consp x) (let ((name (car x))) (if (consp name)