[armedbear-devel] Problem with defstruct accessor functions and included structures in combination with conc-names

[Ralf Moeller]

The following file causes a problem in ABCL (1.1.0-dev-svn-14041) when compiled (!) and loaded.

(in-package cl-user)

(defstruct a (s1 nil))

(defstruct (b (:include a) (:conc-name foo-)) (s2 nil))

(defstruct (c (:include a) (:conc-name foo-)) (s3 nil))

(defun test ()
  (let ((x (make-b :s1 1 :s2 2)))
    (foo-s1 x)))

CL-USER(4): (test)
#<THREAD "interpreter" {2EF7D41F}>: Debugger invoked on condition of type SIMPLE-TYPE-ERROR
  The value #<B {564434F7}> is not of type C.
Restarts:
  0: TOP-LEVEL Return to top level.
[1] CL-USER(6): (lisp-implementation-version)
"1.1.0-dev-svn-14041"
[1] CL-USER(7): 

The problem is that the defstruct declaration for c "overwrites" the accessor foo-s1 generated by defstruct b.
If foo-s1 is called for a b instance, the type assertions introduced by define-reader (and define-writer, see the
ABCL implementation for defstruct) cause the error described above.

The code above runs fine in ACL, Lispworks, SBCL, and other Lisps.
I had to remove the generation of type assertions in define-reader and define-accessor (see below) 
to make the code work in ABCL. Note, however, that there is no type checking pursued with the code below.
Thus, a better solution might be developed.

Regards,
Ralf Moeler
http://www.sts.tu-harburg.de/~r.f.moeller/


(defun define-reader (slot)
  (let ((accessor-name (dsd-reader slot))
        (index (dsd-index slot))
        (type (dsd-type slot)))
    (cond ((eq *dd-type* 'list)
           `((declaim (ftype (function * ,type) ,accessor-name))
             (setf (symbol-function ',accessor-name)
                   (make-list-reader ,index))))
          ((or (eq *dd-type* 'vector)
               (and (consp *dd-type*) (eq (car *dd-type*) 'vector)))
           `((declaim (ftype (function * ,type) ,accessor-name))
             (setf (symbol-function ',accessor-name)
                   (make-vector-reader ,index))
             (define-source-transform ,accessor-name (instance)
               `(aref ,instance ,,index))))
          (t
           `((declaim (ftype (function * ,type) ,accessor-name))
             (setf (symbol-function ',accessor-name)
                   (make-structure-reader ,index ',*dd-name*))
             (define-source-transform ,accessor-name (instance)
               ,(if (eq type 't)
                    ``(structure-ref ,instance ,,index)
                    ``(the ,',type
                        (structure-ref ,instance ,,index)))))))))


(defun define-writer (slot)
  (let ((accessor-name (dsd-reader slot))
        (index (dsd-index slot)))
    (cond ((eq *dd-type* 'list)
           `((setf (get ',accessor-name 'setf-function)
                   (make-list-writer ,index))))
          ((or (eq *dd-type* 'vector)
               (and (consp *dd-type*) (eq (car *dd-type*) 'vector)))
           `((setf (get ',accessor-name 'setf-function)
                   (make-vector-writer ,index))
             (define-source-transform (setf ,accessor-name) (value instance)
               `(aset ,instance ,,index ,value))))
          (t
           `((setf (get ',accessor-name 'setf-function)
                   (make-structure-writer ,index ',*dd-name*))
             (define-source-transform (setf ,accessor-name) (value instance)
               `(structure-set ,instance ,,index ,value)))))))