improved functional suger notation

2 files changed, 82 insertions, 15 deletions

diff --git a/modules/language/python/compile.scm b/modules/language/python/compile.scm
index 10320f5..75ceba1 100644
--- a/modules/language/python/compile.scm
+++ b/modules/language/python/compile.scm
@@ -519,23 +519,58 @@
                          (cons v addings)))
             (v       (car v.add))
             (addings (cdr v.add))
-            (addings (get-addings vs addings)))
+            (addings (get-addings vs addings))
+            (p.a     (match kind
+                       (#f (cons #f '()))
+                       ((v add)
+                        (if (is-prefix? v)
+                            (let ((w (symbol->string (exp vs (car add)))))
+                              (cons (string-append (symbol->string v) "." w)
+                                 (cdr add)))
+                            (cons (exp vs v) add)))))
+            (p      (car p.a))
+            (pa     (cdr p.a))
+            (pa     (get-addings vs pa)))
        (define q (lambda (x) `',x))
        (if kind
-           (if (null? addings)                   
-               (if op
-                   `(,s/d ,v (,(C 'setwrap) (,(tr-op op) ,v ,u)))
-                   `(,s/d ,v (,(C 'setwrap) ,u)))
-               (if op
-                   `(,s/d ,(exp vs kind)
-                           (,(C 'fset-x) ,v ,addings
-                            (,(C 'setwrap)
-                             (,(tr-op op) (,(C 'ref-x) ,v ,@addings) ,u))))
+           (if (not p)
+               (if (null? addings)                   
+                   (if op
+                       `(,s/d ,v (,(C 'setwrap) (,(tr-op op) ,v ,u)))
+                       `(,s/d ,v (,(C 'setwrap) ,u)))
+                   (if op
+                       `(,s/d ,(exp vs kind)
+                              (,(C 'fset-x) ,v ,addings
+                               (,(C 'setwrap)
+                                (,(tr-op op) (,(C 'ref-x) ,v ,@addings) ,u))))
                      
-                   `(,s/d ,(exp vs kind)
-                          (,(C 'fset-x) ,v ,addings
-                           (,(C 'setwrap) ,u)))))
-           
+                       `(,s/d ,(exp vs kind)
+                              (,(C 'fset-x) ,v ,addings
+                               (,(C 'setwrap) ,u)))))
+               
+               (let ((pre (if (equal? p v)
+                              (let lp ((pa pa) (ad addings) (r '()))
+                                (if (and (pair? pa) (pair? ad))
+                                    (let ((px (car pa)) (ax (car ad)))
+                                      (if (equal? px ax)
+                                          (lp (cdr pa) (cdr ad) (cons px r))
+                                          #f))
+                                    (if (pair? pa)
+                                        #f
+                                        (reverse r))))
+                              #f)))
+                 (if (null? addings)                   
+                     (if op
+                         `(,s/d ,v (,(C 'setwrap) (,(tr-op op) ,v ,u)))
+                         `(,s/d ,v (,(C 'setwrap) ,u)))
+                     (if op
+                         `(,(C 'set-x) ,v ,pre ,p ,pa ,addings
+                           (,(C 'setwrap)
+                            (,(tr-op op) (,(C 'ref-x) ,v ,@addings) ,u)))
+                     
+                         `(,(C 'set-x) ,v ,pre ,p ,pa ,addings
+                           (,(C 'setwrap) ,u))))))
+     
            (if (null? addings)
                (if op
                    `(,s/d ,v (,(C 'setwrap)
@@ -1734,8 +1769,23 @@
 (define-syntax set-x
   (syntax-rules ()
     ((_ v (a ... b) val)
+     (set-x-2 (ref-x v a ...) b val))
+    ((_ v #f p pa a val)
+     (set-x p pa (fset-x v a val)))
+    ((_ v pre p pa a val)
+     (set-c v pre a val))
+    ((_ v (a ... b) val)
      (set-x-2 (ref-x v a ...) b val))))
 
+(define-syntax set-c
+  (syntax-rules ()
+    ((_ v (a) (b) val)
+     (set v a val))
+    ((_ v () as val)
+     (tr v (fset-x v as val)))
+    ((_ v ((#:identifier a) . as) (b . bs) val)
+     (set-c (ref v a) as bs val))))
+    
 (define-syntax fset-x
   (syntax-rules ()
     ((_ v ((#:identifier x) ...) val)
diff --git a/modules/oop/pf-objects.scm b/modules/oop/pf-objects.scm
index cf990af..10016c7 100644
--- a/modules/oop/pf-objects.scm
+++ b/modules/oop/pf-objects.scm
@@ -11,7 +11,7 @@
                 object-method class-method static-method
                 py-super-mac py-super py-equal? 
                 *class* *self* pyobject? pytype?
-                type object pylist-set! pylist-ref
+                type object pylist-set! pylist-ref tr
                 ))
 #|
 Python object system is basically syntactic suger otop of a hashmap and one
@@ -396,6 +396,23 @@ explicitly tell it to not update etc.
 
 (define-method (copy (x <pf>)) (mcopy  x))
 (define-method (copy (x <p> )) (mcopy- x))
+
+;; make a copy of a pf object
+(define-syntax-rule (mtr r x)
+  (begin
+    (slot-set! r 'h    (slot-ref x 'h   ))
+    (slot-set! r 'size (slot-ref x 'size))
+    (slot-set! r 'n    (slot-ref x 'n   ))
+    (values)))
+
+(define-syntax-rule (mtr- r x)
+  (begin
+    (slot-set! r 'h (slot-ref x 'h))
+    (values)))
+  
+
+(define-method (tr (r <pf>) (x <pf>)) (mtr  r x))
+(define-method (tr (r <p> ) (x <p> )) (mtr- r x))
   
 
 ;; with will execute thunk and restor x to it's initial state after it has