[Top][All Lists]
[Date Prev][Date Next][Thread Prev][Thread Next][Date Index][Thread Index]
[Guile-commits] GNU Guile branch, master, updated. release_1-9-1-33-g4dc
|
From: |
Andy Wingo |
|
Subject: |
[Guile-commits] GNU Guile branch, master, updated. release_1-9-1-33-g4dcd849 |
|
Date: |
Wed, 05 Aug 2009 19:35:59 +0000 |
This is an automated email from the git hooks/post-receive script. It was
generated because a ref change was pushed to the repository containing
the project "GNU Guile".
http://git.savannah.gnu.org/cgit/guile.git/commit/?id=4dcd84998fc61e15920aea83c4420c7357b9be46
The branch, master has been updated
via 4dcd84998fc61e15920aea83c4420c7357b9be46 (commit)
via c21c89b1384415313cd4bc03e76d6e1507e48d7a (commit)
via dab0f9d55db2e2f4251265443ab0599e424a02c9 (commit)
from 7382f23e58725eef2f7a374ec101a42c0192527e (commit)
Those revisions listed above that are new to this repository have
not appeared on any other notification email; so we list those
revisions in full, below.
- Log -----------------------------------------------------------------
commit 4dcd84998fc61e15920aea83c4420c7357b9be46
Author: Andy Wingo <address@hidden>
Date: Wed Aug 5 21:25:35 2009 +0200
let-values in terms of syntax-case, add make-tree-il-folder
* module/language/tree-il.scm (tree-il-fold): Fix for let-values case.
(make-tree-il-folder): New public macro, makes a multi-valued folder
specific to the number of seeds that the user wants.
* module/language/tree-il/optimize.scm (optimize!): Reverse the order of
inline! and fix-letrec!, as the latter might expose opportunities for
the former.
* module/srfi/srfi-11.scm (let-values): Reimplement in terms of
syntax-case, so that its expressions may reference hygienically bound
variables. See the NEWS for the rationale.
(let*-values): An empty let*-values still introduces a local `let'
binding contour.
* module/system/base/syntax.scm (record-case): Yukkkk. Reimplement in
terms of syntax-case. Ug-ly, but see the NEWS again: "Lexical bindings
introduced by hygienic macros may not be referenced by nonhygienic
macros."
commit c21c89b1384415313cd4bc03e76d6e1507e48d7a
Author: Andy Wingo <address@hidden>
Date: Wed Aug 5 17:51:40 2009 +0200
add <fix> tree-il construct, and compile it
* libguile/vm-i-system.c (fix-closure): New instruction, for wiring
together fixpoint procedures.
* module/Makefile.am (TREE_IL_LANG_SOURCES): Add fix-letrec.scm.
* module/language/glil/compile-assembly.scm (glil->assembly): Reindent
the <glil-lexical> case, and handle 'fix for locally-bound vars.
* module/language/tree-il.scm (<fix>): Add the <fix> tree-il type and
accessors, for fixed-point bindings. This IL construct is taken from
the Waddell paper.
(parse-tree-il, unparse-tree-il, tree-il->scheme, tree-il-fold)
(pre-order!, post-order!): Update for <fix>.
* module/language/tree-il/analyze.scm (analyze-lexicals): Update for
<fix>. The difference here is that the bindings may not be assigned,
and are not marked as such. They are not boxed.
(report-unused-variables): Update for <fix>.
* module/language/tree-il/compile-glil.scm (flatten): Compile <fix> to
GLIL.
* module/language/tree-il/fix-letrec.scm: A stub implementation of
fixing letrec -- will flesh out in a separate commit.
* module/language/tree-il/inline.scm: Fix license, it was mistakenly
added with LGPL v2.1+.
* module/language/tree-il/optimize.scm (optimize!): Run the fix-letrec!
pass.
commit dab0f9d55db2e2f4251265443ab0599e424a02c9
Author: Andy Wingo <address@hidden>
Date: Wed Aug 5 16:17:20 2009 +0200
add a brain-dead inliner
* module/Makefile.am (TREE_IL_LANG_SOURCES):
* module/language/tree-il/inline.scm: Add a brain-dead inliner, to
inline ((lambda () x)) => x.
* module/language/tree-il/optimize.scm (optimize!): Invoke the inliner.
-----------------------------------------------------------------------
Summary of changes:
libguile/vm-i-system.c | 14 ++
module/Makefile.am | 2 +
module/language/glil/compile-assembly.scm | 60 +++---
module/language/tree-il.scm | 102 +++++++++-
module/language/tree-il/analyze.scm | 27 +++
module/language/tree-il/compile-glil.scm | 43 ++++
.../fix-letrec.scm} | 19 +-
.../language/tree-il/{optimize.scm => inline.scm} | 27 ++-
module/language/tree-il/optimize.scm | 18 +-
module/srfi/srfi-11.scm | 212 +++++---------------
module/system/base/syntax.scm | 89 ++++++---
11 files changed, 367 insertions(+), 246 deletions(-)
copy module/language/{scheme/decompile-tree-il.scm => tree-il/fix-letrec.scm}
(64%)
copy module/language/tree-il/{optimize.scm => inline.scm} (72%)
diff --git a/libguile/vm-i-system.c b/libguile/vm-i-system.c
index 4536b91..9604ce5 100644
--- a/libguile/vm-i-system.c
+++ b/libguile/vm-i-system.c
@@ -1232,6 +1232,20 @@ VM_DEFINE_INSTRUCTION (64, make_variable,
"make-variable", 0, 0, 1)
NEXT;
}
+VM_DEFINE_INSTRUCTION (65, fix_closure, "fix-closure", 2, 0, 1)
+{
+ SCM x, vect;
+ unsigned int i = FETCH ();
+ i <<= 8;
+ i += FETCH ();
+ POP (vect);
+ /* FIXME CHECK_LOCAL (i) */
+ x = LOCAL_REF (i);
+ /* FIXME ASSERT_PROGRAM (x); */
+ SCM_SET_CELL_WORD_3 (x, vect);
+ NEXT;
+}
+
/*
(defun renumber-ops ()
diff --git a/module/Makefile.am b/module/Makefile.am
index 2971fc6..f3b7e62 100644
--- a/module/Makefile.am
+++ b/module/Makefile.am
@@ -77,6 +77,8 @@ SCHEME_LANG_SOURCES =
\
TREE_IL_LANG_SOURCES = \
language/tree-il/primitives.scm \
language/tree-il/optimize.scm \
+ language/tree-il/inline.scm \
+ language/tree-il/fix-letrec.scm \
language/tree-il/analyze.scm \
language/tree-il/compile-glil.scm \
language/tree-il/spec.scm
diff --git a/module/language/glil/compile-assembly.scm
b/module/language/glil/compile-assembly.scm
index fa58057..4bd6c4f 100644
--- a/module/language/glil/compile-assembly.scm
+++ b/module/language/glil/compile-assembly.scm
@@ -251,35 +251,41 @@
(emit-code
(if local?
(if (< index 256)
- `((,(case op
- ((ref) (if boxed? 'local-boxed-ref 'local-ref))
- ((set) (if boxed? 'local-boxed-set 'local-set))
- ((box) 'box)
- ((empty-box) 'empty-box)
- (else (error "what" op)))
- ,index))
+ (case op
+ ((ref) (if boxed?
+ `((local-boxed-ref ,index))
+ `((local-ref ,index))))
+ ((set) (if boxed?
+ `((local-boxed-set ,index))
+ `((local-set ,index))))
+ ((box) `((box ,index)))
+ ((empty-box) `((empty-box ,index)))
+ ((fix) `((fix-closure 0 ,index)))
+ (else (error "what" op)))
(let ((a (quotient i 256))
(b (modulo i 256)))
- `((,(case op
- ((ref)
- (if boxed?
- `((long-local-ref ,a ,b)
- (variable-ref))
- `((long-local-ref ,a ,b))))
- ((set)
- (if boxed?
- `((long-local-ref ,a ,b)
- (variable-set))
- `((long-local-set ,a ,b))))
- ((box)
- `((make-variable)
- (variable-set)
- (long-local-set ,a ,b)))
- ((empty-box)
- `((make-variable)
- (long-local-set ,a ,b)))
- (else (error "what" op)))
- ,index))))
+ `((,(case op
+ ((ref)
+ (if boxed?
+ `((long-local-ref ,a ,b)
+ (variable-ref))
+ `((long-local-ref ,a ,b))))
+ ((set)
+ (if boxed?
+ `((long-local-ref ,a ,b)
+ (variable-set))
+ `((long-local-set ,a ,b))))
+ ((box)
+ `((make-variable)
+ (variable-set)
+ (long-local-set ,a ,b)))
+ ((empty-box)
+ `((make-variable)
+ (long-local-set ,a ,b)))
+ ((fix)
+ `((fix-closure ,a ,b)))
+ (else (error "what" op)))
+ ,index))))
`((,(case op
((ref) (if boxed? 'free-boxed-ref 'free-ref))
((set) (if boxed? 'free-boxed-set (error "what." glil)))
diff --git a/module/language/tree-il.scm b/module/language/tree-il.scm
index aec4eed..8ad7065 100644
--- a/module/language/tree-il.scm
+++ b/module/language/tree-il.scm
@@ -18,6 +18,7 @@
(define-module (language tree-il)
#:use-module (srfi srfi-1)
+ #:use-module (srfi srfi-11)
#:use-module (system base pmatch)
#:use-module (system base syntax)
#:export (tree-il-src
@@ -38,6 +39,7 @@
<lambda> lambda? make-lambda lambda-src lambda-names lambda-vars
lambda-meta lambda-body
<let> let? make-let let-src let-names let-vars let-vals let-body
<letrec> letrec? make-letrec letrec-src letrec-names letrec-vars
letrec-vals letrec-body
+ <fix> fix? make-fix fix-src fix-names fix-vars fix-vals fix-body
<let-values> let-values? make-let-values let-values-src
let-values-names let-values-vars let-values-exp let-values-body
parse-tree-il
@@ -45,6 +47,7 @@
tree-il->scheme
tree-il-fold
+ make-tree-il-folder
post-order!
pre-order!))
@@ -65,6 +68,7 @@
(<lambda> names vars meta body)
(<let> names vars vals body)
(<letrec> names vars vals body)
+ (<fix> names vars vals body)
(<let-values> names vars exp body))
@@ -141,6 +145,9 @@
((letrec ,names ,vars ,vals ,body)
(make-letrec loc names vars (map retrans vals) (retrans body)))
+ ((fix ,names ,vars ,vals ,body)
+ (make-fix loc names vars (map retrans vals) (retrans body)))
+
((let-values ,names ,vars ,exp ,body)
(make-let-values loc names vars (retrans exp) (retrans body)))
@@ -197,6 +204,9 @@
((<letrec> names vars vals body)
`(letrec ,names ,vars ,(map unparse-tree-il vals) ,(unparse-tree-il
body)))
+ ((<fix> names vars vals body)
+ `(fix ,names ,vars ,(map unparse-tree-il vals) ,(unparse-tree-il body)))
+
((<let-values> names vars exp body)
`(let-values ,names ,vars ,(unparse-tree-il exp) ,(unparse-tree-il
body)))))
@@ -256,6 +266,10 @@
((<letrec> vars vals body)
`(letrec ,(map list vars (map tree-il->scheme vals)) ,(tree-il->scheme
body)))
+ ((<fix> vars vals body)
+ ;; not a typo, we really do translate back to letrec
+ `(letrec ,(map list vars (map tree-il->scheme vals)) ,(tree-il->scheme
body)))
+
((<let-values> vars exp body)
`(call-with-values (lambda () ,(tree-il->scheme exp))
(lambda ,vars ,(tree-il->scheme body))))))
@@ -300,11 +314,87 @@ This is an implementation of `foldts' as described by
Andy Wingo in
(up tree (loop body
(loop vals
(down tree result)))))
- ((<let-values> body)
- (up tree (loop body (down tree result))))
+ ((<fix> vals body)
+ (up tree (loop body
+ (loop vals
+ (down tree result)))))
+ ((<let-values> exp body)
+ (up tree (loop body (loop exp (down tree result)))))
(else
(leaf tree result))))))
+
+(define-syntax make-tree-il-folder
+ (syntax-rules ()
+ ((_ seed ...)
+ (lambda (tree down up leaf seed ...)
+ (define (fold-values proc exps seed ...)
+ (if (null? exps)
+ (values seed ...)
+ (let-values (((seed ...) (proc (car exps) seed ...)))
+ (fold-values proc (cdr exps) seed ...))))
+ (let foldts ((tree tree) (seed seed) ...)
+ (record-case tree
+ ((<lexical-set> exp)
+ (let*-values (((seed ...) (down tree seed ...))
+ ((seed ...) (foldts exp seed ...)))
+ (up tree seed ...)))
+ ((<module-set> exp)
+ (let*-values (((seed ...) (down tree seed ...))
+ ((seed ...) (foldts exp seed ...)))
+ (up tree seed ...)))
+ ((<toplevel-set> exp)
+ (let*-values (((seed ...) (down tree seed ...))
+ ((seed ...) (foldts exp seed ...)))
+ (up tree seed ...)))
+ ((<toplevel-define> exp)
+ (let*-values (((seed ...) (down tree seed ...))
+ ((seed ...) (foldts exp seed ...)))
+ (up tree seed ...)))
+ ((<conditional> test then else)
+ (let*-values (((seed ...) (down tree seed ...))
+ ((seed ...) (foldts test seed ...))
+ ((seed ...) (foldts then seed ...))
+ ((seed ...) (foldts else seed ...)))
+ (up tree seed ...)))
+ ((<application> proc args)
+ (let*-values (((seed ...) (down tree seed ...))
+ ((seed ...) (foldts proc seed ...))
+ ((seed ...) (fold-values foldts args seed ...)))
+ (up tree seed ...)))
+ ((<sequence> exps)
+ (let*-values (((seed ...) (down tree seed ...))
+ ((seed ...) (fold-values foldts exps seed ...)))
+ (up tree seed ...)))
+ ((<lambda> body)
+ (let*-values (((seed ...) (down tree seed ...))
+ ((seed ...) (foldts body seed ...)))
+ (up tree seed ...)))
+ ((<let> vals body)
+ (let*-values (((seed ...) (down tree seed ...))
+ ((seed ...) (fold-values foldts vals seed ...))
+ ((seed ...) (foldts body seed ...)))
+ (up tree seed ...)))
+ ((<letrec> vals body)
+ (let*-values (((seed ...) (down tree seed ...))
+ ((seed ...) (fold-values foldts vals seed ...))
+ ((seed ...) (foldts body seed ...)))
+ (up tree seed ...)))
+
+ ((<fix> vals body)
+ (let*-values (((seed ...) (down tree seed ...))
+ ((seed ...) (fold-values foldts vals seed ...))
+ ((seed ...) (foldts body seed ...)))
+ (up tree seed ...)))
+ ((<let-values> exp body)
+ (let*-values (((seed ...) (down tree seed ...))
+ ((seed ...) (fold-values foldts vals seed ...))
+ ((seed ...) (foldts body seed ...)))
+ (up tree seed ...)))
+ (else
+ (leaf tree seed ...))))))))
+
+
(define (post-order! f x)
(let lp ((x x))
(record-case x
@@ -343,6 +433,10 @@ This is an implementation of `foldts' as described by Andy
Wingo in
(set! (letrec-vals x) (map lp vals))
(set! (letrec-body x) (lp body)))
+ ((<fix> vars vals body)
+ (set! (fix-vals x) (map lp vals))
+ (set! (fix-body x) (lp body)))
+
((<let-values> vars exp body)
(set! (let-values-exp x) (lp exp))
(set! (let-values-body x) (lp body)))
@@ -390,6 +484,10 @@ This is an implementation of `foldts' as described by Andy
Wingo in
(set! (letrec-vals x) (map lp vals))
(set! (letrec-body x) (lp body)))
+ ((<fix> vars vals body)
+ (set! (fix-vals x) (map lp vals))
+ (set! (fix-body x) (lp body)))
+
((<let-values> vars exp body)
(set! (let-values-exp x) (lp exp))
(set! (let-values-body x) (lp body)))
diff --git a/module/language/tree-il/analyze.scm
b/module/language/tree-il/analyze.scm
index 1b39b2d..35ddfaa 100644
--- a/module/language/tree-il/analyze.scm
+++ b/module/language/tree-il/analyze.scm
@@ -177,6 +177,13 @@
(apply lset-union eq? (step body) (map step vals))
vars))
+ ((<fix> vars vals body)
+ (hashq-set! bound-vars proc
+ (append (reverse vars) (hashq-ref bound-vars proc)))
+ (lset-difference eq?
+ (apply lset-union eq? (step body) (map step vals))
+ vars))
+
((<let-values> vars exp body)
(hashq-set! bound-vars proc
(let lp ((out (hashq-ref bound-vars proc)) (in vars))
@@ -285,6 +292,20 @@
`(#t ,(hashq-ref assigned v) . ,n)))
(lp (cdr vars) (1+ n))))))
+ ((<fix> vars vals body)
+ (let lp ((vars vars) (n n))
+ (if (null? vars)
+ (let ((nmax (apply max
+ (map (lambda (x)
+ (allocate! x proc n))
+ vals))))
+ (max nmax (allocate! body proc n)))
+ (let ((v (car vars)))
+ (if (hashq-ref assigned v)
+ (error "fixpoint procedures may not be assigned" x))
+ (hashq-set! allocation v (make-hashq proc `(#t #f . ,n)))
+ (lp (cdr vars) (1+ n))))))
+
((<let-values> vars exp body)
(let ((nmax (recur exp)))
(let lp ((vars vars) (n n))
@@ -381,6 +402,9 @@
((<letrec> vars names)
(make-binding-info (extend vars names) refs
(cons src locs)))
+ ((<fix> vars names)
+ (make-binding-info (extend vars names) refs
+ (cons src locs)))
((<let-values> vars names)
(make-binding-info (extend vars names) refs
(cons src locs)))
@@ -428,6 +452,9 @@
((<letrec> vars)
(make-binding-info (shrink vars refs) refs
(cdr locs)))
+ ((<fix> vars)
+ (make-binding-info (shrink vars refs) refs
+ (cdr locs)))
((<let-values> vars)
(make-binding-info (shrink vars refs) refs
(cdr locs)))
diff --git a/module/language/tree-il/compile-glil.scm
b/module/language/tree-il/compile-glil.scm
index 975cbf0..e3e45f5 100644
--- a/module/language/tree-il/compile-glil.scm
+++ b/module/language/tree-il/compile-glil.scm
@@ -557,6 +557,49 @@
(comp-tail body)
(emit-code #f (make-glil-unbind)))
+ ((<fix> src names vars vals body)
+ ;; For fixpoint procedures, we can do some tricks to avoid
+ ;; heap-allocation. Since we know the vals are lambdas, we can
+ ;; set them to their local var slots first, then capture their
+ ;; bindings, mutating them in place.
+ (for-each (lambda (x v)
+ (emit-code #f (flatten-lambda x allocation))
+ (if (not (null? (cdr (hashq-ref allocation x))))
+ ;; But we do have to make-closure them first, so
+ ;; we are mutating fresh closures on the heap.
+ (begin
+ (emit-code #f (make-glil-const #f))
+ (emit-code #f (make-glil-call 'make-closure 2))))
+ (pmatch (hashq-ref (hashq-ref allocation v) proc)
+ ((#t #f . ,n)
+ (emit-code src (make-glil-lexical #t #f 'set n)))
+ (,loc (error "badness" x loc))))
+ vals
+ vars)
+ (emit-bindings src names vars allocation proc emit-code)
+ ;; Now go back and fix up the bindings.
+ (for-each
+ (lambda (x v)
+ (let ((free-locs (cdr (hashq-ref allocation x))))
+ (if (not (null? free-locs))
+ (begin
+ (for-each
+ (lambda (loc)
+ (pmatch loc
+ ((,local? ,boxed? . ,n)
+ (emit-code #f (make-glil-lexical local? #f 'ref n)))
+ (else (error "what" x loc))))
+ free-locs)
+ (emit-code #f (make-glil-call 'vector (length free-locs)))
+ (pmatch (hashq-ref (hashq-ref allocation v) proc)
+ ((#t #f . ,n)
+ (emit-code #f (make-glil-lexical #t #f 'fix n)))
+ (,loc (error "badness" x loc)))))))
+ vals
+ vars)
+ (comp-tail body)
+ (emit-code #f (make-glil-unbind)))
+
((<let-values> src names vars exp body)
(let lp ((names '()) (vars '()) (inames names) (ivars vars) (rest? #f))
(cond
diff --git a/module/language/scheme/decompile-tree-il.scm
b/module/language/tree-il/fix-letrec.scm
similarity index 64%
copy from module/language/scheme/decompile-tree-il.scm
copy to module/language/tree-il/fix-letrec.scm
index 9243f4e..61504f6 100644
--- a/module/language/scheme/decompile-tree-il.scm
+++ b/module/language/tree-il/fix-letrec.scm
@@ -1,6 +1,6 @@
-;;; Guile VM code converters
+;;; transformation of letrec into simpler forms
-;; Copyright (C) 2001,2009 Free Software Foundation, Inc.
+;; Copyright (C) 2009 Free Software Foundation, Inc.
;;;; This library is free software; you can redistribute it and/or
;;;; modify it under the terms of the GNU Lesser General Public
@@ -16,11 +16,14 @@
;;;; License along with this library; if not, write to the Free Software
;;;; Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301
USA
-;;; Code:
-
-(define-module (language scheme decompile-tree-il)
+(define-module (language tree-il fix-letrec)
+ #:use-module (system base syntax)
#:use-module (language tree-il)
- #:export (decompile-tree-il))
+ #:export (fix-letrec!))
+
+;; For a detailed discussion, see "Fixing Letrec: A Faithful Yet
+;; Efficient Implementation of Schemeâs Recursive Binding Construct", by
+;; Oscar Waddell, Dipanwita Sarkar, and R. Kent Dybvig.
-(define (decompile-tree-il x env opts)
- (values (tree-il->scheme x) env))
+(define (fix-letrec! x)
+ x)
diff --git a/module/language/tree-il/optimize.scm
b/module/language/tree-il/inline.scm
similarity index 72%
copy from module/language/tree-il/optimize.scm
copy to module/language/tree-il/inline.scm
index ac16a9e..c534f19 100644
--- a/module/language/tree-il/optimize.scm
+++ b/module/language/tree-il/inline.scm
@@ -1,4 +1,4 @@
-;;; Tree-il optimizer
+;;; a simple inliner
;; Copyright (C) 2009 Free Software Foundation, Inc.
@@ -16,18 +16,10 @@
;;;; License along with this library; if not, write to the Free Software
;;;; Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301
USA
-;;; Code:
-
-(define-module (language tree-il optimize)
+(define-module (language tree-il inline)
+ #:use-module (system base syntax)
#:use-module (language tree-il)
- #:use-module (language tree-il primitives)
- #:export (optimize!))
-
-(define (env-module e)
- (if e (car e) (current-module)))
-
-(define (optimize! x env opts)
- (expand-primitives! (resolve-primitives! x (env-module env))))
+ #:export (inline!))
;; Possible optimizations:
;; * constant folding, propagation
@@ -39,3 +31,14 @@
;; * degenerate case optimizations
;; * "fixing letrec"
+;; This is a completely brain-dead optimization pass whose sole claim to
+;; fame is ((lambda () x)) => x.
+(define (inline! x)
+ (post-order!
+ (lambda (x)
+ (record-case x
+ ((<application> proc args)
+ (and (lambda? proc) (null? args)
+ (lambda-body proc)))
+ (else #f)))
+ x))
diff --git a/module/language/tree-il/optimize.scm
b/module/language/tree-il/optimize.scm
index ac16a9e..0e490a6 100644
--- a/module/language/tree-il/optimize.scm
+++ b/module/language/tree-il/optimize.scm
@@ -21,21 +21,15 @@
(define-module (language tree-il optimize)
#:use-module (language tree-il)
#:use-module (language tree-il primitives)
+ #:use-module (language tree-il inline)
+ #:use-module (language tree-il fix-letrec)
#:export (optimize!))
(define (env-module e)
(if e (car e) (current-module)))
(define (optimize! x env opts)
- (expand-primitives! (resolve-primitives! x (env-module env))))
-
-;; Possible optimizations:
-;; * constant folding, propagation
-;; * procedure inlining
-;; * always when single call site
-;; * always for "trivial" procs
-;; * otherwise who knows
-;; * dead code elimination
-;; * degenerate case optimizations
-;; * "fixing letrec"
-
+ (inline!
+ (fix-letrec!
+ (expand-primitives!
+ (resolve-primitives! x (env-module env))))))
diff --git a/module/srfi/srfi-11.scm b/module/srfi/srfi-11.scm
index c8422ee..8a41d00 100644
--- a/module/srfi/srfi-11.scm
+++ b/module/srfi/srfi-11.scm
@@ -1,6 +1,6 @@
;;; srfi-11.scm --- let-values and let*-values
-;; Copyright (C) 2000, 2001, 2002, 2004, 2006 Free Software Foundation, Inc.
+;; Copyright (C) 2000, 2001, 2002, 2004, 2006, 2009 Free Software Foundation,
Inc.
;;
;; This library is free software; you can redistribute it and/or
;; modify it under the terms of the GNU Lesser General Public
@@ -63,148 +63,55 @@
;; (q <tmp-q>))
;; (baz x y z p q))))))
-;; I originally wrote this as a define-macro, but then I found out
-;; that guile's gensym/gentemp was broken, so I tried rewriting it as
-;; a syntax-rules statement.
-;; [make-symbol now fixes gensym/gentemp problems.]
-;;
-;; Since syntax-rules didn't seem powerful enough to implement
-;; let-values in one definition without exposing illegal syntax (or
-;; perhaps my brain's just not powerful enough :>). I tried writing
-;; it using a private helper, but that didn't work because the
-;; let-values expands outside the scope of this module. I wonder why
-;; syntax-rules wasn't designed to allow "private" patterns or
-;; similar...
-;;
-;; So in the end, I dumped the syntax-rules implementation, reproduced
-;; here for posterity, and went with the define-macro one below --
-;; gensym/gentemp's got to be fixed anyhow...
-;
-; (define-syntax let-values-helper
-; (syntax-rules ()
-; ;; Take the vars from one let binding (i.e. the (x y z) from ((x y
-; ;; z) (values 1 2 3)) and turn it in to the corresponding (lambda
-; ;; (<tmp-x> <tmp-y> <tmp-z>) ...) from above, keeping track of the
-; ;; temps you create so you can use them later...
-; ;;
-; ;; I really don't fully understand why the (var-1 var-1) trick
-; ;; works below, but basically, when all those (x x) bindings show
-; ;; up in the final "let", syntax-rules forces a renaming.
-
-; ((_ "consumer" () lambda-tmps final-let-bindings lv-bindings
-; body ...)
-; (lambda lambda-tmps
-; (let-values-helper "cwv" lv-bindings final-let-bindings body ...)))
-
-; ((_ "consumer" (var-1 var-2 ...) (lambda-tmp ...) final-let-bindings
lv-bindings
-; body ...)
-; (let-values-helper "consumer"
-; (var-2 ...)
-; (lambda-tmp ... var-1)
-; ((var-1 var-1) . final-let-bindings)
-; lv-bindings
-; body ...))
-
-; ((_ "cwv" () final-let-bindings body ...)
-; (let final-let-bindings
-; body ...))
-
-; ((_ "cwv" ((vars-1 binding-1) other-bindings ...) final-let-bindings
-; body ...)
-; (call-with-values (lambda () binding-1)
-; (let-values-helper "consumer"
-; vars-1
-; ()
-; final-let-bindings
-; (other-bindings ...)
-; body ...)))))
-;
-; (define-syntax let-values
-; (syntax-rules ()
-; ((let-values () body ...)
-; (begin body ...))
-; ((let-values (binding ...) body ...)
-; (let-values-helper "cwv" (binding ...) () body ...))))
-;
-;
-; (define-syntax let-values
-; (letrec-syntax ((build-consumer
-; ;; Take the vars from one let binding (i.e. the (x
-; ;; y z) from ((x y z) (values 1 2 3)) and turn it
-; ;; in to the corresponding (lambda (<tmp-x> <tmp-y>
-; ;; <tmp-z>) ...) from above.
-; (syntax-rules ()
-; ((_ () new-tmps tmp-vars () body ...)
-; (lambda new-tmps
-; body ...))
-; ((_ () new-tmps tmp-vars vars body ...)
-; (lambda new-tmps
-; (lv-builder vars tmp-vars body ...)))
-; ((_ (var-1 var-2 ...) new-tmps tmp-vars vars body ...)
-; (build-consumer (var-2 ...)
-; (tmp-1 . new-tmps)
-; ((var-1 tmp-1) . tmp-vars)
-; bindings
-; body ...))))
-; (lv-builder
-; (syntax-rules ()
-; ((_ () tmp-vars body ...)
-; (let tmp-vars
-; body ...))
-; ((_ ((vars-1 binding-1) (vars-2 binding-2) ...)
-; tmp-vars
-; body ...)
-; (call-with-values (lambda () binding-1)
-; (build-consumer vars-1
-; ()
-; tmp-vars
-; ((vars-2 binding-2) ...)
-; body ...))))))
-;
-; (syntax-rules ()
-; ((_ () body ...)
-; (begin body ...))
-; ((_ ((vars binding) ...) body ...)
-; (lv-builder ((vars binding) ...) () body ...)))))
-
-(define-macro (let-values vars . body)
-
- (define (map-1-dot proc elts)
- ;; map over one optionally dotted (a b c . d) list, producing an
- ;; optionally dotted result.
- (cond
- ((null? elts) '())
- ((pair? elts) (cons (proc (car elts)) (map-1-dot proc (cdr elts))))
- (else (proc elts))))
-
- (define (undot-list lst)
- ;; produce a non-dotted list from a possibly dotted list.
- (cond
- ((null? lst) '())
- ((pair? lst) (cons (car lst) (undot-list (cdr lst))))
- (else (list lst))))
-
- (define (let-values-helper vars body prev-let-vars)
- (let* ((var-binding (car vars))
- (new-tmps (map-1-dot (lambda (sym) (make-symbol "let-values-var"))
- (car var-binding)))
- (let-vars (map (lambda (sym tmp) (list sym tmp))
- (undot-list (car var-binding))
- (undot-list new-tmps))))
-
- (if (null? (cdr vars))
- `(call-with-values (lambda () ,(cadr var-binding))
- (lambda ,new-tmps
- (let ,(apply append let-vars prev-let-vars)
- ,@body)))
- `(call-with-values (lambda () ,(cadr var-binding))
- (lambda ,new-tmps
- ,(let-values-helper (cdr vars) body
- (cons let-vars prev-let-vars)))))))
-
- (if (null? vars)
- `(begin ,@body)
- (let-values-helper vars body '())))
+;; We could really use quasisyntax here...
+(define-syntax let-values
+ (lambda (x)
+ (syntax-case x ()
+ ((_ (clause ...) b0 b1 ...)
+ (let lp ((clauses (syntax (clause ...)))
+ (ids '())
+ (tmps '()))
+ (if (null? clauses)
+ (with-syntax (((id ...) ids)
+ ((tmp ...) tmps))
+ (syntax (let ((id tmp) ...)
+ b0 b1 ...)))
+ (syntax-case (car clauses) ()
+ (((var ...) exp)
+ (with-syntax (((new-tmp ...) (generate-temporaries
+ (syntax (var ...))))
+ ((id ...) ids)
+ ((tmp ...) tmps))
+ (with-syntax ((inner (lp (cdr clauses)
+ (syntax (var ... id ...))
+ (syntax (new-tmp ... tmp ...)))))
+ (syntax (call-with-values (lambda () exp)
+ (lambda (new-tmp ...) inner))))))
+ ((vars exp)
+ (with-syntax ((((new-tmp . new-var) ...)
+ (let lp ((vars (syntax vars)))
+ (syntax-case vars ()
+ ((id . rest)
+ (acons (syntax id)
+ (car
+ (generate-temporaries (syntax
(id))))
+ (lp (syntax rest))))
+ (id (acons (syntax id)
+ (car
+ (generate-temporaries (syntax
(id))))
+ '())))))
+ ((id ...) ids)
+ ((tmp ...) tmps))
+ (with-syntax ((inner (lp (cdr clauses)
+ (syntax (new-var ... id ...))
+ (syntax (new-tmp ... tmp ...))))
+ (args (let lp ((tmps (syntax (new-tmp ...))))
+ (syntax-case tmps ()
+ ((id) (syntax id))
+ ((id . rest) (cons (syntax id)
+ (lp (syntax
rest))))))))
+ (syntax (call-with-values (lambda () exp)
+ (lambda args inner)))))))))))))
;;;;;;;;;;;;;;
;; let*-values
@@ -226,28 +133,11 @@
(define-syntax let*-values
(syntax-rules ()
((let*-values () body ...)
- (begin body ...))
+ (let () body ...))
((let*-values ((vars-1 binding-1) (vars-2 binding-2) ...) body ...)
(call-with-values (lambda () binding-1)
(lambda vars-1
(let*-values ((vars-2 binding-2) ...)
body ...))))))
-; Alternate define-macro implementation...
-;
-; (define-macro (let*-values vars . body)
-; (define (let-values-helper vars body)
-; (let ((var-binding (car vars)))
-; (if (null? (cdr vars))
-; `(call-with-values (lambda () ,(cadr var-binding))
-; (lambda ,(car var-binding)
-; ,@body))
-; `(call-with-values (lambda () ,(cadr var-binding))
-; (lambda ,(car var-binding)
-; ,(let-values-helper (cdr vars) body))))))
-
-; (if (null? vars)
-; `(begin ,@body)
-; (let-values-helper vars body)))
-
;;; srfi-11.scm ends here
diff --git a/module/system/base/syntax.scm b/module/system/base/syntax.scm
index cc73f38..249961d 100644
--- a/module/system/base/syntax.scm
+++ b/module/system/base/syntax.scm
@@ -1,6 +1,6 @@
;;; Guile VM specific syntaxes and utilities
-;; Copyright (C) 2001 Free Software Foundation, Inc
+;; Copyright (C) 2001, 2009 Free Software Foundation, Inc
;;; This library is free software; you can redistribute it and/or
;;; modify it under the terms of the GNU Lesser General Public
@@ -174,29 +174,70 @@
;; 5.88 0.01 0.01 list-index
-(define-macro (record-case record . clauses)
- (let ((r (gensym))
- (rtd (gensym)))
- (define (process-clause clause)
- (if (eq? (car clause) 'else)
- clause
- (let ((record-type (caar clause))
- (slots (cdar clause))
- (body (cdr clause)))
- (let ((stem (trim-brackets record-type)))
- `((eq? ,rtd ,record-type)
- (let ,(map (lambda (slot)
- (if (pair? slot)
- `(,(car slot) (,(symbol-append stem '- (cadr
slot)) ,r))
- `(,slot (,(symbol-append stem '- slot) ,r))))
- slots)
- ,@(if (pair? body) body '((if #f #f)))))))))
- `(let* ((,r ,record)
- (,rtd (struct-vtable ,r)))
- (cond ,@(let ((clauses (map process-clause clauses)))
- (if (assq 'else clauses)
- clauses
- (append clauses `((else (error "unhandled record"
,r))))))))))
+;;; So ugly... but I am too ignorant to know how to make it better.
+(define-syntax record-case
+ (lambda (x)
+ (syntax-case x ()
+ ((_ record clause ...)
+ (let ((r (syntax r))
+ (rtd (syntax rtd)))
+ (define (process-clause tag fields exprs)
+ (let ((infix (trim-brackets (syntax->datum tag))))
+ (with-syntax ((tag tag)
+ (((f . accessor) ...)
+ (let lp ((fields fields))
+ (syntax-case fields ()
+ (() (syntax ()))
+ (((v0 f0) f1 ...)
+ (acons (syntax v0)
+ (datum->syntax x
+ (symbol-append infix '-
(syntax->datum
+
(syntax f0))))
+ (lp (syntax (f1 ...)))))
+ ((f0 f1 ...)
+ (acons (syntax f0)
+ (datum->syntax x
+ (symbol-append infix '-
(syntax->datum
+
(syntax f0))))
+ (lp (syntax (f1 ...))))))))
+ ((e0 e1 ...)
+ (syntax-case exprs ()
+ (() (syntax (#t)))
+ ((e0 e1 ...) (syntax (e0 e1 ...))))))
+ (syntax
+ ((eq? rtd tag)
+ (let ((f (accessor r))
+ ...)
+ e0 e1 ...))))))
+ (with-syntax
+ ((r r)
+ (rtd rtd)
+ ((processed ...)
+ (let lp ((clauses (syntax (clause ...)))
+ (out '()))
+ (syntax-case clauses (else)
+ (()
+ (reverse! (cons (syntax
+ (else (error "unhandled record" r)))
+ out)))
+ (((else e0 e1 ...))
+ (reverse! (cons (syntax (else e0 e1 ...)) out)))
+ (((else e0 e1 ...) . rest)
+ (syntax-violation 'record-case
+ "bad else clause placement"
+ (syntax x)
+ (syntax (else e0 e1 ...))))
+ ((((<foo> f0 ...) e0 ...) . rest)
+ (lp (syntax rest)
+ (cons (process-clause (syntax <foo>)
+ (syntax (f0 ...))
+ (syntax (e0 ...)))
+ out)))))))
+ (syntax
+ (let* ((r record)
+ (rtd (struct-vtable r)))
+ (cond processed ...)))))))))
+
;; Here we take the terrorism to another level. Nasty, but the client
;; code looks good.
hooks/post-receive
--
GNU Guile
| [Prev in Thread] |
Current Thread |
[Next in Thread] |
- [Guile-commits] GNU Guile branch, master, updated. release_1-9-1-33-g4dcd849,
Andy Wingo <=