;; Interpreter, type checker, compiler, and compilation interpreter
;; for a typed source language with let, proc, and simple records.
;; The records in this language most closely resemble C structs.

;; Example:
;;    a { num x; (a -> num) f } in 
;;    let r = new a(10, proc(a r)10)
;;     in ([r.f] r)
;; The `new' form creates record instances, and the [ . ] form
;; accesses a field.

;; The language does not include `letrec', `cases', or even `if',
;; which means that it is not a useful langauge. But it demonstrates
;; in a relatively simple setting the compilation of named-field
;; access to direct vector lookups.

;; A well-typed program never raises an error, especially not a "no
;; such record" or "no such field" error.

;; An expval is
;;   * a number
;;   * a proc
;;   * a record
;;
;; A denval is an expval

;; Closures in the original language:
(define-datatype
 proc proc?
 (closure (ids (list-of symbol?))
          (body-exp expression?)
          (env environment?)))

;; Closures in the compiled language:
(define-datatype
 cproc cproc?
 (cclosure (body-exp cexpression?)
           (env environment?)))

;; Records in the original langauge:
(define-datatype
  record record?
  (a-record (rec-name symbol?) ;; needed to find fields
            (values vector?)))

;; For compiled records, we just use a vector. No rec-name is needed,
;; because field access has been compiled to position-based vector
;; lookups.

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

(define the-lexical-spec
  '((whitespace (whitespace) 
                skip)
    (id (letter (arbno (or letter digit "?")))
        make-symbol)
    (number ((or "" "-" "+") digit (arbno digit))
            make-number)))

(define the-grammar
  '((program ((arbno record-decl) "in" expression) a-program)

    (record-decl (id "{" (separated-list type id ";") "}")
                 a-record-decl)

    (expression (number) lit-exp)
    (expression (id) var-exp)
    (expression
      (primitive "(" (separated-list expression ",") ")")
      primapp-exp)
    (expression ("let"
                 (arbno id "=" expression)
                 "in"
                 expression)
                let-exp)
    (expression ("proc"
                 "(" (separated-list type id ",") ")"
                 expression)
                proc-exp)
    (expression ("(" expression (arbno expression) ")")
                app-exp)
    ;; -- records --
    (expression ("new" id "(" (separated-list expression ",") ")")
		new-exp)
    (expression ("[" expression "." id "]")
		field-exp)
                 
    (type (id) record-type)
    (type ("num") number-type)
    (type ("(" (arbno type) "->" type ")") 
          proc-type)
    
    (primitive ("+")     add-prim)
    (primitive ("-")     subtract-prim)
    (primitive ("*")     mult-prim)
    (primitive ("add1")  incr-prim)
    (primitive ("sub1")  decr-prim)))

(sllgen:make-define-datatypes the-lexical-spec
                              the-grammar)

(define-datatype cexpression cexpression?
   (lit-cexp (n number?))
   (var-cexp (frame-index number?)
             (position-in-frame number?))
   (primapp-cexp (prim primitive?)
                 (rands (list-of cexpression?)))
   (let-cexp (rands (list-of cexpression?))
             (body cexpression?))
   (proc-cexp (body cexpression?))
   (app-cexp (rator cexpression?)
             (rands (list-of cexpression?)))
   (new-cexp (args (list-of cexpression?)))
   (field-cexp (rec cexpression?)
               (pos number?)))


;;;;;;;;;;;;;;;; the interpreter ;;;;;;;;;;;;;;;;
;;;;;;;;;;; for the original language ;;;;;;;;;;;

; eval-program : program -> expval
(define eval-program 
  (lambda (pgm)
    (cases program pgm
      (a-program (decls body)
        (eval-expression body (empty-env) decls)))))

; eval-expression : expression env list-of-rec-decls -> expval
(define eval-expression 
  (lambda (exp env decls)
    (cases expression exp
      (lit-exp (datum) datum)
      (var-exp (id) (apply-env env id))
      (primapp-exp (prim rands)
        (let ((args (eval-rands rands env decls)))
          (apply-primitive prim args)))
      (let-exp (ids exps body-exp) 
               (eval-expression
                body-exp ;; expression
                (extend-env
                 ids ;; list-of-sym
                 (eval-rands exps env decls)
                 env)
                decls))
      (proc-exp (types ids body-exp)
                (closure ids
                         body-exp
                         env))
      (app-exp (rator rands)
               (apply-proc
                (eval-expression rator env decls)
                (eval-rands rands env decls)
                decls))
      ;; -- records --
      (new-exp (rec-name exprs)
               (make-record rec-name (eval-rands exprs env decls)))
      (field-exp (rec-expr field-id)
                 (let ((rec (eval-expression rec-expr env decls)))
                   (extract-field rec field-id decls))))))
  
; make-record : sym list-of-expval -> expval
(define (make-record rec-name vals)
  (a-record rec-name (list->vector vals)))
  
; extract-field : expval sym list-of-rec-decls
(define (extract-field val id decls)
  (cond
    [(record? val)
     (cases record val
       (a-record (rec-name vals)
                 (vector-ref vals 
                             (find-field-pos rec-name id decls))))]
    [else
     (eopl:error 'extract-field "not a record")]))
       
; eval-rands : list-of-expression env list-of-rec-decls
;               -> list-of-expval
(define eval-rands
  (lambda (rands env decls)
    (map (lambda (x) (eval-expression x env decls)) rands)))

; apply-proc : expval list-of-expressions list-of-rec-decls -> expval
(define (apply-proc func args decls)
  (cond
    [(proc? func) (cases proc func
                         (closure (ids body-exp env)
                                  (eval-expression
                                   body-exp
                                   (extend-env
                                    ids
                                    args
                                    env)
                                   decls)))]
    [else (eopl:error 'apply-proc "not a func")]))

; apply-primitive : primitive list-of-expval -> expval
;  (apply-prim (add-prim) '(0 3)) = 3
;  (apply-prim (sub-prim) '(1 2)) = -1
(define apply-primitive
  (lambda (prim args)
    (cases primitive prim
      (add-prim  () (+ (car args) (cadr args)))
      (subtract-prim () (- (car args) (cadr args)))
      (mult-prim  () (* (car args) (cadr args)))
      (incr-prim  () (+ (car args) 1))
      (decr-prim  () (- (car args) 1)))))

;;;;;;;;;;;;;;;; the type checker ;;;;;;;;;;;;;;;;
;;;;;;;;;;;; for the original language ;;;;;;;;;;;

; type-of-program : program -> type

(define type-of-program 
  (lambda (pgm)
    (cases program pgm
      (a-program (decls body)
        (type-of-expression body (empty-env) decls)))))

; type-of-expression : expression env list-of-rec-decls -> expval
(define type-of-expression 
  (lambda (exp env decls)
    (cases expression exp
      (lit-exp (datum) (number-type))
      (var-exp (id) (apply-env env id))
      (primapp-exp (prim rands)
        (type-of-application
          (type-of-primitive prim)
          (types-of-expressions rands env decls)
          prim rands exp))
      (let-exp (ids exps body-exp)
               (type-of-expression
                body-exp
                (extend-env
                 ids
                 (types-of-expressions exps env decls)
                 env)
                decls))
      (proc-exp (types ids body)
                (proc-type types
                           (type-of-expression
                            body
                            (extend-env 
                             ids
                             types
                             env)
                            decls)))
      (app-exp (rator rands)
               (type-of-application
                (type-of-expression rator env decls)
                (types-of-expressions rands env decls)
                rator rands exp))
      ;; -- records --
      (new-exp (rec-name exprs)
               (cases record-decl (find-decl rec-name decls)
                 (a-record-decl (rec-name field-types field-ids)
                    ;; Check `new a' like a function
	            ;; that takes arguments matching the
                    ;; field types, and that returns a
                    ;; value of record type:
                    (type-of-application
                     (proc-type field-types
                                (record-type rec-name))
                     (types-of-expressions exprs env decls)
                     rec-name exprs exp))))
      (field-exp (rec-expr field-id)
                 ;; Find out what kind of record we have by 
                 ;; typing rec-expr:
                 (cases type (type-of-expression rec-expr env decls)
                   (record-type (rec-name)
                      ;; Find the field type; raise an exception
                      ;;  if the field isn't there.
                      (find-field-type rec-name field-id decls))
                   (else (eopl:error 
                          'field-access 
                          "expression's type not a record type: ~e"
                          rec-expr)))))))

