;;;; Copyright 2002, Jonathan Bachrach.  See file TERMS.
;;;; BASED ON Lisp In Small Pieces by Christian Queinnec

(use goo/boot)
(use goo/fun)
(use goo/macros)
(use goo/loc)
(use goo)
(use goo/cols/rep)
(use eval/ast)

;;; ENV

;;; Global binding box support.  Right now, we allocate storage boxes for
;;; each <module-binding> lazily, and we assume the absence of a box 
;;; means the binding is uninitialized.  When we implement a "LISP in
;;; Small Pieces"-style fast intepreter, we may want to change this around.
(dm env-global-binding-value (b|<module-binding> => <any>)
  (def box (binding-global-box b))
  (if box
      (global-box-value box)
      (sig (new <unbound-variable-error> 
             unbound-variable-error-variable (binding-name b)))))

(dm env-global-binding-value-setter (value b|<module-binding> => <any>)
  (def box (binding-global-box b))
  (unless box
    ;; Lazy box creation.
    ;; TODO - Should we mark this binding non-free at some point?  Ask jrb.
    (set box (set (binding-global-box b) (new <global-box>))))
  (set (global-box-value box) value))

(dm env-global-binding-bound? (b|<module-binding> => <log>)
  (def box (binding-global-box b))
  (if box #t #f))

;;; <runtime-binding>s don't need boxes--they already have storage space
;;; allocated in the C runtime.
(dm env-runtime-value (x|<loc>)
  (loc-val x))

(dm env-runtime-value-setter (v x|<loc>)
  (set (loc-val x) v))

;;; <dynamic-binding>s don't need boxes--they already have storage space
;;; allocated in the thread local storage.
(dm env-dynamic-value (x|<loc> => <any>)
  (%dyn-var-val (loc-val x)))

(dm env-dynamic-value-setter (v x|<loc>)
  (set (%dyn-var-val (loc-val x)) v) v)

(dc <loc-env> (<any>))
  (dp env-parent (<loc-env> => <any>)   #f)
  (dp env-function (<loc-env> => <any>) #f)
  (dp env-names (<loc-env> =>  <lst>)   '())
  (dp env-values (<loc-env> => <rep>)   )

(dv $nul-loc-env (new <loc-env>))

(dm env-frame! (env|<loc-env> function names|<lst> args|<lst> => <loc-env>)
  (def values (rep-into! (rep-fab (len args) #f) args))
  (new <loc-env>
    env-parent   env
    env-function function
    env-values   values
    env-names    names))

(dm env-local-value (env|<loc-env> i|<int> j|<int>)
  (if (= i 0)
      (rep-elt (env-values env) j)
      (env-local-value (env-parent env) (- i 1) j)))

(dm env-local-value-setter (v env|<loc-env> i|<int> j|<int>)
  (if (= i 0)
      (set (rep-elt (env-values env) j) v)
      (set (env-local-value (env-parent env) (- i 1) j) v)))

;; TODO: SHOULD GO AWAY SOON
(dm env-binding-value (env|<loc-env> name|<sym> => <any>)
  (if (== env $nul-loc-env)
      #f
      (rep loop ((names (env-names env)) (i 0))
        (if (nul? names)
            (env-binding-value (env-parent env) name)
            (if (== name (head names))
                (rep-elt (env-values env) i)
                (loop (tail names) (+ i 1)))))))

(dm env-binding-value-setter (v env|<loc-env> name|<sym>)
  (rep loop ((names (env-names env)) (i 0))
    (if (nul? names)
        (set (env-binding-value (env-parent env) name) v)
        (if (== name (head names))
            (set (rep-elt (env-values env) i) v)
            (loop (tail names) (+ i 1))))))

;;; EVAL

;; TODO - Rename ast-eval to ast-eval-(in|env) and ast-evalutate to ast-eval.
;; Or something like that.
(dm ast-evaluate (e|<program>)
  (ast-eval e $nul-loc-env))

(dg ast-eval (e|<program> env|<loc-env>))

(dm ast-eval (e|<constant> env|<loc-env>)
  (constant-value e))

(dm ast-eval (e|<raw-constant> env|<loc-env>)
  (constant-value e))

(dm ast-eval (e|<compile-time> ee|<loc-env>)
  (ast-evaluate (compile-time-program e)))

(dm ast-eval-specs (specs|<lst> nary?|<log> env|<loc-env> => <any>)
  (def nreq (if nary? (- (len specs) 1) (len specs)))
  (rep loop ((res '()) (specs specs) (i 0))
    (if (= i nreq)
        (rev! res)
        (let ((spec (head specs))
              (type (if spec (ast-eval spec env) <any>)))
          (loop (pair type res) (tail specs) (+ i 1))))))

;;; Check to make sure we have a legal number of arguments, and arrange
;;; them in the fashion required by our argument list.
;;; TODO - There's probably another one of these functions hiding somewhere
;;; in the compiler or runtime.  Look for it, and see if we can use it instead
;;; of this code.
;;; TODO - Add function name argument for better error messages.
(df arrange-arguments (f nary?|<log> arity|<int> args|<lst> => <lst>)
  (def count (len args))
  (if nary?
      (if (< count arity)
          (narity-error f args)
          (cat2 (sub args 0 arity) (lst (sub args arity count))))
      (if (~== count arity)
          (arity-error f args)
          args)))

(ds ifun (,env ,f ,nary? ,arity ,names ,body)
  `(fun ((arg-vector ...))
     (def args  (arrange-arguments f nary? arity (as <lst> arg-vector)))
     (def nms   (%next-methods))
     (def frame (env-frame! ;; TODO: SLOW HACK
                 ,env ,f (cat2 ,names (lst '%next-methods))
                 (cat2 args (lst nms))))
     (,body frame)))

;; TODO -- CLEAN UP BELOW
(dm as-fun-name (x|<fun> => <any>)            
  (fun-name x))
(dm as-fun-name (x|<ast-function> => <any>)   
  (as-fun-name (function-debug-name x)))
(dm as-fun-name (x|<module-binding> => <any>) 
  (binding-name x))
(dm as-fun-name (x|<constant> => <any>)
  (as-fun-name (constant-value x)))
(dm as-fun-name (x|<sym> => <sym>)            
  x)
(dm as-fun-name (x|<any> => <any>)
  #f)

(dm export-goo-method (f names specs nary? value body env)
  (def arity (if nary? (- (len specs) 1) (len specs)))
  (def efun  (ifun env f nary? arity names body))
  (set (fun-info efun)
       (new <fun-info>
         fun-info-name  (as-fun-name f)
         fun-info-names names))
  (set (fun-sig efun)
       (new <sig>
         sig-specs (ast-eval-specs specs nary? env)
         sig-nary? nary?
         sig-arity arity
         sig-val   (if value (ast-eval value env) <any>)
         sig-unification-vars '()))
  efun)

(dm ast-eval (e|<ast-method> env|<loc-env>)
  (def params (function-bindings e))
  (def eval   (fun ((env <loc-env>)) (ast-eval (function-body e) env)))
  (export-goo-method
   e (map binding-name params) (map binding-type params) 
   (function-nary? e) (function-value e) eval env))

;; (dm ast-eval (e|<ast-primitive> env|<loc-env>)
;;   (def params (function-bindings e))
;;   (def eval   (fun ((env <loc-env>)) (ast-eval (function-body e) env)))
;;   (make-primitive (map binding-name params) (function-nary? e) eval env))

(dm ast-eval (e|<ast-generic> env|<loc-env>)
  (def params (function-bindings e))
  (def nary?  (function-nary? e))
  (def names  (map binding-name params))
  (def specs  (ast-eval-specs (map binding-type params) nary? env))
  (fab-gen specs nary? <any> (as-fun-name e) names))

(dm env-local-reference-value (env|<loc-env> ref|<local-reference> => <any>)
  (env-local-value
   env (reference-frame-number ref) (reference-frame-offset ref)))

(dm env-local-reference-value-setter (val env|<loc-env> ref|<local-reference>)
  (set (env-local-value 
        env (reference-frame-number ref) (reference-frame-offset ref)) 
       val))

(dm ast-eval (e|<static-module-binding-reference> env|<loc-env>) #f)

(dm ast-eval (e|<local-reference> env|<loc-env>)
  (env-local-reference-value env e))

(dm ast-eval (e|<global-reference> env|<loc-env>)
  (env-global-binding-value (reference-binding e)))

(dm ast-eval (e|<dynamic-reference> env|<loc-env>)
  (env-dynamic-value (binding-locative (reference-binding e))))

(dm ast-eval (e|<runtime-reference> env|<loc-env>)
  (env-runtime-value (binding-locative (reference-binding e))))

(dm ast-eval (e|<bound?> env|<loc-env>)
  (ast-eval-bound? e (reference-binding (bound?-reference e)) env))

(dm env-global-binding-value-or (b|<module-binding> default env|<loc-env>)
  (if (env-global-binding-bound? b) 
      (env-global-binding-value b)
      (ast-eval default env)))

(dm ast-eval-bound? (e|<bound?> binding|<module-binding> env|<loc-env>)
  (case (binding-kind binding)
    (('global) (env-global-binding-value-or binding (bound?-default e) env))
    (#t        (ast-eval (bound?-reference e) env))))

(dm ast-eval-bound? (e|<bound?> binding|<local-binding> env|<loc-env>)
  (ast-eval (bound?-reference e) env))

(dm ast-eval (e|<global-assignment> env|<loc-env>)
  (def value (ast-eval (assignment-form e) env))
  (set (env-global-binding-value (assignment-binding e)) value))

(dm ast-eval (e|<ast-macro-definition> env|<loc-env>)
  #f) ;; PERFORMED DURING OBJECTIFICATION

(dm ast-eval (e|<runtime-assignment> env|<loc-env>)
  (def value (ast-eval (assignment-form e) env))
  (set (env-runtime-value (binding-locative (assignment-binding e))) value))

(dm ast-eval (e|<dynamic-assignment> env|<loc-env>)
  (def value (ast-eval (assignment-form e) env))
  (set (env-dynamic-value (binding-locative (assignment-binding e))) value))

(dm ast-eval (e|<local-assignment> env|<loc-env>)
  (def value (ast-eval (assignment-form e) env))
  (set (env-local-reference-value env (assignment-reference e)) value))

(dm env-define-binding! (b|<module-binding> v)
  (case (binding-kind b)
    (('runtime) (set (env-runtime-value (binding-locative b)) v))
    (('global)  (set (env-global-binding-value b) v))
    (('dynamic) (set (binding-locative b) (%lb (%fab-dyn-var)))
                (set (env-dynamic-value (binding-locative b)) v))
    (#t         (internal-error "Defining invalid binding kind %="
                                (binding-kind b)))))

(dm ast-eval (e|<definition> env|<loc-env>)
  (def value (ast-eval (assignment-form e) env))
  (env-define-binding! (assignment-binding e) value)
  value)

;; (dc <box> (<any>))
;;   (dp box-value (<box> => <any>))
;; 
;; (dm ast-eval (e|<box-read> env|<loc-env>)
;;   (box-value (ast-eval (box-reference e) env)))
;; 
;; (dm ast-eval (e|<box-write> env|<loc-env>)
;;   (set (box-value (ast-eval (box-reference e) env))
;;        (ast-eval (box-form e) env)))
;; 
;; (dm ast-eval (e|<box-creation> env|<loc-env>)
;;   (set (env-binding-value 
;;          env (binding-name (reference-binding (box-reference e))))
;;        (new <box>)))

(dm ast-eval (e|<alternative> env|<loc-env>)
  (if (ast-eval (alternative-condition e) env)
      (ast-eval (alternative-consequent e) env)
      (ast-eval (alternative-alternant e) env)))

(dm ast-eval (e|<loop> env|<loc-env>)
  (esc return
    (rep loop ()
      (esc continue
        (set (loop-continue e) continue)
        (return (ast-eval (loop-body e) env)))
      (loop))))

(dm ast-eval (e|<sequential> env|<loc-env>)
  (rep eval ((e e))
    (def nxt (tail e))
    (def val (ast-eval (head e) env))
    (if (nul? nxt)
        val
        (eval nxt))))

(dm ast-eval (e|<arguments> env|<loc-env>)
  (rep eval ((res '()) (args e))
    (if (nul? args)
        (rev! res)
        (eval (pair (ast-eval (head args) env) res) (tail args)))))

(dm ast-eval (e|<regular-application> env|<loc-env>)
  (def f    (ast-eval (application-function e) env))
  (def args (ast-eval (application-arguments e) env))
  (app f args))

(dm ast-eval (e|<loop-application> env|<loc-env>)
  (def loop (application-loop e))
  (def args (ast-eval (application-arguments e) env))
  (for ((binding (loop-bindings loop)) (arg args))
    (set (env-binding-value env (binding-name binding)) arg))
  ((loop-continue loop) #f))

(dm ast-eval (e|<predefined-application> env|<loc-env>)
  (def b (application-binding e))
  (case (binding-name b)
    (('%next-methods)
     (env-binding-value env '%next-methods))
    (('%fun-reg) ;; ONLY NEEDED FOR NEXT-METHOD ERRORS
     #f)
    (#t
     (let ((f    (%binding-value-of b))
           (args (ast-eval (application-arguments e) env)))
       (app f args)))))

(dm ast-eval (e|<fix-let> env|<loc-env>)
  (def args (ast-eval (fix-let-arguments e) env))
  (def nenv (env-frame! env #f (map binding-name (fix-let-bindings e)) args))
  (ast-eval (fix-let-body e) nenv))

(dm ast-eval (e|<locals> env|<loc-env>)
  (def bindings
    (locals-bindings e))
  (def new-env 
    (env-frame! env #f (map binding-name bindings) (map (always #f) bindings)))
  (do2 (fun (name value)
         (set (env-binding-value new-env name) value))
       (map binding-name bindings)
       (map (rcurry ast-eval new-env) (locals-functions e)))
  ;; (rep loop ((funs (locals-functions e)) (i 0))
  ;;   (unless (nul? funs)
  ;;     (set (env-local-value new-env 0 i) 
  ;;          (ast-eval (head funs) new-env))
  ;;     (loop (tail funs) (+ i 1))))
  (ast-eval (locals-body e) new-env))

(dm ast-eval (e|<bind-exit> env|<loc-env>)
  (esc return
    (def rproc (fun ((env <loc-env>)) (return (env-binding-value env 'x))))
    (def exit  (export-goo-method rproc (lst 'x) (lst #f) #f #f rproc env))
    ((ast-eval (bind-exit-main-fun e) env) exit)))

(dm ast-eval (e|<unwind-protect> env|<loc-env>)
  (fin ((ast-eval (unwind-protect-protected-thunk e) env))
       ((ast-eval (unwind-protect-cleanup-thunk e) env))))

(dm ast-eval (e|<monitor> env|<loc-env>)
  (%with-monitor
   (ast-eval (monitor-type e) env)
   (ast-eval (monitor-info e) env)
   (ast-eval (monitor-test e) env)
   (ast-eval (monitor-handler e) env)
   (ast-eval (monitor-main-thunk e) env)))

;;; ENVIRONMENT

;; Add any bindings required by the interpreter to an environment.
;; The function '%pair' is a compile-time primitive.  Unfortunately, the
;; objectifier inserts it into some of the code it generates, so we need
;; to add a run-time shadow.
;; TODO - This function smells bad.
(df init-environment-for-eval (env|<static-global-environment>)
  (ast-define-binding env '%next-methods #f 'predefined)
  ;; (def b (ast-define-binding env '%pair #f 'predefined))
  ;; (set (env-global-binding-value b) pair)
  )

(export
  ast-evaluate
  init-environment-for-eval)

;;; DYNAMIC LOADING SUPPORT
;;;
;;; TODO: SHOULD MERGE BINDING-INFO REPS OF GLOBAL/RUNTIME
;;;       SHOULD TREAT DYNAMIC BINDINGS SPECIALLY

(dl %dlvar-nam)
(dl %dlvar-mod)
(dl %dlvar)
(dl %dlvar-setter)

(dl %define-binding (raw-mod raw-nam)
  (def e (unchecked-runtime-environment (%%sym raw-mod)))
  (ast-define-binding e (%%sym raw-nam) #f 'global))

(dl %lookup-binding (raw-mod raw-nam)
  (def e (unchecked-runtime-environment (%%sym raw-mod)))
  (find-binding (%%sym raw-nam) e))

(dl %ensure-binding (raw-mod raw-nam)
  (or (%lookup-binding raw-mod raw-nam)
      (%define-binding raw-mod raw-nam)))

(dl %dlvar-binding (dlvar)
  (def b (%dlvar dlvar))
  (if (@== b (%iu 0))
      (set (%dlvar dlvar) 
           (%ensure-binding (%dlvar-mod dlvar) (%dlvar-nam dlvar)))
      b))

(dl (%binding-value-of inline-c) (binding)
  (case (binding-kind binding)
    (('runtime) (env-runtime-value (binding-locative binding)))
    (('dynamic) (env-dynamic-value (binding-locative binding)))
    (#t         (env-global-binding-value binding))))

(dl %binding-value (dlvar)
  (%binding-value-of (%dlvar-binding dlvar)))

(dl (%binding-value-of-setter inline-c) (val binding)
  (case (binding-kind binding)
    (('runtime) (set (env-runtime-value (binding-locative binding)) val))
    (('dynamic) (set (env-dynamic-value (binding-locative binding)) val))
    (#t         (set (env-global-binding-value binding) val))))

(dl %binding-value-setter (val dlvar)
  (set (%binding-value-of (%dlvar-binding dlvar)) val))

(dl (%binding-value-or-of inline-c) (b default)
  (if (and b (binding-info b))
      (%binding-value-of b)
      default))

(df binding-value-or (b|<module-binding> def) (%binding-value-or-of b def))

(dl %binding-value-or (dlvar default)
  (%binding-value-or-of 
   (%lookup-binding (%dlvar-mod dlvar) (%dlvar-nam dlvar)) default))

(export
  binding-value-or
  %binding-value-or     %binding-value-or-of
  %binding-value        %binding-value-of
  %binding-value-setter %binding-value-of-setter)
