diff options
Diffstat (limited to 'modules/language/python/compile.scm')
| -rw-r--r-- | modules/language/python/compile.scm | 182 |
1 files changed, 137 insertions, 45 deletions
diff --git a/modules/language/python/compile.scm b/modules/language/python/compile.scm index 8dc715a..d4b1011 100644 --- a/modules/language/python/compile.scm +++ b/modules/language/python/compile.scm @@ -46,6 +46,43 @@ (define exit-prompt (make-prompt-tag)) (define exit-fluid (make-fluid #f)) +(define (formatter . x) "<missing>") + +(define (mk-string vs l) + (define (mk-string2 x) + (if (string? x) + x + (let ((l (let lp ((l x)) + (match l + ((x . l) + (cons + (if (string? x) + x + (match x + ((#:field tag a b) + `(,(C 'formatter) ,(exp vs tag) ,a ,b)))) + (lp l))) + (() '()))))) + (match l + ((x) x) + ((x . l) (cons* '+ x l)))))) + + (let ((r + (let lp ((l l)) + (match l + ((x . l) + (let ((x (mk-string2 x)) + (l (lp l))) + (if (and (string? x) (= (length l) 1) (string? (car l))) + (list (+ x (car l))) + (cons x l)))) + (() (list "")))))) + (if (string? r) + r + (cons '+ r)))) + + + (define-syntax-rule (with-exit code ...) (with-fluids ((exit-fluid #t)) (call-with-prompt exit-prompt @@ -942,6 +979,19 @@ ...)) +(define *doc* (make-fluid #f)) +(define (get-doc) + (aif it (fluid-ref *doc*) + it + "")) +(define set-doc + (case-lambda + (() (fluid-set! *doc* #f)) + ((x) + (if (not (fluid-ref *doc*)) + (fluid-set! *doc* x))))) + + (define (tr-comp op x y) (match op ((or "<" ">" "<=" ">=") @@ -984,7 +1034,7 @@ (#:string ((_ l) - (string-join l ""))) + (mk-string vs l))) (#:bytes ((_ l) @@ -1156,7 +1206,12 @@ (() #f) (#f #f) ((#:arglist . _) - (get-addings vs (list parents) #f))))) + (get-addings vs (list parents) #f)))) + (cd.doc (with-fluids ((*doc* #f)) + (let ((cd (wth (exp vs code)))) + (cons cd (get-doc))))) + (cd (car cd.doc)) + (doc (cdr cd.doc))) `(set! ,class (,(C 'class-decor) ,decor (,(C 'with-class) ,class @@ -1165,8 +1220,11 @@ ,(if parents (arglist->pkw (clean parents)) `(,(G 'cons) (,(G 'quote) ()) (,(G 'quote) ()))) - ,(map (lambda (x) `(define ,x ,(gw-persson x vo))) ls) - ,(wth (exp vs code))))))))))) + ,doc + ,(cons + (list 'define '__doc__ doc) + (map (lambda (x) `(define ,x ,(gw-persson x vo))) ls)) + ,cd))))))))) (#:verb ((_ x) x)) @@ -1174,8 +1232,28 @@ ((_ (#:string _ s)) (with-input-from-string s read))) (#:comma + ((_ + (and x + (#:expr-stmt + ((#:test + (#:power #f (#:string l) () . #f) + #f)) + (#:assign)))) + (set-doc (mk-string vs l)) + (exp vs x)) + ((_ a) (exp vs a)) + + ((_ (and a + (#:expr-stmt + ((#:test + (#:power #f (#:string ll) () . #f) + #f)) + (#:assign))) . l) + (set-doc (mk-string vs ll)) + `(,(G 'begin) ,(exp vs a) ,(exp vs (cons #:comma l)))) + ((_ a . l) `(,(G 'begin) ,(exp vs a) ,(exp vs (cons #:comma l))))) @@ -1566,8 +1644,18 @@ (ex (gensym "ex")) (y 'scm.yield) (y.f (gen-yield f)) - (ls (diff (diff ns vs) df))) - + (ls (diff (diff ns vs) df)) + (cd.doc (with-fluids ((is-class? #f) + (*doc* #f) + (return r)) + (let ((cd (wth (exp ns code)))) + (cons cd (get-doc))))) + (cd (car cd.doc)) + (doc (cdr cd.doc)) + (docv (gensym "fv")) + (docer (lambda (x) `(,(G 'let) ((,docv ,x)) + (,(C 'set) ,docv (,(G 'quote) __doc__) ,doc) + ,docv)))) (define (mk code) `(let-syntax ((,y (syntax-rules () ((_ . args) @@ -1577,48 +1665,46 @@ (abort-to-prompt ,ab . args))))) ,code)) - (with-fluids ((is-class? #f)) - (if c? - (if y? - `(set! ,f - (,(C 'def-decor) ,decor - (,(C 'def-wrap) ,y? ,f ,ab + (if c? + (if y? + `(set! ,f + ,(docer + `(,(C 'def-decor) ,decor + (,(C 'def-wrap) ,y? ,f ,ab + (,(D 'lam) ,aa + (,(C 'with-return) ,r + ,(mk `(,(G 'let) ,(map (lambda (x) (list x #f)) ls) + (,(C 'with-self) ,c? ,aa + ,cd))))))))) + + `(set! ,f + ,(docer + `(,(C 'def-decor) ,decor (,(D 'lam) ,aa (,(C 'with-return) ,r ,(mk `(,(G 'let) ,(map (lambda (x) (list x #f)) ls) (,(C 'with-self) ,c? ,aa - ,(with-fluids ((return r)) - (wth (exp ns code))))))))))) - - `(set! ,f - (,(C 'def-decor) ,decor - (,(D 'lam) ,aa - (,(C 'with-return) ,r - ,(mk `(,(G 'let) ,(map (lambda (x) (list x #f)) ls) - (,(C 'with-self) ,c? ,aa - ,(with-fluids ((return r)) - (wth (exp ns code))))))))))) + ,cd))))))))) - (if y? - `(set! ,f - (,(C 'def-decor) ,decor - (,(C 'def-wrap) ,y? ,f ,ab - (,(D 'lam) ,aa - (,(C 'with-return) ,r - (,(G 'let) ,(map (lambda (x) (list x #f)) ls) - (,(C 'with-self) ,c? ,aa - ,(with-fluids ((return r)) - (mk - (wth (exp ns code))))))))))) - `(set! ,f - (,(C 'def-decor) ,decor - (,(D 'lam) ,aa - (,(C 'with-return) ,r - (,(G 'let) ,(map (lambda (x) (list x #f)) ls) - (,(C 'with-self) ,c? ,aa - ,(with-fluids ((return r)) - (wth (exp ns code))))))))))))))) - + (if y? + `(set! ,f + ,(docer + `(,(C 'def-decor) ,decor + (,(C 'def-wrap) ,y? ,f ,ab + (,(D 'lam) ,aa + (,(C 'with-return) ,r + (,(G 'let) ,(map (lambda (x) (list x #f)) ls) + (,(C 'with-self) ,c? ,aa + ,(mk cd))))))))) + `(set! ,f + ,(docer + `(,(C 'def-decor) ,decor + (,(D 'lam) ,aa + (,(C 'with-return) ,r + (,(G 'let) ,(map (lambda (x) (list x #f)) ls) + (,(C 'with-self) ,c? ,aa + ,(mk cd))))))))))))) + (#:global ((_ . _) `(,cvalues))) @@ -1946,14 +2032,20 @@ (set! x (cdr x))) (let* ((globs (get-globals x)) - (e (map (g globs exp) x))) + (e.doc (with-fluids ((*doc* #f)) + (let ((r (map (g globs exp) x))) + (cons r (get-doc))))) + (e (car e.doc)) + (doc (cdr e.doc))) + `(begin + (,(G 'set!) __doc__ ,doc) ,@start (,(G 'define) ,fnm (,(G 'make-hash-table))) ,@(map (lambda (s) (if (member s (fluid-ref ignore)) `(,cvalues) - `(,(C 'var) ,s))) globs) + `(,(C 'var) ,(cons '__doc__ s)))) globs) ,@e (,(C 'export-all))))) |