Hello, (hopefully this comes out as normal text)
Any ideas what is going wrong in CMUCL in the follwing?
(works in other lisps)
Loading or evaluating the following code produces the error
The slot PCL:CLASS-PRECEDENCE-LIST is unbound in the object
#<Standard-Class FAMILY-VALUES-SORTED {996BACD}>
(the back trace reveals that the error occurs when the
"(defmethod shared-initialize :after" attempts to add this method
to the class)
Code: (note: code is copyright Kenny Tilton)
(defmodel family-values-sorted (familyvalues)
((sortedkids :cell t :initarg :sortedkids :accessor sortedkids
:initform nil)
(sortmap :cell t :initform (cv nil) :initarg :sortmap :accessor sortmap)
)
(:default-initargs
:kids (c? (assert (listp (kidvalues self)))
(mapsort (^sortmap)
(thekids
(mapcar (lambda (kidvalue)
(trc "making kid" kidvalue)
(or (find kidvalue (c-value c) :key
(kvkey self) :test (kvkeytest self))
(trc nil "familyvalues forced to
make new kid" self .cache. kidvalue)
(funcall (kidfactory self) self
kidvalue)))
(^kidvalues)))))))
The macro defmodel has the following definition
(defmacro defmodel (class directsupers slotspecs &rest options)
`(progn
(eval-when (:compile-toplevel :load-toplevel)
(setf (get ',class :cell-defs) nil))
;
; define slot macros before class so they can appear in initforms and
default-initargs
;
,@(mapcar (lambda (slotspec)
(destructuring-bind
(slotname &rest slotargs
&key cell accessor reader
&allow-other-keys)
slotspec
(declare (ignorable slotargs))
(when cell
(let* ((readerfn (or reader accessor))
(deriverfn (intern$ "^" (symbol-name readerfn)))
)
;
; may as well do this here...
;
(trc nil "slot, deriverfn would be" slotname
deriverfn)
`(eval-when (:compile-toplevel :load-toplevel)
(setf (md-slot-cell-type ',class ',slotname)
,cell)
(unless (macro-function ',deriverfn)
(defmacro ,deriverfn (&optional (model 'self)
synfactory)
`(let ((*synapse-factory* ,synfactory))
(,',readerfn ,model))))
)
))
))
slotspecs)
;
; ------- defclass --------------- (^slot-value ,model ',',slotname)
;
(defclass ,class ,(or directsupers '(model-object));; now we can def
the class
,(mapcar (lambda (s)
(list* (car s)
(let ((ias (cdr s)))
(remf ias :cell)
ias))) slotspecs)
(:documentation
,@(or (cdr (find :documentation options :key #'car))
'("chya")))
(:default-initargs ;; nil ok and needed: acl oddity in re not
clearing d-i's sans this
,@(cdr (find :default-initargs options :key #'car)))
(:metaclass ,(or (find :metaclass options :key #'car)
'standard-class)))
(defmethod shared-initialize :after ((self ,class) slot-names &rest
iargs)
(declare (ignore slot-names iargs))
(assert (typep self 'model-object) () "If no superclass of ~a
inherits directly
or indirectly from model-object, model-object must be included as a direct
super-class in
the defmodel form for ~a" ',class ',class))
;
; slot accessors once class is defined...
;
,@(mapcar (lambda (slotspec)
(destructuring-bind
(slotname &rest slotargs
&key cell accessor reader writer
&allow-other-keys)
slotspec
(declare (ignorable slotargs))
(when cell
(let* ((readerfn (or reader accessor))
(writerfn (or writer accessor))
)
(setf (md-slot-cell-type class slotname) cell)
`(progn
,(when readerfn
`(defmethod ,readerfn ((self ,class))
(md-slot-value self ',slotname)))
,(when writerfn
`(defmethod (setf ,writerfn) (new-value (self
,class))
(setf (md-slot-value self ',slotname)
new-value)))
)
))
))
slotspecs)))
Hello, (hopefully this comes out as normal text)
Any ideas what is going wrong in CMUCL in the follwing?
(works in other lisps)
Loading or evaluating the following code produces the error
The slot PCL:CLASS-PRECEDENCE-LIST is unbound in the object
#<Standard-Class FAMILY-VALUES-SORTED {996BACD}>
(the back trace reveals that the error occurs when the
"(defmethod shared-initialize :after" attempts to add this method
to the class)
Code: (note: code is copyright Kenny Tilton)
(defmodel family-values-sorted (familyvalues)
((sortedkids :cell t :initarg :sortedkids :accessor sortedkids
:initform nil)
(sortmap :cell t :initform (cv nil) :initarg :sortmap :accessor sortmap)
)
(:default-initargs
:kids (c? (assert (listp (kidvalues self)))
(mapsort (^sortmap)
(thekids
(mapcar (lambda (kidvalue)
(trc "making kid" kidvalue)
(or (find kidvalue (c-value c) :key
(kvkey self) :test (kvkeytest self))
(trc nil "familyvalues forced to
make new kid" self .cache. kidvalue)
(funcall (kidfactory self) self
kidvalue)))
(^kidvalues)))))))
The macro defmodel has the following definition
(defmacro defmodel (class directsupers slotspecs &rest options)
`(progn
(eval-when (:compile-toplevel :load-toplevel)
(setf (get ',class :cell-defs) nil))
;
; define slot macros before class so they can appear in initforms and
default-initargs
;
,@(mapcar (lambda (slotspec)
(destructuring-bind
(slotname &rest slotargs
&key cell accessor reader
&allow-other-keys)
slotspec
(declare (ignorable slotargs))
(when cell
(let* ((readerfn (or reader accessor))
(deriverfn (intern$ "^" (symbol-name readerfn)))
)
;
; may as well do this here...
;
(trc nil "slot, deriverfn would be" slotname
deriverfn)
`(eval-when (:compile-toplevel :load-toplevel)
(setf (md-slot-cell-type ',class ',slotname)
,cell)
(unless (macro-function ',deriverfn)
(defmacro ,deriverfn (&optional (model 'self)
synfactory)
`(let ((*synapse-factory* ,synfactory))
(,',readerfn ,model))))
)
))
))
slotspecs)
;
; ------- defclass --------------- (^slot-value ,model ',',slotname)
;
(defclass ,class ,(or directsupers '(model-object));; now we can def
the class
,(mapcar (lambda (s)
(list* (car s)
(let ((ias (cdr s)))
(remf ias :cell)
ias))) slotspecs)
(:documentation
,@(or (cdr (find :documentation options :key #'car))
'("chya")))
(:default-initargs ;; nil ok and needed: acl oddity in re not
clearing d-i's sans this
,@(cdr (find :default-initargs options :key #'car)))
(:metaclass ,(or (find :metaclass options :key #'car)
'standard-class)))
(defmethod shared-initialize :after ((self ,class) slot-names &rest
iargs)
(declare (ignore slot-names iargs))
(assert (typep self 'model-object) () "If no superclass of ~a
inherits directly
or indirectly from model-object, model-object must be included as a direct
super-class in
the defmodel form for ~a" ',class ',class))
;
; slot accessors once class is defined...
;
,@(mapcar (lambda (slotspec)
(destructuring-bind
(slotname &rest slotargs
&key cell accessor reader writer
&allow-other-keys)
slotspec
(declare (ignorable slotargs))
(when cell
(let* ((readerfn (or reader accessor))
(writerfn (or writer accessor))
)
(setf (md-slot-cell-type class slotname) cell)
`(progn
,(when readerfn
`(defmethod ,readerfn ((self ,class))
(md-slot-value self ',slotname)))
,(when writerfn
`(defmethod (setf ,writerfn) (new-value (self
,class))
(setf (md-slot-value self ',slotname)
new-value)))
)
))
))
slotspecs)))
_________________________________________________________________
Tired of spam? Get advanced junk mail protection with MSN 8.
http://join.msn.com/?page=features/junkmail
