applicable structs used

1 files changed, 75 insertions, 75 deletions

diff --git a/modules/oop/pf-objects.scm b/modules/oop/pf-objects.scm
index c036144..50ea983 100644
--- a/modules/oop/pf-objects.scm
+++ b/modules/oop/pf-objects.scm
@@ -5,12 +5,11 @@
   #:export (set ref make-pf <p> <py> <pf> <pyf>
                 call with copy fset fcall make-p put put!
                 pcall pcall! get fset-x
-                mk wrap
                 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
-                define-python-class
+                define-python-class get-type
                 ))
 #|
 Python object system is basically syntactic suger otop of a hashmap and one
@@ -27,24 +26,56 @@ 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 <p>  (<applicable-struct>) 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>))
 
+(define (mk x)
+  (letrec ((o (make (ref x '__goops__))))
+    (slot-set! o 'procedure
+               (lambda x
+                 (apply
+                  (ref o '__call__ (lambda x (error "no __call__ method")))
+                  x)))
+    (cond
+     ((is-a? x <pf>)
+      (let ((r (ref x '__const__)))
+        (slot-set! o 'h    (slot-ref r 'h))
+        (slot-set! o 'size (slot-ref r 'size))
+        (slot-set! o 'n    (slot-ref r 'n))
+        o))
+     
+     ((is-a? x <p>)
+      (let ((r (ref x '__const__))
+            (h (make-hash-table)))        
+        (hash-set! h '__class__ x)
+        (slot-set! o 'h    h))
+      o))))
+          
+(define (make-pyclass x)
+  (letrec ((class (make x)))
+    (slot-set! class 'procedure
+               (lambda x
+                 (let ((obj (mk class)))
+                   (aif it (ref obj '__init__)
+                        (apply it x)
+                        (values))
+                   obj)))
+    class))
+
 ;; Make an empty pf object
 (define (make-pf)
-  (define r (make <pf>))
+  (define r (make-pyclass <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>))
+  (define r (make-pyclass <p>))
   (slot-set! r 'h (make-hash-table))
   r)
 
@@ -125,7 +156,7 @@ explicitly tell it to not update etc.
       (if (eq? r fail)
           (aif class (hash-ref h '__class__)
                (ret (find-in-class (slot-ref class 'h)))
-               fail)
+               (end))
           r))))
 
 (define not-implemented (cons 'not 'implemeneted))
@@ -160,16 +191,7 @@ explicitly tell it to not update etc.
 (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))
-(define-method (ref x key . l)
-  (define (end)   (if (pair? l) (car l) #f))
-  (if (procedure? x)
-      (aif it (procedure-property x 'pyclass)
-           (apply ref it key l)
-           (end))
-      (end)))
       
-
-
 ;; 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
@@ -277,7 +299,7 @@ explicitly tell it to not update etc.
 
 ;; make a copy of a pf object
 (define-syntax-rule (mcopy x)
-  (let ((r (make <pf>)))
+  (let ((r (make-pyclass <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))
@@ -468,7 +490,7 @@ explicitly tell it to not update etc.
      hy
      hx))
   
-  (define out (make <pf>))
+  (define out (make-pyclass <pf>))
   (slot-set! out 'h h)
   (slot-set! out 'n n)
   (slot-set! out 'size s)
@@ -500,24 +522,24 @@ explicitly tell it to not update etc.
                (define class dynamic)
                (define name (make-class (list 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))
+               (define __const__
+                 (union const
+                        (let lp ((sup (list sups (... ...))))
+                          (if (pair? sup)
+                              (union (ref (car sup) '__const__  null)
+                                     (lp (cdr sup)))
+                              null))))
                
-               (put! class.__goops__    name)
-               (put! class.__name__     'name)
-               (put! class.__parents__  (list sups (... ...)))
+               (reshape __const__)
+               (set  class '__const__    __const__)
+               (set  class '__goops__    name)
+               (set  class '__name__     'name)
+               (set  class '__parents__  (list sups (... ...)))
                
-               (put! class.__const__.__name__    (cons 'name 'obj))
-               (put! class.__const__.__class__   class)
-               (put! class.__const__.__parents__ (list sups (... ...)))
-               (put! class.__const__.__goops__   name)
+               (set  __const__ '__name__    'name)
+               (set  __const__ '__class__   class)
+               (set  __const__ '__parents__ (list sups (... ...)))
+               (set  __const__ '__goops__   name)
                class)))))))
 
 (mk-pf make-pf-class <pf>)
@@ -554,23 +576,6 @@ explicitly tell it to not update etc.
 (mk-p  make-py-class <py>)
 
 ;; Let's make an object essentially just move a reference
-(define-method (mk (x <pf>) . l)
-  (let ((r (ref x '__const__))
-        (o (make (ref x '__goops__))))
-    (slot-set! o 'h    (slot-ref r 'h))
-    (slot-set! o 'size (slot-ref r 'size))
-    (slot-set! o 'n    (slot-ref r 'n))
-    (apply (ref o '__init__ (lambda x (error "no init fkn"))) o l)
-    o))
-
-
-(define-method (mk (x <p>) . 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)
@@ -608,20 +613,12 @@ explicitly tell it to not update etc.
 (define-syntax-rule (def-py-class  name . l)
   (define name (mk-py-class name . l)))
 
-(define-syntax-rule (wrap name class)
-  (let* ((c    class)
-         (name (lambda x (apply mk c x))))
-    (set-procedure-property! name 'pyclass c)
-    name))
-
 (define (get-class o)
   (cond
-   ((procedure? o)
-    (aif it (procedure-property o 'pyclass)
-         it
-         (error "not an object ~a" o)))
+   ((is-a? o <p>)
+    o)
    (else
-    (class-of o))))
+    (error "not a pyclass"))))
 
 (define (get-type o)
   (cond
@@ -637,23 +634,26 @@ explicitly tell it to not update etc.
     'none)))
 
 (define (print o l)
+  (define p1 (if (pyclass? o) "Class" "Object"))
+  (define p2 (if (pyclass? o) "Class" "Object"))
   (define port (if (pair? l) (car l) #t))
-  (format port
-          (aif it (ref o '__repr__)
-               (it)
-               (format #f
-                       "~a:~a" (get-type o) (ref o '__name__ 'None)))))
+  (format port "~a"
+          (aif it (ref o '__repr__ #f)
+               (format
+                #f "~a(~a)<~a>" p1 (get-type o) (it))
+               (format
+                #f "~a(~a)<~a>" p2 (get-type o) (ref o '__name__ 'None)))))
 
 (define-method (write (o <p>) . l) (print o l))
 (define-method (display (o <p>) . l) (print o l))
 
-
-
 (define-syntax-rule (define-python-class name parents code ...)
   (define name
-    (wrap name
-          (mk-py-class name parents
-                       #:const
-                       (code ...)
-                       #:dynamic
-                       ()))))
+    (mk-py-class name parents
+                 #:const
+                 (code ...)
+                 #:dynamic
+                 ())))
+
+(define (pyclass? x)
+  (and (is-a? x <p>) (not (ref x '__class__))))