source: project/crunch/crunch-expander.scm @ 7161

Last change on this file since 7161 was 7161, checked in by felix winkelmann, 12 years ago

updated to new alexpander

File size: 74.4 KB
Line 
1;; alexpander.scm: a macro expander for scheme.
2;; based on 1.65
3
4;; Copyright 2002-2004,2006,2007 Al Petrofsky <alexpander@petrofsky.org>
5
6;; LICENSING (3-clause BSD or GNU GPL 2 and up)
7
8;; Redistribution and use in source and binary forms, with or without
9;; modification, are permitted provided that the following conditions
10;; are met:
11;;
12;;   Redistributions of source code must retain the above copyright
13;;     notice, this list of conditions and the following disclaimer.
14;;
15;;   Redistributions in binary form must reproduce the above copyright
16;;     notice, this list of conditions and the following disclaimer in
17;;     the documentation and/or other materials provided with the
18;;     distribution.
19;;
20;;   Neither the name of the author nor the names of its contributors
21;;     may be used to endorse or promote products derived from this
22;;     software without specific prior written permission.
23;;
24;; THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS
25;; "AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT
26;; LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR
27;; A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT
28;; HOLDERS OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT,
29;; INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING,
30;; BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS
31;; OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED
32;; AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT
33;; LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY
34;; WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE
35;; POSSIBILITY OF SUCH DAMAGE.
36
37;; Alternatively, you may redistribute, use, or modify this software
38;; according to the terms of the GNU General Public License as
39;; published by the Free Software Foundation (fsf.org); either version
40;; 2, or (at your option) any later version.
41
42;; INTRODUCTION:
43
44;; This file implements a macro-expander for r5rs scheme (plus some
45;; interesting extensions).  There is no magic here to hook this into
46;; your native eval system: this is a simple data-in, data-out program
47;; that takes a macro-using program represented as scheme data and
48;; produces an equivalent macro-free program represented as scheme
49;; data.
50
51;; This is mostly intended as a demonstration.  Although it certainly
52;; could be useful for adding macros to a simple scheme system that
53;; lacks any macros, it may not be feasible to get it to interact
54;; properly with a low-level macro system or a module system.
55
56;; The expander is written in portable r5rs scheme, except for one use
57;; of the pretty-print procedure which you can easily comment out.
58
59;; To try it out, just load the file and execute (alexpander-repl).
60;; Skip to the "BASIC USAGE" section for more information.
61
62;; To find the latest version of this program, try here:
63;;    http://petrofsky.org/src/alexpander.scm
64;;
65;; To find older versions or the log messages between versions, try here:
66;;    http://petrofsky.org/src/RCS/alexpander.scm,v
67
68;; If you are wondering what "r5rs scheme" is, see:
69;;    Richard Kelsey, William Clinger, and Jonathan Rees, "Revised^5
70;;    report on the algorithmic language Scheme", Higher-Order and
71;;    Symbolic Computation, 11(1):7-105, 1998.  Available at:
72;;       PDF: http://www-swiss.ai.mit.edu/~jaffer/r5rs.pdf
73;;       LaTeX source: ftp://swiss.csail.mit.edu/pub/scheme-reports/r5rs.tar.gz
74
75;; EXTENSIONS:
76
77;; The expander supports all the features of the r5rs macro system,
78;; plus several extensions in the way syntaxes can be specified and
79;; used, which are best summarized in BNF:
80
81;; Modified r5rs productions:
82
83;;   <expression> ---> <variable> | <literal> | <procedure call>
84;;                   | <lambda expression> | <conditional> | <assignment>
85;;                   | <derived expression> | <macro use> | <macro block>
86;;                   | <keyword>
87;;
88;;   <syntax definition> ---> (define-syntax <keyword> <syntax or expression>)
89;;                          | (begin <syntax definition>*)
90;;                          | <macro use>
91;;
92;;   <syntax spec> ---> (<keyword> <syntax or expression>)
93;;
94;;   <macro use> ---> (<syntax> <datum>*)
95;;
96;;   <definition> ---> (define <variable> <expression>)
97;;                   | (define (<variable> <def formals>) <body>)
98;;                   | (define <expression>)
99;;                   | (begin <definition>*)
100;;                   | <macro use>
101;;                   | <syntax definition>
102;;
103;;   <command or definition> ---> <command> | <definition>
104;;                              | (begin <command or definition>*)
105;;                              | <top-level macro block>
106;;                              | <macro use>
107
108;; New productions:
109
110;;   <syntax or expression> ---> <syntax> | <expression>
111;;
112;;   <syntax> ---> <transformer spec>
113;;               | <keyword>
114;;               | <macro use>
115;;               | <syntax macro block>
116;;
117;;   <syntax macro block> ---> (<syntax-only block stuff> <syntax>)
118;;
119;;   <top-level macro block>
120;;       ---> (<syntax-only block stuff> <command or definition>)
121;;
122;;   <syntax-only block stuff>
123;;      ---> <let-or-letrec-syntax> (<syntax spec>*) <syntax definition>*
124;;
125;;   <let-or-letrec-syntax> ---> let-syntax | letrec-syntax
126
127
128;; These extensions all have the obvious meaning.
129
130;; Okay, I'll elaborate on that a little bit.  Consider the intializer
131;; position of a syntax definition and the head position of a
132;; list-format expression:
133
134;;   (define-syntax <keyword> <xxx>)
135
136;;   (<yyy> <foo>*)
137
138;; In r5rs, <xxx> must be a transformer.  <Yyy> may be an expression,
139;; in which case the enclosing expression is taken to be a procedure
140;; call and the <foo>s are the expressions for the operands, or <yyy>
141;; may be a keyword bound to a syntax (a builtin or transformer), in
142;; which case the <foo>s are processed according to that syntax.
143
144;; The core generalization in our system is that both <xxx> and <yyy>
145;; may be any type of expression or syntax.  The four forms of syntax
146;; allowed are: a transformer (as allowed in the <xxx> position in
147;; r5rs), a keyword (as allowed in the <yyy> position in r5rs), a
148;; macro use that expands into a syntax, and a macro block (let-syntax
149;; or letrec-syntax) whose body is a syntax.
150
151;; Some examples:
152;;
153;;  ;; a macro with a local macro
154;;  (let-syntax ((foo (let-syntax ((bar (syntax-rules () ((bar x) (- x)))))
155;;                      (syntax-rules () ((foo) (bar 2))))))
156;;    (foo))
157;;  => -2
158;;
159;;  ;; an anonymous let transformer, used directly in a macro call.
160;;  ((syntax-rules ()
161;;     ((let ((var init) ...) . body)
162;;      ((lambda (var ...) . body)
163;;       init ...)))
164;;   ((x 1) (y 2))
165;;   (+ x y))
166;;  => 3
167;;
168;;  ;; a keyword used to initialize a keyword
169;;  (let-syntax ((q quote)) (q x)) => x
170;;
171;;  ;; Binding a keyword to an expression (which could also be thought
172;;  ;; of as creating a macro that is called without arguments).
173;;  (let ((n 0))
174;;    (let-syntax ((x (set! n (+ n 1))))
175;;      (begin x x x n)))
176;;  => 3
177;;
178;;  (let-syntax ((x append)) ((x x))) => ()
179
180
181;; Internal syntax definitions.
182
183;; Internal syntax definitions are supported wherever they would make
184;; sense (see the BNF), and they have the letrec-syntax semantics you
185;; would expect.  It is legal for the initializer of an internal
186;; variable definition to use one of the internal syntax definitions
187;; in the same body:
188
189;; (let ()
190;;   (define x (y))
191;;   (define-syntax y (syntax-rules () ((y) 1)))
192;;   x)
193;; => 1
194
195;; It's also legal for internal syntax definitions to be mutually
196;; recursive transformers, but it is an error for the expansion of a
197;; syntax definition's initializer to require the result of another
198;; initializer:
199
200;; (let ()
201;;   (define-syntax m1 (syntax-rules () ((m1) #f) ((m1 . args) (m2 . args))))
202;;   (define-syntax m2 (syntax-rules () ((m2 arg . args) (m1 . args))))
203;;   (m1 foo bar baz))
204;; => #f
205
206;; (let ()
207;;   (define-syntax simple-transformer
208;;     (syntax-rules ()
209;;       ((simple-transformer pattern template)
210;;        (syntax-rules () (pattern template)))))
211;;   (define-syntax m (simple-transformer (m x) (- x)))
212;;   (m 1))
213;; => error ("Premature use of keyword bound by an internal define-syntax")
214
215;; (let ()
216;;   (define-syntax simple-transformer
217;;     (syntax-rules ()
218;;       ((simple-transformer pattern template)
219;;        (syntax-rules () (pattern template)))))
220;;   (let ()
221;;     (define-syntax m (simple-transformer (m x) (- x)))
222;;     (m 1)))
223;; => -1
224
225
226;; Top-level macro blocks.
227
228;; At the top level, if a macro block (i.e., a let-syntax or
229;; letrec-syntax form) has only one body element, or if all of the
230;; body elements before the last one are internal syntax definitions,
231;; then the last body element need not be an expression (as would be
232;; required in r5rs).  Instead, it may be anything allowed at top
233;; level: an expression, a definition, a begin sequence of top-level
234;; forms, or another macro block containing a top-level form.
235
236;;   (let-syntax ((- quote))
237;;     (define x (- 1)))
238;;
239;;   (list x (- 1))
240;;   => (1 -1)
241
242;; Note that, unlike the similar extension in Chez scheme 6.0, this is
243;; still r5rs-compatible, because we only treat definitions within the
244;; last body element as top-level definitions (and r5rs does not allow
245;; internal definitions within a body's last element, even if it is a
246;; begin form):
247
248;;   (define x 1)
249;;   (define (f) x)
250;;   (let-syntax ()
251;;     (define x 2)
252;;     (f))
253;;   => 1, in r5rs and alexpander, but 2 in Chez scheme
254
255;;   (define x 1)
256;;   (define (f) x)
257;;   (let-syntax ()
258;;     (begin
259;;       (define x 2)
260;;       (f)))
261;;   => 2, in alexpander and in Chez scheme, but an error in r5rs.
262
263
264;; Syntax-rules ellipsis
265
266;; Per SRFI-46, syntax-rules transformers can specify the
267;; identifier to be used as the ellipsis (such a specification is
268;; treated as a hygienic binding), and a list pattern may contain
269;; subpatterns after an ellipsis as well as before it:
270
271;;   <transformer spec> ---> (syntax-rules (<identifier>*) <syntax rule>*)
272;;              | (syntax-rules <ellipsis> (<identifier>*) <syntax rule>*)
273;;   
274;;   <syntax rule> ---> (<pattern> <template>)
275;;   
276;;   <pattern> ---> <pattern identifier>
277;;                | (<pattern>*)
278;;                | (<pattern>+ . <pattern>)
279;;                | (<pattern>* <pattern> <ellipsis> <pattern>*)
280;;                | #(<pattern>*)
281;;                | #(<pattern>* <pattern> <ellipsis> <pattern>*)
282;;                | <pattern datum>
283;;   
284;;   <pattern identifier> ---> <identifier>
285;;   
286;;   <ellipsis> ---> <identifier>
287
288
289;; Expressions among internal definitions.
290
291;; A definition of the form (define <expression>) causes the
292;; expression to be evaluated at the conclusion of any enclosing set
293;; of internal definitons.  That is, at top level, (define
294;; <expression>) is equivalent to just plain <expression>.  As for
295;; internal definitions, the following are equivalent:
296
297;; (let ()
298;;   (define v1 <init1>)
299;;   (define <expr1>)
300;;   (define <expr2>)
301;;   (define v2 <init2>)
302;;   (define <expr3>)
303;;   (begin
304;;     <expr4>
305;;     <expr5>))
306;;
307;; (let ()
308;;   (define v1 <init1>)
309;;   (define v2 <init2>)
310;;   (begin
311;;     <expr1>
312;;     <expr2>
313;;     <expr3>
314;;     <expr4>
315;;     <expr5>))
316
317;; (Yes, it would probably be better to have a separate builtin for
318;; this rather than to overload define.)
319
320;; This feature makes it possible to implement a define-values that
321;; works properly both at top-level and among internal definitions:
322
323;; (define define-values-temp #f)
324;;
325;; (define-syntax define-values
326;;   (syntax-rules ()
327;;     ((define-values (var ...) init)
328;;      (begin
329;;        (define define-values-temp (call-with-values (lambda () init) list))
330;;        (define var #f) ...
331;;        (define
332;;          (set!-values (var ...) (apply values define-values-temp)))))))
333
334;; (Set!-values is implementable using just r5rs features and is left
335;; as an exercise.)
336
337;; When used among internal definitions, the definition of
338;; define-values-temp in define-values's output creates a local
339;; binding, and thus the top-level binding of define-values-temp is
340;; irrelevant.  When used at top-level, the definition of
341;; define-values-temp in the output does not create a binding.
342;; Instead, it mutates the top-level binding of define-values-temp.
343;; Thus, all top-level uses of define-values share a single temp
344;; variable.  For internal-definition-level uses of define-values, a
345;; single shared temp would not be sufficient, but things work out
346;; okay because hygienic renaming causes each such use to create a
347;; distinct temp variable.
348
349;; The version below works the same way, but hides from the top-level
350;; environment the temp that is shared by top-level uses of
351;; define-values.  For a bit of tutorial and rationale about this
352;; technique, see usenet article
353;; <8765tos2y9.fsf@radish.petrofsky.org>:
354
355;; (define-syntax define-values
356;;   (let-syntax ((temp (syntax-rules ())))
357;;     (syntax-rules ()
358;;       ((define-values (var ...) init)
359;;        (begin
360;;          (define temp (call-with-values (lambda () init) list))
361;;          (define var #f) ...
362;;          (define (set!-values (var ...) (apply values temp))))))))
363
364
365;; Improved nested unquote-splicing. 
366
367;; Quasiquote is extended to make commas and comma-ats distributive
368;; over a nested comma-at, as in Common Lisp's backquote.  See my
369;; 2004-09-03 usenet article <87pt53f9f2.fsf@radish.petrofsky.org>,
370;; Bawden's 1999 quasiquotation paper, and Appendix C of Steele's
371;; "Common Lisp the Language 2nd edition".
372
373;;   <splicing unquotation 1> ---> ,@<qq template 0>
374;;                               | (unquote-splicing <qq template 0>)
375;;
376;;   <splicing unquotation D> ---> ,@<qq template D-1>
377;;                               | ,<splicing unquotaion D-1>
378;;                               | ,@<splicing unquotaion D-1>
379;;                               | (unquote-splicing <qq template D-1>)
380;;                               | (unquote <splicing unquotaion D-1>)
381;;                               | (unquote-splicing <splicing unquotaion D-1>)
382
383;; When a comma at-sign and the expression that follows it are being
384;; replaced by the elements of the list that resulted from the
385;; expression's evaluation, any sequence of commas and comma at-signs
386;; that immediately preceded the comma at-sign is also removed and is
387;; added to the front of each of the replacements.
388
389;;  (let ((x '(a b c))) ``(,,x ,@,x ,,@x ,@,@x))
390;;  => `(,(a b c) ,@(a b c) ,a ,b ,c ,@a ,@b ,@c)
391;;
392;;  ``(,,@'() ,@,@(list))
393;;  => `()
394;;
395;;  `````(a ,(b c ,@,,@,@(list 'a 'b 'c)))
396;;  => ````(a ,(b c ,@,,@a ,@,,@b ,@,,@c))
397;; 
398;; (let ((vars '(x y)))
399;;   (eval `(let ((x '(1 2)) (y '(3 4)))
400;;            `(foo ,@,@vars))
401;;         (null-environment 5)))
402;; => (foo 1 2 3 4)
403
404
405;; BASIC USAGE:
406
407;; There are four supported ways to use this:
408
409;;   1. (alexpander-repl)
410;;      This starts a read-expand-print-loop.  Type in a program and
411;;      see its expansion as you go.
412;;
413;;   2. (expand-program list-of-the-top-level-forms-of-a-program)
414;;      Returns a list of the top-level forms of an equivalent
415;;      macro-free program.
416;;
417;;   3. (expand-top-level-forms! forms mstore)
418;;      Returns some macro-expanded forms and mutates mstore.
419;;      To use this, first create an initial mutable store with
420;;      (null-mstore).  Then you can pass a program in piecemeal, with
421;;      the effects of top-level define-syntaxes saved in mstore
422;;      between calls to expand-top-level-forms!.
423;;
424;;   4. (expand-top-level-forms forms store loc-n k)
425;;      The purely-functional interface.
426;;      This returns by making a tail call to k:
427;;      (k expanded-forms new-store new-loc-n)
428;;      Use null-store and null-loc-n for store and loc-n arguments
429;;      when calling expand-top-level-forms with the first forms in a
430;;      program.
431;;
432;; For options 3 and 4, you need to prepend null-output to the
433;; resulting program.  Null-output contains some definitions like
434;; (define _eqv?_7 eqv?), which create alternate names for some of the
435;; builtin procedures.  These names are used by the standard case and
436;; quasiquote macros so that they can keep working even if you
437;; redefine one of the standard procedures.
438
439;; The output programs use a small subset of the r5rs syntax, namely:
440;; BEGIN, DEFINE, DELAY, IF, LAMBDA, LETREC, QUOTE, AND SET!.
441;; Furthermore, begin is only used for expressions; lambdas and
442;; letrecs always have a single body expression and no internal
443;; definitions; and defines are always of the simple (define
444;; <variable> <expression>) form.  If you want even simpler output,
445;; with no letrecs, see expand-program-to-simple.
446
447;; Any uses or definitions in the original program of a top-level
448;; variable whose name begins with "_", or whose name is one of the
449;; eight primitives in the output language, will be renamed.  This
450;; will only cause a problem if the program is trying to use some
451;; nonstandard library variable that starts with "_".  That is, even
452;; though some of a program's top-level variable names may get
453;; changed, any r5rs-conformant program will still be translated to an
454;; equivalent macro-free r5rs program.
455
456
457;; INTERNALS
458
459;; [NOTE: this documentation is certainly not complete, and it kind of
460;; dissolves after a few pages from verbose paragraphs into cryptic
461;; sentence fragments.  Nonetheless, it might be enough to help
462;; someone figure out the code.]
463
464;; ENVIRONMENTS AND STORES
465
466;; The two principal data structures are the environment and the
467;; store.
468
469;; These work similarly to the runtime environment and store described
470;; in r5rs: in both that system and in ours, to determine the meaning
471;; of an identifier, we lookup which location the environment
472;; associates with the identifier, and then check what value the store
473;; associates with that location.
474
475;; In the runtime system, the identifiers mapped by the environment
476;; are all variables, and the values in the store are the scheme
477;; values the variables currently hold.  Environments may be locally
478;; extended by LAMBDA to map some identifiers to new locations that
479;; initially hold the values passed to the procedure.  Environments
480;; may also be locally extended by internal DEFINE (a.k.a LETREC) to
481;; map some identifiers to new locations that are empty and illegal to
482;; access or SET! until the evaluation of all the initializers has
483;; completed (at which time the results are stored into the
484;; locations).  The store is modified when a SET! or top-level DEFINE
485;; is evaluated, or when a set of internal DEFINE initializers'
486;; evaluations completes, but environments are immutable.  The static
487;; top-level environment maps every variable name to some location,
488;; although most of these locations are illegal to access until the
489;; evaluation of the initializer of the first top-level DEFINE of the
490;; variable has completed.  (The exceptions are the locations to which
491;; the standard procedure names are bound: these locations may be
492;; accessed at any time, but they may not be SET! until after the
493;; first top-level DEFINE of the procedure name.)
494
495;; (R5rs actually does not completely specify how the top-level
496;; environment works, and allows one to consider the top-level
497;; environment to be dynamically extended, but the model I just
498;; described fits within the r5rs parameters and plays well with our
499;; macro system.  To recap: the difference between SET! and top-level
500;; DEFINE is not that top-level DEFINE is able to create a new
501;; binding, rather, the difference is that top-level DEFINE is allowed
502;; to store into any location and SET! is not always allowed to store
503;; into some locations.)
504
505;; In our syntactic system, a value in the store may be either a
506;; syntax (a builtin or a macro transformer), a variable name, or the
507;; expanded code for an expression.  When we encounter a use of an
508;; identifier, we go through the environment and the store to fetch
509;; its value.  If the value is a variable name, we emit that variable
510;; name.  If the value is some code, we emit that code.  If the value
511;; is a syntax, we proceed according to the rules of that syntax.  As
512;; in the runtime system, environments are immutable and the static
513;; top-level environment is infinite.  Environments may be locally
514;; extended by LAMBDA or internal DEFINE to map some identifiers to
515;; new locations that hold variable names.  Environments may also be
516;; extended by LET-SYNTAX to map some identifiers to new locations
517;; that initially hold the syntaxes and/or code resulting from the
518;; expansion of the initializers.  Lastly, environments may be
519;; extended by internal DEFINE-SYNTAX (a.k.a LETREC-SYNTAX) to map
520;; some identifiers to new locations that are empty and illegal to
521;; access until the expansion of their initializers has completed (at
522;; which time the resulting syntaxes and/or code are stored into the
523;; locations).  The store is modified by top-level DEFINE and
524;; DEFINE-SYNTAX, and when a set of internal DEFINE-SYNTAX
525;; initializers' expansions completes.  The store is not altered by a
526;; SET!, because a SET! does not change the fact that the identifier
527;; is a variable: from our perspective a SET! of a variable is simply
528;; a use of the variable.  A top-level DEFINE only alters the store if
529;; an identifier whose location previously held a syntax is now being
530;; defined as a variable.
531
532;; The static top-level environment maps every name to some location.
533;; Initially, the locations to which the environment maps the names of
534;; the ten builtins (BEGIN DEFINE DEFINE-SYNTAX IF LAMBDA QUOTE SET!
535;; DELAY LET-SYNTAX SYNTAX-RULES) hold as their values those builtin
536;; syntaxes.  All other names are bound to locations that hold the
537;; corresponding top-level variable name.
538
539;; I said the top-level environment contains a binding for "every
540;; name" rather than for "every identifier", because the new
541;; identifiers created by a syntax-rules macro expansion are given
542;; numbers rather than names, and the top-level environment has no
543;; bindings for these.  If such an identifier is used in an
544;; environment that does not bind it to any location, then the
545;; location to which the template literal was bound in the environment
546;; of the macro is used instead.  (To be prepared for such a
547;; contingency, this location is stored along with the numeric id in
548;; the "renamed-sid" (see below) that a macro expansion inserts into
549;; the code.)
550
551;; REPRESENTATION OF ENVIRONMENTS AND STORES
552
553;; An environment is represented by an alist mapping ids to local
554;; (non-top-level) locations.  All environments are derived from the
555;; top-level environment, so any symbolic id not in the alist is
556;; implicitly mapped to the corresponding top-level location.
557
558;; An id (identifier) is what we bind to a location in an environment.
559;; Original ids are the symbols directly occuring in the source code.
560;; Renamed ids are created by macro expansions and are represented by
561;; integers.
562
563;; id: original-id | renamed-id
564;; original-id: symbol
565;; renamed-id: integer
566
567;; The static top-level environment maps every symbol to a location.
568;; For simplicity, each of those locations is represented by the
569;; symbol that is bound to it.  All other locations (those created by
570;; lambda, let-syntax, and internal definitions) are represented by
571;; integers.
572
573;; env: ((id . local-location) ...)
574;; store: ((location . val) ...)
575;; location: toplevel-location | local-location  ;; a.k.a. symloc and intloc.
576;; toplevel-location: symbol
577;; local-location: integer
578;; val: variable | syntax | code
579;; variable: #(toplevel-location) | #(symbol local-location)
580;; code: (output) ; output is the expanded code for an expression.
581;; syntax: builtin | transformer
582;; builtin: symbol
583;; transformer: (synrules env)
584;; synrules: the unaltered sexp of the syntax-rules form.
585
586;; REPRESENTATION OF THE CODE UNDERGOING EXPANSION (SEXPS).
587
588;; Any variable named SEXP in the expander code holds a representation
589;; of some code undergoing expansion.  It mostly looks like the
590;; ordinary representation of scheme code, but it may contain some
591;; identifiers that are encoded as two- or three-element vectors
592;; called renamed-sids.  Any actual vector in the code will be
593;; represented as a one-element vector whose element is a list of the
594;; actual elements, i.e., each vector #(elt ...) is mapped to #((elt
595;; ...)), so that we can distinguish these vectors from renamed-sids.
596
597;; In contrast, a variable named OUTPUT is a bit of almost-finished
598;; code.  In this format, symbols and vectors within a quote
599;; expression are represented normally.  All variable names are
600;; represented as vectors of the form #(symbol) or #(symbol integer).
601;; These vectors are converted to suitable, non-clashing symbols by
602;; the symbolize function, which is the final step of expansion.
603
604;; A sid is the representation of an id within a sexp.
605;; sid: original-id | renamed-sid
606
607;; A renamed-sid includes the id's original name, which we will need
608;; if the id gets used in a QUOTE expression.  The renamed-sid also
609;; includes the location of the local binding (if any) of the template
610;; literal that created the id: this is the location to use if the id
611;; gets used freely (i.e., in an environment with no binding for it).
612;; renamed-sid: #(original-id renamed-id)
613;;            | #(original-id renamed-id local-location)
614
615;; Procedures that take a SEXP argument usually also take an ID-N
616;; argument, which is the next higher number after the largest
617;; renamed-id that occurs in the SEXP argument.  (This is to enable
618;; adding new ids without conflict.)
619;;
620;; Similarly, a STORE argument is usually accompanied by a LOC-N
621;; argument, which is the next higher number after the largest
622;; local-location in the STORE argument.
623
624;; SUMMARY OF MAJOR FUNCTIONS:
625
626;; (lookup-sid sid env) => location
627;; (lookup-location location store) => val | #f  ;; #f means letrec violation.
628;; (lookup2 sid env store) => val ;; lookup-sid + lookup-location + fail if #f.
629;; (extend-env env id location) => env
630;; (extend-store store intloc val) => store
631;; (substitute-in-store store loc val) => store
632;; (compile-syntax-rules synrules env) => transformer
633;; (apply-transformer trans sexp id-n env k) => (k sexp id-n)
634;; (expand-any sexp id-n env store loc-n lsd? ek sk dk bk)
635;;    => (ek output)
636;;     | (sk syntax sexp store loc-n)
637;;     | (dk builtin sexp id-n env store loc-n)
638;;     | (bk sexp id-n env store loc-n)
639;; (expand-expr sexp id-n env store loc-n) => output
640;; (expand-val sexp id-n env store loc-n k) => (k val store loc-n)
641;; (expand-top-level-sexps sexps store loc-n k)
642;;   => (k outputs store loc-n)
643;; (expand-body sexps id-n env store loc-n lsd? ek sk dk bk)
644;;    => same as expand-any
645;; (expand-syntax-bindings bindings id-n syntax-env ienv store loc-n k)
646;;   => (k store loc-n)
647
648
649(define (sid? sexp)          (or (symbol? sexp) (renamed-sid? sexp)))
650(define (renamed-sid? sexp)  (and (vector? sexp) (< 1 (vector-length sexp))))
651(define (svector? sexp)      (and (vector? sexp) (= 1 (vector-length sexp))))
652(define (svector->list sexp) (vector-ref sexp 0))
653(define (list->svector l) (vector l))
654
655(define (make-sid name renamed-id location)
656  (if (eq? name location)
657      (vector name renamed-id)
658      (vector name renamed-id location)))
659
660(define (sid-name sid) (if (symbol? sid) sid (vector-ref sid 0)))
661(define (sid-id sid)   (if (symbol? sid) sid (vector-ref sid 1)))
662(define (sid-location sid)
663  (if (symbol? sid) sid (vector-ref sid (if (= 2 (vector-length sid)) 0 2))))
664
665(define (list1? x) (and (pair? x) (null?  (cdr x))))
666(define (list2? x) (and (pair? x) (list1? (cdr x))))
667
668;; Map-vecs does a deep map of x, replacing any vector v with (f v).
669;; We assume that f never returns #f.
670;; If a subpart contains no vectors, we don't waste space copying it.
671;; (Yes, this is grossly premature optimization.)
672(define (map-vecs f x)
673  ;; mv2 returns #f if there are no vectors in x.
674  (define (mv2 x)
675    (if (vector? x)
676        (f x)
677        (and (pair? x)
678             (let ((a (car x)) (b (cdr x)))
679               (let ((a-mapped (mv2 a)))
680                 (if a-mapped
681                     (cons a-mapped (mv b))
682                     (let ((b-mapped (mv2 b)))
683                       (and b-mapped (cons a b-mapped)))))))))
684  (define (mv x) (or (mv2 x) x))
685  (mv x))
686
687(define (wrap-vec v) (list->svector (wrap-vecs (vector->list v))))
688(define (wrap-vecs input) (map-vecs wrap-vec input))
689(define (unwrap-vec v-sexp)
690  (if (= 1 (vector-length v-sexp))
691      (list->vector (unwrap-vecs (svector->list v-sexp)))
692      (vector-ref v-sexp 0)))
693(define (unwrap-vecs sexp) (map-vecs unwrap-vec sexp))
694
695;; The store maps locations to vals.
696;; vals are variables, syntaxes, or code.
697
698(define (make-code output) (list output))
699(define (make-builtin name) name)
700(define (make-transformer synrules env) (list synrules env))
701
702(define (var? val) (vector? val))
703(define (code? val) (list1? val))
704(define (code-output code) (car code))
705
706(define (syntax? val) (or (symbol? val) (list2? val)))
707
708(define (builtin? syntax) (symbol? syntax))
709(define (builtin-name builtin) builtin)
710
711(define (transformer? syntax) (not (builtin? syntax)))
712(define (transformer-synrules trans) (car trans))
713(define (transformer-env trans) (cadr trans))
714
715(define (acons key val alist) (cons (cons key val) alist))
716
717(define empty-env '())
718(define empty-store '())
719
720;; Lookup-sid looks up a sid in an environment.
721;; If there is no binding in the environment, then:
722;;   1. For an original-id, we return the like-named location, because
723;;      the static top-level environment maps every name to a location.
724;;   2. For a renamed id, we return the location to which the template
725;;      literal that created it was bound.
726(define (lookup-sid sid env)
727  (cond ((assv (sid-id sid) env) => cdr)
728        ;; This works for both cases 1 and 2 above.
729        (else (sid-location sid))))
730
731;; Lookup-location looks up a location in the store.
732;; If there is no value explictly listed in the store, then:
733;;   1. For a top-level (named) location, return a top-level variable.
734;;   2. For a local location, return #f.  This can only happen for a
735;;      location allocated by letrec-syntax or internal define-syntax
736;;      and used before it is initialized,
737;;      e.g. (letrec-syntax ((x x)) 1).
738(define (lookup-location location store)
739  (cond ((assv location store) => cdr)
740        ((symbol? location) (symloc->var location))
741        (else #f)))
742
743(define (lookup2 sid env store)
744  (or (lookup-location (lookup-sid sid env) store)
745      (syntax-error
746       "Premature use of keyword bound by letrec-syntax (or an internal define-syntax): "
747       sid)))
748
749(define (extend-env env id location) (acons id location env))
750(define (extend-store store loc val) (acons loc val store))
751
752;; Extend-store just adds to the front of the alist, whereas
753;; substitute-in-store actually bothers to remove the old entry, and
754;; to not add a new entry if it is just the default.
755;; Substitute-in-store is only used by top-level define and
756;; define-syntax.  Because nothing is ever mutated, we could just use
757;; extend-store all the time, but we are endeavoring to keep down the
758;; size of the store to make it more easily printed and examined.
759(define (substitute-in-store store loc val)
760  (let ((store (if (assv loc store)
761                   (let loop ((store store))
762                     (let ((p (car store)))
763                       (if (eqv? loc (car p))
764                           (cdr store)
765                           (cons p (loop (cdr store))))))
766                   store)))
767    (if (and (symbol? loc) (eq? val (symloc->var loc)))
768        store
769        (acons loc val store))))
770
771(define (make-var1 name/loc)
772  (vector name/loc))
773(define (make-var2 name loc)
774  (vector name loc))
775(define (var-name var)
776  (vector-ref var 0))
777(define (var-loc var)
778  (vector-ref var (- (vector-length var) 1)))
779
780(define (symloc->var sym)
781  (make-var1 sym))
782
783(define (intloc->var intloc sid)
784  (make-var2 (sid-name sid) intloc))
785
786(define (loc->var loc sid)
787  (if (symbol? loc)
788      (symloc->var loc)
789      (intloc->var loc sid)))
790
791(define (make-begin outputs)
792  (if (list1? outputs) (car outputs) (cons 'begin outputs)))
793
794(define (make-letrec bindings expr)
795  (if (null? bindings) expr (list 'letrec bindings expr)))
796
797(define (expand-lambda formals expr id-n env store loc-n)
798  ;; (a b . c) => (a b c)
799  (define (flatten-dotted x)
800    (if (pair? x) (cons (car x) (flatten-dotted (cdr x))) (list x)))
801  ;; (a b c) => (a b . c)
802  (define (dot-flattened x)
803    (if (null? (cdr x)) (car x) (cons (car x) (dot-flattened (cdr x)))))
804  (let* ((dotted? (not (list? formals)))
805         (flattened (if dotted? (flatten-dotted formals) formals)))
806    (define (check x)
807      (or (sid? x) (syntax-error "Non-identifier in lambda formals" x formals))
808      (if (member x (cdr (member x flattened)))
809          (syntax-error "Duplicate variable in lambda formals" x formals)))
810    (begin
811      (for-each check flattened)
812      (let loop ((formals flattened) (rvars '())
813                 (env env) (store store) (loc-n loc-n))
814        (if (not (null? formals))
815            (let* ((var (intloc->var loc-n (car formals)))
816                   (env (extend-env env (sid-id (car formals)) loc-n))
817                   (store (extend-store store loc-n var)))
818              (loop (cdr formals) (cons var rvars) env store (+ 1 loc-n)))
819            (let* ((vars (reverse rvars))
820                   (vars (if dotted? (dot-flattened vars) vars)))
821              (list vars (expand-expr expr id-n env store loc-n))))))))
822
823(define (check-syntax-bindings bindings)
824  (or (list? bindings) (syntax-error "Non-list syntax bindings list" bindings))
825  (for-each (lambda (b) (or (and (list2? b) (sid? (car b)))
826                            (syntax-error "Malformed syntax binding" b)))
827            bindings)
828  (do ((bs bindings (cdr bs)))
829      ((null? bs))
830    (let ((dup (assoc (caar bs) (cdr bs))))
831      (if dup (syntax-error "Duplicate bindings for a keyword"
832                     (car bs) dup)))))
833
834;; returns (k store loc-n)
835(define (expand-syntax-bindings bindings id-n syntax-env ienv store loc-n k)
836  (let loop ((bs bindings) (vals '()) (store store) (loc-n loc-n))
837    (if (not (null? bs))
838        (expand-val (cadar bs) id-n syntax-env store loc-n
839          (lambda (val store loc-n)
840            (loop (cdr bs) (cons val vals) store loc-n)))
841        (let loop ((store store) (vals (reverse vals)) (bs bindings))
842          (if (not (null? vals))
843              (let* ((loc (lookup-sid (caar bs) ienv))
844                     (store (extend-store store loc (car vals))))
845                (loop store (cdr vals) (cdr bs)))
846              (k store loc-n))))))
847
848
849;; (expand-any sexp id-n env store loc-n lsd? ek sk dk bk)
850;;
851;; Ek, sk, dk, and bk are continuations for expressions, syntaxes,
852;; definitions and begins:
853;;
854;; If sexp is an expression, returns (ek output).
855;;
856;; If sexp is a syntax, returns (sk syntax error-sexp store loc-n).
857;;   The error-sexp is just for use in error messages if the syntax is
858;;   subsequently misused.  It is the sid that was bound to the
859;;   syntax, unless the syntax is an anonymous transformer, as in
860;;   ((syntax-rules () ((_ x) 'x)) foo), in which case the error-sexp
861;;   will be the entire syntax-rules form.
862;;
863;; If sexp is a definition, returns (dk builtin sexp id-n env store
864;;   loc-n), where builtin is define or define-syntax.
865;;
866;; If sexp is a begin, returns (bk sexp id-n env store loc-n).
867;;
868;; The car of the sexp passed to dk or bk is just for error reporting:
869;; it is the sid that was bound to begin, define, or define-syntax.
870;;
871;; Expand-any signals an error if a malformed e, s, d, or b is
872;; encountered.  It also signals an error if ek, sk, dk, or bk is #f
873;; and the corresponding thing is encountered; however, if a begin is
874;; encountered and bk is #f, the begin is expanded as an expression
875;; and passed to ek.
876;;
877;; lsd? == Let-Syntax around Definitions is okay.  If lsd? is #f and a
878;; let-syntax is encountered, it is assumed to start an expression or
879;; syntax, so if ek and sk are #f an error will be signalled.  lsd? is
880;; only true at top-level.  (Let-syntax around internal definitions is
881;; just too semantically bizarre.)
882(define (expand-any sexp id-n env store loc-n lsd? ek sk dk bk)
883  (define (get-k k sexp name)
884    (or k (syntax-error "name used in bad context" name
885                 sexp)))
886  (define (get-ek sexp) (get-k ek sexp "Expression"))
887  (define (get-sk sexp) (get-k sk sexp "Syntax"))
888  (define (get-dk sexp) (get-k dk sexp "Definition"))
889  (define (get-bk sexp) (get-k bk sexp "Begin"))
890  (let again ((sexp sexp) (id-n id-n) (store store) (loc-n loc-n))
891    (define (expand-subexpr sexp) (expand-expr sexp id-n env store loc-n))
892    (define (handle-syntax-use syntax head store loc-n)
893      (let* ((tail (cdr sexp)) (sexp (cons head tail)))
894        (if (transformer? syntax)
895            (apply-transformer syntax sexp id-n env
896              (lambda (sexp id-n) (again sexp id-n store loc-n)))
897            (let ((builtin (builtin-name syntax)) (len (length tail)))
898              (define (handle-macro-block)
899                (or ek sk lsd?
900                    (syntax-error "Macro block used in bad context" sexp))
901                (or (>= len 2) (syntax-error "Malformed macro block" sexp))
902                (let ((bindings (car tail)) (body (cdr tail)))
903                  (check-syntax-bindings bindings)
904                  (let loop ((bs bindings) (loc-n loc-n) (ienv env))
905                    (if (not (null? bs))
906                        (loop (cdr bs) (+ loc-n 1)
907                              (extend-env ienv (sid-id (caar bs)) loc-n))
908                        (expand-syntax-bindings
909                          bindings id-n env ienv store loc-n
910                          (lambda (store loc-n)
911                            (expand-body body id-n ienv store loc-n
912                                         lsd? ek sk
913                                         (and lsd? dk) (and lsd? bk))))))))
914              (define (handle-expr-builtin)
915                (define (expr-assert test)
916                  (or test (syntax-error "Malformed expression" builtin sexp)))
917                (cons builtin
918                      (case builtin
919                        ((lambda)
920                         (expr-assert (= len 2))
921                         (expand-lambda (car tail) (cadr tail)
922                                        id-n env store loc-n))
923                        ((quote)
924                         (expr-assert (= len 1))
925                         (list (unwrap-vecs (car tail))))
926                        ((set!)
927                         (expr-assert (and (= len 2) (sid? (car tail))))
928                         (let ((var (lookup2 (car tail) env store)))
929                           (or (var? var)
930                               (syntax-error "Attempt to set a keyword" sexp))
931                           (list var (expand-subexpr (cadr tail)))))
932                        ((if)
933                         (expr-assert (<= 2 len 3))
934                         (map expand-subexpr tail))
935                        ((delay)
936                         (expr-assert (= len 1))
937                         (list (expand-subexpr (car tail)))))))
938              (case builtin
939                ((let-syntax) (handle-macro-block))
940                ((syntax-rules)
941                 (if (< len 1) (syntax-error "Empty syntax-rules form" sexp))
942                 (let ((syn (compile-syntax-rules sexp env)))
943                   ((get-sk sexp) syn sexp store loc-n)))
944                ((begin)
945                 (or ek (get-bk sexp))
946                 (cond (bk (bk sexp id-n env store loc-n))
947                       ((null? tail) (syntax-error "Empty begin expression" sexp))
948                       (else (ek (make-begin (map expand-subexpr tail))))))
949                ((define define-syntax)
950                 (or (and (= 2 len) (sid? (car tail)))
951                     (and (= 1 len) (eq? builtin 'define))
952                     (syntax-error "Malformed definition" sexp))
953                 ((get-dk sexp) builtin sexp id-n env store loc-n))
954                (else (get-ek sexp) (ek (handle-expr-builtin))))))))
955    (define (handle-combination output)
956      (ek (if (and (pair? output) (eq? 'lambda (car output))
957                   (null? (cadr output)) (null? (cdr sexp)))
958              ;; simplifies ((lambda () <expr>)) to <expr>
959              (caddr output)
960              (cons output (map expand-subexpr (cdr sexp))))))
961    ;;(pretty-print `(expand-any/again ,sexp))
962    (cond ((sid? sexp)
963           (let ((val (lookup2 sexp env store)))
964             (if (syntax? val)
965                 ((get-sk sexp) val sexp store loc-n)
966                 ((get-ek sexp) (if (code? val) (code-output val) val)))))
967          ((and (pair? sexp) (list? sexp))
968           (expand-any (car sexp) id-n env store loc-n #f
969             (and ek handle-combination) handle-syntax-use #f #f))
970          ((or (number? sexp) (boolean? sexp) (string? sexp) (char? sexp))
971           ((get-ek sexp) sexp))
972          (else (syntax-error
973                 (cond ((pair? sexp) "Improper list")
974                       ((null? sexp) "Empty list")
975                       ((vector? sexp) "Vector")
976                       (else "Non-S-Expression"))
977                 " used as an expression, syntax, or definition" sexp)))))
978
979;; Expands an expression or syntax and returns (k val store loc-n).
980(define (expand-val sexp id-n env store loc-n k)
981  (expand-any sexp id-n env store loc-n #f
982    (lambda (output) (k (make-code output) store loc-n))
983    (lambda (syn error-sexp store loc-n) (k syn store loc-n))
984    #f #f))
985
986(define (expand-expr sexp id-n env store loc-n)
987  (expand-any sexp id-n env store loc-n #f (lambda (x) x) #f #f #f))
988
989;; args and return are as in expand-any.
990(define (expand-body sexps id-n env store loc-n lsd? ek sk dk bk)
991  ;; Expand-def expands a definition or begin sequence, adds entries
992  ;; to the vds and sds lists of variable and syntax definitons, adds
993  ;; entries to the exprs list of expressions from (define <expr>)
994  ;; forms, extends env, and returns (k vds sds exprs id-n env store
995  ;; loc-n).
996  ;; If sexp is an expression, we just return (dek output) instead.
997  (define (expand-def sexp vds sds exprs id-n env store loc-n k dek)
998    (define (dk builtin sexp id-n env store loc-n)
999      (or ek (eq? builtin 'define-syntax)
1000          (syntax-error "Non-syntax definition in a syntax body: " sexp))
1001      (if (list2? sexp) ;; A (define <expression>) form.
1002          (k vds sds (cons (cadr sexp) exprs) id-n env store loc-n)
1003          (let* ((sid (cadr sexp))
1004                 (id (sid-id sid))
1005                 (env (extend-env env id loc-n)))
1006            (define (check def)
1007              (if (eqv? id (sid-id (cadr def)))
1008                  (error "Duplicate internal definitions: "
1009                         def " and: " sexp)))
1010            (begin
1011              (for-each check sds)
1012              (for-each check vds)
1013              (case builtin
1014                ((define-syntax)
1015                 (k vds (cons sexp sds) exprs id-n env store (+ loc-n 1)))
1016                ((define)
1017                 (let* ((var (intloc->var loc-n sid))
1018                        (store (extend-store store loc-n var))
1019                        (loc-n (+ loc-n 1)))
1020                   (k (cons sexp vds) sds exprs id-n env store loc-n))))))))
1021    (define (bk sexp id-n env store loc-n)
1022      (let loop ((sexps (cdr sexp)) (vds vds) (sds sds) (exprs exprs)
1023                 (id-n id-n) (env env) (store store) (loc-n loc-n) (dek dek))
1024        (if (null? sexps)
1025            (k vds sds exprs id-n env store loc-n)
1026            (expand-def (car sexps) vds sds exprs id-n env store loc-n
1027              (lambda (vds sds exprs id-n env store loc-n)
1028                (loop (cdr sexps) vds sds exprs id-n env store loc-n #f))
1029              (and dek (lambda (out)
1030                         (define (expand-one sexp)
1031                           (expand-expr sexp id-n env store loc-n))
1032                         (let ((rest (map expand-one (cdr sexps))))
1033                           (dek (make-begin (cons out rest))))))))))
1034    (expand-any sexp id-n env store loc-n #f dek #f dk bk))
1035  (let loop ((first (car sexps)) (rest (cdr sexps))
1036             (vds '()) (sds '()) (exprs '())
1037             (id-n id-n) (env env) (store store) (loc-n loc-n))
1038    (define (finish-body boundary-exp-output)
1039      (expand-syntax-bindings (map cdr sds) id-n env env store loc-n
1040        (lambda (store loc-n)
1041          (define (iexpand sexp) (expand-expr sexp id-n env store loc-n))
1042          (define (expand-vd vd)
1043            (list (lookup2 (cadr vd) env store) (iexpand (caddr vd))))
1044          (if (and (null? rest) (null? vds) (null? exprs))
1045              (expand-any first id-n env store loc-n lsd? ek sk dk bk)
1046              (ek (make-letrec
1047                    (map expand-vd (reverse vds))
1048                    (let ((body-exprs-output
1049                           (if (null? rest)
1050                               (list (iexpand first))
1051                               (cons boundary-exp-output
1052                                     (map iexpand rest)))))
1053                      (make-begin (append (map iexpand (reverse exprs))
1054                                          body-exprs-output)))))))))
1055    (if (null? rest)
1056        (finish-body #f)
1057        (expand-def first vds sds exprs id-n env store loc-n
1058          (lambda (vds sds exprs id-n env store loc-n)
1059            (loop (car rest) (cdr rest) vds sds exprs id-n env store loc-n))
1060          (and ek finish-body)))))
1061
1062
1063;; Returns (k outputs store loc-n).
1064(define (expand-top-level-sexps sexps store loc-n k)
1065  (define (finish store loc-n acc)
1066    (k (reverse acc) store loc-n))
1067  ;; expand adds stuff to acc and returns (k store loc-n acc)
1068  (let expand ((sexps sexps) (id-n 0) (env empty-env)
1069               (store store) (loc-n loc-n) (acc '()) (k finish))
1070    (if (null? sexps)
1071        (k store loc-n acc)
1072        (let ((rest (cdr sexps)))
1073          (define (ek output)
1074            (expand rest id-n env store loc-n (cons output acc) k))
1075          (define (dk builtin sexp id-n* env* store loc-n)
1076            (if (list2? sexp) ;; A (define <expression>) form.
1077                (ek (expand-expr (cadr sexp) id-n* env* store loc-n))
1078                (let* ((tail (cdr sexp))
1079                       (sid (car tail))
1080                       (loc (lookup-sid sid env*))
1081                       (init (cadr tail)))
1082                  (if (eq? builtin 'define)
1083                      (let* ((expr (expand-expr init id-n* env* store loc-n))
1084                             (var (loc->var loc sid))
1085                             (acc (cons (list 'define var expr) acc))
1086                             (store (substitute-in-store store loc var)))
1087                        (expand rest id-n env store loc-n acc k))
1088                      (expand-val init id-n* env* store loc-n
1089                        (lambda (val store loc-n)
1090                          (let ((store (substitute-in-store store loc val)))
1091                            (expand rest id-n env store loc-n acc k))))))))
1092          (define (bk sexp id-n* env* store loc-n)
1093            (expand (cdr sexp) id-n* env* store loc-n acc
1094                    (lambda (store loc-n acc)
1095                      (expand rest id-n env store loc-n acc k))))
1096          (expand-any (car sexps) id-n env store loc-n #t ek #f dk bk)))))
1097
1098;; Returns (k expanded-forms store loc-n).
1099(define (expand-top-level-forms forms store loc-n k)
1100  (define (finish outputs store loc-n)
1101    (define (finish1 output)
1102      ;; You can leave out the unrename-locals call if you want to.
1103      (symbolize (unrename-locals output)))
1104    (k (map finish1 outputs) store loc-n))
1105  (expand-top-level-sexps (wrap-vecs forms) store loc-n finish))
1106
1107;; Compile-syntax-rules:
1108;; This doesn't actually compile, it just does verification.
1109;; Detects all possible errors:
1110;;   pattern literals list is not a list of identifiers
1111;;   ellipsis in literals list
1112;;   rule is not a two-element list
1113;;   missing pattern keyword (pattern is not a pair whose car is an identifier)
1114;;   duplicate pattern variable
1115;;   ellipsis not preceded by a pattern or template.
1116;;   list or vector pattern with multiple ellipses.
1117;;   improper list pattern with an ellipsis.
1118;;   variable instance in template not at sufficient ellipsis depth.
1119;;   template ellipsis closes no variables.
1120(define (compile-syntax-rules synrules env)
1121  (define ellipsis-id (and (pair? (cddr synrules))
1122                           (sid? (cadr synrules))
1123                           (sid-id (cadr synrules))))
1124  (define (ellipsis? x)
1125    (and (sid? x)
1126         (if ellipsis-id
1127             (eqv? ellipsis-id (sid-id x))
1128             (eq? '... (lookup-sid x env)))))
1129
1130  (define (check-lit lit)
1131    (or (sid? lit)
1132        (error "Non-id: " lit " in literals list of: " synrules))
1133    (if (ellipsis? lit)
1134        (error "Ellipsis " lit " in literals list of: " synrules)))
1135
1136  (let* ((rest (if ellipsis-id (cddr synrules) (cdr synrules)))
1137         (pat-literal-sids (car rest))
1138         (rules (cdr rest))
1139         (pat-literals
1140          (begin (or (list? pat-literal-sids)
1141                     (error "Pattern literals list is not a list: "
1142                            pat-literal-sids))
1143                 (for-each check-lit pat-literal-sids)
1144                 (map sid-id pat-literal-sids))))
1145
1146    (define (ellipsis-pair? x)
1147      (and (pair? x) (ellipsis? (car x))))
1148
1149    (define (check-ellipses pat/tmpl in-template?)
1150      (define (bad-ellipsis x reason)
1151        (error (string-append reason ": ")
1152               x
1153               (if in-template? " in template: " " in pattern: ")
1154               pat/tmpl))
1155
1156      (define (multi-ellipsis-error x)
1157        (bad-ellipsis x "List or vector pattern with multiple ellipses"))
1158
1159      (define (ellipsis/tail-error x)
1160        (bad-ellipsis x "Improper list pattern with an ellipsis"))
1161
1162      (define (ellipsis-follows x thing)
1163        (bad-ellipsis x (string-append "Ellipsis following " thing)))
1164     
1165      (let ((x (if in-template? pat/tmpl (cdr pat/tmpl))))
1166        (if in-template?
1167            (if (ellipsis? x)
1168                (ellipsis-follows x "nothing"))
1169            (cond ((ellipsis? x)
1170                   (ellipsis-follows pat/tmpl "a '.'"))
1171                  ((ellipsis-pair? x)
1172                   (ellipsis-follows pat/tmpl "the pattern keyword"))))
1173        (let check ((x x))
1174          (cond ((pair? x)
1175                 (if (ellipsis? (car x)) (ellipsis-follows x "a '('"))
1176                 (check (car x))
1177                 (if (ellipsis? (cdr x)) (ellipsis-follows x "a '.'"))
1178                 (if (ellipsis-pair? (cdr x))
1179                     (cond ((ellipsis? (cddr x))
1180                            (ellipsis-follows (cdr x) "a '.'"))
1181                           ((ellipsis-pair? (cddr x))
1182                            (ellipsis-follows (cdr x) "an ellipsis"))
1183                           (in-template? (check (cddr x)))
1184                           (else (or (list? x) (ellipsis/tail-error x))
1185                                 (for-each (lambda (y)
1186                                             (if (ellipsis? y)
1187                                                 (multi-ellipsis-error x))
1188                                             (check y))
1189                                  (cddr x))))
1190                       
1191                     (check (cdr x))))
1192                ((svector? x)
1193                 (let ((elts (svector->list x)))
1194                   (if (ellipsis-pair? elts)
1195                       (ellipsis-follows x "a '#('")
1196                       (check elts))))))))
1197
1198    ;; Returns an alist: ((pat-var . depth) ...)
1199    (define (make-pat-env pat)
1200      (let collect ((x (cdr pat)) (depth 0) (l '()))
1201        (cond ((sid? x)
1202               (let ((id (sid-id x)))
1203                 (cond ((memv id pat-literals) l)
1204                       ((assv id l)
1205                        (error "Duplicate pattern var: " x
1206                               " in pattern: " pat))
1207                       (else (acons id depth l)))))
1208              ((vector? x) (collect (svector->list x) depth l))
1209              ((pair? x)
1210               (if (ellipsis-pair? (cdr x))
1211                   (collect (car x) (+ 1 depth) (collect (cddr x) depth l))
1212                   (collect (car x) depth (collect (cdr x) depth l))))
1213              (else l))))
1214
1215    ;; Checks var depths.
1216    (define (check-var-depths tmpl pat-env)
1217      (define (depth-error x)
1218        (error "Pattern var used at bad depth: " x " in template: " tmpl))
1219      (define (close-error x)
1220        (error "Template ellipsis closes no variables: " x
1221               " in template: " tmpl))
1222      ;; collect returns #t if any vars occurred at DEPTH
1223      (let collect ((x tmpl) (depth 0))
1224        (cond ((sid? x)
1225               (let ((p (assv (sid-id x) pat-env)))
1226                 (and p
1227                      (let* ((pat-depth (cdr p))
1228                             (same-depth? (= depth pat-depth)))
1229                        (if (and (positive? pat-depth) (not same-depth?))
1230                            (depth-error x))
1231                        same-depth?))))
1232              ((vector? x) (collect (svector->list x) depth))
1233              ((pair? x)
1234               (let* ((ellip? (ellipsis-pair? (cdr x)))
1235                      (car-closed? (collect (car x)
1236                                            (if ellip? (+ 1 depth) depth)))
1237                      (cdr-closed? (collect ((if ellip? cddr cdr) x)
1238                                            depth)))
1239                 (and ellip? (not car-closed?) (close-error x))
1240                 (or car-closed? cdr-closed?)))
1241              (else #f))))
1242
1243                         
1244    ;; Checks rule and returns a list of the template literal ids.
1245    (define (check-rule rule)
1246      (or (list2? rule) (error "Malformed syntax rule: " rule))
1247      (let ((pat (car rule)) (tmpl (cadr rule)))
1248        (or (and (pair? pat) (sid? (car pat)))
1249            (error "Malformed pattern: " pat))
1250        (check-ellipses pat #f)
1251        (check-ellipses tmpl #t)
1252        (let ((pat-env (make-pat-env pat)))
1253          (check-var-depths tmpl pat-env)
1254          (let collect ((x tmpl) (lits '()))
1255            (cond ((ellipsis? x) lits)
1256                  ((sid? x) (if (assv (sid-id x) pat-env)
1257                                lits
1258                                (cons (sid-id x) lits)))
1259                  ((vector? x) (collect (svector->list x) lits))
1260                  ((pair? x) (collect (car x) (collect (cdr x) lits)))
1261                  (else lits))))))
1262
1263    ;; Reduce-env: this optional hack cuts down on the clutter when
1264    ;; manually examining the store.  Returns an environment with only
1265    ;; the bindings we need: those of pattern or template literals,
1266    ;; and those of identifiers named "..." that prevent a "..." from
1267    ;; being treated as an ellipsis, e.g. in
1268    ;; (let ((... 1)) ((syntax-rules () ((_) ...)))) => 1.
1269    (define (reduce-env lits)
1270      (define (list-dots-ids x ids)
1271        (cond ((sid? x) (if (eq? '... (sid-location x))
1272                            (cons (sid-id x) ids)
1273                            ids))
1274              ((vector? x) (list-dots-ids (svector->list x) ids))
1275              ((pair? x) (list-dots-ids (car x) (list-dots-ids (cdr x) ids)))
1276              (else ids)))
1277      (let loop ((ids (if ellipsis-id lits (list-dots-ids rules lits)))
1278                 (reduced-env empty-env))
1279        (if (null? ids)
1280            reduced-env
1281            (loop (cdr ids)
1282                  (let ((id (car ids)))
1283                    (cond ((and (not (assv id reduced-env)) (assv id env))
1284                           => (lambda (binding) (cons binding reduced-env)))
1285                          (else reduced-env)))))))
1286
1287    (let* ((lits (apply append pat-literals (map check-rule rules)))
1288           (env (reduce-env lits)))
1289      (make-transformer synrules env))))
1290
1291
1292;; returns (k sexp id-n)
1293(define (apply-transformer transformer sexp id-n env k)
1294  (let* ((synrules (transformer-synrules transformer))
1295         (mac-env (transformer-env transformer))
1296         (ellipsis-id (and (sid? (cadr synrules))
1297                           (sid-id (cadr synrules))))
1298         (rest (if ellipsis-id (cddr synrules) (cdr synrules)))
1299         (pat-literals (map sid-id (car rest)))
1300         (rules (cdr rest)))
1301
1302    (define (pat-literal? id)     (memv id pat-literals))
1303    (define (not-pat-literal? id) (not (pat-literal? id)))
1304    (define (ellipsis-pair? x)    (and (pair? x) (ellipsis? (car x))))
1305    (define (ellipsis? x)
1306      (and (sid? x)
1307           (if ellipsis-id
1308               (eqv? ellipsis-id (sid-id x))
1309               (eq? '... (lookup-sid x mac-env)))))
1310
1311    ;; List-ids returns a list of the non-ellipsis ids in a
1312    ;; pattern or template for which (pred? id) is true.  If
1313    ;; include-scalars is false, we only include ids that are
1314    ;; within the scope of at least one ellipsis.
1315    (define (list-ids x include-scalars pred?)
1316      (let collect ((x x) (inc include-scalars) (l '()))
1317        (cond ((sid? x) (let ((id (sid-id x)))
1318                          (if (and inc (pred? id)) (cons id l) l)))
1319              ((vector? x) (collect (svector->list x) inc l))
1320              ((pair? x)
1321               (if (ellipsis-pair? (cdr x))
1322                   (collect (car x) #t (collect (cddr x) inc l))
1323                   (collect (car x) inc (collect (cdr x) inc l))))
1324              (else l))))
1325   
1326   
1327    (define (matches? pat)
1328      (let match ((pat pat) (sexp (cdr sexp)))
1329        (cond ((sid? pat)
1330               (or (not (pat-literal? (sid-id pat)))
1331                   (and (sid? sexp)
1332                        (eqv? (lookup-sid pat mac-env)
1333                              (lookup-sid sexp env)))))
1334              ((svector? pat)
1335               (and (svector? sexp)
1336                    (match (svector->list pat) (svector->list sexp))))
1337              ((not (pair? pat)) (equal? pat sexp))
1338              ((ellipsis-pair? (cdr pat))
1339               (let skip ((p (cddr pat)) (s sexp))
1340                 (if (pair? p)
1341                     (and (pair? s) (skip (cdr p) (cdr s)))
1342                     (let match-cars ((sexp sexp) (s s))
1343                       (if (pair? s)
1344                           (and (match (car pat) (car sexp))
1345                                (match-cars (cdr sexp) (cdr s)))
1346                           (match (cddr pat) sexp))))))
1347              (else (and (pair? sexp)
1348                         (match (car pat) (car sexp))
1349                         (match (cdr pat) (cdr sexp)))))))
1350
1351    ;; Returns an alist binding pattern variables to parts of the input.
1352    ;; An ellipsis variable is bound to a list (or a list of lists, etc.).
1353    (define (make-bindings pat)
1354      (let collect ((pat pat) (sexp (cdr sexp)) (bindings '()))
1355        (cond ((and (sid? pat) (not (pat-literal? (sid-id pat))))
1356               (acons (sid-id pat) sexp bindings))
1357              ((svector? pat)
1358               (collect (svector->list pat) (svector->list sexp) bindings))
1359              ((not (pair? pat)) bindings)
1360              ((ellipsis-pair? (cdr pat))
1361               (let* ((tail-len (length (cddr pat)))
1362                      (tail (list-tail sexp (- (length sexp) tail-len)))
1363                      (matches (reverse (list-tail (reverse sexp) tail-len)))
1364                      (vars (list-ids (car pat) #t not-pat-literal?)))
1365                 (define (collect1 match)
1366                   (map cdr (collect (car pat) match '())))
1367                 (append (apply map list vars (map collect1 matches))
1368                         (collect (cddr pat) tail bindings))))
1369              (else (collect (car pat) (car sexp)
1370                             (collect (cdr pat) (cdr sexp) bindings))))))
1371
1372    ;; Remove duplicates from a list, using eqv?.
1373    (define (remove-dups l)
1374      (let loop ((l l) (result '()))
1375        (if (null? l)
1376            result
1377            (loop (cdr l)
1378                  (let ((elt (car l)))
1379                    (if (memv elt result) result (cons elt result)))))))
1380
1381    (define (expand-template pat tmpl top-bindings)
1382      (define tmpl-literals
1383        (remove-dups (list-ids tmpl #t
1384                               (lambda (id) (not (assv id top-bindings))))))
1385      (define ellipsis-vars (list-ids pat #f not-pat-literal?))
1386      (define (list-ellipsis-vars subtmpl)
1387        (list-ids subtmpl #t (lambda (id) (memv id ellipsis-vars))))
1388      (define (expand tmpl bindings)
1389        (let expand-part ((tmpl tmpl))
1390          (cond
1391           ((sid? tmpl)
1392            (let ((id (sid-id tmpl)))
1393              (cond ((assv id bindings) => cdr)
1394                    ((assv id top-bindings) => cdr)
1395                    (else
1396                     (let ((index (+ -1 (length (memv id tmpl-literals))))
1397                           (location (lookup-sid tmpl mac-env)))
1398                       (make-sid (sid-name tmpl) (+ id-n index) location))))))
1399           ((vector? tmpl)
1400            (list->svector (expand-part (svector->list tmpl))))
1401           ((pair? tmpl)
1402            (if (ellipsis-pair? (cdr tmpl))
1403                (let ((vars-to-iterate (list-ellipsis-vars (car tmpl))))
1404                  (define (lookup var) (cdr (assv var bindings)))
1405                  (define (expand-using-vals . vals)
1406                    (expand (car tmpl) (map cons vars-to-iterate vals)))
1407                  (let ((val-lists (map lookup vars-to-iterate)))
1408                    (if (or (null? (cdr val-lists))
1409                            (apply = (map length val-lists)))
1410                        (append (apply map expand-using-vals val-lists)
1411                                (expand-part (cddr tmpl)))
1412                        (error "Unequal sequence lengths for pattern vars: "
1413                               vars-to-iterate " in macro call: " sexp))))
1414                (cons (expand-part (car tmpl)) (expand-part (cdr tmpl)))))
1415           (else tmpl))))
1416      (k (expand tmpl top-bindings) (+ id-n (length tmpl-literals))))
1417
1418    (let loop ((rules rules))
1419      (if (null? rules)
1420          (error "No matching rule for macro use: " sexp)
1421          (let* ((rule (car rules)) (pat (cdar rule)) (tmpl (cadr rule)))
1422            (if (matches? pat)
1423                (expand-template pat tmpl (make-bindings pat))
1424                (loop (cdr rules))))))))
1425
1426;; Unrename-locals: undoes most of the unnecessary renamings of local
1427;; variables.
1428;;
1429;; When the expander generates variables for lambdas and letrecs, it
1430;; generates variables with integer locations that are unique
1431;; throughout the region of the variable.  These numbers in effect
1432;; rename all the variables so that no variable ever shadows another.
1433;; This may be necessary if hygienic macro expansion caused some
1434;; variable named "foo" to be accessed from inside the region of
1435;; another binding named "foo".
1436;;
1437;; However, in most instances, this renaming is unnecessary.
1438;; Unrename-locals converts variables of the form #(foo n) to plain
1439;; #(foo) wherever this can be done.
1440;;
1441;; (This step is strictly optional.  It just makes the final expansion
1442;; more readable.)
1443(define (unrename-locals output)
1444  ;; Some operations on sets represented as lists with no duplicates.
1445  (define (subtract-lists a b) (a-minus-b-plus-c a b '()))
1446  (define (merge-lists a b) (a-minus-b-plus-c a b b))
1447  ;; a-minus-b-plus-c returns the union of (A - B) and C.
1448  ;; Assumes that (A - B) and C are disjoint.
1449  (define (a-minus-b-plus-c a b c)
1450    (if (null? a)
1451        c
1452        (let ((x (car a))
1453              (y (a-minus-b-plus-c (cdr a) b c)))
1454          (if (member x b) y (cons x y)))))
1455
1456  ;; (a b . c) => (a b c)
1457  (define (flatten-dotted x)
1458    (if (pair? x) (cons (car x) (flatten-dotted (cdr x))) (list x)))
1459
1460  (define (flatten-vars x) (if (list? x) x (flatten-dotted x)))
1461
1462  ;; Compute-free-vars computes the free variables of an expression
1463  ;; and annotates all the local binding forms within the expression
1464  ;; with lists of their free variables.
1465  ;;
1466  ;; Specifically, (compute-free-vars expr k) returns (k free
1467  ;; annexpr), where FREE is a list of the variables that occur freely
1468  ;; in EXPR, and ANNEXPR is like EXPR, but with every (lambda formals
1469  ;; body) or (letrec bindings body) in EXPR replaced by (lambda free*
1470  ;; formals body) or (letrec free* formals body), where FREE* is a
1471  ;; list of the free variables of the lambda or letrec expression as
1472  ;; a whole (i.e., the free variables of the body and initializers,
1473  ;; minus any that are bound by the bindings or formals).  Example:
1474
1475  ;; (compute-free-vars
1476  ;;   '(#(f 5) (lambda (#(a 7) #(b 8)) (#(g) #(a 7) #(b 2))))
1477  ;;   list)
1478  ;; => ((#(f 5) #(g) #(b 2))
1479  ;;     (#(f 5) (lambda (#(g) #(b 2)) (#(a 7) #(b 8)) (#(g) #(a 7) #(b 2)))))
1480  (define (compute-free-vars expr k)
1481    (cond ((var? expr)
1482           (k (list expr) expr))
1483          ((pair? expr)
1484           (case (car expr)
1485             ((quote) (k '() expr))
1486             ((lambda)
1487              (compute-free-vars
1488               (cddr expr)
1489               (lambda (free annexpr)
1490                 (let* ((vars (cadr expr))
1491                        (free (subtract-lists free (flatten-vars vars))))
1492                   (k free `(lambda ,free ,vars . ,annexpr))))))
1493             ((letrec)
1494              (compute-free-vars
1495               `(lambda ,(map car (cadr expr)) ,(cdr expr))
1496               (lambda (free annexpr)
1497                 (k free `(letrec ,free . ,(cadddr annexpr))))))
1498             (else (compute-free-vars
1499                    (car expr)
1500                    (lambda (free1 annexpr1)
1501                      (compute-free-vars
1502                       (cdr expr)
1503                       (lambda (free2 annexpr2)
1504                         (k (merge-lists free1 free2)
1505                            (cons annexpr1 annexpr2)))))))))
1506          (else (k '() expr))))
1507
1508  ;; Unrename: (unrename annexpr changes)
1509  ;;
1510  ;; The ANNEXPR argument must be annotated with free-variable lists
1511  ;; for all the lambdas and letrecs.  CHANGES is an alist of
1512  ;; unrenamings that we've made in the environment of ANNEXPR.  The
1513  ;; return value is a non-annotated expression with most of the local
1514  ;; variables unrenamed.
1515  ;;
1516  ;; When processing a lambda form and deciding whether to unrename
1517  ;; one of the variables that it binds, there are two kinds of
1518  ;; unrenamings we must avoid:
1519  ;;
1520  ;; 1. Avoid unrenamings that conflict with one of the free variables
1521  ;;    and thereby improperly shadow the binding to which the free
1522  ;;    variable is supposed to refer.  That is, don't convert (lambda
1523  ;;    (#(x 1)) #(x)) to (lambda (#(x)) #(x)).
1524  ;;
1525  ;; 2. Avoid unrenaming a variable to the same name as one of the
1526  ;;    other variables in the same set of bindings.  That is, even
1527  ;;    though converting (lambda (#(x 1) #(x 2)) 'foo) to (lambda
1528  ;;    (#(x) #(x)) 'foo) would not shadow any binding that is needed
1529  ;;    by the body, it would still cause an error.
1530
1531  (define (unrename annexpr changes)
1532    (define (unrename-var var)
1533      (if (symbol? (var-loc var)) var (make-var1 (var-name var))))
1534    (cond ((var? annexpr)
1535           (cond ((assoc annexpr changes) => cdr)
1536                 (else annexpr)))
1537          ((pair? annexpr)
1538           (case (car annexpr)
1539             ((quote) annexpr)
1540             ((lambda)
1541              (let* ((vars (flatten-vars (caddr annexpr)))
1542                     (avoid (unrename (cadr annexpr) changes)))
1543                (let scan-vars ((vars vars) (avoid avoid) (changes changes))
1544                  (if (null? vars)
1545                      (cons 'lambda (unrename (cddr annexpr) changes))
1546                      (let* ((var (car vars))
1547                             (urvar (unrename-var var)))
1548                        (if (member urvar avoid)
1549                            (scan-vars (cdr vars) (cons var avoid) changes)
1550                            (scan-vars (cdr vars)
1551                                       (cons urvar avoid)
1552                                       (acons var urvar changes))))))))
1553             ((letrec)
1554              (let ((foo `(lambda ,(cadr annexpr) ,(map car (caddr annexpr))
1555                                  ,(cddr annexpr))))
1556                `(letrec . ,(caddr (unrename foo changes)))))
1557             (else (cons (unrename (car annexpr) changes)
1558                         (unrename (cdr annexpr) changes)))))
1559          (else annexpr)))
1560 
1561  (compute-free-vars output (lambda (free annexpr) (unrename annexpr '()))))
1562
1563;; Some tests to exercise the unrenamer:
1564;;
1565;; (let-syntax ((foo (syntax-rules () ((foo) x)))) (lambda (x y) (foo) x y))
1566;; expands-to=> (lambda (_x_50 y) (begin x _x_50 y))
1567;;
1568;; (let-syntax ((foo (syntax-rules () ((foo x) (lambda (x y) z))))) (foo y))
1569;; expands-to=> (lambda (y _y_51) z)
1570;;
1571;; (let-syntax ((foo (syntax-rules () ((foo x) (lambda (y x) z))))) (foo y))
1572;; expands-to=> (lambda (y _y_51) z)
1573
1574
1575;; Symbolize uses var->symbol to convert all the variables in the
1576;; output from the expander into symbols.
1577(define (symbolize output)
1578  (cond ((var? output)
1579         (var->symbol output))
1580        ((pair? output)
1581         (if (eq? 'quote (car output))
1582             output
1583             (cons (symbolize (car output))
1584                   (symbolize (cdr output)))))
1585        (else output)))
1586
1587;; Var->symbol converts a variable to a symbol.
1588;;
1589;; Note that there are two parts to a variable (a name and a
1590;; location), and any two variables with the same location always have
1591;; the same name.  The location is either a symbol or an integer.  If
1592;; the location is a symbol, then the name is always the same symbol.
1593;; The variables are represented by one-element or two-element vectors
1594;; of the form #(symbolic-location) or #(name integer-location),
1595;; e.g. #(apple) or #(cherry 17).
1596;;
1597;; In other words, the location is what identifies a variable, and the
1598;; name is just additional information that was retained in order to
1599;; help us choose, for the final expansion, a symbol that bears some
1600;; relationship to the symbol that was used in the original code.
1601;;
1602;; The requirements for the var->symbol mapping are:
1603;;
1604;; 1. All variables must be mapped to distinct symbols.
1605;;
1606;; 2. No variable may be mapped to the name of a builtin.
1607;;
1608;; 3. Variables with symbolic locations that are the name of a
1609;;    standard procedure must be mapped to that name, i.e. #(CAR) must
1610;;    map to CAR.
1611;;
1612;; Desired additional properties are:
1613;;
1614;; 4. As many variables as possible should be simply mapped to their
1615;;    names.
1616;;
1617;; 5. Any variables not mapped to their names should at least be
1618;;    mapped to a symbol that includes the name as a substring of the
1619;;    chosen name.
1620;;
1621;; The scheme we use is to follow these rules:
1622;;
1623;;    1. #(foo number) => _foo_number
1624;;
1625;;    2. #(foo) => foo
1626;;       Except that:
1627;;          (a) if foo is a builtin; or
1628;;          (b) if foo starts with an underscore;
1629;;       then #(foo) => _foo_
1630;;
1631;; Without rule 2(a), we would violate requirement 2, and without rule
1632;; 2(b), we would violate requirement 1 (because #(foo 1) and
1633;; #(_foo_1) would both map to _foo_1).
1634
1635(define (var->symbol var)
1636  (let* ((sym (var-name var))
1637         (str (symbol->string sym))
1638         (loc (var-loc var)))
1639    (if (number? loc)
1640        (let ((n (number->string loc)))
1641          (string->symbol (string-append "_" str "_" n)))
1642        (if (case sym
1643              ((begin define delay if lambda letrec quote set!) #t)
1644              (else (and (positive? (string-length str))
1645                         (char=? #\_ (string-ref str 0)))))
1646            (string->symbol (string-append "_" str "_"))
1647            sym))))
1648
1649(define builtins-store
1650  (let loop ((bs '(begin define define-syntax if lambda quote set! delay
1651                         let-syntax syntax-rules))
1652             (store empty-store))
1653    (if (null? bs)
1654        store
1655        (loop (cdr bs)
1656              (extend-store store (car bs) (make-builtin (car bs)))))))
1657
1658;; null-prog is the preamble that defines all the standard macros that
1659;; are in the null-store.  (The "null-" name prefix was chosen to
1660;; correspond to the name of r5rs's null-environment procedure, even
1661;; though the null-store is far from empty.)
1662(define null-prog
1663  '((define-syntax letrec-syntax
1664      (let-syntax ((let-syntax let-syntax) (define-syntax define-syntax))
1665        (syntax-rules ()
1666          ((_ ((kw init) ...) . body)
1667           (let-syntax ()
1668             (define-syntax kw init) ... (let-syntax () . body))))))
1669    (let-syntax ()
1670      (define-syntax multi-define
1671        (syntax-rules ()
1672          ((_ definer (id ...) (init ...))
1673           (begin (definer id init) ...))))
1674      ;; Define-protected-macros defines a set of macros with a
1675      ;; private set of bindings for some keywords and variables.  If
1676      ;; any of the keywords or variables are later redefined at
1677      ;; top-level, the macros will continue to work.  The first
1678      ;; argument to define-protected-macros is let-syntax or
1679      ;; letrec-syntax; if it is letrec-syntax, then the macros will
1680      ;; also have a private set of bindings for one another, and
1681      ;; recursive calls made by the macros to themselves or to one
1682      ;; another will not be affected by later top-level
1683      ;; redefinitions.
1684      ;;
1685      ;; The private binding for a saved variable is created by a
1686      ;; let-syntax, using a dummy syntax as the initializer.  We
1687      ;; later assign a value to it using a top-level define (and thus
1688      ;; change the status of the binding from keyword to variable).
1689      (define-syntax dummy (syntax-rules ()))
1690      (define-syntax define-protected-macros
1691        (syntax-rules (define-syntax)
1692          ((_ let/letrec-syntax (saved-kw ...) (saved-var ...)
1693              (define-syntax kw syntax) ...)
1694           ((let-syntax ((saved-kw saved-kw) ... (saved-var dummy) ...)
1695              (let/letrec-syntax ((kw syntax) ...)
1696                (syntax-rules ()
1697                  ((_ top-level-kws top-level-vars)
1698                   (begin
1699                     (multi-define define (saved-var ...) top-level-vars)
1700                     (multi-define define-syntax top-level-kws (kw ...)))))))
1701            (kw ...) (saved-var ...)))))
1702      (begin
1703        ;; Prototype-style define and lambda with internal definitions
1704        ;; are implemented in define-protected-macros with let-syntax
1705        ;; scope so that they can access the builtin define and lambda.
1706        (define-protected-macros let-syntax (lambda define let-syntax) ()
1707          (define-syntax lambda
1708            (syntax-rules ()
1709              ((lambda args . body)
1710               (lambda args (let-syntax () . body)))))
1711          (define-syntax define
1712            (syntax-rules ()
1713              ((_ expr) (define expr))
1714              ((_ (var . args) . body)
1715               (define var (lambda args (let-syntax () . body))))
1716              ((_ var init) (define var init))))
1717          ;; We put letrec here so that it can use the builtin define,
1718          ;; and won't accidentally allow things like:
1719          ;; (letrec (((f) 1)) (f)) => 1
1720          (define-syntax letrec
1721            (syntax-rules ()
1722              ((_ ((var init) ...) . body)
1723               ;; The lambda ensures letrec is only used for expressions.
1724               ((lambda ()
1725                  (let-syntax ()
1726                    (define var init) ... (let-syntax () . body))))))))
1727        (define-protected-macros letrec-syntax
1728            (if lambda quote begin define letrec) ()
1729          (define-syntax let
1730            (syntax-rules ()
1731              ((_ ((var init) ...) . body)
1732               ((lambda (var ...) . body)
1733                init ...))
1734              ((_ name ((var init) ...) . body)
1735               (let ((var init) ...)
1736                 (crunch:loop
1737                  (name var ...)
1738                  . body) ) ) ) )
1739          (define-syntax let*
1740            (syntax-rules ()
1741              ((_ () . body) (let () . body))
1742              ((let* ((var init) . bindings) . body)
1743               (let ((var init)) (let* bindings . body)))))
1744          (define-syntax letrec
1745            (syntax-rules ()
1746              ((_ ((var init) ...) . body)
1747               (let () (define var init) ... (let () . body))))) 
1748          (define-syntax do
1749            (let-syntax ((do-step (syntax-rules () ((_ x) x) ((_ x y) y))))
1750              (syntax-rules ()
1751                ((_ ((var init step ...) ...)
1752                    (test expr ...)
1753                    command ...)
1754                 (let ((var init) ...)
1755                   (crunch:loop 
1756                    (doloop var ...)
1757                    (if test
1758                        (begin (##core#undefined) expr ... (##core#undefined))
1759                        (begin
1760                          command ...
1761                          (doloop (do-step var step ...) ...)))))))))
1762          (define-syntax case
1763            (letrec-syntax
1764                ((do-case
1765                  (syntax-rules (else)
1766                    ((_ (else body ...))
1767                     (crunch:default body ...) )
1768                    ((_ ((lit ...) body ...))
1769                     (crunch:case lit ... (begin body ...)) ) ) ) )
1770              (syntax-rules ()
1771                ((_ expr clause ...)
1772                 (crunch:switch
1773                  expr
1774                  (do-case clause) ...) ) ) ) )
1775          (define-syntax cond
1776            (syntax-rules (else =>)
1777              ((_) (##core#undefined))
1778              ((_ (else . exps)) (let () (begin . exps)))
1779              ((_ (x) . rest) (or x (cond . rest)))
1780              ((_ (x => proc) . rest)
1781               (let ((tmp x)) (cond (tmp (proc tmp)) . rest)))
1782              ((_ (generator guard => receiver) . rest)
1783               (let ((tmp generator))
1784                 (cond ((guard tmp) (receiver tmp))
1785                       . rest) ) )
1786              ((_ (x . exps) . rest)
1787               (if x (begin . exps) (cond . rest)))))
1788          (define-syntax and
1789            (syntax-rules ()
1790              ((_) #t)
1791              ((_ test) (let () test))
1792              ((_ test . tests) (if test (and . tests) #f))))
1793          (define-syntax or
1794            (syntax-rules ()
1795              ((_) #f)
1796              ((_ test) (let () test))
1797              ((_ test . tests) (let ((x test)) (if x x (or . tests)))))))
1798        ;; Quasiquote uses let-syntax scope so that it can recognize
1799        ;; nested uses of itself using a syntax-rules literal (that
1800        ;; is, the quasiquote binding that is visible in the
1801        ;; environment of the quasiquote transformer must be the same
1802        ;; binding that is visible where quasiquote is used).
1803        (define-protected-macros let-syntax
1804            (lambda quote let) ()
1805          (define-syntax quasiquote
1806            (let-syntax
1807                ((tail-preserving-syntax-rules
1808                  (syntax-rules ()
1809                    ((tail-preserving-syntax-rules literals
1810                        ((subpattern ...) (subtemplate ...))
1811                        ...)
1812                     (syntax-rules literals
1813                       ((subpattern ... . tail) (subtemplate ... . tail))
1814                       ...)))))
1815
1816              (define-syntax qq
1817                (tail-preserving-syntax-rules
1818                    (unquote unquote-splicing quasiquote)
1819                  ((_ ,x        ())      (do-next x))
1820                  ((_ (,@x . y) ())      (qq y () make-splice x))
1821                  ((_ `x         depth)  (qq x (depth) make-list 'quasiquote))
1822                  ((_ ,x        (depth)) (qq x  depth  make-list 'unquote))
1823                  ((_ (,x  . y) (depth)) (qq-nested-unquote (,x  . y) (depth)))
1824                  ((_ (,@x . y) (depth)) (qq-nested-unquote (,@x . y) (depth)))
1825                  ((_ ,@x        depth)  (unquote-splicing-error ,@x))
1826                  ((_ (x . y)    depth)  (qq x depth qq-cdr y depth make-pair))
1827                  ((_ #(x y ...) depth)  (qq (x) depth qq-cdr #(y ...) depth
1828                                             make-vector-splice))
1829                  ((_ x          depth)  (do-next 'x))))
1830
1831              (define-syntax do-next
1832                (syntax-rules ()
1833                  ((_ expr original-template) expr)
1834                  ((_ expr next-macro . tail) (next-macro expr . tail))))
1835
1836              (define-syntax unquote-splicing-error
1837                (syntax-rules ()
1838                  ((_ ,@x stack ... original-template)
1839                   (unquote-splicing-error (,@x in original-template)))))
1840             
1841              (define-syntax qq-cdr
1842                (tail-preserving-syntax-rules ()
1843                  ((_ car cdr depth combiner) (qq cdr depth combiner car))))
1844             
1845              (define-syntax qq-nested-unquote
1846                (tail-preserving-syntax-rules ()
1847                  ((_ ((sym x) . y) (depth))
1848                   (qq (x) depth make-map sym qq-cdr y (depth) make-splice))))
1849             
1850              (define-syntax make-map
1851                (tail-preserving-syntax-rules (quote list map lambda)
1852                  ((_ '(x) sym) (do-next '((sym x))))
1853                  ((_ (list x) sym) (do-next (list (list 'sym x))))
1854                  ((_ (map (lambda (x) y) z) sym)
1855                   (do-next (map (lambda (x) (list 'sym y)) z)))
1856                  ((_ expr sym)
1857                   (do-next (map (lambda (x) (list 'sym x)) expr)))))
1858                                                                     
1859              (define-syntax make-pair
1860                (tail-preserving-syntax-rules (quote list)
1861                  ((_ 'y 'x) (do-next '(x . y)))
1862                  ((_ '() x) (do-next (list x)))
1863                  ((_ (list . elts) x) (do-next (list x . elts)))
1864                  ((_ y x) (do-next (cons x y)))))
1865                                                 
1866              (define-syntax make-list
1867                (tail-preserving-syntax-rules (quote)
1868                  ((_ y x) (make-pair '() y make-pair x))))
1869                                                           
1870              (define-syntax make-splice
1871                (tail-preserving-syntax-rules ()
1872                  ((_ '() x) (do-next x))
1873                  ((_ y x) (do-next (append x y)))))
1874                                                   
1875              (define-syntax make-vector-splice
1876                (tail-preserving-syntax-rules (quote list vector list->vector)
1877                  ((_ '#(y ...) '(x))     (do-next '#(x y ...)))
1878                  ((_ '#(y ...) (list x)) (do-next (vector x 'y ...)))
1879                  ((_ '#()      x)        (do-next (list->vector x)))
1880                  ((_ '#(y ...) x)        (do-next (list->vector
1881                                                     (append x '(y ...)))))
1882                  ((_ y '(x))             (make-vector-splice y (list 'x)))
1883                  ((_ (vector y ...) (list x)) (do-next (vector x y ...)))
1884                  ((_ (vector y ...) x)   (do-next (list->vector
1885                                                     (append x (list y ...)))))
1886                  ((_ (list->vector y) (list x)) (do-next (list->vector
1887                                                            (cons x y))))
1888                  ((_ (list->vector y) x) (do-next (list->vector
1889                                                     (append x y))))))
1890                                                           
1891              (syntax-rules ()
1892                ((_ template) (let () (qq template () template)))))))))))
1893
1894(define null-stuff (expand-top-level-forms null-prog builtins-store 0 list))
1895(define null-output (car null-stuff))
1896(define null-store  (cadr null-stuff))
1897(define null-loc-n  (caddr null-stuff))
1898
1899;; an mstore is a mutable store.
1900(define (null-mstore) (cons null-store null-loc-n))
1901
1902(define (expand-top-level-forms! forms mstore)
1903  (expand-top-level-forms forms (car mstore) (cdr mstore)
1904    (lambda (outputs store loc-n)
1905      (set-car! mstore store)
1906      (set-cdr! mstore loc-n)
1907      outputs)))
1908
1909;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
1910
1911#+compiling
1912(declare
1913  (fixnum)
1914  (export crunch-expand))
1915
1916(define crunch-expand
1917  (let ((mstore (null-mstore)))
1918    (lambda (exp)
1919      (let ((forms (expand-top-level-forms! (list exp) mstore)))
1920        (let ((x (if (and (pair? forms) (null? (cdr forms)))
1921                     (car forms)
1922                     `(begin ,@forms) ) ) )
1923          (if *initforms*
1924              (let ((xi *initforms*))
1925                (set! *initforms* #f)
1926                `(begin ,@xi ,x) )
1927              x) ) ) ) ) )
1928             
1929(define *initforms* null-output)
1930
1931#;(crunch-expand
1932 '(define-syntax letrec
1933    (syntax-rules ()
1934      ((_ ((v x) ...) body ...)
1935       (let () (define v x) ... (let () body ...))))) )
1936
1937(crunch-expand
1938 `(begin
1939    ,@(with-input-from-file (##sys#resolve-include-filename "crunch-syntax.scm" #t #t)
1940        read-file)))
Note: See TracBrowser for help on using the repository browser.