Won't use col-type when retrieve-dao for inherted table

[C-Entropy]

Sample

(deftable file ()
  ((file-name :col-type (:varchar 260)
	      :initarg :file-name
	      :accessor file-name)))

(deftable foo ()
  ((file-dao :col-type file
	     :initarg :file-dao
	     :accessor file-dao)))

(deftable foo-1 (foo)
  ())

(mapc #'ensure-table-exists
      (list 'file 'foo 'foo-1))

(create-dao 'file :file-name "test-1")
(create-dao 'file :file-name "test-2")

;;foo
(create-dao 'foo :file-dao (find-dao 'file :file-name "test-1"))
(create-dao 'foo :file-dao (find-dao 'file :file-name "test-2"))

(retrieve-dao 'foo :file-dao (find-dao 'file :file-name "test-2"))
==>(#<FOO {10063CB2E3}>), #<SXQL-STATEMENT: SELECT * FROM foo WHERE (file_dao_id = 2)>

;;foo-1
(create-dao 'foo-1 :file-dao (find-dao 'file :file-name "test-1"))
(create-dao 'foo-1 :file-dao (find-dao 'file :file-name "test-2"))

(retrieve-dao 'foo-1 :file-dao (find-dao 'file :file-name "test-2"))
==> (#<FOO-1 {10055EB723}> #<FOO-1 {10055EC7E3}>), #<SXQL-STATEMENT: SELECT * FROM foo_1>

as you can see, retrieve-dao for foo and foo-1 is different. I want foo-1 to work like foo, how to achieve this? Please.

[C-Entropy]

It turns out that (slot-value 'foo-1 'parent-column-map), (see here) doesn't have file-dao. Is this a design on purpose?

[fukamachi]

Seems to be a bug.

[C-Entropy]

Here is my simple work around @fukamachi

(defun add-referencing-slots (initargs)
  (let ((parent-column-map NIL))
    (loop for column in (getf initargs :direct-superclasses)
	  when (and (not (eq 'standard-class (type-of column)))
		    (slot-value column 'parent-column-map))
	    do (alexandria:unionf parent-column-map
				  (alexandria:hash-table-alist (slot-value column 'parent-column-map))))
    (setf parent-column-map (alexandria:alist-hash-table parent-column-map :test 'eq))
    (setf (getf initargs :direct-slots)
          (loop for column in (getf initargs :direct-slots)
                for (col-type not-null) = (multiple-value-list (parse-col-type (getf column :col-type)))

                if (typep col-type '(and symbol (not null) (not keyword)))
                  append
                  (let* ((name (getf column :name))
                         ;; FIXME: find-class raises an error if the class is this same class or not defined yet.
                         (rel-class (find-class col-type))
                         (pk-names (table-primary-key rel-class)))
                    (unless pk-names
                      (error "Foreign class ~S has no primary keys."
                             (class-name rel-class)))
                    (rplacd (cdr column)
                            `(:ghost t ,@(cddr column)))

                    (cons column
                          (mapcar (lambda (pk-name)
                                    (let ((rel-column-name (rel-column-name name pk-name)))
                                      (setf (gethash rel-column-name parent-column-map) name)
                                      `(:name ,rel-column-name
                                        :initargs (,(intern (symbol-name rel-column-name) :keyword))
                                        :col-type ,(if not-null
                                                       col-type
                                                       `(or ,col-type :null))
                                        :primary-key ,(getf column :primary-key)
                                        :references (,col-type ,pk-name))))
                                  pk-names)))
                collect column))
    (values initargs parent-column-map)))

(defmethod initialize-instance :around ((class table-class) &rest initargs)
  (multiple-value-bind (initargs parent-column-map)
      (add-referencing-slots initargs)
    (let ((class (apply #'call-next-method class initargs)))
      (setf (slot-value class 'parent-column-map)
	    (alexandria:alist-hash-table
	     (union (alexandria:hash-table-alist (slot-value class 'parent-column-map))
		    (alexandria:hash-table-alist parent-column-map))))
      (expand-relational-keys class 'primary-key)
      (expand-relational-keys class 'unique-keys)
      (expand-relational-keys class 'keys)
      class)))

Should work with the simplest case.