home *** CD-ROM | disk | FTP | other *** search
/ Language/OS - Multiplatform Resource Library / LANGUAGE OS.iso / scheme / schmlbrr / schem_lb.lha / unsupported / general / semant.scm < prev   
Encoding:
Text File  |  1993-07-16  |  30.0 KB  |  1,001 lines
  1. ; -*- Mode: Scheme; Syntax: Scheme; Package: SCHEME; -*-
  2.  
  3. ; Scheme semantics, by Will Clinger, March 1986
  4. ; Updated by Jonathan Rees, April 1986 and January 1987
  5.  
  6. ; This code appears with somewhat different lexical conventions in
  7. ; the Revised^3 Report on the Algorithmic Language Scheme.
  8.  
  9. ; JAR's changes:
  10. ;   - Changed the character singlequote, used in some identifiers, to
  11. ;     at-sign.  (E.g. kappa' -> kappa@.)
  12. ;   - Flushed dummy definition of character?
  13. ;   - Introduced the constant *undefined*.
  14. ;   - #!true -> #t, #!false -> #f, #!null -> '()
  15. ;   - Flushed question marks from =, <, etc.
  16. ;   - Changed ((rec loop (lambda ...)) ...) to (let loop (...) ...)
  17. ;   - Changed CERROR to ERROR
  18.  
  19. ; ---- Abstract syntax ----
  20.  
  21. (define (constant? x)
  22.     (or (and (pair? x) (eq? (car x) 'quote))
  23.         (and (not (pair? x))
  24.              (not (symbol? x)))))
  25.  
  26. (define identifier? symbol?)
  27.  
  28. (define (call? x)
  29.     (and (pair? x)
  30.          (not (memq (car x)
  31.                     '(lambda if cond and or case let let* letrec rec
  32.                       set! begin sequence do delay)))))
  33.  
  34. (define (lambda? x)
  35.     (and (pair? x)
  36.          (eq? (car x) 'lambda)))
  37.  
  38. (define (if? x)
  39.     (and (pair? x)
  40.          (eq? (car x) 'if)))
  41.  
  42. (define (set? x)
  43.     (and (pair? x)
  44.          (eq? (car x) 'set!)))
  45.  
  46. (define (begin? x)
  47.     (and (pair? x)
  48.          (eq? (car x) 'begin)))
  49.  
  50. (define rator car)              ; call
  51. (define rands cdr)
  52.  
  53. (define bvl cadr)               ; lambda
  54. (define (command-body x)
  55.     (reverse (cdr (reverse (cddr x)))))
  56. (define (result-body x)
  57.     (car (reverse x)))
  58. (define (rest-arg? bvl)
  59.     (cond ((null? bvl) #f)
  60.           ((pair? bvl) (rest-arg? (cdr bvl)))
  61.           (else #t)))
  62. (define (required-args bvl)
  63.     (cond ((null? bvl) bvl)
  64.           ((pair? bvl)
  65.            (cons (car bvl) (required-args (cdr bvl))))
  66.           (else '())))
  67. (define (rest-arg bvl)
  68.     (if (pair? bvl)
  69.         (rest-arg (cdr bvl))
  70.         bvl))
  71.  
  72. (define test-part cadr)         ; if
  73. (define then-part caddr)
  74. (define else-part cadddr)
  75. (define (two-armed? x)
  76.     (= (length x) 3))
  77. (define (three-armed? x)
  78.     (= (length x) 4))
  79.  
  80. (define lhs cadr)               ; set!
  81. (define rhs caddr)
  82.  
  83. (define (command-part x)        ; begin
  84.     (reverse (cdr (reverse (cdr x)))))
  85. (define (result-part x)
  86.     (car (reverse x)))
  87.  
  88. ; Domain Equations
  89. ;
  90. ; alpha /       L                               locations/denoted values
  91. ; nu /          N                               natural numbers
  92. ;               T = {false, true}               truth values
  93. ;               Q                               symbols
  94. ;               H                               characters
  95. ;               R                               numbers
  96. ;               EP = L x L                      pairs
  97. ;               EV = L*                         vectors
  98. ;               ES = L*                         strings
  99. ; phi /         F = L x (E* --> K --> C)        procedures
  100. ; epsilon /     E = {false, true, null, undefined, unspecified}
  101. ;                           + Q + H + R + EP + EV + ES + F
  102. ;                                               expressed/stored values
  103. ; sigma /       S = L --> (V x T)               stores
  104. ; rho /         U = Ide --> L                   environments
  105. ; theta /       C = S --> A                     command continuations
  106. ; kappa /       K = E* --> C                    expression continuations
  107. ;               A                               answers
  108. ;               X                               errors
  109.  
  110. (define (in? x tag) (eq? (vector-ref x 0) tag))
  111.  
  112. (define (inject x tag) (vector tag x))
  113.  
  114. (define (project x tag)
  115.     (if (eq? (vector-ref x 0) tag)
  116.         (vector-ref x 1)
  117.         (error "Domain type error" x tag)))
  118.  
  119. ; Some individual domain elements
  120.  
  121. (define *false* (inject 'false 'MISC))
  122. (define *true* (inject 'true 'MISC))
  123. (define *null* (inject 'null 'MISC))
  124. (define *undefined* (inject 'undefined 'MISC))
  125. (define *unspecified* (inject 'unspecified 'MISC))
  126.  
  127.  
  128. ; Semantic Functions
  129. ;
  130. ; K  : Con --> E
  131. ; E  : Exp --> U --> K --> C
  132. ; E* : Exp* --> U --> K --> C
  133. ; C  : Com* --> U --> C --> C
  134.  
  135. (define (K-eval x)
  136.     (let ((x (if (pair? x) (cadr x) x)))
  137.       (cond ((symbol? x) (inject x 'Q))
  138.             ((char? x) (inject x 'H))
  139.             ((number? x) (inject x 'R))
  140.             ((eq? x #f) *false*)
  141.             ((eq? x #t) *true*)
  142.             ; pre-empted by #f in MacScheme; use (list) instead.
  143.             ((eq? x '()) *null*)
  144.             ; quoted pairs are allocated by the reader
  145.             ((in? x 'EP) x)
  146.             ; quoted vectors are allocated by the reader
  147.             ((in? x 'EV) x)
  148.             ; constant strings are allocated by the reader
  149.             ((in? x 'ES) x)
  150.             (else (error "Weird constant" x)))))
  151.  
  152. (define (E-eval exp)
  153.     (cond ((constant? exp)
  154.            (lambda (rho)
  155.                    (lambda (kappa)
  156.                            ((send (K-eval exp)) kappa))))
  157.           ((identifier? exp)
  158.            (E-identifier exp))
  159.           ((call? exp)
  160.            (E-call exp))
  161.           ((and (lambda? exp) (not (rest-arg? (bvl exp))))
  162.            (E-lambda-norest exp))
  163.           ((and (lambda? exp) (rest-arg? (bvl exp)))
  164.            (E-lambda-rest exp))
  165.           ((and (if? exp) (two-armed? exp))
  166.            (E-if2 exp))
  167.           ((and (if? exp) (three-armed? exp))
  168.            (E-if3 exp))
  169.           ((set? exp)
  170.            (E-set exp))
  171.           ((begin? exp)
  172.            (E-begin exp))
  173.           (else (error "Unrecognized expression" exp))))
  174.  
  175. (define (((E-identifier I) rho) kappa)
  176.     ((hold ((lookup rho) I))
  177.      (single
  178.        (lambda (epsilon)
  179.      (if (equal? epsilon *undefined*)
  180.          (wrong "undefined variable")
  181.          ((send epsilon) kappa))))))
  182.  
  183. ; The order of evaluation within a call is unspecified.
  184. ; We mimic that here by allowing arbitrary permutations permute
  185. ; and unpermute, which must be inverses.  This still rules out parallel
  186. ; evaluation and requires that the order of evaluation be constant throughout
  187. ; a program (for any given number of arguments), but it is a closer
  188. ; approximation to the intended semantics than a left-to-right
  189. ; evaluation would be.
  190.  
  191. (define (E-call exp)
  192.   (let ((xx (E*-eval (permute exp))))
  193.     (lambda (rho)
  194.       (lambda (kappa)
  195.         ((xx rho)
  196.          (lambda (epsilon*)
  197.            (let ((epsilon* (unpermute epsilon*)))
  198.              (((applicate (car epsilon*))
  199.            (cdr epsilon*))
  200.           kappa))))))))
  201.  
  202. (define (E-lambda-norest exp)
  203.   (let ((I* (required-args (bvl exp)))
  204.         (C* (command-body exp))
  205.         (E0 (result-body exp)))
  206.     (let ((x1 (C-eval C*))
  207.           (x0 (E-eval E0)))
  208.       (lambda (rho)
  209.         (lambda (kappa)
  210.           (lambda (sigma)
  211.             (if (in? (new sigma) 'L)
  212.                 (((send (inject
  213.                           (list
  214.                             (project (new sigma) 'L)
  215.                             (lambda (epsilon*)
  216.                               (lambda (kappa@)
  217.                                 (if (= (length epsilon*)
  218.                                        (length I*))
  219.                                     ((tievals
  220.                                        (lambda (alpha*)
  221.                                          (let ((rho@ (((extends rho)
  222.                                                        I*)
  223.                                                       alpha*)))
  224.                                            ((x1 rho@)
  225.                                             ((x0 rho@)
  226.                                              kappa@)))))
  227.                                      epsilon*)
  228.                                     (wrong "wrong number of arguments")))))
  229.                           'F))
  230.                   kappa)
  231.                  (((update (project (new sigma) 'L))
  232.                    *unspecified*)
  233.                   sigma))
  234.                 ((wrong "out of memory") sigma))))))))
  235.  
  236. (define (E-lambda-rest exp)
  237.   (let ((I* (required-args (bvl exp)))
  238.         (I@ (rest-arg (bvl exp)))
  239.         (C* (command-body exp))
  240.         (E0 (result-body exp)))
  241.     (let ((x1 (C-eval C*))
  242.           (x0 (E-eval E0)))
  243.       (lambda (rho)
  244.         (lambda (kappa)
  245.           (lambda (sigma)
  246.             (if (in? (new sigma) 'L)
  247.                 (((send (inject
  248.                           (list
  249.                             (project (new sigma) 'L)
  250.                             (lambda (epsilon*)
  251.                               (lambda (kappa@)
  252.                                 (if (>= (length epsilon*)
  253.                                         (length I*))
  254.                                     (((tievalsrest
  255.                                        (lambda (alpha*)
  256.                                          (let ((rho@ (((extends rho)
  257.                                                        (append I* (list I@)))
  258.                                                       alpha*)))
  259.                                            ((x1 rho@)
  260.                                             ((x0 rho@)
  261.                                              kappa@)))))
  262.                                       epsilon*)
  263.                                      (length I*))
  264.                                     (wrong "too few arguments")))))
  265.                           'F))
  266.                   kappa)
  267.                  (((update (project (new sigma) 'L))
  268.                    *unspecified*)
  269.                   sigma))
  270.                 ((wrong "out of memory") sigma))))))))
  271.  
  272. (define (E-if2 exp)
  273.   (let ((E0 (test-part exp))
  274.         (E1 (then-part exp)))
  275.     (let ((x0 (E-eval E0))
  276.           (x1 (E-eval E1)))
  277.       (lambda (rho)
  278.         (lambda (kappa)
  279.           ((x0 rho)
  280.            (single
  281.              (lambda (epsilon)
  282.                (if (truish epsilon)
  283.                    ((x1 rho) kappa)
  284.                    ((send *unspecified*) kappa))))))))))
  285.  
  286.  
  287. (define (E-if3 exp)
  288.   (let ((E0 (test-part exp))
  289.         (E1 (then-part exp))
  290.         (E2 (else-part exp)))
  291.     (let ((x0 (E-eval E0))
  292.           (x1 (E-eval E1))
  293.           (x2 (E-eval E2)))
  294.       (lambda (rho)
  295.         (lambda (kappa)
  296.           ((x0 rho)
  297.            (single
  298.              (lambda (epsilon)
  299.                (if (truish epsilon)
  300.                    ((x1 rho) kappa)
  301.                    ((x2 rho) kappa))))))))))
  302.  
  303. (define (E-set exp)
  304.   (let ((I (lhs exp))
  305.         (E (rhs exp)))
  306.     (let ((x (E-eval E)))
  307.       (lambda (rho)
  308.         (lambda (kappa)
  309.           ((x rho)
  310.            (single
  311.              (lambda (epsilon)
  312.                (((assign ((lookup rho) I))
  313.                  epsilon)
  314.                 ((send *unspecified*)
  315.                  kappa))))))))))
  316.  
  317. (define (E-begin exp)
  318.   (let ((C* (command-part exp))
  319.         (E0 (result-part exp)))
  320.     (let ((x1 (C-eval C*))
  321.           (x0 (E-eval E0)))
  322.       (lambda (rho)
  323.         (lambda (kappa)
  324.           ((x1 rho)
  325.            ((x0 rho)
  326.             kappa)))))))
  327.  
  328. (define (E*-eval E*)
  329.   (if (null? E*)
  330.       (lambda (rho)
  331.         (lambda (kappa)
  332.           (kappa '())))
  333.       (let ((E0 (car E*))
  334.             (E* (cdr E*)))
  335.         (let ((x0 (E-eval E0))
  336.               (x1 (E*-eval E*)))
  337.           (lambda (rho)
  338.             (lambda (kappa)
  339.               ((x0 rho)
  340.                (single
  341.                  (lambda (epsilon0)
  342.                    ((x1 rho)
  343.                     (lambda (epsilon*)
  344.                       (kappa (cons epsilon0 epsilon*)))))))))))))
  345.  
  346. (define (C-eval C*)
  347.   (if (null? C*)
  348.       (lambda (rho)
  349.         (lambda (theta)
  350.           theta))
  351.       (let ((C0 (car C*))
  352.             (C* (cdr C*)))
  353.         (let ((x0 (E-eval C0))
  354.               (x1 (C-eval C*)))
  355.           (lambda (rho)
  356.             (lambda (theta)
  357.               ((x0 rho)
  358.                (lambda (epsilon*)
  359.                  ((x1 rho)
  360.                   theta)))))))))
  361.  
  362. ; ----- Auxiliary Functions -----
  363. ;
  364. ; lookup        : U --> Ide --> L
  365. ; extends       : U --> Ide* --> L* --> U
  366. ; wrong         : X --> C
  367. ; send          : E --> K --> C
  368. ; single        : (E --> C) --> K
  369. ; new           : S --> (L + {error})
  370. ; news          : N --> S --> (L* + {error})
  371. ; newsloop      : N --> S --> L* --> (L* + {error})
  372. ; hold          : L --> K --> C
  373. ; assign        : L --> E --> C --> C
  374. ; update        : L --> E --> S --> S
  375. ; tievals       : (L* --> C) --> E* --> C
  376. ; tievalsrest   : (L* --> C) --> E* --> N --> C
  377. ; list          : E* --> K --> C
  378. ; cons          : E* --> K --> C
  379. ; applicate     : E --> E* --> K --> C
  380. ; truish        : E --> T
  381. ; permute       : Exp* --> Exp*
  382. ; unpermute     : E* --> E*
  383.  
  384. (define ((lookup rho) I) (rho I))
  385.  
  386. (define (((extends rho) I*) alpha*)
  387.   (if (null? I*)
  388.       rho
  389.       (((extends (%extend rho (car I*) (car alpha*)))
  390.         (cdr I*))
  391.        (cdr alpha*))))
  392.  
  393. (define (%extend f x y)
  394.   (lambda (x@)
  395.     (if (eq? x x@)
  396.         y
  397.         (f x@))))
  398.  
  399. ; wrong is implementation-dependent, so ignore the following.
  400.  
  401. (define ((wrong msg) sigma)
  402.   (display msg)
  403.   (newline)
  404.   (dump-core sigma))
  405.  
  406. (define (dump-core sigma)
  407.   (let loop ((alpha 0))
  408.     (let ((x (sigma alpha)))
  409.       (if (cadr x)            ; if in use
  410.       (begin
  411.        (write alpha)
  412.        (display ": ")
  413.        (write (car x))
  414.        (newline)
  415.        (loop (1+ alpha)))))))
  416.  
  417. (define ((send epsilon) kappa)
  418.   (kappa (list epsilon)))
  419.  
  420. ; The following could easily be changed to ignore extra return values
  421. ; as in Common Lisp.
  422.  
  423. (define ((single psi) epsilon*)
  424.   (if (= (length epsilon*) 1)
  425.       (psi (car epsilon*))
  426.       (wrong "wrong number of return values")))
  427.  
  428. ; The storage allocator (new) is implementation-dependent.
  429.  
  430. (define *memorysize* 1000)
  431.  
  432. (define (new sigma)
  433.   (let loop ((alpha 0))
  434.     (cond ((> alpha *memorysize*) 'error)
  435.       ((not (cadr (sigma alpha)))
  436.        (inject alpha 'L))
  437.       (else (loop (1+ alpha))))))
  438.  
  439. (define ((news nu) sigma)
  440.   (newsloop nu sigma '()))
  441.  
  442. (define (newsloop nu sigma alpha*)
  443.   (cond ((zero? nu) alpha*)
  444.         ((in? (new sigma) 'L)
  445.          (newsloop (-1+ nu)
  446.                    (((update (project (new sigma) 'L))
  447.                      *unspecified*)
  448.                     sigma)
  449.                    (cons (project (new sigma) 'L) alpha*)))
  450.         (else 'error)))
  451.  
  452. (define (((hold alpha) kappa) sigma)
  453.   (((send (car (sigma alpha)))
  454.     kappa)
  455.    sigma))
  456.  
  457. (define ((((assign alpha) epsilon) theta) sigma)
  458.   (theta (((update alpha)
  459.            epsilon)
  460.           sigma)))
  461.  
  462. (define (((update alpha) epsilon) sigma)
  463.   (%extend sigma
  464.            alpha
  465.            (list epsilon #t)))
  466.  
  467. (define (((tievals psi) epsilon*) sigma)
  468.   (if (= (length epsilon*) 0)
  469.       ((psi '()) sigma)
  470.       (if (in? (new sigma) 'L)
  471.           (((tievals (lambda (alpha*)
  472.                        (psi (cons (project (new sigma) 'L) alpha*))))
  473.             (cdr epsilon*))
  474.            (((update (project (new sigma) 'L))
  475.              (car epsilon*))
  476.             sigma))
  477.           ((wrong "out of memory") sigma))))
  478.  
  479. (define (((tievalsrest psi) epsilon*) nu)
  480.   ((*list* (dropfirst epsilon* nu))
  481.    (single
  482.      (lambda (epsilon)
  483.        ((tievals psi)
  484.         (append (takefirst epsilon* nu)
  485.                 (list epsilon)))))))
  486.  
  487. (define (dropfirst l n)
  488.   (if (zero? n)
  489.       l
  490.       (dropfirst (cdr l) (- n 1))))
  491.  
  492. (define (takefirst l n)
  493.   (if (zero? n)
  494.       '()
  495.       (cons (car l) (takefirst (cdr l) (- n 1)))))
  496.  
  497. (define ((*list* epsilon*) kappa)
  498.   (if (zero? (length epsilon*))
  499.       ((send *null*) kappa)
  500.       ((*list* (cdr epsilon*))
  501.        (single
  502.          (lambda (epsilon)
  503.            ((*cons* (list (car epsilon*) epsilon))
  504.             kappa))))))
  505.  
  506. (define ((*cons* epsilon*) kappa)
  507.   (if (= (length epsilon*) 2)
  508.       (lambda (sigma)
  509.         (if (in? (new sigma) 'L)
  510.             ((lambda (sigma@)
  511.                (if (in? (new sigma@) 'L)
  512.                    (((send (inject (list (project (new sigma) 'L)
  513.                                          (project (new sigma@) 'L))
  514.                                    'EP))
  515.                      kappa)
  516.                     (((update (project (new sigma@) 'L))
  517.                       (cadr epsilon*))
  518.                      sigma@))
  519.                    ((wrong "out of memory") sigma@)))
  520.              (((update (project (new sigma) 'L))
  521.                (car epsilon*))
  522.               sigma))
  523.             ((wrong "out of memory") sigma)))
  524.       (wrong "wrong number of arguments")))
  525.  
  526. (define (((applicate epsilon) epsilon*) kappa)
  527.   (if (in? epsilon 'F)
  528.       (((cadr (project epsilon 'F)) epsilon*) kappa)
  529.       (wrong "bad procedure")))
  530.  
  531. (define (truish epsilon)
  532.   (if (in? epsilon 'MISC)
  533.       (if (eq? (project epsilon 'MISC) (project *false* 'MISC))
  534.           #f
  535.           (not (eq? (project epsilon 'MISC) (project *null* 'MISC))))
  536.       #t))
  537.  
  538. ; Implementation-dependent
  539. ; permute and unpermute must be inverse permutations.
  540.  
  541. (define (permute exp*) exp*)
  542. (define (unpermute epsilon*) epsilon*)
  543.  
  544. ; ----- Primitive procedures -----
  545.  
  546. (define ((*zero?* epsilon*) kappa)
  547.   (if (= (length epsilon*) 1)
  548.       (let ((epsilon (car epsilon*)))
  549.         (if (in? epsilon 'R)
  550.             ((send (if (zero? (project epsilon 'R))
  551.                        *true*
  552.                        *false*))
  553.              kappa)
  554.             (wrong "non-numeric argument to zero?")))
  555.       (wrong "wrong number of arguments")))
  556.  
  557. (define ((*<* epsilon*) kappa)
  558.   (if (= (length epsilon*) 2)
  559.       (let ((epsilon1 (car epsilon*))
  560.             (epsilon2 (cadr epsilon*)))
  561.         (if (in? epsilon1 'R)
  562.             (if (in? epsilon2 'R)
  563.                 ((send (if (<? (project epsilon1 'R)
  564.                                (project epsilon2 'R))
  565.                            *true*
  566.                            *false*))
  567.                  kappa)
  568.                 (wrong "non-numeric second argument to <"))
  569.             (wrong "non-numeric first argument to <")))
  570.       (wrong "wrong number of arguments")))
  571.  
  572. ; +, -, and * restricted to two arguments for testing purposes.
  573.  
  574. (define ((*+* epsilon*) kappa)
  575.   (if (= (length epsilon*) 2)
  576.       (let ((epsilon1 (car epsilon*))
  577.             (epsilon2 (cadr epsilon*)))
  578.         (if (in? epsilon1 'R)
  579.             (if (in? epsilon2 'R)
  580.                 ((send (inject (+ (project epsilon1 'R)
  581.                                   (project epsilon2 'R))
  582.                                'R))
  583.                  kappa)
  584.                 (wrong "non-numeric second argument to +"))
  585.             (wrong "non-numeric first argument to +")))
  586.       (wrong "wrong number of arguments")))
  587.  
  588. (define ((*-* epsilon*) kappa)
  589.   (if (= (length epsilon*) 2)
  590.       (let ((epsilon1 (car epsilon*))
  591.             (epsilon2 (cadr epsilon*)))
  592.         (if (in? epsilon1 'R)
  593.             (if (in? epsilon2 'R)
  594.                 ((send (inject (- (project epsilon1 'R)
  595.                                   (project epsilon2 'R))
  596.                                'R))
  597.                  kappa)
  598.                 (wrong "non-numeric second argument to -"))
  599.             (wrong "non-numeric first argument to -")))
  600.       (wrong "wrong number of arguments")))
  601.  
  602. (define ((*** epsilon*) kappa)
  603.   (if (= (length epsilon*) 2)
  604.       (let ((epsilon1 (car epsilon*))
  605.             (epsilon2 (cadr epsilon*)))
  606.         (if (in? epsilon1 'R)
  607.             (if (in? epsilon2 'R)
  608.                 ((send (inject (* (project epsilon1 'R)
  609.                                   (project epsilon2 'R))
  610.                                'R))
  611.                  kappa)
  612.                 (wrong "non-numeric second argument to *"))
  613.             (wrong "non-numeric first argument to *")))
  614.       (wrong "wrong number of arguments")))
  615.  
  616. ; car cdr null? eq? set-car!
  617.  
  618. (define ((*car* epsilon*) kappa)
  619.   (if (= (length epsilon*) 1)
  620.       (let ((epsilon1 (car epsilon*)))
  621.         (if (in? epsilon1 'EP)
  622.             ((hold (car (project epsilon1 'EP)))
  623.              kappa)
  624.             (wrong "bad argument to car")))
  625.       (wrong "wrong number of arguments")))
  626.  
  627. (define ((*cdr* epsilon*) kappa)
  628.   (if (= (length epsilon*) 1)
  629.       (let ((epsilon1 (car epsilon*)))
  630.         (if (in? epsilon1 'EP)
  631.             ((hold (cadr (project epsilon1 'EP)))
  632.              kappa)
  633.             (wrong "bad argument to cdr")))
  634.       (wrong "wrong number of arguments")))
  635.  
  636. (define ((*set-car!* epsilon*) kappa)
  637.   (if (= (length epsilon*) 2)
  638.       (let ((epsilon1 (car epsilon*))
  639.             (epsilon2 (cadr epsilon*)))
  640.         (if (in? epsilon1 'EP)
  641.             (((assign (car (project epsilon1 'EP)))
  642.               epsilon2)
  643.              ((send *unspecified*) kappa))
  644.             (wrong "bad argument to set-car!")))
  645.       (wrong "wrong number of arguments")))
  646.  
  647. (define ((*set-cdr!* epsilon*) kappa)
  648.   (if (= (length epsilon*) 2)
  649.       (let ((epsilon1 (car epsilon*))
  650.             (epsilon2 (cadr epsilon*)))
  651.         (if (in? epsilon1 'EP)
  652.             (((assign (cadr (project epsilon1 'EP)))
  653.               epsilon2)
  654.              ((send *unspecified*) kappa))
  655.             (wrong "bad argument to set-cdr!")))
  656.       (wrong "wrong number of arguments")))
  657.  
  658. (define ((*null?* epsilon*) kappa)
  659.   (if (= (length epsilon*) 1)
  660.       (let ((epsilon1 (car epsilon*)))
  661.         (if (in? epsilon1 'MISC)
  662.             (if (eq? (project epsilon1 'MISC) 'null)
  663.                 ((send *true*) kappa)
  664.                 ((send *false*) kappa))
  665.             ((send *false*) kappa)))
  666.       (wrong "wrong number of arguments")))
  667.  
  668. (define ((*eq?* epsilon*) kappa)
  669.   (if (= (length epsilon*) 2)
  670.       (let ((epsilon1 (car epsilon*))
  671.             (epsilon2 (cadr epsilon*)))
  672.         (cond ((and (in? epsilon1 'MISC) (in? epsilon2 'MISC))
  673.                ((send (if (eq? (project epsilon1 'MISC)
  674.                                (project epsilon1 'MISC))
  675.                           *true*
  676.                           *false*))
  677.                 kappa))
  678.               ((and (in? epsilon1 'Q) (in? epsilon2 'Q))
  679.                ((send (if (eq? (project epsilon1 'Q)
  680.                                (project epsilon2 'Q))
  681.                           *true*
  682.                           *false*))
  683.                 kappa))
  684.               ; Implementation-dependent?
  685.               ((and (in? epsilon1 'H) (in? epsilon2 'H))
  686.                ((send (if (char=? (project epsilon1 'H)
  687.                                   (project epsilon2 'H))
  688.                           *true*
  689.                           *false*))
  690.                 kappa))
  691.               ; Implementation-dependent.
  692.               ; Most implementations will tag numbers with locations.
  693.               ((and (in? epsilon1 'R) (in? epsilon2 'R))
  694.                ((send (if (= (project epsilon1 'R)
  695.                              (project epsilon2 'R))
  696.                           *true*
  697.                           *false*))
  698.                 kappa))
  699.               ; The domain structure allows distinct pairs to share
  700.               ; structure, though that can never happen through use
  701.               ; of the standard Scheme procedures.  Should we rule
  702.               ; out procedures that can cause distinct pairs to share
  703.               ; structure?
  704.               ((and (in? epsilon1 'EP) (in? epsilon2 'EP))
  705.                ((send (let ((pair1 (project epsilon1 'EP))
  706.                             (pair2 (project epsilon2 'EP)))
  707.                         (if (and (eq? (car pair1) (car pair2))
  708.                                  (eq? (cadr pair1) (cadr pair2)))
  709.                             *true*
  710.                             *false*)))
  711.                 kappa))
  712.               ; The domain structure allows distinct vectors to share
  713.               ; structure, as in Common Lisp.  Should that be outlawed?
  714.               ((and (in? epsilon1 'EV) (in? epsilon2 'EV))
  715.                ((send (if (and (= (length (project epsilon1 'EV))
  716.                                   (length (project epsilon2 'EV)))
  717.                                (let loop ((v1 (project epsilon1 'EV))
  718.                       (v2 (project epsilon2 'EV)))
  719.                  (cond ((null? v1) #t)
  720.                        ((eq? (car v1) (car v2))
  721.                     (loop (cdr v1) (cdr v2)))
  722.                        (else #f))))
  723.                           *true*
  724.                           *false*))
  725.                 kappa))
  726.               ; The domain structure allows distinct strings to share
  727.               ; structure (as in Common Lisp?).  Should that be outlawed?
  728.               ((and (in? epsilon1 'ES) (in? epsilon2 'ES))
  729.                ((send (if (and (= (length (project epsilon1 'ES))
  730.                                   (length (project epsilon2 'ES)))
  731.                                (let loop ((v1 (project epsilon1 'ES))
  732.                       (v2 (project epsilon2 'ES)))
  733.                  (cond ((null? v1) #t)
  734.                        ((eq? (car v1) (car v2))
  735.                     (loop (cdr v1) (cdr v2)))
  736.                        (else #f))))
  737.                           *true*
  738.                           *false*))
  739.                 kappa))
  740.               ; Pointer comparison for procedures, yuk.
  741.               ((and (in? epsilon1 'F) (in? epsilon2 'F))
  742.                ((send (if (eq? (car (project epsilon1 'F))
  743.                                (car (project epsilon2 'F)))
  744.                           *true*
  745.                           *false*))
  746.                 kappa))
  747.               (else ((send *false*) kappa))))
  748.       (wrong "wrong number of arguments")))
  749.  
  750. ; apply restricted to two arguments.
  751.  
  752. (define ((*apply* epsilon*) kappa)
  753.   (if (= (length epsilon*) 2)
  754.       (let ((epsilon1 (car epsilon*))
  755.             (epsilon2 (cadr epsilon*)))
  756.         (if (in? epsilon1 'F)
  757.             ((*valueslist* (list epsilon2))
  758.          (lambda (epsilon*)
  759.                (((applicate epsilon1)
  760.          epsilon*)
  761.         kappa)))
  762.             (wrong "bad procedure argument to apply")))
  763.       (wrong "wrong number of arguments")))
  764.  
  765. ; Though procedures that return multiple values cannot be defined using
  766. ; the mechanisms in RRRS, the following shows how they can be accomodated
  767. ; within this semantics.  The name VALUES-LIST is taken from Common Lisp.
  768.  
  769. (define ((*valueslist* epsilon*) kappa)
  770.   (if (= (length epsilon*) 1)
  771.       (let ((epsilon (car epsilon*)))
  772.     (if (in? epsilon 'EP)
  773.         ((*cdr* (list epsilon))
  774.          (lambda (epsilon*)
  775.                ((*valueslist* epsilon*)
  776.         (lambda (epsilon*)
  777.                   ((*car* (list epsilon))
  778.            (single
  779.                      (lambda (epsilon)
  780.                        (kappa (cons epsilon epsilon*)))))))))
  781.         (if (in? epsilon 'MISC)
  782.         (if (eq? (project epsilon 'MISC) 'null)
  783.             (kappa '())
  784.             (wrong "improper list argument to values-list"))
  785.         (wrong "improper list argument to values-list"))))
  786.       (wrong "wrong number of arguments")))
  787.  
  788. ; The semantics of call-with-current-continuation would be much simpler
  789. ; if procedures did not have to be tagged by locations.
  790.  
  791. (define ((*call/cc* epsilon*) kappa)
  792.   (if (= (length epsilon*) 1)
  793.       (let ((epsilon (car epsilon*)))
  794.         (if (in? epsilon 'F)
  795.         (lambda (sigma)            ; yuk
  796.               (if (in? (new sigma) 'L)
  797.           ((((applicate epsilon)
  798.              (list (inject (list (project (new sigma) 'L)
  799.                      (lambda (epsilon*)
  800.                        (lambda (kappa@)
  801.                          (kappa epsilon*))))
  802.                    'F)))
  803.             kappa)
  804.            (((update (project (new sigma) 'L))
  805.              *unspecified*)
  806.             sigma))
  807.           ((wrong "out of memory") sigma)))
  808.         (wrong
  809.           "bad procedure argument to call-with-current-continuation")))
  810.       (wrong "wrong number of arguments")))
  811.  
  812. ; Initial environments, stores, continuations, for testing.
  813.  
  814. ; To avoid special treatment for a "top-level" environment, the
  815. ; semantics assumes that all variables are bound to something.
  816. ; For testing, however, I'm only going to use x1, x2, ... as my
  817. ; global variables.
  818.  
  819. (define *rho_init*
  820.   '((x1 -1)
  821.     (x2 -2)
  822.     (x3 -3)
  823.     (x4 -4)
  824.     (x5 -5)
  825.     (x6 -6)
  826.     (x7 -7)
  827.     (x8 -8)
  828.     (x9 -9)
  829.     (zero? -10)
  830.     (<? -11)
  831.     (+ -12)
  832.     (- -13)
  833.     (* -14)
  834.     (cons -15)
  835.     (car -16)
  836.     (cdr -17)
  837.     (set-car! -18)
  838.     (set-cdr! -19)
  839.     (list -20)
  840.     (null? -21)
  841.     (eq? -22)
  842.     (apply -23)
  843.     (call-with-current-continuation -24)))
  844.  
  845. ; Note that the location tags normally won't be the same as the
  846. ; locations in which the procedures are stored.
  847.  
  848. (define *sigma_init*
  849.   `((-10 ,(inject (list -10 *zero?*) 'F))
  850.     (-11 ,(inject (list -11 *<*) 'F))
  851.     (-12 ,(inject (list -12 *+*) 'F))
  852.     (-13 ,(inject (list -13 *-*) 'F))
  853.     (-14 ,(inject (list -14 ***) 'F))
  854.     (-15 ,(inject (list -15 *cons*) 'F))
  855.     (-16 ,(inject (list -16 *car*) 'F))
  856.     (-17 ,(inject (list -17 *cdr*) 'F))
  857.     (-18 ,(inject (list -18 *set-car!*) 'F))
  858.     (-19 ,(inject (list -19 *set-cdr!*) 'F))
  859.     (-20 ,(inject (list -20 *list*) 'F))
  860.     (-21 ,(inject (list -21 *null?*) 'F))
  861.     (-22 ,(inject (list -22 *eq?*) 'F))
  862.     (-23 ,(inject (list -23 *apply*) 'F))
  863.     (-24 ,(inject (list -24 *call/cc*) 'F))))
  864.     
  865.  
  866. (define rho_init
  867.   (lambda (I)
  868.     (let ((entry (assq I *rho_init*)))
  869.       (if entry
  870.           (cadr entry)
  871.           (call-with-current-continuation
  872.             (lambda (k)
  873.               (set! *continue* k)
  874.               (error "Variable not bound in rho_init" I)))))))
  875.  
  876. (define sigma_init
  877.   (lambda (alpha)
  878.     (let ((entry (assq alpha *sigma_init*)))
  879.       (if entry
  880.           (list (cadr entry) #t)
  881.           (list *unspecified*
  882.                 (if (negative? alpha)
  883.                     #t
  884.                     #f))))))
  885.  
  886. (define kappa_init
  887.   (lambda (epsilon*)
  888.     (lambda (sigma)
  889.       (set! *store* sigma)       ; a side effect for testing purposes
  890.       epsilon*)))
  891.  
  892. ; Some code to simplify testing.
  893.  
  894. (define x)             ; in U --> K --> C
  895. (define y)             ; in K --> C
  896. (define z)             ; in C
  897. (define w)             ; expressed value result
  898. (define *store*        ; store result, side effected by kappa_init
  899.   sigma_init)          ; for convenience in testing.
  900.  
  901. (define (run exp)
  902.   (set! x (E-eval exp))
  903.   (set! y (x rho_init))
  904.   (set! z (y kappa_init))
  905.   (set! w (z *store*))
  906.   w)
  907.  
  908. ; ----- Examples -----
  909.  
  910. (define examples
  911.   '(
  912.  
  913.     ;; length
  914.  
  915.     (set! x1 (list 1 2 3 4 5 6 7 8 9 10))
  916.  
  917.     (set! x2
  918.       (lambda (l)
  919.         (if (null? l) 0 (+ 1 (x2 (cdr l))))))
  920.  
  921.     (x2 x1)
  922.  
  923.     ;; memq
  924.  
  925.     (set! x3 (list 'a 'b 'c 'd))
  926.  
  927.     (car (cdr x3))
  928.  
  929.     (set! x4
  930.       (lambda (x l)
  931.         (if (null? l)
  932.         #f
  933.         (if (eq? x (car l))
  934.             #t
  935.             (x4 x (cdr l))))))
  936.  
  937.     (x4 'e x3)
  938.     (x4 'b x3)
  939.     (set-cdr! x3 (list))
  940.     (x4 'b x3)
  941.  
  942.     ;; factorial
  943.  
  944.     ((lambda (fact)
  945.        (set! fact
  946.          (lambda (n)
  947.            (if (zero? n)
  948.            1
  949.            (* n (fact (- n 1))))))
  950.        (fact 10))
  951.      0)
  952.  
  953.     ;; iota
  954.  
  955.     (set! x5
  956.       (lambda (n)
  957.         ((lambda (loop)
  958.            (set! loop
  959.              (lambda (n l)
  960.                (if (zero? n)
  961.                l
  962.                (loop (- n 1) (cons n l)))))
  963.            (loop n (list)))
  964.          0)))
  965.  
  966.     (set! x6 (x5 10))
  967.     (car (cdr (cdr x6)))
  968.     (x2 x6)
  969.  
  970.     ;; apply
  971.  
  972.     (apply + (list 3 4))
  973.  
  974.     ;; call-with-current-continuation
  975.  
  976.     (+ (+ 3
  977.       (call-with-current-continuation
  978.        (lambda (k1)
  979.          (set! x7 k1)
  980.          4)))
  981.        (* (call-with-current-continuation
  982.        (lambda (k2)
  983.          (set! x8 k2)
  984.          5))
  985.       6))
  986.  
  987.     (x8 10)
  988.     (x7 1)
  989.     (x8 10)
  990.     (x7 1)
  991.     ))
  992.  
  993. (define (test)
  994.   (for-each (lambda (exp)
  995.           (write exp)
  996.           (newline)
  997.           (write (run exp))
  998.           (newline)
  999.           (newline))
  1000.         examples))
  1001.