;;; semantic-dispatch.scm
;;;
;;; Procedures to invoke the appropriate semantic functions 
;;; based on the syntax of the provided expression.
;;;
;;; 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
;;;
;;; -------------------------------------------------------------------------
;; Primary non-top-level dispatch function for expression meaning
;; todo: prevent dup symbols in arg lists; other syntactical checks.
    
(define (expression-meaning e)
  (if (not (pair? e))
      (if (symbol? e)
          (expression-meaning-identifier e)
          (expression-meaning-constant e))
      (if (list? (ds:rest e))
          (case (ds:first e)
            ((lambda) (expression-guard-min e 3
                       (lambda ()
                         (expression-meaning-abstraction 
                          (transform-internal-definitions (ds:rest e))))))
                          ; version without internal definitions: (expression-meaning-abstraction (ds:rest E))
            ((if)     (expression-meaning-if (ds:rest e)))
            ((set!)   (expression-guard e 3
                       (lambda ()
                         (expression-meaning-assignment (ds:second e) (ds:third e)))))
            ((quote)  (expression-guard e 2
                       (lambda ()
                         (expression-meaning-quote (ds:second e)))))
            ;; above are defined by DS; below are derived
            ((let)    (expression-guard-min e 3 
                       (lambda ()
                         (if (symbol? (ds:second e))
                             (expression-meaning-named-let (ds:second e) (ds:third e) (cdddr e))
                             (expression-meaning-let (ds:second e) (cddr e))))))
            ((letrec) (expression-guard-min e 3 
                       (lambda ()
                         (expression-meaning-letrec (ds:second e) (cddr e)))))
            ((begin)  (expression-meaning-begin (ds:rest e)))
            (else     (expression-meaning-application (ds:first e) (ds:rest e))))
          (malformed-expression (ds:first e)))))

;; constant-meaning 
;;
;; The definition of this function was deliberately omitted from the Scheme 
;; DS, to avoid complicating the semantics.  Similarly, it is defined here 
;; by effectively snarfing constants from the host Scheme implementation.
;;
;; The meaning of a constant is the constant itself.
   
(define (constant-meaning k) k)

;; quoted expressions must be transferred from host Scheme to store
    
(define (expression-meaning-quote e)
  (lambda (r k)
    (lambda (s)
      ((ds:host-value->value e ds:immutable-cons k) s))))

;; ds:immutable-cons is a direct copy of the auxiliary function 'cons',
;; with a reference to 'true' changed to 'false'.  This supports the
;; creation of immutable pairs.  'cons' was copied to avoid modifying
;; a DS-defined procedure.
;;
;; immutable-cons : E* -> K -> C
  
(define ds:immutable-cons
  (ds:twoarg 
   (lambda (e1 e2 k)
     (lambda (s)
       (if (ds:location? (ds:new s))
           ((lambda (s-prime)
              (if (ds:location? (ds:new s-prime))
                  ((ds:send (ds:inject-value 
                             (ds:sequence (ds:project-location (ds:new s))
                                          (ds:project-location (ds:new s-prime))
                                          ds:false))
                            k)
                   (ds:update (ds:project-location (ds:new s-prime)) e2 s-prime))
                  (ds:wrong "out of memory" s-prime)))
            (ds:update (ds:project-location (ds:new s)) e1 s))
           ((ds:wrong "out of memory") s))))))

   
(define (expression-sequence-meaning e*)
  (if (zero? (length e*))
      (expression-meaning-null)
      (expression-meaning-sequence (ds:first e*) (ds:rest e*))))

   
(define (command-sequence-meaning g*)
  (if (zero? (length g*))
      (command-meaning-null)
      (command-meaning-sequence (ds:first g*) (ds:rest g*))))

   
(define (expression-meaning-if e)
  (case (length e)
    ((2) (expression-meaning-if-then (ds:first e) (ds:second e)))
    ((3) (expression-meaning-if-then-else (ds:first e) (ds:second e) (ds:third e)))
    (else (malformed-expression 'if))))

   
(define (expression-meaning-abstraction e)
  (if (< (length e) 2)
  (begin (display e)
      (malformed-expression 'lambda))      ; this won't handle transformed syntax; do at higher level
      (let* ((param-list (ds:first e))
             (expr-pair (split-list-at-end (ds:rest e)))
             (g* (car expr-pair))
             (e0 (cdr expr-pair)))
        (cond 
          ((list? param-list)
           (expression-meaning-abstraction-fixed-arity param-list g* e0))
          ((pair? param-list)
           (let ((params-pair (split-list-at-end param-list)))
             (expression-meaning-abstraction-variable-arity (car params-pair) 
                                                            (cdr params-pair) 
                                                            g* 
                                                            e0)))
          (else (expression-meaning-abstraction-list-arity param-list g* e0))))))