(*
 JungTaek Kim

 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.
*)

signature PostParseSig =
sig
  val check_topdec: String_ast.Ast.topdec -> unit
  val check_toplevel: String_ast.Ast.toplevel -> unit
end

structure PostParse : PostParseSig = 
struct
open String_ast.Ast
open Format
open Location
open List
open NsyntaxErr

val keywords = [ "and", "as", "case", "do", "else", "end", "exception",
      "fn", "for", "fun", "functor", "handle", "if", "in", "include",
      "let", "local", "of", "open", "raise", "rec", "ref", "sig",
      "signature", "struct", "structure", "then", "type", "val",
      "where", "while",
      ":=", "!", "->", "<-", "=>", "|", ":", ";", "{", "}", "[", "]",
      "[|", "|]", ",", "(", ")", ".",
(*      "array", "bool", "char", "exn", "int", "list", "real", "string",
      "unit", *)
      "nil", "not", "true", "false", "++", "--", "&&", "||",
      "andalso", "orelse" 
      (* ±âº» ¿¬»êÀÚ ºüÁü.
      "True", "False",
      "Nil", 
      "=", "<", ">", "@", "^", "+", "-", "**", "*", "/", "%",
      "&&", "||", "++", "--", "+=", "-=", "*=", "/=",
      ">>", "<<"
      *)
      (* removed
      "div", "mod", "land", "lor", "lxor", "lsl", "lsr" *)
      ]

fun unmatched_err t l s l' s' = raise(Error(Unmatched(t,l,s,l',s')))
fun invalid_err t l = raise(Error(Invalid(t,l)))
fun duplicate_err t l l' n = raise(Error(Duplicate(t,l,l',n)))
fun unknown_err l = raise(Error(Unknown(l)))
fun debug_err l s = raise(Error(Debug(l,s)))
fun predefined l n  = raise(Error(Predefined(l,n)))

