; 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)
    (verbatim
     ("$" (arbno (not #\$)) "$")                   string)
    )
  )

;
; Basic syntax:
;
; program ::= expression
;
; declarations ::=
;  "<declarations" 
;     {"<declaration" "<variable" "value" "=" identifier "/>" expression "/>"}* "/>"
;
; i-vars ::= "<variables" {ivar}* "/>"
;
; methods ::= "<methods" {method}* "/>"
;
; expression ::=
;    "<sequence" {expression}* "/>"
;    "<object" {i-vars}* {methods}* "/>"
;    "<set" "<variable" "value" "=" identifier "/>" expression "/>"
;    "<loop" declarations 
;            "<conditions" {expression}+ /> 
;            "<increments" {expression}+ /> expression "/>"
;    "<reclet" declarations expression "/>"
;    "<href" "value" "=" identifier "/>"
;    "<proc" formals expression "/>"
;    "<send" "<message" "name" "=" identifier "/>" expression arguments "/>"
;    "<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"
;   ; new operations :
;    "div" | "equal" | "less" | "greater" | "not" | "and" | "or"
;
; arguments ::=
;   "<arguments" {expression}* "/>"
;
; formals ::=
;   "<params" {param}* "/>"
;
; param ::=
;   "<param" "value" "=" identifier "/>"
;   "<param" "byref" "=" identifier "/>"
;

(define expression-spec
  '(
    (expression
     ("<loop" 
         opt-declarations opt-conditions opt-increments
         expression "/>")                                      loop-exp)
    (expression
     ("<class" formals i-vars methods "/>")                    class-exp)
    (expression
     ("<set" "<variable" "value" "=" identifier "/>"
                 expression "/>")                              assign-exp)
    (expression
     ("<sequence" expression (arbno expression) "/>")          seq-exp)
    (expression
     ("<proc" formals expression "/>")                         proc-exp)
    (expression
     ("<send" "<message" "name" "=" identifier "/>"
           expression
                "<arguments" (arbno expression) "/>" "/>")     send-exp) 
    (expression
     ("<invoke" expression
                "<arguments" (arbno expression) "/>" "/>")     app-exp) 
    (expression
     ("<reclet" declarations expression "/>")                  reclet-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
     ("<href" "value" "=" identifier "/>")                     extern-exp)
    ; we require at least one argument now
    (expression
     ("<" prim-op "<arguments" expression 
                               (arbno expression) "/>" "/>")   primapp-exp)
    (expression
     ("<verbatim" verbatim "/>")                               verbatim-exp)
    (i-vars
     ()                                                        empty-ivars)
    (i-vars
     ("<instances"
        (arbno "<instance" 
                 "<variable" "value" "=" identifier "/>"
                 expression "/>")
        "/>")                                                  ivar-decls)
    (methods
     ()                                                        empty-methods)
    (methods
     ("<methods"
        (arbno "<method" 
                 "<name" "value" "=" identifier "/>"
                 formals
                 expression "/>")
        "/>")                                                  method-decls)
    (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)    
    (prim-op
     ("div")                                                   div-prim)
    (prim-op
     ("equal")                                                 equal-prim)
    (prim-op
     ("less")                                                  less-prim)
    (prim-op
     ("greater")                                               greater-prim)
    (prim-op
     ("not")                                                   not-prim)
    (prim-op
     ("and")                                                   and-prim)
    (prim-op
     ("or")                                                    or-prim)
    (formals
     ("<params" 
        (arbno "<param" formal-mode "=" identifier "/>") 
          "/>")                                                param-decls)
    (formal-mode
     ("value")                                                 mode-value)
    (formal-mode
     ("byref")                                                 mode-byref)
    (declarations
     ("<declarations"
        (arbno "<declaration" 
                 "<variable" "value" "=" identifier "/>"
                 expression "/>")
        "/>")                                                  let-decls)
    (opt-declarations
     ()                                                        empty-decl-list)
    (opt-declarations
     (declarations)                                            decl-list)
    (opt-conditions
     ()                                                        empty-exp-list)
    (opt-conditions
     ("<conditions" expression (arbno expression) "/>")        exp-list)
    (opt-increments
     ()                                                        empty-exp-list)
    (opt-increments
     ("<increments" expression (arbno expression) "/>")        exp-list)
    )
  )

(define grammar-spec
  '(
    (program 
     (expression)                                              a-program)
    (formals
     ("<params" 
        (arbno "<param" formal-mode "=" identifier "/>") 
          "/>")                                                param-decls)
    (formal-mode
     ("value")                                                 mode-value)
    (formal-mode
     ("byref")                                                 mode-byref)
    (i-vars
     ()                                                        empty-ivars)
    (i-vars
     ("<instances"
        (arbno "<instance" 
                 "<variable" "value" "=" identifier "/>"
                 expression "/>")
        "/>")                                                  ivar-decls)
    (methods
     ()                                                        empty-methods)
    (methods
     ("<methods"
        (arbno "<method" 
                 "<name" "value" "=" identifier "/>"
                 formals
                 expression "/>")
        "/>")                                                  method-decls)
    (declarations
     ("<declarations"
        (arbno "<declaration" 
                 "<variable" "value" "=" identifier "/>"
                 expression "/>")
        "/>")                                                  let-decls)
    (opt-declarations
     ()                                                        empty-decl-list)
    (opt-declarations
     (declarations)                                            decl-list)
    (opt-conditions
     ()                                                        empty-exp-list)
    (opt-conditions
     ("<conditions" expression (arbno expression) "/>")        exp-list)
    (opt-increments
     ()                                                        empty-exp-list)
    (opt-increments
     ("<increments" expression (arbno expression) "/>")        exp-list)
    (expression
     ("<loop" 
         opt-declarations opt-conditions opt-increments
         expression "/>")                                      loop-exp)
    (expression
     ("<class" formals i-vars methods "/>")                    class-exp)
    (expression
     ("<sequence" expression (arbno expression) "/>")          seq-exp)
    (expression
     ("<set" "<variable" "value" "=" identifier "/>"
                 expression "/>")                              assign-exp)
    (expression
     ("<href" "value" "=" identifier "/>")                     extern-exp)
    (expression
     ("<proc" formals expression "/>")                         proc-exp)
    (expression
     ("<send" "<message" "name" "=" identifier "/>"
           expression
                "<arguments" (arbno expression) "/>" "/>")     send-exp) 
    (expression
     ("<invoke" expression
                "<arguments" (arbno expression) "/>" "/>")     app-exp) 
    (expression
     ("<reclet" declarations expression "/>")                  reclet-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)
    ; we require at least one argument now
    (expression
     ("<" prim-op "<arguments" expression 
                               (arbno expression) "/>" "/>")   primapp-exp)
    (expression
     ("<verbatim" verbatim "/>")                               verbatim-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)
    (prim-op
     ("div")                                                   div-prim)
    (prim-op
     ("equal")                                                 equal-prim)
    (prim-op
     ("less")                                                  less-prim)
    (prim-op
     ("greater")                                               greater-prim)
    (prim-op
     ("not")                                                   not-prim)
    (prim-op
     ("and")                                                   and-prim)
    (prim-op
     ("or")                                                    or-prim)
    )
  )

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

