Static class/object orientation

class.lisp

(defun mkstr (&rest args)
  (with-output-to-string (s)
    (dolist (a args) (princ a s))))

(defun symb (&rest args)
  (values (intern (apply #'mkstr args))))

(defparameter *class-table* (make-hash-table :test #'equal))


;; define a static class (static in that a particular instance's class cannot be changed)
;; via closures

;; supports single-inheritance with implicit method overriding

;; self refers to the dispatch function  (send self name)  basically means call the current object's name method

(defmacro def-static-class (name &optional properties methods superclass)
  (let ((superclass (when superclass
                       (let ((res (gethash superclass *class-table*)))
                         (assert res (superclass) "Unknown superclass ~a" superclass) res))))
    (let ((properties (if superclass 
                          (remove-duplicates (append (car superclass)
                                                     properties))
                          properties))
          (methods (if superclass (remove-duplicates (append
                                                      (cadr superclass)
                                                      methods))
                       methods)))
      `(progn (setf (gethash ',name *class-table*) '(,properties ,methods))
              (defun ,(symb 'make '- name) (&key ,@properties)
                (symbol-macrolet ((self #'dispatch))
                  (labels (,@methods
                           (dispatch (msg)
                             (case msg
                               ,@(mapcar (lambda (n) (list (symb 'get- n) `(lambda () ,n))) properties)
                               ,@(mapcar (lambda (n) 
                                           (let ((name (gensym)))
                                             (list (symb 'set- n) `(lambda (,name) (setf ,n ,name))))) properties)
                               ,@(mapcar (lambda (n) (list (car n) `#',(car n))) methods)
                               (name (lambda () ',name))
                               (otherwise (error "Unknown method: ~a" msg)))))
                    self)))))))



(defmacro send (object msg &rest args)
  `(funcall (funcall ,object ',msg) ,@args))
   
                  ;; properties       methods                superclass
(def-static-class 2d (x y)        ( (pos () (cons x y)) )      nil)

(def-static-class rect (w h)      ( (area () (* w h))  
                                    (describe () (format t "I am a ~a" (send self name)))     nil)


(let ((2d (make-2d :x 2 :y 3)))
  (send 2d get-x)   =>  2
  (send 2d pos)     => (2 . 3)
  (send 2d name)    => 2d
  (send 2d area))    => error Unknown method 'area

(let ((rect (make-rect :x 3 :y 3 :w 5 :h 20))
  (send rect area)    =>  100
  (send rect pos)     => (3 . 3)
  (send rect name)    => rect
  (send rect describe)) =>  "I am a RECT"