;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;;                     Tiny Scheme Interpreter                      ;;;
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;; Table of contents:
;;; 1. class definitions for environments
;;; 2. main loop
;;;      - tiny-scheme: entry point for interpreter
;;;      - read-eval-print loop
;;;      - global variables
;;;      - error processing
;;; 3. debugger
;;;      - to be filled in by you
;;; 4. compiler definitions
;;;      - compiler error
;;;      - compile generic function
;;;      - compile combination generic function
;;; 5. environment utilities
;;;      - lookup binding
;;;      - define binding
;;;      - unbound-variable error
;;; 6. evaluation
;;;      - eval generic function
;;;      - eval combination generic function
;;;      - apply generic function
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;


;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;; Class Definitions:
;;; Bindings, Frames, Environments, and Closures -- follows closely the
;;; environment model taking advantage of the object-oriented features
;;; of Swindle.
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;

;;; A binding has a symbol and a value.
(defstruct <binding>
  (symbol <symbol>)
  (value  <top>))

;;; A frame is a list of bindings.
(defstruct <frame>
  (bindings <list>)) ; of bindings

;;; A top-level environment is just a frame.
(defstruct (<env> <frame>))

;;; A nested environment is an environment (i.e., frame) and a previous
;;; environment.
(defstruct (<nested-env> <env>)
  (prev <env>))

;;; A closure has a list of argument symbols, a body expression, and an
;;; environment.
(defstruct <closure>
  (args <list>) ; of symbols
  (body <top>)
  (env  <env>))


;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;; Entry Point for the Interpreter, Global Variables, and the
;;; Read-Eval-Print loop.
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;

;;; This is the top-level enviornment for the interpreter.
(define *ts:top-level-env* (make-env null))

