gt4084c@prism.gatech.EDU (SRINIVASAN,K) (03/19/91)
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. -- SRINIVASAN,K School of Textile Engineering Georgia Tech. uucp: ...!{allegra,amd,hplabs,seismo,ut-ngp}!gatech!prism!gt4084c ARPA: gt4084c@prism.gatech.edu
hall@aplcen.apl.jhu.edu (Marty Hall) (03/20/91)
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))) ))) ;;;======================================================================