;; another binding it won't have a %CLASS
;; declaration anymore, and this won't get
;; executed.
- (pushnew var parameters-setqd))))
+ (pushnew var parameters-setqd :test #'eq))))
form)
((and (eq (car form) 'function)
(cond ((eq (cadr form) 'call-next-method)
(when (eq (layout-invalid (class-wrapper class)) t)
(force-cache-flushes class))
(setf (ctor-class ctor) class)
- (pushnew ctor (plist-value class 'ctors))
+ (pushnew ctor (plist-value class 'ctors) :test #'eq)
(setf (funcallable-instance-fun ctor)
(multiple-value-bind (form locations names)
(constructor-function-form ctor)
(defun canonize-defclass-options (class-name options)
(maplist (lambda (sublist)
(let ((option-name (first (pop sublist))))
- (when (member option-name sublist :key #'first)
+ (when (member option-name sublist :key #'first :test #'eq)
(error 'simple-program-error
:format-control "Multiple ~S options in DEFCLASS ~S."
:format-arguments (list option-name class-name)))))
(:default-initargs
(let (initargs arg-names)
(doplist (key val) (cdr option)
- (when (member key arg-names)
+ (when (member key arg-names :test #'eq)
(error 'simple-program-error
:format-control "~@<Duplicate initialization argument ~
name ~S in :DEFAULT-INITARGS of ~
(slot-name-illegal "a keyword"))
((constantp name env)
(slot-name-illegal "a constant"))
- ((member name *slot-names-for-this-defclass*)
+ ((member name *slot-names-for-this-defclass* :test #'eq)
(error 'simple-program-error
:format-control "Multiple slots named ~S in DEFCLASS ~S."
:format-arguments (list name class-name))))))
(let ((intercept-rebindings
(let (rebindings)
(dolist (arg args-lambda-list (nreverse rebindings))
- (unless (member arg lambda-list-keywords)
+ (unless (member arg lambda-list-keywords :test #'eq)
(typecase arg
(symbol (push `(,arg ',arg) rebindings))
(cons
(dohash ((sub v) subs)
(declare (ignore v))
(/noshow sub)
- (when (member class (direct-supers sub))
+ (when (member class (direct-supers sub) :test #'eq)
(res sub)))))
(res))))
(mapcar (lambda (kernel-bic-entry)
(let ((subcpl (member (ecase type
(reader (car specializers))
(writer (cadr specializers)))
- cpl)))
- (and subcpl (member found-specializer subcpl))))
+ cpl :test #'eq)))
+ (and subcpl (member found-specializer subcpl :test #'eq))))
(setf found-specializer (ecase type
(reader (car specializers))
(writer (cadr specializers))))
(early-class-precedence-list
accessor-class)
(class-precedence-list
- accessor-class)))
+ accessor-class))
+ :test #'eq)
(if early-p
(not (eq *the-class-standard-method*
(early-method-class meth)))
(early-class-precedence-list specl)
(when (class-finalized-p specl)
(class-precedence-list specl))))
- (so-p (member *the-class-standard-object* specl-cpl))
+ (so-p (member *the-class-standard-object* specl-cpl :test #'eq))
(slot-name (if (consp method)
(and (early-method-standard-accessor-p method)
(early-method-standard-accessor-slot-name
(accessor-method-slot-name method))))
(when (or (null specl-cpl)
(null so-p)
- (member *the-class-structure-object* specl-cpl))
+ (member *the-class-structure-object* specl-cpl :test #'eq))
(return-from make-accessor-table nil))
;; Collect all the slot-definitions for SLOT-NAME from SPECL and
;; all of its subclasses. If either SPECL or one of the subclasses
;;; CMUCL comment: used only in map-all-orders
(defun class-might-precede-p (class1 class2)
(if (not *in-precompute-effective-methods-p*)
- (not (member class1 (cdr (class-precedence-list class2))))
+ (not (member class1 (cdr (class-precedence-list class2)) :test #'eq))
(class-can-precede-p class1 class2)))
(defun compute-precedence (lambda-list nreq argument-precedence-order)
(let ((pos 0))
(dolist (type-spec (method-specializers method))
(unless (eq type-spec *the-class-t*)
- (pushnew pos specialized-argument-positions))
+ (pushnew pos specialized-argument-positions :test #'eq))
(incf pos)))
;; Finally merge the values for this method into the values
;; for the exisiting methods and return them. Note that if
(list '(:sbcl :node "Metaobject Protocol")
'(:amop :generic-function (setf slot-value-using-class)))))
+(defgeneric values-for-add-method (gf method)
+ (:method ((gf standard-generic-function) (method standard-method))
+ ;; KLUDGE: Just a single generic dispatch, and everything else
+ ;; comes from permutation vectors. Would be nicer to define
+ ;; REAL-ADD-METHOD with a proper method so that we could efficiently
+ ;; use SLOT-VALUE there.
+ ;;
+ ;; Optimization note: REAL-ADD-METHOD has a lot of O(N) stuff in it (as
+ ;; does PCL as a whole). It should not be too hard to internally store
+ ;; many of the things we now keep in lists as either purely functional
+ ;; O(log N) sets, or --if we don't mind the memory cost-- using
+ ;; specialized hash-tables: most things are used to answer questions about
+ ;; set-membership, not ordering.
+ (values (slot-value gf '%lock)
+ (slot-value method 'qualifiers)
+ (slot-value method 'specializers)
+ (slot-value method 'lambda-list)
+ (slot-value method '%generic-function))))
+
(defun real-add-method (generic-function method &optional skip-dfun-update-p)
- (when (method-generic-function method)
- (error "~@<The method ~S is already part of the generic ~
- function ~S; it can't be added to another generic ~
- function until it is removed from the first one.~@:>"
- method (method-generic-function method)))
- (flet ((similar-lambda-lists-p (method-a method-b)
+ (flet ((similar-lambda-lists-p (old-method new-lambda-list)
(multiple-value-bind (a-nreq a-nopt a-keyp a-restp)
- (analyze-lambda-list (method-lambda-list method-a))
+ (analyze-lambda-list (method-lambda-list old-method))
(multiple-value-bind (b-nreq b-nopt b-keyp b-restp)
- (analyze-lambda-list (method-lambda-list method-b))
+ (analyze-lambda-list new-lambda-list)
(and (= a-nreq b-nreq)
(= a-nopt b-nopt)
(eq (or a-keyp a-restp)
(or b-keyp b-restp)))))))
- (let ((lock (gf-lock generic-function)))
- ;; HANDLER-CASE takes care of releasing the lock and enabling
- ;; interrupts before going forth with the error.
+ (multiple-value-bind (lock qualifiers specializers new-lambda-list
+ method-gf)
+ (values-for-add-method generic-function method)
+ (when method-gf
+ (error "~@<The method ~S is already part of the generic ~
+ function ~S; it can't be added to another generic ~
+ function until it is removed from the first one.~@:>"
+ method method-gf))
(handler-case
;; System lock because interrupts need to be disabled as
;; well: it would be bad to unwind and leave the gf in an
;; inconsistent state.
(sb-thread::with-recursive-system-spinlock (lock)
- (let* ((qualifiers (method-qualifiers method))
- (specializers (method-specializers method))
- (existing (get-method generic-function
- qualifiers
- specializers
- nil)))
+ (let ((existing (get-method generic-function
+ qualifiers
+ specializers
+ nil)))
;; If there is already a method like this one then we must get
;; rid of it before proceeding. Note that we call the generic
;; function REMOVE-METHOD to remove it rather than doing it in
;; some internal way.
- (when (and existing (similar-lambda-lists-p existing method))
+ (when (and existing (similar-lambda-lists-p existing new-lambda-list))
(remove-method generic-function existing))
;; KLUDGE: We have a special case here, as we disallow
(error 'new-value-specialization :method method))
(setf (method-generic-function method) generic-function)
- (pushnew method (generic-function-methods generic-function))
+ (pushnew method (generic-function-methods generic-function) :test #'eq)
(dolist (specializer specializers)
(add-direct-method specializer method))
(dolist (class classes)
(dolist (other-class classes)
(unless (eq class other-class)
- (pushnew other-class (class-incompatible-superclass-list class))))))
+ (pushnew other-class (class-incompatible-superclass-list class) :test #'eq)))))
(defun superclasses-compatible-p (class1 class2)
(let ((cpl1 (cpl-or-nil class1))
(let ((methods (generic-function-methods c-a-m-gf)))
(if (and *old-c-a-m-gf-methods*
(every (lambda (old-method)
- (member old-method methods))
+ (member old-method methods :test #'eq))
*old-c-a-m-gf-methods*))
(let ((gfs-to-do nil)
(gf-classes-to-do nil))
(dolist (method methods)
- (unless (member method *old-c-a-m-gf-methods*)
+ (unless (member method *old-c-a-m-gf-methods* :test #'eq)
(let ((specl (car (method-specializers method))))
(if (eql-specializer-p specl)
- (pushnew (specializer-object specl) gfs-to-do)
- (pushnew (specializer-class specl) gf-classes-to-do)))))
+ (pushnew (specializer-object specl) gfs-to-do :test #'eq)
+ (pushnew (specializer-class specl) gf-classes-to-do :test #'eq)))))
(map-all-generic-functions
(lambda (gf)
- (when (or (member gf gfs-to-do)
+ (when (or (member gf gfs-to-do :test #'eq)
(dolist (class gf-classes-to-do nil)
(member class
- (class-precedence-list (class-of gf)))))
+ (class-precedence-list (class-of gf))
+ :test #'eq)))
(update-c-a-m-gf-info gf)))))
(map-all-generic-functions #'update-c-a-m-gf-info))
(setq *old-c-a-m-gf-methods* methods)))
(get-optimized-std-slot-value-using-class-method-function
class slotd type))
(method-alist
- `((,(car (or (member std-method methods)
- (member str-method methods)
+ `((,(car (or (member std-method methods :test #'eq)
+ (member str-method methods :test #'eq)
(bug "error in ~S"
'get-accessor-method-function)))
,optimized-std-fun)))
(parse-lambda-list lambda-list)
(declare (ignore restp keyp auxp aux morep))
(declare (ignore more-context more-count))
- (values required optional rest keys allowp)))
\ No newline at end of file
+ (values required optional rest keys allowp)))
;;; here, the values are read by an automatically generated reader method.
(defmethod add-direct-subclass ((class class) (subclass class))
(with-slots (direct-subclasses) class
- (pushnew subclass direct-subclasses)
+ (pushnew subclass direct-subclasses :test #'eq)
subclass))
(defmethod remove-direct-subclass ((class class) (subclass class))
(with-slots (direct-subclasses) class
;; be in progress, and because if an interrupt catches us we
;; need to have a consistent state.
(setf (cdr cell) ()
- (car cell) (adjoin method (car cell))))
+ (car cell) (adjoin method (car cell) :test #'eq)))
method)
(defmethod remove-direct-method ((specializer class) (method method))
\f
;;; This hash table is used to store the direct methods and direct generic
;;; functions of EQL specializers. Each value in the table is the cons.
-(defvar *eql-specializer-methods* (make-hash-table :test 'eql))
-(defvar *class-eq-specializer-methods* (make-hash-table :test 'eq))
+;;;
+;;; These tables are shared between threads, so they need to be synchronized.
+(defvar *eql-specializer-methods* (make-hash-table :test 'eql :synchronized t))
+(defvar *class-eq-specializer-methods* (make-hash-table :test 'eq :synchronized t))
(defmethod specializer-method-table ((specializer eql-specializer))
*eql-specializer-methods*)
(let* ((object (specializer-object specializer))
(table (specializer-method-table specializer))
(entry (gethash object table)))
- ;; This table is shared between multiple specializers, but
- ;; no worries as (at least for the time being) our hash-tables
- ;; are thread safe.
(unless entry
(setf entry
(setf (gethash object table) (cons nil nil))))
;; be in progress, and because if an interrupt catches us we
;; need to have a consistent state.
(setf (cdr entry) ()
- (car entry) (adjoin method (car entry)))
+ (car entry) (adjoin method (car entry) :test #'eq))
method))
(defmethod remove-direct-method ((specializer specializer-with-object)
(old (assoc name old-class-slot-cells)))
(if (or (not old)
(eq t slot-names)
- (member name slot-names))
+ (member name slot-names :test #'eq))
(let* ((initfunction (slot-definition-initfunction dslotd))
(value (if initfunction
(funcall initfunction)
(when cpl
(let ((first (car cpl)))
(dolist (c (cdr cpl))
- (pushnew c (slot-value first 'can-precede-list))))
+ (pushnew c (slot-value first 'can-precede-list) :test #'eq)))
(update-class-can-precede-p (cdr cpl))))
(defun class-can-precede-p (class1 class2)
- (member class2 (class-can-precede-list class1)))
+ (member class2 (class-can-precede-list class1) :test #'eq))
(defun update-slots (class eslotds)
(let ((instance-slots ())
(defun update-gfs-of-class (class)
(when (and (class-finalized-p class)
(let ((cpl (class-precedence-list class)))
- (or (member *the-class-slot-class* cpl)
+ (or (member *the-class-slot-class* cpl :test #'eq)
(member *the-class-standard-effective-slot-definition*
- cpl))))
+ cpl :test #'eq))))
(let ((gf-table (make-hash-table :test 'eq)))
(labels ((collect-gfs (class)
(dolist (gf (specializer-direct-generic-functions class))
t)
\f
(defmethod add-dependent ((metaobject dependent-update-mixin) dependent)
- (pushnew dependent (plist-value metaobject 'dependents)))
+ (pushnew dependent (plist-value metaobject 'dependents) :test #'eq))
(defmethod remove-dependent ((metaobject dependent-update-mixin) dependent)
(setf (plist-value metaobject 'dependents)
(list name (pop tail))
(list name))))
(dolist (var tail)
- (if (member var args)
+ (if (member var args :test #'eq)
;; Quietly remove IGNORE declarations on
;; args when a next-method is involved, to
;; prevent compiler warnings about ignored
;; 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)
(push (list thing :lexical-var) (cadddr (env-lock env))))
(defun var-lexical-p (var env)
- (let ((entry (member var (env-lexical-variables env) :key #'car)))
+ (let ((entry (member var (env-lexical-variables env) :key #'car :test #'eq)))
(when (eq (cadar entry) :lexical-var)
entry)))
(defun variable-symbol-macro-p (var env)
- (let ((entry (member var (env-lexical-variables env) :key #'car)))
+ (let ((entry (member var (env-lexical-variables env) :key #'car :test #'eq)))
(when (eq (cadar entry) 'sb!sys:macro)
entry)))
&aux arg)
(cond ((null arglist) ())
((symbolp (setq arg (car arglist)))
- (or (member arg lambda-list-keywords)
+ (or (member arg lambda-list-keywords :test #'eq)
(note-lexical-binding arg env))
(recons arglist
arg
;;; checkins which aren't released. (And occasionally for internal
;;; versions, especially for internal versions off the main CVS
;;; branch, it gets hairier, e.g. "0.pre7.14.flaky4.13".)
-"1.0.17.8"
+"1.0.17.9"
projects / sbcl.git / commitdiff