;;; $Id: ch3-6-1-modified-in-class.scm,v 1.1 2006/03/28 22:16:44 leavens Exp $
;;; Interpreter with letrec and procedural representation of environments

(module ch3-6-1-modified-in-class (lib "typedscm.ss" "typedscm")
  
(provide read-eval-print eval-program run
         scan&parse just-scan
         run-all run-one equal-external-reps?)
  
(require (lib "list-index-find.scm" "lib342")
         (lib "test-suite.scm" "lib342"))

(defrep (environment (-> (symbol) Expressed-Value)))

;;;;;;;;;;;;;;;; top level and tests ;;;;;;;;;;;;;;;;

(deftype run (-> (string) datum))
(define run
  (lambda (string)
    (eval-program (scan&parse string))))

(deftype run-all (-> () void))
(define run-all
  (lambda ()
    (run-experiment run use-execution-outcome
      '(lang3-1 lang3-5 lang3-6) (all-tests))))

(deftype run-one (-> (symbol) datum))
(define run-one
  (lambda (test-name)
    (run-test run test-name)))

;; needed for testing
(deftype equal-external-reps? (-> (datum datum) boolean))
(define equal-external-reps?
  (lambda (x y)
    (equal? x y)))

;;;;;;;;;;;;;;;; grammatical specification ;;;;;;;;;;;;;;;;

(define the-lexical-spec
  '((whitespace (whitespace) skip)
    (comment ("%" (arbno (not #\newline))) skip)
    (identifier
      (letter (arbno (or letter digit "_" "-" "?")))
      symbol)
    (number (digit (arbno digit)) number)))

(define the-grammar
  '((program (expression) a-program)

    (expression (number) lit-exp)
    (expression (identifier) var-exp)   
    (expression
      (primitive "(" (separated-list expression ",") ")")
      primapp-exp)
    (expression
      ("if" expression "then" expression "else" expression)
      if-exp)
    (expression
      ("let" (arbno  identifier "=" expression) "in" expression)
      let-exp)
    (expression
      ("proc" "(" (separated-list identifier ",") ")" expression)
      proc-exp)
    (expression
      ("(" expression (arbno expression) ")")
      app-exp)
    (expression
      ("begin" expression (arbno ";" expression) "end")
      begin-exp)
    (expression                         
      ("letrec"
        (arbno identifier "(" (separated-list identifier ",") ")"
          "=" expression)
        "in" expression)
      letrec-exp)
    (expression
       ("namedlet" identifier
                     "(" (separated-list identifier "=" expression ",") ")"
                   expression)
       namedlet-exp)

    (primitive ("+")     add-prim)
    (primitive ("-")     subtract-prim)
    (primitive ("*")     mult-prim)
    (primitive ("add1")  incr-prim)
    (primitive ("sub1")  decr-prim)
    (primitive ("zero?") zero-test-prim)
    ))

(deftype show-the-datatypes (-> () (list-of datum)))
(define show-the-datatypes
  (lambda ()
    (sllgen:make-define-datatypes the-lexical-spec the-grammar)
    (sllgen:list-define-datatypes the-lexical-spec the-grammar)))

;; The following is generated by calling show-the-datatypes
;; (and then removing the outer lists, indenting, and renaming fields).
(define-datatype
  program
  program?
  (a-program (exp expression?)))

(define-datatype
  expression
  expression?
  (lit-exp (datum number?))
  (var-exp (id symbol?))
  (primapp-exp
   (prim primitive?)
   (rands (list-of expression?)))
  (if-exp
   (test-exp expression?)
   (true-exp expression?)
   (false-exp expression?))
  (let-exp
   (ids (list-of symbol?))
   (rands (list-of expression?))
   (body expression?))
  (proc-exp
   (ids (list-of symbol?))
   (body expression?))
  (app-exp
   (rator expression?)
   (rands (list-of expression?)))
  (begin-exp
   (first expression?)
   (rest (list-of expression?)))
  (letrec-exp
   (proc-names (list-of symbol?))
   (idss (list-of (list-of symbol?)))
   (bodies (list-of expression?))
   (letrec-body expression?))
  (namedlet-exp
   (proc-name symbol?)
   (ids (list-of symbol?))
   (exps (list-of expression?))
   (body expression?))
  )

(define-datatype
  primitive
  primitive?
  (add-prim)
  (subtract-prim)
  (mult-prim)
  (incr-prim)
  (decr-prim)
  (zero-test-prim)
  )

(deftype scan&parse (-> (string) program))
(define scan&parse
  (lambda (ptext)
    ((sllgen:make-string-parser the-lexical-spec the-grammar)
     ptext)))

(deftype just-scan (forall (TOK) (-> (string) (list-of TOK))))
(define just-scan
  (lambda (ptext)
    ((sllgen:make-string-scanner the-lexical-spec the-grammar)
     ptext)))

(deftype read-eval-print (-> () poof))
(define read-eval-print
  (lambda ()
    ((sllgen:make-rep-loop
      "--> "
      (lambda (pgm) (eval-program pgm))
      (sllgen:make-stream-parser 
       the-lexical-spec
       the-grammar)))))

;;; Domains for this interpreter:
;;;
;;; Expressed-Value = Number + ProcVal + List(Expressed-Value)
;;; Denoted-Value = Expressed-Value

;;; ADTs used

;;;;;;;;;;;;;;;; environment ;;;;;;;;;;;;;;;;
;;; Originally letrec1.scm -- procedural rep of environments

;; This can't be a module, because it uses procval->expressed, closure, etc.

;; type predicate
(deftype environment? (type-predicate-for environment))

;; constructors
(deftype empty-env (-> () environment))
(deftype extend-env
  (-> ((list-of symbol) (list-of Expressed-Value) environment) environment))
(deftype extend-env-recursively            ; for section 3.6
  (-> ((list-of symbol) (list-of (list-of symbol)) (list-of expression)
       environment)
      environment))

;; observers
(deftype apply-env
  (-> (environment symbol) Expressed-Value))
(deftype defined-in-env?                   ; added
  (-> (environment symbol) boolean))

(define environment? procedure?)

(define apply-env
  (lambda (env sym)
    (env sym)))

(define empty-env
  (lambda ()
    (lambda (sym)
      (eopl:error 'empty-env "No binding for: ~s" sym))))

(define extend-env
  (lambda (ids vals env)
    (lambda (sym)
      (let ((pos (list-index sym ids)))
        (if (<= 0 pos)
          (list-ref vals pos)
          (apply-env env sym))))))

(define extend-env-recursively
  (lambda (proc-names idss bodies old-env)
    (letrec ((rec-env
              (lambda (sym)
                (let ((pos (list-index sym proc-names)))
                  (if (<= 0 pos)
                      (procval->expressed
                       (closure (list-ref idss pos)
                                (list-ref bodies pos)
                                rec-env))
                      (apply-env old-env sym))))))
      rec-env)))

;;;;;;;;;;;;;;;; ProcVal ;;;;;;;;;;;;;;;;

(deftype procval? (type-predicate-for procval))
(deftype closure (-> ((list-of symbol) expression environment) procval))
(deftype apply-procval
  (-> (procval (list-of Expressed-Value)) Expressed-Value))

(define-datatype procval procval?
  (closure 
    (ids (list-of symbol?)) 
    (body expression?)
    (env environment?)))

(define apply-procval
  (lambda (proc args)
    (cases procval proc
      (closure (ids body env)
        (eval-expression body (extend-env ids args env))))))

;;; Anonymous figure : page 80

(deftype true-value? (-> (Expressed-Value) boolean))
(define true-value?
  (lambda (x)
    (not (zero? (expressed->number x)))))

;;;;;;;;; Expressed-Value ;;;;;;;;;;;;;;;;;;;;;;;;;

;; upcasts
(deftype number->expressed (-> (number) Expressed-Value))
(deftype procval->expressed (-> (Procval) Expressed-Value))
(deftype list->expressed (-> ((list-of Expressed-Value)) Expressed-Value))

;; downcasts
(deftype expressed->number (-> (Expressed-Value) number))
(deftype expressed->procval (-> (Expressed-Value) Procval))
(deftype expressed->list (-> (Expressed-Value) (list-of Expressed-Value)))

;; debugging
(deftype expressed->printable (-> (Expressed-Value) datum))

;; tests
(deftype number->expressed? (-> (Expressed-Value) boolean))
(deftype procval->expressed? (-> (Expressed-Value) boolean))
(deftype list->expressed? (-> (Expressed-Value) boolean))

(define-datatype Expressed-Value expval?
  (number->expressed (num number?))
  (procval->expressed (pv procval?))
  (list->expressed (lst (list-of expval?))))

(define expressed->number
  (lambda (ev)
    (cases Expressed-Value ev
      (number->expressed (num) num)
      (else (error "expressed->number passed non-number argument: " ev)))))

(define expressed->procval
  (lambda (ev)
    (cases Expressed-Value ev
      (procval->expressed (pv) pv)
      (else (error "expressed->procval passed non-procval argument: " ev)))))

(define expressed->list
  (lambda (ev)
    (cases Expressed-Value ev
      (list->expressed (lst) lst)
      (else (error "expressed->list passed non-list argument: " ev)))))

(define expressed->printable
  (lambda (ev)
    (cases Expressed-Value ev
      (number->expressed (num) (has-type datum num))
      (procval->expressed (pv)
        (cases procval pv
          (closure (ids body env)
           (has-type datum (list 'closure ids body "<env>")))))
      (list->expressed (lst)
         (has-type datum (map expressed->printable lst))))))

(define number->expressed?
  (lambda (ev)
    (cases Expressed-Value ev
      (number->expressed (num) #t)
      (else #f))))

(define procval->expressed?
  (lambda (ev)
    (cases Expressed-Value ev
      (procval->expressed (pv) #t)
      (else #f))))

(define list->expressed?
  (lambda (ev)
    (cases Expressed-Value ev
      (list->expressed (lst) #t)
      (else #f))))

;;;;;;;;;;;;;;;; the interpreter ;;;;;;;;;;;;;;;;

(deftype eval-program (-> (program) datum))
(define eval-program 
  (lambda (pgm)
    (cases program pgm
      (a-program (body)
        (expressed->printable (eval-expression body (init-env)))))))

(deftype eval-expression (-> (expression environment) Expressed-Value))
(define eval-expression 
  (lambda (exp env)
    (cases expression exp
      (lit-exp (datum)
        (number->expressed datum))
      (var-exp (id)
        (apply-env env id))
      (primapp-exp (prim rands)
        (let ((args (eval-rands rands env)))
          (apply-primitive prim args)))
      (if-exp (test-exp true-exp false-exp)
        (if (true-value? (eval-expression test-exp env))
          (eval-expression true-exp env)
          (eval-expression false-exp env)))
      (begin-exp (exp1 exps)
        (let loop ((acc (eval-expression exp1 env))
                   (exps exps))
          (if (null? exps) acc
            (loop (eval-expression (car exps) env) (cdr exps)))))
      (let-exp (ids rands body)
        (let ((args (eval-rands rands env)))
          (eval-expression
           body
           (extend-env ids args env))))
      (proc-exp (ids body) (procval->expressed (closure ids body env)))
      (app-exp (rator rands)
        (let ((proc (eval-expression rator env))
              (args (eval-rands rands env)))
          (if (procval->expressed? proc)
            (apply-procval (expressed->procval proc) args)
            (eopl:error 'eval-expression
              "Attempt to apply non-procedure ~s" proc))))
      (letrec-exp (proc-names idss bodies letrec-body)
        (eval-expression letrec-body
          (extend-env-recursively proc-names idss bodies env)))
      (namedlet-exp (proc-name ids exps body)
         (eval-expression (app-exp (var-exp proc-name)
                                   exps)
                          (extend-env-recursively (list proc-name)
                                                  (list ids)
                                                  (list body)
                                                  env)))
      (else (eopl:error 'eval-expression "Missing case:~s" exp))
      )))

(deftype eval-rands
  (-> ((list-of expression) environment) (list-of Expressed-Value)))
(define eval-rands
  (lambda (rands env)
    (map (lambda (x) (eval-rand x env)) rands)))

(deftype eval-rand (-> (expression environment) Expressed-Value))
(define eval-rand
  (lambda (rand env)
    (eval-expression rand env)))

(deftype apply-primitive
  (-> (primitive (list-of Expressed-Value)) Expressed-Value))
(define apply-primitive
  (lambda (prim args)
    (cases primitive prim
      (add-prim  () (number->expressed
                     (+ (expressed->number (car args))
                        (expressed->number (cadr args)))))
      (subtract-prim () (number->expressed
                         (- (expressed->number (car args))
                            (expressed->number (cadr args)))))
      (mult-prim  () (number->expressed
                      (* (expressed->number (car args))
                         (expressed->number (cadr args)))))
      (incr-prim  () (number->expressed
                      (+ (expressed->number (car args)) 1)))
      (decr-prim  () (number->expressed
                      (- (expressed->number (car args)) 1)))
      (zero-test-prim () (number->expressed
                          (if (zero? (expressed->number (car args))) 1 0)))
      )))

(deftype init-env (-> () environment))
(define init-env 
  (lambda ()
    (extend-env
      '(i v x)
      (map number->expressed '(1 5 10))
      (empty-env))))

) ;; end module