summaryrefslogtreecommitdiff
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
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.
-rw-r--r--module/Makefile.am1
-rw-r--r--module/ice-9/Makefile.am2
-rw-r--r--module/ice-9/annotate.scm24
-rw-r--r--module/language/scheme/amatch.scm37
-rw-r--r--module/language/scheme/expand.scm300
-rw-r--r--module/system/base/compile.scm9
6 files changed, 361 insertions, 12 deletions
diff --git a/module/Makefile.am b/module/Makefile.am
index bf137ba48..171f9f1d2 100644
--- a/module/Makefile.am
+++ b/module/Makefile.am
@@ -45,6 +45,7 @@ SOURCES = \
$(OBJCODE_LANG_SOURCES) $(VALUE_LANG_SOURCES)
SCHEME_LANG_SOURCES = \
+ language/scheme/amatch.scm language/scheme/expand.scm \
language/scheme/compile-ghil.scm language/scheme/spec.scm \
language/scheme/inline.scm
diff --git a/module/ice-9/Makefile.am b/module/ice-9/Makefile.am
index a9ff09c7c..8c94d8320 100644
--- a/module/ice-9/Makefile.am
+++ b/module/ice-9/Makefile.am
@@ -30,7 +30,7 @@ modpath = ice-9
# and forth between interpreted and compiled code, we end up using more
# of the C stack than the interpreter would have; so avoid that by
# putting these core modules first.
-SOURCES = psyntax-pp.scm boot-9.scm \
+SOURCES = psyntax-pp.scm annotate.scm boot-9.scm \
and-let-star.scm calling.scm common-list.scm \
debug.scm debugger.scm documentation.scm emacs.scm expect.scm \
format.scm getopt-long.scm hcons.scm i18n.scm \
diff --git a/module/ice-9/annotate.scm b/module/ice-9/annotate.scm
index f09eb1fa9..faa5f859a 100644
--- a/module/ice-9/annotate.scm
+++ b/module/ice-9/annotate.scm
@@ -17,22 +17,24 @@
(define-module (ice-9 annotate)
- :export (<annotation> annotation? annotate make-annotation
+ :export (<annotation> annotation? annotate deannotate make-annotation
annotation-expression annotation-source annotation-stripped
set-annotation-stripped!))
(define <annotation>
(make-vtable "prprpw"
(lambda (struct port)
- (display "#<annotation of ")
- (display (struct-ref 0))
- (display ">"))))
+ (display "#<annotation of " port)
+ (display (struct-ref struct 0) port)
+ (display ">" port))))
(define (annotation? x)
(and (struct? x) (eq? (struct-vtable x) <annotation>)))
-(define (make-annotation e s stripped?)
- (make-struct <annotation> 0 e s stripped?))
+(define (make-annotation e s . stripped?)
+ (if (null? stripped?)
+ (make-struct <annotation> 0 e s #f)
+ (apply make-struct <annotation> 0 e s stripped?)))
(define (annotation-expression a)
(struct-ref a 0))
@@ -44,11 +46,17 @@
(struct-set! a 2 #t))
(define (annotate e)
- (cond ((list? e)
+ (cond ((and (list? e) (not (null? e)))
(make-annotation (map annotate e) (source-properties e) #f))
((pair? e)
(make-annotation (cons (annotate (car e)) (annotate (cdr e)))
(source-properties e) #f))
(else e)))
-
+(define (deannotate e)
+ (cond ((list? e)
+ (map deannotate e))
+ ((pair? e)
+ (cons (deannotate (car e)) (deannotate (cdr e))))
+ ((annotation? e) (deannotate (annotation-expression e)))
+ (else e)))
diff --git a/module/language/scheme/amatch.scm b/module/language/scheme/amatch.scm
new file mode 100644
index 000000000..4ac973620
--- /dev/null
+++ b/module/language/scheme/amatch.scm
@@ -0,0 +1,37 @@
+(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/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)))))))
diff --git a/module/system/base/compile.scm b/module/system/base/compile.scm
index e54b4ac05..891902367 100644
--- a/module/system/base/compile.scm
+++ b/module/system/base/compile.scm
@@ -45,9 +45,12 @@
,thunk
(lambda (key loc msg exp)
(if (pair? loc)
- (format (current-error-port)
- "~A:~A: ~A: ~A~%" (car loc) (cdr loc) msg exp)
- (format (current-error-port)
+ (let ((file (or (assq-ref loc 'filename) "unknown file"))
+ (line (assq-ref loc 'line))
+ (col (assq-ref loc 'column)))
+ (format (current-error-port)
+ "~A:~A:~A: ~A: ~A~%" file line col msg exp))
+ (format (current-error-port)
"unknown location: ~A: ~S~%" msg exp)))))