;;;; Evaluator for Scheme-1.

;;;; This file can be loaded into Scheme as a whole.
;;;; Then you can initialize and start the evaluator by evaluating
;;;; the expression (read-eval-print).

;;; Scheme-1:  
;;;   * Only numbers, strings, #t, and #f are valid self-evaluating 
;;;     (literal) forms.
;;;   * Only the following special forms are defined:
;;;         if, cond, lambda, quote, define
;;;     and define is only allowed at the outer level---no 
;;;     defines inside lambdas.
;;;   * The following primitive procedures are defined:
;;;         car cdr cons null + - * / = > < >= <= list append equal?
;;;         number? symbol? procedure?
;;;   Since no expression has any side-effects, there is no need for
;;;   the begin form, the bodies of lambda expressions consist
;;;   of a single expression, as do the consequent clauses of cond
;;;   clauses (e.g., so that
;;;               (cond ((> i 0) 
;;;                      (* i (f (- i 1)))
;;;                      (+ i 2))
;;;                     ... )
;;;   is illegal).
;;;
;;; 
;;; Several of the functions in this file take two environment
;;; arguments, generally named INNER-ENV and OUTER-ENV (we'll use the
;;; notation INNER-ENV+OUTER-ENV to mean "the environment you'd get by
;;; extending OUTER-ENV with the definitions in INNER-ENV).  OUTER-ENV
;;; corresponds to the "outer-level" definitions---the predefined
;;; global environment, plus the results of any 'define' statements in
;;; the program.  INNER-ENV contains parameter bindings.  Why not just
;;; combine them into one environment?  Well, the problem is that we
;;; want the outer environment to change as do more 'define's.
;;; Suppose we have a sequence of definitions like this
;;;    (define (g x) (f (+ x 1)))
;;;    (define (f x) (if (< x 0) '() ...))
;;; Our intention is that g will use the later definition of f. However,
;;; if we were to expand the definition of g as usual:
;;;    (define g (lambda (x) (f (+ x 1))))
;;; and then include the environment at the time we evaluate this 
;;; definition in the compound procedure returned by lambda, 
;;; that environment would NOT include the definition of f, and we'd have
;;; a problem when it came time to call g.
;;;
;;; To get around this problem, we separate the part of the environment
;;; that EVERYBODY shares (the outer, global environment) from the 
;;; parts introduced by parameter lists (which we're calling "inner" 
;;; environments).  Since by design, only the global environment can
;;; change over time in Scheme-1, we thus get all the flexibility we need.
;;;
;;; In full Scheme, this little trick won't work, because ANY of the
;;; environments can change over time.  So to handle the full language,
;;; we're going to have to use still another approach.
;;;
;;; See the NOTES at the end for other implementation details.

;;; PART 1. Main evaluation procedures

;; Assuming that FORM is a valid Scheme-1 expression or 'define' form,
;; returns a cons pair (v . env') where v is FORM's value in the
;; environment ENV and env' is the resulting environment.  
;; (ENV and env' will be the same unless FORM is a 'define' form.)
(define (eval-and-extend form outer-env)
  (if (eq? (expression-class form) 'define)
      (cons 'okay (add-define (operand 1 form) (operand 2 form) outer-env))
      (cons (eval-1 form (the-empty-environment) outer-env) outer-env)))

;; The value of Scheme-1 expression EXP in the environment defined by
;; INNER-ENV and OUTER-ENV environment ENV.  EXP may not be a 'define'.  
(define (eval-1 exp inner-env outer-env)
  (let ((kind (expression-class exp)))
    (cond ((eq? kind 'self-evaluating) exp)
	  ((eq? kind 'symbol)    (lookup-variable-value exp 
							inner-env outer-env))
	  ((eq? kind 'quote)     (operand 1 exp))
	  ((eq? kind 'if)        (eval-if (operand 1 exp) (operand 2 exp) 
					  (optional-operand 3 exp) 
					  inner-env outer-env))
	  ((eq? kind 'lambda)    (make-procedure (operand 1 exp) 
						 (operand 2 exp)
						 inner-env))
	  ((eq? kind 'cond)      (eval-1 (cond->if exp) inner-env outer-env))
	  ((eq? kind 'pair)      (apply-1 
				  (eval-1 (operand 0 exp) 
					  inner-env outer-env)
				  (map (lambda (e) 
					 (eval-1 e inner-env outer-env))
				       (operand-list 1 exp))
				  outer-env))
	  ((eq? kind 'define)   
	   (error "Misplaced define (inside another expression): " exp))
	  (else 
	   (error "Unknown expression type -- EVAL: " exp)))))

;; Given that the Scheme-1 definition (define HEADER BODY) is valid, and
;; OUTER-ENV is an environment, returns the environment that results from
;; evaluating this definition in OUTER-ENV and extending OUTER-ENV with
;; the resulting binding.
(define (add-define header body outer-env)
  (cond ((symbol? header)
	 (extend-environment header 
			     (eval-1 body (the-empty-environment) outer-env)
			     outer-env))
	((and (pair? header) (symbol? (operand 0 header)))
	 (add-define (operand 0 header) 
		     (make-lambda (operand-list 1 header) body)
		     outer-env))
	(else (error "Bad definition header: " header))))

;; The value of (if TEST THEN-PART ELSE-PART) in the environment
;; INNER-ENV + OUTER-ENV.
(define (eval-if test then-part else-part inner-env outer-env)
  (if (true? (eval-1 test inner-env outer-env))
      (eval-1 then-part inner-env outer-env) 
      (eval-1 else-part inner-env outer-env)))

;; The result of evaluating the list of Scheme-1 expressions and definitions
;; EXPS in environment ENV.   The scope of any 'define' forms at the outer
;; level of EXPS is the entire sequence of 

;; True iff VALUE is a Scheme-1 value that represents true.
(define (true? value) (not (equal? value #f)))

;;; PART 2.  Support for parsing expressions

(define special-form-symbols '(cond if lambda quote define))

;; A symbol indicating what kind of Scheme-1 expression EXP is: 
;;    symbol           For a symbol (identifier)
;;    self-evaluating  For strings, numbers, and booleans
;;    other            For other atoms (nil, vectors, etc.)
;;    cond, if, lambda, quote, define
;;                     For expressions whose car is one of these symbols
;;    pair             For other pairs.
(define (expression-class exp)
  (cond ((or (number? exp) (string? exp) (boolean? exp))
	 'self-evaluating)
	((symbol? exp) 'symbol)
	((atom? exp) 'other)
	((memq (car exp) special-form-symbols) (car exp))
	(else 'pair)))

(define (atom? x) (not (pair? x)))

;; Operand (subexpression) number N in the expression EXP, which must 
;; be a combination or special form with at least N+1 items.  
;; Operands are numbered from 0.
(define (operand n exp)
  (list-ref exp n))

;; Operand number N (>= 0) in the expression EXP, which must be a combination
;; or special form.  Returns #f (false) if EXP has fewer than N+1 operands.
(define (optional-operand n exp)
  (cond ((null? exp) #f)
	((eqv? n 0) (car exp))
	(else (optional-operand (- n 1) (cdr exp)))))

;; The list of operands (subexpressions) in expression EXP, beginning with
;; operand number N (numbering from 0).  EXP must be combination or special
;; form with at least N items.  Operands are numbered from 0.
(define (operand-list n exp)
  (list-tail exp n))

;;; Part 3. Creating and applying procedures

;; A unique value that marks Scheme-1 closure values.  
(define closure-mark (list 'closure))

;; A compound procedure with formal parameters PARAMETERS (a list of
;; symbols), environment ENV, and BODY (a list of 0 or more definitions 
;; followed by an expression) as the body.
(define (make-procedure parameters body env)
  (list closure-mark parameters body env))

;; Accessors: If P is (make-procedure FORMALS BODY ENV), 
;; then (procedure-parameters p) is FORMALS, (procedure-body p) is BODY,
;; and (procedure-environment p) is ENV.
(define (procedure-parameters p) (cadr p))
(define (procedure-body p) (caddr p))
(define (procedure-environment p) (cadddr p))

;; True iff PROC is a value produced by make-procedure. 
(define (compound-procedure? proc)
  (and (pair? proc) (eq? (car proc) closure-mark)))

(define (primitive-procedure? val) (procedure? val))

;; The result of applying PROC, which must be a compound procedure (created
;; by lambda) to the list of values ARGUMENTS, where OUTER-ENV is the current
;; outer (global) environment.
(define (apply-compound-procedure proc arguments outer-env)
  (eval-1
   (procedure-body proc)
   (extend-environment 
    (procedure-parameters proc) arguments (procedure-environment proc))
   outer-env))

;; Apply PROC, which must be a Scheme-1 procedure value (either
;; primitive or compound) to the argument values ARGUMENTS, where OUTER-ENV
;; is the current outer (global) environment.
(define (apply-1 proc arguments outer-env)
  (cond ((primitive-procedure? proc) (apply proc arguments))
	((compound-procedure? proc) 
	 (apply-compound-procedure proc arguments outer-env))
	(else 
	 (error "Attempt to apply something that isn't a function: " proc))))

;;; Part 4. Environments

;;; An environment is a mapping from symbols to Scheme-1 values.

;; Assuming SYMBOLS is the list of symbols (s1 ... sn), VALUES is a
;; list of Scheme-1 values (v1 ... vn), and ENV0 is an environment,
;; the new environment that maps si to vi for i in 1..n, and maps everything
;; else according to ENV0.  It is an error if SYMBOLS contains repeated
;; symbols.
(define (extend-environment symbols values env0)
  (if (symbol? symbols)
      (cons (cons symbols values) env0)
      (append (map cons symbols values) env0)))

(define (the-empty-environment) '())

;; The mapping of VAR in ENV0+ENV1.  It is an error if VAR is defined 
;; in neither ENV0 nor ENV1.
(define (lookup-variable-value var env0 env1)
  (let ((match (or (assq var env0) (assq var env1))))
    (if match (cdr match)
	(error "Undefined variable: " var))))	

;;; Part 5. Constructing Scheme-1 expressions.

(define (make-lambda formals body)
  (cons 'lambda (list formals body)))

(define (make-if predicate consequent alternative)
  (list 'if predicate consequent alternative))

;; A Scheme-1 'if' expression that is equivalent to EXP, which must be
;; a valid Scheme-1 'cond' expression.
(define (cond->if exp)
  (expand-clauses (operand-list 1 exp)))

;; A Scheme-1 'if' expression that is equivalent to the sequence of 
;; clauses CLAUSES, which must be from a valid Scheme-1 'cond' expression.
(define (expand-clauses clauses)
  (if (null? clauses)
      #f
      (let ((first (car clauses))
            (rest (cdr clauses)))
	(cond ((not (pair? first))
	       (error "Badly formed cond clause -- COND->IF" first))
	      ((not (eq? (operand 0 first) 'else))
	       (make-if (operand 0 first)
			(operand 1 first)
			(expand-clauses rest)))
	      ((null? rest) (operand 1 first))
	      (else (error "ELSE clause isn't last -- COND->IF" clauses))))))

;;; Part 6. Predefined procedures.

;; A mapping of primitive procedure names to the procedures.  We just use
;; Scheme's existing functions as the implementation in most cases, since
;; we are using Scheme's representation of values for Scheme-1's 
;; representation.  However, look at the definition of procedure?

(define primitive-procedures
  (list (list 'car car)
        (list 'cdr cdr)
        (list 'cons cons)
        (list 'null? null?)
	(list '+ +)
	(list '- -)
	(list '* *)
	(list '/ /)
	(list '= =)
	(list '< <)
	(list '> >)
	(list '>= >=)
	(list '<= <=)
	(list 'list list)
	(list 'append append)
	(list 'equal? equal?)
	(list 'number? number?)
	(list 'symbol? symbol?)
	(list 'procedure? 
	      (lambda (x) (or (primitive-procedure? x) 
			      (compound-procedure? x))))
;;      more primitives
        ))

;;; To make the global environment, we take the primitive-procedures list
;;; apart again, which may make you ask why we didn't make it two lists
;;; to start with.  It's useful, however, both for clarity and to avoid
;;; errors to keep the symbols and their definitions closely paired.

;; The mapping from predefined Scheme-1 symbols to Scheme-1 values.
(define initial-global-environment 
  (extend-environment
   (map car primitive-procedures)
   (map cadr primitive-procedures)
   (the-empty-environment)))

;;; Part 7. Read-eval-print loop

(define standard-input-prompt "Scheme1> ")
(define standard-output-prompt "")

;; Prompt for, read, evaluate, and print Scheme-1 expressions until
;; or end-of-file is read, using OUTER-ENV as the global environment.
;; INPUT-PROMPT and OUTPUT-PROMPT are issued before each input and output, 
;; respectively.
(define (driver-loop input-prompt output-prompt outer-env)
  (prompt-for-input input-prompt)
  (let ((input (read)))
    (if (not (eof-object? input))
	(let ((output (eval-and-extend input outer-env)))
	  (announce-output output-prompt)
	  (user-print (car output))
	  (driver-loop input-prompt output-prompt (cdr output))))))

(define (prompt-for-input string)
  (display string)
  (flush))

(define (announce-output string)
  (display string))

(define (user-print object)
  (if (compound-procedure? object)
      (display (list 'compound-procedure
                     (procedure-parameters object)
                     (procedure-body object)))
      (display object))
  (newline))

;; Read, evaluate, and print Scheme-1 definitions and expressions from 
;; the standard input, starting with the standard predefined Scheme-1
;; environment.
(define (read-eval-print)
  (display "Scheme-1 Interpreter")
  (newline)
  (driver-loop standard-input-prompt standard-output-prompt
	       initial-global-environment))

;; Read, evaluate, and print Scheme-1 definitions and expressions from
;; the file named FILE-NAME, starting with the standard predefined
;; Scheme-1 environment.
(define (read-eval-print-file file-name)
  (with-input-from-file file-name 
    (lambda () (driver-loop "" "" initial-global-environment))))

;;; Part 9. Testing

;; Evaluate the sequence of expressions and definitions SEQ starting with
;; the predefined environment, yielding the list of resulting values.
(define (eval-1-seq seq)
  (define (eval-loop seq outer-env)
    (if (null? seq) '()
	(let ((result (eval-and-extend (car seq) outer-env)))
	  (cons (car result) 
		(eval-loop (cdr seq) (cdr result))))))
  (eval-loop seq initial-global-environment))

;; Given that TESTS is a list of lists, each of the form (INPUT OUTPUT),
;; check that in each case, the evaluation of (PROC INPUT) yields OUTPUT
;; (using equal? to check). 
(define (test-proc proc tests)
  (if (not (null? tests))
      (let* ((input (caar tests))
	     (output (cadar tests))
	     (result (proc input)))
	(if (not (equal? result output))
	    (format (current-output-port) 
		    "Error: input ~a yields ~a instead of ~a~%" 
		    input result output))
	(test-proc proc (cdr tests)))))

;;; Part 8. NOTES:
;;; Representing Scheme Values
;;;   It's convenient (actually, kind of obvious) to represent most Scheme-1 
;;;   values "as themselves".  Thus, the Scheme values used in the evaluator  
;;;   to represent all Scheme-1's values other than closures (i.e., the 
;;;   results of evaluating lambda expressions) will be those values 
;;;   themselves: evaluating 3 in Scheme-1 yields 3, (cons 1 2), 
;;;   yields (1 . 2), and so forth.  
;;;
;;;   For lambda, we have a little problem.  You might think we could 
;;;   simply represent result of evaluating (lambda (x) x) as the list
;;;   (lambda (x) x), but then how do we tell the value of 
;;;      (lambda (x) x)
;;;   from the value of
;;;      (list 'lambda (list 'x) 'x)  
;;;   or of
;;;      '(lambda (x) x)  ?
;;;   So in Scheme-1, we're going to "mark" closures with a special value,
;;;   closure-mark, defined below.  This value will have the property that 
;;;   no value a user can produce with a Scheme-1 program can be eq? to it.
;;;   We will represent a Scheme-1 closure value, then, with a Scheme list
;;;   of the form
;;;       (<closure> (ARGUMENTS) BODY ENV), 
;;;   where <closure> here stands for the value of closure-mark.  ENV is
;;;   the inner environment at the time the lambda is evaluated (that is,
;;;   enclosing parameter definitions, but not the outer environment, which
;;;   contains predefined names and the results of 'defines').