Re: defstruct with by-order-of-argument constructor

>>>>> "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))))