;;;************************************************************
;;;	Homework 4. Solution
;;;
;;;  This Solution is suggested by stelo@cs.
;;;

;;;************************************************************
;;;
;;; original: Tue Oct 18 11:02:26 1988
;;; revised Fri Oct 23 10:30:16 1992
;;; revised to use sllgen Tue Sep 28 17:09:43 1993

;;; Assumes sllgen.scm is loaded
(load "/.xinuserver/u57/hylee/pub/source/sllgen.scm")

;;; **********************************************************
;;;
;;; Top-level interface

(define run
  (lambda (string)
    (eval-exp (scan&parse string) init-env)))

;;; ***********************************************************

;;; Lexical Specification

; MODIFIED add new keywords, no identifier starts with ':'

(define automaton-5
  '((proc if then else let set! in print begin end cond ==> =)
    (start-state
     ((#\space #\tab #\newline) #f)
     ((alphabetic  #\* #\+ #\- #\/ #\! #\=) 
      (arbno (numeric alphabetic #\* #\+ #\- #\/ #\! #\= #\: #\>))
      identifier)
     ((numeric)
      (arbno numeric)
      number)
     (#\( lparen)
     (#\) rparen)
     (#\^ end-marker)
     (#\: colon)       
     (#\; semicolon)
     (#\% comment-state))
    (comment-state
     (#\newline #f)
     (any comment-state))))

;;; ****************************************************************

;;; Grammar

(define grammar-5
  '((expression
     (number)
     lit-exp)
    (expression
     (identifier)
     var-exp)
    (expression
     (set! identifier expression)
     assign-exp)
    (expression
     (if expression then expression else expression)
     if-exp)
    (expression
     (let (arbno declaration) in expression)
     let-exp)

    ; MODIFIED procedure with optional parameters
    (expression
     (proc lparen (arbno identifier)
	   (arbno colon declaration) rparen expression) 
     proc-exp)

    (expression
     (lparen expression (arbno operand) rparen)
     app-exp)

    (operand                         
     (colon declaration)            
     operand-key)      

    (operand                       
     (expression)                 
     operand-exp)

    ; MODIFIED print
    (expression 
     (print expression)
     print-exp)

    ; MODIFIED begin
    (expression
     (begin (arbno expression semicolon) end) 
     begin-end-exp)

    ; MODIFIED cond
    (expression
     (cond (arbno expression ==> expression) end)
     cond-exp)

    (declaration
     (identifier = expression)
     decl)))

(define scan&parse
  (sllgen:string->tree automaton-5 grammar-5))

;;; End of syntactic specification

;;; ****************************************************************

;;; Data Structure Definitions for Interpreter

;;; ****************************************************************

;;; Cells

(define make-cell
  (lambda (value)
    (cons '*cell value)))

(define deref-cell cdr)

(define set-cell! set-cdr!)		; danger!

;;; ****************************************************************

;; Finite functions:  ribcage (list of frames)

; empty-ribcage ==> nil
; (extend-ribcage names vals ff) ==> ((names . vals) . ff)

(define the-empty-ribcage '())

(define extend-ribcage
  (lambda (names vals ribcage)
    (if (= (length names) (length vals))
      (cons (cons names vals) ribcage)
      (error 'extend-ribcage
	"wrong number of values. names: ~s values: ~s"
	names vals))))

(define apply-ribcage
  (lambda (ribcage z)
    (if (null? ribcage)
      (error 'apply-ribcage "identifier ~s not found" z)
      (let ((names (caar ribcage))(vals (cdar ribcage))(f (cdr ribcage)))
	(if (memq z names)
	  (letrec
	    ;; can assume z will be found in names
	    ((loop (lambda (names vals)
		     (if (eqv? z (car names)) (car vals)
		       (loop (cdr names) (cdr vals))))))
	    (loop names vals))
	  (apply-ribcage f z))))))

;;; ****************************************************************

;;; Building environments from ribcages:

(define the-empty-env the-empty-ribcage)

(define extend-env
  (lambda (names values env)
    (extend-ribcage names (map make-cell values) env)))

(define apply-env apply-ribcage)


;;; *****************************************************************

;;; Declarations

(define-record decl (var exp))

(define-record key-decl (var exp))

;;; Closures and procedures

(define-record closure (formals body env))

(define build-user-proc make-closure)

;;; *****************************************************************
;;; *****************************************************************

;;; The Interpreter Proper

(define eval-exp
  (lambda (exp env)
;   (newline)
;   (display "eval-exp(exp): ")
;   (display exp)
;   (newline)
    (record-case exp
      (lit-exp (constant) 
	constant)

      (var-exp (id) 
	(deref-cell (apply-env env id)))

      (assign-exp (ident rhs-exp)
       (set-cell!
	(apply-env env ident)
	(eval-exp rhs-exp env)))

      (if-exp (test-exp true-exp false-exp)
       (if (zero? (eval-exp test-exp env))
	   (eval-exp false-exp env)
	   (eval-exp true-exp env)))

      (let-exp (decls body)
       (let ((ids (map decl->var decls))
	     (exps  (map decl->exp decls)))
	 (let ((new-env
		(extend-env ids (eval-rands exps env) env)))
	   (eval-exp body new-env))))

      (app-exp (rator rands)
       (let ((proc (eval-exp rator env))
             (args (eval-rands rands env)))
         (apply-proc proc args)))

      ; MODIFIED procedure with optional parameters
      (proc-exp (formals keys body)
       (let ((keys-value (eval-rands keys env)))
         (let ((keys-id (map decl->var keys-value))
               (keys-ex (map decl->exp keys-value)))
           (let ((new-env (extend-env keys-id keys-ex env)))
             (build-user-proc formals body new-env)))))

      (operand-exp (rator)
       (eval-exp rator env))

      (operand-key (rator)
       (eval-exp rator env))

      (decl (var exp)
       (make-decl var (eval-exp exp env)))

      ; MODIFIED print
      (print-exp (print-body)      
        (print (eval-exp print-body env))  
        1)                                
                                         

      ; MODIFIED begin end
      (begin-end-exp (stmnts) 
       (if (null? stmnts)
	   'unspecified 
	   (car (reverse (eval-rands stmnts env)))))

      ; MODIFIED cond end
      (cond-exp (caseslist)
       (resolve-cond caseslist env))

      (else (error 'eval-exp "Bad abstract syntax: ~s" exp)))))

(define resolve-cond
  (lambda (cl env)
    (if (null? cl)
	'unspecified
	(if (eq? (eval-exp (car cl) env) 0)
	    (resolve-cond (cddr cl) env)
	    (eval-exp (cadr cl) env)))))

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

(define apply-proc
  (lambda (proc args)
    (record-case proc
      (primitive-proc (primop)
	(apply-primop primop args))
      (closure (formals body env)
	(let ((actuals (filter-out list? args))           ; MODIFIED 
	      (key-actuals (filter-in list? args)))
	  (let ((new-env (extend-env (map decl->var key-actuals)
				     (map decl->exp key-actuals) env)))
	    (eval-exp body
		      (extend-env
		       formals actuals new-env)))))
      (else (error 'apply-proc "Bad Procedure ~s" proc)))))

; MODIFIED helper function
(define filter-in  
  (lambda (p lst)
    (apply append (map (lambda (x) (if (p x) (list x) '())) lst))))

; MODIFIED helper function
(define filter-out 
  (lambda (p lst)
    (apply append (map (lambda (x) (if (p x) '() (list x))) lst))))

;;; *****************************************************************
;;; Primops

(define-record primitive-proc (primop))

(define apply-primop
  (lambda (primop args)
    (case primop
      ((+-op)  (+ (car args) (cadr args)))
      ((--op)  (- (car args) (cadr args)))
      ((*-op)  (* (car args) (cadr args)))
      ((==-op) (if (eq? (car args) (cadr args)) 1 0)) ; MODIFIED new op ==
      ((+1-op) (+ (car args) 1))
      ((-1-op) (- (car args) 1))
      (else (error 'apply-primop "Unknown Primop: ~s" primop)))))

;;; *****************************************************************

;;; The Initial Environment

(define build-init-env
  (lambda (pairs)
    (extend-env
      (map car pairs)
      (map make-primitive-proc
           (map cadr pairs))
      the-empty-env)))

(define init-pairs
  '((+ +-op)
    (- --op)
    (* *-op)
    (== ==-op)	; MODIFIED new op ==
    (add1 +1-op)
    (sub1 -1-op)))

(define init-env (build-init-env init-pairs))

;;; ***************************************************************