diff options
author | Andy Wingo <wingo@pobox.com> | 2009-02-27 15:17:01 +0100 |
---|---|---|
committer | Andy Wingo <wingo@pobox.com> | 2009-02-27 15:17:01 +0100 |
commit | 3ac6d9f37e9fd127a29b81ffa4c4205c9eca2552 (patch) | |
tree | 8fff9f6fde2a9e1d6fdc08b6b75308449b16b8f3 /module/language/scheme | |
parent | 3ca840111378f0b99d8e4e7e79a73a95d5124518 (diff) | |
download | guile-3ac6d9f37e9fd127a29b81ffa4c4205c9eca2552.tar.gz |
use -> macro in scheme->ghil compiler
* module/language/scheme/compile-ghil.scm (->): New macro, makes GHIL
generation a bit more palatable. Use it in all the transformers.
Diffstat (limited to 'module/language/scheme')
-rw-r--r-- | module/language/scheme/compile-ghil.scm | 87 |
1 files changed, 46 insertions, 41 deletions
diff --git a/module/language/scheme/compile-ghil.scm b/module/language/scheme/compile-ghil.scm index e4f1292bf..db3628366 100644 --- a/module/language/scheme/compile-ghil.scm +++ b/module/language/scheme/compile-ghil.scm @@ -162,6 +162,9 @@ (define *translate-table* (make-hash-table)) +(define-macro (-> form) + `(,(symbol-append 'make-ghil- (car form)) e l . ,(cdr form))) + (define-macro (define-scheme-translator sym . clauses) `(hashq-set! (@ (language scheme compile-ghil) *translate-table*) ,sym @@ -180,18 +183,20 @@ (define-scheme-translator quote ;; (quote OBJ) - ((,obj) (make-ghil-quote e l obj))) + ((,obj) + (-> (quote obj)))) (define-scheme-translator quasiquote ;; (quasiquote OBJ) - ((,obj) (make-ghil-quasiquote e l (trans-quasiquote e l obj 0)))) + ((,obj) + (-> (quasiquote (trans-quasiquote e l obj 0))))) (define-scheme-translator define ;; (define NAME VAL) ((,name ,val) (guard (symbol? name) (ghil-toplevel-env? (ghil-env-parent e))) - (make-ghil-define e l (ghil-var-define! (ghil-env-parent e) name) - (maybe-name-value! (retrans val) name))) + (-> (define (ghil-var-define! (ghil-env-parent e) name) + (maybe-name-value! (retrans val) name)))) ;; (define (NAME FORMALS...) BODY...) (((,name . ,formals) . ,body) (guard (symbol? name)) ;; -> (define NAME (lambda FORMALS BODY...)) @@ -200,7 +205,7 @@ (define-scheme-translator set! ;; (set! NAME VAL) ((,name ,val) (guard (symbol? name)) - (make-ghil-set e l (ghil-var-for-set! e name) (retrans val))) + (-> (set (ghil-var-for-set! e name) (retrans val)))) ;; FIXME: Would be nice to verify the values of @ and @@ relative ;; to imported modules... @@ -208,15 +213,13 @@ (list? modname) (and-map symbol? modname) (not (ghil-var-is-bound? e '@))) - (make-ghil-set e l (ghil-var-at-module! e modname name #t) - (retrans val))) + (-> (set (ghil-var-at-module! e modname name #t) (retrans val)))) (((@@ ,modname ,name) ,val) (guard (symbol? name) (list? modname) (and-map symbol? modname) (not (ghil-var-is-bound? e '@@))) - (make-ghil-set e l (ghil-var-at-module! e modname name #f) - (retrans val))) + (-> (set (ghil-var-at-module! e modname name #f) (retrans val)))) ;; (set! (NAME ARGS...) VAL) (((,name . ,args) ,val) (guard (symbol? name)) @@ -226,21 +229,24 @@ (define-scheme-translator if ;; (if TEST THEN [ELSE]) ((,test ,then) - (make-ghil-if e l (retrans test) (retrans then) (retrans '(begin)))) + (-> (if (retrans test) (retrans then) (retrans '(begin))))) ((,test ,then ,else) - (make-ghil-if e l (retrans test) (retrans then) (retrans else)))) + (-> (if (retrans test) (retrans then) (retrans else))))) (define-scheme-translator and ;; (and EXPS...) - (,tail (make-ghil-and e l (map retrans tail)))) + (,tail + (-> (and (map retrans tail))))) (define-scheme-translator or ;; (or EXPS...) - (,tail (make-ghil-or e l (map retrans tail)))) + (,tail + (-> (or (map retrans tail))))) (define-scheme-translator begin ;; (begin EXPS...) - (,tail (make-ghil-begin e l (map retrans tail)))) + (,tail + (-> (begin (map retrans tail))))) (define-scheme-translator let ;; (let NAME ((SYM VAL) ...) BODY...) @@ -253,7 +259,7 @@ ;; (let () BODY...) ((() . ,body) ;; Note: this differs from `begin' - (make-ghil-begin e l (list (trans-body e l body)))) + (-> (begin (list (trans-body e l body))))) ;; (let ((SYM VAL) ...) BODY...) ((,bindings . ,body) (guard (valid-bindings? bindings)) @@ -262,7 +268,7 @@ bindings))) (call-with-ghil-bindings e (map car bindings) (lambda (vars) - (make-ghil-bind e l vars vals (trans-body e l body))))))) + (-> (bind vars vals (trans-body e l body)))))))) (define-scheme-translator let* ;; (let* ((SYM VAL) ...) BODY...) @@ -280,7 +286,7 @@ (maybe-name-value! (retrans (cadr b)) (car b))) bindings))) - (make-ghil-bind e l vars vals (trans-body e l body))))))) + (-> (bind vars vals (trans-body e l body)))))))) (define-scheme-translator cond ;; (cond (CLAUSE BODY...) ...) @@ -326,11 +332,10 @@ ;; (lambda FORMALS BODY...) ((,formals . ,body) (receive (syms rest) (parse-formals formals) - (call-with-ghil-environment e syms - (lambda (env vars) - (receive (meta body) (parse-lambda-meta body) - (make-ghil-lambda env l vars rest meta - (trans-body env l body)))))))) + (call-with-ghil-environment e syms + (lambda (e vars) + (receive (meta body) (parse-lambda-meta body) + (-> (lambda vars rest meta (trans-body e l body))))))))) (define-scheme-translator delay ;; FIXME not hygienic @@ -339,11 +344,11 @@ (define-scheme-translator @ ((,modname ,sym) - (make-ghil-ref e l (ghil-var-at-module! e modname sym #t)))) + (-> (ref (ghil-var-at-module! e modname sym #t))))) (define-scheme-translator @@ ((,modname ,sym) - (make-ghil-ref e l (ghil-var-at-module! e modname sym #f)))) + (-> (ref (ghil-var-at-module! e modname sym #f))))) (define *the-compile-toplevel-symbol* 'compile-toplevel) (define-scheme-translator eval-case @@ -396,8 +401,8 @@ ;; unit, but defined in the toplevel environment, and has ;; an apply transformer registered => (lambda (t) (t e l args))) - (else (make-ghil-inline e l 'apply - (cons (retrans proc) args))))))) + (else + (-> (inline 'apply (cons (retrans proc) args)))))))) (define-scheme-translator call-with-values ;; FIXME: not hygienic, relies on @call-with-values not being shadowed @@ -407,7 +412,7 @@ (define-scheme-translator @call-with-values ((,producer ,consumer) - (make-ghil-mv-call e l (retrans producer) (retrans consumer)))) + (-> (mv-call (retrans producer) (retrans consumer))))) (define-scheme-translator call-with-current-continuation ;; FIXME: not hygienic, relies on @call-with-current-continuation @@ -418,7 +423,7 @@ (define-scheme-translator @call-with-current-continuation ((,proc) - (make-ghil-inline e l 'call/cc (list (retrans proc))))) + (-> (inline 'call/cc (list (retrans proc)))))) (define-scheme-translator receive ((,formals ,producer-exp . ,body) @@ -429,28 +434,28 @@ (let ((producer (retrans `(lambda () ,producer-exp)))) (call-with-ghil-bindings e syms (lambda (vars) - (make-ghil-mv-bind e l producer - vars rest (trans-body e l body)))))))) + (-> (mv-bind producer vars rest + (trans-body e l body))))))))) (define-scheme-translator values ((,x) (retrans x)) - (,args (make-ghil-values e l (map retrans args)))) + (,args + (-> (values (map retrans args))))) (define-scheme-translator compile-time-environment ;; (compile-time-environment) ;; => (MODULE LEXICALS . EXTERNALS) - (() (make-ghil-inline - e l 'cons - (list (retrans '(current-module)) - (make-ghil-inline - e l 'cons - (list (make-ghil-reified-env e l) - (make-ghil-inline e l 'externals '()))))))) + (() + (-> (inline 'cons + (list (retrans '(current-module)) + (-> (inline 'cons + (list (-> (reified-env)) + (-> (inline 'externals '())))))))))) (define (lookup-apply-transformer proc) (cond ((eq? proc values) (lambda (e l args) - (make-ghil-values* e l args))) + (-> (values* args)))) (else #f))) (define (trans-quasiquote e l x level) @@ -462,8 +467,8 @@ (cond ((zero? level) (if (eq? (car x) 'unquote) - (make-ghil-unquote e l (translate-1 e l obj)) - (make-ghil-unquote-splicing e l (translate-1 e l obj)))) + (-> (unquote (translate-1 e l obj))) + (-> (unquote-splicing (translate-1 e l obj))))) (else (list (car x) (trans-quasiquote e l obj (1- level)))))) (else (syntax-error l (format #f "bad ~A" (car x)) x))))) |