🚀 go-pugleaf

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 lisp-script methods referred to are methods for printing
an evaluatable representation of an object - f.i. '(make-instance
'data-item...).'


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.



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

;===============================================

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