Skip to content

Instantly share code, notes, and snippets.

@ehaliewicz
Last active December 15, 2015 01:59
Show Gist options
  • Save ehaliewicz/5183586 to your computer and use it in GitHub Desktop.
Save ehaliewicz/5183586 to your computer and use it in GitHub Desktop.
Static class/object orientation
(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"
Sign up for free to join this conversation on GitHub. Already have an account? Sign in to comment