From a984e9d1b82715fedf2164785ce0752f31dc8cfe Mon Sep 17 00:00:00 2001
From: Stefan Israelsson Tampe <stefan.itampe@gmail.com>
Date: Sun, 3 Sep 2017 22:32:09 +0200
Subject: improvements of the compiler and the object system added

---
 modules/language/python/compile.scm | 333 +++++++++++++++++------
 modules/language/python/parser.scm  |  20 +-
 modules/language/python/spec.scm    |  12 +-
 modules/oop/pf-objects.scm          | 528 ++++++++++++++++++++++++++++++++++++
 modules/oop/pf-objects.scm~         | 502 ++++++++++++++++++++++++++++++++++
 5 files changed, 1300 insertions(+), 95 deletions(-)
 create mode 100644 modules/oop/pf-objects.scm
 create mode 100644 modules/oop/pf-objects.scm~

diff --git a/modules/language/python/compile.scm b/modules/language/python/compile.scm
index d634d1b..7ffe57a 100644
--- a/modules/language/python/compile.scm
+++ b/modules/language/python/compile.scm
@@ -3,15 +3,28 @@
   #:use-module (ice-9 pretty-print)
   #:export (comp))
 
-(define (p  x) (pretty-print (syntax->datum x)) x)
+(define (fold f init l)
+  (if (pair? l)
+      (fold f (f (car l) init) (cdr l))
+      init))
+
+(define (pr . x)
+  (define port (open-file "/home/stis/src/python-on-guile/log.txt" "a"))
+  (with-output-to-port port
+    (lambda ()
+      (pretty-print x)))
+  (close port)
+  (car (reverse x)))
+
 (define (pf x)
-  (define port (open-file "compile.log" "a"))
+  (define port (open-file "/home/stis/src/python-on-guile/compile.log" "a"))
   (with-output-to-port port
     (lambda () (pretty-print (syntax->datum x)) x))
   (close port)
   x)
 
 (define (C x) `(@@ (language python compile) ,x))
+(define (O x) `(@@ (oop pf-objects) ,x))
 (define (G x) `(@ (guile) ,x))
 
 (define (union as vs)
@@ -49,7 +62,7 @@
     ((#:global . l)
      (let lp ((l l) (vs vs))
        (match l
-         (((#:identifier v) . l)
+         (((#:identifier v . _) . l)
           (let ((s (string->symbol v)))            
             (if (member s vs)
                 (lp l vs)
@@ -62,15 +75,15 @@
 
 (define (scope x vs)
   (match x
-    ((#:def  (#:identifier f) . _)
+    ((#:def  (#:identifier f . _) . _)
      (union (list (string->symbol f)) vs))
     ((#:lambdef . _)
      vs)
-    ((#:class . _)
+    ((#:classdef . _)
      vs)
     ((#:global . _)
      vs)
-    ((#:identifier v)
+    ((#:identifier v . _)
      (let ((s (string->symbol v)))
        (if (member s vs)
            vs
@@ -81,7 +94,7 @@
 
 (define (defs x vs)
   (match x
-    ((#:def  (#:identifier f) . _)
+    ((#:def  (#:identifier f . _) . _)
      (union (list (string->symbol f)) vs))
     ((#:lambdef . _)
      vs)
@@ -98,12 +111,50 @@
 
 (define return (make-fluid 'error-return))
 
+(define (make-set vs x u)
+  (match x
+    ((#:test (#:power (#:identifier v . _) addings . _) . _)
+     (let ((v (string->symbol v)))
+       (if (null? addings)
+           `(set! ,v ,u)
+           (let* ((rev (reverse addings))
+                  (las (car rev))
+                  (new (reverse (cdr rev))))
+             `(,(O 'set) ,(let lp ((v v) (new new))
+                             (match new
+                               ((x . new)
+                                (lp `(,(O 'ref) ,v ,(exp vs x)) ',new))
+                               (() v)))
+               ',(exp vs las) ,u)))))))
+
+             
+     
 (define (exp vs x)
-  (match (p x)
-    ((#:power (#:identifier x) () . #f)
+  (match (pr x)
+    ((#:power x () . #f)
+     (exp vs x))
+
+    ;; Function calls (x1:x1.y.f(1) + x2:x2.y.f(2)) will do functional calls
+    ((#:power vf ((and trailer (#:identifier _ . _)) ...
+                  (#:arglist (args ...) #f #f)) . #f)
+     (let ((args (map (g vs exp) args)))
+       (match vf
+         ((#:f (#:identifier f . _) e)
+          (let ((obj  (gensym "obj"))
+                (l    (gensym "l")))
+            '(call-with-values (lambda () (fcall (,(exp vs e)
+                                                  ,@(map (g vd exp) trailer))
+                                                 ,@args))
+               (lambda (,obj . ,l)
+                 `(set! ,(string->symbol f) ,obj)
+                 (apply 'values ,l)))))
+         (x
+          `(,(C 'call) (,(exp vs x) ,@(map (g vs exp) trailer)) ,@args)))))
+                                                
+    ((#:identifier x . _)
      (string->symbol x))
 
-    ((#:power x () . #f)
+    ((#:string x)
      x)
     
     (((and x (or #:+ #:- #:* #:/)) . l)
@@ -129,12 +180,18 @@
 
     ((#:and . x)
      (cons 'and (map (g vs exp) x)))
-
+    
     ((#:test e1 #f)
      (exp vs e1))
     
     ((#:test e1 e2 e3)
      (list 'if (exp vs e2) (exp vs e1) (exp vs e3)))
+
+    ((#:if test a ((tests . as) ...) . else)
+     `(,(G 'cond)
+       (,(exp vs test) ,(exp vs a))
+       ,@(map (lambda (p a) (list (exp vs p) (exp vs a))) tests as)
+       ,@(if else `((else ,(exp vs else))) '())))
     
     ((#:suite . l) (cons 'begin (map (g vs exp) l)))
 
@@ -152,47 +209,119 @@
                 ,(exp vs code)
                 (,lp))))))
 
-    ((#:for exp in code #f)
-     (match (cons exp in)
-       ((((#:power (#:identifier x) #f . #f)) .
-         ((#:power (#:identifier 'range) ((arg) #f #f) . #f)))
-        (let ((v   (gensym "v"))
-              (lp  (gensym "lp")))
-          `(let ((,v ,(exp arg)))
-             (let ,lp ((,x 0))
-               (if (< ,x ,v)
-                   (begin
-                     ,(exp vs code)
-                     (,lp (+ ,x 1))))))))
-
-       ((((#:power (#:identifier x) #f . #f)) .
-         ((#:power (#:identifier 'range) ((arg1 arg2) #f #f) . #f)))
-        (let ((v1   (gensym "va"))
-              (v2   (gensym "vb"))
-              (lp  (gensym "lp")))
-          `(let ((,v1 ,(exp arg1))
-                 (,v2 ,(exp arg2)))
-             (let ,lp ((,x ,v1))
-                  (if (< ,x ,v2)
-                      (begin
-                        ,(exp vs code)
-                        (,lp (+ ,x 1))))))))
-
-       ((((#:power (#:identifier x) #f . #f)) .
-         ((#:power (#:identifier 'range) ((arg1 arg2 arg3) #f #f) . #f)))
-        (let ((v1   (gensym "va"))
-              (v2   (gensym "vb"))
-              (st   (gensym "vs"))
-              (lp  (gensym "lp")))
-          `(let ((,v1 ,(exp arg1))
-                 (,st ,(exp arg2))
-                 (,v2 ,(exp arg3)))
-             (let ,lp ((,x ,v1))
-               (if (< ,x ,v2)
-                   (begin
-                     ,(exp vs code)
-                     (,lp (+ ,x ,st))))))))))
-        
+    ((#:classdef (#:identifier class . _) parents defs)
+     (let ()
+       (define (filt l)
+         (reverse
+          (fold (lambda (x s)
+                  (match x
+                    (((or 'fast 'functional)) s)
+                    (x (cons x s))))
+                '() l)))
+       (define (is-functional l)
+         (fold (lambda (x pred)
+                 (if pred
+                     pred
+                     (match x
+                       (('functional) #t)
+                       (_ #f)))) #f l))
+       (define (is-fast l)
+         (fold (lambda (x pred)
+                 (if pred
+                     pred
+                     (match x
+                       (('fast) #t)
+                       (_ #f)))) #f l))
+       
+       
+       (let* ((class   (string->symbol class))
+              (parents (match parents
+                         (#f
+                          '())
+                         ((#:arglist args . _)
+                          (map (g vs exp) args))))
+              (is-func (is-functional parents))
+              (is-fast (is-fast       parents))
+              (kind    (if is-func
+                           (if is-fast
+                               'mk-pf-class
+                               'mk-pyf-class)
+                           (if is-fast
+                               'mk-p-class
+                               'mk-py-class)))              
+              (parents (filt parents)))
+         `(define ,class (,(O 'wrap)
+                          (,(O kind)
+                           ,class
+                           ,(map (lambda (x) `(,(O 'get-class) ,x)) parents)
+                          #:const
+                          ,(match (exp vs defs)
+                             ((begin . l)
+                              l)
+                             (l l))
+                          #:dynamic
+                          ()))))))
+                          
+       
+    
+    ((#:for e in code . #f)
+     (=> next)
+     (match e
+       (((#:power (#:identifier x . _) () . #f))
+        (match in
+          (((#:test power . _))
+           (match power
+             ((#:power
+               (#:identifier "range" . _)
+               ((#:arglist arglist . _))
+               . _)
+              (match arglist
+                ((arg)
+                 (let ((v   (gensym "v"))
+                       (x   (string->symbol x))
+                       (lp  (gensym "lp")))
+                   `(let ((,v ,(exp vs arg)))
+                      (let ,lp ((,x 0))
+                           (if (< ,x ,v)
+                               (begin
+                                 ,(exp vs code)
+                                 (,lp (+ ,x 1))))))))
+                ((arg1 arg2)
+                 (let ((v1   (gensym "va"))
+                       (v2   (gensym "vb"))
+                       (lp  (gensym "lp")))
+                   `(let ((,v1 ,(exp vs arg1))
+                          (,v2 ,(exp vs arg2)))
+                      (let ,lp ((,x ,v1))
+                           (if (< ,x ,v2)
+                               (begin
+                                 ,(exp vs code)
+                                 (,lp (+ ,x 1))))))))
+                ((arg1 arg2 arg3)
+                 (let ((v1   (gensym "va"))
+                       (v2   (gensym "vb"))
+                       (st   (gensym "vs"))
+                       (lp  (gensym "lp")))
+                   `(let ((,v1 ,(exp vs arg1))
+                          (,st ,(exp vs arg2))
+                          (,v2 ,(exp vs arg3)))
+                      (if (> st 0)
+                          (let ,lp ((,x ,v1))
+                               (if (< ,x ,v2)
+                                   (begin
+                                     ,(exp vs code)
+                                     (,lp (+ ,x ,st)))))
+                          (if (< st 0)
+                              (let ,lp ((,x ,v1))
+                                   (if (> ,x ,v2)
+                                       (begin
+                                         ,(exp vs code)
+                                         (,lp (+ ,x ,st)))))
+                              (error "range with step 0 not allowed"))))))
+                (_ (next))))
+             (_ (next))))
+          (_ (next))))
+       (_ (next))))
     
     ((#:while test code else)
      (let ((lp (gensym "lp")))
@@ -201,7 +330,7 @@
               (begin
                 ,(exp vs code)
                 (,lp))
-              ,(exp else)))))
+              ,(exp vs else)))))
     
     ((#:try x exc else fin)
      (define (f x)
@@ -221,27 +350,27 @@
                  (lp `(catch ,(exp vs e)
                         (lambda () ,code)
                         (lambda ,(gensym "x")
-                          ,(exp c))) l))
+                          ,(exp vs c))) l))
                 ((((e . as) c) . l)
                  (lp `(let ((,as ,(exp vs e)))
                         (catch ,as
                           (lambda () ,code)
                           (lambda ,(gensym "x")
-                            ,(exp vs c))) l)))
+                            ,(exp vs c)))) l))
                 (()
                  code))))
           (lambda () ,(exp vs fin)))))
 
-    ((#:def (#:identifier f)
+    ((#:def (#:identifier f . _)
             (#:types-args-list
              args
-             #f)
+             #f #f)
             #f
             code)
      (let* ((f  (string->symbol f))
             (r  (gensym "return"))
             (as (map (lambda (x) (match x
-                                  ((((#:identifier x) . #f) #f)
+                                  ((((#:identifier x . _) . #f) #f)
                                    (string->symbol x))))
                      args))
             (vs (union as vs))
@@ -249,11 +378,12 @@
             (df (defs code '()))
             (ls (diff (diff ns vs) df)))
        
-       `(define (,f ,@as) (,(C 'with-return) ,r
-                            (let ,(map (lambda (x) (list x #f)) ls)
-                              ,(with-fluids ((return r))
-                                  (exp ns code)))))))
-
+       `(define ,f (lambda (,@as)
+                     (,(C 'with-return) ,r
+                      (let ,(map (lambda (x) (list x #f)) ls)
+                        ,(with-fluids ((return r))
+                           (exp ns code))))))))
+     
     ((#:global . _)
      '(values))
     
@@ -269,21 +399,35 @@
     ((#:expr-stmt (l) (#:assign))
      (exp vs l))
 
+    ((#:expr-stmt l (#:assign u))
+     (cond
+      ((= (length l) (length u))
+       (cons 'begin (map make-set (map (lambda x vs) l) l (map (g vs exp) u))))
+      ((= (length u) 1)
+       (let ((vars (map (lambda (x) (gensym "v")) l)))
+         `(call-with-values (lambda () (exp vs (car u)))
+            (lambda vars
+              ,@(map make-set l vars)))))))
+                             
+            
+
     ((#:return . x)
      `(,(fluid-ref return) ,@(map (g vs exp) x)))
     
     ((#:expr-stmt
-      ((#:test (#:power (#:identifier v) () . #f) #f))
+      ((#:test (#:power (#:identifier v . _) () . #f) #f))
       (#:assign (l)))
      (let ((s (string->symbol v)))
        `(set! ,s ,(exp vs l))))
                            
-        
-    ((#:comp . l)
+    ((#:comp x #f)
+     (exp vs x))
+
+    ((#:comp x (op . y))
      (define (tr op x y)
        (match op
          ((or "<" ">" "<=" ">=")
-          (list (string->symbol op) x y))
+          (list (G (string->symbol op)) x y))
          ("!="    (list 'not (list 'equal? x y)))
          ("=="    (list 'equal? x y))
          ("is"    (list 'eq? x y))
@@ -291,19 +435,37 @@
          ("in"    (list 'member x y))
          ("notin" (list 'not (list 'member x y)))
          ("<>"    (list 'not (list 'equal? x y)))))
-     (let lp ((l l))
-       (match l
-         (()
-          '())
-         ((x op y)
-          (tr op (exp vs x) (exp vs y)))
-         ((x op . l)
-          (tr op (exp vs x) (lp vs l))))))))
+     (tr op (exp vs x) (exp vs y)))
+    
+    (x x)))
 
 (define (comp x)
+  (define start
+    (match (pr 'start x)
+      (((#:stmt
+         ((#:expr-stmt
+           ((#:test
+             (#:power
+              (#:identifier "module" . _)
+              ((#:arglist arglist #f #f))
+              . #f) #f))
+           (#:assign)))) . _)
+       (let ()
+         (define args
+           (map (lambda (x)
+                  (exp '() x))
+                arglist))
+
+         `((,(G 'define-module) (language python module ,@args)))))
+      (x '())))
+  
+  (if (pair? start)
+      (set! x (cdr x)))
+
   (let ((globs (get-globals x)))
     `(begin
-       ,@(map (lambda (s) `(define ,s (values))) globs)
+       ,@start
+       ,@(map (lambda (s) `(,(C 'var) ,s)) globs)
        ,@(map (g globs exp) x))))
 
 (define-syntax with-return
@@ -376,10 +538,17 @@
 
     (syntax-case x ()
       ((_ ret  l)
-       (pf (let ((code (analyze #'ret #'l)))
-            (if (is-ec #'ret #'l #t)
-                #`(let/ec ret #,code)
-                code)))))))
+       (let ((code (analyze #'ret #'l)))
+         (if (is-ec #'ret #'l #t)
+             #`(let/ec ret #,code)
+             code))))))
+
+(define-syntax call
+  (syntax-rules ()
+    ((_ (f) . l) (f . l))))
+
+(define-syntax-rule (var v)
+  (if (defined? 'v)
+      (values)
+      (define! 'v #f)))
 
-       
-  
diff --git a/modules/language/python/parser.scm b/modules/language/python/parser.scm
index 55c0d2d..55fc02e 100644
--- a/modules/language/python/parser.scm
+++ b/modules/language/python/parser.scm
@@ -590,12 +590,12 @@
 
 (set! test
   (f-or! 'test
-   (f-list #:test
-           (Ds or_test)           
-           (ff? (f-list 
-                 (f-seq "if" (Ds or_test))
-                 (f-seq "else" test))))
-   (Ds lambdef)))
+    (f-list #:test
+            (Ds or_test)           
+            (ff? (f-list 
+                  (f-seq "if" (Ds or_test))
+                  (f-seq "else" test))))
+    (Ds lambdef)))
 
 (define test_nocond
   (f-or 'nocond (Ds or_test) (Ds lambdef_nocond)))
@@ -709,9 +709,9 @@
     mk-id))
 
 (set! power
-  (p-freeze 'power
-    (f-cons 'power #:power
-       (f-cons (Ds atom) 
+  (p-freeze 'power            
+    (f-cons 'power #:power                    
+       (f-cons (f-or (f-list #:f (Ds identifier) ":" (Ds atom)) (Ds atom)) 
    	  (f-cons (ff* (Ds trailer))
                   (f-or! (f-seq "**" factor)
                          FALSE))))
@@ -721,7 +721,7 @@
   (f-or! 'trailer
    (f-seq "(" (ff? (Ds arglist)) ")")
    (f-seq "[" (Ds subscriptlist) "]")
-   (f-seq "." identifier)))
+   (f-seq (f-list #:dot (ff+ "." identifier))))
 
 (set! atom
   (p-freeze 'atom
diff --git a/modules/language/python/spec.scm b/modules/language/python/spec.scm
index 1389165..c22c0b4 100644
--- a/modules/language/python/spec.scm
+++ b/modules/language/python/spec.scm
@@ -1,5 +1,5 @@
 (define-module (language python spec)
-  #:use-module (language python parser)
+  #:use-module (parser stis-parser lang python3-parser)
   #:use-module (language python compile)
   #:use-module (rnrs io ports)
   #:use-module (ice-9 pretty-print)
@@ -14,7 +14,13 @@
 ;;; Language definition
 ;;;
 
-(define (pr . x) (pretty-print x) (car (reverse  x)))
+(define (pr . x)
+  (define port (open-file "/home/stis/src/python-on-guile/log.txt" "a"))
+  (with-output-to-port port
+    (lambda ()
+      (pretty-print x) (car (reverse  x))))
+  (close port)
+  (car (reverse x)))
 
 (define (c x) (pr (comp (pr (p (pr x))))))
 (define (cc port x)
@@ -33,7 +39,7 @@
                 (lambda ()
                   ;; Ideally we'd duplicate the whole module hierarchy so that `set!',
                   ;; `fluid-set!', etc. don't have any effect in the current environment.
-                  (let ((m (make-fresh-user-module)))
+                  (let ((m (make-fresh-user-module)))                    
                     ;; Provide a separate `current-reader' fluid so that
                     ;; compile-time changes to `current-reader' are
                     ;; limited to the current compilation unit.
diff --git a/modules/oop/pf-objects.scm b/modules/oop/pf-objects.scm
new file mode 100644
index 0000000..4ff3d23
--- /dev/null
+++ b/modules/oop/pf-objects.scm
@@ -0,0 +1,528 @@
+(define-module (oop pf-objects)
+  #:use-module (oop goops)
+  #:use-module (ice-9 vlist)
+  #:export (set ref make-pf <pf> call with copy fset fcall make-p put put!
+                pcall pcall! get
+                mk
+                def-pf-class  mk-pf-class  make-pf-class
+                def-p-class   mk-p-class   make-p-class
+                def-pyf-class mk-pyf-class make-pyf-class
+                def-py-class  mk-py-class  make-py-class))
+
+#|
+Python object system is basically syntactic suger otop of a hashmap and one
+this project is inspired by the python object system and what it measn when
+one in stead of hasmaps use functional hashmaps. We use vhashes, but those have a drawback in that those are not thread safe. But it is a small effort to work
+with assocs or tree like functional hashmaps in stead.
+
+The hashmap works like an assoc e.g. we will define new values by 'consing' a
+new binding on the list and when the assoc take up too much space it will be
+reshaped and all extra bindings will be removed.
+
+The datastructure is functional but the objects mutate. So one need to 
+explicitly tell it to not update etc.
+|#
+
+(define-syntax-rule (aif it p x y) (let ((it p)) (if it x y)))
+                
+(define-class <p> () h)
+(define-class <pf> (<p>) size n)         ; the pf object consist of a functional
+                                         ; hashmap it's size and number of live
+                                         ; object
+(define-class <py>  (<p>))
+(define-class <pyf> (<pf>))
+
+;; Make an empty pf object
+(define (make-pf)
+  (define r (make <pf>))
+  (slot-set! r 'h vlist-null)
+  (slot-set! r 'size 0)
+  (slot-set! r 'n 0)
+  r)
+
+(define (make-p)
+  (define r (make <p>))
+  (slot-set! r 'h (make-hash-table))
+  r)
+
+(define fail (cons 'fail '()))
+(define-syntax-rule (mrefx x key l)
+  (let ((h (slot-ref x 'h)))
+    (define pair (vhash-assq key h))
+    (define (end)
+      (if (null? l)
+          #f
+          (car l)))
+    (define (parents)
+      (let ((pair (vhash-assq '__parents__ h)))
+        (if (pair? pair)
+            (let lp ((li (cdr pair)))
+              (if (pair? li)
+                  (let ((r (ref (car li) key fail)))
+                    (if (eq? r fail)
+                        (lp (cdr li))
+                        r))
+                  (end)))
+            (end))))
+
+    (if pair
+        (cdr pair)
+        (let ((cl (ref x '__class__)))
+          (if cl
+              (let ((r (ref cl key fail)))
+                (if (eq? r fail)
+                    (parents)
+                    r))
+              (parents))))))
+
+(define-syntax-rule (mrefx- x key l)
+  (let* ((h (slot-ref x 'h))
+         (r (hash-ref x key fail)))
+    (if (eq? r fail)
+        (if (pair? l)
+            (car l)
+            #f)
+        r)))
+
+(define not-implemented (cons 'not 'implemeneted))
+
+(define-syntax-rule (mrefx-py- x key l)
+  (let ((f (mref- x '__ref__ '())))
+    (if (or (not f) (eq? f not-implemented))
+        (mref- x key l)
+        (apply f x key l))))
+
+(define-syntax-rule (mrefx-py x key l)
+  (let ((f (mref x '__ref__ '())))
+    (if (or (not f) (eq? f not-implemented))
+        (mref    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 <pf> )  key . l) (mref     x key l))
+(define-method (ref (x <p>  )  key . l) (mref-    x key l))
+(define-method (ref (x <pyf>)  key . l) (mref-py  x key l))
+(define-method (ref (x <py> )  key . l) (mref-py- x key l))
+
+
+
+;; the reshape function that will create a fresh new pf object with less size
+;; this is an expensive operation and will only be done when we now there is
+;; a lot to gain essentially tho complexity is as in the number of set
+(define (reshape x)
+  (let ((h (slot-ref x 'h))
+        (m (make-hash-table))
+        (n 0))
+    (define h2 (vhash-fold (lambda (k v s)
+                             (if (hash-ref m k #f)
+                                 s
+                                 (begin
+                                   (hash-set! m k #t)
+                                   (set! n (+ n 1))
+                                   (vhash-consq k v s))))
+                           vlist-null
+                           h))
+    (slot-set! x 'h h2)
+    (slot-set! x 'size n)
+    (slot-set! x 'n    n)
+    (values)))
+
+;; on object x add a binding that key -> val
+(define-syntax-rule (mset x key val)
+  (let ((h (slot-ref x 'h))
+        (s (slot-ref x 'size))
+        (n (slot-ref x 'n)))
+    (slot-set! x 'size (+ 1 s))
+    (let ((r (vhash-assq key h)))
+      (when (not r)
+        (slot-set! x 'n (+ n 1)))
+      (slot-set! x 'h (vhash-consq key val h))
+      (when (> s (* 2 n))
+        (reshape x))
+      (values))))
+
+(define-syntax-rule (mset-py x key val)
+  (let ((f (mref-py x '__set__ '())))
+    (if (or (eq? f not-implemented) (not f))
+        (mset x key val)
+        (f key val))))
+        
+
+(define-syntax-rule (mset- x key val)
+  (let ((h (slot-ref x 'h)))
+    (hash-set! h key val)))
+
+(define-syntax-rule (mset-py- x key val)
+  (let ((f (mref-py- x '__set__ '())))
+    (if (or (eq? f not-implemented) (not f))
+        (mset- x key val)
+        (f key val))))
+
+(define-method (set (x <pf>)  key val) (mset     x key val))
+(define-method (set (x <p>)   key val) (mset-    x key val))
+(define-method (set (x <pyf>) key val) (mset-py  x key val))
+(define-method (set (x <py>)  key val) (mset-py- x key val))
+
+
+;; mref will reference the value of the key in the object x, an extra default
+;; parameter will tell what the fail object is else #f if fail
+;; if there is no found binding in the object search the class and
+;; the super classes for a binding
+
+
+;; call a function as a value of key in x with the object otself as a first
+;; parameter, this is pythonic object semantics
+(define-syntax-rule (mk-call mcall mref)
+  (define-syntax-rule (mcall x key l)
+    (apply (mref x key '()) l)))
+
+(mk-call mcall     mref)
+(mk-call mcall-    mref-)
+(mk-call mcall-py  mref-py)
+(mk-call mcall-py- mref-py-)
+  
+(define-method (call (x <pf>)  key . l) (mcall     x key l))
+(define-method (call (x <p>)   key . l) (mcall-    x key l))
+(define-method (call (x <pyf>) key . l) (mcall-py  x key l))
+(define-method (call (x <py>)  key . l) (mcall-py- x key l))
+
+
+;; make a copy of a pf object
+(define-syntax-rule (mcopy x)
+  (let ((r (make <pf>)))
+    (slot-set! r 'h (slot-ref x 'h))
+    (slot-set! r 'size (slot-ref x 'size))
+    (slot-set! r 'n (slot-ref x 'n))
+    r))
+
+(define-syntax-rule (mcopy- x)
+  (let* ((r (make-p))
+         (h (slot-ref r 'h)))
+    (hash-for-each (lambda (k v) (hash-set! h k v)) (slot-ref x 'h))
+    r))
+
+(define-method (copy (x <pf>)) (mcopy  x))
+(define-method (copy (x <p> )) (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 <pf>) key val)
+  (let ((x (mcopy x)))
+    (mset x key val)
+    x))
+
+(define-method (fset (x <p>) key val)
+  (let ((x (mcopy- x)))
+    (mset x key val)
+    x))
+
+;; 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 <pf>) key . l)
+  (let* ((y (mcopy x))
+         (r (mcall y key l)))
+    (if (eq? (slot-ref x 'h) (slot-ref y 'h))
+        (values r x)
+        (values r y))))
+
+(define-method (fcall (x <p>) 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 <p>) y)
+      (call x '__add__ y))
+
+    (define-method (+ x (y <p>))
+      (call y '__radd__ x))
+
+    (define-method (+ (x <py>) y)
+      (let ((f (mref-py- x '__add__ '())))
+        (if f
+            (f y)
+            (+x y x))))
+
+    (define-method (+ (x <pyf>) y)
+      (let ((f (mref-py x '__add__ '())))
+        (if f
+            (let ((res (f y)))
+              (if (eq? res not-implemented)                  
+                  (+x y x)
+                  res))
+            (+x y x))))
+
+    (define-method (+ (x <py>) y)
+      (let ((f (mref-py- x '__add__ '())))
+        (if f
+            (let ((res (f y)))
+              (if (eq? res not-implemented)                  
+                  (+x y x)
+                  res))
+            (+x y x))))
+    
+    (define-method (+ x (y <py>))
+      (call y '__radd__ x))
+
+    (define-method (+ x (y <pyf>))
+      (call y '__radd__ x))
+    
+    (define-method (+x (x <p>) 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 <pf>))
+  (slot-set! out 'h h)
+  (slot-set! out 'n n)
+  (slot-set! out 'size s)
+  out)
+
+(define (union- x y)
+  (define hx (slot-ref x 'h))
+  (define hy (slot-ref y 'h))  
+  (define out (make <p>))
+  (hash-for-each (lambda (k v) (hash-set! hy k v)) hx)
+  (slot-set! out 'h hy)
+  out)
+
+
+;; make a class. A class add some meta information to allow for multiple
+;; inherritance and add effectively static data to the object the functional
+;; datastructure show it's effeciency now const is data that will not change
+;; and bindings that are added to all objects. Dynamic is the mutating class
+;; information. supers is a list of priorities
+(define-syntax-rule (mk-pf make-pf-class <pf>)
+  (define-syntax make-pf-class
+    (lambda (x)
+      (syntax-case x ()
+        ((_ name const dynamic (supers (... ...)))
+         (with-syntax (((sups (... ...)) (generate-temporaries
+                                          #'(supers (... ...)))))
+           #'(let ((sups supers) (... ...))
+               (define class dynamic)
+               (define-class name (sups (... ...) <pf>))
+               (put! class.__const__
+                     (union const
+                            (let lp ((sup (list sups (... ...))))
+                              (if (pair? sup)
+                                  (union (ref (car sup) '__const__  null)
+                                         (lp (cdr sup)))
+                                  null))))
+  
+               (reshape (get class.__const__ null))
+               
+               (put! class.__goops__    name)
+               (put! class.__name__     'name)
+               (put! class.__parents__  (list sups (... ...)))
+               
+               (put! class.__const__.__name__    (cons 'name 'obj))
+               (put! class.__const__.__class__   class)
+               (put! class.__const__.__parents__ (list sups (... ...)))
+               class)))))))
+
+(mk-pf make-pf-class <pf>)
+(mk-pf make-pyf-class <pyf>)
+
+(define-syntax-rule (mk-p make-p-class <p>)
+  (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-class name (sups (... ...) <p>))
+               (put! class.__const__
+                     (union- const
+                             (let lp ((sup (list sups (... ...))))
+                               (if (pair? sup)
+                                   (union- (ref (car sup) '__const__  null)
+                                           (lp (cdr sup)))
+                                   (make-p)))))
+    
+
+               (put! class.__goops__    name)
+               (put! class.__name__     'name)
+               (put! class.__parents__  (list sups (... ...)))
+
+               (put! class.__const__.__name__    (cons 'name 'obj))
+               (put! class.__const__.__class__   class)
+               (put! class.__const__.__parents__ (list sups (... ...)))
+             
+               (union- class (get class.__const__)))))))))
+         
+(mk-p  make-p-class  <p>)
+(mk-p  make-py-class <py>)
+
+;; Let's make an object essentially just move a reference
+(define-method (mk (x <pf>) . l)
+  (let ((r (get x.__const__))
+        (k (make (get x.__goops__))))
+    (slot-set! k 'h (slot-ref r 'h))
+    (slot-set! k 'size (slot-ref r 'size))
+    (slot-set! k 'n (slot-ref r 'n))
+    (apply (ref k '__init__ (lambda x (values))) k l)
+    k))
+
+(define-method (mk (x <p>) . l)
+  (let ((k (make (get x.__goops__))))
+    (put! k.__class__ x)
+    (apply (ref k '__init__ (lambda x (values))) k l)
+    k))
+
+;; 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 class)
+    ret))
+
+(define (get-class x)
+  (aif it (procedure-property x 'pyclass)
+       it
+       (error "not a class")))
+
+                 
diff --git a/modules/oop/pf-objects.scm~ b/modules/oop/pf-objects.scm~
new file mode 100644
index 0000000..a8f120e
--- /dev/null
+++ b/modules/oop/pf-objects.scm~
@@ -0,0 +1,502 @@
+(define-module (oop pf-objects)
+  #:use-module (oop goops)
+  #:use-module (ice-9 vlist)
+  #:export (set ref make-pf <pf> call with copy fset fcall make-p put put!
+                pcall pcall! get
+                mk
+                def-pf-class  mk-pf-class  make-pf-class
+                def-p-class   mk-p-class   make-p-class
+                def-pyf-class mk-pyf-class make-pyf-class
+                def-py-class  mk-py-class  make-py-class
+
+#|
+Python object system is basically syntactic suger otop of a hashmap and one
+this project is inspired by the python object system and what it measn when
+one in stead of hasmaps use functional hashmaps. We use vhashes, but those have a drawback in that those are not thread safe. But it is a small effort to work
+with assocs or tree like functional hashmaps in stead.
+
+The hashmap works like an assoc e.g. we will define new values by 'consing' a
+new binding on the list and when the assoc take up too much space it will be
+reshaped and all extra bindings will be removed.
+
+The datastructure is functional but the objects mutate. So one need to 
+explicitly tell it to not update etc.
+|#
+
+(define-class <p> () h)
+(define-class <pf> (<p>) size n)         ; the pf object consist of a functional
+                                         ; hashmap it's size and number of live
+                                         ; object
+(define-class <py>  (<p>))
+(define-class <pyf> (<pf>))
+
+;; Make an empty pf object
+(define (make-pf)
+  (define r (make <pf>))
+  (slot-set! r 'h vlist-null)
+  (slot-set! r 'size 0)
+  (slot-set! r 'n 0)
+  r)
+
+(define (make-p)
+  (define r (make <p>))
+  (slot-set! r 'h make-hash-table)
+  r)
+
+(define fail (cons 'fail '()))
+(define-syntax-rule (mrefx x key l)
+  (let ((h (slot-ref x 'h)))
+    (define pair (vhash-assq key h))
+    (define (end)
+      (if (null? l)
+          #f
+          (car l)))
+    (define (parents)
+      (let ((pair (vhash-assq '__parents__ h)))
+        (if (pair? pair)
+            (let lp ((li (cdr pair)))
+              (if (pair? li)
+                  (let ((r (ref (car li) key fail)))
+                    (if (eq? r fail)
+                        (lp (cdr li))
+                        r))
+                  (end)))
+            (end))))
+
+    (if pair
+        (cdr pair)
+        (let ((cl (ref x '__class__)))
+          (if cl
+              (let ((r (ref cl key) fail))
+                (if (eq? r fail)
+                    (parents)
+                    r))
+              (parents))))))
+
+(define-syntax-rule (mrefx- x key l)
+  (let* ((h (slot-ref x 'h))
+         (r (hash-ref x key fail)))
+    (if (eq? r fail)
+        (if (pair? l)
+            (car l)
+            #f)
+        r))))
+
+(define not-implemented (cons 'not 'implemeneted))
+
+(define-syntax-rule (mrefx-py- x key l)
+  (let ((f (mref- x '__ref__)))
+    (if (or (not f) (eq? f not-implemented))
+        (mref- x key l)
+        (apply f x key l))))
+
+(define-syntax-rule (mrefx-py x key l)
+  (let ((f (mref x '__ref__)))
+    (if (or (not f) (eq? f not-implemented))
+        (mref    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 <pf> )  key . l) (mref     x key l))
+(define-method (ref (x <p>  )  key . l) (mref-    x key l))
+(define-method (ref (x <pyf>)  key . l) (mref-py  x key l))
+(define-method (ref (x <py> )  key . l) (mref-py- x key l))
+
+
+
+;; the reshape function that will create a fresh new pf object with less size
+;; this is an expensive operation and will only be done when we now there is
+;; a lot to gain essentially tho complexity is as in the number of set
+(define (reshape x)
+  (let ((h (slot-ref x 'h))
+        (m (make-hash-table))
+        (n 0))
+    (define h2 (vhash-fold (lambda (k v s)
+                             (if (hash-ref m k #f)
+                                 s
+                                 (begin
+                                   (hash-set! m k #t)
+                                   (set! n (+ n 1))
+                                   (vhash-consq k v s))))
+                           vlist-null
+                           h))
+    (slot-set! x 'h h2)
+    (slot-set! x 'size n)
+    (slot-set! x 'n    n)
+    (values)))
+
+;; on object x add a binding that key -> val
+(define-syntax-rule (mset x key val)
+  (let ((h (slot-ref x 'h))
+        (s (slot-ref x 'size))
+        (n (slot-ref x 'n)))
+    (slot-set! x 'size (+ 1 s))
+    (let ((r (vhash-assq key h)))
+      (when (not r)
+        (slot-set! x 'n (+ n 1)))
+      (slot-set! x 'h (vhash-consq key val h))
+      (when (> s (* 2 n))
+        (reshape x))
+      (values))))
+
+(define-syntax-rule (mset-py x key val)
+  (let ((f (mref-py x '__set__)))
+    (if (or (eq? f not-implemented) (not f))
+        (mset x key val)
+        (f key val))))
+        
+
+(define-syntax-rule (mset- x key val)
+  (let ((h (slot-ref x 'h)))
+    (hash-set! h key val)))
+
+(define-syntax-rule (mset-py- x key val)
+  (let ((f (mref-py- x '__set__)))
+    (if (or (eq? f not-implemented) (not f))
+        (mset- x key val)
+        (f key val))))
+
+(define-method (set (x <pf>)  key val) (mset     x key val))
+(define-method (set (x <p>)   key val) (mset-    x key val))
+(define-method (set (x <pyf>) key val) (mset-py  x key val))
+(define-method (set (x <py>)  key val) (mset-py- x key val))
+
+
+;; mref will reference the value of the key in the object x, an extra default
+;; parameter will tell what the fail object is else #f if fail
+;; if there is no found binding in the object search the class and
+;; the super classes for a binding
+
+
+;; call a function as a value of key in x with the object otself as a first
+;; parameter, this is pythonic object semantics
+(define-syntax-rule (mk-call mcall mref)
+  (define-syntax-rule (mcall x key l)
+    (apply (mref y key '()) l)))
+
+(mk-call mcall     mref)
+(mk-call mcall-    mref-)
+(mk-call mcall-py  mref-py)
+(mk-call mcall-py- mref-py-)
+  
+(define-method (call (x <pf>)  key . l) (mcall     x key l))
+(define-method (call (x <p>)   key . l) (mcall-    x key l))
+(define-method (call (x <pyf>) key . l) (mcall-py  x key l))
+(define-method (call (x <py>)  key . l) (mcall-py- x key l))
+
+
+;; make a copy of a pf object
+(define-syntax-rule (mcopy x)
+  (let ((r (make <pf>)))
+    (slot-set! r 'h (slot-ref x 'h))
+    (slot-set! r 'size (slot-ref x 'size))
+    (slot-set! r 'n (slot-ref x 'n))
+    r))
+
+(define-syntax-rule (mcopy- x)
+  (let ((r (make-p))
+        (h (slot-ref r 'h)))
+    (hash-for-each (lambda (k v) (hash-set! h k v)) (slot-ref x 'h))
+    r))
+
+(define-method (copy (x <pf>)) (mcopy  x))
+(define-method (copy (x <p> )) (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 <pf>) key val)
+  (let ((x (mcopy x)))
+    (mset x key val)
+    x))
+
+(define-method (fset (x <p>) key val)
+  (let ((x (mcopy- x)))
+    (mset x key val)
+    x))
+
+;; 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 <pf>) key . l)
+  (let* ((y (mcopy x))
+         (r (mcall y key l)))
+    (if (eq? (slot-ref x 'h) (slot-ref y 'h))
+        (values r x)
+        (values r y))))
+
+(define-method (fcall (x <p>) 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 <p>) y)
+      (call x '__add__ y))
+
+    (define-method (+ x (y <p>))
+      (call y '__radd__ x))
+
+    (define-method (+ (x <py>) y)
+      (let ((f (mref-py- x '__add__)))
+        (if f
+            (f y)
+            (+x y x))))
+
+    (define-method (+ (x <pyf>) y)
+      (let ((f (mref-py x '__add__)))
+        (if f
+            (let ((res (f y)))
+              (if (eq? res not-implemented)                  
+                  (+x y x)
+                  res))
+            (+x y x))))
+
+    (define-method (+ (x <py>) y)
+      (let ((f (mref-py- x '__add__)))
+        (if f
+            (let ((res (f y)))
+              (if (eq? res not-implemented)                  
+                  (+x y x)
+                  res))
+            (+x y x))))
+    
+    (define-method (+ x (y <py>))
+      (call y '__radd__ x))
+
+    (define-method (+ x (y <pyf>))
+      (call y '__radd__ x))
+    
+    (define-method (+x (x <p>) 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 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 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 <pf>))
+  (slot-set! out 'h h)
+  (slot-set! out 'n n)
+  (slot-set! out 'size s)
+  out)
+
+(define (union- x y)
+  (define hx (slot-ref x 'h))
+  (define hy (slot-ref y 'h))  
+  (define out (make <p>))
+  (hash-for-each (lambda (k v) (hash-set! hy k v)) hx)
+  (slot-set! out 'h hy)
+  out)
+
+
+;; make a class. A class add some meta information to allow for multiple
+;; inherritance and add effectively static data to the object the functional
+;; datastructure show it's effeciency now const is data that will not change
+;; and bindings that are added to all objects. Dynamic is the mutating class
+;; information. supers is a list of priorities
+(define-syntax-rule (mk-pf make-pf-class <pf>)
+  (define (make-pf-class name const dynamic supers)
+    (define class dynamic)
+    (define-class <pf> (<pf>))
+    (put! class.__const__
+          (union const
+                 (let lp ((sup supers))
+                   (if (pair? sup)
+                       (union (ref (car sup) '__const__  null)
+                              (lp (cdr supers)))
+                       null))))
+  
+    (reshape (get class.__const__ null))
+
+    (put! class.__goops__    <pf>)
+    (put! class.__name__     name)
+    (put! class.__parents__  supers)
+
+    (put! class.__const__.__name__    (cons name 'obj))
+    (put! class.__const__.__class__   class)
+    (put! class.__const__.__parents__ supers)
+    class))
+
+(mk-pf make-pf-class <pf>)
+(mk-pf make-pf-class <pyf>)
+
+(define-syntax-rule (mk-p make-p-class <p>)
+  (define (make-p-class name const dynamic supers)
+    (define class dynamic)
+    (define-class <p> (<p>))
+    (put! class.__const__
+          (union- const
+                  (let lp ((sup supers))
+                    (if (pair? sup)
+                        (union- (ref (car sup) '__const__  null)
+                                (lp (cdr supers)))
+                        (make-p)))))
+    
+
+    (put! class.__goops__    <p>)
+    (put! class.__name__     name)
+    (put! class.__parents__  supers)
+
+    (put! class.__const__.__name__    (cons name 'obj))
+    (put! class.__const__.__class__   class)
+    (put! class.__const__.__parents__ supers)
+  
+    (union- class (get class.__const__))))
+
+(mk-p  make-p-class  <p>)
+(mk-py make-py-class <py>)
+
+;; Let's make an object essentially just move a reference
+(define-method (mk (x <pf>) . l)
+  (let ((r (get x.__const__))
+        (k (make (get class.__goops__))))
+    (slot-set! k 'h (slot-ref r 'h))
+    (slot-set! k 'size (slot-ref r 'size))
+    (slot-set! k 'n (slot-ref r 'n))
+    (apply (ref k '__init__ (lambda x (values))) k l)
+    k))
+
+(define-method (mk (x <p>) . l)
+  (let ((k (make (get x.__goops__))))
+    (put! r.__class__ x)
+    (apply (ref r '__init__ (lambda x (values))) r l)
+    r))
+
+;; the make class and defclass syntactic sugar
+(define-syntax-rule (mk-p/f 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)                 
+                       (list parents (... ...))))
+      name)))
+
+(mk-p/f mk-pf-class  make-pf-class)
+(mk-p/f mk-p-class   make-p-class)
+(mk-p/f mk-pyf-class make-pyf-class)
+(mk-p/f 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)))
+
-- 
cgit v1.2.3