mirror/guile
mirror/guile
1
Fork 0
mirror of https://git.savannah.gnu.org/git/guile.git synced 2025-05-19 19:20:23 +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

542
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,31 +83,32 @@
(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))))
(cond ((pair? x) (define (retrans x) (translate-1 e #f x))
(let ((head (car x)) (tail (cdr x))) (cond ((pair? x)
(cond (let ((head (car x)) (tail (cdr x)))
((lookup-transformer head retrans) (cond
=> (lambda (t) (t e l x))) ((lookup-transformer head retrans)
=> (lambda (t) (t e l x)))
;; FIXME: lexical/module overrides of forbidden primitives ;; FIXME: lexical/module overrides of forbidden primitives
((memq head *forbidden-primitives*) ((memq head *forbidden-primitives*)
(syntax-error l (format #f "`~a' is forbidden" head) (syntax-error l (format #f "`~a' is forbidden" head)
(cons head tail))) (cons head tail)))
(else (else
(let ((tail (map retrans tail))) (let ((tail (map retrans tail)))
(or (and (symbol? head) (or (and (symbol? head)
(try-inline-with-env e l (cons head tail))) (try-inline-with-env e l (cons head tail)))
(make-ghil-call e l (retrans head) tail))))))) (make-ghil-call e l (retrans head) tail)))))))
((symbol? x) ((symbol? x)
(make-ghil-ref e l (ghil-var-for-ref! e x))) (make-ghil-ref e l (ghil-var-for-ref! e x)))
;; 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,284 +118,280 @@
(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)
(let ((sym (car clause))
(clauses (cdr clause)))
`(cons ,sym
(lambda (,env ,loc ,exp)
(define (,retranslate x) (trans ,env (location x) x))
(pmatch (cdr ,exp)
,@clauses
(else (syntax-error ,loc (format #f "bad ~A" ',sym) ,exp)))))))
`(list ,@(map make1 body)))
(define *the-compile-toplevel-symbol* 'compile-toplevel) (define-macro (define-scheme-translator sym . clauses)
`(hashq-set! (@ (language scheme translate) *translate-table*)
,sym
(lambda (e l exp)
(define (retrans x)
((@ (language scheme translate) translate-1) e #f x))
(define syntax-error (@ (system base compile) syntax-error))
(pmatch (cdr exp)
,@clauses
(else
(syntax-error loc (format #f "bad ~A" ',sym exp)))))))
(define custom-transformer-table (define-scheme-translator quote
(make-pmatch-transformers ;; (quote OBJ)
e l retrans ((,obj) (make-ghil-quote e l obj)))
(quote
;; (quote 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)))
(make-ghil-define e l (ghil-var-define! (ghil-env-parent e) name) (make-ghil-define e l (ghil-var-define! (ghil-env-parent e) name)
(maybe-name-value! (retrans val) name))) (maybe-name-value! (retrans val) name)))
;; (define (NAME FORMALS...) BODY...) ;; (define (NAME FORMALS...) BODY...)
(((,name . ,formals) . ,body) (guard (symbol? name)) (((,name . ,formals) . ,body) (guard (symbol? name))
;; -> (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)))
;; FIXME: Would be nice to verify the values of @ and @@ relative ;; FIXME: Would be nice to verify the values of @ and @@ relative
;; to imported modules... ;; to imported modules...
(((@ ,modname ,name) ,val) (guard (symbol? name) (((@ ,modname ,name) ,val) (guard (symbol? name)
(list? modname) (list? modname)
(and-map symbol? modname) (and-map symbol? modname)
(not (ghil-var-is-bound? e '@))) (not (ghil-var-is-bound? e '@)))
(make-ghil-set e l (ghil-var-at-module! e modname name #t) (make-ghil-set e l (ghil-var-at-module! e modname name #t)
(retrans val))) (retrans val)))
(((@@ ,modname ,name) ,val) (guard (symbol? name) (((@@ ,modname ,name) ,val) (guard (symbol? name)
(list? modname) (list? modname)
(and-map symbol? modname) (and-map symbol? modname)
(not (ghil-var-is-bound? e '@@))) (not (ghil-var-is-bound? e '@@)))
(make-ghil-set e l (ghil-var-at-module! e modname name #f) (make-ghil-set e l (ghil-var-at-module! e modname name #f)
(retrans val))) (retrans val)))
;; (set! (NAME ARGS...) VAL) ;; (set! (NAME ARGS...) VAL)
(((,name . ,args) ,val) (guard (symbol? name)) (((,name . ,args) ,val) (guard (symbol? name))
;; -> ((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))
;; -> (letrec ((NAME (lambda (SYM...) BODY...))) (NAME VAL...)) ;; -> (letrec ((NAME (lambda (SYM...) BODY...))) (NAME VAL...))
(retrans `(letrec ((,name (lambda ,(map car bindings) ,@body))) (retrans `(letrec ((,name (lambda ,(map car bindings) ,@body)))
(,name ,@(map cadr bindings))))) (,name ,@(map cadr bindings)))))
;; (let () BODY...) ;; (let () BODY...)
((() . ,body) ((() . ,body)
;; Note: this differs from `begin' ;; Note: this differs from `begin'
(make-ghil-begin e l (list (trans-body e l body)))) (make-ghil-begin e l (list (trans-body e l body))))
;; (let ((SYM VAL) ...) BODY...) ;; (let ((SYM VAL) ...) BODY...)
((,bindings . ,body) (guard (valid-bindings? bindings)) ((,bindings . ,body) (guard (valid-bindings? bindings))
(let ((vals (map retrans (map cadr bindings)))) (let ((vals (map retrans (map cadr bindings))))
(call-with-ghil-bindings e (map car bindings)
(lambda (vars)
(make-ghil-bind e l vars vals (trans-body e l body)))))))
(let*
;; (let* ((SYM VAL) ...) BODY...)
((() . ,body)
(retrans `(let () ,@body)))
((((,sym ,val) . ,rest) . ,body) (guard (symbol? sym))
(retrans `(let ((,sym ,val)) (let* ,rest ,@body)))))
(letrec
;; (letrec ((SYM VAL) ...) BODY...)
((,bindings . ,body) (guard (valid-bindings? bindings))
(call-with-ghil-bindings e (map car bindings) (call-with-ghil-bindings e (map car bindings)
(lambda (vars) (lambda (vars)
(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 let*
;; (cond (CLAUSE BODY...) ...) ;; (let* ((SYM VAL) ...) BODY...)
(() (retrans '(begin))) ((() . ,body)
(((else . ,body)) (retrans `(begin ,@body))) (retrans `(let () ,@body)))
(((,test) . ,rest) (retrans `(or ,test (cond ,@rest)))) ((((,sym ,val) . ,rest) . ,body) (guard (symbol? sym))
(((,test => ,proc) . ,rest) (retrans `(let ((,sym ,val)) (let* ,rest ,@body)))))
;; FIXME hygiene!
(retrans `(let ((_t ,test)) (if _t (,proc _t) (cond ,@rest)))))
(((,test . ,body) . ,rest)
(retrans `(if ,test (begin ,@body) (cond ,@rest)))))
(case (define-scheme-translator letrec
;; (case EXP ((KEY...) BODY...) ...) ;; (letrec ((SYM VAL) ...) BODY...)
((,exp . ,clauses) ((,bindings . ,body) (guard (valid-bindings? bindings))
(call-with-ghil-bindings e (map car bindings)
(lambda (vars)
(let ((vals (map retrans (map cadr bindings))))
(make-ghil-bind e l vars vals (trans-body e l body)))))))
(define-scheme-translator cond
;; (cond (CLAUSE BODY...) ...)
(() (retrans '(begin)))
(((else . ,body)) (retrans `(begin ,@body)))
(((,test) . ,rest) (retrans `(or ,test (cond ,@rest))))
(((,test => ,proc) . ,rest)
;; FIXME hygiene!
(retrans `(let ((_t ,test)) (if _t (,proc _t) (cond ,@rest)))))
(((,test . ,body) . ,rest)
(retrans `(if ,test (begin ,@body) (cond ,@rest)))))
(define-scheme-translator case
;; (case EXP ((KEY...) BODY...) ...)
((,exp . ,clauses)
(retrans
;; FIXME hygiene!
`(let ((_t ,exp))
,(let loop ((ls clauses))
(cond ((null? ls) '(begin))
((eq? (caar ls) 'else) `(begin ,@(cdar ls)))
(else `(if (memv _t ',(caar ls))
(begin ,@(cdar ls))
,(loop (cdr ls))))))))))
(define-scheme-translator do
;; (do ((SYM VAL [UPDATE]) ...) (TEST RESULT...) BODY...)
((,bindings (,test . ,result) . ,body)
(let ((sym (map car bindings))
(val (map cadr bindings))
(update (map cddr bindings)))
(define (next s x) (if (pair? x) (car x) s))
(retrans (retrans
;; FIXME hygiene! ;; FIXME hygiene!
`(let ((_t ,exp)) `(letrec ((_l (lambda ,sym
,(let loop ((ls clauses)) (if ,test
(cond ((null? ls) '(begin)) (begin ,@result)
((eq? (caar ls) 'else) `(begin ,@(cdar ls))) (begin ,@body
(else `(if (memv _t ',(caar ls)) (_l ,@(map next sym update)))))))
(begin ,@(cdar ls)) (_l ,@val))))))
,(loop (cdr ls))))))))))
(do (define-scheme-translator lambda
;; (do ((SYM VAL [UPDATE]) ...) (TEST RESULT...) BODY...) ;; (lambda FORMALS BODY...)
((,bindings (,test . ,result) . ,body) ((,formals . ,body)
(let ((sym (map car bindings)) (receive (syms rest) (parse-formals formals)
(val (map cadr bindings)) (call-with-ghil-environment e syms
(update (map cddr bindings))) (lambda (env vars)
(define (next s x) (if (pair? x) (car x) s)) (receive (meta body) (parse-lambda-meta body)
(retrans (make-ghil-lambda env l vars rest meta
;; FIXME hygiene! (trans-body env l body))))))))
`(letrec ((_l (lambda ,sym
(if ,test
(begin ,@result)
(begin ,@body
(_l ,@(map next sym update)))))))
(_l ,@val))))))
(lambda (define-scheme-translator delay
;; (lambda FORMALS BODY...) ;; FIXME not hygienic
((,formals . ,body) ((,expr)
(receive (syms rest) (parse-formals formals) (retrans `(make-promise (lambda () ,expr)))))
(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))))))))
;; FIXME not hygienic (define-scheme-translator @
(delay ((,modname ,sym)
((,expr) (make-ghil-ref e l (ghil-var-at-module! e modname sym #t))))
(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 #f))))
(@@ (define *the-compile-toplevel-symbol* 'compile-toplevel)
((,modname ,sym) (define-scheme-translator eval-case
(make-ghil-ref e l (ghil-var-at-module! e modname sym #f)))) (,clauses
(retrans
`(begin
;; Compilation of toplevel units is always wrapped in a lambda
,@(let ((toplevel? (ghil-toplevel-env? (ghil-env-parent e))))
(let loop ((seen '()) (in clauses) (runtime '()))
(cond
((null? in) runtime)
(else
(pmatch (car in)
((else . ,body)
(if (and toplevel? (not (memq *the-compile-toplevel-symbol* seen)))
(primitive-eval `(begin ,@body)))
(if (memq (if toplevel? *the-compile-toplevel-symbol* 'evaluate) seen)
runtime
body))
((,keys . ,body) (guard (list? keys) (and-map symbol? keys))
(for-each (lambda (k)
(if (memq k seen)
(syntax-error l "eval-case condition seen twice" k)))
keys)
(if (and toplevel? (memq *the-compile-toplevel-symbol* keys))
(primitive-eval `(begin ,@body)))
(loop (append keys seen)
(cdr in)
(if (memq (if toplevel? 'load-toplevel 'evaluate) keys)
(append runtime body)
runtime)))
(else (syntax-error l "bad eval-case clause" (car in))))))))))))
(eval-case (define-scheme-translator apply
(,clauses ;; FIXME: not hygienic, relies on @apply not being shadowed
(retrans (,args (retrans `(@apply ,@args))))
`(begin
;; Compilation of toplevel units is always wrapped in a lambda
,@(let ((toplevel? (ghil-toplevel-env? (ghil-env-parent e))))
(let loop ((seen '()) (in clauses) (runtime '()))
(cond
((null? in) runtime)
(else
(pmatch (car in)
((else . ,body)
(if (and toplevel? (not (memq *the-compile-toplevel-symbol* seen)))
(primitive-eval `(begin ,@body)))
(if (memq (if toplevel? *the-compile-toplevel-symbol* 'evaluate) seen)
runtime
body))
((,keys . ,body) (guard (list? keys) (and-map symbol? keys))
(for-each (lambda (k)
(if (memq k seen)
(syntax-error l "eval-case condition seen twice" k)))
keys)
(if (and toplevel? (memq *the-compile-toplevel-symbol* keys))
(primitive-eval `(begin ,@body)))
(loop (append keys seen)
(cdr in)
(if (memq (if toplevel? 'load-toplevel 'evaluate) keys)
(append runtime body)
runtime)))
(else (syntax-error l "bad eval-case clause" (car in))))))))))))
;; FIXME: not hygienic, relies on @apply not being shadowed (define-scheme-translator @apply
(apply ((,proc ,arg1 . ,args)
(,args (retrans `(@apply ,@args)))) (let ((args (cons (retrans arg1) (map retrans args))))
(cond ((and (symbol? proc)
(not (ghil-var-is-bound? e proc))
(and=> (module-variable (current-module) proc)
(lambda (var)
(and (variable-bound? var)
(lookup-apply-transformer (variable-ref var))))))
;; that is, a variable, not part of this compilation
;; 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)))))))
(@apply (define-scheme-translator call-with-values
((,proc ,arg1 . ,args) ;; FIXME: not hygienic, relies on @call-with-values not being shadowed
(let ((args (cons (retrans arg1) (map retrans args)))) ((,producer ,consumer)
(cond ((and (symbol? proc) (retrans `(@call-with-values ,producer ,consumer)))
(not (ghil-var-is-bound? e proc)) (else #f))
(and=> (module-variable (current-module) proc)
(lambda (var)
(and (variable-bound? var)
(lookup-apply-transformer (variable-ref var))))))
;; that is, a variable, not part of this compilation
;; 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)))))))
;; FIXME: not hygienic, relies on @call-with-values not being shadowed (define-scheme-translator @call-with-values
(call-with-values ((,producer ,consumer)
((,producer ,consumer) (make-ghil-mv-call e l (retrans producer) (retrans consumer))))
(retrans `(@call-with-values ,producer ,consumer)))
(else #f))
(@call-with-values (define-scheme-translator call-with-current-continuation
((,producer ,consumer) ;; FIXME: not hygienic, relies on @call-with-current-continuation
(make-ghil-mv-call e l (retrans producer) (retrans consumer)))) ;; not being shadowed
((,proc)
(retrans `(@call-with-current-continuation ,proc)))
(else #f))
;; FIXME: not hygienic, relies on @call-with-current-continuation (define-scheme-translator @call-with-current-continuation
;; not being shadowed ((,proc)
(call-with-current-continuation (make-ghil-inline e l 'call/cc (list (retrans proc)))))
((,proc)
(retrans `(@call-with-current-continuation ,proc)))
(else #f))
(@call-with-current-continuation (define-scheme-translator receive
((,proc) ((,formals ,producer-exp . ,body)
(make-ghil-inline e l 'call/cc (list (retrans proc))))) ;; Lovely, self-referential usage. Not strictly necessary, the
;; macro would do the trick; but it's good to test the mv-bind
;; code.
(receive (syms rest) (parse-formals formals)
(call-with-ghil-bindings e syms
(lambda (vars)
(make-ghil-mv-bind e l (retrans `(lambda () ,producer-exp))
vars rest (trans-body e l body)))))))
(receive (define-scheme-translator values
((,formals ,producer-exp . ,body) ((,x) (retrans x))
;; Lovely, self-referential usage. Not strictly necessary, the (,args (make-ghil-values e l (map retrans args))))
;; macro would do the trick; but it's good to test the mv-bind
;; code.
(receive (syms rest) (parse-formals formals)
(call-with-ghil-bindings e syms
(lambda (vars)
(make-ghil-mv-bind e l (retrans `(lambda () ,producer-exp))
vars rest (trans-body e l body)))))))
(values (define-scheme-translator compile-time-environment
((,x) (retrans x)) ;; (compile-time-environment)
(,args (make-ghil-values e l (map retrans args)))) ;; => (MODULE LEXICALS . EXTERNALS)
(() (make-ghil-inline
;; (compile-time-environment) e l 'cons
;; => (MODULE LEXICALS . EXTERNALS) (list (retrans '(current-module))
(compile-time-environment (make-ghil-inline
(() (make-ghil-inline e l 'cons
e l 'cons (list (make-ghil-reified-env e l)
(list (retrans '(current-module)) (make-ghil-inline e l 'externals '())))))))
(make-ghil-inline
e l 'cons
(list (make-ghil-reified-env e l)
(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