summaryrefslogtreecommitdiff
path: root/module/language/scheme/expand.scm
diff options
context:
space:
mode:
authorAndy Wingo <wingo@pobox.com>2009-03-02 17:27:45 +0100
committerAndy Wingo <wingo@pobox.com>2009-03-02 17:27:45 +0100
commit237f96e7f0c3409ecaf427010048ad60b34b2e54 (patch)
treea56eda9fb10d00ac4c13beed48788cc0f94280e4 /module/language/scheme/expand.scm
parentfb0a63e879117661175e37fd42c089ee25cadf34 (diff)
downloadguile-237f96e7f0c3409ecaf427010048ad60b34b2e54.tar.gz
add separate expansion phase, to detwingle things a bit
* module/language/scheme/expand.scm: New module, implements a separate expansion phase, not interleaved with compilation. * module/language/scheme/amatch.scm: Helper for expand.scm, it's pmatch with support for annotated source. * module/ice-9/Makefile.am (SOURCES): Add annotate.scm to build list -- early on because it will be used in the compiler. * module/ice-9/annotate.scm: Fix the printer, default to unstripped (whatever that is), and add a deannotator. * module/system/base/compile.scm (call-with-compile-error-catch): Fix for new representation of source locations. * module/Makefile.am (SCHEME_LANG_SOURCES): Add amatch and expand.
Diffstat (limited to 'module/language/scheme/expand.scm')
-rw-r--r--module/language/scheme/expand.scm300
1 files changed, 300 insertions, 0 deletions
diff --git a/module/language/scheme/expand.scm b/module/language/scheme/expand.scm
new file mode 100644
index 000000000..b8dc85f3e
--- /dev/null
+++ b/module/language/scheme/expand.scm
@@ -0,0 +1,300 @@
+;;; 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 annotate)
+ #: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 (annotation? x)
+ (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
+ (sc-expand3 (deannotate 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)
+ ((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...)
+ (,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)))))))
+
+ ;; (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))
+ . ,(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))
+ . ,(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 . ,body)
+ (-> `(lambda ,formals . ,(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-case
+ (,clauses
+ (-> `(eval-case . ,(map (lambda (x)
+ (-> `(,(acar x) . ,(map re-expand (acdr x)))))
+ clauses)))))
+
+(define (trans-body e l body)
+ (define (define->binding df)
+ (amatch (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 '()))
+ (amatch 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)))))))