diff options
Diffstat (limited to 'modules/language/python/compile.scm')
| -rw-r--r-- | modules/language/python/compile.scm | 115 |
1 files changed, 106 insertions, 9 deletions
diff --git a/modules/language/python/compile.scm b/modules/language/python/compile.scm index 354b39d..91c33c1 100644 --- a/modules/language/python/compile.scm +++ b/modules/language/python/compile.scm @@ -51,7 +51,7 @@ (call-with-prompt exit-prompt (lambda () code ...) (lambda (k val) - (if (not (= val 0)) + (if (not (equal? val 0)) (format #t "exit with error ~a~%" val)))))) (define (get-exported-symbols x) @@ -76,20 +76,106 @@ r))) +(define-syntax use-modules-- + (lambda (x) + (define (keyword-like? stx) + (let ((dat (syntax->datum stx))) + (and (symbol? dat) + (eqv? (string-ref (symbol->string dat) 0) #\:)))) + (define (->keyword sym) + (symbol->keyword (string->symbol (substring (symbol->string sym) 1)))) + + (define (quotify-iface args) + (let loop ((in args) (out '())) + (syntax-case in () + (() (reverse! out)) + ;; The user wanted #:foo, but wrote :foo. Fix it. + ((sym . in) (keyword-like? #'sym) + (loop #`(#,(->keyword (syntax->datum #'sym)) . in) out)) + ((kw . in) (not (keyword? (syntax->datum #'kw))) + (syntax-violation 'define-module "expected keyword arg" x #'kw)) + ((#:renamer renamer . in) + (loop #'in (cons* #'renamer #:renamer out))) + ((kw val . in) + (loop #'in (cons* #''val #'kw out)))))) + + (define (quotify specs) + (let lp ((in specs) (out '())) + (syntax-case in () + (() (reverse out)) + (((name name* ...) . in) + (and-map symbol? (syntax->datum #'(name name* ...))) + (lp #'in (cons #''((name name* ...)) out))) + ((((name name* ...) arg ...) . in) + (and-map symbol? (syntax->datum #'(name name* ...))) + (with-syntax (((quoted-arg ...) (quotify-iface #'(arg ...)))) + (lp #'in (cons #`(list '(name name* ...) quoted-arg ...) + out))))))) + + (syntax-case x () + ((_ spec ...) + (with-syntax (((quoted-args ...) (quotify #'(spec ...)))) + #'(eval-when (expand) + (process-use-modules (list quoted-args ...)) + *unspecified*)))))) + +(define-syntax use-modules- + (lambda (x) + (define (keyword-like? stx) + (let ((dat (syntax->datum stx))) + (and (symbol? dat) + (eqv? (string-ref (symbol->string dat) 0) #\:)))) + (define (->keyword sym) + (symbol->keyword (string->symbol (substring (symbol->string sym) 1)))) + + (define (quotify-iface args) + (let loop ((in args) (out '())) + (syntax-case in () + (() (reverse! out)) + ;; The user wanted #:foo, but wrote :foo. Fix it. + ((sym . in) (keyword-like? #'sym) + (loop #`(#,(->keyword (syntax->datum #'sym)) . in) out)) + ((kw . in) (not (keyword? (syntax->datum #'kw))) + (syntax-violation 'define-module "expected keyword arg" x #'kw)) + ((#:renamer renamer . in) + (loop #'in (cons* #'renamer #:renamer out))) + ((kw val . in) + (loop #'in (cons* #''val #'kw out)))))) + + (define (quotify specs) + (let lp ((in specs) (out '())) + (syntax-case in () + (() (reverse out)) + (((name name* ...) . in) + (and-map symbol? (syntax->datum #'(name name* ...))) + (lp #'in (cons #''((name name* ...)) out))) + ((((name name* ...) arg ...) . in) + (and-map symbol? (syntax->datum #'(name name* ...))) + (with-syntax (((quoted-arg ...) (quotify-iface #'(arg ...)))) + (lp #'in (cons #`(list '(name name* ...) quoted-arg ...) + out))))))) + + (syntax-case x () + ((_ spec ...) + (with-syntax (((quoted-args ...) (quotify #'(spec ...)))) + #'(eval-when (eval load) + (process-use-modules (list quoted-args ...)) + *unspecified*)))))) + (define-syntax-rule (use p l a ...) (begin - (eval-when (compile) + (eval-when (expand) (catch #t (lambda () (if (not p) (reload-module (resolve-module 'l))) - (use-modules a ...)) + (use-modules-- a ...)) (lambda x #f))) (eval-when (eval load) (catch #t (lambda () (if (not p) (reload-module (resolve-module 'l))) - (use-modules a ...)) + (use-modules- a ...)) (lambda x (raise (ImportError ((@ (guile) format) #f "failed to import ~a ~a" 'l x)))))))) @@ -684,6 +770,14 @@ (define-syntax-rule (setwrap u) (call-with-values (lambda () u) + (lambda (x . x*) + (if (null? x*) + x + (cons x x*))))) + +#; +(define-syntax-rule (setwrap u) + (call-with-values (lambda () u) (case-lambda ((x) x) (x x)))) @@ -1269,7 +1363,7 @@ ((_ es in code . else) (let lp ((es es)) - (match es + (match es (((#:power #f (#:tuple . l) . _)) (lp l)) (_ @@ -1278,7 +1372,10 @@ (code2 (exp vs2 code)) (p (is-ec #t code2 #t (list (C 'continue)))) (else2 (if else (exp vs2 else) #f)) - (in2 (map (g vs exp) in))) + (in2 (match in + ((in) (list (exp vs in))) + ((in ...) (list `(,(G 'list) + ,@ (map (g vs exp) in))))))) (list (C 'cfor) es2 in2 code2 else2 p))))))) (#:sub @@ -1336,7 +1433,7 @@ (#:try ((_ x (or #f ()) #f . fin) (if fin - `(,(T 'try) (lambda () ,(exp vs x)) #:finally (lambda () fin)) + `(,(T 'try) (lambda () ,(exp vs x)) #:finally (lambda () ,(exp vs fin))) `(,(T 'try) (lambda () ,(exp vs x))))) ((_ x exc else . fin) @@ -1699,14 +1796,14 @@ ((_ k (and e (#:cfor . _))) (let ((dict (gensym "dict"))) `(,(G 'let) ((,dict (,(Se 'set)))) - ,(gen-sel vs e `((,(O 'ref) ,dict 'add) ,(exp vs k))) + ,(gen-sel vs e `((,(O 'ref) ,dict (,(G 'quote) add)) ,(exp vs k))) ,dict))) ((_ k ...) (let ((set (gensym "dict"))) `(,(G 'let) ((,set (,(Se 'set)))) ,@(map (lambda (k) - `((,(O 'ref) ,set 'add) ,(exp vs k))) + `((,(O 'ref) ,set (,(G 'quote) add)) ,(exp vs k))) k) ,set)))) |