diff options
author | Stefan Israelsson Tampe <stefan.itampe@gmail.com> | 2017-09-26 22:47:12 +0200 |
---|---|---|
committer | Stefan Israelsson Tampe <stefan.itampe@gmail.com> | 2017-09-26 22:47:12 +0200 |
commit | 67b8025ea15e5df03671bef9ebe48c00e121983a (patch) | |
tree | 9bca3dcab63e045e331091342f0d383048cef6cd /modules/language/python | |
parent | 213731432b36a398c2b3d61390fd1b2cabe99400 (diff) |
big commit
Diffstat (limited to 'modules/language/python')
-rw-r--r-- | modules/language/python/compile.scm | 54 | ||||
-rw-r--r-- | modules/language/python/module/re.scm | 225 | ||||
-rw-r--r-- | modules/language/python/set.scm | 206 |
3 files changed, 483 insertions, 2 deletions
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)))))) + + + + |