;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;
;; MiniScheme Interpreter version 0.901
;;
;; Author       :     Your Name
;; Last modified:     
;;
;; To use the interpreter:  
;; 1. Define the appropriate scheme version
;; 2. Evaluate this file.
;; 3. Start the interpreter by typing (repl) at the prompt
;; 4. Type (exit) to exit from the interpreter.
;;
;; ISSUES:
;;  I've made every effort to make the code "portable" between the various
;;  Scheme environments out there.  It's been tested on DrScheme, Guile, 
;;  and MIT Scheme.  The preferred platform for the class is DrScheme and
;;  we will be grading on that platform.  It is your responsibility to
;;  check your work on that environment before you turn it in.  However,
;;  you're free to do your development on other environments.  We've provided
;;  some support for these environments (see below).
;;
;; HISTORY:
;;   v.901  Fixed error handling for older versions of DrScheme (v102)
;;
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;

(define *scheme-version* 'undefined)

;; The correct one of the below must be defined for your implementation !!
;; DrScheme users don't need to do anything...
;; MIT/Guile users should uncomment the appropriate line (and re-comment 
;; the other line...)

(set! *scheme-version* 'dr-scheme)
;(set! *scheme-version* 'guile-scheme)
;(set! *scheme-version* 'mit-scheme)

;; This takes care of infinite recursion in MIT scheme when printing
;; circular objects...

(if (eq? *scheme-version* 'mit-scheme) 
    (begin
      (set! *unparser-list-depth-limit* 2)
      (set! *unparser-list-breadth-limit* 60)))

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;; Helper functions
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;

(define (first x) 
  (car x))

(define (second x)
  (car (cdr x)))

(define (third x)
  (car (cdr (cdr x))))

(define (fourth x)
  (car (cdr (cdr (cdr x)))))

(define rest cdr)

(define nil ())

;; Controls the verbosity of output. 
;; A higher setting means more error messages!
(define *verbosity* 2)

;; Display an error/warning message.  Will only be displayed if the system 
;; verbosity is >= the provided verbosity.
(define (debug-message verbosity val)
  (cond ((<= verbosity *verbosity*) 
         (display (list 'DEBUG val)) (newline))))


;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;
;; Handling special forms.  
;; The interpreter can be extended to handle new special forms by: 
;; 1. defining a new handler function, which must take the full sexpr being
;; evaluated and the current environment as arguments.
;; 2. adding a binding of special-form-name special-form-code to the 
;; list *special-forms* below
;; 
;; At interpreter start up time, the list *special-forms* is turned
;; into a table (*special-form-fun-table*), which provides myeval
;; with the primitive implementations of the special forms.
;;
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;

;; Handling DEFINE:
;; We need to destructively set the car of the environment 
;; (the top frame) to be the new frame returned by table-associate
;; This is a rare example of a Scheme function that destructively
;; operates on its argument.

(define (do-define s env)
  (let* ((res (myeval (third s) env)))
    (set-car! env (table-associate (second s) res (car env)))
    (second s)))


;; define your own special form handlers here


;; *special-forms* is a list of entries of the form (<name> <code>)
;; new special forms can be added by defining new handler fuction
;; and adding a reference to it in the below list

(define *special-forms*
  (list
   (list 'define do-define)
   (list 'lambda (lambda (sexpr env) (list 'closure (cdr sexpr) env)))
   ))



;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;
;; Handling primitive functions.
;; The interpreter can be extended to handle new primitive functions by:
;; 1. defining a new handler function, which must take a single argument
;; which is the list of values which are the arguments to the primitive.
;; 2. adding a list containing the primitive function name and the
;; primitive function body to the list *primitives* below.
;;
;; At interpreter start up time, the list *primitives* is turned
;; into a table (*primitive-fun-table*), which provides myapply
;; with the primitive implementations of the primitive functions.
;;
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;


;; *primitives* is a list of entries of the form (<name> <code>) where
;; <name> is the name of a primitive function to handle, and <code> is
;; the lisp function that implements <name>.  
 
(define *primitives*
  (list
   (list 'atom? (lambda (v) (atom? (first v))))
   (list 'eq? (lambda (v) (eq? (first v) (second v))))
   (list 'exit (lambda (v) (set! *break* #t)))
   (list 'display (lambda (v) (display (first v)) (newline)))
   (list '+ (lambda (v) (+ (first v) (second v))))
   (list '- (lambda (v) (- (first v) (second v))))
   (list '= (lambda (v) (= (first v) (second v))))
   (list '< (lambda (v) (< (first v) (second v))))
   ))

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;
;; Error handling:
;; We really should have a better way, but there isn't a really good,
;; portable way to do this in Scheme.
;;
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;

;; a predictate to test what kind of error we're dealing with

(define is-miniscm-error? 
  (lambda (exn) (eq? 'miniscm-error exn)))

;; a somewhat portable way to raise an error

(define (raise-error error-name thing msg)
  (debug-message 1 (list error-name thing msg))
  (cond ((eq? *scheme-version* 'dr-scheme)
	 (raise error-name))
	((eq? *scheme-version* 'mit-scheme)
	 (error error-name (list thing msg)))
	((eq? *scheme-version* 'guile-scheme)
	 (scm-error error-name #f "Miniscm Error " () #f))))

(define (not-break-exn? exn)
  (not (exn:misc:user-break? exn)))

(define (handle-error-in thunk)
  (cond
   ((eq? *scheme-version* 'dr-scheme) 
    (with-handlers             
     ((is-miniscm-error?                
       (lambda (exn)                 ; handler for miniscm errors, we just
	 (display exn)))
      (not-break-exn?                ; handler for lower-level errors, we
       (lambda (exn)                 ; just print them (eg. divide-by-zero)
	 (display (exn-message exn)))))
     (thunk)))

   ((eq? *scheme-version* 'mit-scheme)
    (ignore-errors thunk))
   
   ((eq? *scheme-version* 'guile-scheme) 
    (catch #t thunk 
	   (lambda (key . args) 
	     (display key))))

   ))

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;
;; Environment operations
;;
;; conceptually, an environment is just a "stack" of frames, where 
;; each frame is a "table" of key-value bindings (in our case, these
;; are bindings of symbols to values)
;;
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;

;; We implement tables (currently) as lists of lists, as follows:
;; ((key1 val1) (key2 val2) ... (keyN valN))

;; table-lookup returns a list of two elements (<value> <exists>), where
;; <value> is the value bound to the key, and <exist> is a boolean flag telling
;; whether the key exists in the table.

(define (table-lookup key table)
  (cond ((null? table) (list () #F))
	((equal? (caar table) key) (list (cadar table) #T))
	(#T (table-lookup key (cdr table)))))


;; table-associate associates a key and a value in the given table.
;; it returns the new table formed by adding the new binding

(define (table-associate key value table)
  (cond ((null? table) (list (list key value)))
	((equal? (caar table) key)
	 (cons (list key value) (cdr table)))
	(#T (cons (first table) 
		  (table-associate key value (rest table))))))


;; table-new returns an empty table

(define (table-new) ())

;; exists? takes a lookup-result (as returned from table-lookup) and
;; tells whether the value returned is valid (it is only valid if exists?)
;; returns true

(define (exists? lookup-result)
  (second lookup-result))

;; value takes a lookup-result (as returned from table-lookup) and
;; returns the value portion of the result.  this is only guaranteed to
;; be valid if exists? is true

(define (value lookup-result)
  (first lookup-result))

;; table-associate-list, takes a list of keys and a list of values
;; and associates them in the given table
;; it returns the extended table

(define (table-associate-list keylist valuelist table)
  (if (null? keylist) table
    (table-associate-list
     (rest keylist) (rest valuelist) 
     (table-associate (first keylist) (first valuelist) table))))


;; env-lookup takes a symbol and an environment and returns the value
;; bound to the symbol, or raises an error, if the symbol is unbound
;; this is an example of using the table operations:  table-lookup,
;; exists? and value (above)

(define (env-lookup s env)
  (if (null? env)
      (raise-error 'miniscm-error s "Unbound symbol")
    (let ((result (table-lookup s (first env))))
      (if (second result) 
	  (first result)
	(env-lookup s (rest env))))))



;; define any other operations on environments here




;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;
;; myapply
;;
;; myapply takes a function and a list of values (arguments to the 
;; function).  It first looks up that function in the primitive
;; function table.  If it finds a binding, then it simply funcalls the
;; primitive lisp code which implements this function.  Otherwise,
;; it is applying a user defined function in the form of a closure.
;; Currently, myapply only handles built-in functions.  You'll have to 
;; extend it to call a function which handles user defined functions.
;;
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;


(define (myapply f values) 
  (debug-message 3 (list "In Myapply" f values))
  (let ((lookup-result (table-lookup f *primitive-fun-table*)))
    (cond ((exists? lookup-result) ((value lookup-result) values))

	  ;; add the handling of user-defined functions here...

	  (#t (raise-error 'miniscm-error f "Unknown function")))))

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;
;; eval
;;
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;

;; get-values takes a list of expressions and evaluates them wrt to
;; the given environment.  it returns a list of the resulting values

(define (get-values expr-list env)
  (map (lambda (expr) (myeval expr env)) expr-list))


;; an atom is a number, boolean, or symbol, or ()

(define (atom? thing)
  (or (number? thing) (boolean? thing) (symbol? thing) (null? thing)))


;; an atom is self evaluating if it is (), boolean or a number

(define (self-evaluating? anAtom)
  (or (number? anAtom) (boolean? anAtom) (null? anAtom)))



;; an S-expression is a special form if it is a list, and if its head 
;; is a symbol, and if its head is a key in the special-forms-fun-table

(define (special-form? sexpr env)
  (debug-message 3 (list "Checking special form " sexpr))
  (and (list? sexpr)
       (symbol? (car sexpr)) 
       (exists?
	(table-lookup 
	 (env-lookup (car sexpr) env) 
	 *special-forms-fun-table*))))


;; special forms are handled by looking up the code for the 
;; formname in the appropriate function table, and invoking the
;; code on the the sexpression and the environment

(define (handle-special-form form env)
  (debug-message 3 (list "Handling special form" form))
  (let ((lookup-result 
	 (table-lookup (first form) *special-forms-fun-table*)))
    ;;  (print lookup-result)
    ((value lookup-result) form env)))


;; myeval is the heart of the interpreter.  it takes an sexpr and an
;; environment.  if s is:
;;    self-evaluating        then just return it
;;    a variable             then look it up in the current environment
;;    a special form         then call handle-special-form
;;    a function application then call myapply
;;               

(define (myeval sexpr env)
  (cond
   ((self-evaluating? sexpr) sexpr)
   ((symbol? sexpr) (env-lookup sexpr env))
   ((special-form? sexpr env) (handle-special-form sexpr env))
   (#t (myapply (myeval (car sexpr) env)
		(get-values (cdr sexpr) env)))))


;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;
;; MAIN LOOP
;;
;; At startup, the environment is initialized as follows:
;; 1. a global environment is built in which the special-form-names 
;;    and primitive-function names are bound to themselves (ie. car -> car)
;; 2. in *special-forms-fun-table*, the special-form-names are bound to the 
;;    special-form-functions (ie. cond -> #'do-cond)
;; 3. in *primitive-fun-table*, the primitive-fun-names are bound to the
;;    primitive-fun-functions (ie. car -> #'(lambda (v) ...))
;;
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;


;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;; Global Variables
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;

(define *special-forms-fun-table* ())        ; bindings of name -> functions
(define *primitive-fun-table* ())            ; bindings of name -> functions
(define *env* ())                            ; the environment 
(define *break* #f)

;; init-table takes a list of keys and a list of values
;; and adds them to the table.

(define (init-table keys values table)
  (if (null? keys) table
    (init-table
     (cdr keys) (cdr values) 
     (table-associate (car keys) (car values) table))))


;; Set up the global data:  (more or less) empty environment and the 
;; function/form tables

(define (setup)
  (let* ((special-names (map first *special-forms*))
	 (special-funs (map second *special-forms*))
	 (prim-names (map first *primitives*))
	 (prim-funs (map second *primitives*))
	 )
    (set! *break* #f)
    (set! *special-forms-fun-table*
	  (table-associate-list special-names special-funs (table-new)))
    (set! *primitive-fun-table*
	  (table-associate-list prim-names prim-funs (table-new)))
    (set! *env* 
	  (cons (init-table (append special-names prim-names)
                            (append special-names prim-names) 
                            (table-new))
                nil))))


;; Do a setup, and then start looping

(define (repl)
  (if (eq? *scheme-version* 'undefined)
      (begin
	(display "You must define *scheme-version* to one of:") (newline)
	(display " 'dr-scheme") (newline)
	(display " 'mit-scheme") (newline)
	(display " 'guile-scheme") (newline))
      (begin
	(display "Welcome to MiniScheme")
	(setup)
	(repl-loop))))


;; The main loop:  issue a prompt, read an s-expr, evaluate it, and print it
;; Exiting is handled in a somewhat weird way:  internally, (exit) sets
;; the global flag *break* to be true, which we then check and possibly
;; exit the repl-loop

(define (repl-loop)
  (newline)                       ; issue a prompt
  (display "MiniScheme> ")
  
  (let*
      ((sexpr (read))           ; read the next s-expression
       (result                  ; get the result
	(handle-error-in (lambda () (myeval sexpr *env*)))))
    
    (if (not *break*) 
	(begin
	  (display result)
	  (repl-loop)))))