From 992a575254a29a1cfa759b8f2914d2a3b2593414 Mon Sep 17 00:00:00 2001 From: Stefan Israelsson Tampe Date: Mon, 11 Sep 2017 22:51:29 +0200 Subject: try works --- modules/language/python/compile.scm | 218 ++++++++++++++++++++++-------------- modules/language/python/spec.scm | 32 +++--- 2 files changed, 152 insertions(+), 98 deletions(-) (limited to 'modules/language') diff --git a/modules/language/python/compile.scm b/modules/language/python/compile.scm index c11bd76..a1c6509 100644 --- a/modules/language/python/compile.scm +++ b/modules/language/python/compile.scm @@ -14,16 +14,10 @@ (set! (@@ (system base message) %dont-warn-list) '()) #f)) -(define-syntax dont-warn - (lambda (x) - (syntax-case x () - ((_ d) - #t - (begin - (set! (@@ (system base message) %dont-warn-list) - (cons (syntax->datum #'d) - (@@ (system base message) %dont-warn-list))) - #f))))) +(define (dont-warn v) + (set! (@@ (system base message) %dont-warn-list) + (cons v + (@@ (system base message) %dont-warn-list)))) (define-syntax call (syntax-rules () @@ -101,19 +95,33 @@ (define (scope x vs) (match x - ((#:def (#:identifier f . _) . _) - (union (list (string->symbol f)) vs)) + ((#:def f . _) + (union (list (exp '() f)) vs)) + ((#:lambdef . _) vs) - ((#:classdef . _) - vs) + + ((#:classdef f . _) + (union (list (exp '() f)) vs)) + ((#:global . _) vs) - ((#:identifier v . _) - (let ((s (string->symbol v))) - (if (member s vs) - vs - (cons s vs)))) + + ((#:expr-stmt l (#:assign u)) + (union (fold (lambda (x s) + (match x + ((#:test (#:power v2 v1 () . _) . _) + (if v2 + (union + (union (list (exp '() v1)) + (list (exp '() v2))) + s) + (union (list (exp '() v1)) s))) + (() s))) + '() + l) + vs)) + ((x . y) (scope y (scope x vs))) (_ vs))) @@ -241,12 +249,6 @@ ((#:suite . l) (cons 'begin (map (g vs exp) l))) - ((#:try x #f #f fin) - `(dynamic-wind - (lambda () #f) - (lambda () ,(exp vs x)) - (lambda () ,(exp vs fin)))) - ((#:while test code #f) (let ((lp (gensym "lp"))) `(let ,lp () @@ -312,7 +314,9 @@ (l l)) #:dynamic ()))))))) - + + ((#:import ((() nm) . #f)) + `(use-modules (language python module ,(exp vs nm)))) (#:break (C 'break)) @@ -391,41 +395,75 @@ ((#:while test code else) (let ((lp (gensym "lp"))) `(let ,lp () - (if test - (begin - ,(exp vs code) - (,lp)) - ,(exp vs else))))) - - ((#:try x exc else fin) - (define (f x) - (match else - ((#f x) - `(catch #t - (lambda () ,x) - (lambda ,(gensym "x") ,(exp vs x)))))) - + (if test + (begin + ,(exp vs code) + (,lp)) + ,(exp vs else))))) + + ((#:try x (or #f ()) #f . fin) `(dynamic-wind (lambda () #f) - (lambda () - ,(f - (let lp ((code (exp vs x)) (l (reverse exc))) - (match l - ((((e) c) . l) - (lp `(catch ,(exp vs e) - (lambda () ,code) - (lambda ,(gensym "x") - ,(exp vs c))) l)) - ((((e . as) c) . l) - (lp `(let ((,as ,(exp vs e))) - (catch ,as - (lambda () ,code) - (lambda ,(gensym "x") - ,(exp vs c)))) l)) + (lambda () ,(exp vs x)) + (lambda () ,(exp vs fin)))) + + ((#:try x exc else . fin) + (define (guard x) + (if fin + `(dynamic-wind + (lambda () #f) + (lambda () ,x) + (lambda () ,(exp vs fin))) + x)) + (define tag (gensym "tag")) + (define o (gensym "o")) + (define l (gensym "l")) + (guard + `(catch #t + (lambda () ,(exp vs x)) + (lambda (,tag ,o . ,l) + ,(let lp ((it (if else (exp vs else) `(apply throw ,tag ,l))) + (exc exc)) + (match exc + ((((test . #f) code) . exc) + (lp `(if (,(O 'testex) ,tag ,o ,(exp vs test) ,l) + ,(exp vs code) + ,it) + exc)) + ((((test . as) code) . exc) + (let ((a (exp vs as))) + (lp `(if (,(O 'testex) ,o ,tag ,(exp vs test) ,l) + (let ((,a ,o)) + (,(O 'set) ,a '__excargs__ ,l) + ,(exp vs code)) + ,it) + exc))) (() - code)))) - (lambda () ,(exp vs fin))))) + it))))))) + ((#:raise #f . #f) + `(throw 'python (,(O 'Exception)))) + + ((#:raise code . #f) + (let ((c (gensym "c"))) + `(throw 'python + (let ((,c ,(exp vs code))) + (if (,(O 'pyclass?) ,c) + (,c) + ,c))))) + + ((#:raise code . from) + (let ((o (gensym "o")) + (c (gensym "c"))) + `(throw 'python + (let ((,c ,(exp vs code))) + (let ((,o (if (,(O 'pyclass?) ,c) + (,c) + ,c))) + (,(O 'set) ,o '__cause__ ,(exp vs from)) + ,o))))) + + ((#:yield args) `(scm-yield ,@(gen-yargs vs args))) @@ -468,27 +506,42 @@ (with-fluids ((is-class? #f)) (if c? - `(define ,f - (,(C 'def-wrap) ,y? ,f ,ab - (letrec ((,f - (case-lambda - ((,ex ,@as) - (,f ,@as)) - ((,@as) - (,(C 'with-return) ,r + (if y? + `(define ,f + (,(C 'def-wrap) ,y? ,f ,ab + (lambda (,@as) + (,(C 'with-return) ,r + ,(mk `(let ,(map (lambda (x) (list x #f)) ls) + ,(with-fluids ((return r)) + (exp ns code)))))))) + + `(define ,f + (letrec ((,f + (case-lambda + ((,ex ,@as) + (,f ,@as)) + ((,@as) + (,(C 'with-return) ,r ,(mk `(let ,(map (lambda (x) (list x #f)) ls) - ,(with-fluids ((return r)) - (exp ns code))))))))) - ,f))) - - `(define ,f - (,(C 'def-wrap) ,y? ,f ,ab - (lambda (,@as) - (,(C 'with-return) ,r - (let ,(map (lambda (x) (list x #f)) ls) - ,(with-fluids ((return r)) - (mk - (exp ns code)))))))))))) + ,(with-fluids ((return r)) + (exp ns code))))))))) + ,f))) + + (if y? + `(define ,f + (,(C 'def-wrap) ,y? ,f ,ab + (lambda (,@as) + (,(C 'with-return) ,r + (let ,(map (lambda (x) (list x #f)) ls) + ,(with-fluids ((return r)) + (mk + (exp ns code)))))))) + `(define ,f + (lambda (,@as) + (,(C 'with-return) ,r + (let ,(map (lambda (x) (list x #f)) ls) + ,(with-fluids ((return r)) + (exp ns code))))))))))) ((#:global . _) '(values)) @@ -569,7 +622,8 @@ arglist)) `((,(G 'define-module) - (language python module ,@args))))) + (language python module ,@args) + #:use-module (language python module python))))) (x '()))) (if (pair? start) @@ -580,7 +634,7 @@ ,@start ,(C 'clear-warning-data) (set! (@@ (system base message) %dont-warn-list) '()) - ,@(map (lambda (s) `(,(C 'var) ,s)) globs) + ,@(map (lambda (s) `(,(C 'var) ',s)) globs) ,@(map (g globs exp) x)))) (define-syntax-parameter break @@ -742,12 +796,12 @@ #`(let/ec ret #,code) code)))))) -(define-syntax-rule (var v) +(define (var v) (begin (dont-warn v) - (if (defined? 'v) + (if (module-defined? (current-module) v) (values) - (define! 'v #f)))) + (define! v #f)))) (define-inlinable (non? x) (eq? x #:nil)) diff --git a/modules/language/python/spec.scm b/modules/language/python/spec.scm index c22c0b4..0cfb83a 100644 --- a/modules/language/python/spec.scm +++ b/modules/language/python/spec.scm @@ -36,19 +36,19 @@ #: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))) + (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))) -- cgit v1.2.3