mirror/guile
mirror/guile
1
Fork 0
mirror of https://git.savannah.gnu.org/git/guile.git synced 2025-05-20 03:30:27 +02:00
Code Activity

rework the scheme translator so it's extensible by external modules

Browse source 
* module/language/scheme/translate.scm (*translate-table*)
  (define-scheme-translator): Rework the translator to have the clauses
  defined separately via the define-scheme-translator macro, so that
  external modules can define their own translators. Should be no
  functional change in this commit, though.
This commit is contained in:
Andy Wingo 2008-10-31 13:25:11 +01:00
parent 4631414e29
commit fd4da4fae6
1 changed files with 270 additions and 272 deletions
Download patch file Download diff file Expand all files Collapse all files

108
module/language/scheme/translate.scm
View file

@ -27,13 +27,14 @@
#:use-module (ice-9 receive) #:use-module (ice-9 receive)
#:use-module ((ice-9 syncase) #:select (sc-macro)) #:use-module ((ice-9 syncase) #:select (sc-macro))
#:use-module ((system base compile) #:select (syntax-error)) #:use-module ((system base compile) #:select (syntax-error))
#:export (translate)) #:export (translate translate-1
*translate-table* define-scheme-translator))
(define (translate x e) (define (translate x e)
(call-with-ghil-environment e '() (call-with-ghil-environment e '()
(lambda (env vars) (lambda (env vars)
(make-ghil-lambda env #f vars #f '() (trans env (location x) x))))) (make-ghil-lambda env #f vars #f '() (translate-1 env #f x)))))
;;; ;;;
@ -58,7 +59,7 @@
;; definition forward-declared them ;; definition forward-declared them
(and (variable-bound? var) (variable-ref var))))))) (and (variable-bound? var) (variable-ref var)))))))
(cond (cond
((assq-ref custom-transformer-table val)) ((hashq-ref *translate-table* val))
((defmacro? val) ((defmacro? val)
(lambda (env loc exp) (lambda (env loc exp)
@ -82,8 +83,9 @@
(else #f)))) (else #f))))
(define (trans e l x) (define (translate-1 e l x)
(define (retrans x) (trans e (location x) x)) (let ((l (or l (location x))))
(define (retrans x) (translate-1 e #f x))
(cond ((pair? x) (cond ((pair? x)
(let ((head (car x)) (tail (cdr x))) (let ((head (car x)) (tail (cdr x)))
(cond (cond
@ -106,7 +108,7 @@
;; fixme: non-self-quoting objects like #<foo> ;; fixme: non-self-quoting objects like #<foo>
(else (else
(make-ghil-quote e l #:obj x)))) (make-ghil-quote e l #:obj x)))))
(define (valid-bindings? bindings . it-is-for-do) (define (valid-bindings? bindings . it-is-for-do)
(define (valid-binding? b) (define (valid-binding? b)
@ -116,33 +118,29 @@
(else #f))) (else #f)))
(and (list? bindings) (and-map valid-binding? bindings))) (and (list? bindings) (and-map valid-binding? bindings)))
(define-macro (make-pmatch-transformers env loc retranslate . body) (define *translate-table* (make-hash-table))
(define exp (gensym))
(define (make1 clause) (define-macro (define-scheme-translator sym . clauses)
(let ((sym (car clause)) `(hashq-set! (@ (language scheme translate) *translate-table*)
(clauses (cdr clause))) ,sym
`(cons ,sym (lambda (e l exp)
(lambda (,env ,loc ,exp) (define (retrans x)
(define (,retranslate x) (trans ,env (location x) x)) ((@ (language scheme translate) translate-1) e #f x))
(pmatch (cdr ,exp) (define syntax-error (@ (system base compile) syntax-error))
(pmatch (cdr exp)
,@clauses ,@clauses
(else (syntax-error ,loc (format #f "bad ~A" ',sym) ,exp))))))) (else
`(list ,@(map make1 body))) (syntax-error loc (format #f "bad ~A" ',sym exp)))))))
(define *the-compile-toplevel-symbol* 'compile-toplevel) (define-scheme-translator quote
(define custom-transformer-table
(make-pmatch-transformers
e l retrans
(quote
;; (quote OBJ) ;; (quote OBJ)
((,obj) (make-ghil-quote e l obj))) ((,obj) (make-ghil-quote e l obj)))
(quasiquote (define-scheme-translator quasiquote
;; (quasiquote OBJ) ;; (quasiquote OBJ)
((,obj) (make-ghil-quasiquote e l (trans-quasiquote e l obj 0)))) ((,obj) (make-ghil-quasiquote e l (trans-quasiquote e l obj 0))))
(define (define-scheme-translator define
;; (define NAME VAL) ;; (define NAME VAL)
((,name ,val) (guard (symbol? name) ((,name ,val) (guard (symbol? name)
(ghil-toplevel-env? (ghil-env-parent e))) (ghil-toplevel-env? (ghil-env-parent e)))
@ -153,7 +151,7 @@
;; -> (define NAME (lambda FORMALS BODY...)) ;; -> (define NAME (lambda FORMALS BODY...))
(retrans `(define ,name (lambda ,formals ,@body))))) (retrans `(define ,name (lambda ,formals ,@body)))))
(set! (define-scheme-translator set!
;; (set! NAME VAL) ;; (set! NAME VAL)
((,name ,val) (guard (symbol? name)) ((,name ,val) (guard (symbol? name))
(make-ghil-set e l (ghil-var-for-set! e name) (retrans val))) (make-ghil-set e l (ghil-var-for-set! e name) (retrans val)))
@ -179,26 +177,26 @@
;; -> ((setter NAME) ARGS... VAL) ;; -> ((setter NAME) ARGS... VAL)
(retrans `((setter ,name) . (,@args ,val))))) (retrans `((setter ,name) . (,@args ,val)))))
(if (define-scheme-translator if
;; (if TEST THEN [ELSE]) ;; (if TEST THEN [ELSE])
((,test ,then) ((,test ,then)
(make-ghil-if e l (retrans test) (retrans then) (retrans '(begin)))) (make-ghil-if e l (retrans test) (retrans then) (retrans '(begin))))
((,test ,then ,else) ((,test ,then ,else)
(make-ghil-if e l (retrans test) (retrans then) (retrans else)))) (make-ghil-if e l (retrans test) (retrans then) (retrans else))))
(and (define-scheme-translator and
;; (and EXPS...) ;; (and EXPS...)
(,tail (make-ghil-and e l (map retrans tail)))) (,tail (make-ghil-and e l (map retrans tail))))
(or (define-scheme-translator or
;; (or EXPS...) ;; (or EXPS...)
(,tail (make-ghil-or e l (map retrans tail)))) (,tail (make-ghil-or e l (map retrans tail))))
(begin (define-scheme-translator begin
;; (begin EXPS...) ;; (begin EXPS...)
(,tail (make-ghil-begin e l (map retrans tail)))) (,tail (make-ghil-begin e l (map retrans tail))))
(let (define-scheme-translator let
;; (let NAME ((SYM VAL) ...) BODY...) ;; (let NAME ((SYM VAL) ...) BODY...)
((,name ,bindings . ,body) (guard (symbol? name) ((,name ,bindings . ,body) (guard (symbol? name)
(valid-bindings? bindings)) (valid-bindings? bindings))
@ -218,14 +216,14 @@
(lambda (vars) (lambda (vars)
(make-ghil-bind e l vars vals (trans-body e l body))))))) (make-ghil-bind e l vars vals (trans-body e l body)))))))
(let* (define-scheme-translator let*
;; (let* ((SYM VAL) ...) BODY...) ;; (let* ((SYM VAL) ...) BODY...)
((() . ,body) ((() . ,body)
(retrans `(let () ,@body))) (retrans `(let () ,@body)))
((((,sym ,val) . ,rest) . ,body) (guard (symbol? sym)) ((((,sym ,val) . ,rest) . ,body) (guard (symbol? sym))
(retrans `(let ((,sym ,val)) (let* ,rest ,@body))))) (retrans `(let ((,sym ,val)) (let* ,rest ,@body)))))
(letrec (define-scheme-translator letrec
;; (letrec ((SYM VAL) ...) BODY...) ;; (letrec ((SYM VAL) ...) BODY...)
((,bindings . ,body) (guard (valid-bindings? bindings)) ((,bindings . ,body) (guard (valid-bindings? bindings))
(call-with-ghil-bindings e (map car bindings) (call-with-ghil-bindings e (map car bindings)
@ -233,7 +231,7 @@
(let ((vals (map retrans (map cadr bindings)))) (let ((vals (map retrans (map cadr bindings))))
(make-ghil-bind e l vars vals (trans-body e l body))))))) (make-ghil-bind e l vars vals (trans-body e l body)))))))
(cond (define-scheme-translator cond
;; (cond (CLAUSE BODY...) ...) ;; (cond (CLAUSE BODY...) ...)
(() (retrans '(begin))) (() (retrans '(begin)))
(((else . ,body)) (retrans `(begin ,@body))) (((else . ,body)) (retrans `(begin ,@body)))
@ -244,7 +242,7 @@
(((,test . ,body) . ,rest) (((,test . ,body) . ,rest)
(retrans `(if ,test (begin ,@body) (cond ,@rest))))) (retrans `(if ,test (begin ,@body) (cond ,@rest)))))
(case (define-scheme-translator case
;; (case EXP ((KEY...) BODY...) ...) ;; (case EXP ((KEY...) BODY...) ...)
((,exp . ,clauses) ((,exp . ,clauses)
(retrans (retrans
@ -257,7 +255,7 @@
(begin ,@(cdar ls)) (begin ,@(cdar ls))
,(loop (cdr ls)))))))))) ,(loop (cdr ls))))))))))
(do (define-scheme-translator do
;; (do ((SYM VAL [UPDATE]) ...) (TEST RESULT...) BODY...) ;; (do ((SYM VAL [UPDATE]) ...) (TEST RESULT...) BODY...)
((,bindings (,test . ,result) . ,body) ((,bindings (,test . ,result) . ,body)
(let ((sym (map car bindings)) (let ((sym (map car bindings))
@ -273,7 +271,7 @@
(_l ,@(map next sym update))))))) (_l ,@(map next sym update)))))))
(_l ,@val)))))) (_l ,@val))))))
(lambda (define-scheme-translator lambda
;; (lambda FORMALS BODY...) ;; (lambda FORMALS BODY...)
((,formals . ,body) ((,formals . ,body)
(receive (syms rest) (parse-formals formals) (receive (syms rest) (parse-formals formals)
@ -283,20 +281,21 @@
(make-ghil-lambda env l vars rest meta (make-ghil-lambda env l vars rest meta
(trans-body env l body)))))))) (trans-body env l body))))))))
(define-scheme-translator delay
;; FIXME not hygienic ;; FIXME not hygienic
(delay
((,expr) ((,expr)
(retrans `(make-promise (lambda () ,expr))))) (retrans `(make-promise (lambda () ,expr)))))
(@ (define-scheme-translator @
((,modname ,sym) ((,modname ,sym)
(make-ghil-ref e l (ghil-var-at-module! e modname sym #t)))) (make-ghil-ref e l (ghil-var-at-module! e modname sym #t))))
(@@ (define-scheme-translator @@
((,modname ,sym) ((,modname ,sym)
(make-ghil-ref e l (ghil-var-at-module! e modname sym #f)))) (make-ghil-ref e l (ghil-var-at-module! e modname sym #f))))
(eval-case (define *the-compile-toplevel-symbol* 'compile-toplevel)
(define-scheme-translator eval-case
(,clauses (,clauses
(retrans (retrans
`(begin `(begin
@ -327,11 +326,11 @@
runtime))) runtime)))
(else (syntax-error l "bad eval-case clause" (car in)))))))))))) (else (syntax-error l "bad eval-case clause" (car in))))))))))))
(define-scheme-translator apply
;; FIXME: not hygienic, relies on @apply not being shadowed ;; FIXME: not hygienic, relies on @apply not being shadowed
(apply
(,args (retrans `(@apply ,@args)))) (,args (retrans `(@apply ,@args))))
(@apply (define-scheme-translator @apply
((,proc ,arg1 . ,args) ((,proc ,arg1 . ,args)
(let ((args (cons (retrans arg1) (map retrans args)))) (let ((args (cons (retrans arg1) (map retrans args))))
(cond ((and (symbol? proc) (cond ((and (symbol? proc)
@ -347,28 +346,28 @@
(else (make-ghil-inline e l 'apply (else (make-ghil-inline e l 'apply
(cons (retrans proc) args))))))) (cons (retrans proc) args)))))))
(define-scheme-translator call-with-values
;; FIXME: not hygienic, relies on @call-with-values not being shadowed ;; FIXME: not hygienic, relies on @call-with-values not being shadowed
(call-with-values
((,producer ,consumer) ((,producer ,consumer)
(retrans `(@call-with-values ,producer ,consumer))) (retrans `(@call-with-values ,producer ,consumer)))
(else #f)) (else #f))
(@call-with-values (define-scheme-translator @call-with-values
((,producer ,consumer) ((,producer ,consumer)
(make-ghil-mv-call e l (retrans producer) (retrans consumer)))) (make-ghil-mv-call e l (retrans producer) (retrans consumer))))
(define-scheme-translator call-with-current-continuation
;; FIXME: not hygienic, relies on @call-with-current-continuation ;; FIXME: not hygienic, relies on @call-with-current-continuation
;; not being shadowed ;; not being shadowed
(call-with-current-continuation
((,proc) ((,proc)
(retrans `(@call-with-current-continuation ,proc))) (retrans `(@call-with-current-continuation ,proc)))
(else #f)) (else #f))
(@call-with-current-continuation (define-scheme-translator @call-with-current-continuation
((,proc) ((,proc)
(make-ghil-inline e l 'call/cc (list (retrans proc))))) (make-ghil-inline e l 'call/cc (list (retrans proc)))))
(receive (define-scheme-translator receive
((,formals ,producer-exp . ,body) ((,formals ,producer-exp . ,body)
;; Lovely, self-referential usage. Not strictly necessary, the ;; Lovely, self-referential usage. Not strictly necessary, the
;; macro would do the trick; but it's good to test the mv-bind ;; macro would do the trick; but it's good to test the mv-bind
@ -379,13 +378,13 @@
(make-ghil-mv-bind e l (retrans `(lambda () ,producer-exp)) (make-ghil-mv-bind e l (retrans `(lambda () ,producer-exp))
vars rest (trans-body e l body))))))) vars rest (trans-body e l body)))))))
(values (define-scheme-translator values
((,x) (retrans x)) ((,x) (retrans x))
(,args (make-ghil-values e l (map retrans args)))) (,args (make-ghil-values e l (map retrans args))))
(define-scheme-translator compile-time-environment
;; (compile-time-environment) ;; (compile-time-environment)
;; => (MODULE LEXICALS . EXTERNALS) ;; => (MODULE LEXICALS . EXTERNALS)
(compile-time-environment
(() (make-ghil-inline (() (make-ghil-inline
e l 'cons e l 'cons
(list (retrans '(current-module)) (list (retrans '(current-module))
@ -393,7 +392,6 @@
e l 'cons e l 'cons
(list (make-ghil-reified-env e l) (list (make-ghil-reified-env e l)
(make-ghil-inline e l 'externals '()))))))) (make-ghil-inline e l 'externals '())))))))
))
(define (lookup-apply-transformer proc) (define (lookup-apply-transformer proc)
(cond ((eq? proc values) (cond ((eq? proc values)
@ -410,8 +408,8 @@
(cond (cond
((zero? level) ((zero? level)
(if (eq? (car x) 'unquote) (if (eq? (car x) 'unquote)
(make-ghil-unquote e l (trans e l obj)) (make-ghil-unquote e l (translate-1 e l obj))
(make-ghil-unquote-splicing e l (trans e l obj)))) (make-ghil-unquote-splicing e l (translate-1 e l obj))))
(else (else
(list (car x) (trans-quasiquote e l obj (1- level)))))) (list (car x) (trans-quasiquote e l obj (1- level))))))
(else (syntax-error l (format #f "bad ~A" (car x)) x))))) (else (syntax-error l (format #f "bad ~A" (car x)) x)))))
@ -438,8 +436,8 @@
(loop (cdr ls) (cons (car ls) ds))) (loop (cdr ls) (cons (car ls) ds)))
(else (else
(if (null? ds) (if (null? ds)
(trans e l `(begin ,@ls)) (translate-1 e l `(begin ,@ls))
(trans e l `(letrec ,(map define->binding ds) ,@ls))))))) (translate-1 e l `(letrec ,(map define->binding ds) ,@ls)))))))
(define (parse-formals formals) (define (parse-formals formals)
(cond (cond