In response to a previous post by Nicholas Roquette, I am posting this clip of code for my solution to the problem of providing dynamic extension of class definitions.
The code is in two parts: design-object-class and dynamic-design-object-class
Some of the code specifically mentions objects of the class 'data-item. These are the domain specific objects that I put into the initforms of the classes. Their definitions exist elsewhere, but are not needed here. The code can be easily modified to accomodate other types of objects.
The :after methods on the dynamic-design-object-class may seem a bit confusing.
These are needed because overridden slots do not get updated by update-instance-for-redefined-class (possibly an error in CLOS).
Any questions or comments are eagerly sought.
ps - the lisp-script methods are for writing an evaluatable 'make-instance'
form of the data item objects
Gary Hooyman
Department of Civil Engineering
Carnegie Mellon University
Pittsburgh, PA 15201
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;;;;; ;;;;;; CARNEGIE MELLON UNIVERSITY ;;;;;; ;;;;;; DEPARTMENT OF CIVIL ENGINEERING ;;;;;;
;;;;;; COMPUTER-AIDED ENGINEERING GROUP ;;;;;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;;;;; FILE.... : DESIGN-OBJECT-CLASS.LISP ;;;;;;
;;;;;; AUTHOR.. : MAHER HAKIM & GARY HOOYMAN ;;;;;; ;;;;;; CREATED. : JULY 1992 ;;;;;; ;;;;;; ABSTRACT : This file contains the design object class definition for ;;;;;; the STandards REPresentation and Processing ENvironment ;;;;;;
"STREPPEN" ;;;;;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
(defclass design-object-class ()
((satisfied :accessor satisfied
:allocation :instance
:initform
(make-instance 'constant :name
'satisfied :value 'satisfied
:defined-in-class 'design-object-class))
(not-satisfied :accessor not-satisfied
:allocation :instance
:initform
(make-instance 'constant :name
'not-satisfied :value 'not-satisfied
:defined-in-class 'design-object-class))
(not-applicable :accessor not-applicable
:allocation :instance
:initform
(make-instance 'constant :name
'not-applicable :value 'not-applicable
:defined-in-class 'design-object-class)))
(:documentation "the root class for all static design object classes in
STREPPEN"))
;===============================================================================(defmethod class-name ((self design-object-class))
"return the class name symbol"
(clos:class-name (class-of self)))
;================================================================================
(defmethod initialize-instance :after
((self design-object-class) &rest initargs)
"point each slot object to the new instance"
(loop for slot-name in (mapcar #'clos:slot-definition-name
(clos:class-slots (class-of self)))
do (eval (list 'setf (list 'parent-object (list slot-name self))
self))))
;================================================================================
(defmethod defclass-form-slot-definitions ((self design-object-class))
"write the defclass form of the slot definitions"
(mapcar #'(lambda (x-slot-def)
(append
(list (clos:slot-definition-name x-slot-def))
(list :allocation
(clos:slot-definition-allocation x-slot-def))
(mapcan #'(lambda (x-slot-initarg)
(list :initarg x-slot-initarg))
(clos:slot-definition-initargs x-slot-def))
(list :initform
(if (typep ; if the initform evaluates to a data-item
(eval
(list (clos:slot-definition-name x-slot-def)
self))
'data-item)
(lisp-script ; then make clos printed form of the
(eval (list ; object in the slot
; (assures an updated version)
(clos:slot-definition-name x-slot-def)
self)))
(clos:slot-definition-initform x-slot-def)))
; else, reassert the previous initform
(mapcan #'(lambda (x-slot-reader)
(list :reader x-slot-reader))
(clos:slot-definition-readers x-slot-def))
(mapcan #'(lambda (x-slot-writer-method)
(list :writer x-slot-writer-method))
(clos:slot-definition-writers x-slot-def))))
(clos:class-direct-slots (class-of self))))
;===============================================================================(defmethod lisp-script-defclass-form ((self design-object-class))
"returns a written representation of the defclass form of the instance"
(list 'defclass (clos:class-name (class-of self))
(mapcar #'clos:class-name
(clos:class-direct-superclasses
(class-of self)))
(defclass-form-slot-definitions self)
(list ':documentation (documentation (class-of self)))))
;===============================================================================(defmethod list-all-di-names ((self design-object-class))
"returns a list of all the slot names of the instance"
(mapcar #'clos:slot-definition-name
(clos:class-slots (class-of self))))
;===============================================================================(defmethod list-all-di-objects ((self design-object-class))
"returns a list of all the slot objects of the instance"
(mapcar #'(lambda (x-di-name)
(eval (list x-di-name self)))
(list-all-di-names self)))
;===============================================================================(defmethod list-local-di-names ((self design-object-class))
"returns a list of the locally defined slot names of the instance"
(mapcar #'clos:slot-definition-name
(clos:class-direct-slots (class-of self))))
;===============================================================================(defmethod list-local-di-objects ((self design-object-class))
"returns a list of the locally defined slot objects of the instance"
(mapcar #'(lambda (x-di-name)
(eval (list x-di-name self)))
(list-local-di-names self)))
;===============================================================================
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;;;;; ;;;;;; CARNEGIE MELLON UNIVERSITY ;;;;;; ;;;;;; DEPARTMENT OF CIVIL ENGINEERING ;;;;;;
;;;;;; COMPUTER-AIDED ENGINEERING GROUP ;;;;;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;;;;; FILE.... : DYNAMIC-DESIGN-OBJECT-CLASS.LISP ;;;;;;
;;;;;; AUTHOR.. : MAHER HAKIM & GARY HOOYMAN ;;;;;; ;;;;;; CREATED. : JULY 1992 ;;;;;; ;;;;;; ABSTRACT : This file contains the dynamic design object class ;;;;;; definition for the STandards REPresentation and Processing ;;;;;;
ENvironment "STREPPEN" ;;;;;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
(defclass dynamic-design-object-class (design-object-class)
()
(:documentation "a mixin for design object class to support the dynamic
class definition in STREPPEN"))
;================================================================================
;; this function asserts a class definition of a class that is
;; in the design-object-class-hierarchy
(defun make-dynamic-design-object-class (name &key
(parents '(dynamic-design-object-class))
(slot-definitions '())
(documentation "nil"))
(eval
(list 'defclass name
parents
slot-definitions
(list :documentation documentation))))
;================================================================================
;; this method will add any named dependents to the class as
;; slots if they do not exist already
(defmethod add-ingredients-to-di :before
(ingredients di (self dynamic-design-object-class))
(loop for ingredient in ingredients
when (not (slot-exists-p self ingredient))
do (add-di ingredient 'data-item self)))
;================================================================================
(defmethod add-di (name type (self dynamic-design-object-class))
"add a slot filled with a data item of the name and type specified"
(eval
(list 'defclass (class-name (class-of self))
(mapcar #'clos:class-name
(clos:class-direct-superclasses
(class-of self)))
(append (defclass-form-slot-definitions self)
(list (list name
:initarg
(read-from-string
(concatenate 'string
":" (write-to-string name)))
:accessor name
:initform (make-instance type
:name name :defined-in-class
(class-name (class-of self))))))
(list :documentation (documentation (class-of self))))))
; will signal an error if the slot name is already in use locally
;================================================================================
; sets the parent object of the newly added data-item and
; writes an :after method for (setf slot-name) that assures that
; any data-item put into the slot maintains the appropriate name,
; parent object, and the name of the class defined in
(defmethod add-di :after (name type (self dynamic-design-object-class))
"for the new slot, insert the new initform into the prototype instance
and define a setf method to assure the slot object maintains the proper name,
parent-object, and class-defined-in"
(eval (list 'defmethod (list 'setf name) :after
(list 'arg (list 'self (class-name self)))
(list 'if (list 'typep 'arg (quote 'data-item))
(list 'progn
(list 'setf (list 'slot-value
(list name 'self) (quote 'name))
(list 'quote name))
(list 'setf (list 'parent-object 'arg) 'self)
(list 'setf (list 'defined-in-class 'arg)
(list 'quote (class-name self)))))))
(eval (list 'setf (list name self)
(list name (list 'make-instance
(list 'quote (class-name self)))))))
;================================================================================
(defmethod remove-di (name (self dynamic-design-object-class))
"reassert the defclass without the specified slot"
(eval
(list 'defclass (class-name (class-of self))
(mapcar #'clos:class-name
(clos:class-direct-superclasses
(class-of self)))
(remove-if #'(lambda (x-slot-def)
(equal (first x-slot-def) name))
(defclass-form-slot-definitions self))
(list :documentation (documentation (class-of self))))))
(defmethod remove-di :after (name (self dynamic-design-object-class))
"for an overridden slot, remove the local setf method and retrieve the
inherited slot initform"
(if (member name (list-all-di-names self))
(progn
(eval
(list 'defmethod (list 'setf name) :after
(list 'arg (list 'self (class-name self)))))
(eval (list 'setf (list name self)
(list name (list 'make-instance
(list 'quote (class-name self)))))))))
;================================================================================
(defmethod set-class-parents
(parents-list (self dynamic-design-object-class))
"redefine the class with a new set of parents"
(if (null parents-list)
(setq parents-list (list 'dynamic-design-object-class)))
(eval (list 'defclass (class-name (class-of self))
parents-list
(defclass-form-slot-definitions self)
(list :documentation (documentation (class-of self))))))
;================================================================================
(defmethod set-class-documentation
(documentation-string (self dynamic-design-object-class))
"set the documentation string of the class"
(setf (documentation (class-of self)) documentation-string))
;================================================================================
(defmethod class-documentation ((self dynamic-design-object-class))
"return the documentation string of the class"
(documentation (class-of self)))