;;;; specification.
(in-package "SB-PCL")
-
-(sb-int:file-comment
- "$Header$")
\f
(defvar *compile-make-instance-functions-p* nil)
(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 copy.
+ ;; 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.
+ (sb-kernel: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
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)))
'initialize-info name)))
*initialize-info-cached-slots*)))
`(progn
- (defstruct initialize-info
+ (defstruct (initialize-info (:copier nil))
key wrapper
,@(mapcar #'(lambda (name)
`(,name :unknown))
(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)))
(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)))
(get-secondary-dispatch-function
#'shared-initialize shared-initialize-methods
`((class-eq ,class) t t)
- `((,(find-standard-ii-method shared-initialize-methods 'slot-object)
+ `((,(find-standard-ii-method shared-initialize-methods
+ 'slot-object)
,#'(lambda (instance init-type &rest initargs)
(declare (ignore init-type))
(call-initialize-function initialize-function
(get-secondary-dispatch-function
#'initialize-instance initialize-instance-methods
`((class-eq ,class) t)
- `((,(find-standard-ii-method initialize-instance-methods 'slot-object)
+ `((,(find-standard-ii-method initialize-instance-methods
+ 'slot-object)
,#'(lambda (instance &rest initargs)
(invoke-effective-method-function
shared-initialize t instance t initargs))))
initialize-instance t instance initargs)
instance))))))
-(defun get-simple-initialization-function (class keys &optional allow-other-keys-arg)
+(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))
(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* ((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)))))
(nconc *initialize-instance-simple-alist*
(list entry)))))
(unless (or *note-iis-entry-p* (cadr entry))
- (setf (cadr entry) (compile-lambda (car entry))))
+ (setf (cadr entry) (compile nil (car entry))))
(if (cadr entry)
(apply (the function (cadr entry)) args)
`(call-initialize-instance-simple ,pv-cell ,form-list))))
:test #'equal))))
(defmacro precompile-iis-functions (&optional system)
- (let ((index -1))
- `(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
- (make-top-level-form
- `(precompile-initialize-instance-simple ,system ,(incf index))
- '(:load-toplevel)
- `(load-precompiled-iis-entry
- ',(car iis-entry)
- #',(car iis-entry)
- ',system
- ',(cdddr iis-entry))))))))))
+ `(progn
+ ,@(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)
value)))
(if *inline-iis-instance-locations-p*
(typecase location
- (fixnum `((setf (%instance-ref slots ,(const location)) value)))
+ (fixnum `((and slots
+ (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
,(const (caddr form)))))
`((unless ,(if *inline-iis-instance-locations-p*
(typecase location
- (fixnum `(not (eq (%instance-ref slots ,(const location))
- ',*slot-unbound*)))
- (cons `(not (eq (cdr ,(const location)) ',*slot-unbound*)))
+ (fixnum `(not (and slots
+ (eq (clos-slots-ref
+ slots
+ ,(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)
(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))))
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 (symbol-function
- ;; 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
projects / sbcl.git / blobdiff