gistfile1.txt

;; A T-esque object system in Plan
;; Uses new-style let syntax
;; wherein (let (x 1 y 2) ...) replaces both (let x 1 ...) and (with (x 1 y 2) ...)

(deffn (operation? f)
  (and (function? f) (= (tag f 'disposition) 'operation)))
(deffn (object? o)
  (and (function? o) (= (tag o 'disposition) 'object)))

(w/uniq msg-password
  (deffn (basic-object proc handler)
    (tagged 'disposition 'object (fn arg
      (if (= (car arg) msg-password)
            handler
           (apply proc arg)))))
  (deffn (get-handler obj)
    (if (object? obj)
          (obj msg-password)
         (fn a nil))))

(defmac (object f &ops)
  (w/uniq -op
    `(basic-object ,f
       (fn (,-op)
         (if ,@(unpair (map (fn (fcl) `((= ,-op ,(caar fcl)) (fn ,(cdar fcl) ,@(cdr fcl)))) (pairs ops))))))))

(defmac (op default &methods)
  (w/uniq (-op -obj -args -meth)
    `(private ,-op (tagged 'disposition 'operation (object
      (fn (,-obj . ,-args)
        (let (,-meth ((get-handler ,-obj) ,-op))
          (if ,-meth
                (apply ,-meth (cons ,-obj ,-args))
                (apply ,default (cons ,-obj ,-args))))) ,@methods)) ,-op)))
(defmac (defop proto &body)
  `(set! ,(car proto) (op (fn ,(cdr proto) ,@body))))
(defmac (defop-settable proto &body)
  (w/uniq -setr
    `(let (,-setr (op))
      (set! ,(car proto)
        (op (fn ,(cdr proto) ,@body)
          (setter self) ,-setr))
      (set (setter ,(car proto)) ,-setr))))
(defmac (defpred name)
  `(defop (,name obj) nil))

(defmac (join &objs)
  (w/uniq -op
   `(basic-object ,(car objs)
     (fn (,-op) (or ,@(map (fn (o) `((get-handler ,o) ,-op)) objs))))))

(defmac (wrap-op f)
  (w/uniq -name
    `(let (,-name ,f)
      (set! ,f (op ,-name)))))