summaryrefslogtreecommitdiff
path: root/module/language/scheme
diff options
context:
space:
mode:
authorAndy Wingo <wingo@pobox.com>2009-05-29 16:01:43 +0200
committerAndy Wingo <wingo@pobox.com>2009-05-29 16:01:43 +0200
commit938d46a35d39ec5d7b5fa858a8783136ce24d10d (patch)
tree17153f062515c4ae74815f65c4aa1f30a92e1ce4 /module/language/scheme
parent1ee2c72eafaae5f91f4c899bc4b4853af5c16f28 (diff)
parente3c5df539640a36eb1493f581087d54a4714f337 (diff)
downloadguile-938d46a35d39ec5d7b5fa858a8783136ce24d10d.tar.gz
Merge branch 'syncase-in-boot-9'
Conflicts: module/Makefile.am
Diffstat (limited to 'module/language/scheme')
-rw-r--r--module/language/scheme/amatch.scm37
-rw-r--r--module/language/scheme/compile-ghil.scm48
-rw-r--r--module/language/scheme/compile-tree-il.scm64
-rw-r--r--module/language/scheme/decompile-tree-il.scm27
-rw-r--r--module/language/scheme/expand.scm307
-rw-r--r--module/language/scheme/spec.scm13
6 files changed, 106 insertions, 390 deletions
diff --git a/module/language/scheme/amatch.scm b/module/language/scheme/amatch.scm
deleted file mode 100644
index 4ac973620..000000000
--- a/module/language/scheme/amatch.scm
+++ /dev/null
@@ -1,37 +0,0 @@
-(define-module (language scheme amatch)
- #:use-module (ice-9 syncase)
- #:export (amatch apat))
-;; FIXME: shouldn't have to export apat...
-
-;; This is exactly the same as pmatch except that it unpacks annotations
-;; as needed.
-
-(define-syntax amatch
- (syntax-rules (else guard)
- ((_ (op arg ...) cs ...)
- (let ((v (op arg ...)))
- (amatch v cs ...)))
- ((_ v) (if #f #f))
- ((_ v (else e0 e ...)) (begin e0 e ...))
- ((_ v (pat (guard g ...) e0 e ...) cs ...)
- (let ((fk (lambda () (amatch v cs ...))))
- (apat v pat
- (if (and g ...) (begin e0 e ...) (fk))
- (fk))))
- ((_ v (pat e0 e ...) cs ...)
- (let ((fk (lambda () (amatch v cs ...))))
- (apat v pat (begin e0 e ...) (fk))))))
-
-(define-syntax apat
- (syntax-rules (_ quote unquote)
- ((_ v _ kt kf) kt)
- ((_ v () kt kf) (if (null? v) kt kf))
- ((_ v (quote lit) kt kf)
- (if (equal? v (quote lit)) kt kf))
- ((_ v (unquote var) kt kf) (let ((var v)) kt))
- ((_ v (x . y) kt kf)
- (if (apair? v)
- (let ((vx (acar v)) (vy (acdr v)))
- (apat vx x (apat vy y kt kf) kf))
- kf))
- ((_ v lit kt kf) (if (eq? v (quote lit)) kt kf))))
diff --git a/module/language/scheme/compile-ghil.scm b/module/language/scheme/compile-ghil.scm
index 86234059e..8d8332c34 100644
--- a/module/language/scheme/compile-ghil.scm
+++ b/module/language/scheme/compile-ghil.scm
@@ -27,13 +27,11 @@
#:use-module (system vm objcode)
#:use-module (ice-9 receive)
#:use-module (ice-9 optargs)
- #:use-module (ice-9 expand-support)
- #:use-module ((ice-9 syncase) #:select (sc-macro))
+ #:use-module (language tree-il)
#:use-module ((system base compile) #:select (syntax-error))
#:export (compile-ghil translate-1
*translate-table* define-scheme-translator))
-
;;; environment := #f
;;; | MODULE
;;; | COMPILE-ENV
@@ -70,12 +68,14 @@
(and=> (cenv-module e) set-current-module)
(call-with-ghil-environment (cenv-ghil-env e) '()
(lambda (env vars)
- (let ((x (make-ghil-lambda env #f vars #f '()
- (translate-1 env #f x)))
- (cenv (make-cenv (current-module)
- (ghil-env-parent env)
- (if e (cenv-externals e) '()))))
- (values x cenv cenv)))))))
+ (let ((x (tree-il->scheme
+ (sc-expand x 'c '(compile load eval)))))
+ (let ((x (make-ghil-lambda env #f vars #f '()
+ (translate-1 env #f x)))
+ (cenv (make-cenv (current-module)
+ (ghil-env-parent env)
+ (if e (cenv-externals e) '()))))
+ (values x cenv cenv))))))))
;;;
@@ -104,9 +104,6 @@
(let* ((mod (current-module))
(val (cond
((symbol? head) (module-ref/safe mod head))
- ;; allow macros to be unquoted into the output of a macro
- ;; expansion
- ((macro? head) head)
((pmatch head
((@ ,modname ,sym)
(module-ref/safe (resolve-interface modname) sym))
@@ -117,21 +114,6 @@
(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 ((sc-expand3 (@@ (ice-9 syncase) sc-expand3)))
- (lambda (env loc exp)
- (retrans
- (strip-expansion-structures
- (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))
@@ -180,7 +162,7 @@
(define-macro (define-scheme-translator sym . clauses)
`(hashq-set! (@ (language scheme compile-ghil) *translate-table*)
- ,sym
+ (module-ref (current-module) ',sym)
(lambda (e l exp)
(define (retrans x)
((@ (language scheme compile-ghil) translate-1)
@@ -432,16 +414,6 @@
(,args
(-> (values (map retrans args)))))
-(define-scheme-translator compile-time-environment
- ;; (compile-time-environment)
- ;; => (MODULE LEXICALS . EXTERNALS)
- (()
- (-> (inline 'cons
- (list (retrans '(current-module))
- (-> (inline 'cons
- (list (-> (reified-env))
- (-> (inline 'externals '()))))))))))
-
(define (lookup-apply-transformer proc)
(cond ((eq? proc values)
(lambda (e l args)
diff --git a/module/language/scheme/compile-tree-il.scm b/module/language/scheme/compile-tree-il.scm
new file mode 100644
index 000000000..4635abc8a
--- /dev/null
+++ b/module/language/scheme/compile-tree-il.scm
@@ -0,0 +1,64 @@
+;;; 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-tree-il)
+ #:use-module (language tree-il)
+ #:export (compile-tree-il))
+
+;;; 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-lexicals env)
+ (cond ((not env) '())
+ ((module? env) '())
+ ((pair? env) (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 (make-cenv module lexicals externals)
+ (cons module (cons lexicals externals)))
+
+(define (location x)
+ (and (pair? x)
+ (let ((props (source-properties x)))
+ (and (not (null? props))
+ props))))
+
+(define (compile-tree-il x e opts)
+ (save-module-excursion
+ (lambda ()
+ (and=> (cenv-module e) set-current-module)
+ (let* ((x (sc-expand x 'c '(compile load eval)))
+ (cenv (make-cenv (current-module)
+ (cenv-lexicals e) (cenv-externals e))))
+ (values x cenv cenv)))))
diff --git a/module/language/scheme/decompile-tree-il.scm b/module/language/scheme/decompile-tree-il.scm
new file mode 100644
index 000000000..c4903d87f
--- /dev/null
+++ b/module/language/scheme/decompile-tree-il.scm
@@ -0,0 +1,27 @@
+;;; Guile VM code converters
+
+;; Copyright (C) 2001,2009 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 decompile-tree-il)
+ #:use-module (language tree-il)
+ #:export (decompile-tree-il))
+
+(define (decompile-tree-il x env opts)
+ (values (tree-il->scheme x) env))
diff --git a/module/language/scheme/expand.scm b/module/language/scheme/expand.scm
deleted file mode 100644
index 2ffefb318..000000000
--- a/module/language/scheme/expand.scm
+++ /dev/null
@@ -1,307 +0,0 @@
-;;; 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 expand)
- #:use-module (language scheme amatch)
- #:use-module (ice-9 expand-support)
- #:use-module (ice-9 optargs)
- #:use-module ((ice-9 syncase) #:select (sc-macro))
- #:use-module ((system base compile) #:select (syntax-error))
- #:export (expand *expand-table* define-scheme-expander))
-
-(define (aref x) (if (annotation? x) (annotation-expression x) x))
-(define (apair? x) (pair? (aref x)))
-(define (acar x) (car (aref x)))
-(define (acdr x) (cdr (aref x)))
-(define (acaar x) (acar (acar x)))
-(define (acdar x) (acdr (acar x)))
-(define (acadr x) (acar (acdr x)))
-(define (acddr x) (acdr (acdr x)))
-(define (aloc x) (and (annotation? x) (annotation-source x)))
-(define (re-annotate x y)
- (if (and (annotation? x) (not (annotation? y)))
- (make-annotation y (annotation-source x))
- y))
-(define-macro (-> exp) `(re-annotate x ,exp))
-
-(define* (expand x #:optional (mod (current-module)) (once? #f))
- (define re-expand
- (if once?
- (lambda (x) x)
- (lambda (x) (expand x mod once?))))
- (let ((exp (if (annotation? x) (annotation-expression x) x)))
- (cond
- ((pair? exp)
- (let ((head (car exp)) (tail (cdr exp)))
- (cond
- ;; allow macros to be unquoted into the output of a macro
- ;; expansion
- ((or (symbol? head) (macro? head))
- (let ((val (cond
- ((macro? head) head)
- ((module-variable mod head)
- => (lambda (var)
- ;; unbound vars can happen if the module
- ;; definition forward-declared them
- (and (variable-bound? var) (variable-ref var))))
- (else #f))))
- (cond
- ((hashq-ref *expand-table* val)
- => (lambda (expand1) (expand1 x re-expand)))
-
- ((defmacro? val)
- (re-expand (-> (apply (defmacro-transformer val)
- (deannotate tail)))))
-
- ((eq? val sc-macro)
- ;; syncase!
- (let* ((eec (@@ (ice-9 syncase) expansion-eval-closure))
- (sc-expand3 (@@ (ice-9 syncase) sc-expand3)))
- (re-expand
- (with-fluids ((eec (module-eval-closure mod)))
- ;; fixme -- use ewes fluid?
- (sc-expand3 exp 'c '(compile load eval))))))
-
- ((primitive-macro? val)
- (syntax-error (aloc x) "unhandled primitive macro" head))
-
- ((macro? val)
- (syntax-error (aloc x) "unknown kind of macro" head))
-
- (else
- (-> (cons head (map re-expand tail)))))))
-
- (else
- (-> (map re-expand exp))))))
-
- (else x))))
-
-
-(define *expand-table* (make-hash-table))
-
-(define-macro (define-scheme-expander sym . clauses)
- `(hashq-set! (@ (language scheme expand) *expand-table*)
- ,sym
- (lambda (x re-expand)
- (define syntax-error (@ (system base compile) syntax-error))
- (amatch (acdr x)
- ,@clauses
- ,@(if (assq 'else clauses) '()
- `((else
- (syntax-error (aloc x) (format #f "bad ~A" ',sym) x))))))))
-
-(define-scheme-expander quote
- ;; (quote OBJ)
- ((,obj) x))
-
-(define-scheme-expander quasiquote
- ;; (quasiquote OBJ)
- ((,obj)
- (-> `(,'quasiquote
- ,(let lp ((x obj) (level 0))
- (cond ((not (apair? x)) x)
- ;; FIXME: hygiene regarding imported , / ,@ rebinding
- ((memq (acar x) '(unquote unquote-splicing))
- (amatch (acdr x)
- ((,obj)
- (cond
- ((zero? level)
- (-> `(,(acar x) ,(re-expand obj))))
- (else
- (-> `(,(acar x) ,(lp obj (1- level)))))))
- (else (syntax-error (aloc x) (format #f "bad ~A" (acar x)) x))))
- ((eq? (acar x) 'quasiquote)
- (amatch (acdr x)
- ((,obj) (-> `(,'quasiquote ,(lp obj (1+ level)))))
- (else (syntax-error (aloc x) "bad quasiquote" x))))
- (else (-> (cons (lp (acar x) level) (lp (acdr x) level))))))))))
-
-(define-scheme-expander define
- ;; (define NAME VAL)
- ((,name ,val) (guard (symbol? name))
- (-> `(define ,name ,(re-expand val))))
- ;; (define (NAME FORMALS...) BODY...)
- (((,name . ,formals) . ,body) (guard (symbol? name))
- ;; -> (define NAME (lambda FORMALS BODY...))
- (re-expand (-> `(define ,name (lambda ,formals . ,body))))))
-
-(define-scheme-expander set!
- ;; (set! (NAME ARGS...) VAL)
- (((,name . ,args) ,val) (guard (symbol? name)
- (not (eq? name '@)) (not (eq? name '@@)))
- ;; -> ((setter NAME) ARGS... VAL)
- (re-expand (-> `((setter ,name) ,@args ,val))))
-
- ;; (set! NAME VAL)
- ((,name ,val) (guard (symbol? name))
- (-> `(set! ,name ,(re-expand val)))))
-
-(define-scheme-expander if
- ;; (if TEST THEN [ELSE])
- ((,test ,then)
- (-> `(if ,(re-expand test) ,(re-expand then))))
- ((,test ,then ,else)
- (-> `(if ,(re-expand test) ,(re-expand then) ,(re-expand else)))))
-
-(define-scheme-expander and
- ;; (and EXPS...)
- (,tail
- (-> `(and . ,(map re-expand tail)))))
-
-(define-scheme-expander or
- ;; (or EXPS...)
- (,tail
- (-> `(or . ,(map re-expand tail)))))
-
-(define-scheme-expander begin
- ;; (begin EXPS...)
- ((,single-exp)
- (-> (re-expand single-exp)))
- (,tail
- (-> `(begin . ,(map re-expand tail)))))
-
-(define (valid-bindings? bindings . it-is-for-do)
- (define (valid-binding? b)
- (amatch b
- ((,sym ,var) (guard (symbol? sym)) #t)
- ((,sym ,var ,update) (guard (pair? it-is-for-do) (symbol? sym)) #t)
- (else #f)))
- (and (list? (aref bindings))
- (and-map valid-binding? (aref bindings))))
-
-(define-scheme-expander let
- ;; (let NAME ((SYM VAL) ...) BODY...)
- ((,name ,bindings . ,body) (guard (symbol? name)
- (valid-bindings? bindings))
- ;; -> (letrec ((NAME (lambda (SYM...) BODY...))) (NAME VAL...))
- (re-expand (-> `(letrec ((,name (lambda ,(map acar (aref bindings))
- . ,body)))
- (,name . ,(map acadr (aref bindings)))))))
-
- ((() . ,body)
- (re-expand (expand-internal-defines body)))
-
- ;; (let ((SYM VAL) ...) BODY...)
- ((,bindings . ,body) (guard (valid-bindings? bindings))
- (-> `(let ,(map (lambda (x)
- ;; nb, relies on -> non-hygiene
- (-> `(,(acar x) ,(re-expand (acadr x)))))
- (aref bindings))
- ,(expand-internal-defines (map re-expand body))))))
-
-(define-scheme-expander let*
- ;; (let* ((SYM VAL) ...) BODY...)
- ((() . ,body)
- (re-expand (-> `(let () . ,body))))
- ((((,sym ,val) . ,rest) . ,body) (guard (symbol? sym))
- (re-expand (-> `(let ((,sym ,val)) (let* ,rest . ,body))))))
-
-(define-scheme-expander letrec
- ;; (letrec ((SYM VAL) ...) BODY...)
- ((,bindings . ,body) (guard (valid-bindings? bindings))
- (-> `(letrec ,(map (lambda (x)
- ;; nb, relies on -> non-hygiene
- (-> `(,(acar x) ,(re-expand (acadr x)))))
- (aref bindings))
- ,(expand-internal-defines (map re-expand body))))))
-
-(define-scheme-expander cond
- ;; (cond (CLAUSE BODY...) ...)
- (() (-> '(begin)))
- (((else . ,body)) (re-expand (-> `(begin ,@body))))
- (((,test) . ,rest) (re-expand (-> `(or ,test (cond ,@rest)))))
- (((,test => ,proc) . ,rest)
- ;; FIXME hygiene!
- (re-expand (-> `(let ((_t ,test)) (if _t (,proc _t) (cond ,@rest))))))
- (((,test . ,body) . ,rest)
- (re-expand (-> `(if ,test (begin ,@body) (cond ,@rest))))))
-
-(define-scheme-expander case
- ;; (case EXP ((KEY...) BODY...) ...)
- ((,exp . ,clauses)
- ;; FIXME hygiene!
- (re-expand
- (->`(let ((_t ,exp))
- ,(let loop ((ls clauses))
- (cond ((null? ls) '(begin))
- ((eq? (acaar ls) 'else) `(begin ,@(acdar ls)))
- (else `(if (memv _t ',(acaar ls))
- (begin ,@(acdar ls))
- ,(loop (acdr ls)))))))))))
-
-(define-scheme-expander do
- ;; (do ((SYM VAL [UPDATE]) ...) (TEST RESULT...) BODY...)
- ((,bindings (,test . ,result) . ,body) (guard (valid-bindings? bindings #t))
- (let ((sym (map acar (aref bindings)))
- (val (map acadr (aref bindings)))
- (update (map acddr (aref bindings))))
- (define (next s x) (if (pair? x) (car x) s))
- (re-expand
- ;; FIXME hygiene!
- (-> `(letrec ((_l (lambda ,sym
- (if ,test
- (begin ,@result)
- (begin ,@body
- (_l ,@(map next sym update)))))))
- (_l ,@val)))))))
-
-(define-scheme-expander lambda
- ;; (lambda FORMALS BODY...)
- ((,formals ,docstring ,body1 . ,body) (guard (string? docstring))
- (-> `(lambda ,formals ,docstring ,(expand-internal-defines
- (map re-expand (cons body1 body))))))
- ((,formals . ,body)
- (-> `(lambda ,formals ,(expand-internal-defines (map re-expand body))))))
-
-(define-scheme-expander delay
- ;; FIXME not hygienic
- ((,expr)
- (re-expand `(make-promise (lambda () ,expr)))))
-
-(define-scheme-expander @
- ((,modname ,sym)
- x))
-
-(define-scheme-expander @@
- ((,modname ,sym)
- x))
-
-(define-scheme-expander eval-when
- ((,when . ,body) (guard (list? when) (and-map symbol? when))
- (if (memq 'compile when)
- (primitive-eval `(begin . ,body)))
- (if (memq 'load when)
- (-> `(begin . ,body))
- (-> `(begin)))))
-
-;;; Hum, I don't think this takes imported modifications to `define'
-;;; properly into account. (Lexical bindings are OK because of alpha
-;;; renaming.)
-(define (expand-internal-defines body)
- (let loop ((ls body) (ds '()))
- (amatch ls
- (() (syntax-error l "bad body" body))
- (((define ,name ,val) . _)
- (loop (acdr ls) (cons (list name val) ds)))
- (else
- (if (null? ds)
- (if (null? (cdr ls)) (car ls) `(begin ,@ls))
- `(letrec ,ds ,(if (null? (cdr ls)) (car ls) `(begin ,@ls))))))))
diff --git a/module/language/scheme/spec.scm b/module/language/scheme/spec.scm
index 8f958eb63..cec2693aa 100644
--- a/module/language/scheme/spec.scm
+++ b/module/language/scheme/spec.scm
@@ -22,6 +22,8 @@
(define-module (language scheme spec)
#:use-module (system base language)
#:use-module (language scheme compile-ghil)
+ #:use-module (language scheme compile-tree-il)
+ #:use-module (language scheme decompile-tree-il)
#:export (scheme))
;;;
@@ -30,12 +32,6 @@
(read-enable 'positions)
-(define (read-file port)
- (do ((x (read port) (read port))
- (l '() (cons x l)))
- ((eof-object? x)
- (cons 'begin (reverse! l)))))
-
;;;
;;; Language definition
;;;
@@ -44,8 +40,9 @@
#:title "Guile Scheme"
#:version "0.5"
#:reader read
- #:read-file read-file
- #:compilers `((ghil . ,compile-ghil))
+ #:compilers `((tree-il . ,compile-tree-il)
+ (ghil . ,compile-ghil))
+ #:decompilers `((tree-il . ,decompile-tree-il))
#:evaluator (lambda (x module) (primitive-eval x))
#:printer write
)