; useful stuff for object programming ; filter certain keyword arguments for passing argument list to superclass (DEFUN REMOVE-KEYS (KEYS LIST) (COND ((NULL KEYS) LIST) ((NULL LIST) 'NIL) ((MEMBER (CAR LIST) KEYS) (REMOVE-KEYS (REMOVE (CAR LIST) KEYS) (CDDR LIST))) (T (CONS (CAR LIST) (REMOVE-KEYS KEYS (CDR LIST)))))) ; fix so that classes can be named (requires PNAME ivar in class Class) ; The source files have been modified for PNAME instance variable, ; and printing of class PNAME if it exists. (SEND CLASS :ANSWER :SET-PNAME '(NAME) '((SETF PNAME (STRING NAME)))) ; *SETF* property of SEND is set to allow setting instance variables (setf (get 'send '*setf*) #'(lambda (obj ivar value) (send obj :set-ivar (get ivar 'ivarname) value))) ; (defclass [() [() []]]) ; defclass sets up access methods for all instance and class variables! ; an instance variable can be of form or ( ) ; :ISNEW is automatically defined to accept keyword arguments to overide ; default initialization. (DEFMACRO DEFCLASS (NAME &OPTIONAL IVARS CVARS SUPER &AUX (SYM (GENSYM)) (SYM2 (GENSYM))) ; CIVAR is instance variable list with init values removed (LET ((CIVARS (MAPCAR #'(LAMBDA (X) (IF (CONSP X) (CAR X) X)) IVARS))) `(PROGN ; create class and assign to global variable (SETF ,NAME (SEND CLASS :NEW ',CIVARS ',CVARS ,@(IF SUPER (LIST SUPER) NIL))) ; Set the name ivar of the class (SEND ,NAME :SET-PNAME ',NAME) ; Generate the : and : methods ,@(MAPCAR #'(LAMBDA (ARG) `(SEND ,NAME :ANSWER ,(INTERN (STRCAT ":" (STRING ARG))) 'NIL '(,ARG))) (APPEND CIVARS CVARS)) ; The method needed to set the instance variables (SEND ,NAME :ANSWER :SET-IVAR '(,SYM ,SYM2) '((EVAL (LIST 'SETQ ,SYM (LIST 'QUOTE ,SYM2) )))) ; Set the ivarname property of the : symbols ,@(MAPCAR #'(LAMBDA (ARG) `(SETF (GET ',(INTERN (STRCAT ":" (STRING ARG))) 'IVARNAME) ',ARG)) CIVARS) ; Generate the :ISNEW method (SEND ,NAME :ANSWER :ISNEW '(&REST ,SYM &KEY ,@IVARS) ; first :ISNEW setfs ; for all its declared instance variables '(,@(MAPCAR #'(LAMBDA (ARG) `(SETF (SEND SELF ,(INTERN (STRCAT ":" (STRING ARG)))) ,ARG)) CIVARS) ; then the remaining initialization arguments are ; passed to the superclass. (APPLY #'SEND-SUPER (CONS ':ISNEW (REMOVE-KEYS ',(MAPCAR #'(LAMBDA (ARG) (INTERN (STRCAT ":" (STRING ARG)))) CIVARS) ,SYM))) self))))) ; (defmethod () ) (DEFMACRO DEFMETHOD (CLASS MESSAGE ARGLIST &REST BODY) `(SEND ,CLASS :ANSWER ,MESSAGE ',ARGLIST ',BODY)) ; (definst [...]) (DEFMACRO DEFINST (CLASS NAME &REST ARGS) `(SETF ,NAME (SEND ,CLASS :NEW ,@ARGS))) ; (extensions suggested by Jim Ferrans) (DEFUN CLASSP (NAME) (WHEN (OBJECTP NAME) (EQ (SEND NAME :CLASS) CLASS))) (DEFMETHOD CLASS :SUPERCLASS () SUPERCLASS) (DEFMETHOD CLASS :MESSAGES () MESSAGES) (DEFMETHOD OBJECT :SUPERCLASS () NIL) (DEFMETHOD OBJECT :ISMEMBEROF (CLASS) (EQ (SEND SELF :CLASS) CLASS)) (DEFMETHOD OBJECT :ISKINDOF (CLASS) (DO ((THIS (SEND SELF :CLASS) (SEND THIS :SUPERCLASS))) ((OR (NULL THIS)(EQ THIS CLASS)) (EQ THIS CLASS)))) (DEFMETHOD OBJECT :RESPONDSTO (SELECTOR &AUX TEMP) (DO ((THIS (SEND SELF :CLASS) (SEND THIS :SUPERCLASS))) ((OR (NULL THIS) (SETQ TEMP (NOT (NULL (ASSOC SELECTOR (SEND THIS :MESSAGES)))))) TEMP) (SETF TEMP NIL))) (DEFMETHOD CLASS :IVARS () IVARS) (DEFMETHOD CLASS :PNAME () PNAME) ; :Storeon returns a list that can be executed to re-generate the object. ; It relies on the object's class being created using DEFCLASS, so the ; instance variables can be generated. (DEFMETHOD OBJECT :STOREON (&AUX CLASS IVLIST RES) (SETQ CLASS (SEND SELF :CLASS) IVLIST (DO ((IVARS (SEND CLASS :IVARS) (APPEND (SEND SUPER :IVARS) IVARS)) (SUPER (SEND CLASS :SUPERCLASS) (SEND SUPER :SUPERCLASS))) ((EQ SUPER OBJECT) IVARS)) RES (MAPCAN #'(LAMBDA (X) (LET ((TEMP (INTERN (CONCATENATE 'STRING ":" (STRING X))))) (LIST TEMP (LET ((Y (SEND SELF TEMP))) (IF (AND Y (OR (SYMBOLP Y) (CONSP Y))) (LIST 'QUOTE Y) Y))))) IVLIST)) (APPEND (LIST 'SEND (MAKE-SYMBOL (SEND CLASS :PNAME)) ':NEW) RES)) ; For classes we must use a different tact. ; We will return a PROGN that uses SENDs to create the class and any methods. ; It also assumes the global environment. None of the DEFxxx functions ; are needed to do this. ; because of the subrs used in messages, :storeon cannot be used to ; generate a reconstructable copy of classes Object and Class. ; Class variables are not set, because there are no class methods in XLISP ; to do this (one would have to create an instance, and send messages to ; the instance, and I feel that is going too far). (DEFMETHOD CLASS :STOREON (&AUX (CLASSNAME (INTERN PNAME))) (NCONC (LIST 'PROGN) (LIST (LIST 'SETQ CLASSNAME (LIST 'SEND 'CLASS :NEW IVARS CVARS (IF SUPERCLASS (INTERN (SEND SUPERCLASS :PNAME)) NIL)))) (LIST (LIST 'SEND CLASSNAME :SET-PNAME PNAME)) (MAPCAR #'(LAMBDA (MESS &AUX (VAL (IF (EQ 'CLOSURE (TYPE-OF (CDR MESS))) (GET-LAMBDA-EXPRESSION (CDR MESS)) (LIST NIL NIL MESS)))) (LIST 'SEND CLASSNAME :ANSWER (FIRST MESS) (LIST 'QUOTE (CDADR VAL)) (LIST 'QUOTE (CDDR VAL)))) MESSAGES)))