home *** CD-ROM | disk | FTP | other *** search
/ The Atari Compendium / The Atari Compendium (Toad Computers) (1994).iso / files / prgtools / langs / xlisp2.1 / xldist01.zoo / lsp / classes.lsp < prev    next >
Encoding:
Text File  |  1990-11-09  |  5.9 KB  |  207 lines
  1. ; useful stuff for object programming
  2.  
  3. ; filter certain keyword arguments for passing argument list to superclass
  4. (DEFUN REMOVE-KEYS (KEYS LIST)
  5.     (COND ((NULL KEYS) LIST)
  6.       ((NULL LIST) 'NIL)
  7.       ((MEMBER (CAR LIST) KEYS)
  8.        (REMOVE-KEYS (REMOVE (CAR LIST) KEYS) (CDDR LIST)))
  9.       (T (CONS (CAR LIST) (REMOVE-KEYS KEYS (CDR LIST))))))
  10.  
  11.  
  12. ; fix so that classes can be named (requires PNAME ivar in class Class)
  13. ;  The source files have been modified for PNAME instance variable,
  14. ;  and printing of class PNAME if it exists.
  15.  
  16. (SEND CLASS :ANSWER :SET-PNAME
  17.       '(NAME)
  18.       '((SETF PNAME (STRING NAME))))
  19.  
  20.  
  21. ; *SETF* property of SEND is set to allow setting instance variables
  22. (setf (get 'send '*setf*) 
  23.       #'(lambda (obj ivar value) 
  24.         (send obj :set-ivar (get ivar 'ivarname) value)))
  25.  
  26. ; (defclass <classname> [(<instvars>) [(<classvars>) [<superclass>]]])
  27. ; defclass sets up access methods for all instance and class variables!
  28. ; an instance variable can be of form <ivar>  or (<ivar> <init>)
  29. ; :ISNEW is automatically defined to accept keyword arguments to overide
  30. ; default initialization.
  31.  
  32. (DEFMACRO DEFCLASS (NAME &OPTIONAL IVARS CVARS SUPER 
  33.              &AUX (SYM (GENSYM)) (SYM2 (GENSYM)))
  34. ; CIVAR is instance variable list with init values removed
  35.     (LET ((CIVARS (MAPCAR #'(LAMBDA (X) (IF (CONSP X) (CAR X) X))
  36.               IVARS)))
  37.  
  38.       `(PROGN ; create class and assign to global variable
  39.               (SETF ,NAME
  40.             (SEND CLASS :NEW
  41.               ',CIVARS
  42.               ',CVARS
  43.               ,@(IF SUPER (LIST SUPER) NIL)))
  44.  
  45.           ; Set the name ivar of the class
  46.           (SEND ,NAME :SET-PNAME ',NAME)
  47.  
  48.           ; Generate the :<ivar> and :<cvar> methods
  49.           ,@(MAPCAR #'(LAMBDA (ARG)
  50.                 `(SEND ,NAME
  51.                    :ANSWER
  52.                    ,(INTERN (STRCAT ":" (STRING ARG)))
  53.                    'NIL
  54.                    '(,ARG)))
  55.                 (APPEND CIVARS CVARS))
  56.  
  57.           ; The method needed to set the instance variables
  58.           (SEND ,NAME :ANSWER :SET-IVAR
  59.                   '(,SYM ,SYM2)
  60.             '((EVAL (LIST 'SETQ ,SYM (LIST 'QUOTE ,SYM2) ))))
  61.  
  62.           ; Set the ivarname property of the :<ivar> symbols
  63.           ,@(MAPCAR #'(LAMBDA (ARG)
  64.                       `(SETF (GET ',(INTERN (STRCAT ":" (STRING ARG)))
  65.                             'IVARNAME)
  66.                    ',ARG))
  67.                 CIVARS)
  68.  
  69.           ; Generate the :ISNEW method
  70.           (SEND ,NAME
  71.             :ANSWER :ISNEW
  72.             '(&REST ,SYM &KEY ,@IVARS)
  73.  
  74.             ; first :ISNEW setfs 
  75.             ;  for all its declared instance variables
  76.             '(,@(MAPCAR #'(LAMBDA (ARG)
  77.                     `(SETF (SEND SELF
  78.                             ,(INTERN (STRCAT ":" 
  79.                                   (STRING ARG))))
  80.                        ,ARG))
  81.                     CIVARS)
  82.  
  83.               ; then the remaining initialization arguments are
  84.               ;  passed to the superclass.
  85.               (APPLY #'SEND-SUPER
  86.                  (CONS ':ISNEW
  87.                    (REMOVE-KEYS
  88.                       ',(MAPCAR #'(LAMBDA (ARG)
  89.                             (INTERN (STRCAT ":"
  90.                                    (STRING ARG))))
  91.                             CIVARS)
  92.                       ,SYM)))
  93.               self)))))
  94.  
  95.  
  96. ; (defmethod <class> <message> (<arglist>) <body>)
  97.  
  98. (DEFMACRO DEFMETHOD (CLASS MESSAGE ARGLIST &REST BODY)
  99.     `(SEND ,CLASS
  100.        :ANSWER
  101.        ,MESSAGE
  102.        ',ARGLIST
  103.        ',BODY))
  104.  
  105. ; (definst <class> <instname> [<args>...])
  106.  
  107. (DEFMACRO DEFINST (CLASS NAME &REST ARGS)
  108.     `(SETF ,NAME
  109.            (SEND ,CLASS
  110.              :NEW
  111.          ,@ARGS)))
  112.  
  113. ; (extensions suggested by Jim Ferrans)
  114.  
  115. (DEFUN CLASSP (NAME)
  116.        (WHEN (OBJECTP NAME)
  117.          (EQ (SEND NAME :CLASS) CLASS)))
  118.  
  119. (DEFMETHOD CLASS :SUPERCLASS () SUPERCLASS)
  120. (DEFMETHOD CLASS :MESSAGES () MESSAGES)
  121.  
  122. (DEFMETHOD OBJECT :SUPERCLASS () NIL)
  123.  
  124. (DEFMETHOD OBJECT :ISMEMBEROF (CLASS)
  125.        (EQ (SEND SELF :CLASS) CLASS))
  126.  
  127. (DEFMETHOD OBJECT :ISKINDOF (CLASS)
  128.        (DO ((THIS (SEND SELF :CLASS) (SEND THIS :SUPERCLASS)))
  129.            ((OR (NULL THIS)(EQ THIS CLASS))
  130.         (EQ THIS CLASS))))
  131.  
  132. (DEFMETHOD OBJECT :RESPONDSTO (SELECTOR &AUX TEMP)
  133.        (DO ((THIS (SEND SELF :CLASS) (SEND THIS :SUPERCLASS)))
  134.            ((OR (NULL THIS)
  135.             (SETQ TEMP 
  136.               (NOT (NULL (ASSOC SELECTOR 
  137.                        (SEND THIS :MESSAGES))))))
  138.         TEMP)
  139.            (SETF TEMP NIL)))
  140.  
  141.  
  142. (DEFMETHOD CLASS :IVARS () IVARS)
  143.  
  144. (DEFMETHOD CLASS :PNAME () PNAME)
  145.  
  146. ; :Storeon returns a list that can be executed to re-generate the object.
  147. ; It relies on the object's class being created using DEFCLASS,   so the
  148. ; instance variables can be generated.
  149.  
  150.  
  151. (DEFMETHOD OBJECT :STOREON (&AUX CLASS IVLIST RES)
  152.        (SETQ CLASS
  153.          (SEND SELF :CLASS)
  154.          IVLIST
  155.          (DO ((IVARS (SEND CLASS :IVARS)
  156.                  (APPEND (SEND SUPER :IVARS) IVARS))
  157.               (SUPER (SEND CLASS :SUPERCLASS)
  158.                  (SEND SUPER :SUPERCLASS)))
  159.              ((EQ SUPER OBJECT) IVARS))
  160.          RES
  161.          (MAPCAN #'(LAMBDA (X) 
  162.                    (LET ((TEMP
  163.                       (INTERN (CONCATENATE 'STRING
  164.                                    ":"
  165.                                    (STRING X)))))
  166.                     (LIST TEMP
  167.                           (LET ((Y (SEND SELF TEMP)))
  168.                            (IF (AND Y 
  169.                                 (OR (SYMBOLP Y)
  170.                                 (CONSP Y)))
  171.                                (LIST 'QUOTE Y)
  172.                                Y)))))
  173.                    IVLIST))
  174.        (APPEND (LIST 'SEND (MAKE-SYMBOL (SEND CLASS :PNAME)) ':NEW)
  175.            RES))
  176.  
  177. ; For classes we must use a different tact.
  178. ; We will return a PROGN that uses SENDs to create the class and any methods.
  179. ; It also assumes the global environment. None of the DEFxxx functions
  180. ; are needed to do this.
  181.  
  182. ; because of the subrs used in messages, :storeon cannot be  used to
  183. ; generate a reconstructable copy of classes Object and Class.
  184.  
  185. ; Class variables are not set, because there are no class methods in XLISP
  186. ; to do this (one would have to create an instance, and send messages to
  187. ; the instance, and I feel that is going too far).
  188.  
  189.  
  190. (DEFMETHOD CLASS :STOREON (&AUX (CLASSNAME (INTERN PNAME)))
  191.    (NCONC (LIST 'PROGN)
  192.       (LIST (LIST 'SETQ CLASSNAME
  193.               (LIST 'SEND 'CLASS :NEW IVARS CVARS 
  194.                 (IF SUPERCLASS 
  195.                 (INTERN (SEND SUPERCLASS :PNAME))
  196.                 NIL))))
  197.       (LIST (LIST 'SEND CLASSNAME :SET-PNAME PNAME))
  198.       (MAPCAR #'(LAMBDA (MESS &AUX 
  199.                   (VAL (IF (EQ 'CLOSURE (TYPE-OF (CDR MESS)))
  200.                        (GET-LAMBDA-EXPRESSION (CDR MESS))
  201.                        (LIST NIL NIL MESS))))
  202.                 (LIST 'SEND CLASSNAME :ANSWER
  203.                   (FIRST MESS)
  204.                   (LIST 'QUOTE (CDADR VAL))
  205.                   (LIST 'QUOTE (CDDR VAL))))
  206.           MESSAGES)))
  207.