diff options
Diffstat (limited to 'modules')
-rw-r--r-- | modules/language/python/compile.scm | 63 | ||||
-rw-r--r-- | modules/language/python/dict.scm | 42 | ||||
-rw-r--r-- | modules/language/python/list.scm | 93 | ||||
-rw-r--r-- | modules/language/python/module/python.scm | 8 | ||||
-rw-r--r-- | modules/language/python/number.scm | 42 | ||||
-rw-r--r-- | modules/language/python/string.scm | 11 | ||||
-rw-r--r-- | modules/oop/pf-objects.scm | 146 |
7 files changed, 294 insertions, 111 deletions
diff --git a/modules/language/python/compile.scm b/modules/language/python/compile.scm index c9acea1..c3a6493 100644 --- a/modules/language/python/compile.scm +++ b/modules/language/python/compile.scm @@ -223,7 +223,7 @@ (define fasthash (mkfast ;; General - ((__init__) (O 'init)) + ((__init__) (O 'py-init)) ((__getattr__) (O 'getattr)) ((__setattr__) (O 'setattr)) ((__delattr__) (O 'delattr)) @@ -722,18 +722,19 @@ (parents (filt parents))) `(define ,class (,(C 'class-decor) ,decor - (,(O kind) - ,class - ,(map (lambda (x) `(,(O 'get-class) ,x)) parents) - #:const - () - #:dynamic - ,(match (filter-defs (exp vs defs)) - (('begin . l) - l) - ((('begin . l)) - l) - (l l)))))))))) + (,(C 'with-class) ,class + (,(O kind) + ,class + ,(map (lambda (x) `(,(O 'get-class) ,x)) parents) + #:const + () + #:dynamic + ,(match (filter-defs (exp vs defs)) + (('begin . l) + l) + ((('begin . l)) + l) + (l l))))))))))) (#:scm ((_ (#:string _ s)) (with-input-from-string s read))) @@ -968,34 +969,38 @@ (,(D 'lam) (,@args ,@*f ,@**f) (,(C 'with-return) ,r ,(mk `(let ,(map (lambda (x) (list x #f)) ls) - ,(with-fluids ((return r)) - (exp ns code))))))))) + (,(C 'with-self) ,c? ,args + ,(with-fluids ((return r)) + (exp ns code)))))))))) `(define ,f (,(C 'def-decor) ,decor (,(D 'lam) (,@args ,@*f ,@**f) (,(C 'with-return) ,r ,(mk `(let ,(map (lambda (x) (list x #f)) ls) + (,(C 'with-self) ,c? ,args ,(with-fluids ((return r)) - (exp ns code))))))))) + (exp ns code)))))))))) (if y? `(define ,f (,(C 'def-decor) ,decor (,(C 'def-wrap) ,y? ,f ,ab (,(D 'lam) (,@args ,@*f ,@**f) - (,(C 'with-return) ,r + (,(C 'with-return) ,r (let ,(map (lambda (x) (list x #f)) ls) - ,(with-fluids ((return r)) - (mk - (exp ns code))))))))) + (,(C 'with-self) ,c? ,args + ,(with-fluids ((return r)) + (mk + (exp ns code)))))))))) `(define ,f (,(C 'def-decor) ,decor (,(D 'lam) (,@args ,@*f ,@**f) - (,(C 'with-return) ,r + (,(C 'with-return) ,r (let ,(map (lambda (x) (list x #f)) ls) - ,(with-fluids ((return r)) - (exp ns code))))))))))))) + (,(C 'with-self) ,c? ,args + ,(with-fluids ((return r)) + (exp ns code)))))))))))))) (#:global ((_ . _) @@ -1691,5 +1696,15 @@ ((_ () 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)))) diff --git a/modules/language/python/dict.scm b/modules/language/python/dict.scm index 5b6567b..f4d13a5 100644 --- a/modules/language/python/dict.scm +++ b/modules/language/python/dict.scm @@ -17,6 +17,8 @@ py-hash-ref dict pyhash-listing )) +(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-hash-ref . l) @@ -155,15 +157,19 @@ (define-method (nm (o class) l ...) code ...) ... (define-method (nm (o <p>) l ...) - ((ref o 'n) l ...)))) + (aif it (ref o 'n) + (it l ...) + (next-method))))) ((_ (nm n o l ... . u) (class code ...) ...) (begin (define-method (nm (o class) l ... . u) code ...) ... (define-method (nm (o <p>) l ... . u) - (apply (ref o 'n) l ... u)))))) - - + (aif it (ref o 'n) + (apply it l ... u) + (next-method))))))) + + (define-py (py-copy copy o) (<hashtable> @@ -475,19 +481,21 @@ (define-python-class dict (<py-hashtable>) (define __init__ - (case-lambda - ((self) - (let ((r (make-py-hashtable))) - (slot-set! self 't (slot-ref r 't)) - (slot-set! self 'h (slot-ref r 'h)) - (slot-set! self 'n (slot-ref r 'n)))) - ((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))))))) + (letrec ((__init__ + (case-lambda + ((self) + (let ((r (make-py-hashtable))) + (slot-set! self 't (slot-ref r 't)) + (slot-set! self 'h (slot-ref r 'h)) + (slot-set! self 'n (slot-ref r 'n)))) + ((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 diff --git a/modules/language/python/list.scm b/modules/language/python/list.scm index 1a3e7c5..5b4daf0 100644 --- a/modules/language/python/list.scm +++ b/modules/language/python/list.scm @@ -29,7 +29,9 @@ (pylist-subset! o k (+ k 1) None pylist-null))) (define-method (pylist-delete! (o <p>) k) - ((ref o '__delitem__) k)) + (aif it (ref o '__delitem__) + (it k) + (next-method))) (define pylist-null (let ((o (make <py-list>))) @@ -53,7 +55,9 @@ x)) (define-method (to-list (x <p>)) - ((ref x '__tolist__ (lambda () (error "missing __tolist__ in object"))))) + (aif it (ref x '__tolist__) + (it) + (next-method))) (define-method (to-list (x <pair>)) @@ -125,7 +129,9 @@ (vector-ref o n)) (define-method (pylist-ref (o <p>) n) - ((ref o '__getitem__) n)) + (aif it (ref o '__getitem__) + (it n) + (next-method))) ;;; SET (define-method (pylist-set! (o <py-list>) nin val) @@ -143,11 +149,15 @@ (vector-set! o n val)) (define-method (pylist-set! (o <p>) n val) - ((ref o '__setitem__) n val)) + (aif it (ref o '__setitem__) + (it n val) + (next-method))) ;;SLICE (define-method (pylist-slice (o <p>) n1 n2 n3) - ((ref o '__getslice__) n1 n2 n3)) + (aif it (ref o '__getslice__) + (it n1 n2 n3) + (next-method))) (define-method (pylist-slice (o <py-list>) n1 n2 n3) (define N (slot-ref o 'n)) @@ -181,7 +191,9 @@ ;;SUBSET (define-method (pylist-subset! (o <p>) n1 n2 n3 val) - ((ref o '__setslice__) 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)) @@ -247,7 +259,7 @@ (define-method (pylist-append! (o <p>) n . l) (aif it (ref o 'append) (apply it n l) - (error "no append"))) + (next-method))) @@ -368,7 +380,9 @@ (define-method (pylist-reverse! (o <p>) . l) - (apply (ref o 'reverse) l)) + (aif it (ref o 'reverse) + (apply it l) + (next-method))) ;;POP! (define-method (pylist-pop! (o <py-list>)) @@ -383,7 +397,9 @@ (raise IndexError "pop from empty list")))) (define-method (pylist-pop! (o <p>) . l) - (apply (ref o 'pop) l)) + (aif it (ref o 'pop) + (apply it l) + (next-method))) ;;COUNT (define-method (pylist-count (o <py-list>) q) @@ -416,7 +432,9 @@ sum))) (define-method (pylist-count (o <p>) . l) - (apply (ref o 'count) l)) + (aif it (ref o 'count) + (apply it l) + (next-method))) ;; extend! (define-method (pylist-extend! (o <py-list>) iter) @@ -424,7 +442,9 @@ (pylist-append! o x))) (define-method (pylist-extend! (o <p>) . l) - (apply (ref o 'extend) l)) + (aif it (ref o 'extend) + (apply it l) + (next-method))) ;; equal? (define-method (equal? (o1 <py-list>) (o2 <py-list>)) @@ -497,7 +517,10 @@ (pylist-append! o v))) (raise IndexError "Wrong index in insert")))) -(define-method (pylist-insert! (o <p>) . l) (apply (ref o 'insert) l)) +(define-method (pylist-insert! (o <p>) . l) + (aif it (ref o 'insert) + (apply it l) + (next-method))) ;;REMOVE @@ -512,7 +535,10 @@ (lp (+ i 1)))) (raise ValueError "list removal has no element to remove"))))) -(define-method (pylist-remove! (o <p>) . l) (apply (ref o 'remove) l)) +(define-method (pylist-remove! (o <p>) . l) + (aif it (ref o 'remove) + (apply it l) + (next-method))) ;; SORT! (define (id x) id) @@ -526,7 +552,10 @@ (lp (cdr l) (+ i 1)))))) l)) -(define-method (pylist-sort! (o <p>) . l) (apply (ref o 'sort) 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) @@ -602,7 +631,10 @@ (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) (apply (ref o 'index) l)) +(define-method (pylist-index (o <p>) . l) + (aif it (ref o 'index) + (apply it l) + (next-method))) #:len @@ -611,7 +643,10 @@ (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>)) ((ref o '__len__))) +(define-method (len (o <p>)) + (aif it (ref o '__len__) + (it) + (next-method))) (define-method (in x (l <pair>)) (member x l)) (define-method (in x (l <vector>)) @@ -644,13 +679,19 @@ #f))) (define-method (in x (o <p>)) - ((ref o '__contains__) x)) + (aif it (ref o '__contains__) + (it x) + (next-method))) (define-syntax-rule (defgen (op 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 <vector>) (o2 <vector>)) code ...))) + (define-method (op (o1 <vector>) (o2 <vector>)) code ...) + (define-method (op (o1 <p>) o2) + (aif it (ref o1 'r) + (it o2) + (next-method))))) (defgen (< o1 o2) (let ((n1 (len o1)) @@ -690,13 +731,15 @@ (define-python-class list (<py-list>) (define __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)))))) + (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__))) (define pylist list) diff --git a/modules/language/python/module/python.scm b/modules/language/python/module/python.scm index 1b8973f..4103c4d 100644 --- a/modules/language/python/module/python.scm +++ b/modules/language/python/module/python.scm @@ -3,7 +3,8 @@ #:use-module (ice-9 match) #:use-module (ice-9 readline) #:use-module ((oop pf-objects) #:select - (<p> <property> class-method static-method refq)) + (<p> <property> class-method static-method refq + py-super-mac)) #:use-module (language python exceptions ) #:use-module (language python def ) #:use-module (language python for ) @@ -29,7 +30,7 @@ chr classmethod staticmethod divmod enumerate filter format getattr hasattr hash hex isinstance - iter map sum id input oct ord pow)) + iter map sum id input oct ord pow super)) (define-syntax-rule (aif it p x y) (let ((it p)) (if it x y))) @@ -191,9 +192,8 @@ ((x y z) (py-mod (expt x y) z)))) - +(define-syntax-rule (super . l) (py-super-mac . l)) (define min py-min) (define max py-max) (define list pylist) - diff --git a/modules/language/python/number.scm b/modules/language/python/number.scm index efab4e4..45a3cf4 100644 --- a/modules/language/python/number.scm +++ b/modules/language/python/number.scm @@ -38,7 +38,7 @@ (begin (mk-biop0 op) (define-method (op v (o <p>)) - (aif it (ref o 'r2) + (aif it (ref o 'r1) (it v) (next-method))))) @@ -211,26 +211,28 @@ (define-python-class int (<py-int>) (define __init__ - (case-lambda - ((self) - (__init__ self 0)) - - ((self n) - (let lp ((n n)) - (cond - ((and (number? n) (integer? n)) - (slot-set! self 'x n)) - ((number? n) - (lp (py-floor n))) - ((string? n) - (lp (string->number n))) - (else - (aif it (slot-ref n '__int__) - (slot-set! self 'x it) - (raise ValueError "could not make int from " n)))))) + (letrec ((__init__ + (case-lambda + ((self) + (__init__ self 0)) + + ((self n) + (let lp ((n n)) + (cond + ((and (number? n) (integer? n)) + (slot-set! self 'x n)) + ((number? n) + (lp (py-floor n))) + ((string? n) + (lp (string->number n))) + (else + (aif it (slot-ref n '__int__) + (slot-set! self 'x it) + (raise ValueError "could not make int from " n)))))) - ((self n k) - (__init__ self (string->number n k)))))) + ((self n k) + (__init__ self (string->number n k)))))) + __init__))) (define (proj? x) (if (number? x) diff --git a/modules/language/python/string.scm b/modules/language/python/string.scm index 4b22716..6ac8874 100644 --- a/modules/language/python/string.scm +++ b/modules/language/python/string.scm @@ -22,10 +22,13 @@ (define-class <py-string> () 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) ((ref o 'n) l)))) + (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-py (py-capitalize capitalize s) (let* ((n (len s)) diff --git a/modules/oop/pf-objects.scm b/modules/oop/pf-objects.scm index 56247ab..950a0ca 100644 --- a/modules/oop/pf-objects.scm +++ b/modules/oop/pf-objects.scm @@ -11,6 +11,8 @@ def-py-class mk-py-class make-py-class define-python-class get-type py-class object-method class-method static-method + py-super-mac py-super + *class* *self* )) #| Python object system is basically syntactic suger otop of a hashmap and one @@ -597,7 +599,7 @@ explicitly tell it to not update etc. ((ddef dname dval) (... ...))) (let () (define name - (let* ((mname sval) (... ...) (dname dval) (... ...)) + (letruc ((mname sval) (... ...) (dname dval) (... ...)) (make-pf-class name (let ((s (make-pf))) (set s 'mname mname) (... ...) @@ -670,32 +672,142 @@ explicitly tell it to not update etc. (define (pyclass? x) (and (is-a? x <p>) - (not (ref x '__class__)))) - + (if (ref x '__class__) + #f + (if (ref x '__super__) + 'super + #t)))) (define-method (py-class (o <p>)) (ref o '__class__ 'type)) -(define (mark-fkn f) - (set-procedure-property! f 'py-special #t) +(define (mark-fkn tag f) + (set-procedure-property! f 'py-special tag) f) (define (object-method f) - (mark-fkn - (lambda (x) - (if (pyclass? x) - f - (lambda z (apply f x z)))))) + (letrec ((self + (mark-fkn 'object + (lambda (x) + (aif it (pyclass? x) + (if (eq? it 'super) + self + f) + (lambda z (apply f x z))))))) + self)) (define (class-method f) - (mark-fkn - (lambda (x) - (if (pyclass? x) - (lambda z (apply f x z)) - (lambda z (apply f (ref x '__class__) z)))))) + (letrec ((self + (mark-fkn 'class + (lambda (x) + (aif it (pyclass? x) + (if (eq? it 'super) + self + (lambda z (apply f x z))) + (lambda z (apply f (ref x '__class__) z))))))) + self)) (define (static-method f) - (mark-fkn - (lambda (x) f))) + (letrec ((self + (mark-fkn 'static + (lambda (x) + (if (eq? (pyclass? x) 'super) + self + f))))) + self)) +(define-syntax-parameter + *class* (lambda (x) (error "*class* not parameterized"))) +(define-syntax-parameter + *self* (lambda (x) (error "*class* not parameterized"))) + +(define *super* (list 'super)) + +(define (py-super class obj) + (define (make cl parents) + (let ((c (make-p)) + (o (make-p))) + (set c '__super__ #t) + (set c '__parents__ parents) + (set c '__getattribute__ (lambda (self key . l) + (aif it (ref c key) + (if (procedure? it) + (if (eq? (procedure-property + it + 'py-special) + 'class) + (it cl) + (it obj)) + it) + (error "no attribute")))) + (set o '__class__ c) + o)) + + (call-with-values + (lambda () + (let lp ((c (ref obj '__class__))) + (if (eq? class c) + (let ((p (ref c '__parents__))) + (if (pair? p) + (values (car p) p) + (values #t #t))) + (let lp2 ((p (ref c 'parents))) + (if (pair? p) + (call-with-values (lambda () (lp (car p))) + (lambda (c ps) + (cond + ((eq? c #t) + (if (pair? p) + (let ((x (car p))) + (values + x + (append + (ref x '__parents__) + (cdr p)))) + (values #t #t))) + (c + (values c (append ps (cdr p)))) + (else + (lp2 (cdr p)))))) + (values #f #f)))))) + make)) + + + +(define-syntax py-super-mac + (syntax-rules () + ((_) + (py-super *class* *self*)) + ((_ class self) + (py-super class self)))) + +(define-syntax letruc + (lambda (x) + (syntax-case x () + ((_ ((x v) ...) code ...) + (let lp ((a #'(x ...)) (b #'(v ...)) (u '())) + (if (pair? a) + (let* ((x (car a)) + (s (syntax->datum x))) + (let lp2 ((a2 (cdr a)) (b2 (cdr b)) (a3 '()) (b3 '()) + (r (list (car b)))) + (if (pair? a2) + (if (eq? (syntax->datum a2) s) + (lp2 (cdr a2) (cdr b2) a3 b3 (cons (car b2) r)) + (lp2 (cdr a2) (cdr b2) + (cons (car a2) a3) + (cons (car b2) b3) + r)) + (lp (reverse a3) (reverse b3) + (cons + (list x #`(let* #,(map (lambda (v) (list x v)) + (reverse r)) #,x)) + u))))) + #`(letrec #,(reverse u) code ...))))))) + + + + +(define-method (py-init (o <p>) . l) + (apply (ref o '__init__) l)) |