;; build the expression parser (XMLScheme5)
(define expression-parser
  (sllgen:make-string-parser scanner-spec expression-spec))

;; build the define-datatype definitions

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

(define-datatype pdeclarations pdeclarations?
  (param-decls
    (modes (list-of pmode?))
    (ids (list-of symbol?)))
  )
  
(define-datatype pmode pmode?
  (mode-value)
  (mode-byref)
  )
  
(define-datatype declarations declarations?
  (let-decls
    (ids (list-of symbol?))
    (rands (list-of expression?)))
  )

(define-datatype declaration-list declaration-list?
  (empty-decl-list)
  (decl-list
     (decls declarations?))
  )

(define-datatype expression-list expression-list?
  (empty-exp-list)
  (exp-list
     (exp expression?)
     (tail (list-of expression?)))
  )

(define-datatype i-vars i-vars?
  (empty-ivars)
  (ivar-decls
     (ids (list-of symbol?))
     (rands (list-of expression?)))
  )
    
(define-datatype methods methods?
  (empty-methods)
  (method-decls
     (ids (list-of symbol?))
     (params (list-of pdeclarations?))
     (bodies (list-of expression?)))
  )

(define-datatype expression expression?
  (seq-exp
   (exp expression?)
   (exps (list-of expression?)))
  (verbatim-exp
   (code string?))
  (class-exp
   (params pdeclarations?)
   (i-decls i-vars?)
   (m-decls methods?))
  (assign-exp
   (id symbol?)
   (exp expression?))
  (loop-exp
    (decls declaration-list?)
    (conds expression-list?)
    (incrs expression-list?)
    (body expression?))
  (reclet-exp
    (decls declarations?)
    (body expression?))
  (extern-exp
     (unit symbol?))
  (proc-exp
     (ids pdeclarations?)
     (body expression?))
  (send-exp
     (mid symbol?)
     (obj expression?)
     (rands (list-of 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?)
    (hd expression?)
    (rands (list-of expression?)))
)

(define-datatype primitive primitive?
  (add-prim)
  (sub-prim)
  (mult-prim)
  (inc-prim)
  (dec-prim)
  (div-prim)
  (equal-prim)
  (less-prim)
  (greater-prim)
  (not-prim)
  (and-prim)
  (or-prim)
)	

(load "ref-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)
         (get-param-ids decls))
      )
    )
  )

