(*
 Oukseh Lee

 Copyright(c) 2000-2004 KAIST/SNU Research On Program Analysis System
 (National Creative Research Initiative Center 1998-2003)
 http://ropas.snu.ac.kr/n

 All rights reserved. This file is distributed under the terms of
 an Open Source License.
*)

structure Scope = struct

  open String_ast.Ast
  open Hashtbl
  structure M = Make(struct type t = string
                            fun equal x y = x=y 
                            val hash = Hashtbl.hash end)
  structure T = Make(struct type t = Location.t
                            fun equal x y = x=y
                            val hash = Hashtbl.hash end)
  structure SS = ListSetFn(struct type t = string
                                  val compare = compare end)
  type vd = int * Location.t
  val m = (M.create 30): vd list M.t
  val t = (T.create 30): SS.t ref T.t

  fun join (x1 as (l1,a1)::t1) (x2 as (l2,a2)::t2) = 
        if l1<l2 then join x1 t2
        else if l1>l2 then join t1 x2
        else if a1=a2 then x1
        else join t1 t2
    | join _ _ = raise TyDebug.Bug "Scope.join"
 
  fun add tv vdl = let
        val newvdl = join vdl (M.find m tv)
       in M.remove m tv; M.add m tv newvdl end handle Not_found => M.add m tv vdl

  fun addt loc tv = let val a = T.find t loc in a := SS.add tv (!a) end
                      handle Not_found => T.add t loc (ref (SS.singleton tv))
 
  fun clear() = (M.iter (fn tv ((_,loc)::t) => addt loc tv
                          | _ _ => raise TyDebug.Bug "Scope.clear") m;
                 M.clear m)

fun doit (cvd,s) (tv,_) = if SS.mem tv s then () else add tv cvd
fun levelup ([],s) [] i = ([(0,i)],s)
  | levelup ([],s) tvl i = ([(0,i)],List.fold_right (fn (tv,_) => SS.add tv) tvl s)
  | levelup (x as ((l,_)::t),s) [] i = ((l+1,i)::x,s)
  | levelup (x as ((l,_)::t),s) tvl i =
      ((l+1,i)::x,List.fold_right (fn (tv,_) => SS.add tv) tvl s)
val init_c = ([],SS.empty)

fun ty c t = case t of
   VarTy(tv,_) => doit c tv
 | ConstTy(tl,_,_) 
 | TupleTy(tl,_) => List.iter (ty c) tl
 | RecordTy(ll,_) => List.iter (fn(_,t,_) => ty c t) ll
 | FunTy(t1,t2,_) => (ty c t1; ty c t2)

fun pat c p = case p of
   AppPat(_,p,_)
 | RefPat(p,_)
 | AsPat(_,None,p,_) => pat c p 
 | RecordPat(ll,_) 
 | SubRecordPat(ll,_) => List.iter (fn (_,p,_) => pat c p) ll
 | AsPat(_,Some t,p,_)
 | ConstraintPat(p,t,_) => (pat c p; ty c t)
 | TuplePat(pl,_) 
 | ListPat(pl,_) 
 | ArrayPat(pl,_) 
 | OrPat(pl,_) => List.iter (pat c) pl
 | _ => ()

and exp c e = case e of
   RaiseExp(e,_) 
 | RefExp(e,_) 
 | RecordFieldExp(e,_,_)
 | DeRefExp(e,_) => exp c e
 | AppExp(e1,e2,_) => exp c e1; List.iter (exp c) e2
 | ArrayFieldExp(e1,e2,_)
 | SubstRecordExp(e1,_,e2,_)
 | AssignExp(e1,e2,_)
 | WhileExp(e1,e2,_) => (exp c e1; exp c e2)
 | UpdateArrayExp(e1,e2,e3,_) 
 | IfExp(e1,e2,e3,_) => (exp c e1; exp c e2; exp c e3)
 | ForExp(_,e1,e2,e3,e4,_) => (exp c e1; exp c e2; exp c e3; exp c e4)
 | TupleExp(el,_)
 | ListExp (el,_)
 | ArrayExp(el,_)
 | SeqExp(el,_) => List.iter (exp c) el
 | RecordExp(lel,_) => List.iter (fn (_,e,_) => exp c e) lel
 | HandleExp(e,rl,_) 
 | CaseExp(e,rl,_) => (exp c e; List.iter (fn (p,e,_) => (pat c p; exp c e)) rl)
 | LetExp(d,e,_) => (dec c d; exp c e)
 | FnExp(frl,_) => List.iter (fnrule c) frl
 | ConstraintExp(e,t,_) => (exp c e; ty c t)
 | _ => ()

and fnrule c (pl,e,_) = (List.iter (pat c) pl; exp c e)

and dec c d = case d of
  ValDec(tvl,vbl,i) => List.iter (valbind (levelup c tvl i)) vbl
| FunDec(tvl,fbl,i) => List.iter (funbind (levelup c tvl i)) fbl
| LocalDec(d1,d2,_) => (dec c d1; dec c d2)
| SeqDec(dl,_) => List.iter (dec c) dl
| _ => ()

and valbind c (_, p,e,_) = (pat c p; exp c e)
and funbind c (l,_) = List.iter (fn(_,pl,e,_)=>(List.iter (pat c) pl; exp c e)) l

and strdec sd = case sd of
   SimpleDec(d,_) => (dec init_c d; clear())
 | StrDec(sbl,_) => List.iter (fn (_,_,se,_) => strexp se) sbl
 | SeqStrDec(sdl,_) => List.iter strdec sdl

and fctdec(_,_,_,se,_) = strexp se

and strexp se = case se of
   StrStr(sd,_) => strdec sd
 | SigStr(se,_,_) => strexp se
 | FctAppStr(_,sel,_) => List.iter strexp sel
 | _ => ()

and topdec td = case td of
   Fct((_,_,_,se,_),_) => strexp se
 | Str(sd,_) => strdec sd
 | SeqTopDec(l,_) => List.iter topdec l
 | _ => ()

fun print_s s = let
      fun f [] = Format.printf " ]"
        | f [h] = Format.printf "%s]" h
        | f (h::t) = (Format.printf "%s, " h; f t)
     in Format.printf "[ "; f (SS.elements s); Format.printf "@." end

fun pp t = T.iter (fn k v => (Location.print Format.std_formatter k; print_s (!v))) t

fun scope td = topdec td

fun find a = let val l = !(T.find t a)
             in  List.map (fn s => (s,Location.none)) l 
             end handle Not_found => []
end