;;; 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 "mp5.s Thu May  6 23:58:03 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** '(if then else let 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)))
        (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)))
        (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)))))
  (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

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

;;; 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))

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

;;; The Interpreter Proper

(define eval-exp
  (lambda (exp env)
    (record-case exp
      (lit-exp (constant) constant)
      (var-exp (id) (apply-env env id))
      (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
		    (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))
      (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-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)")  ; => 7

(define pgm3a "let z = 5 x = 3
in let x = 4
       y = (+ x z)         % here x = 3
   in (* z (+ x y))        % here x = 4
")  ; => 60

(define pgm3b
"let z = 5 i = 3
 in let x = let y = 5 in (+ z y)
        y = 6
    in (* z (+ x y))")                  ; => 80

(define pgm4
"let x = 5 in begin print x; print (add1 x); print (+ x 2); x end")
;;; => 5 6 7 5


;  (run pgm1)
; 1
; > (run pgm2)

; Error in apply-ribcage: identifier x not found.
; Type (debug) to enter the debugger.
; > (run pgm3)
; 7
; > (run pgm3a)
; 60
; > (run pgm3b)
; 80
; >