From d79c8c56951a60d7dd07d33ee0acc3614d2382eb Mon Sep 17 00:00:00 2001 From: Stefan Israelsson Tampe Date: Fri, 8 Sep 2017 16:34:36 +0200 Subject: [PATCH 1/1] guile modifications git diff and strating supporting yield --- modules/language/python/compile.scm | 214 +++++++++++++++++++--------- python.diff | 70 +++++++++ 2 files changed, 215 insertions(+), 69 deletions(-) create mode 100644 python.diff diff --git a/modules/language/python/compile.scm b/modules/language/python/compile.scm index ce503d9..302e780 100644 --- a/modules/language/python/compile.scm +++ b/modules/language/python/compile.scm @@ -130,6 +130,12 @@ (defs y (defs x vs))) (_ vs))) +(define (gen-yield f) + (string->symbol + (string-concat + (symbol->string f) + ".yield"))) + (define (g vs e) (lambda (x) (e vs x))) @@ -405,14 +411,23 @@ code)))) (lambda () ,(exp vs fin))))) - ((#:def (#:identifier f . _) + ((#:yield args) + '(scm-yield ,@gen-args(args))) + + ((#:yield (f args)) + (let ((f (gen-yield (exp vs f)))) + '(,f ,@gen-args(args))) + + + ((#:def f (#:types-args-list args #f #f) #f code) (let* ((c? (fluid-ref is-class?)) - (f (string->symbol f)) + (f (exp vs f)) + (y? (is-yield f #f code)) (r (gensym "return")) (as (map (lambda (x) (match x ((((#:identifier x . _) . #f) #f) @@ -425,22 +440,26 @@ (ls (diff (diff ns vs) df))) (with-fluids ((is-class? #f)) (if c? - `(define ,f (letrec ((,f - (case-lambda - ((,ex ,@as) - (,f ,@as)) - ((,@as) - (,(C 'with-return) ,r - (let ,(map (lambda (x) (list x #f)) ls) - ,(with-fluids ((return r)) - (exp ns code)))))))) - ,f)) - - `(define ,f (lambda (,@as) - (,(C 'with-return) ,r - (let ,(map (lambda (x) (list x #f)) ls) - ,(with-fluids ((return r)) - (exp ns code)))))))))) + `(define ,f + (def-wrap ,y? + (letrec ((,f + (case-lambda + ((,ex ,@as) + (,f ,@as)) + ((,@as) + (,(C 'with-return) ,r + (let ,(map (lambda (x) (list x #f)) ls) + ,(with-fluids ((return r)) + (exp ns code)))))))) + ,f))) + + `(define ,f + (def-wrap ,y? + (lambda (,@as) + (,(C 'with-return) ,r + (let ,(map (lambda (x) (list x #f)) ls) + ,(with-fluids ((return r)) + (exp ns code))))))))))) ((#:global . _) '(values)) @@ -541,6 +560,23 @@ (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-rule (with-sp ((x v) ...) code ...) (syntax-parameterize ((x (lambda (y) #'v)) ...) code ...)) @@ -737,30 +773,32 @@ ((_ (x ...) (in ...) code #f #f) (with-syntax (((inv ...) (generate-temporaries #'(in ...)))) #'(let ((inv (wrap-in in)) ...) - (let lp () - (call-with-values (lambda () (values (next inv) ...)) - (lambda (x ...) - (if (or (non? x) ...) - (values) - (begin - code - (lp))))))))) + (catch StopIteration + (lambda () + (let lp () + (call-with-values (lambda () (values (next inv) ...)) + (lambda (x ...) + (with-sp ((break (values)) + (continue (values))) + code + (lp)))))) + (lambda x (values)))))) ((_ (x ...) (in ...) code #f #t) (with-syntax (((inv ...) (generate-temporaries #'(in ...)))) #'(let ((inv (wrap-in in)) ...) (let lp () (let/ec break-ret - (call-with-values (lambda () (values (next inv) ...)) - (lambda (x ...) - (if (or (non? x) ...) - (values) - (begin - (let/ec continue-ret - (with-sp ((break (break-ret)) - (continue (continue-ret))) - code)) - (lp)))))))))) + (catch StopIteration + (lambda () + (call-with-values (lambda () (values (next inv) ...)) + (lambda (x ...) + (let/ec continue-ret + (with-sp ((break (break-ret)) + (continue (continue-ret))) + code)) + (lp)))) + (lambda x (values)))))))) ((_ (x ...) in code else #f) #'(for-adv (x ...) in code else #f)) @@ -780,62 +818,70 @@ (syntax-case x () ((_ (x ...) (in ...) code else p) - (with-syntax (((inv ...) (generate-temporaries #'(in ...)))) + (with-syntax (((inv ...) (generate-temporaries #'(in ...)))) (with-syntax ((get (gen #'(inv ...) #'(x ...))) ((xx ...) (generate-temporaries #'(x ...)))) - #'(let ((inv (wrap-in in)) ...) - (if p + (if (syntax->datume #'p) + #'(let ((inv (wrap-in in)) ...) (let/ec break-ret - (call-with-values + (let ((x #f) ...) + (catch StopIteration (lambda () - (let lp ((xx #f) ...) + (let lp () (call-with-values (lambda () get) - (lambda (x ...) + (lambda (xx ...) + (set! x xx) ... (let/ec continue-ret - (if (or (non? x) ...) - (values xx ...) - (with-sp ((break (break-ret)) - (continue (continue-ret))) - code))) - (lp x ...)))))) - (lambda (x ...) else)) - - (let/ec break-ret - (call-with-values + (with-sp ((break (break-ret)) + (continue (continue-ret))) + code)) + (lp))))) + (lambda q else))))) + + #'(let ((inv (wrap-in in)) ...) + (let ((x #f) ...) + (let/ec break-ret + (catch StopIteration (lambda () - (let lp ((xx #f) ...) + (let lp () (call-with-values (lambda () get) - (lambda (x ...) - (if (or (non? x) ...) - (values xx ...) - (begin - (with-sp ((break (break-ret)) - (continue (values))) - code) - (lp x ...))))))) - (lambda (x ...) else))))))))))) + (lambda (xx ...) + (set! x xx) ... + (with-sp ((break (break-ret)) + (continue (values))) + code) + (lp))))) + (lambda e else)))))))))))) -(define-class () (x) l) -(define-class () (x) s i) - +(define-class () l) +(define-class () s i) +(define-class () k) + (define-method (next (l )) (let ((ll (slot-ref l 'l))) (if (pair? ll) (begin (slot-set! l 'l (cdr ll)) (car ll)) - #:nil))) + (throw StopIteration)))) (define-method (next (l )) (let ((s (slot-ref l 's)) (i (slot-ref l 'i))) (if (= i (string-length s)) - #:nil + (throw StopIteration) (begin (slot-set! l 'i (+ i 1)) (string-ref s i))))) +(define-method (next (l )) + (let ((k (slot-ref l 'k)) + (s (slot-ref l 's))) + (if k + (k) + (s)))) + (define (wrap-in x) (cond ((pair? x) @@ -849,6 +895,36 @@ (slot-set! o 'i 0) o)) - (else - x))) + (else + x))) +(define yield-prompt (list 'yield)) +(define-syntax def-wrap + (lambda (x) + (syntax-case x () + ((_ #f f x) + #'x) + + ((_ #t f code) + #'(lambda x + (define obj (make )) + (slot-set! obj 'k #f) + (slot-set! obj 'start + (lambda () + (let/ec return + (with-prompt + yield-prompt + (lambda () (apply code x)) + (letrec ((lam + (lambda (k . l) + (slot-set! obj 'k + (lambda () + (with-prompt + yield-prompt + k + lam)))))) + lam)) + (throw StopIteration))) + + + diff --git a/python.diff b/python.diff new file mode 100644 index 0000000..aa2ffd7 --- /dev/null +++ b/python.diff @@ -0,0 +1,70 @@ +diff --git a/module/system/base/compile.scm b/module/system/base/compile.scm +index c110512f0..d5d63a9e0 100644 +--- a/module/system/base/compile.scm ++++ b/module/system/base/compile.scm +@@ -132,9 +132,30 @@ + (and (false-if-exception (ensure-directory (dirname f))) + f)))) + ++(define *do-extension-dispatch* #f) ++(define *extension-dispatches* '((("py") . python) (("pl") . prolog))) ++ ++(define (default-language file) ++ (define default (current-language)) ++ (if *do-extension-dispatch* ++ (let ((ext (car (reverse (string-split file #\.))))) ++ (let lp ((l *extension-dispatches*)) ++ (if (pair? l) ++ (if (member ext (caar l)) ++ (let ((r (cdar l))) ++ (if (language? default) ++ (if (eq? (language-name default) r) ++ default ++ r) ++ r)) ++ (lp (cdr l))) ++ default))) ++ default)) ++ ++ + (define* (compile-file file #:key + (output-file #f) +- (from (current-language)) ++ (from (default-language file)) + (to 'bytecode) + (env (default-environment from)) + (opts '()) +diff --git a/module/system/base/message.scm b/module/system/base/message.scm +index 979291c1e..c0d639235 100644 +--- a/module/system/base/message.scm ++++ b/module/system/base/message.scm +@@ -34,7 +34,8 @@ + warning-type? warning-type-name warning-type-description + warning-type-printer lookup-warning-type + +- %warning-types)) ++ %warning-types ++ %dont-warn-list)) + + + ;;; +@@ -74,6 +75,7 @@ + (description warning-type-description) + (printer warning-type-printer)) + ++(define %dont-warn-list '()) + (define %warning-types + ;; List of known warning types. + (map (lambda (args) +@@ -112,8 +114,9 @@ + (unbound-variable + "report possibly unbound variables" + ,(lambda (port loc name) +- (emit port "~A: warning: possibly unbound variable `~A'~%" +- loc name))) ++ (if (not (member name %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" -- 2.29.2