diff options
Diffstat (limited to 'module/language/scheme/translate.scm')
| -rw-r--r-- | module/language/scheme/translate.scm | 341 |
1 files changed, 341 insertions, 0 deletions
diff --git a/module/language/scheme/translate.scm b/module/language/scheme/translate.scm new file mode 100644 index 000000000..40ce46675 --- /dev/null +++ b/module/language/scheme/translate.scm @@ -0,0 +1,341 @@ +;;; Guile Scheme specification + +;; Copyright (C) 2001 Free Software Foundation, Inc. + +;; This program is free software; you can redistribute it and/or modify +;; it under the terms of the GNU General Public License as published by +;; the Free Software Foundation; either version 2, or (at your option) +;; any later version. +;; +;; This program is distributed in the hope that it will be useful, +;; but WITHOUT ANY WARRANTY; without even the implied warranty of +;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +;; GNU General Public License for more details. +;; +;; You should have received a copy of the GNU General Public License +;; along with this program; see the file COPYING. If not, write to +;; the Free Software Foundation, Inc., 59 Temple Place - Suite 330, +;; Boston, MA 02111-1307, USA. + +;;; Code: + +(define-module (language scheme translate) + :use-module (system base pmatch) + :use-module (system base language) + :use-module (system il ghil) + :use-module (system il inline) + :use-module (ice-9 receive) + :use-module (srfi srfi-39) + :use-module ((system base compile) :select (syntax-error)) + :export (translate)) + + +(define (translate x e) + (call-with-ghil-environment (make-ghil-mod e) '() + (lambda (env vars) + (make-ghil-lambda env #f vars #f (trans env #f x))))) + + +;;; +;;; Translator +;;; + +(define %forbidden-primitives + ;; Guile's `procedure->macro' family is evil because it crosses the + ;; compilation boundary. One solution might be to evaluate calls to + ;; `procedure->memoizing-macro' at compilation time, but it may be more + ;; compicated than that. + '(procedure->syntax procedure->macro procedure->memoizing-macro)) + +(define (lookup-transformer e head retrans) + (let* ((mod (ghil-mod-module (ghil-env-mod e))) + (val (and=> (module-variable mod head) + (lambda (var) + ;; unbound vars can happen if the module + ;; definition forward-declared them + (and (variable-bound? var) (variable-ref var)))))) + (cond + ((or (primitive-macro? val) (eq? val eval-case)) + (or (assq-ref primitive-syntax-table head) + (syntax-error #f "unhandled primitive macro" head))) + + ((defmacro? val) + (lambda (env loc exp) + (retrans (apply (defmacro-transformer val) (cdr exp))))) + + ((and (macro? val) (eq? (macro-name val) 'sc-macro)) + ;; syncase! + (let* ((the-syncase-module (resolve-module '(ice-9 syncase))) + (eec (module-ref the-syncase-module 'expansion-eval-closure)) + (sc-expand3 (module-ref the-syncase-module 'sc-expand3))) + (lambda (env loc exp) + (retrans + (with-fluids ((eec (module-eval-closure mod))) + (sc-expand3 exp 'c '(compile load eval))))))) + + ((macro? val) + (syntax-error #f "unknown kind of macro" head)) + + (else #f)))) + +(define (trans e l x) + (define (retrans x) (trans e l x)) + (cond ((pair? x) + (let ((head (car x)) (tail (cdr x))) + (cond + ((lookup-transformer e head retrans) + => (lambda (t) (t e l x))) + + ;; FIXME: lexical/module overrides of forbidden primitives + ((memq head %forbidden-primitives) + (syntax-error l (format #f "`~a' is forbidden" head) + (cons head tail))) + + (else + (let ((tail (map retrans tail))) + (or (try-inline-with-env e l (cons head tail)) + (make-ghil-call e l (retrans head) tail))))))) + + ((symbol? x) + (make-ghil-ref e l (ghil-lookup e x))) + + ;; fixme: non-self-quoting objects like #<foo> + (else + (make-ghil-quote e l #:obj x)))) + +(define (valid-bindings? bindings . it-is-for-do) + (define (valid-binding? b) + (pmatch b + ((,sym ,var) (guard (symbol? sym)) #t) + ((,sym ,var ,update) (guard (pair? it-is-for-do) (symbol? sym)) #t) + (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 ,loc 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 primitive-syntax-table + (make-pmatch-transformers + e l retrans + (quote + ;; (quote OBJ) + ((,obj) (make-ghil-quote e l obj))) + + (quasiquote + ;; (quasiquote OBJ) + ((,obj) (make-ghil-quasiquote e l (trans-quasiquote e l obj)))) + + (define + ;; (define NAME VAL) + ((,name ,val) (guard (symbol? name) (ghil-env-toplevel? e)) + (make-ghil-define e l (ghil-define (ghil-env-parent e) name) + (retrans val))) + ;; (define (NAME FORMALS...) BODY...) + (((,name . ,formals) . ,body) (guard (symbol? name)) + ;; -> (define NAME (lambda FORMALS BODY...)) + (retrans `(define ,name (lambda ,formals ,@body))))) + + (set! + ;; (set! NAME VAL) + ((,name ,val) (guard (symbol? name)) + (make-ghil-set e l (ghil-lookup e name) (retrans val))) + + ;; (set! (NAME ARGS...) VAL) + (((,name . ,args) ,val) (guard (symbol? name)) + ;; -> ((setter NAME) ARGS... VAL) + (retrans `((setter ,name) . (,@args ,val))))) + + (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 + ;; (and EXPS...) + (,tail (make-ghil-and e l (map retrans tail)))) + + (or + ;; (or EXPS...) + (,tail (make-ghil-or e l (map retrans tail)))) + + (begin + ;; (begin EXPS...) + (,tail (make-ghil-begin e l (map retrans tail)))) + + (let + ;; (let NAME ((SYM VAL) ...) BODY...) + ((,name ,bindings . ,body) (guard (symbol? name) + (valid-bindings? bindings)) + ;; -> (letrec ((NAME (lambda (SYM...) BODY...))) (NAME VAL...)) + (retrans `(letrec ((,name (lambda ,(map car bindings) ,@body))) + (,name ,@(map cadr bindings))))) + + ;; (let () BODY...) + ((() . ,body) + ;; Note: this differs from `begin' + (make-ghil-begin e l (list (trans-body e l body)))) + + ;; (let ((SYM VAL) ...) BODY...) + ((,bindings . ,body) (guard (valid-bindings? 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) + (lambda (vars) + (let ((vals (map retrans (map cadr bindings)))) + (make-ghil-bind e l vars vals (trans-body e l body))))))) + + (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))))) + + (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)))))))))) + + (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 + ;; FIXME hygiene! + `(letrec ((_l (lambda ,sym + (if ,test + (begin ,@result) + (begin ,@body + (_l ,@(map next sym update))))))) + (_l ,@val)))))) + + (lambda + ;; (lambda FORMALS BODY...) + ((,formals . ,body) + (receive (syms rest) (parse-formals formals) + (call-with-ghil-environment e syms + (lambda (env vars) + (make-ghil-lambda env l vars rest (trans-body env l body))))))) + + (eval-case + (,clauses + (retrans + `(begin + ,@(let ((toplevel? (ghil-env-toplevel? 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)))))))))))))) + +(define (trans-quasiquote e l x) + (cond ((not (pair? x)) x) + ((memq (car x) '(unquote unquote-splicing)) + (let ((l (location x))) + (pmatch (cdr x) + ((,obj) + (if (eq? (car x) 'unquote) + (make-ghil-unquote e l (trans e l obj)) + (make-ghil-unquote-splicing e l (trans e l obj)))) + (else (syntax-error l (format #f "bad ~A" (car x)) x))))) + (else (cons (trans-quasiquote e l (car x)) + (trans-quasiquote e l (cdr x)))))) + +(define (trans-body e l body) + (define (define->binding df) + (pmatch (cdr df) + ((,name ,val) (guard (symbol? name)) (list name val)) + (((,name . ,formals) . ,body) (guard (symbol? name)) + (list name `(lambda ,formals ,@body))) + (else (syntax-error (location df) "bad define" df)))) + ;; main + (let loop ((ls body) (ds '())) + (pmatch ls + (() (syntax-error l "bad body" body)) + (((define . _) . _) + (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))))))) + +(define (parse-formals formals) + (cond + ;; (lambda x ...) + ((symbol? formals) (values (list formals) #t)) + ;; (lambda (x y z) ...) + ((list? formals) (values formals #f)) + ;; (lambda (x y . z) ...) + ((pair? formals) + (let loop ((l formals) (v '())) + (if (pair? l) + (loop (cdr l) (cons (car l) v)) + (values (reverse! (cons l v)) #t)))) + (else (syntax-error (location formals) "bad formals" formals)))) + +(define (location x) + (and (pair? x) + (let ((props (source-properties x))) + (and (not (null? props)) + (cons (assq-ref props 'line) (assq-ref props 'column)))))) |