;;;; Copyright 2002, Jonathan Bachrach.  See file TERMS.

(use goo)
(use goo/boot)
(use goo/fun)
(use goo/system)
(use goo/conditions)
(use eval/syntax)
(use eval/ast)
(use eval/ast-eval)

(df esctst ()
  (esc exit 
    (fin (exit 'exit) 
         (msg out "CLEANUP\n")
         'cleanup) 
    (msg out "DO\n")
    'done))

(dg g2c-eval (exp ct-env))

(dm parse-in (s|<str> ct-env)
  (dlet ((*dynamic-compilation?* #f #/ #t /#))
    (objectify-with-subtransaction (read-from-string s) ct-env #t #f)))

(dm parse (s|<str> modname|<sym>)
  (parse-in s (runtime-environment modname)))

(dm str-parse-in (s|<str> ct-env)
  (msg out "%=\n" (parse-in s ct-env)))

(dm str-parse (s|<str> modname|<sym>)
  (str-parse-in s (runtime-environment modname)))

(dg vm-evaluate (ast env))

(df %%bottom%%vm-run (ast ct-env)
  (vm-evaluate ast ct-env))

(df %%bottom%%ast-run (ast ct-env)
  (ast-evaluate ast))

(df %%bottom%%g2c-run (ast ct-env)
  (g2c-eval ast ct-env))

(df auto-run (ast ct-env)
  (if (ast-contains-fun? ast)
      (%%bottom%%g2c-run ast ct-env)
      (%%bottom%%ast-run ast ct-env)))

(df auto-eval (form ct-env)
  (dlet ((*dynamic-compilation?* #t))
    (zap-referenced-bindings! ct-env)
    (def ast (objectify-with-subtransaction form ct-env #t #f))
    (run ast ct-env)))

(dv $g2c-eval? 
  (let ((mode (os-val "GOO_EVAL_MODE")))
    (and (not (case-insensitive-string-equal mode  "ast"))
         (or (case-insensitive-string-equal mode "g2c")
             #t))))  ;; (= (os-name) "linux")

(ddv run (if $g2c-eval? auto-run %%bottom%%ast-run))

(dm eval-in (x ct-env)
  (def o (objectify-with-subtransaction x ct-env #t #f))
  (def e (ast-evaluate o))
  e)

(dm eval (x modname|<sym>)
  (eval-in x (runtime-environment modname)))

(dm str-eval-in (x|<str> ct-env => <any>)
  (write-to-string (eval-in (read-from-string x) ct-env)))

(dm str-eval (x|<str> modname|<sym>)
  (str-eval-in x (runtime-environment modname)))

(df compiled-file? (name|<str>)
  (suffix? name ".gooc"))

(dm read-file (filename|<str> => <any>)
  (with-port (port (open <file-in-port> filename))
    (rep loop ((forms '()))
      (def x (read port))
      (if (eof-object? x)
          (sexpr-sequence->begin (rev! forms))
          (loop (pair x forms))))))

(dm load-in (filename|<str> ct-env)
  (if (compiled-file? filename)
      (so-load filename)
      (dlet ((*dynamic-compilation?* #t))
        (def x (read-file filename))
        (zap-referenced-bindings! ct-env)
        (def o (objectify-with-subtransaction x ct-env #f #f))
        (run o ct-env)))
  ;; TODO - Hook me into the new module loader system in a useful way.
  ;; (report-undefined-global-bindings ct-env)
  )

(dm load-file (filename|<str> modname|<sym>)
  (load-in filename (runtime-environment modname)))

(dm load (name modname|<sym>)
  (def realfile (find-goo-file-in-path name *module-search-path*))
  (unless realfile
    (file-opening-error name))
  (load-file realfile modname))

(dm prompt-for-command-expression (env level prompt)
  (msg out "%s %=%s" (module-name (find-environment-module env)) level prompt)
  (force-out out)
  (def form (read in))
  (if (and (isa? form <lst>) (== (head form) 'unquote))
      (let ((arg-str (gets in))
            (args    (read-from-string (cat "(" arg-str ")"))))
        (pair (cat-sym "cmd_" (2nd form)) args))
      form))

(dm print-result-expression (env level label result)
  (msg out "%s %=%s" (module-name (find-environment-module env)) level label)
  (write out result))

(dm do-stack-frames (fun)
  (%do-stack-frames fun))

(ds for-frames ((,num ,f ,args) ,@body)
  `(let ((,num 0))
     (do-stack-frames
      (fun (,f _args) (def ,args (rev _args)) ,@body (incf ,num)))))

(ds for-user-frames ((,num ,f ,args) ,@body)
  `(esc break
     (def _seen-top #f)
     (def _top-num  0)
     (for-frames (_num ,f ,args)
       (def _name (if (fun-name ,f) (as <str> (fun-name ,f)) ""))
       (def ,num (- _num _top-num))
       (when _seen-top
         (when (prefix? _name "%%bottom%%")
           (break #f))
         ,@body)
       (when (prefix? _name "%%top%%")
         (set _top-num  num)
         (set _seen-top #t)))))

(dm msg-src-loc (f)
  (when (isa? f <met>)
    (def sl (fun-src-loc f))
    (when (isa? sl <src-loc>)
      (msg out " %s:%d" (src-loc-file sl) (src-loc-line sl)))))

(dm backtrace ()
  (for-user-frames (num f args)
    (msg out "[%=] %= %=" num f args) (msg-src-loc f) (newline out)))

(dm frame (n|<int>)
  (for-user-frames (num f args)
    (when (== n num)
      (msg out "[%=] %= %=" num f args) (msg-src-loc f) (newline out))))

(dm frame-var (n|<int> name|<sym>)
  (esc ret
    (for-user-frames (num f args)
      (when (== n num) 
        (ret (elt args (pos (fun-names f) name)))))
    #f)) ;; TODO: BETTER VALUE


(dm bt ()
  (for-user-frames (num f args)
    (msg out "[%=] %=" num f) (msg-src-loc f) (newline out)))

(df do-restart (restarts n)
  (unless restarts
    (error "No restarts available.\n"))
  (unless (and (> n 0) (<= n (len restarts)))
    (error "No restart #%d.\n" n))
  (invoke-handler-interactively (elt restarts (- n 1)) in out))

(dv $   #f)
(dv $$  #f)
(dv $$$ #f)

;;  Initialization and driver loop
;;  The prompt is handled a bit differently than in the notes
(dm %%top%%top-in (level top quit show-restarts? ct-env)
  (def restarts #f)
  (esc blow
    (rep loop ()
      (esc continue
        (try <condition>
          (fun (c r)
            (case-by c isa?
              ((<keyboard-interrupt>) 
               (msg out "BREAK"))
              (#t
               (esc break
                 (try <error>
                   (fun (c r)
                     (post "<RECURSIVE ERROR ABORTING...>")
                     (break #f))
                   (msg out "ERROR: %s" (describe-condition c))))))
            ;; (backtrace (env))
            (%%top%%top-in (+ level 1) top quit #t ct-env)
            (continue #f))
          (try ((type <restart>)
                (description "Return to interpreter level %d" level))
            (fun (c r) (continue #f))
            (newline out)
            (when show-restarts?
              (msg out "Type \",restart N\" to restart execution:\n")
              (set restarts (list-handlers <restart> out))
              (set show-restarts? #f))
            (def form (prompt-for-command-expression ct-env level "<= "))
            (if (eof-object? form)
                (quit #f)
                (match form
                  ((cmd_quit) 
                   (quit #f))
                  ((cmd_up)
                   (blow #f))
                  ((cmd_top)
                   (top #f))
                  ((cmd_handlers)
                   (list-handlers <condition> out))
                  ((cmd_restarts)
                   (list-handlers <restart> out))
                  ((cmd_restart ,n)
                   (do-restart restarts n))
                  ((cmd_in ,m)
                   (def new-env (runtime-environment m))
                   (set ct-env new-env))
                  ((cmd_g2c-eval)
                   (when $g2c-eval? (set run %%bottom%%g2c-run)))
                  ((cmd_ast-eval)
                   (set run %%bottom%%ast-run))
                  ((cmd_vm-eval)
                   (set run %%bottom%%vm-run))
                  ((cmd_auto-eval)
                   (when $g2c-eval? (set run auto-run)))
                  ((cmd_bt)
                   (bt))
                  ((cmd_backtrace)
                   (backtrace))
                  ((cmd_frame ,n)
                   (frame n))
                  ((cmd_frame-var ,n ,name)
                   (print-result-expression
                    ct-env level "=> " (frame-var n name)))
                  (#t 
                   (def res (auto-eval form ct-env))
                   (print-result-expression
                    ct-env level "=> " res)
                   (rotf $$$ $$ $ res)))))))
      (loop))))

(dm top (modname|<sym>)
  (esc quit
    (try ((type <restart>)
          (description "Exit the top-level interpreter"))
      (fun (c r) (quit #f))
      (rep loop ()
        (esc top
          (%%top%%top-in 0 top quit #f (runtime-environment modname)))
        (loop)))))

(df save-image (image-name|<str>)
  (unexec image-name (fun () (top 'goo/user))))

(export
  eval
  auto-eval
  load
  load-file
  parse-in
  read-file
  top
  do-stack-frames
  backtrace bt frame frame-var
  save-image
  g2c-eval
  vm-evaluate
  esctst
  *dynamic-compilation?*
  $ $$ $$$)
