From 0e6cb5e8b165925597fe5f3d01867d873c16aa9d Mon Sep 17 00:00:00 2001 From: Stefan Israelsson Tampe Date: Wed, 6 Sep 2017 23:10:26 +0200 Subject: improved class handling --- modules/language/python/compile.scm | 214 ++++++++++++++++++++++-------------- 1 file changed, 131 insertions(+), 83 deletions(-) (limited to 'modules/language') diff --git a/modules/language/python/compile.scm b/modules/language/python/compile.scm index 151e0c2..565fdcf 100644 --- a/modules/language/python/compile.scm +++ b/modules/language/python/compile.scm @@ -3,6 +3,23 @@ #:use-module (ice-9 pretty-print) #:export (comp)) +(define-syntax clear-warning-data + (lambda (x) + (pr 'clear) + (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-syntax call (syntax-rules () ((_ (f) . l) (f . l)))) @@ -131,34 +148,37 @@ (() v))) ',(exp vs las) ,u))))))) - - +(define is-class? (make-fluid #f)) + (define (exp vs x) (match (pr x) + + ((#:power (x) () . #f) + (exp vs x)) ((#:power x () . #f) (exp vs x)) - + + ;; Function calls (x1:x1.y.f(1) + x2:x2.y.f(2)) will do functional calls - ((#:power vf ((and trailer (#:identifier _ . _)) ... - (#:arglist (args ...) #f #f)) . #f) - (let ((args (map (g vs exp) args))) - (match vf - ((#:f (#:identifier f . _) e) - (let ((obj (gensym "obj")) - (l (gensym "l"))) - '(call-with-values (lambda () (fcall (,(exp vs e) - ,@(map (g vd exp) trailer)) - ,@args)) - (lambda (,obj . ,l) - `(set! ,(string->symbol f) ,obj) - (apply 'values ,l))))) - (x - `(,(C 'call) (,(exp vs x) ,@(map (g vs exp) trailer)) ,@args))))) - + ((#:power vf trailer . #f) + (let lp ((e (exp vs vf)) (trailer trailer)) + (match trailer + (() + e) + ((#f) + (list e)) + ((x . trailer) + (match (pr x) + ((#:identifier . _) + (lp `(,(O 'ref) ,e ',(exp vs x) #f) trailer)) + ((#:arglist args #f #f) + (lp `(,e ,@(map (g vs exp) args)) trailer)) + (_ (error "unhandled trailer"))))))) + ((#:identifier x . _) (string->symbol x)) - ((#:string x) + ((#:string #f x) x) (((and x (or #:+ #:- #:* #:/)) . l) @@ -214,57 +234,60 @@ (,lp)))))) ((#:classdef (#:identifier class . _) parents defs) - (let () - (define (filt l) - (reverse - (fold (lambda (x s) - (match x - (((or 'fast 'functional)) s) - (x (cons x s)))) - '() l))) - (define (is-functional l) - (fold (lambda (x pred) - (if pred - pred - (match x - (('functional) #t) - (_ #f)))) #f l)) - (define (is-fast l) - (fold (lambda (x pred) - (if pred - pred - (match x - (('fast) #t) - (_ #f)))) #f l)) - - - (let* ((class (string->symbol class)) - (parents (match parents - (#f - '()) - ((#:arglist args . _) - (map (g vs exp) args)))) - (is-func (is-functional parents)) - (is-fast (is-fast parents)) - (kind (if is-func - (if is-fast - 'mk-pf-class - 'mk-pyf-class) - (if is-fast - 'mk-p-class - 'mk-py-class))) - (parents (filt parents))) - `(define ,class (,(O 'wrap) - (,(O kind) - ,class - ,(map (lambda (x) `(,(O 'get-class) ,x)) parents) - #:const - ,(match (exp vs defs) - ((begin . l) - l) - (l l)) - #:dynamic - ())))))) + (with-fluids ((is-class? #t)) + (let () + (define (filt l) + (reverse + (fold (lambda (x s) + (match x + (((or 'fast 'functional)) s) + (x (cons x s)))) + '() l))) + (define (is-functional l) + (fold (lambda (x pred) + (if pred + pred + (match x + (('functional) #t) + (_ #f)))) #f l)) + (define (is-fast l) + (fold (lambda (x pred) + (if pred + pred + (match x + (('fast) #t) + (_ #f)))) #f l)) + + + (let* ((class (string->symbol class)) + (parents (match parents + (#f + '()) + ((#:arglist args . _) + (map (g vs exp) args)))) + (is-func (is-functional parents)) + (is-fast (is-fast parents)) + (kind (if is-func + (if is-fast + 'mk-pf-class + 'mk-pyf-class) + (if is-fast + 'mk-p-class + 'mk-py-class))) + (parents (filt parents))) + `(define ,class (,(O 'wrap) + (,(O kind) + ,class + ,(map (lambda (x) `(,(O 'get-class) ,x)) parents) + #:const + ,(match (exp vs defs) + (('begin . l) + l) + ((('begin . l)) + l) + (l l)) + #:dynamic + ()))))))) @@ -371,7 +394,8 @@ #f #f) #f code) - (let* ((f (string->symbol f)) + (let* ((c? (fluid-ref is-class?)) + (f (string->symbol f)) (r (gensym "return")) (as (map (lambda (x) (match x ((((#:identifier x . _) . #f) #f) @@ -380,13 +404,26 @@ (vs (union as vs)) (ns (scope code vs)) (df (defs code '())) + (ex (gensym "ex")) (ls (diff (diff ns vs) df))) - - `(define ,f (lambda (,@as) - (,(C 'with-return) ,r - (let ,(map (lambda (x) (list x #f)) ls) - ,(with-fluids ((return r)) - (exp ns code)))))))) + (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)))))))))) ((#:global . _) '(values)) @@ -406,7 +443,13 @@ ((#:expr-stmt l (#:assign u)) (cond ((= (length l) (length u)) - (cons 'begin (map make-set (map (lambda x vs) l) l (map (g vs exp) u)))) + (if (= (length l) 1) + (make-set vs (car l) (exp vs (car u))) + (cons 'begin + (map make-set + (map (lambda x vs) l) + l + (map (g vs exp) u))))) ((= (length u) 1) (let ((vars (map (lambda (x) (gensym "v")) l))) `(call-with-values (lambda () (exp vs (car u))) @@ -460,7 +503,8 @@ (exp '() x)) arglist)) - `((,(G 'define-module) (language python module ,@args))))) + `((,(G 'define-module) + (language python module ,@args))))) (x '()))) (if (pair? start) @@ -469,6 +513,8 @@ (let ((globs (get-globals x))) `(begin ,@start + ,(C 'clear-warning-data) + (set! (@@ (system base message) %dont-warn-list) '()) ,@(map (lambda (s) `(,(C 'var) ,s)) globs) ,@(map (g globs exp) x)))) @@ -548,7 +594,9 @@ code)))))) (define-syntax-rule (var v) - (if (defined? 'v) - (values) - (define! 'v #f))) + (begin + (dont-warn v) + (if (defined? 'v) + (values) + (define! 'v #f)))) -- cgit v1.2.3