🚀 go-pugleaf

In article <24620@hydra.gatech.EDU> gt4084c@prism.gatech.EDU (SRINIVASAN,K) 
writes:
>
> Has anybody written a macro which expands into a call to defclass and also 
> creates a constructor function and tailored descriptor function?  Any hints 
> or code will be very much appreciated. 

Here is a simple one. I am by no means a CLOS hacker; when we started my
current program (in the pre CLOS/CLIM days) we needed transportable objects 
and graphics, so have been using KEE. Anyhow, I am sure there are plenty of
whizzy ones out there, but here is a vanilla one.

Pardon the odd capitalization; I have a long habit of capitalizing
functions/vars I write myself in order to distinguish them from predefined
ones when I go back later and look at the code.

Feel free to do whatever you want with the code.

					- Marty Hall
------------------------------------------------------
hall@aplcen.apl.jhu.edu, hall%aplcen@jhunix.bitnet, ..uunet!aplcen!hall
Artificial Intelligence Lab, AAI Corp, PO Box 126, Hunt Valley, MD 21030

(setf (need-p 'disclaimer) NIL)

============================== Cut Here ==============================

;;;======================================================================
;;; Lets you type 
;;;       (define-class Foo (Bar Baz) (A B) (C D)) if you want
;;;       (defclass Foo (Bar Baz)
;;;         ((A :accessor A :initform B :initarg :A)
;;;          (C :accessor C :initform D :initarg :C)))
;;;
;;; I was lazy: B/D cannot be lexical vars.
;;;
;;; 12/90 Marty Hall

(defmacro Define-Class (Object-Name Super-Class-List &rest Slot-Value-Pairs)
  `(defclass ,Object-Name ,Super-Class-List
     ,(mapcar #'Expand-Slot-Name-Value-Pair Slot-Value-Pairs)) )

;;;======================================================================
;;; (A B) --> (A :accessor A :initform B :initarg :A)
;;;
;;; 12/90 Marty Hall

(defun Expand-Slot-Name-Value-Pair (Name-Value-Pair)
  (let ((Slot-Name (first Name-Value-Pair))
	(Slot-Value (eval (second Name-Value-Pair))))
    (list Slot-Name
	  :accessor Slot-Name
	  :initform Slot-Value
	  :initarg (read-from-string 
		    (concatenate 'string ":" (string Slot-Name))) )))

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