| 1 | ;;;; syntax-case.scm |
|---|
| 2 | ; |
|---|
| 3 | |
|---|
| 4 | |
|---|
| 5 | (declare |
|---|
| 6 | (unit syntax-case) |
|---|
| 7 | (interrupts-disabled) |
|---|
| 8 | (number-type fixnum) |
|---|
| 9 | (standard-bindings) |
|---|
| 10 | (extended-bindings) ) |
|---|
| 11 | |
|---|
| 12 | (cond-expand |
|---|
| 13 | [paranoia] |
|---|
| 14 | [else |
|---|
| 15 | (declare |
|---|
| 16 | (no-bound-checks) ) ] ) |
|---|
| 17 | |
|---|
| 18 | #{syncase |
|---|
| 19 | list* eval-hook expand-install-hook error-hook new-symbol-hook global-definitions put-global-definition-hook |
|---|
| 20 | get-global-definition-hook |
|---|
| 21 | build-application build-conditional build-lexical-reference build-lexical-assignment build-global-reference |
|---|
| 22 | build-global-assignment build-lambda build-improper-lambda build-data build-identifier build-sequence |
|---|
| 23 | build-letrec build-global-definition syntax-dispatch install-global-transformer |
|---|
| 24 | install-macro-package srfi-0-def std-defs install-macro-defs} |
|---|
| 25 | |
|---|
| 26 | (declare |
|---|
| 27 | (hide syncase-dispatch build-lambda build-improper-lambda build-data srfi-0-def list* |
|---|
| 28 | expand-install-hook eval-hook new-symbol-hook std-defs get-global-definition-hook |
|---|
| 29 | put-global-definition-hook build-sequence build-letrec build-global-assignment |
|---|
| 30 | build-lexical-assignment global-definitions error-hook build-application |
|---|
| 31 | build-conditional install-global-transformer build-global-definition build-identifier |
|---|
| 32 | build-lexical-reference build-global-reference) ) |
|---|
| 33 | |
|---|
| 34 | |
|---|
| 35 | ;;; compat.ss |
|---|
| 36 | ;;; Robert Hieb & Kent Dybvig |
|---|
| 37 | ;;; 92/06/18 |
|---|
| 38 | |
|---|
| 39 | ;;; This file contains nonstandard help procedures. |
|---|
| 40 | ;;; They are all present in Chez Scheme, but are easily defined |
|---|
| 41 | ;;; in any standard Scheme system. |
|---|
| 42 | ;;; These versions do no error checking. |
|---|
| 43 | |
|---|
| 44 | |
|---|
| 45 | ;;; hooks.ss |
|---|
| 46 | ;;; Robert Hieb & Kent Dybvig |
|---|
| 47 | ;;; 92/06/18 |
|---|
| 48 | |
|---|
| 49 | (define (list* first . rest) |
|---|
| 50 | (let recur ((x first) (rest rest)) |
|---|
| 51 | (if (pair? rest) |
|---|
| 52 | (cons x (recur (car rest) (cdr rest))) |
|---|
| 53 | x))) |
|---|
| 54 | |
|---|
| 55 | |
|---|
| 56 | ;;; This file contains procedures that are best defined using |
|---|
| 57 | ;;; nonstandard features. |
|---|
| 58 | ;;; The following work in Chez Scheme. |
|---|
| 59 | |
|---|
| 60 | ;;; eval-hook should be a one-argument "eval". It is used to evaluate |
|---|
| 61 | ;;; macro definitions during macro expansion. Since it receives |
|---|
| 62 | ;;; an expression that has already been expanded, there is no need |
|---|
| 63 | ;;; to reexpand. |
|---|
| 64 | |
|---|
| 65 | (define eval-hook |
|---|
| 66 | (let ([old (##sys#eval-handler)]) |
|---|
| 67 | (lambda (x) (old x)) ) ) |
|---|
| 68 | |
|---|
| 69 | ;;; expand-install-hook takes a one-argument "expand" procedure as |
|---|
| 70 | ;;; an argument, and installs it as the system expander to be |
|---|
| 71 | ;;; invoked on all expressions prior to evaluation. In Chez Scheme, |
|---|
| 72 | ;;; we redefine the current evaluator (used by the read-eval-print |
|---|
| 73 | ;;; loop and load) to invoke expand and call eval-hook on the result. |
|---|
| 74 | |
|---|
| 75 | (define expand-install-hook |
|---|
| 76 | (lambda (expand) |
|---|
| 77 | (##sys#eval-handler (lambda (x . env) (eval-hook (expand x)))) |
|---|
| 78 | (set! ##sys#macroexpand-hook (lambda (x me) x)) |
|---|
| 79 | (set! ##sys#macroexpand-1-hook (lambda (x me) x)) |
|---|
| 80 | (set! ##sys#compiler-toplevel-macroexpand-hook expand) ) ) |
|---|
| 81 | |
|---|
| 82 | |
|---|
| 83 | ;;; In Chez Scheme, the following reports: |
|---|
| 84 | ;;; "Error in <who>: <why> <what>." |
|---|
| 85 | ;;; "who" is a symbol, "why" is a string, and "what" is an arbitrary object. |
|---|
| 86 | |
|---|
| 87 | (define error-hook |
|---|
| 88 | (lambda (who why what) (##sys#error why what who))) |
|---|
| 89 | |
|---|
| 90 | ;;; New symbols are used to generate non-capturing bindings. If it is |
|---|
| 91 | ;;; impossible to generate unique symbols, output identifiers during |
|---|
| 92 | ;;; expansion and either feed the result directly into the compiler or |
|---|
| 93 | ;;; make another pass to perform alpha substitution. |
|---|
| 94 | |
|---|
| 95 | (define new-symbol-hook gensym) |
|---|
| 96 | |
|---|
| 97 | ;;; "put-global-definition-hook" should overwrite existing definitions. |
|---|
| 98 | |
|---|
| 99 | (define global-definitions (make-vector 997 '())) |
|---|
| 100 | |
|---|
| 101 | (define put-global-definition-hook |
|---|
| 102 | (lambda (symbol binding) |
|---|
| 103 | (##sys#hash-table-set! global-definitions symbol binding))) |
|---|
| 104 | |
|---|
| 105 | ;;; "get-global-definition-hook" should return "#f" if no binding |
|---|
| 106 | ;;; has been established "put-global-definition-hook" for the symbol. |
|---|
| 107 | |
|---|
| 108 | (define get-global-definition-hook |
|---|
| 109 | (lambda (symbol) |
|---|
| 110 | (##sys#hash-table-ref global-definitions symbol) ) ) |
|---|
| 111 | |
|---|
| 112 | |
|---|
| 113 | ;;; output.ss |
|---|
| 114 | ;;; Robert Hieb & Kent Dybvig |
|---|
| 115 | ;;; 92/06/18 |
|---|
| 116 | |
|---|
| 117 | ; The output routines can be tailored to feed a specific system or compiler. |
|---|
| 118 | ; They are set up here to generate the following subset of standard Scheme: |
|---|
| 119 | |
|---|
| 120 | ; <expression> :== <application> |
|---|
| 121 | ; | <variable> |
|---|
| 122 | ; | (set! <variable> <expression>) |
|---|
| 123 | ; | (define <variable> <expression>) |
|---|
| 124 | ; | (lambda (<variable>*) <expression>) |
|---|
| 125 | ; | (lambda <variable> <expression>) |
|---|
| 126 | ; | (lambda (<variable>+ . <variable>) <expression>) |
|---|
| 127 | ; | (letrec (<binding>+) <expression>) |
|---|
| 128 | ; | (if <expression> <expression> <expression>) |
|---|
| 129 | ; | (begin <expression> <expression>) |
|---|
| 130 | ; | (quote <datum>) |
|---|
| 131 | ; <application> :== (<expression>+) |
|---|
| 132 | ; <binding> :== (<variable> <expression>) |
|---|
| 133 | ; <variable> :== <symbol> |
|---|
| 134 | |
|---|
| 135 | ; Definitions are generated only at top level. |
|---|
| 136 | |
|---|
| 137 | (define build-application |
|---|
| 138 | (lambda (fun-exp arg-exps) |
|---|
| 139 | `(,fun-exp ,@arg-exps))) |
|---|
| 140 | |
|---|
| 141 | (define build-conditional |
|---|
| 142 | (lambda (test-exp then-exp else-exp) |
|---|
| 143 | `(if ,test-exp ,then-exp ,else-exp))) |
|---|
| 144 | |
|---|
| 145 | (define build-lexical-reference (lambda (var) var)) |
|---|
| 146 | |
|---|
| 147 | (define build-lexical-assignment |
|---|
| 148 | (lambda (var exp) |
|---|
| 149 | `(##core#set! ,var ,exp))) |
|---|
| 150 | |
|---|
| 151 | (define build-global-reference (lambda (var) var)) |
|---|
| 152 | |
|---|
| 153 | (define build-global-assignment |
|---|
| 154 | (lambda (var exp) |
|---|
| 155 | `(##core#set! ,var ,exp))) |
|---|
| 156 | |
|---|
| 157 | (define build-lambda |
|---|
| 158 | (lambda (vars exp) |
|---|
| 159 | `(lambda ,vars ,exp))) |
|---|
| 160 | |
|---|
| 161 | (define build-improper-lambda |
|---|
| 162 | (lambda (vars var exp) |
|---|
| 163 | `(lambda (,@vars . ,var) ,exp))) |
|---|
| 164 | |
|---|
| 165 | (define build-data |
|---|
| 166 | (lambda (exp) |
|---|
| 167 | `(quote ,exp))) |
|---|
| 168 | |
|---|
| 169 | (define build-identifier |
|---|
| 170 | (lambda (id) |
|---|
| 171 | `(quote ,id))) |
|---|
| 172 | |
|---|
| 173 | (define build-sequence |
|---|
| 174 | (lambda (exps) |
|---|
| 175 | (if (null? (cdr exps)) |
|---|
| 176 | (car exps) |
|---|
| 177 | `(begin ,(car exps) ,(build-sequence (cdr exps)))))) |
|---|
| 178 | |
|---|
| 179 | (define build-letrec |
|---|
| 180 | (let ((map map)) |
|---|
| 181 | (lambda (vars val-exps body-exp) |
|---|
| 182 | (if (null? vars) |
|---|
| 183 | body-exp |
|---|
| 184 | `(let ,(##sys#map (lambda (var) (list var '(##core#undefined))) vars) |
|---|
| 185 | (begin ,@(map (lambda (var val) `(##core#set! ,var ,val)) vars val-exps) |
|---|
| 186 | ,body-exp) ) ) ) ) ) |
|---|
| 187 | |
|---|
| 188 | (define build-global-definition |
|---|
| 189 | (lambda (var val) |
|---|
| 190 | `(##core#set! ,var ,val))) |
|---|
| 191 | |
|---|
| 192 | |
|---|
| 193 | ;;; init.ss |
|---|
| 194 | ;;; Robert Hieb & Kent Dybvig |
|---|
| 195 | ;;; 92/06/18 |
|---|
| 196 | |
|---|
| 197 | ; These initializations are done here rather than "expand.ss" so that |
|---|
| 198 | ; "expand.ss" can be loaded twice (for bootstrapping purposes). |
|---|
| 199 | |
|---|
| 200 | (define expand-syntax #f) |
|---|
| 201 | (define syntax-dispatch #f) |
|---|
| 202 | (define generate-temporaries #f) |
|---|
| 203 | (define identifier? #f) |
|---|
| 204 | (define syntax-error #f) |
|---|
| 205 | (define syntax-object->datum #f) |
|---|
| 206 | (define bound-identifier=? #f) |
|---|
| 207 | (define free-identifier=? #f) |
|---|
| 208 | (define install-global-transformer #f) |
|---|
| 209 | (define implicit-identifier #f) |
|---|
| 210 | |
|---|
| 211 | |
|---|
| 212 | (begin ((lambda () |
|---|
| 213 | (letrec ((lambda-var-list (lambda (vars) |
|---|
| 214 | ((letrec ((lvl (lambda (vars ls) |
|---|
| 215 | (if (pair? vars) |
|---|
| 216 | (lvl (cdr vars) |
|---|
| 217 | (cons (car vars) |
|---|
| 218 | ls)) |
|---|
| 219 | (if (id? vars) |
|---|
| 220 | (cons vars |
|---|
| 221 | ls) |
|---|
| 222 | (if (null? |
|---|
| 223 | vars) |
|---|
| 224 | ls |
|---|
| 225 | (if (syntax-object? |
|---|
| 226 | vars) |
|---|
| 227 | (lvl (unwrap |
|---|
| 228 | vars) |
|---|
| 229 | ls) |
|---|
| 230 | (cons vars |
|---|
| 231 | ls)))))))) |
|---|
| 232 | lvl) |
|---|
| 233 | vars |
|---|
| 234 | '()))) |
|---|
| 235 | (gen-var (lambda (id) (gen-sym (id-sym-name id)))) |
|---|
| 236 | (gen-sym (lambda (sym) |
|---|
| 237 | (new-symbol-hook sym) ) ) ; (new-symbol-hook (symbol->string sym)))) |
|---|
| 238 | (strip (lambda (x) |
|---|
| 239 | (if (syntax-object? x) |
|---|
| 240 | (strip (syntax-object-expression x)) |
|---|
| 241 | (if (pair? x) |
|---|
| 242 | ((lambda (a d) |
|---|
| 243 | (if (if (eq? a (car x)) |
|---|
| 244 | (eq? d (cdr x)) |
|---|
| 245 | #f) |
|---|
| 246 | x |
|---|
| 247 | (cons a d))) |
|---|
| 248 | (strip (car x)) |
|---|
| 249 | (strip (cdr x))) |
|---|
| 250 | (if (vector? x) |
|---|
| 251 | ((lambda (old) |
|---|
| 252 | ((lambda (new) |
|---|
| 253 | (if (andmap eq? old new) |
|---|
| 254 | x |
|---|
| 255 | (list->vector new))) |
|---|
| 256 | (map strip old))) |
|---|
| 257 | (vector->list x)) |
|---|
| 258 | x))))) |
|---|
| 259 | (regen (lambda (x) |
|---|
| 260 | ((lambda (g000139) |
|---|
| 261 | (if (memv g000139 '(ref)) |
|---|
| 262 | (build-lexical-reference (cadr x)) |
|---|
| 263 | (if (memv g000139 '(primitive)) |
|---|
| 264 | (build-global-reference (cadr x)) |
|---|
| 265 | (if (memv g000139 '(id)) |
|---|
| 266 | (build-identifier (cadr x)) |
|---|
| 267 | (if (memv g000139 '(quote)) |
|---|
| 268 | (build-data (cadr x)) |
|---|
| 269 | (if (memv |
|---|
| 270 | g000139 |
|---|
| 271 | '(lambda)) |
|---|
| 272 | (build-lambda |
|---|
| 273 | (cadr x) |
|---|
| 274 | (regen (caddr x))) |
|---|
| 275 | (begin g000139 |
|---|
| 276 | (build-application |
|---|
| 277 | (build-global-reference |
|---|
| 278 | (car x)) |
|---|
| 279 | (map regen |
|---|
| 280 | (cdr x)))))))))) |
|---|
| 281 | (car x)))) |
|---|
| 282 | (gen-vector (lambda (x) |
|---|
| 283 | (if (eq? (car x) 'list) |
|---|
| 284 | (list* 'vector (cdr x)) |
|---|
| 285 | (if (eq? (car x) 'quote) |
|---|
| 286 | (list |
|---|
| 287 | 'quote |
|---|
| 288 | (list->vector (cadr x))) |
|---|
| 289 | (list 'list->vector x))))) |
|---|
| 290 | (gen-append (lambda (x y) |
|---|
| 291 | (if (equal? y ''()) |
|---|
| 292 | x |
|---|
| 293 | (list 'append x y)))) |
|---|
| 294 | (gen-cons (lambda (x y) |
|---|
| 295 | (if (eq? (car y) 'list) |
|---|
| 296 | (list* 'list x (cdr y)) |
|---|
| 297 | (if (if (eq? (car x) 'quote) |
|---|
| 298 | (eq? (car y) 'quote) |
|---|
| 299 | #f) |
|---|
| 300 | (list |
|---|
| 301 | 'quote |
|---|
| 302 | (cons (cadr x) (cadr y))) |
|---|
| 303 | (if (equal? y ''()) |
|---|
| 304 | (list 'list x) |
|---|
| 305 | (list 'cons x y)))))) |
|---|
| 306 | (gen-map (lambda (e map-env) |
|---|
| 307 | ((lambda (formals actuals) |
|---|
| 308 | (if (eq? (car e) 'ref) |
|---|
| 309 | (car actuals) |
|---|
| 310 | (if (andmap |
|---|
| 311 | (lambda (x) |
|---|
| 312 | (if (eq? (car x) 'ref) |
|---|
| 313 | (memq (cadr x) |
|---|
| 314 | formals) |
|---|
| 315 | #f)) |
|---|
| 316 | (cdr e)) |
|---|
| 317 | (list* |
|---|
| 318 | 'map |
|---|
| 319 | (list 'primitive (car e)) |
|---|
| 320 | (map ((lambda (r) |
|---|
| 321 | (lambda (x) |
|---|
| 322 | (cdr (assq (cadr x) |
|---|
| 323 | r)))) |
|---|
| 324 | (map cons |
|---|
| 325 | formals |
|---|
| 326 | actuals)) |
|---|
| 327 | (cdr e))) |
|---|
| 328 | (list* |
|---|
| 329 | 'map |
|---|
| 330 | (list 'lambda formals e) |
|---|
| 331 | actuals)))) |
|---|
| 332 | (map cdr map-env) |
|---|
| 333 | (map (lambda (x) (list 'ref (car x))) |
|---|
| 334 | map-env)))) |
|---|
| 335 | (gen-ref (lambda (var level maps k) |
|---|
| 336 | (if (= level 0) |
|---|
| 337 | (k var maps) |
|---|
| 338 | (gen-ref |
|---|
| 339 | var |
|---|
| 340 | (- level 1) |
|---|
| 341 | (cdr maps) |
|---|
| 342 | (lambda (outer-var outer-maps) |
|---|
| 343 | ((lambda (b) |
|---|
| 344 | (if b |
|---|
| 345 | (k (cdr b) maps) |
|---|
| 346 | ((lambda (inner-var) |
|---|
| 347 | (k inner-var |
|---|
| 348 | (cons (cons (cons outer-var |
|---|
| 349 | inner-var) |
|---|
| 350 | (car maps)) |
|---|
| 351 | outer-maps))) |
|---|
| 352 | (gen-sym var)))) |
|---|
| 353 | (assq outer-var (car maps)))))))) |
|---|
| 354 | (chi-syntax (lambda (src exp r w) |
|---|
| 355 | ((letrec ((gen (lambda (e maps k) |
|---|
| 356 | (if (id? e) |
|---|
| 357 | ((lambda (n) |
|---|
| 358 | ((lambda (b) |
|---|
| 359 | (if (eq? (binding-type |
|---|
| 360 | b) |
|---|
| 361 | 'syntax) |
|---|
| 362 | ((lambda (level) |
|---|
| 363 | (if (< (length |
|---|
| 364 | maps) |
|---|
| 365 | level) |
|---|
| 366 | (syntax-error |
|---|
| 367 | src |
|---|
| 368 | "missing ellipsis in") |
|---|
| 369 | (gen-ref |
|---|
| 370 | n |
|---|
| 371 | level |
|---|
| 372 | maps |
|---|
| 373 | (lambda (x |
|---|
| 374 | maps) |
|---|
| 375 | (k (list |
|---|
| 376 | 'ref |
|---|
| 377 | x) |
|---|
| 378 | maps))))) |
|---|
| 379 | (binding-value |
|---|
| 380 | b)) |
|---|
| 381 | (if (ellipsis? |
|---|
| 382 | (wrap e |
|---|
| 383 | w)) |
|---|
| 384 | (syntax-error |
|---|
| 385 | src |
|---|
| 386 | "invalid context for ... in") |
|---|
| 387 | (k (list |
|---|
| 388 | 'id |
|---|
| 389 | (wrap e |
|---|
| 390 | w)) |
|---|
| 391 | maps)))) |
|---|
| 392 | (lookup |
|---|
| 393 | n |
|---|
| 394 | e |
|---|
| 395 | r))) |
|---|
| 396 | (id-var-name |
|---|
| 397 | e |
|---|
| 398 | w)) |
|---|
| 399 | ((lambda (g000141) |
|---|
| 400 | ((lambda (g000142) |
|---|
| 401 | ((lambda (g000140) |
|---|
| 402 | (if (not (eq? g000140 |
|---|
| 403 | 'no)) |
|---|
| 404 | ((lambda (_dots1 |
|---|
| 405 | _dots2) |
|---|
| 406 | (if (if (ellipsis? |
|---|
| 407 | (wrap _dots1 |
|---|
| 408 | w)) |
|---|
| 409 | (ellipsis? |
|---|
| 410 | (wrap _dots2 |
|---|
| 411 | w)) |
|---|
| 412 | #f) |
|---|
| 413 | (k (list |
|---|
| 414 | 'id |
|---|
| 415 | (wrap _dots1 |
|---|
| 416 | w)) |
|---|
| 417 | maps) |
|---|
| 418 | (g000142))) |
|---|
| 419 | (car g000140) |
|---|
| 420 | (cadr g000140)) |
|---|
| 421 | (g000142))) |
|---|
| 422 | (syntax-dispatch |
|---|
| 423 | g000141 |
|---|
| 424 | '(pair (any) |
|---|
| 425 | pair |
|---|
| 426 | (any) |
|---|
| 427 | atom) |
|---|
| 428 | (vector)))) |
|---|
| 429 | (lambda () |
|---|
| 430 | ((lambda (g000144) |
|---|
| 431 | ((lambda (g000145) |
|---|
| 432 | ((lambda (g000143) |
|---|
| 433 | (if (not (eq? g000143 |
|---|
| 434 | 'no)) |
|---|
| 435 | ((lambda (_x |
|---|
| 436 | _dots |
|---|
| 437 | _y) |
|---|
| 438 | (if (ellipsis? |
|---|
| 439 | (wrap _dots |
|---|
| 440 | w)) |
|---|
| 441 | (gen _y |
|---|
| 442 | maps |
|---|
| 443 | (lambda (y |
|---|
| 444 | maps) |
|---|
| 445 | (gen _x |
|---|
| 446 | (cons '() |
|---|
| 447 | maps) |
|---|
| 448 | (lambda (x |
|---|
| 449 | maps) |
|---|
| 450 | (if (null? |
|---|
| 451 | (car maps)) |
|---|
| 452 | (syntax-error |
|---|
| 453 | src |
|---|
| 454 | "extra ellipsis in") |
|---|
| 455 | (k (gen-append |
|---|
| 456 | (gen-map |
|---|
| 457 | x |
|---|
| 458 | (car maps)) |
|---|
| 459 | y) |
|---|
| 460 | (cdr maps))))))) |
|---|
| 461 | (g000145))) |
|---|
| 462 | (car g000143) |
|---|
| 463 | (cadr g000143) |
|---|
| 464 | (caddr |
|---|
| 465 | g000143)) |
|---|
| 466 | (g000145))) |
|---|
| 467 | (syntax-dispatch |
|---|
| 468 | g000144 |
|---|
| 469 | '(pair (any) |
|---|
| 470 | pair |
|---|
| 471 | (any) |
|---|
| 472 | any) |
|---|
| 473 | (vector)))) |
|---|
| 474 | (lambda () |
|---|
| 475 | ((lambda (g000147) |
|---|
| 476 | ((lambda (g000146) |
|---|
| 477 | (if (not (eq? g000146 |
|---|
| 478 | 'no)) |
|---|
| 479 | ((lambda (_x |
|---|
| 480 | _y) |
|---|
| 481 | (gen _x |
|---|
| 482 | maps |
|---|
| 483 | (lambda (x |
|---|
| 484 | maps) |
|---|
| 485 | (gen _y |
|---|
| 486 | maps |
|---|
| 487 | (lambda (y |
|---|
| 488 | maps) |
|---|
| 489 | (k (gen-cons |
|---|
| 490 | x |
|---|
| 491 | y) |
|---|
| 492 | maps)))))) |
|---|
| 493 | (car g000146) |
|---|
| 494 | (cadr g000146)) |
|---|
| 495 | ((lambda (g000149) |
|---|
| 496 | ((lambda (g000148) |
|---|
| 497 | (if (not (eq? g000148 |
|---|
| 498 | 'no)) |
|---|
| 499 | ((lambda (_e1 |
|---|
| 500 | _e2) |
|---|
| 501 | (gen (cons _e1 |
|---|
| 502 | _e2) |
|---|
| 503 | maps |
|---|
| 504 | (lambda (e |
|---|
| 505 | maps) |
|---|
| 506 | (k (gen-vector |
|---|
| 507 | e) |
|---|
| 508 | maps)))) |
|---|
| 509 | (car g000148) |
|---|
| 510 | (cadr g000148)) |
|---|
| 511 | ((lambda (g000151) |
|---|
| 512 | ((lambda (g000150) |
|---|
| 513 | (if (not (eq? g000150 |
|---|
| 514 | 'no)) |
|---|
| 515 | ((lambda (__) |
|---|
| 516 | (k (list |
|---|
| 517 | 'quote |
|---|
| 518 | (wrap e |
|---|
| 519 | w)) |
|---|
| 520 | maps)) |
|---|
| 521 | (car g000150)) |
|---|
| 522 | (syntax-error |
|---|
| 523 | g000151))) |
|---|
| 524 | (syntax-dispatch |
|---|
| 525 | g000151 |
|---|
| 526 | '(any) |
|---|
| 527 | (vector)))) |
|---|
| 528 | g000149))) |
|---|
| 529 | (syntax-dispatch |
|---|
| 530 | g000149 |
|---|
| 531 | '(vector |
|---|
| 532 | pair |
|---|
| 533 | (any) |
|---|
| 534 | each |
|---|
| 535 | any) |
|---|
| 536 | (vector)))) |
|---|
| 537 | g000147))) |
|---|
| 538 | (syntax-dispatch |
|---|
| 539 | g000147 |
|---|
| 540 | '(pair (any) |
|---|
| 541 | any) |
|---|
| 542 | (vector)))) |
|---|
| 543 | g000144)))) |
|---|
| 544 | g000141)))) |
|---|
| 545 | e))))) |
|---|
| 546 | gen) |
|---|
| 547 | exp |
|---|
| 548 | '() |
|---|
| 549 | (lambda (e maps) (regen e))))) |
|---|
| 550 | (ellipsis? (lambda (x) |
|---|
| 551 | (if (identifier? x) |
|---|
| 552 | (free-id=? x '...) |
|---|
| 553 | #f))) |
|---|
| 554 | (chi-syntax-definition (lambda (e w) |
|---|
| 555 | ((lambda (g000153) |
|---|
| 556 | ((lambda (g000154) |
|---|
| 557 | ((lambda (g000152) |
|---|
| 558 | (if (not (eq? g000152 |
|---|
| 559 | 'no)) |
|---|
| 560 | ((lambda (__ |
|---|
| 561 | _name |
|---|
| 562 | _val) |
|---|
| 563 | (if (id? _name) |
|---|
| 564 | (list _name |
|---|
| 565 | _val) |
|---|
| 566 | (g000154))) |
|---|
| 567 | (car g000152) |
|---|
| 568 | (cadr g000152) |
|---|
| 569 | (caddr |
|---|
| 570 | g000152)) |
|---|
| 571 | (g000154))) |
|---|
| 572 | (syntax-dispatch |
|---|
| 573 | g000153 |
|---|
| 574 | '(pair (any) |
|---|
| 575 | pair |
|---|
| 576 | (any) |
|---|
| 577 | pair |
|---|
| 578 | (any) |
|---|
| 579 | atom) |
|---|
| 580 | (vector)))) |
|---|
| 581 | (lambda () |
|---|
| 582 | (syntax-error |
|---|
| 583 | g000153)))) |
|---|
| 584 | (wrap e w)))) |
|---|
| 585 | (chi-definition (lambda (e w) |
|---|
| 586 | ((lambda (g000156) |
|---|
| 587 | ((lambda (g000157) |
|---|
| 588 | ((lambda (g000155) |
|---|
| 589 | (if (not (eq? g000155 |
|---|
| 590 | 'no)) |
|---|
| 591 | (apply |
|---|
| 592 | (lambda (__ |
|---|
| 593 | _name |
|---|
| 594 | _args |
|---|
| 595 | _e1 |
|---|
| 596 | _e2) |
|---|
| 597 | (if (if (id? _name) |
|---|
| 598 | (valid-bound-ids? |
|---|
| 599 | (lambda-var-list |
|---|
| 600 | _args)) |
|---|
| 601 | #f) |
|---|
| 602 | (list _name |
|---|
| 603 | (cons '#(syntax-object |
|---|
| 604 | lambda |
|---|
| 605 | (top)) |
|---|
| 606 | (cons _args |
|---|
| 607 | (cons _e1 |
|---|
| 608 | _e2)))) |
|---|
| 609 | (g000157))) |
|---|
| 610 | g000155) |
|---|
| 611 | (g000157))) |
|---|
| 612 | (syntax-dispatch |
|---|
| 613 | g000156 |
|---|
| 614 | '(pair (any) |
|---|
| 615 | pair |
|---|
| 616 | (pair (any) any) |
|---|
| 617 | pair |
|---|
| 618 | (any) |
|---|
| 619 | each |
|---|
| 620 | any) |
|---|
| 621 | (vector)))) |
|---|
| 622 | (lambda () |
|---|
| 623 | ((lambda (g000159) |
|---|
| 624 | ((lambda (g000158) |
|---|
| 625 | (if (not (eq? g000158 |
|---|
| 626 | 'no)) |
|---|
| 627 | ((lambda (__ |
|---|
| 628 | _name |
|---|
| 629 | _val) |
|---|
| 630 | (list _name |
|---|
| 631 | _val)) |
|---|
| 632 | (car g000158) |
|---|
| 633 | (cadr g000158) |
|---|
| 634 | (caddr |
|---|
| 635 | g000158)) |
|---|
| 636 | ((lambda (g000161) |
|---|
| 637 | ((lambda (g000162) |
|---|
| 638 | ((lambda (g000160) |
|---|
| 639 | (if (not (eq? g000160 |
|---|
| 640 | 'no)) |
|---|
| 641 | ((lambda (__ |
|---|
| 642 | _name) |
|---|
| 643 | (if (id? _name) |
|---|
| 644 | (list _name |
|---|
| 645 | (list '#(syntax-object |
|---|
| 646 | ##core#undefined |
|---|
| 647 | (top)))) |
|---|
| 648 | (g000162))) |
|---|
| 649 | (car g000160) |
|---|
| 650 | (cadr g000160)) |
|---|
| 651 | (g000162))) |
|---|
| 652 | (syntax-dispatch |
|---|
| 653 | g000161 |
|---|
| 654 | '(pair (any) |
|---|
| 655 | pair |
|---|
| 656 | (any) |
|---|
| 657 | atom) |
|---|
| 658 | (vector)))) |
|---|
| 659 | (lambda () |
|---|
| 660 | (syntax-error |
|---|
| 661 | g000161)))) |
|---|
| 662 | g000159))) |
|---|
| 663 | (syntax-dispatch |
|---|
| 664 | g000159 |
|---|
| 665 | '(pair (any) |
|---|
| 666 | pair |
|---|
| 667 | (any) |
|---|
| 668 | pair |
|---|
| 669 | (any) |
|---|
| 670 | atom) |
|---|
| 671 | (vector)))) |
|---|
| 672 | g000156)))) |
|---|
| 673 | (wrap e w)))) |
|---|
| 674 | (chi-sequence (lambda (e w) |
|---|
| 675 | ((lambda (g000164) |
|---|
| 676 | ((lambda (g000163) |
|---|
| 677 | (if (not (eq? g000163 'no)) |
|---|
| 678 | ((lambda (__ _e) _e) |
|---|
| 679 | (car g000163) |
|---|
| 680 | (cadr g000163)) |
|---|
| 681 | (syntax-error g000164))) |
|---|
| 682 | (syntax-dispatch |
|---|
| 683 | g000164 |
|---|
| 684 | '(pair (any) each any) |
|---|
| 685 | (vector)))) |
|---|
| 686 | (wrap e w)))) |
|---|
| 687 | (chi-macro-def (lambda (def r w) |
|---|
| 688 | (eval-hook (chi def null-env w)))) |
|---|
| 689 | (chi-local-syntax (lambda (e r w) |
|---|
| 690 | ((lambda (g000166) |
|---|
| 691 | ((lambda (g000167) |
|---|
| 692 | ((lambda (g000165) |
|---|
| 693 | (if (not (eq? g000165 |
|---|
| 694 | 'no)) |
|---|
| 695 | (apply |
|---|
| 696 | (lambda (_who |
|---|
| 697 | _var |
|---|
| 698 | _val |
|---|
| 699 | _e1 |
|---|
| 700 | _e2) |
|---|
| 701 | (if (valid-bound-ids? |
|---|
| 702 | _var) |
|---|
| 703 | ((lambda (new-vars) |
|---|
| 704 | ((lambda (new-w) |
|---|
| 705 | (chi-body |
|---|
| 706 | (cons _e1 |
|---|
| 707 | _e2) |
|---|
| 708 | e |
|---|
| 709 | (extend-macro-env |
|---|
| 710 | new-vars |
|---|
| 711 | ((lambda (w) |
|---|
| 712 | (map (lambda (x) |
|---|
| 713 | (chi-macro-def |
|---|
| 714 | x |
|---|
| 715 | r |
|---|
| 716 | w)) |
|---|
| 717 | _val)) |
|---|
| 718 | (if (free-id=? |
|---|
| 719 | _who |
|---|
| 720 | '#(syntax-object |
|---|
| 721 | letrec-syntax |
|---|
| 722 | (top))) |
|---|
| 723 | new-w |
|---|
| 724 | w)) |
|---|
| 725 | r) |
|---|
| 726 | new-w)) |
|---|
| 727 | (make-binding-wrap |
|---|
| 728 | _var |
|---|
| 729 | new-vars |
|---|
| 730 | w))) |
|---|
| 731 | (map gen-var |
|---|
| 732 | _var)) |
|---|
| 733 | (g000167))) |
|---|
| 734 | g000165) |
|---|
| 735 | (g000167))) |
|---|
| 736 | (syntax-dispatch |
|---|
| 737 | g000166 |
|---|
| 738 | '(pair (any) |
|---|
| 739 | pair |
|---|
| 740 | (each pair |
|---|
| 741 | (any) |
|---|
| 742 | pair |
|---|
| 743 | (any) |
|---|
| 744 | atom) |
|---|
| 745 | pair |
|---|
| 746 | (any) |
|---|
| 747 | each |
|---|
| 748 | any) |
|---|
| 749 | (vector)))) |
|---|
| 750 | (lambda () |
|---|
| 751 | ((lambda (g000169) |
|---|
| 752 | ((lambda (g000168) |
|---|
| 753 | (if (not (eq? g000168 |
|---|
| 754 | 'no)) |
|---|
| 755 | ((lambda (__) |
|---|
| 756 | (syntax-error |
|---|
| 757 | (wrap e |
|---|
| 758 | w))) |
|---|
| 759 | (car g000168)) |
|---|
| 760 | (syntax-error |
|---|
| 761 | g000169))) |
|---|
| 762 | (syntax-dispatch |
|---|
| 763 | g000169 |
|---|
| 764 | '(any) |
|---|
| 765 | (vector)))) |
|---|
| 766 | g000166)))) |
|---|
| 767 | e))) |
|---|
| 768 | (chi-body (lambda (body source r w) |
|---|
| 769 | (if (null? (cdr body)) |
|---|
| 770 | (chi (car body) r w) |
|---|
| 771 | ((letrec ((parse1 (lambda (body |
|---|
| 772 | var-ids |
|---|
| 773 | var-vals |
|---|
| 774 | macro-ids |
|---|
| 775 | macro-vals) |
|---|
| 776 | (if (null? body) |
|---|
| 777 | (syntax-error |
|---|
| 778 | (wrap source |
|---|
| 779 | w) |
|---|
| 780 | "no expressions in body") |
|---|
| 781 | ((letrec ((parse2 (lambda (e) |
|---|
| 782 | ((lambda (b) |
|---|
| 783 | ((lambda (g000170) |
|---|
| 784 | (if (memv |
|---|
| 785 | g000170 |
|---|
| 786 | '(macro)) |
|---|
| 787 | (parse2 |
|---|
| 788 | (chi-macro |
|---|
| 789 | (binding-value |
|---|
| 790 | b) |
|---|
| 791 | e |
|---|
| 792 | r |
|---|
| 793 | empty-wrap |
|---|
| 794 | (lambda (e |
|---|
| 795 | r |
|---|
| 796 | w) |
|---|
| 797 | (wrap e |
|---|
| 798 | w)))) |
|---|
| 799 | (if (memv |
|---|
| 800 | g000170 |
|---|
| 801 | '(definition)) |
|---|
| 802 | (parse1 |
|---|
| 803 | (cdr body) |
|---|
| 804 | (cons (cadr b) |
|---|
| 805 | var-ids) |
|---|
| 806 | (cons (caddr |
|---|
| 807 | b) |
|---|
| 808 | var-vals) |
|---|
| 809 | macro-ids |
|---|
| 810 | macro-vals) |
|---|
| 811 | (if (memv |
|---|
| 812 | g000170 |
|---|
| 813 | '(syntax-definition)) |
|---|
| 814 | (parse1 |
|---|
| 815 | (cdr body) |
|---|
| 816 | var-ids |
|---|
| 817 | var-vals |
|---|
| 818 | (cons (cadr b) |
|---|
| 819 | macro-ids) |
|---|
| 820 | (cons (caddr |
|---|
| 821 | b) |
|---|
| 822 | macro-vals)) |
|---|
| 823 | (if (memv |
|---|
| 824 | g000170 |
|---|
| 825 | '(sequence)) |
|---|
| 826 | (parse1 |
|---|
| 827 | (append |
|---|
| 828 | (cdr b) |
|---|
| 829 | (cdr body)) |
|---|
| 830 | var-ids |
|---|
| 831 | var-vals |
|---|
| 832 | macro-ids |
|---|
| 833 | macro-vals) |
|---|
| 834 | (begin g000170 |
|---|
| 835 | (if (valid-bound-ids? |
|---|
| 836 | (append |
|---|
| 837 | var-ids |
|---|
| 838 | macro-ids)) |
|---|
| 839 | ((lambda (new-var-names |
|---|
| 840 | new-macro-names) |
|---|
| 841 | ((lambda (w) |
|---|
| 842 | ((lambda (r) |
|---|
| 843 | (build-letrec |
|---|
| 844 | new-var-names |
|---|
| 845 | (map (lambda (x) |
|---|
| 846 | (chi x |
|---|
| 847 | r |
|---|
| 848 | w)) |
|---|
| 849 | var-vals) |
|---|
| 850 | (build-sequence |
|---|
| 851 | (map (lambda (x) |
|---|
| 852 | (chi x |
|---|
| 853 | r |
|---|
| 854 | w)) |
|---|
| 855 | body)))) |
|---|
| 856 | (extend-macro-env |
|---|
| 857 | new-macro-names |
|---|
| 858 | (map (lambda (x) |
|---|
| 859 | (chi-macro-def |
|---|
| 860 | x |
|---|
| 861 | r |
|---|
| 862 | w)) |
|---|
| 863 | macro-vals) |
|---|
| 864 | (extend-var-env |
|---|
| 865 | new-var-names |
|---|
| 866 | r)))) |
|---|
| 867 | (make-binding-wrap |
|---|
| 868 | (append |
|---|
| 869 | macro-ids |
|---|
| 870 | var-ids) |
|---|
| 871 | (append |
|---|
| 872 | new-macro-names |
|---|
| 873 | new-var-names) |
|---|
| 874 | empty-wrap))) |
|---|
| 875 | (map gen-var |
|---|
| 876 | var-ids) |
|---|
| 877 | (map gen-var |
|---|
| 878 | macro-ids)) |
|---|
| 879 | (syntax-error |
|---|
| 880 | (wrap source |
|---|
| 881 | w) |
|---|
| 882 | "invalid identifier")))))))) |
|---|
| 883 | (car b))) |
|---|
| 884 | (syntax-type |
|---|
| 885 | e |
|---|
| 886 | r |
|---|
| 887 | empty-wrap))))) |
|---|
| 888 | parse2) |
|---|
| 889 | (car body)))))) |
|---|
| 890 | parse1) |
|---|
| 891 | (map (lambda (x) (wrap x w)) body) |
|---|
| 892 | '() |
|---|
| 893 | '() |
|---|
| 894 | '() |
|---|
| 895 | '())))) |
|---|
| 896 | (syntax-type (lambda (e r w) |
|---|
| 897 | (if (syntax-object? e) |
|---|
| 898 | (syntax-type |
|---|
| 899 | (syntax-object-expression e) |
|---|
| 900 | r |
|---|
| 901 | (join-wraps |
|---|
| 902 | (syntax-object-wrap e) |
|---|
| 903 | w)) |
|---|
| 904 | (if (if (pair? e) |
|---|
| 905 | (identifier? (car e)) |
|---|
| 906 | #f) |
|---|
| 907 | ((lambda (n) |
|---|
| 908 | ((lambda (b) |
|---|
| 909 | ((lambda (g000171) |
|---|
| 910 | (if (memv |
|---|
| 911 | g000171 |
|---|
| 912 | '(special)) |
|---|
| 913 | (if (memv |
|---|
| 914 | n |
|---|
| 915 | '(define)) |
|---|
| 916 | (cons 'definition |
|---|
| 917 | (chi-definition |
|---|
| 918 | e |
|---|
| 919 | w)) |
|---|
| 920 | (if (memv |
|---|
| 921 | n |
|---|
| 922 | '(define-syntax)) |
|---|
| 923 | (cons 'syntax-definition |
|---|
| 924 | (chi-syntax-definition |
|---|
| 925 | e |
|---|
| 926 | w)) |
|---|
| 927 | (if (memv |
|---|
| 928 | n |
|---|
| 929 | '(begin)) |
|---|
| 930 | (cons 'sequence |
|---|
| 931 | (chi-sequence |
|---|
| 932 | e |
|---|
| 933 | w)) |
|---|
| 934 | (begin n |
|---|
| 935 | (##core#undefined))))) |
|---|
| 936 | (begin g000171 |
|---|
| 937 | b))) |
|---|
| 938 | (binding-type b))) |
|---|
| 939 | (lookup n (car e) r))) |
|---|
| 940 | (id-var-name (car e) w)) |
|---|
| 941 | '(other))))) |
|---|
| 942 | (chi-args (lambda (args r w source source-w) |
|---|
| 943 | (if (pair? args) |
|---|
| 944 | (cons (chi (car args) r w) |
|---|
| 945 | (chi-args |
|---|
| 946 | (cdr args) |
|---|
| 947 | r |
|---|
| 948 | w |
|---|
| 949 | source |
|---|
| 950 | source-w)) |
|---|
| 951 | (if (null? args) |
|---|
| 952 | '() |
|---|
| 953 | (if (syntax-object? args) |
|---|
| 954 | (chi-args |
|---|
| 955 | (syntax-object-expression |
|---|
| 956 | args) |
|---|
| 957 | r |
|---|
| 958 | (join-wraps |
|---|
| 959 | w |
|---|
| 960 | (syntax-object-wrap |
|---|
| 961 | args)) |
|---|
| 962 | source |
|---|
| 963 | source-w) |
|---|
| 964 | (syntax-error |
|---|
| 965 | (wrap source source-w))))))) |
|---|
| 966 | (chi-ref (lambda (e name binding w) |
|---|
| 967 | ((lambda (g000172) |
|---|
| 968 | (if (memv g000172 '(lexical)) |
|---|
| 969 | (build-lexical-reference name) |
|---|
| 970 | (if (memv |
|---|
| 971 | g000172 |
|---|
| 972 | '(global global-unbound)) |
|---|
| 973 | (build-global-reference name) |
|---|
| 974 | (begin g000172 |
|---|
| 975 | (id-error |
|---|
| 976 | (wrap e w)))))) |
|---|
| 977 | (binding-type binding)))) |
|---|
| 978 | (chi-macro (letrec ((check-macro-output (lambda (x) |
|---|
| 979 | (if (pair? |
|---|
| 980 | x) |
|---|
| 981 | (begin (check-macro-output |
|---|
| 982 | (car x)) |
|---|
| 983 | (check-macro-output |
|---|
| 984 | (cdr x))) |
|---|
| 985 | ((lambda (g000173) |
|---|
| 986 | (if g000173 |
|---|
| 987 | g000173 |
|---|
| 988 | (if (vector? |
|---|
| 989 | x) |
|---|
| 990 | ((lambda (n) |
|---|
| 991 | ((letrec ((g000174 (lambda (i) |
|---|
| 992 | (if (= i |
|---|
| 993 | n) |
|---|
| 994 | (##core#undefined) |
|---|
| 995 | (begin (check-macro-output |
|---|
| 996 | (vector-ref |
|---|
| 997 | x |
|---|
| 998 | i)) |
|---|
| 999 | (g000174 |
|---|
| 1000 | (+ i |
|---|
| 1001 | 1))))))) |
|---|
| 1002 | g000174) |
|---|
| 1003 | 0)) |
|---|
| 1004 | (vector-length |
|---|
| 1005 | x)) |
|---|
| 1006 | (if (symbol? |
|---|
| 1007 | x) |
|---|
| 1008 | (syntax-error |
|---|
| 1009 | x |
|---|
| 1010 | "encountered raw symbol") |
|---|
| 1011 | (##core#undefined))))) |
|---|
| 1012 | (syntax-object? |
|---|
| 1013 | x)))))) |
|---|
| 1014 | (lambda (p e r w k) |
|---|
| 1015 | ((lambda (mw) |
|---|
| 1016 | ((lambda (x) |
|---|
| 1017 | (check-macro-output x) |
|---|
| 1018 | (k x r mw)) |
|---|
| 1019 | (p (wrap e (join-wraps mw w))))) |
|---|
| 1020 | (new-mark-wrap))))) |
|---|
| 1021 | (chi-pair (lambda (e r w k) |
|---|
| 1022 | ((lambda (first rest) |
|---|
| 1023 | (if (id? first) |
|---|
| 1024 | ((lambda (n) |
|---|
| 1025 | ((lambda (b) |
|---|
| 1026 | ((lambda (g000175) |
|---|
| 1027 | (if (memv |
|---|
| 1028 | g000175 |
|---|
| 1029 | '(core)) |
|---|
| 1030 | ((binding-value b) |
|---|
| 1031 | e |
|---|
| 1032 | r |
|---|
| 1033 | w) |
|---|
| 1034 | (if (memv |
|---|
| 1035 | g000175 |
|---|
| 1036 | '(macro)) |
|---|
| 1037 | (chi-macro |
|---|
| 1038 | (binding-value |
|---|
| 1039 | b) |
|---|
| 1040 | e |
|---|
| 1041 | r |
|---|
| 1042 | w |
|---|
| 1043 | k) |
|---|
| 1044 | (if (memv |
|---|
| 1045 | g000175 |
|---|
| 1046 | '(special)) |
|---|
| 1047 | ((binding-value |
|---|
| 1048 | b) |
|---|
| 1049 | e |
|---|
| 1050 | r |
|---|
| 1051 | w |
|---|
| 1052 | k) |
|---|
| 1053 | (begin g000175 |
|---|
| 1054 | (build-application |
|---|
| 1055 | (chi-ref |
|---|
| 1056 | first |
|---|
| 1057 | n |
|---|
| 1058 | b |
|---|
| 1059 | w) |
|---|
| 1060 | (chi-args |
|---|
| 1061 | rest |
|---|
| 1062 | r |
|---|
| 1063 | w |
|---|
| 1064 | e |
|---|
| 1065 | w))))))) |
|---|
| 1066 | (binding-type b))) |
|---|
| 1067 | (lookup n first r))) |
|---|
| 1068 | (id-var-name first w)) |
|---|
| 1069 | (build-application |
|---|
| 1070 | (chi first r w) |
|---|
| 1071 | (chi-args rest r w e w)))) |
|---|
| 1072 | (car e) |
|---|
| 1073 | (cdr e)))) |
|---|
| 1074 | (chi (lambda (e r w) |
|---|
| 1075 | (if (symbol? e) |
|---|
| 1076 | ((lambda (n) |
|---|
| 1077 | (chi-ref e n (lookup n e r) w)) |
|---|
| 1078 | (id-var-name e w)) |
|---|
| 1079 | (if (pair? e) |
|---|
| 1080 | (chi-pair e r w chi) |
|---|
| 1081 | (if (syntax-object? e) |
|---|
| 1082 | (chi (syntax-object-expression e) |
|---|
| 1083 | r |
|---|
| 1084 | (join-wraps |
|---|
| 1085 | w |
|---|
| 1086 | (syntax-object-wrap e))) |
|---|
| 1087 | (if ((lambda (g000176) |
|---|
| 1088 | (if g000176 |
|---|
| 1089 | g000176 |
|---|
| 1090 | ((lambda (g000177) |
|---|
| 1091 | (if g000177 |
|---|
| 1092 | g000177 |
|---|
| 1093 | ((lambda (g000178) |
|---|
| 1094 | (if g000178 |
|---|
| 1095 | g000178 |
|---|
| 1096 | (char? |
|---|
| 1097 | e))) |
|---|
| 1098 | (string? e)))) |
|---|
| 1099 | (number? e)))) |
|---|
| 1100 | (boolean? e)) |
|---|
| 1101 | (build-data e) |
|---|
| 1102 | (syntax-error (wrap e w)))))))) |
|---|
| 1103 | (chi-top (lambda (e r w) |
|---|
| 1104 | (if (pair? e) |
|---|
| 1105 | (chi-pair e r w chi-top) |
|---|
| 1106 | (if (syntax-object? e) |
|---|
| 1107 | (chi-top |
|---|
| 1108 | (syntax-object-expression e) |
|---|
| 1109 | r |
|---|
| 1110 | (join-wraps |
|---|
| 1111 | w |
|---|
| 1112 | (syntax-object-wrap e))) |
|---|
| 1113 | (chi e r w))))) |
|---|
| 1114 | (wrap (lambda (x w) |
|---|
| 1115 | (if (null? w) |
|---|
| 1116 | x |
|---|
| 1117 | (if (syntax-object? x) |
|---|
| 1118 | (make-syntax-object |
|---|
| 1119 | (syntax-object-expression x) |
|---|
| 1120 | (join-wraps |
|---|
| 1121 | w |
|---|
| 1122 | (syntax-object-wrap x))) |
|---|
| 1123 | (if (null? x) |
|---|
| 1124 | x |
|---|
| 1125 | (make-syntax-object x w)))))) |
|---|
| 1126 | (unwrap (lambda (x) |
|---|
| 1127 | (if (syntax-object? x) |
|---|
| 1128 | ((lambda (e w) |
|---|
| 1129 | (if (pair? e) |
|---|
| 1130 | (cons (wrap (car e) w) |
|---|
| 1131 | (wrap (cdr e) w)) |
|---|
| 1132 | (if (vector? e) |
|---|
| 1133 | (list->vector |
|---|
| 1134 | (map (lambda (x) |
|---|
| 1135 | (wrap x w)) |
|---|
| 1136 | (vector->list e))) |
|---|
| 1137 | e))) |
|---|
| 1138 | (syntax-object-expression x) |
|---|
| 1139 | (syntax-object-wrap x)) |
|---|
| 1140 | x))) |
|---|
| 1141 | (bound-id-member? (lambda (x list) |
|---|
| 1142 | (if (not (null? list)) |
|---|
| 1143 | ((lambda (g000179) |
|---|
| 1144 | (if g000179 |
|---|
| 1145 | g000179 |
|---|
| 1146 | (bound-id-member? |
|---|
| 1147 | x |
|---|
| 1148 | (cdr list)))) |
|---|
| 1149 | (bound-id=? x (car list))) |
|---|
| 1150 | #f))) |
|---|
| 1151 | (valid-bound-ids? (lambda (ids) |
|---|
| 1152 | (if ((letrec ((all-ids? (lambda (ids) |
|---|
| 1153 | ((lambda (g000181) |
|---|
| 1154 | (if g000181 |
|---|
| 1155 | g000181 |
|---|
| 1156 | (if (id? (car ids)) |
|---|
| 1157 | (all-ids? |
|---|
| 1158 | (cdr ids)) |
|---|
| 1159 | #f))) |
|---|
| 1160 | (null? |
|---|
| 1161 | ids))))) |
|---|
| 1162 | all-ids?) |
|---|
| 1163 | ids) |
|---|
| 1164 | ((letrec ((unique? (lambda (ids) |
|---|
| 1165 | ((lambda (g000180) |
|---|
| 1166 | (if g000180 |
|---|
| 1167 | g000180 |
|---|
| 1168 | (if (not (bound-id-member? |
|---|
| 1169 | (car ids) |
|---|
| 1170 | (cdr ids))) |
|---|
| 1171 | (unique? |
|---|
| 1172 | (cdr ids)) |
|---|
| 1173 | #f))) |
|---|
| 1174 | (null? |
|---|
| 1175 | ids))))) |
|---|
| 1176 | unique?) |
|---|
| 1177 | ids) |
|---|
| 1178 | #f))) |
|---|
| 1179 | (bound-id=? (lambda (i j) |
|---|
| 1180 | (if (eq? (id-sym-name i) |
|---|
| 1181 | (id-sym-name j)) |
|---|
| 1182 | ((lambda (i j) |
|---|
| 1183 | (if (eq? (car i) (car j)) |
|---|
| 1184 | (same-marks? |
|---|
| 1185 | (cdr i) |
|---|
| 1186 | (cdr j)) |
|---|
| 1187 | #f)) |
|---|
| 1188 | (id-var-name&marks i empty-wrap) |
|---|
| 1189 | (id-var-name&marks j empty-wrap)) |
|---|
| 1190 | #f))) |
|---|
| 1191 | (free-id=? (lambda (i j) |
|---|
| 1192 | (if (eq? (id-sym-name i) (id-sym-name j)) |
|---|
| 1193 | (eq? (id-var-name i empty-wrap) |
|---|
| 1194 | (id-var-name j empty-wrap)) |
|---|
| 1195 | #f))) |
|---|
| 1196 | (id-var-name&marks (lambda (id w) |
|---|
| 1197 | (if (null? w) |
|---|
| 1198 | (if (symbol? id) |
|---|
| 1199 | (list id) |
|---|
| 1200 | (id-var-name&marks |
|---|
| 1201 | (syntax-object-expression |
|---|
| 1202 | id) |
|---|
| 1203 | (syntax-object-wrap |
|---|
| 1204 | id))) |
|---|
| 1205 | ((lambda (n&m first) |
|---|
| 1206 | (if (pair? first) |
|---|
| 1207 | ((lambda (n) |
|---|
| 1208 | ((letrec ((search (lambda (rib) |
|---|
| 1209 | (if (null? |
|---|
| 1210 | rib) |
|---|
| 1211 | n&m |
|---|
| 1212 | (if (if (eq? (caar rib) |
|---|
| 1213 | n) |
|---|
| 1214 | (same-marks? |
|---|
| 1215 | (cdr n&m) |
|---|
| 1216 | (cddar |
|---|
| 1217 | rib)) |
|---|
| 1218 | #f) |
|---|
| 1219 | (cdar rib) |
|---|
| 1220 | (search |
|---|
| 1221 | (cdr rib))))))) |
|---|
| 1222 | search) |
|---|
| 1223 | first)) |
|---|
| 1224 | (car n&m)) |
|---|
| 1225 | (cons (car n&m) |
|---|
| 1226 | (if ((lambda (g000182) |
|---|
| 1227 | (if g000182 |
|---|
| 1228 | g000182 |
|---|
| 1229 | (not (eqv? first |
|---|
| 1230 | (cadr n&m))))) |
|---|
| 1231 | (null? |
|---|
| 1232 | (cdr n&m))) |
|---|
| 1233 | (cons first |
|---|
| 1234 | (cdr n&m)) |
|---|
| 1235 | (cddr n&m))))) |
|---|
| 1236 | (id-var-name&marks |
|---|
| 1237 | id |
|---|
| 1238 | (cdr w)) |
|---|
| 1239 | (car w))))) |
|---|
| 1240 | (id-var-name (lambda (id w) |
|---|
| 1241 | (if (null? w) |
|---|
| 1242 | (if (symbol? id) |
|---|
| 1243 | id |
|---|
| 1244 | (id-var-name |
|---|
| 1245 | (syntax-object-expression |
|---|
| 1246 | id) |
|---|
| 1247 | (syntax-object-wrap id))) |
|---|
| 1248 | (if (pair? (car w)) |
|---|
| 1249 | (car (id-var-name&marks id w)) |
|---|
| 1250 | (id-var-name id (cdr w)))))) |
|---|
| 1251 | (same-marks? (lambda (x y) |
|---|
| 1252 | (if (null? x) |
|---|
| 1253 | (null? y) |
|---|
| 1254 | (if (not (null? y)) |
|---|
| 1255 | (if (eqv? (car x) (car y)) |
|---|
| 1256 | (same-marks? |
|---|
| 1257 | (cdr x) |
|---|
| 1258 | (cdr y)) |
|---|
| 1259 | #f) |
|---|
| 1260 | #f)))) |
|---|
| 1261 | (join-wraps2 (lambda (w1 w2) |
|---|
| 1262 | ((lambda (x w1) |
|---|
| 1263 | (if (null? w1) |
|---|
| 1264 | (if (if (not (pair? x)) |
|---|
| 1265 | (eqv? x (car w2)) |
|---|
| 1266 | #f) |
|---|
| 1267 | (cdr w2) |
|---|
| 1268 | (cons x w2)) |
|---|
| 1269 | (cons x (join-wraps2 w1 w2)))) |
|---|
| 1270 | (car w1) |
|---|
| 1271 | (cdr w1)))) |
|---|
| 1272 | (join-wraps1 (lambda (w1 w2) |
|---|
| 1273 | (if (null? w1) |
|---|
| 1274 | w2 |
|---|
| 1275 | (cons (car w1) |
|---|
| 1276 | (join-wraps1 (cdr w1) w2))))) |
|---|
| 1277 | (join-wraps (lambda (w1 w2) |
|---|
| 1278 | (if (null? w2) |
|---|
| 1279 | w1 |
|---|
| 1280 | (if (null? w1) |
|---|
| 1281 | w2 |
|---|
| 1282 | (if (pair? (car w2)) |
|---|
| 1283 | (join-wraps1 w1 w2) |
|---|
| 1284 | (join-wraps2 w1 w2)))))) |
|---|
| 1285 | (make-wrap-rib (lambda (ids new-names w) |
|---|
| 1286 | (if (null? ids) |
|---|
| 1287 | '() |
|---|
| 1288 | (cons ((lambda (n&m) |
|---|
| 1289 | (cons (car n&m) |
|---|
| 1290 | (cons (car new-names) |
|---|
| 1291 | (cdr n&m)))) |
|---|
| 1292 | (id-var-name&marks |
|---|
| 1293 | (car ids) |
|---|
| 1294 | w)) |
|---|
| 1295 | (make-wrap-rib |
|---|
| 1296 | (cdr ids) |
|---|
| 1297 | (cdr new-names) |
|---|
| 1298 | w))))) |
|---|
| 1299 | (make-binding-wrap (lambda (ids new-names w) |
|---|
| 1300 | (if (null? ids) |
|---|
| 1301 | w |
|---|
| 1302 | (cons (make-wrap-rib |
|---|
| 1303 | ids |
|---|
| 1304 | new-names |
|---|
| 1305 | w) |
|---|
| 1306 | w)))) |
|---|
| 1307 | (new-mark-wrap (lambda () |
|---|
| 1308 | (set! current-mark |
|---|
| 1309 | (+ current-mark 1)) |
|---|
| 1310 | (list current-mark))) |
|---|
| 1311 | (current-mark 0) |
|---|
| 1312 | (top-wrap '(top)) |
|---|
| 1313 | (empty-wrap '()) |
|---|
| 1314 | (id-sym-name (lambda (x) |
|---|
| 1315 | (if (symbol? x) |
|---|
| 1316 | x |
|---|
| 1317 | (syntax-object-expression x)))) |
|---|
| 1318 | (id? (lambda (x) |
|---|
| 1319 | ((lambda (g000183) |
|---|
| 1320 | (if g000183 |
|---|
| 1321 | g000183 |
|---|
| 1322 | (if (syntax-object? x) |
|---|
| 1323 | (symbol? |
|---|
| 1324 | (syntax-object-expression x)) |
|---|
| 1325 | #f))) |
|---|
| 1326 | (symbol? x)))) |
|---|
| 1327 | (global-extend (lambda (type sym val) |
|---|
| 1328 | (extend-global-env |
|---|
| 1329 | sym |
|---|
| 1330 | (cons type val)))) |
|---|
| 1331 | (lookup (lambda (name id r) |
|---|
| 1332 | (if (eq? name (id-sym-name id)) |
|---|
| 1333 | (global-lookup name) |
|---|
| 1334 | ((letrec ((search (lambda (r name) |
|---|
| 1335 | (if (null? r) |
|---|
| 1336 | '(displaced-lexical) |
|---|
| 1337 | (if (pair? |
|---|
| 1338 | (car r)) |
|---|
| 1339 | (if (eq? (caar r) |
|---|
| 1340 | name) |
|---|
| 1341 | (cdar r) |
|---|
| 1342 | (search |
|---|
| 1343 | (cdr r) |
|---|
| 1344 | name)) |
|---|
| 1345 | (if (eq? (car r) |
|---|
| 1346 | name) |
|---|
| 1347 | '(lexical) |
|---|
| 1348 | (search |
|---|
| 1349 | (cdr r) |
|---|
| 1350 | name))))))) |
|---|
| 1351 | search) |
|---|
| 1352 | r |
|---|
| 1353 | name)))) |
|---|
| 1354 | (extend-syntax-env (lambda (vars vals r) |
|---|
| 1355 | (if (null? vars) |
|---|
| 1356 | r |
|---|
| 1357 | (cons (cons (car vars) |
|---|
| 1358 | (cons 'syntax |
|---|
| 1359 | (car vals))) |
|---|
| 1360 | (extend-syntax-env |
|---|
| 1361 | (cdr vars) |
|---|
| 1362 | (cdr vals) |
|---|
| 1363 | r))))) |
|---|
| 1364 | (extend-var-env append) |
|---|
| 1365 | (extend-macro-env (lambda (vars vals r) |
|---|
| 1366 | (if (null? vars) |
|---|
| 1367 | r |
|---|
| 1368 | (cons (cons (car vars) |
|---|
| 1369 | (cons 'macro |
|---|
| 1370 | (car vals))) |
|---|
| 1371 | (extend-macro-env |
|---|
| 1372 | (cdr vars) |
|---|
| 1373 | (cdr vals) |
|---|
| 1374 | r))))) |
|---|
| 1375 | (null-env '()) |
|---|
| 1376 | (global-lookup (lambda (sym) |
|---|
| 1377 | ((lambda (g000184) |
|---|
| 1378 | (if g000184 |
|---|
| 1379 | g000184 |
|---|
| 1380 | '(global-unbound))) |
|---|
| 1381 | (get-global-definition-hook sym)))) |
|---|
| 1382 | (extend-global-env (lambda (sym binding) |
|---|
| 1383 | (put-global-definition-hook |
|---|
| 1384 | sym |
|---|
| 1385 | binding))) |
|---|
| 1386 | (binding-value cdr) |
|---|
| 1387 | (binding-type car) |
|---|
| 1388 | (arg-check (lambda (pred? x who) |
|---|
| 1389 | (if (not (pred? x)) |
|---|
| 1390 | (error-hook who "invalid argument" x) |
|---|
| 1391 | (##core#undefined)))) |
|---|
| 1392 | (id-error (lambda (x) |
|---|
| 1393 | (syntax-error |
|---|
| 1394 | x |
|---|
| 1395 | "invalid context for identifier"))) |
|---|
| 1396 | (scope-error (lambda (id) |
|---|
| 1397 | (syntax-error |
|---|
| 1398 | id |
|---|
| 1399 | "invalid context for bound identifier"))) |
|---|
| 1400 | (syntax-object-wrap (lambda (x) (vector-ref x 2))) |
|---|
| 1401 | (syntax-object-expression (lambda (x) (vector-ref x 1))) |
|---|
| 1402 | (make-syntax-object (lambda (expression wrap) |
|---|
| 1403 | (vector |
|---|
| 1404 | 'syntax-object |
|---|
| 1405 | expression |
|---|
| 1406 | wrap))) |
|---|
| 1407 | (syntax-object? (lambda (x) |
|---|
| 1408 | (if (vector? x) |
|---|
| 1409 | (if (= (vector-length x) 3) |
|---|
| 1410 | (eq? (vector-ref x 0) |
|---|
| 1411 | 'syntax-object) |
|---|
| 1412 | #f) |
|---|
| 1413 | #f)))) |
|---|
| 1414 | (global-extend 'core 'letrec-syntax chi-local-syntax) |
|---|
| 1415 | (global-extend 'core 'let-syntax chi-local-syntax) |
|---|
| 1416 | (global-extend |
|---|
| 1417 | 'core |
|---|
| 1418 | 'quote |
|---|
| 1419 | (lambda (e r w) |
|---|
| 1420 | ((lambda (g000136) |
|---|
| 1421 | ((lambda (g000135) |
|---|
| 1422 | (if (not (eq? g000135 'no)) |
|---|
| 1423 | ((lambda (__ _e) (build-data (strip _e))) |
|---|
| 1424 | (car g000135) |
|---|
| 1425 | (cadr g000135)) |
|---|
| 1426 | ((lambda (g000138) |
|---|
| 1427 | ((lambda (g000137) |
|---|
| 1428 | (if (not (eq? g000137 'no)) |
|---|
| 1429 | ((lambda (__) |
|---|
| 1430 | (syntax-error (wrap e w))) |
|---|
| 1431 | (car g000137)) |
|---|
| 1432 | (syntax-error g000138))) |
|---|
| 1433 | (syntax-dispatch |
|---|
| 1434 | g000138 |
|---|
| 1435 | '(any) |
|---|
| 1436 | (vector)))) |
|---|
| 1437 | g000136))) |
|---|
| 1438 | (syntax-dispatch |
|---|
| 1439 | g000136 |
|---|
| 1440 | '(pair (any) pair (any) atom) |
|---|
| 1441 | (vector)))) |
|---|
| 1442 | e))) |
|---|
| 1443 | (global-extend |
|---|
| 1444 | 'core |
|---|
| 1445 | 'syntax |
|---|
| 1446 | (lambda (e r w) |
|---|
| 1447 | ((lambda (g000132) |
|---|
| 1448 | ((lambda (g000131) |
|---|
| 1449 | (if (not (eq? g000131 'no)) |
|---|
| 1450 | ((lambda (__ _x) (chi-syntax e _x r w)) |
|---|
| 1451 | (car g000131) |
|---|
| 1452 | (cadr g000131)) |
|---|
| 1453 | ((lambda (g000134) |
|---|
| 1454 | ((lambda (g000133) |
|---|
| 1455 | (if (not (eq? g000133 'no)) |
|---|
| 1456 | ((lambda (__) |
|---|
| 1457 | (syntax-error (wrap e w))) |
|---|
| 1458 | (car g000133)) |
|---|
| 1459 | (syntax-error g000134))) |
|---|
| 1460 | (syntax-dispatch |
|---|
| 1461 | g000134 |
|---|
| 1462 | '(any) |
|---|
| 1463 | (vector)))) |
|---|
| 1464 | g000132))) |
|---|
| 1465 | (syntax-dispatch |
|---|
| 1466 | g000132 |
|---|
| 1467 | '(pair (any) pair (any) atom) |
|---|
| 1468 | (vector)))) |
|---|
| 1469 | e))) |
|---|
| 1470 | (global-extend |
|---|
| 1471 | 'core |
|---|
| 1472 | 'syntax-lambda |
|---|
| 1473 | (lambda (e r w) |
|---|
| 1474 | ((lambda (g000127) |
|---|
| 1475 | ((lambda (g000128) |
|---|
| 1476 | ((lambda (g000126) |
|---|
| 1477 | (if (not (eq? g000126 'no)) |
|---|
| 1478 | ((lambda (__ _id _level _exp) |
|---|
| 1479 | (if (if (valid-bound-ids? _id) |
|---|
| 1480 | (map (lambda (x) |
|---|
| 1481 | (if (integer? x) |
|---|
| 1482 | (if (exact? x) |
|---|
| 1483 | (not (negative? |
|---|
| 1484 | x)) |
|---|
| 1485 | #f) |
|---|
| 1486 | #f)) |
|---|
| 1487 | (map unwrap _level)) |
|---|
| 1488 | #f) |
|---|
| 1489 | ((lambda (new-vars) |
|---|
| 1490 | (build-lambda |
|---|
| 1491 | new-vars |
|---|
| 1492 | (chi _exp |
|---|
| 1493 | (extend-syntax-env |
|---|
| 1494 | new-vars |
|---|
| 1495 | (map unwrap |
|---|
| 1496 | _level) |
|---|
| 1497 | r) |
|---|
| 1498 | (make-binding-wrap |
|---|
| 1499 | _id |
|---|
| 1500 | new-vars |
|---|
| 1501 | w)))) |
|---|
| 1502 | (map gen-var _id)) |
|---|
| 1503 | (g000128))) |
|---|
| 1504 | (car g000126) |
|---|
| 1505 | (cadr g000126) |
|---|
| 1506 | (caddr g000126) |
|---|
| 1507 | (cadddr g000126)) |
|---|
| 1508 | (g000128))) |
|---|
| 1509 | (syntax-dispatch |
|---|
| 1510 | g000127 |
|---|
| 1511 | '(pair (any) |
|---|
| 1512 | pair |
|---|
| 1513 | (each pair (any) pair (any) atom) |
|---|
| 1514 | pair |
|---|
| 1515 | (any) |
|---|
| 1516 | atom) |
|---|
| 1517 | (vector)))) |
|---|
| 1518 | (lambda () |
|---|
| 1519 | ((lambda (g000130) |
|---|
| 1520 | ((lambda (g000129) |
|---|
| 1521 | (if (not (eq? g000129 'no)) |
|---|
| 1522 | ((lambda (__) |
|---|
| 1523 | (syntax-error (wrap e w))) |
|---|
| 1524 | (car g000129)) |
|---|
| 1525 | (syntax-error g000130))) |
|---|
| 1526 | (syntax-dispatch |
|---|
| 1527 | g000130 |
|---|
| 1528 | '(any) |
|---|
| 1529 | (vector)))) |
|---|
| 1530 | g000127)))) |
|---|
| 1531 | e))) |
|---|
| 1532 | (global-extend |
|---|
| 1533 | 'core |
|---|
| 1534 | 'lambda |
|---|
| 1535 | (lambda (e r w) |
|---|
| 1536 | ((lambda (g000121) |
|---|
| 1537 | ((lambda (g000120) |
|---|
| 1538 | (if (not (eq? g000120 'no)) |
|---|
| 1539 | ((lambda (__ _id _e1 _e2) |
|---|
| 1540 | (if (not (valid-bound-ids? _id)) |
|---|
| 1541 | (syntax-error |
|---|
| 1542 | (wrap e w) |
|---|
| 1543 | "invalid parameter list") |
|---|
| 1544 | ((lambda (new-vars) |
|---|
| 1545 | (build-lambda |
|---|
| 1546 | new-vars |
|---|
| 1547 | (chi-body |
|---|
| 1548 | (cons _e1 _e2) |
|---|
| 1549 | e |
|---|
| 1550 | (extend-var-env |
|---|
| 1551 | new-vars |
|---|
| 1552 | r) |
|---|
| 1553 | (make-binding-wrap |
|---|
| 1554 | _id |
|---|
| 1555 | new-vars |
|---|
| 1556 | w)))) |
|---|
| 1557 | (map gen-var _id)))) |
|---|
| 1558 | (car g000120) |
|---|
| 1559 | (cadr g000120) |
|---|
| 1560 | (caddr g000120) |
|---|
| 1561 | (cadddr g000120)) |
|---|
| 1562 | ((lambda (g000123) |
|---|
| 1563 | ((lambda (g000122) |
|---|
| 1564 | (if (not (eq? g000122 'no)) |
|---|
| 1565 | ((lambda (__ _ids _e1 _e2) |
|---|
| 1566 | ((lambda (old-ids) |
|---|
| 1567 | (if (not (valid-bound-ids? |
|---|
| 1568 | (lambda-var-list |
|---|
| 1569 | _ids))) |
|---|
| 1570 | (syntax-error |
|---|
| 1571 | (wrap e w) |
|---|
| 1572 | "invalid parameter list") |
|---|
| 1573 | ((lambda (new-vars) |
|---|
| 1574 | (build-improper-lambda |
|---|
| 1575 | (reverse |
|---|
| 1576 | (cdr new-vars)) |
|---|
| 1577 | (car new-vars) |
|---|
| 1578 | (chi-body |
|---|
| 1579 | (cons _e1 |
|---|
| 1580 | _e2) |
|---|
| 1581 | e |
|---|
| 1582 | (extend-var-env |
|---|
| 1583 | new-vars |
|---|
| 1584 | r) |
|---|
| 1585 | (make-binding-wrap |
|---|
| 1586 | old-ids |
|---|
| 1587 | new-vars |
|---|
| 1588 | w)))) |
|---|
| 1589 | (map gen-var |
|---|
| 1590 | old-ids)))) |
|---|
| 1591 | (lambda-var-list _ids))) |
|---|
| 1592 | (car g000122) |
|---|
| 1593 | (cadr g000122) |
|---|
| 1594 | (caddr g000122) |
|---|
| 1595 | (cadddr g000122)) |
|---|
| 1596 | ((lambda (g000125) |
|---|
| 1597 | ((lambda (g000124) |
|---|
| 1598 | (if (not (eq? g000124 |
|---|
| 1599 | 'no)) |
|---|
| 1600 | ((lambda (__) |
|---|
| 1601 | (syntax-error |
|---|
| 1602 | (wrap e w))) |
|---|
| 1603 | (car g000124)) |
|---|
| 1604 | (syntax-error |
|---|
| 1605 | g000125))) |
|---|
| 1606 | (syntax-dispatch |
|---|
| 1607 | g000125 |
|---|
| 1608 | '(any) |
|---|
| 1609 | (vector)))) |
|---|
| 1610 | g000123))) |
|---|
| 1611 | (syntax-dispatch |
|---|
| 1612 | g000123 |
|---|
| 1613 | '(pair (any) |
|---|
| 1614 | pair |
|---|
| 1615 | (any) |
|---|
| 1616 | pair |
|---|
| 1617 | (any) |
|---|
| 1618 | each |
|---|
| 1619 | any) |
|---|
| 1620 | (vector)))) |
|---|
| 1621 | g000121))) |
|---|
| 1622 | (syntax-dispatch |
|---|
| 1623 | g000121 |
|---|
| 1624 | '(pair (any) |
|---|
| 1625 | pair |
|---|
| 1626 | (each any) |
|---|
| 1627 | pair |
|---|
| 1628 | (any) |
|---|
| 1629 | each |
|---|
| 1630 | any) |
|---|
| 1631 | (vector)))) |
|---|
| 1632 | e))) |
|---|
| 1633 | (global-extend |
|---|
| 1634 | 'core |
|---|
| 1635 | 'letrec |
|---|
| 1636 | (lambda (e r w) |
|---|
| 1637 | ((lambda (g000116) |
|---|
| 1638 | ((lambda (g000117) |
|---|
| 1639 | ((lambda (g000115) |
|---|
| 1640 | (if (not (eq? g000115 'no)) |
|---|
| 1641 | (apply |
|---|
| 1642 | (lambda (__ _id _val _e1 _e2) |
|---|
| 1643 | (if (valid-bound-ids? _id) |
|---|
| 1644 | ((lambda (new-vars) |
|---|
| 1645 | ((lambda (w r) |
|---|
| 1646 | (build-letrec |
|---|
| 1647 | new-vars |
|---|
| 1648 | (map (lambda (x) |
|---|
| 1649 | (chi x |
|---|
| 1650 | r |
|---|
| 1651 | w)) |
|---|
| 1652 | _val) |
|---|
| 1653 | (chi-body |
|---|
| 1654 | (cons _e1 _e2) |
|---|
| 1655 | e |
|---|
| 1656 | r |
|---|
| 1657 | w))) |
|---|
| 1658 | (make-binding-wrap |
|---|
| 1659 | _id |
|---|
| 1660 | new-vars |
|---|
| 1661 | w) |
|---|
| 1662 | (extend-var-env |
|---|
| 1663 | new-vars |
|---|
| 1664 | r))) |
|---|
| 1665 | (map gen-var _id)) |
|---|
| 1666 | (g000117))) |
|---|
| 1667 | g000115) |
|---|
| 1668 | (g000117))) |
|---|
| 1669 | (syntax-dispatch |
|---|
| 1670 | g000116 |
|---|
| 1671 | '(pair (any) |
|---|
| 1672 | pair |
|---|
| 1673 | (each pair (any) pair (any) atom) |
|---|
| 1674 | pair |
|---|
| 1675 | (any) |
|---|
| 1676 | each |
|---|
| 1677 | any) |
|---|
| 1678 | (vector)))) |
|---|
| 1679 | (lambda () |
|---|
| 1680 | ((lambda (g000119) |
|---|
| 1681 | ((lambda (g000118) |
|---|
| 1682 | (if (not (eq? g000118 'no)) |
|---|
| 1683 | ((lambda (__) |
|---|
| 1684 | (syntax-error (wrap e w))) |
|---|
| 1685 | (car g000118)) |
|---|
| 1686 | (syntax-error g000119))) |
|---|
| 1687 | (syntax-dispatch |
|---|
| 1688 | g000119 |
|---|
| 1689 | '(any) |
|---|
| 1690 | (vector)))) |
|---|
| 1691 | g000116)))) |
|---|
| 1692 | e))) |
|---|
| 1693 | (global-extend |
|---|
| 1694 | 'core |
|---|
| 1695 | 'if |
|---|
| 1696 | (lambda (e r w) |
|---|
| 1697 | ((lambda (g000110) |
|---|
| 1698 | ((lambda (g000109) |
|---|
| 1699 | (if (not (eq? g000109 'no)) |
|---|
| 1700 | ((lambda (__ _test _then) |
|---|
| 1701 | (build-conditional |
|---|
| 1702 | (chi _test r w) |
|---|
| 1703 | (chi _then r w) |
|---|
| 1704 | (chi (list '#(syntax-object |
|---|
| 1705 | ##core#undefined |
|---|
| 1706 | (top))) |
|---|
| 1707 | r |
|---|
| 1708 | empty-wrap))) |
|---|
| 1709 | (car g000109) |
|---|
| 1710 | (cadr g000109) |
|---|
| 1711 | (caddr g000109)) |
|---|
| 1712 | ((lambda (g000112) |
|---|
| 1713 | ((lambda (g000111) |
|---|
| 1714 | (if (not (eq? g000111 'no)) |
|---|
| 1715 | ((lambda (__ _test _then _else) |
|---|
| 1716 | (build-conditional |
|---|
| 1717 | (chi _test r w) |
|---|
| 1718 | (chi _then r w) |
|---|
| 1719 | (chi _else r w))) |
|---|
| 1720 | (car g000111) |
|---|
| 1721 | (cadr g000111) |
|---|
| 1722 | (caddr g000111) |
|---|
| 1723 | (cadddr g000111)) |
|---|
| 1724 | ((lambda (g000114) |
|---|
| 1725 | ((lambda (g000113) |
|---|
| 1726 | (if (not (eq? g000113 |
|---|
| 1727 | 'no)) |
|---|
| 1728 | ((lambda (__) |
|---|
| 1729 | (syntax-error |
|---|
| 1730 | (wrap e w))) |
|---|
| 1731 | (car g000113)) |
|---|
| 1732 | (syntax-error |
|---|
| 1733 | g000114))) |
|---|
| 1734 | (syntax-dispatch |
|---|
| 1735 | g000114 |
|---|
| 1736 | '(any) |
|---|
| 1737 | (vector)))) |
|---|
| 1738 | g000112))) |
|---|
| 1739 | (syntax-dispatch |
|---|
| 1740 | g000112 |
|---|
| 1741 | '(pair (any) |
|---|
| 1742 | pair |
|---|
| 1743 | (any) |
|---|
| 1744 | pair |
|---|
| 1745 | (any) |
|---|
| 1746 | pair |
|---|
| 1747 | (any) |
|---|
| 1748 | atom) |
|---|
| 1749 | (vector)))) |
|---|
| 1750 | g000110))) |
|---|
| 1751 | (syntax-dispatch |
|---|
| 1752 | g000110 |
|---|
| 1753 | '(pair (any) pair (any) pair (any) atom) |
|---|
| 1754 | (vector)))) |
|---|
| 1755 | e))) |
|---|
| 1756 | (global-extend |
|---|
| 1757 | 'core |
|---|
| 1758 | 'set! |
|---|
| 1759 | (lambda (e r w) |
|---|
| 1760 | ((lambda (g000104) |
|---|
| 1761 | ((lambda (g000105) |
|---|
| 1762 | ((lambda (g000103) |
|---|
| 1763 | (if (not (eq? g000103 'no)) |
|---|
| 1764 | ((lambda (__ _id _val) |
|---|
| 1765 | (if (id? _id) |
|---|
| 1766 | ((lambda (val n) |
|---|
| 1767 | ((lambda (g000108) |
|---|
| 1768 | (if (memv |
|---|
| 1769 | g000108 |
|---|
| 1770 | '(lexical)) |
|---|
| 1771 | (build-lexical-assignment |
|---|
| 1772 | n |
|---|
| 1773 | val) |
|---|
| 1774 | (if (memv |
|---|
| 1775 | g000108 |
|---|
| 1776 | '(global |
|---|
| 1777 | global-unbound)) |
|---|
| 1778 | (build-global-assignment |
|---|
| 1779 | n |
|---|
| 1780 | val) |
|---|
| 1781 | (begin g000108 |
|---|
| 1782 | (id-error |
|---|
| 1783 | (wrap _id |
|---|
| 1784 | w)))))) |
|---|
| 1785 | (binding-type |
|---|
| 1786 | (lookup n _id r)))) |
|---|
| 1787 | (chi _val r w) |
|---|
| 1788 | (id-var-name _id w)) |
|---|
| 1789 | (g000105))) |
|---|
| 1790 | (car g000103) |
|---|
| 1791 | (cadr g000103) |
|---|
| 1792 | (caddr g000103)) |
|---|
| 1793 | (g000105))) |
|---|
| 1794 | (syntax-dispatch |
|---|
| 1795 | g000104 |
|---|
| 1796 | '(pair (any) pair (any) pair (any) atom) |
|---|
| 1797 | (vector)))) |
|---|
| 1798 | (lambda () |
|---|
| 1799 | ((lambda (g000107) |
|---|
| 1800 | ((lambda (g000106) |
|---|
| 1801 | (if (not (eq? g000106 'no)) |
|---|
| 1802 | ((lambda (__) |
|---|
| 1803 | (syntax-error (wrap e w))) |
|---|
| 1804 | (car g000106)) |
|---|
| 1805 | (syntax-error g000107))) |
|---|
| 1806 | (syntax-dispatch |
|---|
| 1807 | g000107 |
|---|
| 1808 | '(any) |
|---|
| 1809 | (vector)))) |
|---|
| 1810 | g000104)))) |
|---|
| 1811 | e))) |
|---|
| 1812 | (global-extend |
|---|
| 1813 | 'special |
|---|
| 1814 | 'begin |
|---|
| 1815 | (lambda (e r w k) |
|---|
| 1816 | ((lambda (body) |
|---|
| 1817 | (if (null? body) |
|---|
| 1818 | (if (eqv? k chi-top) |
|---|
| 1819 | (chi (list '#(syntax-object ##core#undefined (top))) |
|---|
| 1820 | r |
|---|
| 1821 | empty-wrap) |
|---|
| 1822 | (syntax-error |
|---|
| 1823 | (wrap e w) |
|---|
| 1824 | "no expressions in body of")) |
|---|
| 1825 | (build-sequence |
|---|
| 1826 | ((letrec ((dobody (lambda (body) |
|---|
| 1827 | (if (null? body) |
|---|
| 1828 | '() |
|---|
| 1829 | ((lambda (first) |
|---|
| 1830 | (cons first |
|---|
| 1831 | (dobody |
|---|
| 1832 | (cdr body)))) |
|---|
| 1833 | (k (car body) |
|---|
| 1834 | r |
|---|
| 1835 | empty-wrap)))))) |
|---|
| 1836 | dobody) |
|---|
| 1837 | body)))) |
|---|
| 1838 | (chi-sequence e w)))) |
|---|
| 1839 | (global-extend |
|---|
| 1840 | 'special |
|---|
| 1841 | 'define |
|---|
| 1842 | (lambda (e r w k) |
|---|
| 1843 | (if (eqv? k chi-top) |
|---|
| 1844 | ((lambda (n&v) |
|---|
| 1845 | ((lambda (n) |
|---|
| 1846 | (global-extend 'global n '()) |
|---|
| 1847 | (build-global-definition |
|---|
| 1848 | n |
|---|
| 1849 | (chi (cadr n&v) r empty-wrap))) |
|---|
| 1850 | (id-var-name (car n&v) empty-wrap))) |
|---|
| 1851 | (chi-definition e w)) |
|---|
| 1852 | (syntax-error |
|---|
| 1853 | (wrap e w) |
|---|
| 1854 | "invalid context for definition")))) |
|---|
| 1855 | (global-extend |
|---|
| 1856 | 'special |
|---|
| 1857 | 'define-syntax |
|---|
| 1858 | (lambda (e r w k) |
|---|
| 1859 | (if (eqv? k chi-top) |
|---|
| 1860 | ((lambda (n&v) |
|---|
| 1861 | (global-extend |
|---|
| 1862 | 'macro |
|---|
| 1863 | (id-var-name (car n&v) empty-wrap) |
|---|
| 1864 | (chi-macro-def (cadr n&v) r empty-wrap)) |
|---|
| 1865 | (chi (list '#(syntax-object ##core#undefined (top))) |
|---|
| 1866 | r |
|---|
| 1867 | empty-wrap)) |
|---|
| 1868 | (chi-syntax-definition e w)) |
|---|
| 1869 | (syntax-error |
|---|
| 1870 | (wrap e w) |
|---|
| 1871 | "invalid context for definition")))) |
|---|
| 1872 | (set! expand-syntax |
|---|
| 1873 | (lambda (x) (chi-top x null-env top-wrap))) |
|---|
| 1874 | (set! implicit-identifier |
|---|
| 1875 | (lambda (id sym) |
|---|
| 1876 | (arg-check id? id 'implicit-identifier) |
|---|
| 1877 | (arg-check symbol? sym 'implicit-identifier) |
|---|
| 1878 | (if (syntax-object? id) |
|---|
| 1879 | (wrap sym (syntax-object-wrap id)) |
|---|
| 1880 | sym))) |
|---|
| 1881 | (set! syntax-object->datum (lambda (x) (strip x))) |
|---|
| 1882 | (set! generate-temporaries |
|---|
| 1883 | (lambda (ls) |
|---|
| 1884 | (arg-check list? ls 'generate-temporaries) |
|---|
| 1885 | (map (lambda (x) (wrap (gensym) top-wrap)) ls))) |
|---|
| 1886 | (set! free-identifier=? |
|---|
| 1887 | (lambda (x y) |
|---|
| 1888 | (arg-check id? x 'free-identifier=?) |
|---|
| 1889 | (arg-check id? y 'free-identifier=?) |
|---|
| 1890 | (free-id=? x y))) |
|---|
| 1891 | (set! bound-identifier=? |
|---|
| 1892 | (lambda (x y) |
|---|
| 1893 | (arg-check id? x 'bound-identifier=?) |
|---|
| 1894 | (arg-check id? y 'bound-identifier=?) |
|---|
| 1895 | (bound-id=? x y))) |
|---|
| 1896 | (set! identifier? (lambda (x) (id? x))) |
|---|
| 1897 | (set! syntax-error |
|---|
| 1898 | (lambda (object . messages) |
|---|
| 1899 | (for-each |
|---|
| 1900 | (lambda (x) (arg-check string? x 'syntax-error)) |
|---|
| 1901 | messages) |
|---|
| 1902 | ((lambda (message) |
|---|
| 1903 | (error-hook 'expand-syntax message (strip object))) |
|---|
| 1904 | (if (null? messages) |
|---|
| 1905 | "invalid syntax" |
|---|
| 1906 | (apply string-append messages))))) |
|---|
| 1907 | (set! install-global-transformer |
|---|
| 1908 | (lambda (sym p) (global-extend 'macro sym p))) |
|---|
| 1909 | ((lambda () |
|---|
| 1910 | (letrec ((matchx (lambda (e p k w r) |
|---|
| 1911 | (if (eq? r 'no) |
|---|
| 1912 | r |
|---|
| 1913 | ((lambda (g000100) |
|---|
| 1914 | (if (memv g000100 '(any)) |
|---|
| 1915 | (cons (wrap e w) r) |
|---|
| 1916 | (if (memv |
|---|
| 1917 | g000100 |
|---|
| 1918 | '(free-id)) |
|---|
| 1919 | (if (if (identifier? |
|---|
| 1920 | e) |
|---|
| 1921 | (free-id=? |
|---|
| 1922 | (wrap e w) |
|---|
| 1923 | (vector-ref |
|---|
| 1924 | k |
|---|
| 1925 | (cdr p))) |
|---|
| 1926 | #f) |
|---|
| 1927 | r |
|---|
| 1928 | 'no) |
|---|
| 1929 | (begin g000100 |
|---|
| 1930 | (if (syntax-object? |
|---|
| 1931 | e) |
|---|
| 1932 | (match* |
|---|
| 1933 | (syntax-object-expression |
|---|
| 1934 | e) |
|---|
| 1935 | p |
|---|
| 1936 | k |
|---|
| 1937 | (join-wraps |
|---|
| 1938 | w |
|---|
| 1939 | (syntax-object-wrap |
|---|
| 1940 | e)) |
|---|
| 1941 | r) |
|---|
| 1942 | (match* |
|---|
| 1943 | e |
|---|
| 1944 | p |
|---|
| 1945 | k |
|---|
| 1946 | w |
|---|
| 1947 | r)))))) |
|---|
| 1948 | (car p))))) |
|---|
| 1949 | (match* (lambda (e p k w r) |
|---|
| 1950 | ((lambda (g000101) |
|---|
| 1951 | (if (memv g000101 '(pair)) |
|---|
| 1952 | (if (pair? e) |
|---|
| 1953 | (matchx |
|---|
| 1954 | (car e) |
|---|
| 1955 | (cadr p) |
|---|
| 1956 | k |
|---|
| 1957 | w |
|---|
| 1958 | (matchx |
|---|
| 1959 | (cdr e) |
|---|
| 1960 | (cddr p) |
|---|
| 1961 | k |
|---|
| 1962 | w |
|---|
| 1963 | r)) |
|---|
| 1964 | 'no) |
|---|
| 1965 | (if (memv g000101 '(each)) |
|---|
| 1966 | (if (eq? (cadr p) 'any) |
|---|
| 1967 | ((lambda (l) |
|---|
| 1968 | (if (eq? l 'no) |
|---|
| 1969 | l |
|---|
| 1970 | (cons l r))) |
|---|
| 1971 | (match-each-any |
|---|
| 1972 | e |
|---|
| 1973 | w)) |
|---|
| 1974 | (if (null? e) |
|---|
| 1975 | (match-empty |
|---|
| 1976 | (cdr p) |
|---|
| 1977 | r) |
|---|
| 1978 | ((lambda (l) |
|---|
| 1979 | (if (eq? l |
|---|
| 1980 | 'no) |
|---|
| 1981 | l |
|---|
| 1982 | ((letrec ((collect (lambda (l) |
|---|
| 1983 | (if (null? |
|---|
| 1984 | (car l)) |
|---|
| 1985 | r |
|---|
| 1986 | (cons (map car |
|---|
| 1987 | l) |
|---|
| 1988 | (collect |
|---|
| 1989 | (map cdr |
|---|
| 1990 | l))))))) |
|---|
| 1991 | collect) |
|---|
| 1992 | l))) |
|---|
| 1993 | (match-each |
|---|
| 1994 | e |
|---|
| 1995 | (cdr p) |
|---|
| 1996 | k |
|---|
| 1997 | w)))) |
|---|
| 1998 | (if (memv |
|---|
| 1999 | g000101 |
|---|
| 2000 | '(atom)) |
|---|
| 2001 | (if (equal? |
|---|
| 2002 | (cdr p) |
|---|
| 2003 | e) |
|---|
| 2004 | r |
|---|
| 2005 | 'no) |
|---|
| 2006 | (if (memv |
|---|
| 2007 | g000101 |
|---|
| 2008 | '(vector)) |
|---|
| 2009 | (if (vector? e) |
|---|
| 2010 | (matchx |
|---|
| 2011 | (vector->list |
|---|
| 2012 | e) |
|---|
| 2013 | (cdr p) |
|---|
| 2014 | k |
|---|
| 2015 | w |
|---|
| 2016 | r) |
|---|
| 2017 | 'no) |
|---|
| 2018 | (begin g000101 |
|---|
| 2019 | (##core#undefined))))))) |
|---|
| 2020 | (car p)))) |
|---|
| 2021 | (match-empty (lambda (p r) |
|---|
| 2022 | ((lambda (g000102) |
|---|
| 2023 | (if (memv g000102 '(any)) |
|---|
| 2024 | (cons '() r) |
|---|
| 2025 | (if (memv |
|---|
| 2026 | g000102 |
|---|
| 2027 | '(each)) |
|---|
| 2028 | (match-empty |
|---|
| 2029 | (cdr p) |
|---|
| 2030 | r) |
|---|
| 2031 | (if (memv |
|---|
| 2032 | g000102 |
|---|
| 2033 | '(pair)) |
|---|
| 2034 | (match-empty |
|---|
| 2035 | (cadr p) |
|---|
| 2036 | (match-empty |
|---|
| 2037 | (cddr p) |
|---|
| 2038 | r)) |
|---|
| 2039 | (if (memv |
|---|
| 2040 | g000102 |
|---|
| 2041 | '(free-id |
|---|
| 2042 | atom)) |
|---|
| 2043 | r |
|---|
| 2044 | (if (memv |
|---|
| 2045 | g000102 |
|---|
| 2046 | '(vector)) |
|---|
| 2047 | (match-empty |
|---|
| 2048 | (cdr p) |
|---|
| 2049 | r) |
|---|
| 2050 | (begin g000102 |
|---|
| 2051 | (##core#undefined)))))))) |
|---|
| 2052 | (car p)))) |
|---|
| 2053 | (match-each-any (lambda (e w) |
|---|
| 2054 | (if (pair? e) |
|---|
| 2055 | ((lambda (l) |
|---|
| 2056 | (if (eq? l 'no) |
|---|
| 2057 | l |
|---|
| 2058 | (cons (wrap (car e) |
|---|
| 2059 | w) |
|---|
| 2060 | l))) |
|---|
| 2061 | (match-each-any |
|---|
| 2062 | (cdr e) |
|---|
| 2063 | w)) |
|---|
| 2064 | (if (null? e) |
|---|
| 2065 | '() |
|---|
| 2066 | (if (syntax-object? |
|---|
| 2067 | e) |
|---|
| 2068 | (match-each-any |
|---|
| 2069 | (syntax-object-expression |
|---|
| 2070 | e) |
|---|
| 2071 | (join-wraps |
|---|
| 2072 | w |
|---|
| 2073 | (syntax-object-wrap |
|---|
| 2074 | e))) |
|---|
| 2075 | 'no))))) |
|---|
| 2076 | (match-each (lambda (e p k w) |
|---|
| 2077 | (if (pair? e) |
|---|
| 2078 | ((lambda (first) |
|---|
| 2079 | (if (eq? first 'no) |
|---|
| 2080 | first |
|---|
| 2081 | ((lambda (rest) |
|---|
| 2082 | (if (eq? rest |
|---|
| 2083 | 'no) |
|---|
| 2084 | rest |
|---|
| 2085 | (cons first |
|---|
| 2086 | rest))) |
|---|
| 2087 | (match-each |
|---|
| 2088 | (cdr e) |
|---|
| 2089 | p |
|---|
| 2090 | k |
|---|
| 2091 | w)))) |
|---|
| 2092 | (matchx (car e) p k w '())) |
|---|
| 2093 | (if (null? e) |
|---|
| 2094 | '() |
|---|
| 2095 | (if (syntax-object? e) |
|---|
| 2096 | (match-each |
|---|
| 2097 | (syntax-object-expression |
|---|
| 2098 | e) |
|---|
| 2099 | p |
|---|
| 2100 | k |
|---|
| 2101 | (join-wraps |
|---|
| 2102 | w |
|---|
| 2103 | (syntax-object-wrap |
|---|
| 2104 | e))) |
|---|
| 2105 | 'no)))))) |
|---|
| 2106 | (set! syntax-dispatch |
|---|
| 2107 | (lambda (expression pattern keys) |
|---|
| 2108 | (matchx |
|---|
| 2109 | expression |
|---|
| 2110 | pattern |
|---|
| 2111 | keys |
|---|
| 2112 | empty-wrap |
|---|
| 2113 | '()))))))))) |
|---|
| 2114 | (install-global-transformer |
|---|
| 2115 | 'let |
|---|
| 2116 | (lambda (x) |
|---|
| 2117 | ((lambda (g00095) |
|---|
| 2118 | ((lambda (g00096) |
|---|
| 2119 | ((lambda (g00094) |
|---|
| 2120 | (if (not (eq? g00094 'no)) |
|---|
| 2121 | (apply |
|---|
| 2122 | (lambda (__ _x _v _e1 _e2) |
|---|
| 2123 | (if (andmap identifier? _x) |
|---|
| 2124 | (cons (cons '#(syntax-object |
|---|
| 2125 | lambda |
|---|
| 2126 | (top)) |
|---|
| 2127 | (cons _x |
|---|
| 2128 | (cons _e1 _e2))) |
|---|
| 2129 | _v) |
|---|
| 2130 | (g00096))) |
|---|
| 2131 | g00094) |
|---|
| 2132 | (g00096))) |
|---|
| 2133 | (syntax-dispatch |
|---|
| 2134 | g00095 |
|---|
| 2135 | '(pair (any) |
|---|
| 2136 | pair |
|---|
| 2137 | (each pair (any) pair (any) atom) |
|---|
| 2138 | pair |
|---|
| 2139 | (any) |
|---|
| 2140 | each |
|---|
| 2141 | any) |
|---|
| 2142 | (vector)))) |
|---|
| 2143 | (lambda () |
|---|
| 2144 | ((lambda (g00098) |
|---|
| 2145 | ((lambda (g00099) |
|---|
| 2146 | ((lambda (g00097) |
|---|
| 2147 | (if (not (eq? g00097 'no)) |
|---|
| 2148 | (apply |
|---|
| 2149 | (lambda (__ _f _x _v _e1 _e2) |
|---|
| 2150 | (if (andmap |
|---|
| 2151 | identifier? |
|---|
| 2152 | (cons _f _x)) |
|---|
| 2153 | (cons (list '#(syntax-object |
|---|
| 2154 | letrec |
|---|
| 2155 | (top)) |
|---|
| 2156 | (list (list _f |
|---|
| 2157 | (cons '#(syntax-object |
|---|
| 2158 | lambda |
|---|
| 2159 | (top)) |
|---|
| 2160 | (cons _x |
|---|
| 2161 | (cons _e1 |
|---|
| 2162 | _e2))))) |
|---|
| 2163 | _f) |
|---|
| 2164 | _v) |
|---|
| 2165 | (g00099))) |
|---|
| 2166 | g00097) |
|---|
| 2167 | (g00099))) |
|---|
| 2168 | (syntax-dispatch |
|---|
| 2169 | g00098 |
|---|
| 2170 | '(pair (any) |
|---|
| 2171 | pair |
|---|
| 2172 | (any) |
|---|
| 2173 | pair |
|---|
| 2174 | (each pair (any) pair (any) atom) |
|---|
| 2175 | pair |
|---|
| 2176 | (any) |
|---|
| 2177 | each |
|---|
| 2178 | any) |
|---|
| 2179 | (vector)))) |
|---|
| 2180 | (lambda () (syntax-error g00098)))) |
|---|
| 2181 | g00095)))) |
|---|
| 2182 | x))) |
|---|
| 2183 | (install-global-transformer |
|---|
| 2184 | 'syntax-case |
|---|
| 2185 | ((lambda () |
|---|
| 2186 | (letrec ((build-dispatch-call (lambda (args body val) |
|---|
| 2187 | ((lambda (g00046) |
|---|
| 2188 | ((lambda (g00045) |
|---|
| 2189 | (if (not (eq? g00045 |
|---|
| 2190 | 'no)) |
|---|
| 2191 | body |
|---|
| 2192 | ((lambda (g00048) |
|---|
| 2193 | ((lambda (g00047) |
|---|
| 2194 | (if (not (eq? g00047 |
|---|
| 2195 | 'no)) |
|---|
| 2196 | ((lambda (_arg1) |
|---|
| 2197 | ((lambda (g00066) |
|---|
| 2198 | ((lambda (g00065) |
|---|
| 2199 | (if (not (eq? g00065 |
|---|
| 2200 | 'no)) |
|---|
| 2201 | ((lambda (_body |
|---|
| 2202 | _val) |
|---|
| 2203 | (list (list '#(syntax-object |
|---|
| 2204 | syntax-lambda |
|---|
| 2205 | (top)) |
|---|
| 2206 | (list _arg1) |
|---|
| 2207 | _body) |
|---|
| 2208 | (list '#(syntax-object |
|---|
| 2209 | car |
|---|
| 2210 | (top)) |
|---|
| 2211 | _val))) |
|---|
| 2212 | (car g00065) |
|---|
| 2213 | (cadr g00065)) |
|---|
| 2214 | (syntax-error |
|---|
| 2215 | g00066))) |
|---|
| 2216 | (syntax-dispatch |
|---|
| 2217 | g00066 |
|---|
| 2218 | '(pair (any) |
|---|
| 2219 | pair |
|---|
| 2220 | (any) |
|---|
| 2221 | atom) |
|---|
| 2222 | (vector)))) |
|---|
| 2223 | (list body |
|---|
| 2224 | val))) |
|---|
| 2225 | (car g00047)) |
|---|
| 2226 | ((lambda (g00050) |
|---|
| 2227 | ((lambda (g00049) |
|---|
| 2228 | (if (not (eq? g00049 |
|---|
| 2229 | 'no)) |
|---|
| 2230 | ((lambda (_arg1 |
|---|
| 2231 | _arg2) |
|---|
| 2232 | ((lambda (g00064) |
|---|
| 2233 | ((lambda (g00063) |
|---|
| 2234 | (if (not (eq? g00063 |
|---|
| 2235 | 'no)) |
|---|
| 2236 | ((lambda (_body |
|---|
| 2237 | _val) |
|---|
| 2238 | (list (list '#(syntax-object |
|---|
| 2239 | syntax-lambda |
|---|
| 2240 | (top)) |
|---|
| 2241 | (list _arg1 |
|---|
| 2242 | _arg2) |
|---|
| 2243 | _body) |
|---|
| 2244 | (list '#(syntax-object |
|---|
| 2245 | car |
|---|
| 2246 | (top)) |
|---|
| 2247 | _val) |
|---|
| 2248 | (list '#(syntax-object |
|---|
| 2249 | cadr |
|---|
| 2250 | (top)) |
|---|
| 2251 | _val))) |
|---|
| 2252 | (car g00063) |
|---|
| 2253 | (cadr g00063)) |
|---|
| 2254 | (syntax-error |
|---|
| 2255 | g00064))) |
|---|
| 2256 | (syntax-dispatch |
|---|
| 2257 | g00064 |
|---|
| 2258 | '(pair (any) |
|---|
| 2259 | pair |
|---|
| 2260 | (any) |
|---|
| 2261 | atom) |
|---|
| 2262 | (vector)))) |
|---|
| 2263 | (list body |
|---|
| 2264 | val))) |
|---|
| 2265 | (car g00049) |
|---|
| 2266 | (cadr g00049)) |
|---|
| 2267 | ((lambda (g00052) |
|---|
| 2268 | ((lambda (g00051) |
|---|
| 2269 | (if (not (eq? g00051 |
|---|
| 2270 | 'no)) |
|---|
| 2271 | ((lambda (_arg1 |
|---|
| 2272 | _arg2 |
|---|
| 2273 | _arg3) |
|---|
| 2274 | ((lambda (g00062) |
|---|
| 2275 | ((lambda (g00061) |
|---|
| 2276 | (if (not (eq? g00061 |
|---|
| 2277 | 'no)) |
|---|
| 2278 | ((lambda (_body |
|---|
| 2279 | _val) |
|---|
| 2280 | (list (list '#(syntax-object |
|---|
| 2281 | syntax-lambda |
|---|
| 2282 | (top)) |
|---|
| 2283 | (list _arg1 |
|---|
| 2284 | _arg2 |
|---|
| 2285 | _arg3) |
|---|
| 2286 | _body) |
|---|
| 2287 | (list '#(syntax-object |
|---|
| 2288 | car |
|---|
| 2289 | (top)) |
|---|
| 2290 | _val) |
|---|
| 2291 | (list '#(syntax-object |
|---|
| 2292 | cadr |
|---|
| 2293 | (top)) |
|---|
| 2294 | _val) |
|---|
| 2295 | (list '#(syntax-object |
|---|
| 2296 | caddr |
|---|
| 2297 | (top)) |
|---|
| 2298 | _val))) |
|---|
| 2299 | (car g00061) |
|---|
| 2300 | (cadr g00061)) |
|---|
| 2301 | (syntax-error |
|---|
| 2302 | g00062))) |
|---|
| 2303 | (syntax-dispatch |
|---|
| 2304 | g00062 |
|---|
| 2305 | '(pair (any) |
|---|
| 2306 | pair |
|---|
| 2307 | (any) |
|---|
| 2308 | atom) |
|---|
| 2309 | (vector)))) |
|---|
| 2310 | (list body |
|---|
| 2311 | val))) |
|---|
| 2312 | (car g00051) |
|---|
| 2313 | (cadr g00051) |
|---|
| 2314 | (caddr |
|---|
| 2315 | g00051)) |
|---|
| 2316 | ((lambda (g00054) |
|---|
| 2317 | ((lambda (g00053) |
|---|
| 2318 | (if (not (eq? g00053 |
|---|
| 2319 | 'no)) |
|---|
| 2320 | ((lambda (_arg1 |
|---|
| 2321 | _arg2 |
|---|
| 2322 | _arg3 |
|---|
| 2323 | _arg4) |
|---|
| 2324 | ((lambda (g00060) |
|---|
| 2325 | ((lambda (g00059) |
|---|
| 2326 | (if (not (eq? g00059 |
|---|
| 2327 | 'no)) |
|---|
| 2328 | ((lambda (_body |
|---|
| 2329 | _val) |
|---|
| 2330 | (list (list '#(syntax-object |
|---|
| 2331 | syntax-lambda |
|---|
| 2332 | (top)) |
|---|
| 2333 | (list _arg1 |
|---|
| 2334 | _arg2 |
|---|
| 2335 | _arg3 |
|---|
| 2336 | _arg4) |
|---|
| 2337 | _body) |
|---|
| 2338 | (list '#(syntax-object |
|---|
| 2339 | car |
|---|
| 2340 | (top)) |
|---|
| 2341 | _val) |
|---|
| 2342 | (list '#(syntax-object |
|---|
| 2343 | cadr |
|---|
| 2344 | (top)) |
|---|
| 2345 | _val) |
|---|
| 2346 | (list '#(syntax-object |
|---|
| 2347 | caddr |
|---|
| 2348 | (top)) |
|---|
| 2349 | _val) |
|---|
| 2350 | (list '#(syntax-object |
|---|
| 2351 | cadddr |
|---|
| 2352 | (top)) |
|---|
| 2353 | _val))) |
|---|
| 2354 | (car g00059) |
|---|
| 2355 | (cadr g00059)) |
|---|
| 2356 | (syntax-error |
|---|
| 2357 | g00060))) |
|---|
| 2358 | (syntax-dispatch |
|---|
| 2359 | g00060 |
|---|
| 2360 | '(pair (any) |
|---|
| 2361 | pair |
|---|
| 2362 | (any) |
|---|
| 2363 | atom) |
|---|
| 2364 | (vector)))) |
|---|
| 2365 | (list body |
|---|
| 2366 | val))) |
|---|
| 2367 | (car g00053) |
|---|
| 2368 | (cadr g00053) |
|---|
| 2369 | (caddr |
|---|
| 2370 | g00053) |
|---|
| 2371 | (cadddr |
|---|
| 2372 | g00053)) |
|---|
| 2373 | ((lambda (g00056) |
|---|
| 2374 | ((lambda (g00055) |
|---|
| 2375 | (if (not (eq? g00055 |
|---|
| 2376 | 'no)) |
|---|
| 2377 | ((lambda (_arg) |
|---|
| 2378 | ((lambda (g00058) |
|---|
| 2379 | ((lambda (g00057) |
|---|
| 2380 | (if (not (eq? g00057 |
|---|
| 2381 | 'no)) |
|---|
| 2382 | ((lambda (_body |
|---|
| 2383 | _val) |
|---|
| 2384 | (list '#(syntax-object |
|---|
| 2385 | apply |
|---|
| 2386 | (top)) |
|---|
| 2387 | (list '#(syntax-object |
|---|
| 2388 | syntax-lambda |
|---|
| 2389 | (top)) |
|---|
| 2390 | _arg |
|---|
| 2391 | _body) |
|---|
| 2392 | _val)) |
|---|
| 2393 | (car g00057) |
|---|
| 2394 | (cadr g00057)) |
|---|
| 2395 | (syntax-error |
|---|
| 2396 | g00058))) |
|---|
| 2397 | (syntax-dispatch |
|---|
| 2398 | g00058 |
|---|
| 2399 | '(pair (any) |
|---|
| 2400 | pair |
|---|
| 2401 | (any) |
|---|
| 2402 | atom) |
|---|
| 2403 | (vector)))) |
|---|
| 2404 | (list body |
|---|
| 2405 | val))) |
|---|
| 2406 | (car g00055)) |
|---|
| 2407 | (syntax-error |
|---|
| 2408 | g00056))) |
|---|
| 2409 | (syntax-dispatch |
|---|
| 2410 | g00056 |
|---|
| 2411 | '(each any) |
|---|
| 2412 | (vector)))) |
|---|
| 2413 | g00054))) |
|---|
| 2414 | (syntax-dispatch |
|---|
| 2415 | g00054 |
|---|
| 2416 | '(pair (any) |
|---|
| 2417 | pair |
|---|
| 2418 | (any) |
|---|
| 2419 | pair |
|---|
| 2420 | (any) |
|---|
| 2421 | pair |
|---|
| 2422 | (any) |
|---|
| 2423 | atom) |
|---|
| 2424 | (vector)))) |
|---|
| 2425 | g00052))) |
|---|
| 2426 | (syntax-dispatch |
|---|
| 2427 | g00052 |
|---|
| 2428 | '(pair (any) |
|---|
| 2429 | pair |
|---|
| 2430 | (any) |
|---|
| 2431 | pair |
|---|
| 2432 | (any) |
|---|
| 2433 | atom) |
|---|
| 2434 | (vector)))) |
|---|
| 2435 | g00050))) |
|---|
| 2436 | (syntax-dispatch |
|---|
| 2437 | g00050 |
|---|
| 2438 | '(pair (any) |
|---|
| 2439 | pair |
|---|
| 2440 | (any) |
|---|
| 2441 | atom) |
|---|
| 2442 | (vector)))) |
|---|
| 2443 | g00048))) |
|---|
| 2444 | (syntax-dispatch |
|---|
| 2445 | g00048 |
|---|
| 2446 | '(pair (any) |
|---|
| 2447 | atom) |
|---|
| 2448 | (vector)))) |
|---|
| 2449 | g00046))) |
|---|
| 2450 | (syntax-dispatch |
|---|
| 2451 | g00046 |
|---|
| 2452 | '(atom) |
|---|
| 2453 | (vector)))) |
|---|
| 2454 | args))) |
|---|
| 2455 | (extract-bound-syntax-ids (lambda (pattern keys) |
|---|
| 2456 | ((letrec ((gen (lambda (p |
|---|
| 2457 | n |
|---|
| 2458 | ids) |
|---|
| 2459 | (if (identifier? |
|---|
| 2460 | p) |
|---|
| 2461 | (if (key? p |
|---|
| 2462 | keys) |
|---|
| 2463 | ids |
|---|
| 2464 | (cons (list p |
|---|
| 2465 | n) |
|---|
| 2466 | ids)) |
|---|
| 2467 | ((lambda (g00068) |
|---|
| 2468 | ((lambda (g00069) |
|---|
| 2469 | ((lambda (g00067) |
|---|
| 2470 | (if (not (eq? g00067 |
|---|
| 2471 | 'no)) |
|---|
| 2472 | ((lambda (_x |
|---|
| 2473 | _dots) |
|---|
| 2474 | (if (ellipsis? |
|---|
| 2475 | _dots) |
|---|
| 2476 | (gen _x |
|---|
| 2477 | (+ n |
|---|
| 2478 | 1) |
|---|
| 2479 | ids) |
|---|
| 2480 | (g00069))) |
|---|
| 2481 | (car g00067) |
|---|
| 2482 | (cadr g00067)) |
|---|
| 2483 | (g00069))) |
|---|
| 2484 | (syntax-dispatch |
|---|
| 2485 | g00068 |
|---|
| 2486 | '(pair (any) |
|---|
| 2487 | pair |
|---|
| 2488 | (any) |
|---|
| 2489 | atom) |
|---|
| 2490 | (vector)))) |
|---|
| 2491 | (lambda () |
|---|
| 2492 | ((lambda (g00071) |
|---|
| 2493 | ((lambda (g00070) |
|---|
| 2494 | (if (not (eq? g00070 |
|---|
| 2495 | 'no)) |
|---|
| 2496 | ((lambda (_x |
|---|
| 2497 | _y) |
|---|
| 2498 | (gen _x |
|---|
| 2499 | n |
|---|
| 2500 | (gen _y |
|---|
| 2501 | n |
|---|
| 2502 | ids))) |
|---|
| 2503 | (car g00070) |
|---|
| 2504 | (cadr g00070)) |
|---|
| 2505 | ((lambda (g00073) |
|---|
| 2506 | ((lambda (g00072) |
|---|
| 2507 | (if (not (eq? g00072 |
|---|
| 2508 | 'no)) |
|---|
| 2509 | ((lambda (_x) |
|---|
| 2510 | (gen _x |
|---|
| 2511 | n |
|---|
| 2512 | ids)) |
|---|
| 2513 | (car g00072)) |
|---|
| 2514 | ((lambda (g00075) |
|---|
| 2515 | ((lambda (g00074) |
|---|
| 2516 | (if (not (eq? g00074 |
|---|
| 2517 | 'no)) |
|---|
| 2518 | ((lambda (_x) |
|---|
| 2519 | ids) |
|---|
| 2520 | (car g00074)) |
|---|
| 2521 | (syntax-error |
|---|
| 2522 | g00075))) |
|---|
| 2523 | (syntax-dispatch |
|---|
| 2524 | g00075 |
|---|
| 2525 | '(any) |
|---|
| 2526 | (vector)))) |
|---|
| 2527 | g00073))) |
|---|
| 2528 | (syntax-dispatch |
|---|
| 2529 | g00073 |
|---|
| 2530 | '(vector |
|---|
| 2531 | each |
|---|
| 2532 | any) |
|---|
| 2533 | (vector)))) |
|---|
| 2534 | g00071))) |
|---|
| 2535 | (syntax-dispatch |
|---|
| 2536 | g00071 |
|---|
| 2537 | '(pair (any) |
|---|
| 2538 | any) |
|---|
| 2539 | (vector)))) |
|---|
| 2540 | g00068)))) |
|---|
| 2541 | p))))) |
|---|
| 2542 | gen) |
|---|
| 2543 | pattern |
|---|
| 2544 | 0 |
|---|
| 2545 | '()))) |
|---|
| 2546 | (valid-syntax-pattern? (lambda (pattern keys) |
|---|
| 2547 | (letrec ((check? (lambda (p |
|---|
| 2548 | ids) |
|---|
| 2549 | (if (identifier? |
|---|
| 2550 | p) |
|---|
| 2551 | (if (eq? ids |
|---|
| 2552 | 'no) |
|---|
| 2553 | ids |
|---|
| 2554 | (if (key? p |
|---|
| 2555 | keys) |
|---|
| 2556 | ids |
|---|
| 2557 | (if (if (not (ellipsis? |
|---|
| 2558 | p)) |
|---|
| 2559 | (not (memid |
|---|
| 2560 | p |
|---|
| 2561 | ids)) |
|---|
| 2562 | #f) |
|---|
| 2563 | (cons p |
|---|
| 2564 | ids) |
|---|
| 2565 | 'no))) |
|---|
| 2566 | ((lambda (g00077) |
|---|
| 2567 | ((lambda (g00078) |
|---|
| 2568 | ((lambda (g00076) |
|---|
| 2569 | (if (not (eq? g00076 |
|---|
| 2570 | 'no)) |
|---|
| 2571 | ((lambda (_x |
|---|
| 2572 | _dots) |
|---|
| 2573 | (if (ellipsis? |
|---|
| 2574 | _dots) |
|---|
| 2575 | (check? |
|---|
| 2576 | _x |
|---|
| 2577 | ids) |
|---|
| 2578 | (g00078))) |
|---|
| 2579 | (car g00076) |
|---|
| 2580 | (cadr g00076)) |
|---|
| 2581 | (g00078))) |
|---|
| 2582 | (syntax-dispatch |
|---|
| 2583 | g00077 |
|---|
| 2584 | '(pair (any) |
|---|
| 2585 | pair |
|---|
| 2586 | (any) |
|---|
| 2587 | atom) |
|---|
| 2588 | (vector)))) |
|---|
| 2589 | (lambda () |
|---|
| 2590 | ((lambda (g00080) |
|---|
| 2591 | ((lambda (g00079) |
|---|
| 2592 | (if (not (eq? g00079 |
|---|
| 2593 | 'no)) |
|---|
| 2594 | ((lambda (_x |
|---|
| 2595 | _y) |
|---|
| 2596 | (check? |
|---|
| 2597 | _x |
|---|
| 2598 | (check? |
|---|
| 2599 | _y |
|---|
| 2600 | ids))) |
|---|
| 2601 | (car g00079) |
|---|
| 2602 | (cadr g00079)) |
|---|
| 2603 | ((lambda (g00082) |
|---|
| 2604 | ((lambda (g00081) |
|---|
| 2605 | (if (not (eq? g00081 |
|---|
| 2606 | 'no)) |
|---|
| 2607 | ((lambda (_x) |
|---|
| 2608 | (check? |
|---|
| 2609 | _x |
|---|
| 2610 | ids)) |
|---|
| 2611 | (car g00081)) |
|---|
| 2612 | ((lambda (g00084) |
|---|
| 2613 | ((lambda (g00083) |
|---|
| 2614 | (if (not (eq? g00083 |
|---|
| 2615 | 'no)) |
|---|
| 2616 | ((lambda (_x) |
|---|
| 2617 | ids) |
|---|
| 2618 | (car g00083)) |
|---|
| 2619 | (syntax-error |
|---|
| 2620 | g00084))) |
|---|
| 2621 | (syntax-dispatch |
|---|
| 2622 | g00084 |
|---|
| 2623 | '(any) |
|---|
| 2624 | (vector)))) |
|---|
| 2625 | g00082))) |
|---|
| 2626 | (syntax-dispatch |
|---|
| 2627 | g00082 |
|---|
| 2628 | '(vector |
|---|
| 2629 | each |
|---|
| 2630 | any) |
|---|
| 2631 | (vector)))) |
|---|
| 2632 | g00080))) |
|---|
| 2633 | (syntax-dispatch |
|---|
| 2634 | g00080 |
|---|
| 2635 | '(pair (any) |
|---|
| 2636 | any) |
|---|
| 2637 | (vector)))) |
|---|
| 2638 | g00077)))) |
|---|
| 2639 | p))))) |
|---|
| 2640 | (not (eq? (check? |
|---|
| 2641 | pattern |
|---|
| 2642 | '()) |
|---|
| 2643 | 'no))))) |
|---|
| 2644 | (valid-keyword? (lambda (k) |
|---|
| 2645 | (if (identifier? k) |
|---|
| 2646 | (not (free-identifier=? |
|---|
| 2647 | k |
|---|
| 2648 | '...)) |
|---|
| 2649 | #f))) |
|---|
| 2650 | (convert-syntax-dispatch-pattern (lambda (pattern |
|---|
| 2651 | keys) |
|---|
| 2652 | ((letrec ((gen (lambda (p) |
|---|
| 2653 | (if (identifier? |
|---|
| 2654 | p) |
|---|
| 2655 | (if (key? p |
|---|
| 2656 | keys) |
|---|
| 2657 | (cons '#(syntax-object |
|---|
| 2658 | free-id |
|---|
| 2659 | (top)) |
|---|
| 2660 | (key-index |
|---|
| 2661 | p |
|---|
| 2662 | keys)) |
|---|
| 2663 | (list '#(syntax-object |
|---|
| 2664 | any |
|---|
| 2665 | (top)))) |
|---|
| 2666 | ((lambda (g00086) |
|---|
| 2667 | ((lambda (g00087) |
|---|
| 2668 | ((lambda (g00085) |
|---|
| 2669 | (if (not (eq? g00085 |
|---|
| 2670 | 'no)) |
|---|
| 2671 | ((lambda (_x |
|---|
| 2672 | _dots) |
|---|
| 2673 | (if (ellipsis? |
|---|
| 2674 | _dots) |
|---|
| 2675 | (cons '#(syntax-object |
|---|
| 2676 | each |
|---|
| 2677 | (top)) |
|---|
| 2678 | (gen _x)) |
|---|
| 2679 | (g00087))) |
|---|
| 2680 | (car g00085) |
|---|
| 2681 | (cadr g00085)) |
|---|
| 2682 | (g00087))) |
|---|
| 2683 | (syntax-dispatch |
|---|
| 2684 | g00086 |
|---|
| 2685 | '(pair (any) |
|---|
| 2686 | pair |
|---|
| 2687 | (any) |
|---|
| 2688 | atom) |
|---|
| 2689 | (vector)))) |
|---|
| 2690 | (lambda () |
|---|
| 2691 | ((lambda (g00089) |
|---|
| 2692 | ((lambda (g00088) |
|---|
| 2693 | (if (not (eq? g00088 |
|---|
| 2694 | 'no)) |
|---|
| 2695 | ((lambda (_x |
|---|
| 2696 | _y) |
|---|
| 2697 | (cons '#(syntax-object |
|---|
| 2698 | pair |
|---|
| 2699 | (top)) |
|---|
| 2700 | (cons (gen _x) |
|---|
| 2701 | (gen _y)))) |
|---|
| 2702 | (car g00088) |
|---|
| 2703 | (cadr g00088)) |
|---|
| 2704 | ((lambda (g00091) |
|---|
| 2705 | ((lambda (g00090) |
|---|
| 2706 | (if (not (eq? g00090 |
|---|
| 2707 | 'no)) |
|---|
| 2708 | ((lambda (_x) |
|---|
| 2709 | (cons '#(syntax-object |
|---|
| 2710 | vector |
|---|
| 2711 | (top)) |
|---|
| 2712 | (gen _x))) |
|---|
| 2713 | (car g00090)) |
|---|
| 2714 | ((lambda (g00093) |
|---|
| 2715 | ((lambda (g00092) |
|---|
| 2716 | (if (not (eq? g00092 |
|---|
| 2717 | 'no)) |
|---|
| 2718 | ((lambda (_x) |
|---|
| 2719 | (cons '#(syntax-object |
|---|
| 2720 | atom |
|---|
| 2721 | (top)) |
|---|
| 2722 | p)) |
|---|
| 2723 | (car g00092)) |
|---|
| 2724 | (syntax-error |
|---|
| 2725 | g00093))) |
|---|
| 2726 | (syntax-dispatch |
|---|
| 2727 | g00093 |
|---|
| 2728 | '(any) |
|---|
| 2729 | (vector)))) |
|---|
| 2730 | g00091))) |
|---|
| 2731 | (syntax-dispatch |
|---|
| 2732 | g00091 |
|---|
| 2733 | '(vector |
|---|
| 2734 | each |
|---|
| 2735 | any) |
|---|
| 2736 | (vector)))) |
|---|
| 2737 | g00089))) |
|---|
| 2738 | (syntax-dispatch |
|---|
| 2739 | g00089 |
|---|
| 2740 | '(pair (any) |
|---|
| 2741 | any) |
|---|
| 2742 | (vector)))) |
|---|
| 2743 | g00086)))) |
|---|
| 2744 | p))))) |
|---|
| 2745 | gen) |
|---|
| 2746 | pattern))) |
|---|
| 2747 | (key-index (lambda (p keys) |
|---|
| 2748 | (- (length keys) |
|---|
| 2749 | (length (memid p keys))))) |
|---|
| 2750 | (key? (lambda (p keys) |
|---|
| 2751 | (if (identifier? p) (memid p keys) #f))) |
|---|
| 2752 | (memid (lambda (i ids) |
|---|
| 2753 | (if (not (null? ids)) |
|---|
| 2754 | (if (bound-identifier=? i (car ids)) |
|---|
| 2755 | ids |
|---|
| 2756 | (memid i (cdr ids))) |
|---|
| 2757 | #f))) |
|---|
| 2758 | (ellipsis? (lambda (x) |
|---|
| 2759 | (if (identifier? x) |
|---|
| 2760 | (free-identifier=? x '...) |
|---|
| 2761 | #f)))) |
|---|
| 2762 | (lambda (x) |
|---|
| 2763 | ((lambda (g00030) |
|---|
| 2764 | ((lambda (g00031) |
|---|
| 2765 | ((lambda (g00029) |
|---|
| 2766 | (if (not (eq? g00029 'no)) |
|---|
| 2767 | ((lambda (__ _val _key) |
|---|
| 2768 | (if (andmap valid-keyword? _key) |
|---|
| 2769 | (list '#(syntax-object |
|---|
| 2770 | syntax-error |
|---|
| 2771 | (top)) |
|---|
| 2772 | _val) |
|---|
| 2773 | (g00031))) |
|---|
| 2774 | (car g00029) |
|---|
| 2775 | (cadr g00029) |
|---|
| 2776 | (caddr g00029)) |
|---|
| 2777 | (g00031))) |
|---|
| 2778 | (syntax-dispatch |
|---|
| 2779 | g00030 |
|---|
| 2780 | '(pair (any) |
|---|
| 2781 | pair |
|---|
| 2782 | (any) |
|---|
| 2783 | pair |
|---|
| 2784 | (each any) |
|---|
| 2785 | atom) |
|---|
| 2786 | (vector)))) |
|---|
| 2787 | (lambda () |
|---|
| 2788 | ((lambda (g00033) |
|---|
| 2789 | ((lambda (g00034) |
|---|
| 2790 | ((lambda (g00032) |
|---|
| 2791 | (if (not (eq? g00032 'no)) |
|---|
| 2792 | (apply |
|---|
| 2793 | (lambda (__ |
|---|
| 2794 | _val |
|---|
| 2795 | _key |
|---|
| 2796 | _pat |
|---|
| 2797 | _exp) |
|---|
| 2798 | (if (if (identifier? |
|---|
| 2799 | _pat) |
|---|
| 2800 | (if (andmap |
|---|
| 2801 | valid-keyword? |
|---|
| 2802 | _key) |
|---|
| 2803 | (andmap |
|---|
| 2804 | (lambda (x) |
|---|
| 2805 | (not (free-identifier=? |
|---|
| 2806 | _pat |
|---|
| 2807 | x))) |
|---|
| 2808 | (cons '... |
|---|
| 2809 | _key)) |
|---|
| 2810 | #f) |
|---|
| 2811 | #f) |
|---|
| 2812 | (list (list '#(syntax-object |
|---|
| 2813 | syntax-lambda |
|---|
| 2814 | (top)) |
|---|
| 2815 | (list (list _pat |
|---|
| 2816 | 0)) |
|---|
| 2817 | _exp) |
|---|
| 2818 | _val) |
|---|
| 2819 | (g00034))) |
|---|
| 2820 | g00032) |
|---|
| 2821 | (g00034))) |
|---|
| 2822 | (syntax-dispatch |
|---|
| 2823 | g00033 |
|---|
| 2824 | '(pair (any) |
|---|
| 2825 | pair |
|---|
| 2826 | (any) |
|---|
| 2827 | pair |
|---|
| 2828 | (each any) |
|---|
| 2829 | pair |
|---|
| 2830 | (pair (any) pair (any) atom) |
|---|
| 2831 | atom) |
|---|
| 2832 | (vector)))) |
|---|
| 2833 | (lambda () |
|---|
| 2834 | ((lambda (g00036) |
|---|
| 2835 | ((lambda (g00037) |
|---|
| 2836 | ((lambda (g00035) |
|---|
| 2837 | (if (not (eq? g00035 'no)) |
|---|
| 2838 | (apply |
|---|
| 2839 | (lambda (__ |
|---|
| 2840 | _val |
|---|
| 2841 | _key |
|---|
| 2842 | _pat |
|---|
| 2843 | _exp |
|---|
| 2844 | _e1 |
|---|
| 2845 | _e2 |
|---|
| 2846 | _e3) |
|---|
| 2847 | (if (if (andmap |
|---|
| 2848 | valid-keyword? |
|---|
| 2849 | _key) |
|---|
| 2850 | (valid-syntax-pattern? |
|---|
| 2851 | _pat |
|---|
| 2852 | _key) |
|---|
| 2853 | #f) |
|---|
| 2854 | ((lambda (g00044) |
|---|
| 2855 | ((lambda (g00043) |
|---|
| 2856 | (if (not (eq? g00043 |
|---|
| 2857 | 'no)) |
|---|
| 2858 | ((lambda (_pattern |
|---|
| 2859 | _y |
|---|
| 2860 | _call) |
|---|
| 2861 | (list '#(syntax-object |
|---|
| 2862 | let |
|---|
| 2863 | (top)) |
|---|
| 2864 | (list (list '#(syntax-object |
|---|
| 2865 | x |
|---|
| 2866 | (top)) |
|---|
| 2867 | _val)) |
|---|
| 2868 | (list '#(syntax-object |
|---|
| 2869 | let |
|---|
| 2870 | (top)) |
|---|
| 2871 | (list (list _y |
|---|
| 2872 | (list '#(syntax-object |
|---|
| 2873 | syntax-dispatch |
|---|
| 2874 | (top)) |
|---|
| 2875 | '#(syntax-object |
|---|
| 2876 | x |
|---|
| 2877 | (top)) |
|---|
| 2878 | (list '#(syntax-object |
|---|
| 2879 | quote |
|---|
| 2880 | (top)) |
|---|
| 2881 | _pattern) |
|---|
| 2882 | (list '#(syntax-object |
|---|
| 2883 | syntax |
|---|
| 2884 | (top)) |
|---|
| 2885 | (list->vector |
|---|
| 2886 | _key))))) |
|---|
| 2887 | (list '#(syntax-object |
|---|
| 2888 | if |
|---|
| 2889 | (top)) |
|---|
| 2890 | (list '#(syntax-object |
|---|
| 2891 | not |
|---|
| 2892 | (top)) |
|---|
| 2893 | (list '#(syntax-object |
|---|
| 2894 | eq? |
|---|
| 2895 | (top)) |
|---|
| 2896 | _y |
|---|
| 2897 | (list '#(syntax-object |
|---|
| 2898 | quote |
|---|
| 2899 | (top)) |
|---|
| 2900 | '#(syntax-object |
|---|
| 2901 | no |
|---|
| 2902 | (top))))) |
|---|
| 2903 | _call |
|---|
| 2904 | (cons '#(syntax-object |
|---|
| 2905 | syntax-case |
|---|
| 2906 | (top)) |
|---|
| 2907 | (cons '#(syntax-object |
|---|
| 2908 | x |
|---|
| 2909 | (top)) |
|---|
| 2910 | (cons _key |
|---|
| 2911 | (map (lambda (__e1 |
|---|
| 2912 | __e2 |
|---|
| 2913 | __e3) |
|---|
| 2914 | (cons __e1 |
|---|
| 2915 | (cons __e2 |
|---|
| 2916 | __e3))) |
|---|
| 2917 | _e1 |
|---|
| 2918 | _e2 |
|---|
| 2919 | _e3)))))))) |
|---|
| 2920 | (car g00043) |
|---|
| 2921 | (cadr g00043) |
|---|
| 2922 | (caddr |
|---|
| 2923 | g00043)) |
|---|
| 2924 | (syntax-error |
|---|
| 2925 | g00044))) |
|---|
| 2926 | (syntax-dispatch |
|---|
| 2927 | g00044 |
|---|
| 2928 | '(pair (any) |
|---|
| 2929 | pair |
|---|
| 2930 | (any) |
|---|
| 2931 | pair |
|---|
| 2932 | (any) |
|---|
| 2933 | atom) |
|---|
| 2934 | (vector)))) |
|---|
| 2935 | (list (convert-syntax-dispatch-pattern |
|---|
| 2936 | _pat |
|---|
| 2937 | _key) |
|---|
| 2938 | '#(syntax-object |
|---|
| 2939 | y |
|---|
| 2940 | (top)) |
|---|
| 2941 | (build-dispatch-call |
|---|
| 2942 | (extract-bound-syntax-ids |
|---|
| 2943 | _pat |
|---|
| 2944 | _key) |
|---|
| 2945 | _exp |
|---|
| 2946 | '#(syntax-object |
|---|
| 2947 | y |
|---|
| 2948 | (top))))) |
|---|
| 2949 | (g00037))) |
|---|
| 2950 | g00035) |
|---|
| 2951 | (g00037))) |
|---|
| 2952 | (syntax-dispatch |
|---|
| 2953 | g00036 |
|---|
| 2954 | '(pair (any) |
|---|
| 2955 | pair |
|---|
| 2956 | (any) |
|---|
| 2957 | pair |
|---|
| 2958 | (each any) |
|---|
| 2959 | pair |
|---|
| 2960 | (pair (any) |
|---|
| 2961 | pair |
|---|
| 2962 | (any) |
|---|
| 2963 | atom) |
|---|
| 2964 | each |
|---|
| 2965 | pair |
|---|
| 2966 | (any) |
|---|
| 2967 | pair |
|---|
| 2968 | (any) |
|---|
| 2969 | each |
|---|
| 2970 | any) |
|---|
| 2971 | (vector)))) |
|---|
| 2972 | (lambda () |
|---|
| 2973 | ((lambda (g00039) |
|---|
| 2974 | ((lambda (g00040) |
|---|
| 2975 | ((lambda (g00038) |
|---|
| 2976 | (if (not (eq? g00038 |
|---|
| 2977 | 'no)) |
|---|
| 2978 | (apply |
|---|
| 2979 | (lambda (__ |
|---|
| 2980 | _val |
|---|
| 2981 | _key |
|---|
| 2982 | _pat |
|---|
| 2983 | _fender |
|---|
| 2984 | _exp |
|---|
| 2985 | _e1 |
|---|
| 2986 | _e2 |
|---|
| 2987 | _e3) |
|---|
| 2988 | (if (if (andmap |
|---|
| 2989 | valid-keyword? |
|---|
| 2990 | _key) |
|---|
| 2991 | (valid-syntax-pattern? |
|---|
| 2992 | _pat |
|---|
| 2993 | _key) |
|---|
| 2994 | #f) |
|---|
| 2995 | ((lambda (g00042) |
|---|
| 2996 | ((lambda (g00041) |
|---|
| 2997 | (if (not (eq? g00041 |
|---|
| 2998 | 'no)) |
|---|
| 2999 | ((lambda (_pattern |
|---|
| 3000 | _y |
|---|
| 3001 | _dorest |
|---|
| 3002 | _call) |
|---|
| 3003 | (list '#(syntax-object |
|---|
| 3004 | let |
|---|
| 3005 | (top)) |
|---|
| 3006 | (list (list '#(syntax-object |
|---|
| 3007 | x |
|---|
| 3008 | (top)) |
|---|
| 3009 | _val)) |
|---|
| 3010 | (list '#(syntax-object |
|---|
| 3011 | let |
|---|
| 3012 | (top)) |
|---|
| 3013 | (list (list _dorest |
|---|
| 3014 | (list '#(syntax-object |
|---|
| 3015 | lambda |
|---|
| 3016 | (top)) |
|---|
| 3017 | '() |
|---|
| 3018 | (cons '#(syntax-object |
|---|
| 3019 | syntax-case |
|---|
| 3020 | (top)) |
|---|
| 3021 | (cons '#(syntax-object |
|---|
| 3022 | x |
|---|
| 3023 | (top)) |
|---|
| 3024 | (cons _key |
|---|
| 3025 | (map (lambda (__e1 |
|---|
| 3026 | __e2 |
|---|
| 3027 | __e3) |
|---|
| 3028 | (cons __e1 |
|---|
| 3029 | (cons __e2 |
|---|
| 3030 | __e3))) |
|---|
| 3031 | _e1 |
|---|
| 3032 | _e2 |
|---|
| 3033 | _e3))))))) |
|---|
| 3034 | (list '#(syntax-object |
|---|
| 3035 | let |
|---|
| 3036 | (top)) |
|---|
| 3037 | (list (list _y |
|---|
| 3038 | (list '#(syntax-object |
|---|
| 3039 | syntax-dispatch |
|---|
| 3040 | (top)) |
|---|
| 3041 | '#(syntax-object |
|---|
| 3042 | x |
|---|
| 3043 | (top)) |
|---|
| 3044 | (list '#(syntax-object |
|---|
| 3045 | quote |
|---|
| 3046 | (top)) |
|---|
| 3047 | _pattern) |
|---|
| 3048 | (list '#(syntax-object |
|---|
| 3049 | syntax |
|---|
| 3050 | (top)) |
|---|
| 3051 | (list->vector |
|---|
| 3052 | _key))))) |
|---|
| 3053 | (list '#(syntax-object |
|---|
| 3054 | if |
|---|
| 3055 | (top)) |
|---|
| 3056 | (list '#(syntax-object |
|---|
| 3057 | not |
|---|
| 3058 | (top)) |
|---|
| 3059 | (list '#(syntax-object |
|---|
| 3060 | eq? |
|---|
| 3061 | (top)) |
|---|
| 3062 | _y |
|---|
| 3063 | (list '#(syntax-object |
|---|
| 3064 | quote |
|---|
| 3065 | (top)) |
|---|
| 3066 | '#(syntax-object |
|---|
| 3067 | no |
|---|
| 3068 | (top))))) |
|---|
| 3069 | _call |
|---|
| 3070 | (list _dorest)))))) |
|---|
| 3071 | (car g00041) |
|---|
| 3072 | (cadr g00041) |
|---|
| 3073 | (caddr |
|---|
| 3074 | g00041) |
|---|
| 3075 | (cadddr |
|---|
| 3076 | g00041)) |
|---|
| 3077 | (syntax-error |
|---|
| 3078 | g00042))) |
|---|
| 3079 | (syntax-dispatch |
|---|
| 3080 | g00042 |
|---|
| 3081 | '(pair (any) |
|---|
| 3082 | pair |
|---|
| 3083 | (any) |
|---|
| 3084 | pair |
|---|
| 3085 | (any) |
|---|
| 3086 | pair |
|---|
| 3087 | (any) |
|---|
| 3088 | atom) |
|---|
| 3089 | (vector)))) |
|---|
| 3090 | (list (convert-syntax-dispatch-pattern |
|---|
| 3091 | _pat |
|---|
| 3092 | _key) |
|---|
| 3093 | '#(syntax-object |
|---|
| 3094 | y |
|---|
| 3095 | (top)) |
|---|
| 3096 | '#(syntax-object |
|---|
| 3097 | dorest |
|---|
| 3098 | (top)) |
|---|
| 3099 | (build-dispatch-call |
|---|
| 3100 | (extract-bound-syntax-ids |
|---|
| 3101 | _pat |
|---|
| 3102 | _key) |
|---|
| 3103 | (list '#(syntax-object |
|---|
| 3104 | if |
|---|
| 3105 | (top)) |
|---|
| 3106 | _fender |
|---|
| 3107 | _exp |
|---|
| 3108 | (list '#(syntax-object |
|---|
| 3109 | dorest |
|---|
| 3110 | (top)))) |
|---|
| 3111 | '#(syntax-object |
|---|
| 3112 | y |
|---|
| 3113 | (top))))) |
|---|
| 3114 | (g00040))) |
|---|
| 3115 | g00038) |
|---|
| 3116 | (g00040))) |
|---|
| 3117 | (syntax-dispatch |
|---|
| 3118 | g00039 |
|---|
| 3119 | '(pair (any) |
|---|
| 3120 | pair |
|---|
| 3121 | (any) |
|---|
| 3122 | pair |
|---|
| 3123 | (each any) |
|---|
| 3124 | pair |
|---|
| 3125 | (pair (any) |
|---|
| 3126 | pair |
|---|
| 3127 | (any) |
|---|
| 3128 | pair |
|---|
| 3129 | (any) |
|---|
| 3130 | atom) |
|---|
| 3131 | each |
|---|
| 3132 | pair |
|---|
| 3133 | (any) |
|---|
| 3134 | pair |
|---|
| 3135 | (any) |
|---|
| 3136 | each |
|---|
| 3137 | any) |
|---|
| 3138 | (vector)))) |
|---|
| 3139 | (lambda () |
|---|
| 3140 | (syntax-error |
|---|
| 3141 | g00039)))) |
|---|
| 3142 | g00036)))) |
|---|
| 3143 | g00033)))) |
|---|
| 3144 | g00030)))) |
|---|
| 3145 | x))))))) |
|---|
| 3146 | |
|---|
| 3147 | |
|---|
| 3148 | ;;; Install: |
|---|
| 3149 | |
|---|
| 3150 | |
|---|
| 3151 | ;;; CHICKEN specific macros: |
|---|
| 3152 | |
|---|
| 3153 | (define srfi-0-def #<<EOF |
|---|
| 3154 | (define-syntax cond-expand |
|---|
| 3155 | (lambda (x) |
|---|
| 3156 | (syntax-case x (else not or and) |
|---|
| 3157 | [(_) |
|---|
| 3158 | (##sys#error |
|---|
| 3159 | (##core#immutable '"no matching clause in `cond-expand' form") ) ] |
|---|
| 3160 | [(_ (else body ...)) |
|---|
| 3161 | (syntax (begin body ...)) ] |
|---|
| 3162 | [(_ ((and) body ...) more ...) |
|---|
| 3163 | (syntax (begin body ...)) ] |
|---|
| 3164 | [(_ ((and req1 req2 ...) body ...) more ...) |
|---|
| 3165 | (syntax (cond-expand |
|---|
| 3166 | (req1 |
|---|
| 3167 | (cond-expand |
|---|
| 3168 | ((and req2 ...) body ...) |
|---|
| 3169 | more ...)) |
|---|
| 3170 | more ...) ) ] |
|---|
| 3171 | [(_ ((or) body ...) more ...) |
|---|
| 3172 | (syntax (cond-expand more ...)) ] |
|---|
| 3173 | [(_ ((or req1 req2 ...) body ...) more ...) |
|---|
| 3174 | (syntax (cond-expand |
|---|
| 3175 | (req1 (begin body ...)) |
|---|
| 3176 | (else (cond-expand |
|---|
| 3177 | ((or req2 ...) body ...) |
|---|
| 3178 | more ...) ) ) ) ] |
|---|
| 3179 | [(_ ((not req) body ...) more ...) |
|---|
| 3180 | (syntax (cond-expand |
|---|
| 3181 | (req (cond-expand more ...)) |
|---|
| 3182 | (else body ...) ) ) ] |
|---|
| 3183 | [(_ (req body ...) more ...) |
|---|
| 3184 | (if (##sys#test-feature (syntax-object->datum (syntax req))) |
|---|
| 3185 | (syntax (begin body ...)) |
|---|
| 3186 | (syntax (cond-expand more ...)) ) ] ) ) ) |
|---|
| 3187 | EOF |
|---|
| 3188 | ) |
|---|
| 3189 | |
|---|
| 3190 | ;;; macro-defs.ss |
|---|
| 3191 | ;;; Robert Hieb & Kent Dybvig |
|---|
| 3192 | ;;; 92/06/18 |
|---|
| 3193 | |
|---|
| 3194 | (define std-defs #<<EOF |
|---|
| 3195 | (begin |
|---|
| 3196 | |
|---|
| 3197 | (define-syntax with-syntax |
|---|
| 3198 | (lambda (x) |
|---|
| 3199 | (syntax-case x () |
|---|
| 3200 | ((_ () e1 e2 ...) |
|---|
| 3201 | (syntax (begin e1 e2 ...))) |
|---|
| 3202 | ((_ ((out in)) e1 e2 ...) |
|---|
| 3203 | (syntax (syntax-case in () (out (begin e1 e2 ...))))) |
|---|
| 3204 | ((_ ((out in) ...) e1 e2 ...) |
|---|
| 3205 | (syntax (syntax-case (list in ...) () |
|---|
| 3206 | ((out ...) (begin e1 e2 ...)))))))) |
|---|
| 3207 | |
|---|
| 3208 | (define-syntax syntax-rules |
|---|
| 3209 | (lambda (x) |
|---|
| 3210 | (syntax-case x () |
|---|
| 3211 | ((_ (k ...) ((keyword . pattern) template) ...) |
|---|
| 3212 | (with-syntax (((dummy ...) |
|---|
| 3213 | (generate-temporaries (syntax (keyword ...))))) |
|---|
| 3214 | (syntax (lambda (x) |
|---|
| 3215 | (syntax-case x (k ...) |
|---|
| 3216 | ((dummy . pattern) (syntax template)) |
|---|
| 3217 | ...)))))))) |
|---|
| 3218 | |
|---|
| 3219 | (define-syntax or |
|---|
| 3220 | (lambda (x) |
|---|
| 3221 | (syntax-case x () |
|---|
| 3222 | ((_) (syntax #f)) |
|---|
| 3223 | ((_ e) (syntax e)) |
|---|
| 3224 | ((_ e1 e2 e3 ...) |
|---|
| 3225 | (syntax (let ((t e1)) (if t t (or e2 e3 ...)))))))) |
|---|
| 3226 | |
|---|
| 3227 | (define-syntax and |
|---|
| 3228 | (lambda (x) |
|---|
| 3229 | (syntax-case x () |
|---|
| 3230 | ((_ e1 e2 e3 ...) (syntax (if e1 (and e2 e3 ...) #f))) |
|---|
| 3231 | ((_ e) (syntax e)) |
|---|
| 3232 | ((_) (syntax #t))))) |
|---|
| 3233 | |
|---|
| 3234 | (define-syntax cond |
|---|
| 3235 | (lambda (x) |
|---|
| 3236 | (syntax-case x (else =>) |
|---|
| 3237 | ((_ (else e1 e2 ...)) |
|---|
| 3238 | (syntax (begin e1 e2 ...))) |
|---|
| 3239 | ((_ (e0)) |
|---|
| 3240 | (syntax (let ((t e0)) (if t t)))) |
|---|
| 3241 | ((_ (e0) c1 c2 ...) |
|---|
| 3242 | (syntax (let ((t e0)) (if t t (cond c1 c2 ...))))) |
|---|
| 3243 | ((_ (e0 => e1)) (syntax (let ((t e0)) (if t (e1 t))))) |
|---|
| 3244 | ((_ (e0 => e1) c1 c2 ...) |
|---|
| 3245 | (syntax (let ((t e0)) (if t (e1 t) (cond c1 c2 ...))))) |
|---|
| 3246 | ((_ (e0 e1 e2 ...)) (syntax (if e0 (begin e1 e2 ...)))) |
|---|
| 3247 | ((_ (e0 e1 e2 ...) c1 c2 ...) |
|---|
| 3248 | (syntax (if e0 (begin e1 e2 ...) (cond c1 c2 ...))))))) |
|---|
| 3249 | |
|---|
| 3250 | (define-syntax let* |
|---|
| 3251 | (lambda (x) |
|---|
| 3252 | (syntax-case x () |
|---|
| 3253 | ((let* () e1 e2 ...) |
|---|
| 3254 | (syntax (let () e1 e2 ...))) |
|---|
| 3255 | ((let* ((x1 v1) (x2 v2) ...) e1 e2 ...) |
|---|
| 3256 | (andmap identifier? (syntax (x1 x2 ...))) |
|---|
| 3257 | (syntax (let ((x1 v1)) (let* ((x2 v2) ...) e1 e2 ...))))))) |
|---|
| 3258 | |
|---|
| 3259 | (define-syntax case |
|---|
| 3260 | (lambda (x) |
|---|
| 3261 | (syntax-case x (else) |
|---|
| 3262 | ((_ v (else e1 e2 ...)) |
|---|
| 3263 | (syntax (begin e1 e2 ...))) |
|---|
| 3264 | ((_ v ((k1 ...) e1 e2 ...)) |
|---|
| 3265 | (syntax (let ((x v)) |
|---|
| 3266 | (if (or (eqv? x 'k1) ...) (begin e1 e2 ...)) ) ) ) |
|---|
| 3267 | ((_ v ((k1 ...) e1 e2 ...) c1 c2 ...) |
|---|
| 3268 | (syntax (let ((x v)) |
|---|
| 3269 | (if (or (eqv? x 'k1) ...) |
|---|
| 3270 | (begin e1 e2 ...) |
|---|
| 3271 | (case x c1 c2 ...))))))) ) |
|---|
| 3272 | |
|---|
| 3273 | (define-syntax do |
|---|
| 3274 | (lambda (orig-x) |
|---|
| 3275 | (syntax-case orig-x () |
|---|
| 3276 | ((_ ((var init . step) ...) (e0 e1 ...) c ...) |
|---|
| 3277 | (with-syntax (((step ...) |
|---|
| 3278 | (map (lambda (v s) |
|---|
| 3279 | (syntax-case s () |
|---|
| 3280 | (() v) |
|---|
| 3281 | ((e) (syntax e)) |
|---|
| 3282 | (_ (syntax-error orig-x)))) |
|---|
| 3283 | (syntax (var ...)) |
|---|
| 3284 | (syntax (step ...))))) |
|---|
| 3285 | (syntax-case (syntax (e1 ...)) () |
|---|
| 3286 | (() (syntax (let doloop ((var init) ...) |
|---|
| 3287 | (if (not e0) |
|---|
| 3288 | (begin c ... (doloop step ...)))))) |
|---|
| 3289 | ((e1 e2 ...) |
|---|
| 3290 | (syntax (let doloop ((var init) ...) |
|---|
| 3291 | (if e0 |
|---|
| 3292 | (begin e1 e2 ...) |
|---|
| 3293 | (begin c ... (doloop step ...)))))))))))) |
|---|
| 3294 | |
|---|
| 3295 | (define-syntax quasiquote |
|---|
| 3296 | (letrec |
|---|
| 3297 | ((gen-cons |
|---|
| 3298 | (lambda (x y) |
|---|
| 3299 | (syntax-case x (quote) |
|---|
| 3300 | ((quote x) |
|---|
| 3301 | (syntax-case y (quote ##sys#list) |
|---|
| 3302 | ((quote y) (syntax (quote (x . y)))) |
|---|
| 3303 | ((##sys#list y ...) (syntax (##sys#list (quote x) y ...))) |
|---|
| 3304 | (y (syntax (##sys#cons (quote x) y))))) |
|---|
| 3305 | (x (syntax-case y (quote ##sys#list) |
|---|
| 3306 | ((quote ()) (syntax (##sys#list x))) |
|---|
| 3307 | ((##sys#list y ...) (syntax (##sys#list x y ...))) |
|---|
| 3308 | (y (syntax (##sys#cons x y)))))))) |
|---|
| 3309 | |
|---|
| 3310 | (gen-append |
|---|
| 3311 | (lambda (x y) |
|---|
| 3312 | (syntax-case x (quote ##sys#list ##sys#cons) |
|---|
| 3313 | ((quote (x1 x2 ...)) |
|---|
| 3314 | (syntax-case y (quote) |
|---|
| 3315 | ((quote y) (syntax (quote (x1 x2 ... . y)))) |
|---|
| 3316 | (y (syntax (##sys#append (quote (x1 x2 ...) y)))))) |
|---|
| 3317 | ((quote ()) y) |
|---|
| 3318 | ((##sys#list x1 x2 ...) |
|---|
| 3319 | (gen-cons (syntax x1) (gen-append (syntax (##sys#list x2 ...)) y))) |
|---|
| 3320 | (x (syntax-case y (quote ##sys#list) |
|---|
| 3321 | ((quote ()) (syntax x)) |
|---|
| 3322 | (y (syntax (##sys#append x y)))))))) |
|---|
| 3323 | |
|---|
| 3324 | (gen-vector |
|---|
| 3325 | (lambda (x) |
|---|
| 3326 | (syntax-case x (quote ##sys#list) |
|---|
| 3327 | ((quote (x ...)) (syntax (quote #(x ...)))) |
|---|
| 3328 | ((##sys#list x ...) (syntax (##sys#vector x ...))) |
|---|
| 3329 | (x (syntax (##sys#list->vector x)))))) |
|---|
| 3330 | |
|---|
| 3331 | (gen |
|---|
| 3332 | (lambda (p lev) |
|---|
| 3333 | (syntax-case p (unquote unquote-splicing quasiquote) |
|---|
| 3334 | ((unquote p) |
|---|
| 3335 | (if (fx= lev 0) |
|---|
| 3336 | (syntax p) |
|---|
| 3337 | (gen-cons (syntax (quote unquote)) |
|---|
| 3338 | (gen (syntax (p)) (fx- lev 1))))) |
|---|
| 3339 | (((unquote-splicing p) . q) |
|---|
| 3340 | (if (fx= lev 0) |
|---|
| 3341 | (gen-append (syntax p) (gen (syntax q) lev)) |
|---|
| 3342 | (gen-cons (gen-cons (syntax (quote unquote-splicing)) |
|---|
| 3343 | (gen (syntax p) (fx- lev 1))) |
|---|
| 3344 | (gen (syntax q) lev)))) |
|---|
| 3345 | ((quasiquote p) |
|---|
| 3346 | (gen-cons (syntax (quote quasiquote)) |
|---|
| 3347 | (gen (syntax (p)) (fx+ lev 1)))) |
|---|
| 3348 | ((p . q) |
|---|
| 3349 | (gen-cons (gen (syntax p) lev) (gen (syntax q) lev))) |
|---|
| 3350 | (#(x ...) (gen-vector (gen (syntax (x ...)) lev))) |
|---|
| 3351 | (p (syntax (quote p))))))) |
|---|
| 3352 | |
|---|
| 3353 | (lambda (x) |
|---|
| 3354 | (syntax-case x () |
|---|
| 3355 | ((- e) (gen (syntax e) 0)))))) |
|---|
| 3356 | |
|---|
| 3357 | (define-syntax delay |
|---|
| 3358 | (lambda (x) |
|---|
| 3359 | (syntax-case x () |
|---|
| 3360 | ((delay exp) |
|---|
| 3361 | (syntax (##sys#make-promise (lambda () exp))))))) |
|---|
| 3362 | ) |
|---|
| 3363 | EOF |
|---|
| 3364 | ) |
|---|
| 3365 | |
|---|
| 3366 | (define install-macro-defs |
|---|
| 3367 | (let ([open-input-string open-input-string] |
|---|
| 3368 | [read read] |
|---|
| 3369 | [expand-syntax expand-syntax] ) |
|---|
| 3370 | (lambda (defstr) |
|---|
| 3371 | (let ([in (open-input-string defstr)]) |
|---|
| 3372 | (expand-syntax (read in)) ) ) ) ) |
|---|
| 3373 | |
|---|
| 3374 | (define install-macro-package |
|---|
| 3375 | (let ([installed #f]) |
|---|
| 3376 | (lambda args |
|---|
| 3377 | (unless installed |
|---|
| 3378 | (let-optionals* args ([std #f] [srfi0 #f]) |
|---|
| 3379 | (set! installed #t) |
|---|
| 3380 | (expand-install-hook expand-syntax) |
|---|
| 3381 | (set! macro? |
|---|
| 3382 | (lambda (name) |
|---|
| 3383 | (##sys#check-symbol name) |
|---|
| 3384 | (let ((x (get-global-definition-hook name))) |
|---|
| 3385 | (and x (eq? (car x) 'macro)) ) ) ) |
|---|
| 3386 | (set! macroexpand (lambda (exp . me) (expand-syntax exp))) |
|---|
| 3387 | (set! undefine-macro! (lambda names (##sys#error "can not undefine high-level macros" names))) |
|---|
| 3388 | (register-feature! #:hygienic-macros) |
|---|
| 3389 | (install-macro-defs std-defs) |
|---|
| 3390 | (when srfi0 (install-macro-defs srfi-0-def)) |
|---|
| 3391 | (unless std (load (##sys#resolve-include-filename "highlevel-macros"))) ) ) ) ) ) |
|---|
