(defun constant-symbol-p (form)
(and (constantp form)
- (let ((constant (eval form)))
+ (let ((constant (constant-form-value form)))
(and (symbolp constant)
(not (null (symbol-package constant)))))))
;;; funcallable instance is set to it.
;;;
(!defstruct-with-alternate-metaclass ctor
- :slot-names (function-name class-name class initargs)
+ :slot-names (function-name class-name class initargs safe-p)
:boa-constructor %make-ctor
- :superclass-name pcl-funcallable-instance
- :metaclass-name random-pcl-classoid
- :metaclass-constructor make-random-pcl-classoid
+ :superclass-name function
+ :metaclass-name static-classoid
+ :metaclass-constructor make-static-classoid
:dd-type funcallable-structure
:runtime-type-checks-p nil)
(setf (%funcallable-instance-info ctor 1)
(ctor-function-name ctor))))
-(defun make-ctor-function-name (class-name initargs)
- (list* 'ctor class-name initargs))
+(defun make-ctor-function-name (class-name initargs safe-code-p)
+ (list* 'ctor class-name safe-code-p initargs))
;;; Keep this a separate function for testing.
-(defun ensure-ctor (function-name class-name initargs)
+(defun ensure-ctor (function-name class-name initargs safe-code-p)
(unless (fboundp function-name)
- (make-ctor function-name class-name initargs)))
+ (make-ctor function-name class-name initargs safe-code-p)))
;;; Keep this a separate function for testing.
-(defun make-ctor (function-name class-name initargs)
+(defun make-ctor (function-name class-name initargs safe-p)
(without-package-locks ; for (setf symbol-function)
- (let ((ctor (%make-ctor function-name class-name nil initargs)))
+ (let ((ctor (%make-ctor function-name class-name nil initargs safe-p)))
(push ctor *all-ctors*)
(setf (fdefinition function-name) ctor)
(install-initial-constructor ctor :force-p t)
;;; Compile-Time Expansion of MAKE-INSTANCE *******
;;; ***********************************************
-(define-compiler-macro make-instance (&whole form &rest args)
+(define-compiler-macro make-instance (&whole form &rest args &environment env)
(declare (ignore args))
- (or (make-instance->constructor-call form)
+ (or (make-instance->constructor-call form (safe-code-p env))
form))
-(defun make-instance->constructor-call (form)
+(defun make-instance->constructor-call (form safe-code-p)
(destructuring-bind (fn class-name &rest args) form
(declare (ignore fn))
(flet (;;
(loop for (key . more) on args by #'cddr do
(when (or (null more)
(not (constant-symbol-p key))
- (eq :allow-other-keys (eval key)))
+ (eq :allow-other-keys (constant-form-value key)))
(return-from make-instance->constructor-call nil)))))
(check-class)
(check-args)
;; VALUE-FORMS.
(multiple-value-bind (initargs value-forms)
(loop for (key value) on args by #'cddr and i from 0
- collect (eval key) into initargs
+ collect (constant-form-value key) into initargs
if (constantp value)
collect value into initargs
else
and collect value into value-forms
finally
(return (values initargs value-forms)))
- (let* ((class-name (eval class-name))
- (function-name (make-ctor-function-name class-name initargs)))
+ (let* ((class-name (constant-form-value class-name))
+ (function-name (make-ctor-function-name class-name initargs
+ safe-code-p)))
;; Prevent compiler warnings for calling the ctor.
(proclaim-as-fun-name function-name)
(note-name-defined function-name :function)
`(locally
(declare (disable-package-locks ,function-name))
(let ((.x. (load-time-value
- (ensure-ctor ',function-name ',class-name ',initargs))))
+ (ensure-ctor ',function-name ',class-name ',initargs
+ ',safe-code-p))))
(declare (ignore .x.))
;; ??? check if this is worth it.
(declare
(setf (ctor-class ctor) class)
(pushnew ctor (plist-value class 'ctors))
(setf (funcallable-instance-fun ctor)
- ;; KLUDGE: Gerd here has the equivalent of (COMPILE NIL
- ;; (CONSTRUCTOR-FUNCTION-FORM)), but SBCL's COMPILE doesn't
- ;; deal with INSTANCE-LAMBDA expressions, only with LAMBDA
- ;; expressions. The below should be equivalent, since we
- ;; have a compiler-only implementation.
- ;;
- ;; (except maybe for optimization qualities? -- CSR,
- ;; 2004-07-12)
- ;;
- ;; FIXME: INSTANCE-LAMBDA is no more. We could change this.
- (eval `(function ,(constructor-function-form ctor))))))
+ (multiple-value-bind (form locations names)
+ (constructor-function-form ctor)
+ (apply (compile nil `(lambda ,names ,form)) locations)))))
(defun constructor-function-form (ctor)
(let* ((class (ctor-class ctor))
;; MAKE-INSTANCE and/or ALLOCATE-INSTANCE, these will show up
;; together with the system-defined ones in what
;; COMPUTE-APPLICABLE-METHODS returns.
- (or (and (not (structure-class-p class))
+ (if (and (not (structure-class-p class))
(not (condition-class-p class))
(null (cdr make-instance-methods))
(null (cdr allocate-instance-methods))
;; SLOT-BOUNDP-USING-CLASS), so if there are non-standard
;; applicable methods we can't shortcircuit them.
(every (lambda (x) (= (length x) 1)) setf-svuc-slots-methods)
- (every (lambda (x) (= (length x) 1)) sbuc-slots-methods)
- (optimizing-generator ctor ii-methods si-methods))
+ (every (lambda (x) (= (length x) 1)) sbuc-slots-methods))
+ (optimizing-generator ctor ii-methods si-methods)
(fallback-generator ctor ii-methods si-methods))))
(defun around-or-nonstandard-primary-method-p
;; calling it with a class, as here, we inhibit the optimization,
;; so removing the possibility of endless recursion. -- CSR,
;; 2004-07-12
- (make-instance ,(ctor-class ctor) ,@(ctor-initargs ctor))))
+ (make-instance ,(ctor-class ctor)
+ ,@(quote-plist-keys (ctor-initargs ctor)))))
(defun optimizing-generator (ctor ii-methods si-methods)
- (multiple-value-bind (body before-method-p)
+ (multiple-value-bind (locations names body before-method-p)
(fake-initialization-emf ctor ii-methods si-methods)
- `(lambda ,(make-ctor-parameter-list ctor)
+ (values
+ `(lambda ,(make-ctor-parameter-list ctor)
(declare #.*optimize-speed*)
- ,(wrap-in-allocate-forms ctor body before-method-p))))
+ ,(wrap-in-allocate-forms ctor body before-method-p))
+ locations
+ names)))
;;; Return a form wrapped around BODY that allocates an instance
;;; constructed by CTOR. BEFORE-METHOD-P set means we have to run
.instance.)
`(let* ((.instance. (,allocation-function ,wrapper))
(.slots. (,slots-fetcher .instance.)))
+ (declare (ignorable .slots.))
,body
.instance.))))
(declare (ignore si-primary))
(aver (and (null ii-around) (null si-around)))
(let ((initargs (ctor-initargs ctor)))
- (multiple-value-bind (bindings vars defaulting-initargs body)
+ (multiple-value-bind (locations names bindings vars defaulting-initargs body)
(slot-init-forms ctor (or ii-before si-before))
(values
+ locations
+ names
`(let ,bindings
(declare (ignorable ,@vars))
(let (,@(when (or ii-before ii-after)
finally
(return (values around before (first primary) (reverse after)))))
+(defmacro with-type-checked ((type safe-p) &body body)
+ (if safe-p
+ ;; To handle FUNCTION types reasonable, we use SAFETY 3 and
+ ;; THE instead of e.g. CHECK-TYPE.
+ `(locally
+ (declare (optimize (safety 3)))
+ (the ,type (progn ,@body)))
+ `(progn ,@body)))
+
;;; Return as multiple values bindings for default initialization
;;; arguments, variable names, defaulting initargs and a body for
;;; initializing instance and class slots of an object costructed by
(let* ((class (ctor-class ctor))
(initargs (ctor-initargs ctor))
(initkeys (plist-keys initargs))
+ (safe-p (ctor-safe-p ctor))
(slot-vector
(make-array (layout-length (class-wrapper class))
:initial-element nil))
((integerp location)
(not (null (aref slot-vector location))))
(t (bug "Weird location in ~S" 'slot-init-forms))))
- (class-init (location type val)
+ (class-init (location kind val type)
(aver (consp location))
(unless (initializedp location)
- (push (list location type val) class-inits)))
- (instance-init (location type val)
+ (push (list location kind val type) class-inits)))
+ (instance-init (location kind val type)
(aver (integerp location))
(unless (initializedp location)
- (setf (aref slot-vector location) (list type val))))
+ (setf (aref slot-vector location) (list kind val type))))
(default-init-var-name (i)
(let ((ps #(.d0. .d1. .d2. .d3. .d4. .d5.)))
(if (array-in-bounds-p ps i)
(aref ps i)
- (format-symbol *pcl-package* ".D~D." i)))))
+ (format-symbol *pcl-package* ".D~D." i))))
+ (location-var-name (i)
+ (let ((ls #(.l0. .l1. .l2. .l3. .l4. .l5.)))
+ (if (array-in-bounds-p ls i)
+ (aref ls i)
+ (format-symbol *pcl-package* ".L~D." i)))))
;; Loop over supplied initargs and values and record which
;; instance and class slots they initialize.
(loop for (key value) on initargs by #'cddr
- as locations = (initarg-locations key) do
- (if (constantp value)
- (dolist (location locations)
- (if (consp location)
- (class-init location 'constant value)
- (instance-init location 'constant value)))
- (dolist (location locations)
- (if (consp location)
- (class-init location 'param value)
- (instance-init location 'param value)))))
+ as kind = (if (constantp value) 'constant 'param)
+ as locations = (initarg-locations key)
+ do (loop for (location . type) in locations
+ do (if (consp location)
+ (class-init location kind value type)
+ (instance-init location kind value type))))
;; Loop over default initargs of the class, recording
;; initializations of slots that have not been initialized
;; above. Default initargs which are not in the supplied
;; if not actually used for initializing a slot.
(loop for (key initform initfn) in default-initargs and i from 0
unless (member key initkeys :test #'eq) do
- (let* ((type (if (constantp initform) 'constant 'var))
- (init (if (eq type 'var) initfn initform)))
- (ecase type
+ (let* ((kind (if (constantp initform) 'constant 'var))
+ (init (if (eq kind 'var) initfn initform)))
+ (ecase kind
(constant
(push key defaulting-initargs)
(push initform defaulting-initargs))
(var
(push key defaulting-initargs)
(push (default-init-var-name i) defaulting-initargs)))
- (when (eq type 'var)
+ (when (eq kind 'var)
(let ((init-var (default-init-var-name i)))
(setq init init-var)
(push (cons init-var initfn) default-inits)))
- (dolist (location (initarg-locations key))
- (if (consp location)
- (class-init location type init)
- (instance-init location type init)))))
+ (loop for (location . type) in (initarg-locations key)
+ do (if (consp location)
+ (class-init location kind init type)
+ (instance-init location kind init type)))))
;; Loop over all slots of the class, filling in the rest from
;; slot initforms.
(loop for slotd in (class-slots class)
as location = (slot-definition-location slotd)
+ as type = (slot-definition-type slotd)
as allocation = (slot-definition-allocation slotd)
as initfn = (slot-definition-initfunction slotd)
as initform = (slot-definition-initform slotd) do
(null initfn)
(initializedp location))
(if (constantp initform)
- (instance-init location 'initform initform)
- (instance-init location 'initform/initfn initfn))))
+ (instance-init location 'initform initform type)
+ (instance-init location 'initform/initfn initfn type))))
;; Generate the forms for initializing instance and class slots.
(let ((instance-init-forms
(loop for slot-entry across slot-vector and i from 0
- as (type value) = slot-entry collect
- (ecase type
+ as (kind value type) = slot-entry collect
+ (ecase kind
((nil)
(unless before-method-p
`(setf (clos-slots-ref .slots. ,i) +slot-unbound+)))
((param var)
- `(setf (clos-slots-ref .slots. ,i) ,value))
+ `(setf (clos-slots-ref .slots. ,i)
+ (with-type-checked (,type ,safe-p)
+ ,value)))
(initfn
- `(setf (clos-slots-ref .slots. ,i) (funcall ,value)))
+ `(setf (clos-slots-ref .slots. ,i)
+ (with-type-checked (,type ,safe-p)
+ (funcall ,value))))
(initform/initfn
(if before-method-p
`(when (eq (clos-slots-ref .slots. ,i)
+slot-unbound+)
(setf (clos-slots-ref .slots. ,i)
- (funcall ,value)))
+ (with-type-checked (,type ,safe-p)
+ (funcall ,value))))
`(setf (clos-slots-ref .slots. ,i)
- (funcall ,value))))
+ (with-type-checked (,type ,safe-p)
+ (funcall ,value)))))
(initform
(if before-method-p
`(when (eq (clos-slots-ref .slots. ,i)
+slot-unbound+)
(setf (clos-slots-ref .slots. ,i)
- ',(eval value)))
+ (with-type-checked (,type ,safe-p)
+ ',(constant-form-value value))))
`(setf (clos-slots-ref .slots. ,i)
- ',(eval value))))
+ (with-type-checked (,type ,safe-p)
+ ',(constant-form-value value)))))
(constant
- `(setf (clos-slots-ref .slots. ,i) ',(eval value))))))
- (class-init-forms
- (loop for (location type value) in class-inits collect
- `(setf (cdr ',location)
- ,(ecase type
- (constant `',(eval value))
- ((param var) `,value)
- (initfn `(funcall ,value)))))))
- (multiple-value-bind (vars bindings)
- (loop for (var . initfn) in (nreverse default-inits)
- collect var into vars
- collect `(,var (funcall ,initfn)) into bindings
- finally (return (values vars bindings)))
- (values bindings vars (nreverse defaulting-initargs)
- `(,@(delete nil instance-init-forms)
- ,@class-init-forms)))))))
-
-;;; Return an alist of lists (KEY LOCATION ...) telling, for each
-;;; key in INITKEYS, which locations the initarg initializes.
-;;; CLASS is the class of the instance being initialized.
+ `(setf (clos-slots-ref .slots. ,i)
+ (with-type-checked (,type ,safe-p)
+ ',(constant-form-value value))))))))
+ ;; we are not allowed to modify QUOTEd locations, so we can't
+ ;; generate code like (setf (cdr ',location) arg). Instead,
+ ;; we have to do (setf (cdr .L0.) arg) and arrange for .L0. to
+ ;; be bound to the location.
+ (multiple-value-bind (names locations class-init-forms)
+ (loop for (location kind value type) in class-inits
+ for i upfrom 0
+ for name = (location-var-name i)
+ collect name into names
+ collect location into locations
+ collect `(setf (cdr ,name)
+ (with-type-checked (,type ,safe-p)
+ ,(case kind
+ (constant `',(constant-form-value value))
+ ((param var) `,value)
+ (initfn `(funcall ,value)))))
+ into class-init-forms
+ finally (return (values names locations class-init-forms)))
+ (multiple-value-bind (vars bindings)
+ (loop for (var . initfn) in (nreverse default-inits)
+ collect var into vars
+ collect `(,var (funcall ,initfn)) into bindings
+ finally (return (values vars bindings)))
+ (values locations names
+ bindings vars
+ (nreverse defaulting-initargs)
+ `(,@(delete nil instance-init-forms)
+ ,@class-init-forms))))))))
+
+;;; Return an alist of lists (KEY (LOCATION . TYPE-SPECIFIER) ...)
+;;; telling, for each key in INITKEYS, which locations the initarg
+;;; initializes and the associated type with the location. CLASS is
+;;; the class of the instance being initialized.
(defun compute-initarg-locations (class initkeys)
(loop with slots = (class-slots class)
for key in initkeys collect
(loop for slot in slots
if (memq key (slot-definition-initargs slot))
- collect (slot-definition-location slot) into locations
+ collect (cons (slot-definition-location slot)
+ (slot-definition-type slot))
+ into locations
else
collect slot into remaining-slots
finally