;;; Definitions for the semantic functions from the R5RS DS, Section 7.2.3
;;;
;;; This module is intended to remain closely equivalent to the R5RS DS,
;;; and should not be changed without good reason.
;;;
;;; Copyright (C) 2002 Anton van Straaten <anton@ppsolutions.com>
;;;
;;; This program is free software; you can redistribute it and/or
;;; modify it under the terms of the GNU General Public License, 
;;; version 2, as published by the Free Software Foundation.
;;;
;;; This program is distributed in the hope that it will be useful, 
;;; but WITHOUT ANY WARRANTY; without even the implied warranty of
;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
;;; GNU General Public License for more details.
;;;
;;; You should have received a copy of the GNU General Public License
;;; along with this program; if not, see http://www.gnu.org/copyleft/gpl.html
;;;
;;; -------------------------------------------------------------------------

  
(define (expression-meaning-constant k)
  (lambda (r kappa)
    (ds:send (constant-meaning k) kappa)))

  
(define (expression-meaning-identifier i)
  (lambda (r k)
    (ds:hold (ds:lookup r i)
             (ds:single 
              (lambda (e) 
                (if (eq? e ds:undefined)
                    (ds:wrong "undefined variable")
                    (ds:send e k)))))))

  
(define (expression-meaning-application e0 e*)
  (lambda (r k)
    ((expression-sequence-meaning
      (ds:permute (ds:append (ds:sequence e0) e*)))
     r
     (lambda (e*) 
       ((lambda (e*) ((ds:applicate (ds:first e*) (ds:rest e*)) k))
        (ds:unpermute e*))))))

  
(define (expression-meaning-abstraction-fixed-arity i* g* e0)
  (lambda (r k)
    (lambda (s)
      (if (ds:location? (ds:new s))
          ((ds:send 
            (ds:inject-value
             (ds:sequence 
              (ds:project-location (ds:new s))
              (lambda (e* k-prime)
                (if (= (ds:length e*) (ds:length i*))
                    (ds:tievals 
                     (lambda (a*)
                       ((lambda (r-prime)
                          ((command-sequence-meaning g*)
                           r-prime
                           ; delay required to avoid out-of-order evaluation of final expression
                           (delay ((expression-meaning e0) r-prime k-prime))))
                        (ds:extends r i* a*)))
                     e*)
                    (ds:wrong "wrong number of arguments")))))
            k)
           (ds:update (ds:project-location (ds:new s)) ds:unspecified s))
          ((ds:wrong "out of memory") s)))))

  
(define (expression-meaning-abstraction-variable-arity i* i g* e0)
  (lambda (r k)
    (lambda (s)
      (if (ds:location? (ds:new s))
          ((ds:send 
            (ds:inject-value 
             (ds:sequence 
              (ds:project-location (ds:new s))
              (lambda (e* k-prime)
                (if (>= (ds:length e*) (ds:length i*))
                    (ds:tievalsrest
                     (lambda (a*)
                       ((lambda (r-prime)
                          ((command-sequence-meaning g*) 
                           r-prime 
                            ; delay required to avoid out-of-order evaluation of final expression
                           (delay ((expression-meaning e0) r-prime k-prime))))
                        (ds:extends r (ds:append i* (ds:sequence i)) a*)))
                     e*
                     (ds:length i*))
                    (ds:wrong "too few arguments")))))
            k)
           (ds:update (ds:project-location (ds:new s)) ds:unspecified s))
          ((ds:wrong "out of memory") s)))))

  
(define (expression-meaning-abstraction-list-arity i g* e0)
  (expression-meaning-abstraction-variable-arity (ds:sequence) i g* e0))

  
(define (expression-meaning-if-then-else e0 e1 e2)
  (lambda (r k)
    ((expression-meaning e0) 
     r 
     (ds:single (lambda (e) 
                  (if (ds:truish e) 
                      ((expression-meaning e1) r k)
                      ((expression-meaning e2) r k)))))))

  
(define (expression-meaning-if-then e0 e1)
  (lambda (r k)
    ((expression-meaning e0) 
     r 
     (ds:single (lambda (e) 
                  (if (ds:truish e) 
                      ((expression-meaning e1) r k)
                      (ds:send ds:unspecified k)))))))

;;; R5RS comment: Here and elsewhere, any expressed value other
;;; than 'undefined' may be used in place of 'unspecified'.

  
(define (expression-meaning-assignment i e)
  (lambda (r k)
    ((expression-meaning e) 
     r 
     (ds:single (lambda (e) 
                  (ds:assign (ds:lookup r i) 
                             e 
                             (ds:send ds:unspecified k)))))))

  
(define (expression-meaning-null)
  (lambda (r k)
    (k (ds:sequence))))

  
(define (expression-meaning-sequence e0 e*)
  (lambda (r k)
    ((expression-meaning e0) 
     r 
     ;; note lowercase e0 shadows uppercase E0 in case-insensitive Scheme; OK in this instance.
     (ds:single (lambda (e0) 
                  ((expression-sequence-meaning e*) 
                   r 
                   (lambda (e*) 
                     (k (ds:append (ds:sequence e0) e*)))))))))

;; Use of 'force' is required to compensate for delay, used above to avoid
;; out-of-order evaluation of the final expression in a command sequence.
  
(define (command-meaning-null)
  (lambda (r theta) (force theta)))

  
(define (command-meaning-sequence g0 g*)
  (lambda (r theta)
    ((expression-meaning g0) 
     r
     (lambda (e*) ((command-sequence-meaning g*) r theta)))))