- (setf (elt vals (dsd-index dsd)) val))
-
- `(defun ,cons-name ,arglist
- (declare ,@(mapcar #'(lambda (var type) `(type ,type ,var))
- vars types))
- (list ,@vals))))
-(defun create-structure-constructor (dd cons-name arglist vars types values)
- (let* ((temp (gensym))
- (raw-index (dd-raw-index dd))
- (n-raw-data (when raw-index (gensym))))
- `(defun ,cons-name ,arglist
- (declare ,@(mapcar #'(lambda (var type) `(type ,type ,var))
- vars types))
- (let ((,temp (truly-the ,(dd-name dd)
- (%make-instance ,(dd-length dd))))
- ,@(when n-raw-data
- `((,n-raw-data
- (make-array ,(dd-raw-length dd)
- :element-type '(unsigned-byte 32))))))
- (setf (%instance-layout ,temp)
- (%delayed-get-compiler-layout ,(dd-name dd)))
- ,@(when n-raw-data
- `((setf (%instance-ref ,temp ,raw-index) ,n-raw-data)))
- ,@(mapcar (lambda (dsd value)
- ;; (Note that we can't in general use the ordinary
- ;; slot accessor function here because the slot
- ;; might be :READ-ONLY.)
- `(,(slot-setter-lambda-form dd dsd) ,value ,temp))
- (dd-slots dd)
- values)
- ,temp))))
+ (setf (elt vals (dsd-index dsd))
+ (if (eq val '.do-not-initialize-slot.) 0 val)))
+ (values
+ `(defun ,cons-name ,arglist
+ ,@(when decls `((declare ,@decls)))
+ (list ,@vals))
+ `(sfunction ,ftype-arglist list))))
+(defun create-structure-constructor (dd cons-name arglist ftype-arglist decls values)
+ (values
+ ;; The difference between the two implementations here is that on all
+ ;; platforms we don't have the appropriate RAW-INSTANCE-INIT VOPS, which
+ ;; must be able to deal with immediate values as well -- unlike
+ ;; RAW-INSTANCE-SET VOPs, which never end up seeing immediate values. With
+ ;; some additional cleverness we might manage without them and just a single
+ ;; implementation here, though -- figure out a way to ensure that on those
+ ;; platforms we always still get a non-immediate TN in every case...
+ ;;
+ ;; Until someone does that, this means that instances with raw slots can be
+ ;; DX allocated only on platforms with those additional VOPs.
+ #!+raw-instance-init-vops
+ (let* ((slot-values nil)
+ (slot-specs
+ (mapcan (lambda (dsd value)
+ (unless (eq value '.do-not-initialize-slot.)
+ (push value slot-values)
+ (list (list* :slot (dsd-raw-type dsd) (dsd-index dsd)))))
+ (dd-slots dd)
+ values)))
+ `(defun ,cons-name ,arglist
+ ,@(when decls `((declare ,@decls)))
+ (%make-structure-instance-macro ,dd ',slot-specs ,@(reverse slot-values))))
+ #!-raw-instance-init-vops
+ (let ((instance (gensym "INSTANCE")) slot-values slot-specs raw-slots raw-values)
+ (mapc (lambda (dsd value)
+ (unless (eq value '.do-not-initialize-slot.)
+ (let ((raw-type (dsd-raw-type dsd)))
+ (cond ((eq t raw-type)
+ (push value slot-values)
+ (push (list* :slot raw-type (dsd-index dsd)) slot-specs))
+ (t
+ (push value raw-values)
+ (push dsd raw-slots))))))
+ (dd-slots dd)
+ values)
+ `(defun ,cons-name ,arglist
+ ,@(when decls`((declare ,@decls)))
+ ,(if raw-slots
+ `(let ((,instance (%make-structure-instance-macro ,dd ',slot-specs ,@slot-values)))
+ ,@(mapcar (lambda (dsd value)
+ ;; (Note that we can't in general use the
+ ;; ordinary named slot setter function here
+ ;; because the slot might be :READ-ONLY, so we
+ ;; whip up new LAMBDA representations of slot
+ ;; setters for the occasion.)
+ `(,(slot-setter-lambda-form dd dsd) ,value ,instance))
+ raw-slots
+ raw-values)
+ ,instance)
+ `(%make-structure-instance-macro ,dd ',slot-specs ,@slot-values))))
+ `(sfunction ,ftype-arglist ,(dd-name dd))))