lib/_eval.scm

   1 ;;;============================================================================
   2
   3 ;;; File: "_eval.scm", Time-stamp: <2009-02-26 13:40:18 feeley>
   4
   5 ;;; Copyright (c) 1994-2009 by Marc Feeley, All Rights Reserved.
   6
   7 ;;;============================================================================
   8
   9 (##include "header.scm")
  10
  11 ;;(##define-macro (macro-step! leapable? handler-index vars . body) `(let () ,@body)) ;; disable single-stepping
  12
  13 ;;;============================================================================
  14
  15 ;;; Implementation of exceptions.
  16
  17 (implement-library-type-expression-parsing-exception)
  18
  19 (define-prim (##raise-expression-parsing-exception kind source . parameters)
  20   (macro-raise
  21    (macro-make-expression-parsing-exception kind source parameters)))
  22
  23 (implement-library-type-unbound-global-exception)
  24
  25 (define-prim (##raise-unbound-global-exception code rte variable)
  26   (macro-raise (macro-make-unbound-global-exception code rte variable)))
  27
  28 ;;;----------------------------------------------------------------------------
  29
  30 (define (##make-code* code-prc cte src stepper lst n)
  31   (let ((code (##make-vector (##fixnum.+ (##length lst) (##fixnum.+ n 5)) #f)))
  32     (##vector-set! code 0 #f)
  33     (##vector-set! code 1 code-prc)
  34     (##vector-set! code 2 cte)
  35     (##vector-set! code 3 src)
  36     (##vector-set! code 4 stepper)
  37     (let loop ((i 0) (l lst))
  38       (if (##pair? l)
  39         (let ((child (##car l)))
  40           (##vector-set! child 0 code)
  41           (macro-code-set! code i child)
  42           (loop (##fixnum.+ i 1) (##cdr l)))
  43         code))))
  44
  45 (define (##no-stepper) (macro-make-no-stepper))
  46
  47 (define ##main-stepper (##no-stepper))
  48 (set! ##main-stepper ##main-stepper)
  49
  50 (define (##current-stepper) ##main-stepper)
  51
  52 ;;;----------------------------------------------------------------------------
  53
  54 ;;; Structure representing source code.
  55
  56 (define ##source1-marker '#(source1)) ;; source markers
  57 (define ##source2-marker '#(source2))
  58
  59 (define (##make-source code locat)
  60   (##vector ##source1-marker
  61             code
  62             (if locat (##locat-container locat) #f)
  63             (if locat (##locat-position locat) #f)))
  64
  65 (define (##sourcify x src)
  66   (if (##source? x)
  67     x
  68     (##vector ##source2-marker
  69               x
  70               (##vector-ref src 2)
  71               (##vector-ref src 3))))
  72
  73 (define (##sourcify-deep x src)
  74
  75   (define (sourcify-deep-list lst src)
  76     (cond ((##pair? lst)
  77            (let* ((a (##car lst))
  78                   (d (##cdr lst))
  79                   (sa (sourcify-deep a src))
  80                   (sd (sourcify-deep-list d src)))
  81              (if (and (##eq? a sa) (##eq? d sd))
  82                  lst
  83                  (##cons sa sd))))
  84           ((##null? lst)
  85            '())
  86           (else
  87            (sourcify-deep lst src))))
  88
  89   (define (sourcify-deep-vector vect src)
  90     (let* ((len (##vector-length vect))
  91            (x (##make-vector len 0))
  92            (same? #t))
  93       (let loop ((i (##fixnum.- len 1)))
  94         (if (##fixnum.< i 0)
  95             (if same? vect x)
  96             (let ((s (sourcify-deep (##vector-ref vect i) src)))
  97               (if (##not (##eq? s (##vector-ref vect i)))
  98                   (set! same? #f))
  99               (##vector-set! x i s)
 100               (loop (##fixnum.- i 1)))))))
 101
 102   (define (sourcify-deep-box b src)
 103     (let ((val (sourcify-deep (##unbox b) src)))
 104       (if (##eq? val (##unbox b))
 105           b
 106           (##box val))))
 107
 108   (define (sourcify-deep-aux x src)
 109     (cond ((##pair? x)
 110            (sourcify-deep-list x src))
 111           ((##vector? x)
 112            (sourcify-deep-vector x src))
 113           ((##box? x)
 114            (sourcify-deep-box x src))
 115           (else
 116            x)))
 117
 118   (define (sourcify-deep x src)
 119     (if (##source? x)
 120         (let* ((code (##source-code x))
 121                (code2 (sourcify-deep-aux code x)))
 122           (if (##eq? code code2) x (##sourcify code2 x)))
 123         (##sourcify (sourcify-deep-aux x src) src)))
 124
 125   (sourcify-deep x src))
 126
 127 (define (##source? x)
 128   (and (##vector? x)
 129        (##fixnum.< 0 (##vector-length x))
 130        (let ((y (##vector-ref x 0)))
 131          (and (##vector? y)
 132               (##fixnum.= 1 (##vector-length y))
 133               (let ((z (##vector-ref y 0)))
 134                 (or (##eq? z 'source1)
 135                     (##eq? z 'source2)))))))
 136
 137 (define (##source-code src)
 138   (##vector-ref src 1))
 139
 140 (define (##source-locat src)
 141   (let ((container (##vector-ref src 2)))
 142     (if container
 143       (##make-locat container
 144                     (##vector-ref src 3))
 145       #f)))
 146
 147 (define (##desourcify src)
 148
 149   (define (desourcify-list lst)
 150     (cond ((##pair? lst)
 151            (##cons (##desourcify (##car lst))
 152                    (desourcify-list (##cdr lst))))
 153           ((##null? lst)
 154            '())
 155           (else
 156            (##desourcify lst))))
 157
 158   (define (desourcify-vector vect)
 159     (let* ((len (##vector-length vect))
 160            (x (##make-vector len 0)))
 161       (let loop ((i (##fixnum.- len 1)))
 162         (if (##fixnum.< i 0)
 163           x
 164           (begin
 165             (##vector-set! x i (##desourcify (##vector-ref vect i)))
 166             (loop (##fixnum.- i 1)))))))
 167
 168   (if (##source? src)
 169     (let ((code (##source-code src)))
 170       (if (##eq? (##vector-ref src 0) ##source2-marker)
 171         code
 172         (cond ((##pair? code)
 173                (desourcify-list code))
 174               ((##vector? code)
 175                (desourcify-vector code))
 176               ((##box? code)
 177                (##box (##desourcify (##unbox code))))
 178               (else
 179                code))))
 180     src))
 181
 182 (define (##make-alias-syntax alias)
 183   (lambda (src)
 184     (let ((locat (##source-locat src)))
 185       (##make-source
 186        (##cons (##make-source alias locat)
 187                (##cdr (##source-code src)))
 188        locat))))
 189
 190 ;;;----------------------------------------------------------------------------
 191
 192 ;; A "locat" object represents a source code location.  The location
 193 ;; is a 2 element vector composed of the container of the source code
 194 ;; (a file, a text editor window, etc) and a position within that
 195 ;; container (a character offset, a line/column index, a text
 196 ;; bookmark, an expression, etc).
 197 ;;
 198 ;; Source code location containers and positions can be encoded with
 199 ;; any concrete type, except that positions cannot be pairs.  The
 200 ;; procedure "##container->path" takes a container object and returns
 201 ;; #f if the container does not denote a file, otherwise it returns the
 202 ;; absolute path of the file as a string.  The procedure
 203 ;; "##container->id" takes a container object and returns a string that
 204 ;; can be used to identify the container when it is not a file
 205 ;; (e.g. the name of a text editor window).  The procedure
 206 ;; "##position->filepos" takes a position object and returns a fixnum
 207 ;; encoding the line and column position (see function ##make-filepos).
 208
 209 (define-prim (##readenv->locat re)
 210   (let ((container
 211          (or (macro-readenv-container re)
 212              (let ((c
 213                     (##port-name->container
 214                      (##port-name (macro-readenv-port re)))))
 215                (macro-readenv-container-set! re c)
 216                c))))
 217     (##make-locat container
 218                   (##filepos->position
 219                    (macro-readenv-filepos re)))))
 220
 221 (define-prim (##make-locat container position)
 222   (##vector container position))
 223
 224 (define-prim (##locat? x)
 225   (##vector? x))
 226
 227 (define-prim (##locat-container locat)
 228   (let ((container (##vector-ref locat 0)))
 229     (if (##source? container)
 230       (##locat-container (##source-locat container))
 231       container)))
 232
 233 (define-prim (##locat-position locat)
 234   (let ((container (##vector-ref locat 0)))
 235     (if (##source? container)
 236       (##locat-position (##source-locat container))
 237       (##vector-ref locat 1))))
 238
 239 (define-prim (##port-name->container port-name)
 240   ;; port-name is an arbitrary object and result is an arbitrary object
 241   (if (##string? port-name)
 242       (##path->container port-name)
 243       port-name))
 244
 245 (define ##path->container-hook #f)
 246 (set! ##path->container-hook #f)
 247
 248 (define-prim (##path->container path)
 249   ;; path is a string and result is an arbitrary object
 250   (let ((hook ##path->container-hook))
 251     (or (and (##procedure? hook)
 252              (hook path))
 253         path)))
 254
 255 (define ##container->path-hook #f)
 256 (set! ##container->path-hook #f)
 257
 258 (define-prim (##container->path container)
 259   ;; container is an arbitrary object and result must be a string or #f
 260   (let ((x
 261          (let ((hook ##container->path-hook))
 262            (or (and (##procedure? hook)
 263                     (hook container))
 264                container))))
 265     (cond ((##string? x)
 266            x)
 267           (else
 268            #f))))
 269
 270 (define ##container->id-hook #f)
 271 (set! ##container->id-hook #f)
 272
 273 (define-prim (##container->id container)
 274   ;; container is an arbitrary object and result must be a string
 275   (let ((x
 276          (let ((hook ##container->id-hook))
 277            (and (##procedure? hook)
 278                 (hook container)))))
 279     (cond ((##string? x)
 280            x)
 281           (else
 282            (##object->string container)))))
 283
 284 (define-prim (##position->filepos position)
 285   (cond ((##fixnum? position)
 286          position)
 287         (else
 288          0)))
 289
 290 (define-prim (##filepos->position filepos)
 291   filepos)
 292
 293 ;;;============================================================================
 294
 295 ;;; Compiler
 296
 297 ;;;----------------------------------------------------------------------------
 298
 299 ;;; Compile time environments
 300
 301 ;;; - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
 302
 303 ;;; Representation of local variables (up and over) and global variables.
 304
 305 (##define-macro (mk-loc-access up over) `(##cons ,up ,over))
 306 (##define-macro (loc-access? x) `(##pair? ,x))
 307 (##define-macro (loc-access-up x) `(##car ,x))
 308 (##define-macro (loc-access-over x) `(##cdr ,x))
 309
 310 (##define-macro (mk-glo-access src id)
 311   `(##make-global-var ,id))
 312
 313 (##define-macro (glo-access? x)
 314   `(##not (##pair? ,x)))
 315
 316 ;;; - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
 317
 318 ;;; Representation of compile time environments
 319
 320 ;; There are 4 types of structures in a compile time environment:
 321 ;;
 322 ;;    top        end of the environment and container for current state
 323 ;;    frame      binding context for variables
 324 ;;    macro      binding context for a macro
 325 ;;    namespace  binding context for a namespace
 326
 327 (define (##cte-top top-cte)
 328   (##vector top-cte))
 329
 330 (define (##cte-top? cte)
 331   (##fixnum.= (##vector-length cte) 1))
 332
 333 (define (##cte-top-cte cte)
 334   (##vector-ref cte 0))
 335
 336 (define (##cte-top-cte-set! cte new-cte)
 337   (##vector-set! cte 0 new-cte))
 338
 339 (define (##cte-parent-cte cte)
 340   (##vector-ref cte 0))
 341
 342 (define (##cte-frame parent-cte vars)
 343   (##vector parent-cte vars))
 344
 345 (define (##cte-frame? cte)
 346   (##fixnum.= (##vector-length cte) 2))
 347
 348 (define (##cte-frame-vars cte)
 349   (##vector-ref cte 1))
 350
 351 (define (##cte-macro parent-cte name descr)
 352   (##vector parent-cte name descr))
 353
 354 (define (##cte-macro? cte)
 355   (and (##fixnum.= (##vector-length cte) 3)
 356        (##not (##string? (##vector-ref cte 1))))) ;; distinguish from namespace
 357
 358 (define (##cte-macro-name cte)
 359   (##vector-ref cte 1))
 360
 361 (define (##cte-macro-descr cte)
 362   (##vector-ref cte 2))
 363
 364 (define (##cte-decl parent-cte name value)
 365   (##vector parent-cte name value #f))
 366
 367 (define (##cte-decl? cte)
 368   (##fixnum.= (##vector-length cte) 4))
 369
 370 (define (##cte-decl-name cte)
 371   (##vector-ref cte 1))
 372
 373 (define (##cte-decl-value cte)
 374   (##vector-ref cte 2))
 375
 376 (define (##cte-namespace parent-cte prefix vars)
 377   (##vector parent-cte prefix vars))
 378
 379 (define (##cte-namespace? cte)
 380   (and (##fixnum.= (##vector-length cte) 3)
 381        (##string? (##vector-ref cte 1)))) ;; distinguish from macro
 382
 383 (define (##cte-namespace-prefix cte)
 384   (##vector-ref cte 1))
 385
 386 (define (##cte-namespace-vars cte)
 387   (##vector-ref cte 2))
 388
 389 (define (##cte-relink cte new-parent-cte)
 390   (if new-parent-cte
 391     (cond ((##cte-frame? cte)
 392            (##cte-frame new-parent-cte
 393                         (##cte-frame-vars cte)))
 394           ((##cte-macro? cte)
 395            (##cte-macro new-parent-cte
 396                         (##cte-macro-name cte)
 397                         (##cte-macro-descr cte)))
 398           ((##cte-decl? cte)
 399            (##cte-decl new-parent-cte
 400                        (##cte-decl-name cte)
 401                        (##cte-decl-value cte)))
 402           ((##cte-namespace? cte)
 403            (##cte-namespace new-parent-cte
 404                             (##cte-namespace-prefix cte)
 405                             (##cte-namespace-vars cte))))
 406     #f))
 407
 408 (define (##cte-add-macro parent-cte name descr)
 409
 410   (define (replace cte)
 411     (cond ((##cte-top? cte)
 412            (##cte-macro cte name descr))
 413           ((and (##cte-macro? cte) (##eq? name (##cte-macro-name cte)))
 414            (##cte-macro (##cte-parent-cte cte) name descr))
 415           (else
 416            (##cte-relink cte (replace (##cte-parent-cte cte))))))
 417
 418   (replace parent-cte))
 419
 420 (define (##cte-add-namespace parent-cte prefix vars)
 421
 422   (define (replace cte)
 423     (cond ((##cte-top? cte)
 424            #f)
 425           ((##cte-namespace? cte)
 426            (if (##pair? (##cte-namespace-vars cte))
 427              (replace (##cte-parent-cte cte))
 428              (##cte-namespace (##cte-parent-cte cte) prefix vars)))
 429           (else
 430            #f))) ;; don't go beyond a frame, macro definition or declaration
 431
 432   (if (##pair? vars)
 433     (##cte-namespace parent-cte prefix vars)
 434     (or (replace parent-cte)
 435         (##cte-namespace parent-cte prefix vars))))
 436
 437 (define (##check-namespace src)
 438   (let ((code (##source-code src)))
 439     (let loop1 ((forms (##cdr code)))
 440       (cond ((##pair? forms)
 441              (let* ((form-src (##sourcify (##car forms) src))
 442                     (form (##source-code form-src)))
 443                (if (##pair? form)
 444                  (let* ((space-src (##sourcify (##car form) form-src))
 445                         (space (##source-code space-src)))
 446                    (if (##string? space)
 447                      (if (##valid-prefix? space)
 448                        (let loop2 ((lst (##cdr form)))
 449                          (cond ((##pair? lst)
 450                                 (let* ((id-src
 451                                         (##sourcify (##car lst) form-src))
 452                                        (id
 453                                         (##source-code id-src)))
 454                                   (if (##not (##symbol? id))
 455                                     (##raise-expression-parsing-exception
 456                                      'id-expected
 457                                      id-src))
 458                                   (loop2 (##cdr lst))))
 459                                ((##not (##null? lst))
 460                                 (##raise-expression-parsing-exception
 461                                  'ill-formed-namespace
 462                                  form-src))
 463                                (else
 464                                 (loop1 (##cdr forms)))))
 465                          (##raise-expression-parsing-exception
 466                           'ill-formed-namespace-prefix
 467                           space-src))
 468                        (##raise-expression-parsing-exception
 469                         'namespace-prefix-must-be-string
 470                         space-src)))
 471                    (##raise-expression-parsing-exception
 472                     'ill-formed-namespace
 473                     form-src))))
 474             ((##not (##null? forms))
 475              (##raise-expression-parsing-exception
 476               'ill-formed-namespace
 477               src))))))
 478
 479 (define (##cte-process-declare parent-cte src)
 480   (let ((decls (##cdr (##desourcify src))))
 481     (let loop ((cte parent-cte) (decls decls))
 482       (if (##pair? decls)
 483         (let ((decl (##car decls)))
 484           (if (##pair? decl)
 485               (let ((d (##car decl)))
 486                 (cond ((and (##eq? d 'proper-tail-calls)
 487                             (##null? (##cdr decl)))
 488                        (loop (##cte-decl cte 'proper-tail-calls #t)
 489                              (##cdr decls)))
 490                       ((and (##eq? d 'not)
 491                             (##pair? (##cdr decl))
 492                             (##eq? (##cadr decl) 'proper-tail-calls)
 493                             (##null? (##cddr decl)))
 494                        (loop (##cte-decl cte 'proper-tail-calls #f)
 495                              (##cdr decls)))
 496                       (else
 497                        (loop cte
 498                              (##cdr decls)))))
 499               (loop cte
 500                     (##cdr decls))))
 501         cte))))
 502
 503 (define (##cte-process-namespace parent-cte src)
 504   (##check-namespace src)
 505   (let ((forms (##cdr (##desourcify src))))
 506     (let loop ((cte parent-cte) (forms forms))
 507       (if (##pair? forms)
 508         (let ((form (##car forms)))
 509           (loop (##cte-add-namespace cte (##car form) (##cdr form))
 510                 (##cdr forms)))
 511         cte))))
 512
 513 (define (##cte-get-top-cte cte)
 514   (if (##cte-top? cte)
 515     cte
 516     (##cte-get-top-cte (##cte-parent-cte cte))))
 517
 518 (define (##cte-mutate-top-cte! cte proc)
 519   (let ((top-cte (##cte-get-top-cte cte)))
 520     (##cte-top-cte-set! top-cte (proc (##cte-top-cte top-cte)))))
 521
 522 (define (##make-top-cte)
 523   (let ((top-cte (##cte-top #f)))
 524     (##cte-top-cte-set! top-cte top-cte)
 525     top-cte))
 526
 527 (define (##top-cte-add-macro! top-cte name def)
 528   (let ((global-name (##cte-global-macro-name (##cte-top-cte top-cte) name)))
 529     (##cte-mutate-top-cte!
 530       top-cte
 531       (lambda (cte) (##cte-add-macro cte global-name def)))))
 532
 533 (define (##top-cte-process-declare! top-cte src)
 534   (##cte-mutate-top-cte!
 535     top-cte
 536     (lambda (cte) (##cte-process-declare cte src))))
 537
 538 (define (##top-cte-process-namespace! top-cte src)
 539   (##cte-mutate-top-cte!
 540     top-cte
 541     (lambda (cte) (##cte-process-namespace cte src))))
 542
 543 (define (##top-cte-clone top-cte)
 544   (let ((new-top-cte (##cte-top #f)))
 545
 546     (define (clone cte)
 547       (if (##cte-top? cte)
 548         new-top-cte
 549         (##cte-relink cte (clone (##cte-parent-cte cte)))))
 550
 551     (##cte-top-cte-set! new-top-cte (clone (##cte-top-cte top-cte)))
 552     new-top-cte))
 553
 554 (define (##cte-lookup cte name)
 555   (##declare (inlining-limit 500)) ;; inline CTE access procedures
 556   (let loop ((name name) (full? (##full-name? name)) (cte cte) (up 0))
 557     (if (##cte-top? cte)
 558       (##vector 'not-found name)
 559       (let ((parent-cte (##cte-parent-cte cte)))
 560         (cond ((##cte-frame? cte)
 561                (let* ((vars (##cte-frame-vars cte))
 562                       (x (##memq name vars)))
 563                  (if x
 564                    (##vector
 565                      'var
 566                      name
 567                      up
 568                      (##fixnum.+ (##fixnum.- (##length vars) (##length x)) 1))
 569                    (loop name full? parent-cte (##fixnum.+ up 1)))))
 570               ((##cte-macro? cte)
 571                (if (##eq? name (##cte-macro-name cte))
 572                  (##vector 'macro name (##cte-macro-descr cte))
 573                  (loop name full? parent-cte up)))
 574               ((and (##not full?) (##cte-namespace? cte))
 575                (let ((vars (##cte-namespace-vars cte)))
 576                  (if (or (##not (##pair? vars)) (##memq name vars))
 577                    (loop (##make-full-name (##cte-namespace-prefix cte) name)
 578                          #t
 579                          parent-cte
 580                          up)
 581                    (loop name full? parent-cte up))))
 582               (else
 583                (loop name full? parent-cte up)))))))
 584
 585 (define (##cte-global-macro-name cte name)
 586   (if (##full-name? name)
 587     name
 588     (let loop ((cte cte))
 589       (if (##cte-top? cte)
 590         name
 591         (let ((parent-cte (##cte-parent-cte cte)))
 592           (cond ((##cte-namespace? cte)
 593                  (let ((vars (##cte-namespace-vars cte)))
 594                    (if (or (##not (##pair? vars)) (##memq name vars))
 595                      (##make-full-name (##cte-namespace-prefix cte) name)
 596                      (loop parent-cte))))
 597                 (else
 598                  (loop parent-cte))))))))
 599
 600 (define ##namespace-separators '(#\#))
 601 (set! ##namespace-separators ##namespace-separators)
 602
 603 (define (##full-name? sym) ;; full name if it contains a namespace separator
 604   (let ((str (##symbol->string sym)))
 605     (let loop ((i (##fixnum.- (##string-length str) 1)))
 606       (if (##fixnum.< i 0)
 607         #f
 608         (if (##memq (##string-ref str i) ##namespace-separators)
 609           #t
 610           (loop (##fixnum.- i 1)))))))
 611
 612 (define (##make-full-name prefix sym)
 613   (if (##fixnum.= (##string-length prefix) 0)
 614     sym
 615     (##string->symbol (##string-append prefix (##symbol->string sym)))))
 616
 617 (define (##valid-prefix? str)
 618
 619   ;; non-null name followed by a namespace separator at end is
 620   ;; valid as is the special prefix ""
 621
 622   (let ((l (##string-length str)))
 623     (or (##fixnum.= l 0)
 624         (and (##not (##fixnum.< l 2))
 625              (##memq (##string-ref str (##fixnum.- l 1))
 626                      ##namespace-separators)))))
 627
 628 (define (##var-lookup cte src)
 629   (let* ((name (##source-code src))
 630          (ind (##cte-lookup cte name)))
 631     (case (##vector-ref ind 0)
 632       ((not-found)
 633        (mk-glo-access src (##vector-ref ind 1)))
 634       ((var)
 635        (mk-loc-access (##vector-ref ind 2) (##vector-ref ind 3)))
 636       (else
 637        (##raise-expression-parsing-exception
 638         'macro-used-as-variable
 639         src
 640         name)))))
 641
 642 (define (##make-macro-descr def-syntax? size expander expander-src)
 643   (##vector def-syntax? size expander expander-src))
 644
 645 (define (##macro-descr-def-syntax? descr)
 646   (##vector-ref descr 0))
 647
 648 (define (##macro-descr-size descr)
 649   (##vector-ref descr 1))
 650
 651 (define (##macro-descr-expander descr)
 652   (##vector-ref descr 2))
 653
 654 (define (##macro-descr-expander-src descr)
 655   (##vector-ref descr 3))
 656
 657 (define ##macro-lookup #f)
 658 (set! ##macro-lookup
 659   (lambda (cte name)
 660     (and (##symbol? name)
 661          (let ((ind (##cte-lookup cte name)))
 662            (case (##vector-ref ind 0)
 663              ((macro)
 664               (##vector-ref ind 2))
 665              (else
 666               #f))))))
 667
 668 (define ##macro-expand #f)
 669 (set! ##macro-expand
 670   (lambda (cte src descr)
 671     (##shape src src (##macro-descr-size descr))
 672     (##sourcify
 673      (if (##macro-descr-def-syntax? descr)
 674          ((##macro-descr-expander descr) src)
 675          (##apply (##macro-descr-expander descr)
 676                   (##cdr (##desourcify src))))
 677      src)))
 678
 679 (define ##macro-descr #f)
 680 (set! ##macro-descr
 681   (lambda (src def-syntax?)
 682
 683     (define (err)
 684       (##raise-expression-parsing-exception
 685        'ill-formed-macro-transformer
 686        src))
 687
 688     (define (make-descr size)
 689       (let ((expander (##eval-top src ##interaction-cte)))
 690         (if (##not (##procedure? expander))
 691           (err)
 692           (##make-macro-descr def-syntax? size expander src))))
 693
 694     (if def-syntax?
 695       (make-descr -1)
 696       (let ((code (##source-code src)))
 697         (if (and (##pair? code)
 698                  (##memq (##source-code (##sourcify (##car code) src))
 699                          '(##lambda lambda)))
 700           (begin
 701             (##shape src src -3)
 702             (make-descr (##form-size (##sourcify (##cadr code) src))))
 703           (err))))))
 704
 705 (define (##form-size parms-src)
 706   (let ((parms (##source-code parms-src)))
 707     (let loop ((lst parms) (n 1))
 708       (cond ((##pair? lst)
 709              (let ((parm (##source-code (##sourcify (##car lst) parms-src))))
 710                (if (##memq parm '(#!optional #!key #!rest))
 711                  (##fixnum.- 0 n)
 712                  (loop (##cdr lst)
 713                        (##fixnum.+ n 1)))))
 714             ((##null? lst)
 715              n)
 716             (else
 717              (##fixnum.- 0 n))))))
 718
 719 (define (##cte-lookup-decl cte name default-value)
 720   (##declare (inlining-limit 500)) ;; inline CTE access procedures
 721   (let loop ((cte cte))
 722     (if (##cte-top? cte)
 723       default-value
 724       (let ((parent-cte (##cte-parent-cte cte)))
 725         (if (and (##cte-decl? cte)
 726                  (##eq? name (##cte-decl-name cte)))
 727           (##cte-decl-value cte)
 728           (loop parent-cte))))))
 729
 730 (define (##tail-call? cte tail?)
 731   (and tail?
 732        (##cte-lookup-decl cte 'proper-tail-calls #t)))
 733
 734 (define ##interaction-cte
 735   (##make-top-cte))
 736
 737 ;;;----------------------------------------------------------------------------
 738
 739 ;;; Utilities
 740
 741 (define (##self-eval? val)
 742   (or (##complex? val)
 743       (##string? val)
 744       (##char? val)
 745       (##keyword? val)
 746       (##memq val
 747               '(#f
 748                 #t
 749                 #!eof
 750                 #!void
 751                 #!unbound
 752                 #!unbound2
 753                 #!optional
 754                 #!key
 755                 #!rest
 756                 ))))
 757
 758 (define (##variable src)
 759   (let ((code (##source-code src)))
 760     (if (##not (##symbol? code))
 761       (##raise-expression-parsing-exception
 762        'id-expected
 763        src))))
 764
 765 (define (##shape src x size)
 766   (let* ((code (##source-code x))
 767          (n (##proper-length code)))
 768     (if (or (##not n)
 769             (if (##fixnum.< 0 size)
 770               (##not (##fixnum.= n size))
 771               (##fixnum.< n (##fixnum.- 0 size))))
 772       (##raise-expression-parsing-exception
 773        'ill-formed-special-form
 774        src
 775        (let* ((code (##source-code src))
 776               (head (##source-code (##sourcify (##car code) src)))
 777               (name (##symbol->string head))
 778               (len (##string-length name)))
 779          (if (and (##fixnum.< 2 len)
 780                   (##char=? #\# (##string-ref name 0))
 781                   (##char=? #\# (##string-ref name 1)))
 782            (##string->symbol (##substring name 2 len))
 783            head))))))
 784
 785 (define (##proper-length lst)
 786   (let loop ((lst lst) (n 0))
 787     (cond ((##pair? lst) (loop (##cdr lst) (##fixnum.+ n 1)))
 788           ((##null? lst) n)
 789           (else          #f))))
 790
 791 (define (##include-file-as-a-begin-expr src)
 792   (let* ((code (##source-code src))
 793          (filename-src (##sourcify (##cadr code) src))
 794          (filename (##source-code filename-src)))
 795     (if (##string? filename)
 796
 797       (let* ((locat
 798               (##source-locat src))
 799              (relative-to-path
 800               (and locat
 801                    (##container->path (##locat-container locat)))))
 802         (let* ((path
 803                 (##path-reference filename relative-to-path))
 804                (x
 805                 (##read-all-as-a-begin-expr-from-path
 806                  path
 807                  (##current-readtable)
 808                  ##wrap-datum
 809                  ##unwrap-datum)))
 810           (if (##fixnum? x)
 811             (##raise-expression-parsing-exception
 812              'cannot-open-file
 813              src
 814              path)
 815             (##vector-ref x 1))))
 816
 817       (##raise-expression-parsing-exception
 818        'filename-expected
 819        filename-src))))
 820
 821 ;;;----------------------------------------------------------------------------
 822
 823 ;;; Compiler's main entry
 824
 825 (define ##expand-source #f)
 826 (set! ##expand-source
 827   (lambda (src)
 828     src))
 829
 830 (define (##compile-module top-cte src)
 831   (##with-compilation-scope
 832    top-cte
 833    src
 834    #f
 835    (lambda (cte src tail?)
 836      (let* ((lib+body
 837              (##extract-library src))
 838             (new-src
 839              (if lib+body
 840                (let* ((lib (##car lib+body))
 841                       (body (##cdr lib+body))
 842                       (new-lib (##generate-library-prelude lib)))
 843                  (##sourcify
 844                   (##cons (##sourcify '##begin src)
 845                           (##cons new-lib
 846                                   body))
 847                   src))
 848                src)))
 849        (let ((tail? #f))
 850          (##comp-top top-cte new-src tail?))))))
 851
 852 (define (##compile-top top-cte src)
 853   (##with-compilation-scope
 854    top-cte
 855    src
 856    #f
 857    (lambda (cte src tail?)
 858      (let ((tail? #f))
 859        (##comp-top top-cte src tail?)))))
 860
 861 (define (##compile-inner cte src)
 862   (##with-compilation-scope
 863    cte
 864    src
 865    #f
 866    (lambda (cte src tail?)
 867      (macro-gen ##gen-top src
 868        (##comp (##cte-frame cte (##list (macro-self-var))) src tail?)))))
 869
 870 (define (##convert-source-to-locat! code)
 871
 872   (define (convert! container code)
 873     (let ((locat (##source-locat (macro-code-locat code)))) ;; get location
 874       (if (##locat? locat)
 875         (let ((new-container (##locat-container locat)))
 876           (if (##eq? container new-container)
 877             (convert2! container (##locat-position locat) code)
 878             (convert2! new-container locat code)))
 879         (convert2! container #f code))))
 880
 881   (define (convert2! container locat-or-position code)
 882     (macro-code-locat-set! code locat-or-position)
 883     (let ((n (macro-code-length code)))
 884       (let loop ((i 0))
 885         (if (##fixnum.< i n)
 886           (let ((x (macro-code-ref code i)))
 887             (if (macro-is-child-code? x code)
 888               (begin
 889                 (convert! container x)
 890                 (loop (##fixnum.+ i 1)))))))))
 891
 892   (convert! #f code)
 893   code)
 894
 895 (define ##compilation-scope
 896   (##make-parameter #f))
 897
 898 (define (##with-compilation-scope cte src tail? proc)
 899   (let* ((src
 900           (##expand-source src))
 901          (comp-scope
 902           (##vector '()))
 903          (code
 904           (##parameterize
 905            ##compilation-scope
 906            comp-scope
 907            (lambda ()
 908              (proc cte src tail?))))
 909          (imports
 910           (##reverse (##vector-ref comp-scope 0))))
 911     (##convert-source-to-locat!
 912      (if (##null? imports)
 913        code
 914        (macro-gen ##gen-require src
 915          code
 916          imports)))))
 917
 918 (define (##cte-process-import cte src)
 919   (let* ((code (##source-code src))
 920          (lib-name-src (##sourcify (##cadr code) src))
 921          (lib-name (##source-code lib-name-src))
 922          (include-file (##add-import-requirement lib-name)))
 923     (if include-file
 924       (##sourcify (##list (##sourcify '##include src)
 925                           (##sourcify include-file src))
 926                   src)
 927       (##sourcify (##list (##sourcify '##begin src))
 928                   src))))
 929
 930 (define ##add-import-requirement #f)
 931 (set! ##add-import-requirement
 932       (lambda (lib-name)
 933         (let ((comp-scope (##compilation-scope)))
 934           (##vector-set!
 935            comp-scope
 936            0
 937            (##cons lib-name
 938                    (##vector-ref comp-scope 0)))
 939           #f)))
 940
 941 (define ##fulfill-requirements #f)
 942 (set! ##fulfill-requirements
 943       (lambda (requirements)
 944         (##pretty-print (##cons requirements: requirements)
 945                         ##stdout-port)))
 946
 947 (define (##extract-library expr)
 948   #f #; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
 949   (let* ((src (##sourcify expr (##make-source #f #f)))
 950          (code (##source-code src)))
 951     (and (##pair? code)
 952          (let* ((h-src (##sourcify (##car code) src))
 953                 (h (##source-code h-src)))
 954            (and (##eq? h '##begin)
 955                 (##pair? (##cdr code))
 956                 (let* ((lib-src (##sourcify (##cadr code) src))
 957                        (lib (##source-code lib-src)))
 958                   (and (##pair? lib)
 959                        (let* ((libh-src (##sourcify (##car lib) src))
 960                               (libh (##source-code libh-src)))
 961                          (and (or (##eq? libh 'library)
 962                                   (##eq? libh '##library))
 963                               (begin
 964                                 (##shape lib-src lib-src -3)
 965                                 (cond ((##null? (##cdddr lib))
 966                                        (##cons lib-src
 967                                                (##cddr code)))
 968                                       ((##null? (##cddr code))
 969                                        (##cons lib-src
 970                                                (##cdddr lib)))
 971                                       (else
 972                                        (##raise-expression-parsing-exception
 973                                         'ill-placed-library
 974                                         lib-src)))))))))))))
 975
 976 (define ##generate-library-prelude #f)
 977 (set! ##generate-library-prelude
 978       (lambda (lib)
 979         lib))
 980
 981 ;;;----------------------------------------------------------------------------
 982
 983 (define (##comp-top top-cte src tail?)
 984   (let ((code (##source-code src))
 985         (cte (##cte-top-cte top-cte)))
 986     (if (##pair? code)
 987       (let* ((first-src (##sourcify (##car code) src))
 988              (first (##source-code first-src))
 989              (descr (##macro-lookup cte first)))
 990         (if descr
 991           (##comp-top top-cte (##macro-expand cte src descr) tail?)
 992           (case first
 993             ((##begin)           (##comp-top-begin top-cte src tail?))
 994             ((##define)          (##comp-top-define top-cte src tail?))
 995             ((##define-macro)    (##comp-top-define-macro top-cte src tail?))
 996             ((##define-syntax)   (##comp-top-define-syntax top-cte src tail?))
 997             ((##include)         (##comp-top-include top-cte src tail?))
 998             ((##declare)         (##comp-top-declare top-cte src tail?))
 999             ((##namespace)       (##comp-top-namespace top-cte src tail?))
1000 ;;            ((library ##library) (##comp-top-library top-cte src tail?))
1001 ;;            ((export ##export)   (##comp-top-export top-cte src tail?))
1002 ;;            ((import ##import)   (##comp-top-import top-cte src tail?))
1003             (else                (##comp-aux cte src tail? first)))))
1004       (##comp-simple cte src tail?))))
1005
1006 ;;; - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
1007
1008 (define (##comp-top-begin top-cte src tail?)
1009   (##shape src src -1)
1010   (let ((code (##source-code src)))
1011     (##comp-top-seq top-cte src tail? (##cdr code))))
1012
1013 (define (##comp-top-seq top-cte src tail? seq)
1014   (if (##pair? seq)
1015     (##comp-top-seq-aux top-cte src tail? seq)
1016     (let ((cte (##cte-top-cte top-cte)))
1017       (macro-gen ##gen-cst-no-step src
1018         (##void)))))
1019
1020 (define (##comp-top-seq-aux top-cte src tail? seq)
1021   (let ((first-src (##sourcify (##car seq) src))
1022         (rest (##cdr seq)))
1023     (if (##pair? rest)
1024       (let ((cte (##cte-top-cte top-cte)))
1025         (macro-gen ##gen-seq first-src
1026           (##comp-top top-cte first-src #f)
1027           (##comp-top-seq-aux top-cte src tail? rest)))
1028       (##comp-top top-cte first-src tail?))))
1029
1030 ;;; - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
1031
1032 (define (##comp-top-define top-cte src tail?)
1033   (let ((name (##definition-name src)))
1034     (##variable name)
1035     (let* ((cte (##cte-top-cte top-cte))
1036            (ind (##var-lookup cte name))
1037            (val (##definition-value src)))
1038       (macro-gen ##gen-glo-def src
1039         ind
1040         (##comp cte val #f)))))
1041
1042 ;;; - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
1043
1044 (define (##comp-top-include top-cte src tail?)
1045   (##shape src src 2)
1046   (##comp-top top-cte
1047               (##include-file-as-a-begin-expr src)
1048               tail?))
1049
1050 ;;; - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
1051
1052 (define (##comp-top-define-macro top-cte src tail?)
1053   (##comp-top-define-macro-or-syntax top-cte src tail? #f))
1054
1055 (define (##comp-top-define-syntax top-cte src tail?)
1056   (##comp-top-define-macro-or-syntax top-cte src tail? #t))
1057
1058 (define (##comp-top-define-macro-or-syntax top-cte src tail? def-syntax?)
1059   (let* ((cte (##cte-top-cte top-cte))
1060          (name (##definition-name src))
1061          (val (##definition-value src)))
1062     (##top-cte-add-macro!
1063      top-cte
1064      (##source-code name)
1065      (##macro-descr val def-syntax?))
1066     (macro-gen ##gen-cst-no-step src
1067       (##void))))
1068
1069 ;;; - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
1070
1071 (define (##comp-top-declare top-cte src tail?)
1072   (##shape src src -1)
1073   (let ((cte (##cte-top-cte top-cte)))
1074     (##top-cte-process-declare! top-cte src)
1075     (macro-gen ##gen-cst-no-step src
1076       (##void))))
1077
1078 ;;; - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
1079
1080 (define (##comp-top-namespace top-cte src tail?)
1081   (##shape src src -1)
1082   (let ((cte (##cte-top-cte top-cte)))
1083     (##top-cte-process-namespace! top-cte src)
1084     (macro-gen ##gen-cst-no-step src
1085       (##void))))
1086
1087 ;;; - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
1088
1089 (define (##comp-top-library top-cte src tail?)
1090
1091   ;; The library form is handled specially because it must be the only
1092   ;; form in the module.
1093
1094   (##raise-expression-parsing-exception
1095    'ill-placed-library
1096    src))
1097
1098 ;;; - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
1099
1100 (define (##comp-top-export top-cte src tail?)
1101   (##shape src src -2)
1102   #f);;;;;;;;;;;;;;;;;;;;;;;
1103
1104 ;;; - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
1105
1106 (define (##comp-top-import top-cte src tail?)
1107   (##shape src src 2)
1108   (##comp-top top-cte
1109               (##cte-process-import top-cte src)
1110               tail?))
1111
1112 ;;;----------------------------------------------------------------------------
1113
1114 (define (##comp cte src tail?)
1115   (let ((code (##source-code src)))
1116     (if (##pair? code)
1117       (let* ((first-src (##sourcify (##car code) src))
1118              (first (##source-code first-src))
1119              (descr (##macro-lookup cte first)))
1120         (if descr
1121           (##comp cte (##macro-expand cte src descr) tail?)
1122           (case first
1123             ((##begin)
1124              (##comp-begin cte src tail?))
1125             ((##define)
1126              (##raise-expression-parsing-exception
1127               'ill-placed-define
1128               src))
1129             ((##define-macro)
1130              (##raise-expression-parsing-exception
1131               'ill-placed-define-macro
1132               src))
1133             ((##define-syntax)
1134              (##raise-expression-parsing-exception
1135               'ill-placed-define-syntax
1136               src))
1137             ((##include)
1138              (##raise-expression-parsing-exception
1139               'ill-placed-include
1140               src))
1141             ((##declare)
1142              (##raise-expression-parsing-exception
1143               'ill-placed-declare
1144               src))
1145             ((##namespace)
1146              (##raise-expression-parsing-exception
1147               'ill-placed-namespace
1148               src))
1149 ;;            ((library ##library)
1150 ;;             (##raise-expression-parsing-exception
1151 ;;              'ill-placed-library
1152 ;;              src))
1153 ;;            ((export ##export)
1154 ;;             (##raise-expression-parsing-exception
1155 ;;              'ill-placed-export
1156 ;;              src))
1157 ;;            ((import ##import)
1158 ;;             (##raise-expression-parsing-exception
1159 ;;              'ill-placed-import
1160 ;;              src))
1161             (else
1162              (##comp-aux cte src tail? first)))))
1163       (##comp-simple cte src tail?))))
1164
1165 (define (##comp-simple cte src tail?)
1166   (let ((code (##source-code src)))
1167     (cond ((##symbol? code)
1168            (##comp-ref cte src tail?))
1169           ((##self-eval? code)
1170            (##comp-cst cte src tail?))
1171           (else
1172            (##raise-expression-parsing-exception
1173             'ill-formed-expression
1174             src)))))
1175
1176 ;;; - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
1177
1178 (define (##comp-begin cte src tail?)
1179   (##shape src src -2)
1180   (let ((code (##source-code src)))
1181     (##comp-seq cte src tail? (##cdr code))))
1182
1183 (define (##comp-seq cte src tail? seq)
1184   (if (##pair? seq)
1185     (##comp-seq-aux cte src tail? seq)
1186     (macro-gen ##gen-cst-no-step src
1187       (##void))))
1188
1189 (define (##comp-seq-aux cte src tail? seq)
1190   (let ((first-src (##sourcify (##car seq) src))
1191         (rest (##cdr seq)))
1192     (if (##pair? rest)
1193       (let ((code (##source-code first-src)))
1194         (macro-gen ##gen-seq first-src
1195           (##comp cte first-src #f)
1196           (##comp-seq-aux cte src tail? rest)))
1197       (##comp cte first-src tail?))))
1198
1199 ;;;----------------------------------------------------------------------------
1200
1201 (define (##comp-aux cte src tail? first)
1202
1203   (define (unsupported)
1204     (##raise-expression-parsing-exception
1205      'unsupported-special-form
1206      src
1207      first))
1208
1209   (case first
1210     ((##quote)
1211      (##comp-quote cte src tail?))
1212     ((##quasiquote)
1213      (##comp-quasiquote cte src tail?))
1214     ((##set!)
1215      (##comp-set! cte src tail?))
1216     ((##lambda)
1217      (##comp-lambda cte src tail?))
1218     ((##if)
1219      (##comp-if cte src tail?))
1220     ((##cond)
1221      (##comp-cond cte src tail?))
1222     ((##and)
1223      (##comp-and cte src tail?))
1224     ((##or)
1225      (##comp-or cte src tail?))
1226     ((##case)
1227      (##comp-case cte src tail?))
1228     ((##let)
1229      (##comp-let cte src tail?))
1230     ((##let*)
1231      (##comp-let* cte src tail?))
1232     ((##letrec)
1233      (##comp-letrec cte src tail?))
1234     ((##do)
1235      (##comp-do cte src tail?))
1236     ((##delay)
1237      (##comp-delay cte src tail?))
1238     ((##future)
1239      (##comp-future cte src tail?))
1240     ((##c-define-type)
1241      (unsupported))
1242     ((##c-declare)
1243      (unsupported))
1244     ((##c-initialize)
1245      (unsupported))
1246     ((##c-lambda)
1247      (unsupported))
1248     ((##c-define)
1249      (unsupported))
1250     ((##this-source-file)
1251      (##comp-this-source-file cte src tail?))
1252     (else
1253      (##comp-app cte src tail?))))
1254
1255 ;;; - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
1256
1257 (define (##comp-ref cte src tail?)
1258   (##variable src)
1259   (let ((x (##var-lookup cte src)))
1260     (if (loc-access? x)
1261       (let ((up (loc-access-up x))
1262             (over (loc-access-over x)))
1263         (macro-gen ##gen-loc-ref src
1264           up
1265           over))
1266       (macro-gen ##gen-glo-ref src
1267         x))))
1268
1269 ;;; - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
1270
1271 (define (##comp-cst cte src tail?)
1272   (macro-gen ##gen-cst src
1273     (##desourcify src)))
1274
1275 ;;; - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
1276
1277 (define (##comp-quote cte src tail?)
1278   (##shape src src 2)
1279   (let ((code (##source-code src)))
1280     (macro-gen ##gen-cst src
1281       (##desourcify (##cadr code)))))
1282
1283 ;;; - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
1284
1285 (define (##comp-quasiquote cte src tail?)
1286   (##shape src src 2)
1287   (let ((code (##source-code src)))
1288     (##comp-template cte
1289                      src
1290                      tail?
1291                      (##sourcify (##cadr code) src)
1292                      1)))
1293
1294 ;;*********************** fix me
1295
1296 (define (##comp-template cte src tail? form-src depth)
1297   (let ((form (##source-code form-src)))
1298     (cond ((##pair? form)
1299            (##comp-list-template cte
1300                                  src
1301                                  tail?
1302                                  form
1303                                  depth))
1304           ((##vector? form)
1305            (macro-gen ##gen-quasi-list->vector src
1306              (##comp-list-template cte
1307                                    src
1308                                    #f
1309                                    (##vector->list form)
1310                                    depth)))
1311           (else
1312            (macro-gen ##gen-cst-no-step src
1313              (##desourcify form-src))))))
1314
1315 (define (##comp-list-template cte src tail? lst depth)
1316   (cond ((##pair? lst)
1317          (let* ((first-src (##sourcify (##car lst) src))
1318                 (first (##source-code first-src)))
1319
1320            (define (non-special-list)
1321              (if (and (##pair? first)
1322                       (##eq? (##source-code
1323                               (##sourcify (##car first) first-src))
1324                              'unquote-splicing)
1325                       (##pair? (##cdr first)) ;; proper list of length 2?
1326                       (##null? (##cddr first)))
1327                (if (##eq? depth 1)
1328                  (let ((second-src (##sourcify (##cadr first) src)))
1329                    (if (##null? (##cdr lst))
1330                      (##comp cte second-src tail?)
1331                      (macro-gen ##gen-quasi-append src
1332                        (##comp cte second-src #f)
1333                        (##comp-list-template cte
1334                                              src
1335                                              #f
1336                                              (##cdr lst)
1337                                              depth))))
1338                  (macro-gen ##gen-quasi-cons src
1339                    (##comp-template cte
1340                                     src
1341                                     #f
1342                                     first-src
1343                                     (##fixnum.- depth 1))
1344                    (##comp-list-template cte
1345                                          src
1346                                          #f
1347                                          (##cdr lst)
1348                                          depth)))
1349                (macro-gen ##gen-quasi-cons src
1350                  (##comp-template cte
1351                                   src
1352                                   #f
1353                                   first-src
1354                                   depth)
1355                  (##comp-list-template cte
1356                                        src
1357                                        #f
1358                                        (##cdr lst)
1359                                        depth))))
1360
1361            (if (and (##pair? (##cdr lst)) ;; proper list of length 2?
1362                     (##null? (##cddr lst)))
1363              (case first
1364                ((quasiquote)
1365                 (macro-gen ##gen-quasi-cons src
1366                   (macro-gen ##gen-cst-no-step first-src
1367                     first)
1368                   (##comp-list-template cte
1369                                         src
1370                                         #f
1371                                         (##cdr lst)
1372                                         (##fixnum.+ depth 1))))
1373                ((unquote)
1374                 (if (##eq? depth 1)
1375                   (##comp cte (##sourcify (##cadr lst) first-src) tail?)
1376                   (macro-gen ##gen-quasi-cons src
1377                     (macro-gen ##gen-cst-no-step first-src
1378                       first)
1379                     (##comp-list-template cte
1380                                           src
1381                                           #f
1382                                           (##cdr lst)
1383                                           (##fixnum.- depth 1)))))
1384                (else
1385                 (non-special-list)))
1386              (non-special-list))))
1387
1388          ((##null? lst)
1389           (macro-gen ##gen-cst-no-step src
1390             '()))
1391
1392          (else
1393           (##comp-template cte
1394                            src
1395                            tail?
1396                            (##sourcify lst src)
1397                            depth))))
1398
1399 ;;; - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
1400
1401 (define (##comp-set! cte src tail?)
1402   (##shape src src 3)
1403   (let* ((code (##source-code src))
1404          (var-src (##sourcify (##cadr code) src))
1405          (val-src (##sourcify (##caddr code) src)))
1406     (##variable var-src)
1407     (let ((x (##var-lookup cte var-src)))
1408       (if (loc-access? x)
1409         (let ((up (loc-access-up x))
1410               (over (loc-access-over x)))
1411           (macro-gen ##gen-loc-set src
1412             up
1413             over
1414             (##comp cte val-src #f)))
1415         (macro-gen ##gen-glo-set src
1416           x
1417           (##comp cte val-src #f))))))
1418
1419 ;;; - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
1420
1421 (define (##comp-lambda cte src tail?)
1422   (##shape src src -3)
1423   (let* ((code (##source-code src))
1424          (parms-src (##sourcify (##cadr code) src))
1425          (body (##cddr code)))
1426     (##comp-lambda-aux cte src tail? parms-src body)))
1427
1428 (define (##comp-lambda-aux cte src tail? parms-src body)
1429   (let* ((all-parms
1430           (##extract-parameters src parms-src))
1431          (required-parameters
1432           (##vector-ref all-parms 0))
1433          (optional-parameters
1434           (##vector-ref all-parms 1))
1435          (rest-parameter
1436           (##vector-ref all-parms 2))
1437          (dsssl-style-rest?
1438           (##vector-ref all-parms 3))
1439          (key-parameters
1440           (##vector-ref all-parms 4)))
1441     (let loop1 ((frame required-parameters)
1442                 (lst (or optional-parameters '()))
1443                 (rev-inits '()))
1444       (if (##pair? lst)
1445         (let ((x (##car lst))
1446               (new-cte (##cte-frame cte (##cons (macro-self-var) frame))))
1447           (loop1 (##append frame (##list (##car x)))
1448                  (##cdr lst)
1449                  (##cons (##comp new-cte (##cdr x) #f)
1450                          rev-inits)))
1451         (let loop2 ((frame (if (and rest-parameter dsssl-style-rest?)
1452                              (##append frame (##list rest-parameter))
1453                              frame))
1454                     (lst (or key-parameters '()))
1455                     (rev-inits rev-inits)
1456                     (rev-keys '()))
1457           (if (##pair? lst)
1458             (let ((x (##car lst))
1459                   (new-cte (##cte-frame cte (##cons (macro-self-var) frame))))
1460               (loop2 (##append frame (##list (##car x)))
1461                      (##cdr lst)
1462                      (##cons (##comp new-cte (##cdr x) #f)
1463                              rev-inits)
1464                      (##cons (##string->keyword (##symbol->string (##car x)))
1465                              rev-keys)))
1466             (let* ((frame (if (and rest-parameter (not dsssl-style-rest?))
1467                             (##append frame (##list rest-parameter))
1468                             frame))
1469                    (new-cte (##cte-frame cte (##cons (macro-self-var) frame)))
1470                    (c (##comp-body new-cte src #t body)))
1471               (cond ((or optional-parameters key-parameters)
1472                      (macro-gen ##gen-prc src
1473                        frame
1474                        (and rest-parameter (if dsssl-style-rest? 'dsssl #t))
1475                        (and key-parameters
1476                             (##list->vector (##reverse rev-keys)))
1477                        c
1478                        (##reverse rev-inits)))
1479                     (rest-parameter
1480                      (macro-gen ##gen-prc-rest src
1481                        frame
1482                        c))
1483                     (else
1484                      (macro-gen ##gen-prc-req src
1485                        frame
1486                        c))))))))))
1487
1488 (define (##extract-parameters src parms-src)
1489
1490   (define (parm-expected-err src)
1491     (##raise-expression-parsing-exception
1492      'parameter-must-be-id
1493      src))
1494
1495   (define (parm-or-default-binding-expected-err src)
1496     (##raise-expression-parsing-exception
1497      'parameter-must-be-id-or-default
1498      src))
1499
1500   (define (duplicate-parm-err src)
1501     (##raise-expression-parsing-exception
1502      'duplicate-parameter
1503      src))
1504
1505   (define (duplicate-rest-parm-err src)
1506     (##raise-expression-parsing-exception
1507      'duplicate-rest-parameter
1508      src))
1509
1510   (define (rest-parm-expected-err src)
1511     (##raise-expression-parsing-exception
1512      'parameter-expected-after-rest
1513      src))
1514
1515   (define (rest-parm-must-be-last-err src)
1516     (##raise-expression-parsing-exception
1517      'rest-parm-must-be-last
1518      src))
1519
1520   (define (default-binding-err src)
1521     (##raise-expression-parsing-exception
1522      'ill-formed-default
1523      src))
1524
1525   (define (optional-illegal-err src)
1526     (##raise-expression-parsing-exception
1527      'ill-placed-optional
1528      src))
1529
1530   (define (key-illegal-err src)
1531     (##raise-expression-parsing-exception
1532      'ill-placed-key
1533      src))
1534
1535   (define (key-expected-err src)
1536     (##raise-expression-parsing-exception
1537      'key-expected-after-rest
1538      src))
1539
1540   (define (default-binding-illegal-err src)
1541     (##raise-expression-parsing-exception
1542      'ill-placed-default
1543      src))
1544
1545   (let loop ((lst (##source->parms parms-src))
1546              (rev-required-parms '())
1547              (rev-optional-parms #f)
1548              (rest-parm #f)
1549              (rev-key-parms #f)
1550              (state 1)) ;; 1 = required parms or #!optional/#!rest/#!key
1551                         ;; 2 = optional parms or #!rest/#!key
1552                         ;; 3 = #!key
1553                         ;; 4 = key parms (or #!rest if rest-parm=#f)
1554
1555     (define (done rest-parm2)
1556       (##vector (##reverse rev-required-parms)
1557                 (and rev-optional-parms (##reverse rev-optional-parms))
1558                 rest-parm2
1559                 (and rest-parm (##fixnum.= state 4))
1560                 (if (or (##not rev-key-parms)
1561                         (and (##null? rev-key-parms) (##not rest-parm2)))
1562                   #f
1563                   (##reverse rev-key-parms))))
1564
1565     (define (check-if-duplicate parm-src)
1566       (let ((parm (##source-code parm-src)))
1567         (if (or (##memq parm rev-required-parms)
1568                 (and rev-optional-parms (##assq parm rev-optional-parms))
1569                 (and rest-parm (##eq? parm rest-parm))
1570                 (and rev-key-parms (##assq parm rev-key-parms)))
1571           (duplicate-parm-err parm-src))))
1572
1573     (cond ((##null? lst)
1574            (done rest-parm))
1575           ((##pair? lst)
1576            (let* ((parm-src (##sourcify (##car lst) src))
1577                   (parm (##source-code parm-src)))
1578              (cond ((##eq? #!optional parm)
1579                     (if (##not (##fixnum.= 1 state))
1580                       (optional-illegal-err parm-src))
1581                     (loop (##cdr lst)
1582                           rev-required-parms
1583                           '()
1584                           rest-parm
1585                           rev-key-parms
1586                           2))
1587                    ((##eq? #!rest parm)
1588                     (if rest-parm
1589                       (duplicate-rest-parm-err parm-src))
1590                     (if (##pair? (##cdr lst))
1591                       (let* ((parm-src (##sourcify (##cadr lst) src))
1592                              (parm (##source-code parm-src)))
1593                         (##variable parm-src)
1594                         (check-if-duplicate parm-src)
1595                         (if (##fixnum.= state 4)
1596                           (if (##null? (##cddr lst))
1597                             (done parm)
1598                             (rest-parm-must-be-last-err parm-src))
1599                           (loop (##cddr lst)
1600                                 rev-required-parms
1601                                 rev-optional-parms
1602                                 parm
1603                                 rev-key-parms
1604                                 3)))
1605                       (rest-parm-expected-err parm-src)))
1606                    ((##eq? #!key parm)
1607                     (if (##fixnum.= 4 state)
1608                       (key-illegal-err parm-src))
1609                     (loop (##cdr lst)
1610                           rev-required-parms
1611                           rev-optional-parms
1612                           rest-parm
1613                           '()
1614                           4))
1615                    ((##fixnum.= state 3)
1616                     (key-expected-err parm-src))
1617                    ((##symbol? parm)
1618                     (##variable parm-src)
1619                     (check-if-duplicate parm-src)
1620                     (case state
1621                       ((1)
1622                        (loop (##cdr lst)
1623                              (##cons parm
1624                                      rev-required-parms)
1625                              rev-optional-parms
1626                              rest-parm
1627                              rev-key-parms
1628                              state))
1629                       ((2)
1630                        (loop (##cdr lst)
1631                              rev-required-parms
1632                              (##cons (##cons parm
1633                                              (##sourcify #f parm-src))
1634                                      rev-optional-parms)
1635                              rest-parm
1636                              rev-key-parms
1637                              state))
1638                       (else
1639                        (loop (##cdr lst)
1640                              rev-required-parms
1641                              rev-optional-parms
1642                              rest-parm
1643                              (##cons (##cons parm
1644                                              (##sourcify #f parm-src))
1645                                      rev-key-parms)
1646                              state))))
1647                    ((##pair? parm)
1648                     (if (##not (or (##fixnum.= state 2) (##fixnum.= state 4)))
1649                       (default-binding-illegal-err parm-src))
1650                     (let ((len (##proper-length parm)))
1651                       (if (##not (##eq? len 2))
1652                         (default-binding-err parm-src)))
1653                     (let* ((val-src (##sourcify (##cadr parm) parm-src))
1654                            (parm-src (##sourcify (##car parm) parm-src))
1655                            (parm (##source-code parm-src)))
1656                       (##variable parm-src)
1657                       (check-if-duplicate parm-src)
1658                       (case state
1659                         ((2)
1660                          (loop (##cdr lst)
1661                                rev-required-parms
1662                                (##cons (##cons parm val-src)
1663                                        rev-optional-parms)
1664                                rest-parm
1665                                rev-key-parms
1666                                state))
1667                         (else
1668                          (loop (##cdr lst)
1669                                rev-required-parms
1670                                rev-optional-parms
1671                                rest-parm
1672                                (##cons (##cons parm val-src)
1673                                        rev-key-parms)
1674                                state)))))
1675                    (else
1676                     (if (##not (##fixnum.= 1 state))
1677                       (parm-or-default-binding-expected-err parm-src)
1678                       (parm-expected-err parm-src))))))
1679           (else
1680            (let ((parm-src (##sourcify lst src)))
1681              (##variable parm-src)
1682              (if rest-parm
1683                (duplicate-rest-parm-err parm-src))
1684              (check-if-duplicate parm-src)
1685              (done (##source-code parm-src)))))))
1686
1687 (define (##source->parms src)
1688   (let ((x (##source-code src)))
1689     (if (or (##pair? x) (##null? x)) x src)))
1690
1691 (define (##comp-body cte src tail? body)
1692
1693   (define (letrec-defines cte rev-vars rev-vals body)
1694     (if (##pair? body)
1695
1696       (let* ((src (##sourcify (##car body) src))
1697              (code (##source-code src)))
1698         (if (##not (##pair? code))
1699           (letrec-defines* cte rev-vars rev-vals body)
1700           (let* ((first-src (##sourcify (##car code) src))
1701                  (first (##source-code first-src))
1702                  (descr (##macro-lookup cte first)))
1703             (if descr
1704               (letrec-defines cte
1705                               rev-vars
1706                               rev-vals
1707                               (##cons
1708                                (##macro-expand cte src descr)
1709                                (##cdr body)))
1710               (case first
1711                 ((##begin)
1712                  (##shape src src -1)
1713                  (letrec-defines cte
1714                                  rev-vars
1715                                  rev-vals
1716                                  (##append (##cdr code) (##cdr body))))
1717                 ((##define)
1718                  (let* ((name-src (##definition-name src))
1719                         (name (##source-code name-src)))
1720                    (##variable name-src)
1721                    (if (##memq name rev-vars)
1722                      (##raise-expression-parsing-exception
1723                       'duplicate-variable-definition
1724                       name-src))
1725                    (let ((val (##definition-value src)))
1726                      (letrec-defines cte
1727                                      (##cons name rev-vars)
1728                                      (##cons val rev-vals)
1729                                      (##cdr body)))))
1730                 ((##define-macro ##define-syntax)
1731                  (let* ((def-syntax? (##eq? first '##define-syntax))
1732                         (name-src (##definition-name src))
1733                         (name (##source-code name-src))
1734                         (val (##definition-value src)))
1735                    (letrec-defines (##cte-macro
1736                                     cte
1737                                     name
1738                                     (##macro-descr val def-syntax?))
1739                                    rev-vars
1740                                    rev-vals
1741                                    (##cdr body))))
1742                 ((##include)
1743                  (##shape src src 2)
1744                  (letrec-defines cte
1745                                  rev-vars
1746                                  rev-vals
1747                                  (##cons
1748                                   (##include-file-as-a-begin-expr src)
1749                                   (##cdr body))))
1750                 ((##declare)
1751                  (##shape src src -1)
1752                  (letrec-defines (##cte-process-declare cte src)
1753                                  rev-vars
1754                                  rev-vals
1755                                  (##cdr body)))
1756                 ((##namespace)
1757                  (##shape src src -1)
1758                  (letrec-defines (##cte-process-namespace cte src)
1759                                  rev-vars
1760                                  rev-vals
1761                                  (##cdr body)))
1762 ;;                ((library ##library)
1763 ;;                 (##raise-expression-parsing-exception
1764 ;;                  'ill-placed-library
1765 ;;                  src))
1766 ;;                ((export ##export)
1767 ;;                 (##raise-expression-parsing-exception
1768 ;;                  'ill-placed-export
1769 ;;                  src))
1770 ;;                ((import ##import)
1771 ;;                 (##shape src src 2)
1772 ;;                 (letrec-defines cte
1773 ;;                                 rev-vars
1774 ;;                                 rev-vals
1775 ;;                                 (##cons (##cte-process-import cte src)
1776 ;;                                         (##cdr body))))
1777                 (else
1778                  (letrec-defines* cte rev-vars rev-vals body)))))))
1779
1780       (##raise-expression-parsing-exception
1781        'empty-body
1782        src)))
1783
1784   (define (letrec-defines* cte rev-vars rev-vals body)
1785     (if (##null? rev-vars)
1786       (##comp-seq cte src tail? body)
1787       (##comp-letrec-aux cte
1788                          src
1789                          tail?
1790                          (##reverse rev-vars)
1791                          (##reverse rev-vals)
1792                          body)))
1793
1794   (letrec-defines cte '() '() body))
1795
1796 (define (##definition-name src)
1797   (##shape src src -2)
1798   (let* ((code (##source-code src))
1799          (head-src (##sourcify (##car code) src))
1800          (head (##source-code head-src))
1801          (pattern-src (##sourcify (##cadr code) src))
1802          (pattern (##source-code pattern-src)))
1803     (##shape src
1804              src
1805              (cond ((and (##eq? head '##define)
1806                          (##not (##pair? pattern)))
1807                     (if (##not (##pair? (##cddr code)))
1808                       2
1809                       3))
1810                    ((or (##eq? head '##define-syntax)
1811                         (and (##eq? head '##define-macro)
1812                              (##not (##pair? pattern))))
1813                     3)
1814                    (else
1815                     -3)))
1816     (let* ((name-src
1817             (if (and (##not (##eq? head '##define-syntax))
1818                      (##pair? pattern))
1819               (##sourcify (##car pattern) src)
1820               pattern-src))
1821            (name
1822             (##source-code name-src)))
1823       (if (##not (##symbol? name))
1824         (##raise-expression-parsing-exception
1825          'id-expected
1826          name-src))
1827       name-src)))
1828
1829 (define (##definition-value src)
1830   (let* ((code (##source-code src))
1831          (pattern-src (##sourcify (##cadr code) src))
1832          (pattern (##source-code pattern-src))
1833          (locat (##source-locat src)))
1834     (cond ((##pair? pattern)
1835            (let ((parms (##cdr pattern)))
1836              (##make-source
1837               (##cons (##make-source '##lambda locat)
1838                       (##cons (if (##source? parms) ;; rest parameter?
1839                                 parms
1840                                 (##make-source parms locat))
1841                               (##cddr code)))
1842               locat)))
1843            ((##pair? (##cddr code))
1844             (##sourcify (##caddr code) src))
1845            (else
1846             (##make-source
1847              (##list (##make-source '##quote locat)
1848                      (##make-source (##void) locat))
1849              locat)))))
1850
1851 ;;; - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
1852
1853 (define (##comp-if cte src tail?)
1854   (##shape src src -3)
1855   (let* ((code (##source-code src))
1856          (pre-src (##sourcify (##cadr code) src))
1857          (con-src (##sourcify (##caddr code) src)))
1858     (if (##pair? (##cdddr code))
1859       (let ((alt-src (##sourcify (##cadddr code) src)))
1860         (##shape src src 4)
1861         (macro-gen ##gen-if3 src
1862           (##comp cte pre-src #f)
1863           (##comp cte con-src tail?)
1864           (##comp cte alt-src tail?)))
1865       (begin
1866         (##shape src src 3)
1867         (macro-gen ##gen-if2 src
1868           (##comp cte pre-src #f)
1869           (##comp cte con-src tail?))))))
1870
1871 ;;; - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
1872
1873 (define (##comp-cond cte src tail?)
1874   (##shape src src -2)
1875   (let* ((code (##source-code src))
1876          (clauses (##cdr code)))
1877     (##comp-cond-aux cte src tail? clauses)))
1878
1879 (define (##comp-cond-aux cte src tail? clauses)
1880   (if (##pair? clauses)
1881     (let* ((clause-src (##sourcify (##car clauses) src))
1882            (clause (##source-code clause-src)))
1883       (##shape src clause-src -1)
1884       (let* ((first-src (##sourcify (##car clause) clause-src))
1885              (first (##source-code first-src)))
1886         (cond ((##eq? first 'else)
1887                (##shape src clause-src -2)
1888                (if (##not (##null? (##cdr clauses)))
1889                  (##raise-expression-parsing-exception
1890                   'else-clause-not-last
1891                   clause-src))
1892                (##comp-seq cte src tail? (##cdr clause)))
1893               ((##not (##pair? (##cdr clause)))
1894                (macro-gen ##gen-cond-or src
1895                  (##comp cte first-src #f)
1896                  (##comp-cond-aux cte src tail? (##cdr clauses))))
1897               (else
1898                (let* ((second-src (##sourcify (##cadr clause) clause-src))
1899                       (second (##source-code second-src)))
1900                  (if (##eq? second '=>)
1901                    (begin
1902                      (##shape src clause-src 3)
1903                      (let ((third-src
1904                             (##sourcify (##caddr clause) clause-src)))
1905                        (macro-gen ##gen-cond-send src
1906                          (##comp cte first-src #f)
1907                          (##comp cte third-src #f)
1908                          (##comp-cond-aux cte src tail? (##cdr clauses)))))
1909                    (macro-gen ##gen-cond-if src
1910                      (##comp cte first-src #f)
1911                      (##comp-seq cte src tail? (##cdr clause))
1912                      (##comp-cond-aux cte src tail? (##cdr clauses)))))))))
1913     (macro-gen ##gen-cst-no-step src
1914       (##void))))
1915
1916 ;;; - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
1917
1918 (define (##comp-and cte src tail?)
1919   (##shape src src -1)
1920   (let* ((code (##source-code src))
1921          (rest (##cdr code)))
1922     (if (##pair? rest)
1923       (##comp-and-aux cte src tail? rest)
1924       (macro-gen ##gen-cst src
1925         #t))))
1926
1927 (define (##comp-and-aux cte src tail? lst)
1928   (let ((first-src (##sourcify (##car lst) src))
1929         (rest (##cdr lst)))
1930     (if (##pair? rest)
1931       (macro-gen ##gen-and first-src
1932         (##comp cte first-src #f)
1933         (##comp-and-aux cte src tail? rest))
1934       (##comp cte first-src tail?))))
1935
1936 ;;; - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
1937
1938 (define (##comp-or cte src tail?)
1939   (##shape src src -1)
1940   (let* ((code (##source-code src))
1941          (rest (##cdr code)))
1942     (if (##pair? rest)
1943       (##comp-or-aux cte src tail? rest)
1944       (macro-gen ##gen-cst src
1945         #f))))
1946
1947 (define (##comp-or-aux cte src tail? lst)
1948   (let ((first-src (##sourcify (##car lst) src))
1949         (rest (##cdr lst)))
1950     (if (##pair? rest)
1951       (macro-gen ##gen-or first-src
1952         (##comp cte first-src #f)
1953         (##comp-or-aux cte src tail? rest))
1954       (##comp cte first-src tail?))))
1955
1956 ;;; - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
1957
1958 (define (##comp-case cte src tail?)
1959   (##shape src src -3)
1960   (let* ((code (##source-code src))
1961          (first-src (##sourcify (##cadr code) src))
1962          (clauses (##cddr code)))
1963     (macro-gen ##gen-case first-src
1964       (##comp cte first-src #f)
1965       (let ((cte (##cte-frame cte (##list (macro-selector-var)))))
1966         (##comp-case-aux cte src tail? clauses)))))
1967
1968 (define (##comp-case-aux cte src tail? clauses)
1969   (if (##pair? clauses)
1970     (let* ((clause-src (##sourcify (##car clauses) src))
1971            (clause (##source-code clause-src)))
1972       (##shape src clause-src -2)
1973       (let* ((first-src (##sourcify (##car clause) clause-src))
1974              (first (##source-code first-src)))
1975         (if (##eq? first 'else)
1976           (begin
1977             (if (##not (##null? (##cdr clauses)))
1978               (##raise-expression-parsing-exception
1979                'else-clause-not-last
1980                clause-src))
1981             (macro-gen ##gen-case-else clause-src
1982               (##comp-seq cte src tail? (##cdr clause))))
1983           (let ((n (##proper-length first)))
1984             (if (##not n)
1985               (##raise-expression-parsing-exception
1986                'ill-formed-selector-list
1987                first-src))
1988             (macro-gen ##gen-case-clause clause-src
1989               (##desourcify first-src)
1990               (##comp-seq cte src tail? (##cdr clause))
1991               (##comp-case-aux cte src tail? (##cdr clauses)))))))
1992     (macro-gen ##gen-case-else src
1993       (macro-gen ##gen-cst-no-step src
1994         (##void)))))
1995
1996 ;;; - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
1997
1998 (define (##comp-let cte src tail?)
1999   (##shape src src -3)
2000   (let* ((code (##source-code src))
2001          (first-src (##sourcify (##cadr code) src))
2002          (first (##source-code first-src)))
2003     (if (##symbol? first)
2004       (begin
2005         (##shape src src -4)
2006         (let ((bindings-src (##sourcify (##caddr code) src)))
2007           (let* ((vars (##bindings->vars src bindings-src #t #f))
2008                  (vals (##bindings->vals src bindings-src))
2009                  (tail? (##tail-call? cte tail?)))
2010             (macro-gen ##gen-app-no-step src
2011               (let ((inner-cte (##cte-frame cte (##list first)))
2012                     (tail? #f))
2013                 (macro-gen ##gen-letrec src
2014                   (##list first)
2015                   (let ((cte inner-cte))
2016                     (##list (macro-gen ##gen-prc-req-no-step src
2017                               vars
2018                               (##comp-body (##cte-frame
2019                                              cte
2020                                              (##cons (macro-self-var) vars))
2021                                            src
2022                                            #t
2023                                            (##cdddr code)))))
2024                   (let ((cte inner-cte))
2025                     (macro-gen ##gen-loc-ref-no-step src ;; fetch loop variable
2026                       0
2027                       1))))
2028               (##comp-vals cte src vals)))))
2029       (let* ((vars (##bindings->vars src first-src #t #f))
2030              (vals (##bindings->vals src first-src)))
2031         (if (##null? vars)
2032           (##comp-body cte src tail? (##cddr code))
2033           (let ((c
2034                  (##comp-body
2035                    (##cte-frame cte vars)
2036                    src
2037                    tail?
2038                    (##cddr code))))
2039             (macro-gen ##gen-let src
2040               vars
2041               (##comp-vals cte src vals)
2042               c)))))))
2043
2044 (define (##comp-vals cte src lst)
2045   (if (##pair? lst)
2046     (##cons (##comp cte (##sourcify (##car lst) src) #f)
2047             (##comp-vals cte src (##cdr lst)))
2048     '()))
2049
2050 (define (##bindings->vars src bindings-src check-duplicates? allow-steps?)
2051
2052   (define (bindings->vars lst rev-vars)
2053     (if (##pair? lst)
2054       (let* ((binding-src (##sourcify (##car lst) src))
2055              (binding (##source-code binding-src)))
2056         (if allow-steps?
2057           (begin
2058             (##shape src binding-src -2)
2059             (if (##pair? (##cddr binding)) (##shape src binding-src 3)))
2060           (##shape src binding-src 2))
2061         (let* ((first-src (##sourcify (##car binding) binding-src))
2062                (first (##source-code first-src)))
2063           (##variable first-src)
2064           (if (and check-duplicates? (##memq first rev-vars))
2065             (##raise-expression-parsing-exception
2066              'duplicate-variable-binding
2067              first-src))
2068           (bindings->vars (##cdr lst)
2069                           (##cons first rev-vars))))
2070       (##reverse rev-vars)))
2071
2072   (let* ((bindings (##source-code bindings-src))
2073          (len (##proper-length bindings)))
2074     (if len
2075       (bindings->vars bindings '())
2076       (##raise-expression-parsing-exception
2077        'ill-formed-binding-list
2078        bindings-src))))
2079
2080 (define (##bindings->vals src bindings-src)
2081
2082   (define (bindings->vals lst)
2083     (if (##pair? lst)
2084       (let* ((binding-src (##sourcify (##car lst) src))
2085              (binding (##source-code binding-src)))
2086         (##cons (##sourcify (##cadr binding) src)
2087                 (bindings->vals (##cdr lst))))
2088       '()))
2089
2090   (let ((bindings (##source-code bindings-src)))
2091     (bindings->vals bindings)))
2092
2093 (define (##bindings->steps src bindings-src)
2094
2095   (define (bindings->steps lst)
2096     (if (##pair? lst)
2097       (let* ((binding-src (##sourcify (##car lst) src))
2098              (binding (##source-code binding-src)))
2099         (##cons (##sourcify (if (##pair? (##cddr binding))
2100                               (##caddr binding)
2101                               (##car binding))
2102                             src)
2103                 (bindings->steps (##cdr lst))))
2104       '()))
2105
2106   (let ((bindings (##source-code bindings-src)))
2107     (bindings->steps bindings)))
2108
2109 ;;; - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
2110
2111 (define (##comp-let* cte src tail?)
2112   (##shape src src -3)
2113   (let* ((code (##source-code src))
2114          (bindings-src (##sourcify (##cadr code) src))
2115          (vars (##bindings->vars src bindings-src #f #f))
2116          (vals (##bindings->vals src bindings-src)))
2117     (##comp-let*-aux cte src tail? vars vals (##cddr code))))
2118
2119 (define (##comp-let*-aux cte src tail? vars vals body)
2120   (if (##pair? vars)
2121     (let ((frame (##list (##car vars))))
2122       (let ((inner-cte (##cte-frame cte frame)))
2123         (macro-gen ##gen-let src
2124           frame
2125           (##list (##comp cte (##car vals) #f))
2126           (##comp-let*-aux inner-cte
2127                            src
2128                            tail?
2129                            (##cdr vars)
2130                            (##cdr vals)
2131                            body))))
2132     (##comp-body cte src tail? body)))
2133
2134 ;;; - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
2135
2136 (define (##comp-letrec cte src tail?)
2137   (##shape src src -3)
2138   (let* ((code (##source-code src))
2139          (bindings-src (##sourcify (##cadr code) src))
2140          (vars (##bindings->vars src bindings-src #t #f))
2141          (vals (##bindings->vals src bindings-src)))
2142     (##comp-letrec-aux cte src tail? vars vals (##cddr code))))
2143
2144 (define (##comp-letrec-aux cte src tail? vars vals body)
2145   (if (##pair? vars)
2146     (let ((inner-cte (##cte-frame cte vars)))
2147       (macro-gen ##gen-letrec src
2148         vars
2149         (##comp-vals inner-cte src vals)
2150         (##comp-body inner-cte src tail? body)))
2151     (##comp-body cte src tail? body)))
2152
2153 ;;; - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
2154
2155 (define (##comp-do cte src tail?)
2156   (##shape src src -3)
2157   (let* ((outer-cte cte)
2158          (code (##source-code src))
2159          (bindings-src (##sourcify (##cadr code) src))
2160          (exit-src (##sourcify (##caddr code) src))
2161          (exit (##source-code exit-src)))
2162     (##shape src exit-src -1)
2163     (let* ((vars (##bindings->vars src bindings-src #t #t))
2164            (do-loop-vars (##list (macro-do-loop-var)))
2165            (inner-cte (##cte-frame cte do-loop-vars)))
2166       (macro-gen ##gen-letrec src
2167         do-loop-vars
2168         (##list
2169           (let ((cte inner-cte)
2170                 (tail? #f))
2171             (macro-gen ##gen-prc-req-no-step src
2172               vars
2173               (let ((cte (##cte-frame cte (##cons (macro-self-var) vars)))
2174                     (tail? #t))
2175                 (macro-gen ##gen-if3 src
2176                   (##comp cte (##sourcify (##car exit) src) #f)
2177                   (##comp-seq cte src tail? (##cdr exit))
2178                   (let ((call
2179                          (let ((tail? (##tail-call? outer-cte tail?)))
2180                            (macro-gen ##gen-app-no-step src
2181                              (let ((tail? #f))
2182                                (macro-gen ##gen-loc-ref-no-step src ;; fetch do-loop-var
2183                                  1
2184                                  1))
2185                              (##comp-vals cte
2186                                           src
2187                                           (##bindings->steps src
2188                                                              bindings-src))))))
2189                     (if (##null? (##cdddr code))
2190                       call
2191                       (macro-gen ##gen-seq src
2192                         (##comp-seq cte src #f (##cdddr code))
2193                         call))))))))
2194         (let ((cte inner-cte)
2195               (tail? (##tail-call? outer-cte tail?)))
2196           (macro-gen ##gen-app-no-step src
2197             (let ((tail? #f))
2198               (macro-gen ##gen-loc-ref-no-step src ;; fetch do-loop-var
2199                 0
2200                 1))
2201             (##comp-vals cte src (##bindings->vals src bindings-src))))))))
2202
2203 ;;; - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
2204
2205 (define (##comp-app cte src tail?)
2206   (let* ((code (##source-code src))
2207          (len (##proper-length code)))
2208     (if len
2209       (let ((tail? (##tail-call? cte tail?)))
2210         (macro-gen ##gen-app src
2211           (##comp cte (##sourcify (##car code) src) #f)
2212           (##comp-vals cte src (##cdr code))))
2213       (##raise-expression-parsing-exception
2214        'ill-formed-call
2215        src))))
2216
2217 ;;; - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
2218
2219 (define (##comp-delay cte src tail?)
2220   (##shape src src 2)
2221   (let ((code (##source-code src)))
2222     (macro-gen ##gen-delay src
2223       (##comp cte (##sourcify (##cadr code) src) #t))))
2224
2225 ;;; - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
2226
2227 (define (##comp-future cte src tail?)
2228   (##shape src src 2)
2229   (let ((code (##source-code src)))
2230     (macro-gen ##gen-future src
2231       (##comp cte (##sourcify (##cadr code) src) #t))))
2232
2233 ;;; - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
2234
2235 (define (##comp-this-source-file cte src tail?)
2236   (let* ((locat
2237           (##source-locat src))
2238          (path
2239           (and locat
2240                (##container->path (##locat-container locat)))))
2241     (if path
2242       (macro-gen ##gen-cst src
2243         path)
2244       (##raise-expression-parsing-exception
2245        'unknown-location
2246        src))))
2247
2248 ;;;============================================================================
2249
2250 ;;; Code generation procedures
2251
2252 ;;;----------------------------------------------------------------------------
2253
2254 (define ##cprc-top
2255   (macro-make-cprc
2256    (let* (($code (^ 0))
2257           (rte (macro-make-rte rte #f)))
2258      (##first-argument #f) ;; make sure $code and rte are in environment-map
2259      (##check-heap-limit)
2260      (macro-code-run $code))))
2261
2262 (define ##gen-top
2263   (macro-make-gen (val)
2264     (let ((stepper (##no-stepper)))
2265       (macro-make-code ##cprc-top cte src stepper (val)))))
2266
2267 ;;; - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
2268
2269 (define ##cprc-cst
2270   (macro-make-cprc
2271    (macro-constant-step! ()
2272     (^ 0))))
2273
2274 (define ##gen-cst
2275   (macro-make-gen (val)
2276     (let ((stepper (##current-stepper)))
2277       (macro-make-code ##cprc-cst cte src stepper ()
2278         val))))
2279
2280 (define ##gen-cst-no-step
2281   (macro-make-gen (val)
2282     (let ((stepper (##no-stepper)))
2283       (macro-make-code ##cprc-cst cte src stepper ()
2284         val))))
2285
2286 ;;; - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
2287
2288 (define ##cprc-loc-ref-0-1
2289   (macro-make-cprc
2290    (macro-reference-step! ()
2291     (macro-rte-ref rte 1))))
2292
2293 (define ##cprc-loc-ref-0-2
2294   (macro-make-cprc
2295    (macro-reference-step! ()
2296     (macro-rte-ref rte 2))))
2297
2298 (define ##cprc-loc-ref-0-3
2299   (macro-make-cprc
2300    (macro-reference-step! ()
2301     (macro-rte-ref rte 3))))
2302
2303 (define ##cprc-loc-ref-1-1
2304   (macro-make-cprc
2305    (macro-reference-step! ()
2306     (macro-rte-ref (macro-rte-up rte) 1))))
2307
2308 (define ##cprc-loc-ref-1-2
2309   (macro-make-cprc
2310    (macro-reference-step! ()
2311     (macro-rte-ref (macro-rte-up rte) 2))))
2312
2313 (define ##cprc-loc-ref-1-3
2314   (macro-make-cprc
2315    (macro-reference-step! ()
2316     (macro-rte-ref (macro-rte-up rte) 3))))
2317
2318 (define ##cprc-loc-ref-2-1
2319   (macro-make-cprc
2320    (macro-reference-step! ()
2321     (macro-rte-ref (macro-rte-up (macro-rte-up rte)) 1))))
2322
2323 (define ##cprc-loc-ref-2-2
2324   (macro-make-cprc
2325    (macro-reference-step! ()
2326     (macro-rte-ref (macro-rte-up (macro-rte-up rte)) 2))))
2327
2328 (define ##cprc-loc-ref-2-3
2329   (macro-make-cprc
2330    (macro-reference-step! ()
2331     (macro-rte-ref (macro-rte-up (macro-rte-up rte)) 3))))
2332
2333 (define ##cprc-loc-ref
2334   (macro-make-cprc
2335    (macro-reference-step! ()
2336     (let ((up (^ 0)))
2337       (let loop ((e rte) (i up))
2338         (if (##fixnum.< 0 i)
2339           (loop (macro-rte-up e) (##fixnum.- i 1))
2340           (macro-rte-ref e (^ 1))))))))
2341
2342 (define ##gen-loc-ref-aux
2343   (macro-make-gen (stepper up over)
2344     (case up
2345       ((0)
2346        (case over
2347          ((1)  (macro-make-code ##cprc-loc-ref-0-1 cte src stepper ()))
2348          ((2)  (macro-make-code ##cprc-loc-ref-0-2 cte src stepper ()))
2349          ((3)  (macro-make-code ##cprc-loc-ref-0-3 cte src stepper ()))
2350          (else (macro-make-code ##cprc-loc-ref     cte src stepper ()
2351                  up
2352                  over))))
2353       ((1)
2354        (case over
2355          ((1)  (macro-make-code ##cprc-loc-ref-1-1 cte src stepper ()))
2356          ((2)  (macro-make-code ##cprc-loc-ref-1-2 cte src stepper ()))
2357          ((3)  (macro-make-code ##cprc-loc-ref-1-3 cte src stepper ()))
2358          (else (macro-make-code ##cprc-loc-ref     cte src stepper ()
2359                  up
2360                  over))))
2361       ((2)
2362        (case over
2363          ((1)  (macro-make-code ##cprc-loc-ref-2-1 cte src stepper ()))
2364          ((2)  (macro-make-code ##cprc-loc-ref-2-2 cte src stepper ()))
2365          ((3)  (macro-make-code ##cprc-loc-ref-2-3 cte src stepper ()))
2366          (else (macro-make-code ##cprc-loc-ref     cte src stepper ()
2367                  up
2368                  over))))
2369      (else
2370       (macro-make-code ##cprc-loc-ref cte src stepper ()
2371         up
2372         over)))))
2373
2374 (define ##gen-loc-ref
2375   (macro-make-gen (up over)
2376     (let ((stepper (##current-stepper)))
2377       (macro-gen ##gen-loc-ref-aux src stepper up over))))
2378
2379 (define ##gen-loc-ref-no-step
2380   (macro-make-gen (up over)
2381     (let ((stepper (##no-stepper)))
2382       (macro-gen ##gen-loc-ref-aux src stepper up over))))
2383
2384 ;;; - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
2385
2386 (define ##cprc-glo-ref
2387   (macro-make-cprc
2388    (macro-reference-step! ()
2389     (let ((val (##global-var-ref (^ 0))))
2390       (if (macro-unbound? val)
2391         (##first-argument ;; keep $code and rte in environment-map
2392           (##raise-unbound-global-exception $code rte (^ 0))
2393           $code
2394           rte)
2395         val)))))
2396
2397 (define ##gen-glo-ref
2398   (macro-make-gen (ind)
2399     (let ((stepper (##current-stepper)))
2400       (macro-make-code ##cprc-glo-ref cte src stepper ()
2401         ind))))
2402
2403 ;;; - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
2404
2405 (define ##cprc-loc-set
2406   (macro-make-cprc
2407    (let ((val (macro-code-run (^ 0))))
2408      (macro-set!-step! (val)
2409       (let ((up (^ 1)))
2410         (let loop ((e rte) (i up))
2411           (if (##fixnum.< 0 i)
2412             (loop (macro-rte-up e) (##fixnum.- i 1))
2413             (begin
2414               (macro-rte-set! e (^ 2) val)
2415               (##void)))))))))
2416
2417 (define ##gen-loc-set
2418   (macro-make-gen (up over val)
2419     (let ((stepper (##current-stepper)))
2420       (macro-make-code ##cprc-loc-set cte src stepper (val)
2421         up
2422         over))))
2423
2424 (define ##cprc-glo-set
2425   (macro-make-cprc
2426    (let ((val (macro-code-run (^ 0))))
2427      (macro-set!-step! (val)
2428       (if (macro-unbound? (##global-var-ref (^ 1)))
2429         (##first-argument ;; keep $code and rte in environment-map
2430           (##raise-unbound-global-exception $code rte (^ 1))
2431           $code
2432           rte)
2433         (begin
2434           (##global-var-set! (^ 1) val)
2435           (##void)))))))
2436
2437 (define ##gen-glo-set
2438   (macro-make-gen (ind val)
2439     (let ((stepper (##current-stepper)))
2440       (macro-make-code ##cprc-glo-set cte src stepper (val)
2441         ind))))
2442
2443 ;;; - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
2444
2445 (define ##cprc-glo-def
2446   (macro-make-cprc
2447    (let ((rte (##first-argument #f))) ;; avoid constant propagation of #f
2448      (let ((val (macro-code-run (^ 0))))
2449        (macro-define-step! (val)
2450          (##global-var-set! (^ 1) val)
2451          (##void))))))
2452
2453 (define ##gen-glo-def
2454   (macro-make-gen (ind val)
2455     (let ((stepper (##no-stepper)))
2456       (macro-make-code ##cprc-glo-def cte src stepper (val)
2457         ind))))
2458
2459 ;;; - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
2460
2461 (define ##cprc-if2
2462   (macro-make-cprc
2463    (let ((pred (macro-code-run (^ 0))))
2464      (macro-force-vars (pred)
2465        (if (macro-true? pred)
2466          (macro-code-run (^ 1))
2467          (##void))))))
2468
2469 (define ##gen-if2
2470   (macro-make-gen (pre con)
2471     (let ((stepper (##no-stepper)))
2472       (macro-make-code ##cprc-if2 cte src stepper (pre con)))))
2473
2474 (define ##cprc-if3
2475   (macro-make-cprc
2476    (let ((pred (macro-code-run (^ 0))))
2477      (macro-force-vars (pred)
2478        (if (macro-true? pred)
2479          (macro-code-run (^ 1))
2480          (macro-code-run (^ 2)))))))
2481
2482 (define ##gen-if3
2483   (macro-make-gen (pre con alt)
2484     (let ((stepper (##no-stepper)))
2485       (macro-make-code ##cprc-if3 cte src stepper (pre con alt)))))
2486
2487 ;;; - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
2488
2489 (define ##cprc-seq
2490   (macro-make-cprc
2491    (begin
2492      (macro-code-run (^ 0))
2493      (macro-code-run (^ 1)))))
2494
2495 (define ##gen-seq
2496   (macro-make-gen (val1 val2)
2497     (let ((stepper (##no-stepper)))
2498       (macro-make-code ##cprc-seq cte src stepper (val1 val2)))))
2499
2500 ;;; - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
2501
2502 (define ##cprc-quasi-list->vector
2503   (macro-make-cprc
2504    (##quasi-list->vector
2505     (##first-argument ;; keep $code and rte in environment-map
2506       (macro-code-run (^ 0))
2507       $code
2508       rte))))
2509
2510 (define ##gen-quasi-list->vector
2511   (macro-make-gen (val)
2512     (let ((stepper (##no-stepper)))
2513       (macro-make-code ##cprc-quasi-list->vector cte src stepper (val)))))
2514
2515 (define ##cprc-quasi-append
2516   (macro-make-cprc
2517    (let* ((val1
2518            (macro-code-run (^ 0)))
2519           (val2
2520            (macro-code-run (^ 1))))
2521      (##first-argument $code rte) ;; keep $code and rte in environment-map
2522      (##quasi-append val1 val2))))
2523
2524 (define ##gen-quasi-append
2525   (macro-make-gen (val1 val2)
2526     (let ((stepper (##no-stepper)))
2527       (macro-make-code ##cprc-quasi-append cte src stepper (val1 val2)))))
2528
2529 (define ##cprc-quasi-cons
2530   (macro-make-cprc
2531    (let* ((val1
2532            (macro-code-run (^ 0)))
2533           (val2
2534            (macro-code-run (^ 1)))
2535           (result
2536            (##quasi-cons val1 val2)))
2537      (##check-heap-limit)
2538      (##first-argument result $code rte)))) ;; keep $code and rte in environment-map
2539
2540 (define ##gen-quasi-cons
2541   (macro-make-gen (val1 val2)
2542     (let ((stepper (##no-stepper)))
2543       (macro-make-code ##cprc-quasi-cons cte src stepper (val1 val2)))))
2544
2545 ;;; - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
2546
2547 (define ##cprc-cond-if
2548   (macro-make-cprc
2549    (let ((pred (macro-code-run (^ 0))))
2550      (macro-force-vars (pred)
2551        (if (macro-true? pred)
2552          (macro-code-run (^ 1))
2553          (macro-code-run (^ 2)))))))
2554
2555 (define ##gen-cond-if
2556   (macro-make-gen (val1 val2 val3)
2557     (let ((stepper (##no-stepper)))
2558       (macro-make-code ##cprc-cond-if cte src stepper (val1 val2 val3)))))
2559
2560 (define ##cprc-cond-or
2561   (macro-make-cprc
2562    (let ((pred (macro-code-run (^ 0))))
2563      (macro-force-vars (pred)
2564        (if (macro-true? pred)
2565          pred
2566          (macro-code-run (^ 1)))))))
2567
2568 (define ##gen-cond-or
2569   (macro-make-gen (val1 val2)
2570     (let ((stepper (##no-stepper)))
2571       (macro-make-code ##cprc-cond-or cte src stepper (val1 val2)))))
2572
2573 (define ##cprc-cond-send-red
2574   (macro-make-cprc
2575    (let ((pred (macro-code-run (^ 0))))
2576      (macro-force-vars (pred)
2577        (if (macro-true? pred)
2578          (let ((oper (macro-code-run (^ 1))))
2579            (macro-force-vars (oper)
2580              (if (##not (##procedure? oper))
2581                (let ((args (##list pred)))
2582                  (##check-heap-limit)
2583                  (##raise-nonprocedure-operator-exception oper args $code rte))
2584                (macro-call-step! (oper pred)
2585                  (oper pred)))))
2586          (macro-code-run (^ 2)))))))
2587
2588 (define ##cprc-cond-send-sub
2589   (macro-make-cprc
2590    (let ((pred (macro-code-run (^ 0))))
2591      (macro-force-vars (pred)
2592        (if (macro-true? pred)
2593          (let ((oper (macro-code-run (^ 1))))
2594            (macro-force-vars (oper)
2595              (if (##not (##procedure? oper))
2596                (let ((args (##list pred)))
2597                  (##check-heap-limit)
2598                  (##raise-nonprocedure-operator-exception oper args $code rte))
2599                (##subproblem-apply1 $code rte oper pred))))
2600          (macro-code-run (^ 2)))))))
2601
2602 (define ##gen-cond-send
2603   (macro-make-gen (val1 val2 val3)
2604     (let ((stepper (##no-stepper)))
2605       (macro-make-code (if tail? ##cprc-cond-send-red ##cprc-cond-send-sub)
2606                        cte
2607                        src
2608                        stepper
2609                        (val1 val2 val3)))))
2610
2611 ;;; - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
2612
2613 (define ##cprc-or
2614   (macro-make-cprc
2615    (let ((pred (macro-code-run (^ 0))))
2616      (macro-force-vars (pred)
2617        (if (macro-true? pred)
2618          pred
2619          (macro-code-run (^ 1)))))))
2620
2621 (define ##gen-or
2622   (macro-make-gen (val1 val2)
2623     (let ((stepper (##no-stepper)))
2624       (macro-make-code ##cprc-or cte src stepper (val1 val2)))))
2625
2626 (define ##cprc-and
2627   (macro-make-cprc
2628    (let ((pred (macro-code-run (^ 0))))
2629      (macro-force-vars (pred)
2630        (if (##not (macro-true? pred))
2631          pred
2632          (macro-code-run (^ 1)))))))
2633
2634 (define ##gen-and
2635   (macro-make-gen (val1 val2)
2636     (let ((stepper (##no-stepper)))
2637       (macro-make-code ##cprc-and cte src stepper (val1 val2)))))
2638
2639 ;;; - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
2640
2641 (define ##cprc-case
2642   (macro-make-cprc
2643    (let ((selector (macro-code-run (^ 0))))
2644      (macro-force-vars (selector)
2645        (let* (($code (^ 1))
2646               (rte (macro-make-rte rte selector)))
2647          (##first-argument #f) ;; make sure $code and rte are in environment-map
2648          (##check-heap-limit)
2649          (macro-code-run $code))))))
2650
2651 (define ##gen-case
2652   (macro-make-gen (val1 val2)
2653     (let ((stepper (##no-stepper)))
2654       (macro-make-code ##cprc-case cte src stepper (val1 val2)))))
2655
2656 (define ##cprc-case-clause
2657   (macro-make-cprc
2658    (if (##case-memv (macro-rte-ref rte 1) (^ 2))
2659      (macro-code-run (^ 0))
2660      (macro-code-run (^ 1)))))
2661
2662 (define ##gen-case-clause
2663   (macro-make-gen (cases val1 val2)
2664     (let ((stepper (##no-stepper)))
2665       (macro-make-code ##cprc-case-clause cte src stepper (val1 val2)
2666         cases))))
2667
2668 (define ##cprc-case-else
2669   (macro-make-cprc
2670    (macro-code-run (^ 0))))
2671
2672 (define ##gen-case-else
2673   (macro-make-gen (val)
2674     (let ((stepper (##no-stepper)))
2675       (macro-make-code ##cprc-case-else cte src stepper (val)))))
2676
2677 ;;; - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
2678
2679 (define ##cprc-let
2680   (macro-make-cprc
2681    (let ((ns (##fixnum.- (macro-code-length $code) 2)))
2682      (let loop1 ((i 1) (args '()))
2683        (if (##fixnum.< ns i)
2684          (let ((inner-rte (macro-make-rte* rte ns)))
2685            (##check-heap-limit)
2686            (let loop2 ((i ns) (args args))
2687              (if (##fixnum.< 0 i)
2688                (begin
2689                  (macro-rte-set! inner-rte i (##car args))
2690                  (loop2 (##fixnum.- i 1) (##cdr args)))
2691                (let* (($code
2692                        (^ 0))
2693                       (rte
2694                        (##first-argument ;; keep $code and rte in environment-map
2695                          inner-rte
2696                          rte)))
2697                  (macro-code-run $code)))))
2698          (let ((new-args
2699                 (##cons (macro-code-run (macro-code-ref $code i)) args)))
2700            (##check-heap-limit)
2701            (loop1 (##fixnum.+ i 1) new-args)))))))
2702
2703 (define ##gen-let
2704   (macro-make-gen (vars vals body)
2705     (let* ((stepper
2706             (##no-stepper))
2707            (c
2708             (##make-code* ##cprc-let cte src stepper (##cons body vals) 1)))
2709       (macro-code-set! c (##fixnum.+ (##length vals) 1) vars)
2710       c)))
2711
2712 (define ##cprc-letrec
2713   (macro-make-cprc
2714    (let ((ns (##fixnum.- (macro-code-length $code) 2)))
2715      (let ((inner-rte (macro-make-rte* rte ns)))
2716        (let loop1 ((i 1) (rev-vals '()))
2717          (if (##fixnum.< ns i)
2718            (let loop2 ((i i) (rev-vals rev-vals))
2719              (if (##fixnum.< 1 i)
2720                (let ((new-i (##fixnum.- i 1)))
2721                  (macro-rte-set! inner-rte new-i (##car rev-vals))
2722                  (loop2 new-i (##cdr rev-vals)))
2723                (let* (($code (^ 0))
2724                       (rte (##first-argument inner-rte rte)))
2725                  (macro-code-run $code))))
2726            (let ((new-rev-vals
2727                   (##cons (let* (($code (macro-code-ref $code i))
2728                                  (rte inner-rte))
2729                             (macro-code-run $code))
2730                           rev-vals)))
2731              (##check-heap-limit)
2732              (loop1 (##fixnum.+ i 1) new-rev-vals))))))))
2733
2734 (define ##gen-letrec
2735   (macro-make-gen (vars vals body)
2736     (let* ((stepper
2737             (##no-stepper))
2738            (c
2739             (##make-code* ##cprc-letrec cte src stepper (##cons body vals) 1)))
2740       (macro-code-set! c (##fixnum.+ (##length vals) 1) vars)
2741       c)))
2742
2743 ;;; - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
2744
2745 (define ##cprc-prc-req0
2746   (macro-make-cprc
2747    (macro-lambda-step! ()
2748      (letrec ((proc
2749                (lambda arg1-and-up
2750
2751                  (##define-macro (execute)
2752                    `(if (##not (##null? arg1-and-up))
2753                       (##raise-wrong-number-of-arguments-exception
2754                        proc
2755                        arg1-and-up)
2756                       (let* (($code (^ 0))
2757                              (rte (macro-make-rte rte proc)))
2758                         (##first-argument #f) ;; make sure $code and rte are in environment-map
2759                         (##check-heap-limit)
2760                         (macro-code-run $code))))
2761
2762                  (let ((entry-hook (^ 1)))
2763                    (if entry-hook
2764                      (let ((exec (lambda () (execute))))
2765                        (##check-heap-limit)
2766                        (entry-hook proc arg1-and-up exec))
2767                      (execute))))))
2768
2769        (##check-heap-limit)
2770        (##first-argument ;; keep $code and rte in environment-map
2771          proc
2772          $code
2773          rte)))))
2774
2775 (define ##cprc-prc-req1
2776   (macro-make-cprc
2777    (macro-lambda-step! ()
2778      (letrec ((proc
2779                (lambda (#!optional (arg1 (macro-absent-obj))
2780                         #!rest arg2-and-up)
2781
2782                  (##define-macro (execute)
2783                    `(if (or (##eq? arg1 (macro-absent-obj))
2784                             (##not (##null? arg2-and-up)))
2785                       (let ((args
2786                              (cond ((##eq? arg1 (macro-absent-obj))
2787                                     '())
2788                                    (else
2789                                     (##cons arg1 arg2-and-up)))))
2790                         (##check-heap-limit)
2791                         (##first-argument $code rte)
2792                         (##raise-wrong-number-of-arguments-exception
2793                          proc
2794                          args))
2795                       (let* (($code (^ 0))
2796                              (rte (macro-make-rte rte proc arg1)))
2797                         (##first-argument #f) ;; make sure $code and rte are in environment-map
2798                         (##check-heap-limit)
2799                         (macro-code-run $code))))
2800
2801                  (let ((entry-hook (^ 1)))
2802                    (if entry-hook
2803                      (let* ((args
2804                               (##cons arg1 arg2-and-up))
2805                             (exec
2806                              (lambda () (execute))))
2807                        (##check-heap-limit)
2808                        (##first-argument $code rte)
2809                        (entry-hook proc args exec))
2810                      (execute))))))
2811
2812        (##check-heap-limit)
2813        (##first-argument ;; keep $code and rte in environment-map
2814          proc
2815          $code
2816          rte)))))
2817
2818 (define ##cprc-prc-req2
2819   (macro-make-cprc
2820    (macro-lambda-step! ()
2821      (letrec ((proc
2822                (lambda (#!optional (arg1 (macro-absent-obj))
2823                                    (arg2 (macro-absent-obj))
2824                         #!rest arg3-and-up)
2825
2826                  (##define-macro (execute)
2827                    `(if (or (##eq? arg2 (macro-absent-obj))
2828                             (##not (##null? arg3-and-up)))
2829                       (let ((args
2830                              (cond ((##eq? arg1 (macro-absent-obj))
2831                                     '())
2832                                    ((##eq? arg2 (macro-absent-obj))
2833                                     (##list arg1))
2834                                    (else
2835                                     (##cons arg1
2836                                             (##cons arg2 arg3-and-up))))))
2837                         (##check-heap-limit)
2838                         (##first-argument $code rte)
2839                         (##raise-wrong-number-of-arguments-exception
2840                          proc
2841                          args))
2842                       (let* (($code (^ 0))
2843                              (rte (macro-make-rte rte proc arg1 arg2)))
2844                         (##first-argument #f) ;; make sure $code and rte are in environment-map
2845                         (##check-heap-limit)
2846                         (macro-code-run $code))))
2847
2848                  (let ((entry-hook (^ 1)))
2849                    (if entry-hook
2850                      (let* ((args
2851                               (##cons arg1
2852                                       (##cons arg2 arg3-and-up)))
2853                             (exec
2854                              (lambda () (execute))))
2855                        (##check-heap-limit)
2856                        (##first-argument $code rte)
2857                        (entry-hook proc args exec))
2858                      (execute))))))
2859
2860        (##check-heap-limit)
2861        (##first-argument ;; keep $code and rte in environment-map
2862          proc
2863          $code
2864          rte)))))
2865
2866 (define ##cprc-prc-req3
2867   (macro-make-cprc
2868    (macro-lambda-step! ()
2869      (letrec ((proc
2870                (lambda (#!optional (arg1 (macro-absent-obj))
2871                                    (arg2 (macro-absent-obj))
2872                                    (arg3 (macro-absent-obj))
2873                         #!rest arg4-and-up)
2874
2875                  (##define-macro (execute)
2876                    `(if (or (##eq? arg3 (macro-absent-obj))
2877                             (##not (##null? arg4-and-up)))
2878                       (let ((args
2879                              (cond ((##eq? arg1 (macro-absent-obj))
2880                                     '())
2881                                    ((##eq? arg2 (macro-absent-obj))
2882                                     (##list arg1))
2883                                    ((##eq? arg3 (macro-absent-obj))
2884                                     (##list arg1 arg2))
2885                                    (else
2886                                     (##cons arg1
2887                                             (##cons arg2
2888                                                     (##cons arg3
2889                                                             arg4-and-up)))))))
2890                         (##check-heap-limit)
2891                         (##first-argument $code rte)
2892                         (##raise-wrong-number-of-arguments-exception
2893                          proc
2894                          args))
2895                       (let* (($code (^ 0))
2896                              (rte (macro-make-rte rte proc arg1 arg2 arg3)))
2897                         (##first-argument #f) ;; make sure $code and rte are in environment-map
2898                         (##check-heap-limit)
2899                         (macro-code-run $code))))
2900
2901                  (let ((entry-hook (^ 1)))
2902                    (if entry-hook
2903                      (let* ((args
2904                               (##cons arg1
2905                                       (##cons arg2
2906                                               (##cons arg3 arg4-and-up))))
2907                             (exec
2908                              (lambda () (execute))))
2909                        (##check-heap-limit)
2910                        (##first-argument $code rte)
2911                        (entry-hook proc args exec))
2912                      (execute))))))
2913
2914        (##check-heap-limit)
2915        (##first-argument ;; keep $code and rte in environment-map
2916          proc
2917          $code
2918          rte)))))
2919
2920 (define ##cprc-prc-req
2921   (macro-make-cprc
2922    (macro-lambda-step! ()
2923      (letrec ((proc
2924                (lambda args
2925
2926                  (define (execute)
2927                    (let ((ns (^ 1)))
2928                      (let ((inner-rte (macro-make-rte* rte ns)))
2929                        (##check-heap-limit)
2930                        (macro-rte-set! inner-rte 1 proc)
2931                        (let loop ((i 2) (lst args))
2932                          (if (##fixnum.< ns i)
2933                            (if (##pair? lst)
2934                              (##raise-wrong-number-of-arguments-exception
2935                               proc
2936                               args)
2937                              (let* (($code (^ 0))
2938                                     (rte (##first-argument inner-rte rte)))
2939                                (macro-code-run $code)))
2940                            (if (##pair? lst)
2941                              (begin
2942                                (macro-rte-set! inner-rte i (##car lst))
2943                                (loop (##fixnum.+ i 1) (##cdr lst)))
2944                              (##raise-wrong-number-of-arguments-exception
2945                               proc
2946                               args)))))))
2947
2948                  (let ((entry-hook (^ 2)))
2949                    (if entry-hook
2950                      (let ((exec
2951                             (lambda () (execute))))
2952                        (##check-heap-limit)
2953                        (##first-argument $code rte)
2954                        (entry-hook proc args exec))
2955                      (execute))))))
2956
2957        (##check-heap-limit)
2958        (##first-argument ;; keep $code and rte in environment-map
2959          proc
2960          $code
2961          rte)))))
2962
2963 (define ##gen-prc-req-aux
2964   (macro-make-gen (stepper frame body)
2965     (let ((n (##length frame)))
2966       (case n
2967         ((0)
2968          (macro-make-code ##cprc-prc-req0 cte src stepper (body)
2969            #f
2970            frame))
2971         ((1)
2972          (macro-make-code ##cprc-prc-req1 cte src stepper (body)
2973            #f
2974            frame))
2975         ((2)
2976          (macro-make-code ##cprc-prc-req2 cte src stepper (body)
2977            #f
2978            frame))
2979         ((3)
2980          (macro-make-code ##cprc-prc-req3 cte src stepper (body)
2981            #f
2982            frame))
2983         (else
2984          (let ((n+1 (##fixnum.+ n 1)))
2985            (macro-make-code ##cprc-prc-req  cte src stepper (body)
2986              n+1
2987              #f
2988              frame)))))))
2989
2990 (define ##gen-prc-req
2991   (macro-make-gen (frame body)
2992     (let ((stepper (##current-stepper)))
2993       (macro-gen ##gen-prc-req-aux src stepper frame body))))
2994
2995 (define ##gen-prc-req-no-step
2996   (macro-make-gen (frame body)
2997     (let ((stepper (##no-stepper)))
2998       (macro-gen ##gen-prc-req-aux src stepper frame body))))
2999
3000 (define ##cprc-prc-rest
3001   (macro-make-cprc
3002    (macro-lambda-step! ()
3003      (letrec ((proc
3004                (lambda args
3005
3006                  (define (execute)
3007                    (let ((ns (^ 1)))
3008                      (let ((inner-rte (macro-make-rte* rte ns)))
3009                        (##check-heap-limit)
3010                        (macro-rte-set! inner-rte 1 proc)
3011                        (let loop ((i 2) (lst args))
3012                          (if (##fixnum.< i ns)
3013                            (if (##pair? lst)
3014                              (begin
3015                                (macro-rte-set! inner-rte i (##car lst))
3016                                (loop (##fixnum.+ i 1) (##cdr lst)))
3017                              (##raise-wrong-number-of-arguments-exception
3018                               proc
3019                               args))
3020                            (begin
3021                              (macro-rte-set! inner-rte i lst)
3022                              (let* (($code (^ 0))
3023                                     (rte (##first-argument inner-rte rte)))
3024                                (macro-code-run $code))))))))
3025
3026                  (let ((entry-hook (^ 2)))
3027                    (if entry-hook
3028                      (let ((exec
3029                             (lambda () (execute))))
3030                        (##check-heap-limit)
3031                        (##first-argument $code rte)
3032                        (entry-hook proc args exec))
3033                      (execute))))))
3034
3035        (##check-heap-limit)
3036        (##first-argument ;; keep $code and rte in environment-map
3037          proc
3038          $code
3039          rte)))))
3040
3041 (define ##gen-prc-rest
3042   (macro-make-gen (frame body)
3043     (let ((stepper (##current-stepper))
3044           (n+1 (##fixnum.+ (##length frame) 1)))
3045       (macro-make-code ##cprc-prc-rest cte src stepper (body)
3046         n+1
3047         #f
3048         frame))))
3049
3050 (define ##cprc-prc
3051   (macro-make-cprc
3052    (macro-lambda-step! ()
3053      (letrec ((proc
3054                (lambda args
3055
3056                  (define (execute)
3057                    (let* ((n
3058                            (macro-code-length $code))
3059                           (inner-rte
3060                            (macro-make-rte*
3061                             rte
3062                             (macro-code-ref $code (##fixnum.- n 7)))))
3063
3064                      (define reject-illegal-dsssl-parameter-list? #f)
3065
3066                      (define (get-keys i j left rest? keys)
3067                        (let loop1 ((end left))
3068
3069                          (define (keys-ok)
3070                            (let loop3 ((i i) (j j) (k 0))
3071                              (if (##fixnum.< k (##vector-length keys))
3072                                (let ((key (##vector-ref keys k)))
3073                                  (let loop4 ((lst left))
3074                                    (if (##eq? lst end)
3075                                      (begin
3076                                        (macro-rte-set! inner-rte i
3077                                          (let* (($code
3078                                                  (macro-code-ref $code j))
3079                                                 (rte
3080                                                  inner-rte))
3081                                            (macro-code-run $code)))
3082                                        (loop3 (##fixnum.+ i 1)
3083                                               (##fixnum.+ j 1)
3084                                               (##fixnum.+ k 1)))
3085                                      (if (##eq? (##car lst) key)
3086                                        (begin
3087                                          (macro-rte-set! inner-rte i
3088                                            (##cadr lst))
3089                                          (loop3 (##fixnum.+ i 1)
3090                                                 (##fixnum.+ j 1)
3091                                                 (##fixnum.+ k 1)))
3092                                        (loop4 (##cddr lst))))))
3093                                (begin
3094                                  (if (##eq? rest? #t)
3095                                    (macro-rte-set! inner-rte i end))
3096                                  (let* (($code (^ 0))
3097                                         (rte (##first-argument inner-rte rte)))
3098                                    (macro-code-run $code))))))
3099
3100                          (if (##pair? end)
3101                            (let ((key (##car end))
3102                                  (lst (##cdr end)))
3103                              (cond ((##not (##pair? lst))
3104                                     (if (or (##not rest?)
3105                                             (and reject-illegal-dsssl-parameter-list?
3106                                                  (##eq? rest? 'dsssl)))
3107                                       (##raise-wrong-number-of-arguments-exception
3108                                        proc
3109                                        args)
3110                                       (keys-ok)))
3111                                    ((##keyword? key)
3112                                     (if (##eq? rest? 'dsssl)
3113                                       (loop1 (##cdr lst))
3114                                       (let loop2 ((k (##fixnum.-
3115                                                       (##vector-length keys)
3116                                                       1)))
3117                                         (cond ((##fixnum.< k 0)
3118                                                (##raise-unknown-keyword-argument-exception
3119                                                 proc
3120                                                 args))
3121                                               ((##eq? key (##vector-ref keys k))
3122                                                (loop1 (##cdr lst)))
3123                                               (else
3124                                                (loop2 (##fixnum.- k 1)))))))
3125                                    (else
3126                                     (if (or (##not rest?)
3127                                             (and reject-illegal-dsssl-parameter-list?
3128                                                  (##eq? rest? 'dsssl)))
3129                                       (##raise-keyword-expected-exception
3130                                        proc
3131                                        args)
3132                                       (keys-ok)))))
3133                            (keys-ok))))
3134
3135                      (##check-heap-limit)
3136                      (macro-rte-set! inner-rte 1 proc)
3137                      (let loop1 ((i 2) (lst args))
3138                        (if (##fixnum.<
3139                             i
3140                             (macro-code-ref $code (##fixnum.- n 6)))
3141                          (if (##pair? lst)
3142                            (begin
3143                              (macro-rte-set! inner-rte i (##car lst))
3144                              (loop1 (##fixnum.+ i 1) (##cdr lst)))
3145                            (##raise-wrong-number-of-arguments-exception
3146                             proc
3147                             args))
3148                          (let loop2 ((i i) (j 1) (lst lst))
3149                            (if (##fixnum.<
3150                                 i
3151                                 (macro-code-ref $code (##fixnum.- n 5)))
3152                              (if (##pair? lst)
3153                                (begin
3154                                  (macro-rte-set! inner-rte i (##car lst))
3155                                  (loop2 (##fixnum.+ i 1)
3156                                         (##fixnum.+ j 1)
3157                                         (##cdr lst)))
3158                                (begin
3159                                  (macro-rte-set! inner-rte i
3160                                    (let* (($code (macro-code-ref $code j))
3161                                           (rte inner-rte))
3162                                      (macro-code-run $code)))
3163                                  (loop2 (##fixnum.+ i 1)
3164                                         (##fixnum.+ j 1)
3165                                         '())))
3166                              (let ((keys
3167                                     (macro-code-ref $code (##fixnum.- n 3)))
3168                                    (rest?
3169                                     (macro-code-ref $code (##fixnum.- n 4))))
3170                                (cond (rest?
3171                                       (if keys
3172                                         (get-keys
3173                                          (if (##eq? rest? 'dsssl)
3174                                            (begin
3175                                              (macro-rte-set! inner-rte i lst)
3176                                              (##fixnum.+ i 1))
3177                                            i)
3178                                          j
3179                                          lst
3180                                          rest?
3181                                          keys)
3182                                         (begin
3183                                           (macro-rte-set! inner-rte i lst)
3184                                           (let* (($code
3185                                                   (^ 0))
3186                                                  (rte
3187                                                   (##first-argument
3188                                                    inner-rte
3189                                                    rte)))
3190                                             (macro-code-run $code)))))
3191                                      (keys
3192                                       (get-keys i
3193                                                 j
3194                                                 lst
3195                                                 rest?
3196                                                 keys))
3197                                      ((##null? lst)
3198                                       (let* (($code
3199                                               (^ 0))
3200                                              (rte
3201                                               (##first-argument
3202                                                 inner-rte
3203                                                 rte)))
3204                                         (macro-code-run $code)))
3205                                      (else
3206                                       (##raise-wrong-number-of-arguments-exception
3207                                        proc
3208                                        args))))))))))
3209
3210                  (let ((entry-hook
3211                         (macro-code-ref $code
3212                                         (##fixnum.- (macro-code-length $code) 2))))
3213                    (if entry-hook
3214                      (let ((exec
3215                             (lambda () (execute))))
3216                        (##check-heap-limit)
3217                        (##first-argument $code rte)
3218                        (entry-hook proc args exec))
3219                      (execute))))))
3220
3221        (##check-heap-limit)
3222        (##first-argument ;; keep $code and rte in environment-map
3223          proc
3224          $code
3225          rte)))))
3226
3227 (define ##gen-prc
3228   (macro-make-gen (frame rest? keys body inits)
3229     (let* ((stepper
3230             (##current-stepper))
3231            (n
3232             (##length frame))
3233            (ni
3234             (##length inits))
3235            (nr
3236             (##fixnum.- (##fixnum.- n ni) (if rest? 1 0)))
3237            (no
3238             (##fixnum.- ni (if keys (##vector-length keys) 0)))
3239            (c
3240             (##make-code* ##cprc-prc cte src stepper (##cons body inits) 7)))
3241       (macro-code-set! c (##fixnum.+ ni 1) (##fixnum.+ n 1))
3242       (macro-code-set! c (##fixnum.+ ni 2) (##fixnum.+ nr 2))
3243       (macro-code-set! c (##fixnum.+ ni 3) (##fixnum.+ (##fixnum.+ nr 2) no))
3244       (macro-code-set! c (##fixnum.+ ni 4) rest?)
3245       (macro-code-set! c (##fixnum.+ ni 5) keys)
3246       (macro-code-set! c (##fixnum.+ ni 6) #f)
3247       (macro-code-set! c (##fixnum.+ ni 7) frame)
3248       c)))
3249
3250 ;;; - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
3251
3252 (define ##cprc-app0-red
3253   (macro-make-cprc
3254    (let ((oper (macro-code-run (^ 0))))
3255      (macro-force-vars (oper)
3256        (if (##not (##procedure? oper))
3257          (##raise-nonprocedure-operator-exception oper '() $code rte)
3258          (macro-call-step! (oper)
3259            (oper)))))))
3260
3261 (define ##cprc-app1-red
3262   (macro-make-cprc
3263    (let* ((oper (macro-code-run (^ 0)))
3264           (arg1 (macro-code-run (^ 1))))
3265      (macro-force-vars (oper)
3266        (if (##not (##procedure? oper))
3267          (let ((args (##list arg1)))
3268            (##check-heap-limit)
3269            (##raise-nonprocedure-operator-exception oper args $code rte))
3270          (macro-call-step! (oper arg1)
3271            (oper arg1)))))))
3272
3273 (define ##cprc-app2-red
3274   (macro-make-cprc
3275    (let* ((oper (macro-code-run (^ 0)))
3276           (arg1 (macro-code-run (^ 1)))
3277           (arg2 (macro-code-run (^ 2))))
3278      (macro-force-vars (oper)
3279        (if (##not (##procedure? oper))
3280          (let ((args (##list arg1 arg2)))
3281            (##check-heap-limit)
3282            (##raise-nonprocedure-operator-exception oper args $code rte))
3283          (macro-call-step! (oper arg1 arg2)
3284            (oper arg1 arg2)))))))
3285
3286 (define ##cprc-app3-red
3287   (macro-make-cprc
3288    (let* ((oper (macro-code-run (^ 0)))
3289           (arg1 (macro-code-run (^ 1)))
3290           (arg2 (macro-code-run (^ 2)))
3291           (arg3 (macro-code-run (^ 3))))
3292      (macro-force-vars (oper)
3293        (if (##not (##procedure? oper))
3294          (let ((args (##list arg1 arg2 arg3)))
3295            (##check-heap-limit)
3296            (##raise-nonprocedure-operator-exception oper args $code rte))
3297          (macro-call-step! (oper arg1 arg2 arg3)
3298            (oper arg1 arg2 arg3)))))))
3299
3300 (define ##cprc-app4-red
3301   (macro-make-cprc
3302    (let* ((oper (macro-code-run (^ 0)))
3303           (arg1 (macro-code-run (^ 1)))
3304           (arg2 (macro-code-run (^ 2)))
3305           (arg3 (macro-code-run (^ 3)))
3306           (arg4 (macro-code-run (^ 4))))
3307      (macro-force-vars (oper)
3308        (if (##not (##procedure? oper))
3309          (let ((args (##list arg1 arg2 arg3 arg4)))
3310            (##check-heap-limit)
3311            (##raise-nonprocedure-operator-exception oper args $code rte))
3312          (macro-call-step! (oper arg1 arg2 arg3 arg4)
3313            (oper arg1 arg2 arg3 arg4)))))))
3314
3315 (define ##cprc-app-red
3316   (macro-make-cprc
3317    (let ((oper (macro-code-run (^ 0))))
3318      (let loop ((i 1) (rev-args '()))
3319        (if (##fixnum.< i (macro-code-length $code))
3320          (let ((new-rev-args
3321                 (##cons (macro-code-run (macro-code-ref $code i)) rev-args)))
3322            (##check-heap-limit)
3323            (loop (##fixnum.+ i 1) new-rev-args))
3324          (let ((args (##reverse rev-args)))
3325            (macro-force-vars (oper)
3326              (if (##not (##procedure? oper))
3327                (##raise-nonprocedure-operator-exception oper args $code rte)
3328                (macro-call-step! (oper args)
3329                  (begin
3330                    (##first-argument $code rte);;;;;;;;;obsolete?
3331                    (##apply oper args)))))))))))
3332
3333 (define ##cprc-app0-sub
3334   (macro-make-cprc
3335    (let ((oper (macro-code-run (^ 0))))
3336      (macro-force-vars (oper)
3337        (if (##not (##procedure? oper))
3338          (##raise-nonprocedure-operator-exception oper '() $code rte)
3339          (##subproblem-apply0 $code rte oper))))))
3340
3341 (define ##cprc-app1-sub
3342   (macro-make-cprc
3343    (let* ((oper (macro-code-run (^ 0)))
3344           (arg1 (macro-code-run (^ 1))))
3345      (macro-force-vars (oper)
3346        (if (##not (##procedure? oper))
3347          (let ((args (##list arg1)))
3348            (##check-heap-limit)
3349            (##raise-nonprocedure-operator-exception oper args $code rte))
3350          (##subproblem-apply1 $code rte oper arg1))))))
3351
3352 (define ##cprc-app2-sub
3353   (macro-make-cprc
3354    (let* ((oper (macro-code-run (^ 0)))
3355           (arg1 (macro-code-run (^ 1)))
3356           (arg2 (macro-code-run (^ 2))))
3357      (macro-force-vars (oper)
3358        (if (##not (##procedure? oper))
3359          (let ((args (##list arg1 arg2)))
3360            (##check-heap-limit)
3361            (##raise-nonprocedure-operator-exception oper args $code rte))
3362          (##subproblem-apply2 $code rte oper arg1 arg2))))))
3363
3364 (define ##cprc-app3-sub
3365   (macro-make-cprc
3366    (let* ((oper (macro-code-run (^ 0)))
3367           (arg1 (macro-code-run (^ 1)))
3368           (arg2 (macro-code-run (^ 2)))
3369           (arg3 (macro-code-run (^ 3))))
3370      (macro-force-vars (oper)
3371        (if (##not (##procedure? oper))
3372          (let ((args (##list arg1 arg2 arg3)))
3373            (##check-heap-limit)
3374            (##raise-nonprocedure-operator-exception oper args $code rte))
3375          (##subproblem-apply3 $code rte oper arg1 arg2 arg3))))))
3376
3377 (define ##cprc-app4-sub
3378   (macro-make-cprc
3379    (let* ((oper (macro-code-run (^ 0)))
3380           (arg1 (macro-code-run (^ 1)))
3381           (arg2 (macro-code-run (^ 2)))
3382           (arg3 (macro-code-run (^ 3)))
3383           (arg4 (macro-code-run (^ 4))))
3384      (macro-force-vars (oper)
3385        (if (##not (##procedure? oper))
3386          (let ((args (##list arg1 arg2 arg3 arg4)))
3387            (##check-heap-limit)
3388            (##raise-nonprocedure-operator-exception oper args $code rte))
3389          (##subproblem-apply4 $code rte oper arg1 arg2 arg3 arg4))))))
3390
3391 (define ##cprc-app-sub
3392   (macro-make-cprc
3393    (let ((oper (macro-code-run (^ 0))))
3394      (let loop ((i 1) (rev-args '()))
3395        (if (##fixnum.< i (macro-code-length $code))
3396          (let ((new-rev-args
3397                 (##cons (macro-code-run (macro-code-ref $code i)) rev-args)))
3398            (##check-heap-limit)
3399            (loop (##fixnum.+ i 1) new-rev-args))
3400          (let ((args (##reverse rev-args)))
3401            (macro-force-vars (oper)
3402              (if (##not (##procedure? oper))
3403                (##raise-nonprocedure-operator-exception oper args $code rte)
3404                (macro-call-step! (oper args)
3405                  (##subproblem-apply $code rte oper args))))))))))
3406
3407 (define ##generate-proper-tail-calls
3408   (##make-parameter #t))
3409
3410 (define generate-proper-tail-calls
3411   ##generate-proper-tail-calls)
3412
3413 (define ##gen-app-aux
3414   (macro-make-gen (stepper oper args)
3415     (if (and tail? (##generate-proper-tail-calls))
3416       (case (##length args)
3417         ((0)
3418          (macro-make-code ##cprc-app0-red
3419                           cte
3420                           src
3421                           stepper
3422                           (oper)))
3423         ((1)
3424          (macro-make-code ##cprc-app1-red
3425                           cte
3426                           src
3427                           stepper
3428                           (oper (##car args))))
3429         ((2)
3430          (macro-make-code ##cprc-app2-red
3431                           cte
3432                           src
3433                           stepper
3434                           (oper (##car args) (##cadr args))))
3435         ((3)
3436          (macro-make-code ##cprc-app3-red
3437                           cte
3438                           src
3439                           stepper
3440                           (oper (##car args) (##cadr args) (##caddr args))))
3441         ((4)
3442          (macro-make-code ##cprc-app4-red
3443                           cte
3444                           src
3445                           stepper
3446                           (oper (##car args) (##cadr args) (##caddr args) (##cadddr args))))
3447         (else
3448          (##make-code* ##cprc-app-red
3449                        cte
3450                        src
3451                        stepper
3452                        (##cons oper args)
3453                        0)))
3454       (case (##length args)
3455         ((0)
3456          (macro-make-code ##cprc-app0-sub
3457                           cte
3458                           src
3459                           stepper
3460                           (oper)))
3461         ((1)
3462          (macro-make-code ##cprc-app1-sub
3463                           cte
3464                           src
3465                           stepper
3466                           (oper (##car args))))
3467         ((2)
3468          (macro-make-code ##cprc-app2-sub
3469                           cte
3470                           src
3471                           stepper
3472                           (oper (##car args) (##cadr args))))
3473         ((3)
3474          (macro-make-code ##cprc-app3-sub
3475                           cte
3476                           src
3477                           stepper
3478                           (oper (##car args) (##cadr args) (##caddr args))))
3479         ((4)
3480          (macro-make-code ##cprc-app4-sub
3481                           cte
3482                           src
3483                           stepper
3484                           (oper (##car args) (##cadr args) (##caddr args) (##cadddr args))))
3485         (else
3486          (##make-code* ##cprc-app-sub
3487                        cte
3488                        src
3489                        stepper
3490                        (##cons oper args)
3491                        0))))))
3492
3493 (define ##gen-app
3494   (macro-make-gen (oper args)
3495     (let ((stepper (##current-stepper)))
3496       (macro-gen ##gen-app-aux src stepper oper args))))
3497
3498 (define ##gen-app-no-step
3499   (macro-make-gen (oper args)
3500     (let ((stepper (##no-stepper)))
3501       (macro-gen ##gen-app-aux src stepper oper args))))
3502
3503 ;;; - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
3504
3505 (define ##subproblem-apply0
3506   (let ()
3507     (##declare (not inline) (not interrupts-enabled) (environment-map))
3508     (lambda ($code rte proc)
3509       (macro-call-step! (proc)
3510         (##first-argument
3511          (proc)
3512          $code
3513          rte)))))
3514
3515 (define ##subproblem-apply1
3516   (let ()
3517     (##declare (not inline) (not interrupts-enabled) (environment-map))
3518     (lambda ($code rte proc arg1)
3519       (macro-call-step! (proc arg1)
3520         (##first-argument
3521          (proc arg1)
3522          $code
3523          rte)))))
3524
3525 (define ##subproblem-apply2
3526   (let ()
3527     (##declare (not inline) (not interrupts-enabled) (environment-map))
3528     (lambda ($code rte proc arg1 arg2)
3529       (macro-call-step! (proc arg1 arg2)
3530         (##first-argument
3531          (proc arg1 arg2)
3532          $code
3533          rte)))))
3534
3535 (define ##subproblem-apply3
3536   (let ()
3537     (##declare (not inline) (not interrupts-enabled) (environment-map))
3538     (lambda ($code rte proc arg1 arg2 arg3)
3539       (macro-call-step! (proc arg1 arg2 arg3)
3540         (##first-argument
3541          (proc arg1 arg2 arg3)
3542          $code
3543          rte)))))
3544
3545 (define ##subproblem-apply4
3546   (let ()
3547     (##declare (not inline) (not interrupts-enabled) (environment-map))
3548     (lambda ($code rte proc arg1 arg2 arg3 arg4)
3549       (macro-call-step! (proc arg1 arg2 arg3 arg4)
3550         (##first-argument
3551          (proc arg1 arg2 arg3 arg4)
3552          $code
3553          rte)))))
3554
3555 (define ##subproblem-apply
3556   (let ()
3557     (##declare (not inline) (not interrupts-enabled) (environment-map))
3558     (lambda ($code rte proc args)
3559       (macro-call-step! (proc args)
3560         (##first-argument
3561          (##apply proc args)
3562          $code
3563          rte)))))
3564
3565 ;;; - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
3566
3567 (define ##cprc-delay
3568   (macro-make-cprc
3569    (macro-delay-step! ()
3570      (let ((promise (delay (macro-code-run (^ 0)))))
3571        (##check-heap-limit)
3572        (##first-argument promise $code rte)))))
3573
3574 (define ##gen-delay
3575   (macro-make-gen (val)
3576     (let ((stepper (##current-stepper)))
3577       (macro-make-code ##cprc-delay cte src stepper (val)))))
3578
3579 ;;; - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
3580
3581 (define ##cprc-future
3582   (macro-make-cprc
3583    (macro-future-step! ()
3584      (let ((promise (future (macro-code-run (^ 0)))))
3585        (##first-argument promise $code rte)))))
3586
3587 (define ##gen-future
3588   (macro-make-gen (val)
3589     (let ((stepper (##current-stepper)))
3590       (macro-make-code ##cprc-future cte src stepper (val)))))
3591
3592 ;;; - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
3593
3594 (define ##cprc-require
3595   (macro-make-cprc
3596    (let ((requirements (^ 1)))
3597      (##fulfill-requirements requirements)
3598      (macro-code-run (^ 0)))))
3599
3600 (define ##gen-require
3601   (macro-make-gen (val requirements)
3602     (let ((stepper (##no-stepper)))
3603       (macro-make-code ##cprc-require cte src stepper (val)
3604         requirements))))
3605
3606 ;;;============================================================================
3607
3608 ;;; Eval
3609
3610 ;;; - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
3611
3612 ;;; Evaluation in a top environment within the current continuation.
3613
3614 (define ##eval-module #f)
3615 (set! ##eval-module
3616   (lambda (src top-cte)
3617     (let ((c (##compile-module top-cte (##sourcify src (##make-source #f #f)))))
3618       (let ((rte #f))
3619         (macro-code-run c)))))
3620
3621 (define ##eval-top #f)
3622 (set! ##eval-top
3623   (lambda (src top-cte)
3624     (let ((c (##compile-top top-cte (##sourcify src (##make-source #f #f)))))
3625       (let ((rte #f))
3626         (macro-code-run c)))))
3627
3628 (define-prim (##eval expr #!optional env)
3629   (##eval-top (##sourcify expr (##make-source #f #f))
3630               ##interaction-cte))
3631
3632 (define-prim (eval expr #!optional env)
3633   (##eval expr env))
3634
3635 (define-prim (interaction-environment)
3636   'interaction-environment)
3637
3638 (define-prim (null-environment)
3639   'null-environment)
3640
3641 (define-prim (scheme-report-environment n)
3642   n)
3643
3644 ;;;============================================================================
3645
3646 (define (##wrap-datum re x)
3647   (##make-source x (##readenv->locat re)))
3648
3649 (define (##unwrap-datum re x)
3650   (##source-code x))
3651
3652 (define (##read-expr-from-port port)
3653   (let ((re
3654          (##make-readenv port
3655                          (macro-character-port-input-readtable port)
3656                          ##wrap-datum
3657                          ##unwrap-datum
3658                          #f)))
3659     (##read-datum-or-eof re)))
3660
3661 (define (##load
3662          path
3663          script-callback
3664          clone-cte?
3665          raise-os-exception?
3666          quiet?
3667          #!optional
3668          (settings (macro-absent-obj)))
3669
3670   (define (raise-os-exception-if-needed x)
3671     (if (and (##fixnum? x)
3672              raise-os-exception?)
3673       (##raise-os-exception #f x load path settings)
3674       x))
3675
3676   (define (load-source source-path)
3677     (let ((x
3678            (##read-all-as-a-begin-expr-from-path
3679             source-path
3680             (##current-readtable)
3681             ##wrap-datum
3682             ##unwrap-datum)))
3683       (if (##fixnum? x)
3684         x
3685         (begin
3686           (script-callback (##vector-ref x 0) (##vector-ref x 2))
3687           (##eval-module (##vector-ref x 1)
3688                          (if clone-cte?
3689                            (##top-cte-clone ##interaction-cte)
3690                            ##interaction-cte))
3691           (##vector-ref x 2)))))
3692
3693   (define (load-binary abs-path)
3694     (let ((result (##load-object-file abs-path quiet?)))
3695
3696       (define (raise-error code)
3697         (if (##fixnum? code)
3698              (##raise-os-exception #f code load path settings)
3699              (##raise-os-exception code #f load path settings)))
3700
3701       (cond ((##not (##vector? result))
3702              (raise-error result))
3703             ((##fixnum.= 2 (##vector-length result))
3704              (raise-error (##vector-ref result 0)))
3705             (else
3706              (let ((exec-vector (##vector-ref result 0))
3707                    (script-line (##vector-ref result 2)))
3708                (script-callback script-line abs-path)
3709                (##execute-modules exec-vector 0)
3710                abs-path)))))
3711
3712   (define (load-no-ext)
3713     (let* ((source-path (##path-expand path))
3714            (result (load-source source-path)))
3715       (if (##not (##fixnum? result))
3716         result
3717         (let loop1 ((version 1) (last-expanded-path #f))
3718           (let ((expanded-path
3719                  (##path-expand
3720                   (##string-append path
3721                                    ".o"
3722                                    (##number->string version 10)))))
3723             (if (##file-exists? expanded-path)
3724               (loop1 (##fixnum.+ version 1)
3725                      expanded-path)
3726               (if last-expanded-path
3727                 (load-binary last-expanded-path)
3728                 (let loop2 ((lst ##scheme-file-extensions))
3729                   (if (##pair? lst)
3730                     (let* ((source-path
3731                             (##path-expand (##string-append path (##caar lst))))
3732                            (x
3733                             (load-source source-path)))
3734                       (if (##fixnum? x)
3735                         (loop2 (##cdr lst))
3736                         x))
3737                     (raise-os-exception-if-needed result))))))))))
3738
3739   (define (binary-extension? ext)
3740     (let ((len (##string-length ext)))
3741       (and (##fixnum.< 2 len)
3742            (##char=? (##string-ref ext 0) #\.)
3743            (##char=? (##string-ref ext 1) #\o)
3744            (let ((c (##string-ref ext 2)))
3745              (and (##char>=? c #\1) (##char<=? c #\9)
3746                   (let loop ((i (##fixnum.- len 1)))
3747                     (if (##fixnum.< i 3)
3748                       #t
3749                       (let ((c (##string-ref ext i)))
3750                         (and (##char>=? c #\0) (##char<=? c #\9)
3751                              (loop (##fixnum.- i 1)))))))))))
3752
3753   (let ((ext (##path-extension path)))
3754     (cond ((##string=? ext "")
3755            (load-no-ext))
3756           ((binary-extension? ext)
3757            (let ((expanded-path (##path-expand path)))
3758              (load-binary expanded-path)))
3759           (else
3760            (raise-os-exception-if-needed (load-source path))))))
3761
3762 (define-prim (##load-object-file abs-path quiet?)
3763
3764   (##define-macro (module-prefix)
3765     c#module-prefix)
3766
3767   (let* ((module-name
3768           (##string-append
3769            (module-prefix)
3770            (##path-strip-directory abs-path)))
3771          (result
3772           (##os-load-object-file abs-path module-name)))
3773     (cond ((##not (##vector? result))
3774            result)
3775           ((##fixnum.= 2 (##vector-length result))
3776            (if (##not quiet?)
3777                (##repl
3778                 (lambda (first output-port)
3779                   (##write-string "*** WARNING -- Could not find C function: " output-port)
3780                   (##write (##vector-ref result 1) output-port)
3781                   (##newline output-port)
3782                   #t)))
3783            result)
3784           (else
3785            (let ((exec-vector (##vector-ref result 0))
3786                  (script-line (##vector-ref result 2)))
3787              (if (##not quiet?)
3788                  (let ((undefined (##vector-ref result 1)))
3789                    (let loop ((lst (##reverse undefined)))
3790                      (if (##pair? lst)
3791                          (let ((var-module (##car lst)))
3792                            (##repl
3793                             (lambda (first output-port)
3794                               (##write-string "*** WARNING -- Variable " output-port)
3795                               (##write (##car var-module) output-port)
3796                               (##write-string " used in module " output-port)
3797                               (##write (##cdr var-module) output-port)
3798                               (##write-string " is undefined" output-port)
3799                               (##newline output-port)
3800                               #t))
3801                            (loop (##cdr lst)))))))
3802              result)))))
3803
3804 (define (load
3805          path
3806          #!optional
3807          (settings (macro-absent-obj)))
3808   (macro-force-vars (path settings)
3809     (macro-check-string path 1 (load path settings)
3810       (##load path
3811               (lambda (script-line script-path) #f)
3812               #t
3813               #t
3814               #f
3815               settings))))
3816
3817 ;;;----------------------------------------------------------------------------
3818
3819 ;; Load support libraries
3820
3821 (define-prim (##load-support-libraries)
3822
3823   (##define-macro (macro-extension-file)
3824     "~~lib/gambcext")
3825
3826   (##define-macro (macro-syntax-case-file)
3827     "~~lib/syntax-case")
3828
3829   (##load (macro-extension-file)
3830           (lambda (script-line script-path) #f)
3831           #t
3832           #f
3833           #f)
3834
3835   (let ((standard-level (##get-standard-level)))
3836     (if (##fixnum.<= 4 standard-level)
3837         (##load (macro-syntax-case-file)
3838                 (lambda (script-line script-path) #f)
3839                 #t
3840                 #t
3841                 #f))))
3842
3843 ;;;----------------------------------------------------------------------------
3844
3845 ;;; Syntactic aliases.
3846
3847 (define-runtime-syntax quote
3848   (##make-alias-syntax '##quote))
3849
3850 (define-runtime-syntax quasiquote
3851   (##make-alias-syntax '##quasiquote))
3852
3853 (define-runtime-syntax set!
3854   (##make-alias-syntax '##set!))
3855
3856 (define-runtime-syntax lambda
3857   (##make-alias-syntax '##lambda))
3858
3859 (define-runtime-syntax if
3860   (##make-alias-syntax '##if))
3861
3862 (define-runtime-syntax cond
3863   (##make-alias-syntax '##cond))
3864
3865 (define-runtime-syntax and
3866   (##make-alias-syntax '##and))
3867
3868 (define-runtime-syntax or
3869   (##make-alias-syntax '##or))
3870
3871 (define-runtime-syntax case
3872   (##make-alias-syntax '##case))
3873
3874 (define-runtime-syntax let
3875   (##make-alias-syntax '##let))
3876
3877 (define-runtime-syntax let*
3878   (##make-alias-syntax '##let*))
3879
3880 (define-runtime-syntax letrec
3881   (##make-alias-syntax '##letrec))
3882
3883 (define-runtime-syntax do
3884   (##make-alias-syntax '##do))
3885
3886 (define-runtime-syntax delay
3887   (##make-alias-syntax '##delay))
3888
3889 (define-runtime-syntax future
3890   (##make-alias-syntax '##future))
3891
3892 (define-runtime-syntax c-define-type
3893   (##make-alias-syntax '##c-define-type))
3894
3895 (define-runtime-syntax c-declare
3896   (##make-alias-syntax '##c-declare))
3897
3898 (define-runtime-syntax c-initialize
3899   (##make-alias-syntax '##c-initialize))
3900
3901 (define-runtime-syntax c-lambda
3902   (##make-alias-syntax '##c-lambda))
3903
3904 (define-runtime-syntax c-define
3905   (##make-alias-syntax '##c-define))
3906
3907 (define-runtime-syntax begin
3908   (##make-alias-syntax '##begin))
3909
3910 (define-runtime-syntax define
3911   (##make-alias-syntax '##define))
3912
3913 (define-runtime-syntax define-macro
3914   (##make-alias-syntax '##define-macro))
3915
3916 ;;(define-runtime-syntax define-syntax
3917 ;;  (##make-alias-syntax '##define-syntax))
3918
3919 (define-runtime-syntax include
3920   (##make-alias-syntax '##include))
3921
3922 (define-runtime-syntax declare
3923   (##make-alias-syntax '##declare))
3924
3925 (define-runtime-syntax namespace
3926   (##make-alias-syntax '##namespace))
3927
3928 (define-runtime-syntax this-source-file
3929   (##make-alias-syntax '##this-source-file))
3930
3931 ;;;============================================================================