>>>>> "Albert" == Albert Reiner <[EMAIL PROTECTED]> writes:
Albert> Hi,
Albert> using the CMU Common Lisp Snapshot 2005-11 (19C) on Linux x86, I get
Albert> undesirable results for defstructs with b-o-a constructors like the
Albert> following:
Albert> (defstruct (foobar
Albert> (:constructor make-foobar
Albert> (xxx
Albert> &key (aaa nil) (bbb nil)
Albert> &aux
Albert> (foobar-data xxx)
Albert> (aaa (or aaa
Albert> (getf foobar-data :aaa)
Albert> 1))
Albert> (bbb (or bbb
Albert> (getf foobar-data :bbb)
Albert> (1+ aaa))))))
Albert> (aaa (required-argument) :type fixnum)
Albert> (bbb (required-argument) :type fixnum))
Try the following fix. The macroexpansion for the constructor
becomes:
(DEFUN MAKE-FOOBAR
(XXX
&KEY (AAA NIL) (BBB NIL)
&AUX (FOOBAR-DATA XXX) (AAA (OR AAA (GETF FOOBAR-DATA :AAA) 1))
(BBB (OR BBB (GETF FOOBAR-DATA :BBB) (1+ AAA))))
(CHECK-TYPE XXX T)
(CHECK-TYPE AAA FIXNUM)
(CHECK-TYPE BBB FIXNUM)
(CHECK-TYPE FOOBAR-DATA T)
(CHECK-TYPE AAA FIXNUM)
(CHECK-TYPE BBB FIXNUM)
(LET ((#:G12589 (TRULY-THE FOOBAR (KERNEL:%MAKE-INSTANCE 3))))
(SETF (KERNEL:%INSTANCE-LAYOUT #:G12589)
(KERNEL::%GET-COMPILER-LAYOUT FOOBAR))
(SETF (KERNEL:%INSTANCE-REF #:G12589 1) AAA)
(SETF (KERNEL:%INSTANCE-REF #:G12589 2) BBB)
#:G12589))
Your tests work, and if, say, aaa is initialized to something other
than a fixnum, you get a type error.
Ray
(defun create-structure-constructor
(defstruct cons-name arglist vars types values)
(let* ((temp (gensym))
(raw-index (dd-raw-index defstruct))
(n-raw-data (when raw-index (gensym))))
`(defun ,cons-name ,arglist
,@(mapcar #'(lambda (var type)
`(check-type ,var ,type))
vars types)
(let ((,temp (truly-the ,(dd-name defstruct)
(%make-instance ,(dd-length defstruct))))
,@(when n-raw-data
`((,n-raw-data
(make-array ,(dd-raw-length defstruct)
:element-type '(unsigned-byte 32))))))
(setf (%instance-layout ,temp)
(%get-compiler-layout ,(dd-name defstruct)))
,@(when n-raw-data
`((setf (%instance-ref ,temp ,raw-index) ,n-raw-data)))
,@(mapcar #'(lambda (dsd value)
(multiple-value-bind
(accessor index data)
(slot-accessor-form defstruct dsd temp n-raw-data)
`(setf (,accessor ,data ,index) ,value)))
(dd-slots defstruct)
values)
,temp))))
