;; D.S. Blank
;; DaGym Version #3

(load "chez-init.scm")

(define scanner
  '((white-sp (whitespace) skip)
    (comment ("%" (arbno (not #\newline))) skip)
    (id ((or letter "*" "+" "-") (arbno (or letter digit "?"))) symbol)
    (string ("\"" (arbno (not #\")) "\"") string)
    (number (digit (arbno digit)) number)))

(define grammar
  '((program (expression) a-program)
    (expression (number) lit-exp)
    (expression (string) string-exp)
    (expression (id) var-exp)
    (expression ("fn" "(" (separated-list id ",") ")" "[" expression "]")
		proc-exp)
    (expression ("da-" expression "(" (separated-list expression ",") ")")
		app-exp)
    (expression ( "&" expression "(" (separated-list expression ",") ")")
		app-exp)
    (expression ("if" expression "then" expression "else" expression) 
		if-exp)
    (expression ("let" "(" (separated-list id "=" expression ",") ")" 
		 "in" expression) 
		let-exp)
    (expression ("letrec" "(" (separated-list id "=" expression ",") ")" 
		 "in" expression) 
		letrec-exp)
    (expression ("(" expression expression expression ")") infix-exp)
    (expression ("set" id "=" expression) set-exp)
    (expression ("{" (arbno expression ";") "}") begin-exp)
    (expression ("#reload") reload-pragma)
    (expression ("#exit") exit-pragma)
    ))

(define scan&parse (sllgen:make-string-parser scanner grammar))

(sllgen:make-define-datatypes scanner grammar)

(define eval-program
  (lambda (pgm)
    (cases program pgm
	   (a-program (body)
		      (eval-expression body init-env)))))

(define apply-env
  (lambda (env sym)
    (if (null? env)
	(eopl:error 'apply-env "No binding for ~s" sym)
	(let ((syms (car (car env)))
	      (vals (cadr (car env)))
	      (env (cdr env)))
	  (let ((pos (list-find-position sym syms)))
	    (if (number? pos)
		(list-ref vals pos)
		(apply-env env sym)))))))

(define list-find-position
  (lambda (sym syms)
    (list-index (lambda (sym1) (eqv? sym1 sym)) syms)))

(define list-index
  (lambda (pred ls)
    (cond
     ((null? ls) #f)
     ((pred (car ls)) 0)
     (else (let ((list-index-r (list-index pred (cdr ls))))
	     (if (number? list-index-r)
		 (+ list-index-r 1)
		 #f))))))

(define eval-expression 
  (lambda (exp env)
    (cases expression exp
	   (lit-exp (datum) datum)
	   (string-exp (datum) (substring datum 1 
					  (- (string-length datum) 1)))
	   (var-exp (id) (unbox (apply-env env id)))
	   (if-exp (test-exp true-exp false-exp)
		   (if (true-value? (eval-expression test-exp env))
		       (eval-expression true-exp env)
		       (eval-expression false-exp env)))
	   (let-exp (ids rands body)
		    (let ((args (eval-rands rands env)))
		      (eval-expression body (extend-env ids args env))))
	   (proc-exp (ids body)
		     (make-closure ids body env))
	   (app-exp (rator rands)
		    (if (member? (cadr rator) primitives)
			(apply-primitive (cadr rator) (eval-rands rands env))
			(apply-procval (eval-expression rator env) 
				       (eval-rands rands env))))
	   (infix-exp (e1 rator e2)
		      (if (member? (cadr rator) primitives)
			  (apply-primitive (cadr rator) 
					   (eval-rands (list e1 e2) env))
			  (apply-procval (eval-expression rator env) 
					 (eval-rands (list e1 e2) env))))
	   (letrec-exp (ids rands body) (display (list ids rands body)))
	   (set-exp (id exp) (let ((box (apply-env env id))
				   (val (eval-expression exp env)))
			       (set-car! box val)
			       val))
	   (begin-exp (exp-list) (eval-expression-list exp-list env))
	   (reload-pragma () (begin (load "dagym-3.ss")))
	   (exit-pragma () (abort))
	   )))

(define eval-expression-list
  (lambda (exp-list env)
    (cond
     ((null? exp-list) 'void) ;; error?
     ((null? (cdr exp-list)) (eval-expression (car exp-list) env))
     (else (begin (eval-expression (car exp-list) env)
		  (eval-expression-list (cdr exp-list) env))))))

(define member?
  (lambda (a list)
    (cond
     ((null? list) #f)
     ((eqv? a (car list)) #t)
     (else (member? a (cdr list))))))

(define primitives
  '(list car cdr cons print println
	 + * - minus add1 sub1 exit equal?
	 zero? greater? less? load))

(define make-closure
  (lambda (ids body env)
    (list ids body env)))

(define apply-procval
  (lambda (closure args)
    (let ((ids (car closure))
	  (body (cadr closure))
	  (env (caddr closure)))
      (eval-expression body (extend-env ids args env)))))

(define eval-rands
  (lambda (rands env)
    (map (lambda (x) (eval-rand x env)) rands)))

(define eval-rand
  (lambda (rand env)
    (eval-expression rand env)))

(define true-value?
  (lambda (exp)
    (not (zero? exp))))

(define apply-primitive
  (lambda (prim args)
    (case prim
      ('+    (+ (car args) (cadr args)))
      ('-    (- (car args) (cadr args)))
      ('*    (* (car args) (cadr args)))
      ('add1 (+ (car args) 1))
      ('sub1 (- (car args) 1))
      ('car  (car (car args)))
      ('cdr       (cdr (car args)))
      ('cons      (cons (car args) (cadr args)))
      ('minus     (- (car args)))
      ('list      args)
      ('println   (begin (display (car args))
				(newline)
				1))
      ('print     (begin (display (car args))
				1))
      ('exit      (exit))
      ('equal?    (if (= (car args) (cadr args)) 1 0))
      ('zero?     (if (zero? (car args)) 1 0))
      ('greater?  (if (> (car args) (cadr args)) 1 0))
      ('less?     (if (< (car args) (cadr args)) 1 0))
      ('load      (load-dagym-file (car args)))
      )))

(define load-dagym-file
  (lambda (filename)
    (if (file-exists? filename)
        (let ((in (open-input-file filename)))
          (eval-program (scan&parse (list->string (file->list in)))))
	'file-not-found-error)))

(define file->list
  (lambda (in)
    (let ((c (read-char in)))
      (cond
       ((eof-object? c) '())
       (else (cons c (file->list in)))))))

(define box list)
(define unbox car)

(define empty-env '())

(define extend-env
  (lambda (syms vals env)
    (cons (list syms (map box vals)) env)))

(define init-env
  (extend-env 
   '(emptylist)
   '(())
   empty-env))

(define run
  (lambda (string)
    (eval-program (scan&parse string))))

(define read-eval-print
  (sllgen:make-rep-loop "--> " 
			eval-program
			(sllgen:make-stream-parser
			 scanner grammar)))

(define rep read-eval-print)

(rep)