(defun expand-make-instance-form (form)
(let ((class (cadr form)) (initargs (cddr form))
- (keys nil)(allow-other-keys-p nil) key value)
+ (keys nil) (allow-other-keys-p nil) key value)
(when (and (constant-symbol-p class)
(let ((initargs-tail initargs))
(loop (when (null initargs-tail) (return t))
(return nil))
(setq key (eval (pop initargs-tail)))
(setq value (pop initargs-tail))
- (when (eq ':allow-other-keys key)
+ (when (eq :allow-other-keys key)
(setq allow-other-keys-p value))
(push key keys))))
(let* ((class (eval class))
(sym (make-instance-function-symbol key)))
(push key *make-instance-function-keys*)
(when sym
+ ;; (famous last words:
+ ;; 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
+ ;; wouldn't be a cop.
+ ;; 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.
+ (become-defined-fun-name sym)
`(,sym ',class (list ,@initargs)))))))
-(defmacro expanding-make-instance-top-level (&rest forms &environment env)
+(defmacro expanding-make-instance-toplevel (&rest forms &environment env)
(let* ((*make-instance-function-keys* nil)
(form (macroexpand `(expanding-make-instance ,@forms) env)))
`(progn
(defmacro expanding-make-instance (&rest forms &environment env)
`(progn
- ,@(mapcar #'(lambda (form)
- (walk-form form env
- #'(lambda (subform context env)
- (declare (ignore env))
- (or (and (eq context ':eval)
- (consp subform)
- (eq (car subform) 'make-instance)
- (expand-make-instance-form subform))
- subform))))
+ ,@(mapcar (lambda (form)
+ (walk-form form env
+ (lambda (subform context env)
+ (declare (ignore env))
+ (or (and (eq context :eval)
+ (consp subform)
+ (eq (car subform) 'make-instance)
+ (expand-make-instance-form subform))
+ subform))))
forms)))
-(defmacro defconstructor
- (name class lambda-list &rest initialization-arguments)
- `(expanding-make-instance-top-level
- (defun ,name ,lambda-list
- (make-instance ',class ,@initialization-arguments))))
-
(defun get-make-instance-functions (key-list)
(dolist (key key-list)
(let* ((cell (find-class-cell (car key)))
(*print-case* :upcase)
(*print-pretty* nil))
(intern (format nil
- "MAKE-INSTANCE ~S ~S ~S"
- class-name
+ "MAKE-INSTANCE ~A::~A ~S ~S"
+ (package-name (symbol-package class-name))
+ (symbol-name class-name)
keys
allow-other-keys-p))))))))
(cached-name (intern (format nil "~A-CACHED-~A" type name))))
`(defmacro ,reader-name (info)
`(let ((value (,',cached-name ,info)))
- (if (eq value ':unknown)
+ (if (eq value :unknown)
(progn
(,',trap ,info ',',name)
(,',cached-name ,info))
initargs-form-list
new-keys
default-initargs-function
- shared-initialize-t-function
- shared-initialize-nil-function
+ shared-initialize-t-fun
+ shared-initialize-nil-fun
constants
combined-initialize-function ; allocate-instance + shared-initialize
make-instance-function ; nil means use gf
(defmacro define-initialize-info ()
(let ((cached-slot-names
- (mapcar #'(lambda (name)
- (intern (format nil "CACHED-~A" name)))
+ (mapcar (lambda (name)
+ (intern (format nil "CACHED-~A" name)))
*initialize-info-cached-slots*))
(cached-names
- (mapcar #'(lambda (name)
- (intern (format nil "~A-CACHED-~A"
- 'initialize-info name)))
+ (mapcar (lambda (name)
+ (intern (format nil "~A-CACHED-~A"
+ 'initialize-info name)))
*initialize-info-cached-slots*)))
`(progn
- (defstruct initialize-info
+ (defstruct (initialize-info (:copier nil))
key wrapper
- ,@(mapcar #'(lambda (name)
- `(,name :unknown))
+ ,@(mapcar (lambda (name)
+ `(,name :unknown))
cached-slot-names))
(defmacro reset-initialize-info-internal (info)
`(progn
- ,@(mapcar #'(lambda (cname)
- `(setf (,cname ,info) ':unknown))
+ ,@(mapcar (lambda (cname)
+ `(setf (,cname ,info) :unknown))
',cached-names)))
(defun initialize-info-bound-slots (info)
(let ((slots nil))
- ,@(mapcar #'(lambda (name cached-name)
- `(unless (eq ':unknown (,cached-name info))
- (push ',name slots)))
+ ,@(mapcar (lambda (name cached-name)
+ `(unless (eq :unknown (,cached-name info))
+ (push ',name slots)))
*initialize-info-cached-slots* cached-names)
slots))
- ,@(mapcar #'(lambda (name)
- `(define-cached-reader initialize-info ,name
- update-initialize-info-internal))
+ ,@(mapcar (lambda (name)
+ `(define-cached-reader initialize-info ,name
+ update-initialize-info-internal))
*initialize-info-cached-slots*))))
(define-initialize-info)
(dolist (a alist)
(reset-class-initialize-info-1 (cdr a))))))
-(defun initialize-info (class initargs &optional (plist-p t) allow-other-keys-arg)
+(defun initialize-info (class
+ initargs
+ &optional
+ (plist-p t)
+ allow-other-keys-arg)
(let ((info nil))
(if (and (eq *initialize-info-cache-class* class)
(eq *initialize-info-cache-initargs* initargs))
((initargs-form-list new-keys)
(multiple-value-bind (initargs-form-list new-keys)
(make-default-initargs-form-list class keys)
- (setf (initialize-info-cached-initargs-form-list info) initargs-form-list)
+ (setf (initialize-info-cached-initargs-form-list info)
+ initargs-form-list)
(setf (initialize-info-cached-new-keys info) new-keys)))
((default-initargs-function)
(let ((initargs-form-list (initialize-info-initargs-form-list info)))
(setf (initialize-info-cached-default-initargs-function info)
- (initialize-instance-simple-function
+ (initialize-instance-simple-fun
'default-initargs-function info
class initargs-form-list))))
((valid-p ri-valid-p)
(compute-valid-p
(list (list* 'reinitialize-instance proto nil)
(list* 'shared-initialize proto nil nil)))))))
- ((shared-initialize-t-function)
+ ((shared-initialize-t-fun)
(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
class initialize-form-list))))
- ((shared-initialize-nil-function)
+ ((shared-initialize-nil-fun)
(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))
(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)
- (initialize-instance-simple-function
+ (initialize-instance-simple-fun
'combined-initialize-function info
class (append initargs-form-list initialize-form-list))))))
((make-instance-function-symbol)
(setq class (find-class class)))
(when (classp class)
(unless (class-finalized-p class) (finalize-inheritance class)))
- (let* ((initargs (mapcan #'(lambda (key) (list key nil)) keys))
+ (let* ((initargs (mapcan (lambda (key) (list key nil)) keys))
(class-and-initargs (list* class initargs))
(make-instance (gdefinition 'make-instance))
(make-instance-methods
(list* proto t initargs)))))
(when (null make-instance-methods)
(return-from get-make-instance-function
- #'(lambda (class initargs)
- (apply #'no-applicable-method make-instance class initargs))))
+ (lambda (class initargs)
+ (apply #'no-applicable-method make-instance class initargs))))
(unless (and (null (cdr make-instance-methods))
(eq (car make-instance-methods) std-mi-meth)
(null (cdr default-initargs-methods))
- (eq (car (method-specializers (car default-initargs-methods)))
+ (eq (car (method-specializers
+ (car default-initargs-methods)))
*the-class-slot-class*)
(flet ((check-meth (meth)
(let ((quals (method-qualifiers meth)))
(eq (car (method-specializers meth))
*the-class-slot-object*)
(and (null (cdr quals))
- (or (eq (car quals) ':before)
- (eq (car quals) ':after)))))))
+ (or (eq (car quals) :before)
+ (eq (car quals) :after)))))))
(and (every #'check-meth initialize-instance-methods)
(every #'check-meth shared-initialize-methods))))
(return-from get-make-instance-function nil))
(defun complicated-instance-creation-method (m)
(let ((qual (method-qualifiers m)))
(if qual
- (not (and (null (cdr qual)) (eq (car qual) ':after)))
+ (not (and (null (cdr qual)) (eq (car qual) :after)))
(let ((specl (car (method-specializers m))))
(or (not (classp specl))
(not (eq 'slot-object (class-name specl))))))))
(std-si-meth (find-standard-ii-method shared-initialize-methods
'slot-object))
(shared-initfns
- (nreverse (mapcar #'(lambda (method)
- (make-effective-method-function
- #'shared-initialize
- `(call-method ,method nil)
- nil lwrapper))
+ (nreverse (mapcar (lambda (method)
+ (make-effective-method-function
+ #'shared-initialize
+ `(call-method ,method nil)
+ nil lwrapper))
(remove std-si-meth shared-initialize-methods))))
(std-ii-meth (find-standard-ii-method initialize-instance-methods
'slot-object))
(initialize-initfns
- (nreverse (mapcar #'(lambda (method)
- (make-effective-method-function
- #'initialize-instance
- `(call-method ,method nil)
- nil lwrapper))
+ (nreverse (mapcar (lambda (method)
+ (make-effective-method-function
+ #'initialize-instance
+ `(call-method ,method nil)
+ nil lwrapper))
(remove std-ii-meth
initialize-instance-methods)))))
- #'(lambda (class1 initargs)
- (if (not (eq wrapper (class-wrapper class)))
- (let* ((info (initialize-info class1 initargs))
- (fn (initialize-info-make-instance-function info)))
- (declare (type function fn))
- (funcall fn class1 initargs))
- (let* ((instance (funcall allocate-function wrapper constants))
- (initargs (call-initialize-function initialize-function
- instance initargs)))
- (dolist (fn shared-initfns)
- (invoke-effective-method-function fn t instance t initargs))
- (dolist (fn initialize-initfns)
- (invoke-effective-method-function fn t instance initargs))
- instance))))))
+ (lambda (class1 initargs)
+ (if (not (eq wrapper (class-wrapper class)))
+ (let* ((info (initialize-info (coerce-to-class class1) initargs))
+ (fn (initialize-info-make-instance-function info)))
+ (declare (type function fn))
+ (funcall fn class1 initargs))
+ (let* ((instance (funcall allocate-function wrapper constants))
+ (initargs (call-initialize-function initialize-function
+ instance initargs)))
+ (dolist (fn shared-initfns)
+ (invoke-effective-method-function fn t instance t initargs))
+ (dolist (fn initialize-initfns)
+ (invoke-effective-method-function fn t instance initargs))
+ instance))))))
(defun make-instance-function-complex (key class keys
initialize-instance-methods
(get-secondary-dispatch-function
#'shared-initialize shared-initialize-methods
`((class-eq ,class) t t)
- `((,(find-standard-ii-method shared-initialize-methods 'slot-object)
- ,#'(lambda (instance init-type &rest initargs)
- (declare (ignore init-type))
- (call-initialize-function initialize-function
- instance initargs)
- instance)))
+ `((,(find-standard-ii-method shared-initialize-methods
+ 'slot-object)
+ ,(lambda (instance init-type &rest initargs)
+ (declare (ignore init-type))
+ (call-initialize-function initialize-function
+ instance initargs)
+ instance)))
(list wrapper *the-wrapper-of-t* *the-wrapper-of-t*)))
(initialize-instance
(get-secondary-dispatch-function
#'initialize-instance initialize-instance-methods
`((class-eq ,class) t)
- `((,(find-standard-ii-method initialize-instance-methods 'slot-object)
- ,#'(lambda (instance &rest initargs)
- (invoke-effective-method-function
- shared-initialize t instance t initargs))))
+ `((,(find-standard-ii-method initialize-instance-methods
+ 'slot-object)
+ ,(lambda (instance &rest initargs)
+ (invoke-effective-method-function
+ shared-initialize t instance t initargs))))
(list wrapper *the-wrapper-of-t*))))
- #'(lambda (class1 initargs)
- (if (not (eq wrapper (class-wrapper class)))
- (let* ((info (initialize-info class1 initargs))
- (fn (initialize-info-make-instance-function info)))
- (declare (type function fn))
- (funcall fn class1 initargs))
- (let* ((initargs (call-initialize-function initargs-function
- nil initargs))
- (instance (apply #'allocate-instance class initargs)))
- (invoke-effective-method-function
- initialize-instance t instance initargs)
- instance))))))
-
-(defun get-simple-initialization-function (class keys &optional allow-other-keys-arg)
+ (lambda (class1 initargs)
+ (if (not (eq wrapper (class-wrapper class)))
+ (let* ((info (initialize-info (coerce-to-class class1) initargs))
+ (fn (initialize-info-make-instance-function info)))
+ (declare (type function fn))
+ (funcall fn class1 initargs))
+ (let* ((initargs (call-initialize-function initargs-function
+ nil initargs))
+ (instance (apply #'allocate-instance class initargs)))
+ (invoke-effective-method-function
+ initialize-instance t instance initargs)
+ instance))))))
+
+(defun get-simple-initialization-function (class
+ keys
+ &optional allow-other-keys-arg)
(let ((info (initialize-info class keys nil allow-other-keys-arg)))
(values (initialize-info-combined-initialize-function info)
(initialize-info-constants info))))
-(defun get-complex-initialization-functions (class keys &optional allow-other-keys-arg
- separate-p)
+(defun get-complex-initialization-functions (class
+ keys
+ &optional
+ allow-other-keys-arg
+ separate-p)
(let* ((info (initialize-info class keys nil allow-other-keys-arg))
- (default-initargs-function (initialize-info-default-initargs-function info)))
+ (default-initargs-function (initialize-info-default-initargs-function
+ info)))
(if separate-p
(values default-initargs-function
- (initialize-info-shared-initialize-t-function info))
+ (initialize-info-shared-initialize-t-fun info))
(values default-initargs-function
- (initialize-info-shared-initialize-t-function
+ (initialize-info-shared-initialize-t-fun
(initialize-info class (initialize-info-new-keys info)
nil allow-other-keys-arg))))))
(default-initargs (class-default-initargs class))
(nkeys keys)
(slots-alist
- (mapcan #'(lambda (slot)
- (mapcar #'(lambda (arg)
- (cons arg slot))
- (slot-definition-initargs slot)))
+ (mapcan (lambda (slot)
+ (mapcar (lambda (arg)
+ (cons arg slot))
+ (slot-definition-initargs slot)))
(class-slots class)))
(nslots nil))
(dolist (key nkeys)
(wrapper (class-wrapper class))
(constants (when simple-p
(make-list (wrapper-no-of-instance-slots wrapper)
- ':initial-element +slot-unbound+)))
+ :initial-element +slot-unbound+)))
(slots (class-slots class))
(slot-names (mapcar #'slot-definition-name slots))
- (slots-key (mapcar #'(lambda (slot)
- (let ((index most-positive-fixnum))
- (dolist (key (slot-definition-initargs slot))
- (let ((pos (position key keys)))
- (when pos (setq index (min index pos)))))
- (cons slot index)))
+ (slots-key (mapcar (lambda (slot)
+ (let ((index most-positive-fixnum))
+ (dolist (key (slot-definition-initargs slot))
+ (let ((pos (position key keys)))
+ (when pos (setq index (min index pos)))))
+ (cons slot index)))
slots))
(slots (stable-sort slots-key #'< :key #'cdr)))
(let ((n-popped 0))
(let* ((slot (car slot+index))
(name (slot-definition-name slot)))
(when (and (eql (cdr slot+index) most-positive-fixnum)
- (or (eq si-slot-names 't)
+ (or (eq si-slot-names t)
(member name si-slot-names)))
(let* ((initform (slot-definition-initform slot))
(initfunction (slot-definition-initfunction slot))
((constantp initform)
(let ((value (funcall initfunction)))
(if (and simple-p (integerp location))
- (progn (setf (nth location constants) value)
+ (progn (setf (nth location constants)
+ value)
nil)
`((const ,value)
(instance-set ,pv-offset ,slot)))))
(defvar *initialize-instance-simple-alist* nil)
(defvar *note-iis-entry-p* nil)
-(defvar *compiled-initialize-instance-simple-functions*
+(defvar *compiled-initialize-instance-simple-funs*
(make-hash-table :test 'equal))
-(defun initialize-instance-simple-function (use info class form-list)
+(defun initialize-instance-simple-fun (use info class form-list)
(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*
- (gethash sf-key *compiled-initialize-instance-simple-functions*))
+ (gethash sf-key *compiled-initialize-instance-simple-funs*))
(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
- *compiled-initialize-instance-simple-functions*)
+ *compiled-initialize-instance-simple-funs*)
t)
(if entry
(setf (cdddr entry) (union (list sf-key) (cdddr entry)
(apply (the function (cadr entry)) args)
`(call-initialize-instance-simple ,pv-cell ,form-list))))
#||
- #'(lambda (instance initargs)
- (initialize-instance-simple pv-cell form-list instance initargs))
+ (lambda (instance initargs)
+ (initialize-instance-simple pv-cell form-list instance initargs))
||#
`(call-initialize-instance-simple ,pv-cell ,form-list))))
(setf (cadr entry) function)
(setf (caddr entry) system)
(dolist (use uses)
- (setf (gethash use *compiled-initialize-instance-simple-functions*) t))
+ (setf (gethash use *compiled-initialize-instance-simple-funs*) t))
(setf (cdddr entry) (union uses (cdddr entry)
:test #'equal))))
(defmacro precompile-iis-functions (&optional system)
`(progn
- ,@(gathering1 (collecting)
- (dolist (iis-entry *initialize-instance-simple-alist*)
- (when (or (null (caddr iis-entry))
- (eq (caddr iis-entry) system))
- (when system (setf (caddr iis-entry) system))
- (gather1
- `(load-precompiled-iis-entry
- ',(car iis-entry)
- #',(car iis-entry)
- ',system
- ',(cdddr iis-entry))))))))
+ ,@(let (collect)
+ (dolist (iis-entry *initialize-instance-simple-alist*)
+ (when (or (null (caddr iis-entry))
+ (eq (caddr iis-entry) system))
+ (when system (setf (caddr iis-entry) system))
+ (push `(load-precompiled-iis-entry
+ ',(car iis-entry)
+ #',(car iis-entry)
+ ',system
+ ',(cdddr iis-entry))
+ collect)))
+ (nreverse collect))))
(defun compile-iis-functions (after-p)
(let ((*compile-make-instance-functions-p* t)
(if *inline-iis-instance-locations-p*
(typecase location
(fixnum `((and slots
- (setf (instance-ref slots ,(const location))
- value))))
+ (setf (clos-slots-ref slots ,(const location))
+ value))))
(cons `((setf (cdr ,(const location)) value)))
(t `(,default)))
`((instance-write-internal pv slots ,(const pv-offset) value
,default
,(typecase location
- (fixnum ':instance)
- (cons ':class)
- (t ':default)))))))
+ (fixnum :instance)
+ (cons :class)
+ (t :default)))))))
(skip-when-instance-boundp
(let* ((pv-offset (cadr form))
(location (pvref pv pv-offset))
`((unless ,(if *inline-iis-instance-locations-p*
(typecase location
(fixnum `(not (and slots
- (eq (instance-ref slots ,(const location))
+ (eq (clos-slots-ref
+ slots
+ ,(const location))
+slot-unbound+))))
- (cons `(not (eq (cdr ,(const location)) +slot-unbound+)))
+ (cons `(not (eq (cdr ,(const location))
+ +slot-unbound+)))
(t default))
- `(instance-boundp-internal pv slots ,(const pv-offset)
+ `(instance-boundp-internal
+ pv slots ,(const pv-offset)
,default
,(typecase (pvref pv pv-offset)
- (fixnum ':instance)
- (cons ':class)
- (t ':default))))
+ (fixnum :instance)
+ (cons :class)
+ (t :default))))
,@(let ((sforms (cons nil nil)))
(dotimes-fixnum (i (cadddr form) (car sforms))
- (add-forms (first-form-to-lisp forms cvector pv) sforms)))))))
+ (add-forms (first-form-to-lisp forms cvector pv)
+ sforms)))))))
(update-initialize-info-cache
`((when (consp initargs)
(setq initargs (cons (car initargs) (cdr initargs))))
(values
`(lambda (pv-cell cvector)
(declare (type ,cvector-type cvector))
- #'(lambda (instance initargs)
- (declare #.*optimize-speed*)
- (iis-body ,@body)
- initargs))
+ (lambda (instance initargs)
+ (declare #.*optimize-speed*)
+ (iis-body ,@body)
+ initargs))
(list pv-cell (coerce cvector cvector-type)))))
\f
-;;; The effect of this is to cause almost all of the overhead of MAKE-INSTANCE
-;;; to happen at load time (or maybe at precompile time, as explained in a
-;;; previous message) rather than the first time that MAKE-INSTANCE is called
-;;; with a given class-name and sequence of keywords.
+;;; The effect of this is to cause almost all of the overhead of
+;;; MAKE-INSTANCE to happen at load time (or maybe at precompile time,
+;;; as explained in a previous message) rather than the first time
+;;; that MAKE-INSTANCE is called with a given class-name and sequence
+;;; of keywords.
-;;; This optimization applies only when the first argument and all the even
-;;; numbered arguments are constants evaluating to interned symbols.
+;;; This optimization applies only when the first argument and all the
+;;; even numbered arguments are constants evaluating to interned
+;;; symbols.
(declaim (ftype (function (t) symbol) get-make-instance-function-symbol))
(let* ((*make-instance-function-keys* nil)
(expanded-form (expand-make-instance-form form)))
(if expanded-form
- `(funcall (name-get-fdefinition
- ;; The symbol is guaranteed to be fbound.
+ `(funcall (fdefinition
+ ;; The name is guaranteed to be fbound.
;; Is there a way to declare this?
(load-time-value
(get-make-instance-function-symbol