fun check_opt f p = case p of None => () | Some(p') => f p'

fun addenv_distinct env (id,loc) idty = 
  (let val (x,loc') = find (fn (x,loc) => x = id) env
    in duplicate_err idty loc' loc id end)
  handle Not_found => (id,loc)::env

fun chkenv_distinct env (id,loc) idty = 
  (let val (x,loc') = find (fn (x,loc) => x = id) env
    in duplicate_err idty loc' loc id end)
  handle Not_found => [(id,loc)]

fun check_con env (id,_,_) = addenv_distinct env id DupConId
   
val count = ref 0

fun fold_left_env f b l =
  let val (_, nenv) =
        fold_left
          (fn (oenv,nenv) pr => 
             let val newenv = f oenv pr
              in (oenv @ newenv, nenv @ newenv)
             end)
          (b, []) l
   in  nenv
  end

fun check_patrow env (_,p,_) = check_pat_env env p

and check_pat_env env p =
  case p of
    RecordPat(l,_) => fold_left_env check_patrow env l
  | SubRecordPat(l,_) => fold_left_env check_patrow env l
  | RefPat(p,_) => check_pat_env env p
  | VarPat(v as (id,loc),_) => 
      if mem id keywords
      then predefined loc id
      else if id = "true" orelse id = "false"
	  then []
	  else chkenv_distinct env v DupVarId 
  | AppPat(_,p,_) => check_pat_env env p
  | ConstraintPat(p,_,_) => check_pat_env env p
  | AsPat(id,_,p,_) => (check_pat_env (addenv_distinct env id DupVarId) p)@[id]
  | TuplePat(l,_) => fold_left_env check_pat_env env l
  | ListPat(l,_) => fold_left_env check_pat_env env l
  | ArrayPat(l,_) => fold_left_env check_pat_env env l
  | OrPat(l,loc) => 
      let fun check_orpat None p =
                 let val nenv = check_pat_env env p
                  in Some(nenv) end
            | check_orpat (nenv as Some(env')) p =
                if sort compare (fst (split env')) = 
                   sort compare (fst (split (check_pat_env env p)))
                then nenv
                else invalid_err InvOrPat loc 
          
       in case (fold_left check_orpat None l) of
            Some(nenv) => nenv
          | None => debug_err loc "compiler bug : No pattern in or pattern"
      end
  | _ => []

fun check_pat p = ignore(check_pat_env [] p)

fun check_exprow (_,e,_) = check_exp e

and check_rule (p,e,_) = (check_pat p; check_exp e)

and check_fnrule (pl,e,_) =
      (ignore(fold_left_env check_pat_env [] pl); check_exp e)

and check_rec lab_list labexp_list =
  case labexp_list of
    [] => ()
  | (lab,exp,_)::labexp_list' =>
    let fun check_dup _ [] = ()
          | check_dup (name,loc) ((name',loc')::l) =
            if name = name' 
              then duplicate_err DupLabel loc' loc name
              else check_dup (name,loc) l
     in check_dup lab lab_list;
        check_exp exp;
        check_rec (lab::lab_list) labexp_list'
    end

and check_exp p =
  case p of
    AppExp(e,al,_) => check_exp e; iter check_exp al
  | RecordExp(l,_) => check_rec [] l
  | RecordFieldExp(e,_,_) => check_exp e
  | ArrayFieldExp(e,e',_) => check_exp e; check_exp e'
  | UpdateArrayExp(e,e',e'',_) => check_exp e; check_exp e'; check_exp e''
  | SubstRecordExp(e,_,e',_) => check_exp e; check_exp e'
  | TupleExp(l,_) => iter check_exp l
  | ListExp(l,_) => iter check_exp l
  | ArrayExp(l,_) => iter check_exp l
  | LetExp(d,e,_) => check_dec d; check_exp e
  | HandleExp(e,l,_) => check_exp e; iter check_rule l
  | RaiseExp(e,_) => check_exp e
  | FnExp(l,_) => iter check_fnrule l
  | AssignExp(e, e',_) => check_exp e; check_exp e'
  | RefExp(e,_) => check_exp e
  | DeRefExp(e,_) => check_exp e
  | SeqExp(l,_) => iter check_exp l
  | CaseExp(e,l,_) => check_exp e; iter check_rule l
  | IfExp(e,e',e'',_) => check_exp e; check_exp e'; check_exp e''
  | WhileExp(e,e',_) => check_exp e; check_exp e'
  | ForExp(_,e,e',e'',e''',_) =>
      check_exp e; check_exp e'; check_exp e''; check_exp e'''
  | ConstraintExp(e,t,_) => check_exp e
  | _ => ()

and check_valbind env (r,p,e,loc) = 
  (let fun filter (Rec,VarPat(_,_),FnExp(_,_)) = ()
         | filter (Rec,ConstraintPat(p,_,_),e) = filter (Rec,p,e)
         | filter (Rec,VarPat(_,loc'),_) = invalid_err InvRecBind loc'
         | filter (Rec,_,_) = invalid_err InvRecBind loc
         | filter (Nonrec,_,_) = () 
    in filter (r,p,e) ; check_exp e; check_pat_env env p
   end)

and check_funbind env (bl,loc) =
  (let fun check_body None ((id,loc),pl,e,_) = 
            (ignore(fold_left_env check_pat_env [] pl); 
             check_exp e; Some(id,loc))
        | check_body (fid as (Some(id,loc))) ((id',loc'),pl,e,_) =
            (ignore(fold_left_env check_pat_env [] pl); check_exp e;
            if id <> id' then unmatched_err DiffFunId loc' id' loc id;
            fid)
   in case fold_left check_body None bl of
        None => debug_err loc "compiler bug: no function body"
      | Some fid => addenv_distinct env fid DupVarId
   end)

and check_typebind (env,cenv) tb =
  (case tb of
    TypeBind(_,id,_,_) => (addenv_distinct env id DupTypeId,cenv)
  | DataBind(_,id,cl,_) => 
      (addenv_distinct env id DupTypeId, fold_left check_con cenv cl))

and check_exnbind cenv c = check_con cenv c

and check_dec p =
  (case p of
    ValDec(_,l,_) => ignore(fold_left check_valbind [] l)
  | FunDec(_,l,_) => ignore(fold_left check_funbind [] l)
  | TypeDec(l,_) => ignore(fold_left check_typebind ([],[]) l)
(* | AbstypeDec(l,d,_) => ignore(fold_left check_typebind [] l); check_dec d *)
  | ExceptionDec(l,_) => ignore(fold_left check_exnbind [] l)
  | LocalDec(d,d',_) => (check_dec d; check_dec d')
  | OpenDec(l,_) => ()
  | SeqDec(l,_) => iter check_dec l)

fun check_strexp p = 
  (case p of
    VarStr(_,_) => ()
  | StrStr(d,_) => check_strdec d
  | SigStr(ste,sie,_) => (check_strexp ste; check_sigexp sie)
  | FctAppStr(_,sl,_) => iter check_strexp sl)

and check_strbind (_,sgop,se,_) =
  (check_opt check_sigexp sgop; check_strexp se)

and check_strdec p = 
  (case p of
    SimpleDec(d,_) => check_dec d
  | StrDec(l,_) => iter check_strbind l
  | SeqStrDec(l,_) => iter check_strdec l)

and check_valdesc env (id,_,_) = addenv_distinct env id DupVarId

and check_typedesc (env,cenv) td =
  (case td of
    TypeDesc(_,id,_) => (addenv_distinct env id DupTypeId,cenv)
  | TypeBindDesc(_,id,_,_) => (addenv_distinct env id DupTypeId,cenv)
  | DataDesc(_,id,cl,_) =>
      (addenv_distinct env id DupTypeId,fold_left check_con cenv cl))

and check_exndesc cenv c = check_con cenv c

and check_strdesc (_,se,_) = check_sigexp se

and check_spec (tenv,venv) p =
  (case p of
    ValSpec(l,_) => (tenv,fold_left check_valdesc venv l)
  | TypeSpec(l,_) => (fst (fold_left check_typedesc (tenv,[]) l),venv)
  | ExnSpec(l,_) => (ignore(fold_left check_exndesc [] l); (tenv,venv))
  | IncludeSpec(s,_) => check_sigexp_env (tenv,venv) s
  | StrSpec(l,_) => (iter check_strdesc l; (tenv,venv))
  | SeqSpec(l,_) => fold_left check_spec (tenv,venv) l)

and check_sigexp_env (tenv,venv) p =
  (case p of
    VarSig(s,_) => (tenv,venv)
  | SigSig(s,_) => check_spec (tenv,venv) s
  | ConstraintSig(se,_,_) => check_sigexp_env (tenv,venv) se)

and check_sigexp p = ignore(check_sigexp_env ([],[]) p)

fun check_sigbind (_,s,_) = check_sigexp s

fun check_sigdec (l,_) = iter check_sigbind l

fun check_fctarg (_,se,_) = check_sigexp se

fun check_fctdec p =
  (case p of
    (_, al, sgop, se, _) =>
      (iter check_fctarg al; check_opt check_sigexp sgop; check_strexp se))

fun check_topdec p =
  (case p of
    Str(d,_) => check_strdec d
  | Sig(d,_) => check_sigdec d
  | Fct(d,_) => check_fctdec d
  | SeqTopDec(dl,_) => iter check_topdec dl)

fun check_toplevel p =
  (case p of
    TopDec(d,_) => check_topdec d
  | TopExp(e,_) => check_exp e
  | _ => ())

(*
 Modification history.

 2000/03/27 By Judaigi

 - Remove print_databind and print_datadesc functions.
 - Change according to changes in ast.

 2003/04/28 By Youil Kim

 - Add check_rec for record-field-duplication checking.
*)
end