mirror of
https://git.savannah.gnu.org/git/guile.git
synced 2025-05-19 19:20:23 +02:00
rework the scheme translator so it's extensible by external modules
* 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
parent
4631414e29
commit
fd4da4fae6
1 changed files with 270 additions and 272 deletions
|
|
@ -27,13 +27,14 @@
|
|||
#:use-module (ice-9 receive)
|
||||
#:use-module ((ice-9 syncase) #:select (sc-macro))
|
||||
#:use-module ((system base compile) #:select (syntax-error))
|
||||
#:export (translate))
|
||||
#:export (translate translate-1
|
||||
*translate-table* define-scheme-translator))
|
||||
|
||||
|
||||
(define (translate x e)
|
||||
(call-with-ghil-environment e '()
|
||||
(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
|
||||
(and (variable-bound? var) (variable-ref var)))))))
|
||||
(cond
|
||||
((assq-ref custom-transformer-table val))
|
||||
((hashq-ref *translate-table* val))
|
||||
|
||||
((defmacro? val)
|
||||
(lambda (env loc exp)
|
||||
|
|
@ -82,8 +83,9 @@
|
|||
|
||||
(else #f))))
|
||||
|
||||
(define (trans e l x)
|
||||
(define (retrans x) (trans e (location x) x))
|
||||
(define (translate-1 e l x)
|
||||
(let ((l (or l (location x))))
|
||||
(define (retrans x) (translate-1 e #f x))
|
||||
(cond ((pair? x)
|
||||
(let ((head (car x)) (tail (cdr x)))
|
||||
(cond
|
||||
|
|
@ -106,7 +108,7 @@
|
|||
|
||||
;; fixme: non-self-quoting objects like #<foo>
|
||||
(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-binding? b)
|
||||
|
|
@ -116,33 +118,29 @@
|
|||
(else #f)))
|
||||
(and (list? bindings) (and-map valid-binding? bindings)))
|
||||
|
||||
(define-macro (make-pmatch-transformers env loc retranslate . body)
|
||||
(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)
|
||||
(define *translate-table* (make-hash-table))
|
||||
|
||||
(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)))))))
|
||||
`(list ,@(map make1 body)))
|
||||
(else
|
||||
(syntax-error loc (format #f "bad ~A" ',sym exp)))))))
|
||||
|
||||
(define *the-compile-toplevel-symbol* 'compile-toplevel)
|
||||
|
||||
(define custom-transformer-table
|
||||
(make-pmatch-transformers
|
||||
e l retrans
|
||||
(quote
|
||||
(define-scheme-translator quote
|
||||
;; (quote OBJ)
|
||||
((,obj) (make-ghil-quote e l obj)))
|
||||
|
||||
(quasiquote
|
||||
(define-scheme-translator quasiquote
|
||||
;; (quasiquote OBJ)
|
||||
((,obj) (make-ghil-quasiquote e l (trans-quasiquote e l obj 0))))
|
||||
|
||||
(define
|
||||
(define-scheme-translator define
|
||||
;; (define NAME VAL)
|
||||
((,name ,val) (guard (symbol? name)
|
||||
(ghil-toplevel-env? (ghil-env-parent e)))
|
||||
|
|
@ -153,7 +151,7 @@
|
|||
;; -> (define NAME (lambda FORMALS BODY...))
|
||||
(retrans `(define ,name (lambda ,formals ,@body)))))
|
||||
|
||||
(set!
|
||||
(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)))
|
||||
|
|
@ -179,26 +177,26 @@
|
|||
;; -> ((setter NAME) ARGS... VAL)
|
||||
(retrans `((setter ,name) . (,@args ,val)))))
|
||||
|
||||
(if
|
||||
(define-scheme-translator if
|
||||
;; (if TEST THEN [ELSE])
|
||||
((,test ,then)
|
||||
(make-ghil-if e l (retrans test) (retrans then) (retrans '(begin))))
|
||||
((,test ,then ,else)
|
||||
(make-ghil-if e l (retrans test) (retrans then) (retrans else))))
|
||||
|
||||
(and
|
||||
(define-scheme-translator and
|
||||
;; (and EXPS...)
|
||||
(,tail (make-ghil-and e l (map retrans tail))))
|
||||
|
||||
(or
|
||||
(define-scheme-translator or
|
||||
;; (or EXPS...)
|
||||
(,tail (make-ghil-or e l (map retrans tail))))
|
||||
|
||||
(begin
|
||||
(define-scheme-translator begin
|
||||
;; (begin EXPS...)
|
||||
(,tail (make-ghil-begin e l (map retrans tail))))
|
||||
|
||||
(let
|
||||
(define-scheme-translator let
|
||||
;; (let NAME ((SYM VAL) ...) BODY...)
|
||||
((,name ,bindings . ,body) (guard (symbol? name)
|
||||
(valid-bindings? bindings))
|
||||
|
|
@ -218,14 +216,14 @@
|
|||
(lambda (vars)
|
||||
(make-ghil-bind e l vars vals (trans-body e l body)))))))
|
||||
|
||||
(let*
|
||||
(define-scheme-translator let*
|
||||
;; (let* ((SYM VAL) ...) BODY...)
|
||||
((() . ,body)
|
||||
(retrans `(let () ,@body)))
|
||||
((((,sym ,val) . ,rest) . ,body) (guard (symbol? sym))
|
||||
(retrans `(let ((,sym ,val)) (let* ,rest ,@body)))))
|
||||
|
||||
(letrec
|
||||
(define-scheme-translator letrec
|
||||
;; (letrec ((SYM VAL) ...) BODY...)
|
||||
((,bindings . ,body) (guard (valid-bindings? bindings))
|
||||
(call-with-ghil-bindings e (map car bindings)
|
||||
|
|
@ -233,7 +231,7 @@
|
|||
(let ((vals (map retrans (map cadr bindings))))
|
||||
(make-ghil-bind e l vars vals (trans-body e l body)))))))
|
||||
|
||||
(cond
|
||||
(define-scheme-translator cond
|
||||
;; (cond (CLAUSE BODY...) ...)
|
||||
(() (retrans '(begin)))
|
||||
(((else . ,body)) (retrans `(begin ,@body)))
|
||||
|
|
@ -244,7 +242,7 @@
|
|||
(((,test . ,body) . ,rest)
|
||||
(retrans `(if ,test (begin ,@body) (cond ,@rest)))))
|
||||
|
||||
(case
|
||||
(define-scheme-translator case
|
||||
;; (case EXP ((KEY...) BODY...) ...)
|
||||
((,exp . ,clauses)
|
||||
(retrans
|
||||
|
|
@ -257,7 +255,7 @@
|
|||
(begin ,@(cdar ls))
|
||||
,(loop (cdr ls))))))))))
|
||||
|
||||
(do
|
||||
(define-scheme-translator do
|
||||
;; (do ((SYM VAL [UPDATE]) ...) (TEST RESULT...) BODY...)
|
||||
((,bindings (,test . ,result) . ,body)
|
||||
(let ((sym (map car bindings))
|
||||
|
|
@ -273,7 +271,7 @@
|
|||
(_l ,@(map next sym update)))))))
|
||||
(_l ,@val))))))
|
||||
|
||||
(lambda
|
||||
(define-scheme-translator lambda
|
||||
;; (lambda FORMALS BODY...)
|
||||
((,formals . ,body)
|
||||
(receive (syms rest) (parse-formals formals)
|
||||
|
|
@ -283,20 +281,21 @@
|
|||
(make-ghil-lambda env l vars rest meta
|
||||
(trans-body env l body))))))))
|
||||
|
||||
(define-scheme-translator delay
|
||||
;; FIXME not hygienic
|
||||
(delay
|
||||
((,expr)
|
||||
(retrans `(make-promise (lambda () ,expr)))))
|
||||
|
||||
(@
|
||||
(define-scheme-translator @
|
||||
((,modname ,sym)
|
||||
(make-ghil-ref e l (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))))
|
||||
|
||||
(eval-case
|
||||
(define *the-compile-toplevel-symbol* 'compile-toplevel)
|
||||
(define-scheme-translator eval-case
|
||||
(,clauses
|
||||
(retrans
|
||||
`(begin
|
||||
|
|
@ -327,11 +326,11 @@
|
|||
runtime)))
|
||||
(else (syntax-error l "bad eval-case clause" (car in))))))))))))
|
||||
|
||||
(define-scheme-translator apply
|
||||
;; FIXME: not hygienic, relies on @apply not being shadowed
|
||||
(apply
|
||||
(,args (retrans `(@apply ,@args))))
|
||||
|
||||
(@apply
|
||||
(define-scheme-translator @apply
|
||||
((,proc ,arg1 . ,args)
|
||||
(let ((args (cons (retrans arg1) (map retrans args))))
|
||||
(cond ((and (symbol? proc)
|
||||
|
|
@ -347,28 +346,28 @@
|
|||
(else (make-ghil-inline e l 'apply
|
||||
(cons (retrans proc) args)))))))
|
||||
|
||||
(define-scheme-translator call-with-values
|
||||
;; FIXME: not hygienic, relies on @call-with-values not being shadowed
|
||||
(call-with-values
|
||||
((,producer ,consumer)
|
||||
(retrans `(@call-with-values ,producer ,consumer)))
|
||||
(else #f))
|
||||
|
||||
(@call-with-values
|
||||
(define-scheme-translator @call-with-values
|
||||
((,producer ,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
|
||||
;; not being shadowed
|
||||
(call-with-current-continuation
|
||||
((,proc)
|
||||
(retrans `(@call-with-current-continuation ,proc)))
|
||||
(else #f))
|
||||
|
||||
(@call-with-current-continuation
|
||||
(define-scheme-translator @call-with-current-continuation
|
||||
((,proc)
|
||||
(make-ghil-inline e l 'call/cc (list (retrans proc)))))
|
||||
|
||||
(receive
|
||||
(define-scheme-translator receive
|
||||
((,formals ,producer-exp . ,body)
|
||||
;; Lovely, self-referential usage. Not strictly necessary, the
|
||||
;; 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))
|
||||
vars rest (trans-body e l body)))))))
|
||||
|
||||
(values
|
||||
(define-scheme-translator values
|
||||
((,x) (retrans x))
|
||||
(,args (make-ghil-values e l (map retrans args))))
|
||||
|
||||
(define-scheme-translator compile-time-environment
|
||||
;; (compile-time-environment)
|
||||
;; => (MODULE LEXICALS . EXTERNALS)
|
||||
(compile-time-environment
|
||||
(() (make-ghil-inline
|
||||
e l 'cons
|
||||
(list (retrans '(current-module))
|
||||
|
|
@ -393,7 +392,6 @@
|
|||
e l 'cons
|
||||
(list (make-ghil-reified-env e l)
|
||||
(make-ghil-inline e l 'externals '())))))))
|
||||
))
|
||||
|
||||
(define (lookup-apply-transformer proc)
|
||||
(cond ((eq? proc values)
|
||||
|
|
@ -410,8 +408,8 @@
|
|||
(cond
|
||||
((zero? level)
|
||||
(if (eq? (car x) 'unquote)
|
||||
(make-ghil-unquote e l (trans e l obj))
|
||||
(make-ghil-unquote-splicing e l (trans e l obj))))
|
||||
(make-ghil-unquote e l (translate-1 e l obj))
|
||||
(make-ghil-unquote-splicing e l (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)))))
|
||||
|
|
@ -438,8 +436,8 @@
|
|||
(loop (cdr ls) (cons (car ls) ds)))
|
||||
(else
|
||||
(if (null? ds)
|
||||
(trans e l `(begin ,@ls))
|
||||
(trans e l `(letrec ,(map define->binding ds) ,@ls)))))))
|
||||
(translate-1 e l `(begin ,@ls))
|
||||
(translate-1 e l `(letrec ,(map define->binding ds) ,@ls)))))))
|
||||
|
||||
(define (parse-formals formals)
|
||||
(cond
|
||||
|
|
|
|||
Loading…
Add table
Add a link
Reference in a new issue