home *** CD-ROM | disk | FTP | other *** search
/ OS/2 Shareware BBS: 10 Tools / 10-Tools.zip / xl21hos2.zip / CLASSES.LSP < prev    next >
Lisp/Scheme  |  1995-12-27  |  7KB  |  235 lines
  1. ; useful stuff for object programming
  2.  
  3. (in-package "XLISP")
  4.  
  5. (export '(defclass defmethod definst classp))
  6.  
  7. ; filter certain keyword arguments for passing argument list to superclass
  8.  
  9. (defun remove-keys (keys list)
  10.     (cond ((null keys) list)
  11.       ((null list) 'nil)
  12.       ((member (car list) keys)
  13.        (remove-keys (remove (car list) keys) (cddr list)))
  14.       (t (cons (car list) (remove-keys keys (cdr list))))))
  15.  
  16.  
  17. ; fix so that classes can be named (requires PNAME ivar in class Class)
  18. ;  The source files have been modified for PNAME instance variable,
  19. ;  and printing of class PNAME if it exists.
  20.  
  21. (send class :answer :set-pname
  22.       '(name)
  23.       '((setf pname (string name))))
  24.  
  25.  
  26. ; *setf* property of SEND is set to allow setting instance variables
  27.  
  28. (setf (get 'send '*setf*) 
  29.       #'(lambda (obj ivar value) 
  30.         (send obj :set-ivar
  31. #-:packages          (get ivar 'ivarname)
  32. #+:packages          ivar
  33.               value)))
  34.  
  35. ; (defclass <classname> [(<instvars>) [(<classvars>) [<superclass>]]])
  36. ; defclass sets up access methods for all instance and class variables!
  37. ; an instance variable can be of form <ivar>  or (<ivar> <init>)
  38. ; :ISNEW is automatically defined to accept keyword arguments to overide
  39. ; default initialization.
  40.  
  41. (defmacro defclass (name &optional ivars cvars super 
  42.              &aux (sym (gensym)) (sym2 (gensym)))
  43. ; CIVAR is instance variable list with init values removed
  44.     (let ((civars (mapcar #'(lambda (x) (if (consp x) (car x) x))
  45.               ivars)))
  46.  
  47.       `(progn ; Create class and assign to global variable
  48.               (setf ,name
  49.             (send class :new
  50.               ',civars
  51.               ',cvars
  52.               ,@(if super (list super) nil)))
  53.  
  54.           ; Set the name ivar of the class
  55.           (send ,name :set-pname ',name)
  56.  
  57.           ; Generate the :<ivar> and :<cvar> methods
  58.           ,@(mapcar #'(lambda (arg)
  59.                 `(send ,name
  60.                    :answer
  61. #-:packages                ,(intern (strcat ":" (string arg)))
  62. #+:packages                ,(intern (string arg) :keyword)
  63.                    'nil
  64.                    '(,arg)))
  65.                 (append civars cvars))
  66.  
  67.           ; The method needed to set the instance variables
  68.           (send ,name :answer :set-ivar
  69.             '(,sym ,sym2)
  70.             '((case ,sym
  71.                 ,@(mapcar #'(lambda (arg)
  72. #-:packages                        `(,arg (setq ,arg ,sym2))
  73. #+:packages                    `(,(intern (string arg)
  74.                                :keyword)
  75.                           (setq ,arg ,sym2))
  76.                         )
  77.                       (append civars cvars))
  78.                 (t (send-super :set-ivar ,sym ,sym2)))))
  79.  
  80.           ; Set the ivarname property of the :<ivar> symbols
  81. #-:packages   ,@(mapcar #'(lambda (arg)
  82.                       `(setf (get
  83. #-:packages                 ',(intern (strcat ":" (string arg)))
  84.                     'ivarname)
  85.                    ',arg))
  86.                 civars)
  87.  
  88.           ; Generate the :ISNEW method
  89.           (send ,name
  90.             :answer :isnew
  91.             '(&rest ,sym &key ,@ivars &allow-other-keys)
  92.  
  93.             ; first :ISNEW setfs 
  94.             ;  for all its declared instance variables
  95.             '(,@(mapcar #'(lambda (arg)
  96.                     `(setf (send self
  97. #-:packages                         ,(intern (strcat ":" 
  98.                                (string arg)))
  99. #+:packages                      ,(intern (string arg)
  100.                               :keyword)
  101.                          )
  102.                        ,arg))
  103.                     civars)
  104.  
  105.               ; then the remaining initialization arguments are
  106.               ;  passed to the superclass.
  107.               (apply #'send-super
  108.                  (cons ':isnew
  109.                    (remove-keys
  110.                       ',(mapcar #'(lambda (arg)
  111. #-:packages                         (intern (strcat ":"
  112.                                    (string arg)))
  113. #+:packages                         (intern (string arg)
  114.                                 :keyword)
  115.                               )
  116.                             civars)
  117.                       ,sym)))
  118.               self))
  119.           ,name)))
  120.  
  121.  
  122. ; (defmethod <class> <message> (<arglist>) <body>)
  123.  
  124. (defmacro defmethod (cls message arglist &rest body)
  125.     `(send ,cls
  126.        :answer
  127.        ,message
  128.        ',arglist
  129.        ',body))
  130.  
  131. ; (definst <class> <instname> [<args>...])
  132.  
  133. (defmacro definst (cls name &rest args)
  134.     `(setf ,name
  135.            (send ,cls
  136.              :new
  137.          ,@args)))
  138.  
  139. ; (extensions suggested by Jim Ferrans)
  140.  
  141. (defun classp (name)
  142.        (when (objectp name)
  143.          (eq (send name :class) class)))
  144.  
  145. (defmethod class :superclass () superclass)
  146. (defmethod class :messages () messages)
  147.  
  148. (defmethod object :superclass () nil)
  149.  
  150. (defmethod object :ismemberof (cls)
  151.        (eq (send self :class) cls))
  152.  
  153. (defmethod object :iskindof (cls)
  154.        (do ((this (send self :class) (send this :superclass)))
  155.            ((or (null this)(eq this cls))
  156.         (eq this cls))))
  157.  
  158. (defmethod object :respondsto (selector &aux temp)
  159.        (do ((this (send self :class) (send this :superclass)))
  160.            ((or (null this)
  161.             (setq temp 
  162.               (not (null (assoc selector 
  163.                        (send this :messages))))))
  164.         temp)
  165.            (setf temp nil)))
  166.  
  167.  
  168. (defmethod class :ivars () ivars)
  169.  
  170. (defmethod class :pname () pname)
  171.  
  172. ; :Storeon returns a list that can be executed to re-generate the object.
  173. ; It relies on the object's class being created using DEFCLASS,   so the
  174. ; instance variables can be generated.
  175.  
  176.  
  177. (defmethod object :storeon (&aux cls ivlist res)
  178.        (setq cls
  179.          (send self :class)
  180.          ivlist
  181.          (do ((ivars (send cls :ivars)
  182.                  (append (send super :ivars) ivars))
  183.               (super (send cls :superclass)
  184.                  (send super :superclass)))
  185.              ((eq super object) ivars))
  186.          res
  187.          (mapcan #'(lambda (x) 
  188.                    (let ((temp
  189. #-:packages                   (intern (strcat ":" (string x)))
  190. #+:packages                   (intern (string x) :keyword)
  191.                       ))
  192.                     (list temp
  193.                           (let ((y (send self temp)))
  194.                            (if (and y 
  195.                                 (or (symbolp y)
  196.                                 (consp y)))
  197.                                (list 'quote y)
  198.                                y)))))
  199.                    ivlist))
  200.        (append (list 'send (intern (send cls :pname)) ':new)
  201.            res))
  202.  
  203. ; For classes we must use a different tact.
  204. ; We will return a PROGN that uses SENDs to create the class and any methods.
  205. ; It also assumes the global environment. None of the DEFxxx functions
  206. ; are needed to do this.
  207.  
  208. ; because of the subrs used in messages, :storeon cannot be  used to
  209. ; generate a reconstructable copy of classes Object and Class.
  210.  
  211. ; Class variables are not set, because there are no class methods in XLISP
  212. ; to do this (one would have to create an instance, and send messages to
  213. ; the instance, and I feel that is going too far).
  214.  
  215.  
  216. (defmethod class :storeon (&aux (classname (intern pname)))
  217.    (nconc (list 'progn)
  218.       (list (list 'setq classname
  219.               (list 'send 'class :new ivars cvars 
  220.                 (if superclass 
  221.                 (intern (send superclass :pname))
  222.                 nil))))
  223.       (list (list 'send classname :set-pname pname))
  224.       (mapcar #'(lambda (mess &aux 
  225.                   (val (if (typep (cdr mess) 'closure)
  226.                        (get-lambda-expression (cdr mess))
  227.                        (list nil nil mess))))
  228.                 (list 'send classname :answer
  229.                   (first mess)
  230.                   (list 'quote (cdadr val))
  231.                   (list 'quote (cddr val))))
  232.           messages)))
  233.  
  234. (setq *features* (cons :classes *features*))
  235.