(define get-param-ids
  (lambda (ps)
    (cases pdeclarations ps
      (param-decls (modes ids) ids)
      )
    )
  )
    
(define get-param-modes
  (lambda (ps)
    (cases pdeclarations ps
      (param-decls (modes ids) modes)
      )
    )
  )

;; use colosured to allow for classes
(load "closured.scm")

(define build-rec-proc
  (lambda (v rec-ids)
    (cases procval v
      (closure (params body env)
         (closure-rec params body rec-ids env))
      (else v) ;; we should never reach this case
      )
    )
  )

;; load target handling
(load "targetsb.scm")

(define eval-exp-sequence
  (lambda (exp exps env)
    ; while loop
    (let continue ((res (eval-expression exp env))
                   (tail exps))
      ;(display res) (display "\n")
      (if (null? tail)
          res
          (continue (eval-expression (car tail) env)
                    (cdr tail))
          )
      )
    )
  )

(define eval-declaration-list
  (lambda (decl-lst env)
    (cases declaration-list decl-lst
      (empty-decl-list () '())
      (decl-list (decls)
          (zip (get-ids decls)
               (map (lambda (e) (eval-expression e env)) (get-rands decls))))
      )
    )
  )

(define make-exp-list
  (lambda (exps)
    (cases expression-list exps
      (empty-exp-list () '())
      (exp-list (exp tail) (cons exp tail))
      )
    )
  )

(define eval-loop
  (lambda (loop-decls conditions increments body env)
     (let ((p (unzip loop-decls))
           ; map conditions  to or-prim
           (loop-test (primapp-exp (or-prim) (car conditions) (cdr conditions))))
       ; loop
       (let
           continue
             ;; loop var denote direct targets
             ((new-env (extend-env (car p) (map direct-target (cadr p)) env)) ; env
              (res 0))                                    ; res #f
             ;; do loop
             (if (is-true? (eval-expression loop-test new-env))
               (let ((new-res (eval-expression body new-env)) ; eval body => res
                     (step-res (map (lambda (e) (eval-expression e new-env)) increments)))
                   ;; next iteration, direct targets
                   (continue (extend-env (car p) (map direct-target step-res) env) new-res)
                 )
               res
               )
         )
       )
    )
  )

;; objects
(define-datatype objectval objectval?
  (object 
   (ivars environment?)
   (methods environment?)
   (image environment?))
  )

(define lookup-method
  (lambda (obj mid)
    (cases objectval obj
      (object (ivars methods image) (apply-env methods mid))
      )
    )
  )

(define self
  (lambda (obj)
    (cases objectval obj
      (object (ivars methods image) image)
      )
    )
  )

;; load file system utilities
(require (lib "file.ss"))

;; create a visible verbatim environment
(define verbatim-env 0)

(define evaluate-verbatim
  (lambda (code env)
           ;; create temporary file (DrScheme supports optional arguments)
    (let* ((temp-file (open-output-file "eval-verbatim.temp" 'text 'truncate)))
           ;; write file
      (let loop ((contents (string->list code)))
        (if (null? contents)
            (close-output-port temp-file)
            (begin
              (write-char (car contents) temp-file)
              (loop (cdr contents))))
        )
      ;; Load the contents and evaluate it in the current context
      ;; Load does not return a value. However, we have access to 
      ;; set verbatim environment
      (set! verbatim-env (extend-env '(__RESULT__) (list (direct-target 0)) env))
      ;; execute program
      (setref! (apply-env-ref verbatim-env '__RESULT__) (load "eval-verbatim.temp") )
      ;; delete file
      (delete-directory/files "eval-verbatim.temp")
      ;; return value of verbatim expression
      (apply-env verbatim-env '__RESULT__)
      )
    )
  )

(define eval-expression
  (lambda (exp env)
    (cases expression exp
      (extern-exp (unit-name)
         (let ((contents (read-file 
                              (string-append (symbol->string unit-name) ".xml"))))         
            ;; no change
            (eval-expression (expression-parser contents) env)))
      (verbatim-exp (code)
        (evaluate-verbatim (substring code 1 (- (string-length code) 1)) env))
      (seq-exp (exp exps)
        (eval-exp-sequence exp exps env))
      (class-exp (params i-decls m-decls)
         (let ((vtable (evaluate-methods m-decls env)))
            (closure-class params i-decls (car vtable) (cadr vtable) env)))
      (assign-exp (id r-value)
          (let ((val (eval-expression r-value env)))
            ; maps val to direct-target
            (setref! (apply-env-ref env id) val)
            val))
      (loop-exp (decls conds incrs body)
          (let ((new-decls (eval-declaration-list decls env)); list of pairs
                (conditions (make-exp-list conds))
                (increments (make-exp-list incrs)))
            ;; check for correct increments arity
            (if (= (length new-decls) (length increments))
                (eval-loop new-decls conditions increments body env)
               ;; arity error
               (eopl:error 'eval-expression
                           "Arity mismatch in loop increments" )
               )
            ))
      (proc-exp (params body) (closure params body env))
      (send-exp (mid obj rands)
        (let (;; evaluate object
              (receiver (eval-expression obj env)))
          (if (objectval? receiver)
              (let* (;; find method
                     (mproc (lookup-method receiver mid))
                     ;; evaluate arguments
                     (args (eval-proc-rands
                            (get-param-modes (closure-params mproc)) rands env)))
                ;; call method using 'self' as calling env
                (apply-method mproc args (self receiver))
               )
               (eopl:error 'eval-expression "Receiver is not an object")
               )))
      (app-exp (rator rands)
        ;; check procval first in order to extract parameter modes
        (let ((proc (eval-expression rator env)))
             (if (procval? proc)
                 ;; we need parameter modi here
                 (let ((args (eval-proc-rands 
                               (get-param-modes (closure-params proc)) rands env))) 
                      ;; add calling-env to resolve occurring recursive procedures
		      (apply-procval proc args env))
	         (eopl:error 'eval-expression
		             "Attempt to apply non-procedure ~s" proc))))
      (reclet-exp (decls body)
        (let* ((args (eval-rands (get-rands decls) env))
               ;; filter recursive procedure ids
               (rec-proc-ids (map car (filter (lambda (p) (procval? (cadr p))) 
                                              (zip (get-ids decls) args))))
               ;; now change closure to closure-rec
               (new-args (map (lambda (v)
                                (if (procval? v)
                                    (build-rec-proc v rec-proc-ids)
                                    v)) args))
               ;; reclet: binder is direct-target
               (new-d-args (map (lambda (v) (direct-target v)) new-args)))
	     (eval-expression body (extend-env (get-ids decls) new-d-args env))))
      (let-exp (decls body)
        (let ((args (eval-let-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 hd rands)
         (let ((args (eval-rands (cons hd rands) env)))
              (apply-primitive prim args)))
      )
    )
  )

;; procedure arguments
(define eval-proc-rands
  (lambda (modes rands env)
    (if (= (length rands) (length modes))
      (map (lambda (p) (eval-proc-rand p env)) (zip modes rands))
      (eopl:error 'eval-proc-rands "Parameter mismatch")
      )
    )
  )

(define eval-proc-rand
  (lambda (argument env)
    (cases pmode (car argument)
      (mode-value ()
         (direct-target (eval-expression (cadr argument) env)))
      (mode-byref ()
         (cases expression (cadr argument)
           (var-exp (id)
              ;; build new reference 
              (indirect-target (let ((ref (apply-env-ref env id)))
	         (cases target (primitive-deref ref)
		   (direct-target (val) ref) ;; return new reference
                   (indirect-target (a-ref) a-ref))))) ;; return old reference
           (else (direct-target (eval-expression (cadr argument) env)))
           ))
      )
    )
  )
    
;; let (binder is direct-target: call-by-value)
(define eval-let-rands
  (lambda (rands env)
    (map (lambda (x) (eval-let-rand x env)) rands)
    )
  )

(define eval-let-rand
  (lambda (rand env)
    (direct-target (eval-expression rand env) )
    )
  )

;; primapp-exp
(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
      ;; we use a more reliable approach to evaluate primitive expressions
       (add-prim () (eval (append '(+) args))) 
       (sub-prim () (eval (append '(-) args)))
       (mult-prim () (eval (append '(*) args)))
       (inc-prim () (car (reverse (map (lambda (n) (+ n 1)) args)))); return last res
       (dec-prim () (car (reverse (map (lambda (n) (- n 1)) args)))); return last res
       (div-prim () (eval (append '(/) args)))
       (equal-prim ()
          (let cont ((tail (cdr args)))
            (if (null? tail)
                1 ; identity ==> true
                (if (eqv? (car args) (car tail))
                    (cont (cdr tail))
                    0; not all elements are equal
                   )
                )
            ))
       (less-prim () (b->n (eval (append '(<) args))))
       (greater-prim () (b->n (eval (append '(>) args))))
       (not-prim () 
           (b->n (car (reverse (map (lambda (v)
                                (if (number? v)
                                    (not (is-true? v))
                                    (not v)))          args))))); return last res
       ; 'and' and 'or' in order to work correctly have to be applied to booleans
       (and-prim () (b->n (eval (append '(and) (map is-true? args)))))
       (or-prim () (b->n (eval (append '(or) (map is-true? args)))))
      )
    )
  )

(define b->n (lambda (b) (if b 1 0)))

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