(define-module (oop pf-objects) #:use-module (oop goops) #:use-module (ice-9 vlist) #:use-module (ice-9 match) #:export (set ref make-pf
() h)
(define-class ) size n) ; the pf object consist of a functional
; hashmap it's size and number of live
; object
(define-class ))
(define-class ))
(slot-set! r 'h (make-hash-table))
r)
(define-syntax-rule (hif it (k h) x y)
(let ((a (vhash-assq k h)))
(if (pair? a)
(let ((it (cdr a)))
x)
y)))
(define-syntax-rule (cif (it h) (k cl) x y)
(let* ((h (slot-ref cl 'h))
(a (vhash-assq k h)))
(if (pair? a)
(let ((it (cdr a)))
x)
y)))
(define fail (cons 'fail '()))
(define-syntax-rule (mrefx x key l)
(let ()
(define (end)
(if (null? l)
#f
(car l)))
(define (parents li)
(let lp ((li li))
(if (pair? li)
(let ((p (car li)))
(cif (it h) (key p)
it
(hif it ('__parents__ h)
(let ((r (parents it)))
(if (eq? r fail)
(lp (cdr li))
r))
(lp (cdr li)))))
fail)))
(cif (it h) (key x)
it
(hif cl ('__class__ h)
(cif (it h) (key cl)
it
(hif p ('__parents__ h)
(let ((r (parents p)))
(if (eq? r fail)
(end)
r))
(end)))
(end)))))
(define-syntax-rule (mrefx- x key l)
(let ()
(define (end) (if (pair? l) (car l) #f))
(define (ret q) (if (eq? q fail) (end) q))
(define (find-in-class h)
(let lp ((class-h h))
(let ((r (hash-ref class-h key fail)))
(if (eq? r fail)
(aif parents (hash-ref class-h '__parents__ #f)
(let lpp ((parents parents))
(if (pair? parents)
(let ((parent (car parents)))
(let ((r (lp (slot-ref parent 'h))))
(if (eq? r fail)
(lpp (cdr parents))
r)))
fail))
fail)
r))))
(let* ((h (slot-ref x 'h))
(r (hash-ref h key fail)))
(if (eq? r fail)
(aif class (hash-ref h '__class__)
(ret (find-in-class (slot-ref class 'h)))
fail)
r))))
(define not-implemented (cons 'not 'implemeneted))
(define-syntax-rule (mrefx-py- x key l)
(let ((f (mrefx- x '__ref__ '())))
(if (or (not f) (eq? f not-implemented))
(mrefx- x key l)
(apply f x key l))))
(define-syntax-rule (mrefx-py x key l)
(let ((f (mrefx x '__ref__ '())))
(if (or (not f) (eq? f not-implemented))
(mrefx x key l)
(apply f x key l))))
(define-syntax-rule (unx mrefx- mref-)
(define-syntax-rule (mref- x key l)
(let ((xx x))
(let ((res (mrefx- xx key l)))
(if (procedure? res)
(lambda z
(apply res xx z))
res)))))
(unx mrefx- mref-)
(unx mrefx mref)
(unx mrefx-py mref-py)
(unx mrefx-py- mref-py-)
(define-method (ref (x ) key . l) (mref- x key l))
(define-method (ref (x ) key val) (mset- x key val))
(define-method (set (x ) key . l) (mcall- x key l))
(define-method (call (x )) (mcopy- x))
;; with will execute thunk and restor x to it's initial state after it has
;; finished note that this is a cheap operatoin because we use a functional
;; datastructure
(define-syntax-rule (mwith x thunk)
(let ((old (mcopy x)))
(let ((r (thunk)))
(slot-set! x 'h (slot-ref old 'h))
(slot-set! x 'size (slot-ref old 'size))
(slot-set! x 'n (slot-ref old 'n))
r)))
(define-syntax-rule (mwith- x thunk)
(let ((old (mcopy- x)))
(let ((r (thunk)))
(slot-set! x 'h (slot-ref old 'h))
r)))
;; a functional set will return a new object with the added binding and keep
;; x untouched
(define-method (fset (x ) key val)
(let ((x (mcopy- x)))
(mset x key val)
x))
(define (fset-x obj l val)
(let lp ((obj obj) (l l) (r '()))
(match l
(()
(let lp ((v val) (r r))
(if (pair? r)
(lp (fset (caar r) (cdar r) v) (cdr r))
v)))
((k . l)
(lp (ref obj k #f) l (cons (cons obj k) r))))))
;; a functional call will keep x untouched and return (values fknval newx)
;; e.g. we get both the value of the call and the new version of x with
;; perhaps new bindings added
(define-method (fcall (x ) key . l)
(let ((x (mcopy x)))
(values (mcall- x key l)
x)))
;; this shows how we can override addition in a pythonic way
(define-syntax-rule (mk-arith + +x __add__ __radd__)
(begin
(define-method (+ (x ) y)
(call x '__add__ y))
(define-method (+ x (y ))
(call y '__radd__ x))
(define-method (+ (x ) y)
(call x '__radd__ y))))
;; A few arithmetic operations at service
(mk-arith + +x __add__ __radd__)
(mk-arith - -x __sub__ __rsub__)
(mk-arith * *x __mul__ __rmul__)
;; lets define get put pcall etc so that we can refer to an object like
;; e.g. (put x.y.z 1) (pcall x.y 1)
(define-syntax-rule (cross x k f set)
(call-with-values (lambda () f)
(lambda (r y)
(if (eq? x y)
(values r x)
(values r (set x k y))))))
(define-syntax-rule (cross! x k f _) f)
(define-syntax mku
(syntax-rules ()
((_ cross set setx f (key) (val ...))
(setx f key val ...))
((_ cross set setx f (k . l) val)
(cross f k (mku cross set setx (ref f k) l val) set))))
(define-syntax-rule (mkk pset setx set cross)
(define-syntax pset
(lambda (x)
(syntax-case x ()
((_ f val (... ...))
(let* ((to (lambda (x)
(datum->syntax #'f (string->symbol x))))
(l (string-split (symbol->string (syntax->datum #'f)) #\.)))
(with-syntax (((a (... ...)) (map (lambda (x) #`'#,(to x))
(cdr l)))
(h (to (car l))))
#'(mku cross setx set h (a (... ...)) (val (... ...))))))))))
(mkk put fset fset cross)
(mkk put! set set cross!)
(mkk pcall! call fset cross!)
(mkk pcall fcall fset cross)
(mkk get ref fset cross!)
;; it's good to have a null object so we don't need to construct it all the
;; time because it is functional we can get away with this.
(define null (make-pf))
;; append the bindings in x in front of y + some optimizations
(define (union x y)
(define hx (slot-ref x 'h))
(define hy (slot-ref y 'h))
(define n (slot-ref x 'n))
(define s (slot-ref x 'size))
(define m (make-hash-table))
(define h
(vhash-fold
(lambda (k v st)
(if (vhash-assq k hy)
(begin
(set! s (+ s 1))
(vhash-consq k v st))
(if (hash-ref m k)
s
(begin
(set! n (+ n 1))
(set! s (+ s 1))
(hash-set! m k #t)
(vhash-consq k v st)))))
hy
hx))
(define out (make )
(define-syntax make-p-class
(lambda (x)
(syntax-case x ()
((_ name const dynamic (supers (... ...)))
(with-syntax (((sups (... ...)) (generate-temporaries
#'(supers (... ...)))))
#'(let ((sups supers) (... ...))
(define class dynamic)
(define name (make-class (list (ref sups '__goops__ #f)
(... ...) ) '()))
(set! class
(union- const
(let lp ((sup (list sups (... ...))))
(if (pair? sup)
(union- (car sup)
(lp (cdr sup)))
(make-p)))))
(set class '__goops__ name)
(set class '__name__ 'name)
(set class '__parents__ (list sups (... ...)))
class)))))))
(mk-p make-p-class )
(mk-p make-py-class ) . l)
(let ((o (make (ref x '__goops__)))
(h (make-hash-table)))
(slot-set! o 'h h)
(hash-set! h '__class__ x)
(apply (ref o '__init__ (lambda x (error "no init fkn"))) l)
o))
;; the make class and defclass syntactic sugar
(define-syntax-rule (mk-p/f make-pf mk-pf-class make-pf-class)
(define-syntax-rule (mk-pf-class name (parents (... ...))
#:const
((sdef mname sval) (... ...))
#:dynamic
((ddef dname dval) (... ...)))
(let ()
(define name
(make-pf-class name
(let ((s (make-pf)))
(set s 'mname sval) (... ...)
s)
(let ((d (make-pf)))
(set d 'dname dval) (... ...)
d)
(parents (... ...))))
name)))
(mk-p/f make-pf mk-pf-class make-pf-class)
(mk-p/f make-p mk-p-class make-p-class)
(mk-p/f make-pf mk-pyf-class make-pyf-class)
(mk-p/f make-p mk-py-class make-py-class)
(define-syntax-rule (def-pf-class name . l)
(define name (mk-pf-class name . l)))
(define-syntax-rule (def-p-class name . l)
(define name (mk-p-class name . l)))
(define-syntax-rule (def-pyf-class name . l)
(define name (mk-pyf-class name . l)))
(define-syntax-rule (def-py-class name . l)
(define name (mk-py-class name . l)))
(define-syntax-rule (wrap class)
(let* ((c class)
(ret (lambda x (apply mk c x))))
(set-procedure-property! ret 'pyclass c)
ret))
(define (get-class x)
(aif it (procedure-property x 'pyclass)
it
(error "not a class")))
(define StopIteration 'StopIteration)
(define-method (next (o ))
(catch StopIteration
(lambda () ((ref o '__next__)))
(lambda (x) #:nil)))