; XMLScheme (c) Markus Lumpe & EOPL2 (parts)

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

;
; Basic syntax:
;
; program ::= expression
;
; declarations ::=
;  "<declarations" 
;     {"<declaration" "<variable" "value" "=" identifier "/>" expression "/>"}* "/>"
;
; expression ::=
;    "<proc" formals expression "/>"
;    "<invoke" expression arguments "/>"
;    "<let" declarations expression "/>"
;    "<if" "<condition" expression "/>" 
;          "<then" expression "/>"
;          "<else" expression "/>"
;    "<integer" "value" "=" number "/>" 
;    "<reference" "name" "=" identifier "/>"
;    "<" prim-op arguments "/>"
;
; prim-op ::=
;    "add" 
;    "sub"
;    "mul"
;    "inc"
;    "dec"
;
; arguments ::=
;   "<arguments" {expression}* "/>"
;
; formals ::=
;   "<params" {param}* "/>"
;
; param ::=
;   "<param" "value" "=" identifier "/>"
;

(define grammar-spec
  '(
    (program 
     (expression)                                              a-program)
    (formals
     ("<params"
        (arbno "<param" "value" "=" identifier "/>") "/>")     param-decls)
    (declarations
     ("<declarations"
        (arbno "<declaration" 
                 "<variable" "value" "=" identifier "/>"
                 expression "/>")
        "/>")                                                  let-decls)
    (expression
     ("<proc" formals expression "/>")                         proc-exp)
    (expression
     ("<invoke" expression
                "<arguments" (arbno expression) "/>" "/>")     app-exp) 
    (expression
     ("<let" declarations expression "/>")                     let-exp)
    (expression
     ("<if" "<condition" expression "/>"
            "<then" expression "/>"
            "<else" expression "/>" "/>")                      if-exp)
    (expression
     ("<integer" "value" "=" number "/>")                      lit-exp)
    (expression
     ("<reference" "value" "=" identifier "/>")                var-exp)
    (expression
     ("<" prim-op "<arguments" (arbno expression) "/>" "/>")   primapp-exp)
    (prim-op
     ("add")                                                   add-prim)
    (prim-op
     ("sub")                                                   sub-prim)
    (prim-op
     ("mul")                                                   mult-prim)
    (prim-op
     ("inc")                                                   inc-prim)
    (prim-op
     ("dec")                                                   dec-prim)
    )
  )

;; build the scanner and parser
(define front-end
  (sllgen:make-string-parser scanner-spec grammar-spec))

;; build the define-datatype definitions

(define-datatype program program?
  (a-program 
    (exp expression?))
)

(define-datatype pdeclarations pdeclarations?
  (param-decls
    (ids (list-of symbol?)))
  )

(define-datatype declarations declarations?
  (let-decls
    (ids (list-of symbol?))
    (rands (list-of expression?)))
  )

(define-datatype expression expression?
  (proc-exp
     (ids pdeclarations?)
     (body expression?))
  (app-exp
     (rator expression?)
     (rands (list-of expression?)))
  (let-exp
    (decls declarations?)
    (body expression?))
  (if-exp
    (test-exp expression?)
    (then-exp expression?)
    (else-exp expression?))
  (lit-exp 
    (datum number?))
  (var-exp 
    (id symbol?))
  (primapp-exp 
    (prim primitive?) 
    (rands (list-of expression?)))
)

(define-datatype primitive primitive?
  (add-prim)
  (sub-prim)
  (mult-prim)
  (inc-prim)
  (dec-prim)
)	

(load "environment.scm")

(define init-env
  (lambda ()
     (extend-env '(i v x) '(1 5 10) (empty-env))
    )
  )

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

(define is-true?
  (lambda (x)
    (not (zero? x))
    )
  )

(define get-rands
  (lambda (decls)
    (cases declarations decls
      (let-decls (ids rands)
         rands)
      )
    )
  )

(define get-ids
  (lambda (decls)
    (cond
      ((declarations? decls)
         (cases declarations decls
           (let-decls (ids rands)
             ids)))
      ((pdeclarations? decls)
         (cases pdeclarations decls
           (param-decls (ids)
              ids)))
      )
    )
  )

(load "closure.scm")

(define eval-expression
  (lambda (exp env)
    (cases expression exp
      (proc-exp (params body)
        (closure (get-ids params) body env))
      (app-exp (rator rands)
        (let ((proc (eval-expression rator env))
	      (args (eval-rands rands env)))
             (if (procval? proc)
		 (apply-procval proc args)
	         (eopl:error 'eval-expression
		             "Attempt to apply non-procedure ~s" proc))))
      (let-exp (decls body)
        (let ((args (eval-rands (get-rands decls) env)))
	     (eval-expression body (extend-env (get-ids decls) args env))))
      (if-exp (test-exp true-exp false-exp)
	(if (is-true? (eval-expression test-exp env))
            (eval-expression true-exp env)
            (eval-expression false-exp env)))
      (lit-exp (datum) datum)
       (var-exp (id) (apply-env env id))
       (primapp-exp (prim rands)
         (let ((args (eval-rands rands env)))
              (apply-primitive prim args)))
      )
    )
  )

(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 apply-primitive
  (lambda (prim args)
    (cases primitive prim
;       (add-prim () (+ (car args) (cadr args))) 
       (add-prim () (fold-left args + 0)) 
;       (sub-prim () (- (car args) (cadr args))) 
       (sub-prim () (fold-left (cdr args) - (car args))) 
;       (mult-prim () (* (car args) (cadr args)))
       (mult-prim () (fold-left args * 1))
       (inc-prim () (+ (car args) 1))
       (dec-prim () (- (car args) 1))
      )
    )
  )

(define interpreter
  (lambda (string)
    (eval-program (front-end string))
    )
  )

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

(load "readfile.scm")

(define run-from-file
  (lambda (fname)
    (interpreter (read-file fname))
    )
  )

(define parse-from-file
  (lambda (fname)
    (front-end (read-file fname))
    )
  )