;;; This file contains code from "Essentials of Programming Languages".
;;;
;;; Copyright (c) 1992, Massachusetts Institute of Technology

(load "drscheme-eopl.ss")
;; parser-etc.ss is based on EOPL appendices B-F
(load "parser-etc.ss")

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;

(define run
  (lambda (string-expression)
    (eval-exp (character-string-parser string-expression) init-env)))

;;; The following are derived from Figure F.4 : page 495 

(define eval-print
  (lambda (tree)
    (let ((result (eval-exp tree init-env)))
      (if (not (or (define? tree)
                   (definearray? tree)
                   (varassign? tree)
                   (arrayassign? tree)))
          (write result)))))

(define make-read-eval-print  ; by max@gac.edu 2000-03-14 from read-eval-print
  (lambda (eval-print)
    (lambda ()
      (display "--> ")
      (stream-for-each
       (lambda (tree)
         (eval-print tree)
         (newline)
         (display "--> "))
       (parse-token-seq parse-semicolon-terminated-form
                        (scan-char-seq scanner-start-state 
                                       (make-input-stream)))))))

(define read-eval-print (make-read-eval-print eval-print))

(define read-print (make-read-eval-print write))

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;

;; EOPL page 142 defines environments as finite functions, but this
;; won't work well when definitions are added to the language (p. 159),
;; since a definition should really add a new binding to the existing
;; top-level environment, rather than extending it to create a new environment.
;; (That way, any procedures closed over the top-level environment have
;; access to the new binding.  This permits recursion, including mutual
;; recursion.  Even procedures closed over an extension of the top-level
;; environment, rather than the top-level environment itself, ought to have
;; access to the new binding, provided it isn't shadowed by an inner binding.)
;; The definitions below produce an env ADT that can be used just like the one
;; on EOPL p. 142, but with the extra operation add-binding-to-env!.

(define-record empty-env ())
(define-record extended-env (syms vals base-env))

(define the-empty-env (make-extended-env '() '() (make-empty-env)))
(define extend-env make-extended-env)

(define apply-env
  (lambda (env sym)
    (variant-case env
      (empty-env () (error "no binding for symbol" sym))
      (extended-env
       (syms vals base-env)
       (letrec ((loop (lambda (syms vals)
                        (cond ((null? syms)
                               (apply-env base-env sym))
                              ((eq? (car syms) sym)
                               (car vals))
                              (else
                               (loop (cdr syms) (cdr vals)))))))
         (loop syms vals)))
      (else (error "illegal environment" env)))))

(define add-binding-to-env!
  (lambda (sym val env)
    (set-extended-env-syms! env (cons sym (extended-env->syms env)))
    (set-extended-env-vals! env (cons val (extended-env->vals env)))))

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;

;; EOPL p. 143:

(define-record prim-proc (prim-op))

(define apply-proc
  (lambda (proc args)
    (variant-case proc
      (prim-proc (prim-op) (apply-prim-op prim-op args))
      (closure
       (formals body env)
       (eval-exp body
                 (extend-env formals
                             args
                             env)))
      (else (error "Invalid procedure:" proc)))))

(define apply-prim-op
  (lambda (prim-op args)
    (case prim-op
      ((+) (+ (car args) (cadr args)))
      ((-) (- (car args) (cadr args)))
      ((*) (* (car args) (cadr args)))
      ((add1) (+ (car args) 1))
      ((sub1) (- (car args) 1))
      ((list) args)
      (else (error "Invalid prim-op name:" prim-op)))))

(define prim-op-names '(+ - * add1 sub1 list))

(define init-env 
  (extend-env
    prim-op-names
    (map make-prim-proc prim-op-names)
    the-empty-env))

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;

;; EOPL, p. 146:

(define true-value?
  (lambda (x)
    (not (zero? x))))

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;

;;; Second part of Figure 5.3.1 : page 149

(define eval-rands
  (lambda (rands env)
    (map (lambda (rand) (eval-exp rand env))
         rands)))

;;; Figure 5.3.2 : page 150

(define eval-exp
  (lambda (exp env)
    (variant-case exp
      (lit (datum) datum)
      (varref (var) (apply-env env var))
      (app (rator rands)
        (let ((proc (eval-exp rator env))
              (args (eval-rands rands env)))
          (apply-proc proc args)))
      (if (test-exp then-exp else-exp)
        (if (true-value? (eval-exp test-exp env))
            (eval-exp then-exp env)
            (eval-exp else-exp env)))
      (let (decls body)
        (let ((vars (map decl->var decls))
              (exps (map decl->exp decls)))
          (let ((new-env (extend-env vars
                           (eval-rands exps env) 
                           env)))
            (eval-exp body new-env))))
      (proc
       (formals body)
       (make-closure formals body env))
      (else (error "Invalid abstract syntax:" exp)))))

(define-record closure (formals body env))