Object system for NL

[Jeff]

I wanted to write a simple object system for nl.  Specifically, I wanted generic functions, but I didn't think I could quite use FOOP since it stores functions inside the context, rather than defining functions in terms of their arguments.



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 Expand

#!/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))

[Jeff]

Here is a *slightly* cleaned up, *slightly* speedier version:

Code Select Expand

#!/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)))

;;; 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 ()
(cons c (map
 (lambda (slot)
(let ((sn (first slot)))
 (if (member sn (map 'first 'all)) slot
 (throw-error
  (string "invalid slot " sn " in class " c)))))
 (pairlis (args))))) c))))

(define (class? ctx)
  (and (or (symbol? ctx) (context? ctx))
  (member (sym (name ctx)) classes)))

(define (instance? obj)
  (and (list? obj) (class? (first obj))))

;; Generic functions
(define methods:methods)

(define (method-signature arg-list)
  (map (lambda (a) (if (instance? a) (sym (name (first a))) nil)) arg-list))

(define (make-lambda-list arg-list)
  (map (lambda (a)
(cond ((and (list? a) (class? (nth 0 a)))
(if (= 2 (length a))
(list (sym (nth 1 a)) nil)
(rest a)))
  ((list? a) a)
  (true (list 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 (make-lambda-list 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))))
;; define function
(letex ((s sym-name) (sn (name sym-name)))
 (set 's (lambda () (method-call sn (args)))))))

(define methodcache:method-cache)
(define (find-method mtd-name arglst)
  (letex ((sig (method-signature arglst)))
(or (methodcache (string mtd-name sig))
(methodcache (string mtd-name sig)
(if (find '(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 mtd-name arglist)))
(apply mtd arglist)))

(define (expand-slot-pair)
  (list (args 1 0) (slot-value (args 0) (args 1 1))))

(define-macro (with-slots)
  (let ((inst (args 0)))
(letex ((slots (map (fn (p) (expand-slot-pair inst p)) (args 1)))
(body (cons 'begin (slice (args) 2))))
 (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))