gsc/_ptree1.scm

   1 ;;;============================================================================
   2
   3 ;;; File: "_ptree1.scm"
   4
   5 ;;; Copyright (c) 1994-2011 by Marc Feeley, All Rights Reserved.
   6
   7 (include "fixnum.scm")
   8
   9 (include-adt "_envadt.scm")
  10 (include-adt "_gvmadt.scm")
  11 (include     "_ptreeadt.scm")
  12 (include-adt "_sourceadt.scm")
  13
  14 '(begin;**************brad
  15 (##include "_sourceadt.scm")
  16 (##include "_envadt.scm")
  17 (##include "_utilsadt.scm")
  18 (##include "_hostadt.scm")
  19 )
  20
  21 ;;;----------------------------------------------------------------------------
  22 ;;
  23 ;; Parse tree manipulation module: (part 1)
  24 ;; ------------------------------
  25
  26 ;; This module contains procedures to construct the parse tree of a Scheme
  27 ;; expression and manipulate the parse tree.
  28
  29 (define next-node-stamp #f)
  30
  31 (define (node-children-set! x y)
  32   (vector-set! x 2 y)
  33   (for-each (lambda (child) (node-parent-set! child x)) y)
  34   (node-fv-invalidate! x))
  35
  36 (define (node-fv-invalidate! x)
  37   (let loop ((node x))
  38     (if node
  39       (begin
  40         (node-fv-set! node #t)
  41         (node-bfv-set! node #t)
  42         (loop (node-parent node))))))
  43
  44 ;;; - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
  45 ;;
  46 ;; Procedures to create parse tree nodes and extract sub-nodes.
  47
  48 (define (new-cst source env val)
  49   (make-cst #f '() #t #t env source val))
  50
  51 (define (new-ref source env var)
  52   (let ((node (make-ref #f '() #t #t env source var)))
  53     (var-refs-set! var (ptset-adjoin (var-refs var) node))
  54     node))
  55
  56 (define (new-ref-extended-bindings source name env)
  57   (new-ref source (add-extended-bindings env)
  58     (env-lookup-global-var env name)))
  59
  60 (define (new-set source env var val)
  61   (let ((node (make-set #f (list val) #t #t env source var)))
  62     (var-sets-set! var (ptset-adjoin (var-sets var) node))
  63     (node-parent-set! val node)
  64     node))
  65
  66 (define (set-val x)
  67   (if (set? x)
  68     (car (node-children x))
  69     (compiler-internal-error "set-val, 'set' node expected" x)))
  70
  71 (define (new-def source env var val)
  72   (let ((node (make-def #f (list val) #t #t env source var)))
  73     (var-sets-set! var (ptset-adjoin (var-sets var) node))
  74     (node-parent-set! val node)
  75     node))
  76
  77 (define (def-val x)
  78   (if (def? x)
  79     (car (node-children x))
  80     (compiler-internal-error "def-val, 'def' node expected" x)))
  81
  82 (define (new-tst source env pre con alt)
  83   (let ((node (make-tst #f (list pre con alt) #t #t env source)))
  84     (node-parent-set! pre node)
  85     (node-parent-set! con node)
  86     (node-parent-set! alt node)
  87     node))
  88
  89 (define (tst-pre x)
  90   (if (tst? x)
  91     (car (node-children x))
  92     (compiler-internal-error "tst-pre, 'tst' node expected" x)))
  93
  94 (define (tst-con x)
  95   (if (tst? x)
  96     (cadr (node-children x))
  97     (compiler-internal-error "tst-con, 'tst' node expected" x)))
  98
  99 (define (tst-alt x)
 100   (if (tst? x)
 101     (caddr (node-children x))
 102     (compiler-internal-error "tst-alt, 'tst' node expected" x)))
 103
 104 (define (new-conj source env pre alt)
 105   (let ((node (make-conj #f (list pre alt) #t #t env source)))
 106     (node-parent-set! pre node)
 107     (node-parent-set! alt node)
 108     node))
 109
 110 (define (conj-pre x)
 111   (if (conj? x)
 112     (car (node-children x))
 113     (compiler-internal-error "conj-pre, 'conj' node expected" x)))
 114
 115 (define (conj-alt x)
 116   (if (conj? x)
 117     (cadr (node-children x))
 118     (compiler-internal-error "conj-alt, 'conj' node expected" x)))
 119
 120 (define (new-disj source env pre alt)
 121   (let ((node (make-disj #f (list pre alt) #t #t env source)))
 122     (node-parent-set! pre node)
 123     (node-parent-set! alt node)
 124     node))
 125
 126 (define (disj-pre x)
 127   (if (disj? x)
 128     (car (node-children x))
 129     (compiler-internal-error "disj-pre, 'disj' node expected" x)))
 130
 131 (define (disj-alt x)
 132   (if (disj? x)
 133     (cadr (node-children x))
 134     (compiler-internal-error "disj-alt, 'disj' node expected" x)))
 135
 136 (define (new-prc source env name c-name parms opts keys rest? body)
 137   (let* ((children (list body))
 138          (node (make-prc #f children #t #t env source
 139                          name c-name parms opts keys rest?)))
 140     (for-each (lambda (x) (var-bound-set! x node)) parms)
 141     (node-parent-set! body node)
 142     node))
 143
 144 (define (prc-body x)
 145   (if (prc? x)
 146     (car (node-children x))
 147     (compiler-internal-error "prc-body, 'proc' node expected" x)))
 148
 149 (define (prc-req-and-opt-parms-only? x)
 150   (and (not (prc-keys x))
 151        (not (prc-rest? x))))
 152
 153 (define (new-call source env oper args)
 154   (let ((node (make-app #f (cons oper args) #t #t env source)))
 155     (node-parent-set! oper node)
 156     (for-each (lambda (x) (node-parent-set! x node)) args)
 157     node))
 158
 159 (define (new-call* source env oper args)
 160   (new-call source env oper args))
 161
 162 (define (app-oper x)
 163   (if (app? x)
 164     (car (node-children x))
 165     (compiler-internal-error "app-oper, 'call' node expected" x)))
 166
 167 (define (app-args x)
 168   (if (app? x)
 169     (cdr (node-children x))
 170     (compiler-internal-error "app-args, 'call' node expected" x)))
 171
 172 (define (oper-pos? node)
 173   (let ((parent (node-parent node)))
 174     (if parent
 175       (and (app? parent)
 176            (eq? (app-oper parent) node))
 177       #f)))
 178
 179 (define (new-fut source env val)
 180   (let ((node (make-fut #f (list val) #t #t env source)))
 181     (node-parent-set! val node)
 182     node))
 183
 184 (define (fut-val x)
 185   (if (fut? x)
 186     (car (node-children x))
 187     (compiler-internal-error "fut-val, 'fut' node expected" x)))
 188
 189 (define (new-disj-call source env pre oper alt)
 190   (new-call* source env
 191     (let* ((temp (new-temp-variable source 'cond-temp))
 192            (parms (list temp))
 193            (inner-env (env-frame env parms)))
 194       (new-prc source env #f #f parms '() #f #f
 195         (new-tst source inner-env
 196           (new-ref source inner-env temp)
 197           (new-call* source inner-env
 198             oper
 199             (list (new-ref source inner-env temp)))
 200           alt)))
 201     (list pre)))
 202
 203 (define (new-seq source env before after)
 204   (let ((temp (new-temp-variable source 'begin-temp)))
 205     (new-call* source env
 206       (new-prc source env #f #f (list temp) '() #f #f
 207         after)
 208       (list before))))
 209
 210 (define (new-let ptree proc vars vals body)
 211   (if (pair? vars)
 212     (new-call (node-source ptree) (node-env ptree)
 213       (new-prc (node-source proc) (node-env proc)
 214         (prc-name proc)
 215         (prc-c-name proc)
 216         (reverse vars)
 217         '()
 218         #f
 219         #f
 220         body)
 221       (reverse vals))
 222     body))
 223
 224 (define temp-variable-stamp #f)
 225
 226 (define (new-temp-variable source name)
 227   (make-var (string->symbol
 228              (string-append (symbol->string name)
 229                             "."
 230                             (number->string (temp-variable-stamp))))
 231             #t
 232             (ptset-empty)
 233             (ptset-empty)
 234             source))
 235
 236 (define (new-variables sources)
 237   (map new-variable sources))
 238
 239 (define (new-variable source)
 240   (make-var (source-code source) #t (ptset-empty) (ptset-empty) source))
 241
 242 (define (set-prc-names! vars vals)
 243   (let loop ((vars vars) (vals vals))
 244     (if (not (null? vars))
 245       (let ((var (car vars))
 246             (val (car vals)))
 247         (if (prc? val)
 248           (prc-name-set! val (symbol->string (var-name var))))
 249         (loop (cdr vars) (cdr vals))))))
 250
 251 ;;; - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
 252 ;;
 253 ;; Procedures to get variable classes from nodes.
 254
 255 (define (free-variables node) ; set of free variables used in the expression
 256   (if (eq? (node-fv node) #t)
 257     (let ((x (varset-union-multi (map free-variables (node-children node)))))
 258       (node-fv-set! node
 259         (cond ((ref? node)
 260                (varset-adjoin x (ref-var node)))
 261               ((set? node)
 262                (varset-adjoin x (set-var node)))
 263               ((prc? node)
 264                (varset-difference x (bound-variables node)))
 265               ((and (app? node) (prc? (app-oper node)))
 266                (varset-difference x (bound-variables (app-oper node))))
 267               (else
 268                x)))))
 269   (node-fv node))
 270
 271 (define (bound-free-variables node) ; set of bound free variables used in expr
 272   (if (eq? (node-bfv node) #t)
 273     (node-bfv-set! node
 274      (list->varset (keep bound? (varset->list (free-variables node))))))
 275   (node-bfv node))
 276
 277 (define (bound-variables node) ; set of variables bound by a procedure
 278   (list->varset (prc-parms node)))
 279
 280 (define (mutable? var) ; var must be a bound variable (i.e. non-global)
 281   (not (ptset-empty? (var-sets var))))
 282
 283 (define (bound? var)
 284   (var-bound var))
 285
 286 (define (global? var)
 287   (not (bound? var)))
 288
 289 (define (global-single-def var) ; get definition of a global if it is only
 290   (and (global? var)            ; defined once and it will never change
 291        (let ((sets (ptset->list (var-sets var))))
 292          (and (pair? sets)
 293               (null? (cdr sets))
 294               (def? (car sets))
 295               (block-compilation? (node-env (car sets)))
 296               (def-val (car sets))))))
 297
 298 (define (global-proc-obj node)
 299   (let ((var (ref-var node)))
 300     (and (global? var)
 301          (let ((name (var-name var)))
 302            (standard-proc-obj (target.prim-info name)
 303                               name
 304                               (node-env node))))))
 305
 306 (define (global-singly-bound? node)
 307   (or (global-single-def (ref-var node))
 308       (global-proc-obj node)))
 309
 310 (define (app->specialized-proc node)
 311   (let ((oper (app-oper node))
 312         (args (app-args node))
 313         (env (node-env node)))
 314     (specialize-app oper args env)))
 315
 316 (define (specialize-app oper args env)
 317   (specialize-proc
 318    (cond ((cst? oper)
 319           (let ((val (cst-val oper)))
 320             (and (proc-obj? val)
 321                  val)))
 322          ((ref? oper)
 323           (global-proc-obj oper))
 324          (else
 325           #f))
 326    args
 327    env))
 328
 329 (define (specialize-proc proc args env)
 330   (and proc
 331        (nb-args-conforms? (length args) (proc-obj-call-pat proc))
 332        (let loop ((proc proc))
 333          (let ((spec
 334                 ((proc-obj-specialize proc)
 335                  env
 336                  (map (lambda (arg) (if (cst? arg) (cst-val arg) void-object))
 337                       args))))
 338            (if (eq? spec proc)
 339              proc
 340              (loop spec))))))
 341
 342 (define (nb-args-conforms? n call-pat)
 343   (pattern-member? n call-pat))
 344
 345 ;;; - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
 346 ;;
 347 ;; Declarations.
 348
 349 ;; Dialect related declarations:
 350 ;;
 351 ;; (ieee-scheme)     use IEEE Scheme
 352 ;; (r4rs-scheme)     use R4RS Scheme
 353 ;; (r5rs-scheme)     use R5RS Scheme
 354 ;; (gambit-scheme)   use Gambit Scheme
 355 ;; (multilisp)       use Multilisp
 356 ;;
 357 ;; Partial-evaluation declarations:
 358 ;;
 359 ;; (constant-fold)                       can constant-fold primitives
 360 ;; (not constant-fold)                   can't constant-fold primitives
 361 ;;
 362 ;; Lambda-lifting declarations:
 363 ;;
 364 ;; (lambda-lift)                         can lambda-lift user procedures
 365 ;; (not lambda-lift)                     can't lambda-lift user procedures
 366 ;;
 367 ;; Inlining declarations:
 368 ;;
 369 ;; (inline)                              compiler may inline user procedures
 370 ;; (not inline)                          no user procedure will be inlined
 371 ;;
 372 ;; (inline-primitives)                   can inline all primitives
 373 ;; (inline-primitives <var1> ...)        can inline primitives <var1> ...
 374 ;; (not inline-primitives)               can't inline any primitives
 375 ;; (not inline-primitives <var1> ...)    can't inline primitives <var1> ...
 376 ;;
 377 ;; (inlining-limit n)                    inlined user procedures must not be
 378 ;;                                       bigger than 'n'
 379 ;;
 380 ;; Compilation strategy declarations:
 381 ;;
 382 ;; (block)     global vars defined are only mutated by code in the current file
 383 ;; (separate)  global vars defined can be mutated by other code
 384 ;;
 385 ;; (core)      toplevel expressions and definitions must be compiled to code
 386 ;; (not core)  toplevel expressions and definitions belong to another module
 387 ;;
 388 ;; Global variable binding declarations:
 389 ;;
 390 ;; (standard-bindings)                  compiler can assume standard bindings
 391 ;; (standard-bindings <var1> ...)       assume st. bind. for vars specified
 392 ;; (not standard-bindings)              can't assume st. bind. for any var
 393 ;; (not standard-bindings <var1> ...)   can't assume st. bind. for vars spec.
 394 ;;
 395 ;; (extended-bindings)                  compiler can assume extended bindings
 396 ;; (extended-bindings <var1> ...)       assume ext. bind. for vars specified
 397 ;; (not extended-bindings)              can't assume ext. bind. for any var
 398 ;; (not extended-bindings <var1> ...)   can't assume ext. bind. for vars spec.
 399 ;;
 400 ;; (run-time-bindings)                  should check bindings at run-time
 401 ;; (run-time-bindings <var1> ...)       check at run-time for vars specified
 402 ;; (not run-time-bindings)              should not check bindings at run-time
 403 ;; (not run-time-bindings <var1> ...)   don't check at run-time for vars specified
 404 ;;
 405 ;; Code safety declarations:
 406 ;;
 407 ;; (safe)                              runtime errors won't crash system
 408 ;; (not safe)                          assume program doesn't contain errors
 409 ;;
 410 ;; (warnings)                          show warnings
 411 ;; (not warnings)                      suppress warnings
 412 ;;
 413 ;; Interrupt checking declarations:
 414 ;;
 415 ;; (interrupts-enabled)                allow interrupts
 416 ;; (not interrupts-enabled)            disallow interrupts
 417 ;;
 418 ;; Environment map declarations:
 419 ;;
 420 ;; (environment-map)                   generate environment maps
 421 ;; (not environment-map)               don't generate environment maps
 422 ;;
 423 ;; Proper tail calls declarations:
 424 ;;
 425 ;; (proper-tail-calls)                 generate proper tail calls
 426 ;; (not proper-tail-calls)             don't generate proper tail calls
 427 ;;
 428 ;; Optimizing dead local variables declarations:
 429 ;;
 430 ;; (optimize-dead-local-variables)     optimize dead local variables
 431 ;; (not optimize-dead-local-variables) don't optimize dead local variables
 432
 433 (define-flag-decl ieee-scheme-sym   'dialect)
 434 (define-flag-decl r4rs-scheme-sym   'dialect)
 435 (define-flag-decl r5rs-scheme-sym   'dialect)
 436 (define-flag-decl gambit-scheme-sym 'dialect)
 437 (define-flag-decl multilisp-sym     'dialect)
 438
 439 (define-boolean-decl constant-fold-sym)
 440
 441 (define-boolean-decl lambda-lift-sym)
 442
 443 (define-boolean-decl inline-sym)
 444 (define-namable-boolean-decl inline-primitives-sym)
 445 (define-parameterized-decl inlining-limit-sym)
 446
 447 (define-flag-decl block-sym    'compilation-strategy)
 448 (define-flag-decl separate-sym 'compilation-strategy)
 449
 450 (define-boolean-decl core-sym)
 451
 452 (define-namable-boolean-decl standard-bindings-sym)
 453 (define-namable-boolean-decl extended-bindings-sym)
 454 (define-namable-boolean-decl run-time-bindings-sym)
 455
 456 (define-boolean-decl safe-sym)
 457
 458 (define-boolean-decl warnings-sym)
 459
 460 (define-boolean-decl interrupts-enabled-sym)
 461
 462 (define-boolean-decl debug-sym)
 463 (define-boolean-decl debug-location-sym)
 464 (define-boolean-decl debug-source-sym)
 465 (define-boolean-decl debug-environments-sym)
 466
 467 (define-boolean-decl environment-map-sym) ;; deprecated: use debug-environments
 468
 469 (define-boolean-decl proper-tail-calls-sym)
 470
 471 (define-boolean-decl optimize-dead-local-variables-sym)
 472
 473 (define (scheme-dialect env) ; returns dialect in effect
 474   (declaration-value 'dialect #f gambit-scheme-sym env))
 475
 476 (define (constant-fold? env) ; true iff should constant-fold primitives
 477   (declaration-value constant-fold-sym #f #t env))
 478
 479 (define (lambda-lift? env) ; true iff should lambda-lift
 480   (declaration-value lambda-lift-sym #f #t env))
 481
 482 (define (inline? env) ; true iff should inline
 483   (declaration-value inline-sym #f #t env))
 484
 485 (define (inline-primitive? name env) ; true iff name can be inlined
 486   (declaration-value inline-primitives-sym name #t env))
 487
 488 (define (add-not-inline-primitives env)
 489   (env-declare env (list inline-primitives-sym #f)))
 490
 491 (define (inlining-limit env) ; returns the inlining limit
 492   (max 0 (min 1000000 (declaration-value inlining-limit-sym #f 350 env))))
 493
 494 (define (block-compilation? env) ; true iff block compilation strategy
 495   (eq? (declaration-value 'compilation-strategy #f separate-sym env)
 496        block-sym))
 497
 498 (define (core? env) ; true iff core code
 499   (declaration-value core-sym #f #t env))
 500
 501 (define (standard-binding? name env) ; true iff name's binding is standard
 502   (declaration-value standard-bindings-sym name #f env))
 503
 504 (define (extended-binding? name env) ; true iff name's binding is extended
 505   (declaration-value extended-bindings-sym name #f env))
 506
 507 (define (add-extended-bindings env)
 508   (env-declare env (list extended-bindings-sym #t)))
 509
 510 (define (run-time-binding? name env) ; true iff name's binding is checked at run-time
 511   (declaration-value run-time-bindings-sym name #t env))
 512
 513 (define (safe? env) ; true iff system should prevent fatal runtime errors
 514   (declaration-value safe-sym #f #t env))
 515
 516 (define (add-not-safe env)
 517   (env-declare env (list safe-sym #f)))
 518
 519 (define (warnings? env) ; true iff warnings are not suppressed
 520   (declaration-value warnings-sym #f #t env))
 521
 522 (define (intrs-enabled? env) ; true iff interrupt checks should be generated
 523   (declaration-value interrupts-enabled-sym #f #t env))
 524
 525 (define (add-not-interrupts-enabled env)
 526   (env-declare env (list interrupts-enabled-sym #f)))
 527
 528 (define (debug? env) ; true iff debugging information should be generated
 529   (declaration-value debug-sym #f compiler-option-debug env))
 530
 531 (define (debug-location? env) ; true iff source code location debugging information should be generated
 532   (declaration-value debug-location-sym #f compiler-option-debug-location env))
 533
 534 (define (debug-source? env) ; true iff source code debugging information should be generated
 535   (declaration-value debug-source-sym #f compiler-option-debug-source env))
 536
 537 (define (debug-environments? env) ; true iff environment debugging information should be generated
 538   (declaration-value debug-environments-sym #f compiler-option-debug-environments env))
 539
 540 (define (environment-map? env) ; true iff environment map should be generated
 541   (declaration-value environment-map-sym #f #f env))
 542
 543 (define (proper-tail-calls? env) ; true iff proper tail calls should be generated
 544   (declaration-value proper-tail-calls-sym #f #t env))
 545
 546 (define (add-proper-tail-calls env)
 547   (env-declare env (list proper-tail-calls-sym #t)))
 548
 549 (define (optimize-dead-local-variables? env) ; true iff dead local variables should be optimized
 550   (declaration-value optimize-dead-local-variables-sym #f #t env))
 551
 552 ;;; - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
 553 ;;
 554 ;; Dialect info.
 555
 556 (define (standard-proc-obj proc name env)
 557   (and proc
 558        (standard-procedure?
 559         proc
 560         (standard-binding? name env)
 561         (extended-binding? name env)
 562         (scheme-dialect env))
 563        proc))
 564
 565 (define (standard-procedure? proc std? ext? dialect)
 566   (let ((standard (proc-obj-standard proc)))
 567     (if (eq? standard 'extended)
 568       ext?
 569       (and std?
 570            (or (eq? standard 'ieee)
 571                (and (not (eq? dialect ieee-scheme-sym))
 572                     (or (eq? standard 'r4rs)
 573                         (and (not (eq? dialect r4rs-scheme-sym))
 574                              (or (eq? standard 'r5rs)
 575                                  (not (eq? dialect r5rs-scheme-sym)))))))))))
 576
 577 ;;; - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
 578 ;;
 579 ;; (parse-program program env module-name proc) returns a (non-empty)
 580 ;; list of parse trees, one for each top-level expression in the program.
 581 ;; An artificial reference of the constant #f is added to the program
 582 ;; if it is otherwise empty.
 583
 584 (define (parse-program program env module-name proc)
 585
 586   (define (parse-prog program env lst proc)
 587     (if (null? program)
 588       (proc (reverse lst) env)
 589       (let ((source (car program)))
 590
 591         (cond ((macro-expr? source env)
 592                (parse-prog
 593                  (cons (macro-expand source env) (cdr program))
 594                  env
 595                  lst
 596                  proc))
 597
 598               ((**begin-cmd-or-expr? source)
 599                (parse-prog
 600                  (append (begin-body source) (cdr program))
 601                  env
 602                  lst
 603                  proc))
 604
 605               ((**define-expr? source env)
 606                (let* ((var-source (definition-name source env))
 607                       (var (source-code var-source))
 608                       (v (env-lookup-var env var var-source)))
 609
 610                  (if *ptree-port*
 611                    (begin
 612                      (display "  " *ptree-port*)
 613                      (write (var-name v) *ptree-port*)
 614                      (newline *ptree-port*)))
 615
 616                  (let ((node (pt (definition-value source) env 'true)))
 617                    (set-prc-names! (list v) (list node))
 618                    (parse-prog
 619                      (cdr program)
 620                      env
 621                      (cons (new-def source env v node)
 622                            lst)
 623                      proc))))
 624
 625               ((or (**define-macro-expr? source env)
 626                    (**define-syntax-expr? source env))
 627
 628                (if *ptree-port*
 629                  (begin
 630                    (display "  \"macro\"" *ptree-port*)
 631                    (newline *ptree-port*)))
 632
 633                (parse-prog
 634                  (cdr program)
 635                  (add-macro source env)
 636                  lst
 637                  proc))
 638
 639               ((**include-expr? source)
 640
 641                (if *ptree-port*
 642                  (display "  " *ptree-port*))
 643
 644                (let ((x (include-expr->source source *ptree-port*)))
 645
 646                  (if *ptree-port*
 647                    (newline *ptree-port*))
 648
 649                  (parse-prog
 650                    (cons x (cdr program))
 651                    env
 652                    lst
 653                    proc)))
 654
 655               ((**declare-expr? source)
 656
 657                (if *ptree-port*
 658                  (begin
 659                    (display "  \"declare\"" *ptree-port*)
 660                    (newline *ptree-port*)))
 661
 662                (parse-prog
 663                  (cdr program)
 664                  (add-declarations source env)
 665                  lst
 666                  proc))
 667
 668               ((**namespace-expr? source)
 669
 670                (if *ptree-port*
 671                  (begin
 672                    (display "  \"namespace\"" *ptree-port*)
 673                    (newline *ptree-port*)))
 674
 675                (parse-prog
 676                  (cdr program)
 677                  (add-namespace source env)
 678                  lst
 679                  proc))
 680
 681 ;;              ((**require-expr? source)
 682 ;;               (parse-prog
 683 ;;                (cdr program)
 684 ;;                env
 685 ;;                lst
 686 ;;                proc))
 687
 688               ((**c-define-type-expr? source)
 689                (let ((name (source-code (c-type-definition-name source)))
 690                      (type (c-type-definition-type source)))
 691
 692                  (if *ptree-port*
 693                    (begin
 694                      (display "  \"c-define-type\"" *ptree-port*)
 695                      (newline *ptree-port*)))
 696
 697                  (add-c-type name type)
 698
 699                  (parse-prog
 700                    (cdr program)
 701                    env
 702                    lst
 703                    proc)))
 704
 705               ((**c-declare-expr? source)
 706                (let ((body (source-code (c-declaration-body source))))
 707
 708                  (if *ptree-port*
 709                    (begin
 710                      (display "  \"c-declare\"" *ptree-port*)
 711                      (newline *ptree-port*)))
 712
 713                  (add-c-decl body)
 714
 715                  (parse-prog
 716                    (cdr program)
 717                    env
 718                    lst
 719                    proc)))
 720
 721               ((**c-initialize-expr? source)
 722                (let ((body (source-code (c-initialization-body source))))
 723
 724                  (if *ptree-port*
 725                    (begin
 726                      (display "  \"c-initialize\"" *ptree-port*)
 727                      (newline *ptree-port*)))
 728
 729                  (add-c-init body)
 730
 731                  (parse-prog
 732                    (cdr program)
 733                    env
 734                    lst
 735                    proc)))
 736
 737               ((**c-define-expr? source env)
 738                (let* ((var-source (c-definition-name source))
 739                       (var (source-code var-source))
 740                       (v (env-lookup-var env var var-source))
 741                       (param-types (c-definition-param-types source))
 742                       (result-type (c-definition-result-type source))
 743                       (proc-name-source (c-definition-proc-name source))
 744                       (proc-name (source-code proc-name-source))
 745                       (scope-source (c-definition-scope source))
 746                       (scope (source-code scope-source)))
 747
 748                  (if *ptree-port*
 749                    (begin
 750                      (display "  " *ptree-port*)
 751                      (write (var-name v) *ptree-port*)
 752                      (newline *ptree-port*)))
 753
 754                  (build-c-define param-types result-type proc-name scope)
 755
 756                  (let ((node (pt (c-definition-value source) env 'true)))
 757                    (set-prc-names! (list v) (list node))
 758                    (prc-c-name-set! node proc-name)
 759                    (parse-prog
 760                      (cdr program)
 761                      env
 762                      (cons (new-def source env v node)
 763                            lst)
 764                      proc))))
 765
 766               (else
 767
 768                (if *ptree-port*
 769                  (begin
 770                    (display "  \"expr\"" *ptree-port*)
 771                    (newline *ptree-port*)))
 772
 773                (parse-prog
 774                  (cdr program)
 775                  env
 776                  (cons (pt source env 'true) lst)
 777                  proc))))))
 778
 779   (if *ptree-port*
 780     (begin
 781       (display "Parsing:" *ptree-port*)
 782       (newline *ptree-port*)))
 783
 784   (c-interface-begin module-name)
 785
 786   (parse-prog
 787     (list program)
 788     env
 789     '()
 790     (lambda (lst env)
 791
 792       (if *ptree-port*
 793         (newline *ptree-port*))
 794
 795       (check-multiple-global-defs env)
 796
 797       (proc (if (null? lst)
 798               (list (new-cst (expression->source false-object #f) env
 799                       false-object))
 800               lst)
 801             env
 802             (c-interface-end)))))
 803
 804 (define (check-multiple-global-defs env)
 805   (let ((global-vars (env-global-variables env)))
 806     (for-each
 807       (lambda (var)
 808         (let ((defs (keep def? (ptset->list (var-sets var)))))
 809           (if (> (length defs) 1)
 810             (for-each
 811              (lambda (def)
 812                (if (warnings? (node-env def))
 813                  (compiler-user-warning
 814                   (source-locat (node-source def))
 815                   "More than one 'define' of global variable"
 816                   (var-name var))))
 817              defs))))
 818       global-vars)))
 819
 820 ;;; - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
 821 ;;
 822 ;; (pt source env use) returns the parse tree for the Scheme source expression
 823 ;; 'source' in the environment 'env'.  If 'source' is not syntactically
 824 ;; correct, an error is signaled.  The value of 'use' determines what the
 825 ;; expression's value will be used for; it must be one of the following:
 826 ;;
 827 ;;  true  : the true value of the expression is needed
 828 ;;  pred  : the value is used as a predicate
 829 ;;  none  : the value is not needed (but its side effect might)
 830
 831 (define (pt-syntax-error source msg . args)
 832   (apply compiler-user-error
 833          (cons (source-locat source)
 834                (cons msg
 835                      args))))
 836
 837 (define (pt source env use)
 838   (cond ((macro-expr? source env)        (pt (macro-expand source env) env use))
 839         ((self-eval-expr? source)        (pt-self-eval source env use))
 840         ((**quote-expr? source)          (pt-quote source env use))
 841         ((**quasiquote-expr? source)     (pt-quasiquote source env use))
 842         ((var-expr? source env)          (pt-var source env use))
 843         ((**set!-expr? source env)       (pt-set! source env use))
 844         ((**lambda-expr? source env)     (pt-lambda source env use))
 845         ((**if-expr? source)             (pt-if source env use))
 846         ((**cond-expr? source)           (pt-cond source env use))
 847         ((**and-expr? source)            (pt-and source env use))
 848         ((**or-expr? source)             (pt-or source env use))
 849         ((**case-expr? source)           (pt-case source env use))
 850         ((**let-expr? source env)        (pt-let source env use))
 851         ((**let*-expr? source env)       (pt-let* source env use))
 852         ((**letrec-expr? source env)     (pt-letrec source env use))
 853         ((**begin-expr? source)          (pt-begin source env use))
 854         ((**do-expr? source env)         (pt-do source env use))
 855         ((**delay-expr? source env)      (pt-delay source env use))
 856         ((**future-expr? source env)     (pt-future source env use))
 857         ((**define-expr? source env)
 858          (pt-syntax-error source "Ill-placed 'define'"))
 859         ((**define-macro-expr? source env)
 860          (pt-syntax-error source "Ill-placed 'define-macro'"))
 861         ((**define-syntax-expr? source env)
 862          (pt-syntax-error source "Ill-placed 'define-syntax'"))
 863         ((**include-expr? source)
 864          (pt-syntax-error source "Ill-placed 'include'"))
 865         ((**declare-expr? source)
 866          (pt-syntax-error source "Ill-placed 'declare'"))
 867         ((**namespace-expr? source)
 868          (pt-syntax-error source "Ill-placed 'namespace'"))
 869 ;;        ((**require-expr? source)
 870 ;;         (pt-syntax-error source "Ill-placed 'require'"))
 871         ((**c-define-type-expr? source)
 872          (pt-syntax-error source "Ill-placed 'c-define-type'"))
 873         ((**c-declare-expr? source)
 874          (pt-syntax-error source "Ill-placed 'c-declare'"))
 875         ((**c-initialize-expr? source)
 876          (pt-syntax-error source "Ill-placed 'c-initialize'"))
 877         ((**c-lambda-expr? source)         (pt-c-lambda source env use))
 878         ((**c-define-expr? source env)
 879          (pt-syntax-error source "Ill-placed 'c-define'"))
 880         ((combination-expr? source)      (pt-combination source env use))
 881         (else
 882          (pt-syntax-error source "Ill-formed expression"))))
 883
 884 (define (macro-expand source env)
 885   (let ((code (source-code source)))
 886     (let* ((descr (env-lookup-macro env (source-code (car code))))
 887            (expander (##macro-descr-expander descr)))
 888       (##sourcify-deep
 889        (if (##macro-descr-def-syntax? descr)
 890            (expander source)
 891            (apply expander (cdr (source->expression source))))
 892        source))))
 893
 894 (define (pt-self-eval source env use)
 895   (let ((val (source->expression source)))
 896     (if (eq? use 'none)
 897       (new-cst source env void-object)
 898       (new-cst source env val))))
 899
 900 (define (pt-quote source env use)
 901   (let ((code (source-code source)))
 902     (if (eq? use 'none)
 903       (new-cst source env void-object)
 904       (new-cst source env (source->expression (cadr code))))))
 905
 906 (define (pt-quasiquote source env use)
 907   (let ((code (source-code source)))
 908     (pt-quasiquotation (cadr code) 1 env)))
 909
 910 (define (pt-quasiquotation form level env)
 911   (cond ((= level 0)
 912          (pt form env 'true))
 913         ((quasiquote-expr? form)
 914          (pt-quasiquotation-list form (source-code form) (+ level 1) env))
 915         ((unquote-expr? form)
 916          (if (= level 1)
 917            (pt (cadr (source-code form)) env 'true)
 918            (pt-quasiquotation-list form (source-code form) (- level 1) env)))
 919         ((unquote-splicing-expr? form)
 920          (if (= level 1)
 921            (pt-syntax-error form "Ill-placed 'unquote-splicing'")
 922            (pt-quasiquotation-list form (source-code form) (- level 1) env)))
 923         ((pair? (source-code form))
 924          (pt-quasiquotation-list form (source-code form) level env))
 925         ((vector-object? (source-code form))
 926          (let ((lst (vect->list (source-code form))))
 927            (vector-form
 928              form
 929              (pt-quasiquotation-list form lst level env)
 930              env)))
 931         (else
 932          (new-cst form env (source->expression form)))))
 933
 934 (define (pt-quasiquotation-list form l level env)
 935   (cond ((pair? l)
 936          (if (and (unquote-splicing-expr? (car l)) (= level 1))
 937            (let ((x (pt (cadr (source-code (car l))) env 'true)))
 938              (if (null? (cdr l))
 939                x
 940                (append-form (car l)
 941                             x
 942                             (pt-quasiquotation-list form (cdr l) 1 env)
 943                             env)))
 944            (cons-form form
 945                       (pt-quasiquotation (car l) level env)
 946                       (pt-quasiquotation-list form (cdr l) level env)
 947                       env)))
 948         ((null? l)
 949          (new-cst form env '()))
 950         (else
 951          (pt-quasiquotation l level env))))
 952
 953 (define (append-form source ptree1 ptree2 env)
 954
 955   (define (call oper-sym args)
 956     (new-call* source (add-not-safe env)
 957       (new-ref-extended-bindings source oper-sym env)
 958       args))
 959
 960   (cond ((and (cst? ptree1) (cst? ptree2))
 961          (new-cst source env
 962            (append (cst-val ptree1) (cst-val ptree2))))
 963         ((and (cst? ptree2) (null? (cst-val ptree2)))
 964          ptree1)
 965         (else
 966          (call **quasi-append-sym (list ptree1 ptree2)))))
 967
 968 (define (cons-form source ptree1 ptree2 env)
 969
 970   (define (call oper-sym args)
 971     (new-call* source (add-not-safe env)
 972       (new-ref-extended-bindings source oper-sym env)
 973       args))
 974
 975   (cond ((and (cst? ptree1) (cst? ptree2))
 976          (new-cst source env
 977            (cons (cst-val ptree1) (cst-val ptree2))))
 978         ((and (cst? ptree2) (null? (cst-val ptree2)))
 979          (call **quasi-list-sym (list ptree1)))
 980         ((and (app? ptree2)
 981               (app->specialized-proc ptree2))
 982          =>
 983          (lambda (proc)
 984            (if (eq? proc **quasi-list-proc-obj)
 985                (call **quasi-list-sym (cons ptree1 (app-args ptree2)))
 986                (call **quasi-cons-sym (list ptree1 ptree2)))))
 987         (else
 988          (call **quasi-cons-sym (list ptree1 ptree2)))))
 989
 990 (define (vector-form source ptree env)
 991
 992   (define (call oper-sym args)
 993     (new-call* source (add-not-safe env)
 994       (new-ref-extended-bindings source oper-sym env)
 995       args))
 996
 997   (cond ((cst? ptree)
 998          (new-cst source env
 999            (list->vect (cst-val ptree))))
1000         ((list-construction? source ptree env)
1001          =>
1002          (lambda (elems)
1003            (call **quasi-vector-sym elems)))
1004         (else
1005          (call **quasi-list->vector-sym (list ptree)))))
1006
1007 (define (list-construction? source ptree env)
1008   (cond ((cst? ptree)
1009          (let ((val (cst-val ptree)))
1010            (if (proper-length val)
1011                (map (lambda (elem-val)
1012                       (new-cst source env
1013                         elem-val))
1014                     val)
1015                #f)))
1016         ((and (app? ptree)
1017               (app->specialized-proc ptree))
1018          =>
1019          (lambda (proc)
1020            (cond ((eq? proc **quasi-cons-proc-obj)
1021                   (let ((args (app-args ptree)))
1022                     (and (eqv? 2 (proper-length args))
1023                          (let* ((arg1 (car args))
1024                                 (arg2 (cadr args))
1025                                 (x (list-construction? source arg2 env)))
1026                            (and x
1027                                 (cons arg1 x))))))
1028                  ((eq? proc **quasi-list-proc-obj)
1029                   (app-args ptree))
1030                  (else
1031                   #f))))
1032         (else
1033          #f)))
1034
1035 (define (pt-var source env use)
1036   (if (eq? use 'none)
1037     (new-cst source env void-object)
1038     (new-ref source env
1039       (env-lookup-var env (source-code source) source))))
1040
1041 (define (pt-set! source env use)
1042   (let* ((code (source-code source))
1043          (var (cadr code)))
1044     (if (not (var-expr? var env))
1045       (pt-syntax-error var "Identifier expected"))
1046     (new-set source env
1047       (env-lookup-var env (source-code var) var)
1048       (pt (caddr code) env 'true))))
1049
1050 (define (pt-lambda source env use)
1051
1052   (define (check-none-result node)
1053     (if (eq? use 'none)
1054       (new-cst source env void-object)
1055       node))
1056
1057   (define (bind-default-bindings default-bindings env)
1058     (if (null? default-bindings)
1059       (pt-body source (cddr (source-code source)) env 'true)
1060       (let* ((binding (car default-bindings))
1061              (var1 (vector-ref binding 0))
1062              (var2 (vector-ref binding 1))
1063              (val (vector-ref binding 2))
1064              (parm-source (vector-ref binding 3))
1065              (vars (list var2)))
1066         (new-call* parm-source env
1067           (new-prc parm-source env #f #f vars '() #f #f
1068             (bind-default-bindings
1069               (cdr default-bindings)
1070               (env-frame env vars)))
1071           (list (new-tst parm-source env
1072                   (new-call* parm-source env
1073                     (new-ref-extended-bindings
1074                       parm-source
1075                       **eq?-sym
1076                       env)
1077                     (list (new-ref parm-source env var1)
1078                           (new-cst parm-source env absent-object)))
1079                   val
1080                   (new-ref parm-source env var1)))))))
1081
1082   (define (split-default-bindings parms env cont)
1083     (let loop ((lst parms)
1084                (rev-vars '())
1085                (rev-defaults '())
1086                (rev-bindings '())
1087                (env env))
1088       (if (null? lst)
1089
1090         (cont (reverse rev-vars)
1091               (reverse rev-defaults)
1092               (reverse rev-bindings)
1093               env)
1094
1095         (let* ((parameter
1096                 (car lst))
1097                (parm-source
1098                 (parameter-source parameter))
1099                (val-source
1100                 (parameter-default-source parameter))
1101                (var1
1102                 (new-variable parm-source))
1103                (val
1104                 (if val-source
1105                   (pt val-source env 'true)
1106                   (new-cst parm-source env
1107                     false-object))))
1108           (if (cst? val)
1109             (loop (cdr lst)
1110                   (cons var1 rev-vars)
1111                   (cons (cst-val val) rev-defaults)
1112                   rev-bindings
1113                   (env-frame env (list var1)))
1114             (let ((var2 (new-variable parm-source)))
1115               (loop (cdr lst)
1116                     (cons var1 rev-vars)
1117                     (cons absent-object rev-defaults)
1118                     (cons (vector var1 var2 val parm-source)
1119                           rev-bindings)
1120                     (env-frame env (list var2)))))))))
1121
1122   (let* ((code
1123           (source-code source))
1124          (all-parms
1125           (extract-parameters (source->parms (cadr code)) env))
1126          (required-parameters
1127           (vector-ref all-parms 0))
1128          (optional-parameters
1129           (vector-ref all-parms 1))
1130          (rest-parameter
1131           (vector-ref all-parms 2))
1132          (dsssl-style-rest?
1133           (vector-ref all-parms 3))
1134          (key-parameters
1135           (vector-ref all-parms 4))
1136          (required-vars
1137           (new-variables (map parameter-source required-parameters)))
1138          (rest-vars
1139           (if rest-parameter
1140             (list (new-variable (parameter-source rest-parameter)))
1141             '())))
1142
1143     (check-none-result
1144      (split-default-bindings
1145       (or optional-parameters '())
1146       (env-frame env required-vars)
1147       (lambda (opt-vars opt-defaults opt-bindings opt-env)
1148         (split-default-bindings
1149          (or key-parameters '())
1150          (if dsssl-style-rest? (env-frame opt-env rest-vars) opt-env)
1151          (lambda (key-vars key-defaults key-bindings key-env)
1152            (let ((keys
1153                   (and key-parameters
1154                        (map (lambda (x)
1155                               (cons (string->keyword-object
1156                                      (symbol->string (var-name (car x))))
1157                                     (cdr x)))
1158                             (pair-up key-vars key-defaults))))
1159                  (outer-vars
1160                   (append required-vars opt-vars key-vars rest-vars)))
1161              (new-prc source env #f #f outer-vars opt-defaults keys
1162                (and rest-parameter
1163                     (if dsssl-style-rest? 'dsssl #t))
1164                (bind-default-bindings
1165                 (append opt-bindings key-bindings)
1166                 (env-frame env outer-vars)))))))))))
1167
1168 (define (parameter-name parm)
1169   (vector-ref parm 0))
1170
1171 (define (parameter-source parm)
1172   (vector-ref parm 1))
1173
1174 (define (parameter-default-source parm)
1175   (vector-ref parm 2))
1176
1177 (define (extract-parameters param-list env)
1178
1179   (define (parm-expected-err source)
1180     (pt-syntax-error source "Identifier expected"))
1181
1182   (define (parm-or-default-binding-expected-err source)
1183     (pt-syntax-error source "Parameter must be an identifier or default binding"))
1184
1185   (define (duplicate-parm-err source)
1186     (pt-syntax-error source "Duplicate parameter in parameter list"))
1187
1188   (define (duplicate-rest-parm-err source)
1189     (pt-syntax-error source "Duplicate rest parameter in parameter list"))
1190
1191   (define (rest-parm-expected-err source)
1192     (pt-syntax-error source "#!rest must be followed by a parameter"))
1193
1194   (define (rest-parm-must-be-last-err source)
1195     (pt-syntax-error source "Rest parameter must be last"))
1196
1197   (define (default-binding-err source)
1198     (pt-syntax-error source "Ill-formed default binding"))
1199
1200   (define (optional-illegal-err source)
1201     (pt-syntax-error source "Ill-placed #!optional"))
1202
1203   (define (key-illegal-err source)
1204     (pt-syntax-error source "Ill-placed #!key"))
1205
1206   (define (key-expected-err source)
1207     (pt-syntax-error source "#!key expected after rest parameter"))
1208
1209   (define (default-binding-illegal-err source)
1210     (pt-syntax-error source "Ill-placed default binding"))
1211
1212   (let loop ((lst param-list)
1213              (rev-required-parms '())
1214              (rev-optional-parms #f)
1215              (rest-parm #f)
1216              (rev-key-parms #f)
1217              (state 1)) ; 1 = required parms or #!optional/#!rest/#!key
1218                         ; 2 = optional parms or #!rest/#!key
1219                         ; 3 = #!key
1220                         ; 4 = key parms (or #!rest if rest-parm=#f)
1221
1222     (define (done rest-parm2)
1223       (vector (reverse rev-required-parms)
1224               (and rev-optional-parms (reverse rev-optional-parms))
1225               rest-parm2
1226               (and rest-parm (= state 4))
1227               (if (or (not rev-key-parms)
1228                       (and (null? rev-key-parms) (not rest-parm2)))
1229                 #f
1230                 (reverse rev-key-parms))))
1231
1232     (define (parm-exists? parm lst)
1233       (and lst
1234            (not (null? lst))
1235            (or (eq? parm (vector-ref (car lst) 0))
1236                (parm-exists? parm (cdr lst)))))
1237
1238     (define (check-if-duplicate parm parm-source)
1239       (if (or (parm-exists? parm rev-required-parms)
1240               (parm-exists? parm rev-optional-parms)
1241               (and rest-parm (eq? parm (vector-ref rest-parm 0)))
1242               (parm-exists? parm rev-key-parms))
1243         (duplicate-parm-err parm-source)))
1244
1245     (cond ((null? lst)
1246            (done rest-parm))
1247           ((pair? lst)
1248            (let* ((parm-source (car lst))
1249                   (parm (source-code parm-source)))
1250              (cond ((optional-object? parm)
1251                     (if (not (= state 1))
1252                       (optional-illegal-err parm-source))
1253                     (loop (cdr lst)
1254                           rev-required-parms
1255                           '()
1256                           rest-parm
1257                           rev-key-parms
1258                           2))
1259                    ((rest-object? parm)
1260                     (if rest-parm
1261                       (duplicate-rest-parm-err parm-source))
1262                     (if (pair? (cdr lst))
1263                       (let* ((parm-source (cadr lst))
1264                              (parm (source-code parm-source)))
1265                         (if (bindable-var? parm-source env)
1266                           (begin
1267                             (check-if-duplicate parm parm-source)
1268                             (if (= state 4)
1269                               (if (null? (cddr lst))
1270                                 (done (vector parm parm-source))
1271                                 (rest-parm-must-be-last-err parm-source))
1272                               (loop (cddr lst)
1273                                     rev-required-parms
1274                                     rev-optional-parms
1275                                     (vector parm parm-source)
1276                                     rev-key-parms
1277                                     3)))
1278                           (parm-expected-err parm-source)))
1279                       (rest-parm-expected-err parm-source)))
1280                    ((key-object? parm)
1281                     (if (= state 4)
1282                       (key-illegal-err parm-source))
1283                     (loop (cdr lst)
1284                           rev-required-parms
1285                           rev-optional-parms
1286                           rest-parm
1287                           '()
1288                           4))
1289                    ((= state 3)
1290                     (key-expected-err parm-source))
1291                    ((bindable-var? parm-source env)
1292                     (check-if-duplicate parm parm-source)
1293                     (case state
1294                       ((1)
1295                        (loop (cdr lst)
1296                              (cons (vector parm parm-source)
1297                                    rev-required-parms)
1298                              rev-optional-parms
1299                              rest-parm
1300                              rev-key-parms
1301                              state))
1302                       ((2)
1303                        (loop (cdr lst)
1304                              rev-required-parms
1305                              (cons (vector parm parm-source #f)
1306                                    rev-optional-parms)
1307                              rest-parm
1308                              rev-key-parms
1309                              state))
1310                       (else
1311                        (loop (cdr lst)
1312                              rev-required-parms
1313                              rev-optional-parms
1314                              rest-parm
1315                              (cons (vector parm parm-source #f)
1316                                    rev-key-parms)
1317                              state))))
1318                    ((pair? parm)
1319                     (if (not (or (= state 2) (= state 4)))
1320                       (default-binding-illegal-err parm-source))
1321                     (let ((length (proper-length parm)))
1322                       (if (not (eqv? length 2))
1323                         (default-binding-err parm-source)))
1324                     (let* ((parm-source (car parm))
1325                            (val-source (cadr parm))
1326                            (parm (source-code parm-source)))
1327                       (if (bindable-var? parm-source env)
1328                         (begin
1329                           (check-if-duplicate parm parm-source)
1330                           (case state
1331                             ((2)
1332                              (loop (cdr lst)
1333                                    rev-required-parms
1334                                    (cons (vector parm parm-source val-source)
1335                                          rev-optional-parms)
1336                                    rest-parm
1337                                    rev-key-parms
1338                                    state))
1339                             (else
1340                              (loop (cdr lst)
1341                                    rev-required-parms
1342                                    rev-optional-parms
1343                                    rest-parm
1344                                    (cons (vector parm parm-source val-source)
1345                                          rev-key-parms)
1346                                    state))))
1347                         (parm-expected-err parm-source))))
1348                    (else
1349                     (if (not (= state 1))
1350                       (parm-or-default-binding-expected-err parm-source)
1351                       (parm-expected-err parm-source))))))
1352           (else
1353            (let* ((parm-source lst)
1354                   (parm (source-code parm-source)))
1355              (if (bindable-var? parm-source env)
1356                (begin
1357                  (if rest-parm
1358                    (duplicate-rest-parm-err parm-source))
1359                  (check-if-duplicate parm parm-source)
1360                  (done (vector parm parm-source)))
1361                (parm-expected-err parm-source)))))))
1362
1363 (define (source->parms source)
1364   (let ((x (source-code source)))
1365     (if (or (pair? x) (null? x)) x source)))
1366
1367 (define (pt-body source body env use)
1368
1369   (define (letrec-defines vars vals envs body env)
1370     (cond ((null? body)
1371            (pt-syntax-error
1372              source
1373              "Body must contain at least one expression"))
1374           ((macro-expr? (car body) env)
1375            (letrec-defines vars
1376                            vals
1377                            envs
1378                            (cons (macro-expand (car body) env)
1379                                  (cdr body))
1380                            env))
1381           ((**begin-cmd-or-expr? (car body))
1382            (letrec-defines vars
1383                            vals
1384                            envs
1385                            (append (begin-body (car body))
1386                                    (cdr body))
1387                            env))
1388           ((**define-expr? (car body) env)
1389            (let* ((var-source (definition-name (car body) env))
1390                   (var (source-code var-source))
1391                   (v (env-define-var env var var-source)))
1392              (letrec-defines (cons v vars)
1393                              (cons (definition-value (car body)) vals)
1394                              (cons env envs)
1395                              (cdr body)
1396                              env)))
1397           ((or (**define-macro-expr? (car body) env)
1398                (**define-syntax-expr? (car body) env))
1399            (letrec-defines vars
1400                            vals
1401                            envs
1402                            (cdr body)
1403                            (add-macro (car body) env)))
1404           ((**include-expr? (car body))
1405            (if *ptree-port*
1406              (display "  " *ptree-port*))
1407            (let ((x (include-expr->source (car body) *ptree-port*)))
1408              (if *ptree-port*
1409                (newline *ptree-port*))
1410              (letrec-defines vars
1411                              vals
1412                              envs
1413                              (cons x (cdr body))
1414                              env)))
1415           ((**declare-expr? (car body))
1416            (letrec-defines vars
1417                            vals
1418                            envs
1419                            (cdr body)
1420                            (add-declarations (car body) env)))
1421           ((**namespace-expr? (car body))
1422            (letrec-defines vars
1423                            vals
1424                            envs
1425                            (cdr body)
1426                            (add-namespace (car body) env)))
1427 ;;          ((**require-expr? (car body))
1428 ;;           (letrec-defines vars
1429 ;;                           vals
1430 ;;                           envs
1431 ;;                           (cdr body)
1432 ;;                           env))
1433           ((null? vars)
1434            (pt-sequence source body env use))
1435           (else
1436            (let ((vars* (reverse vars)))
1437              (let loop ((vals* '()) (l1 vals) (l2 envs))
1438                (if (not (null? l1))
1439                  (loop (cons (pt (car l1) (car l2) 'true) vals*)
1440                        (cdr l1)
1441                        (cdr l2))
1442                  (pt-recursive-let source vars* vals* body env use)))))))
1443
1444   (letrec-defines '() '() '() body (env-frame env '())))
1445
1446 (define (pt-sequence source seq env use)
1447   (cond ;; ((length? seq 0)
1448         ;; ;; treat empty sequence as constant evaluating to the void object
1449         ;; (new-cst source env void-object))
1450         ((length? seq 1)
1451          (pt (car seq) env use))
1452         (else
1453          (new-seq source env
1454            (pt (car seq) env 'none)
1455            (pt-sequence source (cdr seq) env use)))))
1456
1457 (define (pt-if source env use)
1458   (let ((code (source-code source)))
1459     (new-tst source env
1460       (pt (cadr code) env 'pred)
1461       (pt (caddr code) env use)
1462       (if (length? code 3)
1463         (new-cst source env void-object)
1464         (pt (cadddr code) env use)))))
1465
1466 (define (pt-cond source env use)
1467
1468   (define (pt-clauses clauses)
1469     (if (length? clauses 0)
1470       (new-cst source env void-object)
1471       (let* ((clause-source (car clauses))
1472              (clause (source-code clause-source)))
1473         (cond ((eq? (source-code (car clause)) else-sym)
1474                (pt-sequence clause-source (cdr clause) env use))
1475               ((length? clause 1)
1476                (new-disj clause-source env
1477                  (pt (car clause) env (if (eq? use 'true) 'true 'pred))
1478                  (pt-clauses (cdr clauses))))
1479               ((eq? (source-code (cadr clause)) =>-sym)
1480                (new-disj-call clause-source env
1481                  (pt (car clause) env 'true)
1482                  (pt (caddr clause) env 'true)
1483                  (pt-clauses (cdr clauses))))
1484               (else
1485                (new-tst clause-source env
1486                  (pt (car clause) env 'pred)
1487                  (pt-sequence clause-source (cdr clause) env use)
1488                  (pt-clauses (cdr clauses))))))))
1489
1490   (pt-clauses (cdr (source-code source))))
1491
1492 (define (pt-and source env use)
1493
1494   (define (pt-exprs exprs)
1495     (cond ((length? exprs 0)
1496            (new-cst source env #t))
1497           ((length? exprs 1)
1498            (pt (car exprs) env use))
1499           (else
1500            (new-conj (car exprs) env
1501              (pt (car exprs) env (if (eq? use 'true) 'true 'pred))
1502              (pt-exprs (cdr exprs))))))
1503
1504   (pt-exprs (cdr (source-code source))))
1505
1506 (define (pt-or source env use)
1507
1508   (define (pt-exprs exprs)
1509     (cond ((length? exprs 0)
1510            (new-cst source env false-object))
1511           ((length? exprs 1)
1512            (pt (car exprs) env use))
1513           (else
1514            (new-disj (car exprs) env
1515              (pt (car exprs) env (if (eq? use 'true) 'true 'pred))
1516              (pt-exprs (cdr exprs))))))
1517
1518   (pt-exprs (cdr (source-code source))))
1519
1520 (define (pt-case source env use)
1521   (let ((code (source-code source))
1522         (temp (new-temp-variable source 'case-temp)))
1523
1524     (define (pt-clauses clauses)
1525       (if (length? clauses 0)
1526         (new-cst source env void-object)
1527         (let* ((clause-source (car clauses))
1528                (clause (source-code clause-source)))
1529
1530           (define (pt-inlined-memv constants)
1531             (let ((test
1532                     (new-call*
1533                       clause-source
1534                       (add-not-safe env)
1535                       (new-ref-extended-bindings clause-source **eqv?-sym env)
1536                       (list (new-ref clause-source env
1537                               temp)
1538                             (new-cst (car clause) env
1539                               (car constants))))))
1540               (if (null? (cdr constants))
1541                 test
1542                 (new-disj clause-source env
1543                   test
1544                   (pt-inlined-memv (cdr constants))))))
1545
1546
1547           (if (eq? (source-code (car clause)) else-sym)
1548             (pt-sequence clause-source (cdr clause) env use)
1549             (new-tst clause-source env
1550               (pt-inlined-memv (source->expression (car clause)))
1551               (pt-sequence clause-source (cdr clause) env use)
1552               (pt-clauses (cdr clauses)))))))
1553
1554     (new-call* source env
1555       (new-prc source env #f #f (list temp) '() #f #f
1556         (pt-clauses (cddr code)))
1557       (list (pt (cadr code) env 'true)))))
1558
1559 (define (pt-let source env use)
1560   (let ((code (source-code source)))
1561     (if (bindable-var? (cadr code) env)
1562       (let* ((self
1563               (list (new-variable (cadr code))))
1564              (bindings
1565               (map source-code (source-code (caddr code))))
1566              (vars
1567               (new-variables (map car bindings)))
1568              (vals
1569               (map (lambda (x) (pt (cadr x) env 'true)) bindings))
1570              (inner-env1
1571               (env-frame env vars))
1572              (inner-env2
1573               (env-frame inner-env1 self))
1574              (self-proc
1575               (list (new-prc source inner-env1
1576                       #f
1577                       #f
1578                       vars
1579                       '()
1580                       #f
1581                       #f
1582                       (pt-body source (cdddr code) inner-env2 use)))))
1583         (set-prc-names! self self-proc)
1584         (set-prc-names! vars vals)
1585         (new-call* source env
1586           (new-prc source env #f #f self '() #f #f
1587             (new-call* source inner-env1
1588               (new-ref source inner-env1 (car self))
1589               vals))
1590           self-proc))
1591       (if (null? (source-code (cadr code)))
1592         (pt-body source (cddr code) env use)
1593         (let* ((bindings
1594                 (map source-code (source-code (cadr code))))
1595                (vars
1596                 (new-variables (map car bindings)))
1597                (vals
1598                 (map (lambda (x) (pt (cadr x) env 'true)) bindings))
1599                (inner-env
1600                 (env-frame env vars)))
1601           (set-prc-names! vars vals)
1602           (new-call* source env
1603             (new-prc source env
1604               #f
1605               #f
1606               vars
1607               '()
1608               #f
1609               #f
1610               (pt-body source (cddr code) inner-env use))
1611             vals))))))
1612
1613 (define (pt-let* source env use)
1614   (let ((code (source-code source)))
1615
1616     (define (pt-bindings bindings env use)
1617       (if (null? bindings)
1618         (pt-body source (cddr code) env use)
1619         (let* ((binding-source
1620                 (car bindings))
1621                (binding
1622                 (source-code binding-source))
1623                (vars
1624                 (list (new-variable (car binding))))
1625                (vals
1626                 (list (pt (cadr binding) env 'true)))
1627                (inner-env
1628                 (env-frame env vars)))
1629           (set-prc-names! vars vals)
1630           (new-call* binding-source env
1631             (new-prc binding-source env #f #f vars '() #f #f
1632               (pt-bindings (cdr bindings) inner-env use))
1633             vals))))
1634
1635     (pt-bindings (source-code (cadr code)) env use)))
1636
1637 (define (pt-letrec source env use)
1638   (let* ((code
1639           (source-code source))
1640          (bindings
1641           (map source-code (source-code (cadr code))))
1642          (vars*
1643           (new-variables (map car bindings)))
1644          (env*
1645           (env-frame env vars*)))
1646     (pt-recursive-let
1647       source
1648       vars*
1649       (map (lambda (x) (pt (cadr x) env* 'true)) bindings)
1650       (cddr code)
1651       env*
1652       use)))
1653
1654 (define (pt-recursive-let source vars vals body env use)
1655
1656   (define (dependency-graph vars vals)
1657     (let ((var-set (list->varset vars)))
1658
1659       (define (dgraph vars vals)
1660         (if (null? vars)
1661           '()
1662           (let ((var (car vars)) (val (car vals)))
1663             (cons (make-gnode var (varset-intersection
1664                                     var-set
1665                                     (bound-free-variables val)))
1666                   (dgraph (cdr vars) (cdr vals))))))
1667
1668       (dgraph vars vals)))
1669
1670   (define (val-of var)
1671     (list-ref vals (- (length vars) (length (memq var vars)))))
1672
1673   (define (bind-in-order order)
1674     (if (null? order)
1675       (pt-body source body env use)
1676
1677       ; get vars to be bound and vars to be assigned
1678
1679       (let* ((vars-set (car order))
1680              (vars (varset->list vars-set)))
1681         (let loop1 ((l (reverse vars)) (vars-b '()) (vals-b '()) (vars-a '()))
1682           (if (not (null? l))
1683
1684             (let* ((var (car l))
1685                    (val (val-of var)))
1686               (if (or (prc? val)
1687                       (not (varset-intersects? (bound-free-variables val)
1688                                                vars-set)))
1689                 (loop1 (cdr l)
1690                        (cons var vars-b)
1691                        (cons val vals-b)
1692                        vars-a)
1693                 (loop1 (cdr l)
1694                        vars-b
1695                        vals-b
1696                        (cons var vars-a))))
1697
1698             (let* ((result1
1699                      (let loop2 ((l vars-a))
1700                        (if (not (null? l))
1701
1702                          (let* ((var (car l))
1703                                 (val (val-of var)))
1704                            (new-seq source env
1705                              (new-set source env var val)
1706                              (loop2 (cdr l))))
1707
1708                          (bind-in-order (cdr order)))))
1709
1710                    (result2
1711                      (if (null? vars-b)
1712                        result1
1713                        (new-call* source env
1714                          (new-prc source env
1715                            #f
1716                            #f
1717                            vars-b
1718                            '()
1719                            #f
1720                            #f
1721                            result1)
1722                          vals-b)))
1723
1724                    (result3
1725                      (if (null? vars-a)
1726                        result2
1727                        (new-call* source env
1728                          (new-prc source env
1729                            #f
1730                            #f
1731                            vars-a
1732                            '()
1733                            #f
1734                            #f
1735                            result2)
1736                          (map (lambda (var)
1737                                 (new-cst source env
1738                                   void-object))
1739                               vars-a)))))
1740
1741               result3))))))
1742
1743   (set-prc-names! vars vals)
1744
1745   (bind-in-order
1746     (topological-sort
1747       (transitive-closure
1748         (dependency-graph vars vals)))))
1749
1750 (define (pt-begin source env use)
1751   (pt-sequence source (cdr (source-code source)) env use))
1752
1753 (define (pt-do source env use)
1754   (let* ((code
1755           (source-code source))
1756          (loop
1757           (new-temp-variable source 'do-temp))
1758          (bindings
1759           (map source-code (source-code (cadr code))))
1760          (vars
1761           (new-variables (map car bindings)))
1762          (init
1763           (map (lambda (x) (pt (cadr x) env 'true)) bindings))
1764          (inner-env1
1765           (env-frame env (list loop)))
1766          (inner-env2
1767           (env-frame inner-env1 vars))
1768          (step
1769           (map (lambda (x)
1770                  (pt (if (length? x 2) (car x) (caddr x)) inner-env2 'true))
1771                bindings))
1772          (exit
1773           (source-code (caddr code))))
1774     (set-prc-names! vars init)
1775     (new-call* source env
1776       (new-prc source env #f #f (list loop) '() #f #f
1777         (new-call* source inner-env1
1778           (new-ref source inner-env1
1779             loop)
1780           init))
1781       (list
1782         (new-prc source env #f #f vars '() #f #f
1783           (new-tst source inner-env2
1784             (pt (car exit) inner-env2 'pred)
1785             (if (length? exit 1)
1786               (new-cst (caddr code) inner-env2 void-object)
1787               (pt-sequence (caddr code) (cdr exit) inner-env2 use))
1788             (if (length? code 3)
1789               (new-call* source inner-env2
1790                 (new-ref source inner-env2 loop)
1791                 step)
1792               (new-seq source inner-env2
1793                 (pt-sequence source (cdddr code) inner-env2 'none)
1794                 (new-call* source inner-env2
1795                   (new-ref source inner-env2
1796                     loop)
1797                   step)))))))))
1798
1799 (define (pt-combination source env use)
1800   (let* ((code (source-code source))
1801          (oper (pt (car code) env 'true)))
1802     (new-call* source env
1803       oper
1804       (map (lambda (x) (pt x env 'true)) (cdr code)))))
1805
1806 (define (pt-delay source env use)
1807   (let ((code (source-code source)))
1808     (new-call* source (add-not-safe env)
1809       (new-ref-extended-bindings source **make-promise-sym env)
1810       (list (new-prc source env #f #f '() '() #f #f
1811               (pt (cadr code) env 'true))))))
1812
1813 (define (pt-future source env use)
1814   (let ((code (source-code source)))
1815     (new-fut source env
1816       (pt (cadr code) env 'true))))
1817
1818 ;; Expression identification predicates and syntax checking.
1819
1820 (define (self-eval-expr? source)
1821   (let ((code (source-code source)))
1822     (self-evaluating? code)))
1823
1824 (define (self-evaluating? code)
1825   (or (number? code)
1826       (string? code)
1827       (char? code)
1828       (keyword-object? code)
1829       (false-object? code)
1830       (eq? code #t)
1831       (end-of-file-object? code)
1832       (void-object? code)
1833       (unbound1-object? code)
1834       (unbound2-object? code)
1835       (optional-object? code)
1836       (key-object? code)
1837       (rest-object? code)
1838 ;;      (body-object? code)
1839       ))
1840
1841 (define (**quote-expr? source)
1842   (match **quote-sym 2 source))
1843
1844 (define (**quasiquote-expr? source)
1845   (match **quasiquote-sym 2 source))
1846
1847 (define (quasiquote-expr? source)
1848   (match quasiquote-sym 2 source))
1849
1850 (define (unquote-expr? source)
1851   (match unquote-sym 2 source))
1852
1853 (define (unquote-splicing-expr? source)
1854   (match unquote-splicing-sym 2 source))
1855
1856 (define (var-expr? source env)
1857   (let ((code (source-code source)))
1858     (and (symbol-object? code)
1859          (not-macro source env code))))
1860
1861 (define (not-macro source env name)
1862   (if (env-lookup-macro env name)
1863     (pt-syntax-error source "Macro name can't be used as a variable:" name)
1864     #t))
1865
1866 (define (bindable-var? source env)
1867   (let ((code (source-code source)))
1868     (symbol-object? code)))
1869
1870 (define (**set!-expr? source env)
1871   (match **set!-sym 3 source))
1872
1873 (define (**lambda-expr? source env)
1874   (match **lambda-sym -3 source))
1875
1876 (define (lambda-expr? source env)
1877   (match lambda-sym -3 source))
1878
1879 (define (**if-expr? source)
1880   (and (match **if-sym -3 source)
1881        (or (<= (length (source-code source)) 4)
1882            (ill-formed-special-form source))))
1883
1884 (define (**cond-expr? source)
1885   (and (match **cond-sym -2 source)
1886        (proper-clauses? source)))
1887
1888 (define (**and-expr? source)
1889   (match **and-sym -1 source))
1890
1891 (define (**or-expr? source)
1892   (match **or-sym -1 source))
1893
1894 (define (**case-expr? source)
1895   (and (match **case-sym -3 source)
1896        (proper-case-clauses? source)))
1897
1898 (define (**let-expr? source env)
1899   (and (match **let-sym -3 source)
1900        (let ((code (source-code source)))
1901          (if (bindable-var? (cadr code) env)
1902            (and (proper-bindings? (caddr code) #t env)
1903                 (or (> (length code) 3)
1904                     (ill-formed-special-form source)))
1905            (proper-bindings? (cadr code) #t env)))))
1906
1907 (define (**let*-expr? source env)
1908   (and (match **let*-sym -3 source)
1909        (proper-bindings? (cadr (source-code source)) #f env)))
1910
1911 (define (**letrec-expr? source env)
1912   (and (match **letrec-sym -3 source)
1913        (proper-bindings? (cadr (source-code source)) #t env)))
1914
1915 (define (**do-expr? source env)
1916   (and (match **do-sym -3 source)
1917        (proper-do-bindings? source env)
1918        (proper-do-exit? source)))
1919
1920 (define (combination-expr? source)
1921   (let ((code (source-code source)))
1922     (and (pair? code)
1923          (let ((length (proper-length code)))
1924            (if length
1925              (or (> length 0)
1926                  (pt-syntax-error source "Ill-formed procedure call"))
1927              (pt-syntax-error source "Ill-formed procedure call"))))))
1928
1929 (define (**delay-expr? source env)
1930   (and (not (eq? (scheme-dialect env) ieee-scheme-sym))
1931        (match **delay-sym 2 source)))
1932
1933 (define (**future-expr? source env)
1934   (and (eq? (scheme-dialect env) multilisp-sym)
1935        (match **future-sym 2 source)))
1936
1937 (define (macro-expr? source env)
1938   (let ((code (source-code source)))
1939     (and (pair? code)
1940          (symbol-object? (source-code (car code)))
1941          (let ((descr (env-lookup-macro env (source-code (car code)))))
1942            (and descr
1943                 (let ((len (proper-length code)))
1944                   (if len
1945                     (let ((size (##macro-descr-size descr)))
1946                       (or (if (> size 0) (= len size) (>= len (- size)))
1947                           (ill-formed-special-form source)))
1948                     (ill-formed-special-form source))))))))
1949
1950 (define (**begin-cmd-or-expr? source)
1951   (match **begin-sym -1 source))
1952
1953 (define (**begin-expr? source)
1954   (match **begin-sym -2 source))
1955
1956 (define (**define-expr? source env)
1957   (match **define-sym -2 source))
1958
1959 (define (**define-macro-expr? source env)
1960   (match **define-macro-sym -3 source))
1961
1962 (define (**define-syntax-expr? source env)
1963   (match **define-syntax-sym 3 source))
1964
1965 (define (**include-expr? source)
1966   (and (match **include-sym 2 source)
1967        (let ((filename (cadr (source-code source))))
1968          (if (not (string? (source-code filename)))
1969            (pt-syntax-error filename "Filename expected"))
1970          #t)))
1971
1972 (define (**declare-expr? source)
1973   (match **declare-sym -1 source))
1974
1975 (define (**namespace-expr? source)
1976   (match **namespace-sym -1 source))
1977
1978 ;(define (**require-expr? source)
1979 ;;  (and (match **require-sym 2 source)
1980 ;;       (let ((module-name (cadr (source-code source))))
1981 ;;         (if (not (or (symbol-object? (source-code module-name))
1982 ;;                      (string? (source-code module-name))))
1983 ;;           (pt-syntax-error module-name "Module name expected"))
1984 ;;         #t)))
1985
1986 (define (match head size source)
1987   (let ((code (source-code source)))
1988     (and (pair? code)
1989          (eq? (source-code (car code)) head)
1990          (let ((length (proper-length code)))
1991            (if length
1992              (or (if (> size 0) (= length size) (>= length (- size)))
1993                  (ill-formed-special-form source))
1994              (ill-formed-special-form source))))))
1995
1996 (define (ill-formed-special-form source)
1997   (pt-syntax-error
1998    source
1999    "Ill-formed special form:"
2000    (let* ((code (source-code source))
2001           (head (source-code (car code)))
2002           (name (symbol->string head))
2003           (len (string-length name)))
2004      (if (and (< 2 len)
2005               (char=? #\# (string-ref name 0))
2006               (char=? #\# (string-ref name 1)))
2007          (string->symbol (substring name 2 len))
2008          head))))
2009
2010 (define (proper-length l)
2011   (define (length l n)
2012     (cond ((pair? l) (length (cdr l) (+ n 1)))
2013           ((null? l) n)
2014           (else      #f)))
2015   (length l 0))
2016
2017 (define (definition-name source env)
2018   (let* ((code (source-code source))
2019          (head-source (car code))
2020          (head (source-code head-source))
2021          (pattern-source (cadr code))
2022          (pattern (source-code pattern-source))
2023          (len (proper-length code)))
2024     (if (not (cond ((and (eq? head **define-sym)
2025                          (not (pair? pattern)))
2026                     (or (= len 2)
2027                         (= len 3)))
2028                    ((or (eq? head **define-syntax-sym)
2029                         (and (eq? head **define-macro-sym)
2030                              (not (pair? pattern))))
2031                     (= len 3))
2032                    (else
2033                     (>= len 3))))
2034       (ill-formed-special-form source))
2035     (let* ((name-source
2036             (if (and (not (eq? head **define-syntax-sym))
2037                      (pair? pattern))
2038               (car pattern)
2039               pattern-source))
2040            (name
2041             (source-code name-source)))
2042       (if (not (symbol-object? name))
2043         (pt-syntax-error name-source "Identifier expected"))
2044       name-source)))
2045
2046 (define (definition-value source)
2047   (let ((code (source-code source))
2048         (loc (source-locat source)))
2049     (cond ((pair? (source-code (cadr code)))
2050            (make-source
2051              (cons (make-source **lambda-sym loc)
2052                    (cons (parms->source (cdr (source-code (cadr code))) loc)
2053                          (cddr code)))
2054              loc))
2055           ((null? (cddr code))
2056            (make-source
2057              (list (make-source **quote-sym loc)
2058                    (make-source void-object loc))
2059              loc))
2060           (else
2061            (caddr code)))))
2062
2063 (define (parms->source parms loc)
2064   (if (or (pair? parms) (null? parms))
2065     (make-source parms loc)
2066     parms))
2067
2068 (define (proper-clauses? source)
2069
2070   (define (proper-clauses clauses)
2071     (or (null? clauses)
2072         (let* ((clause-source (car clauses))
2073                (clause (source-code clause-source))
2074                (length (proper-length clause)))
2075           (if length
2076             (if (>= length 1)
2077               (if (eq? (source-code (car clause)) else-sym)
2078                 (cond ((= length 1)
2079                        (pt-syntax-error
2080                          clause-source
2081                          "Else clause must have a body"))
2082                       ((not (null? (cdr clauses)))
2083                        (pt-syntax-error
2084                          clause-source
2085                          "Else clause must be last"))
2086                       (else
2087                        (proper-clauses (cdr clauses))))
2088                 (if (and (>= length 2)
2089                          (eq? (source-code (cadr clause)) =>-sym)
2090                          (not (= length 3)))
2091                   (pt-syntax-error
2092                     (cadr clause)
2093                     "'=>' must be followed by a single expression")
2094                   (proper-clauses (cdr clauses))))
2095               (pt-syntax-error clause-source "Ill-formed 'cond' clause"))
2096             (pt-syntax-error clause-source "Ill-formed 'cond' clause")))))
2097
2098   (proper-clauses (cdr (source-code source))))
2099
2100 (define (proper-case-clauses? source)
2101
2102   (define (proper-case-clauses clauses)
2103     (or (null? clauses)
2104         (let* ((clause-source (car clauses))
2105                (clause (source-code clause-source))
2106                (length (proper-length clause)))
2107           (if length
2108             (if (>= length 2)
2109               (if (eq? (source-code (car clause)) else-sym)
2110                 (if (not (null? (cdr clauses)))
2111                   (pt-syntax-error
2112                     clause-source
2113                     "Else clause must be last")
2114                   (proper-case-clauses (cdr clauses)))
2115                 (begin
2116                   (proper-selector-list? (car clause))
2117                   (proper-case-clauses (cdr clauses))))
2118               (pt-syntax-error
2119                 clause-source
2120                 "A 'case' clause must have a selector list and a body"))
2121             (pt-syntax-error clause-source "Ill-formed 'case' clause")))))
2122
2123   (proper-case-clauses (cddr (source-code source))))
2124
2125 (define (proper-selector-list? source)
2126   (let* ((code (source-code source))
2127          (length (proper-length code)))
2128     (if length
2129       (or (>= length 1)
2130           (pt-syntax-error
2131             source
2132             "Selector list must contain at least one element"))
2133       (pt-syntax-error source "Ill-formed selector list"))))
2134
2135 (define (proper-bindings? bindings check-dupl? env)
2136
2137   (define (proper-bindings l seen)
2138     (cond ((pair? l)
2139            (let* ((binding-source (car l))
2140                   (binding (source-code binding-source)))
2141              (if (eqv? (proper-length binding) 2)
2142                (let ((var (car binding)))
2143                  (if (bindable-var? var env)
2144                    (if (and check-dupl? (memq (source-code var) seen))
2145                      (pt-syntax-error var "Duplicate variable in bindings")
2146                      (proper-bindings (cdr l)
2147                                       (cons (source-code var) seen)))
2148                    (pt-syntax-error var "Identifier expected")))
2149                (pt-syntax-error binding-source "Ill-formed binding"))))
2150           ((null? l)
2151            #t)
2152           (else
2153            (pt-syntax-error bindings "Ill-formed binding list"))))
2154
2155    (proper-bindings (source-code bindings) '()))
2156
2157 (define (proper-do-bindings? source env)
2158   (let ((bindings (cadr (source-code source))))
2159
2160     (define (proper-bindings l seen)
2161       (cond ((pair? l)
2162              (let* ((binding-source (car l))
2163                     (binding (source-code binding-source))
2164                     (length (proper-length binding)))
2165                (if (or (eqv? length 2) (eqv? length 3))
2166                  (let ((var (car binding)))
2167                    (if (bindable-var? var env)
2168                      (if (memq (source-code var) seen)
2169                        (pt-syntax-error var "Duplicate variable in bindings")
2170                        (proper-bindings (cdr l)
2171                                         (cons (source-code var) seen)))
2172                      (pt-syntax-error
2173                        var
2174                        "Identifier expected")))
2175                  (pt-syntax-error binding-source "Ill-formed binding"))))
2176             ((null? l)
2177              #t)
2178             (else
2179              (pt-syntax-error bindings "Ill-formed binding list"))))
2180
2181      (proper-bindings (source-code bindings) '())))
2182
2183 (define (proper-do-exit? source)
2184   (let* ((exit-source (caddr (source-code source)))
2185          (exit (source-code exit-source))
2186          (length (proper-length exit)))
2187     (if (and length (> length 0))
2188       #t
2189       (pt-syntax-error exit-source "Ill-formed exit clause"))))
2190
2191 (define (begin-body source)
2192   (cdr (source-code source)))
2193
2194 (define (length? l n)
2195   (cond ((null? l) (= n 0))
2196         ((> n 0)   (length? (cdr l) (- n 1)))
2197         (else      #f)))
2198
2199 ;;; - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
2200 ;;
2201 ;; Declaration handling:
2202 ;; --------------------
2203
2204 ;; A declaration has the form: (##declare <item1> <item2> ...)
2205 ;;
2206 ;; an <item> can be one of 6 types:
2207 ;;
2208 ;; - flag declaration           : (<id>)
2209 ;; - parameterized declaration  : (<id> <parameter>)
2210 ;; - boolean declaration        : (<id>)  or  (not <id>)
2211 ;; - namable declaration        : (<id> <name>...)
2212 ;; - namable boolean declaration: (<id> <name>...)  or  (not <id> <name>...)
2213
2214 (define (transform-declaration source)
2215   (let ((code (source-code source)))
2216     (if (not (pair? code))
2217       (pt-syntax-error source "Ill-formed declaration")
2218       (let* ((pos (not (eq? (source-code (car code)) not-sym)))
2219              (x (if pos code (cdr code))))
2220         (if (not (pair? x))
2221           (pt-syntax-error source "Ill-formed declaration")
2222           (let* ((id-source (car x))
2223                  (id (source-code id-source)))
2224
2225             (cond ((not (symbol-object? id))
2226                    (pt-syntax-error
2227                      id-source
2228                      "Declaration name must be an identifier"))
2229
2230                   ((assq id flag-declarations)
2231                    (cond ((not pos)
2232                           (pt-syntax-error
2233                             id-source
2234                             "Declaration can't be negated"))
2235                          ((null? (cdr x))
2236                           (flag-decl
2237                             source
2238                             (cdr (assq id flag-declarations))
2239                             id))
2240                          (else
2241                           (pt-syntax-error source "Ill-formed declaration"))))
2242
2243                   ((memq id parameterized-declarations)
2244                    (cond ((not pos)
2245                           (pt-syntax-error
2246                             id-source
2247                             "Declaration can't be negated"))
2248                          ((eqv? (proper-length x) 2)
2249                           (let ((parm (source->expression (cadr x))))
2250                             (if (not (and (integer? parm) (exact? parm)))
2251                               (pt-syntax-error source "Exact integer expected")
2252                               (parameterized-decl source id parm))))
2253                          (else
2254                           (pt-syntax-error source "Ill-formed declaration"))))
2255
2256                   ((memq id boolean-declarations)
2257                    (if (null? (cdr x))
2258                      (boolean-decl source id pos)
2259                      (pt-syntax-error source "Ill-formed declaration")))
2260
2261                   ((assq id namable-declarations)
2262                    (cond ((not pos)
2263                           (pt-syntax-error
2264                             id-source
2265                             "Declaration can't be negated"))
2266                          (else
2267                           (namable-decl
2268                             source
2269                             (cdr (assq id namable-declarations))
2270                             id
2271                             (extract-names source (cdr x))))))
2272
2273                   ((memq id namable-boolean-declarations)
2274                    (namable-boolean-decl
2275                      source
2276                      id
2277                      pos
2278                      (extract-names source (cdr x))))
2279
2280                   (else
2281                    (pt-syntax-error id-source "Unknown declaration")))))))))
2282
2283 (define (extract-names source lst)
2284
2285   (define (extract lst)
2286     (cond ((pair? lst)
2287            (let* ((name-source (car lst))
2288                   (name (source-code name-source)))
2289              (if (symbol-object? name)
2290                (cons name (extract (cdr lst)))
2291                (pt-syntax-error name-source "Identifier expected"))))
2292           ((null? lst)
2293            '())
2294           (else
2295            (pt-syntax-error source "Ill-formed declaration"))))
2296
2297   (extract lst))
2298
2299 (define (add-declarations source env)
2300   (let loop ((lst (cdr (source-code source))) (env env))
2301     (if (pair? lst)
2302       (loop (cdr lst)
2303             (env-declare env (transform-declaration (car lst))))
2304       env)))
2305
2306 ;;; - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
2307 ;;
2308 ;; Namespace handling:
2309 ;; ------------------
2310
2311 (define (add-namespace source env)
2312   (let ((code (cdr (source-code source))))
2313     (let loop ((lst code) (env env))
2314       (if (pair? lst)
2315         (let* ((form-source (car lst))
2316                (form (source-code form-source)))
2317           (if (not (pair? form))
2318             (pt-syntax-error source "Ill-formed namespace")
2319             (let* ((space-source (car form))
2320                    (space (source-code space-source)))
2321               (cond ((not (string? space))
2322                      (pt-syntax-error source "Ill-formed namespace"))
2323                     ((not (valid-prefix? space))
2324                      (pt-syntax-error space-source "Illegal namespace"))
2325                     (else
2326                      (let ()
2327
2328                        (define (extract lst)
2329                          (cond ((pair? lst)
2330                                 (let* ((name-source (car lst))
2331                                        (name (source-code name-source)))
2332                                   (if (symbol-object? name)
2333                                     (cons name (extract (cdr lst)))
2334                                     (pt-syntax-error name-source "Identifier expected"))))
2335                                ((null? lst)
2336                                 '())
2337                                (else
2338                                 (pt-syntax-error source "Ill-formed namespace"))))
2339
2340                        (loop (cdr lst)
2341                              (env-namespace
2342                               env
2343                               (cons space (extract (cdr form)))))))))))
2344         env))))
2345
2346 ;;; - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
2347 ;;
2348 ;; Macro handling:
2349 ;; --------------
2350
2351 (define (add-macro source env)
2352   (let ((def-syntax? (**define-syntax-expr? source env)))
2353
2354     (define (form-size parms)
2355       (let loop ((lst parms) (n 1))
2356         (cond ((pair? lst)
2357                (let ((parm (source-code (car lst))))
2358                  (if (or (optional-object? parm)
2359                          (key-object? parm)
2360                          (rest-object? parm))
2361                      (- n)
2362                      (loop (cdr lst)
2363                            (+ n 1)))))
2364               ((null? lst)
2365                n)
2366               (else
2367                (- n)))))
2368
2369     (define (error-proc . msgs)
2370       (apply compiler-user-error
2371              (cons (source-locat source)
2372                    (cons "(in macro body)" msgs))))
2373
2374     (define (make-descr var proc size)
2375       (let ((expander
2376              (scheme-global-eval (source->expression proc)
2377                                  error-proc)))
2378         (if (not (procedure? expander))
2379             (pt-syntax-error proc "Macro expander must be a procedure")
2380             (env-macro env
2381                        (source-code var)
2382                        (##make-macro-descr def-syntax? size expander proc)))))
2383
2384     (let* ((var (definition-name source env))
2385            (proc (definition-value source)))
2386       (if def-syntax?
2387           (make-descr var
2388                       proc
2389                       -1)
2390           (if (or (**lambda-expr? proc env)
2391                   (lambda-expr? proc env))
2392               (make-descr var
2393                           proc
2394                           (form-size
2395                            (source->parms (cadr (source-code proc)))))
2396               (pt-syntax-error proc "Macro value must be a lambda expression"))))))
2397
2398 ;;; - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
2399
2400 (define (ptree.begin! info-port) ; initialize module
2401   (set! *ptree-port* info-port)
2402   (set! next-node-stamp (make-counter 0))
2403   (set! temp-variable-stamp (make-counter 0))
2404   '())
2405
2406 (define (ptree.end!) ; finalize module
2407   (set! next-node-stamp #f)
2408   (set! temp-variable-stamp #f)
2409   '())
2410
2411 ;;; - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
2412 ;;
2413 ;; Stuff local to the module:
2414
2415 (define *ptree-port* '())
2416
2417 ;;;============================================================================