Changeset 7161 in project


Ignore:
Timestamp:
12/18/07 07:10:13 (12 years ago)
Author:
felix winkelmann
Message:

updated to new alexpander

Location:
crunch
Files:
2 edited

Legend:

Unmodified
Added
Removed
  • crunch/crunch-expander.scm

    r3859 r7161  
    11;; alexpander.scm: a macro expander for scheme.
    2 ;; $Id: alexpander.scm,v 1.58 2004/10/29 00:41:35 al Exp $
    3 
    4 ;; Copyright 2002-2004 Al Petrofsky <alexpander@petrofsky.org>
    5 
    6 
    7 ; Redistribution and use in source and binary forms, with or without
    8 ; modification, are permitted provided that the following conditions
    9 ; are met:
    10 
    11 ;  Redistributions of source code must retain the above copyright
    12 ;    notice, this list of conditions and the following disclaimer.
    13 
    14 ;  Redistributions in binary form must reproduce the above copyright
    15 ;    notice, this list of conditions and the following disclaimer in
    16 ;    the documentation and/or other materials provided with the
    17 ;    distribution.
    18 
    19 ;  Neither the name of the author nor the names of its contributors
    20 ;    may be used to endorse or promote products derived from this
    21 ;    software without specific prior written permission.
    22 
    23 ; THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS
    24 ; "AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT
    25 ; LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR
    26 ; A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT
    27 ; HOLDERS OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT,
    28 ; INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING,
    29 ; BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS
    30 ; OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED
    31 ; AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT
    32 ; LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY
    33 ; WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE
    34 ; POSSIBILITY OF SUCH DAMAGE.
    35 
    36 
    37 ;; INTRO:
     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:
    3843
    3944;; This file implements a macro-expander for r5rs scheme (plus some
     
    5560;; Skip to the "BASIC USAGE" section for more information.
    5661
     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
    5774
    5875;; EXTENSIONS:
     
    6380
    6481;; Modified r5rs productions:
     82
    6583;;   <expression> ---> <variable> | <literal> | <procedure call>
    6684;;                   | <lambda expression> | <conditional> | <assignment>
    6785;;                   | <derived expression> | <macro use> | <macro block>
    6886;;                   | <keyword>
     87;;
    6988;;   <syntax definition> ---> (define-syntax <keyword> <syntax or expression>)
    7089;;                          | (begin <syntax definition>*)
    7190;;                          | <macro use>
    72 ;;   <syntax spec> --> (<keyword> <syntax or expression>)
    73 ;;   <syntax or expression> --> <syntax> | <expression>
     91;;
     92;;   <syntax spec> ---> (<keyword> <syntax or expression>)
     93;;
    7494;;   <macro use> ---> (<syntax> <datum>*)
     95;;
    7596;;   <definition> ---> (define <variable> <expression>)
    7697;;                   | (define (<variable> <def formals>) <body>)
     
    79100;;                   | <macro use>
    80101;;                   | <syntax definition>
     102;;
    81103;;   <command or definition> ---> <command> | <definition>
    82104;;                              | (begin <command or definition>*)
     
    85107
    86108;; New productions:
    87 ;;   <syntax> --> <transformer spec>
    88 ;;              | <keyword>
    89 ;;              | <macro use>
    90 ;;              | <syntax macro block>
    91 ;;   <syntax macro block> --> (<syntax-only block stuff> <syntax>)
     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;;
    92119;;   <top-level macro block>
    93 ;;       --> (<syntax-only block stuff> <command or definition>)
     120;;       ---> (<syntax-only block stuff> <command or definition>)
     121;;
    94122;;   <syntax-only block stuff>
    95123;;      ---> <let-or-letrec-syntax> (<syntax spec>*) <syntax definition>*
     124;;
    96125;;   <let-or-letrec-syntax> ---> let-syntax | letrec-syntax
     126
    97127
    98128;; These extensions all have the obvious meaning.
     
    129159;;  ;; an anonymous let transformer, used directly in a macro call.
    130160;;  ((syntax-rules ()
    131 ;;     ((_ ((var init) ...) . body)
    132 ;;      ((lambda (var ...) . body) init ...)))
     161;;     ((let ((var init) ...) . body)
     162;;      ((lambda (var ...) . body)
     163;;       init ...)))
    133164;;   ((x 1) (y 2))
    134165;;   (+ x y))
     
    148179
    149180
     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
    150226;; Top-level macro blocks.
    151227
    152 ;; At top level, if a macro block (a let-syntax or letrec-syntax form)
    153 ;; has only one body element, that element need not be an expression
    154 ;; (as would be required in r5rs).  Instead, it may be anything
    155 ;; allowed at top level: an expression, a definition, a begin sequence
    156 ;; of top-level forms, or another macro block containing a top-level
    157 ;; form.
    158 
    159 ;; (let-syntax ((- quote))
    160 ;;   (define x (- 1)))
    161 ;; (list x (- 1)) => (1 -1)
     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)
    162241
    163242;; Note that, unlike the similar extension in Chez scheme 6.0, this is
     
    167246;; begin form):
    168247
    169 ;; (begin
    170248;;   (define x 1)
     249;;   (define (f) x)
    171250;;   (let-syntax ()
    172251;;     (define x 2)
    173 ;;     'blah)
    174 ;;   x)
    175 ;; => 1, in r5rs and alexpander, but 2 in Chez scheme
    176 
    177 ;; (begin
     252;;     (f))
     253;;   => 1, in r5rs and alexpander, but 2 in Chez scheme
     254
    178255;;   (define x 1)
     256;;   (define (f) x)
    179257;;   (let-syntax ()
    180 ;;     (begin (define x 2)
    181 ;;            'blah))
    182 ;;   x)
    183 ;; => 2, in alexpander and in Chez scheme, but an error in r5rs.
     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>
    184287
    185288
     
    236339;; binding, and thus the top-level binding of define-values-temp is
    237340;; irrelevant.  When used at top-level, the definition of
    238 ;; define-values-temp in the output does not create a binding, it
    239 ;; mutates the top-level binding of define-values-temp.  Thus, all
    240 ;; top-level uses of define-values share a single temp variable.  For
    241 ;; internal-definition-level uses of define-values, a single shared
    242 ;; temp would not be sufficient, but things work out okay because
    243 ;; hygienic renaming causes each such use to create a distinct temp
    244 ;; variable.
     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.
    245348
    246349;; The version below works the same way, but hides from the top-level
     
    260363
    261364
    262 ;; Internal syntax definitions.
    263 
    264 ;; Internal syntax definitions are supported wherever they would make
    265 ;; sense (see the BNF) and have the letrec-syntax semantics you would
    266 ;; expect.  It is legal for the initializer of an internal variable
    267 ;; definition to use one of the internal syntax definitions in the
    268 ;; same body:
    269 
    270 ;; (let ()
    271 ;;   (define x (y))
    272 ;;   (define-syntax y (syntax-rules () ((y) 1)))
    273 ;;   x)
    274 ;; => 1
    275 
    276 ;; It's also legal for internal syntax definitions to be mutually
    277 ;; recursive transformers, but it is an error for the expansion of a
    278 ;; syntax definition's initializer to require the result of another
    279 ;; initializer:
    280 
    281 ;; (let ()
    282 ;;   (define-syntax m1 (syntax-rules () ((m1) #f) ((m1 . args) (m2 . args))))
    283 ;;   (define-syntax m2 (syntax-rules () ((m2 arg . args) (m1 . args))))
    284 ;;   (m1 foo bar baz))
    285 ;; => #f
    286 
    287 ;; (let ()
    288 ;;   (define-syntax simple-transformer
    289 ;;     (syntax-rules ()
    290 ;;       ((simple-transformer pattern template)
    291 ;;        (syntax-rules () (pattern template)))))
    292 ;;   (define-syntax m (simple-transformer (m x) (- x)))
    293 ;;   (m 1))
    294 ;; => error ("Premature use of keyword bound by an internal define-syntax")
    295 
    296 ;; (let ()
    297 ;;   (define-syntax simple-transformer
    298 ;;     (syntax-rules ()
    299 ;;       ((simple-transformer pattern template)
    300 ;;        (syntax-rules () (pattern template)))))
    301 ;;   (let ()
    302 ;;     (define-syntax m (simple-transformer (m x) (- x)))
    303 ;;     (m 1)))
    304 ;; => -1
    305 
    306 
    307 ;; Syntax-rules ellipsis
    308 
    309 ;; Per draft SRFI-46, syntax-rules transformers can specify the
    310 ;; identifier to be used as the ellipsis (such a specification is
    311 ;; treated as a hygienic binding), and a list pattern may contain
    312 ;; subpatterns after an ellipsis as well as before it:
    313 
    314 ;;   <transformer spec> ---> (syntax-rules (<identifier>*) <syntax rule>*)
    315 ;;              | (syntax-rules <ellipsis> (<identifier>*) <syntax rule>*)
    316 ;;   
    317 ;;   <syntax rule> ---> (<pattern> <template>)
    318 ;;   
    319 ;;   <pattern> ---> <pattern identifier>
    320 ;;                | (<pattern>*)
    321 ;;                | (<pattern>+ . <pattern>)
    322 ;;                | (<pattern>* <pattern> <ellipsis> <pattern>*)
    323 ;;                | #(<pattern>*)
    324 ;;                | #(<pattern>* <pattern> <ellipsis> <pattern>*)
    325 ;;                | <pattern datum>
    326 ;;   
    327 ;;   <pattern identifier> ---> <identifier>
    328 ;;   
    329 ;;   <ellipsis> ---> <identifier>
    330 
    331 
    332365;; Improved nested unquote-splicing. 
    333366
     
    351384;; replaced by the elements of the list that resulted from the
    352385;; expression's evaluation, any sequence of commas and comma at-signs
    353 ;; that immediately preceeded the comma at-sign is also removed and is
     386;; that immediately preceded the comma at-sign is also removed and is
    354387;; added to the front of each of the replacements.
    355388
     
    376409
    377410;;   1. (alexpander-repl)
    378 ;;      This starts a read-expand-print-loop.  Type in a program
    379 ;;      and see its expansion as you go.
     411;;      This starts a read-expand-print-loop.  Type in a program and
     412;;      see its expansion as you go.
    380413;;
    381414;;   2. (expand-program list-of-the-top-level-forms-of-a-program)
     
    384417;;
    385418;;   3. (expand-top-level-forms! forms mstore)
    386 ;;      Returns some macro-expanded forms and side-effects mstore.
    387 ;;      First create an initial mutable store with (null-mstore), then
    388 ;;      you can pass a program in piecemeal, with the effects of
    389 ;;      top-level define-syntaxes saved in mstore between calls to
    390 ;;      expand-top-level-forms!.
     419;;      Returns some macro-expanded forms and mutates mstore.
     420;;      To use this, first create an initial mutable store with
     421;;      (null-mstore).  Then you can pass a program in piecemeal, with
     422;;      the effects of top-level define-syntaxes saved in mstore
     423;;      between calls to expand-top-level-forms!.
    391424;;
    392425;;   4. (expand-top-level-forms forms store loc-n k)
    393426;;      The purely-functional interface.
    394 ;;      Returns by making a tail call to k:
     427;;      This returns by making a tail call to k:
    395428;;      (k expanded-forms new-store new-loc-n)
    396429;;      Use null-store and null-loc-n for store and loc-n arguments
     
    406439
    407440;; The output programs use a small subset of the r5rs syntax, namely:
    408 ;; begin, define, delay, if, lambda, letrec, quote, and set!.
     441;; BEGIN, DEFINE, DELAY, IF, LAMBDA, LETREC, QUOTE, AND SET!.
    409442;; Furthermore, begin is only used for expressions; lambdas and
    410443;; letrecs always have a single body expression and no internal
    411444;; definitions; and defines are always of the simple (define
    412 ;; <variable> <expression>) form.  Any uses or definitions in the
    413 ;; original program of a top-level variable whose name begins with
    414 ;; "_", or whose name is one of the eight primitives just mentioned,
    415 ;; will be renamed.  This will only cause a problem if the program is
    416 ;; trying to use some nonstandard library variable that starts with
    417 ;; "_": any r5rs-conformant program will be translated to an
    418 ;; equivalent macro-free r5rs program, it just might have some of its
    419 ;; top-level variable names changed.
     445;; <variable> <expression>) form.  If you want even simpler output,
     446;; with no letrecs, see expand-program-to-simple.
     447
     448;; Any uses or definitions in the original program of a top-level
     449;; variable whose name begins with "_", or whose name is one of the
     450;; eight primitives in the output language, will be renamed.  This
     451;; will only cause a problem if the program is trying to use some
     452;; nonstandard library variable that starts with "_".  That is, even
     453;; though some of a program's top-level variable names may get
     454;; changed, any r5rs-conformant program will still be translated to an
     455;; equivalent macro-free r5rs program.
    420456
    421457
     
    508544;; numbers rather than names, and the top-level environment has no
    509545;; 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).
     546;; environment that does not bind it to any location, then the
     547;; location to which the template literal was bound in the environment
     548;; of the macro is used instead.  (To be prepared for such a
     549;; contingency, this location is stored along with the numeric id in
     550;; the "renamed-sid" (see below) that a macro expansion inserts into
     551;; the code.)
    515552
    516553;; REPRESENTATION OF ENVIRONMENTS AND STORES
     
    542579;; local-location: integer
    543580;; 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.
     581;; variable: #(toplevel-location) | #(symbol local-location)
     582;; code: (output) ; output is the expanded code for an expression.
    546583;; syntax: builtin | transformer
    547 ;; builtin: (BUILTIN name)
     584;; builtin: symbol
    548585;; transformer: (synrules env)
    549586;; synrules: the unaltered sexp of the syntax-rules form.
     
    560597;; ...)), so that we can distinguish these vectors from renamed-sids.
    561598
    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.
     599;; In contrast, a variable named OUTPUT is a bit of almost-finished
     600;; code.  In this format, symbols and vectors within a quote
     601;; expression are represented normally.  All variable names are
     602;; represented as vectors of the form #(symbol) or #(symbol integer).
     603;; These vectors are converted to suitable, non-clashing symbols by
     604;; the symbolize function, which is the final step of expansion.
    565605
    566606;; A sid is the representation of an id within a sexp.
     
    601641;; (expand-expr sexp id-n env store loc-n) => output
    602642;; (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)
     643;; (expand-top-level-sexps sexps store loc-n k)
    604644;;   => (k outputs store loc-n)
    605645;; (expand-body sexps id-n env store loc-n lsd? ek sk dk bk)
     
    660700
    661701(define (make-code output) (list output))
    662 (define (make-builtin name) (list 'builtin name))
     702(define (make-builtin name) name)
    663703(define (make-transformer synrules env) (list synrules env))
    664704
    665 (define (variable? val) (symbol? val))
     705(define (var? val) (vector? val))
    666706(define (code? val) (list1? val))
    667707(define (code-output code) (car code))
    668708
    669 (define (syntax? val) (list2? val))
    670 
    671 (define (builtin? syntax) (eq? 'builtin (car syntax)))
    672 (define (builtin-name builtin) (cadr builtin))
     709(define (syntax? val) (or (symbol? val) (list2? val)))
     710
     711(define (builtin? syntax) (symbol? syntax))
     712(define (builtin-name builtin) builtin)
    673713
    674714(define (transformer? syntax) (not (builtin? syntax)))
     
    694734;; Lookup-location looks up a location in the store.
    695735;; If there is no value explictly listed in the store, then:
    696 ;;   1. For a top-level (named) location, return a top-level variable name.
     736;;   1. For a top-level (named) location, return a top-level variable.
    697737;;   2. For a local location, return #f.  This can only happen for a
    698738;;      location allocated by letrec-syntax or internal define-syntax
     
    706746(define (lookup2 sid env store)
    707747  (or (lookup-location (lookup-sid sid env) store)
    708       (syntax-error (string-append "Premature use of keyword bound by letrec-syntax"
    709                             " (or an internal define-syntax)")
    710              sid)))
     748      (syntax-error
     749       "Premature use of keyword bound by letrec-syntax (or an internal define-syntax): "
     750       sid)))
    711751
    712752(define (extend-env env id location) (acons id location env))
     
    732772        (acons loc val store))))
    733773
    734 ;; Top-level variables must be renamed if they conflict with the
    735 ;; primitives or local variable names we use in the output.
     774(define (make-var1 name/loc)
     775  (vector name/loc))
     776(define (make-var2 name loc)
     777  (vector name loc))
     778(define (var-name var)
     779  (vector-ref var 0))
     780(define (var-loc var)
     781  (vector-ref var (- (vector-length var) 1)))
     782
    736783(define (symloc->var sym)
    737   (define str (symbol->string sym))
    738   (define (rename) (string->symbol (string-append "_" str "_")))
    739   (case sym
    740     ((begin define delay if lambda letrec quote set!) (rename))
    741     (else (if (and (positive? (string-length str))
    742                    (char=? #\_ (string-ref str 0)))
    743               (rename)
    744               sym))))
    745 
    746 ;; intloc->var:
    747 ;; A simple (string->symbol (string-append "_" (number->string intloc)))
    748 ;; would work, but we use more verbose local variable names to make
    749 ;; the output more decipherable to humans.
     784  (make-var1 sym))
     785
    750786(define (intloc->var intloc sid)
    751   (let ((str (symbol->string (sid-name sid))))
    752     (string->symbol (string-append "_" (number->string intloc) "_" str))))
     787  (make-var2 (sid-name sid) intloc))
    753788
    754789(define (loc->var loc sid)
     
    759794(define (make-begin outputs)
    760795  (if (list1? outputs) (car outputs) (cons 'begin outputs)))
     796
     797(define (make-letrec bindings expr)
     798  (if (null? bindings) expr (list 'letrec bindings expr)))
    761799
    762800(define (expand-lambda formals expr id-n env store loc-n)
     
    821859;; If sexp is a syntax, returns (sk syntax error-sexp store loc-n).
    822860;;   The error-sexp is just for use in error messages if the syntax is
    823 ;;   subsequently misued.  It is the sid that was bound to the syntax,
    824 ;;   unless the syntax is an anonymous transformer, as in
     861;;   subsequently misused.  It is the sid that was bound to the
     862;;   syntax, unless the syntax is an anonymous transformer, as in
    825863;;   ((syntax-rules () ((_ x) 'x)) foo), in which case the error-sexp
    826864;;   will be the entire syntax-rules form.
     
    847885(define (expand-any sexp id-n env store loc-n lsd? ek sk dk bk)
    848886  (define (get-k k sexp name)
    849     (or k (syntax-error (string-append name " used in bad context: ")
     887    (or k (syntax-error "name used in bad context" name
    850888                 sexp)))
    851889  (define (get-ek sexp) (get-k ek sexp "Expression"))
    852890  (define (get-sk sexp) (get-k sk sexp "Syntax"))
    853891  (define (get-dk sexp) (get-k dk sexp "Definition"))
     892  (define (get-bk sexp) (get-k bk sexp "Begin"))
    854893  (let again ((sexp sexp) (id-n id-n) (store store) (loc-n loc-n))
    855894    (define (expand-subexpr sexp) (expand-expr sexp id-n env store loc-n))
     
    891930                         (expr-assert (and (= len 2) (sid? (car tail))))
    892931                         (let ((var (lookup2 (car tail) env store)))
    893                            (or (variable? var)
     932                           (or (var? var)
    894933                               (syntax-error "Attempt to set a keyword" sexp))
    895934                           (list var (expand-subexpr (cadr tail)))))
     
    907946                   ((get-sk sexp) syn sexp store loc-n)))
    908947                ((begin)
     948                 (or ek (get-bk sexp))
    909949                 (cond (bk (bk sexp id-n env store loc-n))
    910950                       ((null? tail) (syntax-error "Empty begin expression" sexp))
    911                        (else (make-begin (map expand-subexpr tail)))))
     951                       (else (ek (make-begin (map expand-subexpr tail))))))
    912952                ((define define-syntax)
    913953                 (or (and (= 2 len) (sid? (car tail)))
     
    915955                     (syntax-error "Malformed definition" sexp))
    916956                 ((get-dk sexp) builtin sexp id-n env store loc-n))
    917                 (else ((get-ek sexp) (handle-expr-builtin))))))))
     957                (else (get-ek sexp) (ek (handle-expr-builtin))))))))
    918958    (define (handle-combination output)
    919959      (ek (if (and (pair? output) (eq? 'lambda (car output))
     
    928968                 ((get-sk sexp) val sexp store loc-n)
    929969                 ((get-ek sexp) (if (code? val) (code-output val) val)))))
    930           ((null? sexp) (syntax-error "Null used as an expression or syntax" sexp))
    931           ((and (list? sexp) (eq? 'include (car sexp)) (= 2 (length sexp)))
    932            (if (not (string? (cadr sexp)))
    933                (syntax-error "invalid argument to `include'" sexp)
    934                (let ((fn (##sys#resolve-include-filename (cadr sexp) #t)))
    935                  (when (load-verbose) (print "; including " fn " ..."))
    936                  (let ((sexp `(begin
    937                                 ,@(with-input-from-file fn
    938                                     (lambda ()
    939                                       (do ([x (read) (read)]
    940                                            [xs '() (cons x xs)] )
    941                                           ((eof-object? x)
    942                                            (reverse xs))) ) ) ) ) )
    943                    (again sexp id-n store loc-n)))))
    944           ((list? sexp)
     970          ((and (pair? sexp) (list? sexp))
    945971           (expand-any (car sexp) id-n env store loc-n #f
    946972             (and ek handle-combination) handle-syntax-use #f #f))
    947           ((or (##sys#number? sexp) (boolean? sexp) (string? sexp)
    948                (char? sexp) (keyword? sexp) (eof-object? sexp))
     973          ((or (number? sexp) (boolean? sexp) (string? sexp) (char? sexp))
    949974           ((get-ek sexp) sexp))
    950           (else (syntax-error (string-append
    951                         (cond ((pair? sexp) "Improper list: ")
    952                               ((vector? sexp) "Vector: ")
    953                               (else "Non-S-Expression: "))
    954                         " used as an expression, syntax, or definition.")
    955                        sexp)))))
     975          (else (syntax-error
     976                 (cond ((pair? sexp) "Improper list")
     977                       ((null? sexp) "Empty list")
     978                       ((vector? sexp) "Vector")
     979                       (else "Non-S-Expression"))
     980                 " used as an expression, syntax, or definition" sexp)))))
    956981
    957982;; Expands an expression or syntax and returns (k val store loc-n).
     
    959984  (expand-any sexp id-n env store loc-n #f
    960985    (lambda (output) (k (make-code output) store loc-n))
    961     (lambda (syn syntax-error-sexp store loc-n) (k syn store loc-n))
     986    (lambda (syn error-sexp store loc-n) (k syn store loc-n))
    962987    #f #f))
    963988
     
    972997  ;; forms, extends env, and returns (k vds sds exprs id-n env store
    973998  ;; loc-n).
    974   ;; If sexp is an expression, we just return (ek output) instead.
    975   (define (expand-def sexp vds sds exprs id-n env store loc-n k ek)
     999  ;; If sexp is an expression, we just return (dek output) instead.
     1000  (define (expand-def sexp vds sds exprs id-n env store loc-n k dek)
    9761001    (define (dk builtin sexp id-n env store loc-n)
     1002      (or ek (eq? builtin 'define-syntax)
     1003          (syntax-error "Non-syntax definition in a syntax body: " sexp))
    9771004      (if (list2? sexp) ;; A (define <expression>) form.
    978           (if exprs
    979               (k vds sds (cons (cadr sexp) exprs) id-n env store loc-n)
    980               (syntax-error "Non-syntax definition in a syntax body" sexp))
     1005          (k vds sds (cons (cadr sexp) exprs) id-n env store loc-n)
    9811006          (let* ((sid (cadr sexp))
    9821007                 (id (sid-id sid))
     
    9841009            (define (check def)
    9851010              (if (eqv? id (sid-id (cadr def)))
    986                   (syntax-error "Duplicate internal definitions: "
    987                          def sexp)))
     1011                  (error "Duplicate internal definitions: "
     1012                         def " and: " sexp)))
    9881013            (begin
    9891014              (for-each check sds)
     
    9931018                 (k vds (cons sexp sds) exprs id-n env store (+ loc-n 1)))
    9941019                ((define)
    995                  (or exprs
    996                      (syntax-error "Variable definition in a syntax body" sexp))
    9971020                 (let* ((var (intloc->var loc-n sid))
    9981021                        (store (extend-store store loc-n var))
     
    10011024    (define (bk sexp id-n env store loc-n)
    10021025      (let loop ((sexps (cdr sexp)) (vds vds) (sds sds) (exprs exprs)
    1003                  (id-n id-n) (env env) (store store) (loc-n loc-n) (ek ek))
     1026                 (id-n id-n) (env env) (store store) (loc-n loc-n) (dek dek))
    10041027        (if (null? sexps)
    10051028            (k vds sds exprs id-n env store loc-n)
     
    10071030              (lambda (vds sds exprs id-n env store loc-n)
    10081031                (loop (cdr sexps) vds sds exprs id-n env store loc-n #f))
    1009               (and ek (lambda (out)
    1010                         (define (expand-one sexp)
    1011                           (expand-expr sexp id-n env store loc-n))
    1012                         (let ((rest (map expand-one (cdr sexps))))
    1013                           (ek (make-begin (cons out rest))))))))))
    1014     (expand-any sexp id-n env store loc-n #f ek #f dk bk))
     1032              (and dek (lambda (out)
     1033                         (define (expand-one sexp)
     1034                           (expand-expr sexp id-n env store loc-n))
     1035                         (let ((rest (map expand-one (cdr sexps))))
     1036                           (dek (make-begin (cons out rest))))))))))
     1037    (expand-any sexp id-n env store loc-n #f dek #f dk bk))
    10151038  (let loop ((first (car sexps)) (rest (cdr sexps))
    1016              (vds '()) (sds '()) (exprs (and ek '()))
     1039             (vds '()) (sds '()) (exprs '())
    10171040             (id-n id-n) (env env) (store store) (loc-n loc-n))
    10181041    (define (finish-body boundary-exp-output)
     
    10221045          (define (expand-vd vd)
    10231046            (list (lookup2 (cadr vd) env store) (iexpand (caddr vd))))
    1024           (define (make-letrec bindings expr)
    1025             (if (null? bindings) expr (list 'letrec bindings expr)))
    1026           (if (and (null? rest) (null? vds) (not (pair? exprs)))
     1047          (if (and (null? rest) (null? vds) (null? exprs))
    10271048              (expand-any first id-n env store loc-n lsd? ek sk dk bk)
    10281049              (ek (make-letrec
    10291050                    (map expand-vd (reverse vds))
    1030                     (let* ((body-exprs-output
    1031                             (if (null? rest)
    1032                                 (list (iexpand first))
    1033                                 (cons boundary-exp-output
    1034                                       (map iexpand rest)))))
     1051                    (let ((body-exprs-output
     1052                           (if (null? rest)
     1053                               (list (iexpand first))
     1054                               (cons boundary-exp-output
     1055                                     (map iexpand rest)))))
    10351056                      (make-begin (append (map iexpand (reverse exprs))
    10361057                                          body-exprs-output)))))))))
     
    10431064
    10441065
    1045 ;; (returns (k outputs store loc-n))
    1046 (define (expand-top-level-forms forms store loc-n k)
    1047   (define (finalize store loc-n acc)
     1066;; Returns (k outputs store loc-n).
     1067(define (expand-top-level-sexps sexps store loc-n k)
     1068  (define (finish store loc-n acc)
    10481069    (k (reverse acc) store loc-n))
    10491070  ;; expand adds stuff to acc and returns (k store loc-n acc)
    1050   (let expand ((sexps (wrap-vecs forms)) (id-n 0) (env empty-env)
    1051                (store store) (loc-n loc-n) (acc '()) (k finalize))
     1071  (let expand ((sexps sexps) (id-n 0) (env empty-env)
     1072               (store store) (loc-n loc-n) (acc '()) (k finish))
    10521073    (if (null? sexps)
    10531074        (k store loc-n acc)
     
    10601081                (let* ((tail (cdr sexp))
    10611082                       (sid (car tail))
    1062                        (loc (sid-location sid))
     1083                       (loc (lookup-sid sid env*))
    10631084                       (init (cadr tail)))
    10641085                  (if (eq? builtin 'define)
     
    10771098                      (expand rest id-n env store loc-n acc k))))
    10781099          (expand-any (car sexps) id-n env store loc-n #t ek #f dk bk)))))
     1100
     1101;; Returns (k expanded-forms store loc-n).
     1102(define (expand-top-level-forms forms store loc-n k)
     1103  (define (finish outputs store loc-n)
     1104    (define (finish1 output)
     1105      ;; You can leave out the unrename-locals call if you want to.
     1106      (symbolize (unrename-locals output)))
     1107    (k (map finish1 outputs) store loc-n))
     1108  (expand-top-level-sexps (wrap-vecs forms) store loc-n finish))
    10791109
    10801110;; Compile-syntax-rules:
     
    11031133  (define (check-lit lit)
    11041134    (or (sid? lit)
    1105         (syntax-error "Non-id: in literals list of" lit synrules))
     1135        (error "Non-id: " lit " in literals list of: " synrules))
    11061136    (if (ellipsis? lit)
    1107         (syntax-error "Ellipsis in literals list of" lit synrules)))
     1137        (error "Ellipsis " lit " in literals list of: " synrules)))
    11081138
    11091139  (let* ((rest (if ellipsis-id (cddr synrules) (cdr synrules)))
     
    11121142         (pat-literals
    11131143          (begin (or (list? pat-literal-sids)
    1114                      (syntax-error "Pattern literals list is not a list"
     1144                     (error "Pattern literals list is not a list: "
    11151145                            pat-literal-sids))
    11161146                 (for-each check-lit pat-literal-sids)
     
    11221152    (define (check-ellipses pat/tmpl in-template?)
    11231153      (define (bad-ellipsis x reason)
    1124         (syntax-error (string-append reason ": ")
     1154        (error (string-append reason ": ")
    11251155               x
    11261156               (if in-template? " in template: " " in pattern: ")
     
    11761206                 (cond ((memv id pat-literals) l)
    11771207                       ((assv id l)
    1178                         (syntax-error "Duplicate pattern var in pattern" x pat))
     1208                        (error "Duplicate pattern var: " x
     1209                               " in pattern: " pat))
    11791210                       (else (acons id depth l)))))
    11801211              ((vector? x) (collect (svector->list x) depth l))
     
    11881219    (define (check-var-depths tmpl pat-env)
    11891220      (define (depth-error x)
    1190         (syntax-error "Pattern var used at bad depth in template" x tmpl))
     1221        (error "Pattern var used at bad depth: " x " in template: " tmpl))
    11911222      (define (close-error x)
    1192         (syntax-error "Template ellipsis closes no variables in template" x
    1193                tmpl))
     1223        (error "Template ellipsis closes no variables: " x
     1224               " in template: " tmpl))
    11941225      ;; collect returns #t if any vars occurred at DEPTH
    11951226      (let collect ((x tmpl) (depth 0))
     
    12161247    ;; Checks rule and returns a list of the template literal ids.
    12171248    (define (check-rule rule)
    1218       (or (list2? rule) (syntax-error "Malformed syntax rule" rule))
     1249      (or (list2? rule) (error "Malformed syntax rule: " rule))
    12191250      (let ((pat (car rule)) (tmpl (cadr rule)))
    12201251        (or (and (pair? pat) (sid? (car pat)))
    1221             (syntax-error "Malformed pattern" pat))
     1252            (error "Malformed pattern: " pat))
    12221253        (check-ellipses pat #f)
    12231254        (check-ellipses tmpl #t)
     
    13821413                        (append (apply map expand-using-vals val-lists)
    13831414                                (expand-part (cddr tmpl)))
    1384                         (syntax-error "Unequal sequence lengths for pattern vars in macro call"
    1385                                vars-to-iterate sexp))))
     1415                        (error "Unequal sequence lengths for pattern vars: "
     1416                               vars-to-iterate " in macro call: " sexp))))
    13861417                (cons (expand-part (car tmpl)) (expand-part (cdr tmpl)))))
    13871418           (else tmpl))))
     
    13901421    (let loop ((rules rules))
    13911422      (if (null? rules)
    1392           (syntax-error "No matching rule for macro use" sexp)
     1423          (error "No matching rule for macro use: " sexp)
    13931424          (let* ((rule (car rules)) (pat (cdar rule)) (tmpl (cadr rule)))
    13941425            (if (matches? pat)
    13951426                (expand-template pat tmpl (make-bindings pat))
    13961427                (loop (cdr rules))))))))
     1428
     1429;; Unrename-locals: undoes most of the unnecessary renamings of local
     1430;; variables.
     1431;;
     1432;; When the expander generates variables for lambdas and letrecs, it
     1433;; generates variables with integer locations that are unique
     1434;; throughout the region of the variable.  These numbers in effect
     1435;; rename all the variables so that no variable ever shadows another.
     1436;; This may be necessary if hygienic macro expansion caused some
     1437;; variable named "foo" to be accessed from inside the region of
     1438;; another binding named "foo".
     1439;;
     1440;; However, in most instances, this renaming is unnecessary.
     1441;; Unrename-locals converts variables of the form #(foo n) to plain
     1442;; #(foo) wherever this can be done.
     1443;;
     1444;; (This step is strictly optional.  It just makes the final expansion
     1445;; more readable.)
     1446(define (unrename-locals output)
     1447  ;; Some operations on sets represented as lists with no duplicates.
     1448  (define (subtract-lists a b) (a-minus-b-plus-c a b '()))
     1449  (define (merge-lists a b) (a-minus-b-plus-c a b b))
     1450  ;; a-minus-b-plus-c returns the union of (A - B) and C.
     1451  ;; Assumes that (A - B) and C are disjoint.
     1452  (define (a-minus-b-plus-c a b c)
     1453    (if (null? a)
     1454        c
     1455        (let ((x (car a))
     1456              (y (a-minus-b-plus-c (cdr a) b c)))
     1457          (if (member x b) y (cons x y)))))
     1458
     1459  ;; (a b . c) => (a b c)
     1460  (define (flatten-dotted x)
     1461    (if (pair? x) (cons (car x) (flatten-dotted (cdr x))) (list x)))
     1462
     1463  (define (flatten-vars x) (if (list? x) x (flatten-dotted x)))
     1464
     1465  ;; Compute-free-vars computes the free variables of an expression
     1466  ;; and annotates all the local binding forms within the expression
     1467  ;; with lists of their free variables.
     1468  ;;
     1469  ;; Specifically, (compute-free-vars expr k) returns (k free
     1470  ;; annexpr), where FREE is a list of the variables that occur freely
     1471  ;; in EXPR, and ANNEXPR is like EXPR, but with every (lambda formals
     1472  ;; body) or (letrec bindings body) in EXPR replaced by (lambda free*
     1473  ;; formals body) or (letrec free* formals body), where FREE* is a
     1474  ;; list of the free variables of the lambda or letrec expression as
     1475  ;; a whole (i.e., the free variables of the body and initializers,
     1476  ;; minus any that are bound by the bindings or formals).  Example:
     1477
     1478  ;; (compute-free-vars
     1479  ;;   '(#(f 5) (lambda (#(a 7) #(b 8)) (#(g) #(a 7) #(b 2))))
     1480  ;;   list)
     1481  ;; => ((#(f 5) #(g) #(b 2))
     1482  ;;     (#(f 5) (lambda (#(g) #(b 2)) (#(a 7) #(b 8)) (#(g) #(a 7) #(b 2)))))
     1483  (define (compute-free-vars expr k)
     1484    (cond ((var? expr)
     1485           (k (list expr) expr))
     1486          ((pair? expr)
     1487           (case (car expr)
     1488             ((quote) (k '() expr))
     1489             ((lambda)
     1490              (compute-free-vars
     1491               (cddr expr)
     1492               (lambda (free annexpr)
     1493                 (let* ((vars (cadr expr))
     1494                        (free (subtract-lists free (flatten-vars vars))))
     1495                   (k free `(lambda ,free ,vars . ,annexpr))))))
     1496             ((letrec)
     1497              (compute-free-vars
     1498               `(lambda ,(map car (cadr expr)) ,(cdr expr))
     1499               (lambda (free annexpr)
     1500                 (k free `(letrec ,free . ,(cadddr annexpr))))))
     1501             (else (compute-free-vars
     1502                    (car expr)
     1503                    (lambda (free1 annexpr1)
     1504                      (compute-free-vars
     1505                       (cdr expr)
     1506                       (lambda (free2 annexpr2)
     1507                         (k (merge-lists free1 free2)
     1508                            (cons annexpr1 annexpr2)))))))))
     1509          (else (k '() expr))))
     1510
     1511  ;; Unrename: (unrename annexpr changes)
     1512  ;;
     1513  ;; The ANNEXPR argument must be annotated with free-variable lists
     1514  ;; for all the lambdas and letrecs.  CHANGES is an alist of
     1515  ;; unrenamings that we've made in the environment of ANNEXPR.  The
     1516  ;; return value is a non-annotated expression with most of the local
     1517  ;; variables unrenamed.
     1518  ;;
     1519  ;; When processing a lambda form and deciding whether to unrename
     1520  ;; one of the variables that it binds, there are two kinds of
     1521  ;; unrenamings we must avoid:
     1522  ;;
     1523  ;; 1. Avoid unrenamings that conflict with one of the free variables
     1524  ;;    and thereby improperly shadow the binding to which the free
     1525  ;;    variable is supposed to refer.  That is, don't convert (lambda
     1526  ;;    (#(x 1)) #(x)) to (lambda (#(x)) #(x)).
     1527  ;;
     1528  ;; 2. Avoid unrenaming a variable to the same name as one of the
     1529  ;;    other variables in the same set of bindings.  That is, even
     1530  ;;    though converting (lambda (#(x 1) #(x 2)) 'foo) to (lambda
     1531  ;;    (#(x) #(x)) 'foo) would not shadow any binding that is needed
     1532  ;;    by the body, it would still cause an error.
     1533
     1534  (define (unrename annexpr changes)
     1535    (define (unrename-var var)
     1536      (if (symbol? (var-loc var)) var (make-var1 (var-name var))))
     1537    (cond ((var? annexpr)
     1538           (cond ((assoc annexpr changes) => cdr)
     1539                 (else annexpr)))
     1540          ((pair? annexpr)
     1541           (case (car annexpr)
     1542             ((quote) annexpr)
     1543             ((lambda)
     1544              (let* ((vars (flatten-vars (caddr annexpr)))
     1545                     (avoid (unrename (cadr annexpr) changes)))
     1546                (let scan-vars ((vars vars) (avoid avoid) (changes changes))
     1547                  (if (null? vars)
     1548                      (cons 'lambda (unrename (cddr annexpr) changes))
     1549                      (let* ((var (car vars))
     1550                             (urvar (unrename-var var)))
     1551                        (if (member urvar avoid)
     1552                            (scan-vars (cdr vars) (cons var avoid) changes)
     1553                            (scan-vars (cdr vars)
     1554                                       (cons urvar avoid)
     1555                                       (acons var urvar changes))))))))
     1556             ((letrec)
     1557              (let ((foo `(lambda ,(cadr annexpr) ,(map car (caddr annexpr))
     1558                                  ,(cddr annexpr))))
     1559                `(letrec . ,(caddr (unrename foo changes)))))
     1560             (else (cons (unrename (car annexpr) changes)
     1561                         (unrename (cdr annexpr) changes)))))
     1562          (else annexpr)))
     1563 
     1564  (compute-free-vars output (lambda (free annexpr) (unrename annexpr '()))))
     1565
     1566;; Some tests to exercise the unrenamer:
     1567;;
     1568;; (let-syntax ((foo (syntax-rules () ((foo) x)))) (lambda (x y) (foo) x y))
     1569;; expands-to=> (lambda (_x_50 y) (begin x _x_50 y))
     1570;;
     1571;; (let-syntax ((foo (syntax-rules () ((foo x) (lambda (x y) z))))) (foo y))
     1572;; expands-to=> (lambda (y _y_51) z)
     1573;;
     1574;; (let-syntax ((foo (syntax-rules () ((foo x) (lambda (y x) z))))) (foo y))
     1575;; expands-to=> (lambda (y _y_51) z)
     1576
     1577
     1578;; Symbolize uses var->symbol to convert all the variables in the
     1579;; output from the expander into symbols.
     1580(define (symbolize output)
     1581  (cond ((var? output)
     1582         (var->symbol output))
     1583        ((pair? output)
     1584         (if (eq? 'quote (car output))
     1585             output
     1586             (cons (symbolize (car output))
     1587                   (symbolize (cdr output)))))
     1588        (else output)))
     1589
     1590;; Var->symbol converts a variable to a symbol.
     1591;;
     1592;; Note that there are two parts to a variable (a name and a
     1593;; location), and any two variables with the same location always have
     1594;; the same name.  The location is either a symbol or an integer.  If
     1595;; the location is a symbol, then the name is always the same symbol.
     1596;; The variables are represented by one-element or two-element vectors
     1597;; of the form #(symbolic-location) or #(name integer-location),
     1598;; e.g. #(apple) or #(cherry 17).
     1599;;
     1600;; In other words, the location is what identifies a variable, and the
     1601;; name is just additional information that was retained in order to
     1602;; help us choose, for the final expansion, a symbol that bears some
     1603;; relationship to the symbol that was used in the original code.
     1604;;
     1605;; The requirements for the var->symbol mapping are:
     1606;;
     1607;; 1. All variables must be mapped to distinct symbols.
     1608;;
     1609;; 2. No variable may be mapped to the name of a builtin.
     1610;;
     1611;; 3. Variables with symbolic locations that are the name of a
     1612;;    standard procedure must be mapped to that name, i.e. #(CAR) must
     1613;;    map to CAR.
     1614;;
     1615;; Desired additional properties are:
     1616;;
     1617;; 4. As many variables as possible should be simply mapped to their
     1618;;    names.
     1619;;
     1620;; 5. Any variables not mapped to their names should at least be
     1621;;    mapped to a symbol that includes the name as a substring of the
     1622;;    chosen name.
     1623;;
     1624;; The scheme we use is to follow these rules:
     1625;;
     1626;;    1. #(foo number) => _foo_number
     1627;;
     1628;;    2. #(foo) => foo
     1629;;       Except that:
     1630;;          (a) if foo is a builtin; or
     1631;;          (b) if foo starts with an underscore;
     1632;;       then #(foo) => _foo_
     1633;;
     1634;; Without rule 2(a), we would violate requirement 2, and without rule
     1635;; 2(b), we would violate requirement 1 (because #(foo 1) and
     1636;; #(_foo_1) would both map to _foo_1).
     1637
     1638(define (var->symbol var)
     1639  (let* ((sym (var-name var))
     1640         (str (symbol->string sym))
     1641         (loc (var-loc var)))
     1642    (if (number? loc)
     1643        (let ((n (number->string loc)))
     1644          (string->symbol (string-append "_" str "_" n)))
     1645        (if (case sym
     1646              ((begin define delay if lambda letrec quote set!) #t)
     1647              (else (and (positive? (string-length str))
     1648                         (char=? #\_ (string-ref str 0)))))
     1649            (string->symbol (string-append "_" str "_"))
     1650            sym))))
    13971651
    13981652(define builtins-store
     
    14631717              ((_ (var . args) . body)
    14641718               (define var (lambda args (let-syntax () . body))))
    1465               ((_ var init) (define var init)))))
     1719              ((_ var init) (define var init))))
     1720          ;; We put letrec here so that it can use the builtin define,
     1721          ;; and won't accidentally allow things like:
     1722          ;; (letrec (((f) 1)) (f)) => 1
     1723          (define-syntax letrec
     1724            (syntax-rules ()
     1725              ((_ ((var init) ...) . body)
     1726               ;; The lambda ensures letrec is only used for expressions.
     1727               ((lambda ()
     1728                  (let-syntax ()
     1729                    (define var init) ... (let-syntax () . body))))))))
    14661730        (define-protected-macros letrec-syntax
    1467             (if lambda quote begin define) ()
     1731            (if lambda quote begin define letrec) ()
    14681732          (define-syntax let
    14691733            (syntax-rules ()
     
    15001764                          (doloop (do-step var step ...) ...)))))))))
    15011765          (define-syntax case
    1502             (letrec-syntax 
    1503                 ((do-case 
     1766            (letrec-syntax
     1767                ((do-case
    15041768                  (syntax-rules (else)
    15051769                    ((_ (else body ...))
     
    15191783              ((_ (x => proc) . rest)
    15201784               (let ((tmp x)) (cond (tmp (proc tmp)) . rest)))
     1785              ((_ (generator guard => receiver) . rest)
     1786               (let ((tmp generator))
     1787                 (cond ((guard tmp) (receiver tmp))
     1788                       . rest) ) )
    15211789              ((_ (x . exps) . rest)
    15221790               (if x (begin . exps) (cond . rest)))))
     
    15421810                ((tail-preserving-syntax-rules
    15431811                  (syntax-rules ()
    1544                     ((_ literals
     1812                    ((tail-preserving-syntax-rules literals
    15451813                        ((subpattern ...) (subtemplate ...))
    15461814                        ...)
     
    16251893                                                           
    16261894              (syntax-rules ()
    1627                 ((_ template) (let () (qq template () template)))))))
    1628         ))))
     1895                ((_ template) (let () (qq template () template)))))))))))
    16291896
    16301897(define null-stuff (expand-top-level-forms null-prog builtins-store 0 list))
     
    16421909      (set-cdr! mstore loc-n)
    16431910      outputs)))
     1911
     1912;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
    16441913
    16451914#+compiling
  • crunch/crunch.setup

    r5137 r7161  
    1111   "crunch-syntax.scm")
    1212 '((documentation "crunch.html")
    13    (version 0.5)
     13   (version 0.6)
    1414   (syntax) ) )
    1515
Note: See TracChangeset for help on using the changeset viewer.