;;C-EVAL.SCM

;;6.001 PROJECT 3: EXPLICIT-CONTINUATION EVALUATOR  


;;C-EVAL
;evaluate Scheme expression EXPR in environment ENV and
;pass its value to the "continuation" procedure CONT:
(define (c-eval expr env cont)
  (cond ((self-evaluating? expr) (cont expr))
        ((variable? expr) (lookup-variable-value expr env cont))
        ((quoted? expr) (cont (text-of-quotation expr)))
        ((assignment? expr) (eval-assignment expr env cont))
        ((definition? expr) (eval-definition expr env cont))
        ((if? expr) (eval-if expr env cont))
        ((lambda? expr)
         (cont (make-procedure
                (lambda-parameters expr)
                (lambda-body expr)
                env)))
        ((begin? expr)
         (eval-sequence (begin-actions expr) env cont))
        ((application? expr)
         (c-eval (operator expr) env
                 (lambda (op)
                   (eval-args-and-apply op (operands expr) env cont))))
        (else (fatal-c-eval-error
               "Unknown expression type -- C-EVAL" expr))))


;;EVAL-SEQUENCE
;EXPRS is a non-null list of expressions.  Evaluate EXPRS in
;environment ENV and pass the value of the last one to procedure CONT:
(define (eval-sequence exprs env cont)
  (if (null? (cdr exprs))
      (c-eval (car exprs) env cont)
      (c-eval (car exprs) env
              (lambda (ignore)
                (eval-sequence (cdr exprs) env cont)))))


;;EVAL-ARGS-AND-APPLY
;evaluate RANDS in environment ENV, apply OP to the list of values
;of RANDS, and pass the result of the application to procedure CONT:
(define (eval-args-and-apply op rands env cont)
  (let ((apply-and-continue
         (lambda (arg-vals)
           (c-apply op arg-vals cont))))
    (list-of-values rands env apply-and-continue)))


;;LIST-OF-VALUES
;evaluate RANDS in environment ENV and pass the list 
;of values of RANDS to the procedure CONT:
(define (list-of-values rands env cont)
  (if (null? rands)
      (cont nil)
      (c-eval
       (car rands) env
       (lambda (arg-val)
         (list-of-values
          (cdr rands) env
          (lambda (rest-vals)
            (cont (cons arg-val rest-vals))))))))

;;C-APPLY
;apply OP to ARG-VALS and pass the result to procedure CONT:
(define (c-apply op arg-vals cont)
  (cond ((primitive-procedure? op)
         (cont (apply-primitive-procedure op arg-vals)))
        ((compound-procedure? op)
         (eval-sequence
          (procedure-body op)
          (extend-environment
           (procedure-parameters op)
           arg-vals
           (procedure-environment op))
          cont))
        ((special-procedure? op)
         (apply-special op arg-vals cont))
        (else (fatal-c-eval-error
               "Unknown procedure type -- C-APPLY" op))))


;;APPLY-PRIMITIVE-PROCEDURE
;apply procedure in underlying Scheme:
(define (apply-primitive-procedure op vals)
  (apply                                ;SCHEME'S APPLY
   (primitive-implementation op) vals))