;;; Add bindings in the top-level environment for a set of primitives.
;;; Feel free to add more primitives.
(define (ts:initialize-environment)
  (set! *ts:top-level-env* (make-env null))
  (env-defines *ts:top-level-env*
               (list (cons '+ +)
                     (cons '- -)
                     (cons '* *)
                     (cons '/ /)
                     (cons '= =)
                     (cons '< <)
                     (cons '<= <=)
                     (cons 'eq? eq?)
                     (cons 'not not)
                     (cons 'null null)
                     (cons 'cons cons)
                     (cons 'null? null?)
                     (cons 'head head)
                     (cons 'tail tail))))

;;; Entry point for the interpreter.
;;; Captures the top-level continuation as the *ts:exit-continuation*
;;; and the continuation right before the read-eval-print loop as the
;;; *ts:continue-continuation*, and then enters the read-eval print
;;; loop.
(define (tiny-scheme)
  (echo "Welcome to the Tiny Scheme Interpeter")
  (ts:initialize-environment)
  (call-with-current-continuation
   (lambda (exit-cont)
     (set! *ts:exit-continuation* exit-cont)
     (call-with-current-continuation
      (lambda (continue-cont)
        (set! *ts:continue-continuation* continue-cont)))
     (ts:read-eval-print-loop)))
  (echo "Exiting the Tiny Scheme Interpreter"))

;;; You can use ts as a shortcut for tiny-scheme.
(define ts tiny-scheme)

;;; The heart of the interpreter is a read-eval-print loop.
(define (ts:read-eval-print-loop)
  (echon "TS==> ")
  (let* ((exp   (ts:read))
         (value (ts:eval exp *ts:top-level-env*)))
    (unless (void? value)
      (echo :w value))
    (ts:read-eval-print-loop)))

;;; This will be set to a function which takes no arguments and causes
;;; the interpreter to exit when called.
(define *ts:exit-continuation* #f)

;;; This will be set to a function which takes no arguments and causes
;;; the interpreter to continue executing the read-eval-print loop.
(define *ts:continue-continuation* #f)

;;; Used to control how much information the interpreter prints during
;;; compilation and evaluation.
(define *ts:verbose* #t)

;;; The tiny-scheme reader reads in an S-expression, and then calls the
;;; compiler.  Displays the resulting expression if *ts:verbose* is not
;;; false, and returns the compiled expression.
(define (ts:read)
  (let ((exp (ts:compile (read))))
    (when *ts:verbose*
      (echo "Compiled expression:" :w exp))
    exp))

;;; This function prints out an error message and causes the interpreter
;;; to stop what it was doing and enter the debugger (which you need to
;;; define.)
(define (ts:error (env <env>) obj (msg <string>))
  (echo "Error!" :w obj :d ":" msg)
  (ts:debugger env))


;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;; Debugger
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;

;;; A bogus debugger which does nothing as of now except return to the
;;; read-eval-print loop by invoking the continue-continuation.
(define (ts:debugger (env <env>))
  (*ts:continue-continuation*))


;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;; Compiler definitions
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;

(define (ts:compiler-error obj (msg <string>))
  (echo "Compiler error!" :w obj :d ":" msg)
  (*ts:continue-continuation*))

;;; Compile a medium-scheme expression to a tiny-scheme expression.
(defgeneric (ts:compile exp))

;;; The default compiler just returns the expression.
(defmethod (ts:compile exp)
  exp)

;;; If the expression is a pair, then call compile-combination with the
;;; operator and the sub-expressions.
(defmethod (ts:compile (exp <pair>))
  (ts:compile-combination (head exp) (tail exp)))

;;; Compile a medium-scheme combination to a tiny-scheme expression.
(defgeneric (ts:compile-combination operator exps))

;;; The default compiler for combinations just compiles the operator and
;;; the sub-expressions.
(defmethod (ts:compile-combination operator exps)
  (map ts:compile (cons operator exps)))

;;; split a list of bindings ((x1 e1) (x2 e2) ... (xn en)) into a pair
;;; of a list of variables and a list of expressions
;;; ((x1 x2 ... xn) (e1 e2 ... en)).  Check that the variables are in
;;; fact symbols.
(define (split-bindings bindings)
  (define (iter ds xs es)
    (if (null? ds)
      (cons (reverse xs) (reverse es))
      (let ((d (head ds)))
        (if (and (= (length d) 2)
                 (symbol? (first d)))
          (iter (tail ds) (cons (first d) xs) (cons (second d) es))
          (ts:compiler-error d "malformed binding")))))
  (iter bindings null null))

;;; We compile (let ((x1 e1) (x2 e2) ... (x1 en)) exp1 ... expm) into
;;; ((lambda (x1 x2 ... xn) exp1 ... expm) e1 e2 ... en).
(defmethod (ts:compile-combination (operator = 'let) exps)
  (if (>= (length exps) 2)
    (let* ((decls (first exps))
           (body  (tail exps))
           (xs-and-es (split-bindings decls))
           (xs (car xs-and-es))
           (es (cdr xs-and-es)))
      (ts:compile (cons (append (list 'lambda xs) body) es)))
    (ts:compiler-error (cons 'let exps) "malformed let-expression")))

;;; Checks that an if-expression is well-formed, i.e., of the form
;;; (if e1 e2 e3) and compiles the sub-expressions.
(defmethod (ts:compile-combination (operator = 'if) exps)
  (if (= (length exps) 3)
    (call-next-method)
    (ts:compiler-error (cons 'if exps) "malformed if-expression")))

;;; Do not recursively compile the sub-expressions of a quote
;;; expression.
(defmethod (ts:compile-combination (operator = 'quote) exps)
  (if (= (length exps) 1)
    (cons 'quote exps)
    (ts:compiler-error (cons 'quote exps)
                       "malformed quote-expression")))

;;; List expressions -- compile to cons expressions.
(defmethod (ts:compile-combination (operator = 'list) exps)
  (define (loop exps)
    (if (null? exps)
      null
      (list 'cons (ts:compile (head exps)) (loop (tail exps)))))
  (loop exps))


;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;; Environment utilities
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;

;;; Given an environment looks up and returns the first binding for a
;;; given variable (if it exists) and otherwise returns #f.
(defgeneric (env-lookup-binding (env <env>) (var <symbol>)))

;;; For top-level environments, we just look through the bindings to
;;; find the variable.
(defmethod (env-lookup-binding (env <env>) (var <symbol>))
  (define (binding-lookup bindings)
    (cond ((null? bindings) #f)
          ((eq? (binding-symbol (head bindings)) var) (head bindings))
          (else (binding-lookup (tail bindings)))))
  (binding-lookup (frame-bindings env)))

;;; For nested environments, we use call-next-method to look through the
;;; bindings.  If the binding is found in this frame, then we return it
;;; and otherwise look in the previous environment frames.
(defmethod (env-lookup-binding (env <nested-env>) (var <symbol>))
  (or (call-next-method)
      (env-lookup-binding (nested-env-prev env) var)))

;;; Add a binding to an environment.
(define (env-define env var val)
  (set! (frame-bindings env)
        (cons (make-binding var val)
              (frame-bindings env))))

;;; Add a list of (symbol,value) pairs as bindings to an environment.
(define (env-defines env vars-and-vals)
  (for-each (lambda (var-and-val)
              (env-define env (head var-and-val) (tail var-and-val)))
            vars-and-vals))

;;; A utility function for signalling an error when a variable is
;;; unbound.
(define (unbound-var (env <env>) (var <symbol>))
  (ts:error env var "is an unbound variable!"))


;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;; ts:eval
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;

;;; Evaluate an expression in an environment.
(defgeneric (ts:eval (exp <top>) (env <env>)))

;;; Default method: return the expression as the value.  Thus, numbers,
;;; booleans, strings, etc. will evaluate to themselves.
(defmethod (ts:eval (exp <top>) (env <env>))
  exp)

;;; This is for when running in console and getting an end-of-file key.
(defmethod (ts:eval (exp <end-of-file>) (env <env>))
  (*ts:exit-continuation*))

;;; We evaluate a symbol by looking it up in the environment.
(defmethod (ts:eval (var <symbol>) (env <env>))
  (let ((bv (env-lookup-binding env var)))
    (if bv
      (binding-value bv)
      (unbound-var env var))))

;;; The exp is of the form (e1 e2 e3 ... en) -- extract the first
;;; expression and use eval-combination to evaluate.
(defmethod (ts:eval (combination <pair>) (env <env>))
  (ts:eval-combination (head combination) (tail combination) env))


;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;; ts:eval-combination
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;

;;; Evaluate a combination expression of the form
;;; (operator e1 e2 e3 ... en) where args is the list of expressions
;;; e1 e2 e3 ... en.
(defgeneric (ts:eval-combination operator sub-exps (env <env>)))

;;; The default method evaluates the operator, and the sub-expressions
;;; and then applies the operator value to the sub-expression values.
;;; Notice that application does not take an environment as an argument.
(defmethod (ts:eval-combination operator sub-exps
                                (env <env>))
  (ts:apply (ts:eval operator env)
            (map (lambda (e) (ts:eval e env)) sub-exps)
            env))

;;; exit is a special form that exits the interpreter by calling the
;;; exit-continuation.
(defmethod (ts:eval-combination (operator = 'exit) (sub-exps = null)
                                (env <env>))
  (*ts:exit-continuation*))

;;; Evaluation of special form (if e1 e2 e3) -- we must override the
;;; behavior so that we do not evaluate all of the sub-expressions.
(defmethod (ts:eval-combination (operator = 'if) sub-exps
                                (env <env>))
  (if (ts:eval (first sub-exps) env)
    (ts:eval (second sub-exps) env)
    (ts:eval (third sub-exps) env)))

;;; Evaluation of special form (lambda (x1 ... xn) e) -- we create a
;;; closure and return it as the value of the combination.
(defmethod (ts:eval-combination (operator = 'lambda) sub-exps
                                (env <env>))
  (make-closure (first sub-exps)  ; (x1 ... xn)
                (second sub-exps) ; e
                env))

;;; Evaluation of special-form (define x e) -- evaluate e and bind its
;;; value to x in the current environment.
(defmethod (ts:eval-combination (operator = 'define) sub-exps
                                (env <env>))
  (let ((sym (first sub-exps))
        (val (ts:eval (second sub-exps) env)))
    (env-define env sym val)))

;;; Evaluation of special-form (set! x e) -- evaluate e and change the
;;; binding for x to the value v, using the lookup rule to modify the
;;; appropriate binding in the environment.
(defmethod (ts:eval-combination (operator = 'set!) sub-exps
                                (env <env>))
  (let* ((var (first sub-exps))
         (val (ts:eval (second sub-exps) env))
         (bv  (env-lookup-binding env var)))
    (if bv
      (set! (binding-value bv) val)
      (unbound-var env var))))

;;; Evaluation of an explicit, user-defined error just calls our error
;;; routine.
(defmethod (ts:eval-combination (operator = 'error) sub-exps
                                (env <env>))
  (ts:error env 'user-error (first sub-exps)))


;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;; Application
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;

;;; Apply a primitive or closure value to a list of argument values.
(defgeneric (ts:apply value args env))

;;; We use Swindle to apply a primitive operator such as +, *, - to
;;; arguments or in fact, any Swindle procedure.
(defmethod (ts:apply (operator <procedure>) args (env <env>))
  (apply operator args))

;;; To apply a closure, zip the formal arguments and actual arguments
;;; into a list of bindings, create a new frame with those bindings, and
;;; link the environment of the the closure in to create a new
;;; environment.  Then evaluate the body of the closure in the new
;;; environment.
(defmethod (ts:apply (operator <closure>) args (env <env>))
  (let ((env (make-nested-env (zip-bindings (closure-args operator)
                                            args
                                            env)
                              (closure-env operator))))
    (ts:eval (closure-body operator) env)))

;;; A utility function for combining a list of symbols (formal
;;; parameters) and a list of values (actual parameters) into bindings.
(define (zip-bindings formals actuals env)
  (cond ((and (null? formals) (null? actuals)) null)
        ((null? formals)
         (ts:error env 'zip-binding "too many arguments"))
        ((null? actuals)
         (ts:error env 'zip-binding "too few arguments"))
        (else (cons (make-binding (head formals) (head actuals))
                    (zip-bindings (tail formals) (tail actuals) env)))))