;; -*- Mode: Irken -*-

(include "self/lisp_reader.scm")

;; --- s-expression input ---

(define (find-and-read-file path)
  (raise (:NoIncludeFiles))
  )

(define (file/read-line file)
  (let loop ((ch (file/read-char file))
	     (r '()))
    (if (eq? ch #\newline)
	(list->string (reverse r))
	(loop (file/read-char file) (list:cons ch r)))))

(define (ask prompt file)
  (printf prompt) (flush)
  (file/read-line file))

;; --- universal datatype ---
;;
;; this datatype covers all the types known by the interpreter.
;; 

(datatype univ
  (:int int)
  (:char char)
  (:string string)
  (:bool bool)
  (:symbol symbol)
  (:undef)
  (:list (list univ))
  ;; (:function ...)
  )

;; how to print out a universal value

(define univ-repr
  (univ:int n)    -> (format (int n))
  (univ:char n)   -> (format (char n))
  (univ:string s) -> (format (string s))
  (univ:bool b)   -> (format (bool b))
  (univ:symbol s) -> (format (sym s))
  (univ:undef)    -> "#u"
  (univ:list subs) 
  -> (format "(" (join univ-repr " " subs) ")")
  )

;; flat variable namespace.
;; I'm using a balanced binary tree here, but this will need
;;  to be replaced by a 'rib' data structure to support function application.

;; the keys are symbols, the values are a record type containing a single
;;  field named 'val', of type 'univ'.

(define namespace (tree/empty))

(define (varref name)
  (match (tree/member namespace symbol<? name) with
    (maybe:yes {val=val}) -> val
    (maybe:no) -> (begin 
                    (printf "undefined variable: '" (sym name) "'\n")
                    (univ:undef))
    ))

(define (varset name val)
  (match (tree/member namespace symbol<? name) with
    (maybe:yes cell) 
    -> (begin 
         (set! cell.val val)
         (univ:undef))
    (maybe:no) 
    -> (let ((cell {val=val}))
         (tree/insert! namespace symbol<? name cell)
         (univ:undef))
    ))

(define (eval-error what)
  (printf "error: " what "\n")
  (univ:undef)
  )

;; evaluate a primitive operator (one starting with '%')

(define eval-prim
  '%+ (arg0 arg1) 
  -> (let ((a (eval arg0))
           (b (eval arg1)))
       (match a b with
         (univ:int a) (univ:int b) -> (univ:int (+ a b))
         _ _ -> (eval-error (format "bad args: " (univ-repr a) " " (univ-repr b)))
         ))
  prim _
  -> (eval-error (format "unknown prim: " (sym prim)))
  )

;; top-level eval function

(define eval
  ;; self-evaluating expressions
  (sexp:int n)    -> (univ:int n)
  (sexp:char ch)  -> (univ:char ch)
  (sexp:string s) -> (univ:string s)
  (sexp:bool b)   -> (univ:bool b)
  (sexp:undef)    -> (univ:undef)
  ;; variable lookup
  (sexp:symbol s) -> (varref s)
  ;; variable assignment
  (sexp:list ((sexp:symbol 'set!) (sexp:symbol name) val))
  -> (varset name (eval val))
  ;; application
  (sexp:list ((sexp:symbol rator) . rands))
  -> (if (starts-with (symbol->string rator) "%")
         (eval-prim rator rands)
         (eval-error "application NYI"))
  ;; anything else...  
  exp -> (eval-error (format "bad/unknown expression: " (repr exp)))
  )

(define (setup-initial-environment)
  (varset 'x (univ:int 34))
  )

(define (read-eval-print-loop stdin)
  (setup-initial-environment)
  (let loop ((line (ask "> " stdin)))
    (match (string-length line) with
      0 -> #u
      _ -> (begin
	     ;;(printf "line = '" line "'\n")
	     (for-list exp (read-string line)
	       (printf (univ-repr (eval exp)) "\n"))
	     (loop (ask "> " stdin)))
      )))

(read-eval-print-loop (file/open-stdin))