home *** CD-ROM | disk | FTP | other *** search
/ Celestin Apprentice 4 / Apprentice-Release4.iso / Languages / XLISP 3.0a1 / OBJECTS.LSP < prev    next >
Encoding:
Text File  |  1995-03-11  |  3.4 KB  |  120 lines  |  [TEXT/????]
  1. #| macro to send a message to the superclass |#
  2.  
  3. (define-macro (super selector &rest args)
  4.   `(%send-super %%class ,selector self ,@args))
  5.  
  6. #|
  7.  
  8. (define-class foo
  9.   (super-class bar)
  10.   (instance-variables a b)
  11.   (class-variables ((c 1)(d 2)))
  12.  
  13. |#
  14.  
  15. (define-macro (define-class class-name &body body)
  16.   (let ((super '())
  17.         (ivars '())
  18.         (cvars '()))
  19.     (let loop ((body body))
  20.       (if body
  21.         (let* ((form (car body))
  22.                (keyword (car form))
  23.                (args (cdr form)))
  24.           (cond ((or (eq? keyword 'super-class)
  25.              (eq? keyword 'super))
  26.              (set! super (append super args)))
  27.                 ((or (eq? keyword 'instance-variables)
  28.                      (eq? keyword 'ivars))
  29.                  (set! ivars (append ivars args)))
  30.                 ((or (eq? keyword 'class-variables)
  31.              (eq? keyword 'cvars))
  32.                  (set! cvars (append cvars args)))
  33.                 (otherwise (error "unexpected define-class clause ~S" form)))
  34.           (loop (cdr body)))))
  35.     (let ((super-class (if super (car super) 'object)))
  36.       (list 'begin
  37.     (list 'let (list (list 'meta-class
  38.                                (list 'class ''new
  39.                                  '()
  40.                      '()
  41.                      'class
  42.                                      ''class)))
  43.           (list 'set! class-name (list 'meta-class ''new
  44.                                          (list 'quote ivars)
  45.                                          (list 'quasiquote
  46.                                                (destructure-cvars cvars))
  47.                                          super-class
  48.                          (list 'quote class-name)))
  49.       (list 'meta-class ''%set-cvars! (list class-name ''%cvars))
  50.       class-name)))))
  51.  
  52. (define (destructure-cvars forms)
  53.   (let ((cvars '()))
  54.     (let loop ((forms forms))
  55.       (if forms
  56.         (let ((form (car forms)))
  57.       (if (pair? form)
  58.         (set! cvars (append cvars (list (list (car form)
  59.                                             (list 'unquote (cadr form))))))
  60.         (set! cvars (append cvars `(,form))))
  61.       (loop (cdr forms)))))
  62.     cvars))
  63. #|
  64.  
  65. (define-method (foo 'do-something a b) ; foo is a class
  66.   (list self a b))
  67.  
  68. |#
  69.  
  70. (define-macro (define-method proto &body body)
  71.   (let ((class (car proto))
  72.     (selector (cadr proto))
  73.     (args (cddr proto))
  74.     (body (%expand-list body))
  75.     (sel (gensym)))
  76.     `(let ((,sel ,selector))
  77.        (,class 'answer ,sel ',args ',body)
  78.        ,sel)))
  79.  
  80. #|
  81.  
  82. (define-class-method (foo 'do-something a b) ; foo is a class
  83.   (list self a b))
  84.  
  85. |#
  86.  
  87. (define-macro (define-class-method proto &body body)
  88.   (let ((class (car proto))
  89.         (selector (cadr proto))
  90.         (args (cddr proto)))
  91.     `(define-method ((,class 'class) ,selector ,@args)
  92.        ,@body)))
  93.  
  94. (define-method (class '%cvars) cvars)
  95. (define-method (class '%set-cvars! vars) (set! cvars vars))
  96.  
  97. #| some useful class methods |#
  98.  
  99. (define-method (class 'name) name)
  100. (define-method (class 'ivars) ivars)
  101.  
  102. #| a method to show the class variables of a class |#
  103.  
  104. (define-method (class 'show-cvars)
  105.   (when cvars
  106.     (let loop ((names (cdr (%vector-ref cvars 1)))
  107.                (i 3))
  108.       (if names
  109.         (begin (fresh-line)
  110.                (write (car names))
  111.                (display " = ")
  112.                (write (%vector-ref cvars i))
  113.                (loop (cdr names) (+ i 1))))))
  114.   self)
  115.  
  116. (class 'answer 'decompile '(sel)
  117. '((let ((binding (assoc sel messages)))
  118.     (if binding
  119.       (decompile (cdr binding))))))
  120.