home *** CD-ROM | disk | FTP | other *** search
/ MacFormat 1994 November / macformat-018.iso / Utility Spectacular / Developer / macgambit-20-compiler-src-p2 / Interp⁄Comp (.scm) / ptree1.scm < prev    next >
Encoding:
Text File  |  1994-07-26  |  73.3 KB  |  2,127 lines  |  [TEXT/gamI]
  1. ;==============================================================================
  2.  
  3. ; file: "ptree1.scm"
  4.  
  5. ;------------------------------------------------------------------------------
  6. ;
  7. ; Parse tree manipulation package: (part 1)
  8. ; -------------------------------
  9.  
  10. ; This package contains procedures to construct the parse tree of a Scheme
  11. ; expression and manipulate the parse tree.
  12.  
  13. ; - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
  14. ;
  15. ; Definition of the structures found in the parse tree.
  16.  
  17. ; These structures define the nodes associated to expressions.
  18.  
  19. ; information common to all nodes
  20.  
  21. ;  parent   ; the node of which this node is a child
  22. ;  children ; list of parse-trees of the sub-expressions
  23. ;  fv       ; set of free/non-global vars contained in this expr
  24. ;  decl     ; declarations that apply to this node
  25. ;  source   ; source corresponding to this node
  26.  
  27. (define (node-parent x)          (vector-ref x 1))
  28. (define (node-children x)        (vector-ref x 2))
  29. (define (node-fv x)              (vector-ref x 3))
  30. (define (node-decl x)            (vector-ref x 4))
  31. (define (node-source x)          (vector-ref x 5))
  32. (define (node-parent-set! x y)   (vector-set! x 1 y))
  33. (define (node-fv-set! x y)       (vector-set! x 3 y))
  34. (define (node-decl-set! x y)     (vector-set! x 4 y))
  35. (define (node-source-set! x y)   (vector-set! x 5 y))
  36.  
  37. (define (node-children-set! x y)
  38.   (vector-set! x 2 y)
  39.   (for-each (lambda (child) (node-parent-set! child x)) y)
  40.   (node-fv-invalidate! x))
  41.  
  42. (define (node-fv-invalidate! x)
  43.   (let loop ((node x))
  44.     (if node
  45.       (begin
  46.         (node-fv-set! node #t)
  47.         (loop (node-parent node))))))
  48.  
  49. (define (make-cst ; node that represents constants
  50.          parent children fv decl source ; common to all nodes
  51.  
  52.     val) ; value of the constant
  53.  
  54.   (vector cst-tag parent children fv decl source val))
  55.  
  56. (define (cst? x)
  57.   (and (vector? x)
  58.        (> (vector-length x) 0)
  59.        (eq? (vector-ref x 0) cst-tag)))
  60.  
  61. (define (cst-val x)        (vector-ref x 6))
  62. (define (cst-val-set! x y) (vector-set! x 6 y))
  63.  
  64. (define cst-tag (list 'cst-tag))
  65.  
  66. (define (make-ref ; node that represents variable references
  67.          parent children fv decl source ; common to all nodes
  68.  
  69.     var) ; the variable which is referenced
  70.  
  71.   (vector ref-tag parent children fv decl source var))
  72.  
  73. (define (ref? x)
  74.   (and (vector? x)
  75.        (> (vector-length x) 0)
  76.        (eq? (vector-ref x 0) ref-tag)))
  77.  
  78. (define (ref-var x)        (vector-ref x 6))
  79. (define (ref-var-set! x y) (vector-set! x 6 y))
  80.  
  81. (define ref-tag (list 'ref-tag))
  82.  
  83. (define (make-set ; node that represents assignments (i.e. set! special forms)
  84.          parent children fv decl source ; common to all nodes
  85.  
  86.     var) ; the variable which is assigned a value
  87.  
  88.   (vector set-tag parent children fv decl source var))
  89.  
  90. (define (set? x)
  91.   (and (vector? x)
  92.        (> (vector-length x) 0)
  93.        (eq? (vector-ref x 0) set-tag)))
  94.  
  95. (define (set-var x)        (vector-ref x 6))
  96. (define (set-var-set! x y) (vector-set! x 6 y))
  97.  
  98. (define set-tag (list 'set-tag))
  99.  
  100. (define (make-def ; node that represents toplevel definitions
  101.          parent children fv decl source ; common to all nodes
  102.  
  103.     var) ; the global variable which is assigned a value
  104.  
  105.   (vector def-tag parent children fv decl source var))
  106.  
  107. (define (def? x)
  108.   (and (vector? x)
  109.        (> (vector-length x) 0)
  110.        (eq? (vector-ref x 0) def-tag)))
  111.  
  112. (define (def-var x)        (vector-ref x 6))
  113. (define (def-var-set! x y) (vector-set! x 6 y))
  114.  
  115. (define def-tag (list 'def-tag))
  116.  
  117. (define (make-tst ; node that represents conditionals (i.e. if special forms)
  118.          parent children fv decl source ; common to all nodes
  119.  
  120.     )
  121.  
  122.   (vector tst-tag parent children fv decl source))
  123.  
  124. (define (tst? x)
  125.   (and (vector? x)
  126.        (> (vector-length x) 0)
  127.        (eq? (vector-ref x 0) tst-tag)))
  128.  
  129. (define tst-tag (list 'tst-tag))
  130.  
  131. (define (make-conj ; node that represents conjunctions (i.e. and special forms)
  132.          parent children fv decl source ; common to all nodes
  133.  
  134.     )
  135.  
  136.   (vector conj-tag parent children fv decl source))
  137.  
  138. (define (conj? x)
  139.   (and (vector? x)
  140.        (> (vector-length x) 0)
  141.        (eq? (vector-ref x 0) conj-tag)))
  142.  
  143. (define conj-tag (list 'conj-tag))
  144.  
  145. (define (make-disj ; node that represents disjunctions (i.e. or special forms)
  146.          parent children fv decl source ; common to all nodes
  147.  
  148.     )
  149.  
  150.   (vector disj-tag parent children fv decl source))
  151.  
  152. (define (disj? x)
  153.   (and (vector? x)
  154.        (> (vector-length x) 0)
  155.        (eq? (vector-ref x 0) disj-tag)))
  156.  
  157. (define disj-tag (list 'disj-tag))
  158.  
  159. (define (make-prc ; node that represents procedures (i.e. lambda-expressions)
  160.          parent children fv decl source ; common to all nodes
  161.  
  162.     name   ; name of this procedure (string)
  163.     min    ; number of required parameters
  164.     rest   ; #t if the last parameter is a rest parameter
  165.     parms) ; the list of parameter variables in order
  166.  
  167.   (vector prc-tag parent children fv decl source name min rest parms))
  168.  
  169. (define (prc? x)
  170.   (and (vector? x)
  171.        (> (vector-length x) 0)
  172.        (eq? (vector-ref x 0) prc-tag)))
  173.  
  174. (define (prc-name x)         (vector-ref x 6))
  175. (define (prc-min x)          (vector-ref x 7))
  176. (define (prc-rest x)         (vector-ref x 8))
  177. (define (prc-parms x)        (vector-ref x 9))
  178. (define (prc-name-set! x y)  (vector-set! x 6 y))
  179. (define (prc-min-set! x y)   (vector-set! x 7 y))
  180. (define (prc-rest-set! x y)  (vector-set! x 8 y))
  181. (define (prc-parms-set! x y) (vector-set! x 9 y))
  182.  
  183. (define prc-tag (list 'prc-tag))
  184.  
  185. (define (make-app ; node that represents procedure calls
  186.          parent children fv decl source ; common to all nodes
  187.  
  188.     )
  189.  
  190.   (vector app-tag parent children fv decl source))
  191.  
  192. (define (app? x)
  193.   (and (vector? x)
  194.        (> (vector-length x) 0)
  195.        (eq? (vector-ref x 0) app-tag)))
  196.  
  197. (define app-tag (list 'app-tag))
  198.  
  199. (define (make-fut ; node that represents future constructs
  200.          parent children fv decl source ; common to all nodes
  201.  
  202.     )
  203.  
  204.   (vector fut-tag parent children fv decl source))
  205.  
  206. (define (fut? x)
  207.   (and (vector? x)
  208.        (> (vector-length x) 0)
  209.        (eq? (vector-ref x 0) fut-tag)))
  210.  
  211. (define fut-tag (list 'fut-tag))
  212.  
  213. ; - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
  214. ;
  215. ; Procedures to create parse tree nodes and extract sub-nodes.
  216.  
  217. (define (new-cst source decl val)
  218.   (make-cst #f '() #t decl source val))
  219.  
  220. (define (new-ref source decl var)
  221.   (let ((node (make-ref #f '() #t decl source var)))
  222.     (var-refs-set! var (set-adjoin (var-refs var) node))
  223.     node))
  224.  
  225. (define (new-ref-extended-bindings source name env)
  226.   (new-ref source
  227.            (add-extended-bindings (env-declarations env))
  228.            (env-lookup-global-var env name)))
  229.  
  230. (define (new-set source decl var val)
  231.   (let ((node (make-set #f (list val) #t decl source var)))
  232.     (var-sets-set! var (set-adjoin (var-sets var) node))
  233.     (node-parent-set! val node)
  234.     node))
  235.  
  236. (define (set-val x)
  237.   (if (set? x)
  238.     (car (node-children x))
  239.     (compiler-internal-error "set-val, 'set' node expected" x)))
  240.  
  241. (define (new-def source decl var val)
  242.   (let ((node (make-def #f (list val) #t decl source var)))
  243.     (var-sets-set! var (set-adjoin (var-sets var) node))
  244.     (node-parent-set! val node)
  245.     node))
  246.  
  247. (define (def-val x)
  248.   (if (def? x)
  249.     (car (node-children x))
  250.     (compiler-internal-error "def-val, 'def' node expected" x)))
  251.  
  252. (define (new-tst source decl pre con alt)
  253.   (let ((node (make-tst #f (list pre con alt) #t decl source)))
  254.     (node-parent-set! pre node)
  255.     (node-parent-set! con node)
  256.     (node-parent-set! alt node)
  257.     node))
  258.  
  259. (define (tst-pre x)
  260.   (if (tst? x)
  261.     (car (node-children x))
  262.     (compiler-internal-error "tst-pre, 'tst' node expected" x)))
  263.  
  264. (define (tst-con x)
  265.   (if (tst? x)
  266.     (cadr (node-children x))
  267.     (compiler-internal-error "tst-con, 'tst' node expected" x)))
  268.  
  269. (define (tst-alt x)
  270.   (if (tst? x)
  271.     (caddr (node-children x))
  272.     (compiler-internal-error "tst-alt, 'tst' node expected" x)))
  273.  
  274. (define (new-conj source decl pre alt)
  275.   (let ((node (make-conj #f (list pre alt) #t decl source)))
  276.     (node-parent-set! pre node)
  277.     (node-parent-set! alt node)
  278.     node))
  279.  
  280. (define (conj-pre x)
  281.   (if (conj? x)
  282.     (car (node-children x))
  283.     (compiler-internal-error "conj-pre, 'conj' node expected" x)))
  284.  
  285. (define (conj-alt x)
  286.   (if (conj? x)
  287.     (cadr (node-children x))
  288.     (compiler-internal-error "conj-alt, 'conj' node expected" x)))
  289.  
  290. (define (new-disj source decl pre alt)
  291.   (let ((node (make-disj #f (list pre alt) #t decl source)))
  292.     (node-parent-set! pre node)
  293.     (node-parent-set! alt node)
  294.     node))
  295.  
  296. (define (disj-pre x)
  297.   (if (disj? x)
  298.     (car (node-children x))
  299.     (compiler-internal-error "disj-pre, 'disj' node expected" x)))
  300.  
  301. (define (disj-alt x)
  302.   (if (disj? x)
  303.     (cadr (node-children x))
  304.     (compiler-internal-error "disj-alt, 'disj' node expected" x)))
  305.  
  306. (define (new-prc source decl name min rest parms body)
  307.   (let ((node (make-prc #f (list body) #t decl source name min rest parms)))
  308.     (for-each (lambda (x) (var-bound-set! x node)) parms)
  309.     (node-parent-set! body node)
  310.     node))
  311.  
  312. (define (prc-body x)
  313.   (if (prc? x)
  314.     (car (node-children x))
  315.     (compiler-internal-error "prc-body, 'proc' node expected" x)))
  316.  
  317. (define (new-call source decl oper args)
  318.   (let ((node (make-app #f (cons oper args) #t decl source)))
  319.     (node-parent-set! oper node)
  320.     (for-each (lambda (x) (node-parent-set! x node)) args)
  321.     node))
  322.  
  323. (define (new-call* source decl oper args)
  324.   (if *ptree-port*
  325.     (if (ref? oper)
  326.       (let ((var (ref-var oper)))
  327.         (if (global? var)
  328.           (let ((proc (standard-procedure (var-name var) (node-decl oper))))
  329.             (if (and proc
  330.                      (not (nb-args-conforms?
  331.                             (length args)
  332.                             (standard-procedure-call-pattern proc))))
  333.               (begin
  334.                 (display "*** Warning: \"" *ptree-port*)
  335.                 (display (var-name var) *ptree-port*)
  336.                 (display "\" is called with " *ptree-port*)
  337.                 (display (length args) *ptree-port*)
  338.                 (display " argument(s)." *ptree-port*)
  339.                 (newline *ptree-port*))))))))
  340.   (new-call source decl oper args))
  341.  
  342. (define (app-oper x)
  343.   (if (app? x)
  344.     (car (node-children x))
  345.     (compiler-internal-error "app-oper, 'call' node expected" x)))
  346.  
  347. (define (app-args x)
  348.   (if (app? x)
  349.     (cdr (node-children x))
  350.     (compiler-internal-error "app-args, 'call' node expected" x)))
  351.  
  352. (define (oper-pos? node)
  353.   (let ((parent (node-parent node)))
  354.     (if parent
  355.       (and (app? parent)
  356.            (eq? (app-oper parent) node))
  357.       #f)))
  358.  
  359. (define (new-fut source decl val)
  360.   (let ((node (make-fut #f (list val) #t decl source)))
  361.     (node-parent-set! val node)
  362.     node))
  363.  
  364. (define (fut-val x)
  365.   (if (fut? x)
  366.     (car (node-children x))
  367.     (compiler-internal-error "fut-val, 'fut' node expected" x)))
  368.  
  369. (define (new-disj-call source decl pre oper alt)
  370.   (new-call* source decl
  371.     (let* ((parms (new-temps source '(temp)))
  372.            (temp (car parms)))
  373.       (new-prc source decl #f 1 #f parms
  374.         (new-tst source decl
  375.           (new-ref source decl temp)
  376.           (new-call* source decl oper (list (new-ref source decl temp)))
  377.           alt)))
  378.     (list pre)))
  379.  
  380. (define (new-seq source decl before after)
  381.   (new-call* source decl
  382.     (new-prc source decl #f 1 #f (new-temps source '(temp))
  383.       after)
  384.     (list before)))
  385.  
  386. (define (new-let ptree proc vars vals body)
  387.   (if (pair? vars)
  388.     (new-call (node-source ptree) (node-decl ptree)
  389.       (new-prc (node-source proc) (node-decl proc)
  390.         (prc-name proc)
  391.         (length vars)
  392.         #f
  393.         (reverse vars)
  394.         body)
  395.       (reverse vals))
  396.     body))
  397.  
  398. (define (new-temps source names)
  399.   (if (null? names)
  400.     '()
  401.     (cons (make-var (car names) #t (set-empty) (set-empty) source)
  402.           (new-temps source (cdr names)))))
  403.  
  404. (define (new-variables vars)
  405.   (if (null? vars)
  406.     '()
  407.     (cons (make-var (source-code (car vars)) #t (set-empty) (set-empty) (car vars))
  408.           (new-variables (cdr vars)))))
  409.  
  410. (define (set-prc-names! vars vals)
  411.   (let loop ((vars vars) (vals vals))
  412.     (if (not (null? vars))
  413.       (let ((var (car vars))
  414.             (val (car vals)))
  415.         (if (prc? val)
  416.           (prc-name-set! val (symbol->string (var-name var))))
  417.         (loop (cdr vars) (cdr vals))))))
  418.  
  419. ; - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
  420. ;
  421. ; Procedures to get variable classes from nodes.
  422.  
  423. (define (free-variables node) ; set of free variables used in the expression
  424.   (if (eq? (node-fv node) #t)
  425.     (let ((x (apply set-union (map free-variables (node-children node)))))
  426.       (node-fv-set! node
  427.         (cond ((ref? node)
  428.                (if (global? (ref-var node)) x (set-adjoin x (ref-var node))))
  429.               ((set? node)
  430.                (if (global? (set-var node)) x (set-adjoin x (set-var node))))
  431.               ((prc? node)
  432.                (set-difference x (list->set (prc-parms node))))
  433.               ((and (app? node) (prc? (app-oper node)))
  434.                (set-difference x (list->set (prc-parms (app-oper node)))))
  435.               (else
  436.                x)))))
  437.   (node-fv node))
  438.  
  439. (define (bound-variables node) ; set of variables bound by a procedure
  440.   (list->set (prc-parms node)))
  441.  
  442. (define (not-mutable? var)
  443.   (set-empty? (var-sets var)))
  444.  
  445. (define (mutable? var)
  446.   (not (not-mutable? var)))
  447.  
  448. (define (bound? var)
  449.   (var-bound var))
  450.  
  451. (define (global? var)
  452.   (not (bound? var)))
  453.  
  454. (define (global-val var) ; get value of a global if it is known to be constant
  455.   (and (global? var)
  456.        (let ((sets (set->list (var-sets var))))
  457.          (and (pair? sets) (null? (cdr sets))
  458.               (def? (car sets))
  459.               (eq? (compilation-strategy (node-decl (car sets))) BLOCK-sym)
  460.               (def-val (car sets))))))
  461.  
  462. ; - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
  463. ;
  464. ; Canonical symbols for procedures needed by the front end:
  465.  
  466. (define **NOT-sym                (string->canonical-symbol "##NOT"))
  467. (define **QUASI-APPEND-sym       (string->canonical-symbol "##QUASI-APPEND"))
  468. (define **QUASI-LIST-sym         (string->canonical-symbol "##QUASI-LIST"))
  469. (define **QUASI-CONS-sym         (string->canonical-symbol "##QUASI-CONS"))
  470. (define **QUASI-LIST->VECTOR-sym (string->canonical-symbol "##QUASI-LIST->VECTOR"))
  471. (define **CASE-MEMV-sym          (string->canonical-symbol "##CASE-MEMV"))
  472. (define **UNASSIGNED?-sym        (string->canonical-symbol "##UNASSIGNED?"))
  473. (define **MAKE-CELL-sym          (string->canonical-symbol "##MAKE-CELL"))
  474. (define **CELL-REF-sym           (string->canonical-symbol "##CELL-REF"))
  475. (define **CELL-SET!-sym          (string->canonical-symbol "##CELL-SET!"))
  476.  
  477. ; - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
  478. ;
  479. ; Declarations relevant to parsing:
  480.  
  481. ; Dialect related declarations:
  482. ;
  483. ; (ieee-scheme)     use IEEE Scheme
  484. ; (r4rs-scheme)     use R4RS Scheme
  485. ; (multilisp)       use Multilisp
  486. ;
  487. ; Lambda-lifting declarations:
  488. ;
  489. ; (lambda-lift)     can lambda-lift procedures
  490. ; (not lambda-lift) can't lambda-lift procedures
  491. ;
  492. ; Compilation strategy declarations:
  493. ;
  494. ; (block)     global vars defined are only mutated by code in the current file
  495. ; (separate)  global vars defined can be mutated by other code
  496. ;
  497. ; Global variable binding declarations:
  498. ;
  499. ; (standard-bindings)                 compiler can assume standard bindings
  500. ; (standard-bindings <var1> ...)      assume st. bind. for vars specified
  501. ; (not standard-bindings)             can't assume st. bind. for any var
  502. ; (not standard-bindings <var1> ...)  can't assume st. bind. for vars spec.
  503. ;
  504. ; (extended-bindings)                 compiler can assume extended bindings
  505. ; (extended-bindings <var1> ...)      assume ext. bind. for vars specified
  506. ; (not extended-bindings)             can't assume ext. bind. for any var
  507. ; (not extended-bindings <var1> ...)  can't assume ext. bind. for vars spec.
  508. ;
  509. ; Code safety declarations:
  510. ;
  511. ; (safe)                              runtime errors won't crash system
  512. ; (not safe)                          assume program doesn't contain errors
  513. ;
  514. ; Interrupt checking declarations:
  515. ;
  516. ; (intr-checks)     generate interrupt checks
  517. ; (not intr-checks) don't generate interrupt checks
  518. ;
  519. ; Future implementation method declarations:
  520. ;
  521. ; (futures off)                       future = identity operation
  522. ; (futures delay)                     'delay' future method
  523. ; (futures eager)                     'eager' future method
  524. ; (futures lazy)                      'lazy' future method
  525. ; (futures eager-inline)              inlined 'eager' future method
  526. ;
  527. ; Touching analysis declarations:
  528. ;
  529. ; (autotouch)                         compiler does touching wherever needed
  530. ; (not autotouch)                     (touch ...) are explicit
  531.  
  532. (define IEEE-SCHEME-sym (string->canonical-symbol "IEEE-SCHEME"))
  533. (define R4RS-SCHEME-sym (string->canonical-symbol "R4RS-SCHEME"))
  534. (define MULTILISP-sym   (string->canonical-symbol "MULTILISP"))
  535.  
  536. (define LAMBDA-LIFT-sym (string->canonical-symbol "LAMBDA-LIFT"))
  537.  
  538. (define BLOCK-sym       (string->canonical-symbol "BLOCK"))
  539. (define SEPARATE-sym    (string->canonical-symbol "SEPARATE"))
  540.  
  541. (define STANDARD-BINDINGS-sym (string->canonical-symbol "STANDARD-BINDINGS"))
  542. (define EXTENDED-BINDINGS-sym (string->canonical-symbol "EXTENDED-BINDINGS"))
  543.  
  544. (define SAFE-sym              (string->canonical-symbol "SAFE"))
  545.  
  546. (define INTR-CHECKS-sym       (string->canonical-symbol "INTR-CHECKS"))
  547.  
  548. (define FUTURES-sym           (string->canonical-symbol "FUTURES"))
  549. (define OFF-sym               (string->canonical-symbol "OFF"))
  550. (define LAZY-sym              (string->canonical-symbol "LAZY"))
  551. (define EAGER-sym             (string->canonical-symbol "EAGER"))
  552. (define EAGER-INLINE-sym      (string->canonical-symbol "EAGER-INLINE"))
  553.  
  554. (define AUTOTOUCH-sym         (string->canonical-symbol "AUTOTOUCH"))
  555.  
  556. (define-flag-decl IEEE-SCHEME-sym 'dialect)
  557. (define-flag-decl R4RS-SCHEME-sym 'dialect)
  558. (define-flag-decl MULTILISP-sym   'dialect)
  559.  
  560. (define-boolean-decl LAMBDA-LIFT-sym)
  561.  
  562. (define-flag-decl BLOCK-sym    'compilation-strategy)
  563. (define-flag-decl SEPARATE-sym 'compilation-strategy)
  564.  
  565. (define-namable-boolean-decl STANDARD-BINDINGS-sym)
  566. (define-namable-boolean-decl EXTENDED-BINDINGS-sym)
  567.  
  568. (define-boolean-decl SAFE-sym)
  569.  
  570. (define-boolean-decl INTR-CHECKS-sym)
  571.  
  572. (define-parameterized-decl FUTURES-sym)
  573.  
  574. (define-boolean-decl AUTOTOUCH-sym)
  575.  
  576. (define (scheme-dialect decl) ; returns dialect in effect
  577.   (declaration-value 'dialect #f IEEE-SCHEME-sym decl))
  578.  
  579. (define (lambda-lift? decl) ; true iff should lambda-lift
  580.   (declaration-value LAMBDA-LIFT-sym #f #t decl))
  581.  
  582. (define (compilation-strategy decl) ; returns compilation strategy in effect
  583.   (declaration-value 'compilation-strategy #f SEPARATE-sym decl))
  584.  
  585. (define (standard-binding? name decl) ; true iff name's binding is standard
  586.   (declaration-value STANDARD-BINDINGS-sym name #f decl))
  587.  
  588. (define (extended-binding? name decl) ; true iff name's binding is extended
  589.   (declaration-value EXTENDED-BINDINGS-sym name #f decl))
  590.  
  591. (define (add-extended-bindings decl)
  592.   (add-decl (list EXTENDED-BINDINGS-sym #t) decl))
  593.  
  594. (define (intr-checks? decl) ; true iff system should generate interrupt checks
  595.   (declaration-value INTR-CHECKS-sym #f #t decl))
  596.  
  597. (define (futures-method decl) ; returns type of future implementation method
  598.   (declaration-value FUTURES-sym #f LAZY-sym decl))
  599.  
  600. (define (add-delay decl)
  601.   (add-decl (list FUTURES-sym DELAY-sym) decl))
  602.  
  603. (define (autotouch? decl) ; true iff autotouching (default depends on dialect)
  604.   (declaration-value AUTOTOUCH-sym
  605.                      #f
  606.                      (eq? (scheme-dialect decl) MULTILISP-sym)
  607.                      decl))
  608.  
  609. (define (safe? decl) ; true iff system should prevent fatal runtime errors
  610.   (declaration-value SAFE-sym #f #f decl))
  611.  
  612. (define (add-not-safe decl)
  613.   (add-decl (list SAFE-sym #f) decl))
  614.  
  615. ; - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
  616. ;
  617. ; Dialect info:
  618.  
  619. (define (dialect-specific-keywords dialect)
  620.   (cond ((eq? dialect IEEE-SCHEME-sym)
  621.          ieee-scheme-specific-keywords)
  622.         ((eq? dialect R4RS-SCHEME-sym)
  623.          r4rs-scheme-specific-keywords)
  624.         ((eq? dialect MULTILISP-sym)
  625.          multilisp-specific-keywords)
  626.         (else
  627.          (compiler-internal-error
  628.            "dialect-specific-keywords, unknown dialect" dialect))))
  629.  
  630. (define (dialect-specific-procedures dialect)
  631.   (cond ((eq? dialect IEEE-SCHEME-sym)
  632.          ieee-scheme-specific-procedures)
  633.         ((eq? dialect R4RS-SCHEME-sym)
  634.          r4rs-scheme-specific-procedures)
  635.         ((eq? dialect MULTILISP-sym)
  636.          multilisp-specific-procedures)
  637.         (else
  638.          (compiler-internal-error
  639.            "dialect-specific-procedures, unknown dialect" dialect))))
  640.  
  641. (define (make-standard-procedure x)
  642.   (cons (string->canonical-symbol (car x)) (cdr x)))
  643.  
  644. (define (standard-procedure name decl)
  645.   (or (assq name (dialect-specific-procedures (scheme-dialect decl)))
  646.       (assq name common-procedures)))
  647.  
  648. (define (standard-procedure-call-pattern proc)
  649.   (cdr proc))
  650.  
  651. ; IEEE Scheme
  652.  
  653. (define ieee-scheme-specific-keywords
  654.   '())
  655.  
  656. (define ieee-scheme-specific-procedures (map make-standard-procedure '(
  657.  
  658. )))
  659.  
  660. ; R4RS Scheme
  661.  
  662. (define r4rs-scheme-specific-keywords
  663.   (list DELAY-sym))
  664.  
  665. (define r4rs-scheme-specific-procedures (map make-standard-procedure '(
  666.  
  667. ; section 6.3
  668.  
  669. ("LIST-TAIL" 2)
  670.  
  671. ; section 6.5
  672.  
  673. ("-" . 1) ("/" . 1)
  674.  
  675. ; section 6.7
  676.  
  677. ("STRING->LIST" 1) ("LIST->STRING" 1) ("STRING-COPY" 1) ("STRING-FILL!" 2)
  678.  
  679. ; section 6.8
  680.  
  681. ("VECTOR->LIST" 1) ("LIST->VECTOR" 1) ("VECTOR-FILL!" 2)
  682.  
  683. ; section 6.9
  684.  
  685. ("FORCE" 1)
  686.  
  687. ; section 6.10
  688.  
  689. ("WITH-INPUT-FROM-FILE" 2) ("WITH-OUTPUT-TO-FILE" 2) ("CHAR-READY?" 0 1)
  690. ("LOAD" 1) ("TRANSCRIPT-ON" 1) ("TRANSCRIPT-OFF" 0)
  691.  
  692. )))
  693.  
  694. ; Multilisp
  695.  
  696. (define multilisp-specific-keywords
  697.   (list DELAY-sym FUTURE-sym))
  698.  
  699. (define multilisp-specific-procedures (map make-standard-procedure '(
  700.  
  701. ("FORCE" 1)
  702. ("TOUCH" 1)
  703.  
  704. )))
  705.  
  706. ; common stuff
  707.  
  708. (define common-keywords
  709.   (list QUOTE-sym QUASIQUOTE-sym UNQUOTE-sym UNQUOTE-SPLICING-sym
  710.         LAMBDA-sym IF-sym SET!-sym COND-sym =>-sym ELSE-sym AND-sym OR-sym
  711.         CASE-sym LET-sym LET*-sym LETREC-sym BEGIN-sym DO-sym DEFINE-sym
  712.         **DEFINE-MACRO-sym **DECLARE-sym **INCLUDE-sym))
  713.  
  714. (define common-procedures (map make-standard-procedure '(
  715.  
  716. ; taken from IEEE Scheme standard draft P1178/D4
  717.  
  718. ; section 6.1
  719.  
  720. ("NOT" 1) ("BOOLEAN?" 1)
  721.  
  722. ; section 6.2
  723.  
  724. ("EQV?" 2) ("EQ?" 2) ("EQUAL?" 2)
  725.  
  726. ; section 6.3
  727.  
  728. ("PAIR?" 1) ("CONS" 2) ("CAR" 1) ("CDR" 1) ("SET-CAR!" 2) ("SET-CDR!" 2)
  729. ("CAAR" 1) ("CADR" 1) ("CDAR" 1) ("CDDR" 1) ("CAAAR" 1) ("CAADR" 1)
  730. ("CADAR" 1) ("CADDR" 1) ("CDAAR" 1) ("CDADR" 1) ("CDDAR" 1) ("CDDDR" 1)
  731. ("CAAAAR" 1) ("CAAADR" 1) ("CAADAR" 1) ("CAADDR" 1) ("CADAAR" 1)
  732. ("CADADR" 1) ("CADDAR" 1) ("CADDDR" 1) ("CDAAAR" 1) ("CDAADR" 1)
  733. ("CDADAR" 1) ("CDADDR" 1) ("CDDAAR" 1) ("CDDADR" 1) ("CDDDAR" 1)
  734. ("CDDDDR" 1) ("NULL?" 1) ("LIST?" 1) ("LIST" . 0) ("LENGTH" 1)
  735. ("APPEND" . 0) ("REVERSE" 1) ("LIST-REF" 2) ("MEMQ" 2) ("MEMV" 2)
  736. ("MEMBER" 2) ("ASSQ" 2) ("ASSV" 2) ("ASSOC" 2)
  737.  
  738. ; section 6.4
  739.  
  740. ("SYMBOL?" 1) ("SYMBOL->STRING" 1) ("STRING->SYMBOL" 1)
  741.  
  742. ; section 6.5
  743.  
  744. ("NUMBER?" 1) ("COMPLEX?" 1) ("REAL?" 1) ("RATIONAL?" 1) ("INTEGER?" 1)
  745. ("EXACT?" 1) ("INEXACT?" 1) ("=" . 2) ("<" . 2) (">" . 2) ("<=" . 2)
  746. (">=" . 2) ("ZERO?" 1) ("POSITIVE?" 1) ("NEGATIVE?" 1) ("ODD?" 1) ("EVEN?" 1)
  747. ("MAX" . 1) ("MIN" . 1) ("+" . 0) ("*" . 0) ("-" 1 2) ("/" 1 2) ("ABS" 1)
  748. ("QUOTIENT" 2) ("REMAINDER" 2) ("MODULO" 2) ("GCD" . 0) ("LCM" . 0)
  749. ("NUMERATOR" 1) ("DENOMINATOR" 1) ("FLOOR" 1) ("CEILING" 1)
  750. ("TRUNCATE" 1) ("ROUND" 1) ("RATIONALIZE" 2) ("EXP" 1) ("LOG" 1)
  751. ("SIN" 1) ("COS" 1) ("TAN" 1) ("ASIN" 1) ("ACOS" 1) ("ATAN" 1 2) ("SQRT" 1)
  752. ("EXPT" 2) ("MAKE-RECTANGULAR" 2) ("MAKE-POLAR" 2) ("REAL-PART" 1)
  753. ("IMAG-PART" 1) ("MAGNITUDE" 1) ("ANGLE" 1) ("EXACT->INEXACT" 1)
  754. ("INEXACT->EXACT" 1) ("NUMBER->STRING" 1 2) ("STRING->NUMBER" 1 2)
  755.  
  756. ; section 6.6
  757.  
  758. ("CHAR?" 1) ("CHAR=?" 2) ("CHAR<?" 2) ("CHAR>?" 2) ("CHAR<=?" 2)
  759. ("CHAR>=?" 2) ("CHAR-CI=?" 2) ("CHAR-CI<?" 2) ("CHAR-CI>?" 2)
  760. ("CHAR-CI<=?" 2) ("CHAR-CI>=?" 2) ("CHAR-ALPHABETIC?" 1)
  761. ("CHAR-NUMERIC?" 1) ("CHAR-WHITESPACE?" 1) ("CHAR-UPPER-CASE?" 1)
  762. ("CHAR-LOWER-CASE?" 1) ("CHAR->INTEGER" 1) ("INTEGER->CHAR" 1)
  763. ("CHAR-UPCASE" 1) ("CHAR-DOWNCASE" 1)
  764.  
  765. ; section 6.7
  766.  
  767. ("STRING?" 1) ("MAKE-STRING" 1 2) ("STRING" . 0) ("STRING-LENGTH" 1)
  768. ("STRING-REF" 2) ("STRING-SET!" 3) ("STRING=?" 2) ("STRING<?" 2)
  769. ("STRING>?" 2) ("STRING<=?" 2) ("STRING>=?" 2) ("STRING-CI=?" 2)
  770. ("STRING-CI<?" 2) ("STRING-CI>?" 2) ("STRING-CI<=?" 2) ("STRING-CI>=?" 2)
  771. ("SUBSTRING" 3) ("STRING-APPEND" . 0)
  772.  
  773. ; section 6.8
  774.  
  775. ("VECTOR?" 1) ("MAKE-VECTOR" 1 2) ("VECTOR" . 0) ("VECTOR-LENGTH" 1)
  776. ("VECTOR-REF" 2) ("VECTOR-SET!" 3)
  777.  
  778. ; section 6.9
  779.  
  780. ("PROCEDURE?" 1) ("APPLY" . 2) ("MAP" . 2) ("FOR-EACH" . 2)
  781. ("CALL-WITH-CURRENT-CONTINUATION" 1)
  782.  
  783. ; section 6.10
  784.  
  785. ("CALL-WITH-INPUT-FILE" 2) ("CALL-WITH-OUTPUT-FILE" 2) ("INPUT-PORT?" 1)
  786. ("OUTPUT-PORT?" 1) ("CURRENT-INPUT-PORT" 0) ("CURRENT-OUTPUT-PORT" 0)
  787. ("OPEN-INPUT-FILE" 1) ("OPEN-OUTPUT-FILE" 1) ("CLOSE-INPUT-PORT" 1)
  788. ("CLOSE-OUTPUT-PORT" 1) ("EOF-OBJECT?" 1) ("READ" 0 1) ("READ-CHAR" 0 1)
  789. ("PEEK-CHAR" 0 1) ("WRITE" 1 2) ("DISPLAY" 1 2) ("NEWLINE" 0 1)
  790. ("WRITE-CHAR" 1 2)
  791.  
  792. )))
  793.  
  794. ; - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
  795. ;
  796. ; (parse-program program env proc) returns a list of parse trees/environment
  797. ; pairs describing the program and the final global environment.
  798.  
  799. (define (parse-program program env proc)
  800.  
  801.   (if *ptree-port*
  802.     (begin
  803.       (display "Parsing:" *ptree-port*)
  804.       (newline *ptree-port*)))
  805.  
  806.   (parse-prog program env '()
  807.     (lambda (lst env)
  808.  
  809.       (if *ptree-port*
  810.         (newline *ptree-port*))
  811.  
  812.       (proc lst env))))
  813.  
  814. (define (parse-prog program env lst proc)
  815.   (if (null? program)
  816.     (proc (reverse lst) env)
  817.     (let ((source (car program)))
  818.  
  819.       (cond ((macro-expr? source env)
  820.              (parse-prog
  821.                (cons (macro-expand source env) (cdr program))
  822.                env
  823.                lst
  824.                proc))
  825.  
  826.             ((begin-defs-expr? source)
  827.              (parse-prog
  828.                (append (begin-defs-body source) (cdr program))
  829.                env
  830.                lst
  831.                proc))
  832.  
  833.             ((include-expr? source)
  834.  
  835.              (if *ptree-port*
  836.                (display "  " *ptree-port*))
  837.  
  838.              (let ((x (file->sources* (include-filename source)
  839.                                       *ptree-port*
  840.                                       (source-locat source))))
  841.  
  842.                (if *ptree-port*
  843.                  (newline *ptree-port*))
  844.                       
  845.                (parse-prog
  846.                  (append x (cdr program))
  847.                  env
  848.                  lst
  849.                  proc)))
  850.  
  851.             ((define-macro-expr? source env)
  852.  
  853.              (if *ptree-port*
  854.                (begin
  855.                  (display "  \"macro\"" *ptree-port*)
  856.                  (newline *ptree-port*)))
  857.  
  858.              (parse-prog
  859.                (cdr program)
  860.                (add-macro source env)
  861.                lst
  862.                proc))
  863.  
  864.             ((declare-expr? source)
  865.  
  866.              (if *ptree-port*
  867.                (begin
  868.                  (display "  \"decl\"" *ptree-port*)
  869.                  (newline *ptree-port*)))
  870.  
  871.              (parse-prog
  872.                (cdr program)
  873.                (add-declarations source env)
  874.                lst
  875.                proc))
  876.  
  877.             ((define-expr? source env)
  878.              (let* ((var** (definition-variable source))
  879.                     (var* (source-code var**))
  880.                     (var (env-lookup-var env var* var**)))
  881.  
  882.                (if *ptree-port*
  883.                  (begin
  884.                    (display "  " *ptree-port*)
  885.                    (display (var-name var) *ptree-port*)
  886.                    (newline *ptree-port*)))
  887.  
  888.                (let ((node (pt (definition-value source) env 'TRUE)))
  889.                  (set-prc-names! (list var) (list node))
  890.                  (parse-prog
  891.                    (cdr program)
  892.                    env
  893.                    (cons (cons (new-def source (env-declarations env) var node) env) lst)
  894.                    proc))))
  895.  
  896.             (else
  897.  
  898.              (if *ptree-port*
  899.                (begin
  900.                  (display "  \"expr\"" *ptree-port*)
  901.                  (newline *ptree-port*)))
  902.  
  903.              (parse-prog
  904.                (cdr program)
  905.                env
  906.                (cons (cons (pt source env 'TRUE) env) lst)
  907.                proc))))))
  908.  
  909. ; - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
  910. ;
  911. ; (pt source env use) returns the parse tree for the Scheme source expression
  912. ; 'source' in the environment 'env'.  If 'source' is not syntactically
  913. ; correct, an error is signaled.  The value of 'use' determines what the
  914. ; expression's value will be used for; it must be one of the following:
  915. ;
  916. ;  TRUE  : the true value of the expression is needed
  917. ;  PRED  : the value is used as a predicate
  918. ;  NONE  : the value is not needed (but its side effect might)
  919.  
  920. (define (pt-syntax-error source msg . args)
  921.   (apply compiler-user-error
  922.          (cons (source-locat source)
  923.                (cons (string-append "Syntax error -- " msg)
  924.                      args))))
  925.  
  926. (define (pt source env use)
  927.   (cond ((macro-expr? source env)        (pt (macro-expand source env) env use))
  928.         ((self-eval-expr? source)        (pt-self-eval source env use))
  929.         ((quote-expr? source)            (pt-quote source env use))
  930.         ((quasiquote-expr? source)       (pt-quasiquote source env use))
  931.         ((unquote-expr? source)
  932.          (pt-syntax-error source "Ill-placed 'unquote'"))
  933.         ((unquote-splicing-expr? source)
  934.          (pt-syntax-error source "Ill-placed 'unquote-splicing'"))
  935.         ((var-expr? source env)          (pt-var source env use))
  936.         ((set!-expr? source env)         (pt-set! source env use))
  937.         ((lambda-expr? source env)       (pt-lambda source env use))
  938.         ((if-expr? source)               (pt-if source env use))
  939.         ((cond-expr? source)             (pt-cond source env use))
  940.         ((and-expr? source)              (pt-and source env use))
  941.         ((or-expr? source)               (pt-or source env use))
  942.         ((case-expr? source)             (pt-case source env use))
  943.         ((let-expr? source env)          (pt-let source env use))
  944.         ((let*-expr? source env)         (pt-let* source env use))
  945.         ((letrec-expr? source env)       (pt-letrec source env use))
  946.         ((begin-expr? source)            (pt-begin source env use))
  947.         ((do-expr? source env)           (pt-do source env use))
  948.         ((define-expr? source env)
  949.          (pt-syntax-error source "Ill-placed 'define'"))
  950.         ((delay-expr? source env)        (pt-delay source env use))
  951.         ((future-expr? source env)       (pt-future source env use))
  952.         ((define-macro-expr? source env)
  953.          (pt-syntax-error source "Ill-placed '##define-macro'"))
  954.         ((begin-defs-expr? source)
  955.          (pt-syntax-error source "Ill-placed 'begin' style definitions"))
  956.         ((declare-expr? source)
  957.          (pt-syntax-error source "Ill-placed '##declare'"))
  958.         ((combination-expr? source)      (pt-combination source env use))
  959.         (else
  960.          (compiler-internal-error "pt, unknown expression type" source))))
  961.  
  962. (define (macro-expand source env)
  963.   (let ((code (source-code source)))
  964.     (expression->source
  965.       (apply (cdr (env-lookup-macro env (source-code (car code))))
  966.              (cdr (source->expression source)))
  967.       source)))
  968.  
  969. (define (pt-self-eval source env use)
  970.   (let ((val (source->expression source)))
  971.     (if (eq? use 'NONE)
  972.       (new-cst source (env-declarations env) undef-object)
  973.       (new-cst source (env-declarations env) val))))
  974.  
  975. (define (pt-quote source env use)
  976.   (let ((code (source-code source)))
  977.     (if (eq? use 'NONE)
  978.       (new-cst source (env-declarations env) undef-object)
  979.       (new-cst source (env-declarations env) (source->expression (cadr code))))))
  980.  
  981. (define (pt-quasiquote source env use)
  982.   (let ((code (source-code source)))
  983.     (pt-quasiquotation (cadr code) 1 env)))
  984.  
  985. (define (pt-quasiquotation form level env)
  986.   (cond ((= level 0)
  987.          (pt form env 'TRUE))
  988.         ((quasiquote-expr? form)
  989.          (pt-quasiquotation-list form (source-code form) (+ level 1) env))
  990.         ((unquote-expr? form)
  991.          (if (= level 1)
  992.            (pt (cadr (source-code form)) env 'TRUE)
  993.            (pt-quasiquotation-list form (source-code form) (- level 1) env)))
  994.         ((unquote-splicing-expr? form)
  995.          (if (= level 1)
  996.            (pt-syntax-error form "Ill-placed 'unquote-splicing'")
  997.            (pt-quasiquotation-list form (source-code form) (- level 1) env)))
  998.         ((pair? (source-code form))
  999.          (pt-quasiquotation-list form (source-code form) level env))
  1000.         ((vector? (source-code form))
  1001.          (vector-form
  1002.            form
  1003.            (pt-quasiquotation-list form (vector->lst (source-code form)) level env)
  1004.            env))
  1005.         (else
  1006.          (new-cst form (env-declarations env) (source->expression form)))))
  1007.  
  1008. (define (pt-quasiquotation-list form l level env)
  1009.   (cond ((pair? l)
  1010.          (if (and (unquote-splicing-expr? (car l)) (= level 1))
  1011.            (let ((x (pt (cadr (source-code (car l))) env 'TRUE)))
  1012.              (if (null? (cdr l))
  1013.                x
  1014.                (append-form (car l) x (pt-quasiquotation-list form (cdr l) 1 env) env)))
  1015.            (cons-form form
  1016.                       (pt-quasiquotation (car l) level env)
  1017.                       (pt-quasiquotation-list form (cdr l) level env)
  1018.                       env)))
  1019.         ((null? l)
  1020.          (new-cst form (env-declarations env) '()))
  1021.         (else
  1022.          (pt-quasiquotation l level env))))
  1023.  
  1024. (define (append-form source ptree1 ptree2 env)
  1025.   (cond ((and (cst? ptree1) (cst? ptree2))
  1026.          (new-cst source (env-declarations env)
  1027.            (append (cst-val ptree1) (cst-val ptree2))))
  1028.         ((and (cst? ptree2) (null? (cst-val ptree2)))
  1029.          ptree1)
  1030.         (else
  1031.          (new-call* source (add-not-safe (env-declarations env))
  1032.            (new-ref-extended-bindings source **QUASI-APPEND-sym env)
  1033.            (list ptree1 ptree2)))))
  1034.  
  1035. (define (cons-form source ptree1 ptree2 env)
  1036.   (cond ((and (cst? ptree1) (cst? ptree2))
  1037.          (new-cst source (env-declarations env)
  1038.            (cons (cst-val ptree1) (cst-val ptree2))))
  1039.         ((and (cst? ptree2) (null? (cst-val ptree2)))
  1040.          (new-call* source (add-not-safe (env-declarations env))
  1041.            (new-ref-extended-bindings source **QUASI-LIST-sym env)
  1042.            (list ptree1)))
  1043.         (else
  1044.          (new-call* source (add-not-safe (env-declarations env))
  1045.            (new-ref-extended-bindings source **QUASI-CONS-sym env)
  1046.            (list ptree1 ptree2)))))
  1047.  
  1048. (define (vector-form source ptree env)
  1049.   (if (cst? ptree)
  1050.     (new-cst source (env-declarations env)
  1051.       (lst->vector (cst-val ptree)))
  1052.     (new-call* source (add-not-safe (env-declarations env))
  1053.       (new-ref-extended-bindings source **QUASI-LIST->VECTOR-sym env)
  1054.       (list ptree))))
  1055.  
  1056. (define (pt-var source env use)
  1057.   (if (eq? use 'NONE)
  1058.     (new-cst source (env-declarations env) undef-object)
  1059.     (new-ref source (env-declarations env)
  1060.       (env-lookup-var env (source-code source) source))))
  1061.  
  1062. (define (pt-set! source env use)
  1063.   (let ((code (source-code source)))
  1064.     (new-set source (env-declarations env)
  1065.       (env-lookup-var env (source-code (cadr code)) (cadr code))
  1066.       (pt (caddr code) env 'TRUE))))
  1067.  
  1068. (define (pt-lambda source env use)
  1069.   (let ((code (source-code source)))
  1070.  
  1071.     (define (new-params parms)
  1072.       (cond ((pair? parms)
  1073.              (let* ((parm* (car parms))
  1074.                     (parm (source-code parm*))
  1075.                     (p* (if (pair? parm) (car parm) parm*)))
  1076.                (cons (make-var (source-code p*) #t (set-empty) (set-empty) p*)
  1077.                      (new-params (cdr parms)))))
  1078.             ((null? parms)
  1079.              '())
  1080.             (else
  1081.              (list (make-var (source-code parms) #t (set-empty) (set-empty) parms)))))
  1082.  
  1083.     (define (min-params parms)
  1084.       (let loop ((l parms) (n 0))
  1085.         (if (pair? l)
  1086.           (if (pair? (source-code (car l)))
  1087.             n
  1088.             (loop (cdr l) (+ n 1)))
  1089.           n)))
  1090.  
  1091.     (define (rest-param? parms)
  1092.       (if (pair? parms)
  1093.         (rest-param? (cdr parms))
  1094.         (not (null? parms))))
  1095.  
  1096.     (define (optionals parms source body env)
  1097.       (if (pair? parms)
  1098.         (let* ((parm* (car parms))
  1099.                (parm (source-code parm*)))
  1100.           (if (and (pair? parm) (length? parm 2))
  1101.             (let* ((var (car parm))
  1102.                    (vars (new-variables (list var)))
  1103.                    (decl (env-declarations env)))
  1104.               (new-call* parm* decl
  1105.                 (new-prc parm* decl
  1106.                   #f
  1107.                   1
  1108.                   #f
  1109.                   vars
  1110.                   (optionals (cdr parms) source body (env-frame env vars)))
  1111.                 (list (new-tst parm* decl
  1112.                         (new-call* parm* decl
  1113.                           (new-ref-extended-bindings parm* **UNASSIGNED?-sym env)
  1114.                           (list (new-ref parm* decl
  1115.                                   (env-lookup-var env (source-code var) var))))
  1116.                         (pt (cadr parm) env 'TRUE)
  1117.                         (new-ref parm* decl
  1118.                           (env-lookup-var env (source-code var) var))))))
  1119.             (optionals (cdr parms) source body env)))
  1120.         (pt-body source body env 'TRUE)))
  1121.  
  1122.     (if (eq? use 'NONE)
  1123.       (new-cst source (env-declarations env) undef-object)
  1124.       (let* ((parms (source->parms (cadr code)))
  1125.              (frame (new-params parms)))
  1126.         (new-prc source (env-declarations env)
  1127.           #f
  1128.           (min-params parms)
  1129.           (rest-param? parms)
  1130.           frame
  1131.           (optionals parms 
  1132.                      source
  1133.                      (cddr code)
  1134.                      (env-frame env frame)))))))
  1135.  
  1136. (define (source->parms source)
  1137.   (let ((x (source-code source)))
  1138.     (if (or (pair? x) (null? x)) x source)))
  1139.  
  1140. (define (pt-body source body env use)
  1141.  
  1142.   (define (letrec-defines vars vals envs body env)
  1143.     (cond ((null? body)
  1144.            (pt-syntax-error
  1145.              source
  1146.              "Body must contain at least one evaluable expression"))
  1147.           ((macro-expr? (car body) env)
  1148.            (letrec-defines vars
  1149.                            vals
  1150.                            envs
  1151.                            (cons (macro-expand (car body) env)
  1152.                                  (cdr body))
  1153.                            env))
  1154.           ((begin-defs-expr? (car body))
  1155.            (letrec-defines vars
  1156.                            vals
  1157.                            envs
  1158.                            (append (begin-defs-body (car body))
  1159.                                    (cdr body))
  1160.                            env))
  1161.           ((include-expr? (car body))
  1162.            (if *ptree-port*
  1163.              (display "  " *ptree-port*))
  1164.            (let ((x (file->sources* (include-filename (car body))
  1165.                                     *ptree-port*
  1166.                                     (source-locat (car body)))))
  1167.              (if *ptree-port*
  1168.                (newline *ptree-port*))
  1169.              (letrec-defines vars
  1170.                              vals
  1171.                              envs
  1172.                              (append x (cdr body))
  1173.                              env)))
  1174.           ((define-expr? (car body) env)
  1175.            (let* ((var** (definition-variable (car body)))
  1176.                   (var* (source-code var**))
  1177.                   (var (env-define-var env var* var**)))
  1178.              (letrec-defines (cons var vars)
  1179.                              (cons (definition-value (car body)) vals)
  1180.                              (cons env envs)
  1181.                              (cdr body)
  1182.                              env)))
  1183.           ((declare-expr? (car body))
  1184.            (letrec-defines vars
  1185.                            vals
  1186.                            envs
  1187.                            (cdr body)
  1188.                            (add-declarations (car body) env)))
  1189.           ((define-macro-expr? (car body) env)
  1190.            (letrec-defines vars
  1191.                            vals
  1192.                            envs
  1193.                            (cdr body)
  1194.                            (add-macro (car body) env)))
  1195.           ((null? vars)
  1196.            (pt-sequence source body env use))
  1197.           (else
  1198.            (let ((vars* (reverse vars)))
  1199.              (let loop ((vals* '()) (l1 vals) (l2 envs))
  1200.                (if (not (null? l1))
  1201.                  (loop (cons (pt (car l1) (car l2) 'TRUE) vals*)
  1202.                        (cdr l1)
  1203.                        (cdr l2))
  1204.                  (pt-recursive-let source vars* vals* body env use)))))))
  1205.  
  1206.   (letrec-defines '() '() '() body (env-frame env '())))
  1207.  
  1208. (define (pt-sequence source seq env use)
  1209.   (if (length? seq 1)
  1210.     (pt (car seq) env use)
  1211.     (new-seq source (env-declarations env)
  1212.       (pt (car seq) env 'NONE)
  1213.       (pt-sequence source (cdr seq) env use))))
  1214.  
  1215. (define (pt-if source env use)
  1216.   (let ((code (source-code source)))
  1217.     (new-tst source (env-declarations env)
  1218.       (pt (cadr code) env 'PRED)
  1219.       (pt (caddr code) env use)
  1220.       (if (length? code 3)
  1221.         (new-cst source (env-declarations env) undef-object)
  1222.         (pt (cadddr code) env use)))))
  1223.  
  1224. (define (pt-cond source env use)
  1225.  
  1226.   (define (pt-clauses clauses)
  1227.     (if (length? clauses 0)
  1228.       (new-cst source (env-declarations env) undef-object)
  1229.       (let* ((clause* (car clauses))
  1230.              (clause (source-code clause*)))
  1231.         (cond ((eq? (source-code (car clause)) ELSE-sym)
  1232.                (pt-sequence clause* (cdr clause) env use))
  1233.               ((length? clause 1)
  1234.                (new-disj clause* (env-declarations env)
  1235.                  (pt (car clause) env (if (eq? use 'TRUE) 'TRUE 'PRED))
  1236.                  (pt-clauses (cdr clauses))))
  1237.               ((eq? (source-code (cadr clause)) =>-sym)
  1238.                (new-disj-call clause* (env-declarations env)
  1239.                  (pt (car clause) env 'TRUE)
  1240.                  (pt (caddr clause) env 'TRUE)
  1241.                  (pt-clauses (cdr clauses))))
  1242.               (else
  1243.                (new-tst clause* (env-declarations env)
  1244.                  (pt (car clause) env 'PRED)
  1245.                  (pt-sequence clause* (cdr clause) env use)
  1246.                  (pt-clauses (cdr clauses))))))))
  1247.  
  1248.   (pt-clauses (cdr (source-code source))))
  1249.  
  1250. (define (pt-and source env use)
  1251.  
  1252.   (define (pt-exprs exprs)
  1253.     (cond ((length? exprs 0)
  1254.            (new-cst source (env-declarations env) #t))
  1255.           ((length? exprs 1)
  1256.            (pt (car exprs) env use))
  1257.           (else
  1258.            (new-conj (car exprs) (env-declarations env)
  1259.              (pt (car exprs) env (if (eq? use 'TRUE) 'TRUE 'PRED))
  1260.              (pt-exprs (cdr exprs))))))
  1261.  
  1262.   (pt-exprs (cdr (source-code source))))
  1263.  
  1264. (define (pt-or source env use)
  1265.  
  1266.   (define (pt-exprs exprs)
  1267.     (cond ((length? exprs 0)
  1268.            (new-cst source (env-declarations env) false-object))
  1269.           ((length? exprs 1)
  1270.            (pt (car exprs) env use))
  1271.           (else
  1272.            (new-disj (car exprs) (env-declarations env)
  1273.              (pt (car exprs) env (if (eq? use 'TRUE) 'TRUE 'PRED))
  1274.              (pt-exprs (cdr exprs))))))
  1275.  
  1276.   (pt-exprs (cdr (source-code source))))
  1277.  
  1278. (define (pt-case source env use)
  1279.   (let ((code (source-code source))
  1280.         (temp (new-temps source '(temp))))
  1281.  
  1282.     (define (pt-clauses clauses)
  1283.       (if (length? clauses 0)
  1284.         (new-cst source (env-declarations env) undef-object)
  1285.         (let* ((clause* (car clauses))
  1286.                (clause (source-code clause*)))
  1287.           (if (eq? (source-code (car clause)) ELSE-sym)
  1288.             (pt-sequence clause* (cdr clause) env use)
  1289.             (new-tst clause* (env-declarations env)
  1290.               (new-call* clause* (add-not-safe (env-declarations env))
  1291.                 (new-ref-extended-bindings clause* **CASE-MEMV-sym env)
  1292.                 (list (new-ref clause* (env-declarations env)
  1293.                         (car temp))
  1294.                       (new-cst (car clause) (env-declarations env)
  1295.                         (source->expression (car clause)))))
  1296.               (pt-sequence clause* (cdr clause) env use)
  1297.               (pt-clauses (cdr clauses)))))))
  1298.  
  1299.     (new-call* source (env-declarations env)
  1300.       (new-prc source (env-declarations env) #f 1 #f temp
  1301.         (pt-clauses (cddr code)))
  1302.       (list (pt (cadr code) env 'TRUE)))))
  1303.  
  1304. (define (pt-let source env use)
  1305.   (let ((code (source-code source)))
  1306.     (if (bindable-var? (cadr code) env)
  1307.       (let* ((self (new-variables (list (cadr code))))
  1308.              (bindings (map source-code (source-code (caddr code))))
  1309.              (vars (new-variables (map car bindings)))
  1310.              (vals (map (lambda (x) (pt (cadr x) env 'TRUE)) bindings))
  1311.              (env  (env-frame (env-frame env vars) self))
  1312.              (self-proc (list (new-prc source (env-declarations env)
  1313.                                 #f
  1314.                                 (length vars)
  1315.                                 #f
  1316.                                 vars
  1317.                                 (pt-body source (cdddr code) env use)))))
  1318.         (set-prc-names! self self-proc)
  1319.         (set-prc-names! vars vals)
  1320.         (new-call* source (env-declarations env)
  1321.           (new-prc source (env-declarations env) #f 1 #f self
  1322.             (new-call* source (env-declarations env)
  1323.               (new-ref source (env-declarations env) (car self))
  1324.               vals))
  1325.           self-proc))
  1326.       (if (null? (source-code (cadr code)))
  1327.         (pt-body source (cddr code) env use)
  1328.         (let* ((bindings (map source-code (source-code (cadr code))))
  1329.                (vars (new-variables (map car bindings)))
  1330.                (vals (map (lambda (x) (pt (cadr x) env 'TRUE)) bindings))
  1331.                (env  (env-frame env vars)))
  1332.           (set-prc-names! vars vals)
  1333.           (new-call* source (env-declarations env)
  1334.             (new-prc source (env-declarations env)
  1335.               #f
  1336.               (length vars)
  1337.               #f
  1338.               vars
  1339.               (pt-body source (cddr code) env use))
  1340.             vals))))))
  1341.  
  1342. (define (pt-let* source env use)
  1343.   (let ((code (source-code source)))
  1344.  
  1345.     (define (pt-bindings bindings env use)
  1346.       (if (null? bindings)
  1347.         (pt-body source (cddr code) env use)
  1348.         (let* ((binding* (car bindings))
  1349.                (binding (source-code binding*))
  1350.                (vars (new-variables (list (car binding))))
  1351.                (vals (list (pt (cadr binding) env 'TRUE)))
  1352.                (env  (env-frame env vars)))
  1353.           (set-prc-names! vars vals)
  1354.           (new-call* binding* (env-declarations env)
  1355.             (new-prc binding* (env-declarations env) #f 1 #f vars
  1356.               (pt-bindings (cdr bindings) env use))
  1357.             vals))))
  1358.  
  1359.     (pt-bindings (source-code (cadr code)) env use)))
  1360.  
  1361. (define (pt-letrec source env use)
  1362.   (let* ((code (source-code source))
  1363.          (bindings (map source-code (source-code (cadr code))))
  1364.          (vars* (new-variables (map car bindings)))
  1365.          (env*  (env-frame env vars*)))
  1366.     (pt-recursive-let
  1367.       source
  1368.       vars*
  1369.       (map (lambda (x) (pt (cadr x) env* 'TRUE)) bindings)
  1370.       (cddr code)
  1371.       env*
  1372.       use)))
  1373.  
  1374. (define (pt-recursive-let source vars vals body env use)
  1375.  
  1376.   (define (val-of var)
  1377.     (list-ref vals (- (length vars) (length (memq var vars)))))
  1378.  
  1379.   (define (bind-in-order order)
  1380.     (if (null? order)
  1381.       (pt-body source body env use)
  1382.  
  1383.       ; get vars to be bound and vars to be assigned
  1384.  
  1385.       (let* ((vars-set (car order))
  1386.              (vars (set->list vars-set)))
  1387.         (let loop1 ((l (reverse vars)) (vars-b '()) (vals-b '()) (vars-a '()))
  1388.           (if (not (null? l))
  1389.             (let* ((var (car l))
  1390.                    (val (val-of var)))
  1391.               (if (or (prc? val)
  1392.                       (set-empty?
  1393.                         (set-intersection (free-variables val) vars-set)))
  1394.                 (loop1 (cdr l)
  1395.                        (cons var vars-b)
  1396.                        (cons val vals-b)
  1397.                        vars-a)
  1398.                 (loop1 (cdr l)
  1399.                        vars-b
  1400.                        vals-b
  1401.                        (cons var vars-a))))
  1402.  
  1403.             (let* ((result1
  1404.                      (let loop2 ((l vars-a))
  1405.                        (if (not (null? l))
  1406.  
  1407.                          (let* ((var (car l))
  1408.                                 (val (val-of var)))
  1409.                            (new-seq source (env-declarations env)
  1410.                              (new-set source (env-declarations env) var val)
  1411.                              (loop2 (cdr l))))
  1412.  
  1413.                          (bind-in-order (cdr order)))))
  1414.  
  1415.                    (result2
  1416.                      (if (null? vars-b)
  1417.                        result1
  1418.                        (new-call* source (env-declarations env)
  1419.                          (new-prc source (env-declarations env) #f (length vars-b) #f vars-b
  1420.                            result1)
  1421.                          vals-b)))
  1422.  
  1423.                    (result3
  1424.                      (if (null? vars-a)
  1425.                        result2
  1426.                        (new-call* source (env-declarations env)
  1427.                          (new-prc source (env-declarations env) #f (length vars-a) #f vars-a
  1428.                            result2)
  1429.                          (map (lambda (var)
  1430.                                 (new-cst source (env-declarations env) undef-object))
  1431.                               vars-a)))))
  1432.  
  1433.           result3))))))
  1434.  
  1435.   (set-prc-names! vars vals)
  1436.  
  1437.   (bind-in-order
  1438.     (topological-sort
  1439.       (transitive-closure
  1440.         (dependency-graph vars vals)))))
  1441.  
  1442. (define (pt-begin source env use)
  1443.   (pt-sequence source (cdr (source-code source)) env use))
  1444.  
  1445. (define (pt-do source env use)
  1446.   (let* ((code (source-code source))
  1447.          (loop (new-temps source '(loop)))
  1448.          (bindings (map source-code (source-code (cadr code))))
  1449.          (vars (new-variables (map car bindings)))
  1450.          (init (map (lambda (x) (pt (cadr x) env 'TRUE)) bindings))
  1451.          (env  (env-frame env vars))
  1452.          (step (map (lambda (x)
  1453.                       (pt (if (length? x 2) (car x) (caddr x)) env 'TRUE))
  1454.                     bindings))
  1455.          (exit (source-code (caddr code))))
  1456.     (set-prc-names! vars init)
  1457.     (new-call* source (env-declarations env)
  1458.       (new-prc source (env-declarations env) #f 1 #f loop
  1459.         (new-call* source (env-declarations env)
  1460.           (new-ref source (env-declarations env) (car loop)) init))
  1461.       (list
  1462.         (new-prc source (env-declarations env) #f (length vars) #f vars
  1463.           (new-tst source (env-declarations env)
  1464.             (pt (car exit) env 'PRED)
  1465.             (if (length? exit 1)
  1466.               (new-cst (caddr code) (env-declarations env) undef-object)
  1467.               (pt-sequence (caddr code) (cdr exit) env use))
  1468.             (if (length? code 3)
  1469.               (new-call* source (env-declarations env)
  1470.                 (new-ref source (env-declarations env) (car loop))
  1471.                 step)
  1472.               (new-seq source (env-declarations env)
  1473.                 (pt-sequence source (cdddr code) env 'NONE)
  1474.                 (new-call* source (env-declarations env)
  1475.                   (new-ref source (env-declarations env)
  1476.                     (car loop))
  1477.                   step)))))))))
  1478.  
  1479. (define (pt-combination source env use)
  1480.   (let* ((code (source-code source))
  1481.          (oper (pt (car code) env 'TRUE))
  1482.          (decl (node-decl oper)))
  1483.     (new-call* source (env-declarations env)
  1484.       oper
  1485.       (map (lambda (x) (pt x env 'TRUE)) (cdr code)))))
  1486.  
  1487. (define (pt-delay source env use)
  1488.   (let ((code (source-code source)))
  1489.     (new-fut source (add-delay (env-declarations env))
  1490.       (pt (cadr code) env 'TRUE))))
  1491.  
  1492. (define (pt-future source env use)
  1493.   (let ((decl (env-declarations env))
  1494.         (code (source-code source)))
  1495.     (if (eq? (futures-method decl) OFF-sym)
  1496.       (pt (cadr code) env 'TRUE)
  1497.       (new-fut source decl
  1498.         (pt (cadr code) env 'TRUE)))))
  1499.  
  1500. ; Expression identification predicates and syntax checking.
  1501.  
  1502. (define (self-eval-expr? source)
  1503.   (let ((code (source-code source)))
  1504.     (and (not (pair? code)) (not (symbol-object? code)))))
  1505.  
  1506. (define (quote-expr? source)
  1507.   (match QUOTE-sym 1 source))
  1508.  
  1509. (define (quasiquote-expr? source)
  1510.   (match QUASIQUOTE-sym 1 source))
  1511.  
  1512. (define (unquote-expr? source)
  1513.   (match UNQUOTE-sym 1 source))
  1514.  
  1515. (define (unquote-splicing-expr? source)
  1516.   (match UNQUOTE-SPLICING-sym 1 source))
  1517.  
  1518. (define (var-expr? source env)
  1519.   (let ((code (source-code source)))
  1520.     (and (symbol-object? code)
  1521.          (not-keyword source env code)
  1522.          (not-macro source env code))))
  1523.  
  1524. (define (not-macro source env name)
  1525.   (if (env-lookup-macro env name)
  1526.     (pt-syntax-error source "Macro name can't be used as a variable:" name)
  1527.     #t))
  1528.  
  1529. (define (bindable-var? source env)
  1530.   (let ((code (source-code source)))
  1531.     (and (symbol-object? code)
  1532.          (not-keyword source env code))))
  1533.  
  1534. (define (not-keyword source env name)
  1535.   (if (or (memq name common-keywords)
  1536.           (memq name (dialect-specific-keywords
  1537.                        (scheme-dialect (env-declarations env)))))
  1538.     (pt-syntax-error source "Predefined keyword can't be used as a variable:" name)
  1539.     #t))
  1540.  
  1541. (define (set!-expr? source env)
  1542.   (and (match SET!-sym 2 source)
  1543.        (var-expr? (cadr (source-code source)) env)))
  1544.  
  1545. (define (lambda-expr? source env)
  1546.   (and (match LAMBDA-sym -2 source)
  1547.        (proper-parms? (source->parms (cadr (source-code source))) env)))
  1548.  
  1549. (define (if-expr? source)
  1550.   (and (match IF-sym -2 source)
  1551.        (or (<= (length (source-code source)) 4)
  1552.            (pt-syntax-error source "Ill-formed special form" IF-sym))))
  1553.  
  1554. (define (cond-expr? source)
  1555.   (and (match COND-sym -1 source)
  1556.        (proper-clauses? source)))
  1557.  
  1558. (define (and-expr? source)
  1559.   (match AND-sym 0 source))
  1560.  
  1561. (define (or-expr? source)
  1562.   (match OR-sym 0 source))
  1563.  
  1564. (define (case-expr? source)
  1565.   (and (match CASE-sym -2 source)
  1566.        (proper-case-clauses? source)))
  1567.  
  1568. (define (let-expr? source env)
  1569.   (and (match LET-sym -2 source)
  1570.        (let ((code (source-code source)))
  1571.          (if (bindable-var? (cadr code) env)
  1572.            (and (proper-bindings? (caddr code) #t env)
  1573.                 (or (> (length code) 3)
  1574.                     (pt-syntax-error source "Ill-formed named 'let'")))
  1575.            (proper-bindings? (cadr code) #t env)))))
  1576.  
  1577. (define (let*-expr? source env)
  1578.   (and (match LET*-sym -2 source)
  1579.        (proper-bindings? (cadr (source-code source)) #f env)))
  1580.  
  1581. (define (letrec-expr? source env)
  1582.   (and (match LETREC-sym -2 source)
  1583.        (proper-bindings? (cadr (source-code source)) #t env)))
  1584.  
  1585. (define (begin-expr? source)
  1586.   (match BEGIN-sym -1 source))
  1587.  
  1588. (define (do-expr? source env)
  1589.   (and (match DO-sym -2 source)
  1590.        (proper-do-bindings? source env)
  1591.        (proper-do-exit? source)))
  1592.  
  1593. (define (define-expr? source env)
  1594.   (and (match DEFINE-sym -1 source)
  1595.        (proper-definition? source env)
  1596.        (let ((v (definition-variable source)))
  1597.          (not-macro v env (source-code v)))))
  1598.  
  1599. (define (combination-expr? source)
  1600.   (let ((length (proper-length (source-code source))))
  1601.     (if length
  1602.       (or (> length 0)
  1603.           (pt-syntax-error source "Ill-formed procedure call"))
  1604.       (pt-syntax-error source "Ill-terminated procedure call"))))
  1605.  
  1606. (define (delay-expr? source env)
  1607.   (and (not (eq? (scheme-dialect (env-declarations env)) IEEE-SCHEME-sym))
  1608.        (match DELAY-sym 1 source)))
  1609.        
  1610. (define (future-expr? source env)
  1611.   (and (eq? (scheme-dialect (env-declarations env)) MULTILISP-sym)
  1612.        (match FUTURE-sym 1 source)))
  1613.        
  1614. (define (macro-expr? source env)
  1615.   (let ((code (source-code source)))
  1616.     (and (pair? code)
  1617.          (symbol-object? (source-code (car code)))
  1618.          (let ((macr (env-lookup-macro env (source-code (car code)))))
  1619.            (and macr
  1620.                 (let ((len (proper-length (cdr code))))
  1621.                   (if len
  1622.                     (let ((len* (+ len 1))
  1623.                           (size (car macr)))
  1624.                       (or (if (> size 0) (= len* size) (>= len* (- size)))
  1625.                           (pt-syntax-error source "Ill-formed macro form")))
  1626.                     (pt-syntax-error source "Ill-terminated macro form"))))))))
  1627.  
  1628. (define (define-macro-expr? source env)
  1629.   (and (match **DEFINE-MACRO-sym -1 source)
  1630.        (proper-definition? source env)))
  1631.  
  1632. (define (declare-expr? source)
  1633.   (match **DECLARE-sym -1 source))
  1634.  
  1635. (define (include-expr? source)
  1636.   (match **INCLUDE-sym 1 source))
  1637.  
  1638. (define (begin-defs-expr? source)
  1639.   (match BEGIN-sym 0 source))
  1640.  
  1641. (define (match keyword size source)
  1642.   (let ((code (source-code source)))
  1643.     (and (pair? code)
  1644.          (eq? (source-code (car code)) keyword)
  1645.          (let ((length (proper-length (cdr code))))
  1646.            (if length
  1647.              (or (if (> size 0) (= length size) (>= length (- size)))
  1648.                  (pt-syntax-error source "Ill-formed special form" keyword))
  1649.              (pt-syntax-error source "Ill-terminated special form" keyword))))))
  1650.  
  1651. (define (proper-length l)
  1652.   (define (length l n)
  1653.     (cond ((pair? l) (length (cdr l) (+ n 1)))
  1654.           ((null? l) n)
  1655.           (else      #f)))
  1656.   (length l 0))
  1657.  
  1658. (define (proper-definition? source env)
  1659.   (let* ((code (source-code source))
  1660.          (pattern* (cadr code))
  1661.          (pattern (source-code pattern*))
  1662.          (body (cddr code)))
  1663.     (cond ((bindable-var? pattern* env)
  1664.            (cond ((length? body 0) #t) ; an unbound variable
  1665.                  ((length? body 1) #t) ; a bound variable
  1666.                  (else
  1667.                   (pt-syntax-error source "Ill-formed definition body"))))
  1668.           ((pair? pattern)
  1669.            (if (length? body 0)
  1670.              (pt-syntax-error
  1671.               source
  1672.               "Body of a definition must have at least one expression"))
  1673.            (if (bindable-var? (car pattern) env)
  1674.              (proper-parms? (cdr pattern) env)
  1675.              (pt-syntax-error
  1676.                (car pattern)
  1677.                "Procedure name must be an identifier")))
  1678.           (else
  1679.            (pt-syntax-error pattern* "Ill-formed definition pattern")))))
  1680.  
  1681. (define (definition-variable def)
  1682.   (let* ((code (source-code def))
  1683.          (pattern (cadr code)))
  1684.     (if (pair? (source-code pattern))
  1685.       (car (source-code pattern))
  1686.       pattern)))
  1687.  
  1688. (define (definition-value def)
  1689.   (let ((code (source-code def))
  1690.         (loc (source-locat def)))
  1691.     (cond ((pair? (source-code (cadr code)))
  1692.            (make-source
  1693.              (cons (make-source LAMBDA-sym loc)
  1694.                    (cons (parms->source (cdr (source-code (cadr code))) loc)
  1695.                          (cddr code)))
  1696.              loc))
  1697.           ((null? (cddr code))
  1698.            (make-source
  1699.              (list (make-source QUOTE-sym loc) (make-source undef-object loc))
  1700.              loc))
  1701.           (else
  1702.            (caddr code)))))
  1703.  
  1704. (define (parms->source parms loc)
  1705.   (if (or (pair? parms) (null? parms)) (make-source parms loc) parms))
  1706.  
  1707. (define (proper-parms? parms env)
  1708.  
  1709.   (define (proper-parms parms seen optional-seen)
  1710.     (cond ((pair? parms)
  1711.            (let* ((parm* (car parms))
  1712.                   (parm (source-code parm*)))
  1713.              (cond ((pair? parm)
  1714.                     (if (eq? (scheme-dialect (env-declarations env)) MULTILISP-sym)
  1715.                       (let ((length (proper-length parm)))
  1716.                         (if (or (eqv? length 1) (eqv? length 2))
  1717.                           (let ((var (car parm)))
  1718.                             (if (bindable-var? var env)
  1719.                               (if (memq (source-code var) seen)
  1720.                                 (pt-syntax-error
  1721.                                   var
  1722.                                   "Duplicate parameter in parameter list")
  1723.                                 (proper-parms
  1724.                                   (cdr parms)
  1725.                                   (cons (source-code var) seen)
  1726.                                   #t))
  1727.                               (pt-syntax-error
  1728.                                 var
  1729.                                 "Parameter must be an identifier")))
  1730.                           (pt-syntax-error parm* "Ill-formed optional parameter")))
  1731.                       (pt-syntax-error
  1732.                          parm*
  1733.                          "optional parameters illegal in this dialect")))
  1734.                    (optional-seen
  1735.                     (pt-syntax-error parm* "Optional parameter expected"))
  1736.                    ((bindable-var? parm* env)
  1737.                     (if (memq parm seen)
  1738.                       (pt-syntax-error
  1739.                         parm*
  1740.                         "Duplicate parameter in parameter list"))
  1741.                       (proper-parms
  1742.                         (cdr parms)
  1743.                         (cons parm seen)
  1744.                         #f))
  1745.                    (else
  1746.                     (pt-syntax-error parm* "Parameter must be an identifier")))))
  1747.           ((null? parms)
  1748.            #t)
  1749.           ((bindable-var? parms env)
  1750.            (if (memq (source-code parms) seen)
  1751.              (pt-syntax-error parms "Duplicate parameter in parameter list")
  1752.              #t))
  1753.           (else
  1754.            (pt-syntax-error parms "Rest parameter must be an identifier"))))
  1755.  
  1756.   (proper-parms parms '() #f))
  1757.  
  1758. (define (proper-clauses? source)
  1759.  
  1760.   (define (proper-clauses clauses)
  1761.     (or (null? clauses)
  1762.         (let* ((clause* (car clauses))
  1763.                (clause (source-code clause*))
  1764.                (length (proper-length clause)))
  1765.           (if length
  1766.             (if (>= length 1)
  1767.               (if (eq? (source-code (car clause)) ELSE-sym)
  1768.                 (cond ((= length 1)
  1769.                        (pt-syntax-error
  1770.                          clause*
  1771.                          "Else clause must have a body"))
  1772.                       ((not (null? (cdr clauses)))
  1773.                        (pt-syntax-error
  1774.                          clause*
  1775.                          "Else clause must be the last clause"))
  1776.                       (else
  1777.                        (proper-clauses (cdr clauses))))
  1778.                 (if (and (>= length 2)
  1779.                          (eq? (source-code (cadr clause)) =>-sym)
  1780.                          (not (= length 3)))
  1781.                   (pt-syntax-error
  1782.                     (cadr clause)
  1783.                     "'=>' must be followed by a single expression")
  1784.                   (proper-clauses (cdr clauses))))
  1785.               (pt-syntax-error clause* "Ill-formed 'cond' clause"))
  1786.             (pt-syntax-error clause* "Ill-terminated 'cond' clause")))))
  1787.  
  1788.   (proper-clauses (cdr (source-code source))))
  1789.  
  1790. (define (proper-case-clauses? source)
  1791.  
  1792.   (define (proper-case-clauses clauses)
  1793.     (or (null? clauses)
  1794.         (let* ((clause* (car clauses))
  1795.                (clause (source-code clause*))
  1796.                (length (proper-length clause)))
  1797.           (if length
  1798.             (if (>= length 2)
  1799.               (if (eq? (source-code (car clause)) ELSE-sym)
  1800.                 (if (not (null? (cdr clauses)))
  1801.                   (pt-syntax-error
  1802.                     clause*
  1803.                     "Else clause must be the last clause")
  1804.                   (proper-case-clauses (cdr clauses)))
  1805.                 (begin
  1806.                   (proper-selector-list? (car clause))
  1807.                   (proper-case-clauses (cdr clauses))))
  1808.               (pt-syntax-error
  1809.                 clause*
  1810.                 "A 'case' clause must have a selector list and a body"))
  1811.             (pt-syntax-error clause* "Ill-terminated 'case' clause")))))
  1812.  
  1813.   (proper-case-clauses (cddr (source-code source))))
  1814.  
  1815. (define (proper-selector-list? source)
  1816.   (let* ((code (source-code source))
  1817.          (length (proper-length code)))
  1818.     (if length
  1819.       (or (>= length 1)
  1820.           (pt-syntax-error
  1821.             source
  1822.             "Selector list must contain at least one element"))
  1823.       (pt-syntax-error source "Ill-terminated selector list"))))
  1824.  
  1825. (define (proper-bindings? bindings check-dupl? env)
  1826.  
  1827.   (define (proper-bindings l seen)
  1828.     (cond ((pair? l)
  1829.            (let* ((binding* (car l))
  1830.                   (binding (source-code binding*)))
  1831.              (if (eqv? (proper-length binding) 2)
  1832.                (let ((var (car binding)))
  1833.                  (if (bindable-var? var env)
  1834.                    (if (and check-dupl? (memq (source-code var) seen))
  1835.                      (pt-syntax-error var "Duplicate variable in bindings")
  1836.                      (proper-bindings (cdr l)
  1837.                                       (cons (source-code var) seen)))
  1838.                    (pt-syntax-error
  1839.                      var
  1840.                      "Binding variable must be an identifier")))
  1841.                (pt-syntax-error binding* "Ill-formed binding"))))
  1842.           ((null? l)
  1843.            #t)
  1844.           (else
  1845.            (pt-syntax-error bindings "Ill-terminated binding list"))))
  1846.           
  1847.    (proper-bindings (source-code bindings) '()))
  1848.  
  1849. (define (proper-do-bindings? source env)
  1850.   (let ((bindings (cadr (source-code source))))
  1851.  
  1852.     (define (proper-bindings l seen)
  1853.       (cond ((pair? l)
  1854.              (let* ((binding* (car l))
  1855.                     (binding (source-code binding*))
  1856.                     (length (proper-length binding)))
  1857.                (if (or (eqv? length 2) (eqv? length 3))
  1858.                  (let ((var (car binding)))
  1859.                    (if (bindable-var? var env)
  1860.                      (if (memq (source-code var) seen)
  1861.                        (pt-syntax-error var "Duplicate variable in bindings")
  1862.                        (proper-bindings (cdr l)
  1863.                                         (cons (source-code var) seen)))
  1864.                      (pt-syntax-error
  1865.                        var
  1866.                        "Binding variable must be an identifier")))
  1867.                  (pt-syntax-error binding* "Ill-formed binding"))))
  1868.             ((null? l)
  1869.              #t)
  1870.             (else
  1871.              (pt-syntax-error bindings "Ill-terminated binding list"))))
  1872.  
  1873.      (proper-bindings (source-code bindings) '())))
  1874.  
  1875. (define (proper-do-exit? source)
  1876.   (let* ((code (source-code (caddr (source-code source))))
  1877.          (length (proper-length code)))
  1878.     (if length
  1879.       (or (> length 0)
  1880.           (pt-syntax-error source "Ill-formed exit clause"))
  1881.       (pt-syntax-error source "Ill-terminated exit clause"))))
  1882.  
  1883. (define (include-filename source)
  1884.   (source-code (cadr (source-code source))))
  1885.  
  1886. (define (begin-defs-body source)
  1887.   (cdr (source-code source)))
  1888.  
  1889. (define (length? l n)
  1890.   (cond ((null? l) (= n 0))
  1891.         ((> n 0)   (length? (cdr l) (- n 1)))
  1892.         (else      #f)))
  1893.  
  1894. ; - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
  1895. ;
  1896. ; Variable dependency analysis for recursive definitions (e.g. 'letrec's).
  1897.  
  1898. (define (make-gnode label edges)
  1899.   (vector gnode-tag label edges))
  1900.  
  1901. (define (gnode? x)
  1902.   (and (vector? x)
  1903.        (> (vector-length x) 0)
  1904.        (eq? (vector-ref x 0) gnode-tag)))
  1905.  
  1906. (define (gnode-label x)        (vector-ref x 1))
  1907. (define (gnode-edges x)        (vector-ref x 2))
  1908. (define (gnode-label-set! x y) (vector-set! x 1 y))
  1909. (define (gnode-edges-set! x y) (vector-set! x 2 y))
  1910.  
  1911. (define gnode-tag (list 'gnode))
  1912.  
  1913. (define (dependency-graph vars vals)
  1914.   (define (dgraph vars* vals*)
  1915.     (if (null? vars*)
  1916.       (set-empty)
  1917.       (let ((var (car vars*)) (val (car vals*)))
  1918.         (set-adjoin (dgraph (cdr vars*) (cdr vals*))
  1919.                     (make-gnode var (set-intersection
  1920.                                       (list->set vars)
  1921.                                       (free-variables val)))))))
  1922.   (dgraph vars vals))
  1923.  
  1924. (define (transitive-closure graph)
  1925.   (define changed? #f)
  1926.   (define (closure edges)
  1927.     (list->set (set-union edges
  1928.                           (apply set-union
  1929.                                  (map (lambda (label)
  1930.                                         (gnode-edges (gnode-find label graph)))
  1931.                                       (set->list edges))))))
  1932.   (let ((new-graph
  1933.           (set-map (lambda (x)
  1934.                      (let ((new-edges (closure (gnode-edges x))))
  1935.                        (if (not (set-equal? new-edges (gnode-edges x)))
  1936.                          (set! changed? #t))
  1937.                        (make-gnode (gnode-label x) new-edges)))
  1938.                    graph)))
  1939.     (if changed? (transitive-closure new-graph) new-graph)))
  1940.  
  1941. (define (gnode-find label graph)
  1942.   (define (find label l)
  1943.     (cond ((null? l)                         #f)
  1944.           ((eq? (gnode-label (car l)) label) (car l))
  1945.           (else                              (find label (cdr l)))))
  1946.   (find label (set->list graph)))
  1947.  
  1948. (define (topological-sort graph) ; topological sort fixed to handle cycles
  1949.   (if (set-empty? graph)
  1950.     '()
  1951.     (let ((to-remove (or (remove-no-edges graph) (remove-cycle graph))))
  1952.       (let ((labels (set-map gnode-label to-remove)))
  1953.         (cons labels
  1954.               (topological-sort
  1955.                 (set-map (lambda (x)
  1956.                            (make-gnode
  1957.                              (gnode-label x)
  1958.                              (set-difference (gnode-edges x) labels)))
  1959.                          (set-difference graph to-remove))))))))
  1960.  
  1961. (define (remove-no-edges graph)
  1962.   (let ((nodes-with-no-edges
  1963.          (set-keep (lambda (x) (set-empty? (gnode-edges x))) graph)))
  1964.     (if (set-empty? nodes-with-no-edges)
  1965.       #f
  1966.       nodes-with-no-edges)))
  1967.  
  1968. (define (remove-cycle graph)
  1969.   (define (remove l)
  1970.     (let ((edges (gnode-edges (car l))))
  1971.       (define (equal-edges? x) (set-equal? (gnode-edges x) edges))
  1972.       (define (member-edges? x) (set-member? (gnode-label x) edges))
  1973.       (if (set-member? (gnode-label (car l)) edges)
  1974.         (let ((edge-graph (set-keep member-edges? graph)))
  1975.           (if (set-every? equal-edges? edge-graph)
  1976.             edge-graph
  1977.             (remove (cdr l))))
  1978.         (remove (cdr l)))))
  1979.   (remove (set->list graph)))
  1980.  
  1981. ; - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
  1982. ;
  1983. ; Declaration handling:
  1984. ; --------------------
  1985.  
  1986. ; A declaration has the form: (##declare <item1> <item2> ...)
  1987. ;
  1988. ; an <item> can be one of 6 types:
  1989. ;
  1990. ; - flag declaration           : (<id>)
  1991. ; - parameterized declaration  : (<id> <parameter>)
  1992. ; - boolean declaration        : (<id>)  or  (NOT <id>)
  1993. ; - namable declaration        : (<id> <name>...)
  1994. ; - namable boolean declaration: (<id> <name>...)  or  (NOT <id> <name>...)
  1995. ; - namable string declaration : (<id> <string> <name>...)
  1996.  
  1997. (define (transform-declaration source)
  1998.   (let ((code (source-code source)))
  1999.     (if (not (pair? code))
  2000.       (pt-syntax-error source "Ill-formed declaration")
  2001.       (let* ((pos (not (eq? (source-code (car code)) NOT-sym)))
  2002.              (x (if pos code (cdr code))))
  2003.         (if (not (pair? x))
  2004.           (pt-syntax-error source "Ill-formed declaration")
  2005.           (let* ((id* (car x))
  2006.                  (id (source-code id*)))
  2007.  
  2008.             (cond ((not (symbol-object? id))
  2009.                    (pt-syntax-error id* "Declaration name must be an identifier"))
  2010.  
  2011.                   ((assq id flag-declarations)
  2012.                    (cond ((not pos)
  2013.                           (pt-syntax-error id* "Declaration can't be negated"))
  2014.                          ((null? (cdr x))
  2015.                           (flag-decl
  2016.                             source
  2017.                             (cdr (assq id flag-declarations))
  2018.                             id))
  2019.                          (else
  2020.                           (pt-syntax-error source "Ill-formed declaration"))))
  2021.  
  2022.                   ((memq id parameterized-declarations)
  2023.                    (cond ((not pos)
  2024.                           (pt-syntax-error id* "Declaration can't be negated"))
  2025.                          ((eqv? (proper-length x) 2)
  2026.                           (parameterized-decl
  2027.                             source
  2028.                             id
  2029.                             (source->expression (cadr x))))
  2030.                          (else
  2031.                           (pt-syntax-error source "Ill-formed declaration"))))
  2032.  
  2033.                   ((memq id boolean-declarations)
  2034.                    (if (null? (cdr x))
  2035.                      (boolean-decl source id pos)
  2036.                      (pt-syntax-error source "Ill-formed declaration")))
  2037.  
  2038.                   ((assq id namable-declarations)
  2039.                    (cond ((not pos)
  2040.                           (pt-syntax-error id* "Declaration can't be negated"))
  2041.                          (else
  2042.                           (namable-decl
  2043.                             source
  2044.                             (cdr (assq id namable-declarations))
  2045.                             id
  2046.                             (map source->expression (cdr x))))))
  2047.  
  2048.                   ((memq id namable-boolean-declarations)
  2049.                    (namable-boolean-decl
  2050.                      source
  2051.                      id
  2052.                      pos
  2053.                      (map source->expression (cdr x))))
  2054.  
  2055.                   ((memq id namable-string-declarations)
  2056.                    (if (not (pair? (cdr x)))
  2057.                      (pt-syntax-error source "Ill-formed declaration")
  2058.                      (let* ((str* (cadr x))
  2059.                             (str (source-code str*)))
  2060.                        (cond ((not pos)
  2061.                               (pt-syntax-error id* "Declaration can't be negated"))
  2062.                              ((not (string? str))
  2063.                               (pt-syntax-error str* "String expected"))
  2064.                              (else
  2065.                               (namable-string-decl
  2066.                                 source
  2067.                                 id
  2068.                                 str
  2069.                                 (map source->expression (cddr x))))))))
  2070.  
  2071.                   (else
  2072.                    (pt-syntax-error id* "Unknown declaration")))))))))
  2073.  
  2074. (define (add-declarations source env)
  2075.   (let loop ((l (cdr (source-code source))) (env env))
  2076.     (if (pair? l)
  2077.       (loop (cdr l) (env-declare env (transform-declaration (car l))))
  2078.       env)))
  2079.  
  2080. (define (add-decl d decl)
  2081.   (env-declare decl d))
  2082.  
  2083. ; - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
  2084. ;
  2085. ; Macro handling:
  2086. ; --------------
  2087.  
  2088. (define (add-macro source env)
  2089.  
  2090.   (define (form-size parms)
  2091.     (let loop ((l parms) (n 1))
  2092.       (if (pair? l)
  2093.         (loop (cdr l) (+ n 1))
  2094.         (if (null? l) n (- n)))))
  2095.  
  2096.   (define (error-proc . msgs)
  2097.     (apply compiler-user-error
  2098.            (cons (source-locat source)
  2099.                  (cons "(in macro body)" msgs))))
  2100.  
  2101.   (let ((var (definition-variable source))
  2102.         (proc (definition-value source)))
  2103.     (if (lambda-expr? proc env)
  2104.       (env-macro env
  2105.                  (source-code var)
  2106.                  (cons (form-size (source->parms (cadr (source-code proc))))
  2107.                        (scheme-global-eval (source->expression proc)
  2108.                                            error-proc)))
  2109.       (pt-syntax-error source "Macro value must be a lambda expression"))))
  2110.  
  2111. ; - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
  2112.  
  2113. (define (ptree.begin! info-port) ; initialize package
  2114.   (set! *ptree-port* info-port)
  2115.   '())
  2116.  
  2117. (define (ptree.end!) ; finalize package
  2118.   '())
  2119.  
  2120. ; - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
  2121. ;
  2122. ; Stuff local to the package:
  2123.  
  2124. (define *ptree-port* '())
  2125.  
  2126. ;==============================================================================
  2127.