(when (and (constant-symbol-p class)
(let ((initargs-tail initargs))
(loop (when (null initargs-tail) (return t))
(when (and (constant-symbol-p class)
(let ((initargs-tail initargs))
(loop (when (null initargs-tail) (return t))
;; 1. Don't worry, I know what I'm doing.
;; 2. You and what army?
;; 3. If you were as smart as you think you are, you
;; 1. Don't worry, I know what I'm doing.
;; 2. You and what army?
;; 3. If you were as smart as you think you are, you
;; This is case #1.:-) Even if SYM hasn't been defined yet,
;; it must be an implementation function, or we we wouldn't
;; have expanded into it. So declare SYM as defined, so that
;; even if it hasn't been defined yet, the user doesn't get
;; obscure warnings about undefined internal implementation
;; functions like HAIRY-MAKE-instance-name.
;; This is case #1.:-) Even if SYM hasn't been defined yet,
;; it must be an implementation function, or we we wouldn't
;; have expanded into it. So declare SYM as defined, so that
;; even if it hasn't been defined yet, the user doesn't get
;; obscure warnings about undefined internal implementation
;; functions like HAIRY-MAKE-instance-name.
`(,sym ',class (list ,@initargs)))))))
(defmacro expanding-make-instance-toplevel (&rest forms &environment env)
`(,sym ',class (list ,@initargs)))))))
(defmacro expanding-make-instance-toplevel (&rest forms &environment env)
(cached-name (intern (format nil "~A-CACHED-~A" type name))))
`(defmacro ,reader-name (info)
`(let ((value (,',cached-name ,info)))
(cached-name (intern (format nil "~A-CACHED-~A" type name))))
`(defmacro ,reader-name (info)
`(let ((value (,',cached-name ,info)))
constants
combined-initialize-function ; allocate-instance + shared-initialize
make-instance-function ; nil means use gf
constants
combined-initialize-function ; allocate-instance + shared-initialize
make-instance-function ; nil means use gf
(defmacro reset-initialize-info-internal (info)
`(progn
,@(mapcar (lambda (cname)
(defmacro reset-initialize-info-internal (info)
`(progn
,@(mapcar (lambda (cname)
',cached-names)))
(defun initialize-info-bound-slots (info)
(let ((slots nil))
,@(mapcar (lambda (name cached-name)
',cached-names)))
(defun initialize-info-bound-slots (info)
(let ((slots nil))
,@(mapcar (lambda (name cached-name)
((default-initargs-function)
(let ((initargs-form-list (initialize-info-initargs-form-list info)))
(setf (initialize-info-cached-default-initargs-function info)
((default-initargs-function)
(let ((initargs-form-list (initialize-info-initargs-form-list info)))
(setf (initialize-info-cached-default-initargs-function info)
(multiple-value-bind (initialize-form-list ignore)
(make-shared-initialize-form-list class keys t nil)
(declare (ignore ignore))
(multiple-value-bind (initialize-form-list ignore)
(make-shared-initialize-form-list class keys t nil)
(declare (ignore ignore))
- (setf (initialize-info-cached-shared-initialize-t-function info)
- (initialize-instance-simple-function
- 'shared-initialize-t-function info
+ (setf (initialize-info-cached-shared-initialize-t-fun info)
+ (initialize-instance-simple-fun
+ 'shared-initialize-t-fun info
(multiple-value-bind (initialize-form-list ignore)
(make-shared-initialize-form-list class keys nil nil)
(declare (ignore ignore))
(multiple-value-bind (initialize-form-list ignore)
(make-shared-initialize-form-list class keys nil nil)
(declare (ignore ignore))
- (setf (initialize-info-cached-shared-initialize-nil-function info)
- (initialize-instance-simple-function
- 'shared-initialize-nil-function info
+ (setf (initialize-info-cached-shared-initialize-nil-fun info)
+ (initialize-instance-simple-fun
+ 'shared-initialize-nil-fun info
class initialize-form-list))))
((constants combined-initialize-function)
(let ((initargs-form-list (initialize-info-initargs-form-list info))
class initialize-form-list))))
((constants combined-initialize-function)
(let ((initargs-form-list (initialize-info-initargs-form-list info))
(make-shared-initialize-form-list class new-keys t t)
(setf (initialize-info-cached-constants info) constants)
(setf (initialize-info-cached-combined-initialize-function info)
(make-shared-initialize-form-list class new-keys t t)
(setf (initialize-info-cached-constants info) constants)
(setf (initialize-info-cached-combined-initialize-function info)
'combined-initialize-function info
class (append initargs-form-list initialize-form-list))))))
((make-instance-function-symbol)
'combined-initialize-function info
class (append initargs-form-list initialize-form-list))))))
((make-instance-function-symbol)
(and (every #'check-meth initialize-instance-methods)
(every #'check-meth shared-initialize-methods))))
(return-from get-make-instance-function nil))
(and (every #'check-meth initialize-instance-methods)
(every #'check-meth shared-initialize-methods))))
(return-from get-make-instance-function nil))
initialize-instance-methods)))))
(lambda (class1 initargs)
(if (not (eq wrapper (class-wrapper class)))
initialize-instance-methods)))))
(lambda (class1 initargs)
(if (not (eq wrapper (class-wrapper class)))
(fn (initialize-info-make-instance-function info)))
(declare (type function fn))
(funcall fn class1 initargs))
(fn (initialize-info-make-instance-function info)))
(declare (type function fn))
(funcall fn class1 initargs))
(list wrapper *the-wrapper-of-t*))))
(lambda (class1 initargs)
(if (not (eq wrapper (class-wrapper class)))
(list wrapper *the-wrapper-of-t*))))
(lambda (class1 initargs)
(if (not (eq wrapper (class-wrapper class)))
(fn (initialize-info-make-instance-function info)))
(declare (type function fn))
(funcall fn class1 initargs))
(fn (initialize-info-make-instance-function info)))
(declare (type function fn))
(funcall fn class1 initargs))
(wrapper (class-wrapper class))
(constants (when simple-p
(make-list (wrapper-no-of-instance-slots wrapper)
(wrapper (class-wrapper class))
(constants (when simple-p
(make-list (wrapper-no-of-instance-slots wrapper)
(slots (class-slots class))
(slot-names (mapcar #'slot-definition-name slots))
(slots-key (mapcar (lambda (slot)
(slots (class-slots class))
(slot-names (mapcar #'slot-definition-name slots))
(slots-key (mapcar (lambda (slot)
(let* ((pv-cell (get-pv-cell-for-class class))
(key (initialize-info-key info))
(sf-key (list* use (class-name (car key)) (cdr key))))
(if (or *compile-make-instance-functions-p*
(let* ((pv-cell (get-pv-cell-for-class class))
(key (initialize-info-key info))
(sf-key (list* use (class-name (car key)) (cdr key))))
(if (or *compile-make-instance-functions-p*
(multiple-value-bind (form args)
(form-list-to-lisp pv-cell form-list)
(let ((entry (assoc form *initialize-instance-simple-alist*
:test #'equal)))
(setf (gethash sf-key
(multiple-value-bind (form args)
(form-list-to-lisp pv-cell form-list)
(let ((entry (assoc form *initialize-instance-simple-alist*
:test #'equal)))
(setf (gethash sf-key
(skip-when-instance-boundp
(let* ((pv-offset (cadr form))
(location (pvref pv pv-offset))
(skip-when-instance-boundp
(let* ((pv-offset (cadr form))
(location (pvref pv pv-offset))
pv slots ,(const pv-offset)
,default
,(typecase (pvref pv pv-offset)
pv slots ,(const pv-offset)
,default
,(typecase (pvref pv pv-offset)
,@(let ((sforms (cons nil nil)))
(dotimes-fixnum (i (cadddr form) (car sforms))
(add-forms (first-form-to-lisp forms cvector pv)
,@(let ((sforms (cons nil nil)))
(dotimes-fixnum (i (cadddr form) (car sforms))
(add-forms (first-form-to-lisp forms cvector pv)