diff options
| -rw-r--r-- | modules/language/python/compile.scm | 2 | ||||
| -rw-r--r-- | modules/language/python/dict.scm | 11 | ||||
| -rw-r--r-- | modules/language/python/dir.scm | 10 | ||||
| -rw-r--r-- | modules/language/python/for.scm | 9 | ||||
| -rw-r--r-- | modules/language/python/procedure.scm | 125 |
5 files changed, 136 insertions, 21 deletions
diff --git a/modules/language/python/compile.scm b/modules/language/python/compile.scm index f97597c..f936aa0 100644 --- a/modules/language/python/compile.scm +++ b/modules/language/python/compile.scm @@ -15,6 +15,8 @@ #: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 with) #:select ()) #:use-module (ice-9 pretty-print) #:export (comp)) diff --git a/modules/language/python/dict.scm b/modules/language/python/dict.scm index 58d7cb7..5c7eb4a 100644 --- a/modules/language/python/dict.scm +++ b/modules/language/python/dict.scm @@ -543,13 +543,9 @@ (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))))))) + (for ((k v : x)) () + (pylist-set! self k v)))))) __init__))) -(name-object dict) (define-python-class weak-key-dict (<py-hashtable>) (define __init__ @@ -568,7 +564,6 @@ (pylist-set! self k v)) (slot-ref x 't))))))) __init__))) -(name-object weak-key-dict) (define-python-class weak-value-dict (<py-hashtable>) (define __init__ @@ -588,8 +583,6 @@ (slot-ref x 't))))))) __init__))) -(name-object weak-value-dict) - (define (pyhash-listing) (let ((l (to-pylist (map symbol->string diff --git a/modules/language/python/dir.scm b/modules/language/python/dir.scm index e41e235..fe7edae 100644 --- a/modules/language/python/dir.scm +++ b/modules/language/python/dir.scm @@ -150,15 +150,5 @@ (pylist-sort! ret) ret))) -(define-method (dir (o <procedure>)) - (let ((ret (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/for.scm b/modules/language/python/for.scm index fcd562b..bf37bad 100644 --- a/modules/language/python/for.scm +++ b/modules/language/python/for.scm @@ -2,6 +2,7 @@ #: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) @@ -78,8 +79,12 @@ (set! x1 x2) ...))) (if (> N 1) (case-lambda - ((q) - (apply f q)) + ((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) diff --git a/modules/language/python/procedure.scm b/modules/language/python/procedure.scm new file mode 100644 index 0000000..55d0b24 --- /dev/null +++ b/modules/language/python/procedure.scm @@ -0,0 +1,125 @@ +(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-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 (rawref (f <procedure>) 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__) + (procedure-name f)) + + ((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 (rawset (x <procedure>) key val) + (set-f x key val)) + +(define-method (py-class (o <procedure>)) + (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)))) + ((member tag fixed) + (raise KeyError (format #f "key ~a is unmutable" tag))) + (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)) |