Here is the code. It's not optimized and at the moment generic function calls have about twice (!!!) the overhead as regular functions. Example usage is at the bottom.
Code: Select all
#!/usr/bin/newlisp
;;; Helper functions
(define (union)
(unique (apply append (args))))
(define (pairlis data)
(if (empty? data) '()
(cons (slice data 0 2) (pairlis (slice data 2)))))
(define-macro (do-pairs)
(letex ((var (args 0 0)) (pairs (args 0 1)) (body (cons 'begin (rest (args)))))
(dolist (var (pairlis pairs))
body)))
(define-macro (bind-plist)
(letex ((lst (args 0)) (body (cons 'begin (rest (args)))))
(letex ((pairs (pairlis 'lst)))
(let pairs body))))
;;; Class construction functions
(define (get-slot inst k)
(letex ((inst inst))
(let ((v (assoc (inst k))))
(if (> (length v) 2) (rest v) (nth (v 1))))))
(define (set-slot inst k v)
(letex ((inst inst))
(set-assoc (inst k) (list k v)))
v)
(define (slot-value inst k (v 'empty))
(if (= v 'empty) (get-slot inst k) (set-slot inst k v)))
(define (make-prec-list cls)
(let ((traverse
(lambda (c)
(cons c (apply append
(map traverse
(context c "parents")))))))
(unique (traverse cls))))
(define (inherit-layout classes)
(unique
(apply append
(map (lambda (c)
(append (context c "layout")
(inherit-layout (context c "parents"))))
classes))))
(setq classes '())
(define-macro (define-class)
(letex ((c (args 0))
(p (or (first (rest (args))) '()))
(s (or (rest (rest (args))) '())))
(letex ((all (union 's (inherit-layout 'p))))
(push 'c classes -1)
(context 'c "parents" 'p)
(context 'c "prec-list" (make-prec-list c))
(context 'c "layout" 'all)
(context 'c (string 'c)
(lambda-macro ()
(let ((lst (list c)) (slot-values (args)))
(do-pairs (slot slot-values)
(if (member (first slot) (map 'first 'all))
(push slot lst -1)
(throw-error (format "invalid slot '%s in class '%s"
(string (first slot))
(name c)))))
lst)))) c))
(define (class? ctx)
(and (or (symbol? ctx) (context? ctx))
(member (sym (name ctx)) classes)))
(define (instance? obj)
(and (list? obj) (class? (first obj))))
;; entries like "method-name" '((args fn) (args fn) ...)
(define methods:methods)
(define (method-signature arg-list)
(map (lambda (a) (if (instance? a) (sym (name (first a))) nil)) arg-list))
(define-macro (define-method)
(letn ((sym-name (args 0 0))
(lst-args (rest (args 0)))
(body (cons 'begin (rest (args))))
(method-sig (method-signature lst-args))
(func-args (map
(lambda (a)
(cond
((and (list? a)
(or (symbol? (nth 0 a)) (context? (nth 0 a)))
(class? (nth 0 a)))
(if (= 2 (length a))
(list (sym (nth 1 a)) nil)
(rest a)))
((list? a) a)
(true (list a nil))))
lst-args)))
(let ((n (string sym-name))
(f func-args)
(s method-sig)
(b body))
;; by default, set to empty list
(unless (methods n) (methods n '()))
;; add new method to list
(let ((mtd (expand (lambda f b) 'f 'b)))
(if (assoc ((methods n) s))
(set-assoc ((methods n) s) (list s mtd))
(push (list s mtd) (methods n) -1))))
(letex ((s sym-name))
(set 's (lambda () (method-call 's (args)))))))
(define (find-method mtd-name arglst)
(let ((sig (method-signature arglst)))
(if (find (list sig '?) (methods mtd-name) match)
(nth 1 $0)
(throw-error (string "no method matches signature: " sig)))))
(define (method-call mtd-name arglist)
(letn ((arglist arglist) (mtd (find-method (name mtd-name) arglist)))
(apply mtd arglist)))
(define (expand-slot-pair)
(letex ((inst (args 0)) (var-name (args 1 0)) (slot-name (args 1 1)))
'(var-name (slot-value 'inst 'slot-name))))
(define-macro (with-slots)
(let ((inst (args 0)) (slot-pairs (args 1)) (body (rest (rest (args)))))
(letex ((slots (map (fn (p) (expand-slot-pair inst p)) slot-pairs))
(body (cons 'begin body)))
(let slots body))))
;; testing
(define-class rect ()
(len nil)
(hgt nil))
(define-class box (rect)
(wid nil))
(define-method (area (rect r))
(with-slots r ((l len) (h hgt))
(* l h)))
(define-method (area (box b))
(with-slots b ((h hgt) (l len) (w wid))
(* 2 (+ (* h l) (* h w) (* l w)))))
(define-method (volume (rect r)) 0)
(define-method (volume (box b))
(with-slots b ((h hgt) (l len) (w wid))
(* h l w)))
(setq r (rect len 10 hgt 20))
(println (area r))
(setq b (box len 10 wid 20 hgt 15))
(println (area b))
(println "Box length is " (slot-value 'b 'len))