├── README.md
└── src
    └── main
        └── scheme
            ├── c.sls
            ├── d.sls
            └── match.sls


/README.md:
--------------------------------------------------------------------------------
  1 | Scheme-to-LLVM
  2 | =================
  3 | 
  4 | The `scheme-to-llvm` compiler is a compiler from a small subset of Scheme to
  5 | [LLVM](http://llvm.org)'s assembly form intermediate representation.  The
  6 | compiler was original developed for an invited workshop at
  7 | 2020 edition of the European Lisp Symposium:
  8 | [ELS2020](https://european-lisp-symposium.org/2020/index.html), and you can
  9 | find slides for the talk and a link to the presentation video.  The compiler is
 10 | based on a student compiler written to use the nanopass framework, but
 11 | enhanced to use some of the techniques from Chez Scheme, which is also the
 12 | host compiler.
 13 | 
 14 | Source Language
 15 | ----------------
 16 | 
 17 | ```
 18 | Expr -> <x>
 19 |       | <imm>
 20 |       | (quote <d>)
 21 |       | (if <Expr> <Expr>)
 22 |       | (if <Expr> <Expr> <Expr>)
 23 |       | (and <Expr>* ...)
 24 |       | (or <Expr>* ...)
 25 |       | (not <Expr>)
 26 |       | (set! <x> <Expr>)
 27 |       | (begin <Expr>* ... <Expr>)
 28 |       | (lambda (<x>* ...) <Expr>* ... <Expr>)
 29 |       | (let ([<x>* <Expr>*] ...) <Expr>* ... <Expr>)
 30 |       | (letrec ([<x>* <Expr>*] ...) <Expr>* ... <Expr>)
 31 |       | (<Expr> <Expr>* ...)
 32 |       | (<pr> <Expr>* ...)
 33 | ```
 34 | 
 35 | Where `x` is a variable, `imm` is an immediate, `d` is a Scheme datum in our
 36 | target language, and `pr` is a primitive.
 37 | 
 38 | - An immediate is a signed 60-bit integer (fixnum), a boolean (`#t` or `#f`),
 39 |   or null (`'()`).
 40 | - Datum is a pair of datum, a vector of datum, or an immediate
 41 | - Variables are represented as Scheme symbols.
 42 | - Primitives are also represented as Scheme symbols, though they are limited to
 43 |   the following table:
 44 | 
 45 | | *primitive*     | *arity* | *argument types*    | *return type* |
 46 | | --------------- | ------- | ------------------- | --------------|
 47 | | `+`             | 2       | fixnum, fixnum      | fixnum        |
 48 | | `-`             | 2       | fixnum, fixnum      | fixnum        |
 49 | | `*`             | 2       | fixnum, fixnum      | fixnum        |
 50 | | `cons`          | 2       | any, any            | pair          |
 51 | | `pair?`         | 1       | any                 | boolean       |
 52 | | `car`           | 1       | pair                | any           |
 53 | | `set-car!`      | 2       | pair, any           | void          |
 54 | | `cdr`           | 1       | pair                | any           |
 55 | | `set-cdr!`      | 2       | pair, any           | void          |
 56 | | `make-vector`   | 1       | fixnum              | vector        |
 57 | | `vector?`       | 1       | any                 | boolean       |
 58 | | `vector-length` | 1       | vector              | fixnum        |
 59 | | `vector-ref`    | 2       | vector, fixnum      | any           |
 60 | | `vector-set!`   | 3       | vector, fixnum, any | void          |
 61 | | `void`          | 0       |                     | void          |
 62 | | `<`             | 2       | fixnum, fixnum      | boolean       |
 63 | | `<=`            | 2       | fixnum, fixnum      | boolean       |
 64 | | `=`             | 2       | fixnum, fixnum      | boolean       |
 65 | | `>=`            | 2       | fixnum, fixnum      | boolean       |
 66 | | `>`             | 2       | fixnum, fixnum      | boolean       |
 67 | | `eq?`           | 2       | any, any            | boolean       |
 68 | | `boolean?`      | 1       | any                 | boolean       |
 69 | | `fixnum?`       | 1       | any                 | boolean       |
 70 | | `null?`         | 1       | any                 | boolean       |
 71 | | `procedure?`    | 1       | any                 | boolean       |
 72 | 
 73 | 
 74 | Building and Using the Compiler
 75 | --------------------------------
 76 | 
 77 | In order to run the compiler you need the following dependencies:
 78 | 
 79 | - LLVM w/Clang installed
 80 |   - If you have LLVM/Clang 10 installed you can use the set the parameter
 81 |     `use-llvm-10-tailcc` to `#t` to use the `tailcc` calling convention added
 82 |     in LLVM 10
 83 | - Chez Scheme: https://github.com/cisco/ChezScheme
 84 | - The nanopas framework: https://github.com/nanopass/nanopass-framework-scheme
 85 | 
 86 | With those installed, you can load compiler into Chez Scheme as follows
 87 | (assuming you are starting from the `scheme-to-llvm` directory).
 88 | 
 89 | ```
 90 | $ scheme --libdirs <path-to-nanopass-framework>:src/main/scheme
 91 | Chez Scheme Version 9.5.3
 92 | Copyright 1984-2019 Cisco Systems, Inc.
 93 | 
 94 | > (import (c))  ;; import the example compiler
 95 | > (tiny-compile
 96 |     '(letrec ([factorial (lambda (n)
 97 |                            (if (= n 0)
 98 |                                1
 99 |                                (* n (factorial (- n 1)))))])
100 |        (factorial 10)))
101 | 3628800
102 | ```
103 | 
104 | Note that under the covers the `tiny-compile` produces a file called `t.ll`,
105 | uses `clang` to compile and link this LLVM IR code into an executable in `t`.
106 | This application writes the result of the program to a temporary output file,
107 | and `tiny-compile` uses the Chez Scheme reader to pull read the result.
108 | 
109 | Testing
110 | --------
111 | 
112 | There is also a set of tests included in the compiler (originally from the
113 | student compiler), which you can run with `test-all` or `analyze-all`.
114 | `test-all` will run all of the tests until one fails, while `analyze-all` will
115 | run all of the tests and print `.` for successful tests, `F` for tests that
116 | produced the incorrect results and `E` for tests that raised an exception.
117 | Optionally `test-all` can also be passed a boolean to indicate if it should be
118 | _noisy_, which when `#t` will print each test as it begins compiling and
119 | running it.
120 | 
121 | Finally, passes can be traced with the `traced-passes` parameter, any pass that
122 | is traced will print the output produced by the pass.  `traced-passes` attempts
123 | to be flexible in specifying the passes:
124 | 
125 | - `(traced-passes 'pass-name)` will add `'pass-name` to the list of traced
126 |   passes if it is not in the list, or remove it from the list if it already is;
127 | - `(traced-passes '(pass-name1 pass-name2 ... pass-nameN))` is equivalent to
128 |   calling `trace-passes` on each `'pass-nameJ`;
129 | - `(traced-passes '())` or `(traced-passes #f)` clears all tracing;
130 | - `(traced-passes #t)` traces all passes; and
131 | - `(traced-passes)` returns the current list of passes.
132 | 
133 | You can see the full list of passes by referencing the variable `all-passes`
134 | 
135 | Source Layout
136 | --------------
137 | 
138 | The source layout is very simple in this example compiler.  All of the source
139 | code is in the `src/main/scheme` directory.  The entire compiler and tests are
140 | in the file `c.sls`.  The `parse-scheme` pass makes use of the s-expression
141 | pattern matcher defined in `match.sls`, and various parts of the compiler make
142 | use of some of the type and primitive definitions in `d.sls`.  If you look at
143 | `d.sls` you'll notice there are a number of data types and primitives not
144 | supported in the current compiler.  This was a very simple start at building a
145 | more complete Scheme implementation, but is, as of yet, unimplemented.
146 | 
147 | 


--------------------------------------------------------------------------------
/src/main/scheme/c.sls:
--------------------------------------------------------------------------------
   1 | #!chezscheme
   2 | (library (c)
   3 |   (export
   4 |     datum?
   5 |     make-var var var? var-name var-unique-name var-flags var-flags-referenced?
   6 |     var-flags-referenced-set! var-flags-assigned? var-flags-assigned-set!
   7 |     var-flags-multiply-referenced? var-flags-multiply-referenced-set!
   8 |     var-flags-multiply-assigned? var-flags-multiply-assigned-set!
   9 |     Lsrc unparse-Lsrc parse-Lsrc
  10 |     parse-scheme
  11 |     Ldatum unparse-Ldatum 
  12 |     convert-complex-datum
  13 |     uncover-assigned!
  14 |     Lletrec unparse-Lletrec
  15 |     purify-letrec
  16 |     Lno-assign unparse-Lno-assign
  17 |     convert-assignments
  18 |     optimize-direct-call
  19 |     remove-anonymous-lambda
  20 |     Lsanitized unparse-Lsanitized
  21 |     sanitize-binding-forms
  22 |     Lfree unparse-Lfree
  23 |     uncover-free
  24 |     make-label label label? label-name label-unique-name label-slot label-slot-set!
  25 |     make-local-label local-label?
  26 |     Lclosure unparse-Lclosure
  27 |     convert-closures
  28 |     optimize-known-call
  29 |     introduce-procedure-primitives
  30 |     Llifted unparse-Llifted
  31 |     lift-letrec
  32 |     Lnormalized unparse-Lnormalized
  33 |     normalize-context
  34 |     Lrep unparse-Lrep
  35 |     specify-representation
  36 |     Llocals unparse-Llocals
  37 |     uncover-locals
  38 |     Lno-let unparse-Lno-let
  39 |     remove-let
  40 |     Lsimple-opnd unparse-Lsimple-opnd
  41 |     remove-complex-opera*
  42 |     Lflat-set! unparse-Lflat-set!
  43 |     flatten-set!
  44 |     Lbb unparse-Lbb
  45 |     expose-basic-blocks
  46 |     optimize-blocks-reorders
  47 |     optimize-blocks
  48 |     Lssa unparse-Lssa
  49 |     convert-to-ssa
  50 |     Lflat-funcs unparse-Lflat-funcs
  51 |     flatten-functions
  52 |     generate-llvm-code
  53 |     tiny-compile
  54 |     all-passes
  55 |     traced-passes
  56 |     tests
  57 |     test-all
  58 |     analyze-all
  59 |     use-llvm-10-tailcc
  60 |     )
  61 |   (import (except (rnrs) with-output-to-file current-output-port flush-output-port)
  62 |           (nanopass)
  63 |           ;; for experimental testing only
  64 |           ; (except (nanopass) define-language)
  65 |           ; (rename (nanopass exp-syntax) (define-language-exp define-language))
  66 |           (match) (d)
  67 |     (only (chezscheme) trace-define trace-define-syntax trace-let trace-lambda
  68 |           format enumerate iota errorf fluid-let module with-implicit datum
  69 |           trace-define-syntax make-list printf pretty-print make-parameter
  70 |           void parameterize with-output-to-file current-output-port system eval flush-output-port))
  71 | 
  72 |   (define use-llvm-10-tailcc (make-parameter #f (lambda (x) (and x #t))))
  73 | 
  74 |   ;;; helpers for the scheme-dependent portion of the compiler
  75 |   (define word-shift 3) ; 64-bit words
  76 |   (define word-size (expt 2 word-shift))
  77 | 
  78 |   (define fixnum-bits 61)
  79 |   (define shift-fixnum 3)
  80 |   (define mask-fixnum #b111)
  81 |   (define tag-fixnum #b000)
  82 | 
  83 |   (define mask-pair #b111)
  84 |   (define tag-pair #b001)
  85 |   (define size-pair 16)
  86 |   (define disp-car 0)
  87 |   (define disp-cdr 8)
  88 | 
  89 |   (define mask-vector #b111)
  90 |   (define tag-vector  #b011)
  91 |   (define disp-vector-length 0)
  92 |   (define disp-vector-data 8)
  93 | 
  94 |   (define mask-procedure #b111)
  95 |   (define tag-procedure  #b010)
  96 |   (define disp-procedure-code 0)
  97 |   (define disp-procedure-data 8)
  98 | 
  99 |   (define mask-boolean   #b11110111)
 100 |   (define tag-boolean    #b00000110)
 101 | 
 102 |   (define $false         #b00000110)
 103 |   (define $true          #b00001110)
 104 |   (define $nil           #b00010110)
 105 |   (define $void          #b00011110)
 106 | 
 107 |   (define fixnum-range?
 108 |     (lambda (n)
 109 |       (<= (- (expt 2 (- fixnum-bits 1)))
 110 |           n
 111 |           (- (expt 2 (- fixnum-bits 1)) 1))))
 112 | 
 113 |   (define datum? (lambda (x) (datatype? x)))
 114 | 
 115 |   ;; utility for keeping our begins flat
 116 |   (define-syntax define-begin-builder
 117 |     (lambda (x)
 118 |       (syntax-case x (begin unquote)
 119 |         [(_ name [(lang nt) (begin ,e* dots ,e)])
 120 |          (eq? (datum dots) '...)
 121 |          #'(define-pass name : (lang nt) (e* e) -> (lang nt) ()
 122 |              (definitions
 123 |                (define (E* e* flat-e*)
 124 |                  (let f ([e* e*])
 125 |                    (if (null? e*)
 126 |                        flat-e*
 127 |                        (let ([e (car e*)] [e* (cdr e*)])
 128 |                          (nt e (f e*)))))))
 129 |              (nt : nt (ir flat-e*) -> * (flat-e*)
 130 |                [(begin ,e* (... ...) ,e) (E* e* (nt e flat-e*))]
 131 |                [else (cons ir flat-e*)])
 132 |              (let ([flat-e* (E* e* (nt e '()))])
 133 |                (let loop ([e (car flat-e*)] [e* (cdr flat-e*)] [re* '()])
 134 |                  (if (null? e*)
 135 |                      (if (null? re*)
 136 |                          e
 137 |                          (with-output-language (lang nt)
 138 |                            `(begin ,(reverse re*) (... ...) ,e)))
 139 |                      (loop (car e*) (cdr e*) (cons e re*))))))]
 140 |         [(_ name [(ef-lang ef-nt) (begin ,ef0* dots0 ,ef)] [(x-lang x-nt) (begin ,ef1* dots1 ,x)])
 141 |          (and (eq? (datum dots0) '...) (eq? (datum dots1) '...))
 142 |          #'(define-pass name : (ef-lang ef-nt) (ef* x) -> (x-lang x-nt) ()
 143 |              (definitions
 144 |                (define (Ef* ef* flat-ef*)
 145 |                  (let f ([ef* ef*])
 146 |                    (if (null? ef*)
 147 |                        flat-ef*
 148 |                        (ef-nt (car ef*) (f (cdr ef*)))))))
 149 |              (ef-nt : ef-nt (ir flat-ef*) -> * (flat-ef*)
 150 |                [(begin ,ef0* (... ...) ,ef) (Ef* ef0* (ef-nt ef flat-ef*))]
 151 |                [else (cons ir flat-ef*)])
 152 |              (x-nt : x-nt (ir) -> x-nt (ef*)
 153 |                [(begin ,ef1* (... ...) ,[x flat-ef*])
 154 |                 (values x (Ef* ef1* flat-ef*))]
 155 |                [else (values ir '())])
 156 |              (let-values ([(x flat-ef*) (x-nt x)])
 157 |                (let ([flat-ef* (Ef* ef* flat-ef*)])
 158 |                  (if (null? flat-ef*)
 159 |                      x
 160 |                      (with-output-language (x-lang x-nt)
 161 |                        `(begin ,flat-ef* (... ...) ,x))))))])))
 162 | 
 163 |   (define-record-type var
 164 |     (nongenerative)
 165 |     (fields name (mutable unique-name $var-unique-name var-unique-name-set!) (mutable flags) (mutable slot))
 166 |     (protocol
 167 |       (lambda (new)
 168 |         (lambda (name)
 169 |           (new (if (var? name) (var-name name) name) #f 0 #f)))))
 170 | 
 171 |   (define var-unique-name
 172 |     (let ([c 0])
 173 |       (lambda (x)
 174 |         (or ($var-unique-name x)
 175 |             (let ([un (string->symbol (format "~s.~s" (var-name x) c))])
 176 |               (set! c (fx+ c 1))
 177 |               (var-unique-name-set! x un)
 178 |               un)))))
 179 | 
 180 |   (define-syntax define-flags-field
 181 |     (lambda (x)
 182 |       (define format-id
 183 |         (lambda (tid fmt . args)
 184 |           (datum->syntax tid
 185 |             (string->symbol
 186 |               (apply format fmt (map syntax->datum args))))))
 187 |       (syntax-case x ()
 188 |         [(_ dt fld flags ...)
 189 |          (with-syntax ([getter (format-id #'dt "~s-~s" #'dt #'fld)]
 190 |                        [setter (format-id #'dt "~s-~s-set!" #'dt #'fld)]
 191 |                        [(index ...) (enumerate #'(flags ...))]
 192 |                        [(flag-getter* ...) (map (lambda (flag) (format-id #'dt "~s-~s-~s?" #'dt #'fld flag)) #'(flags ...))]
 193 |                        [(flag-setter* ...) (map (lambda (flag) (format-id #'dt "~s-~s-~s-set!" #'dt #'fld flag)) #'(flags ...))]
 194 |                        [bitset? (if (< (length #'(flags ...)) (- (fixnum-width) 1)) #'fxbit-set? #'bitwise-bit-set?)]
 195 |                        [bitcopy (if (< (length #'(flags ...)) (- (fixnum-width) 1)) #'fxcopy-bit #'bitwise-copy-bit)])
 196 |            #'(begin
 197 |                (define flag-getter*
 198 |                  (lambda (x)
 199 |                    (bitset? (getter x) index)))
 200 |                ...
 201 |                (define flag-setter*
 202 |                  (lambda (x set?)
 203 |                    (setter x (bitcopy (getter x) index (if set? 1 0)))))
 204 |                ...))])))
 205 | 
 206 |   (define-flags-field var flags referenced assigned multiply-referenced multiply-assigned)
 207 | 
 208 |   (define-language Lsrc
 209 |     (terminals
 210 |       (datum (d))
 211 |       (var (x)) => var-unique-name
 212 |       (primitive-info (pr)) => primitive-info-name)
 213 |     (Expr (e)
 214 |       x
 215 |       (quote d)
 216 |       (if e0 e1 e2)
 217 |       (begin e* ... e)
 218 |       (set! x e)
 219 |       (lambda (x* ...) e)
 220 |       (let ([x* e*] ...) e)
 221 |       (letrec ([x* e*] ...) e)
 222 |       (callable e* ...))
 223 |     (Callable (callable)
 224 |       e
 225 |       pr))
 226 | 
 227 |   (define-parser parse-Lsrc Lsrc)
 228 | 
 229 |   (define void-pr (primitive->primitive-info 'void))
 230 |   (define cons-pr (primitive->primitive-info 'cons))
 231 |   (define car-pr (primitive->primitive-info 'car))
 232 |   (define set-car!-pr (primitive->primitive-info 'set-car!))
 233 | 
 234 |   (define-pass parse-scheme : * (ir) -> Lsrc ()
 235 |     (definitions
 236 |       (module (empty-env extend-env extend-var-env extend-var-env* extend-primitive-syntax extend-primitive-syntax* apply-env)
 237 |         (define (empty-env) '())
 238 |         (define primitive->primitive-transformer
 239 |           (let ()
 240 |             (define t* '())
 241 |             (lambda (x)
 242 |               (cond
 243 |                 [(assq x t*) => cdr]
 244 |                 [else (let ([t (let ([info (primitive->primitive-info x)])
 245 |                                  (case-lambda [(env x)
 246 |                                    (match x
 247 |                                      [,sym (guard (symbol? sym)) (errorf who "primitives are currently only supported in call position")]
 248 |                                      [(,pr ,e* ...)
 249 |                                       (unless (eq? (primitive-info-name info) pr) (errorf who "attempting to apply primitive transformer for ~s to call of ~s" (primitive-info-name info) pr))
 250 |                                       (unless (arity-matches? info e*) (errorf who "incorrect number of arguments ~s" (length e*)))
 251 |                                       (with-output-language (Lsrc Expr) `(,info ,(parse* e* env) ...))]
 252 |                                      [(set! ,x ,e) (errorf who "primitives are immutable, ~s cannot be modified with set!" x)]
 253 |                                      [,x (errorf who "unexpected syntax ~s" x)])]
 254 |                                               [any (errorf who "got ~s arguments ~s, expected 2" (length any) any)]))])
 255 |                         (set! t* (cons (cons x t) t*))
 256 |                         t)]))))
 257 |         (define-syntax extend-primitive-syntax
 258 |           (lambda (x)
 259 |             (define (rewrite-rest rest)
 260 |               (syntax-case rest ()
 261 |                 [() rest]
 262 |                 [dots (eq? (datum dots) '...) #'dots]
 263 |                 [id (identifier? #'id) #',id]
 264 |                 [(a . d) (with-syntax ([a (rewrite-rest #'a)] [d (rewrite-rest #'d)]) #'(a . d))]))
 265 |             (define process-cl 
 266 |               (lambda (name)
 267 |                 (with-syntax ([name name])
 268 |                   (lambda (cl)
 269 |                     (syntax-case cl (set!)
 270 |                       [[id . body]
 271 |                        (identifier? #'id)
 272 |                        #'[,sym (guard (eq? sym 'name)) . body]]
 273 |                       [[(set! x e) . body]
 274 |                        (and (identifier? #'x) (identifier? #'e))
 275 |                        #'[(set! ,x ,e) (guard (eq? x 'name)) . body]]
 276 |                       [[(_ . rest) . body]
 277 |                        (with-syntax ([rest (rewrite-rest #'rest)])
 278 |                          #'[(name . rest) . body])])))))
 279 |             (syntax-case x ()
 280 |               [(k name ct-env cl* ...)
 281 |                (with-implicit (k env)
 282 |                  (with-syntax ([(cl* ...) (map (process-cl #'name) #'(cl* ...))])
 283 |                    #'(extend-env ct-env 'name
 284 |                        (lambda (env x)
 285 |                          (match x
 286 |                            cl* ...
 287 |                            [else (errorf who "invalid syntax ~s" x)])))))])))
 288 |         (define-syntax extend-primitive-syntax*
 289 |           (lambda (x)
 290 |             (syntax-case x ()
 291 |               [(k ct-env) #'ct-env]
 292 |               [(k ct-env [name cl* ...] . rest)
 293 |                (with-implicit (k extend-primitive-syntax extend-primitive-syntax*)
 294 |                  #'(extend-primitive-syntax name (extend-primitive-syntax* ct-env . rest) cl* ...))])))
 295 |         (define (make-var-transformer sym var)
 296 |           (lambda (env x)
 297 |             (with-output-language (Lsrc Expr)
 298 |               (match x
 299 |                 [,id (guard (eq? id sym)) var]
 300 |                 [(,id ,e* ...) (guard (eq? id sym)) `(,var ,(parse* e* env) ...)]
 301 |                 [(set! ,id ,e) (guard (eq? id sym)) `(set! ,var ,(parse e env))]
 302 |                 [else (errorf who "invalid syntax ~s" x)]))))
 303 |         (define (apply-env env x)
 304 |           (cond
 305 |             [(assq x env) => cdr]
 306 |             [(primitive? x) (primitive->primitive-transformer x)]
 307 |             [else (errorf who "~s is unbound" x)]))
 308 |         (define (extend-env env x transformer) (cons (cons x transformer) env))
 309 |         (define (extend-var-env env x var) (extend-env env x (make-var-transformer x var)))
 310 |         (define (extend-var-env* env x* var*) (fold-left extend-var-env env x* var*)))
 311 |       (with-output-language (Lsrc Expr)
 312 |         (define (make-begin e* e)
 313 |           (if (null? e*)
 314 |               e
 315 |               `(begin ,e* ... ,e)))
 316 |         (define initial-env
 317 |           (extend-primitive-syntax* (empty-env)
 318 |             (quote [(_ d) (unless (datum? d) (errorf who "expected datum, but got ~s" d)) `(quote ,d)])
 319 |             (if
 320 |               [(_ e0 e1) `(if ,(parse e0 env) ,(parse e1 env) (,void-pr))]
 321 |               [(_ e0 e1 e2) `(if ,(parse e0 env) ,(parse e1 env) ,(parse e2 env))])
 322 |             (and
 323 |               [(_) `(quote #t)]
 324 |               [(_ e) (parse e env)]
 325 |               [(_ e0 e1 . e*) `(if ,(parse e0 env) ,(parse (cons* 'and e1 e*) env) (quote #f))])
 326 |             (or
 327 |               [(_) `(quote #f)]
 328 |               [(_ e) (parse e env)]
 329 |               [(_ e0 e1 . e*)
 330 |                (let ([t (make-var 't)])
 331 |                  `(let ([,t ,(parse e0 env)])
 332 |                     (if ,t ,t ,(parse (cons* 'or e1 e*) env))))])
 333 |             (not
 334 |               [(_ e) `(if ,(parse e env) (quote #f) (quote #t))])
 335 |             (begin
 336 |               [(_ e* ... e) (make-begin (parse* e* env) (parse e env))])
 337 |             (lambda
 338 |               [(_ (x* ...) e* ... e)
 339 |                (let ([v* (map make-var x*)])
 340 |                  (let ([env (extend-var-env* env x* v*)])
 341 |                    `(lambda (,v* ...) ,(make-begin (parse* e* env) (parse e env)))))])
 342 |             (let
 343 |               [(_ ([x0* e0*] ...) e* ... e)
 344 |                (let ([v0* (map make-var x0*)])
 345 |                  (let ([e0* (parse* e0* env)])
 346 |                    (let ([env (extend-var-env* env x0* v0*)])
 347 |                      `(let ([,v0* ,e0*] ...) ,(make-begin (parse* e* env) (parse e env))))))])
 348 |             (letrec
 349 |               [(_ ([x0* e0*] ...) e* ... e)
 350 |                (let ([v0* (map make-var x0*)])
 351 |                  (let ([env (extend-var-env* env x0* v0*)])
 352 |                    `(letrec ([,v0* ,(parse* e0* env)] ...)
 353 |                       ,(make-begin (parse* e* env) (parse e env)))))])
 354 |             (set!
 355 |               [(_ x e)
 356 |                (let ([t (apply-env env x)])
 357 |                  (t env (list 'set! x e)))]))))
 358 |       (define (parse* e* env) (map (lambda (e) (parse e env)) e*)))
 359 |     (parse : * (x env) -> Expr ()
 360 |       (match x
 361 |         [,imm (guard (immediate? imm)) `(quote ,imm)]
 362 |         [,sym (guard (symbol? sym)) ((apply-env env sym) env x)]
 363 |         [(,sym . ,e*) (guard (symbol? sym)) ((apply-env env sym) env x)]
 364 |         [(,[e] ,[e*] ...) `(,e ,e* ...)]
 365 |         [else (errorf who "expected Expr, but got ~s" x)]))
 366 |     (parse ir initial-env))
 367 | 
 368 |   (define-language Ldatum
 369 |     (extends Lsrc)
 370 |     (terminals
 371 |       (- (datum (d)))
 372 |       (+ (immediate (i))))
 373 |     (Expr (e)
 374 |       (- (quote d))
 375 |       (+ (quote i))))
 376 | 
 377 |   (define-pass convert-complex-datum : Lsrc (ir) -> Ldatum ()
 378 |     (definitions
 379 |       (define datum-var*)
 380 |       (define datum-e*)
 381 |       (define build-prim
 382 |         (lambda (prim)
 383 |           (primitive->primitive-info prim)))
 384 |       (with-output-language (Ldatum Expr)
 385 |         (define build-let
 386 |           (lambda (x* e* e)
 387 |             (if (null? x*)
 388 |                 e
 389 |                 `(let ([,x* ,e*] ...) ,e))))
 390 |         (define build-begin
 391 |           (lambda (e* e)
 392 |             (if (null? e*)
 393 |                 e
 394 |                 `(begin ,e* ... ,e))))
 395 |         (define build-lambda
 396 |           (lambda (x* e)
 397 |             `(lambda (,x* ...) ,e)))
 398 |         (define convert-datum
 399 |           (lambda (d)
 400 |             (cond
 401 |               [(pair? d)
 402 |                (let ([var-a (make-var 'tmp-a)]
 403 |                      [var-d (make-var 'tmp-d)]
 404 |                      [e-a (convert-datum (car d))]
 405 |                      [e-d (convert-datum (cdr d))])
 406 |                  (build-let (list var-a var-d) (list e-a e-d) `(,(build-prim 'cons) ,var-a ,var-d)))]
 407 |               [(vector? d)
 408 |                (let ([n (vector-length d)])
 409 |                  (let ([i* (iota n)])
 410 |                    (let ([t* (map (lambda (i) (make-var (string->symbol (format "tmp-~s" i)))) i*)]
 411 |                          [e* (map (lambda (d) (convert-datum d)) (vector->list d))]
 412 |                          [t (make-var 'tmp-v)])
 413 |                      (build-let t* e*
 414 |                        (build-let (list t) (list `(,(build-prim 'make-vector) ',n))
 415 |                          (build-begin
 416 |                            (map (lambda (ti i) `(,(build-prim 'vector-set!) ,t ',i ,ti)) t* i*)
 417 |                            t))))))]
 418 |               [(immediate? d) `(quote ,d)])))))
 419 |     (Expr : Expr (ir) -> Expr ()
 420 |       [(quote ,d)
 421 |        (if (immediate? d)
 422 |            `(quote ,d)
 423 |            (let ([var (make-var 'tmp)] [e (convert-datum d)])
 424 |              (set! datum-var* (cons var datum-var*))
 425 |              (set! datum-e* (cons e datum-e*))
 426 |              var))])
 427 |     (fluid-let ([datum-var* '()] [datum-e* '()])
 428 |       (let ([ir (Expr ir)])
 429 |         (build-let datum-var* datum-e* ir))))
 430 | 
 431 |   ;; NB: the following pass should not need to return anything, but the current
 432 |   ;; framework makes it easier if it does.
 433 |   (define-pass uncover-assigned! : Ldatum (ir) -> Ldatum ()
 434 |     (Expr : Expr (ir) -> Expr ()
 435 |       [(set! ,x ,[e]) (var-flags-assigned-set! x #t) ir]))
 436 | 
 437 |   (define-language Lletrec
 438 |     (extends Ldatum)
 439 |     (Expr (e)
 440 |       (- (lambda (x* ...) e)
 441 |          (letrec ([x* e*] ...) e))
 442 |       (+ f
 443 |          (letrec ([x* f*] ...) e)))
 444 |     (Lambda (f)
 445 |       (+ (lambda (x* ...) e))))
 446 |          
 447 |   (define-pass purify-letrec : Ldatum (ir) -> Lletrec ()
 448 |     (Expr : Expr (ir) -> Expr ()
 449 |       (definitions
 450 |         (define (build-let x* e* body)
 451 |           (if (null? x*)
 452 |               body
 453 |               `(let ([,x* ,e*] ...) ,body)))
 454 |         (define (build-letrec x* f* body)
 455 |           (if (null? x*)
 456 |               body
 457 |               `(letrec ([,x* ,f*] ...) ,body)))
 458 |         (define (build-set! x* e* body)
 459 |           (if (null? x*)
 460 |               body
 461 |               (let ([ef* (map (lambda (x e) `(set! ,x ,e)) x* e*)])
 462 |                 `(begin ,ef* ... ,body)))))
 463 |       [(letrec ([,x* ,e*] ...) ,[e])
 464 |        (let loop ([tx* x*] [e* e*] [xs* '()] [es* '()] [xl* '()] [el* '()] [xc* '()] [ec* '()])
 465 |          (if (null? tx*)
 466 |              (build-let xs* es*
 467 |                (build-letrec xl* el*
 468 |                  (build-let xc* (make-list (length ec*) `(,void-pr))
 469 |                    (build-set! xc* ec* e))))
 470 |              (let ([x (car tx*)] [e (car e*)])
 471 |                (cond
 472 |                  [(var-flags-assigned? x)
 473 |                   (loop (cdr tx*) (cdr e*) xs* es* xl* el* (cons x xc*) (cons (Expr e) ec*))]
 474 |                  [(lambda-expr? e)
 475 |                   (loop (cdr tx*) (cdr e*) xs* es* (cons x xl*) (cons (Expr e) el*) xc* ec*)]
 476 |                  [(simple-expr? e)
 477 |                   (loop (cdr tx*) (cdr e*) (cons x xs*) (cons (Expr e) es*) xl* el* xc* ec*)]
 478 |                  [else
 479 |                   (var-flags-assigned-set! x #t) ;; we made an unassigned variable assigned, mark it.
 480 |                   (loop (cdr tx*) (cdr e*) xs* es* xl* el* (cons x xc*) (cons (Expr e) ec*))]))))])
 481 |     (lambda-expr? : Expr (ir) -> * (boolean)
 482 |       [(lambda (,x* ...) ,e) #t]
 483 |       [else #f])
 484 |     (simple-expr? : Expr (ir) -> * (boolean)
 485 |       [(quote ,i) #t]
 486 |       [,x (not (var-flags-assigned? x))]
 487 |       [(begin ,e* ... ,e) (and (for-all simple-expr? e*) (simple-expr? e))]
 488 |       [(if ,e0 ,e1 ,e2) (and (simple-expr? e0) (simple-expr? e1) (simple-expr? e2))]
 489 |       [(,pr ,e* ...) (and (pure-primitive? pr) (for-all simple-expr? e*))]
 490 |       [else #f]))
 491 | 
 492 |   (define-language Lno-assign
 493 |     (extends Lletrec)
 494 |     (Expr (e)
 495 |       (- (set! x e))))
 496 | 
 497 |   (define-pass convert-assignments : Lletrec (ir) -> Lno-assign ()
 498 |     (definitions
 499 |       (define with-assigned
 500 |         (lambda (x* f)
 501 |           (let loop ([x* x*] [rx* '()] [rassigned-x* '()] [rnew-x* '()])
 502 |             (if (null? x*)
 503 |                 (if (null? rassigned-x*)
 504 |                     (f (reverse rx*))
 505 |                     (f (reverse rx*) (reverse rassigned-x*) (reverse rnew-x*)))
 506 |                 (let ([x (car x*)] [x* (cdr x*)])
 507 |                   (if (var-flags-assigned? x)
 508 |                       (let ([new-x (make-var x)])
 509 |                         (loop x* (cons new-x rx*) (cons x rassigned-x*) (cons new-x rnew-x*)))
 510 |                       (loop x* (cons x rx*) rassigned-x* rnew-x*)))))))
 511 |       (define convert-bindings
 512 |         (lambda (x* e)
 513 |           (with-assigned x*
 514 |             (case-lambda
 515 |               [(x*) (values x* (Expr e))]
 516 |               [(x* assigned-x* new-x*)
 517 |                (values x*
 518 |                  (with-output-language (Lno-assign Expr)
 519 |                    (let ([pr* (map (lambda (new-x) `(,cons-pr ,new-x (,void-pr))) new-x*)])
 520 |                      `(let ([,assigned-x* ,pr*] ...)
 521 |                         ,(Expr e)))))])))))
 522 |     (Lambda : Lambda (ir) -> Lambda ()
 523 |       [(lambda (,x* ...) ,e)
 524 |        (let-values ([(x* e) (convert-bindings x* e)])
 525 |          `(lambda (,x* ...) ,e))])
 526 |     (Expr : Expr (ir) -> Expr ()
 527 |       [,x (if (var-flags-assigned? x) `(,car-pr ,x) x)]
 528 |       [(set! ,x ,[e]) `(,set-car!-pr ,x ,e)]
 529 |       [(let ([,x* ,[e*]] ...) ,e)
 530 |        (let-values ([(x* e) (convert-bindings x* e)])
 531 |          `(let ([,x* ,e*] ...) ,e))]))
 532 | 
 533 |   (define-pass optimize-direct-call : Lno-assign (ir) -> Lno-assign ()
 534 |     (Expr : Expr (ir) -> Expr ()
 535 |       [((lambda (,x* ...) ,[e]) ,[e* -> e*] ...)
 536 |        (guard (fx=? (length x*) (length e*)))
 537 |        `(let ([,x* ,e*] ...) ,e)]))
 538 | 
 539 |   (define-pass remove-anonymous-lambda : Lno-assign (ir) -> Lno-assign ()
 540 |     (Expr : Expr (ir [needs-name? #t] [maybe-name #f]) -> Expr ()
 541 |       [,f (if needs-name?
 542 |               (let ([t (make-var (or maybe-name 'anon))]) `(letrec ([,t ,(Lambda f)]) ,t))
 543 |               (Lambda f))]
 544 |       [(let ([,x* ,e*] ...) ,e)
 545 |        (let ([e* (map (lambda (x e) (Expr e #f x)) x* e*)] [e (Expr e #t maybe-name)])
 546 |          `(let ([,x* ,e*] ...) ,e))])
 547 |     (Lambda : Lambda (ir) -> Lambda ()))
 548 | 
 549 |   (define-language Lsanitized
 550 |     (extends Lno-assign)
 551 |     (Expr (e)
 552 |       (- f)))
 553 | 
 554 |   (define-pass sanitize-binding-forms : Lno-assign (ir) -> Lsanitized ()
 555 |     (Expr : Expr (ir) -> Expr ()
 556 |       (definitions
 557 |         (define build-letrec
 558 |           (lambda (x* f* e)
 559 |             (if (null? x*)
 560 |                 e
 561 |                 `(letrec ([,x* ,f*] ...) ,e))))
 562 |         (define build-let
 563 |           (lambda (x* e* e)
 564 |             (if (null? x*)
 565 |                 e
 566 |                 `(let ([,x* ,e*] ...) ,e)))))
 567 |       [(let ([,x* ,e*] ...) ,[e])
 568 |        (let loop ([x* x*] [e* e*] [rlet-x* '()] [rlet-e* '()] [rrec-x* '()] [rrec-f* '()])
 569 |          (if (null? x*)
 570 |              (build-letrec (reverse rrec-x*) (reverse rrec-f*)
 571 |                (build-let (reverse rlet-x*) (reverse rlet-e*) e))
 572 |              (nanopass-case (Lno-assign Expr) (car e*)
 573 |                [,f (loop (cdr x*) (cdr e*) rlet-x* rlet-e* (cons (car x*) rrec-x*) (cons (Lambda f) rrec-f*))]
 574 |                [else (loop (cdr x*) (cdr e*) (cons (car x*) rlet-x*) (cons (Expr (car e*)) rlet-e*) rrec-x* rrec-f*)])))])
 575 |     (Lambda : Lambda (ir) -> Lambda ()))
 576 | 
 577 |   (define-language Lfree
 578 |     (extends Lsanitized)
 579 |     (Lambda (f)
 580 |       (- (lambda (x* ...) e))
 581 |       (+ (lambda (x* ...) frbody)))
 582 |     (FreeBody (frbody)
 583 |       (+ (free (x* ...) e))))
 584 | 
 585 |   (define-pass uncover-free : Lsanitized (ir) -> Lfree ()
 586 |     (definitions
 587 |       (define-record-type fv-info
 588 |         (nongenerative)
 589 |         (fields lid (mutable mask) (mutable fv*))
 590 |         (protocol
 591 |           (lambda (new)
 592 |             (lambda (index)
 593 |               (new index 0 '())))))
 594 |       (define (record-ref! x info)
 595 |         (let ([idx (var-slot x)])
 596 |           (unless idx (errorf who "~s referenced without being bound" (var-name x)))
 597 |           (when (fx<? idx (fv-info-lid info))
 598 |             (let ([mask (fv-info-mask info)])
 599 |               (unless (bitwise-bit-set? mask idx)
 600 |                 (fv-info-mask-set! info (bitwise-copy-bit mask idx 1))
 601 |                 (fv-info-fv*-set! info (cons x (fv-info-fv* info))))))))
 602 |       (define (set-offsets! x* index)
 603 |         (fold-left (lambda (index x) (var-slot-set! x index) (fx+ index 1)) index x*))
 604 |       (define ($with-offsets index x* p)
 605 |         (let ([index (set-offsets! x* index)])
 606 |           (let ([v (p index)])
 607 |             (for-each (lambda (x) (var-slot-set! x #f)) x*)
 608 |             v)))
 609 |       (define-syntax with-offsets
 610 |         (lambda (x)
 611 |           (syntax-case x ()
 612 |             [(_ (index ?x*) ?e ?es ...)
 613 |              (identifier? #'index)
 614 |              #'($with-offsets index ?x* (lambda (index) ?e ?es ...))]))))
 615 |     (Callable : Callable (e index fv-info) -> Callable ())
 616 |     (Expr : Expr (e index fv-info) -> Expr ()
 617 |       [,x (record-ref! x fv-info) x]
 618 |       [(let ([,x* ,[e*]] ...) ,e)
 619 |        (with-offsets (index x*)
 620 |          `(let ([,x* ,e*] ...) ,(Expr e index fv-info)))]
 621 |       [(letrec ([,x* ,f*] ...) ,e)
 622 |        (with-offsets (index x*)
 623 |          (let ([f* (map (lambda (f) (Lambda f index fv-info)) f*)]
 624 |                [e (Expr e index fv-info)])
 625 |            `(letrec ([,x* ,f*] ...) ,e)))])
 626 |     (Lambda : Lambda (e index outer-fv-info) -> Lambda ()
 627 |       [(lambda (,x* ...) ,e)
 628 |        (let ([fv-info (make-fv-info index)])
 629 |          (with-offsets (index x*)
 630 |            (let ([e (Expr e index fv-info)])
 631 |              (let ([fv* (fv-info-fv* fv-info)])
 632 |                (for-each (lambda (fv) (record-ref! fv outer-fv-info)) fv*)
 633 |                `(lambda (,x* ...) (free (,fv* ...) ,e))))))])
 634 |     (Expr ir 0 (make-fv-info 0)))
 635 | 
 636 |   (define-record-type label
 637 |     (nongenerative)
 638 |     (fields name (mutable unique-name $label-unique-name label-unique-name-set!) (mutable slot))
 639 |     (protocol
 640 |       (lambda (new)
 641 |         (lambda (name)
 642 |           (cond
 643 |             [(symbol? name) (new name #f #f)]
 644 |             [(string? name) (new (string->symbol name) #f #f)]
 645 |             [(var? name) (new (var-name name) #f #f)])))))
 646 | 
 647 |   (define-record-type local-label
 648 |     (nongenerative)
 649 |     (parent label)
 650 |     (protocol
 651 |       (lambda (pargs->new)
 652 |         (lambda (name)
 653 |           ((pargs->new name))))))
 654 | 
 655 |   (define label-unique-name
 656 |     (let ([c 0])
 657 |       (lambda (l)
 658 |         (or ($label-unique-name l)
 659 |             (let ([un (string->symbol (format "~s$~s" (label-name l) c))])
 660 |               (set! c (fx+ c 1))
 661 |               (label-unique-name-set! l un)
 662 |               un)))))
 663 | 
 664 |   (define-language Lclosure
 665 |     (extends Lfree)
 666 |     (terminals
 667 |       (+ (label (l)) => label-unique-name))
 668 |     (Expr (e)
 669 |       (- (letrec ([x* f*] ...) e))
 670 |       (+ l
 671 |          (letrec ([l* f*] ...) clbody)))
 672 |     (ClosureBody (clbody)
 673 |       (+ (closures ([x* l* x** ...] ...) e)))
 674 |     (Lambda (f)
 675 |       (- (lambda (x* ...) frbody))
 676 |       (+ (lambda (x* ...) bfrbody)))
 677 |     (FreeBody (frbody)
 678 |       (- (free (x* ...) e)))
 679 |     (BindFreeBody (bfrbody)
 680 |       (+ (bind-free (x x* ...) e))))
 681 | 
 682 |   (define-pass convert-closures : Lfree (ir) -> Lclosure ()
 683 |     (Expr : Expr (e) -> Expr ()
 684 |       [(letrec ([,x* ,[f* free**]] ...) ,[e])
 685 |        (let ([l* (map make-label x*)])
 686 |          `(letrec ([,l* ,f*] ...)
 687 |             (closures ([,x* ,l* ,free** ...] ...) ,e)))]
 688 |       [(,x ,[e*] ...) `(,x ,x ,e* ...)]
 689 |       [(,pr ,[e*] ...) `(,pr ,e* ...)]
 690 |       [(,[e] ,[e*] ...)
 691 |        (let ([t (make-var 'proc)])
 692 |          `(let ([,t ,e]) (,t ,t ,e* ...)))])
 693 |     (Lambda : Lambda (f) -> Lambda (x*)
 694 |       [(lambda (,x* ...) (free (,x0* ...) ,[e]))
 695 |        (let ([cp (make-var 'cp)])
 696 |          (values `(lambda (,cp ,x* ...) (bind-free (,cp ,x0* ...) ,e)) x0*))]
 697 |       ;; NB: should be unnecessary
 698 |       [(lambda (,x* ...) ,frbody) (errorf who "unreachable")]))
 699 | 
 700 |   (define-pass optimize-known-call : Lclosure (ir) -> Lclosure ()
 701 |     (Lambda : Lambda (f) -> Lambda ())
 702 |     (Expr : Expr (ir) -> Expr ()
 703 |       [(,x ,[e*] ...)
 704 |        (cond
 705 |          [(var-slot x) => (lambda (l) `(,l ,e* ...))]
 706 |          [else `(,x ,e* ...)])]
 707 |       [(letrec ([,l0* ,f*] ...)
 708 |          (closures ([,x* ,l* ,x** ...] ...) ,e))
 709 |        (for-each (lambda (x l) (var-slot-set! x l)) x* l*)
 710 |        (let ([f* (map Lambda f*)] [e (Expr e)])
 711 |          (for-each (lambda (x) (var-slot-set! x #f)) x*)
 712 |          `(letrec ([,l0* ,f*] ...)
 713 |             (closures ([,x* ,l* ,x** ...] ...) ,e)))]
 714 |       ;; NB: should be unnecessary
 715 |       [(letrec ([,l* ,f*] ...) ,clbody) (errorf who "unreachable")]))
 716 | 
 717 |   (define make-procedure-pr (primitive->primitive-info '$make-procedure))
 718 |   (define procedure-ref-pr (primitive->primitive-info '$procedure-ref))
 719 |   (define procedure-code-pr (primitive->primitive-info '$procedure-code))
 720 |   (define procedure-set!-pr (primitive->primitive-info '$procedure-set!))
 721 | 
 722 |   (define-language Lproc
 723 |     (extends Lclosure)
 724 |     (Expr (e)
 725 |       (- (letrec ([l* f*] ...) clbody))
 726 |       (+ (letrec ([l* f*] ...) e)))
 727 |     (ClosureBody (clbody)
 728 |       (- (closures ([x* l* x** ...] ...) e)))
 729 |     (Lambda (f)
 730 |       (- (lambda (x* ...) bfrbody))
 731 |       (+ (lambda (x* ...) e)))
 732 |     (BindFreeBody (bfrbody)
 733 |       (- (bind-free (x x* ...) e))))
 734 | 
 735 |   (define-pass introduce-procedure-primitives : Lclosure (ir) -> Lproc ()
 736 |     (definitions
 737 |       (define with-fv*
 738 |         (lambda (cp fv* th)
 739 |           (let ([ov* (map var-slot fv*)])
 740 |             (fold-left (lambda (i fv) (var-slot-set! fv (cons cp i)) (fx+ i 1)) 0 fv*)
 741 |             (let ([v (th)])
 742 |               (for-each var-slot-set! fv* ov*)
 743 |               v)))))
 744 |     (var : var (x) -> Expr ()
 745 |       (cond
 746 |         [(var-slot x) => (lambda (pr) `(,procedure-ref-pr ,(car pr) (quote ,(cdr pr))))]
 747 |         [else x]))
 748 |     (Expr : Expr (e) -> Expr ()
 749 |       (definitions
 750 |         (define (build-procedure-set! x* e** e)
 751 |           (let ([ps* (fold-right
 752 |                        (lambda (x e* ps*)
 753 |                          (fold-right
 754 |                            (lambda (e i ps*)
 755 |                              (cons `(,procedure-set!-pr ,x (quote ,i) ,e) ps*))
 756 |                            ps* e* (enumerate e*)))
 757 |                        '() x* e**)])
 758 |             (if (null? ps*)
 759 |                 e
 760 |                 `(begin ,ps* ... ,e)))))
 761 |       [,x 
 762 |        (var x)]
 763 |       [(letrec ([,l0* ,[f*]] ...)
 764 |          (closures ([,x* ,l1* ,[e**] ...] ...) ,[e]))
 765 |        `(letrec ([,l0* ,f*] ...)
 766 |           (let ([,x* ,(map (lambda (l e*) `(,make-procedure-pr ,l (quote ,(length e*)))) l1* e**)] ...)
 767 |             ,(build-procedure-set! x* e** e)))]
 768 |       [(,l ,[e*] ...) `(,l ,e* ...)]
 769 |       [(,pr ,[e*] ...) `(,pr ,e* ...)]
 770 |       [(,[e] ,[e*] ...) `((,procedure-code-pr ,e) ,e* ...)]
 771 |       ;; NB: should be unnecessary
 772 |       [(letrec ([,l* ,f*] ...) ,clbody) (errorf who "unreachable")])
 773 |     (Lambda : Lambda (f) -> Lambda ()
 774 |       [(lambda (,x* ...) (bind-free (,x ,x0* ...) ,e))
 775 |        (with-fv* x x0* (lambda () `(lambda (,x* ...) ,(Expr e))))]
 776 |       ;; NB: should be unnecesary
 777 |       [(lambda (,x* ...) ,bfrbody) (error who "unreachable")]))
 778 | 
 779 |   (define-language Llifted
 780 |     (extends Lproc)
 781 |     (entry Program)
 782 |     (Program (prog)
 783 |       (+ (letrec ([l* f*] ...) e)))
 784 |     (Expr (e)
 785 |       (- (letrec ([l* f*] ...) e))))
 786 | 
 787 |   (define-pass lift-letrec : Lproc (ir) -> Llifted ()
 788 |     (definitions
 789 |       (define all-l*)
 790 |       (define all-f*))
 791 |     (Expr : Expr (ir) -> Expr ()
 792 |       [(letrec ([,l* ,[f*]] ...) ,[e])
 793 |        (set! all-l* (append l* all-l*))
 794 |        (set! all-f* (append f* all-f*))
 795 |        e])
 796 |     (fluid-let ([all-l* '()] [all-f* '()])
 797 |       (let ([e (Expr ir)])
 798 |         `(letrec ([,all-l* ,all-f*] ...) ,e))))
 799 | 
 800 |   (define (value-primitive-info? x)
 801 |     (and (primitive-info? x) (eq? (primitive-info-kind x) 'value)))
 802 |   (define (effect-primitive-info? x)
 803 |     (and (primitive-info? x) (eq? (primitive-info-kind x) 'effect)))
 804 |   (define (predicate-primitive-info? x)
 805 |     (and (primitive-info? x) (eq? (primitive-info-kind x) 'predicate)))
 806 | 
 807 |   (define-language Lnormalized
 808 |     (extends Llifted)
 809 |     (terminals
 810 |       (- (primitive-info (pr)))
 811 |       (+ (value-primitive-info (value-pr))    => primitive-info-name
 812 |          (predicate-primitive-info (pred-pr)) => primitive-info-name
 813 |          (effect-primitive-info (effect-pr))  => primitive-info-name))
 814 |     (Program (prog)
 815 |       (- (letrec ([l* f*] ...) e))
 816 |       (+ (letrec ([l* f*] ...) v)))
 817 |     (Lambda (f)
 818 |       (- (lambda (x* ...) e))
 819 |       (+ (lambda (x* ...) v)))
 820 |     (Expr (e)
 821 |       (- l
 822 |          x
 823 |          (quote i)
 824 |          (if e0 e1 e2)
 825 |          (begin e* ... e)
 826 |          (let ([x* e*] ...) e)
 827 |          (callable e* ...)))
 828 |     (Callable (callable)
 829 |       (- e
 830 |          pr))
 831 |     (Value (v)
 832 |       (+ l
 833 |          x
 834 |          (quote i)
 835 |          (if pr0 v1 v2)
 836 |          (begin ef* ... v)
 837 |          (let ([x* v*] ...) v)
 838 |          (vcallable v* ...)))
 839 |     (ValueCallable (vcallable)
 840 |       (+ v
 841 |          value-pr))
 842 |     (Pred (pr)
 843 |       (+ (true)
 844 |          (false)
 845 |          (if pr0 pr1 pr2)
 846 |          (begin ef* ... pr)
 847 |          (let ([x* v*] ...) pr)
 848 |          (pred-pr v* ...)))
 849 |     (Effect (ef)
 850 |       (+ (nop)
 851 |          (if pr0 ef1 ef2)
 852 |          (begin ef* ... ef)
 853 |          (let ([x* v*] ...) ef)
 854 |          (ecallable v* ...)))
 855 |     (EffectCallable (ecallable)
 856 |       (+ v
 857 |          effect-pr)))
 858 | 
 859 |   (define eq?-pr (primitive->primitive-info 'eq?))
 860 | 
 861 |   (define-pass normalize-context : Llifted (ir) -> Lnormalized ()
 862 |     (Value : Expr (ir) -> Value ()
 863 |       [(,pr ,[v*] ...)
 864 |        (cond
 865 |          [(value-primitive-info? pr) `(,pr ,v* ...)]
 866 |          [(predicate-primitive-info? pr) `(if (,pr ,v* ...) (quote #t) (quote #f))]
 867 |          [(effect-primitive-info? pr) `(begin (,pr ,v* ...) (,void-pr))])])
 868 |     (Pred : Expr (ir) -> Pred ()
 869 |       [,l `(true)]
 870 |       [,x `(if (,eq?-pr ,x (quote #f)) (false) (true))]
 871 |       [(quote ,i) (if (eq? i #f) `(false) `(true))]
 872 |       [(,pr ,[v*] ...)
 873 |        (cond
 874 |          [(value-primitive-info? pr) `(if (,eq?-pr (,pr ,v* ...) (quote #f)) (false) (true))]
 875 |          [(predicate-primitive-info? pr) `(,pr ,v* ...)]
 876 |          [(effect-primitive-info? pr) `(begin (,pr ,v* ...) (true))])]
 877 |       [(,[v] ,[v*] ...) `(if (,eq?-pr (,v ,v* ...) (quote #f)) (false) (true))])
 878 |     (Effect : Expr (ir) -> Effect ()
 879 |       [,l `(nop)]
 880 |       [,x `(nop)]
 881 |       [(quote ,i) `(nop)]
 882 |       [(,pr ,[v*] ...) (guard (effect-primitive-info? pr)) `(,pr ,v* ...)]
 883 |       [(,pr ,[ef*] ...)
 884 |        (let ([ef* (remp (lambda (ef) (nanopass-case (Lnormalized Effect) ef [(nop) #t] [else #f])) ef*)])
 885 |          (cond
 886 |            [(null? ef*) `(nop)]
 887 |            [(= (length ef*) 1) (car ef*)]
 888 |            [else (let loop ([ef (car ef*)] [ef* (cdr ef*)] [ref* '()])
 889 |                    (if (null? ef*)
 890 |                        `(begin ,(reverse ref*) ... ,ef)
 891 |                        (loop (car ef*) (cdr ef*) (cons ef ref*))))]))]))
 892 | 
 893 |   (define (binary-operator? x) (memq x '(+ - * sra logand)))
 894 |   (define (relational-operator? x) (memq x '(< <= = >= > !=)))
 895 | 
 896 |   (define-language Lrep
 897 |     (extends Lnormalized)
 898 |     (terminals
 899 |       (- (immediate (i))
 900 |          (value-primitive-info (value-pr))
 901 |          (predicate-primitive-info (pred-pr))
 902 |          (effect-primitive-info (effect-pr)))
 903 |       (+ (exact-integer (int))
 904 |          (relational-operator (relop))
 905 |          (binary-operator (binop))))
 906 |     (Triv (tr)
 907 |       (+ x
 908 |          int
 909 |          l))
 910 |     (Value (v)
 911 |       (- l
 912 |          x
 913 |          (quote i)
 914 |          (vcallable v* ...))
 915 |       (+ tr
 916 |          (alloc v)
 917 |          (mref v0 v1)
 918 |          (binop v0 v1)
 919 |          (call v v* ...) => (v v* ...)))
 920 |     (ValueCallable (vcallable)
 921 |       (- v
 922 |          value-pr))
 923 |     (Pred (pr)
 924 |       (- (pred-pr v* ...))
 925 |       (+ (relop v0 v1)))
 926 |     (Effect (ef)
 927 |       (- (ecallable v* ...))
 928 |       (+ (mset! v0 v1 v2)
 929 |          (call v v* ...) => (v v* ...)))
 930 |     (EffectCallable (ecallable)
 931 |       (- v
 932 |          effect-pr)))
 933 | 
 934 |   (define-pass specify-representation : Lnormalized (ir) -> Lrep ()
 935 |     (definitions
 936 |       (define-syntax with-args
 937 |         (syntax-rules ()
 938 |           [(_ ([(vs ...) v*]) body0 ... body1)
 939 |            (apply
 940 |              (case-lambda
 941 |                [(vs ...) body0 ... body1]
 942 |                [any (errorf who "expected ~s arguments but got ~s" (length '(vs ...)) (length any))])
 943 |              v*)])))
 944 |     (Value : Value (ir) -> Value ()
 945 |       [(quote ,i)
 946 |        (cond
 947 |          [(eq? i #t) $true]
 948 |          [(eq? i #f) $false]
 949 |          [(eq? i '()) $nil]
 950 |          [else (bitwise-ior (bitwise-arithmetic-shift-left i shift-fixnum) tag-fixnum)])]
 951 |       [(,value-pr ,[v*] ...)
 952 |        (let ([prim-name (primitive-info-name value-pr)])
 953 |          (case prim-name
 954 |            [(+ -) (with-args ([(v0 v1) v*]) `(,prim-name ,v0 ,v1))]
 955 |            [(*)
 956 |             (with-args ([(v0 v1) v*])
 957 |               (cond
 958 |                 [(exact-integer? v0) `(,prim-name ,(bitwise-arithmetic-shift-right v0 shift-fixnum) ,v1)]
 959 |                 [(exact-integer? v1) `(,prim-name ,v0 ,(bitwise-arithmetic-shift-right v1 shift-fixnum))]
 960 |                 [else `(,prim-name ,v0 (sra ,v1 ,shift-fixnum))]))]
 961 |            [(car) (with-args ([(v0) v*]) `(mref ,v0 ,(- disp-car tag-pair)))]
 962 |            [(cdr) (with-args ([(v0) v*]) `(mref ,v0 ,(- disp-cdr tag-pair)))]
 963 |            [(cons) (with-args ([(v0 v1) v*])
 964 |                      (let ([a (make-var 'a)] [d (make-var 'd)] [t (make-var 'p)])
 965 |                        `(let ([,a ,v0] [,d ,v1])
 966 |                           (let ([,t (+ (alloc ,size-pair) ,tag-pair)])
 967 |                             (begin
 968 |                               (mset! ,t ,(- disp-car tag-pair) ,a)
 969 |                               (mset! ,t ,(- disp-cdr tag-pair) ,d)
 970 |                               ,t)))))]
 971 |            [(make-vector)
 972 |             (with-args ([(v) v*])
 973 |               (let ([t (make-var 'v)])
 974 |                 (if (exact-integer? v)
 975 |                     `(let ([,t (+ (alloc ,(+ disp-vector-data v)) ,tag-vector)])
 976 |                        (begin
 977 |                          (mset! ,t ,(- disp-vector-length tag-vector) ,v)
 978 |                          ,t))
 979 |                     (let ([size (make-var 'size)])
 980 |                       `(let ([,size ,v])
 981 |                          (let ([,t (+ (alloc (+ ,disp-vector-data ,size)) ,tag-vector)])
 982 |                            (begin
 983 |                              (mset! ,t ,(- disp-vector-length tag-vector) ,size)
 984 |                              ,t)))))))]
 985 |            [($make-procedure)
 986 |             (with-args ([(l size) v*])
 987 |               (let ([t (make-var 'proc)])
 988 |                 (if (exact-integer? size)
 989 |                     `(let ([,t (+ (alloc ,(+ disp-procedure-data size)) ,tag-procedure)])
 990 |                        (begin
 991 |                          (mset! ,t ,(- disp-procedure-code tag-procedure) ,l)
 992 |                          ,t))
 993 |                     (let ([tsize (make-var 'size)])
 994 |                       `(let ([,tsize ,size])
 995 |                          (let ([,t (+ (alloc (+ ,disp-procedure-data ,tsize)) ,tag-procedure)])
 996 |                            (begin
 997 |                              (mset! ,t ,(- disp-procedure-code tag-procedure) ,l)
 998 |                              ,t)))))))]
 999 |            [($procedure-code) (with-args ([(v) v*]) `(mref ,v ,(- disp-procedure-code tag-procedure)))]
1000 |            [($procedure-ref)
1001 |             (with-args ([(v0 v1) v*])
1002 |               (if (exact-integer? v1)
1003 |                   `(mref ,v0 ,(+ (- disp-procedure-data tag-procedure) v1))
1004 |                   `(mref ,v0 (+ ,(- disp-procedure-data tag-procedure) ,v1))))]
1005 |            [(vector-length) (with-args ([(v) v*]) `(mref ,v ,(- disp-vector-length tag-vector)))]
1006 |            [(vector-ref) (with-args ([(v0 v1) v*])
1007 |                            (if (exact-integer? v1)
1008 |                                `(mref ,v0 ,(+ (- disp-vector-data tag-vector) v1))
1009 |                                `(mref ,v0 (+ ,(- disp-vector-data tag-vector) ,v1))))]
1010 |            [(void) $void]
1011 |            [else (errorf who "unsupported value primitive ~s" prim-name)]))]
1012 |       [(,[v] ,[v*] ...) `(call ,v ,v* ...)])
1013 |     (Pred : Pred (ir) -> Pred ()
1014 |       [(,pred-pr ,[v*] ...)
1015 |        (let ([prim-name (primitive-info-name pred-pr)])
1016 |          (case prim-name
1017 |            [(<) (with-args ([(v0 v1) v*])
1018 |                   (if (and (exact-integer? v0) (exact-integer? v1))
1019 |                       (if (< v0 v1) `(true) `(false))
1020 |                       `(< ,v0 ,v1)))]
1021 |            [(<=) (with-args ([(v0 v1) v*])
1022 |                    (if (and (exact-integer? v0) (exact-integer? v1))
1023 |                        (if (<= v0 v1) `(true) `(false))
1024 |                        `(<= ,v0 ,v1)))]
1025 |            [(= eq?) (with-args ([(v0 v1) v*])
1026 |                       (if (and (exact-integer? v0) (exact-integer? v1))
1027 |                           (if (= v0 v1) `(true) `(false))
1028 |                           `(= ,v0 ,v1)))]
1029 |            [(>=) (with-args ([(v0 v1) v*])
1030 |                    (if (and (exact-integer? v0) (exact-integer? v1))
1031 |                        (if (>= v0 v1) `(true) `(false))
1032 |                        `(>= ,v0 ,v1)))]
1033 |            [(>) (with-args ([(v0 v1) v*])
1034 |                   (if (and (exact-integer? v0) (exact-integer? v1))
1035 |                       (if (> v0 v1) `(true) `(false))
1036 |                       `(> ,v0 ,v1)))]
1037 |            [(boolean?) (with-args ([(v) v*])
1038 |                          (if (exact-integer? v)
1039 |                              (if (or (= v $true) (= v $false)) `(true) `(false))
1040 |                              `(= (logand ,v ,mask-boolean) ,tag-boolean)))]
1041 |            [(fixnum?) (with-args ([(v) v*])
1042 |                         (if (exact-integer? v)
1043 |                             (if (= (bitwise-and v mask-fixnum) tag-fixnum) `(true) `(false))
1044 |                             `(= (logand ,v ,mask-fixnum) ,tag-fixnum)))]
1045 |            [(null?) (with-args ([(v) v*])
1046 |                       (if (exact-integer? v)
1047 |                           (if (= v $nil) `(true) `(false))
1048 |                           `(= ,v ,$nil)))]
1049 |            [(pair?) (with-args ([(v) v*]) `(= (logand ,v ,mask-pair) ,tag-pair))]
1050 |            [(vector?) (with-args ([(v) v*]) `(= (logand ,v ,mask-vector) ,tag-vector))]
1051 |            [(procedure?) (with-args ([(v) v*]) `(= (logand ,v ,mask-procedure) ,tag-procedure))]
1052 |            [else (errorf who "unsupported predicate primitive ~s" prim-name)]))])
1053 |     (Effect : Effect (ir) -> Effect ()
1054 |       [(,effect-pr ,[v*] ...)
1055 |        (let ([prim-name (primitive-info-name effect-pr)])
1056 |          (case prim-name
1057 |            [(set-car!) (with-args ([(v0 v1) v*]) `(mset! ,v0 ,(- disp-car tag-pair) ,v1))]
1058 |            [(set-cdr!) (with-args ([(v0 v1) v*]) `(mset! ,v0 ,(- disp-cdr tag-pair) ,v1))]
1059 |            [($procedure-set!)
1060 |             (with-args ([(v0 v1 v2) v*])
1061 |               (if (exact-integer? v1)
1062 |                   `(mset! ,v0 ,(+ (- disp-procedure-data tag-procedure) v1) ,v2)
1063 |                   `(mset! ,v0 (+ ,(- disp-procedure-data tag-procedure) ,v1) ,v2)))]
1064 |            [(vector-set!)
1065 |             (with-args ([(v0 v1 v2) v*])
1066 |               (if (exact-integer? v1)
1067 |                   `(mset! ,v0 ,(+ (- disp-vector-data tag-vector) v1) ,v2)
1068 |                   `(mset! ,v0 (+ ,(- disp-vector-data tag-vector) ,v1) ,v2)))]
1069 |            [else (errorf who "unsupported effect primitive ~s" prim-name)]))]
1070 |       [(,[v] ,[v*] ...) `(call ,v ,v* ...)]))
1071 | 
1072 |   (define-language Llocals
1073 |     (extends Lrep)
1074 |     (Program (prog)
1075 |       (- (letrec ([l* f*] ...) v))
1076 |       (+ (letrec ([l* f*] ...) b)))
1077 |     (Lambda (f)
1078 |       (- (lambda (x* ...) v))
1079 |       (+ (lambda (x* ...) b)))
1080 |     (Body (b)
1081 |       (+ (locals (x* ...) v))))
1082 | 
1083 |   (define-pass uncover-locals : Lrep (ir) -> Llocals ()
1084 |     (definitions (define local*))
1085 |     (Program : Program (ir) -> Program ()
1086 |       [(letrec ([,l* ,[f*]] ...) ,v)
1087 |        (fluid-let ([local* '()])
1088 |          (let ([v (Value v)])
1089 |            `(letrec ([,l* ,f*] ...) (locals (,local* ...) ,v))))])
1090 |     (Lambda : Lambda (ir) -> Lambda ()
1091 |       [(lambda (,x* ...) ,v)
1092 |        (fluid-let ([local*  '()])
1093 |          (let ([v (Value v)])
1094 |            `(lambda (,x* ...) (locals (,local* ...) ,v))))])
1095 |     (Value : Value (ir) -> Value ()
1096 |       [(let ([,x* ,[v*]] ...) ,[v])
1097 |        (set! local* (append x* local*))
1098 |        `(let ([,x* ,v*] ...) ,v)])
1099 |     (Pred : Pred (ir) -> Pred ()
1100 |       [(let ([,x* ,[v*]] ...) ,[pr])
1101 |        (set! local* (append x* local*))
1102 |        `(let ([,x* ,v*] ...) ,pr)])
1103 |     (Effect : Effect (ir) -> Effect ()
1104 |       [(let ([,x* ,[v*]] ...) ,[ef])
1105 |        (set! local* (append x* local*))
1106 |        `(let ([,x* ,v*] ...) ,ef)]))
1107 | 
1108 |   (define-language Lno-let
1109 |     (extends Llocals)
1110 |     (Value (v)
1111 |       (- (let ([x* v*] ...) v)))
1112 |     (Pred (pr)
1113 |       (- (let ([x* v*] ...) pr)))
1114 |     (Effect (ef)
1115 |       (- (let ([x* v*] ...) ef))
1116 |       (+ (set! x v))))
1117 | 
1118 |   (define-pass remove-let : Llocals (ir) -> Lno-let ()
1119 |     (definitions
1120 |       (define (build-set! x* v*)
1121 |         (map (lambda (x v) (with-output-language (Lno-let Effect) `(set! ,x ,v))) x* v*)))
1122 |     (Value : Value (ir) -> Value ()
1123 |       (definitions
1124 |         (define-begin-builder make-begin
1125 |           [(Lno-let Effect) (begin ,ef* ... ,ef)]
1126 |           [(Lno-let Value) (begin ,ef* ... ,v)]))
1127 |       [(let ([,x* ,[v*]] ...) ,[v]) (make-begin (build-set! x* v*) v)])
1128 |     (Pred : Pred (ir) -> Pred ()
1129 |       (definitions
1130 |         (define-begin-builder make-begin
1131 |           [(Lno-let Effect) (begin ,ef* ... ,ef)]
1132 |           [(Lno-let Pred) (begin ,ef* ... ,pr)]))
1133 |       [(let ([,x* ,[v*]] ...) ,[pr]) (make-begin (build-set! x* v*) pr)])
1134 |     (Effect : Effect (ir) -> Effect ()
1135 |       (definitions
1136 |         (define-begin-builder make-begin
1137 |           [(Lno-let Effect) (begin ,ef* ... ,ef)]))
1138 |       [(let ([,x* ,[v*]] ...) ,[ef]) (make-begin (build-set! x* v*) ef)]))
1139 | 
1140 | 
1141 |   (define-language Lsimple-opnd
1142 |     (extends Lno-let)
1143 |     (Pred (pr)
1144 |       (- (relop v0 v1))
1145 |       (+ (relop tr0 tr1)))
1146 |     (Value (v)
1147 |       (- (binop v0 v1)
1148 |          (call v v* ...)
1149 |          (mref v0 v1)
1150 |          (alloc v))
1151 |       (+ (binop tr0 tr1)
1152 |          (call tr tr* ...)
1153 |          (mref tr0 tr1)
1154 |          (alloc tr)))
1155 |     (Effect (ef)
1156 |       (- (call v v* ...)
1157 |          (mset! v0 v1 v2))
1158 |       (+ (call tr tr* ...)
1159 |          (mset! tr0 tr1 tr2))))
1160 | 
1161 |   (define-pass remove-complex-opera* : Lno-let (ir) -> Lsimple-opnd ()
1162 |     (definitions
1163 |       (define local*)
1164 |       (define (make-temp)
1165 |         (let ([t (make-var 't)])
1166 |           (set! local* (cons t local*))
1167 |           t))
1168 |       (define simplify
1169 |         (case-lambda
1170 |           [(v k) (Simplify v '() k)]
1171 |           [(v0 v1 k)
1172 |            (Simplify v0 '()
1173 |              (lambda (e* tr0)
1174 |                (Simplify v1 e*
1175 |                  (lambda (e* tr1)
1176 |                    (k e* tr0 tr1)))))]
1177 |           [(v0 v1 v2 k)
1178 |            (Simplify v0 '()
1179 |              (lambda (e* tr0)
1180 |                (Simplify v1 e*
1181 |                  (lambda (e* tr1)
1182 |                    (Simplify v2 e*
1183 |                      (lambda (e* tr2)
1184 |                        (k e* tr0 tr1 tr2)))))))]))
1185 |       (define (simplify* v v* k)
1186 |         (Simplify v '()
1187 |           (lambda (e* tr)
1188 |             (let loop ([v* v*] [e* e*] [rtr* '()])
1189 |               (if (null? v*)
1190 |                   (k e* tr (reverse rtr*))
1191 |                   (Simplify (car v*) e*
1192 |                     (lambda (e* tr)
1193 |                       (loop (cdr v*) e* (cons tr rtr*))))))))))
1194 |     (Body : Body (ir) -> Body ()
1195 |       [(locals (,x* ...) ,v)
1196 |        (fluid-let ([local* x*])
1197 |          (let ([v (Value v)])
1198 |            `(locals (,local* ...) ,v)))])
1199 |     (Value : Value (ir) -> Value ()
1200 |       (definitions
1201 |         (define-begin-builder make-begin
1202 |           [(Lsimple-opnd Effect) (begin ,ef* ... ,ef)]
1203 |           [(Lsimple-opnd Value) (begin ,ef* ... ,v)]))
1204 |       [(call ,v ,v* ...)
1205 |        (simplify* v v*
1206 |          (lambda (e* tr tr*)
1207 |            (make-begin e* `(call ,tr ,tr* ...))))]
1208 |       [(,binop ,v0 ,v1)
1209 |        (simplify v0 v1
1210 |          (lambda (e* tr0 tr1)
1211 |            (make-begin e* `(,binop ,tr0 ,tr1))))]
1212 |       [(alloc ,v)
1213 |        (simplify v
1214 |          (lambda (e* tr)
1215 |            (make-begin e* `(alloc ,tr))))]
1216 |       [(mref ,v0 ,v1)
1217 |        (simplify v0 v1
1218 |          (lambda (e* tr0 tr1)
1219 |            (make-begin e* `(mref ,tr0 ,tr1))))])
1220 |     (Pred : Pred (ir) -> Pred ()
1221 |       (definitions
1222 |         (define-begin-builder make-begin
1223 |           [(Lsimple-opnd Effect) (begin ,ef* ... ,ef)]
1224 |           [(Lsimple-opnd Pred) (begin ,ef* ... ,pr)]))
1225 |       [(,relop ,v0 ,v1)
1226 |        (simplify v0 v1
1227 |          (lambda (e* tr0 tr1)
1228 |            (make-begin e* `(,relop ,tr0 ,tr1))))])
1229 |     (Effect : Effect (ir) -> Effect ()
1230 |       (definitions
1231 |         (define-begin-builder make-begin
1232 |           [(Lsimple-opnd Effect) (begin ,ef* ... ,ef)]))
1233 |       [(call ,v ,v* ...)
1234 |        (simplify* v v*
1235 |          (lambda (e* tr tr*)
1236 |            (make-begin e* `(call ,tr ,tr* ...))))]
1237 |       [(mset! ,v0 ,v1 ,v2)
1238 |        (simplify v0 v1 v2
1239 |          (lambda (e* tr0 tr1 tr2)
1240 |            (make-begin e* `(mset! ,tr0 ,tr1 ,tr2))))])
1241 |     (Simplify : Value (ir e* k) -> Triv ()
1242 |       [,tr (k e* tr)]
1243 |       [else (let ([t (make-temp)] [v (Value ir)])
1244 |               (k (cons (in-context Effect `(set! ,t ,v)) e*) t))]))
1245 | 
1246 |   (define-language Lflat-set!
1247 |     (extends Lsimple-opnd)
1248 |     (Effect (ef)
1249 |       (- (set! x v))
1250 |       (+ (set! x rhs)))
1251 |     (Rhs (rhs)
1252 |       (+ tr
1253 |          (alloc tr)
1254 |          (mref tr0 tr1)
1255 |          (binop tr0 tr1)
1256 |          (call tr tr* ...)))
1257 |     (Body (b)
1258 |       (- (locals (x* ...) v))
1259 |       (+ (locals (x* ...) t)))
1260 |     (Tail (t)
1261 |       (+ tr
1262 |          (binop tr0 tr1)
1263 |          (alloc tr)
1264 |          (mref tr0 tr1)
1265 |          (call tr tr* ...)
1266 |          (if pr0 t1 t2)
1267 |          (begin ef* ... t)))
1268 |     (Value (v)
1269 |       (- tr
1270 |          (binop tr0 tr1)
1271 |          (alloc tr)
1272 |          (mref tr0 tr1)
1273 |          (call tr tr* ...)
1274 |          (if pr0 v1 v2)
1275 |          (begin ef* ... v))))
1276 | 
1277 |   (define-pass flatten-set! : Lsimple-opnd (ir) -> Lflat-set! ()
1278 |     (Effect : Effect (ir) -> Effect ()
1279 |       [(set! ,x ,v) (Value v x)])
1280 |     (Value : Value (ir x) -> Effect ()
1281 |       [,tr `(set! ,x ,tr)]
1282 |       [(alloc ,tr) `(set! ,x (alloc ,tr))]
1283 |       [(mref ,tr0 ,tr1) `(set! ,x (mref ,tr0 ,tr1))]
1284 |       [(call ,tr ,tr* ...) `(set! ,x (call ,tr ,tr* ...))]
1285 |       [(,binop ,tr0 ,tr1) `(set! ,x (,binop ,tr0 ,tr1))]
1286 |       [(if ,[pr0] ,[ef1] ,[ef2]) `(if ,pr0 ,ef1 ,ef2)]
1287 |       [(begin ,[ef*] ... ,[ef]) `(begin ,ef* ... ,ef)]))
1288 | 
1289 |   (define-language Lbb
1290 |     (extends Lflat-set!)
1291 |     (Body (b)
1292 |       (- (locals (x* ...) t))
1293 |       (+ (locals (x* ...) blocks)))
1294 |     (Blocks (blocks)
1295 |       (+ (labels ([l* t*] ...) l)))
1296 |     (Tail (t)
1297 |       (- tr
1298 |          (binop tr0 tr1)
1299 |          (alloc tr)
1300 |          (mref tr0 tr1)
1301 |          (call tr tr* ...)
1302 |          (if pr0 t1 t2))
1303 |       (+ (return tr)
1304 |          (goto l)
1305 |          (if (relop tr0 tr1) (l0) (l1))))
1306 |     (Pred (pr)
1307 |       (- (true)
1308 |          (false)
1309 |          (relop tr0 tr1)
1310 |          (if pr0 pr1 pr2)
1311 |          (begin ef* ... pr)))
1312 |     (Effect (ef)
1313 |       (- (nop)
1314 |          (if pr0 ef1 ef2)
1315 |          (begin ef* ... ef)))
1316 |     (Rhs (rhs)
1317 |       (+ (tail-call tr tr* ...))))
1318 | 
1319 |   (define-pass expose-basic-blocks : Lflat-set! (ir) -> Lbb ()
1320 |     (definitions
1321 |       (define local*)
1322 |       (define (make-temp)
1323 |         (let ([t (make-var 'retval)])
1324 |           (set! local* (cons t local*))
1325 |           t))
1326 |       (define (Effect* ef* t tl-ef* label* block*)
1327 |         (if (null? ef*)
1328 |             (values t tl-ef* label* block*)
1329 |             (let-values ([(t tl-ef* label* block*) (Effect* (cdr ef*) t tl-ef* label* block*)])
1330 |               (Effect (car ef*) t tl-ef* label* block*))))
1331 |       (with-output-language Lbb
1332 |         (define (make-begin ef* t)
1333 |           (if (null? ef*)
1334 |               t
1335 |               (in-context Tail `(begin ,ef* ... ,t))))
1336 |         (define (make-return rhs label* block*)
1337 |           (let ([t (make-temp)])
1338 |             (values
1339 |               (in-context Tail `(return ,t))
1340 |               (list (in-context Effect `(set! ,t ,rhs)))
1341 |               label*
1342 |               block*)))
1343 |         (define (build-block sym t ef* label* block*)
1344 |           (let ([l (make-local-label sym)])
1345 |             (values l (cons l label*) (cons (make-begin ef* t) block*))))))
1346 |     (Body : Body (ir) -> Body ()
1347 |       [(locals (,x* ...) ,t)
1348 |        (fluid-let ([local* x*])
1349 |          (let*-values ([(t ef* label* block*) (Tail t '() '())]
1350 |                        [(label label* block*) (build-block 'start t ef* label* block*)])
1351 |            `(locals (,local* ...) (labels ([,label* ,block*] ...) ,label))))])
1352 |     (Tail : Tail (t label* block*) -> Tail (ef* label* block*)
1353 |       [,tr (values `(return ,tr) '() label* block*)]
1354 |       [(,binop ,tr0 ,tr1)
1355 |        (make-return (in-context Rhs `(,binop ,tr0 ,tr1)) label* block*)]
1356 |       [(alloc ,tr)
1357 |        (make-return (in-context Rhs `(alloc ,tr)) label* block*)]
1358 |       [(mref ,tr0 ,tr1)
1359 |        (make-return (in-context Rhs `(mref ,tr0 ,tr1)) label* block*)]
1360 |       [(call ,tr ,tr* ...)
1361 |        (make-return (in-context Rhs `(tail-call ,tr ,tr* ...)) label* block*)]
1362 |       [(begin ,ef* ... ,[t tl-ef* label* block*])
1363 |        (Effect* ef* t tl-ef* label* block*)]
1364 |       [(if ,pr0 ,t1 ,t2)
1365 |        (let*-values ([(t1 ef1* label* block*) (Tail t1 label* block*)]
1366 |                      [(t2 ef2* label* block*) (Tail t2 label* block*)]
1367 |                      [(label1 label* block*) (build-block 'c t1 ef1* label* block*)]
1368 |                      [(label2 label* block*) (build-block 'a t2 ef2* label* block*)])
1369 |          (Pred pr0 label1 label2 label* block*))])
1370 |     (Pred : Pred (ir t-label f-label label* block*) -> Tail (ef* label* block*)
1371 |       [(true) (values `(goto ,t-label) '() label* block*)]
1372 |       [(false) (values `(goto ,f-label) '() label* block*)]
1373 |       [(,relop ,tr0 ,tr1) (values `(if (,relop ,tr0 ,tr1) (,t-label) (,f-label)) '() label* block*)]
1374 |       [(begin ,ef* ... ,[t tl-ef* label* block*])
1375 |        (Effect* ef* t tl-ef* label* block*)]
1376 |       [(if ,pr0 ,pr1 ,pr2)
1377 |        (let*-values ([(t1 ef1* label* block*) (Pred pr1 t-label f-label label* block*)]
1378 |                      [(t2 ef2* label* block*) (Pred pr2 t-label f-label label* block*)]
1379 |                      [(label1 label* block*) (build-block 'c t1 ef1* label* block*)]
1380 |                      [(label2 label* block*) (build-block 'a t2 ef2* label* block*)])
1381 |          (Pred pr0 label1 label2 label* block*))])
1382 |     (Effect : Effect (ir t tl-ef* label* block*) -> Tail (tl-ef* label* block*)
1383 |       [(nop) (values t tl-ef* label* block*)]
1384 |       [(set! ,x ,[rhs])
1385 |        (values t (cons (in-context Effect `(set! ,x ,rhs)) tl-ef*) label* block*)]
1386 |       [(mset! ,tr0 ,tr1 ,tr2)
1387 |        (values t (cons (in-context Effect `(mset! ,tr0 ,tr1 ,tr2)) tl-ef*) label* block*)]
1388 |       [(call ,tr ,tr* ...)
1389 |        (values t (cons (in-context Effect `(call ,tr ,tr* ...)) tl-ef*) label* block*)]
1390 |       [(begin ,ef* ... ,[t tl-ef* label* block*])
1391 |        (Effect* ef* t tl-ef* label* block*)]
1392 |       [(if ,pr0 ,ef1 ,ef2)
1393 |        (let-values ([(label label* block*) (build-block 'j t tl-ef* label* block*)])
1394 |          (let ([t `(goto ,label)])
1395 |            (let*-values ([(t1 tl-ef1* label* block*) (Effect ef1 t '() label* block*)]
1396 |                          [(t2 tl-ef2* label* block*) (Effect ef2 t '() label* block*)]
1397 |                          [(label1 label* block*) (build-block 'c t1 tl-ef1* label* block*)]
1398 |                          [(label2 label* block*) (build-block 'a t2 tl-ef2* label* block*)])
1399 |              (Pred pr0 label1 label2 label* block*))))]))
1400 | 
1401 |   (define optimize-blocks-reorders (make-parameter #t (lambda (x) (and x #t))))
1402 | 
1403 |   ;; TODO: eliminate blocks that are just phi functions
1404 |   (define-pass optimize-blocks : Lbb (ir) -> Lbb ()
1405 |     (definitions
1406 |       (define (label->final-target l)
1407 |         (let loop ([fl l])
1408 |           (cond
1409 |             [(label-slot fl) => loop]
1410 |             [(eq? fl l) l]
1411 |             [else (set! l fl) fl])))
1412 |       (define (filter-out-jumps-to-jumps l* t*)
1413 |         (for-each
1414 |           (lambda (l t)
1415 |             (nanopass-case (Lbb Tail) t
1416 |               [(goto ,l0) (label-slot-set! l l0)]
1417 |               [else (label-slot-set! l #f)]))
1418 |           l* t*))
1419 |       (define-record-type graph-node
1420 |         (nongenerative)
1421 |         (fields tail (mutable written?) (mutable jump-to-jump-target))
1422 |         (protocol
1423 |           (lambda (new)
1424 |             (lambda (tail)
1425 |               (new tail #f
1426 |                 (nanopass-case (Lbb Tail) tail
1427 |                   [(goto ,l) l]
1428 |                   [else #f]))))))
1429 |       (define (build-graph! l* t*)
1430 |         (for-each (lambda (l t) (label-slot-set! l (make-graph-node t))) l* t*))
1431 |       (define (extract-final-target l)
1432 |         (let loop ([fl l])
1433 |           (cond
1434 |             [(let ([node (label-slot fl)]) (and node (graph-node-jump-to-jump-target node))) => loop]
1435 |             [else
1436 |               (unless (eq? l fl) (graph-node-jump-to-jump-target-set! (label-slot l) fl))
1437 |               fl])))
1438 |       (define extend-worklist
1439 |         (case-lambda
1440 |           [(l wl) (if (graph-node-written? (label-slot l)) wl (cons l wl))]
1441 |           [(l0 l1 wl) (extend-worklist l0 (extend-worklist l1 wl))]
1442 |           [(l . ls) (if (label? l) (extend-worklist l (apply extend-worklist ls)) l)]))
1443 |       (define (rewrite-effect* ef* wl)
1444 |         (let loop ([ef* ef*] [wl wl] [ref* '()])
1445 |           (if (null? ef*)
1446 |               (values (reverse ref*) wl)
1447 |               (let-values ([(ef wl) (rewrite-effect (car ef*) wl)])
1448 |                 (loop (cdr ef*) wl (cons ef ref*)))))))
1449 |     (Blocks : Blocks (ir) -> Blocks ()
1450 |       [(labels ([,l* ,t*] ...) ,l)
1451 |        (if (optimize-blocks-reorders)
1452 |            (begin
1453 |              (build-graph! l* t*)
1454 |              (let loop ([wl (list l)] [rl* '()] [rt* '()])
1455 |                (if (null? wl)
1456 |                    (begin
1457 |                      (for-each (lambda (l) (label-slot-set! l #f)) l*)
1458 |                      `(labels ([,(reverse rl*) ,(reverse rt*)] ...) ,l))
1459 |                    (let ([l (car wl)] [wl (cdr wl)])
1460 |                      (let ([node (label-slot l)])
1461 |                        (if (graph-node-written? node)
1462 |                            (loop wl rl* rt*)
1463 |                            (begin
1464 |                              (graph-node-written?-set! node #t)
1465 |                              (let-values ([(t wl) (rewrite-tail (graph-node-tail node) wl)])
1466 |                                (loop wl (cons l rl*) (cons t rt*))))))))))
1467 |            (let-values ([(l* t*) (filter-out-jumps-to-jumps l* t*)])
1468 |              (let ([t* (map Tail t*)])
1469 |                (for-each (lambda (l) (label-slot-set! l #f)) l*)
1470 |                `(labels ([,l* ,t*] ...) ,l))))])
1471 |     (Tail : Tail (t) -> Tail ()
1472 |       [(goto ,l) `(goto ,(label->final-target l))]
1473 |       [(if (,relop ,tr0 ,tr1) (,l0) (,l1))
1474 |        `(if (,relop ,tr0 ,tr1)
1475 |             (,(label->final-target l0))
1476 |             (,(label->final-target l1)))])
1477 |     (Triv : Triv (tr) -> Triv ()
1478 |       [,l (label->final-target l)])
1479 |     (rewrite-tail : Tail (t wl) -> Tail (wl)
1480 |       [(begin ,ef* ... ,t)
1481 |        (let*-values ([(ef* wl) (rewrite-effect* ef* wl)]
1482 |                      [(t wl) (rewrite-tail t wl)])
1483 |          (values `(begin ,ef* ... ,t) wl))]
1484 |       [(goto ,l)
1485 |        (let ([l (extract-final-target l)])
1486 |          (values `(goto ,l) (extend-worklist l wl)))]
1487 |       [(return ,l)
1488 |        (let ([l (extract-final-target l)])
1489 |          (values `(return ,l) (extend-worklist l wl)))]
1490 |       [(return ,tr) (values `(return ,tr) wl)]
1491 |       [(if (,relop ,tr0 ,tr1) (,l0) (,l1))
1492 |        (let ([l0 (extract-final-target l0)]
1493 |              [l1 (extract-final-target l1)])
1494 |          (values `(if (,relop ,tr0 ,tr1) (,l0) (,l1)) (extend-worklist l0 l1 wl)))])
1495 |     (rewrite-effect : Effect (ef wl) -> Effect (wl)
1496 |       [(set! ,x ,l)
1497 |        (let ([l (extract-final-target l)])
1498 |          (values `(set! ,x ,l) (extend-worklist l wl)))]))
1499 | 
1500 |   (define-language Lssa
1501 |     (extends Lbb)
1502 |     (Rhs (rhs)
1503 |       (+ (phi [tr* l*] ...))))
1504 | 
1505 |   (define-pass convert-to-ssa : Lbb (ir) -> Lssa ()
1506 |     (definitions
1507 |       (define-record-type phi
1508 |         (nongenerative)
1509 |         (fields x (mutable x*) (mutable l*)))
1510 |       (define-record-type graph-node
1511 |         (nongenerative)
1512 |         (fields
1513 |           label
1514 |           (mutable prev)
1515 |           (mutable assignments)
1516 |           (mutable phi*)
1517 |           (mutable next graph-node-next $graph-node-next-set!)
1518 |           ;; tarjan related
1519 |           (mutable low-link)
1520 |           (mutable on-stack?)
1521 |           ;; tarjan/dominator shared
1522 |           (mutable index)
1523 |           ;; dominator related
1524 |           (mutable idom)
1525 |           (mutable df))
1526 |         (protocol
1527 |           (lambda (new)
1528 |             (lambda (l)
1529 |               (new l '() '() '() '()
1530 |                    ;; tarjan related
1531 |                    #f #f #f
1532 |                    ;; dominator related
1533 |                    #f '())))))
1534 | 
1535 |       (define tarjan-scc
1536 |         (let ()
1537 |           (define (scc n scc*)
1538 |             (define (tarjan-step n scc* index stack)
1539 |               (graph-node-index-set! n index)
1540 |               (graph-node-low-link-set! n index)
1541 |               (graph-node-on-stack?-set! n #t)
1542 |               (let loop ([m* (graph-node-next n)] [scc* scc*] [index 1] [stack (cons n stack)])
1543 |                 (if (null? m*)
1544 |                     (if (fx=? (graph-node-low-link n) (graph-node-index n))
1545 |                         (let build-sc ([stack stack] [sc '()])
1546 |                           (let ([m (car stack)] [stack (cdr stack)])
1547 |                             (graph-node-on-stack?-set! m #f)
1548 |                             (if (eq? m n)
1549 |                                 (values (cons (cons m sc) scc*) index stack)
1550 |                                 (build-sc stack (cons m sc)))))
1551 |                         (values scc* index stack))
1552 |                     (let ([m (car m*)])
1553 |                       (cond
1554 |                         [(graph-node-index m)
1555 |                          (when (graph-node-on-stack? m)
1556 |                            (graph-node-low-link-set! n (min (graph-node-low-link n) (graph-node-low-link m))))
1557 |                          (loop (cdr m*) scc* index stack)]
1558 |                         [else (let-values ([(scc* index stack) (tarjan-step m scc* index stack)])
1559 |                                 (graph-node-low-link-set! n (min (graph-node-low-link n) (graph-node-low-link m)))
1560 |                                 (loop (cdr m*) scc* index stack))])))))
1561 |             (let-values ([(scc* index stack) (tarjan-step n scc* 0 '())])
1562 |               scc*))
1563 |           (lambda (n*)
1564 |             (fold-left
1565 |               (lambda (scc* n)
1566 |                 (if (graph-node-index n)
1567 |                     scc*
1568 |                     (scc n scc*)))
1569 |               '() n*))))
1570 | 
1571 |       (define (number-scc! scc)
1572 |         (call-with-values
1573 |           (lambda ()
1574 |             (let f ([scc scc] [i 0])
1575 |               (if (null? scc)
1576 |                   (values (make-vector i) 0)
1577 |                   (let g ([sc (car scc)] [i i])
1578 |                     (if (null? sc)
1579 |                         (f (cdr scc) i)
1580 |                         (let-values ([(v i) (g (cdr sc) (fx+ i 1))])
1581 |                           (let ([c (car sc)])
1582 |                             (graph-node-index-set! c i)
1583 |                             (vector-set! v i c)
1584 |                             (values v (fx+ i 1)))))))))
1585 |           (lambda (v idx) v)))
1586 | 
1587 |       ;; expects vector of topologically "sorted" graph nodes,
1588 |       ;; where the strongly connected components are in some 
1589 |       ;; arbitrary order, expects internally 
1590 |       (define build-dom-tree!
1591 |         (let ()
1592 |           (define (intersect v n1 n2)
1593 |             (let loop ([i1 (graph-node-index n1)] [i2 (graph-node-index n2)])
1594 |               (if (fx=? i1 i2)
1595 |                   (vector-ref v i1)
1596 |                   (loop
1597 |                     (let loop ([i1 i1])
1598 |                       (if (fx<? i1 i2)
1599 |                           (loop (graph-node-index (graph-node-idom (vector-ref v i1))))
1600 |                           i1))
1601 |                     (let loop ([i2 i2])
1602 |                       (if (fx<? i2 i1)
1603 |                           (loop (graph-node-index (graph-node-idom (vector-ref v i2))))
1604 |                           i2))))))
1605 |           (lambda (v)
1606 |             (let* ([i (fx- (vector-length v) 1)]
1607 |                    [n (vector-ref v i)]) ;; entry node
1608 |               (graph-node-idom-set! n n)
1609 |               (let fixed-loop ()
1610 |                 (let node-loop ([i i] [changed? #f])
1611 |                   (if (fx=? i 0)
1612 |                       (when changed? (fixed-loop))
1613 |                       (let* ([i (fx- i 1)]
1614 |                              [n (vector-ref v i)]
1615 |                              [p* (graph-node-prev n)])
1616 |                         (let inner ([new-idom (find graph-node-idom p*)] [p* p*])
1617 |                           (if (null? p*)
1618 |                               (begin
1619 |                                 (unless (eq? (graph-node-idom n) new-idom) (graph-node-idom-set! n new-idom))
1620 |                                 (node-loop i changed?))
1621 |                               (let ([p (car p*)])
1622 |                                 (if (graph-node-idom p)
1623 |                                     (inner (intersect v p new-idom) (cdr p*))
1624 |                                     (inner new-idom (cdr p*))))))))))))))
1625 | 
1626 |       ;; TODO: replace this with more efficient set implementation using node-indexes
1627 |       (define (set-cons x ls) (if (memq x ls) ls (cons x ls)))
1628 | 
1629 |       (define (build-df! v)
1630 |         (vector-for-each
1631 |           (lambda (n)
1632 |             (when (> (length (graph-node-prev n)) 1)
1633 |               (let ([idom (graph-node-idom n)])
1634 |                 (for-each
1635 |                   (lambda (p)
1636 |                     (let loop ([p p])
1637 |                       (unless (eq? p idom)
1638 |                         (graph-node-df-set! p (set-cons n (graph-node-df p)))
1639 |                         (loop (graph-node-idom p)))))
1640 |                   (graph-node-prev n)))))
1641 |           v))
1642 | 
1643 |       (define (find-source-label src dest)
1644 |         (let loop ([wl (list src)])
1645 |           (if (null? wl)
1646 |               (errorf 'find-source-label "couldn't find source label")
1647 |               (let ([n (car wl)] [wl (cdr wl)])
1648 |                 (let ([next* (graph-node-next n)])
1649 |                   (if (memq dest next*)
1650 |                       (graph-node-label n)
1651 |                       (loop (append next* wl))))))))
1652 | 
1653 |       (define (add-phi! x dest src)
1654 |         (let ([src-l (find-source-label src dest)])
1655 |           (let ([phi (find (lambda (phi) (eq? x (phi-x phi))) (graph-node-phi* dest))])
1656 |             (cond
1657 |               [(and phi (memq src-l (phi-l* phi))) (void)]
1658 |               [phi 
1659 |                (graph-node-assignments-set! dest (cons x (graph-node-assignments dest)))
1660 |                (rename-var! x dest)
1661 |                (phi-l*-set! phi (cons src-l (phi-l* phi)))
1662 |                (phi-x*-set! phi (cons x (phi-x* phi)))]
1663 |               [else (graph-node-phi*-set! dest
1664 |                       (cons (make-phi x (list x) (list src-l))
1665 |                             (graph-node-phi* dest)))]))))
1666 | 
1667 |       (define (find-match x as* l)
1668 |         (let loop ([node (label-graph-node l)])
1669 |           (cond
1670 |             [(assq node as*) => cdr]
1671 |             [else (let ([prev* (graph-node-prev node)])
1672 |                     (when (null? prev*)
1673 |                       (errorf 'find-match "unable to find ~s for ~s~%" (var-unique-name x) (label-unique-name l)))
1674 |                     (loop (car prev*)))])))
1675 | 
1676 |       (define (rename-var! x node)
1677 |         (cond
1678 |           [(var-slot x) =>
1679 |            (lambda (as*)
1680 |              (unless (assq node as*)
1681 |                (var-slot-set! x (cons (cons node (make-var x)) as*))))]
1682 |           [else (var-slot-set! x (list (cons node (make-var x))))]))
1683 | 
1684 |       (define (insert-phi! v all-x*)
1685 |         (for-each
1686 |           (lambda (x)
1687 |             #;(printf "x: ~s, multiply-assigned? ~s~%" x (var-flags-multiply-assigned? x))
1688 |             (when (var-flags-multiply-assigned? x)
1689 |               (let ([wl (let loop ([i (vector-length v)] [wl '()])
1690 |                           (if (fx=? i 0)
1691 |                               wl
1692 |                               (let ([i (fx- i 1)])
1693 |                                 (loop i (let ([n (vector-ref v i)])
1694 |                                           (if (memq x (graph-node-assignments n))
1695 |                                               (set-cons n wl)
1696 |                                               wl))))))])
1697 |                 #;(printf "wl: ~s~%" (map (lambda (n) (label-unique-name (graph-node-label n))) wl))
1698 |                 (let loop ([wl wl] [ever-on-wl wl])
1699 |                   (unless (null? wl)
1700 |                     (let ([n (car wl)])
1701 |                       (rename-var! x n)
1702 |                       (let inner ([d* (graph-node-df n)] [wl (cdr wl)] [ever-on-wl ever-on-wl])
1703 |                         (if (null? d*)
1704 |                             (loop wl ever-on-wl)
1705 |                             (let ([d (car d*)])
1706 |                               #;(printf "adding phi for ~s to ~s for ~s~%"
1707 |                                       (var-unique-name x)
1708 |                                       (label-unique-name (graph-node-label d))
1709 |                                       (label-unique-name (graph-node-label n)))
1710 |                               (add-phi! x d n)
1711 |                               (if (memq d ever-on-wl)
1712 |                                   (inner (cdr d*) wl ever-on-wl)
1713 |                                   (inner (cdr d*) (cons d wl) (cons d ever-on-wl))))))))))))
1714 |           all-x*))
1715 | 
1716 |       (define (label-graph-node l)
1717 |         (or (label-slot l)
1718 |             (let ([n (make-graph-node l)])
1719 |               (label-slot-set! l n)
1720 |               n)))
1721 |       (define (graph-node-next-set! n l*)
1722 |         (let ([n* (map label-graph-node l*)])
1723 |           ($graph-node-next-set! n n*)
1724 |           (for-each
1725 |             (lambda (nn)
1726 |               (graph-node-prev-set! nn (cons n (graph-node-prev nn))))
1727 |             n*)))
1728 |       (define (label-phi* l)
1729 |         (graph-node-phi* (label-graph-node l)))
1730 |       )
1731 |     (Program : Program (ir) -> Program ()
1732 |       [(letrec ([,l* ,[f*]] ...) ,b) `(letrec ([,l* ,f*] ...) ,(Body b '()))])
1733 |     (Lambda : Lambda (ir) -> Lambda ()
1734 |       [(lambda (,x* ...) ,b) `(lambda (,x* ...) ,(Body b x*))])
1735 |     (Body : Body (ir entry-x*) -> Body ()
1736 |       [(locals (,x* ...) ,blocks)
1737 |        (for-each (lambda (x) (var-flags-assigned-set! x #f) (var-flags-multiply-assigned-set! x #f)) x*)
1738 |        (for-each (lambda (x) (var-flags-assigned-set! x #t) (var-flags-multiply-assigned-set! x #f)) entry-x*)
1739 |        (let ([blocks (Blocks blocks entry-x* (append x* entry-x*))])
1740 |          (for-each (lambda (x) (var-slot-set! x #f)) x*)
1741 |          (for-each (lambda (x) (var-slot-set! x #f)) entry-x*)
1742 |          `(locals (,x* ...) ,blocks))])
1743 |     (Blocks : Blocks (ir entry-x* all-x*) -> Blocks ()
1744 |       [(labels ([,l* ,t*] ...) ,l)
1745 |        (for-each ScanTail! t* l*) ;; build the graph
1746 |        (let* ([artificial-entry-label (make-label 'artifical-entry-node)]
1747 |               [artificial-entry-node (label-graph-node artificial-entry-label)])
1748 |          (graph-node-next-set! artificial-entry-node (list l))
1749 |          (graph-node-assignments-set! artificial-entry-node entry-x*)
1750 |          (let* ([scc* (tarjan-scc (cons artificial-entry-node (map label-graph-node l*)))]
1751 |                 [v (number-scc! scc*)])
1752 |            (build-dom-tree! v)
1753 |            (build-df! v)
1754 |            (insert-phi! v all-x*)
1755 |            (let ([t* (map (lambda (t l) (Tail t l #t)) t* l*)])
1756 |              (for-each (lambda (l) (label-slot-set! l #f)) l*)
1757 |              `(labels ([,l* ,t*] ...) ,l))))])
1758 |     (ScanTail! : Tail (t l) -> * (void)
1759 |       [(begin ,ef* ... ,[* v]) (for-each (lambda (ef) (ScanEffect! ef l)) ef*)]
1760 |       [(goto ,l0) (graph-node-next-set! (label-graph-node l) (list l0))]
1761 |       [(if (,relop ,tr0 ,tr1) (,l0) (,l1))
1762 |        (graph-node-next-set! (label-graph-node l) (list l0 l1))]
1763 |       [(return ,tr) (void)])
1764 |     (ScanEffect! : Effect (ef l) -> * (void)
1765 |       [(set! ,x ,rhs)
1766 |        #;(printf "before in ~s, x: ~s, assigned? ~s, multiply-assigned? ~s~%" (label-unique-name l) (var-unique-name x) (var-flags-assigned? x) (var-flags-multiply-assigned? x))
1767 |        (if (var-flags-assigned? x)
1768 |            (var-flags-multiply-assigned-set! x #t)
1769 |            (var-flags-assigned-set! x #t))
1770 |        #;(printf "after in ~s, x: ~s, assigned? ~s, multiply-assigned? ~s~%" (label-unique-name l) (var-unique-name x) (var-flags-assigned? x) (var-flags-multiply-assigned? x))
1771 |        (let ([n (label-graph-node l)])
1772 |          (graph-node-assignments-set! n
1773 |            (cons x (graph-node-assignments n))))]
1774 |       [else (void)])
1775 |     (Tail : Tail (t l entry?) -> Tail ()
1776 |       (definitions
1777 |         (define (insert-phi phi* ef* l)
1778 |           (fold-left
1779 |             (lambda (ef* phi)
1780 |               (let ([x (phi-x phi)] [l* (phi-l* phi)])
1781 |                 (cons 
1782 |                   (in-context Effect
1783 |                     `(set! ,(var x l) (phi [,(map (lambda (l) (var x l)) l*) ,l*] ...)))
1784 |                 ef*)))
1785 |             ef* phi*))
1786 |         (define (maybe-insert-phi entry? l ef* t)
1787 |           (let ([ef* (if entry? (insert-phi (label-phi* l) ef* l) ef*)])
1788 |             (if (null? ef*)
1789 |                 t
1790 |                 `(begin ,ef* ... ,t)))))
1791 |       [(begin ,[ef*] ... ,[t l #f -> t])
1792 |        (maybe-insert-phi entry? l ef* t)]
1793 |       [(goto ,l0)
1794 |        (maybe-insert-phi entry? l '() `(goto ,l0))]
1795 |       [(if (,relop ,[tr0] ,[tr1]) (,l0) (,l1))
1796 |        (maybe-insert-phi entry? l '() `(if (,relop ,tr0 ,tr1) (,l0) (,l1)))]
1797 |       [(return ,[tr])
1798 |        (maybe-insert-phi entry? l '() `(return ,tr))])
1799 |     (Effect : Effect (ef l) -> Effect ()
1800 |       [(set! ,x ,[rhs]) `(set! ,(var x l) ,rhs)]
1801 |       [(mset! ,[tr0] ,[tr1] ,[tr2]) `(mset! ,tr0 ,tr1 ,tr2)]
1802 |       [(call ,[tr] ,[tr*] ...) `(call ,tr ,tr* ...)])
1803 |     (Rhs : Rhs (rhs l) -> Rhs ())
1804 |     (Triv : Triv (tr l) -> Triv ())
1805 |     (var : var (x l) -> var ()
1806 |       (cond
1807 |         [(var-slot x) => (lambda (as*) (find-match x as* l))]
1808 |         [else x])))
1809 | 
1810 | 
1811 |   (define-language Lflat-funcs
1812 |     (extends Lssa)
1813 |     (Program (prog)
1814 |       (- (letrec ([l* f*] ...) b))
1815 |       (+ (letrec ([l* f*] ...) c* ... c)))
1816 |     (Body (b)
1817 |       (- (locals (x* ...) blocks)))
1818 |     (Blocks (blocks)
1819 |       (- (labels ([l* t*] ...) l)))
1820 |     (Effect (ef)
1821 |       (- (set! x rhs)
1822 |          (mset! tr0 tr1 tr2)
1823 |          (call tr tr* ...)))
1824 |     (Tail (t)
1825 |       (- (if (relop tr0 tr1) (l0) (l1))
1826 |          (goto l)
1827 |          (return tr)
1828 |          (begin ef* ... t)))
1829 |     (Lambda (f)
1830 |       (- (lambda (x* ...) b))
1831 |       (+ (lambda (x* ...) c* ... c)))
1832 |     (Code (c)
1833 |       (+ (label l)
1834 |          (set! x rhs)
1835 |          (mset! tr0 tr1 tr2)
1836 |          (call tr tr* ...)
1837 |          (goto l)
1838 |          (return tr)
1839 |          (if (relop tr0 tr1) (l0) (l1)))))
1840 | 
1841 |   (define-pass flatten-functions : Lssa (ir) -> Lflat-funcs ()
1842 |     (definitions
1843 |       (define (Tail* l* t*)
1844 |         (with-output-language (Lflat-funcs Code)
1845 |           (fold-left
1846 |             (lambda (rc* l t)
1847 |               (Tail t (cons `(label ,l) rc*)))
1848 |             '() l* t*)))
1849 |       (define (Effect* ef* rc*)
1850 |         (fold-left
1851 |           (lambda (rc* ef) (cons (Effect ef) rc*))
1852 |           rc* ef*)))
1853 |     (Program : Program (prog) -> Program ()
1854 |       [(letrec ([,l* ,[f*]] ...) ,[c c*])
1855 |        `(letrec ([,l* ,f*] ...) ,c* ... ,c)])
1856 |     (Lambda : Lambda (f) -> Lambda ()
1857 |       [(lambda (,x* ...) ,[c c*])
1858 |        `(lambda (,x* ...) ,c* ... ,c)])
1859 |     (Body : Body (b) -> Code (c*)
1860 |       [(locals (,x* ...) ,[c c*]) (values c c*)])
1861 |     (Blocks : Blocks (blocks) -> Code (c*)
1862 |       [(labels ([,l* ,t*] ...) ,l)
1863 |        (let ([rc* (if (eq? l (car l*))
1864 |                       (Tail* l* t*)
1865 |                       (Tail*
1866 |                         (cons (make-local-label 'entry) l*)
1867 |                         (cons (with-output-language (Lssa Tail) `(goto ,l)) t*)))])
1868 |          (values (car rc*) (reverse (cdr rc*))))])
1869 |     (Tail : Tail (t rc*) -> Code () ;; cheating, actually returns Code*
1870 |       [(goto ,l) (cons `(goto ,l) rc*)]
1871 |       [(return ,tr) (cons `(return ,tr) rc*)]
1872 |       [(begin ,ef* ... ,t) (Tail t (Effect* ef* rc*))]
1873 |       [(if (,relop ,tr0 ,tr1) (,l0) (,l1))
1874 |        (cons `(if (,relop ,tr0 ,tr1) (,l0) (,l1)) rc*)])
1875 |     (Effect : Effect (ef) -> Code ()))
1876 | 
1877 |   (define-pass eliminate-simple-moves : Lflat-funcs (ir) -> Lflat-funcs ()
1878 |     (definitions
1879 |       (define (Code* c* c)
1880 |         (let loop ([c* c*] [rc* '()])
1881 |           (if (null? c*)
1882 |               (Code c rc*)
1883 |               (loop (cdr c*) (Code (car c*) rc*))))))
1884 |     (Program : Program (prog) -> Program ()
1885 |       [(letrec ([,l* ,[f*]] ...) ,c* ... ,c)
1886 |        (for-each IdentifyMove (cons c c*))
1887 |        (let ([rc* (Code* c* c)])
1888 |          `(letrec ([,l* ,f*] ...) ,(reverse (cdr rc*)) ... ,(car rc*)))])
1889 |     (Lambda : Lambda (ir) -> Lambda ()
1890 |       [(lambda (,x* ...) ,c* ... ,c)
1891 |        (for-each IdentifyMove (cons c c*))
1892 |        (let ([rc* (Code* c* c)])
1893 |          `(lambda (,x* ...) ,(reverse (cdr rc*)) ... ,(car rc*)))])
1894 |     (IdentifyMove : Code (ir) -> * (void)
1895 |       [(set! ,x1 ,x2) (var-slot-set! x1 x2)]
1896 |       [(set! ,x1 ,int2) (var-slot-set! x1 int2)]
1897 |       [else (void)])
1898 |     (Code : Code (c rc*) -> * (rc*) ;; cheating really returning Code*
1899 |       [(set! ,x1 ,x2) rc*]
1900 |       [(set! ,x1 ,int2) rc*]
1901 |       [else (cons (SimpleRewrite c) rc*)])
1902 |     (SimpleRewrite : Code (c) -> Code ())
1903 |     (Triv : Triv (x) -> Triv ()
1904 |       [,x (var x)]
1905 |       [,int int]
1906 |       [,l l])
1907 |     (var : var (x) -> Triv ()
1908 |       (let loop ([target-x x])
1909 |         (let ([next-target-x (var-slot target-x)])
1910 |           (cond
1911 |             [(eq? next-target-x #f)
1912 |              (unless (eq? target-x x) (var-slot-set! x target-x))
1913 |              target-x]
1914 |             [(exact-integer? next-target-x)
1915 |              (var-slot-set! x next-target-x)
1916 |              next-target-x]
1917 |             [else (loop next-target-x)])))))
1918 | 
1919 |   (define-pass generate-llvm-code : Lflat-funcs (ir) -> * (void)
1920 |     (definitions
1921 |       (define calling-convention
1922 |         (if (use-llvm-10-tailcc) "tailcc" "fastcc"))
1923 |       (define (var-printable-name x) (format "%\"~s\"" (var-unique-name x)))
1924 |       (define (label-printable-name l)
1925 |         (if (local-label? l)
1926 |             (format "%~s" (label-unique-name l))
1927 |             (format "@\"~s\"" (label-unique-name l))))
1928 |       (define (relop-to-llvm relop)
1929 |         (case relop
1930 |           [(<) 'slt]
1931 |           [(<=) 'sle]
1932 |           [(=) 'eq]
1933 |           [(>=) 'sge]
1934 |           [(>) 'sgt]
1935 |           [(!=) 'ne]
1936 |           [else (errorf who "unexpected relop ~s" relop)]))
1937 |       (define (binop-to-llvm binop)
1938 |         (case binop
1939 |           [(+) 'add]
1940 |           [(-) 'sub]
1941 |           [(*) 'mul]
1942 |           [(sra) 'ashr]
1943 |           [(logand) 'and]
1944 |           [else (errorf who "unexpected binop ~s" binop)]))
1945 |       (define (printable-triv tr)
1946 |         (cond
1947 |           [(local-label? tr) (format "label ~a" (label-printable-name tr))]
1948 |           [(label? tr)
1949 |            (format "ptrtoint (i64 (~{i64~*~^, ~})* ~a to i64)"
1950 |              (label-slot tr) (label-printable-name tr))]
1951 |           [(var? tr) (var-printable-name tr)]
1952 |           [else (format "~s" tr)]))
1953 |       (define (emit-llvm-prelogue)
1954 |         (printf "source_filename = \"scheme\"~%")
1955 |         (printf "target datalayout = \"e-m:o-i64:64-f80:128-n8:16:32:64-S128\"~%")
1956 |         (printf "target triple = \"x86_64-apple-macosx10.15.0\"~%")
1957 |         (printf "~%")
1958 |         (printf "@.str.nil = private unnamed_addr constant [3 x i8] c\"()\\00\", align 1~%")
1959 |         (printf "@.str.hash_t = private unnamed_addr constant [3 x i8] c\"#t\\00\", align 1~%")
1960 |         (printf "@.str.hash_f = private unnamed_addr constant [3 x i8] c\"#f\\00\", align 1~%")
1961 |         (printf "@.str.void = private unnamed_addr constant [8 x i8] c\"#(void)\\00\", align 1~%")
1962 |         (printf "@.str.proc = private unnamed_addr constant [13 x i8] c\"#(procedure)\\00\", align 1~%")
1963 |         (printf "@.str.fixnum = private unnamed_addr constant [5 x i8] c\"%lld\\00\", align 1~%")
1964 |         (printf "@.str.vector_start = private unnamed_addr constant [3 x i8] c\"#(\\00\", align 1~%")
1965 |         (printf "@.str.space = private unnamed_addr constant [2 x i8] c\" \\00\", align 1~%")
1966 |         (printf "@.str.close_paren = private unnamed_addr constant [2 x i8] c\")\\00\", align 1~%")
1967 |         (printf "@.str.open_paren = private unnamed_addr constant [2 x i8] c\"(\\00\", align 1~%")
1968 |         (printf "@.str.dot = private unnamed_addr constant [4 x i8] c\" . \\00\", align 1~%")
1969 |         (printf "@.str.unknown = private unnamed_addr constant [11 x i8] c\"#(unknown)\\00\", align 1~%")
1970 |         (printf "@.str.newline = private unnamed_addr constant [2 x i8] c\"\\0A\\00\", align 1~%")
1971 |         (printf "~%")
1972 |         (printf "define void @scheme_write(i64 %val) {~%")
1973 |         (printf "entry:~%")
1974 |         (printf "  %is_null = icmp eq i64 %val, ~s ; null?~%" $nil)
1975 |         (printf "  br i1 %is_null, label %nil, label %not_nil~%")
1976 |         (printf "nil:~%")
1977 |         (printf "  call i32 (i8*, ...) @printf(i8* getelementptr inbounds ([3 x i8], [3 x i8]* @.str.nil, i32 0, i32 0))~%")
1978 |         (printf "  br label %exit~%")
1979 |         (printf "not_nil:~%")
1980 |         (printf "  %is_true = icmp eq i64 %val, ~s ; true?~%" $true)
1981 |         (printf "  br i1 %is_true, label %hash_t, label %not_hash_t~%")
1982 |         (printf "hash_t:~%")
1983 |         (printf "  call i32 (i8*, ...) @printf(i8* getelementptr inbounds ([3 x i8], [3 x i8]* @.str.hash_t, i32 0, i32 0))~%")
1984 |         (printf "  br label %exit~%")
1985 |         (printf "not_hash_t:~%")
1986 |         (printf "  %is_false = icmp eq i64 %val, ~s ; false?~%" $false)
1987 |         (printf "  br i1 %is_false, label %hash_f, label %not_hash_f~%")
1988 |         (printf "hash_f:~%")
1989 |         (printf "  call i32 (i8*, ...) @printf(i8* getelementptr inbounds ([3 x i8], [3 x i8]* @.str.hash_f, i32 0, i32 0))~%")
1990 |         (printf "  br label %exit~%")
1991 |         (printf "not_hash_f:~%")
1992 |         (printf "  %is_void = icmp eq i64 %val, ~s ; void?~%" $void)
1993 |         (printf "  br i1 %is_void, label %undef_val, label %not_undef_val~%")
1994 |         (printf "undef_val:~%")
1995 |         (printf "  call i32 (i8*, ...) @printf(i8* getelementptr inbounds ([8 x i8], [8 x i8]* @.str.void, i32 0, i32 0))~%")
1996 |         (printf "  br label %exit~%")
1997 |         (printf "not_undef_val:~%")
1998 |         (printf "  %val_proc_masked = and i64 %val, ~s ; mask with procedure mask~%" mask-procedure)
1999 |         (printf "  %is_proc = icmp eq i64 %val_proc_masked, ~s ; procedure type?~%" tag-procedure)
2000 |         (printf "  br i1 %is_proc, label %procedure, label %not_procedure~%")
2001 |         (printf "procedure:~%")
2002 |         (printf "  call i32 (i8*, ...) @printf(i8* getelementptr inbounds ([13 x i8], [13 x i8]* @.str.proc, i32 0, i32 0))~%")
2003 |         (printf "  br label %exit~%")
2004 |         (printf "not_procedure:~%")
2005 |         (printf "  %val_fixnum_masked = and i64 %val, ~s ; mask with fixnum mask~%" mask-fixnum)
2006 |         (printf "  %is_fixnum = icmp eq i64 %val_fixnum_masked, ~s ; fixnum type?~%" tag-fixnum)
2007 |         (printf "  br i1 %is_fixnum, label %fixnum, label %not_fixnum~%")
2008 |         (printf "fixnum:~%")
2009 |         (printf "  %unfixed = ashr i64 %val, ~s ; fixnum shift~%" shift-fixnum)
2010 |         (printf "  call i32 (i8*, ...) @printf(i8* getelementptr inbounds ([5 x i8], [5 x i8]* @.str.fixnum, i32 0, i32 0), i64 %unfixed)~%")
2011 |         (printf "  br label %exit~%")
2012 |         (printf "not_fixnum:~%")
2013 |         (printf "  %val_vector_masked = and i64 %val, ~s ; mask with vector mask~%" mask-vector)
2014 |         (printf "  %is_vector = icmp eq i64 %val_vector_masked, ~s ; vector tag~%" tag-vector)
2015 |         (printf "  br i1 %is_vector, label %vector, label %not_vector~%")
2016 |         (printf "vector:~%")
2017 |         (printf "  call i32 (i8*, ...) @printf(i8* getelementptr inbounds ([3 x i8], [3 x i8]* @.str.vector_start, i32 0, i32 0))~%")
2018 |         (printf "  %vec_len_addr = add i64 %val, ~s ; pointer to vector-length~%" (- disp-vector-length tag-vector))
2019 |         (printf "  %vec_len_ptr = inttoptr i64 %vec_len_addr to i64*~%")
2020 |         (printf "  %vec_len = load i64, i64* %vec_len_ptr, align 8 ; vector-length~%")
2021 |         (printf "  %vec_data_addr = add i64 %val, ~s ; pointr to vector-data tart~%" (- disp-vector-data tag-vector))
2022 |         (printf "  br label %vector_loop~%")
2023 |         (printf "vector_loop:~%")
2024 |         (printf "  %vec_len.2 = phi i64 [ %vec_len, %vector ], [ %vec_len.3, %vector_cont ]~%")
2025 |         (printf "  %vec_data_addr.2 = phi i64 [ %vec_data_addr, %vector ], [ %vec_data_addr.3, %vector_cont ]~%")
2026 |         (printf "  %vec_data_ptr = inttoptr i64 %vec_data_addr.2 to i64*~%")
2027 |         (printf "  %vec_data = load i64, i64* %vec_data_ptr, align 8 ; vector data~%")
2028 |         (printf "  call void @scheme_write(i64 %vec_data)~%")
2029 |         (printf "  %vec_len.3 = sub i64 %vec_len.2, ~s~%" word-size)
2030 |         (printf "  %vec_data_addr.3 = add i64 %vec_data_addr.2, ~s~%" word-size)
2031 |         (printf "  %is_vec_end = icmp eq i64 %vec_len.3, 0~%")
2032 |         (printf "  br i1 %is_vec_end, label %vector_end, label %vector_cont~%")
2033 |         (printf "vector_cont:~%")
2034 |         (printf "  call i32 (i8*, ...) @printf(i8* getelementptr inbounds ([2 x i8], [2 x i8]* @.str.space, i32 0, i32 0))~%")
2035 |         (printf "  br label %vector_loop~%")
2036 |         (printf "vector_end:~%")
2037 |         (printf "  call i32 (i8*, ...) @printf(i8* getelementptr inbounds ([2 x i8], [2 x i8]* @.str.close_paren, i32 0, i32 0))~%")
2038 |         (printf "  br label %exit~%")
2039 |         (printf "not_vector:~%")
2040 |         (printf "  %val_pair_masked = and i64 %val, ~s ; pair mask~%" mask-pair)
2041 |         (printf "  %is_pair = icmp eq i64 %val_pair_masked, ~s ; tag pair~%" tag-pair)
2042 |         (printf "  br i1 %is_pair, label %pair, label %not_pair~%")
2043 |         (printf "pair:~%")
2044 |         (printf "  call i32 (i8*, ...) @printf(i8* getelementptr inbounds ([2 x i8], [2 x i8]* @.str.open_paren, i32 0, i32 0))~%")
2045 |         (printf "  br label %list_loop~%")
2046 |         (printf "list_loop:~%")
2047 |         (printf "  %pr = phi i64 [%val, %pair], [%cdr_val, %list_really_cont]~%")
2048 |         (printf "  %car_addr = add i64 %pr, ~s ; car disp~%" (- disp-car tag-pair))
2049 |         (printf "  %car_ptr = inttoptr i64 %car_addr to i64*~%")
2050 |         (printf "  %car_val = load i64, i64* %car_ptr, align 8 ; car~%")
2051 |         (printf "  call void @scheme_write(i64 %car_val)~%")
2052 |         (printf "  %cdr_addr = add i64 %pr, ~s ; cdr disp~%" (- disp-cdr tag-pair))
2053 |         (printf "  %cdr_ptr = inttoptr i64 %cdr_addr to i64*~%")
2054 |         (printf "  %cdr_val = load i64, i64* %cdr_ptr, align 8 ; cdr~%")
2055 |         (printf "  %cdr_val_is_null = icmp eq i64 %cdr_val, ~s ; null?~%" $nil)
2056 |         (printf "  br i1 %cdr_val_is_null, label %list_end, label %list_cont~%")
2057 |         (printf "list_end:~%")
2058 |         (printf "  call i32 (i8*, ...) @printf(i8* getelementptr inbounds ([2 x i8], [2 x i8]* @.str.close_paren, i32 0, i32 0))~%")
2059 |         (printf "  br label %exit~%")
2060 |         (printf "list_cont:~%")
2061 |         (printf "  %cdr_val_pair_masked = and i64 %cdr_val, ~s ; mask pair~%" mask-pair)
2062 |         (printf "  %cdr_val_is_pair = icmp eq i64 %cdr_val_pair_masked, ~s ; tag pair~%" tag-pair)
2063 |         (printf "  br i1 %cdr_val_is_pair, label %list_really_cont, label %list_improper_end~%")
2064 |         (printf "list_really_cont:~%")
2065 |         (printf "  call i32 (i8*, ...) @printf(i8* getelementptr inbounds ([2 x i8], [2 x i8]* @.str.space, i32 0, i32 0))~%")
2066 |         (printf "  br label %list_loop~%")
2067 |         (printf "list_improper_end:~%")
2068 |         (printf "  call i32 (i8*, ...) @printf(i8* getelementptr inbounds ([4 x i8], [4 x i8]* @.str.dot, i32 0, i32 0))~%")
2069 |         (printf "  call void @scheme_write(i64 %cdr_val)~%")
2070 |         (printf "  call i32 (i8*, ...) @printf(i8* getelementptr inbounds ([2 x i8], [2 x i8]* @.str.close_paren, i32 0, i32 0))~%")
2071 |         (printf "  br label %exit~%")
2072 |         (printf "not_pair:~%")
2073 |         (printf "  call i32 (i8*, ...) @printf(i8* getelementptr inbounds ([11 x i8], [11 x i8]* @.str.unknown, i32 0, i32 0))~%")
2074 |         (printf "  br label %exit~%")
2075 |         (printf "exit:~%")
2076 |         (printf "  ret void~%")
2077 |         (printf "}~%")
2078 |         (printf "~%")
2079 |         (printf "declare i32 @printf(i8*, ...)~%")
2080 |         (printf "declare i8* @malloc(i64)~%")
2081 |         (printf "~%"))
2082 |       (define (emit-main-function l)
2083 |         (printf "define i32 @main(i32, i8**) {~%")
2084 |         (printf "  %result = call ~a i64 ~a()~%" calling-convention (label-printable-name l))
2085 |         (printf "  call void @scheme_write(i64 %result)~%")
2086 |         (printf "  call i32 (i8*, ...) @printf(i8* getelementptr inbounds ([2 x i8], [2 x i8]* @.str.newline, i32 0, i32 0))~%")
2087 |         (printf "  ret i32 0~%")
2088 |         (printf "}~%"))
2089 |       (define (emit-llvm-prologue)
2090 |         (void))
2091 |       )
2092 |     (Program : Program (prog) -> * (void)
2093 |       [(letrec ([,l* ,f*] ...) ,c* ... ,c)
2094 |        (for-each LambdaArgs f* l*)
2095 |        (emit-llvm-prelogue)
2096 |        (for-each Lambda f* l*)
2097 |        (let ([entry (make-label 'scheme-entry)])
2098 |          (Lambda
2099 |            (with-output-language (Lflat-funcs Lambda)
2100 |              `(lambda () ,c* ... ,c))
2101 |            entry)
2102 |          (emit-main-function entry))
2103 |        (emit-llvm-prologue)])
2104 |     (LambdaArgs : Lambda (f l) -> * (void)
2105 |       [(lambda (,x* ...) ,c* ... ,c) (label-slot-set! l x*)])
2106 |     (Lambda : Lambda (f l) -> * (void)
2107 |       [(lambda (,x* ...) ,c* ... ,c)
2108 |        (printf "define ~a i64 ~a(~{i64 ~a~^, ~}) {~%" calling-convention (label-printable-name l) (map var-printable-name x*))
2109 |        (fold-left (lambda (i x) (var-slot-set! x i) (fx+ i 1)) 0 x*)
2110 |        (for-each Code c*)
2111 |        (Code c)
2112 |        (printf "}~%")])
2113 |     (Code : Code (c) -> * (void)
2114 |       [(label ,l)
2115 |        (printf "~s:~%" (label-unique-name l))]
2116 |       [(set! ,x ,rhs) (Rhs rhs x)]
2117 |       [(mset! ,tr0 ,tr1 ,tr2)
2118 |        (let ([untagged (make-var 'untagged)]
2119 |              [ptr (make-var 'ptr)])
2120 |          (printf "  ~a = add i64 ~a, ~a~%" (var-printable-name untagged) (printable-triv tr0) (printable-triv tr1))
2121 |          (printf "  ~a = inttoptr i64 ~a to i64*~%" (var-printable-name ptr) (var-printable-name untagged))
2122 |          (printf "  store i64 ~a, i64* ~a, align 8~%" (printable-triv tr2) (var-printable-name ptr)))]
2123 |       [(call ,l ,tr* ...)
2124 |        (printf "  call ~a i64 ~a(~{i64 ~a~^, ~})~%" calling-convention (label-printable-name l) (map printable-triv tr*))]
2125 |       [(call ,tr ,tr* ...)
2126 |        (let ([fptr (make-var 'fptr)])
2127 |          (printf "  ~a = inttoptr i64 ~a to i64 (~{i64~*~^, ~})*~%" (var-printable-name fptr) (printable-triv tr) tr*)
2128 |          (printf "  call ~a i64 ~a(~{i64 ~a~^, ~})~%" calling-convention (var-printable-name fptr) (map printable-triv tr*)))]
2129 |       [(goto ,l) (printf "  br label ~a~%" (label-printable-name l))]
2130 |       [(return ,tr) (printf "  ret i64 ~a~%" (printable-triv tr))]
2131 |       [(if (,relop ,tr0 ,tr1) (,l0) (,l1))
2132 |        (let ([cmp (make-var 'cmp)])
2133 |          (printf "  ~a = icmp ~a i64 ~a, ~a~%" (var-printable-name cmp) (relop-to-llvm relop) (printable-triv tr0) (printable-triv tr1))
2134 |          (printf "  br i1 ~a, label ~a, label ~a~%" (var-printable-name cmp) (label-printable-name l0) (label-printable-name l1)))])
2135 |     (Rhs : Rhs (rhs x) -> * (void)
2136 |       [(phi (,tr* ,l*) ...)
2137 |        (printf "  ~a = phi i64 ~{[~{~a~^, ~}]~^, ~}~%" (var-printable-name x) (map list (map printable-triv tr*) (map label-printable-name l*)))]
2138 |       [,tr
2139 |        (printf "  ~a = ~a~%" (var-printable-name x) (printable-triv tr))]
2140 |       [(alloc ,tr)
2141 |        (let ([ptr (make-var 'ptr)])
2142 |          (printf "  ~a = call i8* @malloc(i64 ~a)~%" (var-printable-name ptr) (printable-triv tr))
2143 |          (printf "  ~a = ptrtoint i8* ~a to i64~%" (var-printable-name x) (var-printable-name ptr)))]
2144 |       [(mref ,tr0 ,tr1)
2145 |        (let ([untagged (make-var 'untagged)]
2146 |              [ptr (make-var 'ptr)])
2147 |          (printf "  ~a = add i64 ~a, ~a~%" (var-printable-name untagged) (printable-triv tr0) (printable-triv tr1))
2148 |          (printf "  ~a = inttoptr i64 ~a to i64*~%" (var-printable-name ptr) (var-printable-name untagged))
2149 |          (printf "  ~a = load i64, i64* ~a, align 8~%" (var-printable-name x) (var-printable-name ptr)))]
2150 |       [(,binop ,tr0 ,tr1)
2151 |        (printf "  ~a = ~a i64 ~a, ~a~%" (var-printable-name x) (binop-to-llvm binop) (printable-triv tr0) (printable-triv tr1))]
2152 |       [(tail-call ,l ,tr* ...)
2153 |        (printf "  ~a = tail call ~a i64 ~a(~{i64 ~a~^, ~})~%" (var-printable-name x) calling-convention (label-printable-name l) (map printable-triv tr*))]
2154 |       [(tail-call ,tr ,tr* ...)
2155 |        (let ([fptr (make-var 'fptr)])
2156 |          (printf "  ~a = inttoptr i64 ~a to i64 (~{i64~*~^, ~})*~%" (var-printable-name fptr) (printable-triv tr) tr*)
2157 |          (printf "  ~a = tail call ~a i64 ~a(~{i64 ~a~^, ~})~%" (var-printable-name x) calling-convention (var-printable-name fptr) (map printable-triv tr*)))]
2158 |       [(call ,l ,tr* ...)
2159 |        (printf "  ~a = call ~a i64 ~a(~{i64 ~a~^, ~})~%" (var-printable-name x) calling-convention (label-printable-name l) (map printable-triv tr*))]
2160 |       [(call ,tr ,tr* ...)
2161 |        (let ([fptr (make-var 'fptr)])
2162 |          (printf "  ~a = inttoptr i64 ~a to i64 (~{i64~*~^, ~})*~%" (var-printable-name fptr) (printable-triv tr) tr*)
2163 |          (printf "  ~a = call ~a i64 ~a(~{i64 ~a~^, ~})~%" (var-printable-name x) calling-convention (var-printable-name fptr) (map printable-triv tr*)))])
2164 |     (Program ir))
2165 | 
2166 |   (define (rewrite-result x)
2167 |     (cond
2168 |       [(equal? x '#(void)) (void)]
2169 |       [(equal? x '#(procedure)) (lambda () (void))]
2170 |       [(pair? x) (cons (rewrite-result (car x)) (rewrite-result (cdr x)))]
2171 |       [(vector? x) (vector-map rewrite-result x)]
2172 |       [else x]))
2173 | 
2174 |   (define-syntax define-compiler
2175 |     (lambda (x)
2176 |       (syntax-case x ()
2177 |         [(_ name (pass ... last-pass))
2178 |          (with-implicit (name all-passes)
2179 |            #'(begin
2180 |                (define all-passes '(pass ... last-pass))
2181 |                (define name
2182 |                  (lambda (x)
2183 |                    (let* ([x (let ([x (pass x)])
2184 |                                (when (memq 'pass (traced-passes))
2185 |                                  (printf "~s output:~%" 'pass)
2186 |                                  (pretty-print ((pass-output-unparser pass) x)))
2187 |                                x)]
2188 |                           ...)
2189 |                      (let-values ([(op p) (open-string-output-port)])
2190 |                        (parameterize ([current-output-port op]) (last-pass x))
2191 |                        (let ([str (p)])
2192 |                          (with-output-to-file "t.ll" (lambda () (display str)) 'replace)
2193 |                          (when (memq 'last-pass (traced-passes))
2194 |                            (printf "~s output:~%" 'last-pass)
2195 |                            (display str))
2196 |                          (system (format "clang -O3 -o t t.ll"))
2197 |                          (when (file-exists? "t.out") (delete-file "t.out"))
2198 |                          (when (file-exists? "t.err") (delete-file "t.err"))
2199 |                          (system "./t > t.out 2> t.err")
2200 |                          (rewrite-result (call-with-input-file "t.out" read)))))))))])))
2201 | 
2202 |   (define-compiler tiny-compile
2203 |     (parse-scheme
2204 |      convert-complex-datum
2205 |      uncover-assigned!
2206 |      purify-letrec
2207 |      convert-assignments
2208 |      optimize-direct-call
2209 |      remove-anonymous-lambda
2210 |      sanitize-binding-forms
2211 |      uncover-free
2212 |      convert-closures
2213 |      optimize-known-call
2214 |      introduce-procedure-primitives
2215 |      lift-letrec
2216 |      normalize-context
2217 |      specify-representation
2218 |      uncover-locals
2219 |      remove-let
2220 |      remove-complex-opera*
2221 |      flatten-set!
2222 |      expose-basic-blocks
2223 |      optimize-blocks
2224 |      convert-to-ssa
2225 |      flatten-functions
2226 |      eliminate-simple-moves
2227 |      generate-llvm-code
2228 |      ))
2229 | 
2230 |   (define traced-passes
2231 |     (let ([passes '()])
2232 |       (case-lambda
2233 |         [() passes]
2234 |         [(x) (cond
2235 |                [(or (eq? x #f) (null? x)) (set! passes '())]
2236 |                [(eq? x #t) (set! passes all-passes)]
2237 |                [(symbol? x)
2238 |                 (cond
2239 |                   [(memq x passes) (set! passes (remq x passes))] ;; remove it if it is there
2240 |                   [(memq x all-passes) (set! passes (cons x passes))] ;; add it if it is valid
2241 |                   [else (errorf 'traced-passes "unrecognized pass ~s" x)])]
2242 |                [(and (list? x) (for-all symbol? x))
2243 |                 (unless (null? (filter (lambda (x) (memq x all-passes)) x)) (errorf 'traced-passes "~s are not passes" (filter (lambda (x) (memq x all-passes)) x)))
2244 |                 (for-each traced-passes x)]
2245 |                [else (errorf 'traced-passes "expected boolean, symbol, or list, but got ~s" x)])])))
2246 | 
2247 |   (define tests
2248 |     '(7
2249 |       '()
2250 |       #f
2251 |       '(1 2 3 4)
2252 |       '#(5 4 3 2 1)
2253 |       '#((1 2) (3 4))
2254 |       '(#(1 2) #(3 4))
2255 |       '(#(#t #f 1) #(#f #t 2))
2256 |       (or 10 #f)
2257 |       (and #t 45 7)
2258 |       (+ 4 5)
2259 |       (- 1 4)
2260 |       (* 7 9)
2261 |       (cons 1 '())
2262 |       (car '(1 2))
2263 |       (cdr '(1 2))
2264 |       (if #t 1 2)
2265 |       (pair? '(1 2))
2266 |       (pair? '())
2267 |       (vector? '#(1 2))
2268 |       (vector? '(1 2))
2269 |       (boolean? #f)
2270 |       (boolean? 7)
2271 |       (null? '())
2272 |       (null? '(1 2))
2273 |       (fixnum? 1234)
2274 |       (fixnum? '())
2275 |       (procedure? (lambda (x) x))
2276 |       (procedure? 7)
2277 |       (<= 1 8)
2278 |       (<= 8 1)
2279 |       (<= 1 1)
2280 |       (< 8 1)
2281 |       (< 1 8)
2282 |       (= 1 1)
2283 |       (= 1 0)
2284 |       (>= 8 1)
2285 |       (>= 1 8)
2286 |       (>= 1 1)
2287 |       (> 8 1)
2288 |       (> 1 8)
2289 |       (not #f)
2290 |       (not 10)
2291 |       ;; value primitives in effect context
2292 |       (let ([x 5]) (* 3 x) x)
2293 |       (let ([x 5]) (+ 3 x) x)
2294 |       (let ([x 5]) (- 3 x) x)
2295 |       (let ([x (cons 1 5)]) (car x) x)
2296 |       (let ([x (cons 1 5)]) (cdr x) x)
2297 |       (let ([x 1] [y 5]) (cons x y) x)
2298 |       (begin (make-vector 5) 7)
2299 |       (let ([v (make-vector 2)]) (vector-length v) 7)
2300 |       (let ([v (make-vector 2)]) (vector-ref v 0) 7)
2301 |       (begin (void) 5)
2302 |       ;; value primitives in pred
2303 |       (if (+ 3 5) '7 8)
2304 |       (if (not (* 3 5)) '7 8)
2305 |       (if (- 3 5) '7 8)
2306 |       (if (cons 3 5) 7 8)
2307 |       (if (car (cons #t #f)) 7 8)
2308 |       (if (cdr (cons #t #f)) 7 8)
2309 |       (if (make-vector 10) 7 8)
2310 |       (let ([v (make-vector 10)]) (if (vector-length v) 7 8))
2311 |       (let ([v (make-vector 10)])
2312 |         (vector-set! v 0 #t)
2313 |         (if (vector-ref v 0) 7 8))
2314 |       (if (void) 7 8)
2315 |       ;; pred prims in value
2316 |       (< 7 8)
2317 |       (let () (<= 7 8))
2318 |       (= 7 8)
2319 |       (letrec () (>= 7 8))
2320 |       (> 7 8)
2321 |       (let () (boolean? #f))
2322 |       (not #t)
2323 |       (let ([x (cons 1 '())] [y (cons 1 '())]) (eq? x y))
2324 |       (fixnum? 7)
2325 |       (null? '())
2326 |       (letrec () (pair? (cons 1 '())))
2327 |       (vector? (make-vector 1))
2328 |       (or 5 7 #f 10 11)
2329 |       (and #t #t 10 100)
2330 |       ;; pred prims in effect
2331 |       (letrec () (begin (< 7 8) 7))
2332 |       (begin (<= '7 '8) '7)
2333 |       (letrec () (= 7 8) 7)
2334 |       (begin (>= 7 8) 7)
2335 |       (letrec () (begin (> 7 8) 8))
2336 |       (letrec () (boolean? #f) 9)
2337 |       (letrec () 
2338 |         (let ([x (cons 1 '())] [y (cons 1 '())])
2339 |           (begin (eq? x y) 10)))
2340 |       (letrec () (begin (fixnum? 7) 10))
2341 |       (let () (null? '()) 15)
2342 |       (letrec () (pair? (cons 1 '())) 20)
2343 |       (let () (begin (vector? (make-vector '1)) '10))
2344 |       ;; effect prims in value
2345 |       (letrec () (set-car! (cons 1 2) 10))
2346 |       (let () (set-cdr! (cons 1 2) 14))
2347 |       (vector-set! (make-vector 4) 0 10)
2348 |       ;; effect prims in pred
2349 |       (if (set-car! (cons 1 2) 10) 7 8)
2350 |       (letrec () (if (set-cdr! (cons 1 2) 14) 9 10))
2351 |       (letrec () (if (vector-set! (make-vector 4) 0 10) 11 12))
2352 |   
2353 |       (let ([x '(1 2)]) (eq? x x))
2354 |       (let ([x '(1 2)] [y '(1 2)]) (eq? x y))
2355 |       (+ (let ([x 7] [y 2])
2356 |            (if (if (= x 7) (< y 0) (<= 0 y)) 77 88))
2357 |          99)
2358 |       (if (= (+ 7 (* 2 4)) (- 20 (+ (+ 1 1) (+ (+ 1 1) 1))))
2359 |           (+ 1 (+ 1 (+ 1 (+ 1 (+ 1 10)))))
2360 |           0)
2361 |       (let ([v (make-vector 3)])
2362 |         (vector-set! v 0 1)
2363 |         (vector-set! v 1 2)
2364 |         (vector-set! v 2 3)
2365 |         v)
2366 |       (cons (let ([f (lambda (h v) (* h v))])
2367 |               (let ([k (lambda (x) (+ x 5))])
2368 |                 (letrec ([x 15])
2369 |                   (letrec ([g (lambda (x) (+ 1 x))])
2370 |                     (k (g (let ([g 3]) (f g x))))))))
2371 |             '())
2372 |       (let ([n 4])
2373 |         (let ([v (make-vector n)])
2374 |           (letrec ([iota-fill! (lambda (v i n)
2375 |                                  (if (< i n)
2376 |                                      (begin
2377 |                                        (vector-set! v i i)
2378 |                                        (iota-fill! v (+ i 1) n))))])
2379 |             (iota-fill! v 0 n)
2380 |             v)))
2381 |       (let ([x (cons '1 '())])
2382 |         (let ([x (cons '2 x)])
2383 |           (let ([x (cons '3 x)])
2384 |             (let ([x (cons '4 x)])
2385 |               (let ([x (cons '5 x)])
2386 |                 x)))))
2387 |       (let ([n 5])
2388 |         (let ([a 1])
2389 |           (let ([a (* a n)])
2390 |             (let ([n (- n 1)])
2391 |               (let ([a (* a n)])
2392 |                 (let ([n (- n 1)])
2393 |                   (let ([a (* a n)])
2394 |                     (let ([n (- n 1)])
2395 |                       (let ([a (* a n)])
2396 |                         a)))))))))
2397 |       (let ((n 17) (s 18) (t 19))
2398 |         (let ((st (make-vector 5)))
2399 |           (vector-set! st 0 n)
2400 |           (vector-set! st 1 s)
2401 |           (vector-set! st 2 t)
2402 |           (if (not (vector? st)) 10000 (vector-length st))))
2403 |       (letrec ([list4 (lambda (a b c d) (cons a (cons b (cons c (cons d '())))))])
2404 |         (let ([pair '(1 . 2)] [vect (make-vector 3)])
2405 |           (list4 (set-car! pair 7) (set-cdr! pair 10) (vector-set! vect 0 16) '())))
2406 |       (letrec ([f (lambda (p)
2407 |                       (- (vector-ref
2408 |                            (vector-ref (vector-ref (vector-ref (vector-ref p 0) 0) 1) 0)
2409 |                            (vector-ref (vector-ref p 1) (vector-ref (vector-ref p 0) 4)))
2410 |                          (vector-ref
2411 |                            (vector-ref p (vector-ref p 2))
2412 |                            (vector-ref (vector-ref p 0) (vector-ref p 4)))))]
2413 |                [x (make-vector 6)]
2414 |                [y (make-vector 7)])
2415 |           (begin
2416 |             (vector-set! x 0 y)
2417 |             (vector-set! x 1 x)
2418 |             (vector-set! y 0 x)
2419 |             (vector-set! y '1 '-4421)
2420 |             (vector-set! x '2 '0)
2421 |             (vector-set! x '3 '-37131)
2422 |             (vector-set! x '4 '4)
2423 |             (vector-set! x '5 '6)
2424 |             (vector-set! y '2 '-55151)
2425 |             (vector-set! y '3 '-32000911)
2426 |             (vector-set! y '4 '5)
2427 |             (vector-set! y '5 '55)
2428 |             (vector-set! y '6 '-36)
2429 |             (* (f x) 2)))
2430 |       (let ([vect (make-vector 5)])
2431 |         (vector-set! vect 0 123)
2432 |         (vector-set! vect 1 10)
2433 |         (vector-set! vect 2 7)
2434 |         (vector-set! vect 3 12)
2435 |         (vector-set! vect 4 57)
2436 |         (letrec ([vector-scale! 
2437 |                    (lambda (vect scale)
2438 |                      (let ([size (vector-length vect)])
2439 |                        (letrec ([f (lambda (idx)
2440 |                                      (if (>= idx 1)
2441 |                                        (let ([idx (- idx 1)])
2442 |                                          (vector-set! vect idx
2443 |                                                       (* (vector-ref vect idx)
2444 |                                                          scale))
2445 |                                          (f idx))))])
2446 |                          (f size))))])
2447 |           (vector-scale! vect 10))
2448 |           (letrec ([vector-sum (lambda (vect)
2449 |                                  (letrec ([f (lambda (idx)
2450 |                                                (if (< idx 1)
2451 |                                                    0
2452 |                                                    (+ (vector-ref vect (- idx 1))
2453 |                                                       (f (- idx 1)))))])
2454 |                                    (f (vector-length vect))))])
2455 |             (vector-sum vect)))
2456 |       (letrec ([a (lambda (u v w x) 
2457 |                     (if (= u 0) 
2458 |                         (b v w x)
2459 |                         (a (- u 1) v w x)))]
2460 |                [b (lambda (q r x)
2461 |                     (let ([p (* q r)])
2462 |                       (e (* q r) p x)))]
2463 |                [c (lambda (x) (* 5 x))]
2464 |                [e (lambda (n p x)
2465 |                     (if (= n '0) 
2466 |                         (c p)
2467 |                         (o (- n 1) p x)))]
2468 |                [o (lambda (n p x) 
2469 |                     (if (= 0 n)
2470 |                         (c x)
2471 |                         (e (- n 1) p x)))])
2472 |         (let ([x 5])
2473 |           (a 3 2 1 x)))
2474 |       ((letrec ([length (lambda (ptr)
2475 |                           (if (null? ptr) 0 (+ 1 (length (cdr ptr)))))])
2476 |          length)
2477 |        '(5 10 11 5 15))
2478 |       (letrec ([count-leaves (lambda (p)
2479 |                                (if (pair? p)
2480 |                                    (+ (count-leaves (car p))
2481 |                                       (count-leaves (cdr p)))
2482 |                                    1))])
2483 |         (count-leaves 
2484 |           (cons 
2485 |             (cons '0 (cons '0 '0))
2486 |             (cons 
2487 |               (cons (cons (cons '0 (cons '0 '0)) '0) '0)
2488 |               (cons 
2489 |                 (cons (cons '0 '0) (cons '0 (cons '0 '0)))
2490 |                 (cons (cons '0 '0) '0))))))
2491 |       (letrec ([add1 (lambda (n) (+ n 1))]
2492 |                [map (lambda (f ls)
2493 |                       (if (null? ls) '() (cons (f (car ls)) (map f (cdr ls)))))]
2494 |                [sum (lambda (ls)
2495 |                         (if (null? ls) 0 (+ (car ls) (sum (cdr ls)))))])
2496 |         (let ([ls '(5 4 3 2 1)])
2497 |           (let ([ls (cons '10 (cons '9 (cons '8 (cons '7 (cons '6 ls)))))])
2498 |             (sum (map add1 ls)))))
2499 |       (letrec ([list-ref (lambda (ls offset)
2500 |                              (if (= offset 0)
2501 |                                  (car ls)
2502 |                                  (list-ref (cdr ls) (- offset 1))))]
2503 |                [add (lambda (v w) (+ v w))]
2504 |                [sub (lambda (v w) (- v w))]
2505 |                [mult (lambda (v w) (* v w))]
2506 |                [expt (lambda (v w) (if (= w 0) 1 (* v (expt v (- w 1)))))]
2507 |                [selector (lambda (op* sel rand1 rand2)
2508 |                              (if (null? sel)
2509 |                                  0
2510 |                                  (cons ((list-ref op* (car sel))
2511 |                                         (car rand1) (car rand2))
2512 |                                        (selector op* (cdr sel) (cdr rand1)
2513 |                                                  (cdr rand2)))))]
2514 |                [sum (lambda (ls) (if (pair? ls) (+ (car ls) (sum (cdr ls))) 0))])
2515 |         (sum (selector (cons add (cons sub (cons mult (cons expt '()))))
2516 |                        '(2 0 1 3 2) '(5 9 10 2 3) '(3 1 3 3 8))))
2517 |       (letrec ([thunk-num (lambda (n) (lambda () n))]
2518 |                [force (lambda (th) (th))]
2519 |                [add-ths (lambda (th1 th2 th3 th4)
2520 |                           (+ (+ (force th1) (force th2))
2521 |                              (+ (force th3) (force th4))))])
2522 |         (add-ths (thunk-num 5) (thunk-num 17) (thunk-num 7) (thunk-num 9)))
2523 |       (letrec ([x 7] [f (lambda () x)]) (f))
2524 |       ((lambda (y) ((lambda (f) (f (f y))) (lambda (y) y))) 4)
2525 |       (let ([double (lambda (a) (+ a a))]) (double 10))
2526 |       (let ([t #t] [f #f])
2527 |         (letrec ((even (lambda (x) (if (= x 0) t (odd (- x 1)))))
2528 |                  (odd (lambda (x) (if (= x 0) f (even (- x 1))))))
2529 |           (odd 13)))
2530 |       (letrec ([remq (lambda (x ls)
2531 |                        (if (null? ls)
2532 |                            '()
2533 |                            (if (eq? (car ls) x)
2534 |                                (remq x (cdr ls))
2535 |                                (cons (car ls) (remq x (cdr ls))))))])
2536 |         (remq 3 '(3 1 3)))
2537 |       (letrec ([make-param (lambda (val)
2538 |                              (let ([x val])
2539 |                                (letrec ([param (lambda (set val)
2540 |                                                  (if set (set! x val) x))])
2541 |                                  param)))])
2542 |         (let ([p (make-param 10)])
2543 |           (p #t 15)
2544 |           (p #f #f)))
2545 |       (let ([x 0])
2546 |         (letrec ([inc (lambda () (set! x (+ x 1)))]
2547 |                  [dec (lambda () (set! x (- x 1)))])
2548 |           (inc) (dec) (dec) (inc) (inc) (inc) (dec) (inc) x))
2549 |       (letrec ([gcd (lambda (x y)
2550 |                       (if (= y 0) 
2551 |                           x 
2552 |                           (gcd (if (> x y) (- x y) x)
2553 |                                (if (> x y) y (- y x)))))])
2554 |         (gcd 1071 1029))
2555 |       (letrec ([sub1 (lambda (n) (- n 1))]
2556 |                [fib (lambda (n)
2557 |                       (if (= 0 n)
2558 |                           0
2559 |                           (if (= 1 n)
2560 |                               1
2561 |                               (+ (fib (sub1 n))
2562 |                                  (fib (sub1 (sub1 n)))))))])
2563 |         (fib 10))
2564 |       (letrec ([ack (lambda (m n)
2565 |                       (if (= m 0)
2566 |                           (+ n 1)
2567 |                           (if (if (> m 0) (= n 0) #f)
2568 |                               (ack (- m 1) 1)
2569 |                               (ack (- m 1) (ack m (- n 1))))))])
2570 |         (ack 2 4))
2571 |       (letrec ([fib (lambda (n) 
2572 |                       (letrec ([fib (lambda (n a b)
2573 |                                       (if (= n 0)
2574 |                                           a
2575 |                                           (fib (- n 1) b (+ b a))))])
2576 |                         (fib n 0 1)))])
2577 |         (fib 5))
2578 |       ((((((lambda (x)
2579 |               (lambda (y)
2580 |                 (lambda (z)
2581 |                   (lambda (w)
2582 |                     (lambda (u)
2583 |                       (+ x (+ y (+ z (+ w u)))))))))
2584 |            5) 6) 7) 8) 9)
2585 |       (let ([t #t] [f #f])
2586 |         (let ([bools (cons t f)] [id (lambda (x) (if (not x) f t))])
2587 |           (letrec
2588 |             ([even (lambda (x) (if (= x 0) (id (car bools)) (odd (- x 1))))]
2589 |              [odd (lambda (y) (if (= y 0) (id (cdr bools)) (even (- y 1))))])
2590 |             (odd 5))))
2591 |       (let ([x 7] [y 4])
2592 |         (or (and (fixnum? x) (= x 4) (fixnum? y) (= y 7))
2593 |             (and (fixnum? x) (= x 7) (fixnum? y) (= y 4))))
2594 |       (let ((y '()) (z 10))
2595 |         (let ((test-ls (cons 5 y)))
2596 |           (set! y (lambda (f)
2597 |                     ((lambda (g) (f (lambda (x) ((g g) x))))
2598 |                      (lambda (g) (f (lambda (x) ((g g) x)))))))
2599 |           (set! test-ls (cons z test-ls))
2600 |           (letrec ((length (lambda (ls)
2601 |                              (if (null? ls) 0 (+ 1 (length (cdr ls)))))))
2602 |             (let ((len (length test-ls)))
2603 |               (eq? (begin
2604 |                      (set! length (y (lambda (len)
2605 |                                        (lambda (ls)
2606 |                                          (if (null? ls)
2607 |                                              0
2608 |                                              (+ 1 (len (cdr ls))))))))
2609 |                      (length test-ls))
2610 |                    len)))))
2611 |       (letrec ([if-test (lambda (n x y)
2612 |                           (if (= n 0)
2613 |                               (vector-set! x 0 (+ (vector-ref x 0)
2614 |                                                   (vector-ref y 0)))
2615 |                               (vector-set! y 0 (+ (vector-ref y 0)
2616 |                                                   (vector-ref x 0))))
2617 |                           (vector-set! x 0 (+ (vector-ref x 0) n))
2618 |                           (if (if (= n (vector-ref y 0)) #f #t)
2619 |                               (+ n (vector-ref x 0))
2620 |                               (+ n (vector-ref y 0))))])
2621 |         (let ([q (make-vector 1)] [p (make-vector 1)])
2622 |           (vector-set! q 0 1)
2623 |           (vector-set! p 0 2)
2624 |           (if-test 3 q p)))
2625 |       (letrec ([if-test (lambda (n)
2626 |                           (let ([m (make-vector 1)]
2627 |                                 [x (make-vector 1)]
2628 |                                 [y (make-vector 1)])
2629 |                             (vector-set! m 0 n)
2630 |                             (vector-set! x 0 1)
2631 |                             (begin
2632 |                               (vector-set! y 0 1)
2633 |                               (if (eq? (vector-ref m 0) 0)
2634 |                                   (vector-set! (vector-ref x 0) 0
2635 |                                                (+ (vector-ref x 0)
2636 |                                                   (vector-ref y 0)))
2637 |                                   (vector-set! y 0 (+ (vector-ref y 0)
2638 |                                                       (vector-ref x 0))))
2639 |                               (vector-set! x 0 (+ (vector-ref x 0)
2640 |                                                   (vector-ref m 0))))
2641 |                             (if (if (eq? (vector-ref m 0) (vector-ref y 0)) #f #t)
2642 |                                 (vector-set! m 0 (+ (vector-ref m 0)
2643 |                                                     (vector-ref x 0)))
2644 |                                 (vector-set! m 0 (+ (vector-ref m 0)
2645 |                                                     (vector-ref y 0))))
2646 |                             (+ (vector-ref x 0) (vector-ref m 0))))])
2647 |         (if-test 1))
2648 |       (letrec ([f (lambda (x) (+ 1 x))]
2649 |                [g (lambda (x) (- x 1))]
2650 |                [t (lambda (x) (- x 1))]
2651 |                [j (lambda (x) (- x 1))]
2652 |                [i (lambda (x) (- x 1))]
2653 |                [h (lambda (x) (- x 1))])
2654 |         (let ([x 80])
2655 |           (let ([a (f x)]
2656 |                 [b (g x)]
2657 |                 [c (h (i (j (t x))))])
2658 |             (* a (* b (+ c 0))))))
2659 |       (let ([f (lambda (x) (+ 1 x))] [g (lambda (x) (- x 1))])
2660 |         (let ([x 80])
2661 |           (let ([a (f x)]
2662 |                 [b (g x)]
2663 |                 [c (letrec ([h (lambda (x) (- x 1))])
2664 |                      (h (letrec ([i (lambda (x) (- x 1))])
2665 |                           (i
2666 |                             (letrec ([t (lambda (x) (- x 1))]
2667 |                                      [j (lambda (x) (- x 1))])
2668 |                               (j (t x)))))))])
2669 |             (* a (* b (+ c 0))))))
2670 |       (letrec ([fact (lambda (n)
2671 |                        (if (= n 0)
2672 |                            1
2673 |                            (let ([t (- n 1)])
2674 |                              (let ([t (fact t)])
2675 |                                (* n t)))))])
2676 |         (fact 10))
2677 |       (letrec ([fib (lambda (n k)
2678 |                       (if (or (= n 0) (= n 1))
2679 |                           (k 1)
2680 |                           (fib (- n 1) (lambda (w)
2681 |                                          (fib (- n 2) (lambda (v)
2682 |                                                         (k (+ w v))))))))])
2683 |         (fib 10 (lambda (x) x)))
2684 |       (letrec ()
2685 |         (let ([n (let ([p (make-vector 1)]) (vector-set! p 0 1) p)])
2686 |           (let ([a 2])
2687 |             (let ([b 3])
2688 |               (vector-set! n 0 (+ (vector-ref n 0) 
2689 |                                   (if (= (+ (vector-ref n 0) b) b) 5 10)))
2690 |               (vector-set! n 0 (+ (vector-ref n 0) b)))
2691 |             (vector-set! n 0 (+ (vector-ref n 0) a)))
2692 |           (+ (vector-ref n 0) (vector-ref n 0))))
2693 |       (let ([dot-product (lambda (v1 v2)
2694 |                            (if (and (vector? v1) (vector? v2)
2695 |                                     (= (vector-length v1) (vector-length v2)))
2696 |                                (letrec ([f (lambda (i)
2697 |                                              (if (= i 0)
2698 |                                                  1
2699 |                                                  (let ([i (- i 1)])
2700 |                                                    (+ (* (vector-ref v1 i)
2701 |                                                          (vector-ref v2 i))
2702 |                                                       (f i)))))])
2703 |                                  (f (vector-length v1)))
2704 |                                #f))])
2705 |         (cons (dot-product '(1 2) '#(3 4))
2706 |               (cons (dot-product '#(1 2) '#(3 4 5))
2707 |                     (cons (dot-product '#(4 5 6 7) '#(2 9 8 1)) '()))))
2708 |       (letrec ([num-list? (lambda (ls)
2709 |                             (if (null? ls)
2710 |                                 #t
2711 |                                 (if (fixnum? (car ls))
2712 |                                     (num-list? (cdr ls))
2713 |                                     #f)))]
2714 |                [length (lambda (ls)
2715 |                          (if (null? ls)
2716 |                              0
2717 |                              (+ (length (cdr ls)) 1)))]
2718 |                [dot-prod (lambda (ls1 ls2)
2719 |                            (if (if (null? ls1) (null? ls2) #f)
2720 |                                0
2721 |                                (+ (* (car ls1) (car ls2))
2722 |                                   (dot-prod (cdr ls1) (cdr ls2)))))])
2723 |         (let ([ls1 '(1 2 3 4 5)]
2724 |               [ls2 '(5 4 3 2 1)])
2725 |           (if (if (if (eq? (num-list? ls1) #f) #f #t)
2726 |                   (if (if (eq? (num-list? ls2) #f) #f #t)
2727 |                       (= (length ls1) (length ls2))
2728 |                       #f)
2729 |                   #f)
2730 |               (dot-prod ls1 ls2)
2731 |               #f)))
2732 |       (letrec ([num-list? (lambda (ls)
2733 |                             (or (null? ls) 
2734 |                                 (and (fixnum? (car ls)) (num-list? (cdr ls)))))]
2735 |                [map (lambda (f ls)
2736 |                         (if (null? ls) 
2737 |                             '()
2738 |                             (cons (f (car ls)) (map f (cdr ls)))))]
2739 |                [square (lambda (n) (* n n))])
2740 |         (let ([ls '(1 2 3 4 5)])
2741 |           (if (num-list? ls) (set-car! ls (map square ls)))
2742 |           ls))
2743 |       (letrec ([num-list? (lambda (ls)
2744 |                             (if (null? ls)
2745 |                                 #t
2746 |                                 (if (fixnum? (car ls))
2747 |                                     (num-list? (cdr ls))
2748 |                                     #f)))]
2749 |                [list-product (lambda (ls)
2750 |                                (if (null? ls)
2751 |                                    1
2752 |                                    (* (car ls) (list-product (cdr ls)))))])
2753 |         (let ([ls '(1 2 3 4 5)])
2754 |           (if (num-list? ls) (list-product ls) #f)))
2755 |       (letrec ([f (lambda (x y)
2756 |                       (if x (h (+ x y)) (g (+ x 1) (+ y 1))))]
2757 |                [g (lambda (u v)
2758 |                     (let ([a (+ u v)] [b (* u v)])
2759 |                       (letrec ([e (lambda (d)
2760 |                                     (let ([p (cons a b)])
2761 |                                       (letrec ([q (lambda (m)
2762 |                                                     (if (< m u)
2763 |                                                         (f m d)
2764 |                                                         (h (car p))))])
2765 |                                         (q (f a b)))))])
2766 |                         (e u))))]
2767 |                [h (lambda (w) w)])
2768 |         (f 4 5))
2769 |       (let ((y '())
2770 |             (z 10))
2771 |         (let ((test-ls (cons 5 y)))
2772 |           (set! y (lambda (f)
2773 |                     ((lambda (g) (f (lambda (x) ((g g) x))))
2774 |                      (lambda (g) (f (lambda (x) ((g g) x)))))))
2775 |           (set! test-ls (cons z test-ls))
2776 |           (letrec ((length (lambda (ls)
2777 |                               (if (null? ls) 0 (+ 1 (length (cdr ls)))))))
2778 |             (let ((len (length test-ls)))
2779 |               (eq? (begin
2780 |                     (set! length (y (lambda (len)
2781 |                                       (lambda (ls)
2782 |                                         (if (null? ls)
2783 |                                             0
2784 |                                             (+ 1 (len (cdr ls))))))))
2785 |                     (length test-ls))
2786 |                    len)))))
2787 |       (letrec ([curry-list
2788 |                  (lambda (x)
2789 |                    (lambda (y)
2790 |                      (lambda (z)
2791 |                        (lambda (w)
2792 |                          (cons x (cons y (cons z (cons w '()))))))))]
2793 |                [append (lambda (ls1 ls2)
2794 |                          (if (null? ls1)
2795 |                              ls2
2796 |                              (cons (car ls1)
2797 |                                    (append (cdr ls1) ls2))))])
2798 |         (append
2799 |           ((((curry-list 1) 2) 3) 4)
2800 |           ((((curry-list 5) 6) 7) 8)))
2801 |       (letrec ([quotient (lambda (x y)
2802 |                            (if (< x 0)
2803 |                                (- 0 (quotient (- 0 x) y))
2804 |                                (if (< y 0)
2805 |                                    (- 0 (quotient x (- 0 y)))
2806 |                                    (letrec ([f (lambda (x a)
2807 |                                                  (if (< x y)
2808 |                                                      a
2809 |                                                      (f (- x y) (+ a '1))))])
2810 |                                      (f x 0)))))])
2811 |         (let ([sub-interval 1])
2812 |           (letrec ([sub-and-continue (lambda (n acc k)
2813 |                                        (k (- n sub-interval) (* n acc)))]
2814 |                    [strange-fact (lambda (n acc)
2815 |                                    (if (= n 0)
2816 |                                      (lambda (proc) (proc acc))
2817 |                                      (sub-and-continue n acc strange-fact)))])
2818 |             (let ([x 20] [fact (let ([seed 1])
2819 |                                  (lambda (n) (strange-fact n seed)))])
2820 |               (let ([x (cons x (if #f #f))])
2821 |                 (letrec ([answer-user (lambda (ans) (quotient ans (car x)))])
2822 |                   (let ([give-fact5-answer (fact 5)] [give-fact6-answer (fact 6)])
2823 |                     (begin
2824 |                       (set-car! x (give-fact5-answer answer-user))
2825 |                       (set-car! x (give-fact6-answer answer-user))
2826 |                       (car x)))))))))
2827 |       
2828 |       (letrec ([fib (lambda (x)
2829 |                       (let ([decrx (lambda () (lambda (i) (set! x (- x i))))])
2830 |                         (if (< x 2)
2831 |                             1
2832 |                             (+ (begin ((decrx) 1) (fib x))
2833 |                                (begin ((decrx) 1) (fib x))))))])
2834 |         (fib 10))
2835 |       ; test use of keywords/primitives as variables
2836 |       (let ([quote (lambda (x) x)]
2837 |             [let (lambda (x y) (- y x))]
2838 |             [if (lambda (x y z) (cons x z))]
2839 |             [cons (lambda (x y) (cons y x))]
2840 |             [+ 16])
2841 |         (set! + (* 16 2))
2842 |         (cons (let ((quote (lambda () 0))) +)
2843 |               (if (quote (not #f)) 720000 -1)))
2844 |       (letrec ([sum-all (lambda (x)
2845 |                           (if (fixnum? x)
2846 |                               x
2847 |                               (if (vector? x)
2848 |                                   (sum-vector x)
2849 |                                   (if (pair? x)
2850 |                                       (sum-pair x)
2851 |                                       (if (procedure? x)
2852 |                                           (sum-all (x))
2853 |                                           0)))))]
2854 |                [sum-vector (lambda (v)
2855 |                              (letrec ([l (lambda (v i)
2856 |                                            (if (= i 0) 
2857 |                                                0 
2858 |                                                (sum-all 
2859 |                                                  (vector-ref v (- i 1)))))])
2860 |                                (l v (vector-length v))))]
2861 |                [sum-pair (lambda (p)
2862 |                            (+ (sum-all (car p)) (sum-all (cdr p))))])
2863 |         (sum-all (lambda () '#((7 8 1) 
2864 |                                #(81 23 8)
2865 |                                #(#(#(12) 56) 18 ((1 2) (3 ((4)) 5)))))))
2866 |       (letrec ([div (lambda (d n)
2867 |                       (letrec ([f (lambda (d n q)
2868 |                                     (if (> n d)
2869 |                                         q
2870 |                                         (f (- d n) n (+ q 1))))])
2871 |                         (f d n 0)))])
2872 |         (letrec ([alloc (lambda (n) (make-vector (div n 8)))]
2873 |                  [mref (lambda (x y)
2874 |                          (if (vector? x)
2875 |                              (vector-ref x (div y 8))
2876 |                              (vector-ref y (div x 8))))]
2877 |                  [mset! (lambda (x y z)
2878 |                           (if (vector? x)
2879 |                               (vector-set! x (div y 8) z)
2880 |                               (vector-set! y (div x 8) z))
2881 |                           (if #f #f))])
2882 |           (letrec ([stack-push (lambda (self val)
2883 |                                  (mset! (mref self 16) (* (mref self 8) 8) val)
2884 |                                  (mset! self 8 (+ (mref self 8) 1))
2885 |                                  self)]
2886 |                    [stack-pop (lambda (self)
2887 |                                 (mset! self 8 (- (mref 8 self) 1))
2888 |                                 (mref (mref self 16) (* (mref self 8) 8)))]
2889 |                    [stack-top (lambda (self)
2890 |                                 (mref (mref self 16) 
2891 |                                       (* (- (mref 8 self) 1) 8)))])
2892 |             (letrec ([stack-new
2893 |                        (let ([meths (alloc (* 3 8))])
2894 |                          (mset! meths 0 stack-push)
2895 |                          (mset! meths 8 stack-pop)
2896 |                          (mset! meths 16 stack-top)
2897 |                          (lambda (size)
2898 |                            (let ([self (alloc (* 3 8))])
2899 |                              (mset! self 0 meths)
2900 |                              (mset! self 8 0)
2901 |                              (mset! self 16 (alloc (* 8 size)))
2902 |                              self)))]
2903 |                      [invoke (lambda (obj meth-idx)
2904 |                                (mref (mref obj 0) (* meth-idx 8)))])
2905 |               (let ([s1 (stack-new 10)])
2906 |                 (begin
2907 |                   ((invoke s1 0) s1 10) ;; push '10
2908 |                   ((invoke s1 0) s1 20) ;; push '20
2909 |                   ((invoke s1 0) s1 30) ;; push ... well you get the idea
2910 |                   ((invoke s1 0) s1 40)
2911 |                   ((invoke s1 0) s1 0)
2912 |                   ((invoke s1 0) s1 60)
2913 |                   ((invoke s1 0) s1 70)
2914 |                   ((invoke s1 0) s1 80)
2915 |                   ((invoke s1 0) s1 90)
2916 |                   ((invoke s1 0) s1 100)
2917 |                   (let ([s2 (stack-new 6)])
2918 |                     (begin
2919 |                       ((invoke s2 0) s2 ((invoke s1 1) s1)) ;; push pop
2920 |                       ((invoke s1 1) s1) ;; pop
2921 |                       ((invoke s2 0) s2 ((invoke s1 1) s1))
2922 |                       ((invoke s1 1) s1) ;; pop
2923 |                       ((invoke s2 0) s2 ((invoke s1 1) s1))
2924 |                       ((invoke s1 1) s1) ;; pop
2925 |                       ((invoke s2 0) s2 ((invoke s1 1) s1))
2926 |                       ((invoke s1 1) s1) ;; pop
2927 |                       ((invoke s2 0) s2 ((invoke s1 1) s1))
2928 |                       ((invoke s2 0) s2 ((invoke s1 1) s1))
2929 |                       (let ([x (+ ((invoke s2 1) s2) ((invoke s2 1) s2))])
2930 |                         (* (+ (let ([x (+ ((invoke s2 2) s2)
2931 |                                           ((invoke s2 2) s2))])
2932 |                                 (- x (+ ((invoke s2 1) s2) ((invoke s2 1) s2))))
2933 |                               (let ([x (+ ((invoke s2 2) s2)
2934 |                                           ((invoke s2 2) s2))])
2935 |                                 (- (+ ((invoke s2 1) s2) ((invoke s2 1) s2)) x)))
2936 |                            x))))))))))
2937 |       (if (lambda () 1)
2938 |           (let ((a 2))
2939 |             (if (if ((lambda (x)
2940 |                        (let ((x (set! a (set! a 1))))
2941 |                          x)) 1)
2942 |                     (if (eq? a (void))
2943 |                         #t
2944 |                         #f)
2945 |                     #f)
2946 |                 #36rgood        ; dyb: cannot use symbols, so use radix 36
2947 |                 #36rbad)))
2948 |   
2949 |      ; contributed by Ryan Newton
2950 |       (letrec
2951 |         ([dropsearch
2952 |            (lambda (cell tree)
2953 |              (letrec
2954 |                ([create-link
2955 |                     (lambda (node f)
2956 |                       (lambda (g)
2957 |                         (if (not (pair? node))
2958 |                             (f g)
2959 |                             (if (eq? node cell)
2960 |                                 #f
2961 |                                 (f (create-link (car node)
2962 |                                                 (create-link (cdr node) g)))))))]
2963 |                 [loop
2964 |                   (lambda (link)
2965 |                     (lambda ()
2966 |                       (if link
2967 |                           (loop (link (lambda (v) v)))
2968 |                           #f)))])
2969 |                (loop (create-link tree (lambda (x) x)))))]
2970 |            [racethunks
2971 |              (lambda (thunkx thunky)
2972 |                (if (if thunkx thunky #f)
2973 |                    (racethunks (thunkx) (thunky))
2974 |                    (if thunky
2975 |                        #t
2976 |                        (if thunkx
2977 |                            #f
2978 |                            '()))))]
2979 |            [higher?
2980 |              (lambda (x y tree)
2981 |                (racethunks (dropsearch x tree)
2982 |                            (dropsearch y tree)))]
2983 |            [under?
2984 |              (lambda (x y tree)
2985 |                (racethunks (dropsearch x y)
2986 |                            (dropsearch x tree)))]
2987 |            [explore
2988 |              (lambda (x y tree)
2989 |                (if (not (pair? y))
2990 |                    #t
2991 |                    (if (eq? x y)
2992 |                        #f    ;This will take out anything that points to itself
2993 |                        (let ((result (higher? x y tree)))
2994 |                          (if (eq? result #t)
2995 |                              (if (explore y (car y) tree)
2996 |                                  (explore y (cdr y) tree)
2997 |                                  #f)
2998 |                              (if (eq? result #f)
2999 |                                  (process-vertical-jump x y tree)
3000 |                                  (if (eq? result '())
3001 |                                      (process-horizontal-jump x y tree)
3002 |                                      )))))))]
3003 |            [process-vertical-jump
3004 |              (lambda (jumpedfrom jumpedto tree)
3005 |                (if (under? jumpedfrom jumpedto tree)
3006 |                    #f
3007 |                    (fullfinite? jumpedto)))]
3008 |            [process-horizontal-jump
3009 |              (lambda (jumpedfrom jumpedto tree)
3010 |                (fullfinite? jumpedto))]
3011 |            [fullfinite?
3012 |              (lambda (pair)
3013 |                (if (not (pair? pair))
3014 |                    #t
3015 |                    (if (explore pair (car pair) pair)
3016 |                        (explore pair (cdr pair) pair)
3017 |                        #f)))])
3018 |          (cons
3019 |            (fullfinite? (cons 1 2))
3020 |            (cons
3021 |              (fullfinite? (let ((x (cons 1 2))) (set-car! x x) x))
3022 |              (cons
3023 |                (fullfinite? (let ([a (cons 0 0)] [b (cons 0 0)] [c (cons 0 0)])
3024 |                               (set-car! a b) (set-cdr! a c) (set-cdr! b c)
3025 |                               (set-car! b c) (set-car! c b) (set-cdr! c b) a))
3026 |                '()))))
3027 |       (letrec ([zero? (lambda (x) (= x 0))]
3028 |            [sub1 (lambda (n) (- n 1))]
3029 |            [assq (lambda (sym al)
3030 |                    (if (null? al)
3031 |                        #f
3032 |                        (let ([entry (car al)])
3033 |                          (if (eq? sym (car entry))
3034 |                              (cdr entry)
3035 |                              (assq sym (cdr al))))))]
3036 |            [map (lambda (p ls)
3037 |                   (if (null? ls)
3038 |                       '()
3039 |                       (cons (p (car ls)) (map p (cdr ls)))))]
3040 |            [snoc (lambda (ls sym)
3041 |                    (if (null? ls)
3042 |                        (cons sym '())
3043 |                        (cons (car ls) (snoc (cdr ls) sym))))]
3044 |            [iota (lambda (n)
3045 |                    (if (zero? n)
3046 |                        '(0)
3047 |                        (snoc (iota (sub1 n)) n)))]
3048 |            [fib (lambda (n)
3049 |                   (if (zero? n)
3050 |                       0
3051 |                       (if (= n 1)
3052 |                           1
3053 |                           (+ (fib (- n 1)) (fib (- n 2))))))]
3054 |            [bounded-memoize (lambda (p bound)
3055 |                               (let ([memo '()])
3056 |                                 (lambda (arg)
3057 |                                   (if (if (< arg bound) (assq arg memo) #f)
3058 |                                       (assq arg memo)
3059 |                                       (let ([ans (p arg)])
3060 |                                         (if (< arg bound)
3061 |                                             (set! memo (cons (cons arg ans) memo)))
3062 |                                         ans)))))])
3063 |         (set! fib (bounded-memoize fib 5))
3064 |         (map fib (iota 10)))
3065 |   
3066 |       ;; Francis Fernandez
3067 |       (and (+ ((if (not (cons '1 '(2))) 
3068 |                    '#t 
3069 |                    (letrec ([f.1 '3] [f.2 (lambda (x.3) (+ x.3 '4))])
3070 |                      f.2))
3071 |                '5) '6) '#f)
3072 |   
3073 |       ;; Thiago Rebello
3074 |       (let ([a 5]
3075 |             [b 4])
3076 |         (letrec ([c (lambda(d e) (* d e))]
3077 |                  [f (lambda(g h) (cons g h))])
3078 |           (if (or (> (c a b) 15) (= (c a b) 20))
3079 |               (f a b))))
3080 |   
3081 |       ;; Yin Wang
3082 |       (let ([begin (lambda (x y) (+ x y))]
3083 |             [set! (lambda (x y) (* x y))])
3084 |         (let ([lambda (lambda (x) (begin 1 x))])
3085 |           (let ([lambda (lambda (set! 1 2))])
3086 |             (let ([let (set! lambda lambda)])
3087 |               (begin let (set! lambda (set! 4 (begin 2 3))))))))
3088 |   
3089 |       ;; Ben Peters
3090 |       (let ([x '(4 5 6)]
3091 |             [y '(7 8 9)])
3092 |         (cons 1 (cons 2 (cons 3 (cons (car x) (cons (car (cdr x)) (cons (car (cdr (cdr x))) y)))))))
3093 |       
3094 |       ;; Patrick Jensen
3095 |       (let ([a 1])
3096 |         (letrec ([add1 (lambda (b) (+ b 1))]
3097 |                  [sub1 (lambda (b) (- b 1))])
3098 |           (let ([c (lambda (a)
3099 |                      (if (or (not (= a 1)) (and (> a 1) (< a 4)))
3100 |                          (add1 a)
3101 |                          (sub1 a)))])
3102 |             (let ([d (c a)] [e (c (add1 a))] [f (c (sub1 a))])
3103 |               (cons d (cons e (cons f '())))))))
3104 |   
3105 |       ;; Melanie Dybvig
3106 |       (letrec ((not (lambda (x) x))
3107 |                (a (if (< (* 3 3) (+ 3 3)) #t #f))
3108 |                (b 7))
3109 |         (if (not a)
3110 |             (set! b (+ b 2))
3111 |             (if (not (not a))
3112 |                 (set! b (- b 2))))
3113 |         (cons b (or (not (not a)) (not a))))
3114 |   
3115 |       ;; Lindsey Kuper
3116 |       (let ([foo (lambda (lambda)
3117 |                    (lambda))])
3118 |         (let ([lambda foo]
3119 |               [bar (lambda () #t)])
3120 |           (foo bar)))
3121 |    
3122 |       ;; Yu-Shan Huang
3123 |       (let ([x 1])
3124 |         (let ([x 2])
3125 |           (if (and (< x 5) (not #f))
3126 |             (set! x 6)))
3127 |         x)
3128 |   
3129 |       ;; Chabane Maidi
3130 |       (letrec ([merge (lambda (ls ls2)
3131 |                         (if (null? ls)
3132 |                             ls2
3133 |                             (if (null? ls2)
3134 |                                 ls
3135 |                                 (if (< (car ls) (car ls2))
3136 |                                     (cons (car ls) (merge (cdr ls) ls2))
3137 |                                     (cons (car ls2) (merge ls (cdr ls2)))))))]
3138 |                [sort (lambda (ls)
3139 |                        (if (null? ls)
3140 |                            ls
3141 |                            (if (null? (cdr ls))
3142 |                                ls
3143 |                                (let ([halves (halves ls '() '() #t)])
3144 |                                  (let ([first (car halves)]
3145 |                                        [second (car (cdr halves))])
3146 |                                    (merge (sort first) (sort second)))))))]
3147 |                [halves (lambda (ls first second first?)
3148 |                          (if (null? ls)
3149 |                              (cons first (cons second '()))
3150 |                              (if first?
3151 |                                  (halves (cdr ls) (cons (car ls) first) second #f)
3152 |                                  (halves (cdr ls) first (cons (car ls) second) #t))))]
3153 |                [pend (lambda (ls ls2)
3154 |                        (if (null? ls)
3155 |                            ls2
3156 |                            (cons (car ls) (pend (cdr ls) ls2))))])
3157 |         (pend (sort '(1 5 5 8 2 3 9)) (sort '(5 9 5 7 7 8 7))))
3158 |   
3159 |       ;; Kewal Karavinkoppa
3160 |       (letrec ([depth (lambda (ls)
3161 |                         (if (null? ls)
3162 |                             1
3163 |                             (if (pair? (car ls))
3164 |                                 (let ([l ((lambda (m)
3165 |                                             (+ m 1))
3166 |                                           (depth (car ls)))]
3167 |                                       [r (depth (cdr ls))])
3168 |                                   (if (< l r) r l))
3169 |                                 (depth (cdr ls)))))])
3170 |         (depth '(1 2 (3 (4 (5 (6 7)))))))
3171 |   
3172 |       ;; Brennon York
3173 |       ((lambda (x) (if (if (eq? x 5) x (and x 1 2 3 4 (or 6 7 8 9))) 3)) 4)
3174 |   
3175 |       ;; Nilesh Mahajan
3176 |       (letrec ([F (lambda (func-arg)
3177 |                     (lambda (n)
3178 |                       (if (= n 0)
3179 |                           1
3180 |                           (* n (func-arg (- n 1))))))])
3181 |         (letrec ([Y (lambda (X)
3182 |                       ((lambda (procedure)
3183 |                          (X (lambda (arg) ((procedure procedure) arg))))
3184 |                        (lambda (procedure)
3185 |                          (X (lambda (arg) ((procedure procedure) arg))))))])
3186 |           (letrec ([fact (Y F)])
3187 |             (fact 5))))
3188 |   
3189 |       ;; Joseph Knecht
3190 |       (letrec ([f (lambda () '(1 . 2))]) (eq? (f) (f)))
3191 |   
3192 |       ;; Emily Lyons
3193 |       (letrec ([extend (lambda (num alist)
3194 |                          (if (null? alist)
3195 |                              (cons (cons num 1) '())
3196 |                              (if (= num (car (car alist)))
3197 |                                  (cons (cons num (+ 1 (cdr (car alist))))
3198 |                                        (cdr alist))
3199 |                                  (cons (car alist)
3200 |                                        (extend num (cdr alist))))))]
3201 |                [loop (lambda (ls alist)
3202 |                        (if (null? ls)
3203 |                            alist
3204 |                            (loop (cdr ls) (extend (car ls) alist))))])
3205 |         (loop '(1 3 4 5 5 4 5 2 3 4 1) '()))
3206 |       ))
3207 | 
3208 |   (define last-test
3209 |     (make-parameter 0
3210 |       (lambda (x)
3211 |         (unless (and (integer? x) (exact? x)) (errorf 'last-test "expected exact integer, but got ~s" x))
3212 |         x)))
3213 | 
3214 |   (define test-all
3215 |     (case-lambda
3216 |       [() (test-all #f)]
3217 |       [(noisy?)
3218 |        (for-all
3219 |          (lambda (t)
3220 |            (when noisy? (pretty-print t))
3221 |            (let ([expected (eval t)]
3222 |                  [actual (guard (e [else (printf "test-exception evaluating:~%") (pretty-print t) (raise e)])
3223 |                            (tiny-compile t))])
3224 |              (unless (or (equal? expected actual) (equal? actual '#(exception)))
3225 |                (printf "test-failed: expected ~s, but got ~s but got:~%" expected actual)
3226 |                (pretty-print t)
3227 |                (errorf 'test-all "testing failed"))))
3228 |          tests)]))
3229 | 
3230 |   (define (analyze-all)
3231 |     (let ([c 1])
3232 |       (for-all
3233 |         (lambda (t)
3234 |           (let ([expected (eval t)]
3235 |                 [actual (guard (e [else (printf "E") (flush-output-port) '#(exception)]) (tiny-compile t))])
3236 |             (cond
3237 |               [(equal? expected actual) (printf ".") (flush-output-port)]
3238 |               [(equal? actual '#(exception)) (void)]
3239 |               [else (printf "F") (flush-output-port)])
3240 |             (when (= c 50) (newline) (set! c 0))
3241 |             (set! c (+ c 1))))
3242 |         tests)))
3243 |   )
3244 | 


--------------------------------------------------------------------------------
/src/main/scheme/d.sls:
--------------------------------------------------------------------------------
  1 | ;; Primitives needed for psyntax:
  2 | ;;
  3 | ;; listed? | primitive
  4 | ;; --------+-----------------
  5 | ;; n       | &condition-rcd
  6 | ;; n       | &condition-rtd
  7 | ;; p       | +
  8 | ;; p       | -
  9 | ;; p       | <=
 10 | ;; p       | =
 11 | ;; p       | >
 12 | ;; p       | >=
 13 | ;; l       | append
 14 | ;; p       | apply
 15 | ;; ?       | assertion-violation
 16 | ;; l       | assq
 17 | ;; p       | boolean?
 18 | ;; p       | bytevector?
 19 | ;; l       | caar
 20 | ;; l       | caddr
 21 | ;; l       | cadr
 22 | ;; l       | call-with-values
 23 | ;; p       | car
 24 | ;; l       | cdar
 25 | ;; l       | cddr
 26 | ;; p       | cdr
 27 | ;; p       | char->integer
 28 | ;; p       | char<=?
 29 | ;; p       | char?
 30 | ;; ?       | command-line
 31 | ;; ?       | condition
 32 | ;; ?       | condition-accessor
 33 | ;; ?       | condition-predicate
 34 | ;; p       | cons
 35 | ;; l       | cons*
 36 | ;; ?       | display
 37 | ;; l       | dynamic-wind
 38 | ;; p       | eof-object?
 39 | ;; p       | eq?
 40 | ;; l       | equal?
 41 | ;; l       | eqv?
 42 | ;; ?       | error
 43 | ;; ?       | eval-core
 44 | ;; p       | exact?
 45 | ;; l       | exists
 46 | ;; ?       | exit
 47 | ;; ?       | file-exists?
 48 | ;; l       | for-all
 49 | ;; l       | for-each
 50 | ;; ?       | gensym
 51 | ;; l       | hashtable-entries
 52 | ;; l       | hashtable-ref
 53 | ;; l       | hashtable-set!
 54 | ;; p       | integer->char
 55 | ;; p       | integer?
 56 | ;; l       | length
 57 | ;; l       | list
 58 | ;; l       | list->vector
 59 | ;; l       | list?
 60 | ;; n       | make-assertion-violation
 61 | ;; p       | make-eq-hashtable
 62 | ;; n       | make-irritants-condition
 63 | ;; n       | make-message-condition
 64 | ;; n       | make-record-constructor-descriptor
 65 | ;; n       | make-record-type-descriptor
 66 | ;; n       | make-syntax-violation
 67 | ;; n       | make-undefined-violation
 68 | ;; p       | make-vector
 69 | ;; n       | make-who-condition
 70 | ;; l       | map
 71 | ;; l       | member
 72 | ;; l       | memq
 73 | ;; l       | memv
 74 | ;; n       | newline
 75 | ;; p       | null?
 76 | ;; l       | number?
 77 | ;; n       | open-string-output-port
 78 | ;; p       | pair?
 79 | ;; n       | pretty-print
 80 | ;; p       | procedure?
 81 | ;; p       | quotient
 82 | ;; n       | raise
 83 | ;; n       | read
 84 | ;; n       | record-accessor
 85 | ;; n       | record-constructor
 86 | ;; n       | record-predicate
 87 | ;; p       | remainder
 88 | ;; l       | remq
 89 | ;; l       | reverse
 90 | ;; p       | set-car!
 91 | ;; p       | set-cdr!
 92 | ;; p       | set-symbol-value!
 93 | ;; l       | string
 94 | ;; l       | string->list
 95 | ;; p       | string->symbol
 96 | ;; l       | string-append
 97 | ;; p       | string?
 98 | ;; p       | symbol->string
 99 | ;; p       | symbol-value
100 | ;; p       | symbol?
101 | ;; l       | values
102 | ;; l       | vector
103 | ;; l       | vector->list
104 | ;; l       | vector-for-each
105 | ;; p       | vector-length
106 | ;; l       | vector-map
107 | ;; p       | vector-ref
108 | ;; p       | vector-set!
109 | ;; p       | vector?
110 | ;; p       | void
111 | ;; n       | with-input-from-file
112 | ;; n       | write
113 | ;; l       | zero?
114 | 
115 | (library (d)
116 |   (export immediate? datatype? primitive? pure-primitive? value-primitive?
117 |     predicate-primitive? effect-primitive? primitive->primitive-info
118 |     primitive-info? primitive-info-name primitive-info-arity* arity-matches?
119 |     primitive-info-kind make-primitive-info exact-integer?)
120 |   (import (rnrs) (only (chezscheme) module eq-hashtable? errorf))
121 | 
122 |   (define target-datatype-source-preds
123 |     (let ([ls '()])
124 |       (case-lambda
125 |         [() ls]
126 |         [(pred) (set! ls (cons pred ls))])))
127 | 
128 |   (define-record-type datatype-info
129 |     (nongenerative)
130 |     (fields name cons pred? ops))
131 | 
132 |   (define-record-type primitive-info
133 |     (nongenerative)
134 |     (fields name arity* kind))
135 | 
136 |   (define datatype-prim->prim-info
137 |     (lambda (dt name)
138 |       (find (lambda (pr) (eq? (primitive-info-name pr) name)) (datatype-info-ops dt))))
139 | 
140 |   (define target-primitives (make-hashtable symbol-hash eq?))
141 | 
142 |   (define-syntax define-datatype
143 |     (lambda (x)
144 |       (syntax-case x ()
145 |         [(_ name [cons c-arity c-arities ...] [pred? target-pred?] [op op-arity op-arities ... kind] ...)
146 |          (with-syntax ([(t-cons t-pred? t-op* ...) (generate-temporaries #'(cons pred? op ...))])
147 |            #'(begin
148 |                (define ignore (target-datatype-source-preds pred?))
149 |                (define datatype
150 |                  (make-datatype-info 'name 'cons 'pred?
151 |                    (list
152 |                      (make-primitive-info 'cons (list c-arity c-arities ...) 'value)
153 |                      (make-primitive-info 'pred? (list 1) 'predicate)
154 |                      (make-primitive-info 'op (list op-arity op-arities ...) 'kind) ...)))
155 |                (define t-cons (hashtable-set! target-primitives 'cons (datatype-prim->prim-info datatype 'cons)))
156 |                (define t-pred? (hashtable-set! target-primitives 'pred? (datatype-prim->prim-info datatype 'pred?)))
157 |                (define t-op* (hashtable-set! target-primitives 'op (datatype-prim->prim-info datatype 'op)))
158 |                ...))]
159 |         [(_ name [cons c-arity c-arities ...] pred? [op op-arity op-arities ... kind] ...)
160 |          #'(define-datatype name [cons c-arity c-arities ...] [pred? pred?] [op op-arity op-arities ... kind] ...)] )))
161 | 
162 |   (define-datatype pair [cons 2] [pair? target-pair?] [car 1 value] [cdr 1 value] [set-car! 2 effect] [set-cdr! 2 effect])
163 |   (define-datatype vector [make-vector 1 2] [vector? target-vector?] [vector-length 1 value] [vector-ref 2 value] [vector-set! 3 effect])
164 |   (define-datatype string [make-string 1 2] string? [string-length 1 value] [string-ref 2 value] [string-set! 3 effect])
165 |   (define-datatype symbol [string->symbol 1] symbol? [symbol->string 1 value] [symbol-hash 1 value] [symbol-value 1 value] [set-symbol-value! 2 effect])
166 |   (define-datatype char [integer->char 1] char? [char->integer 1 value] [char<=? -2 predicate])
167 |   (define-datatype bytevector [make-bytevector 1 2] bytevector?)
168 |   (define-datatype eq-hashtable [make-eq-hashtable 0 1] eq-hashtable? [eq-hashtable-ref 3 value] [eq-hashtable-set! 3 effect] [eq-hashtable-entries 1 value])
169 | 
170 |   (define-syntax define-primitive
171 |     (lambda (x)
172 |       (syntax-case x ()
173 |         [(_ name arity arities ... kind)
174 |          (with-syntax ([(t-name) (generate-temporaries #'(name))])
175 |            #'(define t-name (hashtable-set! target-primitives 'name (make-primitive-info 'name (list arity arities ...) 'kind))))])))
176 | 
177 |   (define-primitive + -1 value)
178 |   (define-primitive - -2 value)
179 |   (define-primitive * -1 value)
180 |   (define-primitive void 0 value)
181 | 
182 |   (define-primitive < -2 predicate)
183 |   (define-primitive <= -2 predicate)
184 |   (define-primitive = -2 predicate)
185 |   (define-primitive >= -2 predicate)
186 |   (define-primitive > -2 predicate)
187 |   (define-primitive eq? 2 predicate)
188 |   (define-primitive boolean? 1 predicate)
189 |   (define-primitive fixnum? 1 predicate)
190 |   (define-primitive null? 1 predicate)
191 |   (define-primitive procedure? 1 predicate)
192 | 
193 |   (define-primitive apply -3 value)
194 |   (define-primitive eof-object? 1 predicate)
195 |   (define-primitive exact? 1 predicate)
196 |   (define-primitive integer? 1 predicate)
197 |   (define-primitive quotient 2 value)
198 |   (define-primitive remainder 2 value)
199 | 
200 |   (define-primitive assertion-violation -3 effect)
201 |   (define-primitive command-line 0 1 value)
202 |   (define-primitive condition -1 value)
203 |   (define-primitive condition-accessor 2 value)
204 |   (define-primitive condition-predicate 1 value)
205 |   (define-primitive display 1 2 effect)
206 |   (define-primitive error -3 effect)
207 |   (define-primitive eval-core 1 value)
208 |   (define-primitive exit -1 effect)
209 |   (define-primitive file-exists? 1 2 predicate)
210 |   (define-primitive gensym 0 1 3 value)
211 | 
212 |   (define-primitive raise 1 effect)
213 | 
214 |   (define-primitive $make-procedure 2 value)
215 |   (define-primitive $procedure-code 1 value)
216 |   (define-primitive $procedure-ref 2 value)
217 |   (define-primitive $procedure-set! 3 effect)
218 | 
219 |   (define primitive?
220 |     (lambda (x)
221 |       (and (primitive->primitive-info x) #t)))
222 | 
223 |   (define pure-primitive?
224 |     (lambda (x)
225 |       ;; bad proxy for pure, but using it for the moment
226 |       (or (value-primitive? x) (predicate-primitive? x))))
227 | 
228 |   (define value-primitive?
229 |     (lambda (x)
230 |       (cond
231 |         [(primitive-info? x) (eq? (primitive-info-kind x) 'value)]
232 |         [(primitive->primitive-info x) => value-primitive?]
233 |         [else #f])))
234 | 
235 |   (define predicate-primitive?
236 |     (lambda (x)
237 |       (cond
238 |         [(primitive-info? x) (eq? (primitive-info-kind x) 'predicate)]
239 |         [(primitive->primitive-info x) => predicate-primitive?]
240 |         [else #f])))
241 | 
242 |   (define effect-primitive?
243 |     (lambda (x)
244 |       (cond
245 |         [(primitive-info? x) (eq? (primitive-info-kind x) 'effect)]
246 |         [(primitive->primitive-info x) => effect-primitive?]
247 |         [else #f])))
248 | 
249 |   (define primitive->primitive-info
250 |     (lambda (x)
251 |       (hashtable-ref target-primitives x #f)))
252 | 
253 |   (define arity-matcher
254 |     (lambda (len)
255 |       (lambda (arity)
256 |         (if (fx<? arity 0)
257 |             (fx>=? len (fx- (fx- arity) 1))
258 |             (fx=? len arity)))))
259 | 
260 |   (define $arity-matches?
261 |     (lambda (ls len)
262 |       (and (find (arity-matcher len) ls) #t)))
263 | 
264 |   (define arity-matches?
265 |     (lambda (x y)
266 |       (let ([len (if (fixnum? y) y (length y))])
267 |         (cond
268 |           [(eq? x #f) #f]
269 |           [(symbol? x) (arity-matches? (primitive->primitive-info x) len)]
270 |           [(primitive-info? x) ($arity-matches? (primitive-info-arity* x) len)]
271 |           [(list? x) ($arity-matches? x len)]
272 |           [(fixnum? x) ($arity-matches? (list x) len)]
273 |           [else (errorf 'arity-matches? "unexpected source for arity check ~s" x)]))))
274 | 
275 |   (define exact-integer?
276 |     (lambda (x)
277 |       (and (integer? x) (exact? x))))
278 | 
279 |   (define target-fixnum?
280 |     (lambda (x)
281 |       (and (exact-integer? x)
282 |            (<= (- (expt 2 60)) x (- (expt 2 61) 1)))))
283 | 
284 |   (define immediate?
285 |     (lambda (x)
286 |       (or (target-fixnum? x)
287 |           (null? x)
288 |           (boolean? x))))
289 | 
290 |   (define datatype?
291 |     (lambda (x)
292 |       (or (immediate? x)
293 |           (exists (lambda (p) (p x)) (target-datatype-source-preds)))))
294 |   
295 |   (define target-pair?
296 |     (lambda (x)
297 |       (and (pair? x)
298 |            (datatype? (car x))
299 |            (datatype? (cdr x)))))
300 | 
301 |   (define target-vector?
302 |     (lambda (x)
303 |       (and (vector? x)
304 |            (for-all datatype? (vector->list x)))))
305 | 
306 |   (define library-entries (make-hashtable symbol-hash eq?))
307 | 
308 |   (define-syntax define-library-entry
309 |     (lambda (x)
310 |       (syntax-case x ()
311 |         [(_ name e)
312 |          #'(define ignore (hashtable-set! library-entries 'name 'e))])))
313 | 
314 |   (define-library-entry append
315 |     (case-lambda
316 |       [() '()]
317 |       [(x) x]
318 |       [(x y) (letrec ([f (lambda (x) (if (null? x) y (cons (car x) (f (cdr x)))))]) (f x))]
319 |       [(x . rest) (append x (apply append rest))]))
320 | 
321 |   (define-library-entry assq
322 |     (lambda (x as*)
323 |       (letrec ([f (lambda (as*)
324 |                     (if (null? as*)
325 |                         #f
326 |                         (let ([as (car as*)])
327 |                           (if (eq? (car as) x)
328 |                               as
329 |                               (f (cdr as*))))))])
330 |         (f as*))))
331 | 
332 |   (define-library-entry caar (lambda (x) (car (car x))))
333 |   (define-library-entry cadr (lambda (x) (car (cdr x))))
334 |   (define-library-entry cdar (lambda (x) (cdr (car x))))
335 |   (define-library-entry cddr (lambda (x) (cdr (cdr x))))
336 | 
337 |   (define-library-entry caaar (lambda (x) (car (car (car x)))))
338 |   (define-library-entry caadr (lambda (x) (car (car (cdr x)))))
339 |   (define-library-entry cadar (lambda (x) (car (cdr (car x)))))
340 |   (define-library-entry caddr (lambda (x) (car (cdr (cdr x)))))
341 |   (define-library-entry cdaar (lambda (x) (cdr (car (car x)))))
342 |   (define-library-entry cdadr (lambda (x) (cdr (car (cdr x)))))
343 |   (define-library-entry cddar (lambda (x) (cdr (cdr (car x)))))
344 |   (define-library-entry cdddr (lambda (x) (cdr (cdr (cdr x)))))
345 | 
346 |   (define-library-entry caaaar (lambda (x) (car (car (car (car x))))))
347 |   (define-library-entry caaadr (lambda (x) (car (car (car (cdr x))))))
348 |   (define-library-entry caadar (lambda (x) (car (car (cdr (car x))))))
349 |   (define-library-entry caaddr (lambda (x) (car (car (cdr (cdr x))))))
350 | 
351 |   (define-library-entry cadaar (lambda (x) (car (cdr (car (car x))))))
352 |   (define-library-entry cadadr (lambda (x) (car (cdr (car (cdr x))))))
353 |   (define-library-entry caddar (lambda (x) (car (cdr (cdr (car x))))))
354 |   (define-library-entry cadddr (lambda (x) (car (cdr (cdr (cdr x))))))
355 | 
356 |   (define-library-entry cdaaar (lambda (x) (cdr (car (car (car x))))))
357 |   (define-library-entry cdaadr (lambda (x) (cdr (car (car (cdr x))))))
358 |   (define-library-entry cdadar (lambda (x) (cdr (car (cdr (car x))))))
359 |   (define-library-entry cdaddr (lambda (x) (cdr (car (cdr (cdr x))))))
360 | 
361 |   (define-library-entry cddaar (lambda (x) (cdr (cdr (car (car x))))))
362 |   (define-library-entry cddadr (lambda (x) (cdr (cdr (car (cdr x))))))
363 |   (define-library-entry cdddar (lambda (x) (cdr (cdr (cdr (car x))))))
364 |   (define-library-entry cddddr (lambda (x) (cdr (cdr (cdr (cdr x))))))
365 | 
366 |   (define-library-entry call-with-values
367 |     (lambda (producer consumer)
368 |       (apply consumer (producer))))
369 | 
370 |   (define-library-entry cons*
371 |     (case-lambda
372 |       [(d) d]
373 |       [(a d) (cons a d)]
374 |       [(a . rest) (cons a (apply cons* rest))]))
375 | 
376 |   (define-library-entry dynamic-wind ;; without call/cc can be pretty simple
377 |     (lambda (entry f exit)
378 |       (entry)
379 |       (f)
380 |       (exit)))
381 | 
382 |   (define-library-entry equal?
383 |     (lambda (x y)
384 |       (if (eq? x y)
385 |           #t
386 |           (if (pair? x)
387 |               (if (pair? y)
388 |                   (if (equal? (car x) (car y))
389 |                       (equal? (cdr x) (cdr y))
390 |                       #f)
391 |                   #f)
392 |               (if (vector? x)
393 |                   (if (vector? y)
394 |                       (let ([len (vector-length x)])
395 |                         (if (= len (vector-length y))
396 |                             (letrec ([f (lambda (n)
397 |                                           (if (= n 0)
398 |                                               #t
399 |                                               (let ([n (- n 1)])
400 |                                                 (if (equal? (vector-ref x n) (vector-ref y n))
401 |                                                     (f n)
402 |                                                     #f))))])
403 |                               (f len))
404 |                             #f))
405 |                       #f)
406 |                   (if (string? x)
407 |                       (if (string? y)
408 |                           (let ([len (string-length x)])
409 |                             (if (= len (string-length y))
410 |                                 (letrec ([f (lambda (n)
411 |                                               (if (= n 0)
412 |                                                   #t
413 |                                                   (let ([n (- n 1)])
414 |                                                     (if (equal? (string-ref x n) (string-ref y n))
415 |                                                         (f n)
416 |                                                         #f))))])
417 |                                   (f len))
418 |                                 #f))
419 |                           #f)
420 |                       (if (bytevector? x)
421 |                           (if (bytevector? y)
422 |                               (let ([len (bytevector-length x)])
423 |                                 (if (= len (bytevector-length y))
424 |                                     (letrec ([f (lambda (n)
425 |                                                   (if (= n 0)
426 |                                                       #t
427 |                                                       (let ([n (- n 1)])
428 |                                                         (if (equal? (bytevector-u8-ref x n) (bytevector-u8-ref y n))
429 |                                                             (f n)
430 |                                                             #f))))])
431 |                                       (f len))
432 |                                     #f))
433 |                               #f)
434 |                           #f)))))))
435 | 
436 |   (define-library-entry eqv?
437 |     (lambda (x y)
438 |       (eq? x y)))
439 | 
440 |   (define-library-entry exists
441 |     (case-lambda
442 |       [(p ls) (letrec ([f (lambda (ls)
443 |                             (if (null? ls)
444 |                                 #f
445 |                                 (if (p (car ls))
446 |                                     #t
447 |                                     (f (cdr ls)))))])
448 |                 (f ls))]
449 |       [(p ls0 ls1) (letrec ([f (lambda (ls0 ls1)
450 |                                  (if (null? ls0)
451 |                                      #f
452 |                                      (if (p (car ls0) (car ls1))
453 |                                          #t
454 |                                          (f (cdr ls0) (cdr ls1)))))])
455 |                      (f ls0 ls1))]
456 |       [(p ls . rest) (letrec ([f (lambda (ls rest)
457 |                                     (if (null? ls)
458 |                                         #f
459 |                                         (if (apply p (car ls) (map car rest))
460 |                                             #t
461 |                                             (f (cdr ls) (map cdr rest)))))])
462 |                         (f ls rest))]))
463 | 
464 |   (define-library-entry for-all
465 |     (case-lambda
466 |       [(p ls) (letrec ([f (lambda (ls)
467 |                             (if (null? ls)
468 |                                 #t
469 |                                 (if (p (car ls))
470 |                                     (f (cdr ls))
471 |                                     #f)))])
472 |                 (f ls))]
473 |       [(p ls0 ls1) (letrec ([f (lambda (ls0 ls1)
474 |                                  (if (null? ls0)
475 |                                      #t
476 |                                      (if (p (car ls0) (car ls1))
477 |                                          (f (cdr ls0) (cdr ls1))
478 |                                          #f)))])
479 |                      (f ls0 ls1))]
480 |       [(p ls . rest) (letrec ([f (lambda (ls rest)
481 |                                    (if (null? ls)
482 |                                        #t
483 |                                        (if (apply p (car ls) (map car rest))
484 |                                            (f (cdr ls) (map cdr rest))
485 |                                            #f)))])
486 |                        (f ls rest))]))
487 | 
488 |   (define-library-entry for-each
489 |     (case-lambda
490 |       [(p ls) (letrec ([f (lambda (ls)
491 |                             (if (null? ls)
492 |                                 (void)
493 |                                 (begin
494 |                                   (p (car ls))
495 |                                   (f (cdr ls)))))])
496 |                 (f ls))]
497 |       [(p ls0 ls1) (letrec ([f (lambda (ls0 ls1)
498 |                                  (if (null? ls0)
499 |                                      (void)
500 |                                      (begin
501 |                                        (p (car ls0) (car ls1))
502 |                                        (f (cdr ls0) (cdr ls1)))))])
503 |                      (f ls0 ls1))]
504 |       [(p ls . rest) (letrec ([f (lambda (ls rest)
505 |                                    (if (null? ls)
506 |                                        (void)
507 |                                        (begin
508 |                                          (apply p (car ls) (map car rest))
509 |                                          (f (cdr ls) (map cdr rest)))))])
510 |                        (f ls rest))]))
511 | 
512 |   (define-library-entry hashtable-entries
513 |     (lambda (ht)
514 |       (eq-hashtable-entries ht)))
515 | 
516 |   (define-library-entry hashtable-ref
517 |     (lambda (ht key default)
518 |       (eq-hashtable-ref ht key default)))
519 | 
520 |   (define-library-entry hashtable-set!
521 |     (lambda (ht key value)
522 |       (eq-hashtable-set! ht key value)))
523 | 
524 |   (define-library-entry length
525 |     (lambda (ls)
526 |       (if (pair? ls)
527 |           (+ 1 (length (cdr ls)))
528 |           0)))
529 | 
530 |   (define-library-entry list (lambda ls ls))
531 | 
532 |   (define-library-entry list->vector
533 |     (lambda (ls)
534 |       (letrec ([f (lambda (ls n)
535 |                     (if (null? ls)
536 |                         (make-vector n)
537 |                         (let ([v (f (cdr ls) (+ n 1))])
538 |                           (vector-set! v n (car ls))
539 |                           v)))])
540 |         (f ls 0))))
541 | 
542 |   (define-library-entry list?
543 |     (lambda (x)
544 |       (if (pair? x)
545 |           (list? (cdr x))
546 |           (null? x))))
547 | 
548 |   (define-library-entry map
549 |     (case-lambda
550 |       [(p ls)
551 |        (letrec ([f (lambda (ls)
552 |                      (if (null? ls)
553 |                          '()
554 |                          (cons (p (car ls)) (f (cdr ls)))))])
555 |          (f ls))]
556 |       [(p ls0 ls1)
557 |        (letrec ([f (lambda (ls0 ls1)
558 |                      (if (null? ls0)
559 |                          '()
560 |                          (cons (p (car ls0) (car ls1)) (f (cdr ls0) (cdr ls1)))))])
561 |          (f ls0 ls1))]
562 |       [(p ls . rest)
563 |        (letrec ([f (lambda (ls rest)
564 |                      (if (null? ls)
565 |                          '()
566 |                          (cons (apply p (car ls) (map car rest)) (f (cdr ls) (map cdr rest)))))])
567 |          (f ls rest))]))
568 | 
569 |   (define-library-entry member
570 |     (lambda (x ls)
571 |       (letrec ([f (lambda (ls)
572 |                     (if (null? ls)
573 |                         #f
574 |                         (if (equal? x (car ls))
575 |                             ls
576 |                             (f (cdr ls)))))])
577 |         (f ls))))
578 | 
579 |   (define-library-entry memq
580 |     (lambda (x ls)
581 |       (letrec ([f (lambda (ls)
582 |                     (if (null? ls)
583 |                         #f
584 |                         (if (eq? x (car ls))
585 |                             ls
586 |                             (f (cdr ls)))))])
587 |         (f ls))))
588 | 
589 |   (define-library-entry memv
590 |     (lambda (x ls)
591 |       (letrec ([f (lambda (ls)
592 |                     (if (null? ls)
593 |                         #f
594 |                         (if (eqv? x (car ls))
595 |                             ls
596 |                             (f (cdr ls)))))])
597 |         (f ls))))
598 | 
599 |   (define-library-entry number?
600 |     (lambda (x)
601 |       (fixnum? x)))
602 | 
603 |   (define-library-entry remq
604 |     (lambda (x ls)
605 |       (letrec ([f (lambda (ls)
606 |                     (if (null? ls)
607 |                         '()
608 |                         (let ([y (car ls)])
609 |                           (if (eq? x y)
610 |                               (f (cdr ls))
611 |                               (cons y (f (cdr ls)))))))])
612 |         (f ls))))
613 | 
614 |   (define-library-entry reverse
615 |     (lambda (ls)
616 |       (letrec ([f (lambda (ls rls)
617 |                     (if (null? ls)
618 |                         rls
619 |                         (f (cdr ls) (cons (car ls) rls))))])
620 |         (f ls '()))))
621 | 
622 |   (define-library-entry list->string
623 |     (lambda (ls)
624 |       (letrec ([f (lambda (ls n)
625 |                     (if (null? n)
626 |                         (make-string n)
627 |                         (let ([str (f (cdr ls) (+ n 1))])
628 |                           (string-set! str n (car ls))
629 |                           str)))])
630 |         (f ls))))
631 | 
632 |   (define-library-entry string (lambda ls (list->string ls)))
633 | 
634 |   (define-library-entry string->list
635 |     (lambda (str)
636 |       (letrec ([f (lambda (n ls)
637 |                     (if (= n 0)
638 |                         ls
639 |                         (let ([n (- n 1)])
640 |                           (f n (cons (string-ref str n) ls)))))])
641 |         (f (string-length str) '()))))
642 | 
643 |   (define-library-entry string-append
644 |     (case-lambda
645 |       [() '""]
646 |       [(x) x]
647 |       [(x y) (let ([len-x (string-length x)]
648 |                    [len-y (string-length y)])
649 |                (let ([str (make-string (+ len-x len-y))])
650 |                  (letrec ([f (lambda (n)
651 |                                (if (= n len-x)
652 |                                    (letrec ([f (lambda (n i)
653 |                                                  (if (= i len-y)
654 |                                                      str
655 |                                                      (begin
656 |                                                        (string-set! str n (string-ref y i))
657 |                                                        (f (+ n 1) (+ i 1)))))])
658 |                                      (f n 0))
659 |                                    (begin
660 |                                      (string-set! str n (string-ref x n))
661 |                                      (f (+ n 1)))))])
662 |                    (f 0))))]
663 |       [(x . rest) (string-append x (apply string-append rest))]))
664 | 
665 |   (define-library-entry values (lambda ls ls))
666 | 
667 |   (define-library-entry vector (lambda ls (list->vector ls)))
668 | 
669 |   (define-library-entry vector->list
670 |     (lambda (v)
671 |       (letrec ([f (lambda (n ls)
672 |                     (if (= n 0)
673 |                         ls
674 |                         (let ([n (- n 1)])
675 |                           (f n (cons (vector-ref v n) ls)))))])
676 |         (f (vector-length v)))))
677 | 
678 |   (define-library-entry vector-for-each
679 |     (case-lambda
680 |       [(p v)
681 |        (let ([len (vector-length v)])
682 |          (letrec ([f (lambda (n)
683 |                        (if (= n len)
684 |                            (void)
685 |                            (begin
686 |                              (p (vector-ref v n))
687 |                              (f (+ n 1)))))])
688 |            (f 0)))]
689 |       [(p v0 v1)
690 |        (let ([len (vector-length v0)])
691 |          (letrec ([f (lambda (n)
692 |                        (if (= n len)
693 |                            (void)
694 |                            (begin
695 |                              (p (vector-ref v0 n) (vector-ref v1 n))
696 |                              (f (+ n 1)))))])
697 |            (f 0)))]
698 |       [(p v . rest)
699 |        (let ([len (vector-length v)])
700 |          (letrec ([f (lambda (n)
701 |                        (if (= n len)
702 |                            (void)
703 |                            (begin
704 |                              (apply p (vector-ref v n) (map (lambda (v) (vector-ref v n)) rest))
705 |                              (f (+ n 1)))))])
706 |            (f 0)))]))
707 | 
708 |   (define-library-entry vector-map
709 |     (case-lambda
710 |       [(p v)
711 |        (let ([len (vector-length v)])
712 |          (let ([v-out (make-vector len)])
713 |            (letrec ([f (lambda (n)
714 |                          (if (= n 0)
715 |                              v-out
716 |                              (let ([n (- n 1)])
717 |                                (vector-set! v-out n (p (vector-ref v n)))
718 |                                (f n))))])
719 |              (f len))))]
720 |        [(p v0 v1)
721 |         (let ([len (vector-length v0)])
722 |           (let ([v-out (make-vector len)])
723 |             (letrec ([f (lambda (n)
724 |                           (if (= n 0)
725 |                               v-out
726 |                               (let ([n (- n 1)])
727 |                                 (vector-set! v-out n (p (vector-ref v0 n) (vector-ref v1 n)))
728 |                                 (f n))))])
729 |               (f len))))]
730 |        [(p v . rest)
731 |         (let ([len (vector-length v)])
732 |           (let ([v-out (make-vector len)])
733 |             (letrec ([f (lambda (n)
734 |                           (if (= n 0)
735 |                               v-out
736 |                               (let ([n (- n 1)])
737 |                                 (vector-set! v-out n
738 |                                   (apply p (vector-ref v n)
739 |                                     (map (lambda (v) (vector-ref v n)) rest)))
740 |                                 (f n))))])
741 |               (f n))))]))
742 | 
743 |   (define-library-entry zero?
744 |     (lambda (n)
745 |       (= n 0)))
746 |     
747 | )
748 | 


--------------------------------------------------------------------------------
/src/main/scheme/match.sls:
--------------------------------------------------------------------------------
  1 | ;;; match.ss: a simple pattern matcher in scheme
  2 | ;;;
  3 | ;;; Copyright Andy Keep
  4 | ;;; Licensed under the CRAPL: http://matt.might.net/articles/crapl/
  5 | ;;;
  6 | ;;; I've used or written variations on this kind of a match syntax
  7 | ;;; for a long time now and finally decided to pull together one of
  8 | ;;; my own.  It matches some in syntax and probably inadvertantly
  9 | ;;; steals some of the design pattern (in this case the success and
 10 | ;;; failure continuations, but was written from scratch and could
 11 | ;;; almost certainly use improvement.
 12 | ;;;
 13 | ;;; Syntax:
 14 | ;;; (match <exp> <cl> ...)
 15 | ;;;
 16 | ;;; where <cl> is:
 17 | ;;;
 18 | ;;; <cl> => [<pat> (guard <exp> ... <exp>) <exp> ... <exp>]
 19 | ;;;         [<pat> <exp> ... <exp>]
 20 | ;;;         [else <exp> ... <exp>]
 21 | ;;;
 22 | ;;; where the "else" clause may only appear as the last clause.  The guarded
 23 | ;;; pattern matches when <pat> matches and all of the <exp> in
 24 | ;;; (guard <exp> ...  <exp>) evaluate to true (<exp> in guard are effectively
 25 | ;;; treated as an and).  The unguarded pattern matches when <pat> is matched,
 26 | ;;; and the else clause matches when all else fails.  Clauses are evaluated in
 27 | ;;; order, from first to last, with the else clause executed when all other
 28 | ;;; clauses are exhausted.  If no else clause exists, match will raise an error
 29 | ;;; to indicate it failed to find a suitable match.
 30 | ;;;
 31 | ;;; where <pat> is of the form:
 32 | ;;; <pat> => sym                 -- matches symbol exactly
 33 | ;;;          (<pat>0 . <pat>1)   -- matches a pair with <pat>0 as car and <pat>1 as cdr
 34 | ;;;          (<pat> ...)         -- matches 0 or more <pat>
 35 | ;;;          (<pat>0 ... <pat>1) -- matches 0 or more <pat>0 followed by a <pat>1
 36 | ;;;          ,id                 -- binds id to the current expression
 37 | ;;;
 38 | ;;; examples:
 39 | ;;;
 40 | ;;; (match e
 41 | ;;;   [(lambda (,x) ,body) (guard (symbol? x)) ---]
 42 | ;;;   [(,e0 ,e1) ---]
 43 | ;;;   [,x (guard (symbol? x)) ---])
 44 | ;;;
 45 | ;;; matches the terms of the lambda calculus and
 46 | ;;;
 47 | ;;; (match e
 48 | ;;;   [(lambda (,x* ...) ,body* ... ,body) (guard (andmap symbol? x*)) ---]
 49 | ;;;   [(let ([,x* ,e*] ...) ,body* ... ,body) (guard (andmap symbol? x*)) ---]
 50 | ;;;   [(letrec ([,x* ,e*] ...) ,body* ... ,body) (guard (andmap symbol? x*)) ---]
 51 | ;;;   [(if ,e0 ,e1 ,e2) ---]
 52 | ;;;   [(,e ,e* ...) ---]
 53 | ;;;   [,x (guard (symbol? x)) ---]
 54 | ;;;   [else ---])
 55 | ;;;
 56 | ;;; matches a subset of scheme.
 57 | ;;;
 58 | 
 59 | (library (match)
 60 |   (export match)
 61 |   (import (rnrs) (only (chezscheme) datum errorf trace-define trace-define-syntax))
 62 |   (define-syntax xmatch
 63 |     (lambda (x)
 64 |       (define (extract-bindings pat)
 65 |         (let f ([pat pat] [bindings '()])
 66 |           (syntax-case pat (unquote)
 67 |             [,bind (identifier? #'bind) (cons #'bind bindings)]
 68 |             [(?a . ?d) (f #'?a (f #'?d bindings))]
 69 |             [_ bindings])))
 70 |       (define build-call-exp
 71 |         (case-lambda
 72 |           [(level proc bind-in args)
 73 |            (let f ([level level] [bind-in bind-in])
 74 |              (if (fx=? level 0)
 75 |                  #`(#,proc #,bind-in #,@args)
 76 |                  #`(map (lambda (t) #,(f (fx- level 1) #'t)) #,bind-in)))]
 77 |           [(level proc bind-in args extra-rvs)
 78 |            (if (fx=? level 0)
 79 |                #`(#,proc #,bind-in #,@args)
 80 |                (let f ([level level] [bind-in bind-in])
 81 |                  (with-syntax ([(ts* ...) (generate-temporaries (cons 'x extra-rvs))]
 82 |                                [(ts ...) (generate-temporaries (cons 'x extra-rvs))])
 83 |                    #`(let mv-map ([t bind-in])
 84 |                        (values #,@(map (lambda (x) #''()) (cons 'x extra-rvs)))
 85 |                        (let-values ([(ts* ...) (mv-map (cdr t))]
 86 |                                     [(ts ...) #,(if (fx=? level 1)
 87 |                                                     #`(#,proc (car t) #,@args)
 88 |                                                     #`(let ([t (car t)])
 89 |                                                         #,(f (fx- level 1) #'t)))])
 90 |                          (values (cons ts ts*) ...))))))]))
 91 |       (define (process-pattern id level pat body fk)
 92 |         (with-syntax ([id id] [fk fk])
 93 |           (syntax-case pat (unquote)
 94 |             [,?bind (identifier? #'?bind) #`(let ([?bind id]) #,body)]
 95 |             [(?a dots)
 96 |              (eq? (datum dots) '...)
 97 |              (with-syntax ([(binding ...) (extract-bindings #'?a)]
 98 |                            [(t0 t1 loop) (generate-temporaries '(t0 t1 loop))])
 99 |                (with-syntax ([(tbinding ...) (generate-temporaries #'(binding ...))])
100 |                  #`(let loop ([t0 id] [tbinding '()] ...)
101 |                      (cond
102 |                        [(pair? t0)
103 |                         (let ([t1 (car t0)] [t0 (cdr t0)])
104 |                           #,(process-pattern #'t1 (fx+ level 1) #'?a
105 |                                #'(loop t0 (cons binding tbinding) ...)
106 |                                #'fk))]
107 |                        [(null? t0)
108 |                         (let ([binding (reverse tbinding)] ...)
109 |                           #,body)]
110 |                        [else (fk)]))))]
111 |             [(?a dots . ?d)
112 |              (eq? (datum dots) '...)
113 |              (with-syntax ([(binding ...) (extract-bindings #'?a)]
114 |                            [(t0 t1 new-fk loop) (generate-temporaries '(t0 t1 new-fk loop))])
115 |                (with-syntax ([(tbinding ...) (generate-temporaries #'(binding ...))])
116 |                  #`(let loop ([t0 id] [tbinding '()] ...)
117 |                      (let ([new-fk (lambda ()
118 |                                      (if (pair? t0)
119 |                                          (let ([t1 (car t0)] [t0 (cdr t0)])
120 |                                            #,(process-pattern #'t1 (fx+ level 1) #'?a
121 |                                                #'(loop t0 (cons binding tbinding) ...)
122 |                                                #'fk))
123 |                                          (fk)))])
124 |                        #,(process-pattern #'t0 level #'?d
125 |                            #`(let ([binding (reverse tbinding)] ...)
126 |                                #,body)
127 |                            #'new-fk)))))]
128 |             [(?a . ?d)
129 |              (with-syntax ([(a d) (generate-temporaries '(a d))])
130 |                #`(if (pair? id)
131 |                      (let ([a (car id)] [d (cdr id)])
132 |                        #,(process-pattern #'a level #'?a
133 |                            (process-pattern #'d level #'?d body #'fk)
134 |                            #'fk))
135 |                      (fk)))]
136 |             [under (eq? (datum under) '_) body]
137 |             [sym (identifier? #'sym) #`(if (eq? id 'sym) #,body (fk))]
138 |             [() #`(if (null? id) #,body (fk))])))
139 |       (define (process-clause id cl fk)
140 |         (syntax-case cl (guard)
141 |           [[pat (guard e0 e1 ...) body0 body1 ...]
142 |            (process-pattern id 0 #'pat
143 |              #`(if (and e0 e1 ...)
144 |                    (begin body0 body1 ...)
145 |                    (#,fk))
146 |              fk)]
147 |           [[pat body0 body1 ...]
148 |            (process-pattern id 0 #'pat #'(begin body0 body1 ...) fk)]))
149 |       (define (process-match id cl* else-body)
150 |         (let f ([cl* cl*])
151 |           (if (null? cl*)
152 |               else-body
153 |               (let ([cl (car cl*)] [cl* (cdr cl*)])
154 |                 (with-syntax ([(fk) (generate-temporaries '(fk))])
155 |                   #`(let ([fk (lambda () #,(f cl*))])
156 |                       #,(process-clause id cl #'fk)))))))
157 |       (syntax-case x (else)
158 |         [(_ id cl ... [else ebody0 ebody1 ...])
159 |          (identifier? #'id)
160 |          (with-syntax ([body (process-match #'id #'(cl ...) #'(begin ebody0 ebody1 ...))])
161 |            #`(let f ([id id]) body))]
162 |         [(_ id cl ...)
163 |          (identifier? #'id)
164 |          #'(xmatch id
165 |              cl ...
166 |              [else (errorf 'match "~s does not match any clauses" id)])]
167 |         [(_ e cl ... [else ebody0 ebody1 ...])
168 |          #'(let ([t e]) (xmatch t cl ... [else ebody0 ebody1 ...]))]
169 |         [(_ e cl ...)
170 |          #'(let ([t e])
171 |              (xmatch t
172 |                cl ...
173 |                [else (errorf 'match "~s does not match any clauses" t)]))])))
174 |   
175 |   (define-syntax match
176 |     (lambda (x)
177 |       (define (process-cata cata level body)
178 |         (define (serror) (syntax-violation 'match "invalid cata syntax" x cata))
179 |         (define (s0 cata)
180 |           (syntax-case cata ()
181 |             [[colon . rest] (eq? (datum colon) ':) (s2 #'matcher #'rest)]
182 |             [[arrow . rest] (eq? (datum arrow) '->) (s4 #'matcher (generate-temporaries '(in-id)) '() #'rest)]
183 |             [[e . rest] (s1 #'e #'rest)]
184 |             [[] (finish #'matcher (generate-temporaries '(in-id)) (list))]
185 |             [_ (serror)]))
186 |         (define (s1 e cata)
187 |           (syntax-case cata ()
188 |             [[colon . rest] (eq? (datum colon) ':) (s2 e #'rest)]
189 |             [[arrow . rest]
190 |              (and (eq? (datum arrow) '->) (identifier? e))
191 |              (s4 #'matcher (list e) '() #'rest)]
192 |             [[expr . rest]
193 |              (identifier? e)
194 |              (s3 #'matcher (list e) #'rest)]
195 |             [[] (identifier? e) (finish #'matcher (generate-temporaries '(in-id)) (list e))]
196 |             [_ (serror)]))
197 |         (define (s2 f cata)
198 |           (syntax-case cata ()
199 |             [[arrow . rest] (eq? (datum arrow) '->) (s4 f (generate-temporaries '(in-id)) '() #'rest)]
200 |             [[id . rest] (identifier? #'id) (s3 f (list #'id) #'rest)]
201 |             [_ (serror)]))
202 |         (define (s3 f e* cata)
203 |           (syntax-case cata ()
204 |             [[arrow . rest] (eq? (datum arrow) '->) (s4 f (reverse e*) '() #'rest)]
205 |             [[e . rest] (s3 f (cons #'e e*) #'rest)]
206 |             [[] (for-all identifier? e*) (finish f (generate-temporaries '(in-id)) (reverse e*))]))
207 |         (define (s4 f in-id-arg* out-id* cata)
208 |           (syntax-case cata ()
209 |             [[id . rest] (identifier? #'id) (s4 f in-id-arg* (cons #'id out-id*) #'rest)]
210 |             [[] (finish f in-id-arg* (reverse out-id*))]
211 |             [_ (serror)]))
212 |         (define (finish f in-id-arg* out-id*)
213 |           (if (fx=? (length out-id*) 1)
214 |               (finish-sv f in-id-arg* (car out-id*))
215 |               (finish-mv f in-id-arg* out-id*)))
216 |         (define (finish-sv f in-id-arg* out-id)
217 |           (with-syntax ([call-expr
218 |                          (if (fx=? (length in-id-arg*) 1)
219 |                              (finish-sv-in-sv-out f (car in-id-arg*))
220 |                              (finish-mv-in-sv-out f in-id-arg*))])
221 |             #`(#,(car in-id-arg*) (let ([#,out-id call-expr]) #,body))))
222 |         (define (finish-mv f in-id-arg* out-id*)
223 |           (with-syntax ([call-expr
224 |                          (if (fx=? (length in-id-arg*) 1)
225 |                              (finish-sv-in-mv-out f (car in-id-arg*) out-id*)
226 |                              (finish-mv-in-mv-out f in-id-arg* out-id*))])
227 |             #`(#,(car in-id-arg*) (let-values ([#,out-id* call-expr]) #,body))))
228 |         (define (finish-sv-in-sv-out f in-id)
229 |           (if (fx=? level 0)
230 |               #`(#,f #,in-id)
231 |               (let loop ([level level] [in-id in-id])
232 |                 (if (fx=? level 1)
233 |                     #`(map #,f #,in-id)
234 |                     #`(map (lambda (t) #,(loop (fx- level 1) #'t)) #,in-id)))))
235 |         (define (finish-mv-in-sv-out f in-id-arg*)
236 |           (with-syntax ([(id arg* ...) in-id-arg*])
237 |             (let loop ([level level] [in-id #'id])
238 |               (if (fx=? level 0)
239 |                   #`(#,f #,in-id arg* ...)
240 |                   #`(map (lambda (t) #,(loop (fx- level 1) #'t)) #,in-id)))))
241 |         (define (finish-sv-in-mv-out f in-id out-id*)
242 |           (if (fx=? level 0)
243 |               #`(#,f #,in-id)
244 |               (with-syntax ([(ts* ...) (generate-temporaries out-id*)]
245 |                             [(ts ...) (generate-temporaries out-id*)]
246 |                             [(end ...) (map (lambda (ignore) #''()) out-id*)])
247 |                 (let loop ([level level] [in-id in-id])
248 |                   (if (fx=? level 1)
249 |                       #`(let mv-map ([t #,in-id])
250 |                           (if (null? t)
251 |                               (values end ...)
252 |                               (let-values ([(ts* ...) (mv-map (cdr t))]
253 |                                            [(ts ...) (f (car t))])
254 |                                 (values (cons ts ts*) ...))))
255 |                       #`(let mv-map ([t #,in-id])
256 |                           (if (null? t)
257 |                               (values end ...)
258 |                               (let-values ([(ts* ...) (mv-map (cdr t))]
259 |                                            [(ts ...) #,(loop (fx- level 1) #`(car #,in-id))])
260 |                                 (values (cons ts ts*) ...)))))))))
261 |         (define (finish-mv-in-mv-out f in-id-arg* out-id*)
262 |           (with-syntax ([(id arg* ...) in-id-arg*]
263 |                         [(ts* ...) (generate-temporaries out-id*)]
264 |                         [(ts ...) (generate-temporaries out-id*)]
265 |                         [(end ...) (map (lambda (ignore) #''()) out-id*)])
266 |             (let loop ([level level] [in-id #'id])
267 |               (if (fx=? level 0)
268 |                   #`(#,f #,in-id arg* ...)
269 |                   #`(let mv-map ([t #,in-id])
270 |                       (if (null? t)
271 |                           (values end ...)
272 |                           (let-values ([(ts* ...) (mv-map (cdr t))]
273 |                                        [(ts ...) #,(loop (fx- level 1) #`(car #,in-id))])
274 |                             (values (cons ts ts*) ...))))))))
275 |         (s0 cata))
276 |       (define (realize-catas pat body)
277 |         (let loop ([pat pat] [level 0] [body body])
278 |           (syntax-case pat (unquote)
279 |             [,?bind (identifier? #'?bind) #`(#,pat #,body)]
280 |             [,?cata
281 |              (with-syntax ([(?bind body) (process-cata #'?cata level body)])
282 |                #'(,?bind body))]
283 |             [(?a dots)
284 |              (eq? (datum dots) '...)
285 |              (with-syntax ([(?a body) (loop #'?a (fx+ level 1) body)])
286 |                #`((?a dots) body))]
287 |             [(?a dots . ?d)
288 |              (eq? (datum dots) '...)
289 |              (with-syntax ([(?d body) (loop #'?d level body)])
290 |                (with-syntax ([(?a body) (loop #'?a (fx+ level 1) #'body)])
291 |                  #`((?a dots . ?d) body)))]
292 |             [(?a . ?d)
293 |              (with-syntax ([(?d body) (loop #'?d level body)])
294 |                (with-syntax ([(?a body) (loop #'?a level #'body)])
295 |                  #`((?a . ?d) body)))]
296 |             [under (eq? (datum under) '_) #`(#,pat #,body)]
297 |             [sym (identifier? #'sym) #`(#,pat #,body)]
298 |             [() #`(#,pat #,body)])))
299 |       (define (process-clause cl)
300 |         (syntax-case cl (guard)
301 |           [[pat (guard ge0 ge1 ...) body0 body1 ...]
302 |            (with-syntax ([(pat body) (realize-catas #'pat #'(let () body0 body1 ...))])
303 |              #'[pat (guard ge0 ge1 ...) body])]
304 |           [[pat body0 body1 ...]
305 |            (with-syntax ([(pat body) (realize-catas #'pat #'(let () body0 body1 ...))])
306 |              #'[pat body])]))
307 |       (syntax-case x (else)
308 |         [(_ id cl ... [else e0 e1 ...])
309 |          (identifier? #'id)
310 |          (with-syntax ([(cl ...) (map process-clause #'(cl ...))])
311 |            #'(let matcher ([id id])
312 |                (xmatch id cl ... [else e0 e1 ...])))]
313 |         [(_ id cl ...)
314 |          (identifier? #'id)
315 |          (with-syntax ([(cl ...) (map process-clause #'(cl ...))])
316 |            #'(let matcher ([id id])
317 |                (xmatch id cl ...)))]
318 |         [(_ expr cl ... [else e0 e1 ...])
319 |          (with-syntax ([(cl ...) (map process-clause #'(cl ...))])
320 |            #'(let matcher ([t expr])
321 |                (xmatch t cl ... [else e0 e1 ...])))]
322 |         [(_ expr cl ...)
323 |          (with-syntax ([(cl ...) (map process-clause #'(cl ...))])
324 |            #'(let matcher ([t expr])
325 |                (xmatch t cl ...)))]))))
326 | 


--------------------------------------------------------------------------------