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