From 67b8025ea15e5df03671bef9ebe48c00e121983a Mon Sep 17 00:00:00 2001
From: Stefan Israelsson Tampe <stefan.itampe@gmail.com>
Date: Tue, 26 Sep 2017 22:47:12 +0200
Subject: big commit

---
 modules/language/python/compile.scm   |  54 +++++++-
 modules/language/python/module/re.scm | 225 ++++++++++++++++++++++++++++++++++
 modules/language/python/set.scm       | 206 +++++++++++++++++++++++++++++++
 modules/oop/pf-objects.scm            |  16 +--
 4 files changed, 492 insertions(+), 9 deletions(-)
 create mode 100644 modules/language/python/module/re.scm
 create mode 100644 modules/language/python/set.scm

diff --git a/modules/language/python/compile.scm b/modules/language/python/compile.scm
index 4b32c09..8007449 100644
--- a/modules/language/python/compile.scm
+++ b/modules/language/python/compile.scm
@@ -11,6 +11,7 @@
   #:use-module (language python list)
   #:use-module (language python string)
   #:use-module (language python def)
+  #:use-module (language python set)
   #:use-module (ice-9 pretty-print)
   #:export (comp))
 
@@ -75,6 +76,23 @@
   (pretty-print (syntax->datum x))
   x)
 
