;;;------------------------------------------------------------------------;;;
;;;                     Advanced Programming Techniques                    ;;;
;;;                            Michael Elhadad                             ;;;
;;;                                 Dec 96                                 ;;;
;;;------------------------------------------------------------------------;;;


(require 'struct)

;;;----------------------------------------
;;; Define-records for the following BNF
;;;----------------------------------------

;; <exp>         ::= <varref>                 varref (var)
;;               |  <number>                  lit (datum)
;;               |  (if <exp> <exp> <exp>)    if (test-exp then-exp else-exp)
;;               |  (proc ({<var>}*) <exp>)   proc (formals body)
;;               |  (<exp> {<exp>}*)          app (rator rands)
;;               |  (:= <var> <exp>)          varassign (var exp)
;;               |  (begin {<exp>}+)          begin (exps)
;;               |  (let <decls> <exp>)       let (decls body)
;;               |  (letrec <decls> <exp>)    letrec (decls body)
;;               |  (letmutable <decls> <exp>) letmutable (decls body)
;; <decls> ::= ({<decl>}*)
;; <decl>  ::= (<var> <exp>)                  decl (var exp)

(define-record varref (var))
(define-record lit (datum))
(define-record if-exp (test-exp then-exp else-exp))
(define-record proc (formals body))
(define-record app (rator rands))
(define-record varassign (var exp))
(define-record begin-exp (exps))
(define-record let-exp (decls body))
(define-record letrec-exp (decls body))
(define-record letmutable-exp (decls body))
(define-record decl (var exp))

(define-record closure (formals body env))
(define-record prim-proc (op))
(define-record empty-env ())
(define-record ne-env (symbol value env))
(define-record cell (val))


;;;----------------------------------------
;;; Parser 
;;;----------------------------------------

(define first  car)
(define second cadr)
(define third  caddr)
(define fourth cadddr)

;;; parse expression according to given BNF.
(define (parse exp)
  (cond ((number? exp) (make-lit exp))
        ((symbol? exp) (make-varref exp))
        ((and (list? exp) (= (length exp) 4) (eq? (first exp) 'if))
              (make-if-exp (parse (second exp))
                           (parse (third exp))
                           (parse (fourth exp))))
        ((and (list? exp) (>= (length exp) 3)
              (eq? (first exp) 'proc) (list? (second exp)))
         (make-proc (second exp) (parse (third exp))))
        ((and (list? exp) (= (length exp) 3)
              (eq? (first exp) ':=))
         (make-varassign (parse (second exp)) (parse (third exp))))
        ((and (list? exp) (> (length exp) 2) (eq? (first exp) 'begin))
         (make-begin-exp (map parse (cdr exp))))
        ((and (list? exp) (>= (length exp) 3) (eq? (first exp) 'let)
              (list? (second exp)))
         (make-let-exp (parse-decls (second exp)) (parse (third exp))))
        ((and (list? exp) (>= (length exp) 3) (eq? (first exp) 'letrec)
              (list? (second exp)))
         (make-letrec-exp (parse-decls (second exp)) (parse (third exp))))
        ((and (list? exp) (>= (length exp) 3) (eq? (first exp) 'letmutable)
              (list? (second exp)))
         (make-letmutable-exp (parse-decls (second exp)) (parse (third exp))))
        ((and (list? exp) (> (length exp) 0))
         (make-app (parse (car exp)) (map parse (cdr exp))))
        (else (error "Illegal input to parser"))))

(define (parse-decls decls)
  (if (null? decls)
      ()
      (let* ((decl (car decls)))
        (if (and (list? decl)
                 (= (length decl) 2)
                 (symbol? (first decl)))
            (cons (make-decl (first decl) (parse (second decl)))
                  (parse-decls (cdr decls)))
            (error "Wrong input to parse-decls" decls)))))


;; NOTE: we also unparse closures and numbers to be able to read the output of
;;       the interpreter when it returns a closure.
(define (unparse exp)
  (variant-case exp
    (varref   (var) var)
    (lit      (datum) datum)
    (if-exp   (test-exp then-exp else-exp)
	      (list 'if (unparse test-exp) 
		    (unparse then-exp) (unparse else-exp)))
    (proc     (formals body) (list 'proc formals (unparse body)))
    (app      (rator rands) (cons (unparse rator) (map unparse rands)))
    (varassign (var exp) (list ':= var (unparse exp)))
    (begin-exp
              (exps) (cons 'begin (map unparse exps)))
    (let-exp  (decls body) (list 'let (map unparse decls) (unparse body)))
    (letrec-exp
              (decls body) (list 'letrec (map unparse decls) (unparse body)))
    (letmutable-exp
              (decls body) (list 'letmutable (map unparse decls) 
				 (unparse body)))
    (decl     (var exp) (list var (unparse exp)))
    (closure  (formals body env)
	      (list 'closure formals (unparse body)))
    (else 
      (if (number? exp) 
	  exp
	  (error "unparse: Invalid abstract syntax" exp)))))


;;;------------------------------------------------------------
;;; ENVIRONMENT ADT DEFINITION and initial environment
;;;------------------------------------------------------------

(define (extend-env symb val env)
  (if (not (list? symb))
    (make-ne-env symb val env)
    (if (null? symb)
        env
        (extend-env (cdr symb) (cdr val)
                (make-ne-env (car symb) (car val) env)))))

(define (apply-env env symb)
  (variant-case env
    (empty-env () (error "Symbol Not found in environment" symb))
    (ne-env (symbol value env)
      (if (eq? symbol symb) value (apply-env env symb)))
    (else (error "Error for apply-env"))))

(define empty-env
        (make-empty-env))

(define prim-op-names '(+ - * / add1 sub1 =))

(define init-env
  (extend-env prim-op-names
              (map make-cell
                   (map make-prim-proc prim-op-names))
              empty-env))