diff options
Diffstat (limited to 'modules/language/*.scm')
38 files changed, 0 insertions, 13020 deletions
diff --git a/modules/language/*.scm b/modules/language/*.scm new file mode 100644 index 0000000..e69de29 --- /dev/null +++ b/modules/language/*.scm diff --git a/modules/language/python/bool.scm b/modules/language/python/bool.scm deleted file mode 100644 index d15c749..0000000 --- a/modules/language/python/bool.scm +++ /dev/null @@ -1,35 +0,0 @@ -(define-module (language python bool) - #:use-module (oop goops) - #:use-module (language python exceptions) - #:use-module (oop pf-objects) - #:export (bool)) - -(define-syntax-rule (aif it p x y) (let ((it p)) (if it x y))) - -(define-method (bool x) - (cond - ((null? x) - #f) - ((eq? x None) - #f) - (else x))) - -(define-method (bool (x <integer>)) (if (= x 0) #f x)) -(define-method (bool (x <p>)) - (aif it (ref x '__bool__) - (it) - (next-method))) - - -(define-method (+ (a <boolean>) b) - (+ (if a 1 0) b)) -(define-method (+ b (a <boolean>)) - (+ (if a 1 0) b)) -(define-method (* (a <boolean>) b) - (* (if a 1 0) b)) -(define-method (* b (a <boolean>)) - (* (if a 1 0) b)) -(define-method (- (a <boolean>) b) - (- (if a 1 0) b)) -(define-method (- b (a <boolean>)) - (- b (if a 1 0))) diff --git a/modules/language/python/bytes.scm b/modules/language/python/bytes.scm deleted file mode 100644 index 1e3a0cd..0000000 --- a/modules/language/python/bytes.scm +++ /dev/null @@ -1,1464 +0,0 @@ -(define-module (language python bytes) - #:use-module (oop goops) - #:use-module (oop pf-objects) - #:use-module (ice-9 match) - #:use-module (ice-9 iconv) - #:use-module (rnrs bytevectors) - #:use-module (system foreign) - #:use-module (language python string) - #:use-module (language python for) - #:use-module (language python def) - #:use-module (language python try) - #:use-module (language python exceptions) - #:use-module (language python list) - #:use-module (language python hash) - #:use-module (language python bool) - #:use-module (language python persist) - #:export (<py-bytes> bv-scm pybytes-listing bytes bytearray bytes->bytevector - py-decode make_trans - <py-bytearray> pybytesarray-listing scm-bytevector)) - -(define (bv-scm x) - (slot-ref (bytes x) 'bytes)) - -(define (scm-bytevector x) - (slot-ref (bytes x) 'bytes)) - -(define (bytes->bytevector x) (slot-ref x 'bytes)) -(define-syntax-rule (aif it p x y) (let ((it p)) (if it x y))) - -(define b-ref bytevector-u8-ref) -(define b-set! bytevector-u8-set!) -(define b-make make-bytevector) -(define b-len bytevector-length) -(define (b->list x) (bytevector->u8-list (bv-scm x))) -(define list->b u8-list->bytevector) -(define-class <py-bytes> () bytes) -(define-class <py-bytearray> () n vec) - -(name-object <py-bytes>) -(name-object <py-bytearray>) - -(cpit <py-bytes> (o (lambda (o n l) - (slot-set! o 'bytes - (let lp ((l l) (i 0) (b (b-make n))) - (if (pair? l) - (b-set! b i (car l)) - (lp (cdr l) (+ i 1) b))))) - (let* ((b (slot-ref o 'bytes)) - (n (b-len b))) - (list - n - (let lp ((i 0)) - (if (< i n) - (cons (b-ref b i) (lp (+ i 1))) - '())))))) - -(cpit <py-bytearray> (o (lambda (o n m l) - (slot-set! o 'n m) - (slot-set! o 'vec - (let lp ((l l) (i 0) (b (b-make n))) - (if (pair? l) - (b-set! b i (car l)) - (lp (cdr l) (+ i 1) b))))) - (let* ((b (slot-ref o 'vec)) - (n (b-len b))) - (list - n - (slot-ref o 'n) - (let lp ((i 0)) - (if (< i n) - (cons (b-ref b i) (lp (+ i 1))) - '())))))) - - -(define-method (b-get (o <bytevector>)) - o) -(define-method (b-get (o <py-bytes>)) - (slot-ref o 'bytes)) -(define-method (b-get (o <py-bytearray>)) - (slot-ref o 'vec)) - -(define (b-char x) - (cond - ((char? x) - (ch-find x)) - ((string? x) - (ch-find (string-ref x 0))) - (else - x))) - -(define-python-class bytes (<py-bytes>) - (define maketrans - (lambda (x y) (make_trans x y))) - - (define __init__ - (case-lambda - ((self) - (__init__ self "")) - ((self s) - (cond - ((is-a? s <string>) - (let* ((n (string-length s)) - (bytes (b-make n))) - (let lp ((i 0)) - (if (< i n) - (begin - (b-set! bytes i (ch-find (string-ref s i))) - (lp (+ i 1))))) - (slot-set! self 'bytes bytes))) - ((is-a? s <py-string>) - (__init__ self (slot-ref s 'str))) - ((is-a? s <py-bytes>) - (slot-set! self 'bytes (slot-ref s 'bytes))) - ((is-a? s <bytevector>) - (slot-set! self 'bytes s)) - ((is-a? s <py-bytearray>) - (let* ((n (slot-ref s 'n)) - (b (b-make n))) - (bytevector-copy! (slot-ref s 'vec) 0 b 0 n) - (slot-set! self 'bytes b))) - (else - (for ((x : s)) ((r '())) - (cons (b-char x) r) - - #:final - (let* ((n (length r)) - (bytes (b-make n))) - (let lp ((i (- n 1)) (r r)) - (if (>= i 0) - (begin - (b-set! bytes i (car r)) - (lp (- i 1) (cdr r))) - (slot-set! self 'bytes bytes))))))))))) - -(name-object bytes) - -(define-python-class bytearray (<py-bytearray>) - (define __init__ - (case-lambda - ((self) - (__init__ self "")) - ((self s) - (cond - ((is-a? s <string>) - (let* ((n (string-length s)) - (bytes (b-make n))) - (let lp ((i 0)) - (if (< i n) - (begin - (b-set! bytes i (ch-find (string-ref s i))) - (lp (+ i 1))))) - (slot-set! self 'vec bytes) - (slot-set! self 'n n))) - ((is-a? s <py-string>) - (__init__ self (slot-ref s 'str))) - ((is-a? s <py-bytes>) - (let ((b (slot-ref s 'bytes))) - (slot-set! self 'vec (bytevector-copy b)) - (slot-set! self 'n (b-len b)))) - ((is-a? s <bytevector>) - (slot-set! self 'vec (bytevector-copy s)) - (slot-set! self 'n (b-len s))) - ((is-a? s <py-bytearray>) - (slot-set! self 'vec (bytevector-copy (slot-ref s 'vec))) - (slot-set! self 'n (slot-ref s 'n))) - (else - (for ((x : s)) ((r '())) - (cons (b-char x) r) - #:final - (let* ((n (length r)) - (bytes (b-make n))) - (let lp ((i (- n 1)) (r r)) - (if (>= i 0) - (begin - (b-set! bytes i (car r)) - (lp (- i 1) (cdr r))) - (begin - (slot-set! self 'vec bytes) - (slot-set! self 'n (b-len bytes))))))))))))) - -(name-object bytearray) - -(define-syntax-rule (define-py (f o . u) code ...) - (begin - (define-method (f (o <bytevector>) . u) code ...) - (define-method (f (o <py-bytes>) . l) (apply f (slot-ref o 'bytes) l)))) - -(define-syntax-rule (define-py! (f o . u) code ...) - (begin - (define-method (f (o <py-bytearray>) . u) code ...))) - -(define (idd x) x) -(define-syntax-rule (define-py* g (f m o nn . u) code ...) - (begin - (define (g m o nn . u) code ...) - (define-method (f (o <bytevector>) . l) - (apply g idd o (b-len o) l)) - (define-method (f (o <py-bytes>) . l) - (let ((b (slot-ref o 'bytes))) - (apply g bytes b (b-len b) l))) - (define-method (f (o <py-bytearray>) . l) - (let ((b (slot-ref o 'vec)) - (n (slot-ref o 'n))) - (apply g bytearray b n l))))) - -(define-syntax-rule (define-py** g (f m o nn . u) code ...) - (begin - (define (g m o nn . u) code ...) - (define-method (f (o <bytevector>) . l) - (apply g idd o (b-len o) l)) - (define-method (f (o <py-bytes>) . l) - (let ((b (slot-ref o 'bytes))) - (apply g bytes b (b-len b) l))) - (define-method (f (o <py-bytearray>) . l) - (let ((b (slot-ref o 'vec)) - (n (slot-ref o 'n))) - (apply g bytearray b n l))) - (define-method (f (o <p>) . l) - (aif it (ref o 'g) - (apply it l) - (next-method))))) - -(define-py* -bool (bool m o nn) (if (= (len o) 0) #f o)) - -(define-method (write (b <py-bytes>) . l) - (define port (if (pair? l) (car l) #t)) - (format port "b'") - (b->string port (slot-ref b 'bytes)) - (format port "'")) - -(define-method (write (b <py-bytearray>) . l) - (define port (if (pair? l) (car l) #t)) - (format port "bytearray(b'") - (b->string port (pylist-slice (slot-ref b 'vec) 0 (len b) 1)) - (format port "')")) - - -(define dynlink (dynamic-link)) - -(define stringn - (pointer->procedure - '* - (dynamic-func "scm_from_latin1_stringn" dynlink) - (list '* size_t))) - -(define ch->i (make-hash-table)) - -(define (re-eval ch) - (let lp ((i 0)) - (if (< i 256) - (if (eq? ch (chf i)) - (begin - (hash-set! ch->i ch i) - (lp (+ i 1))) - (lp (+ i 1))) - (hash-ref ch->i ch)))) - -(define (ch-find ch) - (aif it (hash-ref ch->i ch #f) - (if (eq? ch (chf it)) - it - (re-eval ch)) - (re-eval ch))) - -(define (chf ch) - (let ((bytes (pointer->scm - (stringn - (bytevector->pointer - (b-make 1 ch)) - 1)))) - (if (= (string-length bytes) 1) - (string-ref bytes 0) - (chf 0)))) - -(define (b->string port b) - (let ((n (b-len b))) - (let lp ((i 0)) - (if (< i n) - (let ((ch (b-ref b i))) - (cond - ((equal? ch 0) - (format port "\\x00")) - ((equal? (chf ch) #\\) - (format port "\\\\")) - ((equal? (chf ch) #\') - (format port "\\'")) - ((equal? (chf ch) #\newline) - (format port "\\n")) - ((= ch 7) - (format port "\\a")) - ((= ch 8) - (format port "\\b")) - ((= ch 12) - (format port "\\f")) - ((= ch 10) - (format port "\\n")) - ((= ch 13) - (format port "\\r")) - ((= ch 9) - (format port "\\t")) - ((= ch 11) - (format port "\\v")) - (else - (if (< ch 32) - (format port "\\x~2,'0x" ch) - (format port "~a" (make-string 1 (chf ch)))))) - (lp (+ i 1))))))) - -(define-py (py-hash b) (hash b pyhash-N)) - -(define-py* pylist (pylist-ref bytes o N nin) - (define n (if (< nin 0) (+ N nin) nin)) - (if (and (>= n 0) (< n N)) - (if (eq? bytes idd) - (b-ref o n) - (bytes (b-make 1 (b-ref o n)))) - (raise IndexError))) - -(define-py (len b) (b-len b)) -(define-py! (len b) (slot-ref b 'n)) - -(define-py* ->list (to-list mk b n) - (let lp ((i 0) (r '())) - (if (< i n) - (lp (+ i 1) (cons (b-ref b i) r)) - (reverse r)))) - -(define-py* ->pylist (to-pylist mk b n) - (let* ((m n) - (o (make <py-list>)) - (v (make-vector m))) - (slot-set! o 'vec v) - (slot-set! o 'n n) - (let lp ((i 0)) - (if (< i n) - (begin - (vector-set! v i (if (equal? bytes idd) - (b-ref b i) - (bytes (b-make 1 (b-ref b i))))) - (lp (+ i 1))) - o)))) - - -(define-py! (pylist-set! o nin val) - (define N (slot-ref o 'n)) - (define n (if (< nin 0) (+ N nin) nin)) - (if (and (>= n 0) (< n (slot-ref o 'n))) - (b-set! (slot-ref o 'vec) n val) - (raise IndexError))) - -(define-py* slice (pylist-slice bytes o N n1 n2 n3) - (define (f n) (max 0 (min N (if (< n 0) (+ N n) n)))) - - (let* ((n1 (f (if (eq? n1 None) 0 n1))) - (n2 (f (if (eq? n2 None) N n2))) - (n3 (f (if (eq? n3 None) 1 n3))) - (n (let lp ((i n1) (j 0)) - (if (< i n2) - (lp (+ i n3) (+ j 1)) - j))) - (b (b-make n))) - (let lp ((i n1) (j 0)) - (if (< j n) - (begin - (b-set! b j (b-ref o i)) - (lp (+ i n3) (+ j 1))) - (bytes b))))) - -(define-py! (pylist-subset! o n1 n2 n3 val) - (define N (slot-ref o 'n)) - (define (f n) (if (< n 0) (+ N n) n)) - - (let* ((n1 (f (if (eq? n1 None) 0 n1))) - (n2 (f (if (eq? n2 None) (slot-ref o 'n) n2))) - (n3 (f (if (eq? n3 None) 1 n3))) - (vec (slot-ref o 'vec)) - (l2 (to-list val)) - (N2 (length l2))) - (if (<= n2 N) - (let lp ((i 0) (l2 l2) (j n1)) - (if (< j n2) - (if (< i N2) - (let ((r (car l2))) - (if (and (number? r) (integer? r) (>= r 0) (< r 256)) - (begin - (b-set! vec j r) - (lp (+ i 1) (cdr l2) (+ j n3))) - (raise TypeError "not a byte"))) - (let lp ((j2 j)) - (if (< j2 n2) - (lp (+ j2 n3)) - (let lp ((k1 j) (k2 j2)) - (if (< k2 N) - (begin - (b-set! vec k1 (b-ref vec k2)) - (lp (+ k1 1) (+ k2 1))) - (begin - (let lp ((i k2)) - (if (< i N) - (begin - (b-set! vec i #f) - (lp (+ i 1))) - (slot-set! o 'n k1))))))))))) - (raise IndexError)) - (values))) - -(define (byte x) - (or (and (integer? x) (>= x 0) (< x 256) x) - (and (is-a? x <bytevector>) (b-ref x 0)) - (and (is-a? x <py-bytes>) (b-ref (slot-ref x 'bytes) 0)) - (and (is-a? x <py-bytearray>) (b-ref (slot-ref x 'vec) 0)))) - -(define-py! (pylist-append! o val) - (let* ((n (slot-ref o 'n)) - (vec (slot-ref o 'vec)) - (N (b-len vec))) - (aif v (byte val) - (begin - (if (< n N) - (b-set! vec n v) - (let* ((N (* 2 N)) - (vec2 (b-make N))) - (let lp ((i 0)) - (if (< i n) - (begin - (b-set! vec2 i (b-ref vec i)) - (lp (+ i 1))))) - (b-set! vec2 n v) - (slot-set! o 'vec vec2))) - (slot-set! o 'n (+ n 1)) - (values)) - (raise TypeError "not a byte" val)))) - - -(define (b-concat b1 n1 b2 n2) - (let* ((n (+ n1 n2)) - (b (b-make n))) - (let lp ((i 0)) - (if (< i n1) - (begin - (b-set! b i (b-ref b1 i)) - (lp (+ i 1))) - (let lp ((i i) (j 0)) - (if (< j n2) - (begin - (b-set! b i (b-ref b2 j)) - (lp (+ i 1) (+ j 1))) - b)))))) - -(define-method (+ (o1 <py-bytes>) (b2 <bytevector>)) - (let* ((b1 (slot-ref o1 'bytes)) - (n1 (b-len b1)) - (n2 (b-len b2)) - (o (make <py-bytes>)) - (b (b-concat b1 n1 b2 n2))) - (slot-set! o 'bytes b) - o)) - -(define-method (+ (b2 <bytevector>) (o1 <py-bytes>)) - (let* ((b1 (slot-ref o1 'bytes)) - (n1 (b-len b1)) - (n2 (b-len b2)) - (o (make <py-bytes>)) - (b (b-concat b2 n2 b1 n1))) - (slot-set! o 'bytes b) - o)) - -(define-method (+ (b1 <bytevector>) (b2 <bytevector>)) - (let* ((n1 (b-len b1)) - (n2 (b-len b2))) - (b-concat b1 n1 b2 n2))) - -(define-method (+ (o1 <py-bytes>) (o2 <py-bytes>)) - (let* ((b1 (slot-ref o1 'bytes)) - (b2 (slot-ref o2 'bytes)) - (n1 (b-len b1)) - (n2 (b-len b2)) - (o (make <py-bytes>)) - (b (b-concat b1 n1 b2 n2))) - (slot-set! o 'bytes b) - o)) - -(define-method (+ (o1 <py-bytearray>) (o2 <py-bytes>)) - (let* ((b1 (slot-ref o1 'vec)) - (b2 (slot-ref o2 'bytes)) - (n1 (slot-ref o1 'n)) - (n2 (b-len b2)) - (o (make <py-bytearray>)) - (b (b-concat b1 n1 b2 n2))) - (slot-set! o 'vec b) - (slot-set! o 'n (+ n1 n2)) - o)) - -(define-method (+ (o1 <py-bytearray>) (b2 <bytevector>)) - (let* ((b1 (slot-ref o1 'vec)) - (n1 (slot-ref o1 'n)) - (n2 (b-len b2)) - (o (make <py-bytearray>)) - (b (b-concat b1 n1 b2 n2))) - (slot-set! o 'vec b) - (slot-set! o 'n (+ n1 n2)) - o)) - -(define-method (+ (o2 <py-bytes>) (o1 <py-bytearray>)) - (let* ((b1 (slot-ref o1 'vec)) - (b2 (slot-ref o2 'bytes)) - (n1 (slot-ref o1 'n)) - (n2 (b-len b2)) - (o (make <py-bytearray>)) - (b (b-concat b2 n2 b1 n1))) - (slot-set! o 'vec b) - (slot-set! o 'n (+ n1 n2)) - o)) - -(define-method (+ (b2 <bytevector>) (o1 <py-bytearray>) ) - (let* ((b1 (slot-ref o1 'vec)) - (n1 (slot-ref o1 'n)) - (n2 (b-len b2)) - (o (make <py-bytearray>)) - (b (b-concat b2 n2 b1 n1))) - (slot-set! o 'vec b) - (slot-set! o 'n (+ n1 n2)) - o)) - -(define-method (+ (o1 <py-bytearray>) (o2 <py-bytearray>)) - (let* ((b1 (slot-ref o1 'vec)) - (b2 (slot-ref o2 'vec)) - (n1 (slot-ref o1 'n)) - (n2 (slot-ref o2 'n)) - (o (make <py-bytearray>)) - (b (b-concat b1 n1 b2 n2))) - (slot-set! o 'vec b) - (slot-set! o 'n (+ n1 n2)) - o)) - -(define (b-rep b n m) - (let* ((N (* n m)) - (r (b-make N))) - (let lp ((i 0) (j 0)) - (if (< i m) - (let lp2 ((j j) (k 0)) - (if (< k n) - (begin - (b-set! r j (b-ref b k)) - (lp2 (+ j 1) (+ k 1))) - (lp (+ i 1) j))) - r)))) - -(define-method (* (o1 <py-bytearray>) m) - (let* ((b1 (slot-ref o1 'vec)) - (n1 (slot-ref o1 'n)) - (o (make <py-bytearray>)) - (b (b-rep b1 n1 m))) - (slot-set! o 'vec b) - (slot-set! o 'n (* n1 m)) - o)) - -(define-method (* (b1 <bytevector>) m) - (let* ((n1 (b-len b1))) - (b-rep b1 n1 m))) - -(define-method (* (o1 <py-bytes>) m) - (let* ((b1 (slot-ref o1 'bytes)) - (n1 (b-len b1)) - (o (make <py-bytes>)) - (b (b-rep b1 n1 m))) - (slot-set! o 'bytes b) - o)) - -(define-py* cap (py-capitalize bytes s n) - (let* ((w (b-make n))) - (let lp ((i 0) (first? #t)) - (if (< i n) - (let* ((x (b-ref s i)) - (ch (chf x))) - (define (f first?) - (b-set! w i x) - (lp (+ i 1) first?)) - - (if (and first? (char-alphabetic? ch)) - (aif it (ch-find (char-upcase ch)) - (begin - (b-set! w i it) - (lp (+ i 1) #f)) - (f #t)) - (f #f))) - (bytes w))))) - -(define-py* center (py-center bytes o n w . l) - (let* ((ws (if (pair? l) - (ch-find (b-ref (car l) 0)) - (ch-find #\space))) - (w (if (< w n) n w)) - (d (- w n)) - (e (floor-quotient (- w n) 2)) - (s (b-make w (ch-find #\space)))) - (let lp ((i 0) (j e)) - (if (< i n) - (begin - (b-set! s j (b-ref o i)) - (lp (+ i 1) (+ j 1))))) - (bytes s))) - -(define-python-class UnicodeDecodeError (Exception)) - -(define-py** decode (py-decode bytes o n . l) - (apply - (lam ((= encoding "UTF-8") (= errors "strict")) - (set! errors (py-lower (scm-str errors))) - (set! errors (cond - ((equal? errors "strict") - 'error) - ((equal? errors "escape") - 'escape) - ((equal? errors "replace") - 'substitute) - ((equal? errors "ignore") - (warn - (string-append - "not possible to use ignore " - "encodong error strategy " - "using replace in stead")) - 'substitute) - (else - (warn - "not a correct encodong error strategy") - 'error))) - (set! encoding (py-upper (scm-str encoding))) - - (let lp ((i 0) (r '())) - (if (< i n) - (lp (+ i 1) (cons (b-ref o i) r)) - (catch #t - (lambda () - (bytevector->string - (list->b (reverse r)) - encoding - errors)) - (lambda x - (raise (UnicodeDecodeError - (+ - "failed to decode " - encoding)))))))) - l)) - -;;;py-encode - -(define-py* endswith (py-endswith bytes o n suff . l) - (let* ((suff (slot-ref (bytes suff) 'bytes)) - (ns (b-len suff)) - (f (lambda (x) (< x 0) (+ n x) x))) - (call-with-values (lambda () - (match l - (() (values 0 n )) - ((x) (values (f x) n )) - ((x y) (values (f x) (f y))))) - (lambda (start end) - (let lp ((i (- n ns)) (j 0)) - (if (< i start) - (lp (+ i 1) (+ j 1)) - (if (>= i end) - #t - (and - (eq? (b-ref o i) (b-ref suff j)) - (lp (+ i 1) (+ j 1)))))))))) - -(define-py* startswith (py-startswith bytes o n pre . l) - (let* ((pre (slot-ref (bytes pre) 'bytes)) - (pre (b-get pre)) - (ns (len pre)) - (f (lambda (x) (< x 0) (+ n x) x))) - (call-with-values (lambda () - (match l - (() (values 0 n )) - ((x) (values (f x) n )) - ((x y) (values (f x) (f y))))) - (lambda (start end) - (let lp ((i 0)) - (cond - ((or (>= i end) - (>= i ns)) - #t) - ((< i start) - (lp (+ i 1))) - (else - (and - (eq? (b-ref o i) (b-ref pre i)) - (lp (+ i 1)))))))))) - - -(define-py* expand (py-expandtabs bytes s n . l) - (let* ((tabsize (match l (() 8) ((x) x))) - (ct (ch-find #\tab)) - (cs (ch-find #\space)) - (n (b-len s))) - (let lp ((i 0) (r '())) - (if (< i n) - (let ((x (b-ref s i))) - (if (eq? x ct) - (let lp2 ((j 0) (r r)) - (if (< j tabsize) - (lp2 (+ j 1) (cons cs r)) - (lp (+ i 1) r))) - (lp (+ i 1) (cons x r)))) - (bytes (reverse r)))))) - -(define (b-contains s sub nsub start end) - (define (match i) - (let lp ((i i) (j 0)) - (if (and (< j nsub) (< i end)) - (if (eq? (b-ref s i) (b-ref sub j)) - (lp (+ i 1) (+ j 1)) - #f) - #t))) - - (let lp ((i (max start 0))) - (if (< i end) - (if (match i) - i - (lp (+ i 1))) - #f))) - -(define-py* find (py-find bytes s n sub . l) - (let* ((f (lambda (x) (< x 0) (+ n x) x))) - (call-with-values (lambda () - (match l - (() (values 0 n )) - ((x) (values (f x) n )) - ((x y) (values (f x) (f y))))) - (lambda (start end) - (let ((sub (b-get sub))) - (aif it (b-contains s sub (len sub) start end) - it - -1)))))) - -(define (b-reverse s n) - (if (is-a? s (<py-bytes>)) - (b-reverse (slot-ref s 'bytes) n) - (let* ((r (b-make n))) - (let lp ((i 0) (j (- n 1))) - (if (< i n) - (begin - (b-set! r j (b-ref s i)) - (lp (+ i 1) (- j 1))) - r))))) - - -(define-py* rfind (py-rfind bytes s n sub . l) - (let* ((sub (slot-ref (bytes sub) 'bytes)) - (s (b-reverse s n)) - (nsub (len sub)) - (sub (b-reverse (b-get sub) nsub)) - (f (lambda (x) (< x 0) (+ n x) x))) - (call-with-values (lambda () - (match l - (() (values 0 n )) - ((x) (values (f x) n )) - ((x y) (values (f x) (f y))))) - (lambda (start end) - (aif it (b-contains s sub nsub start end) - (- n it nsub) - -1))))) - -#| -(define i (f-list #:i (mk-token (f+ (f-reg! "[0-9]"))))) -(define s (f-list #:s (mk-token (f+ (f-not! (f-tag "}")))))) -(define e (f-list #:e (f-and (f-tag "}") f-true))) -(define tagbody (f-or! e i s)) - -(define tag (f-seq "{" tagbody "}")) -(define nontag (f-list #:bytes (mk-token (f+ (f-or! (f-tag "{{") - (f-not! tag)))))) -(define e (ff* (f-or! tag nontag))) - -(define (compile x args kwargs) - (let lp ((l x) (r '()) (u '()) (i 0)) - (match l - (((#:bytes x) . l) - (lp l (cons x r) u i)) - (((#:i x) . l) - (lp l (cons "~a" r) (cons (list-ref args (string->number x)) u) i)) - (((#:s x) . l) - (lp l (cons "~a" r) (cons (hash-ref kwargs x None) u) i)) - (((#:e) . l) - (lp l (cons "~a" r) (cons (list-ref args i) u) (+ i 1))) - (() - (apply format #f (string-join (reverse r) "") (reverse u)))))) - -(define-py (py-format format s . l) - (call-with-values - (lambda () - (let lp ((l l) (args '()) (kwargs (make-hash-table))) - (match l - (((? keyword? key) x . l) - (hash-set! kwargs (symbol->string (keyword->symbol key)) x) - (lp l args kwargs)) - ((x . l) - (lp l (cons x args) kwargs)) - (() - (values (reverse args) kwargs))))) - (lambda (args kwargs) - (compile (parse s e) args kwargs)))) -|# - -(define-syntax-rule (mk-is py-isalnum x ...) - (define-py* isalnum (py-isalnum bytes s n) - (let lp ((i 0)) - (if (< i n) - (let ((ch (chf (b-ref s i)))) - (if (or (x ch) ...) - (lp (+ i 1)) - #f)) - #t)))) - -(mk-is py-isalnum char-alphabetic? char-numeric?) -(mk-is py-isalpha char-alphabetic?) -(mk-is py-isdigit char-numeric?) -(mk-is py-islower char-lower-case?) -(mk-is py-isspace char-whitespace?) -(mk-is py-isupper char-upper-case?) - - -(define-py* istitle (py-istitle bytes s n) - (if ((> n 0)) - (let lp ((i 0) (space? #t)) - (if (< i n) - (let ((ch (chf (b-ref s i)))) - (if space? - (cond - ((char-whitespace? ch) - (lp (+ i 1) #t)) - ((char-upper-case? ch) - (lp (+ i 1) #f)) - (else - #f)) - (cond - ((char-whitespace? ch) - (lp (+ i 1) #t)) - ((char-upper-case? ch) - #f) - ((char-lower-case? ch) - (lp (+ i 1) #f)) - (else - #f)))) - #t)) - #f)) - -(define (b-join bytes l s ns) - (let* ((n (let lp ((l l) (n 0)) - (if (pair? l) - (let ((x (car l)) - (l (cdr l))) - (lp l (+ n (len x) (if (pair? l) ns 0)))) - n))) - (r (b-make n))) - (let lp ((l l) (i 0)) - (if (pair? l) - (let* ((x (car l)) - (n (len x)) - (x (b-get x)) - (l (cdr l))) - (let lp2 ((j 0) (i i)) - (if (< j n) - (begin - (b-set! r i (b-ref x j)) - (lp2 (+ j 1) (+ i 1))) - (if (pair? l) - (let lp3 ((j 0) (i i)) - (if (< j ns) - (begin - (b-set! r i (b-ref s j)) - (lp3 (+ j 1) (+ i 1))) - (lp l i))) - (lp l i))))) - (bytes r))))) - -(define-py* join (py-join bytes s n iterator) - (b-join bytes (to-list iterator) s n)) - -(define-py* ljust (py-ljust bytes s n width . l) - (let* ((ch (match l - ((x) - (b-char x)) - (() - (b-char #\space))))) - (if (< width n) - (pylist-slice s 0 width 1) - (let ((ret (b-make width ch))) - (let lp ((i 0)) - (if (< i n) - (begin - (b-set! ret i (b-ref s i)) - (lp (+ i 1))) - (bytes ret))))))) - -(define-py* rjust (py-rjust bytes s n width . l) - (let* ((ch (match l - ((x) - (b-char x)) - (() - (b-char #\space))))) - (if (< width n) - (pylist-slice s (- width) (len s) 1) - (let ((ret (b-make width ch))) - (let lp ((i 0) (j (- width n))) - (if (< i n) - (begin - (b-set! ret j (b-ref s i)) - (lp (+ i 1) (+ j 1))) - (bytes ret))))))) - - -(define-py* lower (py-lower bytes s n) - (let* ((r (b-make n))) - (let lp ((i 0)) - (if (< i n) - (let* ((x (b-ref s i)) - (ch (chf x))) - (b-set! r i (if (char-upper-case? ch) - (ch-find (char-downcase ch)) - x)) - (lp (+ i 1))) - (bytes r))))) - -(define-py* upper (py-upper bytes s n) - (let* ((r (b-make n))) - (let lp ((i 0)) - (if (< i n) - (let* ((x (b-ref s i)) - (ch (chf x))) - (b-set! r i (if (char-lower-case? ch) - (ch-find (char-upcase ch)) - x)) - (lp (+ i 1))) - (bytes r))))) - -(define-py* swapcase (py-swapcase bytes s n) - (let* ((r (b-make n))) - (let lp ((i 0)) - (if (< i n) - (let* ((x (b-ref s i)) - (ch (chf x))) - (b-set! r i (cond - ((char-lower-case? ch) - (ch-find (char-upcase ch))) - ((char-upper-case? ch) - (ch-find (char-downcase ch))) - (else - x))) - (lp (+ i 1))) - (bytes r))))) - -(define b-trim - (case-lambda - ((bytes s n) - (b-trim bytes s n (lambda (ch x) (char-whitespace? ch)))) - ((bytes s n p) - (let lp ((i 0) (r '()) (first? #t)) - (if (< i n) - (let ((x (b-ref s i))) - (if first? - (if (p (chf x) x) - (lp (+ i 1) r #t) - (lp (+ i 1) (cons x r) #f)) - (lp (+ i 1) (cons x r) #f))) - (bytes (reverse r))))))) - -(define b-rtrim - (case-lambda - ((bytes s n) - (b-rtrim bytes s n (lambda (ch x) (char-whitespace? ch)))) - ((bytes s n p) - (let lp ((i (- n 1)) (r '()) (first? #t)) - (if (>= i 0) - (let ((x (b-ref s i))) - (if first? - (if (p (chf x) x) - (lp (- i 1) r #t) - (lp (- i 1) (cons x r) #f)) - (lp (- i 1) (cons x r) #f))) - (bytes r)))))) - -(define-py* lstrip (py-lstrip bytes s n . l) - (match l - (() - (b-trim bytes s n)) - ((x) - (let ((l (map b-char (to-list x)))) - (b-trim bytes s n (lambda (ch x) (member x l))))))) - -(define-py* restrip (py-rstrip bytes s n . l) - (match l - (() - (b-rtrim bytes s n)) - ((x) - (let ((l (map b-char (to-list x)))) - (b-rtrim bytes s n (lambda (ch x) (member x l))))))) - - -(define-py* partition (py-partition bytes s n sep) - (let* ((sep (b-get sep)) - (m (b-len sep))) - (define (test i) - (let lp ((i i) (j 0)) - (if (< i n) - (if (< j m) - (if (eq? (b-ref s i) (b-ref sep j)) - (lp (+ i 1) (+ j 1)) - #f) - #t) - #f))) - (let lp ((i 0)) - (if (< i n) - (if (test i) - (list (pylist-slice s 0 i) sep (pylist-slice s (+ i m) n)) - (lp (+ i 1))) - (list s "" ""))))) - -(define-py* rpartition (py-rpartition bytes ss n ssep) - (let* ((s (b-reverse ss n)) - (m (len ssep)) - (sep (b-reverse (b-get ssep) m))) - (define (test i) - (let lp ((i i) (j 0)) - (if (< i n) - (if (< j m) - (if (eq? (b-ref s i) (b-ref sep j)) - (lp (+ i 1) (+ j 1)) - #f) - #t) - #f))) - (let lp ((i 0)) - (if (< i n) - (if (test i) - (list (bytes - (b-reverse - (pylist-slice s (+ i m) n) - (- n (+ i m)))) - (bytes sep) - (bytes - (b-reverse - (pylist-slice s 0 i) - i))) - (lp (+ i 1))) - (list (bytes "") (bytes "") s))))) - -(define-py* replace (py-replace bytes s n old new . l) - (let ((n (match l (() #f) ((n . _) n)))) - (b-join - bytes - (reverse - (let lp ((s s) (r '())) - (let ((l (py-partition s old))) - (if (equal? (cadr l) "") - (cons s r) - (lp (list-ref l 2) (cons (car l) r)))))) - n - new))) - -(define-py (py-stripip s . l) - (apply py-rstrip (apply py-lstrip s l) l)) - -(define-py! (py-stripip s . l) - (apply py-rstrip (apply py-lstrip s l) l)) - -(define-py* index (pylist-index bytes o n val . l) - (let* ((vec o) - (f (lambda (m) (if (< m 0) (+ m n) m)))) - (call-with-values - (lambda () - (match l - (() - (values 0 n)) - ((x) - (values (f x) n)) - ((x y) - (values (f x) (f y))))) - (lambda (n1 n2) - (if (and (>= n1 0) (>= n2 0) (< n1 n) (<= n2 n)) - (let lp ((i n1)) - (if (< i n2) - (let ((r (b-ref vec i))) - (if (equal? r val) - i - (lp (+ i 1)))) - (raise ValueError "could not find value in index fkn"))) - (raise IndexError "index out of scop in index fkn")))))) - -(define-py* rindex (py-rindex býtes s n . l) - (let ((n (b-len s))) - (- n (apply pylist-index (b-reverse s n) l) 1))) - -#; -(define-py (py-title title s) - (string-titlecase s)) - -(define-py* split (py-split bytes o n tag) - (let ((tag (b->list tag))) - (let lp ((i 0) (r '())) - (if (< i n) - (if (eq? (car tag) (b-ref o i)) - (let lp2 ((j i) (tag tag)) - (if (null? tag) - (cons (bytes (list->b (reverse r))) - (lp (+ i 1) '())) - (if (< j n) - (if (eq? (car tag) (b-ref o j)) - (lp2 (+ j 1) (cdr tag)) - (lp (+ i 1) (cons (b-ref o i) r))) - (lp (+ i 1) (cons (b-ref o i) r))))) - (lp (+ i 1) (cons (b-ref o i) r))) - '())))) -#; -(define-py (py-rsplit s . l) - (reverse - (map string-reverse - (apply py-split - (string-reverse s) - (match l - (() '()) - ((sep . l) (cons (string-reverse sep) l))))))) - - -(define-py* splitlines (py-splitlines bytes s n . l) - (let ((keep? (match l - ((#:keepends v) - v) - ((v) - v) - (_ #f)))) - (let lp ((i 0) (r '()) (old 0)) - (if (< i n) - (let* ((x (b-ref s i)) - (ch (chf x))) - (if (eq? ch #\newline) - (if keep? - (lp (+ i 1) - (cons - (pylist-slice s old (+ i 1) 1) - r) - (+ i 1)) - (lp (+ i 1) - (cons - (pylist-slice s old i 1) - r) - (+ i 1))) - (lp (+ i 1) r old))) - (reverse r))))) - -(define (make_trans b1 b2) - (let* ((b1 (bv-scm b1)) - (b2 (bv-scm b2)) - (n1 (len b1)) - (n2 (len b2)) - (n (let lp ((i 0) (r 0)) - (if (< i n1) - (lp (+ i 1) (max (bytevector-u8-ref b1 i) r)) - r)))) - (if (= n1 n2) - (let lp ((i 0) (r '())) - (if (< i n) - (let lp2 ((j 0)) - (if (< j n1) - (if (= (bytevector-u8-ref b1 j) i) - (lp (+ i 1) (cons (bytevector-u8-ref b2 j) r)) - (lp2 (+ j 1))) - (lp (+ i 1) (cons i r)))) - (bytes (list->u8vector (reverse r))))) - (raise - (ValueError - "maketrans: wrong number in second string compared to first"))))) - -(define-py* translate (py-translate bytes s n table . l) - (let* ((table (b-get table)) - (w (b-make n)) - (t (if (eq? table None) #f table)) - (d (match l (() #f) ((x) (map b-char (to-list x)))))) - (define (tr ch) - (define (e) - (if t - (if (< ch (b-len t)) - (b-ref t ch) - ch) - ch)) - - (if d - (if (member ch d) - #f - (e)) - (e))) - - (let lp ((i 0) (k 0)) - (if (< i n) - (let ((ch (tr (b-ref s i)))) - (if ch - (begin - (b-set! w k ch) - (lp (+ i 1) (+ k 1))) - (lp (+ i 1) k))) - (bytes - (if (= k n) - w - (pylist-slice w 0 k 1))))))) - -(define-syntax-rule (a b x y) (b (symbol->string x) (symbol->string y))) - -(define (cmp op s1 n1 s2 n2) - (let ((n (min n1 n2))) - (let lp ((i 0)) - (if (< i n) - (let ((x1 (b-ref s1 i)) - (x2 (b-ref s2 i))) - (if (= x1 x2) - (lp (+ i 1)) - (op x1 x2))) - (op n1 n2))))) - - -(define-syntax-rule (mkop op) - (begin - (define-method (op (b1 <bytevector>) (s2 <py-bytes>)) - (let ((b2 (slot-ref s2 'bytes))) - (cmp op b1 (b-len b1) b2 (b-len b2)))) - (define-method (op (s1 <py-bytes>) (b2 <bytevector>) ) - (let ((b1 (slot-ref s1 'bytes))) - (cmp op b1 (b-len b1) b2 (b-len b2)))) - (define-method (op (b1 <bytevector>) (b2 <bytevector>) ) - (cmp op b1 (b-len b1) b2 (b-len b2))) - (define-method (op (s1 <py-bytes>) (s2 <py-bytes>) ) - (let ((b1 (slot-ref s1 'bytes)) - (b2 (slot-ref s2 'bytes))) - (cmp op b1 (b-len b1) b2 (b-len b2)))) - (define-method (op (a1 <py-bytearray>) (b2 <bytevector>)) - (let ((b1 (slot-ref a1 'vec)) - (n1 (slot-ref a1 'n))) - (cmp op b1 n1 b2 (b-len b2)))) - (define-method (op (b1 <bytevector>) (a2 <py-bytearray>)) - (let ((b2 (slot-ref a2 'vec)) - (n2 (slot-ref a2 'n))) - (cmp op b1 (b-len b1) b2 n2))) - (define-method (op (a1 <py-bytearray>) (s2 <py-bytes>)) - (let ((b1 (slot-ref a1 'vec)) - (n1 (slot-ref a1 'n)) - (b2 (slot-ref s2 'bytes))) - (cmp op b1 n1 b2 (b-len b2)))) - (define-method (op (s1 <py-bytes>) (a2 <py-bytearray>)) - (let ((b2 (slot-ref a2 'vec)) - (n2 (slot-ref a2 'n)) - (b1 (slot-ref s1 'bytes))) - (cmp op b1 (b-len b1) b2 n2))) - (define-method (op (a1 <py-bytearray>) (a2 <py-bytearray>)) - (let ((b1 (slot-ref a1 'vec)) - (n1 (slot-ref a1 'n )) - (b2 (slot-ref a2 'vec)) - (n2 (slot-ref a2 'n ))) - (cmp op b1 n1 b2 n2))))) - -(mkop <) -(mkop <=) -(mkop >) -(mkop >=) -(mkop py-equal?) - -(define-py* zfill (py-zfill bytes s n width) - (let* ((w (pylist-slice s 0 n 1))) - (let lp ((i 0)) - (if (< i n) - (let* ((x (b-ref s i)) - (ch (chf x))) - (if (char-numeric? ch) - (let lp ((j (max 0 (- i width)))) - (if (< j i) - (begin - (b-set! w j (ch-find #\0)) - (lp (+ j 1))) - (bytes w))) - (lp (+ i 1)))) - s)))) - - (define-method (py-hash (o <py-bytes>)) (hash (slot-ref o 'bytes) pyhash-N)) - -(define-class <bytes-iter> (<py-bytes>) i d) -(define-class <bytearray-iter> (<py-bytearray>) i d) - -(define-method (wrap-in (o <bytes-iter> )) - (let ((out (make <bytes-iter>))) - (slot-set! out 'bytes (slot-ref o 'bytes)) - (slot-set! out 'i (slot-ref o 'i)) - (slot-set! out 'd (slot-ref o 'd)) - out)) - -(define-method (wrap-in (o <bytearray-iter> )) - (let ((out (make <bytearray-iter>))) - (slot-set! out 'vec (slot-ref o 'vec)) - (slot-set! out 'n (slot-ref o 'n)) - (slot-set! out 'i (slot-ref o 'i)) - (slot-set! out 'd (slot-ref o 'd)) - out)) - -(define-method (wrap-in (s <bytevector>)) - (let ((out (make <bytes-iter>))) - (slot-set! out 'bytes s) - (slot-set! out 'i 0) - (slot-set! out 'd 1) - out)) - -(define-method (wrap-in (s <py-bytes>)) - (let ((out (make <bytes-iter>))) - (slot-set! out 'bytes (slot-ref s 'bytes)) - (slot-set! out 'i 0) - (slot-set! out 'd 1) - out)) - -(define-method (wrap-in (s <py-bytearray>)) - (let ((out (make <bytes-iter>))) - (slot-set! out 'vec (slot-ref s 'vec)) - (slot-set! out 'n (slot-ref s 'n)) - (slot-set! out 'i 0) - (slot-set! out 'd 1) - out)) - -(define-method (py-reversed (s <py-bytes>)) - (let ((out (make <bytes-iter>))) - (slot-set! out 'bytes (slot-ref s 'bytes)) - (slot-set! out 'i (- (b-len s) 1)) - (slot-set! out 'd -1) - out)) - -(define-method (py-reversed (s <py-bytearray>)) - (let ((out (make <bytearray-iter>))) - (slot-set! out 'n (slot-ref s 'n)) - (slot-set! out 'vec (slot-ref s 'vec)) - (slot-set! out 'i (- (slot-ref s 'n) 1)) - (slot-set! out 'd -1) - out)) - -(define-method (next (o <bytes-iter>)) - (let ((i (slot-ref o 'i )) - (d (slot-ref o 'd)) - (bytes (slot-ref o 'bytes))) - (if (> d 0) - (if (< i (b-len bytes)) - (let ((ret (b-ref bytes i))) - (slot-set! o 'i (+ i d)) - ret) - (throw StopIteration)) - (if (>= i 0) - (let ((ret (b-ref bytes i))) - (slot-set! o 'i (+ i d)) - ret) - (throw StopIteration))))) - -(define-method (next (o <bytearray-iter>)) - (let ((i (slot-ref o 'i )) - (d (slot-ref o 'd )) - (bytes (slot-ref o 'vec)) - (n (slot-ref o 'n ))) - (if (> d 0) - (if (< i n) - (let ((ret (b-ref bytes i))) - (slot-set! o 'i (+ i d)) - ret) - (throw StopIteration)) - (if (>= i 0) - (let ((ret (b-ref bytes i))) - (slot-set! o 'i (+ i d)) - ret) - (throw StopIteration))))) - -(define (pybytes-listing) - (let ((l (to-pylist - (map symbol->string - '(__add__ __class__ __contains__ __delattr__ __doc__ - __eq__ __format__ __ge__ __getattribute__ - __getitem__ __getnewargs__ __getslice__ __gt__ - __hash__ __init__ __le__ __len__ __lt__ __mod__ - __mul__ __ne__ __new__ __reduce__ __reduce_ex__ - __repr__ __rmod__ __rmul__ __setattr__ __sizeof__ - __bytes__ __subclasshook__ - _formatter_field_name_split _formatter_parser - capitalize center count decode endswith - expandtabs find format index isalnum isalpha - isdigit islower isspace istitle isupper join - ljust lower lbytesip partition replace rfind rindex - rjust rpartition rsplit rbytesip split splitlines - startswith strip swapcase - title translate upper zfill))))) - (pylist-sort! l) - l)) - -(define (pybytesarray-listing) - (let ((l (to-pylist - (map symbol->string - '(__add__ __alloc__ __class__ __contains__ __delattr__ - __delitem__ __dir__ __doc__ __eq__ __format__ - __ge__ __getattribute__ __getitem__ __gt__ - __hash__ __iadd__ __imul__ __init__ __iter__ - __le__ __len__ __lt__ __mod__ __mul__ __ne__ - __new__ __reduce__ __reduce_ex__ __repr__ - __rmod__ __rmul__ __setattr__ __setitem__ - __sizeof__ __str__ __subclasshook__ append - capitalize center clear copy count decode endswith - expandtabs extend find fromhex hex index insert - isalnum isalpha isdigit islower isspace istitle - isupper join ljust lower lstrip maketrans - partition pop remove replace reverse rfind rindex - rjust rpartition rsplit rstrip split splitlines - startswith strip swapcase title translate upper - zfill))))) - (pylist-sort! l) - l)) - -(define (_in x y n) - (let lp ((i 0)) - (if (< i n) - (if (= (b-ref y i) x) - #t - (lp (+ i 1))) - #f))) - -(define (_in2 x y n) - (let lp ((i 0)) - (if (< i n) - (let lp2 ((j i) (r x)) - (if (null? r) - #t - (if (< j n) - (if (= (b-ref y j) (car r)) - (lp2 (+ j 1) (cdr r)) - (lp (+ i 1))) - #f))) - #f))) - -(define-method (in (x <integer>) (b <bytevector>)) - (_in x b (len b))) -(define-method (in (x <integer>) (b <py-bytes>)) - (_in x (slot-ref b 'bytes) (len b))) -(define-method (in (x <integer>) (b <py-bytearray>)) - (_in x (slot-ref b 'vec) (len b))) - -(define-method (in (x <pair>) (b <bytevector>)) - (_in2 x b (len b))) -(define-method (in (x <pair>) (b <py-bytes>)) - (_in2 x (slot-ref b 'bytes) (len b))) -(define-method (in (x <pair>) (b <py-bytearray>)) - (_in2 x (slot-ref b 'vec) (len b))) - -(define-method (in (x <bytevector>) b) - (in (b->list x) b)) -(define-method (in (x <py-bytes>) b) - (in (b->list x) b)) -(define-method (in (x <py-bytearray>) b) - (in (b->list x) b)) - - -(set! (@@ (language python string) bytes) bytes) -(set! (@@ (language python string) b?) - (lambda (x) - (or (is-a? x <bytevector>) - (is-a? x <py-bytes>) - (is-a? x <py-bytearray>)))) -(set! (@@ (language python string) b-decode) py-decode) - -(define b-enc #f) diff --git a/modules/language/python/checksum.scm b/modules/language/python/checksum.scm deleted file mode 100644 index dc0ce80..0000000 --- a/modules/language/python/checksum.scm +++ /dev/null @@ -1,124 +0,0 @@ -(define-module (language python checksum) - #:use-module (oop pf-objects) - #:use-module (language python bytes) - #:use-module (language python for) - #:use-module (language python list) - #:use-module (language python exceptions) - #:use-module (ice-9 binary-ports) - #:use-module (rnrs bytevectors) - #:use-module (ice-9 popen) - #:export (Summer run)) - -(define mapper (make-hash-table)) - -(let lp ((i 0)) - (if (< i 256) - (let ((a (logand #xf i)) - (b (ash (logand #xf0 i) -16))) - - (define (m i) - (car (string->list (number->string i 16)))) - - (hash-set! mapper i (cons (m a) (m b))) - (lp (+ i 1))))) - -(define (run data command) - (define n1 (char->integer #\0)) - (define n2 (char->integer #\9)) - (define p1 (char->integer #\a)) - (define p2 (char->integer #\f)) - - (let ((i.o (pipe))) - (with-output-to-port (cdr i.o) - (lambda () - (let ((port (open-pipe command OPEN_WRITE))) - (for ((b : data)) () - (put-u8 port b)) - (close-pipe port)))) - (close-port (cdr i.o)) - (let* ((ret (get-bytevector-all (car i.o))) - (n (len ret))) - (let lp ((i 0)) - (define (hex? i) - (and (< i n) - (let ((i (bytevector-u8-ref ret i))) - (or - (and (>= i n1) (<= i n2)) - (and (>= i p1) (<= i p2)))))) - - (define (hex i) - (let ((i (bytevector-u8-ref ret i))) - (if (and (>= i n1) (<= i n2)) - (+ (- i n1) 0) - (+ (- i p1) 10)))) - - (define (final l) - (let ((ret (make-bytevector (len l)))) - (let lp ((l l) (i (- (len l) 1))) - (if (>= i 0) - (begin - (bytevector-u8-set! ret i (car l)) - (lp (cdr l) (- i 1))) - (bytes ret))))) - - (if (hex? i) - (let lp ((i i) (l '())) - (if (hex? i) - (if (hex? (+ i 1)) - (lp (+ i 2) (cons (+ (hex i) (ash (hex (+ i 1)) 4)) - l)) - (final (cons (hex i) l))) - (final l))) - (error "no hex output checksum code")))))) - - - -(define-python-class Summer () - (define __init__ - (lambda (self) - (set self '_data None))) - - (define update - (lambda (self data) - (let ((old (ref self '_data))) - (if (eq? old None) - (set self '_data data) - (set self '_data (+ old data)))) - (set self '_digest None) - (values))) - - (define digest - (lambda (self) - (let ((data (ref self '_data))) - (if (eq? data None) - (raise (ValueError "no data to digest")) - (let ((old (ref self '_digest))) - (if (eq? old None) - (set! old (run data (ref self '_command)))) - (set self '_digest old) - old))))) - - - (define hexdigest - (lambda (self) - (let* ((x (digest self)) - (o (make-string (* 2 (len x))))) - (for ((b : (bv-scm x))) ((i 0)) - (let ((a.b (hash-ref mapper b))) - (string-set! o i (car a.b)) - (string-set! o (+ i 1) (cdr a.b)) - (+ i 2)) - #:final - o)))) - - (define copy - (lambda (self) - (let ((o ((ref self '__class__)))) - (set o '_data (ref self '_data)) - (set o '_digest (ref self '_digest)) - o)))) - - - - - diff --git a/modules/language/python/class.scm b/modules/language/python/class.scm deleted file mode 100644 index 41ed09a..0000000 --- a/modules/language/python/class.scm +++ /dev/null @@ -1,71 +0,0 @@ -(define-module (language python class) - #:export (class_+ class_- class_* class_// class_% - class_power class_<< class_>> class_ior - class_xor class_band)) - -(define-syntax-rule (class-ref x) (struct-ref x 0)) -(define-syntax-rule (class-num x) (struct-ref x 1)) -(define-syntax-rule (class-log x) (struct-ref x 2)) -(define-syntax-rule (class-map x) (struct-ref x 3)) - -(define-syntax-rule (mkref +-ref n) - (define-syntax-rule (+-ref x) (vector-ref x n))) - -(mkref +-ref 0) -(mkref --ref 1) -(mkref *-ref 2) -(mkref /-ref 3) -(mkref //-ref 4) -(mkref %-ref 5) -(mkref **-ref 6) -(mkref <<-ref 7) -(mkref >>-ref 8) - -(mkref ior-ref 0) -(mkref xor-ref 1) -(mkref and-ref 2) - -(define-syntax-rule (class-lookup class key ) - (hashq-ref (class-map class) key #f)) - -(define-syntax-rule (meta-mk mk-num class-num) -(define-syntax-rule (mk-num class_+ __add__ __radd__ +-ref err) - (define (class_+ x y) - (let* ((cl (class-ref x)) - (r (class-num cl))) - (define (f) - (let ((rrr (class-lookup cl '__add__))) - (if rrr - (rrr x y) - (if (class? y) - (let* ((cl (class-ref y)) - (rrrr (class-lookup cl '__radd__))) - (if rrrr - (rrrr y x) - (err))) - (err))))) - - (if r - (let ((rr (+-ref r))) - (if rr - (rr x y) - (f))) - (f)))))) - -(meta-mk mk-num class-num) -(meta-mk mk-log class-log) - -(define (err) (error "could not do artithmetic ops")) - -(mk-num class_+ __add__ __radd__ +-ref err) -(mk-num class_- __sub__ __rsub__ --ref err) -(mk-num class_* __mul__ __rmul__ *-ref err) -(mk-num class_/ __div__ __rdiv__ /-ref err) -(mk-num class_// __floordiv__ __rfloordiv__ //-ref err) -(mk-num class_% __divmod__ __rdivmod__ %-ref err) -(mk-num class_power __pow__ __rpow__ **-ref err) -(mk-num class_<< __lshift__ __rlshift__ <<-ref err) -(mk-num class_>> __rshift__ __rrshift__ >>-ref err) -(mk-log class_ior __or__ __ror__ ior-ref err) -(mk-log class_xor __xor__ __rxor__ xor-ref err) -(mk-log class_band __and__ __rand__ and-ref err) diff --git a/modules/language/python/compile.scm b/modules/language/python/compile.scm deleted file mode 100644 index 821389c..0000000 --- a/modules/language/python/compile.scm +++ /dev/null @@ -1,3078 +0,0 @@ -(define-module (language python compile) - #:use-module (ice-9 match) - #:use-module (ice-9 control) - #:use-module (oop pf-objects) - #:use-module (oop goops) - #:use-module (rnrs bytevectors) - #:use-module (language python dict) - #:use-module (language python exceptions) - #:use-module (language python yield) - #:use-module (language python for) - #:use-module (language python try) - #:use-module (language python list) - #:use-module (language python string) - #:use-module (language python bytes) - #:use-module (language python number) - #:use-module (language python def) - #:use-module (language python module) - #:use-module (language python dir) - #:use-module (language python procedure) - #:use-module (language python bool) - #:use-module ((language python format2) #:select (fnm)) - #:use-module ((language python with) #:select ()) - #:use-module (ice-9 pretty-print) - #:export (comp exit-fluid exit-prompt pks)) - -(define-syntax-rule (aif it p x y) (let ((it p)) (if it x y))) - -(define-inlinable (C x) `(@@ (language python compile) ,x)) -(define-inlinable (F2 x) `(@@ (language python format2) ,x)) -(define-inlinable (N x) `(@@ (language python number) ,x)) -(define-inlinable (Y x) `(@@ (language python yield) ,x)) -(define-inlinable (T x) `(@@ (language python try) ,x)) -(define-inlinable (F x) `(@@ (language python for) ,x)) -(define-inlinable (E x) `(@@ (language python exceptions) ,x)) -(define-inlinable (L x) `(@@ (language python list) ,x)) -(define-inlinable (S x) `(@@ (language python string) ,x)) -(define-inlinable (B x) `(@@ (language python bytes) ,x)) -(define-inlinable (Se x) `(@@ (language python set) ,x)) -(define-inlinable (D x) `(@@ (language python def) ,x)) -(define-inlinable (Di x) `(@@ (language python dict) ,x)) -(define-inlinable (O x) `(@@ (oop pf-objects) ,x)) -(define-inlinable (G x) `(@ (guile) ,x)) -(define-inlinable (H x) `(@ (language python hash) ,x)) -(define-inlinable (W x) `(@ (language python with) ,x)) - -(define exit-prompt (make-prompt-tag)) -(define exit-fluid (make-fluid #f)) - -(define (formatter . x) "<missing>") - -(define (mk-string vs l) - (define (mk-string2 x) - (if (string? x) - x - (let ((l (let lp ((l x)) - (match l - ((x . l) - (cons - (if (string? x) - x - (match x - ((#:field tag a b) - `(,(C 'formatter) ,(exp vs tag) ,a ,b)))) - (lp l))) - (() '()))))) - (match l - ((x) x) - ((x . l) (cons* '+ x l)))))) - - (let ((r - (let lp ((l l)) - (match l - ((x . l) - (let ((x (mk-string2 x)) - (l (lp l))) - (if (and (string? x) (= (length l) 1) (string? (car l))) - (list (+ x (car l))) - (cons x l)))) - (() (list "")))))) - (if (string? r) - r - (cons '+ r)))) - - - -(define-syntax-rule (with-exit code ...) - (with-fluids ((exit-fluid #t)) - (call-with-prompt exit-prompt - (lambda () code ...) - (lambda (k val) - (if (not (equal? val 0)) - (format #t "exit with error ~a~%" val)))))) - -(define (get-exported-symbols x) - (aif it (resolve-module x) - (aif it (module-public-interface it) - (let ((l '())) - (module-for-each - (lambda (k b) - (set! l (cons k l))) - it) - l) - '()) - '())) - -(define cvalues (G 'values)) - -(define-syntax-rule (wth code) - (let ((old s/d)) - (set! s/d (C 'qset!)) - (let ((r code)) - (set! s/d old) - r))) - - -(define-syntax use-modules-- - (lambda (x) - (define (keyword-like? stx) - (let ((dat (syntax->datum stx))) - (and (symbol? dat) - (eqv? (string-ref (symbol->string dat) 0) #\:)))) - (define (->keyword sym) - (symbol->keyword (string->symbol (substring (symbol->string sym) 1)))) - - (define (quotify-iface args) - (let loop ((in args) (out '())) - (syntax-case in () - (() (reverse! out)) - ;; The user wanted #:foo, but wrote :foo. Fix it. - ((sym . in) (keyword-like? #'sym) - (loop #`(#,(->keyword (syntax->datum #'sym)) . in) out)) - ((kw . in) (not (keyword? (syntax->datum #'kw))) - (syntax-violation 'define-module "expected keyword arg" x #'kw)) - ((#:renamer renamer . in) - (loop #'in (cons* #'renamer #:renamer out))) - ((kw val . in) - (loop #'in (cons* #''val #'kw out)))))) - - (define (quotify specs) - (let lp ((in specs) (out '())) - (syntax-case in () - (() (reverse out)) - (((name name* ...) . in) - (and-map symbol? (syntax->datum #'(name name* ...))) - (lp #'in (cons #''((name name* ...)) out))) - ((((name name* ...) arg ...) . in) - (and-map symbol? (syntax->datum #'(name name* ...))) - (with-syntax (((quoted-arg ...) (quotify-iface #'(arg ...)))) - (lp #'in (cons #`(list '(name name* ...) quoted-arg ...) - out))))))) - - (syntax-case x () - ((_ spec ...) - (with-syntax (((quoted-args ...) (quotify #'(spec ...)))) - #'(eval-when (expand) - (process-use-modules (list quoted-args ...)) - *unspecified*)))))) - -(define-syntax use-modules- - (lambda (x) - (define (keyword-like? stx) - (let ((dat (syntax->datum stx))) - (and (symbol? dat) - (eqv? (string-ref (symbol->string dat) 0) #\:)))) - (define (->keyword sym) - (symbol->keyword (string->symbol (substring (symbol->string sym) 1)))) - - (define (quotify-iface args) - (let loop ((in args) (out '())) - (syntax-case in () - (() (reverse! out)) - ;; The user wanted #:foo, but wrote :foo. Fix it. - ((sym . in) (keyword-like? #'sym) - (loop #`(#,(->keyword (syntax->datum #'sym)) . in) out)) - ((kw . in) (not (keyword? (syntax->datum #'kw))) - (syntax-violation 'define-module "expected keyword arg" x #'kw)) - ((#:renamer renamer . in) - (loop #'in (cons* #'renamer #:renamer out))) - ((kw val . in) - (loop #'in (cons* #''val #'kw out)))))) - - (define (quotify specs) - (let lp ((in specs) (out '())) - (syntax-case in () - (() (reverse out)) - (((name name* ...) . in) - (and-map symbol? (syntax->datum #'(name name* ...))) - (lp #'in (cons #''((name name* ...)) out))) - ((((name name* ...) arg ...) . in) - (and-map symbol? (syntax->datum #'(name name* ...))) - (with-syntax (((quoted-arg ...) (quotify-iface #'(arg ...)))) - (lp #'in (cons #`(list '(name name* ...) quoted-arg ...) - out))))))) - - (syntax-case x () - ((_ spec ...) - (with-syntax (((quoted-args ...) (quotify #'(spec ...)))) - #'(eval-when (eval load) - (process-use-modules (list quoted-args ...)) - *unspecified*)))))) - -(define-syntax-rule (use p l a ...) - (begin - (eval-when (expand) - (catch #t - (lambda () - (if (not p) (reload-module (resolve-module 'l))) - (use-modules-- a ...)) - (lambda x - #f))) - (eval-when (eval load) - (catch #t - (lambda () - (if (not p) (reload-module (resolve-module 'l))) - (use-modules- a ...)) - (lambda x - (raise (ImportError ((@ (guile) format) - #f "failed to import ~a ~a" 'l x)))))))) - -(define level (make-fluid 0)) - -(define (flat x) - (let lp ((x (list x))) - (if (pair? x) - (let ((e (car x))) - (if (pair? e) - (let ((ee (car e))) - (if (equal? ee '(@ (guile) cons)) - (append (lp (list (cadr e))) - (lp (list (caddr e))) - (lp (cdr x))) - (lp (cdr x)))) - (if (symbol? e) - (cons e (lp (cdr x))) - '()))) - '()))) - -(define s/d (C 'qset!)) - -(define (pre) (warn "Patching guile will lead to way better experience use 'python.patch' on guile-2.2 e.g. (use-modules (language python guilemod))")) - -(define (gw-persson x l) - (if (or (member x (fluid-ref (@@ (system base message) %dont-warn-list))) - (member x l)) - x - #f)) - -(define-syntax clear-warning-data - (lambda (x) - (catch #t - (lambda () - (fluid-set! (@@ (system base message) %dont-warn-list) '())) - (lambda x (pre))) - #f)) - -(define-syntax-rule (with-warn code ...) - (with-fluids (((@@ (system base message) %dont-warn-list) '())) - code ...)) - -(define-syntax-rule (with-warn-data x code ...) - (with-fluids (((@@ (system base message) %dont-warn-list) x)) - code ...)) - -(define (get-warns) - (list (G 'quote) (fluid-ref (@@ (system base message) %dont-warn-list)))) - -(define (dont-warn v) - (catch #t - (lambda () - (fluid-set! (@@ (system base message) %dont-warn-list) - (cons v - (fluid-ref (@@ (system base message) %dont-warn-list))))) - (lambda x (values)))) - -(define-syntax call - (syntax-rules () - ((_ (f) . l) (f . l)))) - -(define (fold f init l) - (if (pair? l) - (fold f (f (car l) init) (cdr l)) - init)) - -(define do-pr #t) - -(define (pr . x) - (if do-pr - (let () - (define port (open-file "/home/stis/src/python-on-guile/log.txt" "a")) - (with-output-to-port port - (lambda () - (pretty-print (syntax->datum x)))) - (close port))) - (car (reverse x))) - -(define (pf x) - (define port (open-file "/home/stis/src/python-on-guile/compile.log" "a")) - (with-output-to-port port - (lambda () (pretty-print (syntax->datum x)) x)) - (close port) - x) - -(define (pp x) - (pretty-print (syntax->datum x)) - x) - -(define (gv x) - (if (equal? x '_) - (gensym "_") - x)) - -(define (is-special? vs x) - (if (or-map (lambda (x) (match x ((#:starexpr . _) #t) (_ #f))) x) - (let lp ((l (map (g vs exp) x))) - (if (pair? l) - `((@ (guile) cons) ,(car l) ,(lp (cdr l))) - `((@ (guile) quote) ()))) - #f)) - -(define (gen-sel vs e item) - (match e - (#f item) - ((#:cfor for-e in-e cont) - (let lp ((for-e for-e)) - (match for-e - (((#:sub l)) - `(,(F 'for) ((,@(map (lambda (x) (gv ((g vs exp) x))) l) - : ,(exp vs in-e))) () - ,(gen-sel vs cont item))) - (_ - `(,(F 'for) ((,@(map (lambda (x) (gv ((g vs exp) x))) for-e) - : ,(exp vs in-e))) () - ,(gen-sel vs cont item)))))) - ((#:cif cif cont) - `(,(G 'if) ,(exp vs cif) - ,(gen-sel vs cont item))))) - -(define (union as vs) - (let lp ((as as) (vs vs)) - (match as - ((x . as) - (if (member x vs) - (lp as vs) - (lp as (cons x vs)))) - (() - vs)))) - -(define (diff as vs) - (let lp ((as as) (rs '())) - (match as - ((x . as) - (if (member x vs) - (lp as rs) - (lp as (cons x rs)))) - (() - rs)))) - -(define (get-globals code) - (let lp ((vs (glob code '())) (rs (scope code '()))) - (match vs - ((x . l) - (if (member x rs) - (lp l rs) - (lp l (cons x rs)))) - (() - rs)))) - -(define (glob x vs) - (match x - ((#:global . l) - (let lp ((l l) (vs vs)) - (match l - (((#:identifier v . _) . l) - (let ((s (string->symbol v))) - (if (member s vs) - (lp l vs) - (lp l (cons s vs))))) - (() - vs)))) - ((x . y) - (glob y (glob x vs))) - (x vs))) - -(define (scope x vs) - (match x - ((#:def f . _) - (union (list (exp '() f)) vs)) - - ((#:lambdef . _) - vs) - - ((#:comma a) - (scope a vs)) - - ((#:comma a . l) - (union - (scope a vs) - (scope (cons #:comma l) vs))) - - - ((#:with (l ...) code) - (scope code (union vs - (let lp ((l l)) - (match l - (((a b) . l) - (cons (exp '() b) (lp l))) - ((x . l) (lp l)) - (() '())))))) - - ((#:classdef f . _) - (union (list (exp '() f)) vs)) - - ((#:global . _) - vs) - - ((#:import (#:name ((_ ids ...) . as) ...) ...) - (let lp ((ids ids) (as as) (vs vs)) - (if (pair? ids) - (let lp2 ((ids2 (car ids)) (as2 (car as)) (vs vs)) - (if (pair? as2) - (lp2 (cdr ids2) (cdr as2) - (let ((as2 (car as2)) - (ids2 (car ids2))) - (union vs (list (exp '() (if as2 as2 (car ids2))))))) - (lp (cdr ids) (cdr as) vs))) - vs))) - - ((#:expr-stmt l (#:assign u ... v)) - (union - (fold (lambda (l s) - (union - s - (fold (lambda (x s) - (match x - ((#:test (#:power v2 v1 () . _) . _) - (if v2 - (union - (union (flat (exp '() v1)) - (flat (exp '() v2))) - s) - (union (flat (exp '() v1)) s))) - - ((#:starexpr #:power _ v1 . _) - (union - (flat (exp '() v1)) - s)) - - (_ s))) - '() - l))) - '() - (cons l u)) - vs)) - - ((#:for es in code . final) - (let ((vs (union - vs - (let lp ((es es)) - (match es - (((#:sub . l) . u) - (union (lp l) (lp u))) - (((#:power #f (#:tuple . l) . _) . u) - (union (lp l) (lp u))) - (((and (#:power . _) x) . u) - (union (list (exp vs x)) (lp u))) - ((e . es) - (union (lp e) (lp es))) - (() '())))))) - (scope final (scope code vs)))) - - - ((#:expr-stmt l (#:assign k . u)) - (union - (union (fold (lambda (x s) - (match x - ((#:test (#:power v2 v1 () . _) . _) - (if v2 - (union - (union (flat (exp '() v1)) - (flat (exp '() v2))) - s) - (union (flat (exp '() v1)) s))) - (_ s))) - '() - l) - vs) - (scope `(#:expr-stmt ,k (#:asignvs . ,u)) vs))) - - ((x . y) - (scope y (scope x vs))) - (_ vs))) - -(define ignore (make-fluid '())) - -(define (defs x vs) - (match x - ((#:def (#:identifier f) . _) - (union (list (string->symbol f)) vs)) - ((#:lambdef . _) - vs) - ((#:class . _) - vs) - ((#:global . _) - vs) - ((#:import (#:name ((_ ids ...) . as)) ...) - (let lp ((ids ids) (as as) (vs vs)) - (if (pair? as) - (lp (cdr ids) (cdr as) - (let ((as (car as)) - (ids (car ids))) - (union vs (list (exp '() (if as as (car ids))))))) - vs))) - - ((x . y) - (defs y (defs x vs))) - (_ vs))) - -(define (gen-yield f) - (string->symbol - (string-append - (symbol->string f) - ".yield"))) - -(define (g vs e) - (lambda (x) (e vs x))) - -(define return (make-fluid 'error-return)) - -(define-syntax-rule (<< x y) (ash x y)) -(define-syntax-rule (>> x y) (ash x (- y))) - -(define-syntax-rule (mkfast ((a) v) ...) - (let ((h (make-hash-table))) - (hash-set! h 'a v) - ... - h)) - -(define (fast-ref x) - (aif it (assoc x `((__class__ . ,(O 'py-class)))) - (cdr it) - #f)) - -(define fasthash - (mkfast - ;; General - ((__init__) (O 'py-init)) - ((__ne__) (O 'ne)) - ((__eq__) (O 'equal?)) - ((__repr__) (O 'repr)) - - ;;iterators - ((__iter__) (F 'wrap-in)) - ((__next__) (F 'next)) - ((__send__) (Y 'send)) - ((__exception__) (Y 'sendException)) - ((__close__) (Y 'sendClose)) - - ;; Numerics - ((__index__) (N 'py-index)) - ((__add__ ) (N '+)) - ((__mul__ ) (N '*)) - ((__sub__ ) (N '-)) - ((__radd__ ) (N 'r+)) - ((__rmul__ ) (N 'r*)) - ((__rsub__ ) (N 'r-)) - ((__neg__ ) (N '-)) - ((__le__ ) (N '<)) - ((__lt__ ) (N '<=)) - ((__ge__ ) (N '>)) - ((__gt__ ) (N '>=)) - ((__abs__ ) (N 'py-abs)) - ((__pow__ ) (N 'expt)) - ((__rpow__ ) (N 'rexpt)) - ((__truediv__) (N 'py-/)) - ((__rtruediv__) (N 'py-r/)) - ((__and__) (N 'py-logand)) - ((__or__) (N 'py-logior)) - ((__xor__) (N 'py-logxor)) - ((__rand__) (N 'py-rlogand)) - ((__ror__) (N 'py-rlogior)) - ((__rxor__) (N 'py-rlogxor)) - ((__divmod__) (N 'py-divmod)) - ((__rdivmod__) (N 'py-rdivmod)) - ((__invert__) (N 'py-lognot)) - ((__int__) (N 'mk-int)) - ((__float__) (N 'mk-float)) - ((__lshift__) (N 'py-lshift)) - ((__rshift__) (N 'py-rshift)) - ((__rlshift__) (N 'py-rlshift)) - ((__rrshift__) (N 'py-rrshift)) - ((bit_length) (N 'py-bit-length)) - ((as_integer_ratio) (N 'py-as-integer-ratio)) - ((conjugate) (N 'py-conjugate)) - ((denominator) (N 'py-denominator)) - ((numerator) (N 'py-numerator)) - ((to_bytes) (N 'py-to-bytes)) - ((fromhex) (N 'py-fromhex)) - ((hex) (N 'py-hex)) - ((imag) (N 'py-imag)) - ((is_integer) (N 'py-is-integer)) - ((real) (N 'py-real)) - ((__mod__) (N 'py-mod)) - ((__rmod__) (N 'py-rmod)) - ((__floordiv__) (N 'py-floordiv)) - ((__rfloordiv__)(N 'py-rfloordiv)) - ((__hex__) (N 'hex)) - - ;; Lists - ((append) (L 'pylist-append!)) - ((count) (L 'pylist-count)) - ((extend) (L 'pylist-extend!)) - ((index) (L 'pylist-index)) - ((pop) (L 'pylist-pop!)) - ((insert) (L 'pylist-insert!)) - ((remove) (L 'pylist-remove!)) - ((reverse) (L 'pylist-reverse!)) - ((sort) (L 'pylist-sort!)) - ((__len__) (L 'len)) - ((__contains__) (L 'in)) - ((__delitem__) (L 'pylist-delete!)) - ((__delslice__) (L 'pylist-delslice)) - ((__setitem__) (L 'pylist-set!)) - - ;; String - ((format) (S 'py-strformat)) - ((format_map) (S 'py-format-map)) - ((capitalize) (S 'py-capitalize)) - ((center) (S 'py-center )) - ((endswith) (S 'py-endswith)) - ((expandtabs) (S 'py-expandtabs)) - ((find) (S 'py-find )) - ((rfind) (S 'py-rfind )) - ((isalnum) (S 'py-isalnum)) - ((isalpha) (S 'py-isalpha)) - ((isdigit) (S 'py-isdigit)) - ((islower) (S 'py-islower)) - ((isspace) (S 'py-isspace)) - ((isupper) (S 'py-isupper)) - ((istitle) (S 'py-istitle)) - ((isidentifier) (S 'py-identifier)) - ((join) (S 'py-join )) - ((ljust) (S 'py-join )) - ((rljust) (S 'py-rljust )) - ((lower) (S 'py-lower )) - ((upper) (S 'py-upper )) - ((lstrip) (S 'py-lstrip )) - ((rstrip) (S 'py-rstrip )) - ((partition) (S 'py-partition)) - ((replace) (S 'py-replace)) - ((strip) (S 'py-strip )) - ((title) (S 'py-title )) - ((rpartition) (S 'py-rpartition)) - ((rindex) (S 'py-rindex )) - ((split) (S 'py-split )) - ((rsplit) (S 'py-rsplit )) - ((splitlines) (S 'py-splitlines)) - ((startswith) (S 'py-startswith)) - ((swapcase) (S 'py-swapcase)) - ((translate) (S 'py-translate)) - ((zfill) (S 'py-zfill)) - ((encode) (S 'py-encode)) - - ;;Nytevectors - ((decode) (B 'py-decode)) - - ;;DICTS - ((copy) (Di 'py-copy)) - ((fromkeys) (Di 'py-fromkeys)) - ((get) (Di 'py-get)) - ((has_key) (Di 'py-has_key)) - ((items) (Di 'py-items)) - ((iteritems) (Di 'py-iteritems)) - ((iterkeys) (Di 'py-iterkeys)) - ((itervalues) (Di 'py-itervalues)) - ((keys) (Di 'py-keys)) - ((values) (Di 'py-values)) - ((popitem) (Di 'py-popitem)) - ((setdefault) (Di 'py-setdefault)) - ((update) (Di 'py-update)) - ((clear) (Di 'py-clear)) - ((__hash__) (H 'py-hash)))) - - -(define (fastfkn x) (hash-ref fasthash x)) - -(define (get-kwarg vs arg) - (let lp ((arg arg)) - (match arg - (((#:* a) . arg) - (cons `(* ,(exp vs a)) (lp arg))) - (((#:** a) . arg) - (cons `(** ,(exp vs a)) (lp arg))) - (((#:= a b) . arg) - (cons `(= ,(exp vs a) ,(exp vs b)) (lp arg))) - ((x . arg) - (cons (exp vs x) (lp arg))) - (() - '())))) - -(define (getarg x) - (match x - ((#:tp x . l) - x) - (x x))) - -(define (get-args_ vs arg) - (let lp ((arg arg)) - (match arg - (((#:arg x) . arg) - (cons (exp vs (getarg x)) - (lp arg))) - ((x . args) - (lp args)) - - (() - '())))) - -(define (get-args= vs arg) - (let lp ((arg arg)) - (match arg - (((#:= x v) . arg) - (cons (list '= (exp vs (getarg x)) (exp vs v)) - (lp arg))) - - ((x . args) - (lp args)) - - (() - '())))) - -(define (get-args* vs arg) - (let lp ((arg arg)) - (match arg - (((#:* x) . arg) - (cons (list '* (exp vs (getarg x))) - (lp arg))) - - ((x . args) - (lp args)) - - (() - '())))) - -(define (get-args** vs arg) - (let lp ((arg arg)) - (match arg - (((#:** x) . arg) - (cons (list '** (exp vs (getarg x))) - (lp arg))) - - ((x . args) - (lp args)) - - (() - '())))) - -(define (kw->li dict) - (for ((k v : dict)) ((l '())) - (cons* v (symbol->keyword (string->symbol k)) l) - #:final - (reverse l))) - -(define (arglist->pkw l) - (let lp ((l l) (r '())) - (if (pair? l) - (let ((x (car l))) - (if (keyword? x) - (list (G 'cons) `(,(G 'list) ,@(reverse r)) `(,(G 'list) ,@l)) - (lp (cdr l) (cons x r)))) - (list (G 'cons) `(,(G 'list) ,@(reverse r)) `(,(G 'quote) ()))))) - -(define (get-addings vs x fast?) - (match x - (() '()) - ((x . l) - (let ((is-fkn? (match l - ((#f) #t) - (((#:arglist . _) . _) - #t) - (_ - #f)))) - - (cons - (match x - ((#:identifier . _) - (let* ((tag (exp vs x)) - (xs (gensym "xs")) - (fast (fastfkn tag)) - (is-fkn? (aif it (and fast? is-fkn? fast) - `(#:call-obj (lambda (e) - (lambda ,xs - (,(G 'apply) ,it e ,xs)))) - #f))) - (if is-fkn? - is-fkn? - (if (and fast? fast) - `(#:fastfkn-ref ,fast (,(G 'quote) ,tag)) - (aif it (and fast? (fast-ref tag)) - `(#:fast-id ,it (,(G 'quote) ,tag)) - `(#:identifier (,(G 'quote) ,tag))))))) - - ((#:arglist args) - `(#:apply ,@(get-kwarg vs args))) - - ((#:subscripts (n #f #f)) - `(#:vecref ,(exp vs n))) - - ((#:subscripts (n1 n2 n3)) - (let ((w (lambda (x) (if (eq? x None) (E 'None) x)))) - `(#:vecsub - ,(w (exp vs n1)) ,(w (exp vs n2)) ,(w (exp vs n3))))) - - ((#:subscripts (n #f #f) ...) - `(#:array-ref ,@ (map (lambda (n) - (exp vs n)) - n))) - - ((#:subscripts (n1 n2 n3) ...) - (let ((w (lambda (x) (if (eq? x None) (E 'None) x)))) - `(#:arraysub - ,@(map (lambda (x y z) - `(,(exp vs x) ,(exp vs y) ,(exp vs z))) - n1 n2 n3)))) - - (_ (error "unhandled addings"))) - (get-addings vs l fast?)))))) - -(define-syntax-rule (setwrap u) - (call-with-values (lambda () u) - (lambda (x . x*) - (if (null? x*) - x - (cons x x*))))) - -#; -(define-syntax-rule (setwrap u) - (call-with-values (lambda () u) - (case-lambda - ((x) x) - (x x)))) - -(define (make-set vs op x u) - (define (tr-op op) - (match op - ("+=" '+) - ("-=" '-) - ("*=" '*) - ("/=" '/) - ("%=" (G 'modulo)) - ("&=" (G 'logand)) - ("|=" (G 'logior)) - ("^=" (G 'logxor)) - ("**=" (N 'expt)) - ("<<=" (C '<<)) - (">>=" (C '>>)) - ("//=" (G 'floor-quotient)))) - - (match x - ((#:verb x) x) - ((#:test (#:power kind v addings . _) . _) - (let* ((v (exp vs v)) - (fast? (not (eq? v 'super))) - (addings (get-addings vs addings fast?)) - (p.a (match kind - (#f (cons #f '())) - ((v add) - (cons (exp vs v) add)))) - (p (car p.a)) - (pa (cdr p.a)) - (pa (get-addings vs pa fast?))) - (define q (lambda (x) `',x)) - (if kind - (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))))) - - (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) - (,(tr-op op) (,(C 'ref-x) ,v ,@addings) ,u))) - `(,s/d ,v (,(C 'setwrap) - ,u))) - `(,(C 'set-x) - ,v - ,addings - (,(C 'setwrap) - ,(if op - `(,(tr-op op) (,(C 'ref-x) ,v ,@addings) ,u) - u))))))))) - -(define is-class? (make-fluid #f)) -(define (gen-yargs vs x) - (match x ((#:list args) - (map (g vs exp) args)))) - -(define inhibit-finally #f) -(define decorations (make-fluid '())) -(define tagis (make-hash-table)) - -(define (lr as) - (lambda (vs x) - (define (eval p a b) ((cdr (assoc p as)) a b)) - (define (expit x) - (match x - ((#:e e) e) - (x (exp vs x)))) - (let lp ((x x)) - (match x - ((p a b) - (if (assoc p as) - (match b - ((q c d) - (if (assoc q as) - (lp (list q (list #:e (lp (list p a c))) d)) - (eval p (expit a) (expit b)))) - (_ (eval p (expit a) (expit b)))) - (expit x))) - (_ (expit x)))))) - -(define (mklr x) - (lambda (a b) - (list x a b))) - -(define (f% s a) - (if (string? s) - (list (F2 'format) s a) - (list (N 'py-mod) s a))) - -(define lr+ (lr `((#:+ . ,(mklr (G '+))) (#:- . ,(mklr (G '-)))))) -(define lr* (lr `((#:* . ,(mklr (G '*))) (#:/ . ,(mklr (N 'py-/))) - (#:% . ,f%) (#:// . ,(mklr (N 'py-floordiv)))))) - -(define lr-or (lr `((#:bor . ,(mklr (N 'py-logior)))))) -(define lr-and (lr `((#:band . ,(mklr (N 'py-logand)))))) -(define lr-xor (lr `((#:bxor . ,(mklr (N 'py-logxor)))))) - -(define-syntax-rule (gen-table x vs (tag code ...) ...) - (begin - (hash-set! tagis tag - (lambda (x vs) - (match x code ...))) - - ...)) - -(define *doc* (make-fluid #f)) -(define (get-doc) - (aif it (fluid-ref *doc*) - it - "")) -(define set-doc - (case-lambda - (() (fluid-set! *doc* #f)) - ((x) - (if (not (fluid-ref *doc*)) - (fluid-set! *doc* x))))) - -(define (u-it m) - (if (and (eq? (list-ref m 0) 'language) - (eq? (list-ref m 1) 'python) - (eq? (list-ref m 0) 'module)) - (cddr m) - '())) - -(define (tr-comp op x y) - (match op - ((or "<" ">" "<=" ">=") - (list (G (string->symbol op)) x y)) - ("!=" (list (G 'not) (list (O 'equal?) x y))) - ("==" (list (O 'equal?) x y)) - ("is" (list (G 'eq?) x y)) - ("isnot" (list (G 'not) (list (G 'eq?) x y))) - ("in" (list (L 'in) x y)) - ("notin" (list (G 'not) (list (L 'in) x y))) - ("<>" (list (G 'not) (list (O 'equal?) x y))))) - -(gen-table x vs - (#:power - ((_ _ (x) () . #f) - (exp vs x)) - - ((_ _ x () . #f) - (exp vs x)) - - ((_ #f vf trailer . **) - (let* ((vf (exp vs vf)) - (fast? (not (eq? vf 'super)))) - (define (pw x) - (if ** - `(,(N 'expt) ,x ,(exp vs **)) - x)) - (pw - (let ((trailer (get-addings vs trailer fast?))) - `(,(C 'ref-x) ,vf ,@trailer)))))) - - (#:identifier - ((#:identifier x . _) - (string->symbol x))) - - (#:decorated - ((_ (l ...)) - (fluid-set! decorations (map (g vs exp) l)) - `(,cvalues))) - - (#:string - ((_ l) - (mk-string vs l))) - - (#:bytes - ((_ l) - (let* ((b (make-bytevector (length l)))) - (let lp ((l l) (i 0)) - (if (pair? l) - (begin - (bytevector-u8-set! b i (car l)) - (lp (cdr l) (+ i 1))) - `(,(B 'bytes) ,b)))))) - - - (#:+ - (x - (lr+ vs x))) - - (#:- - (x - (lr+ vs x))) - - (#:* - (x - (lr* vs x))) - - (#:/ - (x - (lr* vs x))) - - (#:% - (x - (lr* vs x))) - - (#:// - (x - (lr* vs x))) - - (#:<< - ((_ . l) - (cons (N 'py-lshift) (map (g vs exp) l)))) - - (#:>> - ((_ . l) - (cons (N 'py-rshift) (map (g vs exp) l)))) - - (#:u~ - ((_ x) - (list (N 'py-lognot) (exp vs x)))) - - (#:u- - ((_ x) - (list '- (exp vs x)))) - - (#:u+ - ((_ x) - (list '+ (exp vs x)))) - - (#:band - (x (lr-and vs x))) - - (#:bxor - (x (lr-xor vs x))) - - (#:bor - (x (lr-or vs x))) - - (#:not - ((_ x) - (list (G 'not) (list (C 'boolit) (exp vs x))))) - - (#:or - ((_ . x) - (cons (G 'or) (map (lambda (x) (list (C 'boolit) (exp vs x))) x)))) - - (#:and - ((_ . x) - (cons (G 'and) (map (lambda (x) (list (C 'boolit) (exp vs x))) x)))) - - (#:test - ((_ e1 #f) - (exp vs e1)) - - ((_ e1 (e2 #f)) - (list (G 'if) (list (C 'boolit) (exp vs e2)) (exp vs e1) (C 'None))) - - ((_ e1 (e2 e3)) - (list (G 'if) (list (C 'boolit) (exp vs e2)) (exp vs e1) (exp vs e3)))) - - (#:del - ;;We don't delete variables - ((_ . l) - `(,(G 'begin) - ,@(let lp ((l l)) - (match l - (((#:power #f base () . #f) . l) - (cons `(set! ,(exp vs base) #f) - (lp l))) - - - (((#:power #f base (l ... fin) . #f) . ll) - (let* ((f (exp vs base)) - (fast? (not (eq? f 'super))) - (add (get-addings vs l fast?)) - (fin (get-addings vs (list fin) fast?))) - (cons - `(,(C 'del-x) (,(C 'ref-x) ,f ,@add) ,@fin) - (lp ll)))) - (() '())))))) - - (#:with - ((_ (l ...) code) - (let* ((l (map (lambda (x) - (match x - ((a b) (list (exp vs b) (gensym "as") (exp vs a))) - ((b) (list (exp vs b))))) - l)) - (vs (union vs (let lp ((l l)) - (match l - (((x) . l) (lp l)) - (((a b c) . l) (cons a (lp l))) - (() '())))))) - - (define (f x) - (match x - ((a b c) (list 'set! a b)) - ((a) (list (G 'values))))) - - (define (g x) - (match x - ((a b c) (list b c)) - ((a) (list a)))) - - `(,(W 'with) ,(map g l) - (,(G 'begin) - ,@(map f l) - ,(exp vs code)))))) - - (#:if - ((_ test a ((tests . as) ...) . else) - `(,(G 'cond) - (,(list (C 'boolit) (exp vs test)) ,(exp vs a)) - ,@(map (lambda (p a) (list (list (C 'boolit) (exp vs p)) - (exp vs a))) tests as) - ,@(if else `((else ,(exp vs else))) '())))) - - (#:suite - ((_ #:stmt . l) (cons (G 'begin) (map (g vs exp) l))) - ((_ . l) (cons (G 'begin) (map (g vs exp) l)))) - - (#:classdef - ((_ class parents code) - (with-fluids ((is-class? #t)) - (let () - (define (clean l) - (match l - (((#:apply . l). u) (append (clean l) (clean u))) - (((`= x v ) . l) (cons* (symbol->keyword x) v (clean l))) - ((x . l) (cons x (clean l))) - (() '()))) - (let* ((decor (let ((r (fluid-ref decorations))) - (fluid-set! decorations '()) - r)) - (class (exp vs class)) - (vo vs) - (vs (union (list class) vs)) - (ns (scope code '())) - (ls ns #;(diff ns vs)) - - (parents (match parents - (() #f) - (#f #f) - ((#:arglist . _) - (get-addings vs (list parents) #f)))) - (cd.doc (with-fluids ((*doc* #f)) - (let ((cd (wth (exp vs code)))) - (cons cd (get-doc))))) - (cd (car cd.doc)) - (doc (cdr cd.doc))) - `(set! ,class - (,(C 'class-decor) ,decor - (,(C 'with-class) ,class - (,(C 'mk-p-class2) - ,class - ,(if parents - (arglist->pkw (clean parents)) - `(,(G 'cons) (,(G 'quote) ()) (,(G 'quote) ()))) - ,doc - ,(map (lambda (x) `(define ,x ,(gw-persson x vo))) ls) - ,cd))))))))) - (#:verb - ((_ x) x)) - - (#:scm - ((_ (#:string _ s)) (with-input-from-string s read))) - - (#:comma - ((_ - (and x - (#:expr-stmt - ((#:test - (#:power #f (#:string l) () . #f) - #f)) - (#:assign)))) - (set-doc (mk-string vs l)) - (exp vs x)) - - ((_ a) - (exp vs a)) - - ((_ (and a - (#:expr-stmt - ((#:test - (#:power #f (#:string ll) () . #f) - #f)) - (#:assign))) . l) - (set-doc (mk-string vs ll)) - `(,(G 'begin) ,(exp vs a) ,(exp vs (cons #:comma l)))) - - ((_ a . l) - `(,(G 'begin) ,(exp vs a) ,(exp vs (cons #:comma l))))) - - (#:import - ((_ (#:from (() . nm) . #f)) - (let* ((xl (map (lambda (nm) (exp vs nm)) nm)) - (l `(language python module ,@xl))) - - ;; Make sure to load the module in - (let ((? (catch #t - (lambda () (Module (reverse l) (reverse xl)) #t) - (lambda x #f)))) - (if (eq? ? #t) (for-each dont-warn (get-exported-symbols l))) - `(,(C 'use) ,? ,l ,l)))) - - ((_ (#:from (("." . nn) . nm) . #f)) - (let* ((u (module-name (current-module))) - (u (reverse (list-cdr-ref (reverse (u-it u)) (length nn)))) - (xl (append u (map (lambda (nm) (exp vs nm)) nm))) - (l `(language python module ,@xl))) - - ;; Make sure to load the module in - (let ((? (catch #t - (lambda () (Module (reverse l) (reverse xl)) #t) - (lambda x #f)))) - (if (eq? ? #t) (for-each dont-warn (get-exported-symbols l))) - `(,(C 'use) ,? ,l ,l)))) - - ((_ (#:from ("." . nn) . #f)) - (let* ((nm '()) - (u (module-name (current-module))) - (u (reverse (list-cdr-ref (reverse (u-it u)) (length nn)))) - (xl (append u (map (lambda (nm) (exp vs nm)) nm))) - (l `(language python module ,@xl))) - - ;; Make sure to load the module in - (let ((? (catch #t - (lambda () (Module (reverse l) (reverse xl)) #t) - (lambda x #f)))) - (if (eq? ? #t) (for-each dont-warn (get-exported-symbols l))) - `(,(C 'use) ,? ,l ,l)))) - - ((_ (#:from (() . nm) l)) - ;; Make sure to load the module in - (let* ((xl (map (lambda (nm) (exp vs nm)) nm)) - (ll `(language python module ,@xl))) - - `(,(C 'use) #t () - (,ll - #:select - ,(map (lambda (x) - (match x - ((a . #f) - (let ((s (exp vs a))) - (fluid-set! ignore - (cons s (fluid-ref ignore))) - (dont-warn s) - s)) - - ((a . b) - (let ((s1 (exp vs a)) - (s2 (exp vs b))) - (fluid-set! ignore - (cons s2 - (fluid-ref ignore))) - (dont-warn s2) - (cons s1 s2))))) - l))))) - - ((_ (#:from (("." . nn) . nm) l)) - ;; Make sure to load the module in - (let* ((u (module-name (current-module))) - (u (reverse (list-cdr-ref (reverse (u-it u)) (length nn)))) - (xl (append u (map (lambda (nm) (exp vs nm)) nm))) - (ll `(language python module ,@xl))) - - `(,(C 'use) #t () - (,ll - #:select - ,(map (lambda (x) - (match x - ((a . #f) - (let ((s (exp vs a))) - (fluid-set! ignore - (cons s (fluid-ref ignore))) - (dont-warn s) - s)) - - ((a . b) - (let ((s1 (exp vs a)) - (s2 (exp vs b))) - (fluid-set! ignore - (cons s2 - (fluid-ref ignore))) - (dont-warn s2) - (cons s1 s2))))) - l))))) - - ((_ (#:from ("." . nn) l)) - ;; Make sure to load the module in - (let* ((nm '()) - (u (module-name (current-module))) - (u (reverse (list-cdr-ref (reverse (u-it u)) (length nn)))) - (xl (append u (map (lambda (nm) (exp vs nm)) nm))) - (ll `(language python module ,@xl))) - - `(,(C 'use) #t () - (,ll - #:select - ,(map (lambda (x) - (match x - ((a . #f) - (let ((s (exp vs a))) - (fluid-set! ignore - (cons s (fluid-ref ignore))) - (dont-warn s) - s)) - - ((a . b) - (let ((s1 (exp vs a)) - (s2 (exp vs b))) - (fluid-set! ignore - (cons s2 - (fluid-ref ignore))) - (dont-warn s2) - (cons s1 s2))))) - l))))) - - - ((_ (#:name ((dots ids ...) . as) ...) ...) - `(,(G 'begin) - ,@(map - (lambda (dots ids as) - `(,(G 'begin) - ,@(map (lambda (dots ids as) - (let* ((u (module-name (current-module))) - (u (reverse (list-cdr-ref (reverse (u-it u)) - (- (length dots) 1)))) - - (path (append (if (null? dots) '() u) - (map (g vs exp) ids)))) - (if as - (exp - vs - `(#:expr-stmt - ((#:test (#:power #f ,as ()))) - (#:assign - ((#:verb - ((@ (language python module) import) - ((@ (language python module) Module) - (,(G 'quote) - ,(reverse (append - '(language python module) - path))) - (,(G 'quote) ,(reverse path))) - ,(exp vs as))))))) - (exp - vs - `(#:expr-stmt - ((#:test (#:power #f ,(car ids) ()))) - (#:assign - ((#:verb - ((@ (language python module) import) - ((@ (language python module) Module) - (,(G 'quote) - ,(append '(language python module) - path))) - ,(exp vs (car ids))))))))))) - dots ids as))) - dots ids as)))) - - (#:for - ((_ e in code . #f) - (=> next) - (let lp ((e e)) - (match e - (((#:power #f (#:tuple . l) . _)) - (lp l)) - - (((#:power #f (#:identifier x . _) () . #f)) - (match in - (((#:test power . _)) - (match power - ((#:power #f - (#:identifier "range" . _) - ((#:arglist arglist . _)) - . _) - (let* ((code2 (exp vs code)) - (p (is-ec #t code2 #t (list (C 'continue))))) - - (match arglist - ((arg) - (if p - (let ((v (gensym "v")) - (x (string->symbol x)) - (lp (gensym "lp"))) - `(,(C 'let/ec) break-ret - (,(G 'let) ((,v ,(exp vs arg))) - (,(G 'let) ,lp ((,x 0)) - (,(G 'if) (< ,x ,v) - (,(G 'begin) - (,(C 'let/ec) continue-ret - (,(C 'with-sp) ((continue (,cvalues)) - (break (break-ret))) - ,code2)) - (,lp (+ ,x 1)))))))) - - (let ((v (gensym "v")) - (x (string->symbol x)) - (lp (gensym "lp"))) - `(,(C 'let/ec) break-ret - (,(G 'let) ((,v ,(exp vs arg))) - (,(G 'let) ,lp ((,x 0)) - (,(G 'if) (< ,x ,v) - (,(G 'begin) - (,(C 'with-sp) ((break (break-ret))) - ,code2) - (,lp (+ ,x 1)))))))))) - - ((arg1 arg2) - (let ((v1 (gensym "va")) - (v2 (gensym "vb")) - (x (string->symbol x)) - (lp (gensym "lp"))) - (if p - `(,(C 'let/ec) break-ret - (,(G 'let) ((,v1 ,(exp vs arg1)) - (,v2 ,(exp vs arg2))) - (,(G 'let) ,lp ((,x ,v1)) - (,(G 'if) (< ,x ,v2) - (,(G 'begin) - (,(C 'let/ec) continue-ret - (,(C 'with-sp) ((continue (,cvalues)) - (break (break-ret))) - ,code2)) - (,lp (+ ,x 1))))))) - `(,(C 'let/ec) break-ret - (,(G 'let) ((,v1 ,(exp vs arg1)) - (,v2 ,(exp vs arg2))) - (,(G 'let) ,lp ((,x ,v1)) - (,(G 'if) (< ,x ,v2) - (,(G 'begin) - (,(C 'with-sp) ((break (break-ret))) - ,code2) - (,lp (+ ,x 1)))))))))) - ((arg1 arg2 arg3) - (let ((v1 (gensym "va")) - (v2 (gensym "vb")) - (st (gensym "vs")) - (x (string->symbol x)) - (lp (gensym "lp"))) - (if p - `(,(C 'let/ec) break-ret - (,(G 'let) ((,v1 ,(exp vs arg1)) - (,st ,(exp vs arg3)) - (,v2 ,(exp vs arg2))) - (,(G 'if) (> ,st 0) - (,(G 'let) ,lp ((,x ,v1)) - (,(G 'if) (< ,x ,v2) - (,(G 'begin) - (,(C 'let/ec) continue-ret - (,(C 'with-sp) - ((continue (,cvalues)) - (break (break-ret))) - ,code2)) - (,lp (+ ,x ,st))))) - (,(G 'if) (< ,st 0) - (,(G 'let) ,lp ((,x ,v1)) - (,(G 'if) (> ,x ,v2) - (,(G 'begin) - (,(C 'let/ec) continue-ret - (,(C 'with-sp) - ((continue (,cvalues)) - (break (break-ret))) - ,code2)) - (,lp (+ ,x ,st))))) - (,(G 'error) - "range with step 0 not allowed"))))) - `(,(C 'let/ec) break-ret - (,(G 'let) ((,v1 ,(exp vs arg1)) - (,st ,(exp vs arg3)) - (,v2 ,(exp vs arg2))) - (,(G 'if) (> ,st 0) - (,(G 'let) ,lp ((,x ,v1)) - (,(G 'if) (< ,x ,v2) - (,(G 'begin) - (,(C 'with-sp) - ((break (break-ret))) - ,code2) - (,lp (+ ,x ,st))))) - (,(G 'if) (< ,st 0) - (,(G 'let) ,lp ((,x ,v1)) - (,(G 'if) (> ,x ,v2) - (,(G 'begin) - (,(C 'with-sp) - ((break (break-ret))) - ,code2) - (,lp (+ ,x ,st))))) - (,(G 'error) - "range with step 0 not allowed")))))))) - (_ (next))))) - (_ (next)))) - (_ (next)))) - (_ (next))))) - - ((_ es in code . else) - (let lp ((es es)) - (match es - (((#:power #f (#:tuple . l) . _)) - (lp l)) - (_ - (let* ((es2 (map (g vs exp) es)) - (vs2 (union es2 vs)) - (code2 (exp vs2 code)) - (p (is-ec #t code2 #t (list (C 'continue)))) - (else2 (if else (exp vs2 else) #f)) - (in2 (match in - ((in) (list (exp vs in))) - ((in ...) (list `(,(G 'list) - ,@ (map (g vs exp) in))))))) - (list (C 'cfor) es2 in2 code2 else2 p))))))) - - (#:sub - ((_ l) - (map (g vs exp) l))) - - (#:while - ((_ test code . #f) - (let* ((lp (gensym "lp")) - (code2 (exp vs code)) - (p (is-ec #t code2 #t (list (C 'continue))))) - (if p - `(,(C 'let/ec) break-ret - (,(G 'let) ,lp () - (,(G 'if) (,(C 'boolit) ,(exp vs test)) - (,(G 'begin) - (,(C 'let/ec) continue-ret - (,(C 'with-sp) ((continue (,cvalues)) - (break (break-ret))) - ,code2)) - (,lp))))) - - `(,(C 'let/ec) break-ret - (,(G 'let) ,lp () - (,(G 'if) (,(C 'boolit) ,(exp vs test)) - (,(G 'begin) - (,(C 'with-sp) ((break (break-ret))) - ,code2) - (,lp)))))))) - - ((_ test code . else) - (let* ((lp (gensym "lp")) - (code2 (exp vs code)) - (p (is-ec #t code2 #t (list (C 'continue))))) - (if p - `(,(C 'let/ec) break-ret - (,(G 'let) ,lp () - (,(G 'if) (,(C 'boolit) ,(exp vs test)) - (,(G 'begin) - (,(C 'let/ec) ,(C 'continue-ret) - (,(C 'with-sp) ((continue (,cvalues)) - (break (break-ret))) - ,code2)) - (,lp)) - ,(exp vs else)))) - `(,(C 'let/ec) break-ret - (,(G 'let) ,lp () - (,(G 'if) (,(C 'boolit) ,(exp vs test)) - (,(G 'begin) - (,(C 'with-sp) ((break (break-ret))) - ,code2) - (,lp)) - ,(exp vs else)))))))) - - (#:try - ((_ x (or #f ()) #f . fin) - (if fin - `(,(T 'try) (,(G 'lambda) () ,(exp vs x)) - #:finally (,(G 'lambda) () ,(exp vs fin))) - `(,(T 'try) (,(G 'lambda) () ,(exp vs x))))) - - ((_ x exc else . fin) - `(,(T 'try) (lambda () ,(exp vs x)) - ,@(let lp ((exc exc) (r '())) - (match exc - ((((test . #f) code) . exc) - (lp exc (cons `(#:except ,(exp vs test) ,(exp vs code)) r))) - - (((#f code) . exc) - (lp exc (cons `(#:except #t ,(exp vs code)) r))) - - ((((test . as) code) . exc) - (let ((l (gensym "l"))) - (lp exc - (cons - `(#:except ,(exp vs test) => (,(G 'lambda) - (,(exp vs as) . ,l) - ,(exp vs code))) - r)))) - (() - (reverse r)))) - - ,@(if else `((#:except #t ,(exp vs else))) '()) - ,@(if fin `(#:finally (,(G 'lambda) () ,(exp vs fin))) '())))) - - (#:subexpr - ((_ . l) - (exp vs l))) - - (#:raise - ((_ #f . #f) - `(,(T 'raise) (,(O 'Exception)))) - - ((_ code . #f) - `(,(T 'raise) ,(exp vs code))) - - ((_ code . from) - (let ((o (gensym "o")) - (c (gensym "c"))) - `(,(T 'raise) - (,(G 'let) ((,c ,(exp vs code))) - (,(G 'let) ((,o (,(G 'if) (,(O 'pyclass?) ,c) - (,c) - ,c))) - (,(O 'set) ,o (,(G 'quote) __cause__) ,(exp vs from)) - ,o)))))) - - - (#:yield - ((_ (#:from x)) - (let ((y (gensym "y")) - (f (gensym "f"))) - `(,(G 'begin) - (fluid-set! ,(Y 'in-yield) #t) - (,(F 'for) ((,y : ,(exp vs x))) () - (,(G 'let) ((,f (scm.yield ,y))) - (,f)))))) - - ((_ args) - (let ((f (gensym "f"))) - `(,(G 'begin) - (,(G 'fluid-set!) ,(Y 'in-yield) #t) - (,(G 'let) ((,f (scm.yield ,@(gen-yargs vs args)))) - (,f))))) - - - ((_ f args) - (let ((f (gen-yield (exp vs f))) - (g (gensym "f"))) - `(,(G 'begin) - (set! ,(C 'inhibit-finally) #t) - (,(G 'let) ((,g (,f ,@(gen-yargs vs args)))) - (,g)))))) - - (#:def - ((_ f - (#:types-args-list . args) - #f - code) - (let* ((decor (let ((r (fluid-ref decorations))) - (fluid-set! decorations '()) - r)) - (arg_ (get-args_ vs args)) - (arg= (get-args= vs args)) - (dd= (map cadr arg=)) - (c? (fluid-ref is-class?)) - (f (exp vs f)) - (y? (is-yield f #f code)) - (r (gensym "return")) - (*f (get-args* vs args)) - (dd* (map cadr *f)) - (**f (get-args** vs args)) - (dd** (map cadr **f)) - (aa `(,@arg_ ,@*f ,@arg= ,@**f)) - (ab (gensym "ab")) - (vs (union dd** (union dd* (union dd= (union arg_ vs))))) - (ns (scope code vs)) - (df '() #;(defs code '())) - (ex (gensym "ex")) - (y 'scm.yield) - (y.f (gen-yield f)) - (ls (diff (diff ns vs) df)) - (cd.doc (with-fluids ((is-class? #f) - (*doc* #f) - (return r)) - (let ((cd (wth (exp ns code)))) - (cons cd (get-doc))))) - (cd (car cd.doc)) - (doc (cdr cd.doc)) - (docv (gensym "fv")) - (docer (lambda (x) `(,(G 'let) ((,docv ,x)) - (,(C 'set) ,docv (,(G 'quote) __doc__) ,doc) - ,docv)))) - (define (mk code) - `(let-syntax ((,y (syntax-rules () - ((_ . args) - (abort-to-prompt ,ab . args)))) - (,y.f (syntax-rules () - ((_ . args) - (abort-to-prompt ,ab . args))))) - ,code)) - - (if c? - (if y? - `(set! ,f - ,(docer - `(,(C 'def-decor) ,decor - (,(C 'def-wrap) ,y? ,f ,ab - (,(D 'lam) ,aa - (,(C 'with-return) ,r - ,(mk `(,(G 'let) ,(map (lambda (x) (list x #f)) ls) - (,(C 'with-self) ,c? ,aa - ,cd))))))))) - - `(set! ,f - ,(docer - `(,(C 'def-decor) ,decor - (,(D 'lam) ,aa - (,(C 'with-return) ,r - ,(mk `(,(G 'let) ,(map (lambda (x) (list x #f)) ls) - (,(C 'with-self) ,c? ,aa - ,cd))))))))) - - (if y? - `(set! ,f - ,(docer - `(,(C 'def-decor) ,decor - (,(C 'def-wrap) ,y? ,f ,ab - (,(D 'lam) ,aa - (,(C 'with-return) ,r - (,(G 'let) ,(map (lambda (x) (list x #f)) ls) - (,(C 'with-self) ,c? ,aa - ,(mk cd))))))))) - `(set! ,f - ,(docer - `(,(C 'def-decor) ,decor - (,(D 'lam) ,aa - (,(C 'with-return) ,r - (,(G 'let) ,(map (lambda (x) (list x #f)) ls) - (,(C 'with-self) ,c? ,aa - ,(mk cd))))))))))))) - - (#:global - ((_ . _) - `(,cvalues))) - - (#:starexpr - ((_ _ _ id . _) - `(#:star ,(exp vs id)))) - - (#:list - ((_ x (and e (#:cfor . _))) - (let ((l (gensym "l"))) - `(,(G 'let) ((,l (,(L 'to-pylist) (,(G 'quote) ())))) - ,(gen-sel vs e `(,(L 'pylist-append!) ,l ,(exp vs x))) - ,l))) - - ((_ . l) - (list (L 'to-pylist) (let lp ((l l)) - (match l - ((or () #f) `(,(G 'quote) ())) - (((#:starexpr #:power #f (#:list . l) . _) . _) - (lp l)) - (((#:starexpr #:power #f (#:tuple . l) . _) . _) - (lp l)) - (((#:starexpr . l) . _) - `(,(L 'to-list) ,(exp vs l))) - ((x . l) - `(,(G 'cons) ,(exp vs x) ,(lp l)))))))) - (#:tuple - ((_ x (and e (#:cfor . _))) - (exp vs (list #:comp x e))) - - ((_ . l) - (let lp ((l l)) - (match l - (() `(,(G 'quote) ())) - (((#:starexpr #:power #f (#:list . l) . _) . _) - (lp l)) - (((#:starexpr #:power #f (#:tuple . l) . _) . _) - (lp l)) - (((#:starexpr . l) . _) - `(,(L 'to-list) ,(exp vs l))) - ((x . l) - `(,(G 'cons) ,(exp vs x) ,(lp l))))))) - - (#:lambdef - ((_ (#:var-args-list . v) e) - (let ((as (get-args_ vs v)) - (a= (get-args= vs v)) - (a* (get-args* vs v)) - (** (get-args** vs v))) - (list (C `lam) `(,@as ,@a* ,@a= ,@**) (exp vs e)))) - - ((_ () e) - (list (C `lam) `() (exp vs e)))) - - (#:stmt - ((_ l) - (exp vs l))) - - (#:expr-stmt - ((_ (l ...) (#:assign)) - (let ((l (map (g vs exp) l))) - (if (= (length l) 1) - (car l) - `(,(G 'values) ,@l)))) - - ((_ a (#:assign b c . u)) - (let ((z (gensym "x"))) - `(,(G 'let) ((,z ,(exp vs `(#:expr-stmt1 ,b (#:assign ,c . ,u))))) - ,(exp vs `(#:expr-stmt ,a (#:assign ((#:verb ,z)))))))) - - ((_ l type) - (=> fail) - (call-with-values - (lambda () (match type - ((#:assign u) - (values #f u)) - ((#:augassign op u) - (values op u)) - (_ (fail)))) - - (lambda (op u) - (cond - ((= (length l) (length u)) - (if (= (length l) 1) - `(,(G 'begin) - ,(make-set vs op (car l) (exp vs (car u))) - (,cvalues)) - `(,(G 'begin) - ,@(map (lambda (l u) (make-set vs op l u)) - l - (map (g vs exp) u)) - (,cvalues)))) - - ((and (= (length u) 1) (not op)) - (let ((vars (map (lambda (x) (gensym "v")) l)) - (spec (gensym "special")) - (q (gensym "q")) - (f (gensym "f")) - (a? (is-special? vs l))) - (if a? - `(,(G 'begin) - (call-with-values (lambda () ,(exp vs (car u))) - (,(G 'letrec) ((,f - (case-lambda - ((,q) - (,(G 'if) (pair? ,q) - (,(G 'apply) ,f ,q) - (,(G 'apply) ,f (,(L 'to-list) ,q)))) - (,spec - (,(C 'qset!) ,a? ,spec))))) - ,f)) - (,cvalues)) - - `(,(G 'begin) - (call-with-values (lambda () ,(exp vs (car u))) - (,(G 'letrec) ((,f - (case-lambda - ((,q) - (,(G 'if) (pair? ,q) - (,(G 'apply) ,f ,q) - (,(G 'apply) ,f (,(L 'to-list) ,q)))) - (,vars - ,@(map (lambda (l v) (make-set vs op l v)) - l vars))))) - ,f)) - (,cvalues))))) - - ((and (= (length l) 1) (not op)) - `(,(G 'begin) - ,(make-set vs op (car l) `(,(G 'list) ,@(map (g vs exp) u))) - (,cvalues))))))) - - ((_ - ((#:test (#:power #f (#:identifier v . _) () . #f) #f)) - (#:assign (l))) - (let ((s (string->symbol v))) - `(,s/d ,s ,(exp vs l))))) - - (#:assert - ((_ x f n m) - `(,(G 'if) - (,(G 'not) (,(G 'and) ,@(map (lambda (x) `(,(C 'boolit) ,(exp vs x))) - x))) - (,(C 'raise) ,(C 'AssertionError) (,(G 'quote) ,f) ,n ,m)))) - - - - (#:expr-stmt1 - ((_ a (#:assign b c . u)) - (let ((z (gensym "x"))) - `(,(G 'let) ((,z ,(exp vs `(#:expr-stmt1 ,b - (#:assign ,c . ,u))))) - ,(exp vs `(#:expr-stmt1 ,a (#:assign ((#:verb ,z)))))))) - - ((_ l type) - (=> fail) - (call-with-values - (lambda () (match type - ((#:assign u) - (values #f u)) - ((#:augassign op u) - (values op u)) - (_ (fail)))) - - (lambda (op u) - (cond - ((= (length l) (length u)) - (if (= (length l) 1) - `(,(G 'begin) - ,(make-set vs op (car l) (exp vs (car u))) - ,(exp vs (car l))) - `(,(G 'begin) - ,@(map (lambda (l u) (make-set vs op l u)) - l - (map (g vs exp) u)) - (,cvalues ,@(map (g exp vs) l))))) - - ((and (= (length u) 1) (not op)) - (let ((vars (map (lambda (x) (gensym "v")) l)) - (q (gensym "q")) - (f (gensym "f"))) - `(,(G 'begin) - (call-with-values (lambda () ,(exp vs (car u))) - (,(G 'letrec) ((,f - (case-lambda - ((,q) - (,(G 'if) (pair? ,q) - (,(G 'apply) ,f ,q) - (,(G 'apply) ,f (,(L 'to-list) ,q)))) - (,vars - ,@(map (lambda (l v) (make-set vs op l v)) - l vars))))) - ,f)) - (,cvalues ,@(map (g exp vs) l))))) - - ((and (= (length l) 1) (not op)) - `(,(G 'begin) - ,(make-set vs op (car l) `(,(G 'list) ,@(map (g vs exp) u))) - (,cvalues ,(exp vs (car l)))))))))) - - (#:return - ((_ x) - (if x - `(,(fluid-ref return) ,@(map (g vs exp) x)) - `(,(fluid-ref return))))) - - - (#:dict - ((_ . #f) - `(,(Di 'make-py-hashtable))) - - ((_ (#:e k . v) (and e (#:cfor . _))) - (let ((dict (gensym "dict"))) - `(,(G 'let) ((,dict (,(Di 'make-py-hashtable)))) - ,(gen-sel vs e `(,(L 'pylist-set!) ,dict ,(exp vs k) ,(exp vs v))) - ,dict))) - - ((_ (#:e k . v) ...) - (let ((dict (gensym "dict"))) - `(,(G '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"))) - `(,(G 'let) ((,dict (,(Se 'set)))) - ,(gen-sel vs e `((,(O 'ref) ,dict (,(G 'quote) add)) ,(exp vs k))) - ,dict))) - - ((_ k ...) - (let ((set (gensym "dict"))) - `(,(G 'let) ((,set (,(Se 'set)))) - ,@(map (lambda (k) - `((,(O 'ref) ,set (,(G 'quote) add)) ,(exp vs k))) - k) - ,set)))) - - - (#:comp - ((_ x (and e (#:cfor . _)) . _) - (let ((yield (gensym "yield"))) - `((,(Y 'make-generator) () - (lambda (,yield) - ,(gen-sel vs e `(,yield ,(exp vs x)))))))) - - ((_ x #f) - (exp vs x)) - - ((_ x (op . y)) - (tr-comp op (exp vs x) (exp vs y))) - - ((_ x (op . y) . l) - (let ((m (gensym "op"))) - `(,(G 'let) ((,m ,(exp vs y))) - (,(G 'and) ,(tr-comp op (exp vs x) m) - ,(exp vs `(#:comp (#:verb ,m) . ,l)))))))) - - -(define (exp vs x) - (match x - ((e) - (exp vs e)) - ((tag . l) - ((hash-ref tagis tag - (lambda y (warn (format #f "not tag in tagis ~a" tag)) x)) - x vs)) - - (#:True #t) - (#:None (E 'None)) - (#:null `(,(G 'quote) ())) - (#:False #f) - (#:pass `(,cvalues)) - (#:break - (C 'break)) - (#:continue - (C 'continue)) - (x x))) - -(define (comp x) - (define start - (match x - (((#:stmt - (#:comma - (#:expr-stmt - ((#:test - (#:power #f - (#:identifier "module" . _) - ((#:arglist arglist)) - . #f) #f)) - (#:assign)))) . rest) - - (let () - (define args - (map (lambda (x) - (exp '() x)) - arglist)) - - (define name (string-join (map symbol->string args) ".")) - - `((define-module (language python module ,@args) - #:pure - #:use-module ((guile) #:select - (@ @@ pk let* lambda call-with-values case-lambda - set! = * + - < <= > >= / pair? fluid-set! - fluid-ref - syntax-rules let-syntax abort-to-prompt)) - #:use-module (language python module python) - #:use-module ((language python compile) #:select (pks)) - #:use-module (language python exceptions) - #:use-module ((oop goops) #:select (<complex> <real> <fraction> <integer> <number>))) - (,(G 'define) __doc__ #f) - (,(G 'define) __name__ ,name) - (,(G 'define) __module__ (,(G 'quote) - (language python module ,@args)))))) - (x '()))) - - (fluid-set! ignore '()) - (if (fluid-ref (@@ (system base compile) %in-compile)) - (begin - (if (fluid-ref (@@ (system base compile) %in-compile)) - (set! s/d (C 'qset!)) - (set! s/d (C 'define-))) - - (if (pair? start) - (set! x (cdr x))) - - (let* ((globs (get-globals x)) - (e.doc (with-fluids ((*doc* #f)) - (let ((r (map (g globs exp) x))) - (cons r (get-doc))))) - (e (car e.doc)) - (doc (cdr e.doc))) - - `(begin - ,@start - (,(G 'define) ,fnm (,(G 'make-hash-table))) - ,@(map (lambda (s) - (if (member s (fluid-ref ignore)) - `(,cvalues) - `(,(C 'var) ,s))) - (cons '__doc__ globs)) - (,(G 'set!) __doc__ ,doc) - ,@e - (,(C 'export-all))))) - - (begin - (if (fluid-ref (@@ (system base compile) %in-compile)) - (set! s/d 'set!) - (set! s/d (C 'define-))) - - (if (pair? start) - (set! x (cdr x))) - - (let* ((globs (get-globals x)) - (res (gensym "res")) - (e (map (g globs exp) x))) - `(,(G 'begin) - ,@start - ,@(map (lambda (s) - (if (member s (fluid-ref ignore)) - `(,cvalues) - `(,(C 'var) ,s))) globs) - (,(C 'with-exit) ,@e)))))) - - - - -(define-syntax-parameter break - (lambda (x) #'(values))) - -(define-syntax-parameter continue - (lambda (x) (error "continue must be bound"))) - -(define (is-yield f p x) - (match x - ((#:def nm args _ code) - (is-yield f #t code)) - ((#:yield x _) - (eq? f (exp '() x))) - ((#:yield _) - (not p)) - ((a . l) - (or - (is-yield f p a) - (is-yield f p l))) - (_ - #f))) - - - -(define-syntax with-sp - (lambda (x) - (syntax-case x () - ((_ ((x v)) code ...) - (equal? (syntax->datum #'x) 'break) - #'(syntax-parameterize ((break (lambda (y) #'v))) code ...)) - - ((_ ((x1 v1) (x2 v2)) code ...) - (and (equal? (syntax->datum #'x1) 'break) - (equal? (syntax->datum #'x2) 'continue)) - #'(syntax-parameterize ((break (lambda (y) #'v1)) - (continue (lambda (y) #'v2))) - code ...)) - - ((_ ((x2 v2) (x1 v1)) code ...) - (and (equal? (syntax->datum #'x1) 'break) - (equal? (syntax->datum #'x2) 'continue)) - #'(syntax-parameterize ((break (lambda (y) #'v1)) - (continue (lambda (y) #'v2))) - code ...))))) - - -(define (is-ec ret x tail tags) - (match x - ((('@ ('guile) 'cond) (p a ... b) ...) - (or - (or-map (lambda (x) (or-map (lambda (x) (is-ec ret x #f tags)) x)) - a) - (or-map (lambda (x) (is-ec ret x tail tags)) - b))) - - (((_ _ 'with-self) u v a ... b) - (or - (or-map (lambda (x) (is-ec ret x #f tags)) a) - (is-ec ret b tail tags))) - - (('let-syntax v a ... b) - (or - (or-map (lambda (x) (is-ec ret x #f tags)) a) - (is-ec ret b tail tags))) - - ((('@ ('guile) 'begin) a ... b) - (or - (or-map (lambda (x) (is-ec ret x #f tags)) a) - (is-ec ret b tail tags))) - - ((('@ ('guile) 'let) lp ((y x) ...) a ... b) (=> next) - (if (symbol? lp) - (or - (or-map (lambda (x) (is-ec ret x #f tags)) x) - (or-map (lambda (x) (is-ec ret x #f tags)) a) - (is-ec ret b tail tags)) - (next))) - - ((('@ ('guile) 'let) ((y x) ...) a ... b) - (or - (or-map (lambda (x) (is-ec ret x #f tags)) x) - (or-map (lambda (x) (is-ec ret x #f tags)) a) - (is-ec ret b tail tags))) - - (('let* ((y x) ...) a ... b) - (or - (or-map (lambda (x) (is-ec ret x #f tags)) x) - (or-map (lambda (x) (is-ec ret x #f tags)) a) - (is-ec ret b tail tags))) - - ((('@ ('guile) 'define) . _) - #f) - - ((('@ ('guile) 'if) p a b) - (or - (is-ec ret p #f tags) - (is-ec ret a tail tags) - (is-ec ret b tail tags))) - - ((('@ ('guile) 'if) p a) - (or - (is-ec ret #'p #f tags) - (is-ec ret #'a tail tags))) - - (('@@ _ _) - (if (member x tags) - #t - #f)) - - - ((a ...) - (or-map (lambda (x) (is-ec ret x #f tags)) a)) - - (x #f))) - -(define-syntax with-return - (lambda (x) - (define (analyze ret x) - (syntax-case x (let-syntax let* @ @@) - ((cond- (p a ... b) ...) - (equal? (syntax->datum #'cond-) - '(@ (guile) cond)) - (with-syntax (((bb ...) (map (lambda (x) (analyze ret x)) #'(b ...)))) - #'(cond (p a ... bb) ...))) - - (((_ _ with-self-) u v a ... b) - (equal? (syntax->datum #'with-self-) - 'with-self) - #`(with-self u v a ... #,(analyze ret #'b))) - - ((let-syntax v a ... b) - #`(let-syntax v a ... #,(analyze ret #'b))) - - (((@ (guile) begin-) a ... b) - (equal? (syntax->datum #'begin-) - 'begin) - #`(begin a ... #,(analyze ret #'b))) - - (((@ (guile) let-) lp v a ... b) - (and - (equal? (syntax->datum #'let-) - 'let) - (symbol? (syntax->datum #'lp))) - #`(let lp v a ... #,(analyze ret #'b))) - - (((@ (guile) let-) v a ... b) - (equal? (syntax->datum #'let-) - 'let) - #`(let v a ... #,(analyze ret #'b))) - - (((@ (guile) if-) p a b) - (equal? (syntax->datum #'if-) - 'if) - #`(if p #,(analyze ret #'a) #,(analyze ret #'b))) - - (((@ (guile) if-) p a) - (equal? (syntax->datum #'if-) - 'if) - #`(if p #,(analyze ret #'a))) - - ((return a b ...) - (equal? (syntax->datum #'return) (syntax->datum ret)) - (if (eq? #'(b ...) '()) - #'a - #`(values a b ...))) - - ((return) - (equal? (syntax->datum #'return) (syntax->datum ret)) - #`(values)) - - (x #'x))) - - (define (is-ec ret x tail) - (syntax-case x (let-syntax let* @@ @) - (((@ (guile) cond) (p a ... b) ...) - (equal? (syntax->datum #'cond) - 'cond) - (or - (or-map (lambda (x) (is-ec ret x #f)) - #'(a ... ...)) - (or-map (lambda (x) (is-ec ret x tail)) - #'(b ...)))) - - (((_ _ with-self) u v a ... b) - (equal? (syntax->datum #'with-self) - 'with-self) - (or - (or-map (lambda (x) (is-ec ret x #f)) #'(a ...)) - (is-ec ret #'b tail))) - - ((let-syntax v a ... b) - #t - (or - (or-map (lambda (x) (is-ec ret x #f)) #'(a ...)) - (is-ec ret #'b tail))) - - (((@ (guile) begin) a ... b) - (equal? (syntax->datum #'begin) - 'begin) - (or - (or-map (lambda (x) (is-ec ret x #f)) #'(a ...)) - (is-ec ret #'b tail))) - - (((@ (guile) let) lp ((y x) ...) a ... b) - (and - (equal? (syntax->datum #'let) - 'let) - (symbol? (syntax->datum #'lp))) - - (or - (or-map (lambda (x) (is-ec ret x #f)) #'(x ...)) - (or-map (lambda (x) (is-ec ret x #f)) #'(a ...)) - (is-ec ret #'b tail))) - - (((@ (guile) let) ((y x) ...) a ... b) - (equal? (syntax->datum #'let) - 'let) - (or - (or-map (lambda (x) (is-ec ret x #f)) #'(x ...)) - (or-map (lambda (x) (is-ec ret x #f)) #'(a ...)) - (is-ec ret #'b tail))) - - ((let* ((y x) ...) a ... b) - #t - (or - (or-map (lambda (x) (is-ec ret x #f)) #'(x ...)) - (or-map (lambda (x) (is-ec ret x #f)) #'(a ...)) - (is-ec ret #'b tail))) - - (((@ (guile) define) . _) - (equal? (syntax->datum #'define) - 'define) - #f) - - (((@ (guile) if) p a b) - (equal? (syntax->datum #'if) - 'if) - (or - (is-ec ret #'p #f) - (is-ec ret #'a tail) - (is-ec ret #'b tail))) - - (((@ (guile) if) p a) - (equal? (syntax->datum #'if) - 'if) - (or - (is-ec ret #'p #f) - (is-ec ret #'a tail))) - - ((return b ...) - (equal? (syntax->datum #'return) (syntax->datum ret)) - (not tail)) - - ((a ...) - #t - (or-map (lambda (x) (is-ec ret x #f)) #'(a ...))) - - (x - #t - #f))) - - (syntax-case x () - ((_ ret l) - (let ((code (analyze #'ret #'l))) - (if (is-ec #'ret #'l #t) - #`(let/ec ret l) - code)))))) - -(define void (list 'void)) - -(define-syntax var - (lambda (x) - (syntax-case x (cons quote) - ((_ '()) - #'(values)) - ((_ (cons x v)) - #'(begin (var x) (var v))) - ((_ v) - (begin - (dont-warn (syntax->datum #'v)) - #'(if (module-defined? (current-module) 'v) - (values) - (define! 'v void))))))) - -(define-inlinable (non? x) (eq? x #:nil)) - -(define (gentemp stx) (datum->syntax stx (gensym "x"))) - -(define-syntax mmatch - (syntax-rules () - ((_ (a . aa) (b . bb) . code) - (match a (b (mmatch aa bb . code)))) - ((_ () () . code) - (begin . code)))) - -(define (mutewarn x y) (list x y)) - -(define-syntax clambda - (lambda (x) - (syntax-case x () - ((_ (x ...) code ...) - (with-syntax ((n (length #'(x ...))) - ((y ...) (generate-temporaries #'(x ...)))) - #'(let ((f (lambda (y ... . u) - (mmatch (y ...) (x ...) code ...)))) - (if (> n 1) - (case-lambda - ((c) - (if (pair? c) - (let ((cc (cdr c))) - (if (pair? cc) - (apply f c) - (apply f (mutewarn c cc)))) - (py-apply f (* c)))) - (q (apply f q))) - f))))))) - -(define (gen-temp x) - (syntax-case x () - ((x ...) (map gen-temp #'(x ...))) - (x (car (generate-temporaries (list #'x)))))) - -(define (replace_ stx l) - (let lp ((l l)) - (syntax-case l () - ((a . l) (cons (lp #'a) (lp #'l))) - (x - (if (equal? (syntax->datum #'x) '_) - (datum->syntax stx (gensym "_")) - #'x))))) - -(define-syntax with-syntax* - (syntax-rules () - ((_ () code) code) - ((_ () . code) (begin . code)) - ((_ (x . l) . code) - (with-syntax (x) (with-syntax* l . code))))) - -(define-syntax cfor - (lambda (xx) - (syntax-case xx () - ((_ (x ...) in code next p) - (or-map pair? #'(x ...)) - #'(for-adv (x ...) in code next p)) - - ((_ (x) (a) code #f #f) - (with-syntax ((x (replace_ xx #'x))) - #'(if (pair? a) - (let/ec break-ret - (let lp ((l a)) - (if (pair? l) - (begin - (set! x (car l)) - (with-sp ((continue (values)) - (break (break-ret))) - code) - (lp (cdr l)))))) - (for/adv1 (x) (a) code #f #f)))) - - ((_ (x) (a) code #f #t) - (with-syntax ((x (replace_ xx #'x))) - #'(if (pair? a) - (let/ec break-ret - (let lp ((l a)) - (if (pair? l) - (begin - (let/ec continue-ret - (set! x (car l)) - (with-sp ((continue (continue-ret)) - (break (break-ret))) - code)) - (lp (cdr l)))))) - (for/adv1 (x) (a) code #f #t)))) - - ((_ (x) (a) code next #f) - (with-syntax ((x (replace_ xx #'x))) - #'(if (pair? a) - (let/ec break-ret - (let lp ((l a)) - (if (pair? l) - (begin - (set! x (car l)) - (with-sp ((continue (values)) - (break (break-ret))) - code)) - (lp (cdr l)))) - next) - (for/adv1 (x) (a) code next #f)))) - - ((_ (x) (a) code next #t) - (with-syntax ((x (replace_ xx #'x))) - #'(if (pair? a) - (let/ec break-ret - (let lp ((l a)) - (if (pair? l) - (let/ec continue-ret - (set! x (car l)) - (with-sp ((continue (continue-ret)) - (break (break-ret))) - code)) - (lp (cdr l)))) - next) - (for/adv1 (x) (a) code next #f)))) - - ((_ x a code next p) - #'(for/adv1 x a code next p))))) - -(define-syntax for/adv1 - (lambda (zz) - (syntax-case zz () - ((_ (xy ...) (in) code #f #f) - (with-syntax* ((inv (gentemp #'in)) - ((yy ...) (replace_ zz #'(xy ...))) - ((xx ...) (gen-temp #'(yy ...)))) - #'(let ((inv (wrap-in in))) - (clet (yy ...) - (catch StopIteration - (lambda () - (let lp () - (call-with-values (lambda () (next inv)) - (clambda (xx ...) - (cset! yy xx) ... - (with-sp ((break (values)) - (continue (values))) - code - (lp)))))) - (lambda z (values))))))) - - ((_ (xy ...) (in ...) code #f #f) - (with-syntax* (((inv ...) (generate-temporaries #'(in ...))) - ((yy ...) (replace_ zz #'(xy ...))) - ((xx ...) (gen-temp #'(yy ...)))) - #'(let ((inv (wrap-in in)) ...) - (clet (yy ...) - (catch StopIteration - (lambda () - (let lp () - (call-with-values (lambda () (values (next inv) ...)) - (clambda (xx ...) - (cset! yy xx) ... - (with-sp ((break (values)) - (continue (values))) - code - (lp)))))) - (lambda z (values))))))) - - ((_ (xy ...) (in) code #f #t) - (with-syntax* ((inv (gentemp #'in)) - ((yy ...) (replace_ zz #'(xy ...))) - ((xx ...) (gen-temp #'(yy ...)))) - #'(let ((inv (wrap-in in))) - (clet (yy ...) - (let lp () - (let/ec break-ret - (catch StopIteration - (lambda () - (call-with-values (lambda () (next inv)) - (clambda (xx ...) - (cset! yy xx) ... - (let/ec continue-ret - (with-sp ((break (break-ret)) - (continue (continue-ret))) - code)) - (lp)))) - (lambda z (values))))))))) - - ((_ (xy ...) (in ...) code #f #t) - (with-syntax* (((inv ...) (generate-temporaries #'(in ...))) - ((yy ...) (replace_ zz #'(xy ...))) - ((xx ...) (gen-temp #'(yy ...)))) - #'(let ((inv (wrap-in in)) ...) - (clet (yy ...) - (let lp () - (let/ec break-ret - (catch StopIteration - (lambda () - (call-with-values (lambda () (values (next inv) ...)) - (clambda (xx ...) - (cset! yy xx) ... - (let/ec continue-ret - (with-sp ((break (break-ret)) - (continue (continue-ret))) - code)) - (lp)))) - (lambda z (values))))))))) - - ((_ (x ...) in code else #f) - #'(for-adv (x ...) in code else #f)) - - ((_ (x ...) in code else #t) - #'(for-adv (x ...) in code else #t))))) - - -(define-syntax for-adv - (lambda (zz) - (define (gen x y) - (if (= (length (syntax->datum x)) (= (length (syntax->datum y)))) - (syntax-case x () - ((x ...) #'(values (next x) ...))) - (syntax-case x () - ((x) #'(next x))))) - - (syntax-case zz () - ((_ (xy ...) (in) code else p) - (with-syntax* ((inv (gentemp #'in)) - ((yy ...) (replace_ zz #'(xy ...))) - ((xx ...) (gen-temp #'(yy ...)))) - - (if (syntax->datum #'p) - #'(let ((inv (wrap-in in))) - (clet (yy ...) - (let/ec break-ret - (catch StopIteration - (lambda () - (let lp () - (call-with-values (lambda () (next inv)) - (clambda (xx ...) - (cset! yy xx) ... - (let/ec continue-ret - (with-sp ((break (break-ret)) - (continue (continue-ret))) - code)) - (lp))))) - (lambda q else))))) - - #'(let ((inv (wrap-in in))) - (clet (yy ...) - (let/ec break-ret - (catch StopIteration - (lambda () - (let lp () - (call-with-values (lambda () (next inv)) - (clambda (xx ...) - (cset! yy xx) ... - (with-sp ((break (break-ret)) - (continue (values))) - code) - (lp))))) - (lambda e else)))))))) - - ((_ (xy ...) (in ...) code else p) - (with-syntax* (((inv ...) (generate-temporaries #'(in ...))) - ((yy ...) (replace_ zz #'(xy ...))) - (get (gen #'(inv ...) #'(yy ...))) - ((xx ...) (gen-temp #'(yy ...)))) - (if (syntax->datum #'p) - #'(clet (yy ...) - (let ((inv (wrap-in in)) ...) - (let/ec break-ret - (catch StopIteration - (lambda () - (let lp () - (call-with-values (lambda () get) - (clambda (xx ...) - (cset! yy xx) ... - (let/ec continue-ret - (with-sp ((break (break-ret)) - (continue (continue-ret))) - code)) - (lp))))) - (lambda q else))))) - - #'(clet (yy ...) - (let ((inv (wrap-in in)) ...) - (let/ec break-ret - (catch StopIteration - (lambda () - (let lp () - (call-with-values (lambda () get) - (clambda (xx ...) - (cset! yy xx) ... - (with-sp ((break (break-ret)) - (continue (values))) - code) - (lp))))) - (lambda e else))))))))))) - -(define-syntax cset! - (syntax-rules () - ((_ (a . aa) (b . bb)) - (begin - (cset! a b) - (cset! aa bb))) - ((_ () ()) - (values)) - ((_ a b) - (set! a b)))) - -(define-syntax clet - (syntax-rules () - ((_ ((a . l) . u) . code) - (clet (a l . u) . code)) - ((_ (() . u) . code) - (clet u . code)) - ((_ (a . u) . code) - (let ((a #f)) - (clet u . code))) - ((_ () . code) - (begin . code)))) - -(define-syntax def-wrap - (lambda (x) - (syntax-case x () - ((_ #f f ab x) - #'x) - - ((_ #t f ab code) - #'(lambda x - (define obj (make <yield>)) - (define ab (make-prompt-tag)) - (slot-set! obj 'k #f) - (slot-set! obj 'closed #f) - (slot-set! obj 's - (lambda () - (call-with-prompt - ab - (lambda () - (let/ec return - (apply code x)) - (slot-set! obj 'closed #t) - (throw StopIteration)) - (letrec ((lam - (lambda (k . l) - (fluid-set! in-yield #f) - (slot-set! obj 'k - (lambda (a) - (call-with-prompt - ab - (lambda () - (k a)) - lam))) - (apply values l)))) - lam)))) - obj))))) - -(define miss (list 'miss)) -(define-inlinable (wr o k x) - (if (eq? x miss) - (raise (AttributeError (cons o k))) - x)) - -(define-syntax ref-x - (lambda (x) - (syntax-case x (@) - ((_ v) - #'v) - ((_ v (#:fastfkn-ref f tag) . l) - #'(let ((vv v)) - (if (is-a? vv <p>) - (ref-x v (#:identifier tag) . l) - (ref-x (lambda x - (if (pyclass? v) - (apply f x) - (apply f v x))) . l)))) - ((_ v (#:fast-id f _) . l) - #'(ref-x (f v) . l)) - - ((_ v (#:identifier ((@ x q) dict)) . l) - (equal? (syntax->datum #'dict) '__dict__) - #'(ref-x (py-dict v) . l)) - - ((_ v (#:identifier x) . l) - #'(ref-x (wr v x (ref v x miss)) . l)) - - ((_ v (#:call-obj x) . l) - #'(ref-x (x v) . l)) - - ((_ v (#:call x ...) . l) - #'(ref-x (v x ...) . l)) - - ((_ v (#:apply x ...) . l) - #'(ref-x (py-apply v x ...) . l)) - - ((_ v (#:apply x ...) . l) - #'(ref-x (py-apply v x ...) . l)) - - ((_ v (#:vecref x) . l) - #'(ref-x (pylist-ref v x) . l)) - - ((_ v (#:vecsub . x) . l) - #'(ref-x (pylist-slice v . x) . l))))) - -(define-syntax del-x - (syntax-rules () - ((_ v (#:identifier x)) - (ref-x (wr v x (ref v x)))) - ((_ v (#:call-obj x)) - (values)) - ((_ v (#:call x ...)) - (values)) - ((_ v (#:apply x ...)) - (values)) - ((_ v (#:vecref x)) - (pylist-delete! v x)) - ((_ v (#:vecsub x ...)) - (pylist-subset! v x ... pylist-null)))) - -(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) - ((@ (oop pf-objects) fset-x) v (list x ...) val)))) - -(define-syntax set-x-2 - (syntax-rules () - ((_ v (#:fastfkn-ref f id) val) - (set v id val)) - ((_ v (#:fastid-ref f id) val) - (set v id val)) - ((_ v (#:identifier x) val) - (set v x val)) - ((_ v (#:vecref n) val) - (pylist-set! v n val)) - ((_ v (#:array-ref n ...) val) - (pylist-set! v (list n ...) val)) - ((_ v (#:vecsub x ...) val) - (pylist-subset! v x ... val)))) - - -(define-syntax class-decor - (syntax-rules () - ((_ () x) x) - ((_ (f ... r) y) - (class-decor (f ...) (r y))))) - -(define-syntax def-decor - (syntax-rules () - ((_ () x) x) - ((_ (f ... r) y) - (def-decor (f ...) (r y))))) - -(define-syntax with-self - (syntax-rules () - ((_ #f _ c) - c) - ((_ _ (s . b) c) - (syntax-parameterize ((*self* (lambda (x) #'s))) c)))) - -(define-syntax with-class - (syntax-rules () - ((_ s c) - (syntax-parameterize ((*class* (lambda (x) #'s))) c)))) - - -(define-syntax boolit - (syntax-rules (@ and eq? equal? or not < <= > >=) - ((_ (and x y)) (and (boolit x) (boolit y))) - ((_ (or x y)) (or (boolit x) (boolit y))) - ((_ (not x )) (not (boolit x))) - ((_ (< x y)) (< x y)) - ((_ (<= x y)) (<= x y)) - ((_ (> x y)) (> x y)) - ((_ (>= x y)) (>= x y)) - ((_ (eq? x y)) (eq? x y)) - ((_ (equal? x y)) (equal? x y)) - - ((_ ((@ (guile) eq? ) x y)) (eq? x y)) - ((_ ((@ (guile) equal?) x y)) (equal? x y)) - ((_ ((@ (guile) and ) x y)) (and (boolit x) (boolit y))) - ((_ ((@ (guile) or ) x y)) (or (boolit x) (boolit y))) - ((_ ((@ (guile) not ) x )) (not (boolit x))) - ((_ ((@ (guile) < ) x y)) (< x y)) - ((_ ((@ (guile) <= ) x y)) (<= x y)) - ((_ ((@ (guile) > ) x y)) (> x y)) - ((_ ((@ (guile) >= ) x y)) (>= x y)) - ((_ #t) #t) - ((_ #f) #f) - ((_ x ) (bool x)))) - -(define (export-all) - (define mod (current-module)) - (if (module-defined? mod '__all__) - (begin - (module-export! mod - (for ((x : (module-ref mod '__all__))) ((l '())) - (let ((x (string->symbol (scm-str x)))) - (if (module-locally-bound? mod x) - (cons x l) - l)) - #:final l)) - (module-re-export! mod - (for ((x : (module-ref mod '__all__))) ((l '())) - (let ((x (string->symbol (scm-str x)))) - (if (not (module-locally-bound? mod x)) - (cons x l) - l)) - #:final l))))) - -(define (pkkk x) - (pk (syntax->datum x)) - x) - -(define (get-q-n x) - (syntax-case x () - ((cons a b) - (+ 1 (get-q-n #'b))) - ((q ()) - 0))) - -(define (take-n n v) - (let lp ((i 0) (v (reverse v)) (r '())) - (if (< i n) - (if (pair? v) - (lp (+ i 1) (cdr v) (cons (car v) r)) - (raise (ValueError "wrone number of values in values"))) - (cons - (reverse v) - r)))) - -(define-syntax qset! - (lambda (x) - (syntax-case x (@@ @) - ((_ (cons (#:star x) y) v) - (let ((n (get-q-n #'y))) - #`(let* ((h.r (take-n #,n v)) - (h (car h.r)) - (r (cdr h.r))) - (qset! x h) - (qset0! y r)))) - - ((_ (cons x y) v) - (equal? (syntax->datum #'cons) '(@ (guile) cons)) - #'(let ((w (to-list v))) - (qset! x (car w)) - (qset0! y (cdr w)))) - - ((_ ((@ (guile) q) ()) v) - (equal? (syntax->datum #'q) 'quote) - #'(if (not (null? v)) - (raise (ValueError "too many values to unpack")) - (values))) - - ((_ ((@@ u li) x) v) - (equal? (syntax->datum #'li) 'to-pylist) - #'(let ((w (to-list v))) - (qset! x w))) - - ((_ (ref v a ...) w) - #'(set-x v (a ...) w)) - - ((_ x v) - #'(set! x v))))) - -(define-syntax qset0! - (lambda (x) - (syntax-case x (@@ @) - ((_ (cons (#:star x) y) v) - (let ((n (get-q-n #'y))) - #`(let* ((h.r (take-n v #,n)) - (h (car h.r)) - (r (cdr h.r))) - (qset! x h) - (qset0! y r)))) - - ((_ (cons x y) v) - (equal? (syntax->datum #'cons) '(@ (guile) cons)) - #'(let ((w v)) - (qset! x (car w)) - (qset0! y (cdr w)))) - - ((_ ((@ (guile) q) ()) v) - (equal? (syntax->datum #'q) 'quote) - #'(if (not (null? v)) - (raise (ValueError "too many values to unpack")) - (values))) - - ((_ ((@@ u li) x) v) - (equal? (syntax->datum #'li) 'to-pylist) - #'(let ((w (to-list v))) - (qset! x w))) - - ((_ (ref v a ...) w) - #'(set-x v (a ...) w)) - - ((_ x v) - #'(set! x v))))) - -(define-syntax define- - (syntax-rules (cons quote) - ((_ (cons x y) v) - (let ((w v)) - (define- x (car w)) - (define- y (cdr w)))) - ((_ '() v) (values)) - ((_ x v) - (define! 'x v)))) - -(define-syntax pks - (lambda (x) - (pk (syntax->datum x)) - #f)) diff --git a/modules/language/python/completer.scm b/modules/language/python/completer.scm deleted file mode 100644 index 73f96bd..0000000 --- a/modules/language/python/completer.scm +++ /dev/null @@ -1,48 +0,0 @@ -(define-module (language python completer) - #:use-module (language python list) - #:use-module (language python dir) - #:use-module (system base language) - #:use-module (ice-9 regex) - #:export (complete-fkn)) - -(define-syntax-rule (aif it p x y) (let ((it p)) (if it x y))) - -(define (old) (@@ (ice-9 readline) *readline-completion-function*)) - -(define reg "(\\w+(\\.\\w+)*)\\.(\\w*)$") - -(define (complete-fkn eval) - (let ((old (old)) - (strs '() ) - (pp "" ) - (regexp #f )) - (letrec - ((compl - (lambda (text continue?) - (if continue? - (if (null? strs) - #f - (let ((str (car strs))) - (set! strs (cdr strs)) - (if (string-match regexp str) - (string-append pp "." str) - (compl text #t)))) - (if (and (equal? (language-name (current-language)) 'python) - (in "." text)) - (aif it (string-match reg text) - (let* ((n (match:count it)) - (p (match:substring it 1)) - (t (match:substring it (- n 1))) - (d (to-list (dir (eval p))))) - (begin - (set! strs d) - (set! pp p) - (set! regexp (string-append - "^" (if (equal? t "") - "[^_]" - (regexp-quote t)))) - (compl text #t))) - #f) - (old text continue?)))))) - compl))) - diff --git a/modules/language/python/def.scm b/modules/language/python/def.scm deleted file mode 100644 index 569023c..0000000 --- a/modules/language/python/def.scm +++ /dev/null @@ -1,168 +0,0 @@ -(define-module (language python def) - #:use-module (oop pf-objects) - #:use-module (language python for) - #:use-module (language python list) - #:use-module (language python exceptions) - #:use-module (ice-9 match) - #:use-module (srfi srfi-11) - #:export (def lam py-apply)) - -(define e (list 'error)) -(define-syntax-rule (aif it p x y) (let ((it p)) (if (not (eq? it e)) x y))) -(define (fold lam s l) - (if (pair? l) - (lam (car l) (fold lam s (cdr l))) - s)) - -(define-syntax-rule (take-1 pww ww* kw s v) - (if (not pww) - (values ww* - (aif it (hash-ref kw s e) - (begin - (hash-remove! kw s) - it) - v)) - (if (pair? ww*) - (begin - (hash-remove! kw s) - (values (cdr ww*) (car ww*))) - (values ww* - (aif it (hash-ref kw s e) - (begin - (hash-remove! kw s) - it) - v))))) - - -(define (get-akw l) - (let lp ((l l) (args '()) (kw (make-hash-table))) - (match l - (((? keyword? k) v . l) - (hash-set! kw k v) - (lp l args kw)) - ((x . l) - (lp l (cons x args) kw)) - (() - (values (reverse args) kw))))) - -(define hset! hash-set!) - -(define (pytonize kw) - (hash-fold - (lambda (k v h) - (hset! h (symbol->string (keyword->symbol k)) v) - h) - (make-hash-table) - kw)) - -(define-syntax lam - (lambda (x) - (define-syntax-rule (mk get-as (k v s) x y z w) - (define get-as - (lambda (a s) - (syntax-case a (= * **) - ((= k v) x) - ((** k) y) - ((* k) z) - (k w))))) - - (mk get-as (k v s) - s s s (cons #'k s)) - (mk get-kw (k v s) - s (cons #'k s) s s ) - (mk get-ww (k v s) - s s (cons #'k s) s ) - (mk get-kv (k v s) - (cons (cons #'k #'v) s) s s s ) - - (define (->kw x) (symbol->keyword (syntax->datum x))) - - (syntax-case x (*) - ((_ (arg ...) code ...) - (let* ((as (fold get-as '() #'(arg ...))) - (kw (fold get-kw '() #'(arg ...))) - (ww- (fold get-ww '() #'(arg ...))) - (kv (fold get-kv '() #'(arg ...)))) - (if (and-map null? (list kw ww- kv)) - #`(object-method - (lambda (#,@as . u12345678) - (if (and (pair? u12345678) - (not (keyword? (car u12345678)))) - (raise (ArgumentError "too many arguments to function"))) - (let () code ...))) - (with-syntax ((kw (if (null? kw) - (datum->syntax x (gensym "kw")) - (car kw))) - (ww (if (null? ww-) - (datum->syntax x (gensym "ww")) - (car ww-))) - ((k ...) (map car kv)) - ((s ...) (map ->kw (map car kv))) - ((v ...) (map cdr kv))) - #`(object-method - (lambda* (#,@as . l) - (call-with-values (lambda () (get-akw l)) - (lambda (ww* kw) - (let*-values (((ww* k) (take-1 #,(null? ww-) ww* kw s v)) - ...) - (let ((ww ww*) - (kw (pytonize kw))) - (let () code ...)))))))))))))) - -(define-syntax-rule (def (f . args) code ...) (define f (lam args code ...))) - - -(define (no x) - (and-map - (lambda (x) - (syntax-case x (* ** =) - ((* _) #f) - ((** _) #f) - ((= a b) #f) - (_ #t))) - x)) - -(define (mk-k x) - (if (keyword? x) - x - (symbol->keyword - (if (string? x) - (string->symbol x) - x)))) - -(define-syntax m* - (syntax-rules (* ** =) - ((_ (= a b)) - (list (symbol->keyword 'a) b)) - ((_ (* a)) a) - ((_ (** kw)) - (for ((k v : kw)) ((l '())) - (cons* v (mk-k k) l) - #:final (reverse l))) - ((_ a) (list a)))) - -(define-syntax py-apply - (lambda (x) - (syntax-case x () - ((_ f a ... (op x)) - (and (syntax-case #'op (*) - (* #t) - (_ #f)) - (and-map (lambda (q) - (syntax-case q (* ** =) - ((= _ _) #f) - ((* _ ) #f) - ((** _ ) #f) - (_ #t))) #'(a ...))) - #'(if (or (null? x) (pair? x)) - (apply f a ... x) - (apply f a ... (to-list x)))) - - ((_ f a ...) - (if (no #'(a ...)) - #'(f a ...) - #'(apply f (let lp ((l (list (m* a) ...))) - (if (pair? l) - (append (to-list (car l)) (lp (cdr l))) - '())))))))) - diff --git a/modules/language/python/dict.scm b/modules/language/python/dict.scm deleted file mode 100644 index 9eb698d..0000000 --- a/modules/language/python/dict.scm +++ /dev/null @@ -1,795 +0,0 @@ -(define-module (language python dict) - #:use-module (language python list) - #:use-module (language python try) - #:use-module (language python hash) - #:use-module (language python yield) - #:use-module (language python def) - #:use-module (language python for) - #:use-module (language python bool) - #:use-module (language python exceptions) - #:use-module (language python persist) - #:use-module (ice-9 match) - #:use-module (ice-9 control) - #:use-module (oop goops) - #:use-module (oop pf-objects) - #:re-export (py-get) - #:export (make-py-hashtable <py-hashtable> - py-copy py-fromkeys py-has_key py-items py-iteritems - py-iterkeys py-itervalues py-keys py-values - py-popitem py-setdefault py-update py-clear - py-hash-ref dict pyhash-listing - weak-key-dict weak-value-dict - py-hash-ref py-hash-set! dictNs dictRNs - make-py-weak-key-hashtable - make-py-weak-value-hashtable - )) - -(define-syntax-rule (aif it p x y) (let ((it p)) (if it x y))) - -(define (h x n) (modulo (py-hash x) n)) -(define (py-assoc k l) - (if (pair? l) - (if (equal? (caar l) k) - (car l) - (py-assoc k (cdr l))) - #f)) - -(define (py-hash-ref . l) - (apply hashx-ref h py-assoc l)) -(define (py-hash-set! . l) - (apply hashx-set! h py-assoc l)) -(define (py-hash-remove! . l) - (apply hashx-remove! h py-assoc l)) - -(set! (@@ (language python def) hset!) py-hash-set!) - -(define H (hash 1333674836 complexity)) - -(define-class <py-hashtable> () t hash n) - -(name-object <py-hashtable>) - -(cpit <py-hashtable> - (o (lambda (o h n a) - (slot-set! o 'hash h) - (slot-set! o 'n n) - (slot-set! o 't - (let ((t (make-hash-table))) - (let lp ((a a)) - (if (pair? a) - (begin - (py-hash-set! t (caar a) (cdar a)) - (lp (cdr a))))) - t))) - (let ((t (slot-ref o 't))) - (list - (slot-ref o 'hash) - (slot-ref o 'n) - (hash-fold (lambda (k v s) (cons (cons k v) s)) '() t))))) - -(define (make-py-hashtable) - (let* ((o (make <py-hashtable>)) - (t (make-hash-table)) - (h H)) - (slot-set! o 't t) - (slot-set! o 'hash h) - (slot-set! o 'n 0) - o)) - -(define (make-py-weak-key-hashtable) - (let* ((o (make <py-hashtable>)) - (t (make-weak-key-hash-table)) - (h H)) - (slot-set! o 't t) - (slot-set! o 'hash h) - (slot-set! o 'n 0) - o)) - -(define (make-py-weak-value-hashtable) - (let* ((o (make <py-hashtable>)) - (t (make-weak-value-hash-table)) - (h H)) - (slot-set! o 't t) - (slot-set! o 'hash h) - (slot-set! o 'n 0) - o)) - -(define miss (list 'miss)) -(define-method (pylist-ref (o <hashtable>) x) - (let ((r (py-hash-ref o x miss))) - (if (eq? r miss) - (raise KeyError x) - r))) - -(define-method (pylist-ref (o <py-hashtable>) x) - (let ((r (py-hash-ref (slot-ref o 't) x miss))) - (if (eq? r miss) - (aif it (ref o '__missing__) - (it x) - (raise KeyError x)) - r))) - -(define-method (pylist-delete! (o <hashtable>) k) - (pyhash-rem! o k)) - -(define-method (pylist-delete! (o <py-hashtable>) k) - (pyhash-rem! o k)) - -(define-method (py-hash (o <hashtable>)) - (hash-fold - (lambda (k v s) - (logxor - (xy (py-hash k) (py-hash v)) - s)) - 0 o)) - -(define-method (py-hash (o <py-hashtable>)) - (slot-ref o 'hash)) - -(define-method (len (o <hashtable>)) - (hash-fold (lambda (k v s) (+ s 1)) 0 o)) - -(define-method (len (o <py-hashtable>)) - (slot-ref o 'n)) - -(define-method (pylist-pop! (o <hashtable>) k . l) - (match l - ((v) - (let ((ret (py-hash-ref o k v))) - (py-hash-remove! o k) - ret)) - (() - (let ((ret (hash-ref o k miss))) - (if (eq? ret miss) - (raise KeyError k) - (begin - (hash-remove! o k) - ret)))))) - -(define-method (pyhash-rem! (o <hashtable>) k) - (py-hash-remove! o k) - (values)) - -(define-method (pyhash-rem! (o <py-hashtable>) k) - (let ((t (slot-ref o 't)) - (n (slot-ref o 'n)) - (h (slot-ref o 'hash))) - (let ((ret (py-hash-ref t k miss))) - (if (eq? ret miss) - (values) - (begin - (py-hash-remove! t k) - (slot-set! o 'n (- n 1)) - (slot-set! o 'hash (logxor h (xy (py-hash k) (py-hash ret)))) - (values)))))) - -(define-method (pylist-pop! (o <py-hashtable>) k . l) - (let ((t (slot-ref o 't))) - (match l - ((v) - (let ((ret (py-hash-ref t k miss))) - (if (eq? ret miss) - v - (begin - (pyhash-rem! o k) - ret)))) - (() - (let ((ret (hash-ref o k miss))) - (if (eq? ret miss) - (raise KeyError k) - (begin - (pyhash-rem! o k) - ret))))))) - -(define-method (pylist-set! (o <hashtable>) key val) - (py-hash-set! o key val) - (values)) - -(define-method (pylist-set! (o <py-hashtable>) key val) - (let ((t (slot-ref o 't)) - (n (slot-ref o 'n)) - (h (slot-ref o 'hash))) - (let ((ret (py-hash-ref t key miss))) - (if (eq? ret miss) - (begin - (py-hash-set! t key val) - (slot-set! o 'n (+ n 1)) - (slot-set! o 'hash (logxor (xy (py-hash key) (py-hash val)) h))) - (begin - (py-hash-set! t key val) - (slot-set! o 'hash - (logxor (xy (py-hash key) (py-hash val)) - (logxor - (xy (py-hash key) (py-hash ret)) - h))))))) - (values)) - -(define-syntax define-py - (syntax-rules () - ((_ (nm n o l ...) (class code ...) ...) - (begin - (define-method (nm (o class) l ...) code ...) - ... - (define-method (nm (o <p>) . v) - (aif it (ref o 'n) - (apply it v) - (next-method))))) - ((_ (nm n o l ... . u) (class code ...) ...) - (begin - (define-method (nm (o class) l ... . u) code ...) - ... - (define-method (nm (o <p>) . v) - (aif it (ref o 'n) - (apply it v) - (next-method))))))) - - -(define-method (bool (o <hashtable>)) - (for ((k v : o)) () - (break o) - #:final #f)) - -(define-method (bool (o <py-hashtable>)) - (if (= (len o) 0) - #f - o)) - -(define-py (py-copy copy o) - (<hashtable> - (hash-fold - (lambda (k v h) - (py-hash-set! h k v) - h) - (make-hash-table) - o)) - - (<py-hashtable> - (let ((r (make <py-hashtable>))) - (slot-set! r 'hash (slot-ref o 'hash)) - (slot-set! r 'n (slot-ref o 'n)) - (slot-set! r 't (py-copy (slot-ref o 't))) - r))) - -(define-py (py-fromkeys fromkeys o . l) - (<hashtable> - (let ((newval (match l - (() None) - ((v) v)))) - (hash-fold - (lambda (k v h) - (py-hash-set! h k newval) - h) - (make-hash-table) - o))) - - (<py-hashtable> - (let ((newval (match l - (() None) - ((v) v)))) - (hash-fold - (lambda (k v h) - (pylist-set! h k newval) - h) - (make-py-hashtable) - (slot-ref o 't))))) - -(define-py (py-get get o k . l) - (<hashtable> - (let ((elseval (match l - (() None) - ((v) v)))) - (let ((ret (py-hash-ref o k miss))) - (if (eq? ret miss) - elseval - ret)))) - - (<py-hashtable> - (let ((elseval (match l - (() None) - ((v) v)))) - (let ((ret (py-hash-ref (slot-ref o 't) k miss))) - (if (eq? ret miss) - elseval - ret))))) - -(define-py (py-has_key has_key o k . l) - (<hashtable> - (let ((elseval (match l - (() None) - ((v) v)))) - (let ((ret (py-hash-ref o k miss))) - (if (eq? ret miss) - #f - #t)))) - - (<py-hashtable> - (let ((elseval (match l - (() None) - ((v) v)))) - (let ((ret (py-hash-ref (slot-ref o 't) k miss))) - (if (eq? ret miss) - #f - #t))))) - -(define-py (py-items items o) - (<module> - (to-pylist - (let ((l '())) - (module-for-each - (lambda (k v) - (set! l (cons (list (symbol->string k) (variable-ref v)) l))) - o) - l))) - - (<hashtable> - (to-pylist - (hash-fold - (lambda (k v l) - (cons (list k v) l)) - '() o))) - - (<py-hashtable> - (to-pylist - (hash-fold - (lambda (k v l) - (cons (list k v) l)) - '() (slot-ref o 't))))) - -(define-generator (hash-item-gen yield hash-table) - (let lp ((l (hash-fold cons* '() hash-table))) - (match l - ((k v . l) - (yield k v) - (lp l)) - (() - #t)))) - -(define-generator (hash-values-gen yield hash-table) - (let lp ((l (hash-fold cons* '() hash-table))) - (match l - ((k v . l) - (yield v) - (lp l)) - (() - #t)))) - -(define-generator (hash-keys-gen yield hash-table) - (let lp ((l (hash-fold cons* '() hash-table))) - (match l - ((k v . l) - (yield k) - (lp l)) - (() - #t)))) - -(define-py (py-iteritems iteritems o) - (<hashtable> - (hash-item-gen o)) - - (<py-hashtable> - (hash-item-gen (slot-ref o 't)))) - -(define-py (py-iterkeys iterkeys o) - (<hashtable> - (hash-keys-gen o)) - - (<py-hashtable> - (hash-keys-gen (slot-ref o 't)))) - -(define-py (py-itervalues itervalues o) - (<hashtable> - (hash-values-gen o)) - - (<py-hashtable> - (hash-values-gen (slot-ref o 't)))) - -(define-py (py-keys keys o) - (<hashtable> - (to-pylist - (hash-fold - (lambda (k v l) (cons k l)) - '() - o))) - - (<py-hashtable> - (to-pylist - (hash-fold - (lambda (k v l) (cons k l)) - '() - (slot-ref o 't))))) - -(define-py (py-values values o) - (<hashtable> - (to-pylist - (hash-fold - (lambda (k v l) (cons v l)) - '() - o))) - - (<py-hashtable> - (to-pylist - (hash-fold - (lambda (k v l) (cons v l)) - '() - (slot-ref o 't))))) - -(define-py (py-popitem popitem o) - (<hashtable> - (let ((k.v (let/ec ret - (hash-for-each - (lambda (k v) - (ret (cons k v))) - o) - #f))) - (if k.v - (begin (pyhash-rem! o (car k.v)) k.v) - (raise KeyError "No elements in hash")))) - - (<py-hashtable> - (let ((k.v (let/ec ret - (hash-for-each - (lambda (k v) - (ret (cons k v))) - (slot-ref o 't)) - #f))) - (if k.v - (begin (pyhash-rem! o (car k.v)) k.v) - (raise KeyError "No elements in hash"))))) - -(define-py (py-setdefault setdefault o k . l) - (<hashtable> - (pylist-set! o k (apply py-get o k l)) - (apply py-get o k l)) - - (<py-hashtable> - (pylist-set! o k (apply py-get o k l)) - (apply py-get o k l))) - -(define update - (lam (o (* L) (** K)) - (match L - ((L) - (for ((k v : L)) () - (pylist-set! o k v))) - (_ #f)) - (for ((k v : K)) () - (pylist-set! o k v)))) - -(define-py (py-update update o . l) - (<hashtable> - (apply update o l)) - (<py-hashtable> - (apply update o l))) - -(define-py (py-clear clear o) - (<hashtable> - (hash-clear! o)) - (<py-hashtable> - (let ((t (slot-ref o 't))) - (hash-clear! t) - (slot-set! o 'n 0) - (slot-set! o 'hash H) - (values)))) - -#| -'viewitems' -'viewkeys' -'viewvalues' -|# - -(define-syntax-rule (top <) - (begin - (define-method (< (o1 <hashtable>) (o2 <hashtable>)) - (< (len o1) (len o2))) - (define-method (< (o1 <hashtable>) (o2 <py-hashtable>)) - (< (len o1) (len o2))) - (define-method (< (o1 <py-hashtable>) (o2 <hashtable>)) - (< (len o1) (len o2))) - (define-method (< (o1 <py-hashtable>) (o2 <py-hashtable>)) - (< (len o1) (len o2))))) - -(top <) -(top >) -(top <=) -(top >=) - -(define (fold f s l) - (if (pair? l) - (f (car l) (fold f s (cdr l))) - s)) - -(define-method (write (o <py-hashtable>) . l) - (define port (match l (() #f) ((p) p))) - (define li (hash-fold cons* '() (slot-ref o 't))) - (if (null? li) - (format port "{}") - (format port "{~a: ~a~{, ~a: ~a~}}" (car li) (cadr li) (cddr li)))) - -(define-method (py-equal? (o1 <py-hashtable>) (o2 <py-hashtable>)) - (and - (equal? (slot-ref o1 'n) (slot-ref o2 'n)) - (equal? (slot-ref o1 'hash) (slot-ref o2 'hash)) - (e? (slot-ref o1 't) (slot-ref o2 't)))) - -(define (e? t1 t2) - (let/ec ret - (hash-fold - (lambda (k v s) - (let ((r (py-hash-ref t2 k miss))) - (if (eq? r miss) - (ret #f) - (if (equal? r v) - #t - (ret #f))))) - #t - t1))) - - -(define-class <hashiter> () l) -(name-object <hashiter>) -(cpit <hashiter> (o (lambda (o l) (slot-set! o 'l l)) - (list (slot-ref o 'l)))) - - -(define-method (wrap-in (t <hashtable>)) - (let ((o (make <hashiter>))) - (slot-set! o 'l (to-list (py-items t))) - o)) - -(define-method (wrap-in (t <py-hashtable>)) - (let ((o (make <hashiter>))) - (slot-set! o 'l (to-list (py-items t))) - o)) - -(define-method (next (o <hashiter>)) - (let ((l (slot-ref o 'l))) - (if (pair? l) - (let ((k (caar l)) - (v (cadar l)) - (l (cdr l))) - (slot-set! o 'l l) - (values k v)) - (throw StopIteration)))) - - -(define-method (in key (o <hashtable>)) - (py-has_key o key)) - -(define-method (in key (o <py-hashtable>)) - (py-has_key o key)) - - -(define <dict> `(,<py-hashtable> . _)) -(define <in> `(,<top> ,<py-hashtable>)) -(define (resolve a b) (object-method (resolve-method-g a b))) -(define dict-set! (resolve pylist-set! <dict>)) -(define dict-ref (resolve pylist-ref <dict>)) -(define dict-del! (resolve pylist-delete! <dict>)) -(define dict-pop! (resolve pylist-pop! <dict>)) -(define dict-clear! (resolve py-clear <dict>)) -(define dict-get (resolve py-get <dict>)) -(define dict-len (resolve len <dict>)) -(define dict-bool (resolve bool <dict>)) -(define dict-in (resolve in <in> )) -(define dict-items (resolve py-items <dict>)) - -(define-python-class dict (<py> <py-hashtable>) - (define __getitem__ dict-ref) - (define __setitem__ - (lambda (self key val) - (dict-set! self key val))) - (define __delitem__ dict-del!) - (define pop dict-pop!) - (define clear dict-clear!) - (define get dict-get) - (define __len__ dict-len) - (define __bool__ dict-bool) - (define items dict-items) - (define __iter__ (lambda (self) - (wrap-in (slot-ref self 't)))) - (define __contains__ - (lambda (self x) (dict-in x self))) - (define __format___ (lambda x #f)) - (define __setattr__ (@@ (oop pf-objects) __setattr__)) - (define __getattribute__ (@@ (oop pf-objects) __getattribute__)) - - - (define __init__ - (letrec ((__init__ - (case-lambda - ((self) - (let ((r (make-hash-table))) - (slot-set! self 't r) - (slot-set! self 'hash H) - (slot-set! self 'n 0))) - ((self x) - (__init__ self) - (catch #t - (lambda () - (for ((k v : x)) () - (pylist-set! self k v))) - (lambda y - (for ((k : x)) () - (if (pair? k) - (pylist-set! self (car k) (cdr k)) - (raise TypeError - "wrong type of argument to dict" k)))))) - ((self . l) - (__init__ - self - (let lp ((l l)) - (match l - ((x y . l) - (cons (cons (symbol->string - (keyword->symbol x)) - y) (lp l))) - (() '()) - (_ (raise - (ValueError - "init argument to dict malformed expected key value list")))))))))) - - __init__))) - -(define (renorm k) - (if (symbol? k) - k - (string->symbol k))) - -(define (norm k) - (if (symbol? k) - (symbol->string k) - k)) - -(define fail (list 'fail)) - -(define-syntax-rule (mkwrap dictNs norm renorm) -(define-python-class dictNs () - (define __getitem__ - (lambda (self k) - (pylist-ref (ref self '_dict) (norm k)))) - - (define __setitem__ - (lambda (self k v) - (pylist-set! (ref self '_dict) (norm k) v))) - - (define __iter__ - (lambda (self) - ((make-generator () - (lambda (yield) - (for ((k v : (ref self '_dict))) () - (yield (renorm k) v))))))) - - (define pop - (lambda (self k . l) - (apply pylist-pop! (ref self '_dict) (norm k) l))) - - (define clear - (lambda (self) - (py-clear (ref self '_dict)))) - - (define get - (lambda (self key . l) - (apply py-get (ref self '_dict) (norm key) l))) - - (define __len__ - (lambda (self) - (len (ref self '_dict)))) - - (define __bool__ - (lambda (self) - (bool (ref self '_dict)))) - - (define __contains__ - (lambda (self x) - (in (norm x) (ref self '_dict)))) - - (define items - (lambda (self) - (for ((k v : (ref self '_dict))) ((l '())) - (cons (list (renorm k) v) l) - #:final (reverse l)))) - - (define keys - (lambda (self) - (for ((k v : self)) ((l '())) - (cons (renorm k) l) - #:final - l))) - - (define values - (lambda (self) - (for ((k v : self)) ((l '())) - (cons v l) - #:final - l))) - - (define __repr__ - (lambda (self) - (for ((k v : (ref self '_dict))) ((l '())) - (cons (format #f "~a:~a" k v) l) - #:final - (aif it (ref (ref self '_dict) '__name__) - (format #f "Ns-~a: ~a" it (reverse l)) - (format #f "Ns: ~a" (reverse l)))))) - - (define __str__ __repr__) - - (define __getattr__ - (lambda (self key) - (let ((r (ref (ref self '_dict) key fail))) - (if (eq? r fail) - (raise (AttributeError key)) - r)))) - - (define __init__ - (lambda (self d) (set self '_dict d))))) - -(mkwrap dictNs norm renorm) -(mkwrap dictRNs renorm norm) - -(set! (@@ (oop pf-objects) dictNs) dictNs) -(set! (@@ (oop pf-objects) dictRNs) dictRNs) - -(define-python-class weak-key-dict (<py> <py-hashtable>) - (define __init__ - (letrec ((__init__ - (case-lambda - ((self) - (let ((r (make-hash-table))) - (slot-set! self 't r) - (slot-set! self 'hash H) - (slot-set! self 'n 0))) - - ((self x) - (__init__ self) - (if (is-a? x <py-hashtable>) - (hash-for-each - (lambda (k v) - (pylist-set! self k v)) - (slot-ref x 't))))))) - __init__))) - -(define-python-class weak-value-dict (<py> <py-hashtable>) - (define __init__ - (letrec ((__init__ - (case-lambda - ((self) - (let ((r (make-hash-table))) - (slot-set! self 't r) - (slot-set! self 'hash H) - (slot-set! self 'n 0))) - - ((self x) - (__init__ self) - (if (is-a? x <py-hashtable>) - (hash-for-each - (lambda (k v) - (pylist-set! self k v)) - (slot-ref x 't))))))) - __init__))) - -(define (pyhash-listing) - (let ((l (to-pylist - (map symbol->string - '(__class__ __cmp__ __contains__ __delattr__ - __delitem__ __doc__ __eq__ __format__ - __ge__ __getattribute__ __getitem__ - __gt__ __hash__ __init__ __iter__ - __le__ __len__ __lt__ __ne__ __new__ - __reduce__ __reduce_ex__ __repr__ - __setattr__ __setitem__ __sizeof__ - __str__ __subclasshook__ - clear copy fromkeys get has_key - items iteritems iterkeys itervalues - keys pop popitem setdefault update - values viewitems viewkeys viewvalues))))) - (pylist-sort! l) - l)) - -(set! (@@ (oop pf-objects) hash-for-each*) - (lambda (f dict) - (for ((k v : dict)) () - (f k v)))) - -(define-method (py-class (o <hashtable>)) dict) -(define-method (py-class (o <py-hashtable>)) dict) diff --git a/modules/language/python/dir.scm b/modules/language/python/dir.scm deleted file mode 100644 index 0791666..0000000 --- a/modules/language/python/dir.scm +++ /dev/null @@ -1,180 +0,0 @@ -(define-module (language python dir) - #:use-module (language python list) - #:use-module (language python for) - #:use-module (language python dict) - #:use-module (language python string) - #:use-module (language python bytes) - #:use-module (language python number) - #:use-module (language python bytes) - #:use-module (oop goops) - #:use-module (ice-9 vlist) - #:use-module (oop pf-objects) - #:export (dir)) - -(define-syntax-rule (aif it p x y) (let ((it p)) (if it x y))) - -(define in-p (make-fluid #f)) -(define-method (dir x) (py-list)) -(define (cont l1 l2) - (let ((h (make-hash-table)) - (l (py-list))) - (for ((x : l1)) () - (hash-set! h x #t)) - (for ((x : l2)) () - (hash-set! h x #t)) - (for ((k v : h)) () - (pylist-append! l k)) - (pylist-sort! l) - - l)) - -(define (p x) (if (symbol? x) (symbol->string x) x)) -(define (chash-for-each t c) - (let ((h (slot-ref c 'h))) - (if (is-a? c <pf>) - (vhash-fold - (lambda (k v s) - (hash-set! t (p k) #t)) - #f h) - (hash-for-each - (lambda (k v) - (hash-set! t (p k) #t)) - h)))) - -(define (find-in o h c) - (aif it (and o (find-in-class c '__dir__ #f)) - (for ((k : (it o))) () - (hash-set! h (p k) #t)) - (chash-for-each h c))) - -(define (find-in-mro o h l) - (let lp ((l l)) - (if (pair? l) - (begin - (find-in o h (car l)) - (lp (cdr l)))))) - - -(define-method (dir (o <p>)) - (if (fluid-ref in-p) - (next-method) - (with-fluids ((in-p #t)) - (cont - (next-method) - (let ((h (make-hash-table))) - (find-in-mro #f h (find-in-class o '__mro__ (list o))) - (aif cl (find-in-class o '__class__ #f) - (find-in-mro o h (find-in-class cl '__mro__ (list cl))) - #f) - (let ((l (py-list))) - (hash-for-each - (lambda (k v) - (pylist-append! l k)) - h) - (pylist-sort! l) - l)))))) - -(define-method (dir (o <py-list>)) - (cont - (next-method) - (let ((l1 (pylist-listing))) - (if (is-a? o <p>) - (let* ((l2 (next-method)) - (l (+ l1 l2))) - (pylist-sort! l) - l) - l1)))) - -(define-method (dir (o <py-hashtable>)) - (cont - (next-method) - (let ((l1 (pyhash-listing))) - (if (is-a? o <p>) - (let* ((l2 (next-method)) - (l (+ l1 l2))) - (pylist-sort! l) - l) - l1)))) - -(define-method (dir (o <py-string>)) - (cont - (next-method) - (let ((l1 (pystring-listing))) - (if (is-a? o <p>) - (let* ((l2 (next-method)) - (l (+ l1 l2))) - (pylist-sort! l) - l) - l1)))) - -(define-method (dir (o <py-int>)) - (cont - (next-method) - (let ((l1 (pyint-listing))) - (if (is-a? o <p>) - (let* ((l2 (next-method)) - (l (+ l1 l2))) - (pylist-sort! l) - l) - l1)))) - -(define-method (dir (o <py-float>)) - (cont - (next-method) - (let ((l1 (pyfloat-listing))) - (if (is-a? o <p>) - (let* ((l2 (next-method)) - (l (+ l1 l2))) - (pylist-sort! l) - l) - l1)))) - -(define-method (dir (o <py-complex>)) - (cont - (next-method) - (let ((l1 (pycomplex-listing))) - (if (is-a? o <p>) - (let* ((l2 (next-method)) - (l (+ l1 l2))) - (pylist-sort! l) - l) - l1)))) - -(define-method (dir (o <py-bytes>)) - (cont - (next-method) - (let ((l1 (pybytes-listing))) - (if (is-a? o <p>) - (let* ((l2 (next-method)) - (l (+ l1 l2))) - (pylist-sort! l) - l) - l1)))) - -(define-method (dir (o <py-bytearray>)) - (cont - (next-method) - (let ((l1 (pybytesarray-listing))) - (if (is-a? o <p>) - (let* ((l2 (next-method)) - (l (+ l1 l2))) - (pylist-sort! l) - l) - l1)))) - -(define-method (dir (o <hashtable> )) (pyhash-listing)) -(define-method (dir (o <string> )) (pystring-listing)) -(define-method (dir (o <complex> )) (pycomplex-listing)) -(define-method (dir (o <real> )) (pyfloat-listing)) -(define-method (dir (o <integer> )) (pyint-listing)) -(define-method (dir (o <bytevector> )) (pybytes-listing)) -(define-method (dir) - (let ((l '())) - (module-for-each (lambda (m . u) - (set! l (cons (symbol->string m) l))) - (current-module)) - (let ((ret (to-pylist l))) - (pylist-sort! ret) - ret))) - - diff --git a/modules/language/python/eval.scm b/modules/language/python/eval.scm deleted file mode 100644 index 1cd92ad..0000000 --- a/modules/language/python/eval.scm +++ /dev/null @@ -1,170 +0,0 @@ -(define-module (language python eval) - #:use-module (parser stis-parser lang python3-parser) - #:use-module (language python exceptions) - #:use-module (language python module) - #:use-module (language python try) - #:use-module (language python list) - #:use-module (language python for) - #:use-module (language python dict) - #:use-module (oop pf-objects) - #:use-module ((ice-9 local-eval) #:select ((the-environment . locals))) - #:re-export (locals) - #:replace (eval) - #:export (local-eval local-compile globals compile exec)) - -(define seval (@ (guile) eval)) - -(define-syntax-rule (aif it p x y) (let ((it p)) (if it x y))) - -(define-syntax-rule (L x) (@@ (ice-9 local-eval) x)) - -(define-syntax globals - (lambda (x) - (syntax-case x () - ((g) - #'(M ((L env-module) (locals g))))))) - -(define-syntax-rule (call- self item a ...) - (let ((class (ref self '_module))) - ((rawref class item) class a ...))) - -(define-syntax-rule (apply- self item a ...) - (let ((class (ref self '_module))) - (apply (rawref class item) class a ...))) - -(define-syntax-rule (ref- self item) - (let ((class (ref self '_module))) - (rawref class item))) - - -(define-python-class GlobalModuleWrap (dict) - (define __init__ - (lambda (self module) - (set self '_module module))) - - (define __getitem__ - (lambda (self key) - (if (string? key) (set! key (string->symbol key))) - (call- self '__global_getitem__ key))) - - (define get - (lambda (self key . es) - (if (string? key) (set! key (string->symbol key))) - (apply- self '__global_get__ key es))) - - (define __setitem__ - (lambda (self key val) - (if (string? key) (set! key (string->symbol key))) - (call- self '__global_setitem__ key val))) - - (define __iter__ - (lambda (self) - (call- self '__global_iter__))) - - (define values - (lambda (self) - (for ((k v : (__iter__ self))) ((l '())) - (cons v l) - #:final l))) - - (define keys - (lambda (self) - (for ((k v : (__iter__ self))) ((l '())) - (cons k l) - #:final l))) - - (define __contains__ - (lambda (self key) - (if (string? key) (set! key (string->symbol key))) - (for ((k v : (__iter__ self))) () - (if (eq? k key) - (break #t)) - #:final - #f))) - - (define items __iter__) - - (define __repr__ - (lambda (self) - (format #f "globals(~a)" (ref- self '__name__))))) - - - -(define MM (list 'error)) -(define (M mod) - (set! mod (module-name mod)) - (if (and (> (length mod) 3) - (eq? (car mod) 'language) - (eq? (cadr mod) 'python) - (eq? (caddr mod) 'module)) - (set! mod (Module (reverse mod) - (reverse (cdddr mod)))) - (set! mod (Module (reverse mod) (reverse mod)))) - - (GlobalModuleWrap mod)) - - -(define* (local-eval x locals globals) - "Evaluate the expression @var{x} within the local environment @var{local} and -global environment @var{global}." - (if locals - (if globals - (apply (seval ((L local-wrap) x locals) globals) - ((L env-boxes) locals)) - (apply (seval ((L local-wrap) x locals) ((L env-module) locals)) - ((L env-boxes) locals))) - (seval x (current-module)))) - -(define* (local-compile x locals globals #:key (opts '())) - "Compile the expression @var{x} within the local environment @var{local} and -global environment @var{global}." - (if locals - (if globals - (apply ((@ (system base compile) compile) - ((L local-wrap) x locals) #:env globals - #:from 'scheme #:opts opts) - ((L env-boxes) locals)) - (apply ((@ (system base compile) compile) ((L local-wrap) x locals) - #:env ((L env-module) locals) - #:from 'scheme #:opts opts) - ((L env-boxes) locals))) - ((@ (system base compile) compile) x #:env (current-module) - #:from 'scheme #:opts opts))) - -(define-syntax eval - (lambda (x) - (syntax-case x () - ((eval x) - #'(eval0 x (locals eval))) - ((eval x . l) - #'(eval0 x . l))))) - -(define* (eval0 x #:optional (locals #f) (globals #f)) - (cond - ((string? x) - (aif xp (p x) - (aif cp (comp xp) - (local-eval cp locals globals) - (raise SyntaxError)) - (raise SyntaxError))) - ((pair? x) - (local-eval x locals globals)))) - -(define* (compile x filename mode - #:optional (flags 0) (dont_inherit #f) (optiomize -1)) - (aif xp (p x) - (aif cp (comp xp) - cp - (raise SyntaxError)) - (raise SyntaxError))) - -(define-syntax exec - (lambda (x) - (syntax-case x () - ((exec x) - #'(eval0 x (locals exec))) - ((exec x . l) - #'(exec0 x . l))))) - -(define* (exec0 x #:optional (locals #f) (globals #f)) - (local-eval x locals globals)) diff --git a/modules/language/python/exceptions.scm b/modules/language/python/exceptions.scm deleted file mode 100644 index fd1f0e1..0000000 --- a/modules/language/python/exceptions.scm +++ /dev/null @@ -1,173 +0,0 @@ -(define-module (language python exceptions) - #:use-module (oop pf-objects) - #:use-module (oop goops) - #:export (StopIteration GeneratorExit RuntimeError TabError - Exception ValueError TypeError - IndexError KeyError AttributeError ArgumentError - SyntaxError SystemException - OSError ProcessLookupError PermissionError - None NotImplemented NotImplementedError - AssertionError ImportError - ModuleNotFoundError BlockingIOError - InterruptedError BaseException - ZeroDivisionError PendingDeprecationWarning - OverflowError RecursionError RuntimeWarning - Warning DeprecationWarning BytesWarning - ResourceWarning UserWarning UnicodeTranslateError - UnicodeDecodeError LookupError IndentationError - KeyboardInterrupt MemoryError NameError - EOFError UnicodeError UnicodeEncodeError - FileExistsError FileNotFoundError IsADirectoryError - EnvironmentError ConnectionError NotADirectoryError - ConnectionResetError ChildProcessError TimeOutError - BrokenPipeError ConnectionAbortedError SystemExit - ConnectionRefusedError ArithmeticError - FutureWarning)) - -(define-syntax-rule (aif it p x y) (let ((it p)) (if it x y))) - -(define-python-class Exception () - (define __init__ - (case-lambda - ((self) - (values)) - ((self val . l) - (set self 'value val)))) - - (define __repr__ - (lambda (self) - (aif it (rawref self 'value #f) - (format #f "~a:~a" - (rawref self '__name__) it) - (format #f "~a" - (rawref self '__name__)))))) - -(define-python-class SystemExit () - (define __init__ - (case-lambda - ((self) - (values)) - ((self val . l) - (set self 'value val)))) - - (define __repr__ - (lambda (self) - (aif it (rawref self 'value #f) - (format #f "~a:~a" - (rawref self '__name__) it) - (format #f "~a" - (rawref self '__name__)))))) - -(define-python-class Warning () - (define __init__ - (case-lambda - ((self) - (values)) - ((self val . l) - (set self 'value val)))) - - (define __repr__ - (lambda (self) - (aif it (rawref self 'value #f) - (format #f "~a:~a" - (rawref self '__name__) it) - (format #f "~a" - (rawref self '__name__)))))) - -(define-syntax define-er - (syntax-rules () - ((_ nm k) - (define-python-class nm (Exception))) - ((_ nm w k) - (define-python-class nm w)))) - -(define-syntax define-er2 - (syntax-rules () - ((_ nm k) - (define-python-class nm (BaseException))) - ((_ nm w k) - (define-python-class nm w)))) - -(define StopIteration 'StopIteration) -(define GeneratorExit 'GeneratorExit) -(define-er EnvironmentError 'EnvironmentError) - -(define-er EOFError 'EOFError) -(define-er MemoryError 'MemoryError) -(define-er NameError 'NameError) - -(define-er ValueError 'ValueError) -(define-python-class UnicodeError (ValueError)) -(define-python-class UnicodeDecodeError (UnicodeError)) -(define-python-class UnicodeEncodeError (UnicodeError)) -(define-python-class UnicodeTranslateError (UnicodeError)) - -(define-er LookupError 'LookupError) - (define-python-class IndexError (LookupError)) - (define-python-class KeyError (LookupError)) - -(define-er ArithmeticError 'OverflowError) - (define-python-class OverflowError (ArithmeticError)) - (define-python-class ZeroDivisionError (ArithmeticError)) - - -(define-er KeyboardInterrupt 'KeyboardInterrupt) -(define-er BaseException 'BaseException) -(define-er SystemException 'SystemException) -(define-er RuntimeError 'RuntimeError) - (define-python-class NotImplementedError (RuntimeError)) - (define-python-class RecursionError (RuntimeError)) - - -(define-er ArgumentError 'IndexError) - -(define-er OSError 'OSError) - (define-python-class BlockingIOError (OSError)) - (define-python-class ChildProcessError (OSError)) - (define-python-class ConnectionError (OSError)) - (define-python-class BrokenPipeError (ConnectionError)) - (define-python-class ConnectionAbortedError (ConnectionError)) - (define-python-class ConnectionRefusedError (ConnectionError)) - (define-python-class ConnectionResetError (ConnectionError)) - (define-python-class FileExistsError (OSError)) - (define-python-class FileNotFoundError (OSError)) - (define-python-class InterruptedError (OSError)) - (define-python-class IsADirectoryError (OSError)) - (define-python-class NotADirectoryError (OSError)) - (define-python-class PermissionError (OSError)) - (define-python-class ProcessLookupError (OSError)) - (define-python-class TimeOutError (OSError)) -(define None 'None) - - -(define-er TypeError 'TypeError) -(define-er AttributeError 'AttributeError) -(define-er SyntaxError 'SyntaxError) - (define-python-class IndentationError (SyntaxError)) - (define-python-class TabError (IndentationError)) - -(define-er RunTimeError 'RunTimeError) - -(define AssertionError 'AssertionError) -(define-er ImportError 'ImportError) -(define-er ModuleNotFoundError (ImportError) 'ModuleNotFoundError) - -(define NotImplemented (list 'NotImplemented)) - - - - -(define-syntax define-wr - (syntax-rules () - ((_ nm k) - (define-python-class nm (Warning))) - ((_ nm w k) - (define-python-class nm w)))) - -(define-wr BytesWarning 'BytesWarning) -(define-wr DepricationWarning 'DeprecationWarning) -(define-wr ResourceWarning 'ResourceWarning) -(define-wr UserWarning 'UserWarning) -(define-wr PendingDeprecationWarning 'PendingDeprecationWarning) -(define-wr RuntimeWarning 'RuntimeWarning) -(define-wr FutureWarning 'FutureWarning) diff --git a/modules/language/python/expr.scm b/modules/language/python/expr.scm deleted file mode 100644 index 81c2cbe..0000000 --- a/modules/language/python/expr.scm +++ /dev/null @@ -1,106 +0,0 @@ -(define-module (language python expr) - #:use-module (language python class) - #:export (py-true? to-py py-or py-and py-not py_== - py_>= py_<= py_< py_> py_<> py_!= py_in py_notin py_is - py_isnot py_bor py_xor py_band py-<< py->> py-+ py-- - py-* py-/ py-% py-// py-u+ py-u- py-u~ py-power - )) - - -(define-syntax-rule (py-true? x) (eq? x 'True)) -(define-syntax-rule (to-py x) (if x 'True 'false)) -(define-syntax-rule (py-or x ...) (to-py (or (py-true? x) ...))) -(define-syntax-rule (py-and x ...) (to-py (and (py-true? x) ...))) -(define-syntax-rule (py-not x) (if (py-true? x) 'False 'True)) - -(define-syntax-rule (py_== x y) - (if (struct? x) - (if (class? x) - (class_== x y) - (to-py (equal? x y))) - (to-py (equal? x y)))) - -(define-syntax-rule (mk-comp py_>= >= class_>=) - (define-syntax-rule (py_>= x y) - (if (number? x) - (to-py (>= x y)) - (if (class? x) - (class_>= x y) - 'False)))) - -(mk-comp py_>= >= class_>=) -(mk-comp py_<= <= class_<=) -(mk-comp py_< < class_<) -(mk-comp py_> > class_>) - -(define-syntax-rule (<> x y) (not (= x y))) -(mk-comp py_<> <> class_<>) -(mk-comp py_!= <> class_<>) - - -(define-syntax-rule (py_in x y) - (cond - ((struct? y) - (if (class? y) - (to-py (class_in y x)) - 'False)) - ((pair? y) - (list-in x y)) - ((vector? y) - (vector-in x y)) - (else - 'False))) - -(define-syntax-rule (py_notin x y) - (cond - ((struct? y) - (if (class? y) - (to-py (not (class_in y x))) - 'True)) - ((pair? y) - (to-py (list-in x y))) - ((vector? y) - (to-py (vector-in x y))) - (else - 'True))) - -(define-syntax-rule (py_is x y) - (to-py (and (class? x) (class? y) (eq? (class-ref x) (class-ref y))))) - -(define-syntax-rule (py_isnot x y) - (to-py (not (and (class? x) (class? y) (eq? (class-ref x) (class-ref y)))))) - -(define-syntax-rule (mk-num py_>= >= class_>=) - (define-syntax-rule (py_>= x . y) - (if (number? x) - (>= x . y) - (if (class? x) - (class_>= x . y) - (error "wrong numerics"))))) - -(mk-num py_bor logior class_ior) -(mk-num py_xor logxor class_xor) -(mk-num py_band logand class_band) -(mk-num py-<< ash class_<<) -(define-syntax-rule (rash x y) (ash x (- y))) -(mk-num py->> rash class_>>) -(mk-num py-+ + class_+) -(mk-num py-- - class_-) -(mk-num py-* * class_*) -(mk-num py-/ / class_/) -(mk-num py-% modulo class_%) -(mk-num py-// truncate-quotient class_//) - -(define-syntax-rule (mk-unum py_>= >= class_>=) - (define-syntax-rule (py_>= x) - (if (number? x) - (>= x) - (if (class? x) - (class_>= x) - (error "wrong numerics"))))) - -(mk-unum py-u+ + class_u+) -(mk-unum py-u- - class_u-) -(mk-unum py-u~ lognot class_u~) - -(mk-num py-power expt class_power) diff --git a/modules/language/python/for.scm b/modules/language/python/for.scm deleted file mode 100644 index cebb5d1..0000000 --- a/modules/language/python/for.scm +++ /dev/null @@ -1,182 +0,0 @@ -(define-module (language python for) - #:use-module (language python yield) - #:use-module (oop pf-objects) - #:use-module (language python exceptions) - #:use-module (language python def) - #:use-module (oop goops) - #:use-module (ice-9 control) - #:use-module (language python persist) - #:export (for break next wrap-in)) - -(define-syntax-rule (aif it p x y) (let ((it p)) (if it x y))) - -(eval-when (compile eval load) - (define (generate-temporaries2 x) - (map (lambda (x) (generate-temporaries x)) x))) - -(define-syntax-parameter break (lambda (x) #f)) - -(define-syntax for - (syntax-rules (:) - ((for ((x ... : E) ...) ((c n) ...) code ... #:final fin) - (for-work #f ((x ... : E) ...) ((c n) ...) (code ...) fin values)) - ((for ((x ... : E) ...) ((c n) ...) code ... #:finally fin) - (for-work #f ((x ... : E) ...) ((c n) ...) (code ...) fin values)) - - ((for ((x ... : E) ...) ((c n) ...) code ... #:else fin) - (for-work #f ((x ... : E) ...) ((c n) ...) (code ...) (values) - (lambda () fin))) - - ((for lp ((x ... : E) ...) ((c n) ...) code ... #:final fin) - (for-work lp ((x ... : E) ...) ((c n) ...) (code ...) fin values)) - - ((for lp ((x ... : E) ...) ((c n) ...) code ... #:finally fin) - (for-work lp ((x ... : E) ...) ((c n) ...) (code ...) fin values)) - - ((for lp ((x ... : E) ...) ((c n) ...) code ... #:else fin) - (for-work lp ((x ... : E) ...) ((c n) ...) (code ...) (values) - (lambda () fin))) - - ((for ((x ... : E) ...) ((c n) ...) code ...) - (for-work #f ((x ... : E) ...) ((c n) ...) (code ...) (values) values)) - - ((for lp ((x ... : E) ...) ((c n) ...) code ...) - (for-work lp ((x ... : E) ...) ((c n) ...) (code ...) (values) values)))) - -(define-syntax for-work - (lambda (z) - (define (wrap-continue lp code) - (if (syntax->datum lp) - #`(lambda () (let/ec #,lp #,@code)) - #`(lambda () #,@code))) - - (syntax-case z () - ((for lp ((x ... : E) ...) ((c n) ...) (code ...) fin er) - (with-syntax (((It ...) (generate-temporaries #'(E ...))) - ((cc ...) (generate-temporaries #'(c ...))) - (((x1 ...) ...) (generate-temporaries2 #'((x ...) ...))) - (((x2 ...) ...) (generate-temporaries2 #'((x ...) ...))) - ((N ...) (map length #'((x ...) ...))) - (M (length #'(c ...))) - (else- (datum->syntax #'for 'else-)) - (llp (if (syntax->datum #'lp) #'lp #'lpu))) - - #`(let/ec lp-break0 - (let ((It (wrap-in E)) ... - (c n ) ... - (x 'None ) ... ... - (x1 #f ) ... ...) - (let* ((else- er ) - (lp-break (lambda q (else-) (apply lp-break0 q)))) - (syntax-parameterize ((break (lambda (z) - (syntax-case z () - ((_ . l) - #'(lp-break . l)) - (_ #'lp-break))))) - - (catch StopIteration - (lambda () - (let llp ((cc c) ...) - (set! c cc) ... - (call-with-values - (lambda () (next It)) - (let ((f - (lambda (x2 ... . ll) - (set! x1 x2) ...))) - (if (> N 1) - (case-lambda - ((q) - (if (pair? q) - (if (pair? (cdr q)) - (apply f q) - (apply f (car q) (cdr q))) - (py-apply f (* q)))) - (q - (apply f q))) - (lambda (x2 ... . ll) - (set! x1 x2) ...)))) - ... - (set! x x1) - ... ... - (call-with-values - #,(wrap-continue - #'lp - #'((let ((x x) ... ...) code ...))) - (lambda (cc ... . q) (llp cc ...))))) - (lambda q (else-) fin))))))))))) - -(define-class <scm-list> () l) -(define-class <scm-string> () s i) - -(name-object <scm-list>) -(name-object <scm-string>) -(cpit <scm-list> (o (lambda (o l) (slot-set! o 'l l)) - (list (slot-ref o 'l)))) -(cpit <scm-string> (o (lambda (o s i) - (slot-set! o 's s) - (slot-set! o 'i i)) - (list - (slot-ref o 's) - (slot-ref o 'i)))) - -(define-method (next x) - (throw StopIteration)) - -(define-method (next (l <scm-list>)) - (let ((ll (slot-ref l 'l))) - (if (pair? ll) - (begin - (slot-set! l 'l (cdr ll)) - (car ll)) - (throw StopIteration)))) - -(define-method (next (l <scm-string>)) - (let ((s (slot-ref l 's)) - (i (slot-ref l 'i))) - (if (= i (string-length s)) - (throw StopIteration) - (begin - (slot-set! l 'i (+ i 1)) - (string-ref s i))))) - -(define-method (next (l <yield>)) - (let ((k (slot-ref l 'k)) - (s (slot-ref l 's))) - (if k - (k (lambda () 'None)) - (s)))) - -(define-method (wrap-in (o <yield>)) - o) - -(define-method (wrap-in (o <p>)) - (aif it (ref o '__iter__) - (let ((x (it))) - (pk 'wrap-in o x) - (cond - ((pair? x) (wrap-in x)) - (else x))) - (next-method))) - -(define-method (next (l <p>)) - ((ref l '__next__))) - -(define-method (wrap-in x) - (cond - ((or (null? x) (pair? x)) - (let ((o (make <scm-list>))) - (slot-set! o 'l x) - o)) - - ((string? x) - (let ((o (make <scm-string>))) - (slot-set! o 's x) - (slot-set! o 'i 0) - o)) - - (else - x))) - -(set! (@@ (oop pf-objects) hashforeach) - (lambda (f d) - (for ((k v : d)) () (f k v)))) diff --git a/modules/language/python/format2.scm b/modules/language/python/format2.scm deleted file mode 100644 index 437623c..0000000 --- a/modules/language/python/format2.scm +++ /dev/null @@ -1,324 +0,0 @@ -(define-module (language python format2) - #:use-module (ice-9 match) - #:use-module (parser stis-parser) - #:use-module (oop pf-objects) - #:use-module (oop goops) - #:use-module (language python exceptions) - #:use-module (language python number) - #:use-module (language python dict) - #:use-module (language python list) - #:export (format fnm)) - -(define splitm #f) -(define splitmm #f) - -(define-syntax-rule (aif it p x y) (let ((it p)) (if it x y))) - -(define scm-format (@ (guile) format)) - -(define e-map (f-seq "(" (mk-token (f* (f-not! (f-tag ")")))) ")")) -(define e-conv (mk-token (f+ (f-reg! "[-#0 +]")))) -(define e-min (f-or! (mk-token (f+ (f-reg! "[0-9]")) string->number) - (f-seq "*" (f-out #:*)))) -(define e-prec (f-seq "." (f-or! - (mk-token (f+ (f-reg! "[0-9]")) string->number) - (f-seq "*" (f-out #:*))))) -(define e-len (mk-token (f-reg! "[hlL]"))) -(define e-type (mk-token (f-reg! "[diouxXeEfFgGcrsa%]"))) -(define e (f-list #:% "%" (ff? e-map) (ff? e-conv) (ff? e-min) - (ff? e-prec) (ff? e-len) e-type)) - -(define (map? l) - (let lp ((l l)) - (match l - ((a (#:% #f . _) . l) - (lp l)) - ((a (#:% _ . _) . l) - #t) - (_ #f)))) - -(define (get-n p) - (match p - ((#:% _ _ _ _ _ "%") - -1) - - ((#:% #f _ #:* #:* . _) - 2) - ((#:% #f _ #:* _ . _) - 1) - ((#:% #f _ _ #:* . _) - 1) - (_ - 0))) - -(define (create c min prec tp) - (define (get-intkind tp) - (match tp - ((or "d" "i" "u") - "d") - ("o" - "o") - ((or "x" "X") - "x"))) - - (let ((prec (if prec prec 6)) - (min (if min min 0)) - (c (if c c ""))) - (match tp - ("c" - (lambda (x) - (if (and (number? x) (integer? x)) - (list->string (list (integer->char x))) - x))) - - ("s" (lambda (x) - (let ((s (if (is-a? x <p>) - (aif it (ref x '__str__) - (scm-format #f "~a" (it)) - (scm-format #f "~a" x)) - (scm-format #f "~a" x)))) - (+ s (* " " (max 0 (- min (len s)))))))) - - ("a" (lambda (x) - (let ((s (scm-format #f "~a" x))) - (+ s (* " " (max 0 (- min (len s)))))))) - - ("r" (lambda (x) - (let ((s (scm-format #f "~a" x))) - (+ s (* " " (max 0 (- min (len s)))))))) - - ("%" - (lambda (x) (* "%" (if min min 1)))) - ((or "f" "F" "e" "E" "g" "G") - (let ((c (string->list c))) - (define (make-decimal) - (string-append - "~" - (if min (number->string min) "") - "," - (number->string prec) - ",,," - (if (member #\0 c) - "0" - (if (member #\space c) - " " - "")) - (if (member #\+ c) "@" "") - "f")) - (define (make-exp expchar) - (string-append - "~" - (if min (number->string min) "") - "," - (number->string prec) - ",,,," - (if (member #\0 c) - "0" - (if (member #\space c) - " " - "")) - ",'" - expchar - (if (member #\+ c) "@" "") - "e")) - (match tp - ((or "f" "F") - (let ((pat (make-decimal))) - (lambda (x) (scm-format #f pat x)))) - ((or "e" "E") - (let ((pat (make-exp tp))) - (lambda (x) (scm-format #f pat x)))) - ((or "g" "G") - (let ((pat1 (make-decimal)) - (pat2 (make-exp (if (equal? tp "g") "e" "E")))) - (lambda (x) - (if (or (< (log10 (abs x)) -4) - (if prec (< (log10 (abs x)) (- prec)) #f)) - (scm-format #f pat2 x) - (scm-format #f pat1 x)))))))) - - - ((or "d" "i" "u" "o" "x" "X") - (match c - ("" - (let ((kind (get-intkind tp))) - (if min - (let ((pat (string-append "~" - (number->string min) ",' " kind))) - (lambda (x) - (scm-format #f pat x))) - (let ((pat (string-append "~" kind))) - (lambda (x) - (scm-format #f pat x)))))) - (_ - (if min - (let ((c (string->list c))) - (if (and (member #\# c) - (match tp - ((or "x" "o" "X") #t) - (_ #f))) - (set! c (cons #\0 c))) - (let* ((kind (get-intkind tp)) - (padchar (if (member #\0 c) "0" " ")) - (pre (if (member #\+ c) - "~a" - (if (member #\0 c) - "~a" - (if (member #\space c) - "~a" - "")))) - (pos (if (member #\+ c) "+" - (if (member #\space c) - " " - padchar))) - (kpre (if (member #\# c) - (match tp - ("o" "0o") - ((or "x" "X") "0x") - (_ "")) - "")) - - (neg (if (or (member #\+ c) - (member #\space c) - (member #\0 c)) - "-" - "")) - (d (string-append - pre kpre "~" - (number->string - (- min - (if (= (string-length kpre) 0) 0 2) - (if (= (string-length pre ) 0) 0 1))) - ",'" - padchar - kind))) - (if (= (string-length pre) 0) - (lambda (x) - (if (and (number? x) (integer? x)) - (scm-format #f d x) - (raise - (ValueError "not a integer, format spec %d")))) - (lambda (x) - (if (and (number? x) (integer? x)) - (scm-format #f d (if (< x 0) neg pos) (abs x)) - (raise - (ValueError - "not a integer, format spec %d"))))))) - (let* ((kind (get-intkind tp)) - (pat (string-append "~" kind))) - (lambda (x) - (if (and (number? x) (integer? x)) - (scm-format #f pat x) - (raise - (ValueError "not a integer, format spec %d")))))))))))) - - -(define (analyze p) - (match p - ((#:% #f c #:* #:* _ tp) - (lambda (min prec x) - ((create c min prec tp) x))) - ((#:% #f c #:* prec _ tp) - (lambda (min x) - ((create c min prec tp) x))) - ((#:% #f c #:* prec _ tp) - (lambda (min x) - ((create c min prec tp) x))) - ((#:% #f c min #:* _ tp) - (lambda (prec x) - ((create c min prec tp) x))) - - ((#:% #f c min prec _ tp) - (create c min prec tp)) - ((#:% tag c min prec _ tp) - (let ((f (create c min prec tp))) - (lambda (x) - (f (pylist-ref x tag))))))) - - -(define (compile str) - (let* ((l (splitmm e str))) - (if (map? l) - (let lp ((l l)) - (match l - ((a p . l) - (let ((rest (lp l)) - (f (analyze p))) - (lambda (x) - (cons* a (f x) (rest x))))) - ((a) - (lambda (x) - (list a))) - (() - (lambda (x) - '())))) - - (let lp ((l l)) - (match l - ((a p . l) - (let ((rest (lp l)) - (n (get-n p)) - (f (analyze p))) - (case n - ((-1) - (lambda (x) - (cons* a "%" (rest x)))) - - ((0) - (lambda (x) - (cons* a (f (car x)) (rest (cdr x))))) - ((1) - (lambda (x) - (cons* a (f (car x) (cadr x)) (rest (cddr x))))) - ((2) - (lambda (x) - (cons* a (f (car x) (cadr x) (caddr x)) - (rest (cdddr x)))))))) - ((a) - (lambda (x) - (list a))) - (() - (lambda (x) - '()))))))) - -(define (id? x) - (or (pair? x) - (hash-table? x) - (is-a? x <py-hashtable>))) - -(define (format-- s l ha) - (set! l (if (id? l) l (list l))) - (aif it (hashq-ref ha s #f) - (string-join (it l) "") - (begin - (hashq-set! ha s (compile s)) - (format-- s l ha)))) - -(define (format- str l) - (string-join ((compile str) (if (id? l) l (list l))) "")) - -(define formatters (make-hash-table)) - -(define fnm 'formatter-map132) -(define-syntax format - (lambda (x) - (syntax-case x () - ((_ a b) - (let ((s (syntax->datum #'a))) - (if (string? s) - (let* ((mod (datum->syntax #'a (module-name (current-module)))) - (f (datum->syntax #'a fnm))) - - (if (not (module-defined? (current-module) fnm)) - (module-define! (current-module) fnm (make-hash-table))) - - (with-syntax ((u (list #'@@ mod f))) - #'(format-- a b u))) - #'(format- a b)))) - ((_ . _) - (error "wrong number of arguments to format")) - (_ - #'format-)))) - -(define-method (py-mod (s <string>) l) - (format s l)) diff --git a/modules/language/python/guilemod.scm b/modules/language/python/guilemod.scm deleted file mode 100644 index da1f5c7..0000000 --- a/modules/language/python/guilemod.scm +++ /dev/null @@ -1,261 +0,0 @@ -(define-module (language python guilemod) - #:export ()) - -(define-syntax-rule (mk-commands path mod-C define-C define-exp-C define-set-C) - (begin - (define mod-C (resolve-module 'path)) - (define-syntax-rule (define-C f val) - (begin - (define f val) - (module-define! mod-C 'f f))) - - (define-syntax-rule (define-exp-C f val) - (begin - (define f val) - (module-define! mod-C 'f val) - (module-export! mod-C (list 'f)))) - - (define-syntax-rule (define-set-C f val) - (module-set! mod-C 'f (let ((x val)) x))))) - -(mk-commands (system base compile) mod-C define-C define-exp-C define-set-C) -(mk-commands (system base message) mod-M define-M define-exp-M define-set-M) -(mk-commands (guile) mod-G define-G define-exp-G define-set-G) -(define-syntax-rule (C x) (@@ (system base compile) x)) -(define-syntax-rule (M x) (@@ (system base message) x)) - -(define-exp-C *do-extension-dispatch* #t) -(define-exp-C *extension-dispatches* '((("py" "python") . python) - (("pl" "prolog") . prolog))) -(define-exp-C %current-file% (make-fluid '(guile))) - -(define-C default-language - (lambda (file) - (define default ((C current-language))) - (if (C *do-extension-dispatch*) - (let ((ext (car (reverse (string-split file #\.))))) - (let lp ((l (C *extension-dispatches*))) - (if (pair? l) - (if (member ext (caar l)) - (let ((r (cdar l))) - (if ((C language?) default) - (if (eq? ((C language-name) default) r) - default - r) - r)) - (lp (cdr l))) - default))) - default))) - - -(define-exp-C %in-compile (make-fluid #f)) - -(define-set-C compile-file - (lambda* (file #:key - (output-file #f) - (from ((C default-language) file)) - (to 'bytecode) - (env ((C default-environment) from)) - (opts '()) - (canonicalization 'relative)) - - (with-fluids (((C %in-compile ) #t ) - ((M %dont-warn-list ) '() ) - ((C %file-port-name-canonicalization) canonicalization ) - ((C %current-file% ) file)) - - (let* ((comp (or output-file ((C compiled-file-name) file) - (error "failed to create path for auto-compiled file" - file))) - (in ((C open-input-file) file)) - (enc ((C file-encoding) in))) - ;; Choose the input encoding deterministically. - ((C set-port-encoding!) in (or enc "UTF-8")) - - ((C ensure-directory) ((C dirname) comp)) - ((C call-with-output-file/atomic) comp - (lambda (port) - (((C language-printer) ((C ensure-language) to)) - ((C read-and-compile) - in #:env env #:from from #:to to #:opts - (cons* #:to-file? #t opts)) - port)) - file) - comp)))) - -;; MESSAGE (Mute some variable warnings) -(define-exp-M %add-to-warn-list - (lambda (sym) - (fluid-set! (M %dont-warn-list) - (cons sym (fluid-ref (M %dont-warn-list)))))) - -(define-exp-M %dont-warn-list (make-fluid '())) -(define-set-M %warning-types - ;; List of known warning types. - (map (lambda (args) - (apply (M make-warning-type) args)) - - (let-syntax ((emit - (lambda (s) - (syntax-case s () - ((_ port fmt args ...) - (string? (syntax->datum #'fmt)) - (with-syntax ((fmt - (string-append "~a" - (syntax->datum - #'fmt)))) - #'(format port fmt - (fluid-ref (M *current-warning-prefix*)) - args ...))))))) - `((unsupported-warning ;; a "meta warning" - "warn about unknown warning types" - ,(lambda (port unused name) - (emit port "warning: unknown warning type `~A'~%" - name))) - - (unused-variable - "report unused variables" - ,(lambda (port loc name) - (emit port "~A: warning: unused variable `~A'~%" - loc name))) - - (unused-toplevel - "report unused local top-level variables" - ,(lambda (port loc name) - (emit port - "~A: warning: possibly unused local top-level variable `~A'~%" - loc name))) - - (unbound-variable - "report possibly unbound variables" - ,(lambda (port loc name) - (if (not (member name (fluid-ref (M %dont-warn-list)))) - (emit port - "~A: warning: possibly unbound variable `~A'~%" - loc name)))) - - (macro-use-before-definition - "report possibly mis-use of macros before they are defined" - ,(lambda (port loc name) - (emit port - "~A: warning: macro `~A' used before definition~%" - loc name))) - - (arity-mismatch - "report procedure arity mismatches (wrong number of arguments)" - ,(lambda (port loc name certain?) - (if certain? - (emit port - "~A: warning: wrong number of arguments to `~A'~%" - loc name) - (emit port - "~A: warning: possibly wrong number of arguments to `~A'~%" - loc name)))) - - (duplicate-case-datum - "report a duplicate datum in a case expression" - ,(lambda (port loc datum clause case-expr) - (emit port - "~A: warning: duplicate datum ~S in clause ~S of case expression ~S~%" - loc datum clause case-expr))) - - (bad-case-datum - "report a case datum that cannot be meaningfully compared using `eqv?'" - ,(lambda (port loc datum clause case-expr) - (emit port - "~A: warning: datum ~S cannot be meaningfully compared using `eqv?' in clause ~S of case expression ~S~%" - loc datum clause case-expr))) - - (format - "report wrong number of arguments to `format'" - ,(lambda (port loc . rest) - (define (escape-newlines str) - (list->string - (string-fold-right (lambda (c r) - (if (eq? c #\newline) - (append '(#\\ #\n) r) - (cons c r))) - '() - str))) - - (define (range min max) - (cond ((eq? min 'any) - (if (eq? max 'any) - "any number" ;; can't happen - (emit #f "up to ~a" max))) - ((eq? max 'any) - (emit #f "at least ~a" min)) - ((= min max) (number->string min)) - (else - (emit #f "~a to ~a" min max)))) - - ((M match) rest - (('simple-format fmt opt) - (emit port - "~A: warning: ~S: unsupported format option ~~~A, use (ice-9 format) instead~%" - loc (escape-newlines fmt) opt)) - (('wrong-format-arg-count fmt min max actual) - (emit port - "~A: warning: ~S: wrong number of `format' arguments: expected ~A, got ~A~%" - loc (escape-newlines fmt) - (range min max) actual)) - (('syntax-error 'unterminated-iteration fmt) - (emit port "~A: warning: ~S: unterminated iteration~%" - loc (escape-newlines fmt))) - (('syntax-error 'unterminated-conditional fmt) - (emit port "~A: warning: ~S: unterminated conditional~%" - loc (escape-newlines fmt))) - (('syntax-error 'unexpected-semicolon fmt) - (emit port "~A: warning: ~S: unexpected `~~;'~%" - loc (escape-newlines fmt))) - (('syntax-error 'unexpected-conditional-termination fmt) - (emit port "~A: warning: ~S: unexpected `~~]'~%" - loc (escape-newlines fmt))) - (('wrong-port wrong-port) - (emit port - "~A: warning: ~S: wrong port argument~%" - loc wrong-port)) - (('wrong-format-string fmt) - (emit port - "~A: warning: ~S: wrong format string~%" - loc fmt)) - (('non-literal-format-string) - (emit port - "~A: warning: non-literal format string~%" - loc)) - (('wrong-num-args count) - (emit port - "~A: warning: wrong number of arguments to `format'~%" - loc)) - (else - (emit port "~A: `format' warning~%" loc))))))))) - - - -(define pload - (let ((guile-load (@ (guile) primitive-load-path))) - (lambda (p . q) - (let ((tag (make-prompt-tag))) - (call-with-prompt - tag - (lambda () - (guile-load p (lambda () (abort-to-prompt tag)))) - (lambda (k) - (let lp ((l *extension-dispatches*)) - (if (pair? l) - (let lp2 ((u (caar l))) - (if (pair? u) - (let ((tag (make-prompt-tag))) - (call-with-prompt - tag - (lambda () - (guile-load (string-append p "." (car u)) - (lambda () (abort-to-prompt tag)))) - (lambda (k) (lp2 (cdr u))))) - (lp (cdr l)))))) - (if (pair? q) - ((car q)) - (error (string-append "no code for path " p))))))))) - - -(define-set-G primitive-load-path pload) diff --git a/modules/language/python/hash.scm b/modules/language/python/hash.scm deleted file mode 100644 index 423abb3..0000000 --- a/modules/language/python/hash.scm +++ /dev/null @@ -1,52 +0,0 @@ -(define-module (language python hash) - #:use-module (oop goops) - #:use-module (oop pf-objects) - #:export (py-hash complexity xy pyhash-N)) - -(define-syntax-rule (aif it p x y) (let ((it p)) (if it x y))) - -(define N #xefffffffffffffff) -(define pyhash-N N) - -(define-inlinable (xy v seed) - (modulo - (logxor seed - (+ v - #x9e3779b9 - (ash seed 6) - (ash seed -2))) - N)) - -(define complexity 10) - -;; The default is to use guile's hash function -(define-method (py-hash x) (hash x N)) - -(define-method (py-hash (x <pair>)) - (define i 0) - (let lp ((x x)) - (if (< i complexity) - (begin - (set! i (+ i 1)) - (if (pair? x) - (xy (lp (car x)) (lp (cdr x))) - (py-hash x))) - 0))) - -(define-method (py-hash (x <vector>)) - (let ((n (min complexity (vector-length x)))) - (let lp ((i 0) (s 0)) - (if (< i n) - (lp (+ i 1) - (xy (py-hash (vector-ref x i)) s)) - s)))) - -(define-method (py-hash (x <p>)) - (define (next) - (catch #t - (lambda () (next-method)) - (lambda x (hash x N)))) - - (aif it (ref-class x '__hash__ #f) - (it) - (next))) diff --git a/modules/language/python/list.scm b/modules/language/python/list.scm deleted file mode 100644 index c656edf..0000000 --- a/modules/language/python/list.scm +++ /dev/null @@ -1,1002 +0,0 @@ -(define-module (language python list) - #:use-module (ice-9 match) - #:use-module (ice-9 control) - #:use-module (oop pf-objects) - #:use-module (oop goops) - #:use-module (language python hash) - #:use-module (language python tuple) - #:use-module (language python exceptions) - #:use-module (language python yield) - #:use-module (language python for) - #:use-module (language python try) - #:use-module (language python bool) - #:use-module (language python exceptions) - #:use-module (language python persist) - #:re-export (pylist-ref pylist-set!) - #:export (to-list to-pylist <py-list> py-list - pylist-append! - pylist-slice pylist-subset! pylist-reverse! - pylist-pop! pylist-count pylist-extend! len in - pylist-insert! pylist-remove! pylist-sort! - pylist-index pylist-null pylist-delete! - pylist pylist-listing py-reversed - py-all py-any py-reversed)) - -(define scm-list list) - -(define-method (+ (x <null>) (y <pair>)) - (let lp ((l y)) - (if (pair? l) - (cons (car l) (lp (cdr l))) - '()))) - -(define-method (+ (x <pair>) (y <null>)) - (let lp ((l x)) - (if (pair? l) - (cons (car l) (lp (cdr l))) - '()))) - -(define-method (in x (y <null>)) #f) - -(define-syntax-rule (aif it p x y) (let ((it p)) (if it x y))) - -(define-class <py-list> () vec n) -(name-object <py-list>) - -(cpit <py-list> (o (lambda (o n l) - (slot-set! o 'n n) - (slot-set! o 'vec (list->vector l))) - ((@ (guile) list) - (slot-ref o 'n) - (vector->list (slot-ref o 'vec))))) - -(define (int x) x) - -(define-method (pylist-delete! (o <py-list>) k) - (let* ((n (slot-ref o 'n)) - (k (int k)) - (k (if (< k 0) (+ k n) k))) - (pylist-subset! o k (+ k 1) None pylist-null))) - -(define-method (pylist-delete! (o <p>) k) - (aif it (ref o '__delitem__) - (it k) - (next-method))) - -(define pylist-null - (let ((o (make <py-list>))) - (slot-set! o 'vec (make-vector 0)) - (slot-set! o 'n 0) - o)) - -(define-method (py-hash (o <py-list>)) - (let ((n (min complexity (slot-ref o 'n))) - (v (slot-ref o 'vec))) - (let lp ((i 0) (s 0)) - (if (< i n) - (lp (+ i 1) - (xy (py-hash (vector-ref v i)) s)) - s)))) - -(define-method (to-list x) - (for ((i : x)) ((r '())) - (cons i r) - #:final (reverse r))) - -(define-method (to-list (x <p>)) - (aif it (ref x '__tolist__) - (it) - (next-method))) - - -(defpair (to-list x) x) - -(define-method (to-list (x <yield>)) - (define l '()) - (catch StopIteration - (lambda () - (let lp () - (set! l (cons (next x) l)) - (lp))) - (lambda x - (reverse l)))) - -(define-method (to-list (x <py-list>)) - (let ((vec (slot-ref x 'vec)) - (n (slot-ref x 'n))) - (let lp ((i 0)) - (if (< i n) - (cons (vector-ref vec i) (lp (+ i 1))) - '())))) - -(define-method (to-pylist (l <py-list>)) - l) - -(defpair (to-pylist l) - (let* ((n (length l)) - (vec (make-vector (* 2 n))) - (o (make <py-list>))) - - (let lp ((l l) (i 0)) - (if (pair? l) - (begin - (vector-set! vec i (car l)) - (lp (cdr l) (+ i 1))))) - - (slot-set! o 'n n) - (slot-set! o 'vec vec) - o)) - -(define-method (to-pylist (l <vector>)) - (to-pylist (vector->list l))) - -(define-method (to-pylist (o <string>)) - (to-pylist (string->list o))) - -(define-method (bool (o <py-list>)) - (if (= (len o) 0) - #f - o)) -(define-method (bool (o <vector>)) - (if (= (len o) 0) - #f - o)) -(define-method (bool (o <string>)) - (if (= (len o) 0) - #f - o)) - -(define-method (to-pylist l) - (if (null? l) - (let ((o (make <py-list>))) - (slot-set! o 'vec (make-vector 4)) - (slot-set! o 'n 0) - o) - (error "not able to make a pylist"))) - -;;; REF -(define-method (pylist-ref (o <py-list>) nin) - (define N (slot-ref o 'n)) - (define n0 (int nin)) - (define n (if (< n0 0) (+ N n0) n0)) - (if (and (>= n 0) (< n (slot-ref o 'n))) - (vector-ref (slot-ref o 'vec) n) - (raise IndexError))) - -(defpair (pylist-ref o n) - (list-ref o (let ((n (int n))) (if (< n 0) (+ (length o) n) n)))) - -(define-method (pylist-ref (o <vector>) n) - (vector-ref o (let ((n (int n))) (if (< n 0) (+ (vector-length o) n) n)))) - -;;; SET -(define-method (pylist-set! (o <py-list>) nin val) - (define N (slot-ref o 'n)) - (define n0 (int nin)) - (define n (if (< n0 0) (+ N n0) n0)) - - (if (and (>= n 0) (< n (slot-ref o 'n))) - (vector-set! (slot-ref o 'vec) n val) - (raise IndexError))) - -(defpair (pylist-set! o n val) - (list-set! o (let ((n (int n))) (if (< n 0) (+ (length o) n) n)) val)) - -(define-method (pylist-set! (o <vector>) n val) - (vector-set! o (let ((n (int n))) (if (< n 0) (+ (length o) n) n)) val)) - - -;;SLICE -(define-method (pylist-slice (o <p>) . l) - (aif it (ref o '__getslice__) - (apply it l) - (next-method))) - -(define-method (pylist-slice (o <py-list>) n1 n2 n3) - (define N (slot-ref o 'n)) - (define (f n) - (let ((x (if (< n 0) (+ N n) n))) - (if (< x 0) - 0 - (if (> x N) - N - x)))) - (let* ((n1 (f (if (eq? n1 None) 0 n1))) - (n2 (f (if (eq? n2 None) (slot-ref o 'n) n2))) - (n3 (f (if (eq? n3 None) 1 n3))) - - (vec (slot-ref o 'vec)) - (l (let lp ((i n1)) - (if (< i n2) - (cons (vector-ref vec i) (lp (+ i n3))) - '())))) - (to-pylist l))) - -(define-method (pylist-slice (o <string>) n1 n2 n3) - (define N (string-length o)) - (define (f n) - (let ((x (if (< n 0) (+ N n) n))) - (if (< x 0) - 0 - (if (> x N) - N - x)))) - - (let* ((n1 (f (if (eq? n1 None) 0 n1))) - (n2 (f (if (eq? n2 None) (string-length o) n2))) - (n3 (f (if (eq? n3 None) 1 n3)))) - (list->string - (to-list - (pylist-slice (to-pylist o) n1 n2 n3))))) - - -(defpair (pylist-slice o n1 n2 n3) - (to-list - (pylist-slice (to-pylist o) n1 n2 n3))) - -(define-method (pylist-slice (o <vector>) n1 n2 n3) - (list->vector - (to-list - (pylist-slice (to-pylist o) n1 n2 n3)))) - -;;SUBSET -(define-method (pylist-subset! (o <p>) n1 n2 n3 val) - (aif it (ref o '__setslice__) - (it n1 n2 n3 val) - (next-method))) - -(define-method (pylist-subset! (o <py-list>) n1 n2 n3 val) - (define N (slot-ref o 'n)) - (define (f n) (if (< n 0) (+ N n) n)) - - (let* ((n1 (f (if (eq? n1 None) 0 n1))) - (n2 (f (if (eq? n2 None) (slot-ref o 'n) n2))) - (n3 (f (if (eq? n3 None) 1 n3))) - (vec (slot-ref o 'vec)) - (o2 (to-pylist val)) - (N2 (slot-ref o2 'n)) - (vec2 (slot-ref o2 'vec))) - (if (<= n2 N) - (let lp ((i 0) (j n1)) - (if (< j n2) - (if (< i N2) - (begin - (vector-set! vec j (vector-ref vec2 i)) - (lp (+ i 1) (+ j n3))) - (let lp ((j2 j)) - (if (< j2 n2) - (lp (+ j2 n3)) - (let lp ((k1 j) (k2 j2)) - (if (< k2 N) - (begin - (vector-set! vec k1 (vector-ref vec k2)) - (lp (+ k1 1) (+ k2 1))) - (begin - (let lp ((i k2)) - (if (< i N) - (begin - (vector-set! vec i #f) - (lp (+ i 1))) - (slot-set! o 'n k1))))))))))) - (raise IndexError)) - (values))) - - -;;APPEND -(define-method (pylist-append! (o <py-list>) val) - (let* ((n (slot-ref o 'n)) - (vec (slot-ref o 'vec)) - (N (vector-length vec))) - (if (< n N) - (vector-set! vec n val) - (let* ((N (* 2 N)) - (vec2 (make-vector N))) - (let lp ((i 0)) - (if (< i n) - (begin - (vector-set! vec2 i (vector-ref vec i)) - (lp (+ i 1))))) - (vector-set! vec2 n val) - (slot-set! o 'vec vec2))) - (slot-set! o 'n (+ n 1)) - (values))) - -(define-method (pylist-append! o n) - (raise 'NotSupportedOP '__append__)) - -(define-method (pylist-append! (o <p>) n . l) - (aif it (ref o 'append) - (apply it n l) - (next-method))) - - - -(define-method (write (o <py-list>) . l) - (define port (if (null? l) #t (car l))) - (let* ((l (to-list o))) - (if (null? l) - (format port "[]") - (format port "[~a~{, ~a~}]" (car l) (cdr l))))) - -(define-method (display (o <py-list>) . l) - (define port (if (null? l) #t (car l))) - - (let* ((l (to-list o))) - (if (null? l) - (format port "[]") - (format port "[~a~{, ~a~}]" (car l) (cdr l))))) - - -(define-method (+ (o1 <py-list>) (o2 <py-list>)) - (let* ((vec1 (slot-ref o1 'vec)) - (vec2 (slot-ref o2 'vec)) - (n1 (slot-ref o1 'n)) - (n2 (slot-ref o2 'n)) - (n (+ n1 n2)) - (vec (make-vector (* 2 n))) - (o (make <py-list>))) - - (let lp ((i1 0)) - (if (< i1 n1) - (begin - (vector-set! vec i1 (vector-ref vec1 i1)) - (lp (+ i1 1))) - (let lp ((i2 0) (i i1)) - (if (< i2 n2) - (begin - (vector-set! vec i (vector-ref vec2 i2)) - (lp (+ i2 1) (+ i 1))))))) - - (slot-set! o 'n n ) - (slot-set! o 'vec vec) - o)) - - -(define-method (+ (o1 <pair>) (o2 <pair>)) - (append o1 o2)) - -(define-method (+ (o1 <py-tuple>) o2) - (+ (slot-ref o1 'l) o2)) - -(define-method (+ o2 (o1 <py-tuple>)) - (+ o2 (slot-ref o1 'l))) - -(define-method (+ (o1 <string>) (o2 <string>)) - (string-append o1 o2)) - -(define-method (+ (o1 <symbol>) (o2 <symbol>)) - (string->symbol - (string-append - (symbol->string o1) - (symbol->string o2)))) - -(define-method (* (x <integer>) (o1 <py-list>)) (* o1 x)) -(define-method (* (o1 <py-list>) (x <integer>)) - (let* ((vec (slot-ref o1 'vec)) - (n (slot-ref o1 'n)) - (n2 (* n x)) - (vec2 (make-vector (* 2 n2))) - (o (make <py-list>))) - - (let lp1 ((i 0) (j 0)) - (if (< i x) - (let lp2 ((j j) (k 0)) - (if (< k n) - (begin - (vector-set! vec2 j (vector-ref vec k)) - (lp2 (+ j 1) (+ k 1))) - (lp1 (+ i 1) j))))) - - (slot-set! o 'n n2 ) - (slot-set! o 'vec vec2) - o)) - -(define-method (* (x <integer>) (vec <string>)) (* vec x)) -(define-method (* (vec <string>) (x <integer>)) - (let* ((n (string-length vec)) - (n2 (* n x)) - (vec2 (make-string n2))) - - (let lp1 ((i 0) (j 0)) - (if (< i x) - (let lp2 ((j j) (k 0)) - (if (< k n) - (begin - (string-set! vec2 j (string-ref vec k)) - (lp2 (+ j 1) (+ k 1))) - (lp1 (+ i 1) j))))) - vec2)) - -(define-method (* (x <integer> ) (l <pair>)) (* l x)) -(define-method (* (x <py-tuple>) l) (* (slot-ref x 'l) l)) -(define-method (* l (x <py-tuple>)) (* l (slot-ref x 'l))) -(define-method (* (l <pair>) (x <integer>)) - (let lp1 ((i 0)) - (if (< i x) - (let lp2 ((k l)) - (if (pair? k) - (cons (car k) (lp2 (cdr k))) - (lp1 (+ i 1)))) - '()))) - - -;;REVERSE -(define-method (pylist-reverse! (o <py-list>)) - (let* ((N (slot-ref o 'n)) - (M (- N 1)) - (n (floor-quotient N 2)) - (vec (slot-ref o 'vec))) - (let lp ((i 0)) - (if (< i n) - (let ((swap (vector-ref vec i)) - (k (- M i))) - (vector-set! vec i (vector-ref vec k)) - (vector-set! vec k swap) - (lp (+ i 1))))))) - - -(define-method (pylist-reverse! (o <p>) . l) - (aif it (ref o 'reverse) - (apply it l) - (next-method))) - -;;POP! -(define-method (pylist-pop! (o <py-list>) . l) - (let ((index (if (null? l) - #f - (car l)))) - (if index - (let ((x (pylist-ref o index))) - (pylist-delete! o index) - x) - (let* ((n (slot-ref o 'n)) - (m (- n 1)) - (vec (slot-ref o 'vec))) - (if (> n 0) - (let ((ret (vector-ref vec m))) - (slot-set! o 'n m) - (vector-set! vec m #f) - ret) - (raise IndexError "pop from empty list")))))) - -(define-method (pylist-pop! (o <p>) . l) - (aif it (ref o 'pop) - (apply it l) - (next-method))) - -;;COUNT -(define-method (pylist-count (o <py-list>) q) - (let* ((n (slot-ref o 'n)) - (vec (slot-ref o 'vec))) - (let lp ((i 0) (sum 0)) - (if (< i n) - (if (equal? (vector-ref vec i) q) - (lp (+ i 1) (+ sum 1)) - (lp (+ i 1) sum )) - sum)))) - -(define-method (pylist-count (s <string>) q) - (let* ((n (string-length s)) - (q (if (and (string? q) (= (string-length q) 1)) - (string-ref q 0)))) - (let lp ((i 0) (sum 0)) - (if (< i n) - (if (eq? (string-ref s i) q) - (lp (+ i 1) (+ sum 1)) - (lp (+ i 1) sum )) - sum)))) - -(defpair (pylist-count l q) - (let lp ((l l) (sum 0)) - (if (pair? l) - (if (eq? (car l) q) - (lp (cdr l) (+ sum 1)) - (lp (cdr l) sum )) - sum))) - -(define-method (pylist-count (o <p>) . l) - (aif it (ref o 'count) - (apply it l) - (next-method))) - -;; extend! -(define-method (pylist-extend! (o <py-list>) iter) - (for ((x : iter)) () - (pylist-append! o x))) - -(define-method (pylist-extend! (o <p>) . l) - (aif it (ref o 'extend) - (apply it l) - (next-method))) - -;; equal? -(define-method (py-equal? (o1 <py-list>) (o2 <py-list>)) - (equal o1 o2)) - -(define (equal o1 o2) - (let ((n1 (slot-ref o1 'n)) - (n2 (slot-ref o2 'n)) - (vec1 (slot-ref o1 'vec)) - (vec2 (slot-ref o2 'vec))) - (and - (equal? n1 n2) - (let lp ((i 0)) - (if (< i n1) - (and (equal? (vector-ref vec1 i) (vector-ref vec2 i)) - (lp (+ i 1))) - #t))))) - -(define-class <py-seq-iter> () o i n d) -(define-class <py-list-iter> (<py-list>) i d) - -(name-object <py-seq-iter>) -(name-object <py-list-iter>) - -(cpit <py-list-iter> (o (lambda (o i d) - (slot-set! o 'i i) - (slot-set! o 'd d)) - (list - (slot-ref o 'i) - (slot-ref o 'd)))) - -(cpit <py-seq-iter> (o (lambda (o oo i n d) - (slot-set! o 'o oo) - (slot-set! o 'i i) - (slot-set! o 'n i) - (slot-set! o 'd d)) - (list - (slot-ref o 'o) - (slot-ref o 'i) - (slot-ref o 'n) - (slot-ref o 'd)))) - - - -(define-method (write (o <py-list-iter>) . l) - (define port (if (null? l) #t (car l))) - (for ((x : o)) ((l '())) - (cons x l) - #:final - (let ((l (reverse l))) - (if (null? l) - (format port "iter[]") - (format port "iter[~a~{, ~a~}]" (car l) (cdr l)))))) - -(define-method (write (o <py-seq-iter>) . l) - (define port (if (null? l) #t (car l))) - (for ((x : o)) ((l '())) - (cons x l) - #:final - (let ((l (reverse l))) - (if (null? l) - (format port "iter[]") - (format port "iter[~a~{, ~a~}]" (car l) (cdr l)))))) - - -;;WRAP-IN -(define-method (wrap-in (o <py-list>)) - (let ((out (make <py-list-iter>))) - (slot-set! out 'n (slot-ref o 'n )) - (slot-set! out 'vec (slot-ref o 'vec)) - (slot-set! out 'i 0) - (slot-set! out 'd 1) - out)) - -(define-method (wrap-in (o <vector>)) - (let ((out (make <py-list-iter>))) - (slot-set! out 'n (vector-length o)) - (slot-set! out 'vec o) - (slot-set! out 'i 0) - (slot-set! out 'd 1) - out)) - -(define-method (py-reversed (o <py-list>)) - (let ((out (make <py-list-iter>))) - (slot-set! out 'i (- (slot-ref o 'n) 1)) - (slot-set! out 'vec (slot-ref o 'vec)) - (slot-set! out 'n (slot-ref o 'n)) - (slot-set! out 'd -1) - out)) - -(define-method (py-reversed (o <p>)) - (aif it (ref o '__reversed__) - (it) - (let ((a (ref o '__getitem__)) - (n (ref o '__len__))) - (if (and a n) - (let ((ret (make <py-seq-iter>))) - (slot-set! ret 'o a) - (slot-set! ret 'i (n)) - (slot-set! ret 'n -1) - (slot-set! ret 'd -1)) - (next-method))))) - -(define-method (wrap-in (o <p>)) - (aif it (ref o '__iter__) - (let ((x (it))) - (cond - ((pair? x) - (wrap-in x)) - (else - x))) - (let ((a (ref o '__getitem__))) - (if a - (let ((ret (make <py-seq-iter>))) - (slot-set! ret 'o a) - (slot-set! ret 'i 0) - (slot-set! ret 'n -1) - (slot-set! ret 'd 1)) - (next-method))))) - - -(define-method (wrap-in (o <py-list-iter>)) o) - -(define-method (wrap-in (o <py-seq-iter>)) o) - -(define-method (wrap-in (o <py-seq-iter> )) o) - -;;NEXT -(define-method (next (o <py-seq-iter>)) - (let ((i (slot-ref o 'i)) - (d (slot-ref o 'd)) - (a (slot-ref o 'a))) - (let ((r (a i))) - (slot-set! o 'i (+ i d)) - r))) - -(define-method (next (o <py-list-iter>)) - (let ((i (slot-ref o 'i )) - (d (slot-ref o 'd)) - (n (slot-ref o 'n )) - (vec (slot-ref o 'vec))) - (if (> d 0) - (if (< i n) - (let ((ret (vector-ref vec i))) - (slot-set! o 'i (+ i 1)) - ret) - (throw StopIteration)) - (if (>= i 0) - (let ((ret (vector-ref vec i))) - (slot-set! o 'i (- i 1)) - ret) - (throw StopIteration))))) - -;;INSERT -(define-method (pylist-insert! (o <py-list>) i val) - (let* ((vec (slot-ref o 'vec)) - (n (slot-ref o 'n)) - (i (if (< i 0) (+ n i) i))) - (if (and (>= i 0) (<= i n)) - (let lp ((v val) (i i)) - (if (< i n) - (let ((swap (vector-ref vec i))) - (vector-set! vec i v) - (lp swap (+ i 1))) - (pylist-append! o v))) - (raise IndexError "Wrong index in insert")))) - -(define-method (pylist-insert! (o <p>) . l) - (aif it (ref o 'insert) - (apply it l) - (next-method))) - - -;;REMOVE -(define-method (pylist-remove! (o <py-list>) val) - (let ((n (slot-ref o 'n )) - (vec (slot-ref o 'vec))) - (let lp ((i 0)) - (if (< i n) - (let ((r (vector-ref vec i))) - (if (equal? r val) - (pylist-subset! o i (+ i 1) 1 '()) - (lp (+ i 1)))) - (raise ValueError "list removal has no element to remove"))))) - -(define-method (pylist-remove! (o <p>) . l) - (aif it (ref o 'remove) - (apply it l) - (next-method))) - -;; SORT! -(define (id x) x) -(define (sort- it key reverse) - (catch #t - (lambda () - (for ((x : it)) ((l '()) (i 0)) - (values (cons ((@ (guile) list) (key x) i x) l) - (+ i 1)) - - #:final - (begin - (let lp ((l (sort (reverse! l) (if reverse > <))) - (i 0)) - (if (pair? l) - (let ((x (car l))) - (pylist-set! it i (caddr x)) - (lp (cdr l) (+ i 1)))))))) - (lambda x (raise (TypeError "problem in sorting layout"))))) - -(define-method (pylist-sort! (o <py-list>) . l) - (apply - (lambda* (#:key (key id) (reverse #f)) - (sort- o key reverse)) - l)) - -(define-method (pylist-sort! (o <p>) . l) - (aif it (ref o 'sort) - (apply it l) - (next-method))) - -;; INDEX -(define-method (pylist-index (o <py-list>) val . l) - (let* ((n (slot-ref o 'n )) - (vec (slot-ref o 'vec)) - (f (lambda (m) (if (< m 0) (+ m n) m)))) - (call-with-values - (lambda () - (match l - (() - (values 0 n)) - ((x) - (values (f x) n)) - ((x y) - (values (f x) (f y))))) - (lambda (n1 n2) - (if (and (>= n1 0) (>= n2 0) (< n1 n) (<= n2 n)) - (let lp ((i n1)) - (if (< i n2) - (let ((r (vector-ref vec i))) - (if (equal? r val) - i - (lp (+ i 1)))) - (raise ValueError "could not find value in index fkn"))) - (raise IndexError "index out of scop in index fkn")))))) - -(define-method (pylist-index (o <string>) val . l) - (let* ((n (string-length o)) - (f (lambda (m) (if (< m 0) (+ m n) m))) - (val (if (and (string? val) (> (string-length val) 0)) - (string-ref val 0) - val))) - (call-with-values - (lambda () - (match l - (() - (values 0 n)) - ((x) - (values (f x) n)) - ((x y) - (values (f x) (f y))))) - (lambda (n1 n2) - (if (and (>= n1 0) (>= n2 0) (< n1 n) (<= n2 n)) - (let lp ((i n1)) - (if (< i n2) - (let ((r (string-ref o i))) - (if (equal? r val) - i - (lp (+ i 1)))) - (raise ValueError "could not find value in index fkn"))) - (raise IndexError "index out of scop in index fkn")))))) - -(defpair (pylist-index o val . l) - (let* ((n (length o)) - (f (lambda (m) (if (< m 0) (+ m n) m)))) - (call-with-values - (lambda () - (match l - (() - (values 0 n)) - ((x) - (values (f x) n)) - ((x y) - (values (f x) (f y))))) - (lambda (n1 n2) - (if (and (>= n1 0) (>= n2 0) (< n1 n) (<= n2 n)) - (let lp ((i o)) - (if (pair? i) - (let ((r (car i))) - (if (equal? r val) - i - (lp (cdr i)))) - (raise ValueError "could not find value in index fkn"))) - (raise IndexError "index out of scop in index fkn")))))) - -(define-method (pylist-index (o <p>) . l) - (aif it (ref o 'index) - (apply it l) - (next-method))) - - -;; len - - -(defpair (len l) (length l)) -(define-method (len x) - (if (null? x) - 0 - (error "not a suitable lengthof" x))) -(define-method (len (v <vector>)) (vector-length v)) -(define-method (len (s <string>)) (string-length s)) -(define-method (len (o <py-list>)) (slot-ref o 'n)) -(define-method (len (o <p>)) - (aif it (ref o '__len__) - (it) - (next-method))) - -(define (bo x) (if x #t #f)) -(define-method (in x (l <py-tuple>)) (bo (member x (slot-ref l 'l)))) -(define-method (in x (l <pair>)) (bo (member x l))) -(define-method (in x (l <vector>)) - (define n (vector-length l)) - (let lp ((i 0)) - (if (< i n) - (if (equal? x (vector-ref l i)) - #t - (lp (+ i 1))) - #f))) - -(define-method (in (x <string>) (s <string>)) - (string-contains s x)) - -(define-method (in (x <char>) (s <string>)) - (let/ec ret - (string-for-each - (lambda (ch) - (if (eq? ch x) - (ret #t))) - s)) - #f) - -(define-method (in x (o <py-list>)) - (define l (slot-ref o 'vec)) - (define n (slot-ref o 'n)) - (let lp ((i 0)) - (if (< i n) - (if (equal? x (vector-ref l i)) - #t - (lp (+ i 1))) - #f))) - -(define-method (in x (o <p>)) - (aif it (ref o '__contains__) - (it x) - (next-method))) - -(define-syntax-rule (defgen (op r s o1 o2) code ...) - (begin - (define-method (op (o1 <py-list>) (o2 <py-list>)) code ...) - (define-method (op (o1 <pair>) (o2 <pair> )) code ...) - (define-method (op (o1 <py-tuple>) o2) - (op (slot-ref o1 'l) o2)) - (define-method (op o2 (o1 <py-tuple>)) - (op o2 (slot-ref o1 'l))) - (define-method (op (o1 <vector>) (o2 <vector>)) code ...) - (define-method (op (o1 <p>) o2) - (aif it (ref o1 'r) - (it o2) - (next-method))) - (define-method (op o1 (o2 <p>)) - (aif it (ref o2 's) - (it o1) - (next-method))))) - -(defgen (< __le__ __gt__ o1 o2) - (let ((n1 (len o1)) - (n2 (len o2))) - (for ((x1 : o1) (x2 : o2)) () - (if (< x1 x2) - (break #t)) - (if (> x1 x2) - (break #f)) - #:final - (< n1 n2)))) - -(defgen (<= __lt__ __ge__ o1 o2) - (let ((n1 (len o1)) - (n2 (len o2))) - (for ((x1 : o1) (x2 : o2)) () - (if (< x1 x2) - (break #t)) - (if (> x1 x2) - (break #f)) - - #:final - (<= n1 n2)))) - -(defgen (> __ge__ __lt__ o1 o2) - (let ((n1 (len o1)) - (n2 (len o2))) - (for ((x1 : o1) (x2 : o2)) () - (if (> x1 x2) - (break #t)) - (if (< x1 x2) - (break #f)) - - #:final - (> n1 n2)))) - -(defgen (>= __gt__ __le__ o1 o2) - (let ((n1 (len o1)) - (n2 (len o2))) - (for ((x1 : o1) (x2 : o2)) () - (if (> x1 x2) - (break #t)) - (if (< x1 x2) - (break #f)) - - #:final - (>= n1 n2)))) - -(define-python-class list (<py-list>) - (define __init__ - (letrec ((__init__ - (case-lambda - ((self) - (slot-set! self 'vec (make-vector 30)) - (slot-set! self 'n 0)) - ((self it) - (__init__ self) - (for ((i : it)) () (pylist-append! self i)))))) - __init__))) - -(name-object list) - -(define pylist list) - -(define-method (py-class (o <py-list>) list)) - -(define (pylist-listing) - (let ((l - (to-pylist - (map symbol->string - '(append - count - extend - index - pop - insert - remove - reverse - sort - __init__ - __le__ - __lt__ - __gt__ - __ge__ - __ne__ - __eq__ - __len__ - __init__ - __add__ - __mul__ - __rmul__ - __radd__ - __repr__ - __contains__ - __getattr__ - __setattr__ - __delattr__ - __delitem__ - __setitem__ - __iter__ - ))))) - - (pylist-sort! l) - l)) - -(define (py-all x) - (for ((i : x)) () - (if (not i) - (break #f)) - #:final - #t)) - -(define (py-any . x) - (for ((i : x)) () - (if i - (break #t)) - #:final - #f)) - -(define py-list list) diff --git a/modules/language/python/module.scm b/modules/language/python/module.scm deleted file mode 100644 index 49a4366..0000000 --- a/modules/language/python/module.scm +++ /dev/null @@ -1,356 +0,0 @@ -(define-module (language python module) - #:use-module (oop pf-objects) - #:use-module (oop goops) - #:use-module (ice-9 match) - #:use-module (system syntax) - #:use-module (language python exceptions) - #:use-module (language python yield) - #:use-module (language python try) - #:use-module (language python dir) - #:use-module (language python list) - #:use-module (language python dict) - #:export (Module private public import __import__ modules)) - -(define-syntax-rule (aif it p . x) (let ((it p)) (if it . x))) - -(define-syntax-rule (in-scheme x) - (let ((lan (current-language))) - (dynamic-wind - (lambda () (current-language 'scheme)) - (lambda () x) - (lambda () (current-language lan))))) - -(define (private mod) - ((ref mod '__setprivate__) #t)) -(define (public mod) - ((ref mod '__setprivate__) #f)) - -(define e (list 'e)) - -(define _k - (lambda (k) - (if (string? k) - (string->symbol k) - k))) - -(define _m - (lambda (self) - (if (rawref self '_private) - (rawref self '_module) - (rawref self '_export)))) - -(define (globals self) - (aif it (rawref self '_export) - it - (rawref self '_module))) - -(define-python-class Module () - (define _modules (make-hash-table)) - (define __setprivate__ - (lambda (self p) - (rawset self '_private p))) - - (define _cont - (lambda (self id pre l nm skip-error?) - (if id - (aif it (rawref self id) - (begin - ((ref it '__init__) pre l nm)) - - (begin - (rawset self id (Module pre l nm)) - (_make self pre nm skip-error?))) - (aif it (and (module-defined? (current-module) (car nm)) - (module-ref (current-module) (car nm))) - (if (module? it) - (begin - ((rawref it '__init__) pre l nm) - it) - (begin - (_make self pre nm skip-error?))) - (begin - (_make self pre nm skip-error?)))))) - - (define _contupdate - (lambda (self id pre l nm) - (if id - (aif it (rawref self id) - ((ref it '__update__) pre l nm) - (rawset self id (Module pre l nm))) - #f))) - - (define __init__ - (case-lambda - ((self pre l nm) - (match l - ((name) - (rawset self '_path (reverse (cons name pre))) - (_cont self #f (cons name pre) #f (cons name nm) #f)) - - ((name . (and l (name2 . _))) - (rawset self '_path (reverse (cons name pre))) - (_cont self name2 (cons name pre) l (cons name nm) #t)))) - - - ((self l nm) - (_cont self #f l #f nm #f)) - - ((self l) - (if (pair? l) - (if (and (> (length l) 3) - (equal? (list (list-ref l 0) - (list-ref l 1) - (list-ref l 2)) - '(language python module))) - (__init__ self (reverse '(language python module)) (cdddr l) - '()) - (__init__ self '() (reverse l) '())) - (__init__ self - (append - '(language python module) - (map string->symbol - (string-split l #\.)))))))) - - (define __update__ - (case-lambda - ((self pre l nm) - (match l - ((name) - (_contupdate self #f (cons name pre) #f (cons name nm))) - - ((name . (and l (name2 . _))) - (_contupdate self name2 (cons name pre) l (cons name nm))))) - - - ((self l nm) - (_contupdate self #f l #f nm)) - - ((self l) - (if (pair? l) - (if (and (> (length l) 3) - (equal? (list (list-ref l 0) - (list-ref l 1) - (list-ref l 2)) - '(language python module))) - (__update__ self (reverse '(language python module)) - (cdddr l) '())) - (__update__ self - (map string->symbol - (string-split l #\.))))))) - - (define _make - (lambda (self l nm skip-error?) - (rawset self '_private #t) - (if (not (rawref self '_module)) - (begin - (rawset self '__name__ (string-join - (map symbol->string (reverse nm)) ".")) - (let* ((_module (in-scheme (resolve-module (reverse l)))) - (public-i (and _module (module-public-interface _module)))) - (if (and (not skip-error?) (not public-i)) - (raise (ModuleNotFoundError - (format #f "No module named ~a" - (rawref self '__name__))))) - - (rawset self '_export (module-public-interface _module)) - (rawset self '_module _module) - (hash-set! _modules l self)))))) - - (define __getattribute__ - (lambda (self k) - (define (fail) - (raise (AttributeError "getattr in Module"))) - (let ((k (_k k))) - (cond - ((memq k '(__iter__ __repr__ __dir__)) - (lambda () ((rawref self k) self))) - (else - (let ((x (aif it (rawref self '_export) - (module-ref it k e) - e))) - (if (eq? e x) - (let ((x (aif it (_m self) - (module-ref it k e) - e))) - (if (eq? e x) - (let ((x (rawref self k e))) - (if (eq? e x) - (fail) - x)) - x)) - x))))))) - - (define __setattr__ - (lambda (self k v) - (let ((k (_k k)) - (fail (lambda () (raise KeyError "setattr in Module" k)))) - (if (rawref self k) - (fail) - (aif m (rawref self '_module) - (catch #t - (lambda () - (if (module-defined? m k) - (module-set! m k v) - (module-define! m k v))) - (lambda x (fail))) - (fail)))))) - - (define __global_setitem__ - (lambda (self k v) - (let ((k (_k k)) - (fail (lambda () (raise KeyError "setattr in Module" k)))) - (aif m (rawref self '_module) - (catch #t - (lambda () - (if (module-defined? m k) - (module-set! m k v) - (begin - (module-define! m k v) - (module-export! m (list k))))) - (lambda x (fail))) - (fail))))) - - (define __global_getitem__ - (lambda (self k) - (let ((k (_k k)) - (fail (lambda () (raise KeyError "global setattr in Module" k)))) - (aif m (rawref self '_export) - (catch #t - (lambda () - (if (module-defined? m k) - (module-ref m k) - (fail))) - (lambda x (fail))) - (fail))))) - - (define __global_get__ - (lambda (self k . es) - (let ((k (_k k)) - (fail (lambda () (raise KeyError "global setattr in Module" k)))) - (aif m (rawref self '_export) - (catch #t - (lambda () - (if (module-defined? m k) - (module-ref m k) - (if (pair? es) (car es) #f))) - (lambda x (fail))) - (fail))))) - - (define __delattr__ - (lambda (self k) - (define (fail) (raise KeyError "delattr in Module")) - (aif m (rawref self '_module) - (let ((k (_k k))) - (if (module-defined? m k) - (module-remove! m k) - (raise KeyError "delattr of missing key in Module"))) - (fail)))) - - (define __dir__ - (lambda (self) - (let* ((h (slot-ref self 'h)) - (l '()) - (m (_m self)) - (add (lambda (k . u) - (if (not (in "-" (symbol->string k))) - (set! l (cons (symbol->string k) l)))))) - (hash-for-each add h) - (if m (module-for-each add m)) - (aif it (rawref self '_export) (module-for-each add it)) - (hash-for-each add (slot-ref self 'h)) - (py-list l)))) - - - (define __iter__ - (lambda (self) - (let* ((h (slot-ref self 'h)) - (l '()) - (m (_m self)) - (add (lambda (k v) - (let ((k (symbol->string k))) - (if (and (not (in "-" k)) (variable-bound? v)) - (set! l (cons (list k (variable-ref v)) - l))))))) - (module-for-each add m) - (module-for-each add (rawref self '_export)) - l))) - - (define __global_iter__ - (lambda (self) - (let* ((m (globals self)) - (l '()) - (add (lambda (k v) - (let ((k (symbol->string k))) - (if (and (not (in "-" k)) (variable-bound? v)) - (set! l (cons (list k (variable-ref v)) - l))))))) - (module-for-each add m) - l))) - - - - (define __repr__ - (lambda (self) (format #f "Module(~a)" (rawref self '__name__)))) - - (define __getitem__ - (lambda (self k) - (define k (if (string? k) (string->symbol k) k)) - (__getattribute__ self k)))) - - -(define-syntax import - (lambda (x) - (syntax-case x () - ((_ (a ...) var) - #`(import-f #,(case (syntax-local-binding #'var) - ((lexical) - #'var) - ((global) - #'(if (module-defined? (current-module) - (syntax->datum #'var)) - var - #f)) - (else - #f)) a ...))))) - -(define (m? x) ((@ (language python module _python) isinstance) x Module)) -(define (import-f x f . l) - (if x - (if (m? x) - (begin (apply (rawref x '__update__) x l) x) - (apply f l)) - (apply f l))) - -(define-python-class ms (dict) - (define __getitem__ - (lambda (self k) - (if (string? k) - (aif it (py-get (slot-ref self 't) k #f) - it - (let* ((l (map string->symbol (string-split k #\.))) - (pth (cons* 'language 'python 'module l))) - (Module (reverse pth) (reverse l)))) - (pylist-ref (slot-ref self 't) k)))) - - (define get - (lambda* (self k #:optional (e #f)) - (if (string? k) - (aif it (py-get (slot-ref self 't) k #f) - it - (let* ((l (map string->symbol (string-split k #\.))) - (pth (cons* 'language 'python 'module l))) - (Module (reverse pth) (reverse l)))) - (py-get (slot-ref self 't) k e))))) - - - -(define modules (ms)) -(define (__import__ x) - (let ((x (py-get modules x #f))) - (if x - (values) - (let ((e (Module x))) - (pylist-set! modules x e) - e)))) - -(set! (@@ (oop pf-objects) Module) Module) diff --git a/modules/language/python/module/_blake2b.scm b/modules/language/python/module/_blake2b.scm deleted file mode 100644 index dd24634..0000000 --- a/modules/language/python/module/_blake2b.scm +++ /dev/null @@ -1,10 +0,0 @@ -(define-module (language python module _blake2b) - #:use-module (language python checksum) - #:use-module (oop pf-objects) - #:export (blake2b)) - -(define-python-class blake2b (Summer) - (define name "blake2b") - (define digest_size 64) - - (define _command "/usr/bin/blake2bsum")) diff --git a/modules/language/python/module/_blake2s.scm b/modules/language/python/module/_blake2s.scm deleted file mode 100644 index 659dae0..0000000 --- a/modules/language/python/module/_blake2s.scm +++ /dev/null @@ -1,10 +0,0 @@ -(define-module (language python module _blake2s) - #:use-module (language python checksum) - #:use-module (oop pf-objects) - #:export (blake2s)) - -(define-python-class blake2s (Summer) - (define name "blake2s") - (define digest_size 32) - - (define _command "/usr/bin/blake2ssum")) diff --git a/modules/language/python/module/_csv.scm b/modules/language/python/module/_csv.scm deleted file mode 100644 index 5ac6159..0000000 --- a/modules/language/python/module/_csv.scm +++ /dev/null @@ -1,614 +0,0 @@ -(define-module (language python module _csv) - #:use-module (ice-9 control) - #:use-module (oop pf-objects) - #:use-module (language python list) - #:use-module (language python def) - #:use-module (language python yield) - #:use-module (language python for) - #:use-module (language python string) - #:use-module (language python exceptions) - #:export (QUOTE_ALL QUOTE_MINIMAL QUOTE_NONNUMERIC QUOTE_NONE - reader writer Error field_size_limit - get_dialect register_dialect unregister_dialect - list_dialects __doc__ Dialect __version__)) - -(define __version__ "1.0") - -(define-syntax-rule (aif it p . l) (let ((it p)) (if it . l))) - -(define-python-class Error (Exception)) - -(define-python-class Dialect () - (define __init__ - (lambda (self . x) - #f))) - -(define *field-size* (make-fluid 131072)) -(define field_size_limit - (case-lambda - (() (fluid-ref *field-size*)) - ((x) (fluid-set! *field-size* x)))) - -(define *dialects* (make-hash-table)) -(define register_dialect - (lam (nm (= val None) (** keyw)) - (let ((newval (Dialect))) - (define-syntax-rule (set- x y z key default) - (set x 'key (hash-ref z (symbol->string 'key) - (if (eq? y None) - default - (ref y 'key default))))) - (define-syntax-rule (setter x y z ((k def) ...)) - (begin (set- x y z k def) ...)) - - (setter newval val keyw - ((delimiter ",") - (doublequote #t) - (escapechar None) - (lineterminator "\r\n") - (quotechar "\"") - (quoting 'minimal) - (skipinitialspace #f) - (strict #f))) - - (hash-set! *dialects* nm newval)))) - -(define (get_dialect nm) - (hash-ref *dialects* nm None)) -(define (unregister_dialect nm) - (hash-remove! *dialects* nm)) - -(define (list_dialects) - (let ((ret '())) - (hash-for-each - (lambda (k v) - (set! ret (cons k ret))) - *dialects*) - (py-list ret))) - -(define __doc__ -"CSV parsing and writing. - -This module provides classes that assist in the reading and writing -of Comma Separated Value (CSV) files, and implements the interface -described by PEP 305. Although many CSV files are simple to parse, -the format is not formally defined by a stable specification and -is subtle enough that parsing lines of a CSV file with something -like line.split(\",\") is bound to fail. The module supports three\n -basic APIs: reading, writing, and registration of dialects. - - -DIALECT REGISTRATION: - -Readers and writers support a dialect argument, which is a convenient -handle on a group of settings. When the dialect argument is a string, -it identifies one of the dialects previously registered with the module. -If it is a class or instance, the attributes of the argument are used as -the settings for the reader or writer: - - class excel: - delimiter = ',' - quotechar = '\"' - escapechar = None - doublequote = True - skipinitialspace = False - lineterminator = '\\r\\n' - quoting = QUOTE_MINIMAL - -SETTINGS: - - * quotechar - specifies a one-character string to use as the - quoting character. It defaults to '\"'. - * delimiter - specifies a one-character string to use as the - field separator. It defaults to ','. - * skipinitialspace - specifies how to interpret whitespace which - immediately follows a delimiter. It defaults to False, which - means that whitespace immediately following a delimiter is part - of the following field. - * lineterminator - specifies the character sequence which should - terminate rows. - * quoting - controls when quotes should be generated by the writer. - It can take on any of the following module constants: - - csv.QUOTE_MINIMAL means only when required, for example, when a - field contains either the quotechar or the delimiter - csv.QUOTE_ALL means that quotes are always placed around fields. - csv.QUOTE_NONNUMERIC means that quotes are always placed around - fields which do not parse as integers or floating point - numbers. - csv.QUOTE_NONE means that quotes are never placed around fields. - * escapechar - specifies a one-character string used to escape - the delimiter when quoting is set to QUOTE_NONE. - * doublequote - controls the handling of quotes inside fields. When - True, two consecutive quotes are interpreted as one during read, - and when writing, each quote character embedded in the data is - written as two quotes") - -(define QUOTE_ALL 'all) -(define QUOTE_MINIMAL 'minimal) -(define QUOTE_NONNUMERIC 'nonnumeric) -(define QUOTE_NONE 'none) - -(define e (list 'fail)) - -(define-syntax-rule (bif it p a b) - (let ((it p)) - (if (eq? it e) - b - a))) - -(define-syntax-rule (chr a b c) - (let ((x - (bif it a - it - (bif it b - it - c)))) - (if (string? x) - (string-ref x 0) - #f))) - -(define-syntax-rule (oor a b c) - (bif it a - it - (bif it b - it - c))) - -(define-syntax-rule (str a b c) (oor a b c)) - -(def (reader csvfile (= dialect "excel") (** fmtparams)) - (let* - ((dialect (get_dialect dialect)) - - (delimiter (chr (py-get fmtparams "delimiter" e) - (ref dialect 'Delimiter e) - ",")) - - (doublequote (oor (py-get fmtparams "doublequote" e) - (ref dialect 'doublequote e) - #t)) - - (escapechar (chr (py-get fmtparams "escapechar" e) - (ref dialect 'escapechar e) - None)) - - (lineterminator (str (py-get fmtparams "lineterminator" e) - (ref dialect 'lineterminator e) - "\r\n")) - - (quotechar (chr (py-get fmtparams "quotechar" e) - (ref dialect 'quotechar e) - "\"")) - - (quoting (oor (py-get fmtparams "quoting" e) - (ref dialect 'quoting e) - QUOTE_MINIMAL)) - - (skipispace (oor (py-get fmtparams "skipinitialspace" e) - (ref dialect 'skipinitialspace e) - #t)) - - (strict (oor (py-get fmtparams "strict" e) - (ref dialect 'strict e) - #f))) - ((make-generator () - (lambda (yield) - (let/ec ret - (let ((iter (wrap-in csvfile))) - (let lp0 ((state 'start) (r '()) (l '())) - (define-syntax-rule (raise- s) (if strict (raise s))) - (define-syntax-rule (mk-wrap wrap state) - (define (wrap r) - (let* ((x (list->string (reverse r))) - (x (if (eq? state 'numeric) - (string->number x) - x))) - x))) - (mk-wrap wrap1 state) - (let ((s (catch #t (lambda () (next iter)) - (lambda x - (cond - ((or (eq? state 'line-end) - (eq? state 'start)) - (ret (reverse l))) - - ((eq? state 'field-end) - (ret (reverse (cons (wrap1 r) l)))) - - ((or (eq? state 'numeric) - (eq? state 'normal)) - (ret (reverse (cons (wrap1 r) l)))) - - (else - (raise- (Error "missing quote")) - (ret (reverse (cons (wrap1 r) l))))))))) - - (let* ((n (len s)) - (? (= n 1))) - (let lp ((i 0) (state state) (r r) (l l)) - (mk-wrap wrap state) - (define-syntax-rule (raise- s) - (if strict - (raise s) - (lp (+ i 1) state r l))) - - (define (end j ch) - (if (eq? ch #\newline) - (cond - ((eq? state 'start) - (begin - (yield (py-list (reverse l))) - (if (= n j) - (lp0 'start '() '()) - (lp (+ j 1) 'line-end '() '())))) - - ((eq? state 'quote) - (if strict - (raise (Error "newline in quote")) - (lp j 'normal r l))) - - ((eq? state 'line-end) - (if (= n j) - (lp0 'start r l) - (lp (+ j 1) state r l))) - - (else - (yield (reverse (cons (wrap r) l))) - (if (= n j) - (lp0 'start '() '()) - (lp (+ j 1) 'line-end '() '())))) - (if (= j n) - (begin - (yield (reverse (cons* "" (wrap r) l))) - (lp0 'start '() '())) - (lp (+ j 1) 'start '() (cons (wrap r) l))))) - - (define (do-quotechar ch) - (cond - ((eq? state 'doublequote) - (lp (+ i 1) 'quote (cons ch r) l)) - - ((and (pair? state) (eq? (car state) 'escape)) - (lp (+ i 1) (cdr state) (cons ch r) l)) - - ((eq? state 'quote) - (if doublequote - (if (and (< (+ i 1) n) - (equal? quotechar - (string-ref s (+ i 1)))) - (lp (+ i 2) state (cons quotechar r) l) - (lp (+ i 1) 'doublequote r l)) - (lp (+ i 1) 'field-end r l))) - - ((eq? state 'start) - (if (or (eq? quoting 'minimal) - (eq? quoting 'all) - (eq? quoting 'nonnumeric)) - (lp (+ i 1) 'quote r l) - (raise- - (Error - "QOUTE_NONE supports no quoteing")))) - - (else - (raise- (Error "wrong quoting found"))))) - - (define (do-whitespace ch) - (cond - ((eq? state 'doublequote) - (raise- - (Error "whitespace after end of quote"))) - - ((pair? state) - (lp (+ i 1) (cdr state) r l)) - - ((eq? state 'start) - (if skipispace - (lp (+ i 1) state r l) - (if (or (eq? quoting 'minimal) - (eq? quoting 'none) - (eq? quoting 'nonnumeric)) - (lp i 'normal r l) - (raise- - (Error "whitespace outside quote"))))) - - ((or (eq? state 'normal) - (eq? state 'quote)) - (lp (+ i 1) state (cons ch r) l)) - - ((eq? state 'numeric) - (raise- (Error "whitespace in numeric field"))))) - - (define (do-esc-quote) - (if (< (+ i 1) n) - (let ((ch2 (string-ref s (+ i 1)))) - (cond - ((and (eq? state 'quoting) - (eq? ch2 quotechar)) - (lp (+ i 2) state (cons quotechar r) l)) - - ((eq? ch2 delimiter) - (lp (+ i 2) state (cons delimiter r) l)) - - ((eq? ch2 escapechar) - (lp (+ i 2) state (cons escapechar r) l)) - - (else - (lp (+ i 2) state r l)))) - (lp (+ i 1) (cons 'escape state) r l))) - - (define (do-escape ch) - (cond - ((pair? state) - (lp (+ i 1) (cdr state) (cons ch r) l)) - - ((eq? state 'doublequote) - (raise - (Error - "no field or line end after quote, found esc"))) - - ((eq? state 'start) - (if (eq? quoting 'none) - (lp i 'normal r l) - (raise- (Error "escapecharacter in nonquote")))) - - ((eq? state 'normal) - (if (eq? quoting 'none) - (do-esc-quote) - (raise- (Error "escapecharacter in nonequote")))) - - ((eq? state 'numeric) - (raise- (Error "escacpechar in numeric field"))) - - ((eq? state 'quote) - (do-esc-quote)) - - ((eq? state 'end) - (raise- (Error "escapechar after quote"))))) - - (define (do-delim ch) - (cond - ((eq? state 'start) - (end i ch)) - - ((eq? state 'quote) - (lp (+ i 1) state (cons ch r) l)) - - ((eq? state 'normal) - (end i ch)) - - ((eq? state 'doublequote) - (lp (+ i 1) 'start '() (cons (wrap r) l))) - - ((eq? state 'numeric) - (end i ch)))) - - (define (do-line-end ch) - (cond - ((eq? state 'quote) - (lp (+ i 1) state (cons ch r) l)) - - ((pair? state) - (lp (+ i 1) (cdr state) (cons ch r) l)) - - ((eq? state 'field-end) - (end i ch)) - - ((eq? state 'line-end) - (lp (+ i 1) 'line-end r l)) - - (else - (end i #\newline)))) - (if (< i n) - (let ((ch (string-ref s i))) - (cond - ((or (eq? ch #\newline) - (eq? ch #\return)) - (do-line-end ch)) - - ((eq? state 'line-end) - (lp i 'start r l)) - - ((eq? ch delimiter) - (do-delim ch)) - - ((eq? state 'field-end) - (raise- - (Error "no ending char after field-end"))) - - ((or (eq? ch #\space) (eq? ch #\tab)) - (do-whitespace ch)) - - ((eq? ch quotechar) - (do-quotechar ch)) - - ((eq? ch escapechar) - (do-escape ch)) - - ((eq? state 'numeric) - (if (or (eq? ch #\.) - (eq? ch #\-) - (eq? ch #\e) - (eq? ch #\E) - (char-numeric? ch)) - (lp (+ i 1) state (cons ch r) l) - (raise- - (Error "nonumeric in numeric field")))) - - ((eq? state 'start) - (cond - ((eq? quoting 'all) - (raise- - (Error - "nonquoted field when all should be quoted"))) - - ((eq? quoting 'nonnumeric) - (lp i 'numeric r l)) - - (else - (lp i 'normal r l)))) - - ((or (eq? state 'quote) (eq? state 'normal)) - (lp (+ i 1) state (cons ch r) l)) - - ((eq? state 'doublequote) - (raise- (Error "spur char after end of quote"))) - - ((pair? state) - (lp (+ i 1) (cdr state) r l)) - - (else - (error "Bug in csv reader")))) - (if ? - (lp0 state r l) - (end i #\newline)))))))))))))) - -(define-python-class writer () - (define __init__ - (lam (self csvfile (= dialect "excel") (** fmtparams)) - (set! dialect (if (string? dialect) - (get_dialect dialect) - dialect)) - (let* ((hash (make-hash-table))) - (hash-set! hash 'delimiter - (chr (py-get fmtparams "delimiter" e) - (ref dialect 'Delimiter e) - ",")) - - (hash-set! hash 'doublequote - (oor (py-get fmtparams "doublequote" e) - (ref dialect 'doublequote e) - #t)) - - (hash-set! hash 'escapechar - (chr (py-get fmtparams "escapechar" e) - (ref dialect 'escapechar e) - None)) - - (hash-set! hash 'lineterminator - (str (py-get fmtparams "lineterminator" e) - (ref dialect 'lineterminator e) - "\r\n")) - - (hash-set! hash 'quotechar - (chr (py-get fmtparams "quotechar" e) - (ref dialect 'quotechar e) - "\"")) - - (hash-set! hash 'quoting - (oor (py-get fmtparams "quoting" e) - (ref dialect 'quoting e) - QUOTE_MINIMAL)) - - (hash-set! hash 'skipispace - (oor (py-get fmtparams "skipinitialspace" e) - (ref dialect 'skipinitialspace e) - #t)) - - (hash-set! hash 'strict - (oor (py-get fmtparams "strict" e) - (ref dialect 'strict e) - #f)) - - (set self 'csvfile csvfile) - (set self '_hash csvfile)))) - - (define writerow - (lambda (self l) - (define (write x) - ((ref (ref self 'csvfile) 'write) x)) - - (define (get-str x) (if (string? x) x (scm-str x))) - - (let* ((hash (ref self '_hash)) - (delimiter (hash-ref hash 'delimiter)) - (doublequote (hash-ref hash 'doublequote)) - (escapechar (hash-ref hash 'escapechar)) - (lineterminator (hash-ref hash 'lineterminator)) - (quotechar (hash-ref hash 'quotechar)) - (quoting (hash-ref hash 'quoting)) - (skipispace (hash-ref hash 'skipinitialspace)) - (strict (hash-ref hash 'strict)) - (terms (string->list lineterminator))) - - (define (has-escape-1 x) - (let ((n (len x))) - (let lp ((i 0)) - (if (< i n) - (let ((a (string-ref x i))) - (if (or (eq? a #\,) (member a terms)) - #t - (lp (+ i 1)))) - #f)))) - - (define (has-escape-2 x) - (let ((n (len x))) - (let lp ((i 0)) - (if (< i n) - (let ((a (string-ref x i))) - (if (or (eq? a quotechar) - (eq? a delimiter) - (member a terms)) - #t - (lp (+ i 1)))) - #f)))) - - (define (quote-it x) - (let ((n (len x))) - (let lp ((i 0) (r '())) - (if (< i n) - (let ((a (string-ref x i))) - (cond - ((eq? a quotechar) - (if doublequote - (lp (+ i 1) (cons* a a r)) - (if escapechar - (lp (+ i 1) (cons* a escapechar r)) - (raise (Error "no escapechar defined"))))) - ((eq? a escapechar) - (lp (+ i 1) (cons* a a r))) - (else - (lp (+ i 1) (cons a r))))) - (list->string (reverse! r)))))) - - (define (is-numeric x) - (catch #t - (lambda () - (string->number x)) - (lambda x #f))) - - - - (for ((x : l)) ((r '())) - (let/ec ret - (cons - (cond - ((eq? quoting 'none) - (let ((x (get-str x))) - (if (has-escape-1 x) - (if strict - (raise (Error "None quoting and nonspecial chars")) - (ret r)) - x))) - - ((eq? quoting 'nonnumeric) - (let ((x (get-str x))) - (aif it (is-numeric x) - (number->string it) - (quote-it x)))) - - ((eq? quoting 'none) - (get-str x)) - - ((eq? quoting 'minimal) - (let ((x (get-str x))) - (if (has-escape-2 x) - (quote-it x) - x)))) - r) - #:final - (write - (string-join - (reverse - (cons lineterminator r)) (string-ref delimiter 0))))))))) - diff --git a/modules/language/python/number.scm b/modules/language/python/number.scm deleted file mode 100644 index 3744fec..0000000 --- a/modules/language/python/number.scm +++ /dev/null @@ -1,637 +0,0 @@ -(define-module (language python number) - #:use-module (oop pf-objects) - #:use-module (oop goops) - #:use-module (rnrs bytevectors) - #:use-module (language python hash) - #:use-module (language python list) - #:use-module (language python try) - #:use-module (language python for) - #:use-module (language python def) - #:use-module (language python exceptions) - #:use-module (language python bytes) - #:use-module (language python persist) - #:export (py-int py-float py-complex - py-/ py-logand py-logior py-logxor py-abs py-trunc - py-lshift py-rshift py-mod py-floordiv py-round py-iadd - py-lognot py-matmul - <py-int> <py-float> <py-complex> - py-divmod pyfloat-listing pyint-listing pycomplex-listing - py-as-integer-ratio py-conjugate py-fromhex py-hex py-imag - py-is-integer py-real hex py-bin py-index - py-ifloordiv py-ilshift py-imod py-imul py-imatmul - py-bit-length py-to-bytes - py-ilogior py-ilogand py-ipow py-isub py-i/ - py-irshift py-ilogxor)) - -(define-method (> (o <boolean>) x) - (> (if o 1 0) x)) -(define-method (> x (o <boolean>)) - (> x (if o 1 0))) -(define-method (>= (o <boolean>) x) - (>= (if o 1 0) x)) -(define-method (>= x (o <boolean>)) - (>= x (if o 1 0))) -(define-method (< (o <boolean>) x) - (< (if o 1 0) x)) -(define-method (< x (o <boolean>)) - (< x (if o 1 0))) -(define-method (<= (o <boolean>) x) - (<= (if o 1 0) x)) -(define-method (<= x (o <boolean>)) - (<= x (if o 1 0))) - -(define-syntax-rule (aif it p x y) (let ((it p)) (if it x y))) - -(define-syntax-rule (mki py-iadd __iadd__) - (define (py-iadd x y) - ((ref x '__iadd__) y))) - -(mki py-iadd __iadd__) - -(mki py-matmul __matmul__) -(mki py-ifloordiv __ifloordiv__) -(mki py-ilshift __ilshift__) -(mki py-imod __imod__) -(mki py-imul __imul__) -(mki py-imatmul __imatmul__) -(mki py-ilogior __ior__) -(mki py-ilogand __iand__) -(mki py-ipow __ipow__) -(mki py-isub __isub__) -(mki py-irshift __irshift__) -(mki py-ilogxor __ixor__) -(mki py-i/ __itruediv__) - - -(define-class <py-int> () x) -(define-class <py-float> () x) -(define-class <py-complex> () x) - -(name-object <py-int>) -(name-object <py-float>) -(name-object <py-complex>) - -(define-syntax-rule (mk <py-int>) - (cpit <py-int> (o (lambda (o x) (slot-set! o 'x x)) (list (slot-ref o 'x))))) - -(mk <py-int>) -(mk <py-float>) -(mk <py-complex>) - -(define-syntax-rule (b0 op) - (begin - (define-method (op (o1 <py-int>) o2) - (op (slot-ref o1 'x) o2)) - (define-method (op (o1 <py-float>) o2) - (op (slot-ref o1 'x) o2)) - (define-method (op (o1 <py-complex>) o2) - (op (slot-ref o1 'x) o2)) - (define-method (op o2 (o1 <py-int>)) - (op o2 (slot-ref o1 'x))) - (define-method (op o2 (o1 <py-complex>)) - (op o2 (slot-ref o1 'x))) - (define-method (op o2 (o1 <py-float>)) - (op o2 (slot-ref o1 'x))))) - -(define-syntax-rule (mk-biop1 mk-biop0 op r1) - (begin - (mk-biop0 op) - (define-method (op (o <p>) v) - (aif it (ref o 'r1) - (it v) - (next-method))))) - -(define-syntax-rule (mk-biop2 mk-biop0 rop op r1 r2) - (begin - (define-syntax-rule (rop x y) (op y x)) - (mk-biop1 mk-biop0 op r1) - (define-method (op v (o <p>)) - (aif it (ref o 'r2) - (it v) - (next-method))))) - -(define-syntax-rule (i0 op) - (begin - (define-method (op (o1 <py-int>) o2) - (op (slot-ref o1 'x) o2)) - (define-method (op o2 (o1 <py-int>)) - (op o2 (slot-ref o1 'x))))) - - -(mk-biop2 b0 r+ + __add__ __radd__) -(mk-biop2 b0 r- - __sub__ __rsub__) -(mk-biop2 b0 r* * __mul__ __rmul__) - -(mk-biop1 b0 < __le__) -(mk-biop1 b0 > __ge__) -(mk-biop1 b0 <= __lt__) -(mk-biop1 b0 >= __gt__) -(mk-biop2 b0 rexpt expt __pow__ __rpow__) -(b0 py-equal?) - - -(define-method (py-lshift (o1 <integer>) (o2 <integer>)) - (ash o1 o2)) -(define-method (py-rshift (o1 <integer>) (o2 <integer>)) - (ash o1 (- o2))) - -(mk-biop2 i0 py-rlshift py-lshift __lshift__ __rlshift__) -(mk-biop2 i0 py-rrshift py-rshift __rshift__ __rrshift__) - -(define-method (py-logand (o1 <integer>) (o2 <integer>)) - (logand o1 o2)) -(define-method (py-logior (o1 <integer>) (o2 <integer>)) - (logior o1 o2)) -(define-method (py-logxor (o1 <integer>) (o2 <integer>)) - (logxor o1 o2)) -(define-method (py-lognot (o1 <integer>)) - (lognot o1)) - -(define-method (py-logand o1 (o2 <py-int>)) - (py-logand o1 (slot-ref o2 'x))) - -(define-method (py-logand (o1 <py-int>) o2) - (py-logand (slot-ref o1 'x) o2)) - -(define-method (py-logior o1 (o2 <py-int>)) - (py-logior o1 (slot-ref o2 'x))) - -(define-method (py-logior (o1 <py-int>) o2) - (py-logior (slot-ref o1 'x) o2)) - -(define-method (py-logxor o1 (o2 <py-int>)) - (py-logxor o1 (slot-ref o2 'x))) - -(define-method (py-logxor (o1 <py-int>) o2) - (py-logxor (slot-ref o1 'x) o2)) - -(define-method (py-lognot (o1 <py-int>)) - (lognot (slot-ref o1 'x))) - -(define-method (py-logand (o1 <p>) o2) - (aif it (ref o1 '__and__) - (it o2) - (next-method))) - -(define-method (py-logand o1 (o2 <p>)) - (aif it (ref o1 '__rand__) - (it o2) - (next-method))) - -(define-method (py-logior (o1 <p>) o2) - (aif it (ref o1 '__or__) - (it o2) - (next-method))) - -(define-method (py-logior o1 (o2 <p>)) - (aif it (ref o1 '__ror__) - (it o2) - (next-method))) - -(define-method (py-logxor (o1 <p>) o2) - (aif it (ref o1 '__xor__) - (it o2) - (next-method))) - -(define-method (py-logxor o1 (o2 <p>)) - (aif it (ref o1 '__rxor__) - (it o2) - (next-method))) - -(define-method (py-lognot (o1 <p>)) - (aif it (ref o1 '__not__) - (it) - (next-method))) - - -(define-method (py-/ (o1 <number>) (o2 <integer>)) - (/ o1 (exact->inexact o2))) -(define-method (py-/ (o1 <number>) (o2 <number>)) - (/ o1 o2)) - -(define-method (py-divmod (o1 <integer>) (o2 <integer>)) - (values - (floor-quotient o1 o2) - (modulo o1 o2))) - -(define-method (py-divmod (o1 <number>) (o2 <number>)) - (values - (floor-quotient o1 o2) - (floor-remainder o1 o2))) - -(define-method (py-floordiv (o1 <number>) (o2 <number>)) - (floor-quotient o1 o2)) - -(mk-biop2 b0 py-rfloordiv py-floordiv __floordiv__ __rfloordiv__) -(mk-biop2 b0 py-rdivmod py-divmod __divmod__ __rdivmod__) -(mk-biop2 b0 py-r/ py-/ __truediv__ __rtruediv__) - -(mk-biop2 i0 py-rlogand py-logand __and__ __rand__) -(mk-biop2 i0 py-rlogior py-logior __or__ __ror__) -(mk-biop2 i0 py-rlogxor py-logxor __xor__ __rxor__) - -(define-method (py-mod (o1 <integer>) (o2 <integer>)) - (modulo o1 o2)) -(define-method (py-mod (o1 <real>) (o2 <real>)) - (floor-remainder o1 o2)) - -(mk-biop2 i0 py-rmod py-mod __mod__ __rmod__) - - -(define-method (py-floor (o1 <integer>)) o1) -(define-method (py-floor (o1 <number> )) (inexact->exact (floor o1))) -(define-method (py-trunc (o1 <integer>)) (exact->inexact o1)) -(define-method (py-trunc (o1 <number> )) - (floor o1)) - -(define-syntax-rule (u0 f) - (begin - (define-method (f (o <py-int> )) (f (slot-ref o 'x))) - (define-method (f (o <py-float>)) (f (slot-ref o 'x))) - (define-method (f (o <py-complex>)) (f (slot-ref o 'x))))) - -(define-syntax-rule (i0 f) - (begin - (define-method (f (o <py-int> )) (f (slot-ref o 'x))))) - -(define-syntax-rule (mk-unop u0 f r) - (begin - (u0 f) - (define-method (f (o <p>)) - ((ref o 'r))))) - -(u0 py-hash ) -(mk-unop u0 - __neg__ ) -(mk-unop u0 py-trunc __trunc__ ) -(mk-unop i0 py-lognot __invert__) - -(define-method (py-bit-length (i <integer>)) - (integer-length (abs i))) - -(define-method (py-conjugate (i <complex>)) - (make-rectangular (real-part i) (- (imag-part i)))) -(define-method (py-conjugate (i <number>)) i) - -(define-method (py-imag (i <complex>)) (imag-part i)) -(define-method (py-imag (i <number>)) i) - -(define-method (py-real (i <complex>)) (real-part i)) -(define-method (py-real (i <number>)) i) - -(define-method (py-denominator (o <integer>)) 0) -(define-method (py-denominator (o <real>)) - (denominator (inexact->exact o))) - -(define-method (py-numerator (o <integer>)) o) -(define-method (py-numerator (o <real> )) - (numerator (inexact->exact o))) - -(define-method (py-as-integer-ratio (o <integer>)) - (list o 0)) -(define-method (py-as-integer-ratio (o <real>)) - (let ((r (inexact->exact o))) - (list (numerator r) (denominator r)))) - -(define-method (py-fromhex (o <real>)) - (error "1.2.fromhex('0x1.ap4') is not implemented")) - -(define (py-hex x) - (+ "0x" (number->string (py-index x) 16))) - -(define-method (py-is-integer (o <real>)) - (= 1 (denominator (inexact->exact o)))) -(define-method (py-is-integer (o <integer>)) #t) - -(define-method (hex (o <integer>)) - (+ "0x" (number->string o 16))) - -(define-method (py-abs (o <complex>)) - (magnitude o)) -(define-method (py-abs (o <number>)) - (abs o)) -(define-method (py-index (o <integer>)) o) -(mk-unop u0 py-abs __abs__) -(mk-unop u0 py-conjugate conjugate) -(mk-unop u0 py-imag imag) -(mk-unop u0 py-real real) -(mk-unop u0 py-denominator denominator) -(mk-unop u0 py-numerator numerator) -(mk-unop u0 py-as-integer-ratio as_integer_ratio) -(mk-unop u0 py-fromhex fromhex) -(mk-unop i0 hex __hex__) -(mk-unop u0 py-is-integer is_integer) -(mk-unop u0 py-index __index__) - -(define-method (write (o <py-float>) . l) - (apply write (slot-ref o 'x) l)) -(define-method (write (o <py-int>) . l) - (apply write (slot-ref o 'x) l)) - -(define-method (py-from-bytes (o <p>) . l) - (aif it (ref o 'from_bytes) - (apply it l) - (next-method))) - -(define-method (py-from-bytes (o <integer>) . l) - (apply py-from-bytes int l)) - -(define-method (py-to-bytes (o <p>) . l) - (aif it (ref o 'to_bytes) - (apply it l) - (aif it (ref o '__int__) - (apply py-to-bytes (int) l) - (next-method)))) - -(define-method (py-to-bytes (o <integer>) . l) - (apply - (lam (length (= byteorder "big") (= signed #f)) - (let ((big? (cond - ((equal? byteorder "little") - #f) - ((equal? byteorder "big") - #t) - (else - (raise (ValueError "to_bytes with wrong byteorder")))))) - - (if (and (< o 0) (not signed)) - (raise (OverflowError - "to_byted, integer negative but not signed"))) - - (if signed - (let ((mask (ash 1 (- (* 8 length) 1)))) - (set! o (+ mask o)))) - - (let lp ((o o) (l '())) - (if (= o 0) - (let ((n (len l))) - (if (> n length) - (raise (OverflowError - "to bytes number larger than size"))) - (let lp ((i (len l)) (l l)) - (if (< i length) - (lp (+ i 1) (cons 0 l)) - (begin - (if signed - (let ((x (car l))) - (if (> (logand x #x80) 0) - (raise - "OverflowError to large number compared to size in to_bytes")) - (set-car! l (logior #x80 x)))) - - (bytes - (if big? - l - (reverse l))))))) - (lp (ash o -8) (cons (logand o #xff) l)))))) - l)) - - - - - -(define-python-class int (<py> <py-int>) - (define from_bytes - (class-method - (lam (self bytes byteorder (= signed #f)) - (for ((x : bytes)) ((l '())) - (cons - (let ((i (if (and (number? x) (integer? x)) - x - (list-ref (bv-scm x) 0)))) - (if (not (and (number? i) (integer? i) - (>= i 0) (<= i 356))) - (raise (ValueError "wrong bytevector in from_bytes")) - i)) - l) - #:final - (begin - (if (equal? byteorder "little") - (set! l (reverse l))) - (let lp ((s 0) (i 0) (l l)) - (if (pair? l) - (let ((x (car l))) - (if (null? (cdr l)) - (if (and signed (not (= 0 (logand x #x80)))) - (set! x (logand x #x7f)) - (set! signed #f))) - (lp (logior s (ash x i)) (+ i 8) (cdr l))) - (if signed - (let ((mask (ash 1 (- i 1)))) - (- s mask)) - s)))))))) - (define __newobj__ - (lambda (cls n) - (let ((obj ((rawref object '__new__) cls))) - (slot-set! obj 'x (__new__ cls n)) - obj))) - - (define __new__ - (letrec ((__new__ - (case-lambda - ((self) - 0) - - ((self n) - (let lp ((n n)) - (cond - ((and (number? n) (integer? n)) - (inexact->exact n)) - ((boolean? n) - (if n 1 0)) - ((number? n) - (lp (py-floor n))) - - ((string? n) - (lp (aif it (string->number n) - it - (raise - (ValueError - "invalid literal for int() with base 10"))))) - (else - (catch #t - (lambda () - (aif it (ref n '__int__) - (it) - (raise (ValueError - (py-mod "could not make int from %r" - (list n)))))) - (lambda z - (raise - (ValueError (py-mod "could not make int from %r" - (list n)))))))))) - - ((self n k) - (__new__ self (string->number n k)))))) - __new__))) - -(name-object int) - -(define (proj? x) - (if (number? x) - x - (and - (or (is-a? x <py-complex>) - (is-a? x <py-int>) - (is-a? x <py-float>)) - (slot-ref x 'x)))) - -(define (projc? x) - (if (number? x) - (cond - ((or (integer? x) (rational? x)) - (exact->inexact x)) - ((real? x) - x) - (raise (ValueError "cannot make a float out of a complex"))) - (and - (or (is-a? x <py-complex>) - (is-a? x <py-int>) - (is-a? x <py-float>)) - (let ((ret (slot-ref x 'x))) - (if (not (complex? ret)) - ret - #f))))) - -(define-python-class float (<py> <py-float>) - (define __init__ - (case-lambda - ((self n) - (let lp ((n n)) - (cond - ((projc? n) => - (lambda (x) x)) - ((string? n) - (cond - ((equal? n "nan") - (nan)) - ((equal? n "inf") - (inf)) - ((equal? n "-inf") - (- (inf))) - (else - (string->number n)))) - ((is-a? n <py-float>) - (slot-ref n '__float__))))))) - - (define __new__ - (lambda (cls a . l) - (__init__ cls a)))) - - - - -(name-object float) - -(define-python-class py-complex (<py> <py-complex>) - (define __init__ - (case-lambda - ((self n) - (cond - ((proj? n) => - (lambda (n) - (slot-set! self 'x n))) - (else - (raise ValueError "could not make complex from " n)))) - ((self n m) - (cond - ((projc? n) => - (lambda (n) - (cond - ((projc? m) - (lambda (m) - (slot-set! self 'x (make-rectangular n m)))) - (else - (raise ValueError "could not make complex from " n m))))) - (else - (raise ValueError "could not make complex from " n m))))))) - -(name-object py-complex) - -(define-method (py-class (o <integer> )) int) -(define-method (py-class (o <real> )) float) -(u0 py-class) - -(define py-int int) -(define py-float float) - -(define-method (mk-int (o <number>)) (slot-ref (py-int o) 'x)) -(define-method (mk-float (o <number>)) (slot-ref (py-float o) 'x)) - -(mk-unop u0 mk-int __int__) -(mk-unop u0 mk-float __float__) - -(define (pyint-listing) - (let ((l - (to-pylist - (map symbol->string - '(__abs__ __add__ __and__ __class__ __cmp__ __coerce__ - __delattr__ __div__ __divmod__ __doc__ __float__ - __floordiv__ __format__ __getattribute__ - __getnewargs__ __hash__ __hex__ __index__ __init__ - __int__ __invert__ __long__ __lshift__ __mod__ - __mul__ __neg__ __new__ __nonzero__ __oct__ __or__ - __pos__ __pow__ __radd__ __rand__ __rdiv__ - __rdivmod__ __reduce__ __reduce_ex__ __repr__ - __rfloordiv__ __rlshift__ __rmod__ __rmul__ __ror__ - __rpow__ __rrshift__ __rshift__ __rsub__ __rtruediv__ - __rxor__ __setattr__ __sizeof__ __str__ __sub__ - __subclasshook__ __truediv__ __trunc__ __xor__ - bit_length conjugate denominator imag numerator from_bytes to_bytes - real))))) - (pylist-sort! l) - l)) - -(define (pyfloat-listing) - (let ((l - (to-pylist - (map symbol->string - '(__abs__ __add__ __class__ __coerce__ __delattr__ __div__ - __divmod__ __doc__ __eq__ __float__ __floordiv__ - __format__ __ge__ __getattribute__ __getformat__ - __getnewargs__ __gt__ __hash__ __init__ __int__ - __le__ __long__ __lt__ __mod__ __mul__ __ne__ - __neg__ __new__ __nonzero__ __pos__ __pow__ - __radd__ __rdiv__ __rdivmod__ __reduce__ - __reduce_ex__ __repr__ __rfloordiv__ __rmod__ - __rmul__ __rpow__ __rsub__ __rtruediv__ - __setattr__ __setformat__ __sizeof__ __str__ - __sub__ __subclasshook__ __truediv__ __trunc__ - as_integer_ratio conjugate fromhex hex imag - is_integer real))))) - (pylist-sort! l) - l)) - -(define (pycomplex-listing) - (let ((l - (to-pylist - (map symbol->string - '(__abs__ __add__ __class__ __coerce__ __delattr__ __div__ - __divmod__ __doc__ __eq__ __float__ __floordiv__ - __format__ __ge__ __getattribute__ __getnewargs__ - __gt__ __hash__ __init__ __int__ __le__ __long__ - __lt__ __mod__ __mul__ __ne__ __neg__ __new__ - __nonzero__ __pos__ __pow__ __radd__ __rdiv__ - __rdivmod__ __reduce__ __reduce_ex__ __repr__ - __rfloordiv__ __rmod__ __rmul__ __rpow__ __rsub__ - __rtruediv__ __setattr__ __sizeof__ __str__ - __sub__ __subclasshook__ __truediv__ - conjugate imag real))))) - (pylist-sort! l) - l)) - -(define* (py-round x #:optional (digits 0)) - (let* ((f (expt 10.0 digits))) - (inexact->exact - (if (equal? digits 0) - (round x) - (/ (round (* x f)) f))))) - -(define-method (py-bin (o <integer>)) - (number->string o 2)) -(define-method (py-bin (o <py-int>)) - (number->string (slot-ref o 'x) 2)) -(define (py-bin o) - (+ "0b" (number->string (py-index o) 2))) - - -(set! (@@ (language python list) int) int) diff --git a/modules/language/python/parser-tool.scm b/modules/language/python/parser-tool.scm deleted file mode 100644 index 75da429..0000000 --- a/modules/language/python/parser-tool.scm +++ /dev/null @@ -1,46 +0,0 @@ -(define-module (language python parser-tool) - #:use-module (ice-9 pretty-print) - #:use-module (logic guile-log parsing scanner) - #:use-module ((logic guile-log parser) - #:select (setup-parser - f-nl f-nl! - *current-file-parsing* - make-file-reader file-next-line file-skip)) - #:use-module (logic guile-log) - #:re-export (f-nl f-nl!) - #:export (f-seq f-seq! f-or f-or! f-not f-not! f-true f-false f-cons f-cons* - f-list INDENT <p-lambda> f* ff* ff? f? ff+ f+ - f-reg f-reg! f-tag f-tag! f-eof f-out f-and f-and! - mk-token p-freeze parse f-append - .. xx <p-cc> - f-pk)) - -;; Preliminary -(define do-print #f) -(define pp - (case-lambda - ((s x) - (when do-print - (pretty-print `(,s ,(syntax->datum x)))) - x) - ((x) - (when do-print - (pretty-print (syntax->datum x))) - x))) - - -(begin - (define-guile-log-parser-tool (<p-lambda> (X XL N M INDENT)) <p-define> .. - xx <p-cc>) - - - (make-guile-log-scanner-tools <p-lambda> <fail> <p-cc> <succeds> .. - (X XL N M INDENT) - (c) (d) - s-false s-true s-mk-seq s-mk-and s-mk-or) - - ;; Sets up a standar parser functionals with INDENT field added - (setup-parser - <p-define> <p-lambda> <fail> <p-cc> <succeds> .. xx - X XL ((N 0) (M 0) (INDENT (list 0))) - s-false s-true s-mk-seq s-mk-and s-mk-or)) diff --git a/modules/language/python/parser.scm b/modules/language/python/parser.scm deleted file mode 100644 index 55fc02e..0000000 --- a/modules/language/python/parser.scm +++ /dev/null @@ -1,849 +0,0 @@ -(define-module (language python parser) - #:use-module (logic guile-log) - #:use-module ((logic guile-log parser) #:select (*whitespace*)) - #:use-module (ice-9 match) - #:use-module (ice-9 pretty-print) - #:use-module (language python parser-tool) - #:export (p python-parser)) - -(define do-print #f) -(define pp - (case-lambda - ((s x) - (when do-print - (pretty-print `(,s ,(syntax->datum x)))) - x) - ((x) - (when do-print - (pretty-print (syntax->datum x))) - x))) -(define ppp - (case-lambda - ((s x) - (pretty-print `(,s ,(syntax->datum x))) - x) - ((x) - (pretty-print (syntax->datum x)) - x))) - -(define-syntax-rule (Ds f) (lambda x (apply f x))) -(define-syntax-rule (DDs op f ...) (op (lambda x (apply f x)) ...)) - -(define divide truncate/) -;; +++++++++++++++++++++++++++++++++++++ SCANNER SUBSECTION -(define nl (f-or f-nl f-eof)) -(define com (f-seq "#" (f* (f-not f-nl)) nl)) -(define w (f-reg "[\t\r| ]")) -(define ws+ (f+ (f-or (f-reg "[\t\r| ]") com))) -(define ws* (f+ (f-or (f-reg "[\t\r| ]") com))) -(define ws ws*) - - -(define (wn_ n i) - (<p-lambda> (c) - (cond - ((> i n) <fail>) - ((= i n) - (.. ((f-and (f-not w) f-true) c))) - ((< i n) - (<or> - (<and!> - (.. (c) ((f-tag " ") c)) - (.. ((wn_ n (+ i 1)) c))) - (<and!> - (.. (c) ((f-tag "\t") c)) - (.. ((wn_ n (divide (+ i 8) 8)) c))) - (<and!> - (.. (c) ((f-tag "\r") c)) - (.. ((wn_ n i) c)))))))) - -(define (wn+_ n i) - (<p-lambda> (c) - (<pp> `(,n ,i)) - (<or> - (<and!> - (.. (c) ((f-tag " ") c)) - (.. ((wn+_ n (+ i 1)) c))) - (<and!> - (.. (c) ((f-tag "\t") c)) - (.. ((wn+_ n (divide (+ i 8) 8)) c))) - (<and!> - (.. (c) ((f-tag "\r") c)) - (.. ((wn+_ n i) c))) - (<and!> - (when (> i n)) - (<with-bind> ((INDENT (cons i INDENT))) - (<p-cc> c)))))) - -(define wn+ - (<p-lambda> (c) - (<let> ((n (car INDENT))) - (.. ((wn+_ n 0) c))))) - -(define wn - (<p-lambda> (c) - (<let> ((n (car INDENT))) - (.. ((wn_ n 0) c))))) - -(define indent= wn) -(define indent+ wn+) -(define indent- - (<p-lambda> (c) - (<with-bind> ((INDENT (cdr INDENT))) - (<p-cc> c)))) - -(define identifier__ - (let () - (define ih (f-reg! "[a-zA-Z_]")) - (define i.. (f-or! 'or ih (f-reg! "[0-9]"))) - (mk-token - (f-seq ih (f* i..))))) - -(define keyw (make-hash-table)) -(for-each - (lambda (x) (hash-set! keyw (symbol->string x) #t)) - '(False None True and as assert break class continue def - del elif else except finally for from global if import - in is lambda nonlocal not or pass raise return try - while with yield)) - -(define decimal (mk-token (f-seq (f-reg! "[1-9]") (f* (f-reg! "[0-9]"))))) -(define oct (mk-token - (f-seq "0" (f-reg "[oO]") (f+ (f-reg! "[0-7]"))))) -(define hex (mk-token - (f-seq "0" (f-reg "[xX]") (f+ (f-reg! "[0-7a-fA-F]"))))) -(define bin (mk-token - (f-seq "0" (f-reg "[bB]") (f+ (f-reg! "[01]"))))) - -(define integer - (<p-lambda> (c) - (<and!> - (<or> - (<and> - (.. (c) (decimal c)) - (<p-cc> (string->number c 10))) - (<and> - (.. (c) (oct c)) - (<p-cc> (string->number c 8))) - (<and> - (.. (c) (hex c)) - (<p-cc> (string->number c 16))) - (<and> - (.. (c) (bin c)) - (<p-cc> (string->number c 2))))))) - -(define intpart (f+ (f-reg! "[0-9]"))) -(define fraction (f-seq (f-tag! ".") intpart)) -(define exponent (f-seq (f-reg! "[eE]") (f? (f-reg! "[+-]")) intpart)) -(define pointfloat (f-or! (f-seq (f? intpart) fraction) - (f-seq intpart (f-tag! ".")))) -(define exponentfloat (f-seq (f-or intpart pointfloat) exponent)) - -(define floatnumber (mk-token (f-or! exponentfloat pointfloat))) -(define float - (<p-lambda> (c) - (.. (c) (floatnumber c)) - (<p-cc> (string->number c)))) - -(define imagnumber (mk-token (f-seq (f-or floatnumber integer) (f-reg "[jJ]")))) -(define imag - (<p-lambda> (c) - (.. (c) (imagnumber c)) - (<p-cc> (string->number (string-append "0+" c "i"))))) - -(define (mk-id S c cc) cc) - -(define number - (p-freeze 'number - (f-or! imag float integer) - mk-id)) - -(define identifier_ - (let () - (define (__*__ i) - (match (string->list i) - ((#\_ #\_ . l) - (match (reverse l) - ((#\_ #\_ . l) #t) - (_ #f))) - (_ #f))) - - (define (__* i) - (match (string->list i) - ((#\_ #\_ . l) - #t) - (_ #f))) - - (define (_* i) - (match (string->list i) - ((#\_ . l) - #t) - (_ #f))) - - (<p-lambda> (c) - (.. (i) (identifier__ c)) - (cond - ((__*__ i) - (<p-cc> `(#:identifier ,i #:system))) - ((__* i) - (<p-cc> `(#:identifier ,i #:private))) - ((_* i) - (<p-cc> `(#:identifier ,i #:local))) - ((eq? i '_) - (<p-cc> #:_)) - ((hash-ref keyw i) - (<p-cc> `(#:keyword ,i))) - (else - (<p-cc> `(#:identifier ,i))))))) - -(define identifier - (<p-lambda> (c) - (.. (i) (identifier_ c)) - (if (not (eq? (car i) #:keyword)) - (<p-cc> i) - <fail>))) - -;;;; +++++++++++++++++++++++++++++++++++++++++++++++ STRING +++++++++++++++ -(define string-prefix (mk-token (f-reg! "[ruRU]"))) -(define short-string-char (f-not! (f-reg "[\n\"']"))) -(define long-string-char (f-not! "\n")) -(define string-esc (f-seq (f-tag "\\") (f-reg! "."))) -(define short-string-item (f-or short-string-char string-esc)) -(define long-string-item (f-or long-string-char string-esc)) - -(define long-string - (mk-token - (f-or - (f-seq! "'''" (f* long-string-item) "'''") - (f-seq! "\"\"\"" (f* long-string-item) "\"\"\"")))) - -(define short-string - (mk-token - (f-or - (f-seq! "'" (f* short-string-item) "'") - (f-seq! "\"" (f* short-string-item) "\"")))) - -(define string - (p-freeze 'string-literal - (f-list #:string - (ff? string-prefix) - (f-or! long-string short-string)) - mk-id)) - -;; ++++++++++++++++++++++++++++++++++++++++++ BYTE ++++++++++++++++++++++++++ - -(define bytes-prefix - (mk-token - (f-or! - (f-seq! (f-tag! "b") (f-or f-true (f-reg! "[rR]"))) - (f-seq! (f-tag! "B") (f-or f-true (f-reg! "[rR]"))) - (f-seq! (f-tag! "r") (f-or f-true (f-reg! "[bB]"))) - (f-seq! (f-tag! "R") (f-or f-true (f-reg! "[bB]")))))) - -(define bytes-esc (f-seq "\\" (f-reg "."))) - -(define short-bytes-char (f-not! (f-reg "[\\\n'\"]"))) -(define long-bytes-char (f-not! (f-reg "[\\]"))) - -(define short-bytes-item - (f-or short-bytes-char bytes-esc)) - -(define long-bytes-item - (f-or long-bytes-char bytes-esc)) - -(define short-bytes - (mk-token - (f-or! (f-seq! "'" (f* short-bytes-item) "'") - (f-seq! "\"" (f* short-bytes-item) " \"")))) - -(define long-bytes - (mk-token - (f-or! (f-seq! "'''" (f* long-bytes-item) "'''") - (f-seq! "\"\"\"" (f* long-bytes-item) "\"\"\"")))) - -(define bytes-literal - (p-freeze 'string-literal - (<p-lambda> (c) - (.. (pre) (bytes-prefix c)) - (.. (str) ((f-or! long-bytes short-bytes) pre)) - (<p-cc> (#:bytes pre str))) - mk-id)) - - -; +++++++++++++++++++++++++++++++++++ PARSER SUBSECTION +++++++++++++++++ -(define stmt #f) -(define testlist #f) -(define dottaed_name #f) -(define arglist #f) -(define classdef #f) -(define funcdef #f) -(define test #f) -(define small_stmt #f) - - -(define expr_stmt #f) -(define del_stmt #f) -(define pass_stmt #f) -(define flow_stmt #f) -(define import_stmt #f) -(define global_stmt #f) -(define nonlocal_stmt #f) -(define assert_stmt #f) -(define testlist_star_expr #f) -(define augassign #f) -(define yield_expr #f) -(define star_expr #f) -(define exprlist #f) -(define import_name #f) -(define import_from #f) -(define dotted_as_names #f) -(define import_as_names #f) -(define if_stmt #f) -(define while_stmt #f) -(define for_stmt #f) -(define try_stmt #f) -(define with_stmt #f) -(define suite #f) -(define except_clause #f) -(define with_item #f) -(define expr #f) -(define or_test #f) -(define lambdef #f) -(define lambdef_nocond #f) -(define and_test #f) -(define not_test #f) -(define comparison #f) -(define comp_op #f) -(define xor_expr #f) -(define and_expr #f) -(define or_expr #f) -(define arith_expr #f) -(define shift_expr #f) -(define term #f) -(define factor #f) -(define power #f) -(define atom #f) -(define trailer #f) -(define subscriptlist #f) -(define testlist_comp #f) -(define dictorsetmaker #f) -(define comp_for #f) -(define subscript #f) -(define sliceop #f) -(define argument #f) -(define comp_if #f) -(define yield_arg #f) -(define dotted_name #f) - -(define file-input (f-seq (f* (f-or nl (f-seq indent= stmt))) f-eof)) - -(define eval-input (f-seq testlist (f* nl) f-eof)) - -(define decorator (f-cons (f-seq ws "@" ws (Ds dotted_name) ws) - (f-seq (ff? (f-seq "(" ws (ff? (Ds arglist)) - ws ")" ws)) - f-nl))) - -(define decorators (ff+ decorator)) - - -(define decorated (f-list #:decorated - decorators - (f-or classdef funcdef))) - -(define FALSE (f-out #f)) -(define tfpdef - (f-cons identifier (f-or - (f-seq ":" ws test ws) - FALSE))) - -(define vfpdef identifier) -(define mk-py-list - (lambda (targlist tfpdef) - (let* ((t (f-or (f-seq "=" (Ds test)) FALSE)) - (arg (f-list tfpdef t)) - (arg.. (ff* (f-seq "," arg))) - (args (f-cons arg arg..)) - (arg* (f-seq "*" (f-list tfpdef arg..))) - (arg** (f-seq "**" tfpdef))) - (f-cons - targlist - (f-or! - (f-cons args - (f-or (f-list arg* (f-or arg** FALSE)) - (f-list FALSE FALSE))) - (f-list FALSE arg* (f-or arg** FALSE)) - (f-list FALSE FALSE arg**) - (f-list 'a1 '() FALSE FALSE)))))) - -(define typedargslist (mk-py-list #:types-args-list tfpdef)) -(define varargslist (mk-py-list #:var-args-list vfpdef)) - -(define parameters (f-seq! 'parameters - "(" (f-or typedargslist - (f-out (list #f #f #f))) - ")")) - -(set! funcdef - (p-freeze 'funcdef - (f-list 'fundef - #:def - (f-seq "def" identifier) - parameters - (ff? (f-seq! "->" (Ds test))) - (f-seq ":" (Ds suite))) - mk-id)) - -(define simple_stmt (f-list 'simple_stmt #:stmt - (f-seq - (f-cons (Ds small_stmt) - (ff* (f-seq ";" (Ds small_stmt)))) - (f? ";") (f? ws) (f-or nl f-eof)))) -(set! small_stmt - (Ds - (f-or 'small expr_stmt del_stmt pass_stmt flow_stmt import_stmt global_stmt - nonlocal_stmt assert_stmt))) - -(set! expr_stmt - (f-list 'expr_stmt - #:expr-stmt - (Ds testlist_star_expr) - (f-or! - (f-list 'augassign #:augassign - (Ds augassign) - (f-or (Ds yield_expr) (Ds testlist))) - (f-cons 'assign #:assign - (ff* (f-seq "=" - (f-or (Ds yield_expr) - (Ds testlist_star_expr)))))))) - -(set! testlist_star_expr - (f-cons 'testlist_star_expr - (f-or (Ds test) (Ds star_expr)) - (f-seq - (ff* (f-seq "," (f-or (Ds test) (Ds star_expr)))) - (f? ",")))) - - -(set! augassign - (mk-token - (f-seq 'augassign - ws - (apply f-or! - (map f-tag - '("+=" "-=" "*=" "/=" "%=" "&=" "|=" "^=" - "<<=" ">>=" "**=" "//="))) - ws))) - -(set! del_stmt (f-cons 'del_stmt #:del (f-seq "del" (Ds exprlist)))) - -(set! pass_stmt (f-seq 'pass_stmt "pass" #:pass)) - -(set! flow_stmt - (f-or 'flow_stmt - (f-seq "break" #:break) - (f-seq "continue" #:continue) - (f-cons #:return (f-seq "return" (ff? (Ds testlist)))) - (Ds yield_expr) - (f-cons #:raise (f-seq "raise" - (f-or (f-cons (Ds test) - (ff? - (f-seq "from" (Ds test)))) - (f-cons FALSE FALSE)))))) - -(set! import_name (f-seq "import" dotted_as_names)) -(set! import_stmt (f-list #:import - (f-or 'import_stmt import_name (Ds import_from)))) - - - -(define dottir (mk-token (f-or! (f-tag! "...") (f-tag! ".")))) -(define dots* (ff* dottir)) -(define dots+ (ff+ dottir)) - -(set! import_from - (f-seq 'import_from "from" - (f-cons - (f-or (f-cons dots* (Ds dotted_name)) dots+) - (f-seq "import" (f-or "*" - (f-seq "(" (Ds import_as_names) ")") - (Ds import_as_names)))))) - -(define import_as_name - (f-cons identifier (ff? (f-seq "as" identifier)))) - -(define dotted_as_name - (f-cons (Ds dotted_name) (ff? (f-seq "as" identifier)))) - -(set! import_as_names - (f-seq - (f-cons import_as_name (ff* (f-seq "," import_as_name))) - (f? ","))) - -(set! dotted_as_names - (f-cons dotted_as_name (ff* (f-seq "," dotted_as_name)))) - -(set! dotted_name - (f-cons identifier (ff* (f-seq "." identifier)))) - -(define comma_name - (f-cons identifier (ff* (f-seq "," identifier)))) - -(set! global_stmt - (f-cons 'global #:global (f-seq "global" comma_name))) - -(set! nonlocal_stmt - (f-cons 'nonlocal #:nonlocal (f-seq "nonlocal" comma_name))) - -(set! assert_stmt - (f-cons 'assert #:assert - (f-seq "assert" (f-cons (Ds test) (ff* (f-seq "," (Ds test))))))) - - -(define compound_stmt - (Ds - (f-or! 'compound - if_stmt while_stmt for_stmt try_stmt with_stmt funcdef classdef - decorated))) - -(define single_input (f-or! (f-seq indent= simple_stmt) - (f-seq indent= compound_stmt nl) - (f-seq (f-or nl f-eof)))) - - -(set! stmt (f-or 'stmt simple_stmt compound_stmt)) - -(set! if_stmt - (f-cons 'if_stmt - #:if - (f-seq - "if" - (f-cons (Ds test) - (f-seq ":" - (f-cons (Ds suite) - (f-cons - (ff* (f-seq "elif" - (f-cons (Ds test) - (f-seq ":" (Ds suite))))) - (ff? (f-seq "else" ":" (Ds suite)))))))))) - -(set! while_stmt - (f-cons 'while - #:while - (f-seq "while" - (f-cons (Ds test) - (f-seq ":" - (f-cons (Ds suite) - (ff? (f-seq "else" ":" (Ds suite))))))))) - -(set! for_stmt - (f-cons 'for - #:for - (f-seq "for" - (f-cons (Ds exprlist) - (f-seq "in" - (f-cons (Ds testlist) - (f-cons (f-seq ":" (Ds suite)) - (ff? (f-seq "else" ":" (Ds suite)))))))))) - -(set! try_stmt - (f-cons 'try - #:try - (f-seq ws "try" ":" - (f-cons (Ds suite) - (f-or - (f-cons - (ff+ (f-list (Ds except_clause) ":" (Ds suite))) - (f-cons - (ff? (f-seq "else" ":" (Ds suite))) - (ff? (f-seq "finally" ":" ws (Ds suite))))) - (f-cons - FALSE - (f-cons - FALSE - (f-seq "finally" ":" (Ds suite))))))))) - -(set! with_item - (f-cons (Ds test) (f-seq "as" (Ds expr)))) - -(set! with_stmt - (f-cons 'with - #:with - (f-seq "with" - (f-cons - (f-cons with_item - (ff* (f-seq "," with_item))) - (f-seq ":" (Ds suite)))))) - - -(set! except_clause - (f-seq 'except "except" - (ff? (f-cons (Ds test) (ff? (f-seq "as" identifier)))))) - -(set! suite - (f-cons #:suite - (f-or! (f-list simple_stmt) - (f-seq nl indent+ - (f-cons stmt - (ff* (f-seq indent= stmt))) - indent-)))) - -(set! test - (f-or! 'test - (f-list #:test - (Ds or_test) - (ff? (f-list - (f-seq "if" (Ds or_test)) - (f-seq "else" test)))) - (Ds lambdef))) - -(define test_nocond - (f-or 'nocond (Ds or_test) (Ds lambdef_nocond))) - -(set! lambdef - (f-list 'lambdef - #:lambdef - (f-seq "lambda" (ff? (Ds varargslist) '())) - (f-seq ":" (Ds test)))) - -(set! lambdef_nocond - (f-list 'lambdef_nocond - 'lambdef #:lambdef - (f-seq "lambda" (ff? (Ds varargslist) '())) - (f-seq ":" test_nocond))) - -(set! or_test - (p-freeze 'or_test - (f-or! 'or_test - (f-cons #:or (f-cons (Ds and_test) (ff+ (f-seq "or" (Ds and_test))))) - (Ds and_test)) - mk-id)) - -(set! and_test - (p-freeze 'and_test - (f-or! 'and_test - (f-cons #:and (f-cons (Ds not_test) (ff+ (f-seq "and" (Ds not_test))))) - (Ds not_test)) - mk-id)) - -(set! not_test - (f-or! 'not_test - (f-cons #:not (f-seq "not" not_test)) - (Ds comparison))) - -(set! comparison - (p-freeze 'comparison - (f-or! 'comparison - (f-cons #:comp - (f-cons (Ds expr) - (ff+ (f-cons (Ds comp_op) (Ds expr))))) - (Ds expr)) - mk-id)) - -(set! comp_op - (f-or! 'comp_op - (f-seq (f-seq "not" "in" ) (f-out "notin")) - (f-seq (f-seq "is" "not") (f-out "isnot")) - (apply f-or! - (map (lambda (x) (f-seq x (f-out x))) - '("==" ">=" "<=" "<>" "!=" "in" "is" "<" ">" ))))) - - -(set! star_expr (f-cons 'star_expr #:starexpr (f-seq "*" (Ds expr)))) -(set! expr - (p-freeze 'expr - (f-or! 'expr - (f-cons #:bor (f-cons (Ds xor_expr) (ff+ (f-seq "|" (Ds xor_expr))))) - (Ds xor_expr)) - mk-id)) - -(set! xor_expr - (p-freeze 'xor - (f-or! 'xor - (f-cons #:bxor (f-cons (Ds and_expr) (ff+ (f-seq "^" (Ds and_expr))))) - (Ds and_expr)) - mk-id)) - -(set! and_expr - (p-freeze 'and - (f-or! 'and - (f-cons #:band (f-cons (Ds shift_expr) - (ff+ (f-seq "&" (Ds shift_expr))))) - (Ds shift_expr)) - mk-id)) - -(set! shift_expr - (p-freeze 'shift - (f-or! 'shift - (f-cons #:<< (f-cons (Ds arith_expr) (ff+ (f-seq "<<" (Ds arith_expr) )))) - (f-cons #:>> (f-cons (Ds arith_expr) (ff+ (f-seq ">>" (Ds arith_expr) )))) - (Ds arith_expr)) - mk-id)) - -(set! arith_expr - (p-freeze 'arith - (f-or! 'arith - (f-cons #:+ (f-cons (Ds term) (ff+ (f-seq 'rest "+" (Ds term) )))) - (f-cons #:- (f-cons (Ds term) (ff+ (f-seq "-" (Ds term) )))) - (f-seq 'single_term (Ds term))) - mk-id)) - -(set! term - (p-freeze 'term - (f-or! 'term - (f-cons #:* (f-cons (Ds factor) (ff+ (f-seq "*" (Ds factor) )))) - (f-cons #:// (f-cons (Ds factor) (ff+ (f-seq "//" (Ds factor) )))) - (f-cons #:/ (f-cons (Ds factor) (ff+ (f-seq "/" (Ds factor) )))) - (f-cons #:% (f-cons (Ds factor) (ff+ (f-seq "%" (Ds factor) )))) - (f-seq 'single-factor (Ds factor))) - mk-id)) - - -(set! factor - (p-freeze 'factor - (f-or! 'factor - (f-cons #:u+ (f-seq "+" factor)) - (f-cons #:u- (f-seq "-" factor)) - (f-cons #:u~ (f-seq "~" factor)) - (Ds power)) - mk-id)) - -(set! power - (p-freeze 'power - (f-cons 'power #:power - (f-cons (f-or (f-list #:f (Ds identifier) ":" (Ds atom)) (Ds atom)) - (f-cons (ff* (Ds trailer)) - (f-or! (f-seq "**" factor) - FALSE)))) - mk-id)) - -(set! trailer - (f-or! 'trailer - (f-seq "(" (ff? (Ds arglist)) ")") - (f-seq "[" (Ds subscriptlist) "]") - (f-seq (f-list #:dot (ff+ "." identifier)))) - -(set! atom - (p-freeze 'atom - (f-or! 'atom - (f-cons - #:subexpr - (f-seq "(" (ff? (f-or! (Ds yield_expr) (Ds testlist_comp))) ")")) - (f-cons - #:list - (f-seq "[" (ff? (Ds testlist_comp)) ")")) - (f-cons - #:dict - (f-seq "{" (ff? (Ds dictorsetmaker)) "}")) - (f-seq 'identifier identifier) - (f-seq 'number number) - (ff+ string) - (f-seq #:... "...") - (f-seq #:None "None") - (f-seq #:True "True") - (f-seq #:false "False")) - mk-id)) - -(set! testlist_comp - (f-cons - (f-or! star_expr test) - (f-or! - comp_for - (f-seq (ff* (f-seq "," (f-or! star_expr test))) - (f? ","))))) - -(set! subscriptlist - (f-cons* 'subscriptlist - #:subscripts - (Ds subscript) - (f-seq (ff* (f-seq "," (Ds subscript))) (f? ",")))) - -(set! subscript - (f-or! 'subscript - (f-list (ff? test '()) (f-seq ":" (ff? test '())) (ff? (Ds sliceop))) - (f-list test FALSE FALSE))) - -(set! sliceop - (f-seq ":" (ff? test '()))) - -(define exprlist - (let ((f (f-or expr star_expr))) - (f-cons f (f-seq (ff* (f-seq "," f)) (f? ","))))) - -(set! testlist - (f-cons - test - (f-seq (ff* (f-seq "," test)) (f? ",")))) - -(set! dictorsetmaker - (let ((f (f-cons test (f-seq ":" test)))) - (f-or! - (f-cons* f (f-seq (ff* (f-seq "," f)) (f? ","))) - (f-cons f (Ds comp_for)) - (f-cons test (Ds comp_for)) - (f-cons test (f-seq (ff* (f-seq "," test)) (f? ",")))))) - -(set! classdef - (f-list - #:classdef - (f-seq "class" identifier) - (ff? (f-seq "(" (ff? (Ds arglist) '()) ")")) - (f-seq ":" suite))) - -(set! arglist - (f-or! 'arglist - (f-list 'arg0 - #:arglist - (f-seq (ff* (f-seq (Ds argument) ","))) - (f-seq "*" (f-cons test (ff* (f-seq "," (Ds argument))))) - (ff? (f-seq "," "**" test))) - - (f-list 'arg1 - #:arglist - (f-seq (ff* (f-seq (Ds argument) ","))) - FALSE - (f-seq "**" test)) - - (f-list 'arg2 - #:arglist - (f-seq (f-append (ff* (f-seq (Ds argument) ",")) - (f-seq (Ds argument) (f? ",")))) - FALSE FALSE))) - -(set! argument - (f-or! - (f-list #:= test (f-seq "=" test)) - (f-list #:comp test (ff? (Ds comp_for))))) - -(define comp_iter (f-or! (Ds comp_for) (Ds comp_if))) -(define comp_for (f-list (f-seq "for" exprlist) - (f-seq "in" or_test) - (ff? comp_iter))) -(set! comp_if (f-list (f-seq "if" test_nocond) - (ff? comp_iter))) - -(set! yield_expr - (f-list #:yield (f-seq "yield" (ff? (Ds yield_arg))))) - -(set! yield_arg - (f-or! - (f-list #:from (f-seq "from" test)) - (f-list #:list testlist))) - - -(define input (f-seq - (ff+ (f-seq (f? ws) - (f-or! (f-seq indent= simple_stmt) - (f-seq indent= compound_stmt nl)))) - - (f-seq (f? ws) (f-or nl f-eof)))) - -(define (p str) - (with-fluids ((*whitespace* (f* (f-reg "[ \t\r]")))) - (parse str input))) - -(define (python-parser . l) - (with-fluids ((*whitespace* (f* (f-reg "[ \t\r]")))) - (ppp (apply parse (append l (list (f-seq nl ws single_input ws))))))) - - diff --git a/modules/language/python/persist.scm b/modules/language/python/persist.scm deleted file mode 100644 index 4ee46fc..0000000 --- a/modules/language/python/persist.scm +++ /dev/null @@ -1,114 +0,0 @@ -(define-module (language python persist) - #:use-module (ice-9 match) - #:use-module (ice-9 vlist) - #:use-module (ice-9 pretty-print) - #:use-module (oop goops) - #:use-module (oop pf-objects) - #:use-module (logic guile-log persistance) - #:re-export(pcopyable? deep-pcopyable? pcopy deep-pcopy name-object - name-object-deep) - #:export (reduce cp red cpit)) - -(define-syntax-rule (aif it p x y) (let ((it p)) (if it x y))) - -(define (vhash->assoc v) - (let ((t (make-hash-table))) - (vhash-fold - (lambda (k v s) - (if (hash-ref t k) - s - (begin - (hash-set! t k #t) - (cons (cons k v) s)))) - '() v))) - -(define-method (pcopyable? (o <p>)) #t) -(define-method (deep-pcopyable? (o <p>)) #t) - -(define (cp o) - (match (red o) - ((#:reduce mk f) - (let ((oo (mk))) - (for-each (lambda (x) (apply (car x) oo (cdr x))) f) - oo)))) - -(define (red o) - (fluid-set! first #t) - (list #:reduce - (let ((cl (class-of o))) - (lambda () (make cl))) - (reduce o))) - - -(define-method (pcopy (o <p>)) - (list #:obj - (aif it (ref o '__copy__) - (it) - (cp o)))) - -(define-method (deep-pcopy (o <p>) p?) - (aif it (and p? (ref o '__deepcopy__)) - (list #:obj (it)) - (red o))) - -(define first (make-fluid #f)) -(define-method (reduce o) '()) -(define-method (reduce (o <p>)) - (if (fluid-ref first) - (begin - (fluid-set! first #f) - (cons - (aif it (ref o '__reduce__) - (it) - (cons - (lambda (o args) - (let ((h (make-hash-table))) - (slot-set! o 'h h) - (for-each - (lambda (x) (hash-set! h (car x) (cdr x))) - args))) - (list - (hash-fold - (lambda (k v s) (cons (cons k v) s)) - '() - (slot-ref o 'h))))) - (next-method))) - (next-method))) - -(define (fold f s l) - (if (pair? l) - (fold f (f (car l) s) (cdr l)) - s)) - -(define-method (reduce (o <pf>)) - (if (fluid-ref first) - (begin - (fluid-set! first #f) - (cons* - (cons - (lambda (o n args) - (slot-set! o 'size n) - (slot-set! o 'n n) - (let ((h - (fold - (lambda (k v s) (vhash-assoc k v s)) - vlist-null - args))) - (slot-set! o 'h h))) - (list (slot-ref o 'n) (vhash->assoc (slot-ref o 'h)))) - (next-method))) - (next-method))) - -(define-syntax cpit - (lambda (x) - (syntax-case x () - ((_ <c> (o lam a)) - #'(begin - (define-method (pcopyable? (o <c>) ) #t) - (define-method (deep-pcopyable? (o <c>) ) #t) - (define-method (pcopy (o <c>) ) (cp o)) - (define-method (deep-pcopy (o <c>) p?) (red o)) - (define-method (reduce (o <c>) ) - (cons* - (cons lam a) - (next-method)))))))) diff --git a/modules/language/python/procedure.scm b/modules/language/python/procedure.scm deleted file mode 100644 index e408225..0000000 --- a/modules/language/python/procedure.scm +++ /dev/null @@ -1,165 +0,0 @@ -(define-module (language python procedure) - #:use-module (oop pf-objects) - #:use-module (oop goops) - #:use-module (language python dir) - #:use-module (language python try) - #:use-module (language python def) - #:use-module (language python list) - #:use-module (language python for) - #:use-module (language python exceptions) - #:use-module (language python dict) - #:export (function)) - -(define procedure-property- (@@ (oop pf-objects) procedure-property-)) -(define procedure-properties- (@@ (oop pf-objects) procedure-properties-)) -(define set-procedure-property!- (@@ (oop pf-objects) set-procedure-property!-)) -(define set-procedure-properties!- (@@ (oop pf-objects) set-procedure-properties!-)) - -(define-syntax-rule (aif it p x y) (let ((it p)) (if it x y))) - -(define-python-class function () - (define __init__ - (lambda x (error "function objects not implemented"))) - - (define __call__ - (lam ((* l) (** kw)) - (py-apply (* l) (** kw))))) - -(define e (list 'e)) - -(define-method (ref (f <procedure>) tag . l) - (apply ref-f f tag l)) - -(define-method (ref (f <generic>) tag . l) - (apply ref-f f tag l)) - -(define-method (rawref (f <procedure>) tag . l) - (apply ref-f f tag l)) - -(define-method (rawref (f <generic>) tag . l) - (apply ref-f f tag l)) - -(define (ref-f f tag . l) - (set! tag (if (symbol? tag) tag (string->symbol tag))) - - (cond - ((equal? tag '__class__) - function) - - ((equal? tag '__name__) - (let ((r (procedure-property- f '__name__))) - (if (not r) - (symbol->string (procedure-name f)) - r))) - - ((equal? tag '__doc__) - (let ((r (procedure-property- f tag))) - (if (not r) - "" - r))) - - ((equal? tag '__qualname__) - (aif it (procedure-property- f '__qualname__) - it - (procedure-name f))) - - ((equal? tag '__dict__) - (dict (let lp ((l (procedure-properties- f))) - (if (pair? l) - (cons (list (car l) (cdr l)) - (lp (cdr l))) - '())))) - - ((equal? tag '__annotations__) - (procedure-property- f '__annotations__)) - - ((equal? tag '__closure__) - (error "closure property is not implemented")) - - ((equal? tag '__code__) - (error "code tag is not implemented")) - - ((equal? tag '__defaults) - (error "defaults tag is not implemented")) - - ((equal? tag '__kwdefaults__) - (error "kwdefaults tag is not implemented")) - - (else - (let ((r (procedure-property- f tag))) - (if (not r) - (if (pair? l) (car l) #f) - r))))) - -(define fixed '(__class__ - __call__ - __get__ - __annotations__ - __closure__ - __dict__ - __globals__ - __defaults__ - __kwdefaults__)) - -(define fixed-str (map symbol->string fixed)) - -(define-method (set (x <procedure>) key val) - (set-f x key val)) - -(define-method (set (x <generic>) key val) - (set-f x key val)) - -(define-method (rawset (x <procedure>) key val) - (set-f x key val)) - -(define-method (rawset (x <generic>) key val) - (set-f x key val)) - -(define-method (py-class (o <procedure>)) - (ref o '__class__)) - -(define-method (py-class (o <generic>)) - (ref o '__class__)) - -(define (set-f f tag val) - (set! tag (if (symbol? tag) tag (string->symbol tag))) - - (cond - ((equal? tag '__name__) - (set-procedure-property!- f 'name - (if (symbol? val) - val - (string->symbol val)))) - ((equal? tag '__dict__) - (set-procedure-properties!- f - (for ((k v : val)) ((l '())) - (cons (cons k v) l) - #:final - (reverse l)))) - (else - (set-procedure-property!- f tag val)))) - -(define-method (dir (o <procedure>)) - (let ((ret (+ (to-pylist '("__name__" "__qualname__")) - (to-pylist fixed-str) - (to-pylist (map (lambda (x) - (let ((x (car x))) - (if (symbol? x) - (symbol->string x) - x))) - (procedure-properties- o)))))) - (pylist-sort! ret) - ret)) - -(define-method (dir (o <generic>)) - (let ((ret (+ (to-pylist '("__name__" "__qualname__")) - (to-pylist fixed-str) - (to-pylist (map (lambda (x) - (let ((x (car x))) - (if (symbol? x) - (symbol->string x) - x))) - (procedure-properties- o)))))) - (pylist-sort! ret) - ret)) - diff --git a/modules/language/python/property.scm b/modules/language/python/property.scm deleted file mode 100644 index 132de35..0000000 --- a/modules/language/python/property.scm +++ /dev/null @@ -1,48 +0,0 @@ -(define-module (language python property) - #:use-module (oop pf-objects) - #:use-module (oop goops) - #:use-module (language python def) - #:use-module (language python exceptions) - #:use-module (language python persist) - #:export (property)) - -(cpit <property> (o (lambda (o get set del) - (slot-set! o 'get get) - (slot-set! o 'set set) - (slot-set! o 'del del)) - (list - (slot-ref o 'get) - (slot-ref o 'set) - (slot-ref o 'del)))) - -(define-python-class property (<property>) - (define __init__ - (lam (o (= getx None) (= setx None) (= delx None)) - (slot-set! o 'get getx) - (slot-set! o 'set setx) - (slot-set! o 'del delx) - o)) - - (define __get__ - (lambda (self obj class) - ((slot-ref self 'get) obj))) - - (define setter - (lambda (self f) - (slot-set! self 'set f) - self)) - - (define getter - (lambda (self f) - (slot-set! self 'get f) - self)) - - (define deleter - (lambda (self f) - (slot-set! self 'del f) - self)) - - (define fget (lambda (self) (slot-ref self 'get))) - (define fset (lambda (self) (slot-ref self 'set))) - (define fdel (lambda (self) (slot-ref self 'del)))) - diff --git a/modules/language/python/python.scm b/modules/language/python/python.scm deleted file mode 100644 index e8621ad..0000000 --- a/modules/language/python/python.scm +++ /dev/null @@ -1,265 +0,0 @@ -(define-module (language python python) - #:use-module (language python parser) - #:use-module (language python expr) - #:use-module (ice-9 match) - #:export (compile-python-string compile-python-file)) - -;;; VARIABLES ---------------------------------------------------------------- -(define (find-global-variables vars tree) - (define (for-each* f l) - (match l - ((x . l) - (f x) - (for-each* f l)) - (x - (f x)))) - - (define (local tree) - (match tree - ((#:global l) - (for-each* - (lambda (x) (hash-set! vars x #t)) l)) - ((x . l) - (for-each* local tree)) - (_ - #t))) - - (define (collect tree) - (match tree - ((#:lambdef . _) - #t) - ((#:identifier . l) - (hash-set! vars tree #t)) - ((_ . _) - (for-each* collect tree)) - (_ - #t))) - - (let lp ((tree tree)) - (match tree - ((#:def . l) - (for-each* local l)) - ((#:lambdef . l) - (for-each* local l)) - ((#:class . l) - (for-each* local l)) - ((#:expr-stmt - a (#:assign x ... e)) - (collect a) - (collect x)) - ((x . l) - (for-each* lp tree)) - (_ - #t)))) -;; COMPILATION - -(define (expr stx out tree) - (define (expr-lhs tree) - (match tree - ((#:test (#:power (#:identifier v . _))) - (datum->syntax stx (string->symbol v))))) - - - (define (expr-rhs tree) - (define (comp-tr op) - (match op - ("notin" #'py-notin) - ("isnot" #'py-isnot) - ("==" #'py_==) - (">=" #'py_>=) - ("<=" #'py_<=) - ("<>" #'py_<>) - ("!=" #'py_!=) - ("in" #'py_in) - ("is" #'py_is) - ("<" #'py_< ) - (">" #'py_> ))) - - (let lp ((tree tree)) - (match tree - ((#:test x #f) - (lp x)) - ((#:test x (a b)) - #`(if #,(py-true? (lp a)) #,(lp x) #,(lp b))) - ((#:or x . y) - #`(py-or #,(lp x) #,@(map lp y))) - ((#:and x y) - #`(py-and #,(lp x) #,@(map lp y))) - ((#:not x) - #`(py-not #,(lp x))) - ((#:comp x) - (lp x)) - ((#:comp x (op . y) . l) - #'(#,(comp-tr op) #,(lp x) #,(lp (cons* #:comp y l)))) - ((#:bor x y) - #`(py-bor #,(lp x) #,@(map lp y))) - ((#:bxor x y) - #`(py-bxor #,(lp x) #,@(map lp y))) - ((#:xand x y) - #`(py-band #,(lp x) #,@(map lp y))) - ((#:<< x y) - #`(py-<< #,(lp x) #,@(map lp y))) - ((#:>> x y) - #`(py->> #,(lp x) #,@(map lp y))) - ((#:+ x y) - #`(py-+ #,(lp x) #,@(map lp y))) - ((#:- x y) - #`(py-- #,(lp x) #,@(map lp y))) - ((#:* x y) - #`(py-* #,(lp x) #,@(map lp y))) - ((#:/ x y) - #`(py-/ #,(lp x) #,@(map lp y))) - ((#:// x y) - #`(py-// #,(lp x) #,@(map lp y))) - ((#:% x y) - #`(py-% #,(lp x) #,@(map lp y))) - ((#:u+ x) - #`(py-u+ #,(lp x))) - ((#:u- x) - #`(py-u- #,(lp x))) - ((#:u~ x) - #`(py-u~ #,(lp x))) - ((#:power x trailer . #f) - (compile-trailer trailer (lp x))) - ((#:power x trailer . l) - #'(py-power ,#(compile-trailer trailer (lp x)) #,(lp l))) - ((#:identifier x . _) - (datum->syntax stx (string->symbol x))) - ((not (_ . _)) - tree)))) - - - - (lambda (tree) - (match tree - ((test1 (#:assign)) - (expr-rhs test1)) - ((test1 (#:assign tests ... last)) - (with-syntax (((rhs ...) (map expr-rhs last)) - ((lhs1 ...) (map expr-lhs test1)) - (((lhs ...) ...) (reverse (map (lambda (l) - (map expr-lhs l)) - tests)))) - (with-syntax (((v ...) (generate-temporaries #'(lhs1 ...)))) - (out #'(call-with-values (lambda () (values rhs ...)) - (lambda (v ...) - (begin - (set! lhs v) ...) - ... - (set! lhs1 v) ...))))))))) - - -(define (compile-outer state out tree) - (define (compile-stmt state tree) - (match tree - ((#:expr-stmt l) - (compile-expr l)) - - ((#:del l) - (compile-del l)) - - (#:pass - (out #'(if #f #f))) - - (#:break - (break out)) - - (#:continue - (continue out)) - - ((#:return . l) - (compile-return state l)) - - ((#:raise . l) - (compile-raise state l)) - - ((#:import l) - (compile-import state l)) - - ((#:global . _) - #t) - - ((#:nonlocal . _) - #t) - - ((#:assert . l) - (compile-assert state l)))) - - (match tree - ((#:stmt x) - (for-each* compile-stmt tree)) - ((#:if . l) - (compile-if state l)) - ((#:while . l) - (compile-while state l)) - ((#:for . l) - (compile-for state l)) - ((#:try . l) - (compile-try state l)) - ((#:with . l) - (compile-with state l)) - ((#:def . l) - (compile-def state l)) - ((#:decorated . l) - (compile-decorated state l)))) - - -(define (compile-python0 stx tree output) - (define global-variables (make-hash-table)) - - (find-global-variables global-variables tree) - (set! all-variables - (hash-fold - (lambda (k v e) - (match k - ((_ v . _) - (cons (datum->syntax stx (string->symbol v)) e)))) - '() global-variables)) - (set! all-globals - (hash-fold - (lambda (k v e) - (match k - ((_ v) - (cons (datum->syntax stx (string->symbol v)) e)))) - '() global-variables)) - - (output (with-syntax (((v ...) all-variables)) - #'(begin (define v (if #f #f)) ...))) - - (output (with-syntax (((v ...) all-globals)) - #'(export v ...))) - - (output #`(begin #,@(compile-outer)))) - - -(define (compile-python1 stx tree) - (let ((out '())) - (define (out x) (set! out (cons x out))) - (compile-python0 stx tree out) - (cons* #'begin (reverse out)))) - -(define-syntax compile-python-string - (lambda (x) - (syntax-case x () - ((_ y) - (if (string? (syntax->datum #'y)) - (compile-python1 x (python-parser (syntax->datum #'y)))))))) - -(define-syntax compile-python-file - (lambda (x) - (syntax-case x () - ((_ y) - (if (string? (syntax->datum #'y)) - (with-input-from-file (syntax->datum #'y) - (lambda () (compile-python1 x (python-parser)))) - #f))))) - - - - - - - - - - diff --git a/modules/language/python/range.scm b/modules/language/python/range.scm deleted file mode 100644 index 8cc2741..0000000 --- a/modules/language/python/range.scm +++ /dev/null @@ -1,204 +0,0 @@ -(define-module (language python range) - #:use-module (oop pf-objects) - #:use-module (language python exceptions) - #:use-module (language python number) - #:use-module (language python list) - #:use-module (language python yield) - #:use-module (language python try) - #:use-module (language python persist) - #:export (range)) - -(define-python-class range () - (define __init__ - (case-lambda - ((self n) - (let ((n (py-index n))) - (set self '_a 0) - (set self '_b (max 0 n)) - (set self '_c 1))) - - ((self n m) - (let ((n (py-index n)) - (m (py-index m))) - (set self '_a n) - (set self '_b (max m n)) - (set self '_c 1))) - - ((self n m k) - (let ((n (py-index n)) - (m (py-index m)) - (k (py-index k))) - (cond - ((= k 0) - (raise TypeError "range does not allow 0 as a step")) - ((> k 0) - (set self '_a n) - (set self '_b (if (< m n) n m)) - (set self '_c k)) - ((< k 0) - (set self '_a n) - (set self '_b (if (> m n) n m)) - (set self '_c k))))))) - - (define __iter__ - (lambda (self) - ((make-generator () - (lambda (yield) - (let* ((a (ref self '_a)) - (b (ref self '_b)) - (c (ref self '_c)) - (aa (if (> c 0) a a)) - (op (if (> c 0) < >))) - (let lp ((i aa)) - (if (op i b) - (begin - (yield i) - (lp (+ i c))))))))))) - - (define __reversed__ - (lambda (self) - (__getslice__ self None None -1))) - - (define __repr__ - (lambda (self) - (format #f "range(~a,~a,~a)" - (ref self '_a) - (ref self '_b) - (ref self '_c)))) - - (define __contains__ - (lambda (self x) - (let ((x (py-index x )) - (a (ref self '_a)) - (b (ref self '_b)) - (c (ref self '_c))) - (if (> c 0) - (and - (>= x a) - (< x b) - (= (modulo (- x a) c) 0)) - (and - (<= x a) - (> x b) - (= (modulo (- x a) c) 0)))))) - - (define __getitem__ - (lambda (self x) - (let* ((x (py-index x)) - (a (ref self '_a)) - (b (ref self '_b)) - (c (ref self '_c)) - (m (+ a (* c x)))) - (if (> c 0) - (if (and (>= x 0) - (< m b)) - m - (raise IndexError "getitem out of range")) - (if (and (<= x 0) - (> m b)) - m - (raise IndexError "getitem out of range")))))) - - (define __min__ - (lambda (self) - (let* ((a (ref self '_a)) - (b (ref self '_b)) - (c (ref self '_c)) - (n (abs (py-floordiv (- a b) c)))) - (if (> c 0) - a - (+ a (* c (- n 1))))))) - - (define __max__ - (lambda (self) - (let* ((a (ref self '_a)) - (b (ref self '_b)) - (c (ref self '_c)) - (n (abs (py-floordiv (- a b) c)))) - (if (> c 0) - (+ a (* c (- n 1))) - n)))) - - (define __len__ - (lambda (self) - (let* ((a (ref self '_a)) - (b (ref self '_b)) - (c (ref self '_c))) - (abs (py-floordiv (- a b) c))))) - - (define __getslice__ - (lambda (self x y z) - (let* ((a (ref self '_a)) - (b (ref self '_b)) - (c (ref self '_c)) - (x (if (eq? x None) None (py-index x))) - (y (if (eq? y None) None (py-index y))) - (z (if (eq? z None) None (py-index z))) - (n (abs (py-floordiv (- a b) c)))) - (if (or (eq? z None) (> (* z c) 0)) - (begin - (if (eq? z 'None) (set! z 1)) - (if (eq? y 'None) (set! y n)) - (if (eq? x 'None) (set! x 0)) - (if (< x 0) (set! x 0)) - (if (> x n) (set! x n)) - (if (< y 0) (set! y 0)) - (if (> y n) (set! y n)) - (let* ((cc (* c z)) - (xx (+ a (* c x))) - (yy (+ a (* c y))) - (aa (min xx yy)) - (bb (max xx yy))) - (range aa bb cc))) - (begin - (if (eq? y 'None) (set! y 0)) - (if (eq? x 'None) (set! x n)) - (if (< x 0) (set! x 0)) - (if (> x n) (set! x n)) - (if (< y 0) (set! y 0)) - (if (> y n) (set! y n)) - (let* ((cc (* c z)) - (xx (+ a (* c x))) - (yy (+ a (* c y))) - (aa (max xx yy)) - (bb (min xx yy))) - (range aa bb cc))))))) - - (define __index__ - (case-lambda - ((self x) - (let ((x (py-index x )) - (a (ref self '_a)) - (b (ref self '_b)) - (c (ref self '_c))) - (if (> c 0) - (if (and - (>= x a) - (< x b) - (= (modulo (- x a) c) 0)) - (py-floordiv (- x a) c) - (raise IndexError)) - - (if (and - (<= x a) - (> x b) - (= (modulo (- x a) c) 0)) - (py-floordiv (- x a) c) - (raise IndexError))))) - - ((self x i) - (py-index (pylist-slice None i 1) x)) - ((self x i j) - (py-index (pylist-slice i j 1) x)))) - - (define __count__ - (lambda (self i) - (if (__contains__ self i) - 1 - 0)))) - -(name-object range) - - - - diff --git a/modules/language/python/set.scm b/modules/language/python/set.scm deleted file mode 100644 index 23fb552..0000000 --- a/modules/language/python/set.scm +++ /dev/null @@ -1,295 +0,0 @@ -(define-module (language python set) - #:use-module (oop pf-objects) - #:use-module (oop goops) - #:use-module (language python exceptions) - #:use-module (language python dict) - #:use-module (language python for) - #:use-module (language python try) - #:use-module (language python list) - #:use-module (language python yield) - #:use-module (language python persist) - #:use-module (language python bool) - #:export (py-set frozenset weak-set)) - -(define-class <set> () dict) -(name-object <set>) - -(cpit <set> - (o (lambda (o a) - (slot-set! o 'dict - (let ((h (make-py-hashtable))) - (let lp ((a a)) - (if (pair? a) - (begin - (py-hash-set! h (caar a) (cdar a)) - (lp (cdr a)))))))) - (list - (hash-fold (lambda (k v s) (cons (cons k v) s)) - '() - (slot-ref o 'dict))))) - - -(define miss (list 'miss)) - -(define-method (< (o1 <set>) ( o2 <set>)) - (and (not (equal? o1 o2)) - (for ((k : o1)) () - (if (in k o2) - (values) - (break #f)) - #:final #t))) - -(define-method (> (o1 <set>) ( o2 <set>)) - (and (not (equal? o1 o2)) - (for ((k : o2)) () - (if (in k o1) - (values) - (break #f)) - #:final #t))) - -(define-method (<= (o1 <set>) ( o2 <set>)) - (for ((k : o1)) () - (if (in k o2) - (values) - (break #f)) - #:final #t)) - -(define-method (>= (o1 <set>) ( o2 <set>)) - (for ((k : o2)) () - (if (in k o1) - (values) - (break #f)) - #:final #t)) - -(define-method (in k (o <set>)) - (in k (slot-ref o 'dict))) - -(define-syntax-rule (mk set make-py-hashtable) -(define-python-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 d) - (if (eq? x '()) - (values) - (for ((y : x)) () - (pylist-set! d y #t))))))) - - (define __bool__ - (lambda (self) - (bool (slot-ref self 'dict)))) - - (define pop - (lambda (self) - (call-with-values (lambda () (pylist-pop! (slot-ref self 'dict))) - (lambda (k v) k)))) - - (define add - (lambda (self k) - (pylist-set! (slot-ref self 'dict) k #t))) - - (define copy - (lambda (self) - (let ((dict (py-copy (slot-ref self 'dict)))) - (set dict)))) - - (define difference - (lambda (self . l) - (let* ((d (slot-ref self 'dict)) - (r (py-copy d))) - (let lp ((l l)) - (if (pair? l) - (begin - (for ((x : (car l))) () - (when (in x d) - (pylist-delete! r x))) - (lp (cdr l))))) - (set 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 (in x r) - (pylist-delete! 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 - (pylist-delete! r (car l)) - (lp (cdr l)))))))) - - (define intersection - (lambda (self . l) - (let* ((d (slot-ref self 'dict)) - (r (py-copy d))) - (let lp ((l l)) - (if (pair? l) - (let ((y (car l))) - (for ((k v : r)) ((dels '())) - (if (not (__contains__ y k)) - (cons k dels) - dels) - #:final - (let lp ((dels dels)) - (if (pair? dels) - (begin - (pylist-delete! r (car dels)) - (lp (cdr dels)))))) - (lp (cdr l))))) - (set 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 v : r)) ((dels '())) - (if (not (__contains__ y k)) - (cons k dels) - dels) - #:final - (let lp ((dels dels)) - (if (pair? dels) - (begin - (pylist-delete! 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 v : r)) () - (if (in k x) - (break #f)) - #:final - #t)))) - - (define issubset - (lambda (self x) - (let* ((r (slot-ref self 'dict))) - (for ((k v : r)) () - (if (not (__contains__ x k)) - (break #f)) - #:final - #t)))) - - (define issuperset - (lambda (self x) - (let* ((r (slot-ref self 'dict))) - (for ((x v : r)) () - (if (not (in x r)) - (break #f)) - #:final - #t)))) - - (define remove - (lambda (self x) - (let* ((r (slot-ref self 'dict))) - (if (not (in x r)) - (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 (py-copy d))) - (let lp ((l l)) - (if (pair? l) - (begin - (for ((k : (car l))) () - (pylist-set! r k #t)) - (lp (cdr l))) - (set r)))))) - - (define update - (lambda (self . l) - (let* ((r (slot-ref self 'dict))) - (let lp ((l l)) - (if (pair? l) - (begin - (for ((k v : (car l))) () - (pylist-set! r k #t)) - (lp (cdr l))) - (values)))))) - - (define __repr__ - (lambda (self) - (let* ((r (py-keys (slot-ref self 'dict))) - (n (len r)) - (l (to-list r))) - (cond - ((= n 0) - (format #f "set([])")) - (else - (format #f "set([~a~{, ~a~}])" (car l) (cdr l))))))) - - (define __contains__ - (lambda (self x) - (let* ((d (slot-ref self 'dict)) - (t (slot-ref d 't))) - (not (eq? miss (py-hash-ref t x miss)))))) - - (define __and__ - (lambda (self op) - (intersection self op))) - - (define __or__ - (lambda (self op) - (union self op))) - - (define __sub__ - (lambda (self op) - (difference self op))) - - (define __xor__ - (lambda (self op) - (symmetric_difference self op))) - - (define __eq__ - (lambda (self x) - (and - (is-a? x <p>) - (eq? (ref self '__class__ 1) (ref x '__class__ 2)) - (equal? (ref self 'd 1) (ref x 'd 2))))) - - (define __iter__ - (lambda (self) - ((make-generator () - (lambda (yield) - (for ((k v : (slot-ref self 'dict))) () - (yield k) - (values))))))))) - -(mk set make-py-hashtable) -(mk weak-set make-py-weak-key-hashtable) - -(define py-set set) -(define-python-class frozenset (set)) diff --git a/modules/language/python/spec.scm b/modules/language/python/spec.scm deleted file mode 100644 index 8451222..0000000 --- a/modules/language/python/spec.scm +++ /dev/null @@ -1,63 +0,0 @@ -(define-module (language python spec) - #:use-module (parser stis-parser lang python3-parser) - #:use-module ((language python module python) #:select ()) - #:use-module (language python compile) - #:use-module (language python completer) - #:use-module (rnrs io ports) - #:use-module (ice-9 pretty-print) - #:use-module (ice-9 readline) - #:use-module (system base compile) - #:use-module (system base language) - #:use-module (language scheme compile-tree-il) - #:use-module (language scheme decompile-tree-il) - #:use-module (ice-9 rdelim) - #:export (python)) - -;;; -;;; Language definition -;;; - -(define (pr . x) - (define port (open-file "/home/stis/src/python-on-guile/log.txt" "a")) - (with-output-to-port port - (lambda () - (pretty-print x) (car (reverse x)))) - (close port) - (car (reverse x))) - -(define (c x) (pr (comp (pr (p (pr x)))))) -(define (cc port x) - (if (equal? x "") (read port) (c x))) - -(define (e x) (eval (c x) (current-module))) - -(set! (@@ (ice-9 readline) *readline-completion-function*) (complete-fkn e)) - -(define-language python - #:title "python" - #:reader (lambda (port env) - (if (not (fluid-ref (@@ (system base compile) %in-compile))) - (cc port (read-line port)) - (cc port (read-string port)))) - - #:compilers `((tree-il . ,compile-tree-il)) - #:decompilers `((tree-il . ,decompile-tree-il)) - #:evaluator (lambda (x module) (primitive-eval x)) - #:printer write - #:make-default-environment - (lambda () - ;; Ideally we'd duplicate the whole module hierarchy so that `set!', - ;; `fluid-set!', etc. don't have any effect in the current environment. - (let ((m (make-fresh-user-module))) - ;; Provide a separate `current-reader' fluid so that - ;; compile-time changes to `current-reader' are - ;; limited to the current compilation unit. - (module-define! m 'current-reader (make-fluid)) - - ;; Default to `simple-format', as is the case until - ;; (ice-9 format) is loaded. This allows - ;; compile-time warnings to be emitted when using - ;; unsupported options. - (module-set! m 'format simple-format) - - m))) diff --git a/modules/language/python/string.scm b/modules/language/python/string.scm deleted file mode 100644 index 864a7a1..0000000 --- a/modules/language/python/string.scm +++ /dev/null @@ -1,747 +0,0 @@ -(define-module (language python string) - #:use-module (parser stis-parser) - #:use-module (oop goops) - #:use-module (oop pf-objects) - #:use-module (language python hash) - #:use-module (ice-9 match) - #:use-module (ice-9 iconv) - #:use-module (language python list) - #:use-module (language python exceptions) - #:use-module (language python for) - #:use-module (language python def) - #:use-module (language python bool) - #:use-module (language python persist) - #:use-module (rnrs bytevectors) - #:export (py-format py-capitalize py-center py-endswith - py-expandtabs py-find py-rfind - py-isalnum py-isalpha py-isdigit py-islower - py-isspace py-isupper py-istitle py-join py-ljust - py-rjust py-format-map py-encode - py-rljust py-lower py-upper py-lstrip py-rstrip - py-partition py-replace py-strip py-title - py-rpartitio py-rindex py-split py-rsplit py-splitlines - py-startswith py-swapcase py-translate py-zfill - pystring-listing <py-string> pystring py-string? - scm-str scm-sym py-identifier?)) - -(define-syntax-rule (aif it p x y) (let ((it p)) (if it x y))) - -(define (scm-str x) - (if (string? x) - x - (slot-ref (pystring x) 'str))) - -(define (scm-sym x) - (if (symbol? x) - x - (string->symbol (scm-str x)))) - -(define (py-string? x) - (or (string? x) - (is-a? x <py-string>))) - -(define-class <py-string> () str) -(name-object <py-string>) - -(cpit <py-string> (o (lambda (o s) (slot-set! o 'str s)) - (list (slot-ref o 'str)))) - -(define-syntax-rule (define-py (f n o . u) code ...) - (begin - (define-method (f (o <string>) . u) code ...) - (define-method (f (o <py-string>) . l) (apply f (slot-ref o 'str) l)) - (define-method (f (o <p>) . l) - (aif it (ref o 'n) - (apply it l) - (next-method))))) - -(define-syntax-rule (define-py0 (f o . u) code ...) - (begin - (define-method (f (o <string>) . u) code ...) - (define-method (f (o <py-string>) . l) (apply f (slot-ref o 'str) l)))) - -(define-py0 (pylist-ref s i) - (list->string (list (string-ref s (if (< i 0) - (+ (len s) i) - i))))) - -(define-py0 (bool s) - (if (= (len s) 0) - #f - s)) - -(define-py (py-capitalize capitalize s) - (let* ((n (len s)) - (w (make-string n))) - (let lp ((i 0) (first? #t)) - (if (< i n) - (let ((ch (string-ref s i))) - (if (and first? (char-alphabetic? ch)) - (begin - (string-set! w i (char-upcase ch)) - (lp (+ i 1) #f)) - (begin - (string-set! w i ch) - (lp (+ i 1) first?)))) - w)))) - -(define-py (py-center center o w . l) - (let* ((ws (if (pair? l) - (car (string->list (car l))) - #\space)) - (n (string-length o)) - (w (if (< w n) n w)) - (d (- w n)) - (e (floor-quotient (- w n) 2)) - (s (make-string w #\space))) - (let lp ((i 0) (j e)) - (if (< i n) - (begin - (string-set! s j (string-ref o i)) - (lp (+ i 1) (+ j 1))))) - s)) - - - -(define-py (py-endswith endswith o (suff <string>) . l) - (let* ((n (string-length o)) - (ns (string-length suff)) - (f (lambda (x) (< x 0) (+ n x) x))) - (call-with-values (lambda () - (match l - (() (values 0 n )) - ((x) (values (f x) n )) - ((x y) (values (f x) (f y))))) - (lambda (start end) - (string-suffix? suff o 0 ns start end))))) - -(define-py (py-startswith startswith o (suff <string>) . l) - (let* ((n (string-length o)) - (ns (string-length suff)) - (f (lambda (x) (< x 0) (+ n x) x))) - (call-with-values (lambda () - (match l - (() (values 0 n )) - ((x) (values (f x) n )) - ((x y) (values (f x) (f y))))) - (lambda (start end) - (string-prefix? suff o 0 ns start end))))) - -(define-py (py-expandtabs expandtabs s . l) - (let* ((tabsize (match l (() 8) ((x) x))) - (u (string->list (make-string tabsize #\space))) - (n (string-length s))) - (let lp ((l (string->list s)) (r '())) - (if (pair? l) - (let ((x (car l))) - (if (eq? x #\tab) - (lp (cdr l) (append u r)) - (lp (cdr l) (cons x r)))) - (list->string (reverse r)))))) - -(define-py (py-find find s sub . l) - (let* ((n (string-length s)) - (f (lambda (x) (< x 0) (+ n x) x))) - (call-with-values (lambda () - (match l - (() (values 0 n )) - ((x) (values (f x) n )) - ((x y) (values (f x) (f y))))) - (lambda (start end) - (aif it (string-contains s sub start end) - it - -1))))) - -(define-py (py-rfind rfind s sub . l) - (let* ((n (string-length s)) - (s (string-reverse s)) - (sub (string-reverse sub)) - (f (lambda (x) (< x 0) (+ n x) x))) - (call-with-values (lambda () - (match l - (() (values 0 n )) - ((x) (values (f x) n )) - ((x y) (values (f x) (f y))))) - (lambda (start end) - (aif it (string-contains s sub start end) - (- n it (len sub)) - -1))))) - -(define formatter #f) -(define-py (py-strformat format s . l) - (apply (ref formatter 'format) s l)) - -(define-py (py-format-map format_map s map) - (apply (ref formatter 'vformat) s '() map)) - -(define format (lambda (a b) a)) -(define-py (py-format format s format-string) - (format s format-string)) - -(define-syntax-rule (mk-is py-isalnum isalnum x ...) - (define-py (py-isalnum isalnum s) - (and (> (len s) 0) - (string-fold - (lambda (ch s) - (if (or (x ch) ...) - s - #f)) - #t s)))) - -(mk-is py-isalnum isalnum char-alphabetic? char-numeric?) -(mk-is py-isalpha isalpha char-alphabetic?) -(mk-is py-isdigit isdigit char-numeric?) -(mk-is py-islower islower (lambda (ch) (or (eq? ch #\_) (char-lower-case? ch)))) -(mk-is py-isspace isspace char-whitespace?) -(mk-is py-isupper isupper (lambda (ch) (or (eq? ch #\_) (char-upper-case? ch)))) - -(define-py (py-identifier? isidentifier s) - (let lp ((l (string->list s)) (first? #t)) - (if (pair? l) - (let ((x (car l))) - (if first? - (if (or (char-alphabetic? x) - (eq? x #\_)) - (lp (cdr l) #f) - #f) - (if (or (char-alphabetic? x) - (char-numeric? x) - (eq? x #\_)) - (lp (cdr l) #f) - #f))) - (if ((@ (language python module keyword) iskeyword) s) - #f - #t)))) - -(define-py (py-istitle istitle s) - (let ((n (len s))) - (if ((> n 0)) - (let lp ((i 0) (space? #t)) - (if (< i n) - (let ((ch (string-ref s i))) - (if space? - (cond - ((char-whitespace? ch) - (lp (+ i 1) #t)) - ((char-upper-case? ch) - (lp (+ i 1) #f)) - (else - #f)) - (cond - ((char-whitespace? ch) - (lp (+ i 1) #t)) - ((char-upper-case? ch) - #f) - ((char-lower-case? ch) - (lp (+ i 1) #f)) - (else - #f)))) - #t)) - #f))) - - -(define-py (py-join join s iterator) - (string-join (to-list iterator) s)) - -(define-py (py-ljust ljust s width . l) - (let* ((n (len s)) - (ch (match l - ((x . l) - (if (string? x) - (string-ref x 0) - x)) - (() - #\space)))) - (if (< width n) - (pylist-slice s 0 width 1) - (let ((ret (make-string width ch))) - (let lp ((i 0)) - (if (< i n) - (begin - (string-set! ret i (string-ref s i)) - (lp (+ i 1))) - ret)))))) - -(define-py (py-rjust rjust s width . l) - (let* ((n (len s)) - (ch (match l - ((x . l) - (if (string? x) - (string-ref x 0) - x)) - (() - #\space)))) - (if (< width n) - (pylist-slice s (- width) (len s) 1) - (let ((ret (make-string width ch))) - (let lp ((i 0) (j (- width n))) - (if (< i n) - (begin - (string-set! ret j (string-ref s i)) - (lp (+ i 1) (+ j 1))) - ret)))))) - -(define-py (py-lower lower s) - (string-downcase s)) - -(define-py (py-upper upper s) - (string-upcase s)) - -(define-py (py-lstrip lstrip s . l) - (match l - (() - (string-trim s)) - ((x . _) - (let ((l (map (lambda (x) (if (string? x) (string-ref x 0) x)) (to-list x)))) - (string-trim s (lambda (ch) (member ch l))))))) - -(define-py (py-rstrip rstrip s . l) - (match l - (() - (string-trim-right s)) - ((x . _) - (let ((l (map (lambda (x) (if (string? x) (string-ref x 0) x)) - (to-list x)))) - (string-trim-right s (lambda (ch) (member ch l))))))) - -(define-py (py-partition partition s (sep <string>)) - (let ((n (len s)) - (m (len sep))) - (define (test i) - (let lp ((i i) (j 0)) - (if (< i n) - (if (< j m) - (if (eq? (string-ref s i) (string-ref sep j)) - (lp (+ i 1) (+ j 1)) - #f) - #t) - #f))) - (let lp ((i 0)) - (if (< i n) - (if (test i) - (list (pylist-slice s 0 i 1) sep (pylist-slice s (+ i m) n 1)) - (lp (+ i 1))) - (list s "" ""))))) - -(define-py (py-partition partition s (sep <py-string>)) - (py-partition s (slot-ref sep 'str))) - - -(define-py (py-rpartition rpartition ss (ssep <string>)) - (let* ((s (string-reverse ss)) - (sep (string-reverse ssep)) - (n (len s)) - (m (len sep))) - (define (test i) - (let lp ((i i) (j 0)) - (if (< i n) - (if (< j m) - (if (eq? (string-ref s i) (string-ref sep j)) - (lp (+ i 1) (+ j 1)) - #f) - #t) - #f))) - (let lp ((i 0)) - (if (< i n) - (if (test i) - (list (string-reverse - (pylist-slice s (+ i m) n 1)) - ssep - (string-reverse - (pylist-slice s 0 i 1))) - (lp (+ i 1))) - (list "" "" s))))) - -(define-py (py-rpartition rpartition s (sep <py-string>)) - (py-rpartition s (slot-ref sep 'str))) - -(define-py (py-replace replace s old new . l) - (let ((n (match l (() #f) ((n . _) n)))) - (string-join - (reverse - (let lp ((s s) (r '())) - (let ((l (py-partition s old))) - (if (equal? (cadr l) "") - (cons s r) - (lp (list-ref l 2) (cons (car l) r)))))) - new))) - -(define-py (py-strip strip s . l) - (apply py-rstrip (apply py-lstrip s l) l)) - -(define-py (py-title title s) - (string-titlecase s)) - -(define-py (py-rindex rindex s . l) - (let ((n (len s))) - (- n (apply pylist-index (string-reverse s) l) 1))) - -(define bytes #f) - -(define (geterr errors) - (set! errors (py-lower (scm-str errors))) - (cond - ((equal? errors "strict") - 'error) - ((equal? errors "escape") - 'escape) - ((equal? errors "replace") - 'substitute) - ((equal? errors "ignore") - (warn - (string-append - "not possible to use ignore " - "encodong error strategy " - "using replace in stead")) - 'substitute) - (else - (warn - "not a correct encodong error strategy") - 'error))) - -(define-py (py-encode encode s . l) - (apply (lam ((= encoding "UTF-8") (= errors "strict")) - (set! encoding (py-upper (scm-str encoding))) - (set! errors (geterr errors)) - (bytes (string->bytevector (scm-str s) encoding errors))) - l)) - -(define-py (py-split split s . l) - (define N 1000000000000) - - (define ws? #f) - (define ws (list #\space #\newline #\tab #\return)) - (define (to-ch x) (string-ref (scm-str x) 0)) - - (define (mksep sep) - (for ((x : sep)) ((l '())) - (cons - (cond - ((and (number? x) (integer? x)) - (integer->char x)) - ((char? x) - x) - (else - (to-ch x))) l) - #:final - (reverse l))) - - (call-with-values - (lambda () - (match l - (() - (set! ws? #t) - (values '() N)) - - ((sep) - (values (mksep sep) N)) - - ((sep n) - (values (mksep sep) n)))) - - (lambda (sep n) - (let lp ((l (string->list (scm-str s))) (i 0) (v '()) (r '())) - (if (= i n) - (reverse (cons (list->string l) r)) - (if (pair? l) - (let ((ch (car l))) - (if ws? - (if (member ch ws) - (let lp2 ((l (cdr l))) - (if (pair? l) - (let ((ch (car l))) - (if (member ch ws) - (lp2 (cdr l)) - (lp l (+ i 1) '() - (cons - (list->string (reverse v)) - r)))) - (lp l (+ i 1) '() - (cons - (list->string (reverse v)) - r)))) - (lp (cdr l) i (cons ch v) r)) - (if (eq? ch (car sep)) - (let lp2 ((ll (cdr l)) (s (cdr sep))) - (if (pair? s) - (if (pair? ll) - (let ((ch2 (car ll))) - (if (eq? ch2 (car s)) - (lp2 (cdr ll) (cdr sep)) - (lp (cdr l) i (cons ch v) r))) - (lp (cdr l) i (cons ch v) r)) - (lp ll (+ i 1) '() - (cons - (list->string (reverse v)) - r)))) - (lp (cdr l) i (cons ch v) r)))) - (reverse (cons (list->string (reverse v)) r)))))))) - - - - - - - - - - - - - -(define-py (py-rsplit rsplit s . l) - (reverse - (map string-reverse - (apply py-split - (string-reverse s) - (match l - (() '()) - ((sep . l) (cons (string-reverse sep) l))))))) - - -(define-py (py-splitlines splitlines s . l) - (let ((n (len s)) - (keep? (match l - ((#:keepends v) - v) - ((v) - v) - (_ #f)))) - (let lp ((i 0) (r '()) (old 0)) - (if (< i n) - (let ((ch (string-ref s i))) - (if (eq? ch #\newline) - (if keep? - (lp (+ i 1) - (cons - (pylist-slice s old (+ i 1) 1) - r) - (+ i 1)) - (lp (+ i 1) - (cons - (pylist-slice s old i 1) - r) - (+ i 1))) - (lp (+ i 1) r old))) - (reverse r))))) - -(define-py (py-swapcase swapcase s) - (list->string - (string-fold - (lambda (ch s) - (cons - (cond - ((char-upper-case? ch) - (char-downcase ch)) - ((char-lower-case? ch) - (char-upcase ch)) - (else ch)) - s)) - '() - s))) - -(define-py (py-translate translate s table . l) - (let* ((n (len s)) - (w (make-string n)) - (t (if (eq? table None) - #f - table)) - (d (match l (() #f) ((x) x)))) - (define (tr ch) - (define (e) - (if t - (let ((i (char->integer ch))) - (catch #t - (lambda () (integer->char (pylist-ref t i))) - (lambda x ch))) - ch)) - - (if d - (if (string-contains d (list->string (list ch))) - #f - (e)) - (e))) - - (let lp ((i 0) (k 0)) - (if (< i n) - (let ((ch (tr (string-ref s i)))) - (if ch - (begin - (string-set! w k ch) - (lp (+ i 1) (+ k 1))) - (lp (+ i 1) k))) - (if (= k n) - w - (pylist-slice w 0 k 1)))))) - -(define-syntax-rule (a b x y) (b (symbol->string x) (symbol->string y))) - -(define-syntax-rule (mkop op) - (begin - (define-method (op (s1 <string>) (s2 <py-string>)) - (op s1 (slot-ref s2 'str))) - (define-method (op (s2 <py-string>) (s1 <string>)) - (op s1 (slot-ref s2 'str))))) - -(mkop <) -(mkop <=) -(mkop >) -(mkop >=) -(mkop +) -(mkop *) - -(define-method (< (s1 <string>) (s2 <string>)) (string-ci< s1 s2)) -(define-method (<= (s1 <string>) (s2 <string>)) (string-ci<= s1 s2)) -(define-method (> (s1 <string>) (s2 <string>)) (string-ci> s1 s2)) -(define-method (>= (s1 <string>) (s2 <string>)) (string-ci>= s1 s2)) - -(define-method (< (s1 <symbol>) (s2 <symbol>)) (a string-ci< s1 s2)) -(define-method (<= (s1 <symbol>) (s2 <symbol>)) (a string-ci<= s1 s2)) -(define-method (> (s1 <symbol>) (s2 <symbol>)) (a string-ci> s1 s2)) -(define-method (>= (s1 <symbol>) (s2 <symbol>)) (a string-ci>= s1 s2)) - - -(define-py (py-zfill zfill s width) - (let* ((n (len s)) - (w (pylist-slice s 0 n 1))) - (let lp ((i 0)) - (if (< i n) - (let ((ch (string-ref s i))) - (if (char-numeric? ch) - (let lp ((j (max 0 (- i width)))) - (if (< j i) - (begin - (string-set! w j #\0) - (lp (+ j 1))) - w)) - (lp (+ i 1)))) - s)))) - -(define b? #f) -(define b-decode #f) -(define-python-class string (<py> <py-string>) - (define __init__ - (case-lambda - ((self) - "") - ((self s . l) - (cond - ((is-a? s <py-string>) - (slot-ref s 'str)) - ((is-a? s <string>) - s) - ((b? s) - (apply b-decode s l)) - (else - (aif it (ref s '__str__) - (it) - (__init__ self ((@ (guile) format) #f "~a" s)))))))) - - - (define __new__ - (lambda x - (apply __init__ x))) - - (define __newobj__ - (lambda (cls value) - (let ((obj ((rawref object '__new__) cls))) - (slot-set! obj 'str (__new__ cls value)) - obj))) - - (define __repr__ - (lambda (self) - (slot-ref self 'str)))) - -(name-object string) - -(define pystring string) - -(define-method (py-class (o <string>)) string) -(define-method (py-class (o <py-string>)) string) - -(define-method (pyhash (o <py-string>)) (hash (slot-ref o 'str) pyhash-N)) - -(define-method (py-equal? (o <py-string>) x) - (equal? (slot-ref o 'str) x)) -(define-method (py-equal? x (o <py-string>)) - (equal? (slot-ref o 'str) x)) - -(define-class <string-iter> (<py-string>) str i d) -(name-object <string-iter>) -(cpit <string-iter> (o - (lambda (o str i d) - (slot-set! o 'str str) - (slot-set! o 'i i ) - (slot-set! o 'd d )) - (list - (slot-ref o 'str) - (slot-ref o 'i) - (slot-ref o 'd)))) - - -(define-method (write (o <string-iter>) . l) - (define port (if (null? l) #t (car l))) - (for ((x : o)) ((l '())) - (cons (string-ref x 0) l) - #:final - ((@ (guile) format) port "iter(~s)" (list->string (reverse l))))) - -(define-method (wrap-in (o <string-iter> )) - (let ((out (make <string-iter>))) - (slot-set! out 'str (slot-ref o 'str)) - (slot-set! out 'i (slot-ref o 'i)) - (slot-set! out 'd (slot-ref o 'd)) - out)) - -(define-method (wrap-in (s <string>)) - (let ((out (make <string-iter>))) - (slot-set! out 'str s) - (slot-set! out 'i 0) - (slot-set! out 'd 1) - out)) - -(define-method (py-reversed (s <string>)) - (let ((out (make <string-iter>))) - (slot-set! out 'str s) - (slot-set! out 'i (- (string-length s) 1)) - (slot-set! out 'd -1) - out)) - -(define-method (next (o <string-iter>)) - (let ((i (slot-ref o 'i )) - (d (slot-ref o 'd)) - (str (slot-ref o 'str))) - (if (> d 0) - (if (< i (string-length str)) - (let ((ret (string-ref str i))) - (slot-set! o 'i (+ i d)) - (list->string (list ret))) - (throw StopIteration)) - (if (>= i 0) - (let ((ret (string-ref str i))) - (slot-set! o 'i (+ i d)) - (list->string (list ret))) - (throw StopIteration))))) - -(define (pystring-listing) - (let ((l (to-pylist - (map symbol->string - '(__add__ __class__ __contains__ __delattr__ __doc__ - __eq__ __format__ __ge__ __getattribute__ - __getitem__ __getnewargs__ __getslice__ __gt__ - __hash__ __init__ __le__ __len__ __lt__ __mod__ - __mul__ __ne__ __new__ __reduce__ __reduce_ex__ - __repr__ __rmod__ __rmul__ __setattr__ __sizeof__ - __str__ __subclasshook__ - _formatter_field_name_split _formatter_parser - capitalize center count encode endswith - expandtabs find format index isalnum isalpha - isdigit islower isspace istitle isupper join - ljust lower lstrip partition replace rfind rindex - rjust rpartition rsplit rstrip split splitlines - startswith strip swapcase format_map - title translate upper zfill))))) - (pylist-sort! l) - l)) - - diff --git a/modules/language/python/try.scm b/modules/language/python/try.scm deleted file mode 100644 index 50ca23f..0000000 --- a/modules/language/python/try.scm +++ /dev/null @@ -1,122 +0,0 @@ -(define-module (language python try) - #:use-module (language python exceptions) - #:use-module (language python yield) - #:use-module (oop pf-objects) - #:use-module (oop goops) - #:use-module (ice-9 control) - #:use-module (ice-9 match) - #:replace (raise) - #:export (try)) - -(define-syntax-rule (aif it p x y) (let ((it p)) (if it x y))) - -(define-inlinable (standard-check class obj l) - (cond - ((eq? class #t) - #t) - ((struct? obj) - (if (is-a? obj <p>) - (if (is-a? class <p>) - (is-a? obj (ref class '__goops__)) - (is-a? obj class)) - (if (is-a? obj <object>) - (is-a? obj class) - (eq? obj class)))) - ((and (procedure? class) (not (pyclass? class))) - (apply class obj l)) - (else - (eq? class obj)))) - - -(define (check class obj l) - (standard-check class obj l)) - -(define-syntax compile-error - (lambda (x) - (syntax-case x () - ((_ x) - (error (syntax->datum #'x)))))) - -(define-syntax check-exception - (syntax-rules (and or not) - ((_ (or E ...) tag l) - (or (check-exception E tag l) ...)) - ((_ (and E ...) tag l) - (and (check-exception E tag l) ...)) - ((_ (not E) tag l) - (not (check-exception E tag l))) - ((_ E tag l) - (check E tag l)))) - -(define (m code) - (let ((c code)) - (lambda (k . l) - (if (eq? k StopIteration) - (apply c 'python k l) - (apply c k l))))) - -(define-syntax handler - (lambda (x) - (syntax-case x () - ((_ . l) #'(handler_ . l))))) - -(define-syntax handler_ - (syntax-rules (=>) - ((handler ecx) - (m - (lambda (k tag . l) - (handler ecx tag l)))) - - ((handler ((#:except E => lam) . ecx) tag l) - (if (check-exception E tag l) - (lam tag l) - (handler ecx tag l))) - - ((handler ((#:except E) . ecx) tag l) - (if (check-exception E tag l) - (begin (values)) - (handler ecx tag l))) - - ((handler ((#:except E code ...) . ecx) tag l) - (if (check-exception E tag l) - (begin code ...) - (handler ecx tag l))) - - ((handler ((#:else code ...)) tag l) - (begin code ...)) - - ((handler () tag l) - (apply throw 'python tag l)) - - ((a ...) - (compile-error "not a proper python macro try block")))) - - - -(define-syntax try - (syntax-rules () - ((try code exc ... #:finally fin) - (dynamic-wind - (lambda () #f) - (lambda () - (catch #t - code - (handler (exc ...)))) - (lambda () - (if (not (fluid-ref in-yield)) - (fin))))) - - ((try code exc ...) - (catch #t - code - (handler (exc ...)))))) - - -(define raise - (case-lambda - ((x . l) - (if (pyclass? x) - (throw 'python (apply x l)) - (apply throw 'python x l))) - - (() (raise Exception)))) diff --git a/modules/language/python/tuple.scm b/modules/language/python/tuple.scm deleted file mode 100644 index 4ba83b1..0000000 --- a/modules/language/python/tuple.scm +++ /dev/null @@ -1,49 +0,0 @@ -(define-module (language python tuple) - #:use-module (oop goops) - #:use-module (oop pf-objects) - #:use-module (language python hash) - #:use-module (language python for) - #:use-module (language python bool) - #:use-module (language python persist) - #:export (tuple <py-tuple> defpair)) - - -(define-class <py-tuple> () l) -(name-object <py-tuple>) -(cpit <py-tuple> - (o (lambda (o l) - (slot-set! o 'l (map (lambda (x) x) l))) - (list - (slot-ref o 'l)))) - -(define-method (py-hash (o <py-tuple>)) (py-hash (slot-ref o 'l))) -(define-method (py-class (o <py-tuple>) tuple)) -(define-method (py-equal? (o1 <py-tuple>) o2) (equal? (slot-ref o1 'l) o2)) -(define-method (py-equal? o1 (o2 <py-tuple>)) (equal? o1 (slot-ref o2 'l))) -(define-method (bool (o <py-tuple>)) (pair? (slot-ref o 'l))) -(define-method (wrap-in (o <py-tuple>)) - (wrap-in (slot-ref o 'l))) - -(define-python-class tuple (<py-tuple>) - (define __init__ - (case-lambda - ((self) - (slot-set! self 'l '())) - ((self it) - (slot-set! self 'l - (for ((x : it)) ((l '())) - (cons x l) - #:final - (reverse l)))))) - (define __repr__ - (lambda (self) (format #f "~a" (slot-ref self 'l))))) - -(name-object tuple) - -(define-syntax-rule (defpair (f o . u) code ...) - (begin - (define-method (f (o <pair>) . u) - code ...) - (define-method (f (o <py-tuple>) . l) - (let ((o (slot-ref o 'l))) - (apply f o l))))) diff --git a/modules/language/python/util.scm b/modules/language/python/util.scm deleted file mode 100644 index 40206f0..0000000 --- a/modules/language/python/util.scm +++ /dev/null @@ -1,2 +0,0 @@ -(define-module (language python util) - #:export ()) diff --git a/modules/language/python/with.scm b/modules/language/python/with.scm deleted file mode 100644 index 0193189..0000000 --- a/modules/language/python/with.scm +++ /dev/null @@ -1,53 +0,0 @@ -(define-module (language python with) - #:use-module (language python try) - #:use-module (language python exceptions) - #:use-module (oop pf-objects) - #:export (with)) - -(define-syntax-rule (aif it p x y) (let ((it p)) (if it x y))) - -(define-syntax with - (syntax-rules () - ((_ () . code) - (begin . code)) - ((_ (x . l) . code) - (with0 x (with l . code))))) - -(define-syntax with0 - (syntax-rules () - ((_ (id exp) . code) - (let ((type None) - (value None) - (trace None)) - (aif exit (ref exp '__exit__) - (aif enter (ref exp '__enter__) - (try - (lambda () - (let ((id (enter))) . code)) - (#:except #t => - (lambda (tag l) - (set! type (if (pyclass? tag) - tag - (aif it (ref tag '__class__) - it - tag))) - (set! value - (aif it (ref tag 'value) - it - (if (pair? l) - (car l) - None))))) - #:finally - (lambda () - (exit type value trace))) - (raise TypeError "no __enter__ member")) - (raise TypeError "no __exit__ member")))) - - ((_ (exp) . code) - (with0 (id exp) . code)))) - - - - - - diff --git a/modules/language/python/yield.scm b/modules/language/python/yield.scm deleted file mode 100644 index 9fb5d8e..0000000 --- a/modules/language/python/yield.scm +++ /dev/null @@ -1,138 +0,0 @@ -(define-module (language python yield) - #:use-module (oop pf-objects) - #:use-module (language python exceptions) - #:use-module (oop goops) - #:use-module (ice-9 control) - #:use-module (ice-9 match) - #:use-module (language python persist) - #:replace (send) - #:export (<yield> - in-yield define-generator - make-generator - sendException sendClose)) - -(define-syntax-rule (aif it p x y) (let ((it p)) (if it x y))) - -(define in-yield (make-fluid #f)) - -(define-syntax-parameter YIELD (lambda (x) #f)) - -(define-syntax yield - (lambda (x) - (syntax-case x () - ((_ x ...) - #'(begin - (fluid-set! in-yield #t) - ((abort-to-prompt YIELD x ...)))) - (x - #'(lambda x - (fluid-set! in-yield #t) - ((apply abort-to-prompt YIELD x))))))) - -(define-syntax make-generator - (syntax-rules () - ((_ closure) - (make-generator () closure)) - ((_ args closure) - (lambda a - (let () - (define obj (make <yield>)) - (define ab (make-prompt-tag)) - (syntax-parameterize ((YIELD (lambda x #'ab))) - (slot-set! obj 'k #f) - (slot-set! obj 'closed #f) - (slot-set! obj 's - (lambda () - (call-with-prompt - ab - (lambda () - (apply closure yield a) - (slot-set! obj 'closed #t) - (throw StopIteration)) - (letrec ((lam - (lambda (k . l) - (fluid-set! in-yield #f) - (slot-set! obj 'k - (lambda (a) - (call-with-prompt - ab - (lambda () - (k a)) - lam))) - (apply values l)))) - lam)))) - obj)))))) - -(define-syntax define-generator - (lambda (x) - (syntax-case x () - ((_ (f y . args) code ...) - #'(define f (make-generator args (lambda (y . args) code ...))))))) - -(define-class <yield> () s k closed) -(name-object <yield>) -(cpit <yield> (o (lambda (o s k closed) - (slot-set! o 's s ) - (slot-set! o 'k k ) - (slot-set! o 'closed closed)) - (list - (slot-ref o 's) - (slot-ref o 'k) - (slot-ref o 'closed)))) - -(define-method (send (l <yield>) . u) - (let ((k (slot-ref l 'k)) - (s (slot-ref l 's)) - (c (slot-ref l 'closed))) - (if (not c) - (if k - (k (lambda () - (if (null? u) - 'Null - (apply values u)))) - (throw 'python (Exception)))))) - - -(define-method (sendException (l <yield>) e . ls) - (let ((k (slot-ref l 'k)) - (s (slot-ref l 's)) - (c (slot-ref l 'closed))) - (if (not c) - (if k - (k (lambda () - (if (pyclass? e) - (throw 'python (apply e ls)) - (apply throw 'python e ls)))) - (throw 'python (Exception)))))) - -(define-method (sendClose (l <yield>)) - (let ((k (slot-ref l 'k)) - (s (slot-ref l 's)) - (c (slot-ref l 'closed))) - (if c - (values) - (if k - (catch #t - (lambda () - (k (lambda () (throw 'python GeneratorExit))) - (slot-set! l 'closed #t) - (throw 'python RuntimeError)) - (lambda (k tag . v) - (slot-set! l 'closed #t) - (if (eq? tag 'python) - (match v - ((tag . l) - (if (eq? tag GeneratorExit) - (values) - (apply throw tag l)))) - (apply throw tag v)))) - (slot-set! l 'closed #t))))) - -(define-method (send (l <p>) . u) - (apply (ref l '__send__) u)) - -(define-method (sendException (l <p>) . u) - (apply (ref l '__exception__) u)) - -(define-method (sendClose (l <p>)) - ((ref l '__close__))) |