(ctor-function-name ctor))))
(defun make-ctor-function-name (class-name initargs safe-code-p)
- (list* 'ctor class-name safe-code-p initargs))
+ (labels ((arg-name (x)
+ (typecase x
+ ;; this list of types might look arbitrary but it is
+ ;; exactly the set of types descended into by EQUAL,
+ ;; which is the predicate used by globaldb to test for
+ ;; name equality.
+ (list (gensym "LIST-INITARG-"))
+ (string (gensym "STRING-INITARG-"))
+ (bit-vector (gensym "BIT-VECTOR-INITARG-"))
+ (pathname (gensym "PATHNAME-INITARG-"))
+ (t x)))
+ (munge (list)
+ (let ((*gensym-counter* 0))
+ (mapcar #'arg-name list))))
+ (list* 'ctor class-name safe-code-p (munge initargs))))
;;; Keep this a separate function for testing.
(defun ensure-ctor (function-name class-name initargs safe-code-p)
'(:instance :class)))
(class-slots class))
(not maybe-invalid-initargs)
- (not (nonstandard-primary-method-p
+ (not (hairy-around-or-nonstandard-primary-method-p
ii-methods *the-system-ii-method*))
(not (around-or-nonstandard-primary-method-p
si-methods *the-system-si-method*)))
when (null qualifiers) do
(setq primary-checked-p t)))
-(defun nonstandard-primary-method-p
+(defun hairy-around-or-nonstandard-primary-method-p
(methods &optional standard-method)
(loop with primary-checked-p = nil
for method in methods
as qualifiers = (if (consp method)
(early-method-qualifiers method)
(safe-method-qualifiers method))
- when (or (and (null qualifiers)
+ when (or (and (eq :around (car qualifiers))
+ (not (simple-next-method-call-p method)))
+ (and (null qualifiers)
(not primary-checked-p)
(not (null standard-method))
(not (eq standard-method method))))
(declare (ignore ii-methods si-methods))
(let ((class (ctor-class ctor))
(lambda-list (make-ctor-parameter-list ctor))
- (initargs (quote-plist-keys (ctor-initargs ctor))))
+ (initargs (ctor-initargs ctor)))
(if use-make-instance
`(lambda ,lambda-list
(declare #.*optimize-speed*)
;; *COMPILING-OPTIMIZED-CONSTRUCTOR* which is bound around
;; compilation of the constructor, hence avoiding the
;; possibility of endless recursion.
- (make-instance ,class ,@initargs))
+ (make-instance ,class ,@(quote-plist-keys initargs)))
(let ((defaults (class-default-initargs class)))
(when defaults
(setf initargs (ctor-default-initargs initargs defaults)))
`(lambda ,lambda-list
(declare #.*optimize-speed*)
- (fast-make-instance ,class ,@initargs))))))
+ (fast-make-instance ,class ,@(quote-plist-keys initargs)))))))
;;; Not as good as the real optimizing generator, but faster than going
;;; via MAKE-INSTANCE: 1 GF call less, and no need to check initargs.
,value-form))))
(not-boundp-form ()
(if (member slotd sbuc-slots :test #'eq)
- `(slot-boundp-using-class
- ,class .instance. ,slotd)
+ `(not (slot-boundp-using-class
+ ,class .instance. ,slotd))
`(eq (clos-slots-ref .slots. ,i)
+slot-unbound+))))
(ecase kind