;;APPLY-SPECIAL
(define (apply-special op vals cont)
  (let ((name (special-op-name op)))
    (cond
     ((eq? '*apply name)
      (c-apply (first vals) (second vals) cont))
     ((eq? '*error name)                ;CONT IS IGNORED HERE
      (apply fatal-c-eval-error vals))
     ((eq? '*exit name)
      "exited C-EVAL")
     (else (fatal-c-eval-error
            "unknown operator -- APPLY-SPECIAL" op)))))

;;EVAL-IF
;evaluate IF expression EXPR in environment ENV and
;pass its value to procedure CONT:
(define (eval-if expr env cont)
  (let ((choose-branch-eval-and-continue
         (lambda (pred-val)
           (let ((next-branch
                  (if pred-val
                      (if-consequent expr)
                      (if-alternative expr))))
             (c-eval next-branch env cont)))))
    (c-eval
     (if-predicate expr) env choose-branch-eval-and-continue)))


;;EVAL-ASSIGNMENT
;evaluate the SET! expression EXPR in environment ENV to update
;a binding in ENV.  Pass an unspecified value to CONT:
(define (eval-assignment expr env cont)
  (c-eval (assignment-value expr) env
          (lambda (val)
            (set-variable-value!
             (assignment-variable expr) val env cont))))


;;EVAL-DEFINITION
;evaluate the DEFINE expression EXPR in environment ENV to
;update a binding in the first frame of ENV.  Pass an
;unspecified value to CONT:
(define (eval-definition expr env cont)
  (c-eval (definition-value expr) env
          (lambda (val)
            (define-variable!
              (definition-variable expr) val env cont))))


;;FATAL-C-EVAL-ERROR
;display error message and return an unspecified
;value directly to the superior READ-EVAL-PRINT-LOOP
(define (fatal-c-eval-error . stuff)
  (display "FATAL-C-EVAL-ERROR: ")
  (map (lambda (item) (c-print item) (display " ")) stuff)
  *unspecified)


;;INTERPRETATION-ERROR
;display error message and restart the C-EVAL read-eval-print-loop
(define (interpretation-error . stuff)
  (display "C-EVAL INTERPETATION ERROR: ")
  (map (lambda (item) (c-print item) (display " ")) stuff)
  (newline)
  (restart-c-eval))


;;PROCEDURE VALUES

;COMPOUND PROCEDURE ADT
;same as in lecture (except for the tag)

(define (make-procedure parameters body env)
  (list procedure-tag parameters body env))
(define procedure-tag (list 'procedure))  ;the tag will be a unique CONS-cell
(define (compound-procedure? expr)
  (tagged-list? expr procedure-tag))
(define (procedure-parameters p) (second p))
(define (procedure-body p) (third p))
(define (procedure-environment p) (fourth p))

;C-EVAL PRIMITIVE PROCEDURE ADT
;same as in lecture (except for the tag)

(define (make-primitive-procedure scheme-proc)
  (list primitive-tag scheme-proc))
(define primitive-tag (list 'primitive))
(define (primitive-implementation proc) (second proc))
(define (primitive-procedure? proc)
  (tagged-list? proc primitive-tag))

;SPECIAL PROCEDURE ADT
(define (make-special-procedure name . maybe)
  (cons special-tag (cons name maybe)))
(define (special-op-name op)
  (second op))
(define (special-procedure? op)
  (tagged-list? op special-tag))
(define special-tag (list 'special))


;;ENVIRONMENTS

;Same as in lecture:
;; Implement environments as a list of frames; parent environment is
;; the cdr of the list.  Each frame will be implemented as a list
;; of variables and a list of corresponding values.

(define (enclosing-environment env) (cdr env))
(define (first-frame env) (car env))
(define the-empty-environment '())

;;MAKE-FRAME
; modified from lecture to handle DOTTED PARAMETERS
(define (make-frame variables values)
  (define (iter vars reverse-vars vals reverse-vals)
    (cond
     ((null? vars)
      (cons reverse-vars reverse-vals))
     ((symbol? vars)  ;DOTTED PARAMETER
      (cons
       (cons vars reverse-vars)
       (cons vals reverse-vals)))
     (else
      (iter (cdr vars)
            (cons (car vars) reverse-vars)
            (cdr vals)
            (cons (car vals) reverse-vals)))))
  (iter variables nil values nil))

(define (frame-variables frame) (car frame))
(define (frame-values frame) (cdr frame))
(define (add-binding-to-frame! var val frame)
  (set-car! frame (cons var (car frame)))
  (set-cdr! frame (cons val (cdr frame))))

(define (extend-environment vars vals base-env)
  (cons (make-frame vars vals) base-env))


;;LOOKUP-VARIABLE-VALUE
;lookup the value of variable VAR in environment ENV and
;pass the value to procedure CONT:
(define (lookup-variable-value var env cont)
  (define (env-loop env)
    (define (scan vars vals)
      (cond ((null? vars)
             (env-loop (enclosing-environment env)))
            ((eq? var (car vars)) (cont (car vals)))
            (else (scan (cdr vars) (cdr vals)))))
    (if (eq? env the-empty-environment)
        (interpretation-error
          "Unbound variable -- LOOKUP" var)
        (let ((frame (first-frame env)))
          (scan (frame-variables frame) (frame-values frame)))))
  (env-loop env))


;;SET-VARIABLE-VALUE!
;find the binding of variable VAR in environment ENV and
;reset its value to VAL.  Pass an unspecified value to procedure CONT:
(define (set-variable-value! var val env cont)
  (define (env-loop env)
    (define (scan vars vals)
      (cond ((null? vars)
             (env-loop (enclosing-environment env)))
            ((eq? var (car vars))
             (set-car! vals val)
             (cont *unspecified))
            (else (scan (cdr vars) (cdr vals)))))
    (if (eq? env the-empty-environment)
        (interpretation-error "Unbound variable -- SET!" var)
        (let ((frame (first-frame env)))
          (scan (frame-variables frame) (frame-values frame)))))
  (env-loop env))

(define *unspecified (list 'unspecified))


;;DEFINE-VARIABLE!
;find the binding of variable VAR in the first frame of environment
;ENV, or add such a binding to the frame if there is none.  Reset
;the value in the binding to VAL, and pass an unspecified value to CONT:
(define (define-variable! var val env cont)
  (let ((frame (first-frame env)))
    (define (scan vars vals)
      (cond ((null? vars)
             (add-binding-to-frame! var val frame)
             (cont (string-append
                    (symbol->string var)
                    " DEFINED!")))
            ((eq? var (car vars))
             (set-car! vals val)
             (cont (string-append
                    (symbol->string var)
                    " REDEFINED!")))
            (else (scan (cdr vars) (cdr vals)))))
    (scan (frame-variables frame)
          (frame-values frame))))


;;THE INITIAL ENVIRONMENT

;;MAKE-INITIAL-ENVIRONMENT
(define (make-initial-environment)
  (let* ((c-pair?
          (lambda (x)
            (and (pair? x)
                 (not (primitive-procedure? x))
                 (not (compound-procedure? x))
                 (not (special-procedure? x)))))
         (c-eval-primitive-procedure-bindings
          (list
           (list 'car car)
           (list 'cdr cdr)
           (list 'cons cons)
           (list 'null? null?)
           (list 'list list)
           (list 'length length)
           (list 'eq? eq?)
           (list 'caar caar)
           (list 'cadr cadr)
           (list 'cdar cdar)
           (list 'cddr cddr)
           (list 'first first)
           (list 'second second)
           (list 'third third)
           (list 'fourth fourth)
           (list 'cdddr cdddr)
           (list 'boolean? boolean?)
           (list 'not not)
           (list 'number? number?)
           (list 'string? string?)
           (list 'string-append string-append)
           (list 'number->string number->string)
           (list 'symbol? symbol?)
           (list 'symbol->string symbol->string)
           (list 'string->symbol string->symbol)
           (list 'string=? string=?)
           (list 'string-length string-length)
           (list 'string-head string-head)
           (list '> >)
           (list '< <)
           (list '= =)
           (list '+ +)
           (list '- -)
           (list '* *)
           (list 'read read)
           (list 'pretty-print pretty-print)
           (list 'desugar desugar)      ;defined in DESUGAR.SCM
           (list 'dynamic? dynamic?)    ;defined for Part 2 
           ;;CUSTOMIZED BUILTINS FOR C-EVAL:
           (list 'pair? c-pair?)
           (list 'set-car!
                 (lambda (l v) (set-car! l v) *unspecified))
           (list 'set-cdr!
                 (lambda (l v) (set-cdr! l v) *unspecified))
           (list 'newline
                 (lambda () (newline) *unspecified))
           (list 'display
                 (lambda (stuff) (display stuff) *unspecified))))
         (primitive-procedure-names
          (map first
               c-eval-primitive-procedure-bindings))
         (c-eval-primitive-procedures
          (map (lambda (binding)
                 (make-primitive-procedure (second binding)))
               c-eval-primitive-procedure-bindings))
         (initial-env
          (extend-environment primitive-procedure-names
                              c-eval-primitive-procedures
                              the-empty-environment))
         (frame1 (first-frame initial-env)))
    (add-binding-to-frame! 'true #t frame1)
    (add-binding-to-frame! 'false #f frame1)
    (add-binding-to-frame! 'nil (list) frame1)
    (add-binding-to-frame!
     'apply (make-special-procedure '*apply) frame1)
    (add-binding-to-frame!
     'error (make-special-procedure '*error) frame1)
    (add-binding-to-frame!
     'exit (make-special-procedure '*exit) frame1)
    (add-binding-to-frame!
     'append
     (make-procedure
      '(l1 l2)
      '((if (null? l1)
            l2
            (cons (car l1)
                  (append (cdr l1) l2))))
      initial-env) frame1)
    initial-env))


;;THE READ-EVAL-PRINT LOOP

(define the-global-environment 'dummy)
(define restart-c-eval 'dummy)

;;START-C-EVAL
(define (start-c-eval n)
  (define (driver-loop)
    (prompt-for-input (input-prompt n))
    (c-eval (desugar (read))            ;AN EXPRESSION FROM USER INPUT
            the-global-environment
            (lambda (output)
              (announce-output (output-prompt n))
              (c-print output)
              (driver-loop))))
  (set! the-global-environment (make-initial-environment))
  (set! restart-c-eval driver-loop)
  (driver-loop))


(define (prompt-for-input string)
  (newline) (newline) (display string) (newline))
(define (announce-output string)
  (newline) (display string))

(define (input-prompt n)
  (string-append
   ";;C-Eval" (number->string n) ">> "))

(define (output-prompt n)
  (string-append
   ";;C-Eval" (number->string n) " value: "))


;;SYNTAX
;Essentially same as in Lecture

(define (tagged-list? expr tag)
  (and (pair? expr) (eq? (car expr) tag)))

(define (self-evaluating? expr)
  (or (number? expr) (string? expr) (boolean? expr)))

(define (quoted? expr) (tagged-list? expr 'quote))
(define (text-of-quotation expr) (second expr))

(define (variable? expr) (symbol? expr))
(define (assignment? expr) (tagged-list? expr 'set!))
(define (assignment-variable expr) (second expr))
(define (assignment-value expr) (third expr))

(define (definition? expr) (tagged-list? expr 'define))
(define (definition-variable expr)
  (let ((definiens (second expr)))
    (if (symbol? definiens)
        definiens
        (first definiens))))
(define (definition-value expr)
  (let ((definiens (second expr)))
    (if (symbol? definiens)
        (third expr)
        (make-lambda (cdr definiens)    ;formal params
                     (cddr expr)))))    ;body

(define (lambda? expr) (tagged-list? expr 'lambda))
(define (lambda-parameters lambda-expr) (second lambda-expr))
(define (lambda-body lambda-expr) (cddr lambda-expr))
(define (make-lambda parms body)
  (cons 'lambda (cons parms body)))

(define (if? expr) (tagged-list? expr 'if))
(define (if-predicate expr) (second expr)) 
(define (if-consequent expr) (third expr)) 
(define (if-alternative expr)
  (if (not (null? (cdddr expr))) (fourth expr) 'false))

(define (begin? expr) (tagged-list? expr 'begin))
   ;BEGIN-ACTIONS returns a nonnull LIST of expressions:
(define (begin-actions begin-expr) (cdr begin-expr))

(define (application? expr) (pair? expr))
(define (operator app) (first app))
(define (operands app) (cdr app))
(define (no-operands? rands) (null? rands))
(define (first-operand rands) (first rands))
(define (rest-operands rands) (cdr rands))


;;PRINTING

;;C-PRINT
;print a c-eval value in readable format
(define (c-print val)
  (let ((global-frame (first-frame the-global-environment)))
    (define (make-printable object)
      (cond
       ((not (pair? object)) object)
       ((eq? object global-frame)
        '*the-global-env*)
       ((compound-procedure? object)
        (list
         '*compound-proc:
         (cons '*params: (procedure-parameters object))
         (cons '*body: (procedure-body object))
         (let ((env (procedure-environment object)))
           (cons
            '*vars-in-frames:
            (map (lambda (frame)
                   (if (eq? frame global-frame)
                       '*the-global-env*
                       (car frame)))
                 env)))))
       ((eq? *unspecified object) (car object))
       ((special-procedure? object)
        (let ((name (special-op-name object)))
          (cond ((null? (cddr object)) name)
                ((null? (cdddr object))
                 (list name (make-printable (third object))))
                (else (cons name
                            (apply make-printable (cddr object)))))))
       (else
        (cons (make-printable (car object))
              (make-printable (cdr object))))))
    (pretty-print (make-printable val))))


(define (dynamic? var)
  (let ((string-name (symbol->string var)))
    (and (> (string-length string-name) 2)
         (string=? "%d-" (string-head string-name 3)))))