; types-of-expression : list-of-expression env list-of-rec-decls 
;                       -> list-of-types
(define types-of-expressions
  (lambda (exprs env decls)
    (map (lambda (x) (type-of-expression x env decls)) exprs)))

; type-of-application : type lof-type 
;                       expr lof-expr expr ; for err msgs
;                       -> type
(define type-of-application
  (lambda (rator-type rand-types rator rands exp)
    (cases type rator-type
      (proc-type (arg-types result-type)
        (if (= (length arg-types) (length rand-types))
          (begin 
            (for-each
              check-equal-type!
              rand-types arg-types rands)
            result-type)
          (eopl:error 'type-of-expression
            (string-append
              "Wrong num of arguments in expression ~s:"
              "~%expected ~s~%got ~s")
            exp arg-types rand-types)))
      (else
        (eopl:error 'type-of-expression
          "Rator not a proc type:~%~s~%had type ~s"   
          rator rator-type)))))

; type-of-primitive : primitive -> type
(define type-of-primitive
  (lambda (prim)
    (cases primitive prim
      (add-prim ()
        (proc-type (list (number-type) (number-type)) (number-type)))
      (subtract-prim ()
        (proc-type (list (number-type) (number-type)) (number-type)))
      (mult-prim ()
        (proc-type (list (number-type) (number-type)) (number-type)))
      (incr-prim ()
        (proc-type (list (number-type)) (number-type)))
      (decr-prim ()
        (proc-type (list (number-type)) (number-type))))))

