;;; Scanner, Parser, and Interpreter for Chapter 5/Lecture 5

;;; original: Tue Oct 18 11:02:26 1988
;;; revised Fri Oct 23 10:30:16 1992

(printf "interp5.s Fri Apr 30 13:36:28 1993~%")

;;; Assumes mp4.s is loaded (includes scanner)

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

;;; Top-level interface

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

(define scan&parse
  (lambda (string)
    (parse-top-level grammar-5
      (string->token-stream automaton-5 string))))

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

;;; Lexical Specification

;;; We need to modify automaton-1, because + wants to be an identifier,
;;; not a special symbol.  We can also remove assign-sym.

(define automaton-5
  '((start-state
      (cond
        (#\space (drop (goto start-state)))
        (#\tab (drop (goto start-state)))
        (#\newline (drop (goto start-state)))
        (alphabetic (shift (goto identifier-state)))
        (numeric (shift (goto number-state)))
        (#\, (drop (emit comma)))
        (#\; (drop (emit semicolon)))
        (#\+ (shift (goto identifier-state)))
        (#\- (goto identifier-state))
        (#\* (goto identifier-state))
        (#\/ (shift (goto identifier-state)))
        (#\= (shift (goto identifier-state)))
        (#\( (drop (emit lparen)))
        (#\) (drop (emit rparen)))
        (#\^ (emit end-marker))
        (#\% (drop (goto comment-state)))))
    (identifier-state
      (cond
        (alphabetic (shift (goto identifier-state)))
        (numeric (shift (goto identifier-state)))
        (#\* (shift (goto identifier-state)))
        (#\+ (shift (goto identifier-state)))
        (#\- (shift (goto identifier-state)))
        (#\/ (shift (goto identifier-state)))
        (#\! (shift (goto identifier-state)))
        (#\= (shift (goto identifier-state)))
        (else (emit cook-identifier))))
    (comment-state
      (cond
        (#\newline (drop (goto start-state)))
        (else (drop (goto comment-state)))))
    (number-state
      (cond
        (numeric (shift (goto number-state)))
        (else (emit cook-number))))
    ))

;;; Keywords for our language are defined as follows:

(define **keywords-list** '(proc if then else let set! in =))

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

;;; Grammar

(define grammar-5
  '((start-state
      ((goto expression)))
    (expression
      (cond
        (number
          ((check/shift number)
           (reduce lit-exp)))
        (identifier
          ((check/shift identifier)
           (reduce var-exp)))
        (set!
          ((check/drop set!)
           (check/shift identifier)
           (process-nt expression)
           (reduce assign-exp)))
        (if
          ((check/drop if)
           (process-nt expression)
           (check/drop then)
           (process-nt expression)
           (check/drop else)
           (process-nt expression)
           (reduce if-exp)))
        (let
          ((check/drop let)
           (process-nt declaration-list)
           (check/drop in)
           (process-nt expression)
           (reduce let-exp)))
        (proc
          ((check/drop proc)
           (check/drop lparen)
           (process-nt formal-parameter-list)
           (check/drop rparen)
           (process-nt expression)
           (reduce proc-exp)))
        (lparen
          ((check/drop lparen)
           (process-nt expression)
           (process-nt operand-list)
           (check/drop rparen)
           (reduce app-exp)))))
  (declaration
    (cond
      (identifier
        ((check/shift identifier)
         (check/drop =)
         (process-nt expression)
         (reduce decl)))))
  (declaration-list                     ; bounded by "in"
    (cond
      (in
        ((emit-list)))
      (else
        ((process-nt declaration)
         (goto declaration-list)))))
  (formal-parameter-list		; bounded by rparen
    (cond
      (rparen
        ((emit-list)))
      (else
        ((check/shift identifier)	; modified Tue Oct 30 10:37:27 1990
         (goto formal-parameter-list)))))
  (operand-list                         ; bounded by rparen
    (cond
      (rparen
        ((emit-list)))
      (else
        ((process-nt expression)
         (goto operand-list)))))
    ))
       
;;; 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 f)
    (if (= (length names) (length vals))
      (cons (cons names vals) f)
      (error 'extend-ribcage
	"wrong number of values. names: ~s values: ~s"
	names values))))

(define apply-ribcage
  (lambda (ast z)
    (if (null? ast)
      (error 'apply-ribcage "identifier ~s not found" z)
      (let ((names (caar ast))(vals (cdar ast))(f (cdr ast)))
	(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 extend-ribcage)
(define apply-env apply-ribcage)


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

;;; Declarations

(define-record 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)
    (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)))
      (proc-exp (formals body)
	(build-user-proc
	  formals
	  body env))
      (if-exp (test-exp exp1 exp2)
	(if (zero? (eval-exp test-exp env))
	  (eval-exp exp2 env)
	  (eval-exp exp1 env)))
      (let-exp (decls body)
	(let ((ids (map decl->var decls))
	      (exps  (map decl->exp decls)))
	  (let ((new-env
		  (extend-env ids
		    (map make-cell (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)))
      (else (error 'eval-exp
	      "Bad abstract syntax: ~s" exp)))))

(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)
	(eval-exp body
	  (extend-env
	    formals
	    (map make-cell args)	; change
	    env)))
      (else (error 'apply-proc "Bad Procedure ~s" proc)))))


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

;;; 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)))
      ((+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-cell
	   (map make-primitive-proc
		(map cadr pairs)))
      the-empty-env)))


(define init-pairs
  '((+ +-op)
    (- --op)
    (* *-op)
    (add1 +1-op)
    (sub1 -1-op)))

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

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

;;; Tests

(define pgm1 "1")

(define pgm2 "(add1 x)")		; this one should end on a
					; domain error

(define pgm3 "let x = 3 y = 4 in (+ x y)")

(define pgm4 "let f = proc (x) (add1 x) in (f 4)")  

(define pgm5 "(proc (x) (add1 x) 4)")

(define pgm6 "let x = 3 
              in let y = set! x (add1 x)
                 in x")

; > (run pgm1)
; 1
; > (run pgm2)
; 
; Error in apply-ribcage: identifier x not found.
; 
; > (run pgm3)
; 7
; > (run pgm4)
; 5
; > (run pgm5)
; 5
; > (run pgm6)
; 4