head	1.65;
access;
symbols;
locks; strict;
comment	@# @;


1.65
date	2007.11.05.02.50.34;	author al;	state Exp;
branches;
next	1.64;

1.64
date	2006.11.25.05.11.24;	author al;	state Exp;
branches;
next	1.63;

1.63
date	2006.05.28.03.42.52;	author al;	state Exp;
branches;
next	1.62;

1.62
date	2006.05.28.00.57.55;	author al;	state Exp;
branches;
next	1.61;

1.61
date	2006.05.24.00.54.56;	author al;	state Exp;
branches;
next	1.60;

1.60
date	2006.05.24.00.54.01;	author al;	state Exp;
branches;
next	1.59;

1.59
date	2006.05.23.23.47.17;	author al;	state Exp;
branches;
next	1.58;

1.58
date	2004.10.29.00.41.35;	author al;	state Exp;
branches;
next	1.57;

1.57
date	2004.10.29.00.37.04;	author al;	state Exp;
branches;
next	1.56;

1.56
date	2004.10.28.11.12.33;	author al;	state Exp;
branches;
next	1.55;

1.55
date	2004.10.28.09.43.14;	author al;	state Exp;
branches;
next	1.54;

1.54
date	2003.11.16.02.27.39;	author al;	state Exp;
branches;
next	1.53;

1.53
date	2003.11.15.17.40.54;	author al;	state Exp;
branches;
next	1.52;

1.52
date	2003.11.15.00.55.27;	author al;	state Exp;
branches;
next	1.51;

1.51
date	2003.10.25.19.14.46;	author al;	state Exp;
branches;
next	1.50;

1.50
date	2003.10.23.04.11.31;	author al;	state Exp;
branches;
next	1.49;

1.49
date	2003.10.20.07.10.42;	author al;	state Exp;
branches;
next	1.48;

1.48
date	2003.10.20.01.03.09;	author al;	state Exp;
branches;
next	1.47;

1.47
date	2003.10.20.00.33.03;	author al;	state Exp;
branches;
next	1.46;

1.46
date	2003.10.18.20.39.04;	author al;	state Exp;
branches;
next	1.45;

1.45
date	2003.10.18.12.17.05;	author al;	state Exp;
branches;
next	1.44;

1.44
date	2003.10.06.01.05.06;	author al;	state Exp;
branches;
next	1.43;

1.43
date	2003.10.05.17.06.04;	author al;	state Exp;
branches;
next	1.42;

1.42
date	2002.10.03.18.47.08;	author al;	state Exp;
branches;
next	1.41;

1.41
date	2002.09.25.20.44.50;	author al;	state Exp;
branches;
next	1.40;

1.40
date	2002.09.16.04.48.48;	author al;	state Exp;
branches;
next	1.39;

1.39
date	2002.09.15.23.29.39;	author al;	state Exp;
branches;
next	1.38;

1.38
date	2002.09.12.05.06.55;	author al;	state Exp;
branches;
next	1.37;

1.37
date	2002.09.12.01.28.04;	author al;	state Exp;
branches;
next	1.36;

1.36
date	2002.09.11.22.22.23;	author al;	state Exp;
branches;
next	1.35;

1.35
date	2002.09.11.06.11.28;	author al;	state Exp;
branches;
next	1.34;

1.34
date	2002.09.09.04.27.35;	author al;	state Exp;
branches;
next	1.33;

1.33
date	2002.09.06.20.17.26;	author al;	state Exp;
branches;
next	1.32;

1.32
date	2002.09.06.20.07.05;	author al;	state Exp;
branches;
next	1.31;

1.31
date	2002.09.06.12.33.16;	author al;	state Exp;
branches;
next	1.30;

1.30
date	2002.09.06.07.08.36;	author al;	state Exp;
branches;
next	1.29;

1.29
date	2002.09.06.04.01.48;	author al;	state Exp;
branches;
next	1.28;

1.28
date	2002.09.06.02.18.36;	author al;	state Exp;
branches;
next	1.27;

1.27
date	2002.09.05.19.45.08;	author al;	state Exp;
branches;
next	1.26;

1.26
date	2002.09.05.17.30.35;	author al;	state Exp;
branches;
next	1.25;

1.25
date	2002.09.05.09.44.36;	author al;	state Exp;
branches;
next	1.24;

1.24
date	2002.09.04.22.50.03;	author al;	state Exp;
branches;
next	1.23;

1.23
date	2002.09.04.14.56.38;	author al;	state Exp;
branches;
next	1.22;

1.22
date	2002.09.04.03.01.39;	author al;	state Exp;
branches;
next	1.21;

1.21
date	2002.08.25.06.22.16;	author al;	state Exp;
branches;
next	1.20;

1.20
date	2002.08.23.22.02.03;	author al;	state Exp;
branches;
next	1.19;

1.19
date	2002.08.20.16.36.32;	author al;	state Exp;
branches;
next	1.18;

1.18
date	2002.08.19.23.27.56;	author al;	state Exp;
branches;
next	1.17;

1.17
date	2002.08.19.19.50.11;	author al;	state Exp;
branches;
next	1.16;

1.16
date	2002.08.19.14.23.39;	author al;	state Exp;
branches;
next	1.15;

1.15
date	2002.08.18.21.06.12;	author al;	state Exp;
branches;
next	1.14;

1.14
date	2002.08.18.18.48.35;	author al;	state Exp;
branches;
next	1.13;

1.13
date	2002.08.18.12.18.01;	author al;	state Exp;
branches;
next	1.12;

1.12
date	2002.08.18.05.00.19;	author al;	state Exp;
branches;
next	1.11;

1.11
date	2002.08.18.00.20.54;	author al;	state Exp;
branches;
next	1.10;

1.10
date	2002.08.17.19.47.28;	author al;	state Exp;
branches;
next	1.9;

1.9
date	2002.08.17.04.03.39;	author al;	state Exp;
branches;
next	1.8;

1.8
date	2002.08.07.23.19.28;	author al;	state Exp;
branches;
next	1.7;

1.7
date	2002.08.07.23.10.47;	author al;	state Exp;
branches;
next	1.6;

1.6
date	2002.08.07.04.42.10;	author al;	state Exp;
branches;
next	1.5;

1.5
date	2002.08.06.21.49.53;	author al;	state Exp;
branches;
next	1.4;

1.4
date	2002.08.06.17.56.10;	author al;	state Exp;
branches;
next	1.3;

1.3
date	2002.08.02.04.25.41;	author al;	state Exp;
branches;
next	1.2;

1.2
date	2002.08.02.01.31.33;	author al;	state Exp;
branches;
next	1.1;

1.1
date	2002.08.01.22.30.13;	author al;	state Exp;
branches;
next	;


desc
@@


1.65
log
@Local variables are no longer all gratuitously renamed.  We only
rename when necessary.  See unrename-locals.

New function expand-program-to-simple shows how to use a second pass to
get even simpler output (with no LETREC, DELAY, or BEGIN).

Now dual-licensed under 3-clause BSD license and GNU GPL >= 2.  (Added
BSD licensing per request of Felix Winkelmann, for use in
Chicken-related work.)

Choosing symbols for variables in the final output is now put off to a
later pass (the symbolize function).  During the main expander
functions, any variables in the generated pieces of output code are
represented by vectors.  No new symbols are created until symbolize is
invoked.

Added a link to the source distribution site (petrofsky.org).

New top-level functions: expand-top-level-sexps (broken out from
expand-top-level-forms), make-var1, make-var2, var-name, var-loc,
make-letrec (broken out from expand-body), unrename-locals, symbolize,
var->symbol, expand-program-to-simple.

Renamed functions: variable? -> var?
@
text
@;; alexpander.scm: a macro expander for scheme.
;; $Id$

;; Copyright 2002-2004,2006,2007 Al Petrofsky <alexpander@@petrofsky.org>

;; LICENSING (3-clause BSD or GNU GPL 2 and up)

;; Redistribution and use in source and binary forms, with or without
;; modification, are permitted provided that the following conditions
;; are met:
;; 
;;   Redistributions of source code must retain the above copyright
;;     notice, this list of conditions and the following disclaimer.
;; 
;;   Redistributions in binary form must reproduce the above copyright
;;     notice, this list of conditions and the following disclaimer in
;;     the documentation and/or other materials provided with the
;;     distribution.
;; 
;;   Neither the name of the author nor the names of its contributors
;;     may be used to endorse or promote products derived from this
;;     software without specific prior written permission.
;; 
;; THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS
;; "AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT
;; LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR
;; A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT
;; HOLDERS OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT,
;; INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING,
;; BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS
;; OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED
;; AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT
;; LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY
;; WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE
;; POSSIBILITY OF SUCH DAMAGE.

;; Alternatively, you may redistribute, use, or modify this software
;; according to the terms of the GNU General Public License as
;; published by the Free Software Foundation (fsf.org); either version
;; 2, or (at your option) any later version.

;; INTRODUCTION:

;; This file implements a macro-expander for r5rs scheme (plus some
;; interesting extensions).  There is no magic here to hook this into
;; your native eval system: this is a simple data-in, data-out program
;; that takes a macro-using program represented as scheme data and
;; produces an equivalent macro-free program represented as scheme
;; data.

;; This is mostly intended as a demonstration.  Although it certainly
;; could be useful for adding macros to a simple scheme system that
;; lacks any macros, it may not be feasible to get it to interact
;; properly with a low-level macro system or a module system.

;; The expander is written in portable r5rs scheme, except for one use
;; of the pretty-print procedure which you can easily comment out.

;; To try it out, just load the file and execute (alexpander-repl).
;; Skip to the "BASIC USAGE" section for more information.

;; To find the latest version of this program, try here:
;;    http://petrofsky.org/src/alexpander.scm
;;
;; To find older versions or the log messages between versions, try here:
;;    http://petrofsky.org/src/RCS/alexpander.scm,v

;; If you are wondering what "r5rs scheme" is, see: 
;;    Richard Kelsey, William Clinger, and Jonathan Rees, "Revised^5
;;    report on the algorithmic language Scheme", Higher-Order and
;;    Symbolic Computation, 11(1):7-105, 1998.  Available at:
;;       PDF: http://www-swiss.ai.mit.edu/~jaffer/r5rs.pdf
;;       LaTeX source: ftp://swiss.csail.mit.edu/pub/scheme-reports/r5rs.tar.gz

;; EXTENSIONS:

;; The expander supports all the features of the r5rs macro system,
;; plus several extensions in the way syntaxes can be specified and
;; used, which are best summarized in BNF:

;; Modified r5rs productions:

;;   <expression> ---> <variable> | <literal> | <procedure call>
;;                   | <lambda expression> | <conditional> | <assignment>
;;                   | <derived expression> | <macro use> | <macro block>
;;                   | <keyword>
;;
;;   <syntax definition> ---> (define-syntax <keyword> <syntax or expression>)
;;                          | (begin <syntax definition>*)
;;                          | <macro use>
;;
;;   <syntax spec> ---> (<keyword> <syntax or expression>)
;;
;;   <macro use> ---> (<syntax> <datum>*)
;;
;;   <definition> ---> (define <variable> <expression>)
;;                   | (define (<variable> <def formals>) <body>)
;;                   | (define <expression>)
;;                   | (begin <definition>*)
;;                   | <macro use>
;;                   | <syntax definition>
;;
;;   <command or definition> ---> <command> | <definition>
;;                              | (begin <command or definition>*)
;;                              | <top-level macro block>
;;                              | <macro use>

;; New productions:

;;   <syntax or expression> ---> <syntax> | <expression>
;;
;;   <syntax> ---> <transformer spec>
;;               | <keyword>
;;               | <macro use>
;;               | <syntax macro block>
;;
;;   <syntax macro block> ---> (<syntax-only block stuff> <syntax>)
;;
;;   <top-level macro block>
;;       ---> (<syntax-only block stuff> <command or definition>)
;;
;;   <syntax-only block stuff>
;;      ---> <let-or-letrec-syntax> (<syntax spec>*) <syntax definition>*
;;
;;   <let-or-letrec-syntax> ---> let-syntax | letrec-syntax


;; These extensions all have the obvious meaning.

;; Okay, I'll elaborate on that a little bit.  Consider the intializer
;; position of a syntax definition and the head position of a
;; list-format expression:

;;   (define-syntax <keyword> <xxx>)

;;   (<yyy> <foo>*)

;; In r5rs, <xxx> must be a transformer.  <Yyy> may be an expression,
;; in which case the enclosing expression is taken to be a procedure
;; call and the <foo>s are the expressions for the operands, or <yyy>
;; may be a keyword bound to a syntax (a builtin or transformer), in
;; which case the <foo>s are processed according to that syntax.

;; The core generalization in our system is that both <xxx> and <yyy>
;; may be any type of expression or syntax.  The four forms of syntax
;; allowed are: a transformer (as allowed in the <xxx> position in
;; r5rs), a keyword (as allowed in the <yyy> position in r5rs), a
;; macro use that expands into a syntax, and a macro block (let-syntax
;; or letrec-syntax) whose body is a syntax.

;; Some examples:
;; 
;;  ;; a macro with a local macro
;;  (let-syntax ((foo (let-syntax ((bar (syntax-rules () ((bar x) (- x)))))
;;                      (syntax-rules () ((foo) (bar 2))))))
;;    (foo))
;;  => -2
;;
;;  ;; an anonymous let transformer, used directly in a macro call.
;;  ((syntax-rules ()
;;     ((let ((var init) ...) . body)
;;      ((lambda (var ...) . body)
;;       init ...)))
;;   ((x 1) (y 2))
;;   (+ x y))
;;  => 3
;;
;;  ;; a keyword used to initialize a keyword
;;  (let-syntax ((q quote)) (q x)) => x
;;
;;  ;; Binding a keyword to an expression (which could also be thought
;;  ;; of as creating a macro that is called without arguments).
;;  (let ((n 0))
;;    (let-syntax ((x (set! n (+ n 1))))
;;      (begin x x x n)))
;;  => 3
;;
;;  (let-syntax ((x append)) ((x x))) => ()


;; Internal syntax definitions.

;; Internal syntax definitions are supported wherever they would make
;; sense (see the BNF), and they have the letrec-syntax semantics you
;; would expect.  It is legal for the initializer of an internal
;; variable definition to use one of the internal syntax definitions
;; in the same body:

;; (let ()
;;   (define x (y))
;;   (define-syntax y (syntax-rules () ((y) 1)))
;;   x)
;; => 1

;; It's also legal for internal syntax definitions to be mutually
;; recursive transformers, but it is an error for the expansion of a
;; syntax definition's initializer to require the result of another
;; initializer:

;; (let ()
;;   (define-syntax m1 (syntax-rules () ((m1) #f) ((m1 . args) (m2 . args))))
;;   (define-syntax m2 (syntax-rules () ((m2 arg . args) (m1 . args))))
;;   (m1 foo bar baz))
;; => #f

;; (let ()
;;   (define-syntax simple-transformer
;;     (syntax-rules ()
;;       ((simple-transformer pattern template)
;;        (syntax-rules () (pattern template)))))
;;   (define-syntax m (simple-transformer (m x) (- x)))
;;   (m 1))
;; => error ("Premature use of keyword bound by an internal define-syntax")

;; (let ()
;;   (define-syntax simple-transformer
;;     (syntax-rules ()
;;       ((simple-transformer pattern template)
;;        (syntax-rules () (pattern template)))))
;;   (let ()
;;     (define-syntax m (simple-transformer (m x) (- x)))
;;     (m 1)))
;; => -1


;; Top-level macro blocks.

;; At the top level, if a macro block (i.e., a let-syntax or
;; letrec-syntax form) has only one body element, or if all of the
;; body elements before the last one are internal syntax definitions,
;; then the last body element need not be an expression (as would be
;; required in r5rs).  Instead, it may be anything allowed at top
;; level: an expression, a definition, a begin sequence of top-level
;; forms, or another macro block containing a top-level form.

;;   (let-syntax ((- quote))
;;     (define x (- 1)))
;;
;;   (list x (- 1))
;;   => (1 -1)

;; Note that, unlike the similar extension in Chez scheme 6.0, this is
;; still r5rs-compatible, because we only treat definitions within the
;; last body element as top-level definitions (and r5rs does not allow
;; internal definitions within a body's last element, even if it is a
;; begin form):

;;   (define x 1)
;;   (define (f) x)
;;   (let-syntax ()
;;     (define x 2)
;;     (f))
;;   => 1, in r5rs and alexpander, but 2 in Chez scheme

;;   (define x 1)
;;   (define (f) x)
;;   (let-syntax ()
;;     (begin
;;       (define x 2)
;;       (f)))
;;   => 2, in alexpander and in Chez scheme, but an error in r5rs.


;; Syntax-rules ellipsis

;; Per SRFI-46, syntax-rules transformers can specify the
;; identifier to be used as the ellipsis (such a specification is
;; treated as a hygienic binding), and a list pattern may contain
;; subpatterns after an ellipsis as well as before it:

;;   <transformer spec> ---> (syntax-rules (<identifier>*) <syntax rule>*)
;;              | (syntax-rules <ellipsis> (<identifier>*) <syntax rule>*)
;;   
;;   <syntax rule> ---> (<pattern> <template>)
;;   
;;   <pattern> ---> <pattern identifier>
;;                | (<pattern>*)
;;                | (<pattern>+ . <pattern>)
;;                | (<pattern>* <pattern> <ellipsis> <pattern>*)
;;                | #(<pattern>*)
;;                | #(<pattern>* <pattern> <ellipsis> <pattern>*)
;;                | <pattern datum>
;;   
;;   <pattern identifier> ---> <identifier>
;;   
;;   <ellipsis> ---> <identifier>


;; Expressions among internal definitions.

;; A definition of the form (define <expression>) causes the
;; expression to be evaluated at the conclusion of any enclosing set
;; of internal definitons.  That is, at top level, (define
;; <expression>) is equivalent to just plain <expression>.  As for
;; internal definitions, the following are equivalent:

;; (let ()
;;   (define v1 <init1>)
;;   (define <expr1>)
;;   (define <expr2>)
;;   (define v2 <init2>)
;;   (define <expr3>)
;;   (begin
;;     <expr4>
;;     <expr5>))
;; 
;; (let ()
;;   (define v1 <init1>)
;;   (define v2 <init2>)
;;   (begin
;;     <expr1>
;;     <expr2>
;;     <expr3>
;;     <expr4>
;;     <expr5>))

;; (Yes, it would probably be better to have a separate builtin for
;; this rather than to overload define.)

;; This feature makes it possible to implement a define-values that
;; works properly both at top-level and among internal definitions:

;; (define define-values-temp #f)
;;
;; (define-syntax define-values
;;   (syntax-rules ()
;;     ((define-values (var ...) init)
;;      (begin
;;        (define define-values-temp (call-with-values (lambda () init) list))
;;        (define var #f) ...
;;        (define
;;          (set!-values (var ...) (apply values define-values-temp)))))))

;; (Set!-values is implementable using just r5rs features and is left
;; as an exercise.)

;; When used among internal definitions, the definition of
;; define-values-temp in define-values's output creates a local
;; binding, and thus the top-level binding of define-values-temp is
;; irrelevant.  When used at top-level, the definition of
;; define-values-temp in the output does not create a binding.
;; Instead, it mutates the top-level binding of define-values-temp.
;; Thus, all top-level uses of define-values share a single temp
;; variable.  For internal-definition-level uses of define-values, a
;; single shared temp would not be sufficient, but things work out
;; okay because hygienic renaming causes each such use to create a
;; distinct temp variable.

;; The version below works the same way, but hides from the top-level
;; environment the temp that is shared by top-level uses of
;; define-values.  For a bit of tutorial and rationale about this
;; technique, see usenet article
;; <8765tos2y9.fsf@@radish.petrofsky.org>:

;; (define-syntax define-values
;;   (let-syntax ((temp (syntax-rules ())))
;;     (syntax-rules ()
;;       ((define-values (var ...) init)
;;        (begin
;;          (define temp (call-with-values (lambda () init) list))
;;          (define var #f) ...
;;          (define (set!-values (var ...) (apply values temp))))))))


;; Improved nested unquote-splicing.  

;; Quasiquote is extended to make commas and comma-ats distributive
;; over a nested comma-at, as in Common Lisp's backquote.  See my
;; 2004-09-03 usenet article <87pt53f9f2.fsf@@radish.petrofsky.org>,
;; Bawden's 1999 quasiquotation paper, and Appendix C of Steele's
;; "Common Lisp the Language 2nd edition".

;;   <splicing unquotation 1> ---> ,@@<qq template 0>
;;                               | (unquote-splicing <qq template 0>)
;;
;;   <splicing unquotation D> ---> ,@@<qq template D-1>
;;                               | ,<splicing unquotaion D-1>
;;                               | ,@@<splicing unquotaion D-1>
;;                               | (unquote-splicing <qq template D-1>)
;;                               | (unquote <splicing unquotaion D-1>)
;;                               | (unquote-splicing <splicing unquotaion D-1>)

;; When a comma at-sign and the expression that follows it are being
;; replaced by the elements of the list that resulted from the
;; expression's evaluation, any sequence of commas and comma at-signs
;; that immediately preceded the comma at-sign is also removed and is
;; added to the front of each of the replacements.

;;  (let ((x '(a b c))) ``(,,x ,@@,x ,,@@x ,@@,@@x))
;;  => `(,(a b c) ,@@(a b c) ,a ,b ,c ,@@a ,@@b ,@@c)
;;
;;  ``(,,@@'() ,@@,@@(list))
;;  => `()
;;
;;  `````(a ,(b c ,@@,,@@,@@(list 'a 'b 'c)))
;;  => ````(a ,(b c ,@@,,@@a ,@@,,@@b ,@@,,@@c))
;;  
;; (let ((vars '(x y)))
;;   (eval `(let ((x '(1 2)) (y '(3 4)))
;;            `(foo ,@@,@@vars))
;;         (null-environment 5)))
;; => (foo 1 2 3 4)


;; BASIC USAGE:

;; There are four supported ways to use this:

;;   1. (alexpander-repl)
;;      This starts a read-expand-print-loop.  Type in a program and
;;      see its expansion as you go.
;;
;;   2. (expand-program list-of-the-top-level-forms-of-a-program)
;;      Returns a list of the top-level forms of an equivalent
;;      macro-free program.
;;
;;   3. (expand-top-level-forms! forms mstore)
;;      Returns some macro-expanded forms and mutates mstore.
;;      To use this, first create an initial mutable store with
;;      (null-mstore).  Then you can pass a program in piecemeal, with
;;      the effects of top-level define-syntaxes saved in mstore
;;      between calls to expand-top-level-forms!.
;;
;;   4. (expand-top-level-forms forms store loc-n k)
;;      The purely-functional interface.
;;      This returns by making a tail call to k:
;;      (k expanded-forms new-store new-loc-n)
;;      Use null-store and null-loc-n for store and loc-n arguments
;;      when calling expand-top-level-forms with the first forms in a
;;      program.
;;
;; For options 3 and 4, you need to prepend null-output to the
;; resulting program.  Null-output contains some definitions like
;; (define _eqv?_7 eqv?), which create alternate names for some of the
;; builtin procedures.  These names are used by the standard case and
;; quasiquote macros so that they can keep working even if you
;; redefine one of the standard procedures.

;; The output programs use a small subset of the r5rs syntax, namely:
;; BEGIN, DEFINE, DELAY, IF, LAMBDA, LETREC, QUOTE, AND SET!.
;; Furthermore, begin is only used for expressions; lambdas and
;; letrecs always have a single body expression and no internal
;; definitions; and defines are always of the simple (define
;; <variable> <expression>) form.  If you want even simpler output,
;; with no letrecs, see expand-program-to-simple.

;; Any uses or definitions in the original program of a top-level
;; variable whose name begins with "_", or whose name is one of the
;; eight primitives in the output language, will be renamed.  This
;; will only cause a problem if the program is trying to use some
;; nonstandard library variable that starts with "_".  That is, even
;; though some of a program's top-level variable names may get
;; changed, any r5rs-conformant program will still be translated to an
;; equivalent macro-free r5rs program.


;; INTERNALS

;; [NOTE: this documentation is certainly not complete, and it kind of
;; dissolves after a few pages from verbose paragraphs into cryptic
;; sentence fragments.  Nonetheless, it might be enough to help
;; someone figure out the code.]

;; ENVIRONMENTS AND STORES

;; The two principal data structures are the environment and the
;; store.

;; These work similarly to the runtime environment and store described
;; in r5rs: in both that system and in ours, to determine the meaning
;; of an identifier, we lookup which location the environment
;; associates with the identifier, and then check what value the store
;; associates with that location.

;; In the runtime system, the identifiers mapped by the environment
;; are all variables, and the values in the store are the scheme
;; values the variables currently hold.  Environments may be locally
;; extended by LAMBDA to map some identifiers to new locations that
;; initially hold the values passed to the procedure.  Environments
;; may also be locally extended by internal DEFINE (a.k.a LETREC) to
;; map some identifiers to new locations that are empty and illegal to
;; access or SET! until the evaluation of all the initializers has
;; completed (at which time the results are stored into the
;; locations).  The store is modified when a SET! or top-level DEFINE
;; is evaluated, or when a set of internal DEFINE initializers'
;; evaluations completes, but environments are immutable.  The static
;; top-level environment maps every variable name to some location,
;; although most of these locations are illegal to access until the
;; evaluation of the initializer of the first top-level DEFINE of the
;; variable has completed.  (The exceptions are the locations to which
;; the standard procedure names are bound: these locations may be
;; accessed at any time, but they may not be SET! until after the
;; first top-level DEFINE of the procedure name.)

;; (R5rs actually does not completely specify how the top-level
;; environment works, and allows one to consider the top-level
;; environment to be dynamically extended, but the model I just
;; described fits within the r5rs parameters and plays well with our
;; macro system.  To recap: the difference between SET! and top-level
;; DEFINE is not that top-level DEFINE is able to create a new
;; binding, rather, the difference is that top-level DEFINE is allowed
;; to store into any location and SET! is not always allowed to store
;; into some locations.)

;; In our syntactic system, a value in the store may be either a
;; syntax (a builtin or a macro transformer), a variable name, or the
;; expanded code for an expression.  When we encounter a use of an
;; identifier, we go through the environment and the store to fetch
;; its value.  If the value is a variable name, we emit that variable
;; name.  If the value is some code, we emit that code.  If the value
;; is a syntax, we proceed according to the rules of that syntax.  As
;; in the runtime system, environments are immutable and the static
;; top-level environment is infinite.  Environments may be locally
;; extended by LAMBDA or internal DEFINE to map some identifiers to
;; new locations that hold variable names.  Environments may also be
;; extended by LET-SYNTAX to map some identifiers to new locations
;; that initially hold the syntaxes and/or code resulting from the
;; expansion of the initializers.  Lastly, environments may be
;; extended by internal DEFINE-SYNTAX (a.k.a LETREC-SYNTAX) to map
;; some identifiers to new locations that are empty and illegal to
;; access until the expansion of their initializers has completed (at
;; which time the resulting syntaxes and/or code are stored into the
;; locations).  The store is modified by top-level DEFINE and
;; DEFINE-SYNTAX, and when a set of internal DEFINE-SYNTAX
;; initializers' expansions completes.  The store is not altered by a
;; SET!, because a SET! does not change the fact that the identifier
;; is a variable: from our perspective a SET! of a variable is simply
;; a use of the variable.  A top-level DEFINE only alters the store if
;; an identifier whose location previously held a syntax is now being
;; defined as a variable.

;; The static top-level environment maps every name to some location.
;; Initially, the locations to which the environment maps the names of
;; the ten builtins (BEGIN DEFINE DEFINE-SYNTAX IF LAMBDA QUOTE SET!
;; DELAY LET-SYNTAX SYNTAX-RULES) hold as their values those builtin
;; syntaxes.  All other names are bound to locations that hold the
;; corresponding top-level variable name.

;; I said the top-level environment contains a binding for "every
;; name" rather than for "every identifier", because the new
;; identifiers created by a syntax-rules macro expansion are given
;; numbers rather than names, and the top-level environment has no
;; bindings for these.  If such an identifier is used in an
;; environment that does not bind it to any location, then the
;; location to which the template literal was bound in the environment
;; of the macro is used instead.  (To be prepared for such a
;; contingency, this location is stored along with the numeric id in
;; the "renamed-sid" (see below) that a macro expansion inserts into
;; the code.)

;; REPRESENTATION OF ENVIRONMENTS AND STORES

;; An environment is represented by an alist mapping ids to local
;; (non-top-level) locations.  All environments are derived from the
;; top-level environment, so any symbolic id not in the alist is
;; implicitly mapped to the corresponding top-level location.

;; An id (identifier) is what we bind to a location in an environment.
;; Original ids are the symbols directly occuring in the source code.
;; Renamed ids are created by macro expansions and are represented by
;; integers.

;; id: original-id | renamed-id
;; original-id: symbol
;; renamed-id: integer

;; The static top-level environment maps every symbol to a location.
;; For simplicity, each of those locations is represented by the
;; symbol that is bound to it.  All other locations (those created by
;; lambda, let-syntax, and internal definitions) are represented by
;; integers.

;; env: ((id . local-location) ...)
;; store: ((location . val) ...)
;; location: toplevel-location | local-location  ;; a.k.a. symloc and intloc.
;; toplevel-location: symbol
;; local-location: integer
;; val: variable | syntax | code
;; variable: #(toplevel-location) | #(symbol local-location)
;; code: (output) ; output is the expanded code for an expression.
;; syntax: builtin | transformer
;; builtin: symbol
;; transformer: (synrules env)
;; synrules: the unaltered sexp of the syntax-rules form.

;; REPRESENTATION OF THE CODE UNDERGOING EXPANSION (SEXPS).

;; Any variable named SEXP in the expander code holds a representation
;; of some code undergoing expansion.  It mostly looks like the
;; ordinary representation of scheme code, but it may contain some
;; identifiers that are encoded as two- or three-element vectors
;; called renamed-sids.  Any actual vector in the code will be
;; represented as a one-element vector whose element is a list of the
;; actual elements, i.e., each vector #(elt ...) is mapped to #((elt
;; ...)), so that we can distinguish these vectors from renamed-sids.

;; In contrast, a variable named OUTPUT is a bit of almost-finished
;; code.  In this format, symbols and vectors within a quote
;; expression are represented normally.  All variable names are
;; represented as vectors of the form #(symbol) or #(symbol integer).
;; These vectors are converted to suitable, non-clashing symbols by
;; the symbolize function, which is the final step of expansion.

;; A sid is the representation of an id within a sexp.
;; sid: original-id | renamed-sid

;; A renamed-sid includes the id's original name, which we will need
;; if the id gets used in a QUOTE expression.  The renamed-sid also
;; includes the location of the local binding (if any) of the template
;; literal that created the id: this is the location to use if the id
;; gets used freely (i.e., in an environment with no binding for it). 
;; renamed-sid: #(original-id renamed-id)
;;            | #(original-id renamed-id local-location)

;; Procedures that take a SEXP argument usually also take an ID-N
;; argument, which is the next higher number after the largest
;; renamed-id that occurs in the SEXP argument.  (This is to enable
;; adding new ids without conflict.)
;;
;; Similarly, a STORE argument is usually accompanied by a LOC-N
;; argument, which is the next higher number after the largest
;; local-location in the STORE argument.

;; SUMMARY OF MAJOR FUNCTIONS:

;; (lookup-sid sid env) => location
;; (lookup-location location store) => val | #f  ;; #f means letrec violation.
;; (lookup2 sid env store) => val ;; lookup-sid + lookup-location + fail if #f.
;; (extend-env env id location) => env
;; (extend-store store intloc val) => store
;; (substitute-in-store store loc val) => store
;; (compile-syntax-rules synrules env) => transformer
;; (apply-transformer trans sexp id-n env k) => (k sexp id-n)
;; (expand-any sexp id-n env store loc-n lsd? ek sk dk bk)
;;    => (ek output)
;;     | (sk syntax sexp store loc-n)
;;     | (dk builtin sexp id-n env store loc-n)
;;     | (bk sexp id-n env store loc-n)
;; (expand-expr sexp id-n env store loc-n) => output
;; (expand-val sexp id-n env store loc-n k) => (k val store loc-n)
;; (expand-top-level-sexps sexps store loc-n k)
;;   => (k outputs store loc-n)
;; (expand-body sexps id-n env store loc-n lsd? ek sk dk bk)
;;    => same as expand-any
;; (expand-syntax-bindings bindings id-n syntax-env ienv store loc-n k)
;;   => (k store loc-n)


(define (sid? sexp)          (or (symbol? sexp) (renamed-sid? sexp)))
(define (renamed-sid? sexp)  (and (vector? sexp) (< 1 (vector-length sexp))))
(define (svector? sexp)      (and (vector? sexp) (= 1 (vector-length sexp))))
(define (svector->list sexp) (vector-ref sexp 0))
(define (list->svector l) (vector l))

(define (make-sid name renamed-id location)
  (if (eq? name location)
      (vector name renamed-id)
      (vector name renamed-id location)))

(define (sid-name sid) (if (symbol? sid) sid (vector-ref sid 0)))
(define (sid-id sid)   (if (symbol? sid) sid (vector-ref sid 1)))
(define (sid-location sid)
  (if (symbol? sid) sid (vector-ref sid (if (= 2 (vector-length sid)) 0 2))))

(define (list1? x) (and (pair? x) (null?  (cdr x))))
(define (list2? x) (and (pair? x) (list1? (cdr x))))

;; Map-vecs does a deep map of x, replacing any vector v with (f v).
;; We assume that f never returns #f.
;; If a subpart contains no vectors, we don't waste space copying it.
;; (Yes, this is grossly premature optimization.)
(define (map-vecs f x)
  ;; mv2 returns #f if there are no vectors in x.
  (define (mv2 x)
    (if (vector? x)
	(f x)
	(and (pair? x)
	     (let ((a (car x)) (b (cdr x)))
	       (let ((a-mapped (mv2 a)))
		 (if a-mapped
		     (cons a-mapped (mv b))
		     (let ((b-mapped (mv2 b)))
		       (and b-mapped (cons a b-mapped)))))))))
  (define (mv x) (or (mv2 x) x))
  (mv x))

(define (wrap-vec v) (list->svector (wrap-vecs (vector->list v))))
(define (wrap-vecs input) (map-vecs wrap-vec input))
(define (unwrap-vec v-sexp)
  (if (= 1 (vector-length v-sexp))
      (list->vector (unwrap-vecs (svector->list v-sexp)))
      (vector-ref v-sexp 0)))
(define (unwrap-vecs sexp) (map-vecs unwrap-vec sexp))

;; The store maps locations to vals.
;; vals are variables, syntaxes, or code.

(define (make-code output) (list output))
(define (make-builtin name) name)
(define (make-transformer synrules env) (list synrules env))

(define (var? val) (vector? val))
(define (code? val) (list1? val))
(define (code-output code) (car code))

(define (syntax? val) (or (symbol? val) (list2? val)))

(define (builtin? syntax) (symbol? syntax))
(define (builtin-name builtin) builtin)

(define (transformer? syntax) (not (builtin? syntax)))
(define (transformer-synrules trans) (car trans))
(define (transformer-env trans) (cadr trans))

(define (acons key val alist) (cons (cons key val) alist))

(define empty-env '())
(define empty-store '())

;; Lookup-sid looks up a sid in an environment.
;; If there is no binding in the environment, then:
;;   1. For an original-id, we return the like-named location, because
;;      the static top-level environment maps every name to a location.
;;   2. For a renamed id, we return the location to which the template
;;      literal that created it was bound.
(define (lookup-sid sid env)
  (cond ((assv (sid-id sid) env) => cdr)
	;; This works for both cases 1 and 2 above.
	(else (sid-location sid))))

;; Lookup-location looks up a location in the store.
;; If there is no value explictly listed in the store, then:
;;   1. For a top-level (named) location, return a top-level variable.
;;   2. For a local location, return #f.  This can only happen for a
;;      location allocated by letrec-syntax or internal define-syntax
;;      and used before it is initialized,
;;      e.g. (letrec-syntax ((x x)) 1).
(define (lookup-location location store)
  (cond ((assv location store) => cdr)
	((symbol? location) (symloc->var location))
	(else #f)))

(define (lookup2 sid env store)
  (or (lookup-location (lookup-sid sid env) store)
      (error (string-append "Premature use of keyword bound by letrec-syntax"
			    " (or an internal define-syntax): ")
	     sid)))

(define (extend-env env id location) (acons id location env))
(define (extend-store store loc val) (acons loc val store))

;; Extend-store just adds to the front of the alist, whereas
;; substitute-in-store actually bothers to remove the old entry, and
;; to not add a new entry if it is just the default.
;; Substitute-in-store is only used by top-level define and
;; define-syntax.  Because nothing is ever mutated, we could just use
;; extend-store all the time, but we are endeavoring to keep down the
;; size of the store to make it more easily printed and examined.
(define (substitute-in-store store loc val)
  (let ((store (if (assv loc store)
		   (let loop ((store store))
		     (let ((p (car store)))
		       (if (eqv? loc (car p))
			   (cdr store)
			   (cons p (loop (cdr store))))))
		   store)))
    (if (and (symbol? loc) (eq? val (symloc->var loc)))
	store
	(acons loc val store))))

(define (make-var1 name/loc)
  (vector name/loc))
(define (make-var2 name loc)
  (vector name loc))
(define (var-name var)
  (vector-ref var 0))
(define (var-loc var)
  (vector-ref var (- (vector-length var) 1)))

(define (symloc->var sym)
  (make-var1 sym))

(define (intloc->var intloc sid)
  (make-var2 (sid-name sid) intloc))

(define (loc->var loc sid)
  (if (symbol? loc)
      (symloc->var loc)
      (intloc->var loc sid)))

(define (make-begin outputs)
  (if (list1? outputs) (car outputs) (cons 'begin outputs)))

(define (make-letrec bindings expr)
  (if (null? bindings) expr (list 'letrec bindings expr)))

(define (expand-lambda formals expr id-n env store loc-n)
  ;; (a b . c) => (a b c)
  (define (flatten-dotted x)
    (if (pair? x) (cons (car x) (flatten-dotted (cdr x))) (list x)))
  ;; (a b c) => (a b . c)
  (define (dot-flattened x)
    (if (null? (cdr x)) (car x) (cons (car x) (dot-flattened (cdr x)))))
  (let* ((dotted? (not (list? formals)))
	 (flattened (if dotted? (flatten-dotted formals) formals)))
    (define (check x)
      (or (sid? x) (error "Non-identifier: " x " in lambda formals: " formals))
      (if (member x (cdr (member x flattened)))
	  (error "Duplicate variable: " x " in lambda formals: " formals)))
    (begin
      (for-each check flattened)
      (let loop ((formals flattened) (rvars '())
		 (env env) (store store) (loc-n loc-n))
	(if (not (null? formals))
	    (let* ((var (intloc->var loc-n (car formals)))
		   (env (extend-env env (sid-id (car formals)) loc-n))
		   (store (extend-store store loc-n var)))
	      (loop (cdr formals) (cons var rvars) env store (+ 1 loc-n)))
	    (let* ((vars (reverse rvars))
		   (vars (if dotted? (dot-flattened vars) vars)))
	      (list vars (expand-expr expr id-n env store loc-n))))))))

(define (check-syntax-bindings bindings)
  (or (list? bindings) (error "Non-list syntax bindings list: " bindings))
  (for-each (lambda (b) (or (and (list2? b) (sid? (car b)))
			    (error "Malformed syntax binding: " b)))
	    bindings)
  (do ((bs bindings (cdr bs)))
      ((null? bs))
    (let ((dup (assoc (caar bs) (cdr bs))))
      (if dup (error "Duplicate bindings for a keyword: "
		     (car bs) " and: " dup)))))

;; returns (k store loc-n)
(define (expand-syntax-bindings bindings id-n syntax-env ienv store loc-n k)
  (let loop ((bs bindings) (vals '()) (store store) (loc-n loc-n))
    (if (not (null? bs))
	(expand-val (cadar bs) id-n syntax-env store loc-n
	  (lambda (val store loc-n)
	    (loop (cdr bs) (cons val vals) store loc-n)))
	(let loop ((store store) (vals (reverse vals)) (bs bindings))
	  (if (not (null? vals))
	      (let* ((loc (lookup-sid (caar bs) ienv))
		     (store (extend-store store loc (car vals))))
		(loop store (cdr vals) (cdr bs)))
	      (k store loc-n))))))


;; (expand-any sexp id-n env store loc-n lsd? ek sk dk bk)
;;
;; Ek, sk, dk, and bk are continuations for expressions, syntaxes,
;; definitions and begins:
;;
;; If sexp is an expression, returns (ek output).
;;
;; If sexp is a syntax, returns (sk syntax error-sexp store loc-n).
;;   The error-sexp is just for use in error messages if the syntax is
;;   subsequently misused.  It is the sid that was bound to the
;;   syntax, unless the syntax is an anonymous transformer, as in
;;   ((syntax-rules () ((_ x) 'x)) foo), in which case the error-sexp
;;   will be the entire syntax-rules form.
;;
;; If sexp is a definition, returns (dk builtin sexp id-n env store
;;   loc-n), where builtin is define or define-syntax.
;;
;; If sexp is a begin, returns (bk sexp id-n env store loc-n).
;;
;; The car of the sexp passed to dk or bk is just for error reporting:
;; it is the sid that was bound to begin, define, or define-syntax.
;;
;; Expand-any signals an error if a malformed e, s, d, or b is
;; encountered.  It also signals an error if ek, sk, dk, or bk is #f
;; and the corresponding thing is encountered; however, if a begin is
;; encountered and bk is #f, the begin is expanded as an expression
;; and passed to ek.
;;
;; lsd? == Let-Syntax around Definitions is okay.  If lsd? is #f and a
;; let-syntax is encountered, it is assumed to start an expression or
;; syntax, so if ek and sk are #f an error will be signalled.  lsd? is
;; only true at top-level.  (Let-syntax around internal definitions is
;; just too semantically bizarre.)
(define (expand-any sexp id-n env store loc-n lsd? ek sk dk bk)
  (define (get-k k sexp name)
    (or k (error (string-append name " used in bad context: ")
		 sexp)))
  (define (get-ek sexp) (get-k ek sexp "Expression"))
  (define (get-sk sexp) (get-k sk sexp "Syntax"))
  (define (get-dk sexp) (get-k dk sexp "Definition"))
  (define (get-bk sexp) (get-k bk sexp "Begin"))
  (let again ((sexp sexp) (id-n id-n) (store store) (loc-n loc-n))
    (define (expand-subexpr sexp) (expand-expr sexp id-n env store loc-n))
    (define (handle-syntax-use syntax head store loc-n)
      (let* ((tail (cdr sexp)) (sexp (cons head tail)))
	(if (transformer? syntax)
	    (apply-transformer syntax sexp id-n env
	      (lambda (sexp id-n) (again sexp id-n store loc-n)))
	    (let ((builtin (builtin-name syntax)) (len (length tail)))
	      (define (handle-macro-block)
		(or ek sk lsd?
		    (error "Macro block used in bad context: " sexp))
		(or (>= len 2) (error "Malformed macro block: " sexp))
		(let ((bindings (car tail)) (body (cdr tail)))
		  (check-syntax-bindings bindings)
		  (let loop ((bs bindings) (loc-n loc-n) (ienv env))
		    (if (not (null? bs))
			(loop (cdr bs) (+ loc-n 1)
			      (extend-env ienv (sid-id (caar bs)) loc-n))
			(expand-syntax-bindings
			  bindings id-n env ienv store loc-n
			  (lambda (store loc-n)
			    (expand-body body id-n ienv store loc-n
					 lsd? ek sk
					 (and lsd? dk) (and lsd? bk))))))))
	      (define (handle-expr-builtin)
		(define (expr-assert test)
		  (or test (error "Malformed " builtin " expression: " sexp)))
		(cons builtin
		      (case builtin
			((lambda)
			 (expr-assert (= len 2))
			 (expand-lambda (car tail) (cadr tail)
					id-n env store loc-n))
			((quote)
			 (expr-assert (= len 1))
			 (list (unwrap-vecs (car tail))))
			((set!)
			 (expr-assert (and (= len 2) (sid? (car tail))))
			 (let ((var (lookup2 (car tail) env store)))
			   (or (var? var)
			       (error "Attempt to set a keyword: " sexp))
			   (list var (expand-subexpr (cadr tail)))))
			((if)
			 (expr-assert (<= 2 len 3))
			 (map expand-subexpr tail))
			((delay)
			 (expr-assert (= len 1))
			 (list (expand-subexpr (car tail)))))))
	      (case builtin
		((let-syntax) (handle-macro-block))
		((syntax-rules)
		 (if (< len 1) (error "Empty syntax-rules form: " sexp))
		 (let ((syn (compile-syntax-rules sexp env)))
		   ((get-sk sexp) syn sexp store loc-n)))
		((begin)
		 (or ek (get-bk sexp))
		 (cond (bk (bk sexp id-n env store loc-n))
		       ((null? tail) (error "Empty begin expression: " sexp))
		       (else (ek (make-begin (map expand-subexpr tail))))))
		((define define-syntax)
		 (or (and (= 2 len) (sid? (car tail)))
		     (and (= 1 len) (eq? builtin 'define))
		     (error "Malformed definition: " sexp))
		 ((get-dk sexp) builtin sexp id-n env store loc-n))
		(else (get-ek sexp) (ek (handle-expr-builtin))))))))
    (define (handle-combination output)
      (ek (if (and (pair? output) (eq? 'lambda (car output))
		   (null? (cadr output)) (null? (cdr sexp)))
	      ;; simplifies ((lambda () <expr>)) to <expr>
	      (caddr output)
	      (cons output (map expand-subexpr (cdr sexp))))))
    ;;(pretty-print `(expand-any/again ,sexp))
    (cond ((sid? sexp)
	   (let ((val (lookup2 sexp env store)))
	     (if (syntax? val)
		 ((get-sk sexp) val sexp store loc-n)
		 ((get-ek sexp) (if (code? val) (code-output val) val)))))
	  ((and (pair? sexp) (list? sexp))
	   (expand-any (car sexp) id-n env store loc-n #f
	     (and ek handle-combination) handle-syntax-use #f #f))
	  ((or (number? sexp) (boolean? sexp) (string? sexp) (char? sexp))
	   ((get-ek sexp) sexp))
	  (else (error (cond ((pair? sexp) "Improper list: ")
			     ((null? sexp) "Empty list: ")
			     ((vector? sexp) "Vector: ")
			     (else "Non-S-Expression: "))
		       sexp
		       " used as an expression, syntax, or definition.")))))

;; Expands an expression or syntax and returns (k val store loc-n).
(define (expand-val sexp id-n env store loc-n k)
  (expand-any sexp id-n env store loc-n #f
    (lambda (output) (k (make-code output) store loc-n))
    (lambda (syn error-sexp store loc-n) (k syn store loc-n))
    #f #f))

(define (expand-expr sexp id-n env store loc-n)
  (expand-any sexp id-n env store loc-n #f (lambda (x) x) #f #f #f))

;; args and return are as in expand-any.
(define (expand-body sexps id-n env store loc-n lsd? ek sk dk bk)
  ;; Expand-def expands a definition or begin sequence, adds entries
  ;; to the vds and sds lists of variable and syntax definitons, adds
  ;; entries to the exprs list of expressions from (define <expr>)
  ;; forms, extends env, and returns (k vds sds exprs id-n env store
  ;; loc-n).
  ;; If sexp is an expression, we just return (dek output) instead.
  (define (expand-def sexp vds sds exprs id-n env store loc-n k dek)
    (define (dk builtin sexp id-n env store loc-n)
      (or ek (eq? builtin 'define-syntax)
	  (error "Non-syntax definition in a syntax body: " sexp))
      (if (list2? sexp) ;; A (define <expression>) form.
	  (k vds sds (cons (cadr sexp) exprs) id-n env store loc-n)
          (let* ((sid (cadr sexp))
		 (id (sid-id sid))
		 (env (extend-env env id loc-n)))
	    (define (check def)
	      (if (eqv? id (sid-id (cadr def)))
		  (error "Duplicate internal definitions: "
			 def " and: " sexp)))
	    (begin
	      (for-each check sds)
	      (for-each check vds)
	      (case builtin
		((define-syntax)
		 (k vds (cons sexp sds) exprs id-n env store (+ loc-n 1)))
		((define)
		 (let* ((var (intloc->var loc-n sid))
			(store (extend-store store loc-n var))
			(loc-n (+ loc-n 1)))
		   (k (cons sexp vds) sds exprs id-n env store loc-n))))))))
    (define (bk sexp id-n env store loc-n)
      (let loop ((sexps (cdr sexp)) (vds vds) (sds sds) (exprs exprs)
		 (id-n id-n) (env env) (store store) (loc-n loc-n) (dek dek))
	(if (null? sexps)
	    (k vds sds exprs id-n env store loc-n)
	    (expand-def (car sexps) vds sds exprs id-n env store loc-n
	      (lambda (vds sds exprs id-n env store loc-n)
		(loop (cdr sexps) vds sds exprs id-n env store loc-n #f))
	      (and dek (lambda (out)
			 (define (expand-one sexp)
			   (expand-expr sexp id-n env store loc-n))
			 (let ((rest (map expand-one (cdr sexps))))
			   (dek (make-begin (cons out rest))))))))))
    (expand-any sexp id-n env store loc-n #f dek #f dk bk))
  (let loop ((first (car sexps)) (rest (cdr sexps))
	     (vds '()) (sds '()) (exprs '())
	     (id-n id-n) (env env) (store store) (loc-n loc-n))
    (define (finish-body boundary-exp-output)
      (expand-syntax-bindings (map cdr sds) id-n env env store loc-n
	(lambda (store loc-n)
	  (define (iexpand sexp) (expand-expr sexp id-n env store loc-n))
	  (define (expand-vd vd)
	    (list (lookup2 (cadr vd) env store) (iexpand (caddr vd))))
	  (if (and (null? rest) (null? vds) (null? exprs))
	      (expand-any first id-n env store loc-n lsd? ek sk dk bk)
	      (ek (make-letrec
		    (map expand-vd (reverse vds))
		    (let ((body-exprs-output
			   (if (null? rest)
			       (list (iexpand first))
			       (cons boundary-exp-output
				     (map iexpand rest)))))
		      (make-begin (append (map iexpand (reverse exprs))
					  body-exprs-output)))))))))
    (if (null? rest)
	(finish-body #f)
	(expand-def first vds sds exprs id-n env store loc-n
	  (lambda (vds sds exprs id-n env store loc-n)
	    (loop (car rest) (cdr rest) vds sds exprs id-n env store loc-n))
	  (and ek finish-body)))))


;; Returns (k outputs store loc-n).
(define (expand-top-level-sexps sexps store loc-n k)
  (define (finish store loc-n acc)
    (k (reverse acc) store loc-n))
  ;; expand adds stuff to acc and returns (k store loc-n acc)
  (let expand ((sexps sexps) (id-n 0) (env empty-env)
	       (store store) (loc-n loc-n) (acc '()) (k finish))
    (if (null? sexps)
	(k store loc-n acc)
	(let ((rest (cdr sexps)))
	  (define (ek output)
	    (expand rest id-n env store loc-n (cons output acc) k))
	  (define (dk builtin sexp id-n* env* store loc-n)
	    (if (list2? sexp) ;; A (define <expression>) form.
		(ek (expand-expr (cadr sexp) id-n* env* store loc-n))
	        (let* ((tail (cdr sexp))
		       (sid (car tail))
		       (loc (lookup-sid sid env*))
		       (init (cadr tail)))
		  (if (eq? builtin 'define)
		      (let* ((expr (expand-expr init id-n* env* store loc-n))
			     (var (loc->var loc sid))
			     (acc (cons (list 'define var expr) acc))
			     (store (substitute-in-store store loc var)))
			(expand rest id-n env store loc-n acc k))
		      (expand-val init id-n* env* store loc-n
			(lambda (val store loc-n)
			  (let ((store (substitute-in-store store loc val)))
			    (expand rest id-n env store loc-n acc k))))))))
	  (define (bk sexp id-n* env* store loc-n)
	    (expand (cdr sexp) id-n* env* store loc-n acc
		    (lambda (store loc-n acc)
		      (expand rest id-n env store loc-n acc k))))
	  (expand-any (car sexps) id-n env store loc-n #t ek #f dk bk)))))

;; Returns (k expanded-forms store loc-n).
(define (expand-top-level-forms forms store loc-n k)
  (define (finish outputs store loc-n)
    (define (finish1 output)
      ;; You can leave out the unrename-locals call if you want to.
      (symbolize (unrename-locals output)))
    (k (map finish1 outputs) store loc-n))
  (expand-top-level-sexps (wrap-vecs forms) store loc-n finish))

;; Compile-syntax-rules:
;; This doesn't actually compile, it just does verification.
;; Detects all possible errors:
;;   pattern literals list is not a list of identifiers
;;   ellipsis in literals list
;;   rule is not a two-element list
;;   missing pattern keyword (pattern is not a pair whose car is an identifier)
;;   duplicate pattern variable
;;   ellipsis not preceded by a pattern or template.
;;   list or vector pattern with multiple ellipses.
;;   improper list pattern with an ellipsis.
;;   variable instance in template not at sufficient ellipsis depth.
;;   template ellipsis closes no variables.
(define (compile-syntax-rules synrules env)
  (define ellipsis-id (and (pair? (cddr synrules))
			   (sid? (cadr synrules))
			   (sid-id (cadr synrules))))
  (define (ellipsis? x)
    (and (sid? x)
	 (if ellipsis-id
	     (eqv? ellipsis-id (sid-id x))
	     (eq? '... (lookup-sid x env)))))

  (define (check-lit lit)
    (or (sid? lit)
	(error "Non-id: " lit " in literals list of: " synrules))
    (if (ellipsis? lit)
	(error "Ellipsis " lit " in literals list of: " synrules)))

  (let* ((rest (if ellipsis-id (cddr synrules) (cdr synrules)))
	 (pat-literal-sids (car rest))
	 (rules (cdr rest))
	 (pat-literals
	  (begin (or (list? pat-literal-sids)
		     (error "Pattern literals list is not a list: "
			    pat-literal-sids))
		 (for-each check-lit pat-literal-sids)
		 (map sid-id pat-literal-sids))))

    (define (ellipsis-pair? x)
      (and (pair? x) (ellipsis? (car x))))

    (define (check-ellipses pat/tmpl in-template?)
      (define (bad-ellipsis x reason)
	(error (string-append reason ": ")
	       x
	       (if in-template? " in template: " " in pattern: ")
	       pat/tmpl))

      (define (multi-ellipsis-error x)
	(bad-ellipsis x "List or vector pattern with multiple ellipses"))

      (define (ellipsis/tail-error x)
	(bad-ellipsis x "Improper list pattern with an ellipsis"))

      (define (ellipsis-follows x thing)
	(bad-ellipsis x (string-append "Ellipsis following " thing)))
      
      (let ((x (if in-template? pat/tmpl (cdr pat/tmpl))))
	(if in-template?
	    (if (ellipsis? x)
		(ellipsis-follows x "nothing"))
	    (cond ((ellipsis? x)
		   (ellipsis-follows pat/tmpl "a '.'"))
		  ((ellipsis-pair? x)
		   (ellipsis-follows pat/tmpl "the pattern keyword"))))
	(let check ((x x))
	  (cond ((pair? x)
		 (if (ellipsis? (car x)) (ellipsis-follows x "a '('"))
		 (check (car x))
		 (if (ellipsis? (cdr x)) (ellipsis-follows x "a '.'"))
		 (if (ellipsis-pair? (cdr x))
		     (cond ((ellipsis? (cddr x))
			    (ellipsis-follows (cdr x) "a '.'"))
			   ((ellipsis-pair? (cddr x))
			    (ellipsis-follows (cdr x) "an ellipsis"))
			   (in-template? (check (cddr x)))
			   (else (or (list? x) (ellipsis/tail-error x))
				 (for-each (lambda (y)
					     (if (ellipsis? y)
						 (multi-ellipsis-error x))
					     (check y))
				  (cddr x))))
			
		     (check (cdr x))))
		((svector? x)
		 (let ((elts (svector->list x)))
		   (if (ellipsis-pair? elts)
		       (ellipsis-follows x "a '#('")
		       (check elts))))))))

    ;; Returns an alist: ((pat-var . depth) ...)
    (define (make-pat-env pat)
      (let collect ((x (cdr pat)) (depth 0) (l '()))
	(cond ((sid? x)
	       (let ((id (sid-id x)))
		 (cond ((memv id pat-literals) l)
		       ((assv id l)
			(error "Duplicate pattern var: " x
			       " in pattern: " pat))
		       (else (acons id depth l)))))
	      ((vector? x) (collect (svector->list x) depth l))
	      ((pair? x)
	       (if (ellipsis-pair? (cdr x))
		   (collect (car x) (+ 1 depth) (collect (cddr x) depth l))
		   (collect (car x) depth (collect (cdr x) depth l))))
	      (else l))))

    ;; Checks var depths.
    (define (check-var-depths tmpl pat-env)
      (define (depth-error x)
	(error "Pattern var used at bad depth: " x " in template: " tmpl))
      (define (close-error x)
	(error "Template ellipsis closes no variables: " x
	       " in template: " tmpl))
      ;; collect returns #t if any vars occurred at DEPTH
      (let collect ((x tmpl) (depth 0))
	(cond ((sid? x)
	       (let ((p (assv (sid-id x) pat-env)))
		 (and p
		      (let* ((pat-depth (cdr p))
			     (same-depth? (= depth pat-depth)))
			(if (and (positive? pat-depth) (not same-depth?))
			    (depth-error x))
			same-depth?))))
	      ((vector? x) (collect (svector->list x) depth))
	      ((pair? x)
	       (let* ((ellip? (ellipsis-pair? (cdr x)))
		      (car-closed? (collect (car x)
					    (if ellip? (+ 1 depth) depth)))
		      (cdr-closed? (collect ((if ellip? cddr cdr) x)
					    depth)))
		 (and ellip? (not car-closed?) (close-error x))
		 (or car-closed? cdr-closed?)))
	      (else #f))))

			 
    ;; Checks rule and returns a list of the template literal ids.
    (define (check-rule rule)
      (or (list2? rule) (error "Malformed syntax rule: " rule))
      (let ((pat (car rule)) (tmpl (cadr rule)))
	(or (and (pair? pat) (sid? (car pat)))
	    (error "Malformed pattern: " pat))
	(check-ellipses pat #f)
	(check-ellipses tmpl #t)
	(let ((pat-env (make-pat-env pat)))
	  (check-var-depths tmpl pat-env)
	  (let collect ((x tmpl) (lits '()))
	    (cond ((ellipsis? x) lits)
		  ((sid? x) (if (assv (sid-id x) pat-env)
				lits
				(cons (sid-id x) lits)))
		  ((vector? x) (collect (svector->list x) lits))
		  ((pair? x) (collect (car x) (collect (cdr x) lits)))
		  (else lits))))))

    ;; Reduce-env: this optional hack cuts down on the clutter when
    ;; manually examining the store.  Returns an environment with only
    ;; the bindings we need: those of pattern or template literals,
    ;; and those of identifiers named "..." that prevent a "..." from
    ;; being treated as an ellipsis, e.g. in
    ;; (let ((... 1)) ((syntax-rules () ((_) ...)))) => 1.
    (define (reduce-env lits)
      (define (list-dots-ids x ids)
	(cond ((sid? x) (if (eq? '... (sid-location x))
			    (cons (sid-id x) ids)
			    ids))
	      ((vector? x) (list-dots-ids (svector->list x) ids))
	      ((pair? x) (list-dots-ids (car x) (list-dots-ids (cdr x) ids)))
	      (else ids)))
      (let loop ((ids (if ellipsis-id lits (list-dots-ids rules lits)))
		 (reduced-env empty-env))
	(if (null? ids)
	    reduced-env
	    (loop (cdr ids)
		  (let ((id (car ids)))
		    (cond ((and (not (assv id reduced-env)) (assv id env))
			   => (lambda (binding) (cons binding reduced-env)))
			  (else reduced-env)))))))

    (let* ((lits (apply append pat-literals (map check-rule rules)))
	   (env (reduce-env lits)))
      (make-transformer synrules env))))


;; returns (k sexp id-n)
(define (apply-transformer transformer sexp id-n env k)
  (let* ((synrules (transformer-synrules transformer))
	 (mac-env (transformer-env transformer))
	 (ellipsis-id (and (sid? (cadr synrules))
			   (sid-id (cadr synrules))))
	 (rest (if ellipsis-id (cddr synrules) (cdr synrules)))
	 (pat-literals (map sid-id (car rest)))
	 (rules (cdr rest)))

    (define (pat-literal? id)     (memv id pat-literals))
    (define (not-pat-literal? id) (not (pat-literal? id)))
    (define (ellipsis-pair? x)    (and (pair? x) (ellipsis? (car x))))
    (define (ellipsis? x)
      (and (sid? x)
	   (if ellipsis-id
	       (eqv? ellipsis-id (sid-id x))
	       (eq? '... (lookup-sid x mac-env)))))

    ;; List-ids returns a list of the non-ellipsis ids in a
    ;; pattern or template for which (pred? id) is true.  If
    ;; include-scalars is false, we only include ids that are
    ;; within the scope of at least one ellipsis.
    (define (list-ids x include-scalars pred?)
      (let collect ((x x) (inc include-scalars) (l '()))
	(cond ((sid? x) (let ((id (sid-id x)))
			  (if (and inc (pred? id)) (cons id l) l)))
	      ((vector? x) (collect (svector->list x) inc l))
	      ((pair? x)
	       (if (ellipsis-pair? (cdr x))
		   (collect (car x) #t (collect (cddr x) inc l))
		   (collect (car x) inc (collect (cdr x) inc l))))
	      (else l))))
    
    
    (define (matches? pat)
      (let match ((pat pat) (sexp (cdr sexp)))
	(cond ((sid? pat)
	       (or (not (pat-literal? (sid-id pat)))
		   (and (sid? sexp)
			(eqv? (lookup-sid pat mac-env)
			      (lookup-sid sexp env)))))
	      ((svector? pat)
	       (and (svector? sexp)
		    (match (svector->list pat) (svector->list sexp))))
	      ((not (pair? pat)) (equal? pat sexp))
	      ((ellipsis-pair? (cdr pat))
	       (let skip ((p (cddr pat)) (s sexp))
		 (if (pair? p)
		     (and (pair? s) (skip (cdr p) (cdr s)))
		     (let match-cars ((sexp sexp) (s s))
		       (if (pair? s)
			   (and (match (car pat) (car sexp))
				(match-cars (cdr sexp) (cdr s)))
			   (match (cddr pat) sexp))))))
	      (else (and (pair? sexp)
			 (match (car pat) (car sexp))
			 (match (cdr pat) (cdr sexp)))))))

    ;; Returns an alist binding pattern variables to parts of the input.
    ;; An ellipsis variable is bound to a list (or a list of lists, etc.).
    (define (make-bindings pat)
      (let collect ((pat pat) (sexp (cdr sexp)) (bindings '()))
	(cond ((and (sid? pat) (not (pat-literal? (sid-id pat))))
	       (acons (sid-id pat) sexp bindings))
	      ((svector? pat)
	       (collect (svector->list pat) (svector->list sexp) bindings))
	      ((not (pair? pat)) bindings)
	      ((ellipsis-pair? (cdr pat))
	       (let* ((tail-len (length (cddr pat)))
		      (tail (list-tail sexp (- (length sexp) tail-len)))
		      (matches (reverse (list-tail (reverse sexp) tail-len)))
		      (vars (list-ids (car pat) #t not-pat-literal?)))
		 (define (collect1 match)
		   (map cdr (collect (car pat) match '())))
		 (append (apply map list vars (map collect1 matches))
			 (collect (cddr pat) tail bindings))))
	      (else (collect (car pat) (car sexp)
			     (collect (cdr pat) (cdr sexp) bindings))))))

    ;; Remove duplicates from a list, using eqv?.
    (define (remove-dups l)
      (let loop ((l l) (result '()))
	(if (null? l)
	    result
	    (loop (cdr l)
		  (let ((elt (car l)))
		    (if (memv elt result) result (cons elt result)))))))

    (define (expand-template pat tmpl top-bindings)
      (define tmpl-literals
	(remove-dups (list-ids tmpl #t
			       (lambda (id) (not (assv id top-bindings))))))
      (define ellipsis-vars (list-ids pat #f not-pat-literal?))
      (define (list-ellipsis-vars subtmpl)
	(list-ids subtmpl #t (lambda (id) (memv id ellipsis-vars))))
      (define (expand tmpl bindings)
	(let expand-part ((tmpl tmpl))
	  (cond
	   ((sid? tmpl)
	    (let ((id (sid-id tmpl)))
	      (cond ((assv id bindings) => cdr)
		    ((assv id top-bindings) => cdr)
		    (else
		     (let ((index (+ -1 (length (memv id tmpl-literals))))
			   (location (lookup-sid tmpl mac-env)))
		       (make-sid (sid-name tmpl) (+ id-n index) location))))))
	   ((vector? tmpl)
	    (list->svector (expand-part (svector->list tmpl))))
	   ((pair? tmpl)
	    (if (ellipsis-pair? (cdr tmpl))
		(let ((vars-to-iterate (list-ellipsis-vars (car tmpl))))
		  (define (lookup var) (cdr (assv var bindings)))
		  (define (expand-using-vals . vals)
		    (expand (car tmpl) (map cons vars-to-iterate vals)))
		  (let ((val-lists (map lookup vars-to-iterate)))
		    (if (or (null? (cdr val-lists))
			    (apply = (map length val-lists)))
			(append (apply map expand-using-vals val-lists)
				(expand-part (cddr tmpl)))
			(error "Unequal sequence lengths for pattern vars: "
			       vars-to-iterate " in macro call: " sexp))))
		(cons (expand-part (car tmpl)) (expand-part (cdr tmpl)))))
	   (else tmpl))))
      (k (expand tmpl top-bindings) (+ id-n (length tmpl-literals))))

    (let loop ((rules rules))
      (if (null? rules)
	  (error "No matching rule for macro use: " sexp)
	  (let* ((rule (car rules)) (pat (cdar rule)) (tmpl (cadr rule)))
	    (if (matches? pat)
		(expand-template pat tmpl (make-bindings pat))
		(loop (cdr rules))))))))

;; Unrename-locals: undoes most of the unnecessary renamings of local
;; variables.
;;
;; When the expander generates variables for lambdas and letrecs, it
;; generates variables with integer locations that are unique
;; throughout the region of the variable.  These numbers in effect
;; rename all the variables so that no variable ever shadows another.
;; This may be necessary if hygienic macro expansion caused some
;; variable named "foo" to be accessed from inside the region of
;; another binding named "foo".
;;
;; However, in most instances, this renaming is unnecessary.
;; Unrename-locals converts variables of the form #(foo n) to plain
;; #(foo) wherever this can be done.
;;
;; (This step is strictly optional.  It just makes the final expansion
;; more readable.)
(define (unrename-locals output)
  ;; Some operations on sets represented as lists with no duplicates.
  (define (subtract-lists a b) (a-minus-b-plus-c a b '()))
  (define (merge-lists a b) (a-minus-b-plus-c a b b))
  ;; a-minus-b-plus-c returns the union of (A - B) and C.
  ;; Assumes that (A - B) and C are disjoint.
  (define (a-minus-b-plus-c a b c)
    (if (null? a)
	c
	(let ((x (car a))
	      (y (a-minus-b-plus-c (cdr a) b c)))
	  (if (member x b) y (cons x y)))))

  ;; (a b . c) => (a b c)
  (define (flatten-dotted x)
    (if (pair? x) (cons (car x) (flatten-dotted (cdr x))) (list x)))

  (define (flatten-vars x) (if (list? x) x (flatten-dotted x)))

  ;; Compute-free-vars computes the free variables of an expression
  ;; and annotates all the local binding forms within the expression
  ;; with lists of their free variables.
  ;;
  ;; Specifically, (compute-free-vars expr k) returns (k free
  ;; annexpr), where FREE is a list of the variables that occur freely
  ;; in EXPR, and ANNEXPR is like EXPR, but with every (lambda formals
  ;; body) or (letrec bindings body) in EXPR replaced by (lambda free*
  ;; formals body) or (letrec free* formals body), where FREE* is a
  ;; list of the free variables of the lambda or letrec expression as
  ;; a whole (i.e., the free variables of the body and initializers,
  ;; minus any that are bound by the bindings or formals).  Example:

  ;; (compute-free-vars
  ;;   '(#(f 5) (lambda (#(a 7) #(b 8)) (#(g) #(a 7) #(b 2))))
  ;;   list)
  ;; => ((#(f 5) #(g) #(b 2))
  ;;     (#(f 5) (lambda (#(g) #(b 2)) (#(a 7) #(b 8)) (#(g) #(a 7) #(b 2)))))
  (define (compute-free-vars expr k)
    (cond ((var? expr)
	   (k (list expr) expr))
	  ((pair? expr)
	   (case (car expr)
	     ((quote) (k '() expr))
	     ((lambda)
	      (compute-free-vars
	       (cddr expr)
	       (lambda (free annexpr)
		 (let* ((vars (cadr expr))
			(free (subtract-lists free (flatten-vars vars))))
		   (k free `(lambda ,free ,vars . ,annexpr))))))
	     ((letrec)
	      (compute-free-vars
	       `(lambda ,(map car (cadr expr)) ,(cdr expr))
	       (lambda (free annexpr)
		 (k free `(letrec ,free . ,(cadddr annexpr))))))
	     (else (compute-free-vars
		    (car expr)
		    (lambda (free1 annexpr1)
		      (compute-free-vars
		       (cdr expr)
		       (lambda (free2 annexpr2)
			 (k (merge-lists free1 free2)
			    (cons annexpr1 annexpr2)))))))))
	  (else (k '() expr))))

  ;; Unrename: (unrename annexpr changes)
  ;;
  ;; The ANNEXPR argument must be annotated with free-variable lists
  ;; for all the lambdas and letrecs.  CHANGES is an alist of
  ;; unrenamings that we've made in the environment of ANNEXPR.  The
  ;; return value is a non-annotated expression with most of the local
  ;; variables unrenamed.
  ;;
  ;; When processing a lambda form and deciding whether to unrename
  ;; one of the variables that it binds, there are two kinds of
  ;; unrenamings we must avoid:
  ;;
  ;; 1. Avoid unrenamings that conflict with one of the free variables
  ;;    and thereby improperly shadow the binding to which the free
  ;;    variable is supposed to refer.  That is, don't convert (lambda
  ;;    (#(x 1)) #(x)) to (lambda (#(x)) #(x)).
  ;;
  ;; 2. Avoid unrenaming a variable to the same name as one of the
  ;;    other variables in the same set of bindings.  That is, even
  ;;    though converting (lambda (#(x 1) #(x 2)) 'foo) to (lambda
  ;;    (#(x) #(x)) 'foo) would not shadow any binding that is needed
  ;;    by the body, it would still cause an error.

  (define (unrename annexpr changes)
    (define (unrename-var var)
      (if (symbol? (var-loc var)) var (make-var1 (var-name var))))
    (cond ((var? annexpr)
	   (cond ((assoc annexpr changes) => cdr)
		 (else annexpr)))
	  ((pair? annexpr)
	   (case (car annexpr)
	     ((quote) annexpr)
	     ((lambda)
	      (let* ((vars (flatten-vars (caddr annexpr)))
		     (avoid (unrename (cadr annexpr) changes)))
		(let scan-vars ((vars vars) (avoid avoid) (changes changes))
		  (if (null? vars)
		      (cons 'lambda (unrename (cddr annexpr) changes))
		      (let* ((var (car vars))
			     (urvar (unrename-var var)))
			(if (member urvar avoid)
			    (scan-vars (cdr vars) (cons var avoid) changes)
			    (scan-vars (cdr vars)
				       (cons urvar avoid)
				       (acons var urvar changes))))))))
	     ((letrec)
	      (let ((foo `(lambda ,(cadr annexpr) ,(map car (caddr annexpr))
				  ,(cddr annexpr))))
		`(letrec . ,(caddr (unrename foo changes)))))
	     (else (cons (unrename (car annexpr) changes)
			 (unrename (cdr annexpr) changes)))))
	  (else annexpr)))
  
  (compute-free-vars output (lambda (free annexpr) (unrename annexpr '()))))

;; Some tests to exercise the unrenamer:
;;
;; (let-syntax ((foo (syntax-rules () ((foo) x)))) (lambda (x y) (foo) x y))
;; expands-to=> (lambda (_x_50 y) (begin x _x_50 y))
;; 
;; (let-syntax ((foo (syntax-rules () ((foo x) (lambda (x y) z))))) (foo y))
;; expands-to=> (lambda (y _y_51) z)
;; 
;; (let-syntax ((foo (syntax-rules () ((foo x) (lambda (y x) z))))) (foo y))
;; expands-to=> (lambda (y _y_51) z)


;; Symbolize uses var->symbol to convert all the variables in the
;; output from the expander into symbols.
(define (symbolize output)
  (cond ((var? output)
	 (var->symbol output))
	((pair? output)
	 (if (eq? 'quote (car output))
	     output
	     (cons (symbolize (car output))
		   (symbolize (cdr output)))))
	(else output)))

;; Var->symbol converts a variable to a symbol.
;;
;; Note that there are two parts to a variable (a name and a
;; location), and any two variables with the same location always have
;; the same name.  The location is either a symbol or an integer.  If
;; the location is a symbol, then the name is always the same symbol.
;; The variables are represented by one-element or two-element vectors
;; of the form #(symbolic-location) or #(name integer-location),
;; e.g. #(apple) or #(cherry 17).
;;
;; In other words, the location is what identifies a variable, and the
;; name is just additional information that was retained in order to
;; help us choose, for the final expansion, a symbol that bears some
;; relationship to the symbol that was used in the original code.
;;
;; The requirements for the var->symbol mapping are:
;;
;; 1. All variables must be mapped to distinct symbols.
;;
;; 2. No variable may be mapped to the name of a builtin.
;;
;; 3. Variables with symbolic locations that are the name of a
;;    standard procedure must be mapped to that name, i.e. #(CAR) must
;;    map to CAR.
;;
;; Desired additional properties are:
;;
;; 4. As many variables as possible should be simply mapped to their
;;    names.
;;
;; 5. Any variables not mapped to their names should at least be
;;    mapped to a symbol that includes the name as a substring of the
;;    chosen name.
;;
;; The scheme we use is to follow these rules:
;;
;;    1. #(foo number) => _foo_number
;;
;;    2. #(foo) => foo
;;       Except that:
;;          (a) if foo is a builtin; or
;;          (b) if foo starts with an underscore;
;;       then #(foo) => _foo_
;;
;; Without rule 2(a), we would violate requirement 2, and without rule
;; 2(b), we would violate requirement 1 (because #(foo 1) and
;; #(_foo_1) would both map to _foo_1).

(define (var->symbol var)
  (let* ((sym (var-name var))
	 (str (symbol->string sym))
	 (loc (var-loc var)))
    (if (number? loc)
	(let ((n (number->string loc)))
	  (string->symbol (string-append "_" str "_" n)))
	(if (case sym
	      ((begin define delay if lambda letrec quote set!) #t)
	      (else (and (positive? (string-length str))
			 (char=? #\_ (string-ref str 0)))))
	    (string->symbol (string-append "_" str "_"))
	    sym))))

(define builtins-store
  (let loop ((bs '(begin define define-syntax if lambda quote set! delay
			 let-syntax syntax-rules))
	     (store empty-store))
    (if (null? bs)
	store
	(loop (cdr bs)
	      (extend-store store (car bs) (make-builtin (car bs)))))))

;; null-prog is the preamble that defines all the standard macros that
;; are in the null-store.  (The "null-" name prefix was chosen to
;; correspond to the name of r5rs's null-environment procedure, even
;; though the null-store is far from empty.)
(define null-prog
  '((define-syntax letrec-syntax
      (let-syntax ((let-syntax let-syntax) (define-syntax define-syntax))
	(syntax-rules ()
	  ((_ ((kw init) ...) . body)
	   (let-syntax ()
	     (define-syntax kw init) ... (let-syntax () . body))))))
    (let-syntax ()
      (define-syntax multi-define
	(syntax-rules ()
	  ((_ definer (id ...) (init ...))
	   (begin (definer id init) ...))))
      ;; Define-protected-macros defines a set of macros with a
      ;; private set of bindings for some keywords and variables.  If
      ;; any of the keywords or variables are later redefined at
      ;; top-level, the macros will continue to work.  The first
      ;; argument to define-protected-macros is let-syntax or
      ;; letrec-syntax; if it is letrec-syntax, then the macros will
      ;; also have a private set of bindings for one another, and
      ;; recursive calls made by the macros to themselves or to one
      ;; another will not be affected by later top-level
      ;; redefinitions.
      ;;
      ;; The private binding for a saved variable is created by a
      ;; let-syntax, using a dummy syntax as the initializer.  We
      ;; later assign a value to it using a top-level define (and thus
      ;; change the status of the binding from keyword to variable).
      (define-syntax dummy (syntax-rules ()))
      (define-syntax define-protected-macros
	(syntax-rules (define-syntax)
	  ((_ let/letrec-syntax (saved-kw ...) (saved-var ...)
	      (define-syntax kw syntax) ...)
	   ((let-syntax ((saved-kw saved-kw) ... (saved-var dummy) ...)
	      (let/letrec-syntax ((kw syntax) ...)
		(syntax-rules ()
		  ((_ top-level-kws top-level-vars)
		   (begin
		     (multi-define define (saved-var ...) top-level-vars)
		     (multi-define define-syntax top-level-kws (kw ...)))))))
	    (kw ...) (saved-var ...)))))
      (begin
	;; Prototype-style define and lambda with internal definitions
	;; are implemented in define-protected-macros with let-syntax
	;; scope so that they can access the builtin define and lambda.
	(define-protected-macros let-syntax (lambda define let-syntax) ()
	  (define-syntax lambda
	    (syntax-rules ()
	      ((lambda args . body)
	       (lambda args (let-syntax () . body)))))
	  (define-syntax define
	    (syntax-rules ()
	      ((_ expr) (define expr))
	      ((_ (var . args) . body)
	       (define var (lambda args (let-syntax () . body))))
	      ((_ var init) (define var init))))
	  ;; We put letrec here so that it can use the builtin define,
	  ;; and won't accidentally allow things like:
	  ;; (letrec (((f) 1)) (f)) => 1
	  (define-syntax letrec
	    (syntax-rules ()
	      ((_ ((var init) ...) . body)
	       ;; The lambda ensures letrec is only used for expressions.
	       ((lambda ()
		  (let-syntax ()
		    (define var init) ... (let-syntax () . body))))))))
	(define-protected-macros letrec-syntax
	    (if lambda quote begin define letrec) (eqv?)
	  (define-syntax let
	    (syntax-rules ()
	      ((_ ((var init) ...) . body)
	       ((lambda (var ...) . body)
		init ...))
	      ((_ name ((var init) ...) . body)
	       ((letrec ((name (lambda (var ...) . body)))
		  name)
		init ...))))
	  (define-syntax let*
	    (syntax-rules ()
	      ((_ () . body) (let () . body))
	      ((let* ((var init) . bindings) . body)
	       (let ((var init)) (let* bindings . body)))))
	  (define-syntax do
	    (let-syntax ((do-step (syntax-rules () ((_ x) x) ((_ x y) y))))
	      (syntax-rules ()
		((_ ((var init step ...) ...)
		    (test expr ...)
		    command ...)
		 (let loop ((var init) ...)
		   (if test
		       (begin (if #f #f) expr ...)
		       (begin command ...
			      (loop (do-step var step ...) ...))))))))
	  (define-syntax case
	    (letrec-syntax
		((compare
		  (syntax-rules ()
		    ((_ key ()) #f)
		    ((_ key (datum . data))
		     (if (eqv? key 'datum) #t (compare key data)))))
		 (case
		  (syntax-rules (else)
		    ((case key) (if #f #f))
		    ((case key (else result1 . results))
		     (begin result1 . results))
		    ((case key ((datum ...) result1 . results) . clauses)
		     (if (compare key (datum ...))
			 (begin result1 . results)
			 (case key . clauses))))))
	      (syntax-rules ()
		((_ expr clause1 clause ...)
		 (let ((key expr))
		   (case key clause1 clause ...))))))
	  (define-syntax cond
	    (syntax-rules (else =>)
	      ((_) (if #f #f))
	      ((_ (else . exps)) (let () (begin . exps)))
	      ((_ (x) . rest) (or x (cond . rest)))
	      ((_ (x => proc) . rest)
	       (let ((tmp x)) (cond (tmp (proc tmp)) . rest)))
	      ((_ (x . exps) . rest)
	       (if x (begin . exps) (cond . rest)))))
	  (define-syntax and
	    (syntax-rules ()
	      ((_) #t)
	      ((_ test) (let () test))
	      ((_ test . tests) (if test (and . tests) #f))))
	  (define-syntax or
	    (syntax-rules ()
	      ((_) #f)
	      ((_ test) (let () test))
	      ((_ test . tests) (let ((x test)) (if x x (or . tests)))))))
	;; Quasiquote uses let-syntax scope so that it can recognize
	;; nested uses of itself using a syntax-rules literal (that
	;; is, the quasiquote binding that is visible in the
	;; environment of the quasiquote transformer must be the same
	;; binding that is visible where quasiquote is used).
	(define-protected-macros let-syntax
	    (lambda quote let) (cons append list vector list->vector map)
	  (define-syntax quasiquote
	    (let-syntax
		((tail-preserving-syntax-rules
		  (syntax-rules ()
		    ((tail-preserving-syntax-rules literals
			((subpattern ...) (subtemplate ...))
			...)
		     (syntax-rules literals
		       ((subpattern ... . tail) (subtemplate ... . tail))
		       ...)))))

	      (define-syntax qq
		(tail-preserving-syntax-rules
		    (unquote unquote-splicing quasiquote)
		  ((_ ,x        ())      (do-next x))
		  ((_ (,@@x . y) ())      (qq y () make-splice x))
		  ((_ `x         depth)  (qq x (depth) make-list 'quasiquote))
		  ((_ ,x        (depth)) (qq x  depth  make-list 'unquote))
		  ((_ (,x  . y) (depth)) (qq-nested-unquote (,x  . y) (depth)))
		  ((_ (,@@x . y) (depth)) (qq-nested-unquote (,@@x . y) (depth)))
		  ((_ ,@@x        depth)  (unquote-splicing-error ,@@x))
		  ((_ (x . y)    depth)  (qq x depth qq-cdr y depth make-pair))
		  ((_ #(x y ...) depth)  (qq (x) depth qq-cdr #(y ...) depth
					     make-vector-splice))
		  ((_ x          depth)  (do-next 'x))))

	      (define-syntax do-next
		(syntax-rules ()
		  ((_ expr original-template) expr)
		  ((_ expr next-macro . tail) (next-macro expr . tail))))

	      (define-syntax unquote-splicing-error
		(syntax-rules ()
		  ((_ ,@@x stack ... original-template)
		   (unquote-splicing-error (,@@x in original-template)))))
	      
	      (define-syntax qq-cdr
		(tail-preserving-syntax-rules ()
		  ((_ car cdr depth combiner) (qq cdr depth combiner car))))
	      
	      (define-syntax qq-nested-unquote
		(tail-preserving-syntax-rules ()
		  ((_ ((sym x) . y) (depth))
		   (qq (x) depth make-map sym qq-cdr y (depth) make-splice))))
	      
	      (define-syntax make-map
		(tail-preserving-syntax-rules (quote list map lambda)
		  ((_ '(x) sym) (do-next '((sym x))))
	          ((_ (list x) sym) (do-next (list (list 'sym x))))
		  ((_ (map (lambda (x) y) z) sym)
		   (do-next (map (lambda (x) (list 'sym y)) z)))
		  ((_ expr sym)
		   (do-next (map (lambda (x) (list 'sym x)) expr)))))
								     
	      (define-syntax make-pair
		(tail-preserving-syntax-rules (quote list)
		  ((_ 'y 'x) (do-next '(x . y)))
		  ((_ '() x) (do-next (list x)))
		  ((_ (list . elts) x) (do-next (list x . elts)))
		  ((_ y x) (do-next (cons x y)))))
						  
	      (define-syntax make-list
		(tail-preserving-syntax-rules (quote)
		  ((_ y x) (make-pair '() y make-pair x))))
							   
	      (define-syntax make-splice
		(tail-preserving-syntax-rules ()
		  ((_ '() x) (do-next x))
		  ((_ y x) (do-next (append x y)))))
						    
	      (define-syntax make-vector-splice
		(tail-preserving-syntax-rules (quote list vector list->vector)
		  ((_ '#(y ...) '(x))     (do-next '#(x y ...)))
		  ((_ '#(y ...) (list x)) (do-next (vector x 'y ...)))
		  ((_ '#()      x)        (do-next (list->vector x)))
		  ((_ '#(y ...) x)        (do-next (list->vector
						     (append x '(y ...)))))
		  ((_ y '(x))             (make-vector-splice y (list 'x)))
		  ((_ (vector y ...) (list x)) (do-next (vector x y ...)))
		  ((_ (vector y ...) x)   (do-next (list->vector
						     (append x (list y ...)))))
		  ((_ (list->vector y) (list x)) (do-next (list->vector
							    (cons x y))))
		  ((_ (list->vector y) x) (do-next (list->vector
						     (append x y))))))
							   
	      (syntax-rules ()
		((_ template) (let () (qq template () template)))))))))))

(define null-stuff (expand-top-level-forms null-prog builtins-store 0 list))
(define null-output (car null-stuff))
(define null-store  (cadr null-stuff))
(define null-loc-n  (caddr null-stuff))

(define (expand-program forms)
  (expand-top-level-forms forms null-store null-loc-n
    (lambda (outputs store loc-n) (append null-output outputs))))

;; an mstore is a mutable store.
(define (null-mstore) (cons null-store null-loc-n))

(define (expand-top-level-forms! forms mstore)
  (expand-top-level-forms forms (car mstore) (cdr mstore)
    (lambda (outputs store loc-n)
      (set-car! mstore store)
      (set-cdr! mstore loc-n)
      outputs)))

(define repl-mstore (null-mstore))

;; alexpander-repl: a read-expand-print loop.
;; If called with an argument, resumes a previous session.
;; Top-level vectors are interpreted as directives to the repl:
;;   #(show loc ...) shows values stored in the locations.
;;   #(dump) dumps the whole store.
;;   #(restart) restarts.

(define (alexpander-repl . resume?)
  (define (pp x) (pretty-print x))
  (define (restart)
    (set! repl-mstore (null-mstore))
    (for-each pp null-output))
  (define (repl)
    (display "expander> ")
    (let ((form (read)))
      (if (not (eof-object? form))
	  (begin
	    (if (vector? form)
		(let ((l (vector->list form)))
		  (case (car l)
		    ((dump) (pp (car repl-mstore)))
		    ((show)
		     (for-each (lambda (loc)
				 (pp (assv loc (car repl-mstore))))
			       (cdr l)))
		    ((restart) (restart))))
		(for-each pp (expand-top-level-forms! (list form)
						      repl-mstore)))
	    (repl)))))
  (begin
    (if (null? resume?) (restart))
    (repl)))

;; If you don't have a pretty-print, here's an unsatisfying substitute:
;;(define (pretty-print x) (write x) (newline))


;; If you want to target an even simpler output language, with no
;; LETREC, DELAY, or BEGIN, then one inefficient way to do so is to
;; use a second pass, like this:
(define (expand-program-to-simple forms)
  (define startup
    '(begin
       (define-syntax letrec
	 (syntax-rules ()
	   ((letrec ((var init) ...) expr)
	    (let ((var #f) ...)
	      (let ((var (let ((tmp init)) (lambda () (set! var tmp))))
		    ...
		    (thunk (lambda () expr)))
		(begin (var) ... (thunk)))))))
       (define-syntax delay
	 (syntax-rules ()
	   ((delay expr)
	    (let ((result #f) (thunk (lambda () expr)))
	      (lambda ()
		(if thunk (let ((x (thunk)))
			    (if thunk (begin (set! result x)
					     (set! thunk #f)))))
		result)))))
       (define (force x) (x))
       (define-syntax begin
	 (syntax-rules ()
	   ((begin x) x)
	   ((begin x . y)
	    ((lambda (ignore) (begin . y)) x))))))
  (expand-program (cons startup (expand-program forms))))


;; Rest of file is a junkyard of thoughts.

'
(begin
  (define (file->list file)
    (define (f) (let ((x (read))) (if (eof-object? x) '() (cons x (f)))))
    (with-input-from-file file f))

  (define (evali expr) (eval expr (interaction-environment)))

  (define (check-expander filename)
    (let* ((src (file->list filename))
	   (out1 (begin (for-each evali src) (expand-program src))))
      (begin (for-each evali out1) (equal? out1 (expand-program src)))))
)

;; r2rs-style currying define.
'(define-syntax define
   (let-syntax ((old-define define))
     (letrec-syntax
	 ((new-define
	   (syntax-rules ()
	     ((_ (var-or-prototype . args) . body)
	      (new-define var-or-prototype (lambda args . body)))
	     ((_ var expr) (old-define var expr)))))
       new-define)))

'(define-syntax define
   (let-syntax ((old-define define))
     (define-syntax new-define
       (syntax-rules ()
	 ((_ (var-or-prototype . args) . body)
	  (new-define var-or-prototype (lambda args . body)))
	 ((_ var expr) (old-define var expr))))
     new-define))

'(let ((multiplier 2))
   (define ((curried-* x) y) (* x y))
   (map (curried-* multiplier) '(3 4 5)))

;; Notes:

;; TODO:
;;
;; * fluid-let-syntax
;; * revamp error handling:
;;     add an error continuation to expand-top-level-forms.
;;     keep a backtrace.


;; Are these legal in r5rs?
;;   (let () (define if 1) (+ if) if) => 1
;;   (let () (define if 1) (set! if 2) if) => 2
;; The 2002 version of the expander didn't allow them.
;;
;; First solution to above problem didn't fix this:
;;   (let () (define if 1) ((let-syntax () if +)) if) => 1
;;
;; 2003-10-05:
;; New semantics:
;;
;;   (let ((a 1) (b 1))
;;     (define a 2)
;;     ((syntax-rules () ((_ m) (define (m) (list a b)))) m)
;;     (define b 2)
;;     (m))
;;   => (1 2)
;;
;;   (let ((a 1) (b 1))
;;     (define a 2)
;;     (define-syntax m (syntax-rules () ((_) (list a b))))
;;     (define b 2)
;;     (m))
;;   => (2 2)


;; Idea for syntax-rules extension to provide automatic gensym sequences:

;; (syntax-rules with-id-sequence ()
;;   ((letrec ((var init) ... (with-id-sequence temp)) . body)
;;    (let ((var 'undefined) ...)
;;      (let ((temp init) ...)
;;        (set! var temp) ... (let () . body)))))

;; (syntax-rules with-ids ()
;;   ((letrec-values (((var ... (with-ids tmp)) init) ... (with-ids thunk))
;;      . body)
;;    (let ()
;;      (begin (define var 'undefined) ...)
;;      ...
;;      (define thunk (call-with-values (lambda () init)
;; 		        (lambda (tmp ...) (lambda () #f (set! var tmp) ...))))
;;      ...
;;      (thunk) ... (let () . body))))

;; (syntax-rules with-ids ()
;;   ((set!-values (var ... (with-ids tmp)) expr)
;;    (call-with-values (lambda () expr)
;;      (lambda (tmp ...) (if #f #f) (set! var tmp) ...))))

;; (let ()
;;   (define n 0)
;;   (define (inc) (set! n (+ n 1)) n)
;;   (define-syntax x (inc))
;;   (begin x x x x x))
;; => 5

;; (let-syntax ((real-x #f)
;;              (real-set! set!))
;;   (begin
;;     (define real-x #f)
;;     (define-syntax x
;;       (begin (display "x accessed")
;;              real-x))
;;     (define-syntax set!
;;       (syntax-rules (x)
;;         ((set! x foo)
;;          (begin (display "x set")
;;                 (real-set! real-x foo)))
;;         ((set! . whatever)
;;          (real-set! . whatever))))))

;; At top-level, (define-identifier-syntax id arg ...)
;; is equivalent to chez's (define-syntax id (identifier-syntax id arg ...))
'
(define-syntax define-identifier-syntax
  (syntax-rules (set!)
    ((_ id e)
     (define-syntax id e))
    ((_ id (id* e1) ((set! id** pat) tmpl)) ;; id* and id** are ignored
     (begin
       (define-syntax id e1)
       (define-syntax set!
         (let-syntax ((real-set! set!))
           (syntax-rules (id)
             ((set! id pat) tmpl)
             ((set! . whatever)
              (real-set! . whatever)))))))))


;; Safe-letrec is a letrec that does its own run-time error-checking
;; for premature variable accesses.  It signals errors by calling
;; letrec-set!-error or letrec-access-error.
;; We're careful not to signal an error for cases like:
;; (call/cc (lambda (k) (letrec ((x (set! x (k 1)))) 2))) => 1
'(define-syntax safe-letrec
  (let-syntax ()
    (define-syntax safe-letrec-with-alt-names
      (syntax-rules ()
	((safe-letrec-with-alt-names (var* ...) ((var init) ...) . body)
	 (let ((var #f) ... (ready? #f))
	   (define (set-em! var* ...)
	     (set! var var*) ... (set! ready? #t))
	   (define (var* new-val)
	     (if ready? (set! var new-val) (letrec-set!-error 'var new-val)))
	   ...
	   (begin
	     (let-syntax ((var (if ready? var (letrec-access-error 'var))) ...)
	       (define-syntax new-set!
		 (let-syntax ((set! set!))
		   (syntax-rules no-ellipsis (var ...)
		     ((new-set! var x) (var* x)) ...
		     ((new-set! . other) (set! . other)))))
	       (fluid-let-syntax ((set! new-set!))
		 (set-em! init ...)))
	     (let () . body))))))
    (syntax-rules ()
      ((safe-letrec ((var init) ...) . body)
       ((syntax-rules no-ellipsis ()
	  ((_ . args) (safe-letrec-with-alt-names (var ...) . args)))
	((var init) ...) . body)))))

;; Similarly, an error-checking letrec*.
'(define-syntax safe-letrec*
  (let-syntax ()
    (define-syntax process-bindings
      (syntax-rules ()
	((process-bindings) #f)
	((process-bindings binding ... (var init))
	 (let ((ready? #f))
	   (define (finish val) (set! var val) (set! ready? #t))
	   (define (safe-setter new-val)
	     (if ready? (set! var new-val) (letrec-set!-error 'var new-val)))
	   (let-syntax ((var (if ready? var (letrec-access-error 'var))))
	     (define-syntax new-set!
	       (let-syntax ((set! set!))
		 (syntax-rules no-ellipsis (var)
		   ((new-set! var x) (safe-setter x))
		   ((new-set! . other) (set! . other)))))
	     (fluid-let-syntax ((set! new-set!))
	       (process-bindings binding ...)
	       (finish init)))))))
    (syntax-rules ()
      ((safe-letrec* ((var init) ...) . body)
       (let ((var #f) ...)
	 (process-bindings (var init) ...)
	 (let () . body))))))


;; If we wanted to simplify the primitive let-syntax by saying the
;; first argument must by (), then the full let-syntax could be
;; written this way:
'(define-syntax let-syntax
  (let-syntax ()
    (define-syntax original-let-syntax let-syntax)
    (define-syntax original-define-syntax define-syntax)
    (define-syntax original-syntax-rules syntax-rules)
    (define-syntax let-syntax-with-temps
      (syntax-rules ()
	((let-syntax-with-temps (temp ...) ((kw syn) ...) . body)
	 (original-let-syntax ()
	   (original-define-syntax temp syn) ...
	   (original-let-syntax ()
	     (original-define-syntax kw temp) ...
	     (original-let-syntax () . body))))))
    (syntax-rules ()
      ((let-syntax ((kw syn) ...) . body)
       ((original-syntax-rules no-ellipsis ()
	  ((_ . args) (let-syntax-with-temps (kw ...) . args)))
	((kw syn) ...) . body)))))


;; Example of how an error-checking letrec would be written if we
;; support an extra slot in keyword bindings such that if we bind a
;; keyword with (foo expr/syntax1 expr/syntax2) then the form (set!
;; foo datum ...) gets expanded as (expr/syntax2 datum ...).
'
(define-syntax letrec
  (syntax-rules ()
    ((_ ((var init) ...) . body)
     (let ((var #f) ... (ready? #f))
       (let-syntax
	   ((var (if ready? var (letrec-access-error 'var))
		 (syntax-rules ()
		   ((set!_var expr)
		    (let ((val expr))
		      (if ready?
			  (set! var val)
			  (letrec-set!-error 'var val))))))
	    ...)
	 (let ((var (let ((tmp init)) (lambda () (set! var tmp))))
	       ...)
	   (var) ... (set! ready? #t)))
       (let () . body)))))


;; Nested unquote-splicing:
;;
;; (define x '(a b c))
;; (define a 1) (define b 2) (define c 3)
;;
;; scheme:
;; ``(,,@@x)
;; expands=>   (list 'quasiquote (map (lambda (y) (list 'unquote y)) x))
;; evaluates=> `(,a ,b ,c)
;; expands=>   (list a b c)
;; evaluates=> (1 2 3)
;;
;; lisp:
;; ``(,,@@x)
;; expands=>   `(list ,@@x)
;; expands=>   (cons 'list x)
;; evaluates=> (list a b c)
;; evaluates=> (1 2 3)

;; ;; Ways to convert a program to an expression suitable for eval:
;; (expand-program-to-an-expression
;;   '((define x (- 1))
;;     (write x)
;;     (define f (lambda () (if (read) x (set! y 2))))
;;     (define y (f))
;;     (define - *)
;;     (write (+ (-) (-)))))
;; =>
;; ;; Simple answer requires knowing which top-level vars are in the
;; ;; standard environment:
;; ((lambda (x f y -)
;;      (begin (set! x (- 1))
;;             (write x)
;;             (set! f (lambda () (if (read) x (set! y 2))))
;;             (set! y (f))
;;             (set! - *)
;;             (write (+ (-) (-)))))
;;    #f #f #f -)
;; 
;; ;; More sophisticated version:
;; ((lambda (x f y - _x_setter _f_setter _y_setter _-_setter)
;;    ((lambda (_x_inner-setter _f_inner-setter _y_inner-setter _-_inner-setter)
;;       ((lambda (_x_definer _f_definer _y_definer _-_definer)
;;          (begin (_x_definer ((-) 1))
;;                 (write (x))
;;                 (_f_definer (lambda () (if (read) (x) (_y_setter 2))))
;;                 (_y_definer ((f)))
;;                 (_-_definer *)
;;                 (write (+ ((-)) ((-))))))
;;        (lambda (_) (begin (set! _x_setter _x_inner-setter) (_x_setter _)))
;;        (lambda (_) (begin (set! _f_setter _f_inner-setter) (_f_setter _)))
;;        (lambda (_) (begin (set! _y_setter _y_inner-setter) (_y_setter _)))
;;        (lambda (_) (begin (set! _-_setter _-_inner-setter) (_-_setter _)))))
;;     (lambda (_) (set! x (lambda () _)))
;;     (lambda (_) (set! f (lambda () _)))
;;     (lambda (_) (set! y (lambda () _)))
;;     (lambda (_) (set! - (lambda () _)))))
;;  (lambda () x) (lambda () f) (lambda () y) (lambda () -)
;;  (lambda (_) (set! x (lambda () _)))
;;  (lambda (_) (set! f (lambda () _)))
;;  (lambda (_) (set! y (lambda () _)))
;;  (lambda (_) (set! - (lambda () _))))
@


1.64
log
@Fixed copyright notice (added 2006).
Minor cleanup in expand-body.
@
text
@d2 1
a2 1
;; $Id: alexpander.scm,v 1.63 2006/05/28 03:42:52 al Exp al $
d4 1
a4 1
;; Copyright 2002-2004,2006 Al Petrofsky <alexpander@@petrofsky.org>
d6 1
a6 11
;; You may redistribute and/or modify this software under the terms of
;; the GNU General Public License as published by the Free Software
;; Foundation (fsf.org); either version 2, or (at your option) any
;; later version.

;; You should have received a copy of the GNU General Public License
;; along with this program; if not, see
;; http://www.fsf.org/licenses/gpl.txt, or write to the Free Software
;; Foundation, 59 Temple Pl Ste 330, Boston MA 02111, U.S.A..

;; Feel free to ask me for different licensing terms. 
d8 33
d42 1
a42 1
;; INTRO:
d62 12
d181 45
d228 7
a234 6
;; At top level, if a macro block (a let-syntax or letrec-syntax form)
;; has only one body element, that element need not be an expression
;; (as would be required in r5rs).  Instead, it may be anything
;; allowed at top level: an expression, a definition, a begin sequence
;; of top-level forms, or another macro block containing a top-level
;; form.
d264 25
d341 7
a347 7
;; define-values-temp in the output does not create a binding, it
;; mutates the top-level binding of define-values-temp.  Thus, all
;; top-level uses of define-values share a single temp variable.  For
;; internal-definition-level uses of define-values, a single shared
;; temp would not be sufficient, but things work out okay because
;; hygienic renaming causes each such use to create a distinct temp
;; variable.
a364 70
;; Internal syntax definitions.

;; Internal syntax definitions are supported wherever they would make
;; sense (see the BNF) and have the letrec-syntax semantics you would
;; expect.  It is legal for the initializer of an internal variable
;; definition to use one of the internal syntax definitions in the
;; same body:

;; (let ()
;;   (define x (y))
;;   (define-syntax y (syntax-rules () ((y) 1)))
;;   x)
;; => 1

;; It's also legal for internal syntax definitions to be mutually
;; recursive transformers, but it is an error for the expansion of a
;; syntax definition's initializer to require the result of another
;; initializer:

;; (let ()
;;   (define-syntax m1 (syntax-rules () ((m1) #f) ((m1 . args) (m2 . args))))
;;   (define-syntax m2 (syntax-rules () ((m2 arg . args) (m1 . args))))
;;   (m1 foo bar baz))
;; => #f

;; (let ()
;;   (define-syntax simple-transformer
;;     (syntax-rules ()
;;       ((simple-transformer pattern template)
;;        (syntax-rules () (pattern template)))))
;;   (define-syntax m (simple-transformer (m x) (- x)))
;;   (m 1))
;; => error ("Premature use of keyword bound by an internal define-syntax")

;; (let ()
;;   (define-syntax simple-transformer
;;     (syntax-rules ()
;;       ((simple-transformer pattern template)
;;        (syntax-rules () (pattern template)))))
;;   (let ()
;;     (define-syntax m (simple-transformer (m x) (- x)))
;;     (m 1)))
;; => -1


;; Syntax-rules ellipsis

;; Per SRFI-46, syntax-rules transformers can specify the
;; identifier to be used as the ellipsis (such a specification is
;; treated as a hygienic binding), and a list pattern may contain
;; subpatterns after an ellipsis as well as before it:

;;   <transformer spec> ---> (syntax-rules (<identifier>*) <syntax rule>*)
;;              | (syntax-rules <ellipsis> (<identifier>*) <syntax rule>*)
;;   
;;   <syntax rule> ---> (<pattern> <template>)
;;   
;;   <pattern> ---> <pattern identifier>
;;                | (<pattern>*)
;;                | (<pattern>+ . <pattern>)
;;                | (<pattern>* <pattern> <ellipsis> <pattern>*)
;;                | #(<pattern>*)
;;                | #(<pattern>* <pattern> <ellipsis> <pattern>*)
;;                | <pattern datum>
;;   
;;   <pattern identifier> ---> <identifier>
;;   
;;   <ellipsis> ---> <identifier>


d386 1
a386 1
;; that immediately preceeded the comma at-sign is also removed and is
d410 2
a411 2
;;      This starts a read-expand-print-loop.  Type in a program
;;      and see its expansion as you go.
d418 5
a422 5
;;      Returns some macro-expanded forms and side-effects mstore.
;;      First create an initial mutable store with (null-mstore), then
;;      you can pass a program in piecemeal, with the effects of
;;      top-level define-syntaxes saved in mstore between calls to
;;      expand-top-level-forms!.
d426 1
a426 1
;;      Returns by making a tail call to k:
d440 1
a440 1
;; begin, define, delay, if, lambda, letrec, quote, and set!.
d444 11
a454 8
;; <variable> <expression>) form.  Any uses or definitions in the
;; original program of a top-level variable whose name begins with
;; "_", or whose name is one of the eight primitives just mentioned,
;; will be renamed.  This will only cause a problem if the program is
;; trying to use some nonstandard library variable that starts with
;; "_": any r5rs-conformant program will be translated to an
;; equivalent macro-free r5rs program, it just might have some of its
;; top-level variable names changed.
d544 6
a549 5
;; environment with no binding for it, then the location to which the
;; template literal in the macro was bound is used instead (to be
;; prepared for such a contingency, this location is stored along with
;; the numeric id in the "renamed-sid" (see below) that a macro
;; expansion inserts into the code).
d579 2
a580 2
;; variable: symbol  ; the symbol that is used in the output, e.g. _foo_42.
;; code: (output) ; output is the finished code for an expression.
d582 1
a582 1
;; builtin: (BUILTIN name)
d597 6
a602 3
;; In contrast, a variable named OUTPUT is a bit of finished code, in
;; which vectors represent themselves and all renamed identifiers have
;; been mapped to suitable symbols.
d641 1
a641 1
;; (expand-top-level-forms forms store loc-n k)
d699 1
a699 1
(define (make-builtin name) (list 'builtin name))
d702 1
a702 1
(define (variable? val) (symbol? val))
d706 1
a706 1
(define (syntax? val) (list2? val))
d708 2
a709 2
(define (builtin? syntax) (eq? 'builtin (car syntax)))
(define (builtin-name builtin) (cadr builtin))
d733 1
a733 1
;;   1. For a top-level (named) location, return a top-level variable name.
d771 9
a779 2
;; Top-level variables must be renamed if they conflict with the
;; primitives or local variable names we use in the output.
d781 2
a782 13
  (define str (symbol->string sym))
  (define (rename) (string->symbol (string-append "_" str "_")))
  (case sym
    ((begin define delay if lambda letrec quote set!) (rename))
    (else (if (and (positive? (string-length str))
		   (char=? #\_ (string-ref str 0)))
	      (rename)
	      sym))))

;; intloc->var:
;; A simple (string->symbol (string-append "_" (number->string intloc)))
;; would work, but we use more verbose local variable names to make
;; the output more decipherable to humans.
d784 1
a784 2
  (let ((str (symbol->string (sid-name sid))))
    (string->symbol (string-append "_" str "_" (number->string intloc)))))
d794 3
d929 1
a929 1
			   (or (variable? var)
a1043 2
	  (define (make-letrec bindings expr)
	    (if (null? bindings) expr (list 'letrec bindings expr)))
d1063 3
a1065 3
;; (returns (k outputs store loc-n))
(define (expand-top-level-forms forms store loc-n k)
  (define (finalize store loc-n acc)
d1068 2
a1069 2
  (let expand ((sexps (wrap-vecs forms)) (id-n 0) (env empty-env)
	       (store store) (loc-n loc-n) (acc '()) (k finalize))
d1098 9
d1426 223
d1804 1
a1804 1
		    ((_ literals
a1917 1
  ;;(define (pp x) (write x) (newline))
d1943 35
a1980 1

d1987 2
d1991 3
a1993 2
	   (out1 (begin (for-each eval src) (expand-program src))))
      (begin (for-each eval out1) (equal? out1 (expand-program src))))))
d2188 1
a2188 1
	((_ (temp ...) ((kw syn) ...) . body)
d2195 1
a2195 1
      ((_ ((kw syn) ...) . body)
@


1.63
log
@Documentation: changed "draft SRFI-46" to "SRFI-46".  (It was
finalized in 2005.)
@
text
@d2 1
a2 1
;; $Id: alexpander.scm,v 1.62 2006/05/28 00:57:55 al Exp al $
d4 1
a4 1
;; Copyright 2002-2004 Al Petrofsky <alexpander@@petrofsky.org>
d955 2
a956 2
  ;; If sexp is an expression, we just return (ek output) instead.
  (define (expand-def sexp vds sds exprs id-n env store loc-n k ek)
d958 2
d961 1
a961 3
	  (if exprs
	      (k vds sds (cons (cadr sexp) exprs) id-n env store loc-n)
	      (error "Non-syntax definition in a syntax body: " sexp))
a975 2
		 (or exprs
		     (error "Variable definition in a syntax body: " sexp))
d982 1
a982 1
		 (id-n id-n) (env env) (store store) (loc-n loc-n) (ek ek))
d988 6
a993 6
	      (and ek (lambda (out)
			(define (expand-one sexp)
			  (expand-expr sexp id-n env store loc-n))
			(let ((rest (map expand-one (cdr sexps))))
			  (ek (make-begin (cons out rest))))))))))
    (expand-any sexp id-n env store loc-n #f ek #f dk bk))
d995 1
a995 1
	     (vds '()) (sds '()) (exprs (and ek '()))
d1005 1
a1005 1
	  (if (and (null? rest) (null? vds) (not (pair? exprs)))
d1009 5
a1013 5
		    (let* ((body-exprs-output
			    (if (null? rest)
				(list (iexpand first))
				(cons boundary-exp-output
				      (map iexpand rest)))))
a1715 1
;; * allow expressions among internal definitions.
@


1.62
log
@Fixed a remaining bug in the BEGIN handling of EXPAND-ANY: if a BEGIN
is used in an expansion context that does not allow a BEGIN, then we
now explicitly signal an appropriate error, rather than blowing up by
attempting to call EK when EK is #f.

  (let-syntax () (begin (begin) ((begin foo))) bar)

  => ERROR: Begin used in bad context:  (begin foo)
@
text
@d2 1
a2 1
;; $Id: alexpander.scm,v 1.61 2006/05/24 00:54:56 al Exp al $
d306 1
a306 1
;; Per draft SRFI-46, syntax-rules transformers can specify the
@


1.61
log
@One-line bug fix for handling of BEGIN expressions.  The ek argument
was not being used.  This bug was introduced in rev. 1.54.  It was
reported by Göran Weinholt <goran@@weinholt.se>.
@
text
@d2 1
a2 1
;; $Id: alexpander.scm,v 1.60 2006/05/24 00:54:01 al Exp al $
d848 1
d904 1
d913 1
a913 1
		(else ((get-ek sexp) (handle-expr-builtin))))))))
@


1.60
log
@One-line bug fix for redefinitions within a top-level let-syntax.  The
identifier being defined was not being looked up in the local
environment.

  (expand-top-level-forms!
    '((let-syntax ((x 1))
        (define-syntax x 2))
      x)
    (null-mstore))
  => (x), not (2)

This bug had existed since support for redefinitions within a
top-level let-syntax was added in rev. 1.53.
@
text
@d2 1
a2 1
;; $Id$
d905 1
a905 1
		       (else (make-begin (map expand-subexpr tail)))))
@


1.59
log
@Letrec no longer accidentally allows (letrec (((f) 1)) (f)) => 1
Several minor documentation improvements.
@
text
@d2 1
a2 1
;; $Id: alexpander.scm,v 1.58 2004/10/29 00:41:35 al Exp al $
d1041 1
a1041 1
		       (loc (sid-location sid))
@


1.58
log
@Added support for (define <expression>)
@
text
@d2 1
a2 1
;; $Id: alexpander.scm,v 1.57 2004/10/29 00:37:04 al Exp al $
d47 1
d52 1
d56 3
a58 2
;;   <syntax spec> --> (<keyword> <syntax or expression>)
;;   <syntax or expression> --> <syntax> | <expression>
d60 1
d67 1
d74 10
a83 5
;;   <syntax> --> <transformer spec>
;;              | <keyword>
;;              | <macro use>
;;              | <syntax macro block>
;;   <syntax macro block> --> (<syntax-only block stuff> <syntax>)
d85 2
a86 1
;;       --> (<syntax-only block stuff> <command or definition>)
d89 1
d92 1
d126 3
a128 2
;;     ((_ ((var init) ...) . body)
;;      ((lambda (var ...) . body) init ...)))
d155 5
a159 3
;; (let-syntax ((- quote))
;;   (define x (- 1)))
;; (list x (- 1)) => (1 -1)
a166 1
;; (begin
d168 1
d171 2
a172 3
;;     'blah)
;;   x)
;; => 1, in r5rs and alexpander, but 2 in Chez scheme
a173 1
;; (begin
d175 1
d177 4
a180 4
;;     (begin (define x 2)
;;            'blah))
;;   x)
;; => 2, in alexpander and in Chez scheme, but an error in r5rs.
d540 1
a540 1
;; code: (output) ; the finished code for an expression.
d817 2
a818 2
;;   subsequently misued.  It is the sid that was bound to the syntax,
;;   unless the syntax is an anonymous transformer, as in
d924 1
a924 2
	  ((null? sexp) (error "Null used as an expression or syntax: " sexp))
	  ((list? sexp)
d930 1
d1445 11
a1455 1
	      ((_ var init) (define var init)))))
d1457 1
a1457 1
	    (if lambda quote begin define) (eqv?)
a1471 4
	  (define-syntax letrec
	    (syntax-rules ()
	      ((_ ((var init) ...) . body)
	       (let () (define var init) ... (let () . body))))) 
d1937 44
@


1.57
log
@Fixed bug in make-vector-splice that was breaking `#(,@@x)
@
text
@d2 1
a2 1
;; $Id: alexpander.scm,v 1.56 2004/10/28 11:12:33 al Exp al $
d59 1
d106 2
a107 2
;;  (let-syntax ((foo (let-syntax ((bar (syntax-rules () ((_ x) (- x)))))
;;                      (syntax-rules () ((_) (bar 2))))))
d168 76
d292 3
a294 2
;; identifier to be used as the ellipsis, and a list pattern may
;; contain subpatterns after an ellipsis as well as before it:
d316 1
a316 1
;; We also extend quasiquote to make commas and comma-ats distributive
d323 1
a323 1
;;                               | (unquote-splicing <qq template 0)
d326 2
a328 1
;;                               | ,<splicing unquotaion D-1>
a329 1
;;                               | ,@@<splicing unquotaion D-1>
d893 1
d934 6
a939 4
  ;; to the vds and sds lists of variable and syntax definitons,
  ;; extends env, and returns (k vds sds id-n env store loc-n).  If an
  ;; expression is encountered, returns (ek output) instead.
  (define (expand-def sexp vds sds id-n env store loc-n k ek)
d941 24
a964 16
      (let* ((sid (cadr sexp))
	     (id (sid-id sid))
	     (env (extend-env env id loc-n)))
	(define (check def)
	  (if (eqv? id (sid-id (cadr def)))
	      (error "Duplicate internal definitions: " def " and: " sexp)))
	(begin
	  (for-each check sds)
	  (if vds (for-each check vds))
	  (case builtin
	    ((define-syntax)
	     (k vds (cons sexp sds) id-n env store (+ loc-n 1)))
	    ((define)
	     (or vds (error "Variable definition in a syntax body: " sexp))
	     (let ((store (extend-store store loc-n (intloc->var loc-n sid))))
	       (k (cons sexp vds) sds id-n env store (+ loc-n 1))))))))
d966 2
a967 2
      (let loop ((sexps (cdr sexp)) (vds vds) (sds sds) (id-n id-n)
		 (env env) (store store) (loc-n loc-n) (ek ek))
d969 4
a972 4
	    (k vds sds id-n env store loc-n)
	    (expand-def (car sexps) vds sds id-n env store loc-n
	      (lambda (vds sds id-n env store loc-n)
		(loop (cdr sexps) vds sds id-n env store loc-n #f))
d980 2
a981 2
	     (vds (and ek '())) (sds '()) (id-n id-n)
	     (env env) (store store) (loc-n loc-n))
d990 1
a990 1
	  (if (and (null? rest) (not (pair? vds)))
d993 8
a1000 5
		   (map expand-vd (reverse vds))
		   (if (null? rest)
		       (iexpand first)
		       (make-begin (cons boundary-exp-output
					 (map iexpand rest))))))))))
d1003 3
a1005 3
	(expand-def first vds sds id-n env store loc-n
	  (lambda (vds sds id-n env store loc-n)
	    (loop (car rest) (cdr rest) vds sds id-n env store loc-n))
d1022 16
a1037 14
	    (let* ((tail (cdr sexp))
		   (sid (car tail))
		   (loc (sid-location sid))
		   (init (cadr tail)))
	      (if (eq? builtin 'define)
		  (let* ((expr (expand-expr init id-n* env* store loc-n))
			 (var (loc->var loc sid))
			 (acc (cons (list 'define var expr) acc))
			 (store (substitute-in-store store loc var)))
		    (expand rest id-n env store loc-n acc k))
		  (expand-val init id-n* env* store loc-n
		    (lambda (val store loc-n)
		      (let ((store (substitute-in-store store loc val)))
			(expand rest id-n env store loc-n acc k)))))))
d1427 1
d1626 2
a1627 3
  (define (pp x)
    ;;(write x) (newline)    
    (pretty-print x))
a1896 23

;; ;; idea to allow body expressions among internal definitions.
;; (let ()
;;   (define x (f))
;;   (define (g))
;;   (define y (h))
;;   (define (i))
;;   (begin (j) (k)))
;; ==
;; (let ()
;;   (define x (f))
;;   (define y (h))
;;   (begin (g) (i) (j) (k)))

;; ;; This would work at top-level and among internal definitions.
;; (define-syntax define-values
;;   (let-syntax ((vals (syntax-rules ())))
;;     (syntax-rules ()
;;       ((define-values (var ...) init)
;;        (begin
;;          (define vals (call-with-values init list))
;;          (define var #f) ...
;;          (define (set!-values (var ...) (apply values vals))))))))
@


1.56
log
@Fixed bug in expand-def's handling of BEGIN among internal
definitions.
@
text
@d2 1
a2 1
;; $Id: alexpander.scm,v 1.55 2004/10/28 09:43:14 al Exp al $
d1435 2
a1436 2
		  ((_ #(x y ...) depth)
		   (qq (x) depth qq-cdr #(y ...) depth make-vector-splice))
d1460 1
a1461 1
		  ((_ '(x) sym) (do-next '((sym x))))
d1485 1
a1485 1
		  ((_ '#(y ...) '(x)) (do-next '#(x y ...)))
d1487 4
a1490 4
		  ((_ '#()      x) (list->vector x))
		  ((_ '#(y ...) x)
		   (do-next (list->vector (append x '(y ...)))))
		  ((_ y '(x)) (make-vector-splice y (list 'x)))
d1492 6
a1497 6
		  ((_ (vector y ...) x)
		   (do-next (list->vector (append x (list y ...)))))
		  ((_ (list->vector y) (list x))
		   (do-next (list->vector (cons x y))))
		  ((_ (list->vector y) x)
		   (do-next (list->vector (append x y))))))
@


1.55
log
@* Extensive improvements to comments, including new EXTENSIONS section.
* Added make-vector-splice to quasiquote.  Now catches more errors.
  and doesn't do `#(unquote '(1)) => #(1)
* fixed bug in reduce-env.
@
text
@d2 1
a2 1
;; $Id: alexpander.scm,v 1.54 2003/11/16 02:27:39 al Exp al $
d882 2
a883 2
	      (lambda (id-n store loc-n vds sds)
		(loop (cdr sexps) id-n store loc-n vds sds #f))
@


1.54
log
@Added support for keywords bound to expressions, e.g.:

  (let ((n 0))
    (define (inc) (set! n (+ n 1)) n)
    (define-syntax x (inc))
    (begin x x x))
  => 3

  ;; At top-level, (define-identifier-syntax id arg ...)
  ;; is equivalent to chez's (define-syntax id (identifier-syntax id arg ...))

  (define-syntax define-identifier-syntax
    (syntax-rules (set!)
      ((_ id e)
       (define-syntax id e))
      ((_ id (id* e1) ((set! id** pat) tmpl)) ;; id* and id** are ignored
       (begin
	 (define-syntax id e1)
	 (define-syntax set!
	   (let-syntax ((real-set! set!))
	     (syntax-rules (id)
	       ((set! id pat) tmpl)
	       ((set! . whatever)
		(real-set! . whatever)))))))))

  (define real-x 0)
  (define x-accs 0)
  (define x-sets 0)
  (define (acc-x)   (set! x-accs (+ 1 x-accs)) real-x)
  (define (set-x y) (set! x-sets (+ 1 x-sets)) real-x)

  (define-identifier-syntax x
    (x (acc-x))
    ((set! x e) (set-x e)))

  (begin x
         (set! x (+ x 1))
	 (list x-accs x-sets))
  => (2 1)

Any context that used to require a syntax now accepts a syntax or an
expression.

Changed format of store "vals" to support this.

Made transformer vals more readable: they are now simply (synrules
env), where synrules is the whole syntax-rules form as it occurred in
the program.

Still need to work out a sensible nomenclature for everything.

Added expand-val.
@
text
@d2 1
a2 1
;; $Id: alexpander.scm,v 1.53 2003/11/15 17:40:54 al Exp al $
d4 1
a4 1
;; Copyright 2002, 2003 Al Petrofsky <alexpander@@petrofsky.org>
d36 6
d47 5
a51 2
;;   <syntax spec> --> (<keyword> <syntax>)
;;   <syntax definition> ---> (define-syntax <keyword> <syntax>)
d53 3
d60 1
d62 4
d72 58
a129 3
;;   <syntax macro block> --> (let-syntax    (<syntax spec>*) <syntax body>)
;;                          | (letrec-syntax (<syntax spec>*) <syntax body>)
;;   <syntax body> ---> <syntax definition>* <syntax>
d131 1
d133 84
a216 3
;; Also, syntax-rules transformers can specify the identifier to be
;; used as the ellipsis, and a list pattern may contain subpatterns
;; after an ellipsis as well as before it:
d236 40
d312 1
a312 1
;; Furthermore, begin is only used for expressions, lambdas and
d314 1
a314 1
;; definitions, and defines are always of the simple (define
d354 1
a354 1
;; evaluation completes, but environments are immutable.  The static
d374 20
a393 18
;; syntax (a builtin or a macro transformer) or a variable name.  When
;; we encounter a use of an identifier, we go through the environment
;; and the store to fetch its value.  If the value is a variable name,
;; we emit that variable name.  If the value is a syntax, we proceed
;; according to the rules of that syntax.  As in the runtime system,
;; environments are immutable and the static top-level environment is
;; infinite.  Environments may be locally extended by LAMBDA or
;; internal DEFINE to map some identifiers to new locations that hold
;; variable names.  Environments may also be extended by LET-SYNTAX to
;; map some identifiers to new locations that initially hold the
;; syntaxes resulting from the expansion of the initializers.  Lastly,
;; environments may be extended by LETREC-SYNTAX or internal
;; DEFINE-SYNTAX to map some identifiers to new locations that are
;; empty and illegal to access until the expansion of their
;; initializers has completed (at which time the resulting syntaxes
;; are stored into the locations).  The store is modified by top-level
;; DEFINE and DEFINE-SYNTAX, and when a set of internal DEFINE-SYNTAX
;; initializers' expansion completes.  The store is not altered by a
d402 4
a405 4
;; the eleven builtins (BEGIN DEFINE DEFINE-SYNTAX IF LAMBDA QUOTE
;; SET! DELAY LET-SYNTAX LETREC-SYNTAX SYNTAX-RULES) hold as their
;; values those builtin syntaxes.  All other names are bound to
;; locations that hold the corresponding top-level variable name.
d437 2
a438 2
;; lambda, let-syntax, letrec-syntax, and internal definitions) are
;; represented by integers.
d476 2
a477 2
;; renamed-sid: #(original-id renamed-id local-location)
;;            | #(original-id renamed-id)
d496 1
a496 1
;; (compile-syntax-rules env ellipsis pat-literals rules) => transformer
a502 1
;; (expand-syntax sexp id-n env store loc-n k) => (k syntax store loc-n)
d504 1
d513 4
a516 5
(define (id? x)           (or (symbol? x) (number? x)))
(define (sid? s)          (or (symbol? s) (renamed-sid? s)))
(define (renamed-sid? s)  (and (vector? s) (< 1 (vector-length s))))
(define (svector? s)      (and (vector? s) (= 1 (vector-length s))))
(define (svector->list s) (vector-ref s 0))
d529 2
a530 2
(define (list1? s) (and (pair? s) (null?  (cdr s))))
(define (list2? s) (and (pair? s) (list1? (cdr s))))
d560 1
a560 1
;; vals are variables, syntaxes
d647 1
a647 1
;; make-local-var:
d763 3
a765 2
	      (define (handle-let-syntax)
		(or ek sk lsd? (error "let-syntax used in bad context: " sexp))
d767 1
a767 1
		(let ((bindings (car tail)))
d776 1
a776 1
			    (expand-body (cdr tail) id-n ienv store loc-n
d804 1
a804 1
		((let-syntax) (handle-let-syntax))
d1107 3
a1109 3
    ;; examining the store.  Returns an environment with only the
    ;; bindings we need: those of pattern or template literals, and
    ;; those of identifiers named "..." that prevent a "..." from
d1120 1
a1120 1
      (let loop ((ids (if ellipsis-id (list-dots-ids rules lits) lits))
d1423 1
d1427 4
a1430 5
		  ((_ ,expr ()) (do-next expr))
		  ((_ (,@@expr . y) ()) (qq y () make-splice expr))
		  ((_ ,x (depth)) (qq (x)  depth  make-pair 'unquote))
		  ((_ `x  depth)  (qq (x) (depth) make-pair 'quasiquote))
		  ((_ ,@@x depth)  (unquote-splicing-error ,@@x))
d1433 6
a1438 3
		  ((_ (x . y) depth) (qq x depth qq-cdr y depth make-pair))
		  ((_ #(x ...) depth) (qq (x ...) depth make-vector))
		  ((_ x depth) (do-next 'x))))
d1443 1
d1448 1
d1452 1
d1457 1
d1466 1
d1473 5
a1477 15
	      (define-syntax make-vector
		(tail-preserving-syntax-rules (quote list)
		  ((_ '(x ...)) (do-next '#(x ...)))
		  ((_ (list . elts)) (do-next (vector . elts)))
		  ((_ expr) (scan-conses () expr expr))))
	      ;; scan-conses: check if expr is a nesting of conses
	      ;; whose last cdr is a quoted list, i.e., convert (cons
	      ;; x1 (cons x2 (cons x3 '(x4 x5 x6)))) to (vector x1 x2
	      ;; x3 'x4 'x5 'x6).  Otherwise, use (list->vector expr).
	      (define-syntax scan-conses
		(tail-preserving-syntax-rules (quote cons)
		  ((_ (elt ...) (cons x y)) (scan-conses (elt ... x) y))
		  ((_ (elt ...) '(x ...) orig)
		   (do-next (vector elt ... 'x ...)))
		  ((_ elts other orig) (do-next (list->vector orig)))))
d1482 17
d1559 3
d1573 1
a1596 18
;; Example of how a safe letrec could be written if we support macro
;; calls of the forms (SET! KEYWORD DATUM) and just plain KEYWORD.
'
(define-syntax letrec
  (syntax-rules ()
    ((_ ((var init) ...) . body)
     (let ((ready? #f) (var #f) ...)
       (let-syntax
	   ((var (syntax-rules (set!)
		   ((_ set! val) (if ready? (set! var val) (error)))
		   ((_ . args) ((if ready? var (error)) . args))
		   (_ (if ready? var (error)))))
	    ...)
	 (let ((var (let ((tmp init)) (lambda () (set! var tmp))))
	       ...)
	   (set! ready? #t) (var) ...)
	 (let () . body))))))

d1601 1
a1601 7
;; * remove internal definition support from primitive lambda.
;; * remove letrec-syntax primitive.
;; * top-level let-syntax
;; * fix nested unquote-splicing.
;; * allow syntax bindings to expressions: (let-syntax ((foo (- 1))) foo) => -1
;;     (let ((x 1)) (let-syntax ((y x)) (set! y 2) x)) => 2
;; * store transformers in same format as syntax-rules sexp
a1602 1
;; * update documentation.
a1664 1

d1697 7
a1703 2
'
(define-syntax safe-letrec
d1705 1
a1705 1
    (define-syntax finish
d1707 6
a1712 4
	((finish ready? (real-var ...) (var ...) (init ...) thunk)
	 (let-syntax ((real-set! set!))
	   (define-syntax var
	     (if ready? real-var (letrec-access-error 'var)))
d1714 59
a1772 11
	   (define-syntax new-set!
	     (syntax-rules no-ellipsis (var ...)
	       ((new-set! var x)
		(if ready? (real-set! real-var x) (letrec-set!-error 'var)))
	       ...
	       ((new-set! . stuff) (real-set! . stuff))))
	   (fluid-let-syntax ((set! new-set!))
	     ;; here we're just using (var ...) as temp names:
	     (let ((var init) ...)
	       (real-set! ready? #t) (real-set! real-var var) ...)
	     (thunk))))))
d1774 71
a1844 7
      ((letrec ((var init) ...) . body)
       (let ((ready? #f) (var #f) ...)
	 (define (thunk) . body)
	 ((syntax-rules no-ellipsis ()
	    ((_ vars inits)
	     (finish ready? (var ...) vars inits thunk)))
	  (var ...) (init ...)))))))
@


1.53
log
@* Simplified builtin lambda to (lambda <formals> <expr>).
  Null-store's lambda uses let-syntax to support internal definitions.
* Replaced letrec-syntax builtin with a macro using internal define-syntax.
* Added top-level let-syntax.  At top-level, allow:
    (let-syntax (<syntax spec>*) <syntax definition>* <command or definition>)
  Example:
    (let-syntax () (define-syntax - quote) (define-syntax r -))
    (r 1) =>  1
    (- 1) => -1
** Added lsd? argument to expand-any.  It's a flag to allow Let-Syntax
   around Definitions; it's only true at top-level.
** Restored old expand-any behavior of handling begin expressions
   automatically if (and ek (not bk)).  Removed expand-exprs.
** Revamped null-prog to use top-level let-syntax.
* Fixed nested unquote-splicing: ``(,,@@'(x y)) => `(,x ,y)
* Changed name of make-local-var to intloc->var, so as to match symloc->var.
* Consolidated check-formals, make-var-bindings, flatten-dotted, and
  dot-flattened into expand-lambda.
* Cleaned up check-syntax-bindings.
@
text
@d2 1
a2 1
;; $Id: alexpander.scm,v 1.52 2003/11/15 00:55:27 al Exp al $
d14 1
a14 1
;; Foundation, Inc., 59 Temple Pl Ste 330, Boston MA 02111-1307, USA.
d249 1
a249 1
;; val: variable | syntax
d251 1
d253 3
a255 5
;; builtin: (symbol)
;; transformer: (env ellipsis literals rule ...)
;; ellipsis: id | #f   ;; #f if implicitly "..."
;; literals: (id ...)  ;; note: ids, not sids.  No need for the extra info.
;; rule: the unaltered sexp from the syntax-rules form.
d300 1
a300 1
;; (compile-syntax-rules env ellipsis pattern-lits rules) => transformer
d364 7
d372 7
a378 1
(define (syntax? val) (pair? val))
a379 1
(define (builtin? syntax) (null? (cdr syntax)))
d381 2
a382 2

(define (builtin-name builtin) (car builtin))
d436 1
a436 1
    (if (and (symbol? loc) (variable? val))
d485 1
a485 4
	(if (null? formals)
	    (let* ((vars (reverse rvars))
		   (vars (if dotted? (dot-flattened vars) vars)))
	      (list vars (expand-expr expr id-n env store loc-n)))
d489 4
a492 1
	      (loop (cdr formals) (cons var rvars) env store (+ 1 loc-n))))))))
d507 1
a507 1
  (let loop ((bs bindings) (syns '()) (store store) (loc-n loc-n))
d509 5
a513 5
	(expand-syntax (cadar bs) id-n syntax-env store loc-n
		       (lambda (syn error-sexp store loc-n)
			 (loop (cdr bs) (cons syn syns) store loc-n)))
	(let loop ((store store) (syns (reverse syns)) (bs bindings))
	  (if (not (null? syns))
d515 2
a516 2
		     (store (extend-store store loc (car syns))))
		(loop store (cdr syns) (cdr bs)))
d545 2
a546 2
;; encountered and bk is #f but ek is not, the begin is expanded as an
;; expression and passed to ek.
a559 1
  (define (get-bk sexp) (get-k bk sexp "Begin"))
d585 1
a585 1
		  (or test (error "Malformed expression: " sexp)))
d611 1
a611 6
		 (let* ((ellipsis
			 (and (> len 1) (sid? (car tail)) (sid-id (car tail))))
			(rest (if ellipsis (cdr tail) tail))
			(literals (car rest))
			(rules (cdr rest))
			(syn (compile-syntax-rules env ellipsis literals rules)))
d614 3
a616 5
		 (if (and ek (not bk))
		     (if (null? tail)
			 (error "Empty begin expression: " sexp)
			 (ek (make-begin (map expand-subexpr tail))))
		     ((get-bk sexp) sexp id-n env store loc-n)))
d631 3
a633 3
	     (if (variable? val)
		 ((get-ek sexp) val)
		 ((get-sk sexp) val sexp store loc-n))))
d636 2
a637 3
	   (expand-expr-or-syntax (car sexp) id-n env store loc-n
	     (and ek handle-combination)
	     handle-syntax-use))
d646 6
a651 2
(define (expand-expr-or-syntax sexp id-n env store loc-n ek sk)
  (expand-any sexp id-n env store loc-n #f ek sk #f #f))
a655 3
(define (expand-syntax sexp id-n env store loc-n k)
  (expand-any sexp id-n env store loc-n #f #f k #f #f))

d670 10
a679 8
	(for-each check sds)
	(if vds (for-each check vds))
	(case builtin
	  ((define-syntax) (k vds (cons sexp sds) id-n env store (+ loc-n 1)))
	  ((define)
	   (or vds (error "Variable definition in a syntax body: " sexp))
	   (let ((store (extend-store store loc-n (intloc->var loc-n sid))))
	     (k (cons sexp vds) sds id-n env store (+ loc-n 1)))))))
d744 3
a746 3
		  (expand-syntax init id-n* env* store loc-n
		    (lambda (syn error-sexp store loc-n)
		      (let ((store (substitute-in-store store loc syn)))
d755 1
a755 1
;; This doesn't do much compiling, it mostly just does verification.
d767 4
a770 1
(define (compile-syntax-rules env ellipsis pattern-lits rules)
d773 2
a774 2
	 (if ellipsis
	     (eqv? ellipsis (sid-id x))
d776 1
d779 1
a779 1
	(error "Non-id: " lit " in literals list: " pattern-lits))
d781 11
a791 5
	(error "Ellipsis " lit " in literals list: " pattern-lits)))
  (or (list? pattern-lits)
      (error "Pattern literals list is not a list: " pattern-lits))
  (for-each check-lit pattern-lits)
  (let ((pattern-lits (map sid-id pattern-lits)))
d850 1
a850 1
		 (cond ((memv id pattern-lits) l)
d924 1
a924 1
      (let loop ((ids (if ellipsis (list-dots-ids rules lits) lits))
d934 1
a934 1
    (let* ((lits (apply append pattern-lits (map check-rule rules)))
d936 1
a936 1
	  (cons env (cons ellipsis (cons pattern-lits rules))))))
d941 7
a947 4
  (let ((mac-env (car transformer))
	(ellipsis (cadr transformer))
	(pat-literals (caddr transformer))
	(rules (cdddr transformer)))
d954 2
a955 2
	   (if ellipsis
	       (eqv? ellipsis (sid-id x))
d1079 2
a1080 1
	(loop (cdr bs) (extend-store store (car bs) (list (car bs)))))))
d1336 3
a1338 3
		     (map (lambda (loc)
			    (pp (lookup-location loc (car repl-mstore))))
			  (cdr l)))
d1343 3
a1345 2
  (if (null? resume?) (restart))
  (repl))
d1493 14
a1506 13
;; (define-syntax define-identifier-syntax
;;   (syntax-rules (set!)
;;     ((_ id e)
;;      (define-syntax id e))
;;     ((_ id (id* e1) ((set! id** pat) tmpl)) ;; id* and id** are ignored
;;      (begin
;;        (define-syntax id e1)
;;        (define-syntax set!
;;          (let-syntax ((real-set! set!))
;;            (syntax-rules (id)
;;              ((set! id pat) tmpl)
;;              ((set! . whatever)
;;               (real-set! . whatever)))))))))
@


1.52
log
@* Improved separation of reduce-env hack from the rest of
  compile-syntax-rules.

* minor cleanups.
@
text
@d2 1
a2 1
;; $Id: alexpander.scm,v 1.51 2003/10/25 19:14:46 al Exp al $
d303 1
a303 1
;; (expand-any sexp id-n env store loc-n ek sk dk bk)
d306 2
a307 2
;;     | (dk builtin sexp id-n store loc-n)
;;     | (bk sexp id-n store loc-n)
d312 2
a313 2
;; (expand-body sexps id-n env store loc-n ek sk)
;;   => (ek output) | (sk syntax sexp store loc-n).
d445 1
a445 1
(define (make-local-var intloc sid)
d452 1
a452 1
      (make-local-var loc sid)))
d457 7
a463 30
;; flatten-dotted:
;; (a b . c) => (a b c)
(define (flatten-dotted x)
  (if (pair? x)
      (cons (car x) (flatten-dotted (cdr x)))
      (list x)))

(define (dot-flattened x)
  (if (null? (cdr x))
      (car x)
      (cons (car x) (dot-flattened (cdr x)))))

;; Check lambda formals for non-identifiers or duplicates.
(define (check-formals formals)
  (define (bad-var x)
    (error "Non-identifier: " x " in lambda formals: " formals))
  (define (dup-var sid)
    (error "Duplicate variable: " sid " in lambda formals: " formals))
  (let ((formals (if (list? formals) formals (flatten-dotted formals))))
    (for-each (lambda (formal) (or (sid? formal) (bad-var formal)))
	      formals)
    (let ((ids (map sid-id formals)))
      (for-each (lambda (formal)
		  (let ((id (sid-id formal)))
		    (if (memv id (cdr (memv id ids)))
			(dup-var formal))))
		formals))))

;; returns (k vars env store loc-n)
(define (make-var-bindings formals env store loc-n k)
d465 17
a481 11
	 (formals (if dotted? (flatten-dotted formals) formals)))
    (let loop
	((formals formals) (rvars '()) (env env) (store store) (loc-n loc-n))
      (if (null? formals)
	  (let* ((vars (reverse rvars))
		 (vars (if dotted? (dot-flattened vars) vars)))
	    (k vars env store loc-n))
	  (let* ((var (make-local-var loc-n (car formals)))
		 (env (extend-env env (sid-id (car formals)) loc-n))
		 (store (extend-store store loc-n var)))
	    (loop (cdr formals) (cons var rvars) env store (+ 1 loc-n)))))))
a483 3
  (define (check-binding b)
    (or (and (list2? b) (sid? (car b)))
	(error "Malformed syntax binding: " b)))
d485 3
a487 1
  (for-each check-binding bindings)
d490 3
a492 5
    (let ((id (sid-id (caar bs))))
      (define (check b)
	(if (eqv? id (sid-id (car b)))
	    (error "Duplicate bindings for a keyword: " (car bs) " and: " b)))
      (for-each check (cdr bs)))))
d509 1
a509 1
;; (expand-any sexp id-n env store loc-n ek sk dk bk)
d518 2
a519 2
;;   subsequently misued.  It is the sid that was bound to the syntax
;;   (unless the syntax is an anonymous transformer, as in
d521 1
a521 1
;;   will be the syntax-rules form).
d523 1
a523 1
;; If sexp is a definition, returns (dk builtin sexp id-n store
d526 1
a526 1
;; If sexp is a begin, returns (bk sexp id-n store loc-n).
d531 12
a542 4
;; Expand-any signals an error if an improper list is encountered.  It
;; also signals an error if ek, sk, dk, or bk is #f and the
;; corresponding thing is encountered.
(define (expand-any sexp id-n env store loc-n ek sk dk bk)
d558 2
a559 2
	      (define (handle-let-syntax rec?)
		(or ek sk (error "Macro block used in bad context: " sexp))
d568 1
a568 1
			  bindings id-n (if rec? ienv env) ienv store loc-n
d571 2
a572 1
					 ek sk)))))))
d579 3
a581 7
			 (expr-assert (>= len 2))
			 (check-formals (car tail))
			 (make-var-bindings (car tail) env store loc-n
			   (lambda (vars env store loc-n)
			     (expand-body (cdr tail) id-n env store loc-n
			       (lambda (output) (list vars output))
			       #f))))
a584 6
			((delay)
			 (expr-assert (= len 1))
			 (list (expand-subexpr (car tail))))
			((if)
			 (expr-assert (<= 2 len 3))
			 (map expand-subexpr tail))
d590 7
a596 1
			   (list var (expand-subexpr (cadr tail))))))))
d598 1
a598 2
		((let-syntax) (handle-let-syntax #f))
		((letrec-syntax) (handle-let-syntax #t))
d601 13
a613 9
		 (let* ((ellipsis (and (sid? (car tail)) (sid-id (car tail))))
			(rest (if ellipsis (cdr tail) tail)))
		   (if (null? rest)
		       (error "Missing literals in syntax-rules: " sexp))
		   (let* ((literals (car rest))
			  (rules (cdr rest))
			  (syn (compile-syntax-rules env ellipsis literals rules)))
		     ((get-sk sexp) syn sexp store loc-n))))
		((begin) ((get-bk sexp) sexp id-n store loc-n))
d617 1
a617 1
		 ((get-dk sexp) builtin sexp id-n store loc-n))
d645 1
a645 4
  (define (bk sexp id-n store loc-n)
    (if (null? (cdr sexp)) (error "Empty begin expression: " sexp))
    (ek (make-begin (expand-exprs (cdr sexp) id-n env store loc-n))))
  (expand-any sexp id-n env store loc-n ek sk #f bk))
d648 1
a648 5
  (expand-expr-or-syntax sexp id-n env store loc-n (lambda (x) x) #f))

(define (expand-exprs sexps id-n env store loc-n)
  (define (expand-one sexp) (expand-expr sexp id-n env store loc-n))
  (map expand-one sexps))
d651 1
a651 1
  (expand-any sexp id-n env store loc-n #f k #f #f))
d653 2
a654 3
;; For an expression body, returns (ek output).
;; For a syntax body, returns (sk syntax sexp store loc-n).
(define (expand-body sexps id-n env store loc-n ek sk)
d656 3
a658 3
  ;; to the vds and sds lists of variable and syntax definitons, and
  ;; returns (k vds sds id-n env store loc-n).  If an expression is
  ;; encountered, returns (ek output) instead.
d660 1
a660 1
    (define (dk builtin sexp id-n store loc-n)
d673 1
a673 1
	   (let ((store (extend-store store loc-n (make-local-var loc-n sid))))
d675 1
a675 1
    (define (bk sexp id-n store loc-n)
d684 3
a686 2
			(let ((rest (expand-exprs (cdr sexps) id-n env
						  store loc-n)))
d688 1
a688 1
    (expand-any sexp id-n env store loc-n ek #f dk bk))
d701 1
a701 1
	      (expand-expr-or-syntax first id-n env store loc-n ek sk)
d721 1
a721 1
  (let expand ((sexps (wrap-vecs forms)) (id-n 0)
d727 2
a728 2
	    (expand rest id-n store loc-n (cons output acc) k))
	  (define (dk builtin sexp id-n* store loc-n)
d734 1
a734 1
		  (let* ((expr (expand-expr init id-n* empty-env store loc-n))
d738 2
a739 2
		    (expand rest id-n store loc-n acc k))
		  (expand-syntax init id-n* empty-env store loc-n
d742 3
a744 3
			(expand rest id-n store loc-n acc k)))))))
	  (define (bk sexp id-n* store loc-n)
	    (expand (cdr sexp) id-n* store loc-n acc
d746 2
a747 2
		      (expand rest id-n store loc-n acc k))))
	  (expand-any (car sexps) id-n empty-env store loc-n ek #f dk bk)))))
d1057 1
a1057 1
			 let-syntax letrec-syntax syntax-rules))
d1068 203
a1270 177
  ;; Define-protected-macros defines a set of macros with a private
  ;; set of bindings for some keywords and variables.  If any of the
  ;; keywords or variables are later redefined at top-level, the
  ;; macros will continue to work.  The first argument to
  ;; define-protected-macros is let-syntax or letrec-syntax; if it is
  ;; letrec-syntax, then the macros will also have a private set of
  ;; bindings for one another, and recursive calls made by the macros
  ;; to themselves or to one another will not be affected by later
  ;; top-level redefinitions.
  ;;
  ;; (You'll notice we don't actually bind anything to the name
  ;; define-protected-macros, we just use it as a pattern literal in
  ;; an anonymous transformer.)
  '(((let-syntax
	 ((multi-define
	   (syntax-rules ()
	     ((_ definer (id ...) (init ...))
	      (begin (definer id init) ...))))
	  ;; The private binding for a saved variable is created by a
	  ;; let-syntax, using a dummy syntax as the initializer.  We
	  ;; later assign a value to it using a top-level define (and
	  ;; thus change the status of the binding from keyword to
	  ;; variable).
	  (dummy (syntax-rules ())))
       (syntax-rules (define-protected-macros define-syntax)
	 ((_ (define-protected-macros let/letrec-syntax
	       (saved-kw ...) (saved-var ...)
	       (define-syntax kw syntax)
	       ...)
	     ...)
	  (begin
	    ((let-syntax ((saved-kw saved-kw) ... (saved-var dummy) ...)
	       (let/letrec-syntax ((kw syntax) ...)
		 (syntax-rules ()
		   ((_ top-level-kws top-level-vars)
		    (begin
		      (multi-define define (saved-var ...) top-level-vars)
		      (multi-define define-syntax top-level-kws (kw ...)))))))
	     (kw ...) (saved-var ...))
	    ...))))
     (define-protected-macros letrec-syntax
       (if lambda quote begin define) (eqv?)
       (define-syntax let
	 (syntax-rules ()
	   ((_ ((var init) ...) . body)
	    ((lambda (var ...) . body)
	     init ...))
	   ((_ name ((var init) ...) . body)
	    ((letrec ((name (lambda (var ...) . body)))
	       name)
	     init ...))))
       (define-syntax let*
	 (syntax-rules ()
	   ((_ () . body) (let () . body))
	   ((let* ((var init) . bindings) . body)
	    (let ((var init)) (let* bindings . body)))))
       (define-syntax letrec
	 (syntax-rules ()
	   ((_ ((var init) ...) . body)
	    (let () (define var init) ... (let () . body))))) 
       (define-syntax do
	 (let-syntax ((do-step (syntax-rules () ((_ x) x) ((_ x y) y))))
	   (syntax-rules ()
	     ((_ ((var init step ...) ...)
		 (test expr ...)
		 command ...)
	      (let loop ((var init) ...)
		(if test
		    (begin (if #f #f) expr ...)
		    (begin command ...
			   (loop (do-step var step ...) ...))))))))
       (define-syntax case
	 (letrec-syntax
	     ((compare
	       (syntax-rules ()
		 ((_ key ()) #f)
		 ((_ key (datum . data))
		  (if (eqv? key 'datum) #t (compare key data)))))
	      (case
	       (syntax-rules (else)
		 ((case key) (if #f #f))
		 ((case key (else result1 . results))
		  (begin result1 . results))
		 ((case key ((datum ...) result1 . results) . clauses)
		  (if (compare key (datum ...))
		      (begin result1 . results)
		      (case key . clauses))))))
	   (syntax-rules ()
	     ((_ expr clause1 clause ...)
	      (let ((key expr))
		(case key clause1 clause ...))))))
       (define-syntax cond
	 (syntax-rules (else =>)
	   ((_) (if #f #f))
	   ((_ (else . exps)) (let () (begin . exps)))
	   ((_ (x) . rest) (or x (cond . rest)))
	   ((_ (x => proc) . rest)
	    (let ((tmp x)) (cond (tmp (proc tmp)) . rest)))
	   ((_ (x . exps) . rest)
	    (if x (begin . exps) (cond . rest)))))
       (define-syntax and
	 (syntax-rules ()
	   ((_) #t)
	   ((_ test) (let () test))
	   ((_ test . tests) (if test (and . tests) #f))))
       (define-syntax or
	 (syntax-rules ()
	   ((_) #f)
	   ((_ test) (let () test))
	   ((_ test . tests) (let ((x test)) (if x x (or . tests)))))))
     ;; Prototype-style define is implemented in a
     ;; define-protected-macros with let-syntax scope so that it can
     ;; access the builtin define.  Quasiquote is here too so that it
     ;; can recognize nested uses of itself using a syntax-rules
     ;; literal (that is, the quasiquote binding that is visible in
     ;; the environment of the quasiquote transformer must be the same
     ;; binding that is visible where quasiquote is used).
     (define-protected-macros let-syntax
       (lambda define quote let) (cons append list vector list->vector)
       (define-syntax define
	 (syntax-rules ()
	   ((_ (var . args) . body)
	    (define var (lambda args . body)))
	   ((_ var init) (define var init))))
       (define-syntax quasiquote
	 (let-syntax
	     ((tail-preserving-syntax-rules
	       (syntax-rules ()
		 ((_ literals
		     ((subpattern ...) (subtemplate ...))
		     ...)
		  (syntax-rules literals
		    ((subpattern ... . tail) (subtemplate ... . tail))
		    ...)))))
	   (define-syntax qq
	     (tail-preserving-syntax-rules
	         (unquote unquote-splicing quasiquote)
	       ((_ ,expr ()) (do-next expr))
	       ((_ `x depth) (qq (x) (depth) make-pair 'quasiquote))
	       ((_ ,x (depth)) (qq (x) depth make-pair 'unquote))
	       ((_ ,@@x (depth)) (qq (x) depth make-pair 'unquote-splicing))
	       ((_ (,@@x . y) ()) (qq y () make-splice x))
	       ((_ (x . y) depth) (qq x depth qq-cdr y depth))
	       ((_ #(x ...) depth) (qq (x ...) depth make-vector))
	       ((_ x depth) (do-next 'x))))
	   (define-syntax do-next
	     (syntax-rules ()
	       ((_ expr) expr)
	       ((_ expr next-macro . tail) (next-macro expr . tail))))
	   (define-syntax qq-cdr
	     (tail-preserving-syntax-rules ()
	       ((_ car cdr depth) (qq cdr depth make-pair car))))
	   (define-syntax make-pair
	     (tail-preserving-syntax-rules (quote list)
	       ((_ 'y 'x) (do-next '(x . y)))
	       ((_ '() x) (do-next (list x)))
	       ((_ (list . elts) x) (do-next (list x . elts)))
	       ((_ y x) (do-next (cons x y)))))
	   (define-syntax make-vector
	     (tail-preserving-syntax-rules (quote list)
	       ((_ '(x ...)) (do-next '#(x ...)))
	       ((_ (list . elts)) (do-next (vector . elts)))
	       ((_ expr) (scan-conses () expr expr))))
	   ;; Check if expr is a nesting of conses whose last cdr is a
	   ;; quoted list, i.e., convert (cons x1 (cons x2 (cons x3
	   ;; '(x4 x5 x6)))) to (vector x1 x2 x3 'x4 'x5 'x6).
	   ;; Otherwise, use (list->vector expr).
	   (define-syntax scan-conses
	     (tail-preserving-syntax-rules (quote cons)
	       ((_ (elt ...) (cons x y)) (scan-conses (elt ... x) y))
	       ((_ (elt ...) '(x ...) orig) (do-next (vector elt ... 'x ...)))
	       ((_ elts other orig) (do-next (list->vector orig)))))
	   (define-syntax make-splice
	     (tail-preserving-syntax-rules ()
	       ((_ '() x) (do-next x))
	       ((_ y x) (do-next (append x y)))))
	   (syntax-rules () ((_ template) (let () (qq template ()))))))))))
d1387 1
d1390 1
a1391 2
;; * store transformers in same format as syntax-rules sexp
;; * fix nested unquote-splicing.
@


1.51
log
@Simple cleanups in check-formals and make-pat-env.
@
text
@d2 1
a2 1
;; $Id: alexpander.scm,v 1.50 2003/10/23 04:11:31 al Exp al $
d866 2
a867 2
    ;; Checks var depths and returns a list of template literals 
    (define (list-template-lits tmpl pat-env)
d873 2
a874 2
      (define (finish lits closed?) lits)
      (let collect ((x tmpl) (lits '()) (depth 0) (k finish))
d876 8
a883 9
	       (cond ((assv (sid-id x) pat-env)
		      => (lambda (p)
			   (let* ((pat-depth (cdr p))
				  (same-depth? (= depth pat-depth)))
			     (if (and (positive? pat-depth) (not same-depth?))
				 (depth-error x))
			     (k lits same-depth?))))
		     (else (k (cons (sid-id x) lits) #f))))
	      ((vector? x) (collect (svector->list x) lits depth k))
d885 9
a893 8
	       (let ((ellip? (ellipsis-pair? (cdr x))))
		 (collect (car x) lits (if ellip? (+ 1 depth) depth)
		   (lambda (lits car-closed?)
		     (or car-closed? (not ellip?) (close-error x))
		     (collect ((if ellip? cddr cdr) x) lits depth
		       (lambda (lits cdr-closed?)
			 (k lits (or car-closed? cdr-closed?))))))))
	      (else (k lits #f)))))
d895 1
a895 1
    ;; Checks rule and returns the list of the template literals.
d903 10
a912 1
	(list-template-lits tmpl (make-pat-env pat))))
d929 1
a929 1
		 (reduced-env '()))
d1201 1
a1201 1
     ;; literal.  That is, the quasiquote binding that is visible in
d1203 1
a1203 1
     ;; binding that is visible where quasiquote is used.
d1309 4
a1312 3
		    ((show) (map (lambda (loc)
				   (pp (assv loc (car repl-mstore))))
				 (cdr l)))
d1321 10
a1330 9
'(begin
   (define (file->list file)
     (define (f) (let ((x (read))) (if (eof-object? x) '() (cons x (f)))))
     (with-input-from-file file f))

   (define (check-expander filename)
     (let* ((src (file->list filename))
	    (out1 (begin (for-each eval src) (expand-program src))))
       (begin (for-each eval out1) (equal? out1 (expand-program src))))))
d1375 15
a1389 2
;; TODO: revamp error handling, add an error continuation to
;; expand-top-level-forms.
d1440 69
@


1.50
log
@Removed gratuitous call/cc in MATCHES?, which was left over from when
MATCHES? and MAKE-BINDINGS were a single procedure.

Simplified MAKE-BINDINGS in light of dropping support for ellipsis
followed by an improper list.
@
text
@d2 1
a2 1
;; $Id: alexpander.scm,v 1.49 2003/10/20 07:10:42 al Exp al $
d458 1
a458 1
;; (a b . c) => (a b c), a => (a)
d475 9
a483 10
  (or (null? formals)
      (let ((formals (if (list? formals) formals (flatten-dotted formals))))
	(for-each (lambda (formal) (or (sid? formal) (bad-var formal)))
		  formals)
	(let ((ids (map sid-id formals)))
	  (for-each (lambda (formal)
		      (let ((id (sid-id formal)))
			(if (memv id (cdr (memv id ids)))
			    (dup-var formal))))
		    formals)))))
d861 3
a863 3
	       (cond ((ellipsis-pair? (cdr x))
		      (collect (car x) (+ 1 depth) (collect (cddr x) depth l)))
		     (else (collect (car x) depth (collect (cdr x) depth l)))))
@


1.49
log
@typo
@
text
@d2 1
a2 1
;; $Id: alexpander.scm,v 1.48 2003/10/20 01:03:09 al Exp al $
d966 1
d968 22
a989 27
      (call-with-current-continuation
       (lambda (return)
	 (define (fail-unless x) (if (not x) (return #f)))
	 (let match ((pat pat) (sexp (cdr sexp)))
	   (cond ((sid? pat)
		  (fail-unless (or (not (pat-literal? (sid-id pat)))
				   (and (sid? sexp)
					(eqv? (lookup-sid pat mac-env)
					      (lookup-sid sexp env))))))
		 ((svector? pat)
		  (fail-unless (svector? sexp))
		  (match (svector->list pat) (svector->list sexp)))
		 ((not (pair? pat)) (fail-unless (equal? pat sexp)))
		 ((ellipsis-pair? (cdr pat))
		  (let skip ((p (cddr pat)) (s sexp))
		    (if (pair? p)
			(begin (fail-unless (pair? s))
			       (skip (cdr p) (cdr s)))
			(let match-cars ((sexp sexp) (s s))
			  (if (pair? s)
			      (begin (match (car pat) (car sexp))
				     (match-cars (cdr sexp) (cdr s)))
			      (match (cddr pat) sexp))))))
		 (else (fail-unless (pair? sexp))
		       (match (car pat) (car sexp))
		       (match (cdr pat) (cdr sexp)))))
	 #t)))
d1001 8
a1008 14
	       (let skip ((p (cddr pat)) (s sexp))
		 (if (pair? p)
		     (skip (cdr p) (cdr s))
		     (let get-elts ((sexp sexp) (s s) (reversed-elts '()))
		       (if (pair? s)
			   (get-elts (cdr sexp) (cdr s)
				     (cons (car sexp) reversed-elts))
			   (let ((elts (reverse reversed-elts))
				 (vars
				  (list-ids (car pat) #t not-pat-literal?)))
			     (define (collect1 elt)
			       (map cdr (collect (car pat) elt '())))
			     (append (apply map list vars (map collect1 elts))
				     (collect (cddr pat) sexp bindings))))))))
@


1.48
log
@Fixed an old comment.
@
text
@d2 1
a2 1
;; $Id: alexpander.scm,v 1.47 2003/10/20 00:33:03 al Exp al $
d43 1
a43 1
;;                          | (befin <syntax definition>*)
@


1.47
log
@Added more commentary.

Removed support for improper list patterns with an ellipsis.

Added Choose-Your-Own-Ellipsis support:
  ((syntax-rules ::: () ((_ x :::) '((x) :::))) 1 2)
  => ((1) (2))

Alexpander-repl now supports #(show loc) escape.

Several cleanups.

Will release this version and announce on the SRFI-46 list.
@
text
@d2 1
a2 1
;; $Id: alexpander.scm,v 1.46 2003/10/18 20:39:04 al Exp al $
d279 1
a279 1
;; literal that created the id: this is the binding to use if the id
@


1.46
log
@Added lots of commentary.

Cleaned up some variable name choices.

Added dot-flattened and flatten-dotted.  Cleaned up check-formals and
make-var-bindings.

Removed old plan for compiled macros.

Removed this old musing:

;; There are two ways (idefs-let-syntax ((kw syntax) ...) def ...)
;; could work in internal-definition contexts: it could create an
;; environment, derived from the outer environment, that is only used
;; for the expansion of the definitions; or it could create an
;; environment, derived from the inner environment, that is only used
;; for the expansion of the initializers.  The first is the easier of
;; the two to implement.  Implementing one form that does both things
;; would require putting the same frame of bindings into two different
;; environments, i.e. it would mean supporting non-hierarchical
;; environments.

;; 2002-09-05: Hmm, the ability to use ((let-syntax ...) arg ...)
;; among internal definitions actually gives you the power to do
;; things similar to either of the semantics described above.  It also
;; obviates the need for top-let-syntax.
@
text
@d2 3
a4 2
;; Copyright 2002 Al Petrofsky <alexpander@@petrofsky.org>
;; $Id: expander.scm,v 1.45 2003/10/18 12:17:05 al Exp al $
d16 2
d33 2
a34 2
;; The expander is written in portable r5rs scheme, but for one use of
;; the pretty-print procedure which you can easily comment out.
d61 2
a62 2
;; used as the ellipsis, and a pattern ellipsis may be followed by
;; patterns:
d102 1
a102 2
;;      The purely-functional interface.  Use null-store and
;;      null-loc-n when calling with the first forms in a program.
d105 3
d118 1
a118 1
;; Furthermore, begin is only used for expressions; lambdas and
d120 1
a120 1
;; definitions; and defines are always of the simple (define
d130 2
d133 88
a220 1
;; INTERNALS
d222 1
a222 8
;; Any variable named SEXP in the expander code holds a representation
;; of some code undergoing expansion.  It mostly looks like the
;; ordinary representation of scheme code, but it may contain some
;; identifiers that are encoded as two- or three-element vectors
;; called renamed-sids.  Any actual vector in the code will be
;; represented as a one-element vector whose element is a list of the
;; actual elements, i.e., each vector #(elt ...) is mapped to #((elt
;; ...)), so that we can distinguish these vectors from renamed-sids.
d224 4
a227 3
;; In contrast, a variable named OUTPUT is a bit of finished code, in
;; which vectors represent themselves and all renamed identifiers have
;; been mapped to suitable symbols.
d233 1
a233 1
;;
d238 5
a242 24
;; A sid is the representation of an id within a sexp.
;; sid: original-id | renamed-sid

;; A renamed-sid includes the id's original name, which we will need
;; if the id gets used in a QUOTE expression.  The renamed-sid also
;; includes the location of the local binding (if any) of the template
;; literal that created the id: this is the binding to use if the id
;; gets used freely (i.e., in an environment with no binding for it). 
;; renamed-sid: #(original-id renamed-id local-location)
;;            | #(original-id renamed-id)



;; An environment maps ids to locations, and a store maps locations to
;; values.  The unchanging top-level environment maps every symbol to
;; a location.  For simplicity, each of those locations is represented
;; by the symbol that is bound to it.  All other locations (those
;; created by lambda, let-syntax, letrec-syntax, and internal
;; definitions) are represented by integers.

;; An environment is represented by an alist mapping ids to local
;; (non-top-level) locations.  All environments are derived from the
;; top-level environment, so any symbolic id not in the alist is
;; implicitly mapped to the corresponding top-level location.
d258 26
d293 2
a294 1
;; Summary of major functions:
d301 1
d323 1
a323 1
(define list->svector     vector)
d375 4
a378 1
;; Lookup-sid looks up a sid an an environment.
d390 1
a390 1
;; If there is no value explictly mentioned in the environment:
d393 2
a394 1
;;      location allocated by letrec-syntax or internal define-syntax,
d408 1
a408 1
(define (extend-store store intloc val) (acons intloc val store))
d479 6
a484 8
	(do ((formal (car formals) (car formals))
	     (formals (cdr formals) (cdr formals)))
	    ((null? formals))
	  (let ((id (sid-id formal)))
	    (for-each (lambda (formal)
			(if (eqv? id (sid-id formal))
			    (dup-var sid)))
		      formals))))))
d491 1
a491 1
	((formals formals) (vars '()) (env env) (store store) (loc-n loc-n))
d493 1
a493 1
	  (let* ((vars (reverse vars))
d499 1
a499 1
	    (loop (cdr formals) (cons var vars) env store (+ 1 loc-n)))))))
d617 9
a625 3
		 (if (< len 1) (error "Malformed syntax: " sexp))
		 (let ((syn (compile-syntax-rules (car tail) (cdr tail) env)))
		   ((get-sk sexp) syn sexp store loc-n)))
d653 1
a653 1
			     (else "Illegal s-expression: "))
d673 1
a673 1
;; For an expression body, returns output.
d754 1
a754 1
		  (let* ((expr (expand-expr init id-n* '() store loc-n))
d759 1
a759 1
		  (expand-syntax init id-n* '() store loc-n
d767 1
a767 1
	  (expand-any (car sexps) id-n '() store loc-n ek #f dk bk)))))
d778 2
a779 2
;;   list or vector pattern with multiple ellipses
;;   list pattern with an ellipsis and a variable-length tail.
d782 6
a787 1
(define (compile-syntax-rules pattern-lits rules env)
d790 3
a792 2
	(error "Non-identifier: " lit
	       " in list of pattern literals: " pattern-lits)))
d796 1
a796 4
  (let ((pattern-lits (map sid-id pattern-lits))
	(ellipsis-binding (assq '... env)))
    (define ellipsis?
      (if ellipsis-binding (lambda (x) #f) (lambda (x) (eq? '... x))))
d807 1
d810 1
d812 1
a812 2
	(bad-ellipsis x
	  "List pattern with an ellipsis and a variable-length tail"))
d836 6
a841 12
			   (else (let check-rest ((y (cddr x)))
				   (cond ((pair? y)
					  (if (ellipsis? (car y))
					      (multi-ellipsis-error x))
					  (check (car y))
					  (if (ellipsis? (cdr y))
					      (ellipsis-follows y "a '.'"))
					  (check-rest (cdr y)))
					 ((sid? y)
					  (or (memv (sid-id y) pattern-lits)
					      (ellipsis/tail-error x)))
					 (else (check y))))))
d896 1
a896 1
    ;; Returns a list of the rule's template literals.
d906 28
a933 12
    (or ellipsis-binding (not (memq '... pattern-lits))
	(error "Ellipsis in literals list: " pattern-lits))  
    (let loop
	((lits (apply append pattern-lits (map check-rule rules)))
	 (reduced-env (if ellipsis-binding (list ellipsis-binding) '())))
      (if (null? lits)
	  (cons reduced-env (cons pattern-lits rules))
	  (loop (cdr lits)
		(let ((lit (car lits)))
		  (cond ((and (not (assv lit reduced-env)) (assv lit env))
			 => (lambda (binding) (cons binding reduced-env)))
			(else reduced-env))))))))
d938 3
a940 2
	(pat-literals (cadr transformer))
	(rules (cddr transformer)))
d945 5
a949 2
    (define ellipsis?
      (if (memq '... mac-env) (lambda (x) #f) (lambda (x) (eq? '... x))))
d995 2
d1022 1
d1062 2
a1063 2
			(error "Unequal sequence lengths in macro call: "
			       sexp))))
d1079 1
a1079 1
	     (store '()))
d1082 1
a1082 1
	(loop (cdr bs) (substitute-in-store store (car bs) (list (car bs)))))))
d1276 1
a1276 1
;; a mstore is a mutable store.
d1286 10
a1295 2
;;  A read-expand-print loop.
(define (alexpander-repl)
d1299 4
a1302 2
  (for-each pp null-output)
  (let repl ((store null-store) (loc-n null-loc-n))
d1306 14
a1319 4
	  (expand-top-level-forms (list form) store loc-n
	    (lambda (outputs store loc-n)
	      (for-each pp outputs)
	      (repl store loc-n)))))))
d1374 3
@


1.45
log
@Added support for pattern ellipsis in the middle of a list or vector,
e.g. (x ... y z)

Includes support for improper lists like (x ... . 1) or (x ... . #(y ...)),
but not (x ... y ...) or (x ... . y), which could be matched in more
than one way.  Hmm, nor do we support (x ... () (y) ...), which could *not*
be matched in more than one way, but we don't want to have to do that
analysis.  Okay, let's just say we don't support lists with more than
one variable-length part.
@
text
@d1 1
a1 1
;; expander.scm: a macro expander.
d3 1
a3 1
;; $Id: expander.scm,v 1.44 2003/10/06 01:05:06 al Exp al $
d15 131
a145 1
;; Current data model:
d149 26
a179 8
;; A sid comprises the info stored with an id within source code s-expressions.
;; sid: original-id | renamed-sid
;; A renamed-sid includes the id's original name, to be used if the id
;; occurs within a constant.  It also includes the location of the
;; local binding (if any) of the template literal that created the id:
;; this is the binding to use if the id occurs freely.
;; renamed-sid: #(name renamed-id local-location) | #(name renamed-id)
;; name: symbol
d184 13
a196 10
;; transformer: (env (id ...) rule ...)

;; Within sexps, a vector #(elt ...) is represented as #((elt ...)).
;; This makes vectors distinguishable from renamed-sids.  (Putting the
;; elements in a list also makes vectors easier to process.)

;; An id-n argument is the next higher number after the largest
;; renamed-id that occurs in the sexp argument.
;; A loc-n argument is the next higher number after the largest
;; local-location in the store argument.
d198 1
d202 3
d212 3
a214 3
;; (expand-expr sexp id-n env store loc-n) => output-sexp
;; (expand-top-level-forms input-sexps store loc-n k)
;;   => (k output-sexps store loc-n)
d216 1
a216 1
;;   => (ek output-sexp) | (sk syntax sexp store loc-n).
a219 35
;; Plan for compiled macros:
;; transformer: (rule ...)
;; rule: (pat tmpl inserted-literal ...)
;; inserted-literal: name | (name . location)
;; ellipsis: the symbol named "..."
;; pat: constant
;;    | (pat . pat)
;;    | X              ;; matches anything
;;    | (pat ellipsis) ;; an ellipsis pattern
;;    | #(location)    ;; matches a literal
;;    | #((pat ...))   ;; a vector pattern
;; tmpl: constant
;;    | (tmpl . tmpl)
;;    | ((tmpl tmpl ...) ellipsis . tmpl) ;; an ellipsis template
;;    | #(stack-index (accessor ...))     ;; a variable or inserted literal
;;    | #((tmpl ...))                     ;; a vector template
;; accessor: CAR | CDR | VECTOR->LIST

;; While compiling,
;; hmm...
;; pat-vars-alist: ((id depth accessors . pat-ellip) ...)
;; pat-ellip: (accessors ...)
;; tmpl-ellip: (pat-ellip ...)
;; tmpl-ellips: (tmpl-ellip ...)
;; hmm...

;; (compile-template sexp depth tmpl-ellips k) => (k tmpl-ellips tmpl)

;; If we compile transformers all the way, with eval and
;; scheme-report-environment, patterns would use these bindings:
;;   lambda, if, car, cdr, null?, eq?, eqv?, equal?,
;;   pair?, vector?, vector-length, vector-ref, =
;; templates would use:
;;   lambda, if, car, cdr, null?, pair?, vector-ref, cons, vector

d241 1
a241 1
;; Map-vecs does a deep map of sexp, replacing any vector v with (f v).
d245 7
a251 7
(define (map-vecs f sexp)
  ;; mv2 returns #f if there are no vectors in sexp.
  (define (mv2 sexp)
    (if (vector? sexp)
	(f sexp)
	(and (pair? sexp)
	     (let ((a (car sexp)) (b (cdr sexp)))
d257 2
a258 2
  (define (mv sexp) (or (mv2 sexp) sexp))
  (mv sexp))
d261 5
a265 5
(define (wrap-vecs sexp) (map-vecs wrap-vec sexp))
(define (unwrap-vec v)
  (if (= 1 (vector-length v))
      (list->vector (unwrap-vecs (svector->list v)))
      (vector-ref v 0)))
d269 1
a269 1
(define (syntax? val) (not (variable? val)))
d271 1
a271 1
(define (builtin? syntax) (and (pair? syntax) (symbol? (car syntax))))
d278 6
d286 1
d289 6
d302 3
a304 1
      (error "Premature use of keyword bound by letrec-syntax: " sid)))
a306 1

d309 7
d329 1
a329 1
;; primitives we use in the output.
d356 13
d374 12
a385 15
  (do ((formals formals (cdr formals)))
      ((not (pair? formals))
       (or (null? formals) (sid? formals) (bad-var formals)))
    (or (sid? (car formals))
	(bad-var (car formals))))
  (do ((formals formals (cdr formals)))
      ((not (pair? formals)))
    (let ((sid (car formals)) (rest (cdr formals)))
      (let ((id (sid-id sid)))
	(do ((rest rest (cdr rest)))
	    ((not (pair? rest))
	     (or (null? rest) (not (eqv? id (sid-id rest)))
		 (dup-var sid)))
	  (if (eqv? id (sid-id (car rest)))
	      (dup-var sid)))))))
d389 2
a390 6
  (let ((vars (let make-vars ((formals formals) (loc-n loc-n))
		(cond ((pair? formals)
		       (cons (make-local-var loc-n (car formals))
			     (make-vars (cdr formals) (+ 1 loc-n))))
		      ((null? formals) '())
		      (else (make-local-var loc-n formals))))))
d392 9
a400 9
	((formals formals) (vs vars) (env env) (store store) (loc-n loc-n))
      (cond ((pair? vs)
	     (let ((env (extend-env env (sid-id (car formals)) loc-n))
		   (store (extend-store store loc-n (car vs))))
	       (loop (cdr formals) (cdr vs) env store (+ 1 loc-n))))
	    ((null? vs) (k vars env store loc-n))
	    (else (let ((env (extend-env env (sid-id formals) loc-n))
			(store (extend-store store loc-n vs)))
		    (k vars env store (+ 1 loc-n))))))))
a429 61
;; For an expression body, returns output-sexp.
;; For a syntax body, returns (sk syntax sexp store loc-n).
(define (expand-body sexps id-n env store loc-n ek sk)
  ;; Expand-def expands a definition or begin sequence, adds entries
  ;; to the vds and sds lists of variable and syntax definitons, and
  ;; returns (k vds sds id-n env store loc-n).  If an expression is
  ;; encountered, returns (ek output) instead.
  (define (expand-def sexp vds sds id-n env store loc-n k ek)
    (define (dk builtin sexp id-n store loc-n)
      (let* ((sid (cadr sexp))
	     (id (sid-id sid))
	     (env (extend-env env id loc-n)))
	(define (check def)
	  (if (eqv? id (sid-id (cadr def)))
	      (error "Duplicate internal definitions: " def " and: " sexp)))
	(for-each check sds)
	(if vds (for-each check vds))
	(case builtin
	  ((define-syntax) (k vds (cons sexp sds) id-n env store (+ loc-n 1)))
	  ((define)
	   (or vds (error "Variable definition in a syntax body: " sexp))
	   (let ((store (extend-store store loc-n (make-local-var loc-n sid))))
	     (k (cons sexp vds) sds id-n env store (+ loc-n 1)))))))
    (define (bk sexp id-n store loc-n)
      (let loop ((sexps (cdr sexp)) (vds vds) (sds sds) (id-n id-n)
		 (env env) (store store) (loc-n loc-n) (ek ek))
	(if (null? sexps)
	    (k vds sds id-n env store loc-n)
	    (expand-def (car sexps) vds sds id-n env store loc-n
	      (lambda (id-n store loc-n vds sds)
		(loop (cdr sexps) id-n store loc-n vds sds #f))
	      (and ek (lambda (out)
			(let ((rest (expand-exprs (cdr sexps) id-n env
						  store loc-n)))
			  (ek (make-begin (cons out rest))))))))))
    (expand-any sexp id-n env store loc-n ek #f dk bk))
  (let loop ((first (car sexps)) (rest (cdr sexps))
	     (vds (and ek '())) (sds '()) (id-n id-n)
	     (env env) (store store) (loc-n loc-n))
    (define (finish-body boundary-exp-output)
      (expand-syntax-bindings (map cdr sds) id-n env env store loc-n
	(lambda (store loc-n)
	  (define (iexpand sexp) (expand-expr sexp id-n env store loc-n))
	  (define (expand-vd vd)
	    (list (lookup2 (cadr vd) env store) (iexpand (caddr vd))))
	  (define (make-letrec bindings expr)
	    (if (null? bindings) expr (list 'letrec bindings expr)))
	  (if (and (null? rest) (not (pair? vds)))
	      (expand-expr-or-syntax first id-n env store loc-n ek sk)
	      (ek (make-letrec
		   (map expand-vd (reverse vds))
		   (if (null? rest)
		       (iexpand first)
		       (make-begin (cons boundary-exp-output
					 (map iexpand rest))))))))))
    (if (null? rest)
	(finish-body #f)
	(expand-def first vds sds id-n env store loc-n
	  (lambda (vds sds id-n env store loc-n)
	    (loop (car rest) (cdr rest) vds sds id-n env store loc-n))
	  (and ek finish-body)))))
d436 1
a436 1
;; If sexp is an expression, returns (ek output-sexp).
d568 65
a632 2
;; (returns (k output-sexps store loc-n))
(define (expand-top-level-forms input-sexps store loc-n k)
d636 1
a636 1
  (let expand ((sexps (wrap-vecs input-sexps)) (id-n 0)
a949 4
(define builtins
  '(begin define define-syntax if lambda quote set! delay
	  let-syntax letrec-syntax syntax-rules))

d951 6
a956 3
  (do ((bs builtins (cdr bs))
       (store '() (substitute-in-store store (car bs) (list (car bs)))))
      ((null? bs) store)))
d958 4
d972 4
d1146 13
a1158 13
(define (expand-program sexps)
  (expand-top-level-forms sexps null-store null-loc-n
    (lambda (sexps store loc-n) (append null-output sexps))))

;; a menv is a mutable environment.
(define (null-menv) (cons null-store null-loc-n))

(define (expand-program! sexps menv)
  (expand-top-level-forms sexps (car menv) (cdr menv)
    (lambda (sexps store loc-n)
      (set-car! menv store)
      (set-cdr! menv loc-n)
      sexps)))
d1161 1
a1161 1
(define (repl)
d1168 5
a1172 5
    (let ((sexp (read)))
      (if (not (eof-object? sexp))
	  (expand-top-level-forms (list sexp) store loc-n
	    (lambda (sexps store loc-n)
	      (for-each pp sexps)
a1252 17


;; There are two ways (idefs-let-syntax ((kw syntax) ...) def ...)
;; could work in internal-definition contexts: it could create an
;; environment, derived from the outer environment, that is only used
;; for the expansion of the definitions; or it could create an
;; environment, derived from the inner environment, that is only used
;; for the expansion of the initializers.  The first is the easier of
;; the two to implement.  Implementing one form that does both things
;; would require putting the same frame of bindings into two different
;; environments, i.e. it would mean supporting non-hierarchical
;; environments.

;; 2002-09-05: Hmm, the ability to use ((let-syntax ...) arg ...)
;; among internal definitions actually gives you the power to do
;; things similar to either of the semantics described above.  It also
;; obviates the need for top-let-syntax.
@


1.44
log
@Internal definitions are now expanded in an environment that includes
all definitions passed so far (with defined-syntaxed keywords bound to
empty locations).

Now we have:

  (let ((a 1) (b 1))
    (define a 2)
    (define-syntax m (syntax-rules () ((_) (list a b))))
    (define b 2)
    (m))
  => (2 2)

  (let ((a 1) (b 1))
    (define a 2)
    ((syntax-rules () ((_ m) (define (m) (list a b)))) m)
    (define b 2)
    (m))
  => (1 2)

If there are multiple body expressions, the internal syntax
definitions will not be available in the first body expression.


Ripped out expressions-returned-as-thunks stuff added in previous
revision.

Expand-syntax-bindings now expects the locations to already be
allocated.

Added expand-exprs.
@
text
@d1 3
a3 3
;; expander.scm:  macro expander
;; Copyright 2002 Al Petrofsky <al@@petrofsky.org>
;; $Id: expander.scm,v 1.43 2003/10/05 17:06:04 al Exp al $
d10 5
d95 2
a96 2
;;   lambda, if, car, cdr, null?, eq?, eqv?, equal?, symbol?
;;   pair?, vector?, vector-length, vector-ref, =, >
d98 1
a98 1
;;   lambda, if, car, cdr, null?, vector-ref, +, cons, vector
d517 1
a517 1
;; Errors that are detected:
d524 2
a525 1
;;   pattern ellipsis not at end of a list or vector.
d545 14
a558 6
      (define (bad-ellipsis x)
	(error "Misplaced ellipsis: " x
	       (if in-template? " in template: " " in pattern: ") pat/tmpl))
      (define (midlist-error x)
	(error "Pattern ellipsis not at end of list or vector: " x
	       " in pattern: " pat/tmpl))
d560 7
a566 2
	  (if (or (ellipsis? x) (ellipsis-pair? x))
	      (bad-ellipsis pat/tmpl))
d569 23
a591 10
		 (cond ((ellipsis? (car x)) (bad-ellipsis x))
		       ((ellipsis? (cdr x)) (bad-ellipsis x))
		       ((ellipsis-pair? (cdr x))
			(cond
			  ((or (ellipsis? (cddr x)) (ellipsis-pair? (cddr x)))
			   (bad-ellipsis (cdr x)))
			  ((not (or in-template? (null? (cddr x))))
			   (midlist-error x))
			  (else (check (car x)) (check (cddr x)))))
		       (else (check (car x)) (check (cdr x)))))
d595 1
a595 1
		       (bad-ellipsis x)
d709 9
a717 3
		  (fail-unless (list? sexp))
		  (for-each (lambda (sexp) (match (car pat) sexp))
			    sexp))
d731 14
a744 5
	       (let ((vars (list-ids pat #t not-pat-literal?)))
		 (define (collect1 sexp)
		   (map cdr (collect (car pat) sexp '())))
		 (append (apply map list vars (map collect1 sexp))
			 bindings)))
@


1.43
log
@Changed expand-top-level to expand-top-level-forms.

Changed expand-any to take separate dk and bk continuations for
definitions and begin forms (versus the old miscellaneous mk).
Expand-any no longer automatically handles begin expressions when bk
is #f.  Moved this functionality to new expand-expr-or-syntax
function.

Minor changes to map-vecs, substitute-in-store.


Realized that we were not handling these expressions correctly:

   (let () (define if 1) (+ if) if) => 1
   (let () (define if 1) (set! if 2) if) => 2

The uses of IF in the expression on the definitions/expressions
boundary were causing errors because the boundary expression needed to
completely successfully expand in the outer environment before it
would be re-expanded in the inner environment.

To fix this, I changed expand-any to return a thunk to ek as soon as
it is clear that we are dealing with an expression, with all remaining
processing deferred until the thunk is invoked.  Expand-body was
changed to exploit this so that expansion of (+ if) in the outer
environment would be cut short before an error occurred.
Unfortunately, this still doesn't work for cases like:

  (let () (define if 1) ((let-syntax () if +)) 1) => 1

I've decided to fix the problem by changing to expanding boundary
forms in an environment that includes all definitions passed so far
(with defined-syntaxed keywords bound to empty locations), and thus we
will never have to do a re-expansion.  This should be easier to
understand than the "ek returns a thunk as soon as possible"
gyrations.

(Because I've decided to flush the (ek thunk) change, I didn't bother
updating all the comments in this version to reflect it.)
@
text
@d3 1
a3 1
;; $Id: expander.scm,v 1.42 2002/10/03 18:47:08 al Exp al $
d57 2
a58 2
;; (expand-syntax-bindings bindings id-n rec? env store loc-n k)
;;   => (k env store loc-n)
d264 3
a266 3
;; returns (k env store loc-n)
(define (expand-syntax-bindings bindings id-n rec? env store loc-n k)
  (let loop ((bs bindings) (loc-n loc-n) (ienv env))
d268 9
a276 12
	(loop (cdr bs) (+ loc-n 1) (extend-env ienv (sid-id (caar bs)) loc-n))
	(let ((last-loc (- loc-n 1)) (syntax-env (if rec? ienv env)))
	  (let loop ((bs bindings) (syns '()) (store store) (loc-n loc-n))
	    (if (not (null? bs))
		(expand-syntax (cadar bs) id-n syntax-env store loc-n
		  (lambda (syn error-sexp store loc-n)
		    (loop (cdr bs) (cons syn syns) store loc-n)))
		(let loop ((store store) (syns syns) (loc last-loc))
		  (if (not (null? syns))
		      (let ((store (extend-store store loc (car syns))))
			(loop store (cdr syns) (- loc 1)))
		      (k ienv store loc-n)))))))))
d278 1
a278 1
;; For an expression body, returns (ek output-sexp-thunk)
d283 3
a285 3
  ;; returns (k id-n store loc-n vds sds).  If an expression is
  ;; encountered, returns (stop dummy-arg) instead.
  (define (expand-def sexp id-n store loc-n vds sds k stop)
d287 3
a289 1
      (let ((id (sid-id (cadr sexp))))
d292 1
a292 2
	      (error "Duplicate internal definitions: " def
		     " and: " sexp)))
d294 7
a300 9
	(for-each check vds))
      (case builtin
	((define-syntax)
	 (k id-n store loc-n vds (cons sexp sds)))
	((define)
	 (if (null? vds)
	     ((or ek (error "Variable definition in a syntax body: " sexp))
	      (lambda () (k id-n store loc-n (cons sexp vds) sds)))
	     (k id-n store loc-n (cons sexp vds) sds)))))
d302 2
a303 2
      (let loop ((sexps (cdr sexp)) (id-n id-n) (store store) (loc-n loc-n)
		 (vds vds) (sds sds) (stop stop))
d305 28
a332 21
	    (k id-n store loc-n vds sds)
	    (expand-def (car sexps) id-n store loc-n vds sds
			(lambda (id-n store loc-n vds sds)
			  (loop (cdr sexps) id-n store loc-n vds sds #f))
			stop))))
    (expand-any sexp id-n env store loc-n stop #f dk bk))
  (let loop ((sexps sexps) (id-n id-n) (store store) (loc-n loc-n)
	     (vds '()) (sds '()))
    (define first (car sexps))
    (define rest (cdr sexps))
    (define (finish-expr-body)
      (make-var-bindings (map cadr vds) env store loc-n
	(lambda (vars env store loc-n)
	  (expand-syntax-bindings (map cdr sds) id-n #t env store loc-n
	    (lambda (env store loc-n)
	      (define (iexpand sexp) (expand-expr sexp id-n env store loc-n))
	      (define (expand-vd var vd) (list var (iexpand (caddr vd))))
	      (define (make-letrec bindings expr)
		(if (null? bindings) expr (list 'letrec bindings expr)))
	      (make-letrec (map expand-vd vars vds)
			   (make-begin (map iexpand sexps))))))))
d334 5
a338 12
	(if (null? vds)
	    (expand-syntax-bindings (map cdr sds) id-n #t env store loc-n 
	      (lambda (env store loc-n)
		(expand-expr-or-syntax first id-n env store loc-n ek sk)))
	    (finish-expr-body))
	(expand-def first id-n store loc-n vds sds
	  (lambda (id-n store loc-n vds sds)
	    (loop rest id-n store loc-n vds sds))
	  (and ek (lambda (output-thunk)
		    (if (null? vds)
			(ek finish-expr-body)
			(finish-expr-body))))))))
d341 1
d346 8
a353 5
;; If sexp is a syntax, returns (sk syntax sexp store loc-n).  The
;;   returned sexp is just for better error reporting: it is the sid
;;   that was bound to the syntax (unless the syntax is an anonymous
;;   transformer, as in ((syntax-rules () ((_ x) 'x)) foo), in which
;;   case the sexp will be the syntax-rules form).
d356 1
d362 3
a364 3
;; Signals an error if an improper list is encountered.  Also signals
;; an error if ek, sk, dk, or bk is #f and the corresponding thing is
;; encountered.
d386 9
a394 3
		  (expand-syntax-bindings bindings id-n rec? env store loc-n
		    (lambda (env store loc-n)
		      (expand-body (cdr tail) id-n env store loc-n ek sk)))))
d406 1
a406 1
			       (lambda (thunk) (list vars (thunk)))
d435 7
a441 9
		(else ((get-ek sexp) handle-expr-builtin)))))))
    (define (handle-combination head-thunk)
      (ek (lambda ()
	    (let ((output (head-thunk)))
	      (if (and (pair? output) (eq? 'lambda (car output))
		       (null? (cadr output)) (null? (cdr sexp)))
		  ;; simplifies ((lambda () <expr>)) to <expr>
		  (caddr output)
		  (cons output (map expand-subexpr (cdr sexp))))))))
d446 1
a446 1
		 ((get-ek sexp) (lambda () val))
d454 1
a454 1
	   ((get-ek sexp) (lambda () sexp)))
a462 1
    (define (expand-subexpr sexp) (expand-expr sexp id-n env store loc-n))
d464 1
a464 1
    (ek (lambda () (make-begin (map expand-subexpr (cdr sexp))))))
d468 5
a472 2
  (define (ek thunk) (thunk))
  (expand-expr-or-syntax sexp id-n env store loc-n ek #f))
d487 2
a488 2
	  (define (ek thunk)
	    (expand rest id-n store loc-n (cons (thunk) acc) k))
d501 1
a501 1
		    (lambda (syn sexp store loc-n)
d1030 20
a1049 2
;; How about this?:
;;   (let () (define if 1) ((let-syntax () if +)) if)
@


1.42
log
@Simplified let*.
Fixed a typo.
@
text
@d3 1
a3 1
;; $Id: expander.scm,v 1.41 2002/09/25 20:44:50 al Exp al $
d46 5
a50 4
;; (expand-any sexp id-n env store loc-n ek sk mk)
;;  => (ek output)
;;   | (sk syntax sexp store loc-n)
;;   | (mk builtin sexp id-n store loc-n)
d53 2
a54 1
;; (expand-top-level input-sexp store loc-n k) => (k output-sexps store loc-n)
d56 1
a56 1
;; => (ek output-sexp) | (sk syntax sexp store loc-n).
d123 9
a131 9
    (cond ((vector? sexp) (f sexp))
	  ((pair? sexp)
	   (let ((a (car sexp)) (b (cdr sexp)))
	     (let ((a-mapped (mv2 a)))
	       (if a-mapped
		   (cons a-mapped (mv b))
		   (let ((b-mapped (mv2 b)))
		     (and b-mapped (cons a b-mapped))))))) 
	  (else #f)))
d171 7
a177 1
  (define (add-it-if-not-default store)
d180 1
a180 8
	(acons loc val store)))
  (if (not (assv loc store))
      (add-it-if-not-default store)
      (let loop ((store store))
	(let ((p (car store)))
	  (if (eqv? loc (car p))
	      (add-it-if-not-default (cdr store))
	      (cons p (loop (cdr store))))))))
d281 1
a281 1
;; For an expression body, returns (ek output-sexp)
d286 29
a314 38
  ;; returns (dk id-n store loc-n vds sds).  If an expression is
  ;; encountered, returns (ek output) instead.
  (define (expand-def sexp id-n store loc-n vds sds ek dk)
    (expand-any sexp id-n env store loc-n ek #f
      (lambda (builtin sexp id-n store loc-n)
	(define tail (cdr sexp))
	(define (check-def)
	  (or (list2? tail) (error "Malformed definition: " sexp))
	  (let ((sid (car tail)))
	    (or (sid? sid) (error "Bad identifier in definition: " sexp))
	    (let ((id (sid-id sid)))
	      (define (check def)
		(if (eqv? id (sid-id (cadr def)))
		    (error "Duplicate internal definitions: " def
			   " and: " sexp)))
	      (for-each check sds)
	      (if vds (for-each check vds)))))
	(case builtin
	  ((define)
	   (or vds (error "Variable definition in a syntax body: " sexp))
	   (check-def)
	   (dk id-n store loc-n (cons sexp vds) sds))
	  ((define-syntax)
	   (check-def)
	   (dk id-n store loc-n vds (cons sexp sds)))
	  ((begin)
	   (let loop ((sexps tail) (id-n id-n) (store store) (loc-n loc-n)
		      (vds vds) (sds sds) (ek ek))
	     (if (null? sexps)
		 (dk id-n store loc-n vds sds)
		 (expand-def (car sexps) id-n store loc-n vds sds
		   (and ek (lambda (out)
			     (define (expand-another-one sexp)
			       (expand-expr sexp id-n env store loc-n))
			     (let ((rest (map expand-another-one (cdr sexps))))
			       (ek (make-begin (cons out rest))))))
		   (lambda (id-n store loc-n vds sds)
		     (loop (cdr sexps) id-n store loc-n vds sds #f))))))))))
d316 1
a316 1
	     (vds (and ek '())) (sds '()))
d328 20
a347 18
	      (ek (make-letrec (map expand-vd vars vds)
			       (make-begin (map iexpand sexps)))))))))
    (define (maybe-reexpand first-output)
      (define (expand-elt sexp) (expand-expr sexp id-n env store loc-n))
      (if (and (null? vds) (null? sds))
	  (ek (cons 'begin (cons first-output (map expand-elt rest))))
	  (finish-expr-body)))
    (cond ((not (null? rest))
	   (expand-def first id-n store loc-n vds sds (and ek maybe-reexpand)
	     (lambda (id-n store loc-n vds sds)
	       (loop rest id-n store loc-n vds sds))))
	  ((pair? vds) (finish-expr-body))
	  (else (expand-syntax-bindings (map cdr sds) id-n #t env store loc-n 
		  (lambda (env store loc-n)
		    (expand-any first id-n env store loc-n ek sk #f)))))))

;; (expand-any sexp id-n env store loc-n ek sk mk)
;; Ek, sk, and mk are continuations for expressions, syntaxes, and misc..
d350 10
a359 6
;;   returned sexp is just for better error reporting: if the syntax
;;   is a builtin, this sexp will be a sid; if the syntax is a
;;   transformer, this sexp may be a sid or a syntax-rules form.
;; If sexp is a begin, define, or define-syntax, returns (mk builtin
;;   sexp id-n store loc-n).  The car of the returned sexp is just for
;;   error reporting: it is the sid that was bound to the builtin.
d362 10
a371 9
;; an error if ek, sk, or mk is #f and the corresponding thing is
;; encountered.  (But if a begin is encountered and mk is #f, we just
;; expand it as an expression and pass it to ek, unless ek is also #f,
;; in which case we signal an error.)
(define (expand-any sexp id-n env store loc-n ek sk mk)
  (define (efail sexp) (error "Expression used in bad context: " sexp))
  (define (sfail sexp) (error "Syntax used in bad context: " sexp))
  (define (mfail sexp) (error "Definition or begin used in bad context: "
			      sexp))
d373 1
a379 9
	      (define (check-type-and-assert k fail test message)
		(if (not k) (fail sexp))
		(if (not test) (error message sexp)))
	      (define (expr-assert test)
		(check-type-and-assert ek efail test "Malformed expression: "))
	      (define (syntax-assert test)
		(check-type-and-assert sk sfail test "Malformed syntax: "))
	      (define (expand-subexpr sexp)
		(expand-expr sexp id-n env store loc-n))
d388 28
a416 23
		((lambda)
		 (expr-assert (>= len 2))
		 (check-formals (car tail))
		 (make-var-bindings (car tail) env store loc-n
		   (lambda (vars env store loc-n)
		     (expand-body (cdr tail) id-n env store loc-n
		       (lambda (output) (ek (list 'lambda vars output)))
		       #f))))
		((quote)
		 (expr-assert (= len 1))
		 (ek (list 'quote (unwrap-vecs (car tail)))))
		((delay)
		 (expr-assert (= len 1))
		 (ek (list 'delay (expand-subexpr (car tail)))))
		((if)
		 (expr-assert (<= 2 len 3))
		 (ek (cons 'if (map expand-subexpr tail))))
		((set!)
		 (expr-assert (and (= len 2) (sid? (car tail))))
		 (let ((var (lookup2 (car tail) env store)))
		   (or (variable? var)
		       (error "Attempt to set a keyword: " sexp))
		   (ek (list 'set! var (expand-subexpr (cadr tail))))))
d420 1
a420 1
		 (syntax-assert (>= len 1))
d422 15
a436 9
		   (sk syn sexp store loc-n)))
		((begin)
		 (cond (mk (mk builtin sexp id-n store loc-n))
		       (ek (expr-assert (>= len 1))
			   (ek (make-begin (map expand-subexpr tail))))
		       (else (mfail sexp))))
		(else ;; (define define-syntax)
		 (or mk (mfail sexp))
		 (mk builtin sexp id-n store loc-n)))))))
d441 2
a442 2
		 (if ek (ek val) (efail sexp))
		 (if sk (sk val sexp store loc-n) (sfail sexp)))))
d445 3
a447 10
	   (expand-any (car sexp) id-n env store loc-n
	     (and ek (lambda (output)
		       (define (expand-arg sexp)
			 (expand-expr sexp id-n env store loc-n))
		       (ek (if (and (pair? output) (eq? 'lambda (car output))
				    (null? (cadr output)) (null? (cdr sexp)))
			       (caddr output)
			       (cons output (map expand-arg (cdr sexp)))))))
	     handle-syntax-use
	     #f))
d449 1
a449 1
	   ((or ek efail) sexp))
d456 7
d464 2
a465 1
  (expand-any sexp id-n env store loc-n (lambda (x) x) #f #f))
d468 1
a468 1
  (expand-any sexp id-n env store loc-n #f k #f))
d471 1
a471 1
(define (expand-top-level input-sexp store loc-n k)
d475 1
a475 1
  (let expand ((sexp (wrap-vecs input-sexp)) (id-n 0) (env '())
d477 25
a501 28
    (expand-any sexp id-n env store loc-n
      (lambda (output) (k store loc-n (cons output acc)))
      #f
      (lambda (builtin sexp id-n store loc-n)
	(define tail (cdr sexp))
	(define (fail message) (error message sexp))
	(case builtin
	  ((begin)
	   (let loop ((sexps tail) (store store) (loc-n loc-n) (acc acc))
	     (if (null? sexps)
		 (k store loc-n acc)
		 (expand (car sexps) id-n env store loc-n acc
			 (lambda (store loc-n acc)
			   (loop (cdr sexps) store loc-n acc))))))
	  (else
	   (or (and (= 2 (length tail)) (sid? (car tail)))
	       (fail "Malformed definition: "))
	   (let* ((sid (car tail))
		  (loc (lookup-sid sid env)))
	     (if (eq? builtin 'define)
		 (let* ((var (loc->var loc sid))
			(init (expand-expr (cadr tail) id-n env store loc-n))
			(store (substitute-in-store store loc var)))
		   (k store loc-n (cons (list 'define var init) acc)))
		 (expand-syntax (cadr tail) id-n env store loc-n
		   (lambda (syn sexp store loc-n)
		     (let ((store (substitute-in-store store loc syn)))
		       (k store loc-n acc))))))))))))
d766 164
a929 163
  '((let-syntax
	((multi-define
	  (syntax-rules ()
	    ((_ definer (id ...) (init ...))
	     (begin (definer id init) ...))))
	 ;; The private binding for a saved variable is created by a
	 ;; let-syntax, using a dummy syntax as the initializer.  We
	 ;; later assign a value to it using a top-level define (and
	 ;; thus change the status of the binding from keyword to
	 ;; variable).
	 (dummy (syntax-rules ())))
      (syntax-rules (define-protected-macros define-syntax)
	((_ (define-protected-macros let/letrec-syntax
	      (saved-kw ...) (saved-var ...)
	      (define-syntax kw syntax)
	      ...)
	    ...)
	 (begin
	   ((let-syntax ((saved-kw saved-kw) ... (saved-var dummy) ...)
	      (let/letrec-syntax ((kw syntax) ...)
		(syntax-rules ()
		  ((_ top-level-kws top-level-vars)
		   (begin
		     (multi-define define (saved-var ...) top-level-vars)
		     (multi-define define-syntax top-level-kws (kw ...)))))))
	    (kw ...) (saved-var ...))
	   ...))))
    (define-protected-macros letrec-syntax
      (if lambda quote begin define) (eqv?)
      (define-syntax let
	(syntax-rules ()
	  ((_ ((var init) ...) . body)
	   ((lambda (var ...) . body)
	    init ...))
	  ((_ name ((var init) ...) . body)
	   ((letrec ((name (lambda (var ...) . body)))
	      name)
	    init ...))))
      (define-syntax let*
	(syntax-rules ()
	  ((_ () . body) (let () . body))
	  ((let* ((var init) . bindings) . body)
	   (let ((var init)) (let* bindings . body)))))
      (define-syntax letrec
	(syntax-rules ()
	  ((_ ((var init) ...) . body)
	   (let () (define var init) ... (let () . body))))) 
      (define-syntax do
	(let-syntax ((do-step (syntax-rules () ((_ x) x) ((_ x y) y))))
	  (syntax-rules ()
	    ((_ ((var init step ...) ...)
		(test expr ...)
		command ...)
	     (let loop ((var init) ...)
	       (if test
		   (begin (if #f #f) expr ...)
		   (begin command ...
			  (loop (do-step var step ...) ...))))))))
      (define-syntax case
	(letrec-syntax
	    ((compare
	      (syntax-rules ()
		((_ key ()) #f)
		((_ key (datum . data))
		 (if (eqv? key 'datum) #t (compare key data)))))
	     (case
	      (syntax-rules (else)
		((case key) (if #f #f))
		((case key (else result1 . results))
		 (begin result1 . results))
		((case key ((datum ...) result1 . results) . clauses)
		 (if (compare key (datum ...))
		     (begin result1 . results)
		     (case key . clauses))))))
	  (syntax-rules ()
	    ((_ expr clause1 clause ...)
	     (let ((key expr))
	       (case key clause1 clause ...))))))
      (define-syntax cond
	(syntax-rules (else =>)
	  ((_) (if #f #f))
	  ((_ (else . exps)) (let () (begin . exps)))
	  ((_ (x) . rest) (or x (cond . rest)))
	  ((_ (x => proc) . rest)
	   (let ((tmp x)) (cond (tmp (proc tmp)) . rest)))
	  ((_ (x . exps) . rest)
	   (if x (begin . exps) (cond . rest)))))
      (define-syntax and
	(syntax-rules ()
	  ((_) #t)
	  ((_ test) (let () test))
	  ((_ test . tests) (if test (and . tests) #f))))
      (define-syntax or
	(syntax-rules ()
	  ((_) #f)
	  ((_ test) (let () test))
	  ((_ test . tests) (let ((x test)) (if x x (or . tests)))))))
    ;; Prototype-style define is implemented in a
    ;; define-protected-macros with let-syntax scope so that it can
    ;; access the builtin define.  Quasiquote is here too so that it
    ;; can recognize nested uses of itself using a syntax-rules
    ;; literal.  That is, the quasiquote binding that is visible in
    ;; the environment of the quasiquote transformer must be the same
    ;; binding that is visible where quasiquote is used.
    (define-protected-macros let-syntax
      (lambda define quote let) (cons append list vector list->vector)
      (define-syntax define
	(syntax-rules ()
	  ((_ (var . args) . body)
	   (define var (lambda args . body)))
	  ((_ var init) (define var init))))
      (define-syntax quasiquote
        (let-syntax
	    ((tail-preserving-syntax-rules
	      (syntax-rules ()
		((_ literals
		    ((subpattern ...) (subtemplate ...))
		    ...)
		 (syntax-rules literals
		   ((subpattern ... . tail) (subtemplate ... . tail))
		   ...)))))
	  (define-syntax qq
	    (tail-preserving-syntax-rules (unquote unquote-splicing quasiquote)
	      ((_ ,expr ()) (do-next expr))
	      ((_ `x depth) (qq (x) (depth) make-pair 'quasiquote))
	      ((_ ,x (depth)) (qq (x) depth make-pair 'unquote))
	      ((_ ,@@x (depth)) (qq (x) depth make-pair 'unquote-splicing))
	      ((_ (,@@x . y) ()) (qq y () make-splice x))
	      ((_ (x . y) depth) (qq x depth qq-cdr y depth))
	      ((_ #(x ...) depth) (qq (x ...) depth make-vector))
	      ((_ x depth) (do-next 'x))))
	  (define-syntax do-next
	    (syntax-rules ()
	      ((_ expr) expr)
	      ((_ expr next-macro . tail) (next-macro expr . tail))))
	  (define-syntax qq-cdr
	    (tail-preserving-syntax-rules ()
	      ((_ car cdr depth) (qq cdr depth make-pair car))))
	  (define-syntax make-pair
	    (tail-preserving-syntax-rules (quote list)
	      ((_ 'y 'x) (do-next '(x . y)))
	      ((_ '() x) (do-next (list x)))
	      ((_ (list . elts) x) (do-next (list x . elts)))
	      ((_ y x) (do-next (cons x y)))))
	  (define-syntax make-vector
	    (tail-preserving-syntax-rules (quote list)
	      ((_ '(x ...)) (do-next '#(x ...)))
	      ((_ (list . elts)) (do-next (vector . elts)))
	      ((_ expr) (scan-conses () expr expr))))
	  ;; Check if expr is a nesting of conses whose last cdr is a
	  ;; quoted list, i.e., convert (cons x1 (cons x2 (cons x3
	  ;; '(x4 x5 x6)))) to (vector x1 x2 x3 'x4 'x5 'x6).
	  ;; Otherwise, use (list->vector expr).
	  (define-syntax scan-conses
	    (tail-preserving-syntax-rules (quote cons)
	      ((_ (elt ...) (cons x y)) (scan-conses (elt ... x) y))
	      ((_ (elt ...) '(x ...) orig) (do-next (vector elt ... 'x ...)))
	      ((_ elts other orig) (do-next (list->vector orig)))))
	  (define-syntax make-splice
	    (tail-preserving-syntax-rules ()
	      ((_ '() x) (do-next x))
	      ((_ y x) (do-next (append x y)))))
	  (syntax-rules () ((_ template) (let () (qq template ())))))))))
d931 1
a931 1
(define null-stuff (expand-top-level null-prog builtins-store 0 list))
d936 3
a938 3
(define (expand-program sexp)
  (expand-top-level sexp null-store null-loc-n
    (lambda (sexps store loc-n) (make-begin (append null-output sexps)))))
d943 2
a944 2
(define (expand-program! sexp menv)
  (expand-top-level sexp (car menv) (cdr menv)
d948 1
a948 1
      (make-begin sexps))))
d960 1
a960 1
	  (expand-top-level sexp store loc-n
d972 3
a974 3
     (let* ((src (cons 'begin (file->list filename)))
	    (out1 (begin (eval src) (expand-program src))))
       (begin (eval out1) (equal? out1 (expand-program src))))))
d1018 8
@


1.41
log
@"Attempt to redefine a locally bound keyword" is no longer an error.
As a result, macros can now have private top-level variables, and
null-prog takes advantage of this to make case and quasiquote
unaffected by redefinitions of eqv?, cons, etc..

When appropriate, quasiquote now uses list and vector (in addition to
cons, append, and list->vector).

Expand-top-level now returns a list of sexps, rather than a single
begin form.

Changed local variables back to _name_loc.  They had been
_name_id_loc, which gave more information, but was harder to read, and
would have required more effort to support now that we allow
redefinition of let-syntax bindings.
@
text
@d3 1
a3 1
;; $Id: expander.scm,v 1.40 2002/09/16 04:48:48 al Exp al $
d566 2
a567 1
			(error "Duplicate pattern var: " x " in pattern: "))
d763 2
a764 2
  ;; bindings for one other, and recursive calls made by the macros to
  ;; themselves or to one another will not be affected by later
d806 3
a808 7
	  ((_ () body1 body2 ...)
	   (let () body1 body2 ...))
	  ((let* ((name1 val1) (name2 val2) ...)
	     body1 body2 ...)
	   (let ((name1 val1))
	     (let* ((name2 val2) ...)
	       body1 body2 ...)))))
d1050 1
a1050 1
;; 		        (lambda (tmp ...) (lambda () (set! var tmp) ...))))
@


1.40
log
@*** empty log message ***
@
text
@d3 1
a3 1
;; $Id: expander.scm,v 1.39 2002/09/15 23:29:39 al Exp al $
d28 1
a28 1
;; variable: symbol  ; the symbol that is used in the output, e.g. _foo_3_42.
d52 1
a52 1
;; (expand-top-level input-sexp store loc-n k) => (k output-sexp store loc-n)
d168 1
a168 1
(define (substitute-in-store store symloc val)
d170 4
a173 2
    (if (syntax? val) (acons symloc val store) store))
  (if (not (assq symloc store))
d177 1
a177 1
	  (if (eq? symloc (car p))
d198 7
a204 4
  (let ((name-str (symbol->string (sid-name sid)))
	(id-str (if (symbol? sid) "" (number->string (sid-id sid))))
	(loc-str (number->string intloc)))
    (string->symbol (string-append "_" name-str "_" id-str "_" loc-str))))
d467 1
a467 1
;; (returns (k output-sexp store loc-n))
d470 1
a470 1
    (k (make-begin (reverse acc)) store loc-n))
d491 2
a492 3
	   (let ((symloc (lookup-sid (car tail) env)))
	     (or (symbol? symloc)
		 (fail "Attempt to redefine a locally bound keyword: "))
d494 1
a494 1
		 (let* ((var (symloc->var symloc))
d496 1
a496 1
			(store (substitute-in-store store symloc var)))
d500 1
a500 1
		     (let ((store (substitute-in-store store symloc syn)))
d756 38
a793 28
  '(begin
     ((letrec-syntax
	  ((define-syntaxes
	     (syntax-rules ()
	       ((_ (kw ...) (syntax ...))
		(begin (define-syntax kw syntax) ...))))
	   ;; Define-protected-syntaxes defines a set of syntaxes with a
	   ;; private set of bindings for one another, so that if one of
	   ;; the keywords is redefined at top-level, any of the other
	   ;; syntaxes that used it will continue to work.
	   (define-protected-syntaxes
	     (syntax-rules (define-syntax)
	       ((_ (saved-kw ...) (define-syntax kw syntax) ...)
		((let-syntax ((saved-kw saved-kw) ...)
		   (letrec-syntax ((kw syntax) ...)
		     (syntax-rules ()
		       ((_ . kws)
			(define-syntaxes kws
			  ;; Plain (kw ...) would work fine here, but
			  ;; we create indirect macros instead so as
			  ;; to make null-store shorter when printed.
			  ((syntax-rules () ((_ . x) (kw . x))) ...))))))
		 kw ...)))))
	define-protected-syntaxes)
      ;; First argument to define-protected-syntaxes:
      ;; (These are the builtins used by the macros.)
      (if lambda quote begin define)
      ;; Remaining arguments to define-protected-syntaxes:
d839 1
a839 3
		((case key
		   ((datum ...) result1 . results)
		   . clauses)
d866 66
a931 58
     ;; We define signature-style define after we've done letrec, so
     ;; as to disallow (letrec (((f x) (+ x 1))) (f 1)).
     (define-syntax define
       (let-syntax ((define define) (lambda lambda))
	 (syntax-rules ()
	   ((_ (var . args) . body)
	    (define var (lambda args . body)))
	   ((_ var init) (define var init)))))
     ;; Quasiquote needs to be outside of the
     ;; define-protected-syntaxes so that it can recognize nested uses
     ;; of itself using a syntax-rules literal.  That is, the
     ;; quasiquote binding visible where quasiquote is defined must be
     ;; the same binding that is visible where quasiquote is used.
     (define-syntax quasiquote
       (let-syntax
	   ((quote quote)
	    (tail-preserving-syntax-rules
		(syntax-rules ()
		  ((_ literals
		      ((subpattern ...) (subtemplate ...))
		      ...)
		   (syntax-rules literals
		     ((subpattern ... . tail) (subtemplate ... . tail))
		     ...)))))
	 (letrec-syntax
	     ((qq
	       (tail-preserving-syntax-rules
		   (unquote unquote-splicing quasiquote)
		 ((_ ,expr ()) (do-next expr))
		 ((_ `x depth) (qq (x) (depth) make-pair 'quasiquote))
		 ((_ ,x (depth)) (qq (x) depth make-pair 'unquote))
		 ((_ ,@@x (depth)) (qq (x) depth make-pair 'unquote-splicing))
		 ((_ (,@@car . cdr) ())
		  (qq cdr () make-splice car))
		 ((_ (car . cdr) depth)
		  (qq car depth qq-cdr cdr depth))
		 ((_ #(elt ...) depth) (qq (elt ...) depth make-vector))
		 ((_ x depth) (do-next 'x))))
	      (do-next
	       (syntax-rules ()
		 ((_ expr) expr)
		 ((_ expr next-macro . tail) (next-macro expr . tail))))
	      (qq-cdr
	       (tail-preserving-syntax-rules ()
		 ((_ car cdr depth) (qq cdr depth make-pair car))))
	      (make-pair
	       (tail-preserving-syntax-rules (quote)
		 ((_ 'cdr 'car) (do-next '(car . cdr)))
		 ((_ cdr car) (do-next (cons car cdr)))))
	      (make-vector
	       (tail-preserving-syntax-rules (quote)
		 ((_ '(elt ...)) (do-next '#(elt ...)))
		 ((_ expr) (do-next (list->vector expr)))))
	      (make-splice
	       (tail-preserving-syntax-rules ()
		 ((_ cdr car) (do-next (append car cdr))))))
	   (syntax-rules ()
	     ((_ template) (qq template ()))))))))
d934 3
a936 2
(define null-store (cadr null-stuff))
(define null-loc-n (caddr null-stuff))
d940 1
a940 1
    (lambda (sexp store loc-n) sexp)))
d947 1
a947 1
    (lambda (sexp store loc-n)
d950 1
a950 1
      sexp)))
d954 4
d963 2
a964 3
	    (lambda (sexp store loc-n)
	      ;;(write sexp) (newline)
	      (pretty-print sexp)
@


1.39
log
@Some minor changes.
No longer chokes on (expand-program (string->symbol ""))
@
text
@d3 1
a3 1
;; $Id: expander.scm,v 1.38 2002/09/12 05:06:55 al Exp al $
d235 1
a235 2
      (cond ((null? vs) (k vars env store loc-n))
	    ((pair? vs)
d239 1
d296 1
a296 1
	      (and vds (for-each check vds)))))
@


1.38
log
@Found two more begin bugs, one in expand-def and one in expand-any.
They were causing these erroneous expansions:
  (lambda () (begin 1 2) 3)  ==>  (lambda () (begin 1 3))
  ((begin f) x)  ==>  f
@
text
@d3 1
a3 1
;; $Id: expander.scm,v 1.37 2002/09/12 01:28:04 al Exp al $
d102 3
a104 3
  (if (number? location)
      (vector name renamed-id location)
      (vector name renamed-id)))
d115 1
d186 4
a189 1
    (else (case (string-ref str 0) ((#\_) (rename)) (else sym)))))
d201 1
a201 1
(define (maybe-begin outputs)
d312 1
a312 1
			     (define (iexpand sexp)
d314 2
a315 2
			     (let ((rest (map iexpand (cdr sexps))))
			       (ek (maybe-begin (cons out rest))))))
d329 1
a329 1
	      (define (maybe-letrec bindings expr)
d331 2
a332 2
	      (ek (maybe-letrec (map expand-vd vars vds)
				(maybe-begin (map iexpand sexps)))))))))
d425 1
a425 1
			   (ek (maybe-begin (map expand-subexpr tail))))
d430 1
a430 1
    '(pretty-print `(expand-any/again ,sexp))
d437 1
a437 6
	  ((vector? sexp)
	   (error "Vector used as an expression or syntax: " sexp))
	  ((not (pair? sexp)) ((or ek efail) sexp))
	  ((not (list? sexp))
	   (error "Improper list used as an expression or syntax: " sexp))
	  (else
d447 8
a454 1
	     #f)))))
d465 1
a465 1
    (k (maybe-begin (reverse acc)) store loc-n))
d529 2
a530 1
	(error "Misplaced ellipsis: " x " in pattern/template: " pat/tmpl))
a572 1
      (define (finish lits closed?) lits)
d578 1
d594 1
a594 2
		     (or car-closed? (not ellip?)
			 (close-error x))
d653 1
a653 1
	 (define (assert x) (if (not x) (return #f)))
d655 5
a659 4
	   (cond ((sid? pat) (assert (or (not (pat-literal? (sid-id pat)))
					 (and (sid? sexp)
					      (eqv? (lookup-sid pat mac-env)
						    (lookup-sid sexp env))))))
d661 1
a661 1
		  (assert (svector? sexp))
d663 1
a663 1
		 ((not (pair? pat)) (assert (equal? pat sexp)))
d665 1
a665 1
		  (assert (list? sexp))
d668 1
a668 1
		 (else (assert (pair? sexp))
@


1.37
log
@Fixed bug in expand-body: in a begin sequence of internal definitions,
it wasn't allowing variable definitions after the first element.  (It
still correctly refuses to allow expressions after the first element.)

Duplicate binding and duplicate definition errors now report both of
the duplicates.

Removed sid-assv and revappend.
@
text
@d3 1
a3 1
;; $Id: expander.scm,v 1.36 2002/09/11 22:22:23 al Exp al $
d283 1
a283 2
	  (if (not (list2? tail))
	      (error "Malformed definition: " sexp))
d285 1
a285 2
	    (if (not (sid? sid))
		(error "Bad identifier in definition: " sexp))
d306 6
a311 1
		 (expand-def (car sexps) id-n store loc-n vds sds ek
d421 1
a421 1
			   (maybe-begin (map expand-subexpr tail)))
@


1.36
log
@All syntax-rules error messages now include an entire pattern or
template or literals list, in addition to the problem subpattern,
subtemplate or literal.
@
text
@d3 1
a3 1
;; $Id: expander.scm,v 1.35 2002/09/11 06:11:28 al Exp al $
a153 28
;; Like assv, but compares using (eqv? (sid-id x) (sid-id y))
(define (sid-assv sid alist)
  (let ((id (sid-id sid)))
    (let loop ((alist alist))
      (and (not (null? alist))
	   (let ((p (car alist)))
	     (if (eqv? id (sid-id (car p)))
		 p
		 (loop (cdr alist))))))))

;; Top-level variables must be renamed if they conflict with the
;; primitives we use in the output.
(define (symloc->var sym)
  (define str (symbol->string sym))
  (define (rename) (string->symbol (string-append "_" str "_")))
  (case sym
    ((begin define delay if lambda letrec quote set!) (rename))
    (else (case (string-ref str 0) ((#\_) (rename)) (else sym)))))

(define (make-local-var intloc sid)
  (let ((name-str (symbol->string (sid-name sid)))
	(id-str (if (symbol? sid) "" (number->string (sid-id sid))))
	(loc-str (number->string intloc)))
    (string->symbol (string-append "_" name-str "_" id-str "_" loc-str))))

(define (maybe-begin outputs)
  (if (list1? outputs) (car outputs) (cons 'begin outputs)))

d178 21
a198 2
(define (revappend l x)
  (if (null? l) x (revappend (cdr l) (cons (car l) x))))
d251 1
a251 1
	    (error "Duplicate binding for a keyword: " b)))
d275 2
a276 2
  ;; to the vbs and sbs lists of variable and syntax bindings, and
  ;; returns (dk id-n store loc-n vbs sbs).  If an expression is
d278 1
a278 1
  (define (expand-def sexp id-n store loc-n vbs sbs ek dk)
d288 7
a294 2
	    (if (or (sid-assv sid vbs) (sid-assv sid sbs))
		(error "Duplicate internal definition: " sexp))))
d297 1
a297 1
	   (or ek (error "Variable definition in a syntax body: " sexp))
d299 1
a299 1
	   (dk id-n store loc-n (cons tail vbs) sbs))
d302 1
a302 1
	   (dk id-n store loc-n vbs (cons tail sbs)))
d305 1
a305 1
		      (vbs vbs) (sbs sbs) (ek ek))
d307 4
a310 4
		 (dk id-n store loc-n vbs sbs)
		 (expand-def (car sexps) id-n store loc-n vbs sbs ek
		   (lambda (id-n store loc-n vbs sbs)
		     (loop (cdr sexps) id-n store loc-n vbs sbs #f))))))))))
d312 1
a312 1
	     (vbs '()) (sbs '()))
d316 1
a316 1
      (make-var-bindings (map car vbs) env store loc-n
d318 1
a318 1
	  (expand-syntax-bindings sbs id-n #t env store loc-n
d321 1
a321 1
	      (define (expand-vb var vb) (list var (iexpand (cadr vb))))
d324 1
a324 1
	      (ek (maybe-letrec (map expand-vb vars vbs)
d328 1
a328 1
      (if (and (null? vbs) (null? sbs))
d332 7
a338 8
	   (expand-def first id-n store loc-n vbs sbs (and ek maybe-reexpand)
	     (lambda (id-n store loc-n vbs sbs)
	       (loop rest id-n store loc-n vbs sbs))))
	  ((null? vbs)
	   (expand-syntax-bindings sbs id-n #t env store loc-n 
	     (lambda (env store loc-n)
	       (expand-any first id-n env store loc-n ek sk #f))))
	  (else (finish-expr-body)))))
d939 4
a942 3
   (let* ((src (cons 'begin (file->list "expander.scm")))
	  (out1 (begin (eval src) (expand-program src))))
     (begin (eval out1) (equal? out1 (expand-program src)))))
@


1.35
log
@First version to pass Oleg's syntax-rule-stress-test.scm

Changed a use of vector? to svector? to fix a bug in apply-transformer.
Removed non-standard calls to = with less than two arguments.

Several cleanups that reduce consing a bit:
Added sid-assv, which is used in expand-body.
Removed check-sids.  Added check-formals and check-syntax-bindings.
General cleanup of compile-syntax-rules.
@
text
@d3 1
a3 1
;; $Id: expander.scm,v 1.34 2002/09/09 04:27:35 al Exp al $
d211 1
a211 1
    (error "Non-identifier " x " in lambda formals: " formals))
d213 1
a213 1
    (error "Duplicate variable " sid " in lambda formals: " formals))
d354 1
a354 1
;;   error reporting.
d510 1
a510 1
	(error "Non-identifier " lit
d525 4
a528 1
	(error "Ellipsis not preceded by a subpattern or subtemplate: " x))
d541 1
a541 1
			   (error "Junk following a pattern ellipsis: " x))
d556 2
a557 1
		       ((assv id l) (error "Duplicate pattern var: " x))
d569 5
d581 1
a581 1
				 (error "Pattern var used at bad depth: " x))
d590 1
a590 1
			 (error "Template ellipsis closes no variables: " x))
d773 1
a773 1
      (if lambda quote set! begin define)
d939 8
a946 7
'((define (file->list file)
    (define (f) (let ((x (read))) (if (eof-object? x) '() (cons x (f)))))
    (with-input-from-file file f))

  (let* ((src (cons 'begin (file->list "expander.scm")))
	 (out1 (begin (eval src) (expand-program src))))
    (begin (eval out1) (equal? out1 (expand-program src)))))
@


1.34
log
@Fixed bug in delay.
Changed repl to use pretty-print.
@
text
@d3 1
a3 1
;; $Id: expander.scm,v 1.33 2002/09/06 20:17:26 al Exp al $
a76 2
;; pat-vars-alist: ((id (pat-ellip-num . accessors) ... (0 . accessors)) ...)
;; tmpl-ellip-alist: ((tmpl-ellip-num pat-ellip-num ...) ...)
d78 7
d154 10
d209 20
a228 11
(define (check-sids sids)
  (let loop ((sids sids) (others '()))
    (if (not (null? sids))
	(let ((sid (if (pair? sids) (car sids) sids)))
	  (if (not (sid? sid))
	      (error "Attempt to bind non-identifier: " sid)
	      (let ((id (sid-id sid)))
		(if (memv id others)
		    (error "Attempt to bind duplicate identifiers: " sid)
		    (if (pair? sids)
			(loop (cdr sids) (cons id others))))))))))
d231 31
a261 12
(define (make-var-bindings sids env store loc-n k)
  (check-sids sids)
  (let loop ((sids sids) (env env) (store store) (loc-n loc-n) (vars '()))
    (if (null? sids)
	(k (reverse vars) env store loc-n)
	(let* ((sid (if (pair? sids) (car sids) sids))
	       (var (make-local-var loc-n sid))
	       (env (extend-env env (sid-id sid) loc-n))
	       (store (extend-store store loc-n var)))
	  (if (pair? sids)
	      (loop (cdr sids) env store (+ 1 loc-n) (cons var vars))
	      (k (revappend vars var) env store (+ 1 loc-n)))))))
d265 14
a278 20
  (define (check-binding binding)
    (or (list2? binding) (error "Malformed syntax binding: " binding)))
  (or (list? bindings) (error "Malformed syntax bindings list: " bindings))
  (for-each check-binding bindings)
  (let ((sids (map car bindings)) (sexps (map cadr bindings)))
    (check-sids sids)
    (let loop ((ids (map sid-id sids)) (loc-n loc-n) (ienv env))
      (if (not (null? ids))
	  (loop (cdr ids) (+ loc-n 1) (extend-env ienv (car ids) loc-n))
	  (let ((last-loc (- loc-n 1)) (syntax-env (if rec? ienv env)))
	    (let loop ((sexps sexps) (syns '()) (store store) (loc-n loc-n))
	      (if (not (null? sexps))
		  (expand-syntax (car sexps) id-n syntax-env store loc-n
		    (lambda (syn error-sexp store loc-n)
		      (loop (cdr sexps) (cons syn syns) store loc-n)))
		  (let loop ((store store) (syns syns) (loc last-loc))
		    (if (not (null? syns))
			(let ((store (extend-store store loc (car syns))))
			  (loop store (cdr syns) (- loc 1)))
			(k ienv store loc-n))))))))))
d292 7
a298 2
	  (if (not (and (list2? tail) (sid? (car tail))))
	      (error "Malformed definition: " sexp)))
d325 1
d328 1
a328 1
	      (ek (maybe-letrec (map list vars (map iexpand (map cadr vbs)))
d353 2
a354 2
;;   sexp id-n store loc-n).  The car of the sexp is just for error
;;   reporting.
d364 2
a365 2
  (define (mfail sexp)
    (error "Definition or begin used in bad context: " sexp))
d385 5
a389 3
		(expand-syntax-bindings (car tail) id-n rec? env store loc-n
		  (lambda (env store loc-n)
		    (expand-body (cdr tail) id-n env store loc-n ek sk))))
d393 1
d428 1
d498 1
a498 1
;;   literals is not a list of distinct identifiers
d508 7
a514 2
  (or (list? pattern-lits) (error "Malformed literals list: " pattern-lits))
  (check-sids pattern-lits)
d523 1
a523 1
    (define (list-ids pat/tmpl in-template? var-depths)
d525 1
a525 1
	(error "Ellipsis not preceded by a pattern or template: " x))
d529 2
a530 21
	(let collect ((x x) (depth 0) (l '()))
	  (cond ((sid? x)
		 (let ((id (sid-id x)))
		   (if in-template?
		       (cond ((assv id var-depths)
			      => (lambda (p)
				   (let ((pat-depth (cdr p)))
				     (if (and (positive? pat-depth)
					      (not (= pat-depth depth)))
					 (error "Pattern var at bad depth: " x)
					 l))))
			     (else (cons id l)))
		       (cond ((memv id pattern-lits) l)
			     ((assv id l) (error "Duplicate pattern var: " x))
			     (else (acons id depth l))))))
		((vector? x)
		 (let ((elts (svector->list x)))
		   (if (ellipsis-pair? elts)
		       (bad-ellipsis x)
		       (collect elts depth l))))
		((pair? x)
d535 2
d538 38
a575 16
			   (error "Subpattern following a pattern ellipsis: "
				  x))
			  ((or (ellipsis? (cddr x))
			       (ellipsis-pair? (cddr x)))
			   (bad-ellipsis (cdr x)))
			  (else (collect (car x) (+ 1 depth)
					 (collect (cddr x) depth l)))))
		       (else
			(collect (car x) depth (collect (cdr x) depth l)))))
		(else l)))))

    (define (check-ellipses tmpl var-depths)
      (let check ((x tmpl) (depth 0))
	(cond ((sid? x) (let ((p (assv (sid-id x) var-depths)))
			  (and p (= depth (cdr p)))))
	      ((vector? x) (check (svector->list x) depth))
d577 9
a585 8
	       (if (ellipsis-pair? (cdr x))
		   (begin
		     (check (cddr x) depth)
		     (or (check (car x) (+ depth 1))
			 (error "Template ellipsis closes no variables: " x)))
		   (let ((cdr-result (check (cdr x) depth)))
		     (or (check (car x) depth) cdr-result))))
	      (else #f))))
d587 3
a589 2
    (define (list-template-lits rule)
      (or (list2? rule) (error "Malformed rule: " rule))
d593 3
a595 4
	(let* ((var-depths (list-ids pat #f #f))
	       (lits (list-ids tmpl #t var-depths)))
	  (check-ellipses tmpl var-depths)
	  lits)))
d600 2
a601 2
	((lits (apply append pattern-lits (map list-template-lits rules)))
	 (bindings (if ellipsis-binding (list ellipsis-binding) '())))
d603 1
a603 1
	  (cons bindings (cons pattern-lits rules))
d606 3
a608 3
		  (cond ((and (not (assv lit bindings)) (assv lit env))
			 => (lambda (binding) (cons binding bindings)))
			(else bindings))))))))
d663 1
a663 1
	      ((vector? pat)
d710 2
a711 1
		    (if (apply = (map length val-lists))
d963 15
a977 21
'(define-syntax letrec
  (let-syntax
      ((make-setter
	(syntax-rules ()
	  ((_ (tmp ...) ready? (var ...))
	   (lambda (tmp ...) (set! ready? #t) (set! var) ...)))))
    (syntax-rules ()
      ((_ ((var init) ...) . body)
       (let ((ready? #f) (var #f) ...)
	 (let-syntax
	     ((var
	       (syntax-rules (set!)
		 ((_ set! val) (if ready? (set! var val) (error)))
		 ((_ . args) ((if ready? var (error)) . args))
		 (_ (if ready? var (error)))))
	      ...
	      (call-make-setter
	       (syntax-rules ()
		 ((_ vars) (make-setter (var ...) ready? vars)))))
	   ((call-make-setter (var ...)) init ...)
	   (let () . body)))))))
@


1.33
log
@*** empty log message ***
@
text
@d3 1
a3 1
;; $Id: expander.scm,v 1.32 2002/09/06 20:07:05 al Exp al $
d358 1
a358 1
		 (ek (cons 'delay (expand-subexpr (car tail)))))
d866 2
a867 2
	      (write sexp)
	      (newline)
d901 24
@


1.32
log
@Removed a remnant of top-let-syntax processing from expand-top-level
@
text
@d3 1
a3 1
;; $Id: expander.scm,v 1.31 2002/09/06 12:33:16 al Exp al $
d283 2
a284 2
	      (define (maybe-letrec bs e)
		(if (null? bs) e (list 'letrec bs e)))
@


1.31
log
@Removed comments about annotations.
Removed object->string.

Added repl.

About to send to Oleg
@
text
@d3 1
a3 1
;; $Id: expander.scm,v 1.30 2002/09/06 07:08:36 al Exp al $
a423 7
	(define (do-begin sexps env store loc-n)
	  (let loop ((sexps sexps) (store store) (loc-n loc-n) (acc acc))
	    (if (null? sexps)
		(k store loc-n acc)
		(expand (car sexps) id-n env store loc-n acc
			(lambda (store loc-n acc)
			  (loop (cdr sexps) store loc-n acc))))))
d425 7
a431 1
	  ((begin) (do-begin tail env store loc-n))
@


1.30
log
@Simplified calling sequence of miscellaneous combinations:
was (mk builtin sid tail id-n store loc-n);
now (mk builtin sexp     id-n store loc-n).
@
text
@d3 1
a3 1
;; $Id: expander.scm,v 1.29 2002/09/06 04:01:48 al Exp al $
d10 1
a10 27
'((define (file->list file)
    (define (f) (let ((x (read))) (if (eof-object? x) '() (cons x (f)))))
    (with-input-from-file file f))
  (let* ((src (cons 'begin (file->list "expander.scm")))
	 (out1 (begin (eval src) (expand-program src))))
    (begin (eval out1) (equal? out1 (expand-program src)))))

;; [Some Future plans:]
;; input and output are annotated s-expressions, or asexps.

;; (unannotate asexp) returns a number, character, string, boolean, null,
;; symbol, or a pair or vector of asexps.

;; (annotate asexp pair-vec-sym) returns an annotated pair, vector, or
;; symbol using the annotation of asexp (which is always of the same type
;; as pair-vec-sym).

;; (bogus-annotate pair-vec) returns an annotated pair or vector with
;; a bogus annotation.  We promise never to use one of these in the
;; completely expanded output.  They would be used to store renamed
;; ids as annotated vectors within an asexp, and to temporarily store
;; the elements of an annotated vector in an annotated list (i.e. the
;; vector->list and list->vector operations done during macro
;; transcription).


;; Current Model:
d81 2
a82 2
;; If we compile transformers with eval and scheme-report-environment,
;; patterns would use:
d84 1
a84 1
;;   pair?, vector?, vector-length, vector-ref, +, -, zero?, =, >
d86 1
a86 24
;;   lambda, if, car, cdr, null?, symbol?
;;   pair?, vector-length, vector-ref, +, -, zero?, =, >
;;   cons, vector, list->vector

;; ;; idea for syntax-rules extension to provide automatic gensym sequences:
;; (syntax-rules with-id-sequence ()
;;   ((letrec ((var init) ... (with-id-sequence temp)) . body)
;;    (let ((var 'undefined) ...)
;;      (let ((temp init) ...)
;;        (set! var temp) ... (let () . body)))))

;; (syntax-rules with-ids ()
;;   ((letrec-values (((var ... (with-ids tmp)) init) ... (with-ids thunk))
;;      . body)
;;    (letrec ((var 'undefined) ... ...
;; 	    (thunk (call-with-values (lambda () init)
;; 		     (lambda (tmp ...) (lambda () (set! var tmp) ...))))
;; 	    ...)
;;      (thunk) ... (let () . body))))

;; (syntax-rules with-ids ()
;;   ((set!-values (var ... (with-ids tmp)) expr)
;;    (call-with-values (lambda () expr)
;;      (lambda (tmp ...) (if #f #f) (set! var tmp) ...))))
a515 2
      (define (bad-ellipsis x)
	(error "Ellipsis not preceded by a pattern or template: " x))
d858 13
d872 8
a879 150
(define (object->string obj)
  (define abbrevs-alist
    '((quote . "'") (quasiquote . "`") (unquote . ",")
      (unquote-splicing . ",@@")))    
  (define (collect obj l)
    (cond ((pair? obj)
	   (cond ((and (list1? (cdr obj)) (assq (car obj) abbrevs-alist))
		  => (lambda (p) (cons (cdr p) (collect (cadr obj) l))))
		 (else
		  (cons "("
			(collect
			 (car obj)
			 (let collect-cdr ((obj (cdr obj)) (l (cons ")" l)))
			   (cond ((null? obj) l)
				 ((pair? obj)
				  (cons " "
					(collect
					 (car obj)
					 (collect-cdr (cdr obj) l))))
				 (else (cons " . " (collect obj l))))))))))
	  ((vector? obj)
	   (let ((len (vector-length obj)))
	     (if (zero? len)
		 (cons "#()" l)
		 (cons "#("
		       (do ((i (- len 1) (- i 1))
			    (l (cons ")" l)
			       (cons " " (collect (vector-ref obj i) l))))
			   ((zero? i) (collect (vector-ref obj 0) l)))))))
	  ((string? obj)
	   (let ((len (string-length obj)))
	     (let check-for-specials ((i 0))
	       (if (= i len)
		   `("\"" ,obj "\"" . ,l)
		   (case (string-ref obj i)
		     ((#\\ #\")
		      (do ((i (- len 1) (- i 1))
			   (s '(#\")
			      (let* ((c (string-ref obj i))
				     (s (cons c s)))
				(case c
				  ((#\\ #\") (cons #\\ s))
				  (else s)))))
			  ((< i 0) (cons (apply string #\" s) l))))
		     (else (check-for-specials (+ i 1))))))))
	  (else (cons (cond ((input-port? obj) "#<input-port>")
			    ((output-port? obj) "#<output-port>")
			    ((eof-object? obj) "#<eof-object>")
			    ((procedure? obj) "#<procedure>")
			    ((number? obj) (number->string obj))
			    ((symbol? obj) (symbol->string obj))
			    ((boolean? obj) (if obj "#t" "#f"))
			    ((null? obj) "()")
			    ((char? obj) (case obj
					   ((#\newline) "#\\newline")
					   ((#\space) "#\\space")
					   (else (string #\# #\\ obj))))
			    (else "#<unknown>"))
		      l))))
  (apply string-append (collect obj '())))

;; If n is at least 18, always returns a string of length <=n.
;; Otherwise, might return #f.
(define (object->string-n obj n)
  (define puncts-alist
    '((quote . "'") (quasiquote . "`") (unquote . ",")
      (unquote-splicing . ",@@")))    
  (define (collect obj n l k)
    (cond ((negative? n) (k n l))
	  ((pair? obj)
	   (cond ((and (list1? (cdr obj)) (assq (car obj) puncts-alist))
		  => (lambda (p)
		       (let* ((punct (cdr p))
			      (len (string-length punct)))
		       (collect (cadr obj) (- n len) (cons punct l)
			 (lambda (n* l*)
			   (if (negative? n*)
			       (k (- n 6) (cons "(#...)" l))
			       (k n* l*)))))))
		 ((null? (cdr obj))
		  (collect (car obj) (- n 2) (cons "(" l)
		    (lambda (n* l*)
		      (if (negative? n*)
			  (k (- n 6) (cons "(#...)" l))
			  (k n* (cons ")" l*))))))
		 ((list? obj)
		  (collect (car obj) (- n )
		   (let collect-cdr ((obj (cdr obj)) (l (cons ")" l)))
		     (cond ((null? obj) l)
			   ((pair? obj)
			    (cons " "
				  (collect
				   (car obj)
				   (collect-cdr (cdr obj) l))))
			   (else (cons " . " (collect obj l))))))
		  (cons "("
			))
		 (else
		  (cons "("
			(collect
			 (car obj)
			 (let collect-cdr ((obj (cdr obj)) (l (cons ")" l)))
			   (cond ((null? obj) l)
				 ((pair? obj)
				  (cons " "
					(collect
					 (car obj)
					 (collect-cdr (cdr obj) l))))
				 (else (cons " . " (collect obj l))))))))))
	  ((vector? obj)
	   (let ((len (vector-length obj)))
	     (if (zero? len)
		 (cons "#()" l)
		 (cons "#("
		       (do ((i (- len 1) (- i 1))
			    (l (cons ")" l)
			       (cons " " (collect (vector-ref obj i) l))))
			   ((zero? i) (collect (vector-ref obj 0) l)))))))
	  ((string? obj)
	   (let ((len (string-length obj)))
	     (let check-for-specials ((i 0))
	       (if (= i len)
		   `("\"" ,obj "\"" . ,l)
		   (case (string-ref obj i)
		     ((#\\ #\")
		      (do ((i (- len 1) (- i 1))
			   (s '(#\")
			      (let* ((c (string-ref obj i))
				     (s (cons c s)))
				(case c
				  ((#\\ #\") (cons #\\ s))
				  (else s)))))
			  ((< i 0) (cons (apply string #\" s) l))))
		     (else (check-for-specials (+ i 1))))))))
	  (else (cons (cond ((input-port? obj) "#<input-port>")
			    ((output-port? obj) "#<output-port>")
			    ((eof-object? obj) "#<eof-object>")
			    ((procedure? obj) "#<procedure>")
			    ((number? obj) (number->string obj))
			    ((symbol? obj) (symbol->string obj))
			    ((boolean? obj) (if obj "#t" "#f"))
			    ((null? obj) "()")
			    ((char? obj) (case obj
					   ((#\newline) "#\\newline")
					   ((#\space) "#\\space")
					   (else (string #\# #\\ obj))))
			    (else "#<unknown>"))
		      l))))
  (apply string-append (collect obj n '())))

d889 1
d898 1
d920 25
@


1.29
log
@Changed names of syn-let-syntax and syn-letrec-syntax back to just
plain let-syntax and letrec-syntax, with disambiguation by content.

Flushed top-let-syntax and top-letrec-syntax after realizing that the
ability to place a macro-block transformer directly in a macro call at
top level, i.e. ((let-syntax ... syntax) arg ...) obviated the need
for them.  Rewrote define-protected-syntaxes accordingly.
@
text
@d3 1
a3 1
;; $Id: expander.scm,v 1.28 2002/09/06 02:18:36 al Exp al $
d75 1
a75 1
;;   | (mk builtin sid tail id-n store loc-n)
d102 5
d301 2
a302 2
      (lambda (builtin sid tail id-n store loc-n)
	(define (err-sexp) (cons sid tail))
d305 1
a305 1
	      (error "Malformed definition: " (err-sexp))))
d308 1
a308 1
	   (or ek (error "Variable definition in a syntax body: " (err-sexp)))
d359 2
a360 1
;;   sid tail id-n store loc-n).  The sid is just for error reporting.
d374 57
a430 58
      (define tail (cdr sexp))
      (if (transformer? syntax)
	  (apply-transformer syntax (cons head tail) id-n env
	    (lambda (sexp id-n) (again sexp id-n store loc-n)))
	  (let ((builtin (builtin-name syntax)) (len (length tail)))
	    (define (err-sexp) (cons head tail))
	    (define (check-type-and-assert k fail test message)
	      (if (not k) (fail (err-sexp)))
	      (if (not test) (error message (err-sexp))))
	    (define (expr-assert test)
	      (check-type-and-assert ek efail test "Malformed expression: "))
	    (define (syntax-assert test)
	      (check-type-and-assert sk sfail test "Malformed syntax: "))
	    (define (expand-subexpr sexp)
	      (expand-expr sexp id-n env store loc-n))
	    (define (handle-let-syntax rec?)
	      (or ek sk (error "Macro block used in bad context: " sexp))
	      (or (>= len 2) (error "Malformed macro block: " sexp))
	      (expand-syntax-bindings (car tail) id-n rec? env store loc-n
		(lambda (env store loc-n)
		  (expand-body (cdr tail) id-n env store loc-n ek sk))))
	    (case builtin
	      ((lambda)
	       (expr-assert (>= len 2))
	       (make-var-bindings (car tail) env store loc-n
		 (lambda (vars env store loc-n)
		   (expand-body (cdr tail) id-n env store loc-n
		     (lambda (output) (ek (list 'lambda vars output)))
		     #f))))
	      ((quote)
	       (expr-assert (= len 1))
	       (ek (list 'quote (unwrap-vecs (car tail)))))
	      ((delay)
	       (expr-assert (= len 1))
	       (ek (cons 'delay (expand-subexpr (car tail)))))
	      ((if)
	       (expr-assert (<= 2 len 3))
	       (ek (cons 'if (map expand-subexpr tail))))
	      ((set!)
	       (expr-assert (and (= len 2) (sid? (car tail))))
	       (let ((var (lookup2 (car tail) env store)))
		 (or (variable? var)
		     (error "Attempt to set a keyword: " (err-sexp)))
		 (ek (list 'set! var (expand-subexpr (cadr tail))))))
	      ((let-syntax) (handle-let-syntax #f))
	      ((letrec-syntax) (handle-let-syntax #t))
	      ((syntax-rules)
	       (syntax-assert (>= len 1))
	       (let ((trans (compile-syntax-rules (car tail) (cdr tail) env)))
		 (sk trans (err-sexp) store loc-n)))
	      ((begin)
	       (cond (mk (mk builtin head tail id-n store loc-n))
		     (ek (expr-assert (>= len 1))
			 (maybe-begin (map expand-subexpr tail)))
		     (else (mfail (err-sexp)))))
	      (else ;; (define define-syntax)
	       (or mk (mfail (err-sexp)))
	       (mk builtin head tail id-n store loc-n))))))
d470 3
a472 2
      (lambda (builtin sid tail id-n store loc-n)
	(define (fail message) (error message (cons sid tail)))
@


1.28
log
@Added top-level procedure maybe-begin, and changed expand-any,
expand-body, and expand-top-level to use it.  Macros can now expand an
expression sequence to (let () (begin x ...)), which avoids
ambiguities about whether an x is an expression or a definition, and
still expands to a simple expression if there is only one x.  Changed
(cond (else x ...)) to use this feature.  Made a couple other changes
to null-program.

Changed scope of the signature-style define macro, so that error
messages will no longer expose the name plain-define.
@
text
@d3 1
a3 1
;; $Id$
d57 1
a57 1
;; transformer: (rule ...)
d84 2
d88 1
d98 2
a99 2
;;    | #(stack-index (accessor ...))        ;; a variable or inserted literal
;;    | #((tmpl ...))                       ;; a vector template
a100 1
;; ellipsis: the symbol named "..."
d316 1
a316 2
		     (loop (cdr sexps) id-n store loc-n vbs sbs #f))))))
	  (else (error "Top-level form used in a body: " (err-sexp)))))))
d321 1
a321 1
    (define (finish-body)
d335 1
a335 1
	  (finish-body)))
d344 1
a344 1
	  (else (finish-body)))))
d353 2
a354 3
;; If sexp is a begin, define, define-syntax, top-let-syntax, or
;;   top-letrec-syntax form, returns (mk builtin sid tail id-n store
;;   loc-n).  The sid is just for error reporting.
d365 1
a365 1
    (error "Definition or top-level form used in bad context: " sexp))
d383 3
a385 2
	    (define (handle-let-syntax asserter rec? ek sk)
	      (asserter (>= len 2))
d412 2
a413 4
	      ((let-syntax) (handle-let-syntax expr-assert #f ek #f))
	      ((letrec-syntax) (handle-let-syntax expr-assert #t ek #f))
	      ((syn-let-syntax) (handle-let-syntax syntax-assert #f #f sk))
	      ((syn-letrec-syntax) (handle-let-syntax syntax-assert #t #f sk))
d420 4
a423 3
		     (else (expr-assert (>= len 1))
			   (maybe-begin (map expand-subexpr tail)))))
	      (else ;; (define define-syntax top-let-syntax top-letrec-syntax)
d476 1
a476 1
	  ((define define-syntax)
d481 1
a481 1
		 (fail "Attempt to redefine a top-let-syntax keyword: "))
d490 1
a490 7
		       (k store loc-n acc)))))))
	  ((top-let-syntax top-letrec-syntax)
	   (or (pair? tail) (fail "Missing bindings in macro block:"))
	   (let ((rec? (eq? builtin 'top-letrec-syntax)))
	     (expand-syntax-bindings (car tail) id-n rec? env store loc-n
	       (lambda (env store loc-n)
		 (do-begin (cdr tail) env store loc-n))))))))))
d716 2
a717 3
  '(begin if lambda quote set! delay let-syntax letrec-syntax
	  syntax-rules syn-let-syntax syn-letrec-syntax
	  define define-syntax top-let-syntax top-letrec-syntax))
d726 10
a735 19
     (top-let-syntax
	 ((if if) (lambda lambda) (quote quote) (set! set!) (begin begin)
	  (define define)  ;; the builtin define, w/o signature support.
	  ;; Define-protected-syntaxes defines a set of syntaxes with a
	  ;; private set of bindings for one another, so that if one of
	  ;; the keywords is redefined at top-level, any of the other
	  ;; syntaxes that used it will continue to work.
	  (define-protected-syntaxes
	   (syn-let-syntax
	       ((define-syntaxes
		  (syntax-rules ()
		    ((_ (kw ...) syntax ...)
		     ;; This works:
		     ;;  (begin (define-syntax kw syntax) ...)
		     ;; We do it the indirect way just to make null-store
		     ;; shorter when printed.
		     (begin (define-syntax kw
			      (syntax-rules () ((_ . args) (syntax . args))))
			    ...)))))
d737 90
a826 82
	       ((_ (define-syntax kw syntax) ...)
		(top-let-syntax
		    ((m (syn-letrec-syntax ((kw syntax) ...)
			  (syntax-rules ()
			    ((_ . top-level-kws)
			     (define-syntaxes top-level-kws kw ...))))))
		  (m kw ...)))))))
       (define-protected-syntaxes
	 (define-syntax let
	   (syntax-rules ()
	     ((_ ((var init) ...) . body)
	      ((lambda (var ...) . body)
	       init ...))
	     ((_ name ((var init) ...) . body)
	      ((letrec ((name (lambda (var ...) . body)))
		 name)
	       init ...))))
	 (define-syntax let*
	   (syntax-rules ()
	     ((_ () body1 body2 ...)
	      (let () body1 body2 ...))
	     ((let* ((name1 val1) (name2 val2) ...)
		body1 body2 ...)
	      (let ((name1 val1))
		(let* ((name2 val2) ...)
		  body1 body2 ...)))))
	 (define-syntax letrec
	   (syntax-rules ()
	     ((_ ((var init) ...) . body)
	      (let () (define var init) ... (let () . body))))) 
	 (define-syntax do
	   (syn-let-syntax ((do-step (syntax-rules () ((_ x) x) ((_ x y) y))))
	     (syntax-rules ()
	       ((_ ((var init step ...) ...)
		   (test expr ...)
		   command ...)
		(let loop ((var init) ...)
		  (if test
		      (begin (if #f #f) expr ...)
		      (begin command ...
			     (loop (do-step var step ...) ...))))))))
	 (define-syntax case
	   (syn-letrec-syntax
	       ((compare
		 (syntax-rules ()
		   ((_ key ()) #f)
		   ((_ key (datum . data))
		    (if (eqv? key 'datum) #t (compare key data)))))
		(case
		 (syntax-rules (else)
		   ((case key) (if #f #f))
		   ((case key (else result1 . results))
		    (begin result1 . results))
		   ((case key
		      ((datum ...) result1 . results)
		      . clauses)
		    (if (compare key (datum ...))
			(begin result1 . results)
			(case key . clauses))))))
	     (syntax-rules ()
	       ((_ expr clause1 clause ...)
		(let ((key expr))
		  (case key clause1 clause ...))))))
	 (define-syntax cond
	   (syntax-rules (else =>)
	     ((_) (if #f #f))
	     ((_ (else . exps)) (let () (begin . exps)))
	     ((_ (x) . rest) (or x (cond . rest)))
	     ((_ (x => proc) . rest)
	      (let ((tmp x)) (cond (tmp (proc tmp)) . rest)))
	     ((_ (x . exps) . rest)
	      (if x (begin . exps) (cond . rest)))))
	 (define-syntax and
	   (syntax-rules ()
	     ((_) #t)
	     ((_ test) (let () test))
	     ((_ test . tests) (if test (and . tests) #f))))
	 (define-syntax or
	   (syntax-rules ()
	     ((_) #f)
	     ((_ test) (let () test))
	     ((_ test . tests) (let ((x test)) (if x x (or . tests))))))))
d830 1
a830 1
       (syn-let-syntax ((define define) (lambda lambda))
d841 1
a841 1
       (syn-let-syntax
d851 1
a851 1
	 (syn-letrec-syntax
d1087 5
@


1.27
log
@Optimized output case of ((lambda () foo)) to just output foo.  This
means that letrec and other macros that do (let () . body) just for
the sake of internal definitions will not clutter the output with
extra lambdas.
@
text
@d1 8
a8 1
;; macro expander
d14 1
a14 1
	 (out1 (expand-program src)))
d206 3
d298 1
a298 1
	      (error "Malformed definition: ") (err-sexp)))
a325 1
	      (define (maybe-begin l) (if (list1? l) (car l) (cons 'begin l)))
d422 1
a422 1
			   (ek (cons 'begin (map expand-subexpr tail))))))
d458 1
a458 2
    (let ((output (if (list1? acc) (car acc) (cons 'begin (reverse acc)))))
      (k output store loc-n)))
d478 1
a478 1
	       (fail "Malformed definition"))
d732 94
a825 57
  '(top-let-syntax
       ((if if) (lambda lambda) (quote quote) (set! set!) (begin begin)
	(plain-define define)  ;; the builtin define, w/o signature support.
	;; Define-protected-syntaxes defines a set of syntaxes with a
	;; private set of bindings for one another, so that if one of
	;; the keywords is redefined at top-level, any of the other
	;; syntaxes that used it will continue to work.
	(define-protected-syntaxes
	 (syn-let-syntax
	     ((define-syntaxes
		(syntax-rules ()
		  ((_ (kw ...) syntax ...)
		   ;; This works:
		   ;;  (begin (define-syntax kw syntax) ...)
		   ;; We do it the indirect way just to make null-store
		   ;; shorter when printed.
		   (begin (define-syntax kw
			    (syntax-rules () ((_ . args) (syntax . args))))
			  ...)))))
	   (syntax-rules (define-syntax)
	     ((_ (define-syntax kw syntax) ...)
	      (top-let-syntax
		  ((m (syn-letrec-syntax ((kw syntax) ...)
			(syntax-rules ()
			  ((_ . top-level-kws)
			   (define-syntaxes top-level-kws kw ...))))))
		(m kw ...)))))))
     (define-protected-syntaxes
       (define-syntax define
	 (syntax-rules ()
	   ((_ (var . args) . body)
	    (plain-define var (lambda args . body)))
	   ((_ var init) (plain-define var init))))
       (define-syntax let
	 (syntax-rules ()
	   ((_ ((var init) ...) . body)
	    ((lambda (var ...) . body)
	     init ...))
	   ((_ name ((var init) ...) . body)
	    ((letrec ((name (lambda (var ...) . body)))
	       name)
	     init ...))))
       (define-syntax let*
	 (syntax-rules ()
	   ((_ () body1 body2 ...)
	    (let () body1 body2 ...))
	   ((let* ((name1 val1) (name2 val2) ...)
	      body1 body2 ...)
	    (let ((name1 val1))
	      (let* ((name2 val2) ...)
		body1 body2 ...)))))
       (define-syntax letrec
	 (syntax-rules ()
	   ((_ ((var init) ...) . body)
	    (let () (plain-define var init) ... (let () . body))))) 
       (define-syntax do
	 (syn-let-syntax ((do-step (syntax-rules () ((_ x) x) ((_ x y) y))))
d827 4
a830 25
	     ((_ ((var init step ...) ...)
		 (test expr ...)
		 command ...)
	      (let loop ((var init) ...)
		(if test
		    (begin (if #f #f) expr ...)
		    (begin command ... (loop (do-step var step ...) ...))))))))
       (define-syntax case
	 (syn-letrec-syntax
	     ((compare
	       (syntax-rules ()
		 ((_ key ()) #f)
		 ((_ key (datum . data))
		  (if (eqv? key 'datum) #t (compare key data)))))
	      (case
	       (syntax-rules (else)
		 ((case key) (if #f #f))
		 ((case key (else result1 . results))
		  (let () #f result1 . results))
		 ((case key
		    ((datum ...) result1 . results)
		    . clauses)
		  (if (compare key (datum ...))
		      (begin result1 . results)
		      (case key . clauses))))))
d832 7
a838 13
	     ((_ expr clause1 clause ...)
	      (let ((key expr))
		(case key clause1 clause ...))))))
       (define-syntax cond
	 (syntax-rules (else =>)
	   ((_) (if #f #f))
	   ((_ (else . exps)) (begin #f . exps))
	   ((_ (x) . rest) (or x (cond . rest)))
	   ((_ (x => proc) . rest)
	    (let ((tmp x)) (cond (tmp (proc tmp)) . rest)))
	   ((_ (x . exps) . rest)
	    (if x (begin . exps) (cond . rest)))))
       (define-syntax and
d840 3
a842 8
	   ((_) #t)
	   ((_ test) test)
	   ((_ test . tests) (if test (and . tests) #f))))
       (define-syntax or
	 (syntax-rules ()
	   ((_) #f)
	   ((_ test) test)
	   ((_ test . tests) (let ((x test)) (if x x (or . tests)))))))
d850 9
a858 8
	   ((tail-preserving-syntax-rules
	     (syntax-rules ()
	       ((_ literals
		  ((subpattern ...) (subtemplate ...))
		  ...)
		(syntax-rules literals
		  ((subpattern ... . tail) (subtemplate ... . tail))
		  ...)))))
d874 3
a876 2
	       (tail-preserving-syntax-rules ()
		 ((_ expr next-macro) (next-macro expr))))
d892 1
a892 1
	     ((_ template) (qq template () begin))))))))
@


1.26
log
@Added check in compile-syntax-rules for template ellipses that close
no variables.  Now the whole system should be detecting and reporting
every possible syntax error.
@
text
@d431 1
a431 1
		       (define (expand-subexpr sexp)
d433 4
a436 1
		       (ek (cons output (map expand-subexpr (cdr sexp))))))
@


1.25
log
@Added more error-checking to compile-syntax-rules.  Only thing it
doesn't catch now is a template ellipsis that closes no variables.

In apply-transformer, separated match-pattern into separate matches?
and make-bindings procedures.
@
text
@a497 1
;; Errors that aren't checked yet:
d552 17
d575 4
a578 1
	(list-ids tmpl #t (list-ids pat #f #f))))
@


1.24
log
@Fixed compile-syntax-rules to include the bindings of the pattern
literals, as well as those of the template literals, in the
environment that is placed in the transformer.
@
text
@d78 1
a78 1
;; inserted-literal: (name . location)
d81 2
a82 1
;;    | #()            ;; matches anything
a83 1
;;    | #(SEQ pat)     ;; an ellipsis pattern
d86 4
a89 4
;;    | (templ . templ)
;;    | #((accessor ...) stack-index)  ;; a variable or inserted literal
;;    | #((templ ...) templ templ)  ;; an ellipsis template
;;    | #((templ ...))              ;; a vector template
d91 1
d487 11
d499 1
a499 3
;;  duplicate pattern variable
;;  variable instance in template not at sufficient ellipsis depth.
;;  template ellipsis closes no variables.
a504 3
    (define (pat-literal? id)     (memv id pattern-lits))
    (define (not-pat-literal? id) (not (pat-literal? id)))
    (define (ellipsis-pair? x)    (and (pair? x) (ellipsis? (car x))))
d508 4
a511 1
    (define (list-ids x midlist-ellipsis-ok? pred?)
d513 40
a552 20
	(if midlist-ellipsis-ok?
	    (error "Template ellipsis not preceded by a subtemplate: " x)
	    (error "Pattern ellipsis not preceded by a subpattern: " x)))
      (define (bad-midlist-ellipsis x)
	(error "Subpattern following a pattern ellipsis: " x))
      (if (ellipsis? x) (bad-ellipsis x))
      (let collect ((x x) (l '()))
	(cond ((sid? x) (let ((id (sid-id x)))
			  (if (pred? id) (cons id l) l)))
	      ((vector? x) (collect (svector->list x) l))
	      ((pair? x)
	       (cond ((ellipsis? (car x)) (bad-ellipsis x))
		     ((ellipsis? (cdr x)) (bad-ellipsis x))
		     ((ellipsis-pair? (cdr x))
		      (cond ((not (or (null? (cddr x)) midlist-ellipsis-ok?))
			     (bad-midlist-ellipsis (cdr x)))
			    ((ellipsis? (cddr x)) (bad-ellipsis (cdr x)))
			    (else (collect (car x) (collect (cddr x) l)))))
		     (else (collect (car x) (collect (cdr x) l)))))
	      (else l))))
d559 1
a559 2
	(let ((pat-vars (list-ids (cdr pat) #f not-pat-literal?)))
	  (list-ids tmpl #t (lambda (x) (not (memv x pat-vars)))))))
d601 1
a601 4
    ;; Returns #f or an alist mapping each pattern var to a part of
    ;; the input.  Ellipsis vars are mapped to lists of parts (or
    ;; lists of lists...).
    (define (match-pattern pat use env)
d604 34
a637 23
	 (define (fail) (return #f))
	 (let match ((pat pat) (sexp use) (bindings '()))
	   (define (continue-if condition) (if condition bindings (fail)))
	   (cond
	    ((sid? pat)
	     (if (pat-literal? (sid-id pat))
		 (continue-if (and (sid? sexp)
				   (eqv? (lookup-sid pat mac-env)
					 (lookup-sid sexp env))))
		 (cons (cons (sid-id pat) sexp) bindings)))
	    ((vector? pat)
	     (or (svector? sexp) (fail))
	     (match (svector->list pat) (svector->list sexp) bindings))
	    ((not (pair? pat)) (continue-if (equal? pat sexp)))
	    ((ellipsis-pair? (cdr pat))
	     (or (list? sexp) (fail))
	     (let ((vars (list-ids pat #t not-pat-literal?)))
	       (define (match1 sexp) (map cdr (match (car pat) sexp '())))
	       (append (apply map list vars (map match1 sexp))
		       bindings)))
	    ((pair? sexp) (match (car pat) (car sexp)
				 (match (cdr pat) (cdr sexp) bindings)))
	    (else (fail)))))))
d687 3
a689 3
	    (cond ((match-pattern pat (cdr sexp) env)
		   => (lambda (bindings) (expand-template pat tmpl bindings)))
		  (else (loop (cdr rules)))))))))
@


1.23
log
@[Comparing to 1.21]

Added the number of a renamed id to the local variable name used in
the output (just to make it clearer what happened during expansion).

Finished removing the old variable aliasing feature.  (let ((x 1))
(let-syntax ((y x)) y)) is now an error again.

Compile-syntax-rules (which still doesn't do much in the way of
actually compiling) now does error-checking, but it is not yet
complete.  Apply-transformer does complete error-checking (only cases
it needs to check are "no match" and "unequal sequence lengths").

Expand-template now removes dups from the list of inserted literals,
and thus increases id-n by only the amount required.

Fixed (cond) to expand to (if #f #f) rather than #f.

Changes to make null-store shorter when printed (reduced from 22k to 5k):

  Compile-syntax-rules, instead of placing the whole macro environment
  in the transformer, now places in it an environment including only
  the bindings that are used by template literals (and the binding for
  ..., if any).

  Omitted location from renamed-sids when location = name.

  In define-protected-syntaxes (which is in null-prog), the public
  bindings are trivial macros that invoke the private macros, rather
  than copies of the private macros.
@
text
@d534 8
a541 11
    (let loop ((template-lits (apply append (map list-template-lits rules)))
	       (bindings '()))
      (if (null? template-lits)
	  (cons (if (and ellipsis-binding (not (assv '... bindings)))
		    (cons ellipsis-binding bindings)
		    bindings)
		(cons pattern-lits rules))
	  (loop (cdr template-lits)
		(let ((template-lit (car template-lits)))
		  (cond ((and (not (assv template-lit bindings))
			      (assv template-lit env))
@


1.22
log
@About to abort an attempt to pre-process sids in a transformer like so:

;; All sids in rules are replaced as follows:
;; ellipses           =>  ...
;; pattern variables  =>  #(id)
;; pattern literals   =>  #(name local-location) | name
;; template literals  =>  #(name local-location) | name
;; In a literal, the location is the location of the binding to use
;; for comparison (if a pattern literal) or for creating a new sid (if
;; a template literal).  If it is omitted, location = name.
@
text
@d63 1
a63 1
;; (lookup2 sid env store) => val ;; lookup-sid + lookup-location + check #f.
d73 1
a73 1
;; => (ek output-sexp) | (sk val sexp store loc-n).
a76 10
;; rule:
;; All sids in rules are replaced as follows:
;; ellipses           =>  ...
;; pattern variables  =>  #(id)
;; pattern literals   =>  #(name local-location) | name
;; template literals  =>  #(name local-location) | name
;; In a literal, the location is the location of the binding to use
;; for comparison (if a pattern literal) or for creating a new sid (if
;; a template literal).  If it is omitted, location = name.

d164 3
a166 3
  (if (= 3 (vector-length v))
      (vector-ref v 2)
      (list->vector (unwrap-vecs (svector->list v)))))
d275 1
a275 1
;; For a syntax body, returns (sk val sexp store loc-n).
d360 1
a360 1
	  (apply-transformer syntax tail id-n env
d406 1
a406 1
	       (syntax-assert (>= len 2))
d486 10
a495 15
(define (compile-syntax-rules lits rules env)
  (or (list? lits) (error "Malformed literals list: " lits))
  (check-sids lits)
  (let ((lits (map sid-id lits)))
    (define (compile-rule rule)
      (or (list2? rule) (error "Malformed syntax rule: " rule))
      (let* ((pat (car rule))
	     (tmpl (cadr rule))
	     (compiled-pat (compile-pat pat))
	     (bindings (make-bindings pat))
	     (inserted-lits (make-inserted-lits tmpl bindings))
	     (compiled-tmpl (compile-tmpl tmpl bindings inserted-lits)))
	(cons compiled-pat (cons compiled-tmpl inserted-lits))))

    (define (pat-literal? id)     (memv id lits))
a496 1
    (define (ellipsis? x)         (and (sid? x) (eq? '... (lookup-sid x env))))
d498 2
d501 8
a508 1
    (define (list-ids x pred?)
d513 9
a521 3
	      ((pair? x) (if (ellipsis-pair? (cdr x))
			     (collect (car x) (collect (cddr x) l))
			     (collect (car x) (collect (cdr x) l))))
d525 22
a546 2
      (define pat-vars (list-ids (cdar rule) not-pat-literal?))
      (list-ids (cadr rule) (lambda (x) (not (memv x pat-vars)))))
d548 5
a552 91
    (define (apply-transformer transformer sexp id-n env k)
      (let ((mac-env (car transformer))
	    (pat-literals (cadr transformer))
	    (rules (cddr transformer)))
	(define (pat-literal? id)     (memv id pat-literals))
	(define (not-pat-literal? id) (not (pat-literal? id)))
	(define (ellipsis? x) (and (sid? x) (eq? '... (lookup-sid x mac-env))))
	(define (ellipsis-pair? x) (and (pair? x) (ellipsis? (car x))))

	;; List-ids returns a list of the non-ellipsis ids in a
	;; pattern or template for which (pred? id) is true.  If
	;; include-scalars is false, we only include ids that are
	;; within the scope of at least one ellipsis.
	(define (list-ids x include-scalars pred?)
	  (let collect ((x x) (inc include-scalars) (l '()))
	    (cond ((sid? x) (let ((id (sid-id x)))
			      (if (and inc (pred? id)) (cons id l) l)))
		  ((vector? x) (collect (svector->list x) inc l))
		  ((pair? x)
		   (if (ellipsis-pair? (cdr x))
		       (collect (car x) #t (collect (cddr x) inc l))
		       (collect (car x) inc (collect (cdr x) inc l))))
		  (else l))))
    
	;; Returns #f or an alist mapping each pattern var to a part of
	;; the input.  Ellipsis vars are mapped to lists of parts (or
	;; lists of lists...).
	(define (match-pattern pat use env)
	  (call-with-current-continuation
	   (lambda (return)
	     (define (fail) (return #f))
	     (let match ((pat pat) (sexp use) (bindings '()))
	       (define (continue-if condition) (if condition bindings (fail)))
	       (cond
		((sid? pat)
		 (if (pat-literal? (sid-id pat))
		     (continue-if (and (sid? sexp)
				       (eqv? (lookup-sid pat mac-env)
					     (lookup-sid sexp env))))
		     (cons (cons (sid-id pat) sexp) bindings)))
		((vector? pat)
		 (or (svector? sexp) (fail))
		 (match (svector->list pat) (svector->list sexp) bindings))
		((not (pair? pat)) (continue-if (equal? pat sexp)))
		((ellipsis-pair? (cdr pat))
		 (or (list? sexp) (fail))
		 (let ((vars (list-ids pat #t not-pat-literal?)))
		   (define (match1 sexp) (map cdr (match (car pat) sexp '())))
		   (append (apply map list vars (map match1 sexp))
			   bindings)))
		((pair? sexp) (match (car pat) (car sexp)
				     (match (cdr pat) (cdr sexp) bindings)))
		(else (fail)))))))

	(define (expand-template pat tmpl top-bindings)
	  (define tmpl-literals
	    (list-ids tmpl #t (lambda (id) (not (assv id top-bindings)))))
	  (define ellipsis-vars (list-ids pat #f not-pat-literal?))
	  (define (list-ellipsis-vars subtmpl)
	    (list-ids subtmpl #t (lambda (id) (memv id ellipsis-vars))))
	  (define (expand tmpl bindings)
	    (let expand-part ((tmpl tmpl))
	      (cond
	       ((sid? tmpl)
		(let ((id (sid-id tmpl)))
		  (cond ((assv id bindings) => cdr)
			((assv id top-bindings) => cdr)
			(else (let ((index (+ -1 (length (memv id tmpl-literals))))
				    (location (lookup-sid tmpl mac-env)))
				(make-sid (sid-name tmpl) (+ id-n index) location))))))
	       ((vector? tmpl)
		(list->svector (expand-part (svector->list tmpl))))
	       ((pair? tmpl)
		(if (ellipsis-pair? (cdr tmpl))
		    (let ((vars-to-iterate (list-ellipsis-vars (car tmpl))))
		      (define (lookup var) (cdr (assv var bindings)))
		      (define (expand-car . vals)
			(expand (car tmpl) (map cons vars-to-iterate vals)))
		      (append (apply map expand-car (map lookup vars-to-iterate))
			      (expand-part (cddr tmpl))))
		    (cons (expand-part (car tmpl)) (expand-part (cdr tmpl)))))
	       (else tmpl))))
	  (k (expand tmpl top-bindings) (+ id-n (length tmpl-literals))))

	'(display transformer)
	'(display rules)
	(let loop ((rules rules))
	  (let* ((rule (car rules)) (pat (car rule)) (tmpl (cadr rule)))
	    (cond ((match-pattern pat sexp env)
		   => (lambda (bindings) (expand-template pat tmpl bindings)))
		  (else (loop (cdr rules))))))))
d554 5
a558 14
    ;;(map compile-rule rules)
    (let ((template-lits (apply append (map list-template-lits rules))))
      (let collect-bindings ((template-lits template-lits) (bindings '()))
	(if (null? template-lits)
	    (cons bindings
		  (cons lits (map list (map cdar rules) (map cadr rules))))
	    (let ((template-lit (car template-lits)))
	      (cond ((and (not (assv template-lit bindings))
			  (assv template-lit env))
		     => (lambda (binding)
			  (collect-bindings (cdr template-lits)
					    (cons binding bindings))))
		    (else (collect-bindings (cdr template-lits)
					    bindings)))))))))
d560 14
a573 54
;; returns (k sexp id-n)
(define (apply-transformer transformer sexp id-n env k)
  (define (pat-literal? id)     (memv id pat-literals))
  (define (not-pat-literal? id) (not (pat-literal? id)))
  (define (ellipsis? x)      (eq? x '...))
  (define (ellipsis-pair? x) (and (pair? x) (ellipsis? (car x))))

  (define (list-vars x)
    (let collect ((x x) (l '()))
      (cond ((pair? x) (collect (car x) (collect (cdr x) l)))
	    ((and (vector? x) (= 1 (vector-length x)))
	     (let ((x0 (vector-ref x 0)))
	       (if (id? x0) (cons x0 l) (collect x0 l))))
	    (else l))))

  (define (list-lits x)
    (let collect ((x x) (l '()))
      (cond ((pair? x) (collect (car x) (collect (cdr x) l)))
	    ((or (and (symbol? x) (not (ellipsis? x)))
		 (and (vector? x) (< 1 (vector-length x))))
	     (cons x l))
	    ((svector? x) (collect (svector->list x)))
	    (else l))))

  (define (pat-var? x) (and (vector? x) (id? (vector-ref x 0))))
  (define (rvector? x) (and (not (pat-var? x)) (svector? x)))
  (define rvector->list svector->list)
  (define (lit? x)
    (or (and (symbol? x) (not (ellipsis? x)))
	(and (vector? x) (= 2 (vector-length x)))))

  (define (list-atoms pred? x)
    (let collect ((x x) (l '()))
      (cond ((pair? x) (collect (car x) (collect (cdr x) l)))
	    ((rvector? x) (collect (rvector->list x) l))
	    ((pred? x) (cons x l))
	    (else l))))

  (define (make-renamed-sids))

  ;; List-ids returns a list of the non-ellipsis ids in a
  ;; pattern or template for which (pred? id) is true.  If
  ;; include-scalars is false, we only include ids that are
  ;; within the scope of at least one ellipsis.
  (define (list-ids x include-scalars pred?)
    (let collect ((x x) (inc include-scalars) (l '()))
      (cond ((sid? x) (let ((id (sid-id x)))
			(if (and inc (pred? id)) (cons id l) l)))
	    ((vector? x) (collect (svector->list x) inc l))
	    ((pair? x)
	     (if (ellipsis-pair? (cdr x))
		 (collect (car x) #t (collect (cddr x) inc l))
		 (collect (car x) inc (collect (cdr x) inc l))))
	    (else l))))
d575 81
a655 67
  ;; Returns #f or an alist mapping each pattern var to a part of
  ;; the input.  Ellipsis vars are mapped to lists of parts (or
  ;; lists of lists...).
  (define (match-pattern pat use env)
    (call-with-current-continuation
     (lambda (return)
       (define (fail) (return #f))
       (let match ((pat pat) (sexp use) (bindings '()))
	 (define (continue-if condition) (if condition bindings (fail)))
	 (cond
	  ((sid? pat)
	   (if (pat-literal? (sid-id pat))
	       (continue-if (and (sid? sexp)
				 (eqv? (lookup-sid pat mac-env)
				       (lookup-sid sexp env))))
	       (cons (cons (sid-id pat) sexp) bindings)))
	  ((vector? pat)
	   (or (svector? sexp) (fail))
	   (match (svector->list pat) (svector->list sexp) bindings))
	  ((not (pair? pat)) (continue-if (equal? pat sexp)))
	  ((ellipsis-pair? (cdr pat))
	   (or (list? sexp) (fail))
	   (let ((vars (list-ids pat #t not-pat-literal?)))
	     (define (match1 sexp) (map cdr (match (car pat) sexp '())))
	     (append (apply map list vars (map match1 sexp))
		     bindings)))
	  ((pair? sexp) (match (car pat) (car sexp)
			       (match (cdr pat) (cdr sexp) bindings)))
	  (else (fail)))))))

  (define (expand-template pat tmpl top-bindings)
    (define tmpl-literals
      (list-ids tmpl #t (lambda (id) (not (assv id top-bindings)))))
    (define ellipsis-vars (list-ids pat #f not-pat-literal?))
    (define (list-ellipsis-vars subtmpl)
      (list-ids subtmpl #t (lambda (id) (memv id ellipsis-vars))))
    (define (expand tmpl bindings)
      (let expand-part ((tmpl tmpl))
	(cond
	 ((sid? tmpl)
	  (let ((id (sid-id tmpl)))
	    (cond ((assv id bindings) => cdr)
		  ((assv id top-bindings) => cdr)
		  (else (let ((index (+ -1 (length (memv id tmpl-literals))))
			      (location (lookup-sid tmpl mac-env)))
			  (make-sid (sid-name tmpl) (+ id-n index) location))))))
	 ((vector? tmpl)
	  (list->svector (expand-part (svector->list tmpl))))
	 ((pair? tmpl)
	  (if (ellipsis-pair? (cdr tmpl))
	      (let ((vars-to-iterate (list-ellipsis-vars (car tmpl))))
		(define (lookup var) (cdr (assv var bindings)))
		(define (expand-car . vals)
		  (expand (car tmpl) (map cons vars-to-iterate vals)))
		(append (apply map expand-car (map lookup vars-to-iterate))
			(expand-part (cddr tmpl))))
	      (cons (expand-part (car tmpl)) (expand-part (cdr tmpl)))))
	 (else tmpl))))
    (k (expand tmpl top-bindings) (+ id-n (length tmpl-literals))))

  '(display transformer)
  '(display rules)
  (let loop ((rules transformer))
    (let* ((rule (car rules)) (pat (car rule)) (tmpl (cadr rule)))
      (cond ((match-pattern pat sexp env)
	     => (lambda (bindings) (expand-template pat tmpl bindings)))
	    (else (loop (cdr rules)))))))
@


1.21
log
@Fixed a bug in make-var-bindings.
@
text
@d40 6
a45 3
;; A renamed-sid includes the location to use if the renamed-id occurs freely,
;; and the name to use if it occurs within a constant.
;; renamed-sid: #(renamed-id location name)
d47 1
a47 1
;; variable: symbol  ; the symbol that is used in the output, e.g. _foo_42.
d69 1
a69 1
;; (expand-syntax sexp id-n env store loc-n k) => (k val store loc-n)
d77 10
d88 13
a100 16
;; inserted-literal: (location . name)
;; pat: (literal . location)
;;    | () ;; matches anything
;;    | (quote . constant)
;;    | (list->vector . pat)
;;    | (cons pat . pat)
;;    | (seq . pat)  ;; or (seq pat . pat) to handle (x ... y) patterns.
;;    ;; or (seq (pat ...) . pat) to handle (x y ... ... z) patterns.
;; tmpl: (ref frame . index)
;;    | (quote . constant)
;;    | (list->vector . templ)
;;    | (vector->list . templ)
;;    | (car . templ)
;;    | (cdr . templ)
;;    | (cons templ . templ)
;;    | (seq (templ ...) templ . templ)
d133 1
d135 1
a135 1
(define (renamed-sid? s)  (and (vector? s) (= 3 (vector-length s))))
d140 9
a148 4
(define make-sid vector)
(define (sid-id sid)       (if (symbol? sid) sid (vector-ref sid 0)))
(define (sid-location sid) (if (symbol? sid) sid (vector-ref sid 1)))
(define (sid-name sid)     (if (symbol? sid) sid (vector-ref sid 2)))
d150 2
a151 2
(define (list1?  s) (and (pair? s) (null?  (cdr s))))
(define (list2?  s) (and (pair? s) (list1? (cdr s))))
d155 1
a155 1
;; (This is grossly premature optimization.)
d202 5
a206 3
(define (make-local-var intloc name)
  (let ((str (symbol->string name)))
    (string->symbol (string-append "_" str "_" (number->string intloc)))))
d215 1
a215 1
      (error "Premature use of keyword bound by letrec-syntax:" sid)))
d223 1
a223 3
    (if (and (variable? val) (eq? val (symloc->var symloc)))
	store
	(acons symloc val store)))
d254 1
a254 1
	       (var (make-local-var loc-n (sid-name sid)))
d438 7
a444 9
	   (let ((head (car sexp)) (tail (cdr sexp)))
	     (define (expand-tail-exprs)
	       (map (lambda (sexp) (expand-expr sexp id-n env store loc-n))
		    tail))
	     (expand-any head id-n env store loc-n
	       (and ek
		    (lambda (output) (ek (cons output (expand-tail-exprs)))))
	       handle-syntax-use
	       #f))))))
d486 2
a487 2
		   (lambda (val sexp store loc-n)
		     (let ((store (substitute-in-store store symloc val)))
a508 2
    '(map compile-rule rules)
    (list env lits rules)))
d510 1
a510 6
;; returns (k sexp id-n)
(define (apply-transformer transformer sexp id-n env k)
  (let ((mac-env (car transformer))
	(pat-literals (cadr transformer))
	(rules (caddr transformer)))
    (define (pat-literal? id)     (memv id pat-literals))
d512 2
a513 2
    (define (ellipsis? x) (and (sid? x) (eq? '... (lookup-sid x mac-env))))
    (define (ellipsis-pair? x) (and (pair? x) (ellipsis? (car x))))
d515 2
a516 6
    ;; List-ids returns a list of the non-ellipsis ids in a
    ;; pattern or template for which (pred? id) is true.  If
    ;; include-scalars is false, we only include ids that are
    ;; within the scope of at least one ellipsis.
    (define (list-ids x include-scalars pred?)
      (let collect ((x x) (inc include-scalars) (l '()))
d518 5
a522 6
			  (if (and inc (pred? id)) (cons id l) l)))
	      ((vector? x) (collect (svector->list x) inc l))
	      ((pair? x)
	       (if (ellipsis-pair? (cdr x))
		   (collect (car x) #t (collect (cddr x) inc l))
		   (collect (car x) inc (collect (cdr x) inc l))))
d524 28
d553 205
a757 67
    ;; Returns #f or an alist mapping each pattern var to a part of
    ;; the input.  Ellipsis vars are mapped to lists of parts (or
    ;; lists of lists...).
    (define (match-pattern pat use env)
      (call-with-current-continuation
       (lambda (return)
	 (define (fail) (return #f))
	 (let match ((pat pat) (sexp use) (bindings '()))
	   (define (continue-if condition) (if condition bindings (fail)))
	   (cond
	    ((sid? pat)
	     (if (pat-literal? (sid-id pat))
		 (continue-if (and (sid? sexp)
				   (eqv? (lookup-sid pat mac-env)
					 (lookup-sid sexp env))))
		 (cons (cons (sid-id pat) sexp) bindings)))
	    ((vector? pat)
	     (or (svector? sexp) (fail))
	     (match (svector->list pat) (svector->list sexp) bindings))
	    ((not (pair? pat)) (continue-if (equal? pat sexp)))
	    ((ellipsis-pair? (cdr pat))
	     (or (list? sexp) (fail))
	     (let ((vars (list-ids pat #t not-pat-literal?)))
	       (define (match1 sexp) (map cdr (match (car pat) sexp '())))
	       (append (apply map list vars (map match1 sexp))
		       bindings)))
	    ((pair? sexp) (match (car pat) (car sexp)
				  (match (cdr pat) (cdr sexp) bindings)))
	    (else (fail)))))))

    (define (expand-template pat tmpl top-bindings)
      (define tmpl-literals
	(list-ids tmpl #t (lambda (id) (not (assv id top-bindings)))))
      (define ellipsis-vars (list-ids pat #f not-pat-literal?))
      (define (list-ellipsis-vars subtmpl)
	(list-ids subtmpl #t (lambda (id) (memv id ellipsis-vars))))
      (define (expand tmpl bindings)
	(let expand-part ((tmpl tmpl))
	  (cond
	   ((sid? tmpl)
	    (let ((id (sid-id tmpl)))
	      (cond ((assv id bindings) => cdr)
		    ((assv id top-bindings) => cdr)
		    (else (let ((index (+ -1 (length (memv id tmpl-literals))))
				(location (lookup-sid tmpl mac-env)))
		       (make-sid (+ id-n index) location (sid-name tmpl)))))))
	   ((vector? tmpl)
	    (list->svector (expand-part (svector->list tmpl))))
	   ((pair? tmpl)
	    (if (ellipsis-pair? (cdr tmpl))
		(let ((vars-to-iterate (list-ellipsis-vars (car tmpl))))
		  (define (lookup var) (cdr (assv var bindings)))
		  (define (expand-car . vals)
		    (expand (car tmpl) (map cons vars-to-iterate vals)))
		  (append (apply map expand-car (map lookup vars-to-iterate))
			  (expand-part (cddr tmpl))))
		(cons (expand-part (car tmpl)) (expand-part (cdr tmpl)))))
	   (else tmpl))))
      (k (expand tmpl top-bindings) (+ id-n (length tmpl-literals))))

    '(display transformer)
    '(display rules)
    (let loop ((rules rules))
      (let* ((rule (car rules)) (pat (cdar rule)) (tmpl (cadr rule)))
	(cond ((match-pattern pat sexp env)
	       => (lambda (bindings) (expand-template pat tmpl bindings)))
	      (else (loop (cdr rules))))))))
d782 7
a788 1
		   (begin (define-syntax kw syntax) ...)))))
d859 1
a859 1
	   ((_) #f)
d943 150
d1123 1
a1123 1
;; would require putting a frame of bindings into two different
@


1.20
log
@Revamped machinery to support arbitray syntaxes in the head position
of macro calls, i.e., ((syntax-rules () ((_ x) 'x)) foo) and
((syn-let-syntax () quote) foo) are now legal expressions.  Replaced
apply-macros with expand-any, which takes three continuation arguments
to handle expressions, syntaxes, and miscellany.  Expand-expr and
expand-syntax are now simple wrappers around expand-any.

Added syn-let-syntax and syn-letrec-syntax.  They can only be used
with syntax bodies, and let-syntax and letrec-syntax can only be used
with expression bodies.  Not sure if I like this better than having
one name.

Removed old comments about an idea for more complicated, but more
source-correlated, identifier names in the output.
@
text
@d243 1
a243 1
	      (k (revappend vars var) env store loc-n))))))
@


1.19
log
@Fixed the bug that apply-macros wasn't catching letrec-syntax
violation errors.
@
text
@a28 43
;; An alternate model:
;; id: (mark ... . name)     ;; just enough information to uniquely identify.
;; sid: ((id . binding) . name)  ;; additional info stored in sexp instances.
;;                               ;; name is redundant, but convenient.
;; mark: (serial . place)
;; binding: toplevel-binding | local-binding
;; toplevel-binding: name
;; local-binding: (id-index . normal-place)
;; place: normal-place | idef-place
;; normal-place: expr-place | syntax-place | toplevel-place
;; expr-place: depth
;; syntax-place: (depth . syntax-context)
;; toplevel-place: (subindex ... index)
;; idef-place: (subindex ... index . expr-place)
;; The two syntax-contexts correspond to define-syntax and *let*syntax.
;; syntax-context: toplevel-place | local-binding
;; name: symbol
;; depth: integer
;; For more descriptive variables names, make id-index and index something
;; distinguishable from depth, e.g. (n) and -n.
;; id-index: integer
;; index: integer
;; subindex: integer
;; val: variable | syntax
;; variable: symbol ;; _name_/index/index:id-index@@depth.serial@@depth
;; syntax: builtin | transformer
;; builtin: (symbol)
;; transformer: (env rule ...)
;; env: ((id . binding) ...)
;; store: ((binding . val) ...)

;; (lookup-sid sid env) => binding
;; (lookup-binding binding store) => val | #f  ;; #f means letrec violation.
;; (lookup2 sid env store) => val | #f
;; (expand-expr sexp env store depth) => output-sexp
;; (expand-top-level input-sexp store index k) => (k output-sexp store)
;; (transform sexp env store place) => sexp  ;; expands until not a macro call.
;; (apply-transformer trans sexp env mark) => sexp
;; (compile-syntax sexp env store syntax-context k) => (k val store)
;; (compile-syntax-bindings bindings rec? env store normal-place k)
;;   => (k env store)


d60 7
a66 1
;; (lookup2 sid env store) => (lookup-location (lookup-sid sid env) store)
d69 3
a71 4
;; (apply-transformer trans sexp id-n env k) => (k sexp id-n)
;; (apply-macros sexp id-n env store k) => (k builtin sexp id-n)
;; (compile-syntax sexp id-n env store loc-n k) => (k val store loc-n)
;; (compile-syntax-bindings bindings id-n rec? env store loc-n k)
a134 1
(define (list1+? s) (and (pair? s) (list?  (cdr s))))
d139 1
d183 1
a183 1
    ((begin define delay if lambda! letrec quote set) (rename))
d186 4
a215 4
(define (make-local-var intloc name)
  (let ((str (symbol->string name)))
    (string->symbol (string-append "_" str "_" (number->string intloc)))))

a218 131
;; (returns (k output-sexp store loc-n))
(define (expand-top-level input-sexp store loc-n k)
  (define (finalize store loc-n acc)
    (let ((output (if (list1? acc) (car acc) (cons 'begin (reverse acc)))))
      (k output store loc-n)))
  (let expand ((sexp (wrap-vecs input-sexp)) (id-n 0) (env '())
	       (store store) (loc-n loc-n) (acc '()) (k finalize))
    (apply-macros sexp id-n env store
      (lambda (sexp id-n builtin tail)
	(define (do-begin sexps env store loc-n)
	  (let loop ((sexps sexps) (store store) (loc-n loc-n) (acc acc))
	    (if (null? sexps)
		(k store loc-n acc)
		(expand (car sexps) id-n env store loc-n acc
			(lambda (store loc-n acc)
			  (loop (cdr sexps) store loc-n acc))))))
	(define (do-expr)
	  (k store loc-n (cons (expand-expr sexp id-n env store loc-n) acc)))
	(case builtin
	  ((#f) (do-expr))
	  ((begin) (do-begin tail env store loc-n))
	  ((define define-syntax)
	   (or (and (= 2 (length tail)) (sid? (car tail)))
	       (error "Malformed definition" sexp))
	   (let ((symloc (lookup-sid (car tail) env)))
	     (or (symbol? symloc)
		 (error "Attempt to redefine a local: " sexp))
	     (if (eq? builtin 'define)
		 (let* ((var (symloc->var symloc))
			(init (expand-expr (cadr tail) id-n env store loc-n))
			(store (substitute-in-store store symloc var)))
		   (k store loc-n (cons (list 'define var init) acc)))
		 (compile-syntax (cadr tail) id-n env store loc-n
		   (lambda (val store loc-n)
		     (let ((store (substitute-in-store store symloc val)))
		       (k store loc-n acc)))))))
	  ((top-let-syntax top-letrec-syntax)
	   (or (pair? tail) (error "Missing bindings in macro block:" sexp))
	   (let ((rec? (eq? builtin 'top-letrec-syntax)))
	     (compile-syntax-bindings (car tail) id-n rec? env store loc-n
	       (lambda (env store loc-n)
		 (do-begin (cdr tail) env store loc-n)))))
	  (else (do-expr)))))))

;; returns (k val store loc-n)
(define (compile-syntax sexp id-n env store loc-n k)
  (apply-macros sexp id-n env store
    (lambda (sexp id-n builtin tail)
      (define (fail) (error "Invalid syntax: " sexp))
      (case builtin
	((syntax-rules)
	 (or (pair? tail) (fail))
	 (let ((val (compile-syntax-rules (car tail) (cdr tail) env)))
	   (k val store loc-n)))
	((let-syntax letrec-syntax)
	 (or (pair? tail) (fail))
	 (let ((rec? (eq? builtin 'letrec-syntax)))
	   (compile-syntax-bindings (car tail) id-n rec? env store loc-n
	     (lambda (env store loc-n)
	       (expand-body (cdr tail) id-n env store loc-n k)))))
	(else (if (sid? sexp)
		  (k (lookup2 sexp env store) store loc-n)
		  (fail)))))))

;; returns (k env store loc-n)
(define (compile-syntax-bindings bindings id-n rec? env store loc-n k)
  (define (check-binding binding)
    (or (list2? binding) (error "Malformed syntax binding: " binding)))
  (or (list? bindings) (error "Malformed syntax bindings list: " bindings))
  (for-each check-binding bindings)
  (let ((sids (map car bindings)) (sexps (map cadr bindings)))
    (check-sids sids)
    (let loop ((ids (map sid-id sids)) (loc-n loc-n) (ienv env))
      (if (not (null? ids))
	  (loop (cdr ids) (+ loc-n 1) (extend-env ienv (car ids) loc-n))
	  (let ((last-loc (- loc-n 1)) (syntax-env (if rec? ienv env)))
	    (let loop ((sexps sexps) (vals '()) (store store) (loc-n loc-n))
	      (if (not (null? sexps))
		  (compile-syntax (car sexps) id-n syntax-env store loc-n
		    (lambda (val store loc-n)
		      (loop (cdr sexps) (cons val vals) store loc-n)))
		  (let loop ((store store) (vals vals) (loc last-loc))
		    (if (not (null? vals))
			(let ((store (extend-store store loc (car vals))))
			  (loop store (cdr vals) (- loc 1)))
			(k ienv store loc-n))))))))))

(define (expand-expr sexp id-n env store loc-n)
  (let again ((sexp sexp) (id-n id-n))
    (apply-macros sexp id-n env store
      (lambda (sexp id-n builtin tail)
	(define (expand-here sexp) (again sexp id-n))
	(define (do-builtin)
	  (define (fail) (error "Malformed expression: " sexp))
	  (define (fail-unless test) (or test (fail)))
	  (define (expand-parts-if test)
	    (if (not test) (fail) (cons builtin (map expand-here tail))))
	  (define len (length tail))
	  (case builtin
	    ((lambda)
	     (fail-unless (>= len 2))
	     (make-var-bindings (car tail) env store loc-n
	       (lambda (vars env store loc-n)
		 (list 'lambda vars
		       (expand-body (cdr tail) id-n env store loc-n #f)))))
	    ((quote)
	     (fail-unless (= len 1))
	     (list 'quote (unwrap-vecs (car tail))))
	    ((set!)  (expand-parts-if (and (= len 2) (sid? (car tail)))))
	    ((delay) (expand-parts-if (= len 1)))
	    ((begin) (expand-parts-if (positive? len)))
	    ((if)    (expand-parts-if (<= 2 len 3)))
	    ((let-syntax letrec-syntax)
	     (fail-unless (>= len 2))
	     (let ((rec? (eq? builtin 'letrec-syntax)))
	       (compile-syntax-bindings (car tail) id-n rec? env store loc-n
		(lambda (env store loc-n)
		  (expand-body (cdr tail) id-n env store loc-n #f)))))
	    ((define define-syntax syntax-rules
	       top-let-syntax top-letrec-syntax)
	     (error "Special form invalid as an expression: " sexp))
	    (else (error "Unknown builtin [can't happen]." sexp))))
	(cond (builtin (do-builtin))
	      ((sid? sexp)
	       (let ((val (lookup2 sexp env store)))
		 (or (variable? val) (error "Keyword used as variable: " sexp))
		 val))
	      ((vector? sexp) (error "Vector used as expression: " sexp))
	      ((pair? sexp) (map expand-here sexp))
	      (else sexp))))))

d245 26
a270 6
;; For a normal body, k is #f, and the return value is an output-sexp.
;; For a syntax body, returns (k val store loc-n).
(define (expand-body sexps id-n env store loc-n k)
  (define normal? (not k))
  (define (maybe-letrec bs e) (if (null? bs) e (list 'letrec bs e)))
  (define (maybe-begin l)     (if (list1? l) (car l) (cons 'begin l)))
d273 9
a281 7
  ;; returns (k id-n vbs sbs).  If a non-definition is encountered,
  ;; returns (fk), or signals an error if fk is #f.
  (define (expand-def sexp id-n vbs sbs fk k)
    (apply-macros sexp id-n env store
      (lambda (sexp id-n builtin tail)
	(define (err)
	  (error "Non-definition in a group of internal definitions: " sexp))
d283 7
d291 2
a292 2
	   (let loop ((sexps tail) (id-n id-n) (vbs vbs) (sbs sbs) (fk fk))
	     (define (next id-n vbs sbs) (loop (cdr sexps) id-n vbs sbs #f))
d294 7
a300 10
		 (k id-n vbs sbs)
		 (expand-def (car sexps) id-n vbs sbs fk next))))
	  ((define define-syntax)
	   (or (and (list2? tail) (sid? (car tail)))
	       (error "Malformed definition: " sexp))
	   (if (eq? builtin 'define)
	       (k id-n (cons tail vbs) sbs)
	       (k id-n vbs (cons tail sbs))))
	  (else (if fk (fk) (err)))))))
  (let loop ((sexps sexps) (id-n id-n) (vbs '()) (sbs '()))
d303 67
a369 6
    (define (next id-n vbs sbs) (loop rest id-n vbs sbs))
    (define (finish)
      (if normal?
	  (make-var-bindings (map car vbs) env store loc-n
	    (lambda (vars env store loc-n)
	      (compile-syntax-bindings sbs id-n #t env store loc-n
d371 110
a480 11
		  (define (iexpand sexp)
		    (expand-expr sexp id-n env store loc-n))
		  (maybe-letrec (map list vars (map iexpand (map cadr vbs)))
				(maybe-begin (map iexpand sexps)))))))
	  (if (null? vbs)
	      (compile-syntax-bindings sbs id-n #t env store loc-n 
		(lambda (env store loc-n)
		  (compile-syntax first id-n env store loc-n k)))
	      (error "Variable definitions in a syntax body: " vbs))))
    (let ((fk (if normal? finish #f)))
      (if (null? rest) (finish) (expand-def first id-n vbs sbs fk next)))))
d530 1
a530 1
	 (let match ((pat (cdr pat)) (sexp (cdr use)) (bindings '()))
d556 1
a556 1
      (define ellipsis-vars (list-ids (cdr pat) #f not-pat-literal?))
d586 1
a586 1
      (let* ((rule (car rules)) (pat (car rule)) (tmpl (cadr rule)))
a590 25
;; (apply-macros sexp id-n env store k) => (k sexp id-n builtin tail)
;; Expands sexp until it is not a macro call, and returns the result.
;; If the result is a use of a builtin, also returns the name of the builtin
;; and a list of its args.
;; (Otherwise, those two return values are #f and ().)
;; Signals an error if an improper or empty list is encountered.
(define (apply-macros sexp id-n env store k)
  (let again ((sexp sexp) (id-n id-n))
    (define (normal-return) (k sexp id-n #f '()))
    (cond ((null? sexp) (error "Null used as an expression or syntax: " sexp))
	  ((not (pair? sexp)) (normal-return))
	  ((not (list? sexp))
	   (error "Improper list used as an expression or syntax: " sexp))
	  (else
	   (let ((head (car sexp)))
	     (if (not (sid? head))
		 (normal-return)
		 (let ((val (lookup2 head env store)))
		   (cond ((variable? val) (normal-return))
			 ((builtin? val)
			  (k sexp id-n (builtin-name val) (cdr sexp)))
			 (else
			  (apply-transformer val sexp id-n env again))))))))))


d592 3
a594 2
  '(if lambda quote set! delay let-syntax letrec-syntax begin
       define define-syntax syntax-rules top-let-syntax top-letrec-syntax))
d610 1
a610 1
	 (let-syntax
d618 1
a618 1
		  ((m (letrec-syntax ((kw syntax) ...)
d652 1
a652 1
	 (let-syntax ((do-step (syntax-rules () ((_ x) x) ((_ x y) y))))
d662 1
a662 1
	 (letrec-syntax
d708 1
a708 1
       (let-syntax
d717 1
a717 1
	 (letrec-syntax
d792 1
a792 1
;; There are two ways that a (let-syntax ((kw syntax) ...) def ...)
d799 3
a801 1
;; would mean supporting non-hierarchical environments.
@


1.18
log
@Added internal syntax definitions for regular bodies.
  (let () (define-syntax q quote) (define x (q x)) x)
  => x
@
text
@d229 3
a231 1
(define (lookup2 sid env store) (lookup-location (lookup-sid sid env) store))
a305 3
      (define (lookup-or-fail sid)
	(or (lookup2 sid env store)
	    (error "Premature use of letrec-syntax binding: " sexp)))
a306 3
	((#f) (if (sid? sexp)
		  (k (lookup-or-fail sexp) store loc-n)
		  (fail)))
d317 3
a319 1
	(else (fail))))))
d414 1
a414 1
;; For a regular body, k is #f, and the return value is an output-sexp.
d417 1
d448 1
a448 6
      (if k
	  (if (null? vbs)
	      (compile-syntax-bindings sbs id-n #t env store loc-n 
		(lambda (env store loc-n)
		  (compile-syntax first id-n env store loc-n k)))
	      (error "Variable definitions in a syntax body: " vbs))
d456 7
a462 2
				(maybe-begin (map iexpand sexps)))))))))
    (let ((fk (and (not k) finish)))
d799 2
a800 2
;; There are two ways that a (foo-syntax ((kw syntax) ...) def ...)
;; could work in internal-definition contexts.  It could create an
d802 1
a802 1
;; for the expansion of the definitions: or it could create an
@


1.17
log
@Added make-var-bindings.  Removed expand-lambda.
@
text
@d421 5
a425 5
  (define def-builtin (if k 'define-syntax 'define))
  ;; Expand-def expands a definition or begin sequence, adds them to
  ;; bindings, and returns (k id-n bindings).  If a non-definition is
  ;; encountered, returns (fk), or signals an error if fk is #f.
  (define (expand-def sexp id-n bindings fk k)
d428 6
a433 4
	(cond
	  ((eq? builtin 'begin)
	   (let loop ((sexps tail) (id-n id-n) (bindings bindings) (fk fk))
	     (define (next id-n bindings) (loop (cdr sexps) id-n bindings #f))
d435 3
a437 3
		 (k id-n bindings)
		 (expand-def (car sexps) id-n bindings fk next))))
	  ((eq? builtin def-builtin)
d440 5
a444 5
	   (k id-n (cons tail bindings)))
	  (fk (fk))
	  (else (error "Non-definition in a group of internal definitions: "
		       sexp))))))
  (let loop ((sexps sexps) (id-n id-n) (bindings '()))
d447 1
a447 1
    (define (next id-n bindings) (loop rest id-n bindings))
d450 2
a451 3
	  (if (not (null? rest))
	      (error "Multiple non-definitions at end of syntax body: " sexps)
	      (compile-syntax-bindings bindings id-n #t env store loc-n 
d453 3
a455 2
		  (compile-syntax first id-n env store loc-n k))))
	  (make-var-bindings (map car bindings) env store loc-n
d457 8
a464 4
	      (define (iexpand sexp) (expand-expr sexp id-n env store loc-n))
	      (maybe-letrec (map list vars (map iexpand (map cadr bindings)))
			    (maybe-begin (map iexpand sexps)))))))
    (if (null? rest) (finish) (expand-def first id-n bindings finish next))))
d797 11
@


1.16
log
@To macro-expand internal definitions we now use the environment of the
body, rather than an incremental environment containing the preceeding
definitions.

Syntax bodies may now contain internal syntax definitions:

  (let-syntax ((m (let-syntax () (define-syntax q quote) q)))
    (m x))
  => x
@
text
@d20 7
a26 4
;; (make-gensym asexp) returns a function, called as (gensym sym n),
;; which, when passed a symbol in asexp and an exact integer, should
;; return a symbol that differs from every symbol in asexp and from the
;; result of calling gensym with any other integer.
d255 1
d299 1
d323 1
d360 4
a363 1
	     (expand-lambda (car tail) (cdr tail) id-n env store loc-n))
d402 9
a410 10
(define (expand-lambda formals body id-n env store loc-n)
  (check-sids formals)
  (let loop
      ((env env) (store store) (loc-n loc-n) (formals formals) (vars '()))
    (if (null? formals)
	(list 'lambda (reverse vars)
	      (expand-body body id-n env store loc-n #f))
	(let* ((formal (if (pair? formals) (car formals) formals))
	       (var (make-local-var loc-n (sid-name formal)))
	       (env (extend-env env (sid-id formal) loc-n))
d412 3
a414 33
	  (if (pair? formals)
	      (loop env store (+ 1 loc-n) (cdr formals) (cons var vars))
	      (let ((output (expand-body body id-n env store (+ 1 loc-n) #f)))
		(list 'lambda (revappend vars var) output)))))))

'(define (expand-body sexps id-n env store loc-n)
  (let loop ((body sexps) (id-n id-n) (env env) (store store) (loc-n loc-n)
	     (bindings '()))
    (if (null? body) (error "Empty body: " sexps))
    (apply-macros (car body) id-n env store
      (lambda (first id-n builtin tail)
	(define rest (cdr body))
	(define (done)
	  (define (iexpand sexp) (expand-expr sexp id-n env store loc-n))
	  (define (expand-binding binding) (map iexpand binding))
	  (check-sids (map car bindings))
	  (let ((body-output (if (null? rest)
				 (iexpand first)
				 (cons 'begin (map iexpand body)))))
	    (if (null? bindings)
		body-output
		(list 'letrec (map expand-binding bindings) body-output))))
	(case builtin
	  ((begin) (loop (append tail rest) id-n env store loc-n bindings))
	  ((define)
	   (or (and (list2? tail) (sid? (car tail)))
	       (error "Malformed definition: " first))
	   (let* ((sid (car tail))
		  (var (make-local-var loc-n (sid-name sid)))
		  (env (extend-env env (sid-id sid) loc-n))
		  (store (extend-store store loc-n var)))
	     (loop rest id-n env store (+ loc-n 1) (cons tail bindings))))
	  (else (done)))))))
d416 2
a417 2
;; k is #f for a regular body, and return value is an output-sexp.
;; For a syntax body, returns (k val store).
d419 2
d445 1
d449 2
a450 2
	      (error "Multiple syntaxes in syntax body: " sexps)
	      (compile-syntax-bindings bindings id-n #t env store loc-n
d453 5
a457 20
	  (let ((sids (map car bindings)))
	    (check-sids sids)
	    (let loop ((env env) (store store) (loc-n loc-n) (sids sids))
	      (if (not (null? sids))
		  (let* ((sid (car sids))
			 (var (make-local-var loc-n (sid-name sid)))
			 (env (extend-env env (sid-id sid) loc-n))
			 (store (extend-store store loc-n var)))
		    (loop env store (+ loc-n 1) (cdr sids)))
		  (let ((iexpand (lambda (sexp)
				   (expand-expr sexp id-n env store loc-n))))
		    (let ((body-output (if (null? rest)
					   (iexpand first)
					   (cons 'begin (map iexpand sexps)))))
		      (define (expand-binding binding) (map iexpand binding))
		      (if (null? bindings)
			  body-output
			  (list 'letrec (map expand-binding bindings)
				body-output)))))))))
    (define (next id-n bindings) (loop rest id-n bindings))
d476 1
a568 1

d577 1
a577 1
    (define (done) (k sexp id-n #f '()))
d579 1
a579 1
	  ((not (pair? sexp)) (done))
d585 1
a585 1
		 (done)
d587 1
a587 1
		   (cond ((variable? val) (done))
d772 15
a786 7
   (letrec-syntax
       ((old-define define)
	(new-define
	 (syntax-rules ()
	   ((_ (prototype . args) . body)
	    (new-define prototype (lambda args . body)))
	   ((_ var expr) (old-define var expr)))))
@


1.15
log
@Added tail to return values of apply-macros.
Simplified expand-top-level to only add begin when all done.
@
text
@d253 1
a253 1
  (define (finalize acc store loc-n)
d256 2
a257 2
  (let expand ((sexp (wrap-vecs input-sexp)) (id-n 0) (acc '()) (env '())
	       (store store) (loc-n loc-n) (k finalize))
d261 1
a261 1
	  (let loop ((sexps sexps) (acc acc) (store store) (loc-n loc-n))
d263 4
a266 4
		(k acc store loc-n)
		(expand (car sexps) id-n acc env store loc-n
			(lambda (acc store loc-n)
			  (loop (cdr sexps) acc store loc-n))))))
d268 1
a268 2
	  (let ((acc (cons (expand-expr sexp id-n env store loc-n) acc)))
	    (k acc store loc-n)))
d281 2
a282 3
			(store (substitute-in-store store symloc var))
			(acc (cons (list 'define var init) acc)))
		   (k acc store loc-n))
d286 1
a286 1
		       (k acc store loc-n)))))))
d311 1
a311 1
	 (or (= 2 (length tail)) (fail))
d315 1
a315 1
	       (compile-syntax (cadr tail) id-n env store loc-n k)))))
d367 1
a367 1
		  (expand-body (cdr tail) id-n env store loc-n)))))
d398 2
a399 1
	(list 'lambda (reverse vars) (expand-body body id-n env store loc-n))
d406 1
a406 1
	      (let ((output (expand-body body id-n env store (+ 1 loc-n))))
d409 1
a409 1
(define (expand-body sexps id-n env store loc-n)
d438 8
a445 2
'(define (expand-body sexps id-n env store loc-n)
  (define (expand-def sexp id-n env store loc-n defs k)
d447 39
a485 35
      (lambda (builtin sexp id-n)
	(define (do-begin sexps id-n env store loc-n defs))
	(define (do-builtin tail)
	  (case builtin
	    ((begin) (do-begin tail id-n env store loc-n defs))
	    ((define)
	     (or (and (list2? tail) (sid? (car tail)))
		 (error "Malformed definition: " first))
	     (let* ((sid (car tail))
		    (var (make-local-var loc-n (sid-name sid)))
		    (env (extend-env env (sid-id sid) loc-n))
		    (store (extend-store store loc-n var)))
	       (loop rest id-n env store (+ loc-n 1) (cons tail bindings))))
	    (else (done))))
	(and builtin (do-builtin (cdr sexp))))))
  (let loop ((body sexps) (id-n id-n) (env env) (store store) (loc-n loc-n)
	     (bindings '()))
    (if (null? body) (error "Empty body: " sexps))
    (apply-macros (car body) id-n env store
		  (lambda (builtin first id-n)
		    (define rest (cdr body))
		    (define (do-builtin tail)
		      (case builtin
			((begin) (loop (append tail rest) id-n env store loc-n bindings))
			((define)
			 (or (and (list2? tail) (sid? (car tail)))
			     (error "Malformed definition: " first))
			 (let* ((sid (car tail))
				(var (make-local-var loc-n (sid-name sid)))
				(env (extend-env env (sid-id sid) loc-n))
				(store (extend-store store loc-n var)))
			   (loop rest id-n env store (+ loc-n 1) (cons tail bindings))))
			(else (done))))
		    (define (done)
		      (define (iexpand sexp) (expand-expr sexp id-n env store loc-n))
d487 6
a492 8
		      (check-sids (map car bindings))
		      (let ((body-output (if (null? rest)
					     (iexpand first)
					     (cons 'begin (map iexpand body)))))
			(if (null? bindings)
			    body-output
			    (list 'letrec (map expand-binding bindings) body-output))))
		    (if builtin (do-builtin (cdr first)) (done))))))
@


1.14
log
@Moved common code from the four macro contexts to the new apply-macros
procedure.
@
text
@d253 5
a257 2
  (let expand ((sexp (wrap-vecs input-sexp)) (id-n 0) (env '())
	       (store store) (loc-n loc-n) (k k))
d259 3
a261 3
      (lambda (builtin sexp id-n)
	(define (do-sequence sexps env store loc-n)
	  (let loop ((sexps sexps) (acc '()) (store store) (loc-n loc-n))
d263 4
a266 35
		(k (if (list1? acc) (car acc) (cons 'begin (reverse acc)))
		   store
		   loc-n)
		(expand (car sexps) id-n env store loc-n
		  (lambda (output store loc-n)
		    (let ((acc (if (and (pair? output)
					(eq? 'begin (car output)))
				   (revappend (cdr output) acc)
				   (cons output acc))))
		      (loop (cdr sexps) acc store loc-n)))))))
	(define (do-builtin tail)
	  (case builtin
	    ((begin) (do-sequence tail env store loc-n))
	    ((define define-syntax)
	     (or (and (= 2 (length tail)) (sid? (car tail)))
		 (error "Malformed definition" sexp))
	     (let ((symloc (lookup-sid (car tail) env)))
	       (or (symbol? symloc)
		   (error "Attempt to redefine a local: " sexp))
	       (if (eq? builtin 'define)
		   (let* ((var (symloc->var symloc))
			  (init (expand-expr (cadr tail) id-n env store loc-n))
			  (store (substitute-in-store store symloc var)))
		     (k (list 'define var init) store loc-n))
		   (compile-syntax (cadr tail) id-n env store loc-n
		     (lambda (val store loc-n)
		       (let ((store (substitute-in-store store symloc val)))
			 (k '(begin) store loc-n)))))))
	    ((top-let-syntax top-letrec-syntax)
	     (or (pair? tail) (error "Missing bindings in macro block:" sexp))
	     (let ((rec? (eq? builtin 'top-letrec-syntax)))
	       (compile-syntax-bindings (car tail) id-n rec? env store loc-n
		 (lambda (env store loc-n)
		   (do-sequence (cdr tail) env store loc-n)))))
	    (else (do-expr))))
d268 28
a295 2
	  (k (expand-expr sexp id-n env store loc-n) store loc-n))
	(if builtin (do-builtin (cdr sexp)) (do-expr))))))
d299 1
a299 1
    (lambda (builtin sexp id-n)
d304 15
a318 16
      (define (do-builtin tail)
	(case builtin
	  ((syntax-rules)
	   (or (pair? tail) (fail))
	   (let ((val (compile-syntax-rules (car tail) (cdr tail) env)))
	     (k val store loc-n)))
	  ((let-syntax letrec-syntax)
	   (or (= 2 (length tail)) (fail))
	   (let ((rec? (eq? builtin 'letrec-syntax)))
	     (compile-syntax-bindings (car tail) id-n rec? env store loc-n
	       (lambda (env store loc-n)
		 (compile-syntax (cadr tail) id-n env store loc-n k)))))
	  (else (fail))))
      (cond (builtin (do-builtin (cdr sexp)))
	    ((sid? sexp) (k (lookup-or-fail sexp) store loc-n))
	    (else (fail))))))
d345 1
a345 1
      (lambda (builtin sexp id-n)
d347 1
a347 1
	(define (do-builtin tail)
d374 1
a374 1
	(cond (builtin (do-builtin (cdr sexp)))
d415 1
a415 1
      (lambda (builtin first id-n)
d417 27
d446 1
a446 1
	    ((begin) (loop (append tail rest) id-n env store loc-n bindings))
d456 30
a485 11
	(define (done)
	  (define (iexpand sexp) (expand-expr sexp id-n env store loc-n))
	  (define (expand-binding binding) (map iexpand binding))
	  (check-sids (map car bindings))
	  (let ((body-output (if (null? rest)
				 (iexpand first)
				 (cons 'begin (map iexpand body)))))
	    (if (null? bindings)
		body-output
		(list 'letrec (map expand-binding bindings) body-output))))
	(if builtin (do-builtin (cdr first)) (done))))))
d596 1
a596 1
;; (apply-macros sexp id-n env store k) => (k builtin sexp id-n)
d598 3
a600 2
;; If the result is a use of a builtin, also returns the name of the builtin.
;; (Otherwise, returns #f and the result.)
d604 1
d606 1
a606 1
	  ((not (pair? sexp)) (k #f sexp id-n))
d612 1
a612 1
		 (k #f sexp id-n)
d614 3
a616 2
		   (cond ((variable? val) (k #f sexp id-n))
			 ((builtin? val) (k (builtin-name val) sexp id-n))
@


1.13
log
@Separated color into id-n and loc-n.
@
text
@d91 1
a91 1
;; elements in a list also makes vectors easier to handle.)
d101 1
a101 1
;; (expand-expr sexp env store loc-n) => output-sexp
d104 1
d253 54
a306 18
  (define sexp (wrap-vecs input-sexp))
  (let expand
      ((sexp sexp) (id-n 0) (env '()) (store store) (loc-n loc-n) (k k))
    (let redo ((sexp sexp) (id-n id-n))
      (define (do-sequence sexps env store loc-n)
	(let loop ((sexps sexps) (acc '()) (store store) (loc-n loc-n))
	  (if (null? sexps)
	      (k (if (list1? acc) (car acc) (cons 'begin (reverse acc)))
		 store
		 loc-n)
	      (expand (car sexps) id-n env store loc-n
		(lambda (output store loc-n)
		  (let ((acc (if (and (pair? output) (eq? 'begin (car output)))
				 (revappend (cdr output) acc)
				 (cons output acc))))
		    (loop (cdr sexps) acc store loc-n)))))))
      (define (do-builtin builtin)
	(define tail (cdr sexp))
d308 7
a314 18
	  ((begin) (do-sequence tail env store loc-n))
	  ((define define-syntax)
	   (or (and (= 2 (length tail)) (sid? (car tail)))
	       (error "Malformed definition" sexp))
	   (let* ((symloc (lookup-sid (car tail) env)))
	     (or (symbol? symloc) (error "Attempt to redefine a local: " sexp))
	     (if (eq? builtin 'define)
		 (let* ((var (symloc->var symloc))
			(init (expand-expr (cadr tail) id-n env store loc-n))
			(store (substitute-in-store store symloc var)))
		   (k (list 'define var init) store loc-n))
		 (compile-syntax (cadr tail) id-n env store loc-n
		   (lambda (val store loc-n)
		     (let ((store (substitute-in-store store symloc val)))
		       (k '(begin) store loc-n)))))))
	  ((top-let-syntax top-letrec-syntax)
	   (or (pair? tail) (error "Missing bindings in macro block:" sexp))
	   (let ((rec? (eq? builtin 'top-letrec-syntax)))
d317 5
a321 43
		 (do-sequence (cdr tail) env store loc-n)))))
	  (else (do-expr))))
      (define (do-expr)
	(k (expand-expr sexp id-n env store loc-n) store loc-n))
      (cond ((not (pair? sexp)) (do-expr))
	    ((not (list? sexp)) (error "Improper list: " sexp))
	    (else (let ((head (car sexp)))
		    (if (not (sid? head))
			(do-expr)
			(let ((val (lookup2 head env store)))
			  (cond ((variable? val) (do-expr))
				((transformer? val)
				 (apply-transformer val sexp id-n env redo))
				(else (do-builtin (builtin-name val))))))))))))

(define (compile-syntax sexp id-n env store loc-n k)
  (let redo ((sexp sexp) (id-n id-n))
    (define (fail) (error "Invalid syntax: " sexp))
    (define (lookup-or-fail sid)
      (or (lookup2 sid env store)
	  (error "Premature use of letrec-syntax binding: " sexp)))
    (define (do-builtin builtin)
      (define tail (cdr sexp))
      (case builtin
	((syntax-rules)
	 (or (pair? tail) (fail))
	 (let ((val (compile-syntax-rules (car tail) (cdr tail) env)))
	   (k val store loc-n)))
	((let-syntax letrec-syntax)
	 (or (= 2 (length tail)) (fail))
	 (let ((rec? (eq? builtin 'letrec-syntax)))
	   (compile-syntax-bindings (car tail) id-n rec? env store loc-n
	     (lambda (env store loc-n)
	       (compile-syntax (cadr tail) id-n env store loc-n k)))))
	(else (fail))))
    (cond ((sid? sexp) (k (lookup-or-fail sexp) store loc-n))
	  ((not (and (list1+? sexp) (sid? (car sexp))))
	   (fail))
	  (else (let ((val (lookup-or-fail (car sexp))))
		  (cond ((variable? val) (fail))
			((transformer? val)
			 (apply-transformer val sexp id-n env redo))
			(else (do-builtin (builtin-name val)))))))))
d346 39
a384 48
  (let redo ((sexp sexp) (id-n id-n))
    (let expand-here ((sexp sexp))
      (define (do-builtin builtin tail)
	(define (fail) (error "Malformed expression: " sexp))
	(define len (length tail))
	(case builtin
	  ((lambda)
	   (if (< len 2) (fail) (expand-lambda tail id-n env store loc-n)))
	  ((delay)
	   (if (not (= len 1)) (fail) (list 'delay (expand-here (car tail)))))
	  ((quote)
	   (if (not (= len 1)) (fail) (list 'quote (unwrap-vecs (car tail)))))
	  ((set!) (if (and (= len 2) (sid? (car tail)))
		      (cons 'set! (map expand-here tail))
		      (fail)))
	  ((if) (if (<= 2 len 3)
		    (cons 'if (map expand-here tail))
		    (fail)))
	  ((begin)
	   (if (zero? len) (fail) (cons 'begin (map expand-here tail))))
	  ((let-syntax letrec-syntax)
	   (or (>= len 2) (fail))
	   (let ((rec? (eq? builtin 'letrec-syntax)))
	     (compile-syntax-bindings (car tail) id-n rec? env store loc-n
	      (lambda (env store loc-n)
		(expand-body (cdr tail) id-n env store loc-n)))))
	  ((define define-syntax syntax-rules top-let-syntax top-letrec-syntax)
	   (error "Special form invalid as an expression: " sexp))
	  (else (error "Unknown builtin [can't happen]." sexp))))
      (cond ((sid? sexp)
	     (let ((val (lookup2 sexp env store)))
	       (if (variable? val)
		   val
		   (error "Use of keyword as variable: " sexp))))
	    ((vector? sexp) (error "Vector used as expression: " sexp))
	    ((null? sexp) (error "Null used as expression: " sexp))
	    ((not (pair? sexp)) sexp)
	    ((not (list? sexp)) (error "Improper list expression: " sexp))
	    (else
	     (let ((head (car sexp)) (tail (cdr sexp)))
	       (if (not (sid? head))
		   (map expand-here sexp)
		   (let ((val (lookup2 head env store)))
		     (cond
		      ((variable? val) (cons val (map expand-here tail)))
		      ((builtin? val) (do-builtin (builtin-name val) tail))
		      (else
		       (apply-transformer val sexp id-n env redo)))))))))))
d398 1
a398 3
(define (expand-lambda tail id-n env store loc-n)
  (define formals (car tail))
  (define body (cdr tail))
d417 4
a420 4
    (let ((rest (cdr body)))
      (let redo ((first (car body)) (id-n id-n))
	(define (do-builtin builtin)
	  (define tail (cdr first))
d424 1
a424 1
	     (or (and (= 2 (length tail)) (sid? (car tail)))
d442 1
a442 7
	(if (not (and (list1+? first) (sid? (car first))))
	    (done)
	    (let ((val (lookup2 (car first) env store)))
	      (cond ((variable? val) (done))
		    ((transformer? val)
		     (apply-transformer val first id-n env redo))
		    (else (do-builtin (builtin-name val))))))))))
d551 23
@


1.12
log
@Changed from pair to vector representation for renamed identifiers.
Original (non-renamed) identifiers are now left as bare symbols.

We now avoid copying (whenever possible) during the initial wrapping
of the input and the unwrapping of quoted structures in the output.
@
text
@d61 1
a61 1
;; (expand-top-level sexp store index k) => (k output-sexp store)
d81 1
a81 1
;; plus the name to use if it occurs within a constant.
d84 1
a84 1
;; variable: symbol  ; the symbol that is used in the output, e.g. _foo_53.
d89 18
a106 12
;; The color argument is a number guaranteed to be larger than the
;; highest numbered renamed-id and the highest numbered local-location
;; that occur in the other arguments.
;; (lookup-sid sid env) => binding
;; (lookup-binding binding store) => val | #f  ;; #f means letrec violation.
;; (lookup2 sid env store) => (lookup-binding (lookup-sid sid env) store)
;; (expand-expr sexp env store color) => output-sexp
;; (expand-top-level sexp store color k) => (k output-sexp store color)
;; (apply-transformer trans sexp env color k) => (k sexp color)
;; (compile-syntax sexp env store color k) => (k val store color)
;; (compile-syntax-bindings bindings rec? env store color k)
;;   => (k env store color)
d220 1
a220 1
(define (lookup-binding location store)
d225 1
a225 1
(define (lookup2 sid env store) (lookup-binding (lookup-sid sid env) store))
d239 2
a240 2
	(let ((frame (car store)))
	  (if (eq? symloc (car frame))
d242 1
a242 1
	      (cons frame (loop (cdr store))))))))
d251 7
a257 5
(define (expand-top-level sexp store color k)
  (let with-env ((sexp sexp) (env '()) (store store) (color color) (k k))
    (let redo ((sexp sexp) (color color))
      (define (do-sequence sexps env store color)
	(let loop ((sexps sexps) (acc '()) (store store) (color color))
d259 6
a264 8
	      (let ((output (if (and (pair? acc) (null? (cdr acc)))
				(car acc)
				(cons 'begin (reverse acc)))))
		(k output store color))
	      (with-env (car sexps) env store color
		(lambda (output store color)
		  (let ((acc (if (and (pair? output)
				      (eq? 'begin (car output)))
d267 1
a267 1
		    (loop (cdr sexps) acc store color)))))))
d271 1
a271 1
	  ((begin) (do-sequence tail env store color))
d279 1
a279 1
			(init (expand-expr (cadr tail) env store color))
d281 3
a283 3
		   (k (list 'define var init) store color))
		 (compile-syntax (cadr tail) env store color
		   (lambda (val store color)
d285 1
a285 1
		       (k '(begin) store color)))))))
d289 3
a291 3
	     (compile-syntax-bindings (car tail) rec? env store color
	       (lambda (env store color)
		 (do-sequence (cdr tail) env store color)))))
d293 2
a294 1
      (define (do-expr) (k (expand-expr sexp env store color) store color))
d303 1
a303 1
				 (apply-transformer val sexp env color redo))
d306 2
a307 2
(define (compile-syntax sexp env store color k)
  (let redo ((sexp sexp) (color color))
d318 1
a318 1
	   (k val store color)))
d322 3
a324 3
	   (compile-syntax-bindings (car tail) rec? env store color
	     (lambda (env store color)
	       (compile-syntax (cadr tail) env store color k)))))
d326 1
a326 1
    (cond ((sid? sexp) (k (lookup-or-fail sexp) store color))
d332 1
a332 1
			 (apply-transformer val sexp env color redo))
d335 1
a335 1
(define (compile-syntax-bindings bindings rec? env store color k)
d342 1
a342 1
    (let loop ((ids (map sid-id sids)) (color color) (ienv env))
d344 3
a346 3
	  (loop (cdr ids) (+ color 1) (extend-env ienv (car ids) color))
	  (let ((last-loc (- color 1)) (syntax-env (if rec? ienv env)))
	    (let loop ((sexps sexps) (vals '()) (store store) (color color))
d348 3
a350 3
		  (compile-syntax (car sexps) syntax-env store color
		    (lambda (val store color)
		      (loop (cdr sexps) (cons val vals) store color)))
d355 1
a355 1
			(k ienv store color))))))))))
d357 2
a358 2
(define (expand-expr sexp env store color)
  (let redo ((sexp sexp) (color color))
d365 1
a365 1
	   (if (< len 2) (fail) (expand-lambda tail env store color)))
d381 3
a383 3
	     (compile-syntax-bindings (car tail) rec? env store color
	      (lambda (env store color)
		(expand-body (cdr tail) env store color)))))
d405 1
a405 1
		       (apply-transformer val sexp env color redo)))))))))))
d419 1
a419 1
(define (expand-lambda tail env store color)
d424 1
a424 1
      ((env env) (store store) (color color) (formals formals) (vars '()))
d426 1
a426 1
	(list 'lambda (reverse vars) (expand-body body env store color))
d428 3
a430 5
	       (location color)
	       (color (+ 1 color))
	       (var (make-local-var location (sid-name formal)))
	       (env (extend-env env (sid-id formal) location))
	       (store (extend-store store location var)))
d432 7
a438 6
	      (loop env store color (cdr formals) (cons var vars))
	      (let ((vars (revappend vars var)))
		(list 'lambda vars (expand-body body env store color))))))))

(define (expand-body sexps env store color)
  (let loop ((env env) (store store) (bindings '()) (body sexps) (color color))
d441 1
a441 1
      (let redo ((first (car body)) (color color))
d445 1
a445 1
	    ((begin) (loop env store bindings (append tail rest) color))
d450 4
a453 6
		    (location color)
		    (color (+ 1 color))
		    (var (make-local-var location (sid-name sid)))
		    (env (extend-env env (sid-id sid) location))
		    (store (extend-store store location var)))
	       (loop env store (cons tail bindings) rest (+ color 1))))
d456 1
a456 1
	  (define (iexpand sexp) (expand-expr sexp env store color))
d470 1
a470 1
		     (apply-transformer val first env color redo))
d489 1
a489 1
(define (apply-transformer transformer sexp env color k)
d558 1
a558 1
		       (make-sid (+ color index) location (sid-name tmpl)))))))
d571 1
a571 1
      (k (expand tmpl top-bindings) (+ color (length tmpl-literals))))
d740 1
a740 2
(define null-stuff
  (expand-top-level (wrap-vecs null-prog) builtins-store 0 list))
d742 1
a742 1
(define null-color (caddr null-stuff))
d745 2
a746 2
  (expand-top-level (wrap-vecs sexp) null-store null-color
    (lambda (sexp store color) sexp)))
d749 1
a749 1
(define (null-menv) (cons null-store null-color))
d752 2
a753 2
  (expand-top-level (wrap-vecs sexp) (car menv) (cdr menv)
    (lambda (sexp store color)
d755 1
a755 1
      (set-cdr! menv color)
@


1.11
log
@Changed back to simpler env/store model in which no values are stored
in the environment; all value lookups go through the environment and
the store.
@
text
@d79 4
a82 2
;; The location is the location to use if the id occurs freely.
;; sid: ((id . location) . name)
d89 3
d105 1
a105 1
;;    | (variable)
d151 39
a189 26
(define (sid? s)   (and (pair? s) (symbol? (cdr s))))
;; spair? and slist? are like pair? and list? except that they do not
;; consider sids to be pairs.
;; We can use list? for slist? because a sid is never a list.
(define (spair? s) (and (pair? s) (not (symbol? (cdr s)))))
(define slist? list?)
(define (slist1+? s) (and (pair? s) (slist? (cdr s))))
(define (slist1? s) (and (pair? s) (null? (cdr s))))
(define (slist2? s) (and (pair? s) (slist1? (cdr s))))

(define (make-sid id location name) (cons (cons id location) name))
(define sid-id caar)
(define sid-location cdar)
(define sid-name cdr)

(define (syms->sids sexp)
  (cond ((symbol? sexp) (make-sid sexp sexp sexp))
	((pair? sexp) (cons (syms->sids (car sexp)) (syms->sids (cdr sexp))))
	((vector? sexp) (list->vector (syms->sids (vector->list sexp))))
	(else sexp)))

(define (sids->syms sexp)
  (cond ((sid? sexp) (sid-name sexp))
	((pair? sexp) (cons (sids->syms (car sexp)) (sids->syms (cdr sexp))))
	((vector? sexp) (list->vector (sids->syms (vector->list sexp))))
	(else sexp)))
d288 2
a289 2
      (cond ((not (spair? sexp)) (do-expr))
	    ((not (slist? sexp)) (error "Improper list: " sexp))
d320 1
a320 1
	  ((not (and (slist1+? sexp) (sid? (car sexp))))
d330 2
a331 2
    (or (slist2? binding) (error "Malformed syntax binding: " binding)))
  (or (slist? bindings) (error "Malformed syntax bindings list: " bindings))
d362 1
a362 1
	   (if (not (= len 1)) (fail) (list 'quote (sids->syms (car tail)))))
d387 2
a388 2
	    ((not (spair? sexp)) sexp)
	    ((not (slist? sexp)) (error "Improper list expression: " sexp))
d403 1
a403 1
	(let ((sid (if (spair? sids) (car sids) sids)))
d409 1
a409 1
		    (if (spair? sids)
d420 1
a420 1
	(let* ((formal (if (spair? formals) (car formals) formals))
d426 1
a426 1
	  (if (spair? formals)
d461 1
a461 1
	(if (not (and (slist1+? first) (sid? (car first))))
d470 1
a470 1
  (or (slist? lits) (error "Malformed literals list: " lits))
d474 1
a474 1
      (or (slist2? rule) (error "Malformed syntax rule: " rule))
d492 1
a492 1
    (define (ellipsis-pair? x) (and (spair? x) (ellipsis? (car x))))
d502 1
a502 1
	      ((vector? x) (collect (vector->list x) inc l))
d526 3
a528 3
	     (or (vector? sexp) (fail))
	     (match (vector->list pat) (vector->list sexp) bindings))
	    ((not (spair? pat)) (continue-if (equal? pat sexp)))
d530 1
a530 1
	     (or (slist? sexp) (fail))
d535 1
a535 1
	    ((spair? sexp) (match (car pat) (car sexp)
d556 1
a556 1
	    (list->vector (expand-part (vector->list tmpl))))
d737 1
a737 1
  (expand-top-level (syms->sids null-prog) builtins-store 0 list))
d742 1
a742 1
  (expand-top-level (syms->sids sexp) null-store null-color
d749 1
a749 1
  (expand-top-level (syms->sids sexp) (car menv) (cdr menv)
@


1.10
log
@Nothing major.
@
text
@d70 11
a80 7
;; id: symbol | integer      ;; just enough information to uniquely identify.
;; sid: ((id . binding) . name)  ;; additional info stored in sexp instances.
;; name: symbol
;; location: symloc | intloc
;; symloc: symbol
;; intloc: integer
;; binding: (intloc . val) | (intloc . frame-start) | (symloc)
d82 1
a82 1
;; variable: symbol
a85 3
;; env: ((id . binding) ...)
;; store: (frame ...)
;; frame: (symloc . val) | (intloc . #(val ...))
d98 1
a98 1
;; inserted-literal: (binding . name)
d156 1
a156 1
(define (make-sid id binding name) (cons (cons id binding) name))
d158 1
a158 1
(define sid-binding cdar)
a160 2
(define binding-loc car)

d162 1
a162 1
  (cond ((symbol? sexp) (make-sid sexp (list sexp) sexp))
d185 1
a185 1
	(else (sid-binding sid))))
d196 4
a199 10
(define (lookup-binding binding store)
  (let ((location (binding-loc binding)))
    (if (symbol? location)
	(cond ((assq location store) => cdr)
	      (else (symloc->var location)))
	(let ((val (cdr binding)))
	  (cond ((not (number? val)) val)
		((assv val store)
		 => (lambda (frame) (vector-ref (cdr frame) (- location val))))
		(else #f))))))
d203 1
a203 1
(define (extend-env env id binding) (acons id binding env))
d205 1
a205 2
(define (extend-store store intloc vals)
  (if (null? vals) store (acons intloc (list->vector vals) store)))
d251 1
a251 1
	   (let* ((symloc (binding-loc (lookup-sid (car tail) env))))
d292 2
a293 1
	 (k (compile-syntax-rules (car tail) (cdr tail) env) store color))
d317 14
a330 25
    (let ((ids (map sid-id sids)))
      (if (not rec?)
	  (let loop
	      ((sexps sexps) (ids ids) (ienv env) (store store) (color color))
	    (if (null? ids)
		(k ienv store color)
		(compile-syntax (car sexps) env store color
		  (lambda (val store color)
		    (let ((ienv (extend-env ienv (car ids) (cons color val))))
		      (loop (cdr sexps) (cdr ids) ienv store (+ color 1)))))))
	  (let ((frame-start color))
	    (let loop ((ids ids) (ienv env) (color color))
	      (if (pair? ids)
		  (let* ((binding (cons color frame-start))
			 (ienv (extend-env ienv (car ids) binding)))
		    (loop (cdr ids) ienv (+ color 1)))
		  (let loop2 ((sexps sexps) (vals '())
			      (store store) (color color))
		    (if (null? sexps)
			(k ienv (extend-store store frame-start (reverse vals))
			   color)
			(compile-syntax (car sexps) ienv store color
			  (lambda (val store color)
			    (loop2 (cdr sexps) (cons val vals)
				   store color))))))))))))
d398 2
a399 1
  (let loop ((env env) (color color) (formals formals) (vars '()))
d406 2
a407 2
	       (binding (cons location var))
	       (env (extend-env env (sid-id formal) binding)))
d409 1
a409 1
	      (loop env color (cdr formals) (cons var vars))
d414 1
a414 1
  (let loop ((env env) (bindings '()) (body sexps) (color color))
d421 1
a421 1
	    ((begin) (loop env bindings (append tail rest) color))
d429 3
a431 3
		    (binding (cons location var))
		    (env (extend-env env (sid-id sid) binding)))
	       (loop env (cons tail bindings) rest (+ color 1))))
d443 1
a443 1
	(if (not (slist1+? first))
d445 5
a449 8
	    (let ((head (car first)))
	      (if (not (sid? head))
		  (done)
		  (let ((val (lookup2 head env store)))
		    (cond ((variable? val) (done))
			  ((transformer? val)
			   (apply-transformer val first env color redo))
			  (else (do-builtin (builtin-name val))))))))))))
d473 1
a473 2
    (define (ellipsis? x)
      (and (sid? x) (eq? '... (binding-loc (lookup-sid x mac-env)))))
d504 2
a505 2
				   (eqv? (binding-loc (lookup-sid pat mac-env))
					 (binding-loc (lookup-sid sexp env)))))
d535 2
a536 2
				(binding (lookup-sid tmpl mac-env)))
		       (make-sid (+ color index) binding (sid-name tmpl)))))))
d551 2
@


1.9
log
@Moved the name to the cdr of a sid, so that slist? can just be list?.

Changed representation of a toplevel binding from symbol to (symbol).
Now bindings comparison is a little simpler: (eqv? (car binding1) (car
binding2)).
@
text
@d10 1
d26 1
a26 1
;; New model:
d69 2
a70 1
;; id: symbol | number     ;; just enough information to uniquely identify.
d73 1
a73 1
;; location: symloc | numloc
d75 2
a76 2
;; numloc: integer
;; binding: (numloc . val) | (numloc . frame-start) | (symloc)
d81 2
d84 1
a84 3
;; frame: (symloc . val) | (numloc . #(val ...))
;; env: ((id . binding) ...)
;; transformer: (rule ...)
d88 1
a88 1
;; (lookup2 sid env store) => val | #f
d98 1
a98 1
;; pat: (literal . binding)
d152 2
d155 1
a155 1
(define sid-name cdr)
d158 2
a159 1
(define (make-sid id binding name) (cons (cons id binding) name))
d194 1
a194 1
    ((lambda quote set! if delay letrec begin define) (rename))
d212 2
a213 2
(define (extend-store store numloc vals)
  (if (null? vals) store (acons numloc (list->vector vals) store)))
d228 1
a228 1
(define (make-local-var numloc name)
d230 1
a230 1
    (string->symbol (string-append "_" str "_" (number->string numloc)))))
d298 3
a300 1
	((syntax-rules) (k (cons env tail) store color))
d319 1
a319 2
    (or (and (slist? binding) (= 2 (length binding)))
	(error "Malformed syntax binding: " binding)))
d324 25
a348 24
    (if rec?
	(let loop ((sids sids) (ienv env) (icolor color))
	  (if (pair? sids)
	      (let ((id (sid-id (car sids)))
		    (binding (cons icolor color)))
		(loop (cdr sids) (extend-env ienv id binding) (+ icolor 1)))
	      (let loop ((sexps sexps) (vals '())
			 (store store) (icolor icolor))
		(if (null? sexps)
		    (let ((store (extend-store store color (reverse vals))))
		      (k ienv store icolor))
		    (compile-syntax (car sexps) ienv store icolor
		      (lambda (val store icolor)
			(loop (cdr sexps) (cons val vals) store icolor)))))))
	(let loop ((sexps sexps) (sids sids) (ienv env)
		   (store store) (color color))
	  (if (null? sids)
	      (k ienv store color)
	      (compile-syntax (car sexps) env store color
		(lambda (val store color)
		  (let* ((id (sid-id (car sids)))
			 (ienv (extend-env ienv id (cons color val))))
		    (loop (cdr sexps) (cdr sids) ienv
			  store (+ color 1))))))))))
d420 5
a424 3
	       (var (make-local-var color (sid-name formal)))
	       (env (extend-env env (sid-id formal) (cons color var)))
	       (color (+ 1 color)))
d443 5
a447 2
		    (var (make-local-var color (sid-name sid)))
		    (env (extend-env env (sid-id sid) (cons color var))))
d471 16
d489 2
a490 2
	(pat-literals (map sid-id (cadr transformer)))
	(rules (cddr transformer)))
d613 1
a613 1
	    (define var (lambda args . body)))
d690 3
a692 1
     ;; of itself using a syntax-rules hygienic literal.
d695 1
a695 1
	   ((letrec-syntax-all-rules-preserve-tail
d697 39
a735 31
	       ((_  ((m               lits ((p ...    ) (t ...    )) ... ) ...)
		  . body)
		(letrec-syntax
		    ((m (syntax-rules lits ((p ... . k) (t ... . k)) ...)) ...)
		  . body)))))
	 (letrec-syntax-all-rules-preserve-tail
	   ((qq (unquote unquote-splicing quasiquote)
	      ((_ ,expr ()) (do-next expr))
	      ((_ `x depth) (qq (x) (depth) make-pair 'quasiquote))
	      ((_ ,x (depth)) (qq (x) depth make-pair 'unquote))
	      ((_ ,@@x (depth)) (qq (x) depth make-pair 'unquote-splicing))
	      ((_ (,@@car . cdr) ())
	       (qq cdr () make-splice car))
	      ((_ (car . cdr) depth)
	       (qq car depth qq-cdr cdr depth))
	      ((_ #(elt ...) depth) (qq (elt ...) depth make-vector))
	      ((_ x depth) (do-next 'x)))
	    (do-next ()
	      ((_ expr next-macro) (next-macro expr)))
	    (qq-cdr ()
	      ((_ car cdr depth) (qq cdr depth make-pair car)))
	    (make-pair (quote)
	      ((_ 'cdr 'car) (do-next '(car . cdr)))
	      ((_ cdr car) (do-next (cons car cdr))))
	    (make-vector (quote)
	      ((_ '(elt ...)) (do-next '#(elt ...)))
	      ((_ expr) (do-next (list->vector expr))))
	    (make-splice ()
	      ((_ cdr car) (do-next (append car cdr)))))
	 (syntax-rules ()
	   ((_ template) (qq template () begin))))))))
d755 13
@


1.8
log
@*** empty log message ***
@
text
@d3 7
d24 44
d69 1
a69 1
;; sid: (name id . binding)  ;; additional info stored in sexp instances.
d73 2
a74 2
;; numloc: number
;; binding: (location . val) | (numloc . frame-start) | symloc
d82 1
a82 1
;; transformer: (env rule ...)
d94 2
a95 1
;; rule: (num-colors pat . tmpl)
a96 1
;;    | (constant . sexp)
d98 3
a100 2
;;    | (vector . pat)
;;    | (pair pat . pat)
d103 8
a110 14
;; tmpl: (literal color-offset binding . name)
;;    | (constant . sexp)
;;    | (variable . accessor)
;;    | (vector . templ)
;;    | (pair templ . templ)
;;    | (seq (accessor ...) templ)
;; accessor: (part-index subpart ...)
;; subpart: car | cdr | vector->list

;; (expand-expr sexp env store color) => output-sexp
;; (expand-top-level sexp store color k) => (k output-sexp store color)
;; (expand-macro-use sexp trans env color k) => (k sexp color)
;; (compile-trans sexp env store color k) => (k trans store color)
;; (compile-trans-bindings sexp rec? env store color k) => (k env store color)
d143 13
a155 8
(define (sid? s)   (and (pair? s) (symbol? (car s))))
(define (spair? s) (and (pair? s) (not (symbol? (car s)))))
(define (slist? s) (or (null? s) (and (spair? s) (slist? (cdr s)))))

(define sid-name car)
(define sid-id cadr)
(define sid-binding cddr)
(define (make-sid name id binding) (cons name (cons id binding)))
d158 1
a158 1
  (cond ((symbol? sexp) (make-sid sexp sexp sexp))
d193 9
a201 9
  (if (symbol? binding)
      (cond ((assq binding store) => cdr)
	    (else (symloc->var binding)))
      (let ((val (cdr binding)))
	(cond ((not (number? val)) val)
	      ((assv val store)
	       => (lambda (frame)
		    (vector-ref (cdr frame) (- (car binding) val))))
	      (else #f)))))
a222 3
(define (same-binding? b1 b2)
  (or (eq? b1 b2) (and (pair? b1) (pair? b2) (eqv? (car b1) (car b2)))))

d234 1
a234 1
	(let loop ((sexps sexps) (output '()) (store store) (color color))
d236 3
a238 3
	      (let ((output (if (and (pair? output) (null? (cdr output)))
				(car output)
				(cons 'begin (reverse output)))))
d241 6
a246 6
		(lambda (output1 store color)
		  (let ((output (if (and (pair? output1)
					 (eq? 'begin (car output1)))
				    (revappend (cdr output1) output)
				    (cons output1 output))))
		    (loop (cdr sexps) output store color)))))))
d248 1
d250 1
a250 1
	  ((begin) (do-sequence (cdr sexp) env store color))
d252 1
a252 1
	   (or (and (= 3 (length sexp)) (sid? (cadr sexp)))
d254 1
a254 1
	   (let ((symloc (lookup-sid (cadr sexp) env)))
d258 1
a258 1
			(init (expand-expr (caddr sexp) env store color))
d261 1
a261 1
		 (compile-syntax (caddr sexp) env store color
d266 1
a266 2
	   (or (pair? (cdr sexp))
	       (error "Missing bindings in macro block:" sexp))
d268 1
a268 1
	     (compile-syntax-bindings (cadr sexp) rec? env store color
d270 1
a270 1
		 (do-sequence (cddr sexp) env store color)))))
d287 3
d301 2
a302 6
    (cond ((sid? sexp)
	   (let ((val (lookup2 sexp env store)))
	     (if val
		 (k val store color)
		 (error "Premature use of letrec-syntax binding: " sexp))))
	  ((not (and (spair? sexp) (slist? sexp) (sid? (car sexp))))
d304 5
a308 8
	  (else
	   (let ((val (lookup2 (car sexp) env store)))
	     (cond ((not val)
		    (error "Premature use of letrec-syntax binding: " sexp))
		   ((variable? val) (fail))
		   ((transformer? val)
		    (apply-transformer val sexp env color redo))
		   (else (do-builtin (builtin-name val)))))))))
d313 2
a314 2
	(error "Malformed binding: " binding)))
  (or (slist? bindings) (error "Malformed bindings list" bindings))
a319 1
	  ;;(print sids ienv icolor)
d363 1
a363 4
	   (case len
	     ((0) (fail))
	     ((1) (expand-here (car tail)))
	     (else (cons 'begin (map expand-here tail)))))
d427 11
a437 11
	  (let ((tail (cdr first)))
	    (case builtin
	      ((begin) (loop env bindings (append tail rest) color))
	      ((define)
	       (or (and (= 2 (length tail)) (sid? (car tail)))
		   (error "Malformed definition: " first))
	       (let* ((sid (car tail))
		      (var (make-local-var color (sid-name sid)))
		      (env (extend-env env (sid-id sid) (cons color var))))
		 (loop env (cons tail bindings) rest (+ color 1))))
	      (else (done)))))
d448 1
a448 1
	(if (not (and (spair? first) (slist? (cdr first))))
d465 2
a466 2

    (define (ellipsis? x) (and (sid? x) (eq? '... (lookup-sid x mac-env))))
d497 2
a498 2
				   (same-binding? (lookup-sid pat mac-env)
						  (lookup-sid sexp env))))
d529 1
a529 1
		       (make-sid (sid-name tmpl) (+ color index) binding))))))
d535 1
a535 1
		  (define (lookup var) (cdr (assq var bindings)))
d563 4
d578 2
a579 1
			  ((_ . kws) (define-syntaxes kws kw ...))))))
d629 5
a633 3
		 ((case key (else . results))
		  (begin . results))
		 ((case key ((datum ...) . results) . clauses)
d635 1
a635 1
		      (begin . results)
d660 3
@


1.7
log
@Added a null-prog with implementations of all the r5rs library
syntaxes.  The expander can now succesfully expand itself.
@
text
@d618 1
a618 1
		    . body)
d659 1
a659 1
(define (builtins-menv) (cons builtins-store 0))
@


1.6
log
@First working version with the new model: a unified store for
top-level bindings and letrec-syntax bindings (with each letrec-syntax
frame stored in a single vector); lambda and let-syntax bindings are
stored directly in the environment.

Internal definitions are supported.

The syntax position of a syntax binding is now allowed to be any bare
identifier (previously, a bare identifier had to be a keyword).  This
allows a kind of variable aliasing:

  (let ((x 1)) (let-syntax ((y x)) (set! y 2) (list 'x x 'y y))) => (x 2 y 2)
@
text
@d34 1
a34 1
;; (lookup-binding binding store) => val | #f
a42 11
;; an old plan:
;; environment: id -> location
;; store: location -> value
;; id: symbol | number
;; location: symbol | number
;; sid: (symbol id . location)
;; value: #f | special  ;; #f means variable
;; special: builtin | transformer
;; builtin: symbol  ;; including undefined.
;; transformer: (rule ...)

d138 1
a138 1
    ((lambda quote set! if begin define letrec) (rename))
d179 3
d184 55
a238 9
    (define (do-sequence sexps env store color)
      (define (loop sexps output store color)
	(if (null? sexps)
	    (let ((output (cons 'begin (reverse output))))
	      (k output store color))
	    (with-env (car sexps) env store color
	      (lambda (output1 store color)
		(loop (cdr sexps) (cons output1 output) store color)))))
      (loop sexps '() store color))
d240 1
d242 5
a246 20
	((begin) (do-sequence (cdr sexp) env store color))
	((define define-syntax)
	 (or (and (= 3 (length sexp)) (sid? (cadr sexp)))
	     (error "Malformed definition" sexp))
	 (let ((symloc (lookup-sid (cadr sexp) env)))
	   (or (symbol? symloc) (error "Attempt to redefine a local: " sexp))
	   (if (eq? builtin 'define)
	       (let* ((var (symloc->var symloc))
		      (init (expand-expr (caddr sexp) env store color))
		      (store (substitute-in-store store symloc var)))
		 (k (list 'define var init) store color))
	       (compile-syntax (caddr sexp) env store color
	         (lambda (val store color)
		   (let ((store (substitute-in-store store symloc val)))
		     (k '(begin) store color)))))))
	((top-let-syntax top-letrec-syntax)
	 (or (pair? (cdr sexp))
	     (error "Missing bindings in macro block:" sexp))
	 (let ((rec? (eq? builtin 'top-letrec-syntax)))
	   (compile-syntax-bindings (cadr sexp) rec? env store color
d248 17
a264 136
	       (do-sequence (cddr sexp) env store color)))))
	(else (do-expr))))
    (define (do-expr) (k (expand-expr sexp env store color) store color))
    (cond ((not (spair? sexp)) (do-expr))
	  ((not (slist? sexp)) (error "Improper list" sexp))
	  (else (let ((head (car sexp)))
		  (if (not (sid? head))
		      (do-expr)
		      (let ((val (lookup2 head env store)))
			(cond ((variable? val) (do-expr))
			      ((builtin? val) (do-builtin (builtin-name val)))
			      (else 
			       (apply-transformer val sexp env color
				 (lambda (sexp color)
				   (with-env sexp env store color k))))))))))))

(define (apply-transformer transformer sexp env color k)
  (let ((mac-env (car transformer))
	(pat-literals (map sid-id (cadr transformer)))
	(rules (cddr transformer)))
    (define (pat-literal? id)     (memv id pat-literals))
    (define (not-pat-literal? id) (not (pat-literal? id)))

    (define (ellipsis? x) (and (sid? x) (eq? '... (lookup-sid x mac-env))))
    (define (ellipsis-pair? x) (and (spair? x) (ellipsis? (car x))))

    ;; List-ids returns a list of the non-ellipsis ids in a
    ;; pattern or template for which (pred? id) is true.  If
    ;; include-scalars is false, we only include ids that are
    ;; within the scope of at least one ellipsis.
    (define (list-ids x include-scalars pred?)
      (let collect ((x x) (inc include-scalars) (l '()))
	(cond ((sid? x) (let ((id (sid-id x)))
			  (if (and inc (pred? id)) (cons id l) l)))
	      ((vector? x) (collect (vector->list x) inc l))
	      ((pair? x)
	       (if (ellipsis-pair? (cdr x))
		   (collect (car x) #t (collect (cddr x) inc l))
		   (collect (car x) inc (collect (cdr x) inc l))))
	      (else l))))
    
    ;; Returns #f or an alist mapping each pattern var to a part of
    ;; the input.  Ellipsis vars are mapped to lists of parts (or
    ;; lists of lists...).
    (define (match-pattern pat use env)
      (call-with-current-continuation
       (lambda (return)
	 (define (fail) (return #f))
	 (let match ((pat (cdr pat)) (sexp (cdr use)) (bindings '()))
	   (define (continue-if condition) (if condition bindings (fail)))
	   (cond
	    ((sid? pat)
	     (if (pat-literal? (sid-id pat))
		 (continue-if (and (sid? sexp)
				   (same-binding? (lookup-sid pat mac-env)
						  (lookup-sid sexp env))))
		 (cons (cons (sid-id pat) sexp) bindings)))
	    ((vector? pat)
	     (or (vector? sexp) (fail))
	     (match (vector->list pat) (vector->list sexp) bindings))
	    ((not (spair? pat)) (continue-if (equal? pat sexp)))
	    ((ellipsis-pair? (cdr pat))
	     (or (slist? sexp) (fail))
	     (let ((vars (list-ids pat #t not-pat-literal?)))
	       (define (match1 sexp) (map cdr (match (car pat) sexp '())))
	       (append (apply map list vars (map match1 sexp))
		       bindings)))
	    ((spair? sexp) (match (car pat) (car sexp)
				  (match (cdr pat) (cdr sexp) bindings)))
	    (else (fail)))))))

    (define (expand-template pat tmpl top-bindings)
      (define tmpl-literals
	(list-ids tmpl #t (lambda (id) (not (assv id top-bindings)))))
      (define ellipsis-vars (list-ids (cdr pat) #f not-pat-literal?))
      (define (list-ellipsis-vars subtmpl)
	(list-ids subtmpl #t (lambda (id) (memv id ellipsis-vars))))
      (define (expand tmpl bindings)
	(let expand-part ((tmpl tmpl))
	  (cond
	   ((sid? tmpl)
	    (let ((id (sid-id tmpl)))
	      (cond ((assv id bindings) => cdr)
		    ((assv id top-bindings) => cdr)
		    (else (let ((index (+ -1 (length (memv id tmpl-literals))))
				(binding (lookup-sid tmpl mac-env)))
		       (make-sid (sid-name tmpl) (+ color index) binding))))))
	   ((vector? tmpl)
	    (list->vector (expand-part (vector->list tmpl))))
	   ((pair? tmpl)
	    (if (ellipsis-pair? (cdr tmpl))
		(let ((vars-to-iterate (list-ellipsis-vars (car tmpl))))
		  (define (lookup var) (cdr (assq var bindings)))
		  (define (expand-car . vals)
		    (expand (car tmpl) (map cons vars-to-iterate vals)))
		  (append (apply map expand-car (map lookup vars-to-iterate))
			  (expand-part (cddr tmpl))))
		(cons (expand-part (car tmpl)) (expand-part (cdr tmpl)))))
	   (else tmpl))))
      (k (expand tmpl top-bindings) (+ color (length tmpl-literals))))

    (let loop ((rules rules))
      (let* ((rule (car rules)) (pat (car rule)) (tmpl (cadr rule)))
	(cond ((match-pattern pat sexp env)
	       => (lambda (bindings) (expand-template pat tmpl bindings)))
	      (else (loop (cdr rules))))))))

(define (compile-syntax sexp env store color k)
  (define (fail) (error "Invalid syntax: " sexp))
  (define (do-builtin builtin)
    (case builtin
      ((syntax-rules) (k (cons env (cdr sexp)) store color))
      ((let-syntax letrec-syntax)
       (or (= 3 (length sexp)) (fail))
       (let ((rec? (eq? builtin 'letrec-syntax)))
	 (compile-syntax-bindings (cadr sexp) rec? env store color
	   (lambda (env store color)
	     (compile-syntax (caddr sexp) env store color k)))))
      (else (fail))))
  (cond ((sid? sexp)
	 (let ((val (lookup2 sexp env store)))
	   (if val
	       (k val store color)
	       (error "Premature use of letrec-syntax binding: " sexp))))
	((not (and (spair? sexp) (slist? sexp) (sid? (car sexp))))
	 (fail))
	(else
	 (let ((val (lookup2 (car sexp) env store)))
	   (cond ((not val)
		  (error "Premature use of letrec-syntax binding: " sexp))
		 ((variable? val) (fail))
		 ((transformer? val)
		  (apply-transformer val sexp env color
		    (lambda (sexp color)
		      (compile-syntax sexp env store color k))))
		 (else (do-builtin (builtin-name val))))))))
d301 5
a305 4
  (let expand-here ((sexp sexp))
    (define (do-builtin builtin tail)
      (define (fail) (error "Malformed expression: " sexp))
      (let ((len (length tail)))
d309 2
d332 20
a351 22
	  (else (error "Unknown builtin [can't happen]." sexp)))))
    (cond ((sid? sexp)
	   (let ((val (lookup2 sexp env store)))
	     (if (variable? val)
		 val
		 (error "Use of keyword as variable: " sexp))))
	  ((vector? sexp) (error "Vector used as expression: " sexp))
	  ((null? sexp) (error "Null used as expression: " sexp))
	  ((not (spair? sexp)) sexp)
	  ((not (slist? sexp)) (error "Improper list expression: " sexp))
	  (else
	   (let ((head (car sexp)) (tail (cdr sexp)))
	     (if (not (sid? head))
		 (map expand-here sexp)
		 (let ((val (lookup2 head env store)))
		   (cond
		    ((variable? val) (cons val (map expand-here tail)))
		    ((builtin? val) (do-builtin (builtin-name val) tail))
		    (else
		     (apply-transformer val sexp env color
		       (lambda (sexp color)
			 (expand-expr sexp env store color))))))))))))
a365 2
  (define (revappend l1 l2)
    (if (null? l1) l2 (revappend (cdr l1) (cons (car l1) l2))))
d368 1
a368 1
  (check-ids formals)
d419 91
d511 1
a511 1
  '(if lambda quote set! let-syntax letrec-syntax begin
d520 46
a565 4
  '(begin
     (top-let-syntax
         ((def define)
	  (with-saved-syntaxes
d567 23
a589 4
	     ((_ (id ...) x ...)
	      (top-let-syntax ((id id) ...) x ...)))))
       (with-saved-syntaxes (if lambda quote set! begin)
	 (define-syntax define
d591 57
a647 3
	     ((_ (f . args) . body)
	      (def f (lambda args . body)))
	     ((_ var init) (def var init))))))))
@


1.5
log
@About to also abandon the idea of keeping the letrec frames in a
separate store from the store for global bindings.  All hail simplicity.
@
text
@a16 1
;; New Plan (unimplemented):
d18 1
a18 1
;; sid: (id binding . name)  ;; additional info stored in sexp instances.
a19 3
;; binding: location | (location . val)
;; val: variable | syntax
;; variable: symbol
d23 3
d28 10
a37 11
;; transformer: (lenv rule ...)
;; Gstore is global; lstore and lenv are for locals:
;; gstore: ((symloc . val) ...)
;; lstore: ((numloc . #(val ...)) ...)
;; lenv: ((id . binding) ...)

;; (lookup-id id env) => binding
;; (lookup-binding binding lstore gstore) => val
;; (expand-expr sexp env lstore gstore color) => output-sexp
;; (expand-top-level sexp lstore gstore color k)
;;   => (k output-sexp lstore gstore color)
d39 3
a41 4
;; (compile-syntax sexp env lstore gstore color k) => (k val lstore color)
;; (compile-syntax-bindings bindings rec? env lstore gstore color k)
;;   => (k env lstore color)

d112 4
a115 4
(define sid-id car)
(define sid-binding cadr)
(define sid-name cddr)
(define (make-sid id binding name) (cons id (cons binding name)))
d118 1
a118 1
  (cond ((symbol? sexp) (make-sid sym sym sym))
d130 1
a130 1
(define (syntax? val) (pair? val))
d145 1
a145 1
(define (maybe-rename sym)
d152 12
a163 17
(define (lookup-binding binding lstore gstore)
  (cond ((pair? binding) (cdr binding))
	((symbol? binding) (cond ((assv binding gstore) => cdr)
				 (else (maybe-rename binding))))
	(else (let loop ((lstore lstore))
		(if (null? lstore)
		    #f
		    (let* ((frame (car lstore))
			   (firstloc (car frame))
			   (index (- binding firstloc)))
		      (if (negative? index)
			  (loop (cdr lstore))
			  (let* ((vec (cdr frame))
				 (len (vector-length vec)))
			    (if (>= index len)
				(loop (cdr lstore))
				(vector-ref vec index))))))))))
d167 2
a168 2
(define (extend-lstore lstore numloc vals)
  (acons numloc (list->vector vals) lstore))
d170 9
a178 9
(define (substitute-in-gstore gstore symloc val)
  (define (add-it-if-not-default gstore)
    (if (and (variable? val) (eq? val (maybe-rename symloc)))
	gstore
	(acons symloc val gstore)))
  (if (not (assv symloc gstore))
      (add-it-if-not-default gstore)
      (let loop ((gstore gstore))
	(let ((frame (car gstore)))
d180 5
a184 2
	      (add-it-if-not-default (cdr gstore))
	      (cons frame (loop (cdr gstore))))))))
d186 1
a186 1
(define (make-var numloc name)
d190 4
a193 6
(define (expand-top-level sexp lstore gstore color k)
  (define (with-env sexp env lstore gstore color k)
    (define (do-expr)
      (k (expand-expr sexp env lstore gstore color) lstore gstore color))
    (define (do-sequence sexps env lstore color)
      (define (loop sexps output lstore gstore color)
d196 5
a200 5
	      (k output lstore gstore color))
	    (with-env (car sexps) env lstore gstore color
	      (lambda (output1 lstore gstore color)
		(loop (cdr sexps) (cons output1 output) gstore color)))))
      (loop sexps '() lstore gstore color))
d203 1
a203 1
	((begin) (do-sequence (cdr sexp) env lstore gstore color))
d207 1
a207 1
	 (let ((symloc (lookup-id (cadr sexp) env)))
d210 8
a217 8
	       (let* ((var (lookup-binding symloc lstore gstore))
		      (init (expand-expr (caddr sexp) env lstore gstore color))
		      (gstore (substitute-in-gstore gstore symloc var)))
		 (k (list 'define var init) lstore gstore color))
	       (compile-syntax (caddr sexp) env lstore gstore color
	         (lambda (val lstore color)
		   (let ((gstore (substitute-in-gstore gstore symloc val)))
		     (k '(begin) lstore gstore color)))))))
d222 3
a224 3
	   (compile-syntax-bindings (cadr sexp) rec? env lstore gstore color
	     (lambda (env lstore color)
	       (do-sequence (cddr sexp) env lstore color)))))
d226 1
d229 15
a243 18
	  (else
	   (let ((head (car sexp)))
	     (if (not (sid? head))
		 (do-expr)
		 (let* ((binding (lookup-sid head env))
			(val (lookup-binding binding lstore gstore)))
		   (cond ((not (syntax? val)) (do-expr))
			 ((transformer? val) 
			  (apply-transformer val sexp env color
			    (lambda (sexp color)
			      (with-env sexp env lstore gstore color k))))
			 (else (do-builtin (builtin-name val))))))))))
  (with-env sexp '() lstore gstore color k))

(define (apply-rules rules sexp env color k)
  (let ((mac-env (car rules))
	(pat-literals (map sid-id (cadr rules)))
	(rules (cddr rules)))
d247 1
a247 1
    (define (ellipsis? x)      (and (sid? x) (eq? '... (lookup-id x mac-env))))
d275 6
a280 5
	    ((sid? pat) (if (pat-literal? (sid-id pat))
			    (continue-if (and (sid? sexp)
					      (eqv? (env-lookup mac-env pat)
						    (env-lookup env sexp))))
			    (cons (cons (sid-id pat) sexp) bindings)))
d310 1
a310 1
		       (make-sid (+ color index) binding (sid-name tmpl)))))))
d327 2
a328 2
	(cond ((match-pattern pat sexp env) =>
	       (lambda (bindings) (expand-template pat tmpl bindings)))
d331 34
a364 36
(define (compile-syntax sexp env lstore gstore color k)
  (define (fail) (error "Invalid transformer: " sexp))
  (define (do-builtin))
  (cond
    ((sid? sexp)
     (let ((val (lookup-binding (lookup-sid sexp env) lstore gstore)))
       (if val
	   (k val lstore color)
	   (error "Premature use of letrec-syntax binding: " sexp))))
    ((not (and (spair? sexp) (slist? sexp) (sid? (car sexp))))
     (fail))
    (else
      (let ((val (lookup-binding (lookup-sid (car sexp) env) lstore gstore)))
	(cond
	 ((not val)
	  (error "Premature use of letrec-syntax binding: " sexp))
	 ((variable? val) (fail))
	 ((transformer? val)
	  (apply-transformer val sexp env color
	    (lambda (sexp color)
	      (compile-syntax sexp env lstore gstore color k))))
	 (else
	  (let ((builtin (builtin-name val)))
	    (case (builtin-name val)
	      ((syntax-rules) (k (cons env (cdr sexp)) lstore color))
	      ((let-syntax letrec-syntax)
	       (or (= 3 (length sexp)) (fail))
	       (let ((rec? (eq? builtin 'letrec-syntax))
		     (bindings (cadr sexp))
		     (body (cddr sexp)))
		 (compile-syntax-bindings bindings rec? env lstore gstore color
		   (lambda (env lstore color)
		     (compile-syntax body env lstore gstore color k)))))
	      (else (fail))))))))))

(define (compile-syntax-bindings bindings rec? env lstore gstore color k)
d366 1
a366 3
  (for-each (lambda (binding) (or (and (slist? binding) (= 2 (length binding)))
				  (error "Malformed binding: " binding)))
	    bindings)
d371 5
a375 3
	  (if (not (null? sids))
	      (let ((id (sid-id (car sids))))
		(loop (cdr sids) (env-extend ienv id icolor) (+ icolor 1)))
d377 1
a377 1
			 (lstore lstore) (icolor icolor))
d379 5
a383 5
		    (let ((lstore (extend-lstore lstore color (reverse vals))))
		      (k ienv lstore icolor))
		    (compile-syntax (car sexps) ienv lstore gstore icolor
		      (lambda (val lstore icolor)
			(loop (cdr sexps) (cons val vals) lstore icolor)))))))
d385 1
a385 1
		   (lstore lstore) (color color))
d387 3
a389 3
	      (k ienv lstore color)
	      (compile-syntax (car sexps) env lstore gstore color
		(lambda (val lstore color)
d393 1
a393 1
			  lstore (+ color 1))))))))))
d395 1
a395 1
(define (expand-expr sexp env lstore gstore color)
d402 1
a402 1
	   (if (< len 2) (fail) (expand-lambda tail env lstore gstore color)))
d411 5
a415 1
	  ((begin) (cons 'begin (map expand-here tail)))
d419 4
a422 4
	     (compile-syntax-bindings (car tail) rec? env lstore gstore color
	      (lambda (env lstore color)
		(expand-body (cdr tail) env lstore gstore color)))))
	  ((define define-syntax top-let-syntax top-letrec-syntax syntax-rules)
d426 4
a429 4
	   (let ((val (lookup-binding (lookup-sid sexp env) lstore gstore)))
	     (if (syntax? val)
		 (error "Use of keyword as variable: " sexp)
		 val)))
d438 1
a438 2
		 (let* ((binding (lookup-sid head env))
			(val (lookup-binding binding lstore gstore)))
d443 1
a443 1
		     (apply-transformer sexp val env color
d445 1
a445 1
			 (expand-expr sexp env lstore gstore color))))))))))))
d459 1
a459 1
(define (expand-lambda tail env lstore gstore color)
d462 4
a465 2
  (check-ids (car tail))
  (let loop ((env env) (color color) (formals (car tail)) (output-formals '()))
d467 1
a467 3
	(list 'lambda
	      (reverse output-formals)
	      (expand-body (cdr tail) env store color))
d469 2
a470 2
	       (var (make-var color (sid-name formal)))
	       (env (env-extend env formal color))
d473 3
a475 4
	      (loop env color (cdr formals) (cons output-id output-formals))
	      (list 'lambda
		    (revappend output-formals output-id)
		    (expand-body (cdr tail) env store color)))))))
d478 65
a542 12
  ;; FIXME: handle internal definitions
  (cons 'begin (map (lambda (sexp) (expand-expr sexp env store color))
		    sexps)))

(define builtins-gstore
  (do ((builtins '(lambda quote set! if begin define
			  let-syntax letrec-syntax define-syntax syntax-rules
			  top-let-syntax top-letrec-syntax)
		 (cdr builtins))
       (gstore '()
	       (substitute-in-gstore gstore (car builtins) (car builtins))))
      ((null? builtins) gstore)))
d545 1
a545 1
  (expand-top-level (syms->sids sexp) builtins-store 0
a546 1

@


1.4
log
@About to abandon the idea of saving the letrec store with transformers
in top-level bindings.  I will go back to simply carrying over the
letrec store across top-level expansions.  The disadvantage of this is
in situations like this:

  (define-syntax f (letrec-syntax ((g quote)) (syntax-rules ((_) (g x)))))
  (define f #f)

After f is redefined, the transformer can be garbage-collected, but
the letrec frame for g hangs around forever.  Oh well.
@
text
@d29 1
a29 1
;; transformer: (lstore lenv rule ...)
d31 2
a32 2
;; gstore: ((symloc . syntax) ...)
;; lstore: ((numloc . #(syntax ...)) ...)
d38 4
a41 5
;; (expand-top-level sexp gstore color k) => (k output-sexp gstore color)
;; (apply-transformer trans sexp env lstore gstore color k)
;;   => (k sexp lstore color)
;; (compile-syntax sexp top? env lstore gstore color k)
;;   => (k syntax lstore color)
a109 5
;; Allow both of these at top level:
;; (splicing-let-syntax ((keyword transformer) ...) expr-or-def ...)
;; (splicing-let ((var init) ...) expr-or-def ...)
;; splicing-letrec-syntax, splicing-letrec

d135 1
a135 1
(define (builtin? syntax) (symbol? (car syntax)))
a139 3
(define (transformer-lstore transformer) (car transformer))
(define (transformer-rules transformer) (cdr transformer))

d146 9
a155 8
  ;; top-level variables must be renamed if they conflict with the
  ;; primitives we use in the output.
  (define (maybe-rename sym)
    (define str (symbol->string sym))
    (define (rename) (string->symbol (string-append "_" str "_")))
    (case sym
      ((lambda quote set! if begin define letrec) (rename))
      (else (case (string-ref str 0) ((#\_) (rename)) (else sym)))))
d161 1
a161 1
		    '(undefined)
d179 4
a182 2
  (define (add-it gstore)
    (if (syntax? val) (acons symloc val gstore) gstore))
d184 1
a184 1
      (add-it gstore)
d188 1
a188 1
	      (add-it (cdr gstore))
d191 2
a192 24
(define (add-lstores lstore1 lstore2)
  (if (null? lstore2)
      lstore1
      (let* ((frame (car lstore2))
	     (firstloc (car frame)))
	(if (assv firstloc lstore1)
	    (add-lstores lstore1 (cdr lstore2))
	    (add-lstores (cons frame lstore1) (cdr lstore2))))))

;; Assuming lstore1 consists of some frames consed onto lstore2, returns a
;; list of just those frames.
(define (subtract-lstores lstore1 lstore2)
  (if (null? lstore2)
      lstore1
      (let ((stoploc (caar lstore2)))
	(let loop ((lstore1 lstore1) (diff '()))
	  (let* ((frame (car lstore1))
		 (firstloc (car frame)))
	    (if (= firstloc stop)
		diff
		(loop (cdr lstore1) (cons frame diff))))))))

(define (make-var numloc sid)
  (let ((str (symbol->string (sid-name sid))))
d195 4
a198 4
(define (expand-top-level sexp gstore color k)
  (let with-locals
      ((sexp sexp) (lenv '()) (lstore '()) (gstore gstore) (color color) (k k))
    (define (do-expr) (k (expand-expr sexp env gstore color) gstore color))
d200 1
a200 1
      (let loop ((sexps sexps) (output '()) (gstore gstore) (color color))
d203 5
a207 4
	      (k output gstore color))
	    (with-locals (car sexps) lenv lstore gstore color
	      (lambda (output1 gstore color)
		(loop (cdr sexps) (cons output1 output) gstore color))))))
d210 1
a210 1
	((begin) (do-sequence (cdr sexp) env gstore color))
d216 1
a216 1
	   (if (eq? val 'define)
d220 5
a224 5
		 (k (list 'define var init) gstore color))
	       (compile-syntax (caddr sexp) #t env lstore gstore color
	         (lambda (syntax lstore color)
		   (let ((gstore (substitute-in-gstore gstore symloc syntax)))
		     (k '(begin) gstore color)))))))
d228 1
a228 1
	 (let ((rec? (eq? val 'top-letrec-syntax)))
d243 5
a247 4
			  (apply-transformer val sexp env lstore color
			    (lambda (sexp lstore color)
			      (with-locals sexp env lstore gstore color k))))
			 (else (do-builtin (builtin-name val)))))))))))
d339 1
a339 1
(define (compile-syntax sexp top? env lstore gstore color k)
d341 1
d344 4
a347 11
     (let ((val (lookup-binding (lookup-id sexp env) lstore gstore)))
       (cond ((variable? val) (fail))
	     ((builtin? val)
	      (if (eq? 'undefined (builtin-name val))
		  (error "Premature use of letrec-syntax binding: " sexp)
		  (k val lstore color))))
       (case val
	 ((undefined)
	  (error "Premature use of letrec-syntax binding: " sexp))
	 ((#f) (fail))
	 (else (k val store color)))))
d351 13
a363 6
      (let ((val (store-lookup store (env-lookup env (car sexp)))))
	(if (trans? val)
	    (expand-macro-use sexp val env color
	      (lambda (sexp color) (compile-trans sexp env store color k)))
	    (case val
	      ((syntax-rules) (k (cons (cdr sexp) env) store color))
d366 12
a377 11
	       (let ((rec? (eq? val 'letrec-syntax)))
		 (compile-trans-bindings (cadr sexp) rec? env store color
		   (lambda (env store color)
		     (compile-trans (caddr sexp) env store color k)))))
	      ((undefined)
	       (error "Premature use of letrec-syntax binding: " sexp))
	      (else (fail))))))))

(define (compile-trans-bindings bindings rec? env store color k)
  (for-each (lambda (sexp) (or (and (slist? sexp) (= 2 (length sexp)))
			       (error "Malformed binding: " sexp)))
d379 25
a403 28
  (let ((sids (map car bindings)) (trans-sexps (map cadr bindings)))
    (check-ids sids)
    (let loop ((sids sids) (ienv env) (icolor color))
      (if (not (null? sids))
	  (let ((id (sid-id (car sids))))
	    (loop (cdr sids) (env-extend ienv id icolor) (+ icolor 1)))
	  (let* ((last-loc (- icolor 1))
		 (trans-env (if rec? ienv env))
		 (istore (if rec?
			     (let loop ((istore store) (loc color))
			       (if (<= loc last-loc)
				   (loop (store-extend istore loc 'undefined)
					 (+ loc 1))
				   istore))
			     store)))
	    (let loop ((trans-sexps trans-sexps) (transes '())
		       (istore istore) (icolor icolor))
	      (if (not (null? trans-sexps))
		  (compile-trans (car trans-sexps) trans-env istore icolor
		    (lambda (trans istore icolor)
		      (loop (cdr trans-sexps) (cons trans transes)
			    istore icolor)))
		  (let loop ((transes transes) (istore istore) (loc last-loc))
		    (if (null? transes)
			(k ienv istore icolor)
			(loop (cdr transes)
			      (store-extend istore loc (car transes))
			      (- loc 1)))))))))))
d405 1
a405 1
(define (expand-expr sexp env store color)
d407 24
d432 2
a433 3
	   (let* ((loc (env-lookup env sexp))
		  (val (store-lookup store loc)))
	     (if val
d435 1
a435 1
		 (sid->output-id sexp loc))))
d442 11
a452 39
	     (let ((val (and (sid? head)
			     (store-lookup store (env-lookup env head)))))
	       (cond ((trans? val)
		      (expand-macro-use sexp val env color
					(lambda (sexp color)
					  (expand-expr sexp env store color))))
		     ((symbol? val)
		      (case val
			((begin) (cons 'begin (map expand-here tail)))
			((set!)
			 (or (and (= 2 (length tail)) (sid? (car tail)))
			     (error "Malformed set!: " sexp))
			 (cons 'set! (map expand-here tail)))
			((if)
			 (or (<= 2 (length tail) 3)
			     (error "Malformed if: " sexp))
			 (cons 'if (map expand-here tail)))
			((quote)
			 (or (= 1 (length tail))
			     (error "Malformed quote: " sexp))
			 (list 'quote (sids->syms (car tail))))
			((lambda)
			 (or (>= (length tail) 2)
			     (error "Malformed lambda: " sexp))
			 (expand-lambda tail env store color))
			((let-syntax letrec-syntax)
			 (or (>= (length tail) 2)
			     (error "Malformed macro block: " sexp))
			 (let ((rec? (eq? val 'letrec-syntax)))
			   (compile-trans-bindings
			    (car tail) rec? env store color
			    (lambda (env store color)
			      (expand-body (cdr tail) env store color)))))
			((define define-syntax top-let-syntax top-letrec-syntax
			      syntax-rules)
			 (error "Special form invalid as an expression: "
				sexp))
			(else (error "Unknown builtin [can't happen]."))))
		     (else (map expand-here sexp)))))))))
d454 1
a454 1
(define (check-ids sids)
d466 3
a468 3
(define (expand-lambda tail env store color)
  (define (revappend l tail)
    (if (null? l) tail (revappend (cdr l) (cons (car l) tail))))
d476 1
a476 1
	       (var (make-var color formal))
@


1.3
log
@Added support for macro uses as transformers.

Store-extend now removes the old value, for top-level (non-numeric) locations.
@
text
@d17 28
a44 1
;; Simple color version:
d46 2
d57 3
a59 2
;; rule: (pat . tmpl)
;; pat: (literal . location)
d61 1
a61 1
;;    | (variable . #f)
d66 1
a66 1
;; tmpl: (literal symbol number . location)
d68 2
a69 2
;;    | (variable . number)
;;    | (seq (number ...) templ)
d71 3
a73 1
;;    | (vector . templ)
d118 1
a118 1
(define (spair? s) (and (pair? s) (not (sid? s))))
d121 4
a124 8
(define trans? pair?)

(define sid-sym car)
(define sid-id cadr)
(define sid-loc cddr)

(define (new-id sid id env)
  (cons (sid-sym sid) (cons id (env-lookup env sid))))
d127 1
a127 1
  (cond ((symbol? sexp) `(,sexp ,sexp . ,sexp))
d133 1
a133 1
  (cond ((sid? sexp) (sid-sym sexp))
d138 11
d151 1
a151 1
(define (env-lookup env sid)
d153 1
a153 1
	(else (sid-loc sid))))
d155 74
a228 36
(define (env-extend env sid location)
  (acons (sid-id sid) location env))

(define (store-lookup store location)
  (cond ((assv location store) => cdr)
	(else #f)))

(define (store-extend store location val)
  (if (number? location)
      (acons location val store)
      ;; For top-level storage, we go to the trouble of removing the old val.
      (let ((p (assv location store)))
	(if (not p)
	    (if (not val) store (acons location val store))
	    (let loop ((store store))
	      (if (eqv? (caar store) location)
		  (if (not val) (cdr store) (acons location val (cdr store)))
		  (cons (car store) (loop (cdr store)))))))))

(define (sid->output-id sid location)
  (if (number? location)
      (string->symbol (string-append "_" (symbol->string (sid-sym sid)) "_"
				     (number->string location)))
      (let ((str (symbol->string location)))
	(if (or (memq location '(lambda quote set! if begin define letrec))
		(char=? #\_ (string-ref str 0)))
	    (string->symbol (string-append "_" str "_"))
	    location))))

(define (expand-top-level sexp store color k)
  (let with-env ((sexp sexp) (env '()) (store store) (color color) (k k))
    (define (do-expr)
      (let ((output (expand-expr sexp env store color)))
	(k output store color)))
    (define (do-sequence sexps env store color)
      (let loop ((sexps sexps) (output '()) (store store) (color color))
d231 48
a278 43
	      (k output store color))
	    (with-env (car sexps) env store color
	      (lambda (output1 store color)
		(loop (cdr sexps) (cons output1 output) store color))))))
    (cond
     ((not (spair? sexp)) (do-expr))
     ((not (slist? sexp)) (error "Improper list" sexp))
     ((not (sid? (car sexp))) (do-expr))
     (else
      (let ((val (store-lookup store (env-lookup env (car sexp)))))
	(if (trans? val)
	    (expand-macro-use sexp val env color
	      (lambda (sexp color) (with-env sexp env store color k)))
	    (case val
	      ((begin) (do-sequence (cdr sexp) env store color))
	      ((def define-syntax)
	       (or (and (= 3 (length sexp)) (sid? (cadr sexp)))
		   (error "Malformed definition" sexp))
	       (let ((location (env-lookup env (cadr sexp))))
		 (or (symbol? location)
		     (error "Attempt to redefine a local: " sexp))
		 (if (eq? val 'def)
		     (let* ((init (expand-expr (caddr sexp) env store color))
			    (output-id (sid->output-id (cadr sexp) location))
			    (output (list 'define output-id init))
			    (store (store-extend store location #f)))
		       (k output store color))
		     (compile-trans (caddr sexp) env store color
		       (lambda (trans store color)
			 (let ((store (store-extend store location trans)))
			   (k '(begin) store color)))))))
	      ((top-let-syntax top-letrec-syntax)
	       (or (pair? (cdr sexp))
		   (error "Missing bindings in macro block:" sexp))
	       (let ((rec? (eq? val 'top-letrec-syntax)))
		 (compile-trans-bindings (cadr sexp) rec? env store color
		   (lambda (env store color)
		     (do-sequence (cddr sexp) env store color)))))
	      (else (do-expr)))))))))

(define (expand-macro-use sexp trans env color k)
  (let ((pat-literals (map sid-id (caar trans))) (rules (cdar trans))
	(mac-env (cdr trans)))
d281 3
a283 3
    (define (ellipsis? x)          (and (sid? x)
					(eq? '... (env-lookup mac-env x))))
    (define (ellipsis-pair? x)     (and (spair? x) (ellipsis? (car x))))
d342 3
a344 3
		    (else
		     (let ((id (+ color -1 (length (memv id tmpl-literals)))))
		       (new-id tmpl id mac-env))))))
d365 1
a365 1
(define (compile-trans sexp env store color k)
d367 31
a397 25
  (cond ((sid? sexp)
	 (let ((val (store-lookup store (env-lookup env sexp))))
	   (case val
	     ((undefined)
	      (error "Premature use of letrec-syntax binding: " sexp))
	     ((#f) (fail))
	     (else (k val store color)))))
	((not (and (spair? sexp) (slist? sexp) (sid? (car sexp))))
	 (fail))
	(else
	 (let ((val (store-lookup store (env-lookup env (car sexp)))))
	   (if (trans? val)
	       (expand-macro-use sexp val env color
		 (lambda (sexp color) (compile-trans sexp env store color k)))
	       (case val
		 ((syntax-rules) (k (cons (cdr sexp) env) store color))
		 ((let-syntax letrec-syntax)
		  (or (= 3 (length sexp)) (fail))
		  (let ((rec? (eq? val 'letrec-syntax)))
		    (compile-trans-bindings (cadr sexp) rec? env store color
		      (lambda (env store color)
			(compile-trans (caddr sexp) env store color k)))))
		 ((undefined)
		  (error "Premature use of letrec-syntax binding: " sexp))
		 (else (fail))))))))
d407 2
a408 1
	  (loop (cdr sids) (env-extend ienv (car sids) icolor) (+ icolor 1))
d479 1
a479 1
			((def define-syntax top-let-syntax top-letrec-syntax
d483 1
a483 1
			(else (error "Unknown primitive [can't happen]."))))
d508 1
a508 1
	       (output-id (sid->output-id formal color))
d522 8
a529 7
(define primitives-store
  (do ((primitives '(lambda quote set! if begin def
			    let-syntax letrec-syntax define-syntax syntax-rules
			    top-let-syntax top-letrec-syntax)
		   (cdr primitives))
       (store '() (store-extend store (car primitives) (car primitives))))
      ((null? primitives) store)))
d532 1
a532 1
  (expand-top-level (syms->sids sexp) primitives-store 0
d537 1
a537 1
(define (primitives-menv) (cons primitives-store 0))
@


1.2
log
@Seems to be working.
@
text
@d110 2
d116 3
a122 3
(define (env-extend env sid location)
  (cons (cons (sid-id sid) location) env))

d124 10
a133 1
  (cons (cons location val) store))
d294 16
a309 12
	(else (let ((val (store-lookup store (env-lookup env (car sexp)))))
		(case val
		  ((syntax-rules) (k (cons (cdr sexp) env) store color))
		  ((let-syntax letrec-syntax)
		   (or (= 3 (length sexp)) (fail))
		   (let ((rec? (eq? val 'letrec-syntax)))
		     (compile-trans-bindings (cadr sexp) rec? env store color
		       (lambda (env store color)
			 (compile-trans (caddr sexp) env store color k)))))
		  ((undefined)
		   (error "Premature use of letrec-syntax binding: " sexp))
		  (else (fail)))))))
@


1.1
log
@Initial revision
@
text
@d232 2
a233 2
	    ((pair? sexp) (match (car pat) (car sexp)
				 (match (cdr pat) (cdr sexp) bindings)))
d302 1
a302 1
    (let loop1 ((sids sids) (ienv env) (istore store) (icolor color))
d304 12
a315 8
	  (loop1 (cdr sids)
		 (env-extend ienv (car sids) icolor)
		 (store-extend istore icolor 'undefined)
		 (+ icolor 1))
	  (let ((trans-env (if rec? ienv env))
		(last-loc (- icolor 1)))
	    (let loop2 ((trans-sexps trans-sexps) (transes '())
			(istore istore) (icolor icolor))
d319 3
a321 3
		      (loop2 (cdr trans-sexps) (cons trans transes)
			     istore icolor)))
		  (let loop3 ((transes transes) (istore istore) (loc last-loc))
d324 3
a326 3
			(loop3 (cdr transes)
			       (store-extend istore loc (car transes))
			       (- loc 1)))))))))))
d437 2
a438 2
      (set!-car menv store)
      (set!-cdr menv color)
@