; check-equal-type! : type type 
;                     expr ; for err msg
;                     -> 
(define check-equal-type!
  (lambda (t1 t2 exp)
    (if (equal? t1 t2) 
        #t
        (eopl:error 'check-equal-type!
          "Types didn't match: ~s != ~s in~%~s"
          t1 t2 exp))))

;;;;;;;;;;;;;;;;;;;; compiler ;;;;;;;;;;;;;;;;;;;;

(define-datatype cprogram cprogram?
    (a-cprogram (expr cexpression?)))

; compile-program : program -> cprogram
(define compile-program 
  (lambda (pgm)
    (cases program pgm
      (a-program (decls body)
                 (a-cprogram
                  (compile-expression body (empty-env) decls))))))

; compile-expression : expression env list-of-rec-decls 
;                      -> cexpression
(define compile-expression 
  (lambda (exp env decls)
    (cases expression exp
      (lit-exp (datum) (lit-cexp datum))
      (var-exp (id) (lexical-position-in-env env id))
      (primapp-exp (prim rands)
        (let ((crands (compile-rands rands env decls)))
          (primapp-cexp prim crands)))
      (let-exp (ids exps body-exp) 
               (let ([cexps (compile-rands exps env decls)]
                     [types (types-of-expressions exps env decls)])
                 (let ([cbody-exp (compile-expression 
                                   body-exp 
                                   (extend-env
                                    ids
                                    types
                                    env)
                                   decls)])
                   (let-cexp cexps cbody-exp))))
      (proc-exp (types ids body-exp)
                (let ([cbody-exp (compile-expression
                                  body-exp
                                  (extend-env
                                   ids
                                   types
                                   env)
                                  decls)])
                  (proc-cexp cbody-exp)))
      (app-exp (rator rands)
               (app-cexp
                (compile-expression rator env decls)
                (compile-rands rands env decls)))
      ;; -- records ---
      (new-exp (rec-name exprs)
	       ;; We can forget the rec-name, now
               (new-cexp (compile-rands exprs env decls)))
      (field-exp (rec-expr field-id)
                 (field-cexp
                  (compile-expression rec-expr env decls)
		  ;; Using the type of rec-expr, find the field
		  ;;  position in the correct record; we can then
		  ;;  throw away the field-id.
                  (cases type (type-of-expression rec-expr env decls)
                    (record-type (rec-name)
                        (find-field-pos rec-name field-id decls))
                    (else (eopl:error 
                           'compile 
                           "not a record expression"))))))))
  
