functional objects
authorStefan Israelsson Tampe <stefan.itampe@gmail.com>
Sat, 9 Sep 2017 14:26:52 +0000 (16:26 +0200)
committerStefan Israelsson Tampe <stefan.itampe@gmail.com>
Sat, 9 Sep 2017 14:26:52 +0000 (16:26 +0200)
modules/language/python/compile.scm
modules/oop/pf-objects.scm

index e515ded925fa70efd6dc596625f0a6bb701842a7..c11bd762bec07ca065f75265e86530bd52ac241f 100644 (file)
 
 (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)))))))
-
+    ((#:test (#:power kind (#:identifier v . _) addings . _) . _)
+     (if kind
+         (let ((v (string->symbol v)))
+           (if (null? addings)                   
+               `(set! ,v ,u)
+               (let ((addings (map (lambda (x) `',(exp vs x)) addings)))
+                 `(set! ,(exp vs kind)
+                    (,(O 'fset-x) ,v (list ,@addings) ,u)))))
+
+         (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 is-class? (make-fluid #f))
 (define (gen-yargs vs x)
   (match (pr 'yarg x)    ((#:list args)
 
 (define (exp vs x)
   (match (pr x)
-    ((#:power (x) () . #f)
+    ((#:power (x) () . #f)
      (exp vs x))
-    ((#:power x () . #f)
+    ((#:power x () . #f)
      (exp vs x))
     
     
     ;; Function calls (x1:x1.y.f(1) + x2:x2.y.f(2)) will do functional calls
-    ((#:power vf trailer . #f)
+    ((#:power #f vf trailer . #f)
      (let lp ((e (exp vs vf)) (trailer trailer))
        (match trailer
          (()
            (reverse
             (fold (lambda (x s)
                     (match x
-                      (((or 'fast 'functional)) s)
+                      ((or 'fast 'functional) s)
                       (x (cons x s))))
                   '() l)))
          (define (is-functional l)
                    (if pred
                        pred
                        (match x
-                         (('functional) #t)
-                         (_ #f)))) #f l))
+                         ('functional #t)
+                         (_ #f))))
+                 #f l))
          (define (is-fast l)
            (fold (lambda (x pred)
                    (if pred
                        pred
                        (match x
-                         (('fast) #t)
-                         (_ #f)))) #f l))
+                         ('fast #t)
+                         (_ #f))))
+                 #f l))
          
          
          (let* ((class   (string->symbol class))
     ((#:for e in code . #f)
      (=> next)
      (match e
-       (((#:power (#:identifier x . _) () . #f))
+       (((#:power #f (#:identifier x . _) () . #f))
         (match in
           (((#:test power . _))
            (match power
-             ((#:power
+             ((#:power #f
                (#:identifier "range" . _)
                ((#:arglist arglist . _))
                . _)
      `(,(fluid-ref return) ,@(map (g vs exp) x)))
     
     ((#:expr-stmt
-      ((#:test (#:power (#:identifier v . _) () . #f) #f))
+      ((#:test (#:power #f (#:identifier v . _) () . #f) #f))
       (#:assign (l)))
      (let ((s (string->symbol v)))
        `(set! ,s ,(exp vs l))))
       (((#:stmt
          ((#:expr-stmt
            ((#:test
-             (#:power
+             (#:power #f
               (#:identifier "module" . _)
               ((#:arglist arglist #f #f))
               . #f) #f))
index 91014158d3e0904936e4a0cbb6cc504f04ab8421..761d44ccf2345466d1196ebfd565ede41cbb9d51 100644 (file)
@@ -1,9 +1,10 @@
 (define-module (oop pf-objects)
   #:use-module (oop goops)
   #:use-module (ice-9 vlist)
+  #: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
+                pcall pcall! get next fset-x
                 mk
                 def-pf-class  mk-pf-class  make-pf-class
                 def-p-class   mk-p-class   make-p-class
@@ -47,35 +48,55 @@ explicitly tell it to not update etc.
   (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 ((h (slot-ref x 'h)))
-    (define pair (vhash-assq key h))
+  (let ()
     (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 (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 ()
@@ -275,6 +296,21 @@ explicitly tell it to not update etc.
     (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
@@ -434,7 +470,7 @@ explicitly tell it to not update etc.
                                           #'(supers (... ...)))))
            #'(let ((sups supers) (... ...))
                (define class dynamic)
-               (define name (make-class (list sups (... ...) <p>) '()))
+               (define name (make-class (list sups (... ...) <pf>) '()))
 
                (put! class.__const__
                      (union const