diff options
Diffstat (limited to 'modules')
-rw-r--r-- | modules/language/python/compile.scm | 130 | ||||
-rw-r--r-- | modules/language/python/exceptions.scm | 33 | ||||
-rw-r--r-- | modules/language/python/for.scm | 60 | ||||
-rw-r--r-- | modules/language/python/try.scm | 94 | ||||
-rw-r--r-- | modules/language/python/yield.scm | 116 | ||||
-rw-r--r-- | modules/oop/pf-objects.scm | 140 |
6 files changed, 382 insertions, 191 deletions
diff --git a/modules/language/python/compile.scm b/modules/language/python/compile.scm index 962c877..e74b9f2 100644 --- a/modules/language/python/compile.scm +++ b/modules/language/python/compile.scm @@ -3,9 +3,12 @@ #:use-module (ice-9 control) #:use-module (oop pf-objects) #:use-module (oop goops) + #:use-module (language python exceptions) + #:use-module (language python yield) + #:use-module (language python for) + #:use-module (language python try) #:use-module (ice-9 pretty-print) - #:replace (send) - #:export (comp sendException sendClose)) + #:export (comp)) (define-syntax-rule (aif it p x y) (let ((it p)) (if it x y))) @@ -44,6 +47,7 @@ x) (define (C x) `(@@ (language python compile) ,x)) +(define (Y x) `(@@ (language python yield) ,x)) (define (O x) `(@@ (oop pf-objects) ,x)) (define (G x) `(@ (guile) ,x)) @@ -302,7 +306,7 @@ (#:True #t) (#:False #f) - + (#:pass `(values)) ((#:while test code . #f) (let ((lp (gensym "lp"))) `(let ,lp () @@ -357,8 +361,8 @@ 'mk-p-class 'mk-py-class))) (parents (filt parents))) - `(define ,class (,(O 'wrap) - (,(O kind) + `(define ,class (,(O 'wrap) ,class + (,(O kind) ,class ,(map (lambda (x) `(,(O 'get-class) ,x)) parents) #:const @@ -531,7 +535,7 @@ ((#:yield args) (let ((f (gensym "f"))) `(begin - (set! ,(C 'inhibit-finally) #t) + (fluid-set! ,(Y 'in-yield) #t) (let ((,f (scm.yield ,@(gen-yargs vs args)))) (,f))))) @@ -1021,116 +1025,6 @@ (lp))))) (lambda e else)))))))))))) - -(define-class <scm-list> () l) -(define-class <scm-string> () s i) -(define-class <yield> () s k closed) - -(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 (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 () (throw 'python (apply 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 'python 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__))) - -(define-method (next (l <p>)) - ((ref l '__next__))) - - - -(define-method (wrap-in (x <p>)) - (aif it (ref x '__iter__ #f) - (it) - x)) - -(define-method (wrap-in x) - (cond - ((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))) - -(define yield-prompt (list 'yield)) (define-syntax def-wrap (lambda (x) (syntax-case x () @@ -1156,7 +1050,7 @@ (throw StopIteration)) (letrec ((lam (lambda (k . l) - (set! inhibit-finally #f) + (fluid-set! in-yield #f) (slot-set! obj 'k (lambda (a) (call-with-prompt @@ -1168,8 +1062,6 @@ lam)))) obj))))) - - (define-syntax ref-x (syntax-rules () ((_ v) diff --git a/modules/language/python/exceptions.scm b/modules/language/python/exceptions.scm new file mode 100644 index 0000000..57690aa --- /dev/null +++ b/modules/language/python/exceptions.scm @@ -0,0 +1,33 @@ +(define-module (language python exceptions) + #:use-module (oop pf-objects) + #:use-module (oop goops) + #:export (StopIteration GeneratorExit RuntimeError + Exception)) + +(define-syntax-rule (aif it p x y) (let ((it p)) (if it x y))) + +(define StopIteration 'StopIteration) +(define GeneratorExit 'GeneratorExit) +(define RuntimeError 'RuntimeError) + +(define-python-class Exception () + (define __init__ + (case-lambda + ((self) + (values)) + ((self str) + (set self 'str str)))) + + (define __repr__ + (lambda (self . l) + (define port (if (pair? l) (car l) #f)) + (aif it (ref self 'str) + (format port "~s: ~a" + (ref self '__name__) it) + (format port "~s" + (ref self '__name__)))))) + + + + + diff --git a/modules/language/python/for.scm b/modules/language/python/for.scm index 47f6992..f23ce6e 100644 --- a/modules/language/python/for.scm +++ b/modules/language/python/for.scm @@ -1,7 +1,12 @@ (define-module (language python for) + #:use-module (language python yield) #:use-module (oop pf-objects) + #:use-module (language python exceptions) + #:use-module (oop goops) #:use-module (ice-9 control) - #:export (for break)) + #:export (for break next write)) + +(define-syntax-rule (aif it p x y) (let ((it p)) (if it x y))) (eval-when (compile eval load) (define (generate-temporaries2 x) @@ -129,6 +134,59 @@ (lambda q (values))))))))))) +(define-class <scm-list> () l) +(define-class <scm-string> () s i) + +(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 (next (l <p>)) + ((ref l '__next__))) + +(define-method (wrap-in (x <p>)) + (aif it (ref x '__iter__ #f) + (it) + x)) + +(define-method (wrap-in x) + (cond + ((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))) + + #; (pk (for c ((x : (gen '(1 2 3)))) ((s 0)) diff --git a/modules/language/python/try.scm b/modules/language/python/try.scm new file mode 100644 index 0000000..2d10ad2 --- /dev/null +++ b/modules/language/python/try.scm @@ -0,0 +1,94 @@ +(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) + #:export (raise try)) + +(define-syntax-rule (aif it p x y) (let ((it p)) (if it x y))) + +(define-method (check (class <class> ) obj l) (is-a? obj class)) +(define-method (check (s <symbol>) obj l) (eq? obj s)) +(define-method (check (p <procedure>) obj l) + (aif it (procedure-property p 'pyclass) + (is-a? obj it) + (p 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-syntax handler + (syntax-rules () + ((handler ecx) + (lambda x + (match x + ((_ 'python tag . l) + (handler ecx tag l)) + ((k . x) + (apply throw x))))) + + ((handler ((#:except E => lam) . ecx) tag l) + (if (check-exception E tag l) + (lam tag l) + (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 + (lambda () code) + (handler (exc ...)))) + (lambda () + (if (not (fluid-ref in-yield)) + fin)))) + + ((try code exc ...) + (catch #t + (lambda () code) + (handler (exc ...)))))) + + +(define raise + (case-lambda + (() (raise Exception)) + ((x) + (if (procedure? x) + (if (procedure-property x 'pyclass) + (throw 'python (x)) + (throw 'python x)) + (throw 'python x))))) diff --git a/modules/language/python/yield.scm b/modules/language/python/yield.scm new file mode 100644 index 0000000..289eb4d --- /dev/null +++ b/modules/language/python/yield.scm @@ -0,0 +1,116 @@ +(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) + #:replace (send) + #:export (<yield> in-yield 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-rule (make-generator (args) code ...) + (lambda args + (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 () + code ... + (slot-set! obj 'closed #t) + (throw StopIteration)) + (letrec ((lam + (lambda (k . l) + (set! in-yield #f) + (slot-set! obj 'k + (lambda (a) + (call-with-prompt + ab + (lambda () + (k a)) + lam))) + (apply values l)))) + lam)))) + ob)))) + +(define-syntax-rule (define-generator (f . args) code ...) + (define f (make-generator args code ...))) +(define-class <yield> () s k 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 () (throw 'python (apply 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__))) diff --git a/modules/oop/pf-objects.scm b/modules/oop/pf-objects.scm index ca9a11b..c270e11 100644 --- a/modules/oop/pf-objects.scm +++ b/modules/oop/pf-objects.scm @@ -4,15 +4,14 @@ #:use-module (ice-9 match) #:export (set ref make-pf <p> <py> <pf> <pyf> call with copy fset fcall make-p put put! - pcall pcall! get next fset-x - mk + pcall pcall! get fset-x + mk wrap def-pf-class mk-pf-class make-pf-class def-p-class mk-p-class make-p-class def-pyf-class mk-pyf-class make-pyf-class def-py-class mk-py-class make-py-class - StopIteration GeneratorExit RuntimeError - Exception)) - + define-python-class + )) #| Python object system is basically syntactic suger otop of a hashmap and one this project is inspired by the python object system and what it measn when @@ -609,69 +608,68 @@ explicitly tell it to not update etc. (define-syntax-rule (def-py-class name . l) (define name (mk-py-class name . l))) -(define-syntax-rule (wrap class) - (let* ((c class) - (ret (lambda x (apply mk c x)))) - (set-procedure-property! ret 'pyclass c) - ret)) - -(define (get-class x) - (aif it (procedure-property x 'pyclass) - it - (error "not a class"))) - -(define StopIteration 'StopIteration) -(define GeneratorExit 'GeneratorExit) -(define RuntimeError 'RuntimeError) - -(define-method (next (o <p>)) - (catch StopIteration - (lambda () ((ref o '__next__))) - (lambda (x) #:nil))) - - -(define-inlinable (super-obj tag ex) - (let* ((classtag (ref tag '__class__ #f)) - (exid (ref ex '__goops__ #f))) - (let check-class ((tag classtag)) - (if (and exid (eq? (ref tag '__goops__ #f) exid)) - #t - (let lp ((parents (ref tag '__parents__ '()))) - (if (pair? parents) - (or - (check-class (car parents)) - (lp (cdr parents))) - #f)))))) - -(define-inlinable (pyclass? x) - (and (procedure? x) (procedure-property x 'pyclass))) - - -(define-method (testex py (tag <p>) (ex <p>) . l) - (super-obj tag ex)) - -(define-method (testex py tag ex l) - (if (eq? py 'python) - (cond - ((pair? ex) - (or - (testex py tag (car ex) l) - (testex py tag (cdr ex) l))) - ((pyclass? ex) - => - (lambda (cl) - (testex py tag cl l))) - (else - (eq? tag ex))) - #f)) - - - -(define Exception - (wrap - (mk-py-class Exception () - #:const - ((define __init__ - (lambda (self) (values)))) - #:dynamic - ()))) +(define-syntax-rule (wrap name class) + (let* ((c class) + (name (lambda x (apply mk c x)))) + (set-procedure-property! name 'pyclass c) + name)) + +(define-method (write (o <p>) . l) + (aif it (ref o '__repr__) + (apply it l) + (apply display (format #f "object<p>: ~s" (class-name o)) l))) + +(define-method (display (o <p>) . l) + (aif it (ref o '__repr__) + (apply it l) + (apply display (format #f "object<p>: ~s" (class-name o)) l))) + +(define-method (write (o <p>) . l) + (aif it (ref o '__repr__) + (apply it l) + (apply display (format #f "object<p>: ~s" (class-name o)) l))) + +(define-method (display (o <p>) . l) + (aif it (ref o '__repr__) + (apply it l) + (apply display (format #f "object<pf>: ~s" (class-name o)) l))) + +(define-method (write (o <pf>) . l) + (aif it (ref o '__repr__) + (apply it l) + (apply display (format #f "object<pf>: ~s" (class-name o)) l))) + +(define-method (display (o <pf>) . l) + (aif it (ref o '__repr__) + (apply it l) + (apply display (format #f "object<p>: ~s" (class-name o)) l))) + +(define-method (write (o <py>) . l) + (aif it (ref o '__repr__) + (apply it l) + (apply display (format #f "object<py>: ~s" (class-name o)) l))) + +(define-method (display (o <py>) . l) + (aif it (ref o '__repr__) + (apply it l) + (apply display (format #f "object<py>: ~s" (class-name o)) l))) + + +(define-method (write (o <pyf>) . l) + (aif it (ref o '__repr__) + (apply it l) + (apply display (format #f "object<pyf>: ~s" (class-name o)) l))) + +(define-method (display (o <pyf>) . l) + (aif it (ref o '__repr__) + (apply it l) + (apply display (format #f "object<pyf>: ~s" (class-name o)) l))) + +(define-syntax-rule (define-python-class name parents code ...) + (define name + (wrap name + (mk-py-class name parents + #:const + (code ...) + #:dynamic + ())))) |