(define (compile-rands rands env decls)
  (map (lambda (rand)
         (compile-expression rand env decls))
       rands))

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; new interpreter

; eval-cprogram : cprogram -> expval
(define eval-cprogram 
  (lambda (pgm)
    (cases cprogram pgm
      (a-cprogram (body)
        (eval-cexpression body (empty-env))))))

; eval-cexpression : cexpression env -> expval
(define eval-cexpression 
  (lambda (exp env)
    (cases cexpression exp
      (lit-cexp (datum) datum)
      (var-cexp (frame pos)
                (apply-lexical-address-to-env env frame pos))
      (primapp-cexp (prim rands)
        (let ((args (eval-crands rands env)))
          (apply-primitive prim args)))
      (let-cexp (exps body-exp) 
                (eval-cexpression
                 body-exp ;; expression
                 (extend-env
                  (map (lambda (x) 'dont-care) exps) ;; list-of-sym
                  (eval-crands exps env)
                  env)))
      (proc-cexp (body-exp)
                 (cclosure body-exp
                           env))
      (app-cexp (rator rands)
                (apply-cproc
                 (eval-cexpression rator env)
                 (eval-crands rands env)))
      ;; -- records --
      (new-cexp (args)
		;; Evaluate all the field arguments and
		;; put them into a vector:
                (list->vector (eval-crands args env)))
      (field-cexp (rec-expr pos)
		  ;; Evaluate rec-expr to get a record, which is
		  ;; represented by a vector, and pull the value
		  ;; out of the vector at position `pos':
                  (vector-ref (eval-cexpression rec-expr env)
                              pos)))))

; apply-proc : expval list-of-cexpressions -> expval
(define (apply-cproc func args)
  (cond
    [(cproc? func) (cases cproc func
                          (cclosure (body-exp env)
                                    (eval-cexpression
                                     body-exp
                                     (extend-env
                                      (map (lambda (x) 'dont-care)
                                           args)
                                      args
                                      env))))]
    [else (eopl:error 'apply-proc "not a func")]))


; eval-crands : list-of-cexpression env -> list-of-expval
(define eval-crands
  (lambda (rands env)
    (map (lambda (x) (eval-cexpression x env)) rands)))

;;;;;;;;;;;;;;;; record helpers ;;;;;;;;;;;;;;;;

; find-decl : sym list-of-rec-decls -> rec-decl
(define (find-decl rec-name decls)
  (cond
    [(null? decls)
     (eopl:error 'find-decl "record type not declared: ~a" rec-name)]
    [else (cases record-decl (car decls)
            (a-record-decl (name field-types field-ids)
                           (cond
                             [(eq? rec-name name)
                              (car decls)]
                             [else
                              (find-field-pos rec-name id 
                                              (cdr decls))])))]))

; find-field : sym sym list-of-rec-decls (num list-of-types -> T1)
;              -> T1
(define (find-field rec-name id decls f)
  (cases record-decl (find-decl rec-name decls)
    (a-record-decl (name field-types field-ids)
                   (let ((pos (env-find-position id field-ids)))
                     (if pos
                         (f pos field-types)
                         (eopl:error 
                          'find-field
                          "no field named ~a in record type ~a"
                          id rec-name))))))

; find-field-pos : sym sym list-of-rec-decls -> num
(define (find-field-pos rec-name id decls)
  (find-field rec-name id decls (lambda (pos field-types) pos)))

; find-field-type : sym sym list-of-rec-decls -> type
(define (find-field-type rec-name id decls)
  (find-field rec-name id decls (lambda (pos field-types) 
                                  (list-ref field-types pos))))

;;;;;;;;;;;;;;;; environments ;;;;;;;;;;;;;;;;

;; General-purpose environment, works for original langugae, compiled
;; language, and even type environments.

(define-datatype environment environment?
  (empty-env-record)
  (extended-env-record
    (syms (list-of symbol?))
    (vec vector?)
    (env environment?)))

; empty-env : -> env
(define empty-env
  (lambda ()
    (empty-env-record)))

; extend-env : list-of-sym list-of-any env -> env 
(define extend-env
  (lambda (syms vals env)
    (extended-env-record syms (list->vector vals) env)))

; apply-env : env sym -> any
(define apply-env
  (lambda (env sym)
    (cases environment env
      (empty-env-record ()
        (eopl:error 'apply-env "No binding for ~s" sym))
      (extended-env-record (syms vals env)
        (let ((position (env-find-position sym syms)))
          (if (number? position)
              (vector-ref vals position)
              (apply-env env sym)))))))

; apply-lexical-address-to-env : env frame pos -> any
(define apply-lexical-address-to-env
  (lambda (env frame pos)
    (cases environment env
      (empty-env-record ()
        (eopl:error 'apply-lex-pos-env "No more frames"))
      (extended-env-record (syms vals env)
        (if (zero? frame)
            (vector-ref vals pos)
            (apply-lexical-address-to-env
             env
             (- frame 1)
             pos))))))

; lexical-position-in-env : env sym -> cexp
(define lexical-position-in-env
  (lambda (env sym)
    (cases environment env
      (empty-env-record ()
        (eopl:error 'lex-pos-in-env "No binding for ~s" sym))
      (extended-env-record (syms vals env)
        (let ((position (env-find-position sym syms)))
          (if (number? position)
              (var-cexp 0 position)
              (cases cexpression (lexical-position-in-env env sym)
                     (var-cexp (frame pos)
                               (var-cexp (+ frame 1) pos))
                     (else 'impossible))))))))

;; Environment helper functions

; env-find-position : sym list-of-symbols -> num-or-#f
(define env-find-position 
  (lambda (sym los)
    (list-find-position sym los)))

; list-find-position : sym list-of-symbols -> num-or-#f
(define list-find-position
  (lambda (sym los)
    (list-index (lambda (sym1) (eqv? sym1 sym)) los)))

; list-index : pred list-of-symbols -> num-or-#f
(define list-index
  (lambda (pred ls)
    (cond
      ((null? ls) #f)
      ((pred (car ls)) 0)
      (else (let ((list-index-r 
                   (list-index pred (cdr ls))))
              (if (number? list-index-r)
                (+ list-index-r 1)
                #f))))))

;;;;;;;;;;;;;;;; top level ;;;;;;;;;;;;;;;;

(define scan&parse
  (sllgen:make-string-parser the-lexical-spec the-grammar))

(define (run str)
  (eval-program (scan&parse str)))

(define (type-check str)
  (type-of-program (scan&parse str)))

(define (compile str)
  (compile-program (scan&parse str)))

(define (compile&run str)
  (eval-cprogram (compile-program (scan&parse str))))


(define simple-program
  "a { num x } in [new a(10) . x]")
;; produces 10

(define simple-program2 
  "a { num x; (num -> num) f } 
   in 
   let r = new a(10, proc(num x)+(x,1))
     in ([r.f] [r.x])")
;; produces 11