+(define (gen-sel vs e item)
+  (match e
+    ((#:cfor for-e in-e cont)
+     `(,(F 'for) ((,@(map (g vs exp) for-e) : ,(exp vs in)))
+       ,(if cont
+            (gen-sel vs cont item)
+            item)))
+    ((#:cif cif cont)
+     `(if ,(exp vs cif)          
+          ,(if cont
+               (gen-sel vs cont item)
+               item)))))
+
+(define (gen-sel vs e item)
+  (match e
+    ((#:cif . l)
+     (gen-cif vs e item
 
 (define-inlinable (C  x) `(@@ (language python compile) ,x))
 (define-inlinable (Y  x) `(@@ (language python yield)   ,x))
@@ -927,6 +945,12 @@
    '(values)))
  
  (#:list
+  ((_ x (and e (#:cfor . _)))
+   (let ((l (gensym "l")))
+     `(let ((,l ,((L 'to-pylist) '())))
+        ,(gen-sel vs e `(pylist-append ,l ,(exp vs x)))
+        ,l)))
+  
   ((_ . l)
    (list (L 'to-pylist) (let lp ((l l))
                           (match l                             
@@ -940,6 +964,12 @@
                             ((x . l)
                              `(cons ,(exp vs x) ,(lp l))))))))
  (#:tuple
+  ((_ x (and e (#:cfor . _)))
+   (let ((l (gensym "l")))
+     `(let ((,l '()))
+        ,(gen-sel vs e `(set! ,l (cons ,(exp vs x) ,l)))
+        (reverse ,l))))
+
   ((_ . l)
    (let lp ((l l))
      (match l
@@ -1008,14 +1038,34 @@
  (#:dict
   ((_ . #f)
    `(,(Di 'make-py-hashtable)))
-   
-  ((_  (k . v) ...)
+
+  ((_  (#:e k . v) (and e (#:cfor . _)))
+   (let ((dict (gensym "dict")))
+     `(let ((,dict (,(Di 'make-py-hashtable))))
+        ,(gen-sel vs e `(pylist-set! ,dict ,(exp vs k) ,(exp vs v)))
+        ,dict)))
+  
+  ((_  (#:e k . v) ...)
    (let ((dict (gensym "dict")))
      `(let ((,dict (,(Di 'make-py-hashtable))))
         ,@(map (lambda (k v)
                  `(,(L 'pylist-set!) ,dict ,(exp vs k) ,(exp vs v)))
                k v)
         ,dict))))
+
+ ((_  k (and e (#:cfor . _)))
+   (let ((dict (gensym "dict")))
+     `(let ((,dict (,(Se 'set))))
+        ,(gen-sel vs e `(,(O 'ref) ,dict 'add) ,(exp vs k))
+        ,dict)))
+  
+ ((_  k ...)
+   (let ((set (gensym "dict")))
+     `(let ((,set (,(Se 'set))))
+        ,@(map (lambda (k v)
+                 `((,(O 'ref) 'add) ,set ,(exp vs k)))
+               k v)
+        ,dict))))
                   
                            
  (#:comp
diff --git a/modules/language/python/module/re.scm b/modules/language/python/module/re.scm
new file mode 100644
index 0000000..0efbec9
--- /dev/null
+++ b/modules/language/python/module/re.scm
@@ -0,0 +1,225 @@
+(define-module (language python modules re)
+  #:export())
+
+
+(define-sytax-rule (mk n tag str) (define n (f-seq tag (f-tag str))))
+(mk f-. #:. ".")
+(mk f-^ #:^ "^")
+(mk f-$ #:$ "$")
+
+(define subexpr (f-list #:sub
+                        (f-seq (f-tag "(") f-start ee f-end (f-tag ")"))))
+
+(define f-back
+  (f-or (f-list #:class (mk-token (f-reg! "[AZbBdDsSwS]")))
+        (mk-token (f-reg "."))))
+
+(define (ch not)
+  (f-list #:ch
+          (f-or! (f-seq (f-char #\\) f-back)
+                 (mk-token (f-not! not)))))
+
+(define bbody (f-cons (ch "[\\]") (ff* (ch "[]\\]"))))
+
+(define choice
+  (f-cons #:bracket
+          (f-or!
+           (f-seq "[^]" (f-out (list #:ch "^")))
+           (f-cons*
+            (f-tag "[")
+            (f? (f-seq (f-tag "^") (f-out #t)))
+            bbody))))
+
+(define-syntax-rule (mk-post q* str tag)
+  (define q*
+    (<p-lambda> (c)
+      (.. c2  ((f-tag str) c))
+      (<p-cc> (cons (list tag (car c)) (cdr c))))))
+
+(mk-post q* "*" #:*)
+(mk-post q? "?" #:?)
+(mk-post q+ "+" #:+)
+(mk-post q* "*?" #:*?)
+(mk-post q? "??" #:??)
+(mk-post q+ "+?" #:+?)
+
+(define q-or
+  (<p-lambda> (c)     
+    (.. (c2) ((f-seq (f-tag "|") e) '()))
+    (<p-cc> (list #:or c c2))))
+  
+(define q?
+  (<p-lambda> (c)
+    (.. c2  ((f-tag "*") c))
+    (<p-cc> (cons (list #:* (car c)) (cdr c)))))
+
+(define group
+  (lambda (f)
+    (<p-lambda> (c1)
+      (.. c2 (f '()))
+      (with ((L (cons (cons I c2) L))
+             (I (+ i 1)))
+        (<p-cc> (list #:list (#:append c1 c2)))))))
+
+(define group-name
+  (lambda (f name)
+    (<p-lambda> (c1)
+      (.. c2 (f '()))
+      (with ((L (cons* (cons name c2) (cons I c2) L))
+             (I (+ i 1)))
+        (<p-cc> (list #:list (#:append c1 c2)))))))
+
+(define (incant name)
+  (<p-lambda> (c)
+    (let ((r (assoc name L)))
+      (if r
+          (<and> (.. (f-tag (cdr r))))
+          (<code> (error "group is not existing in the history"))))))
+
+(define (incant-rev name)
+  (<p-lambda> (c)
+    (let ((r (assoc name L)))
+      (if r
+          (<and> (.. (f-tag (reverse (cdr r)))))
+          (<code> (error "group is not existing in the history"))))))
+
+(define (reverse-form x)
+  (match x
+    ((#:or x y)
+     (list #:or (reverse-form x) (reverse-form y)))
+    ((#:group f)
+     (list #:group (reverse-form f)))
+    ((#:?P< f n)
+     (list #:?P< (reverse-form f) n))
+    ((#:?: f)
+     (reverse-form f))
+    ((#:?P= name)
+     (#:?P=-rev name))
+    ((#:?P=-rev name)
+     (#:?P= name))
+    ((#:?if name yes no)
+     (list #:?if-rev name (reverse-form yes) (reverse-form no)))
+    ((#:?if-rev name yes no)
+     (list #:?if name (reverse-form yes) (reverse-form no)))
+    ((#:?=  f    ) (list #:?=  (reverse-form f)))
+    ((#:?!  f    ) (list #:?!  (reverse-form f)))
+    ((#:?<= f    ) (list #:?<= f))
+    ((#:?<! f    ) (list #:?<! f))
+    ((#:*   x    ) (list #:*   (reverse-form x)))
+    ((#:+   x    ) (list #:+   (reverse-form x)))
+    ((#:mn  x m n) (list #:mn  (reverse-form x) m n))
+    ((#:?   x    ) (list #:?   (reverse-form x)))
+    ((#:*?  x    ) (list #:*?  (reverse-form x)))
+    ((#:+?  x    ) (list #:+?  (reverse-form x)))
+    ((#:??  x    ) (list #:??  (reverse-form x)))
+    ((:mn?  x m n) (list #:mn? (reverse-form x) m n))
+    ((#:ch  x    ) (list #:ch  x))
+    ((#:bracket . l) (cons #:bracket l))
+    ((x . l) (map reverse-form (cons x l)))
+    (x x)))
+    
+(define (compile x)
+  (match x
+    ((#:or x y)
+     (f-or (compile x) (compile y)))
+    ((#:group f)
+     (group (compile f)))
+    ((#:?P< f n)
+     (group-name (compile f) n))
+    ((#:?: f)
+     (compile f))
+    ((#:?P= name)
+     (incant name))
+    ((#:?P=-rev name)
+     (incant-rev name))
+    ((#:?=  f) (f-and (compile f) f-true))
+    ((#:?!  f) (f-and (f-not (compile f)) f-true))
+    ((#:?<= f) (f-and (f-seq f-rev (compile (reverse-form f))) f-true))
+    ((#:?<! f) (f-and (f-seq f-rev (f-not (compile (reverse-form f)))) f-true))
+    ((#:?if name yes no)
+     (f-or (f-seq (incant name) yes)
+           no))
+    ((#:?if-rev name yes no)
+     (f-or (f-seq yes (incant-rev name))
+           no))
+    ((#:*   x    ) (g*   (compile x)    ))
+    ((#:+   x    ) (g+   (compile x)    ))
+    ((#:mn  x m n) (gmn  (commile x) m n))
+    ((#:?   x    ) (g?   (compile x)    ))
+    ((#:*?  x    ) (ng*  (compile x)    ))
+    ((#:+?  x    ) (ng+  (compile x)    ))
+    ((#:??  x    ) (ng?  (compile x)    ))
+    ((:mn?  x m n) (ngmn (compile x) m n))
+    ((#:ch (#:class x))
+     (get-class ch))
+    ((#:ch x)
+     (f-tag! x))    
+    ((#:bracket not ch ...)
+     (let ((f (apply f-or!
+                     (map (lambda (x)
+                            (match x
+                              ((#:ch (:class ch))
+                               (get-class ch))
+                              ((#:ch ch)
+                               (f-tag! ch)))) ch))))
+       
+       (if not
+           (f-not f)
+           f)))))
+
+(define (id c) c)
+(define (e-match     e)
+  (f-seq (f-or! (f-mute e) (f-return #f))
+         (f-retfkn id)))
+
+(define (e-fullmatch e)
+  (f-or! (f-seq (f-mute e) f-eof (f-retfkn id))
+         (f-return #f)))
+
+(define (e-search    e)
+  (f-or! (f-seq (f-mute e) (f-retfkn id))
+         (f-seq (f-take 1) (Ds (e-search e)))
+         (f-return None)))
+
+
+(define (e-sub e str)
+  (f-or! (f-seq (f-subst (f-mute e) str) (Ds (e-sub e str)))
+         (f-seq (f-take 1) (Ds (e-search e)))
+         (f-out-written)))
+
+(define (e-subn e str)
+  (let lp ((i 0))
+    (f-or! (f-seq (f-subst (f-mute e) str) (Ds (lp (+ i 1))))
+           (f-seq (f-take 1) (Ds (e-search e)))
+           (f-seq (f-out-written) (f-retfkn (lambda (c) (values c i)))))))
+
+(define (e-split e)
+  (f-or! (f-cons (f-seq (mk-token f-out-written) (f-mute e)) (e-split e))
+         (f-cons (f-out-remaining) (f-out '()))))
+
+(define* (findall x s (#:flags 0))
+  (call-with-values (lambda () (parse e-search x s flags))
+    (lambda (m cont)
+      (let lp ((m m) (cont cont))
+        (if (eq? m None)
+            '()
+            (cons m (call-with-values cont lp)))))))
+
+(define* (finditer x s (#:flags 0))
+  ((make-generator ()
+    (lambda (yield)              
+      (call-with-values (lambda () (parse e-search x s flags))
+        (lambda (m cont)
+          (let lp ((m m) (cont cont))
+            (if (eq? m None)
+                #f
+                (begin
+                  (yield m)
+                  (call-with-values cont lp))))))))))
+                    
+            
+          
+
+
+  
+  
diff --git a/modules/language/python/set.scm b/modules/language/python/set.scm
new file mode 100644
index 0000000..5a9cddc
--- /dev/null
+++ b/modules/language/python/set.scm
@@ -0,0 +1,206 @@
+(define-module (language prolog set)
+  #:use-module (oop pf-objects)
+  #:use-module (oop goops)
+  #:use-module (language prolog dict)
+  #:use-module (language prolog for)
+  #:use-module (language prolog try)
+  #:use-module (language prolog list)
+  #:(set))
+
+(define-class <set> () 'dict)
+
+(define-class set (<set>)
+  (define __init__
+    (case-lambda
+      ((self)       
+       (slot-set! self 'dict (make-py-hashtable)))
+      ((self x)
+       (let ((d (make-py-hashtable)))
+         (slot-set! self 'dict (make-py-hashtable))
+         (cond
+          ((or (is-a? x <py-list>) (pair? x) (string? x))
+           (for ((y : x)) ()
+                (pyhash-set! d y #t)))
+          ((is-a? x <py-hash>)
+           (slot-set! self 'dict x))
+          (else
+           (raise TypeError)))))))
+
+  (define pop
+    (lambda (self)
+      (call-with-values (lambda () (pyhash-pop! (slot-ref self 'dict)))
+        (lambda (k v) k))))
+  
+  (define  add
+    (lambda (self k)
+      (pyhash-set! (slot-ref self 'dict) k #t)))
+  
+  (define copy
+    (lambda (self)
+      (let ((dict (pyhash-copy (slot-ref self 'dict))))
+        (set dict))))
+
+  (define difference
+    (lambda (self . l)
+      (let* ((d (slot-ref self 'dict))
+             (r (pyhash-copy d)))
+        (let lp ((l l))
+          (if (pair? l)
+              (begin
+                (for ((x : (car l))) ()
+                     (when (not (eq? miss (pyhash-ref d x miss)))
+                       (pyhash-remove! r x)))
+                (lp (cdr l)))))
+        r)))
+
+  (define difference_update
+    (lambda (self . l)
+      (let* ((r (slot-ref self 'dict)))
+        (let lp ((l l))
+          (if (pair? l)
+              (begin
+                (for ((x : (car l))) ()
+                     (when (not (eq? miss (pyhash-ref d x miss)))
+                       (pyhash-remove! r x)))
+                (lp (cdr l)))))
+        (values))))
+  
+  (define discard
+    (lambda (self . l)
+      (let* ((r (slot-ref self 'dict)))
+        (let lp ((l l))
+          (if (pair? l)
+              (begin
+                (pyhash-remove! d (car l))
+                (lp (cdr l))))))))
+  
+  (define intersection
+    (lambda (self . l)
+      (let* ((d (slot-ref self 'dict))
+             (r (pyhash-copy d)))
+        (let lp ((l l))
+          (if (pair? l)
+              (let ((y (car l)))
+                (for ((k : r)) ((dels '()))
+                  (if (not (eq? miss (pylist-ref y k miss)))
+                      (cons k dels)
+                      dels)
+                  #:finally
+                  (let lp ((dels dels))
+                    (if (pair? dels)
+                        (begin
+                          (pylist-remove! r (car dels))
+                          (lp (cdr dels))))))
+                (lp (cdr l)))))
+        r)))
+
+  (define intersection_update
+    (lambda (self . l)
+      (let* ((r (slot-ref self 'dict)))
+        (let lp ((l l))
+          (if (pair? l)
+              (let ((y (car l)))
+                (for ((k : r)) ((dels '()))
+                  (if (not (eq? miss (pylist-ref y k miss)))
+                      (cons k dels)
+                      dels)
+                  #:finally
+                  (let lp ((dels dels))
+                    (if (pair? dels)
+                        (begin
+                          (pylist-remove! r (car dels))
+                          (lp (cdr dels))))))
+                (lp (cdr l))))))))
+
+  (define isdisjoint
+    (lambda (self x)
+      (let* ((r  (slot-ref self 'dict))
+             (n1 (len r))
+             (n2 (len x)))
+        (if (< n2 n1)
+            (let ((xx x))
+              (set! x r)
+              (set! r xx)))
+        (for ((k : r)) ()
+             (if (not (eq? miss (pylist-ref x 'k miss)))
+                 (break #f))
+             #:finally
+             #t))))
+  
+  (define issubset
+    (lambda (self x)
+      (let* ((r  (slot-ref self 'dict)))
+        (for ((k : r))
+          (if (eq? miss (pylist-ref x 'k miss))
+              (break #f))
+          #:finally
+          #t))))
+
+  (define issuperset
+    (lambda (self x)
+      (let* ((r  (slot-ref self 'dict)))
+        (for ((x : r))
+          (if (eq? miss (pylist-ref r 'k miss))
+              (break #f))
+          #:finally
+          #t))))
+
+  (define remove
+    (lambda (self x)
+      (let* ((r (slot-ref self 'dict)))
+        (if (eq? miss (pylist-ref r x miss))
+            (raise KeyError "missing key in set at remove")
+            (pylist-delete! r x)))))
+
+  (define symmetric_difference
+    (lambda (self x)
+      (union (difference self x) (difference x self))))
+  
+  (define symmetric_difference_update
+    (lambda (self x)
+      (difference_update self x)
+      (update self (difference x self))))
+
+  (define union
+    (lambda (self . l)
+      (let* ((d (slot-ref self 'dict))
+             (r (pyhash-copy d)))
+        (let lp ((l l))
+          (if (pair? l)
+              (begin
+                (for ((k : (car l))) ()
+                     (pylist-set! r k #t))
+                (lp (cdr l)))
+              r)))))
+  
+  (define update
+    (lambda (self . l)
+      (let* ((r (slot-ref self 'dict)))             
+        (let lp ((l l))
+          (if (pair? l)
+              (begin
+                (for ((k : (car l))) ()
+                     (pylist-set! r k #t))
+                (lp (cdr l)))
+              (values))))))
+
+  (define __repr__(self):
+    (let ((r (py-keys (slot-ref self 'dicy)))
+          (n (len r))
+          (l (to-list r)))
+      (cond
+       ((= n 0)
+        (format #f "set([])"))
+       (else
+        (format #f "set([~a ~{, ~a~}])" (car l) (cdr l))))))
+
+  (define __iter__
+    (make-generator (self)
+      (lambda (yield self)
+        (for ((k : (slot-ref self 'dict))) ()
+             (yield k)
+             (values))))))
+       
+
+    
+        
diff --git a/modules/oop/pf-objects.scm b/modules/oop/pf-objects.scm
index e50073f..d22a9a0 100644
--- a/modules/oop/pf-objects.scm
+++ b/modules/oop/pf-objects.scm
@@ -608,13 +608,15 @@ explicitly tell it to not update etc.
     (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 (... ...))))
+                       (letrec ((mname sval) ...)
+                         (let ((s (make-pf)))
+                           (set s 'mname mname) (... ...)
+                           s))
+                       (letrec ((dname dval) ...)
+                         (let ((d (make-pf)))
+                           (set d 'dname dname) (... ...)
+                           d)                 
+                         (parents (... ...)))))
       name)))
 
 (mk-p/f make-pf mk-pf-class  make-pf-class)
-- 
cgit v1.2.3