summaryrefslogtreecommitdiff
path: root/module/language/scheme/compile-ghil.scm
diff options
context:
space:
mode:
authorAndy Wingo <wingo@pobox.com>2009-01-09 17:49:09 +0100
committerAndy Wingo <wingo@pobox.com>2009-01-09 17:49:09 +0100
commitca445ba5ec5babe2d160061ed627570e36a28dd1 (patch)
treec0d44488556de14ab1d8fc4b3c6e6c691ee87cc1 /module/language/scheme/compile-ghil.scm
parente3ba263de48a2a7cce27f773bd9be079eb5517db (diff)
downloadguile-ca445ba5ec5babe2d160061ed627570e36a28dd1.tar.gz
rename translate.scm to compile-ghil.scm, and more work on compiler.texi
* doc/ref/api-evaluation.texi: Fix some typos and xrefs. * doc/ref/compiler.texi (The Scheme Compiler): Document the scheme compiler, and start documenting the GHIL language. * doc/ref/guile.texi (Guile Implementation): Whoops, put autoconf after the implementation foo. Unless we want it before? * doc/ref/history.texi (The Emacs Thesis): Fix typo. * doc/ref/vm.texi (Environment Control Instructions): Rename offset to index. * module/language/ghil.scm (parse-ghil): Fix what I think was a bug -- the consumer in a mv-call shouldn't be a rest arg. * module/language/scheme/Makefile.am (SOURCES): * module/language/scheme/compile-ghil.scm: Rename this file from translate.scm. * module/oop/goops.scm: * module/language/scheme/spec.scm: Deal with renaming.
Diffstat (limited to 'module/language/scheme/compile-ghil.scm')
-rw-r--r--module/language/scheme/compile-ghil.scm514
1 files changed, 514 insertions, 0 deletions
diff --git a/module/language/scheme/compile-ghil.scm b/module/language/scheme/compile-ghil.scm
new file mode 100644
index 000000000..19ced1df2
--- /dev/null
+++ b/module/language/scheme/compile-ghil.scm
@@ -0,0 +1,514 @@
+;;; 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 compile-ghil)
+ #:use-module (system base pmatch)
+ #:use-module (system base language)
+ #:use-module (language ghil)
+ #:use-module (language scheme inline)
+ #:use-module (system vm objcode)
+ #:use-module (ice-9 receive)
+ #:use-module (ice-9 optargs)
+ #:use-module ((ice-9 syncase) #:select (sc-macro))
+ #:use-module ((system base compile) #:select (syntax-error))
+ #:export (compile-ghil translate-1
+ *translate-table* define-scheme-translator))
+
+
+;;; environment := #f
+;;; | MODULE
+;;; | COMPILE-ENV
+;;; compile-env := (MODULE LEXICALS . EXTERNALS)
+(define (cenv-module env)
+ (cond ((not env) #f)
+ ((module? env) env)
+ ((and (pair? env) (module? (car env))) (car env))
+ (else (error "bad environment" env))))
+
+(define (cenv-ghil-env env)
+ (cond ((not env) (make-ghil-toplevel-env))
+ ((module? env) (make-ghil-toplevel-env))
+ ((pair? env)
+ (ghil-env-dereify (cadr env)))
+ (else (error "bad environment" env))))
+
+(define (cenv-externals env)
+ (cond ((not env) '())
+ ((module? env) '())
+ ((pair? env) (cddr env))
+ (else (error "bad environment" env))))
+
+
+
+
+(define (compile-ghil x e opts)
+ (save-module-excursion
+ (lambda ()
+ (and=> (cenv-module e) set-current-module)
+ (call-with-ghil-environment (cenv-ghil-env e) '()
+ (lambda (env vars)
+ (values (make-ghil-lambda env #f vars #f '() (translate-1 env #f x))
+ (and e
+ (cons* (cenv-module e)
+ (ghil-env-parent env)
+ (cenv-externals e)))))))))
+
+
+;;;
+;;; 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))
+
+;; Looks up transformers relative to the current module at
+;; compilation-time. See also the discussion of ghil-lookup in ghil.scm.
+;;
+;; FIXME shadowing lexicals?
+(define (lookup-transformer head retrans)
+ (let* ((mod (current-module))
+ (val (and (symbol? head)
+ (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
+ ((hashq-ref *translate-table* val))
+
+ ((defmacro? val)
+ (lambda (env loc exp)
+ (retrans (apply (defmacro-transformer val) (cdr exp)))))
+
+ ((eq? 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)))))))
+
+ ((primitive-macro? val)
+ (syntax-error #f "unhandled primitive macro" head))
+
+ ((macro? val)
+ (syntax-error #f "unknown kind of macro" head))
+
+ (else #f))))
+
+(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
+ ((lookup-transformer 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 (and (symbol? head)
+ (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-var-for-ref! 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 *translate-table* (make-hash-table))
+
+(define-macro (define-scheme-translator sym . clauses)
+ `(hashq-set! (@ (language scheme compile-ghil) *translate-table*)
+ ,sym
+ (lambda (e l exp)
+ (define (retrans x)
+ ((@ (language scheme compile-ghil) translate-1) e #f x))
+ (define syntax-error (@ (system base compile) syntax-error))
+ (pmatch (cdr exp)
+ ,@clauses
+ (else
+ (syntax-error l (format #f "bad ~A" ',sym) exp))))))
+
+(define-scheme-translator quote
+ ;; (quote OBJ)
+ ((,obj) (make-ghil-quote e l #:obj obj)))
+
+(define-scheme-translator quasiquote
+ ;; (quasiquote OBJ)
+ ((,obj) (make-ghil-quasiquote e l #:exp (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 (NAME FORMALS...) BODY...)
+ (((,name . ,formals) . ,body) (guard (symbol? name))
+ ;; -> (define NAME (lambda FORMALS BODY...))
+ (retrans `(define ,name (lambda ,formals ,@body)))))
+
+(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)))
+
+ ;; FIXME: Would be nice to verify the values of @ and @@ relative
+ ;; to imported modules...
+ (((@ ,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 #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! (NAME ARGS...) VAL)
+ (((,name . ,args) ,val) (guard (symbol? name))
+ ;; -> ((setter NAME) ARGS... VAL)
+ (retrans `((setter ,name) . (,@args ,val)))))
+
+(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))))
+
+(define-scheme-translator and
+ ;; (and EXPS...)
+ (,tail (make-ghil-and e l (map retrans tail))))
+
+(define-scheme-translator or
+ ;; (or EXPS...)
+ (,tail (make-ghil-or e l (map retrans tail))))
+
+(define-scheme-translator begin
+ ;; (begin EXPS...)
+ (,tail (make-ghil-begin e l (map retrans tail))))
+
+(define-scheme-translator 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)))))))
+
+(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)))))
+
+(define-scheme-translator 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)))))))
+
+(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
+ ;; FIXME hygiene!
+ `(letrec ((_l (lambda ,sym
+ (if ,test
+ (begin ,@result)
+ (begin ,@body
+ (_l ,@(map next sym update)))))))
+ (_l ,@val))))))
+
+(define-scheme-translator lambda
+ ;; (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))))))))
+
+(define-scheme-translator delay
+ ;; FIXME not hygienic
+ ((,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))))
+
+(define *the-compile-toplevel-symbol* 'compile-toplevel)
+(define-scheme-translator eval-case
+ (,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))))))))))))
+
+(define-scheme-translator apply
+ ;; FIXME: not hygienic, relies on @apply not being shadowed
+ (,args (retrans `(@apply ,@args))))
+
+(define-scheme-translator @apply
+ ((,proc ,arg1 . ,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)))))))
+
+(define-scheme-translator call-with-values
+ ;; FIXME: not hygienic, relies on @call-with-values not being shadowed
+ ((,producer ,consumer)
+ (retrans `(@call-with-values ,producer ,consumer)))
+ (else #f))
+
+(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
+ ((,proc)
+ (retrans `(@call-with-current-continuation ,proc)))
+ (else #f))
+
+(define-scheme-translator @call-with-current-continuation
+ ((,proc)
+ (make-ghil-inline e l 'call/cc (list (retrans proc)))))
+
+(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
+ ;; code.
+ (receive (syms rest) (parse-formals formals)
+ (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))))))))
+
+(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)
+ (() (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 '())))))))
+
+(define (lookup-apply-transformer proc)
+ (cond ((eq? proc values)
+ (lambda (e l args)
+ (make-ghil-values* e l args)))
+ (else #f)))
+
+(define (trans-quasiquote e l x level)
+ (cond ((not (pair? x)) x)
+ ((memq (car x) '(unquote unquote-splicing))
+ (let ((l (location x)))
+ (pmatch (cdr x)
+ ((,obj)
+ (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))))
+ (else
+ (list (car x) (trans-quasiquote e l obj (1- level))))))
+ (else (syntax-error l (format #f "bad ~A" (car x)) x)))))
+ ((eq? (car x) 'quasiquote)
+ (let ((l (location x)))
+ (pmatch (cdr x)
+ ((,obj) (list 'quasiquote (trans-quasiquote e l obj (1+ level))))
+ (else (syntax-error l (format #f "bad ~A" (car x)) x)))))
+ (else (cons (trans-quasiquote e l (car x) level)
+ (trans-quasiquote e l (cdr x) level)))))
+
+(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)
+ (translate-1 e l `(begin ,@ls))
+ (translate-1 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 (parse-lambda-meta body)
+ (cond ((or (null? body) (null? (cdr body))) (values '() body))
+ ((string? (car body))
+ (values `((documentation . ,(car body))) (cdr body)))
+ (else (values '() body))))
+
+(define (maybe-name-value! val name)
+ (cond
+ ((ghil-lambda? val)
+ (if (not (assq-ref (ghil-lambda-meta val) 'name))
+ (set! (ghil-lambda-meta val)
+ (acons 'name name (ghil-lambda-meta val))))))
+ val)
+
+(define (location x)
+ (and (pair? x)
+ (let ((props (source-properties x)))
+ (and (not (null? props))
+ (vector (assq-ref props 'line)
+ (assq-ref props 'column)
+ (assq-ref props 'filename))))))