refactoring scheme macros out from the compilier

1 files changed, 69 insertions, 71 deletions

diff --git a/modules/oop/pf-objects.scm b/modules/oop/pf-objects.scm
index ca9a11b..c270e11 100644
--- a/modules/oop/pf-objects.scm
+++ b/modules/oop/pf-objects.scm
@@ -4,15 +4,14 @@
   #:use-module (ice-9 match)
   #:export (set ref make-pf <p> <py> <pf> <pyf>
                 call with copy fset fcall make-p put put!
-                pcall pcall! get next fset-x
-                mk
+                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
-                StopIteration GeneratorExit RuntimeError
-                Exception))
-
+                define-python-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
@@ -609,69 +608,68 @@ 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 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 GeneratorExit 'GeneratorExit)
-(define RuntimeError  'RuntimeError)
-
-(define-method (next (o <p>))
-  (catch StopIteration
-    (lambda () ((ref o '__next__)))
-    (lambda (x) #:nil)))
-       
-
-(define-inlinable (super-obj tag ex)
-  (let* ((classtag (ref tag '__class__ #f))
-         (exid     (ref ex '__goops__ #f)))
-    (let check-class ((tag classtag))
-      (if (and exid (eq? (ref tag '__goops__ #f) exid))
-          #t
-          (let lp ((parents (ref tag '__parents__ '())))
-            (if (pair? parents)
-                (or
-                 (check-class (car parents))
-                 (lp (cdr parents)))
-                #f))))))
-
-(define-inlinable (pyclass? x)
-  (and (procedure? x) (procedure-property x 'pyclass)))
-
-
-(define-method (testex py (tag <p>) (ex <p>) . l)
-  (super-obj tag ex))
-
-(define-method (testex py tag ex l)
-  (if (eq? py 'python)
-      (cond
-       ((pair? ex)
-        (or
-         (testex py tag (car ex) l)
-         (testex py tag (cdr ex) l)))
-       ((pyclass? ex)
-        =>
-        (lambda (cl)
-          (testex py tag cl l)))
-       (else
-        (eq? tag ex)))
-      #f))
-
-
-
-(define Exception
-  (wrap
-   (mk-py-class Exception ()
-                #:const
-                ((define __init__
-                   (lambda (self) (values))))                
-                #:dynamic
-                ())))
+(define-syntax-rule (wrap name class)
+  (let* ((c    class)
+         (name (lambda x (apply mk c x))))
+    (set-procedure-property! name 'pyclass c)
+    name))
+
+(define-method (write (o <p>) . l)
+  (aif it (ref o '__repr__)
+       (apply it l)
+       (apply display (format #f "object<p>: ~s" (class-name o)) l)))
+
+(define-method (display (o <p>) . l)
+  (aif it (ref o '__repr__)
+       (apply it l)
+       (apply display (format #f "object<p>: ~s" (class-name o)) l)))
+
+(define-method (write (o <p>) . l)
+  (aif it (ref o '__repr__)
+       (apply it l)
+       (apply display (format #f "object<p>: ~s" (class-name o)) l)))
+
+(define-method (display (o <p>) . l)
+  (aif it (ref o '__repr__)
+       (apply it l)
+       (apply display (format #f "object<pf>: ~s" (class-name o)) l)))
+
+(define-method (write (o <pf>) . l)
+  (aif it (ref o '__repr__)
+       (apply it l)
+       (apply display (format #f "object<pf>: ~s" (class-name o)) l)))
+
+(define-method (display (o <pf>) . l)
+  (aif it (ref o '__repr__)
+       (apply it l)
+       (apply display (format #f "object<p>: ~s" (class-name o)) l)))
+
+(define-method (write (o <py>) . l)
+  (aif it (ref o '__repr__)
+       (apply it l)
+       (apply display (format #f "object<py>: ~s" (class-name o)) l)))
+
+(define-method (display (o <py>) . l)
+  (aif it (ref o '__repr__)
+       (apply it l)
+       (apply display (format #f "object<py>: ~s" (class-name o)) l)))
+
+
+(define-method (write (o <pyf>) . l)
+  (aif it (ref o '__repr__)
+       (apply it l)
+       (apply display (format #f "object<pyf>: ~s" (class-name o)) l)))
+
+(define-method (display (o <pyf>) . l)
+  (aif it (ref o '__repr__)
+       (apply it l)
+       (apply display (format #f "object<pyf>: ~s" (class-name o)) l)))
+
+(define-syntax-rule (define-python-class name parents code ...)
+  (define name
+    (wrap name
+          (mk-py-class name parents
+                       #:const
+                       (code ...)
+                       #:dynamic
+                       ()))))