(* tag-parser.ml
 * A compiler from Scheme to CISC
 *
 * Programmer: Mayer Goldberg, 2018
 *)

#use "tag-parser.ml";;

type var =
  | VarFree of string
  | VarParam of string * int
  | VarBound of string * int * int;;

type expr' =
  | Const' of constant
  | Var' of var
  | Box' of var
  | BoxGet' of var
  | BoxSet' of var * expr'
  | If' of expr' * expr' * expr'
  | Seq' of expr' list
  | Set' of expr' * expr'
  | Def' of expr' * expr'
  | Or' of expr' list
  | LambdaSimple' of string list * expr'
  | LambdaOpt' of string list * string * expr'
  | Applic' of expr' * (expr' list)
  | ApplicTP' of expr' * (expr' list);;

let rec expr'_eq e1 e2 =
  match e1, e2 with
  | Const' Void, Const' Void -> true
  | Const'(Sexpr s1), Const'(Sexpr s2) -> sexpr_eq s1 s2
  | Var'(VarFree v1), Var'(VarFree v2) -> String.equal v1 v2
  | Var'(VarParam (v1,mn1)), Var'(VarParam (v2,mn2)) -> String.equal v1 v2 && mn1 = mn2
  | Var'(VarBound (v1,mj1,mn1)), Var'(VarBound (v2,mj2,mn2)) -> String.equal v1 v2 && mj1 = mj2  && mn1 = mn2
  | If'(t1, th1, el1), If'(t2, th2, el2) -> (expr'_eq t1 t2) &&
                                            (expr'_eq th1 th2) &&
                                              (expr'_eq el1 el2)
  | (Seq'(l1), Seq'(l2)
  | Or'(l1), Or'(l2)) -> List.for_all2 expr'_eq l1 l2
  | (Set'(var1, val1), Set'(var2, val2)
  | Def'(var1, val1), Def'(var2, val2)) -> (expr'_eq var1 var2) &&
                                             (expr'_eq val1 val2)
  | LambdaSimple'(vars1, body1), LambdaSimple'(vars2, body2) ->
     (List.for_all2 String.equal vars1 vars2) &&
       (expr'_eq body1 body2)
  | LambdaOpt'(vars1, var1, body1), LambdaOpt'(vars2, var2, body2) ->
     (String.equal var1 var2) &&
       (List.for_all2 String.equal vars1 vars2) &&
         (expr'_eq body1 body2)
  | Applic'(e1, args1), Applic'(e2, args2)
  | ApplicTP'(e1, args1), ApplicTP'(e2, args2) ->
	 (expr'_eq e1 e2) &&
	   (List.for_all2 expr'_eq args1 args2)
  | _ -> false;;


exception X_syntax_error;;

module type SEMANTICS = sig
  val run_semantics : expr -> expr'
  val annotate_lexical_addresses : expr -> expr'
  val annotate_tail_calls : expr' -> expr'
  val box_set : expr' -> expr'
end;;

module Semantics : SEMANTICS = struct

let rec _find_minor_index_ x params =
  match params with
  |[] -> raise X_syntax_error
  |a::b -> if x=a then 0 else 1 + _find_minor_index_ x b;;

let rec _exists_major_index_ x simulated_scope =
  if(simulated_scope = [])
  then false
  else(
  let _head_ = List.hd simulated_scope in
  let _tail_ = List.tl simulated_scope in
  if(List.mem x _head_)
  then true
  else(
    if (_tail_ = [])
    then false
    else _exists_major_index_ x _tail_
  ));;

let rec _find_major_index_ x simulated_scope =
  match simulated_scope with
  |[]->raise X_syntax_error
  |[[]] -> raise X_syntax_error
  |a::b ->  if (List.mem x a)
            then 0
            else 1 + _find_major_index_ x b;;

let rec _ala_helper_ e params simulated_scope =
  let _matcher_ e params simulated_scope =
    match e with
    |Const(a)->Const'(a)
    |If(a,b,c)->If'(_ala_helper_ a params simulated_scope,_ala_helper_ b params simulated_scope,_ala_helper_ c params simulated_scope)
    |Seq(exprlist)->Seq'(List.map (fun(x)->_ala_helper_ x params simulated_scope) exprlist)
    |Set(a,b)->Set'(_ala_helper_ a params simulated_scope,_ala_helper_ b params simulated_scope)
    |Def(a,b)->Def'(_ala_helper_ a params simulated_scope,_ala_helper_ b params simulated_scope)
    |Or(exprlist)->Or'(List.map (fun(x)->_ala_helper_ x params simulated_scope) exprlist)
    |Applic(a,exprlist)->Applic'(_ala_helper_ a params simulated_scope ,(List.map (fun(x)->_ala_helper_ x params simulated_scope) exprlist))
    |Var(a)-> (
      if (List.mem a params)
      then (
        let _minor_index_ = _find_minor_index_ a params in
        Var'(VarParam(a,_minor_index_))
      )
      else(
        if (_exists_major_index_ a simulated_scope)
        then(
          let _major_index_ = _find_major_index_ a simulated_scope in
          let _minor_index_ = _find_minor_index_ a (List.nth simulated_scope _major_index_) in
          Var'(VarBound(a,_major_index_,_minor_index_))
        )
        else Var'(VarFree(a))
      ))
    |LambdaSimple(varlist,exprlist)-> _handle_lambda_ e params simulated_scope
    |LambdaOpt(varlist,varopt,exprlist)-> _handle_lambda_ e params simulated_scope
      in (_matcher_ e params simulated_scope)

  and _handle_lambda_ e params simulated_scope =
    match e with
    |LambdaSimple(varlist,exprlist)-> let simulated_scope = [params]@simulated_scope in
                                      let params = varlist in
                                      LambdaSimple'(varlist,_ala_helper_ exprlist params simulated_scope)
    |LambdaOpt(varlist,varopt,exprlist)-> let simulated_scope = [params]@simulated_scope in
                                          let params = varlist@[varopt] in
                                          LambdaOpt'(varlist,varopt,_ala_helper_ exprlist params simulated_scope)
    |_->raise X_syntax_error;;

let annotate_lexical_addresses e =
  _ala_helper_ e [] [];;

let rec _atc_helper_ e tp =
  let _matcher_ e tp =
    match e with
    |Const'(a)->Const'(a)
    |Var'(a)->Var'(a)
    |Applic'(expr,exprlist)-> if tp
                              then ApplicTP'(_atc_helper_ expr false,List.map (fun(x)-> _atc_helper_ x false) exprlist)
                              else Applic'(_atc_helper_ expr false,List.map (fun(x)-> _atc_helper_ x false) exprlist)
    |Or'(exprlist)-> (let last = List.hd (List.rev exprlist) in
                      let reisha =List.rev (List.tl (List.rev exprlist)) in
                      Or'((List.map (fun(x)->_atc_helper_ x false) reisha)@[_atc_helper_ last tp])
                      )
    |If'(test,dit,dif)->If'(_atc_helper_ test false, _atc_helper_ dit tp,_atc_helper_ dif tp)
    |Def'(a,b)->Def'(a,_atc_helper_ b false)
    |LambdaSimple'(varlist,exprlist)->LambdaSimple'(varlist,_atc_helper_ exprlist true)
    |LambdaOpt'(varlist,varopt,exprlist)->LambdaOpt'(varlist,varopt,_atc_helper_ exprlist true)
    |Seq'(exprlist)->(let last = List.hd (List.rev exprlist) in
                      let reisha =List.rev (List.tl (List.rev exprlist)) in
                      Seq'((List.map (fun(x)->_atc_helper_ x false) reisha)@[_atc_helper_ last tp])
                      )
    |Set'(a,b) -> Set'(_atc_helper_ a false,_atc_helper_ b false)
    |_->raise X_syntax_error
    in (_matcher_ e tp);;

let annotate_tail_calls e = _atc_helper_ e false;;

let rec box_set_helper e need_boxing_list =
  let matcher e need_boxing_list =
    match e with
    |Const'(a)->Const'(a)
    |Var'(a)-> (match a with
                |VarFree(name)-> Var'(a)
                |VarParam(name,minor)-> if(List.mem a need_boxing_list)
                                        then(BoxGet'(VarParam(name,minor)))
                                        else(Var'(a))
                |VarBound(name,major,minor)-> if(List.mem a need_boxing_list)
                                              then(BoxGet'(VarBound(name,major,minor)))
                                              else(Var'(a))
                )
    |Applic'(expr,exprlist)->Applic'(box_set_helper expr need_boxing_list, List.map (fun(x)->box_set_helper x need_boxing_list) exprlist)
    |ApplicTP'(expr,exprlist)->ApplicTP'(box_set_helper expr need_boxing_list, List.map (fun(x)->box_set_helper x need_boxing_list) exprlist)
    |Or'(exprlist)->Or'(List.map (fun(x)->box_set_helper x need_boxing_list) exprlist)
    |If'(test,dit,dif)->If'(box_set_helper test need_boxing_list,box_set_helper dit need_boxing_list,box_set_helper dif need_boxing_list)
    |Def'(a,b)->Def'(box_set_helper a need_boxing_list,box_set_helper b need_boxing_list)
    |LambdaSimple'(varlist,exprlist)-> let need_boxing_list = (List.map (fun(x)-> match x with
                                                                        |VarParam(name,minor)->VarBound(name,0,minor)
                                                                        |VarBound(name,major,minor)->VarBound(name,major+1,minor)
                                                                        |a->a) need_boxing_list) in
                                       let vars_to_set = [] in
                                       let vars_to_set,need_boxing_list = (lambda_helper varlist varlist exprlist vars_to_set need_boxing_list) in
                                        if(vars_to_set = [])
                                        then (LambdaSimple'(varlist, box_set_helper exprlist need_boxing_list))
                                        else (LambdaSimple'(varlist, Seq'(vars_to_set@[box_set_helper exprlist need_boxing_list])))
    |LambdaOpt'(varlist,varopt,exprlist)->  let need_boxing_list = (List.map (fun(x)-> match x with
                                                                                      |VarParam(name,minor)->VarBound(name,0,minor)
                                                                                      |VarBound(name,major,minor)->VarBound(name,major+1,minor)
                                                                                      |a->a) need_boxing_list) in
                                            let vars_to_set = [] in
                                            let vars_to_set,need_boxing_list = (lambda_helper (varlist@[varopt]) (varlist@[varopt]) exprlist vars_to_set need_boxing_list) in
                                            if(vars_to_set = [])
                                            then (LambdaOpt'(varlist,varopt, box_set_helper exprlist need_boxing_list))
                                            else (LambdaOpt'(varlist,varopt, Seq'(vars_to_set @[box_set_helper exprlist need_boxing_list])))
    |Seq'(exprlist)->Seq'(List.map (fun(x)->box_set_helper x need_boxing_list) exprlist)
    |Set'(Var'(a),b)->(match a with
                |VarFree(name)->Set'(Var'(a),box_set_helper b need_boxing_list)
                |VarParam(name,minor)->if(List.mem a need_boxing_list)
                                        then(BoxSet'(a,box_set_helper b need_boxing_list))
                                        else(Set'(Var'(a),box_set_helper b need_boxing_list))
                |VarBound(name,major,minor)-> if(List.mem a need_boxing_list)
                                              then(BoxSet'(a,box_set_helper b need_boxing_list))
                                              else(Set'(Var'(a),box_set_helper b need_boxing_list))
                )
    |_->raise X_syntax_error
    in (matcher e need_boxing_list)

  and lambda_helper varlist_full varlist exprlist vars_to_set need_boxing_list =
    match varlist with
    |[]-> vars_to_set,need_boxing_list
    |var::rest -> (
      if(need_boxing var exprlist)
      then(
        let minor_index = _find_minor_index_ var varlist_full in
        let vars_to_set = vars_to_set@[Set'(Var'(VarParam(var,minor_index)),Box'(VarParam(var,minor_index)))] in
        let current = VarParam(var,minor_index) in
        let need_boxing_list = need_boxing_list@[current] in
        (lambda_helper varlist_full rest exprlist vars_to_set need_boxing_list)
      )
      else (lambda_helper varlist_full rest exprlist vars_to_set need_boxing_list)
    )

  and check_read var body counter =
    match body with
    |Const'(a)->[]
    |Var'(a)->(match a with
              |VarParam(name,mn)->if(name=var) then (if (counter=0) then [0] else [-1]) else []
              |VarBound(name,mj,mn)->if(name=var) then (if (counter=0) then [0] else [-1]) else []
              |_->[])
    |Applic'(expr,exprlist)-> (check_read var expr counter)@(List.flatten (List.map (fun(x)-> check_read var x counter) exprlist))
    |ApplicTP'(expr,exprlist)->(check_read var expr counter)@(List.flatten (List.map (fun(x)-> check_read var x counter) exprlist))
    |Or'(exprlist)->(List.flatten (List.map (fun(x)-> check_read var x counter) exprlist))
    |If'(test,dit,dif)-> (check_read var test counter)@(check_read var dit counter)@(check_read var dif counter)
    |Def'(a,b)->(check_read var a counter)@(check_read var b counter)
    |LambdaSimple'(varlist,exprlist)-> let counter = counter+1 in
                                        if((check_read var exprlist counter) = [])
                                        then []
                                        else [counter]
    |LambdaOpt'(varlist,varopt,exprlist)-> let counter = counter+1 in
                                        if((check_read var exprlist counter) = [])
                                        then []
                                        else [counter]
    |Seq'(exprlist)->(List.flatten (List.map (fun(x)-> check_read var x counter) exprlist))
    |Set'(a,b)->(check_read var a counter)@(check_read var b counter)
    |_->raise X_syntax_error

  and check_write var body counter =
    match body with
    |Const'(a)->[]
    |Set'(Var'(a),b)-> (match a with
                        |VarParam(name,mn)->if(name=var) then (if (counter=0) then [0] else [-1]) else []
                        |VarBound(name,mj,mn)-> if(name=var) then (if (counter=0) then [0] else [-1]) else []
                        |_->[])
    |Applic'(expr,exprlist)-> (check_write var expr counter)@(List.flatten (List.map (fun(x)-> check_write var x counter) exprlist))
    |ApplicTP'(expr,exprlist)->(check_write var expr counter)@(List.flatten (List.map (fun(x)-> check_write var x counter) exprlist))
    |Or'(exprlist)->(List.flatten (List.map (fun(x)-> check_write var x counter) exprlist))
    |If'(test,dit,dif)-> (check_write var test counter)@(check_write var dit counter)@(check_write var dif counter)
    |Def'(a,b)->(check_write var a counter)@(check_write var b counter)
    |LambdaSimple'(varlist,exprlist)-> let counter = counter+1 in
                                        if((check_write var exprlist counter) = [])
                                        then []
                                        else [counter]
    |LambdaOpt'(varlist,varopt,exprlist)->let counter = counter+1 in
                                        if((check_write var exprlist counter) = [])
                                        then []
                                        else [counter]
    |Seq'(exprlist)->(List.flatten (List.map (fun(x)-> check_write var x counter) exprlist))
    |Var'(a)->[]
    |_->raise X_syntax_error

  and need_boxing var body=
    let read_list = check_read var body 0 in
    let write_list = check_write var body 0 in
    if (not((read_list = [])&&(write_list = [])))
    then(
      let cart = List.flatten (List.map (fun(x)-> (List.map (fun(y)-> [x;y]) write_list)) read_list) in
      let mapped = (List.map (fun(x)-> match x with
                                      |[a;b]-> a=b
                                      |_->false) cart) in
      if (List.mem false mapped)
      then true
      else false
    )
    else false;;


    let rec box_set_helper e need_boxing_list =
      let matcher e need_boxing_list =
        match e with
        |Const'(a)->Const'(a)
        |Var'(a)-> (match a with
                    |VarFree(name)-> Var'(a)
                    |VarParam(name,minor)-> if(List.mem a need_boxing_list)
                                            then(BoxGet'(VarParam(name,minor)))
                                            else(Var'(a))
                    |VarBound(name,major,minor)-> if(List.mem a need_boxing_list)
                                                  then(BoxGet'(VarBound(name,major,minor)))
                                                  else(Var'(a))
                    )
        |Applic'(expr,exprlist)->Applic'(box_set_helper expr need_boxing_list, List.map (fun(x)->box_set_helper x need_boxing_list) exprlist)
        |ApplicTP'(expr,exprlist)->ApplicTP'(box_set_helper expr need_boxing_list, List.map (fun(x)->box_set_helper x need_boxing_list) exprlist)
        |Or'(exprlist)->Or'(List.map (fun(x)->box_set_helper x need_boxing_list) exprlist)
        |If'(test,dit,dif)->If'(box_set_helper test need_boxing_list,box_set_helper dit need_boxing_list,box_set_helper dif need_boxing_list)
        |Def'(a,b)->Def'(box_set_helper a need_boxing_list,box_set_helper b need_boxing_list)
        |LambdaSimple'(varlist,exprlist)-> let need_boxing_list = (List.map (fun(x)-> match x with
                                                                            |VarParam(name,minor)->VarBound(name,0,minor)
                                                                            |VarBound(name,major,minor)->VarBound(name,major+1,minor)
                                                                            |a->a) need_boxing_list) in
                                           let vars_to_set = [] in
                                           let vars_to_set,need_boxing_list = (lambda_helper varlist varlist exprlist vars_to_set need_boxing_list) in
                                            if(vars_to_set = [])
                                            then (LambdaSimple'(varlist, box_set_helper exprlist need_boxing_list))
                                            else (LambdaSimple'(varlist, Seq'(vars_to_set@[box_set_helper exprlist need_boxing_list])))
        |LambdaOpt'(varlist,varopt,exprlist)->  let need_boxing_list = (List.map (fun(x)-> match x with
                                                                                          |VarParam(name,minor)->VarBound(name,0,minor)
                                                                                          |VarBound(name,major,minor)->VarBound(name,major+1,minor)
                                                                                          |a->a) need_boxing_list) in
                                                let vars_to_set = [] in
                                                let vars_to_set,need_boxing_list = (lambda_helper (varlist@[varopt]) (varlist@[varopt]) exprlist vars_to_set need_boxing_list) in
                                                if(vars_to_set = [])
                                                then (LambdaOpt'(varlist,varopt, box_set_helper exprlist need_boxing_list))
                                                else (LambdaOpt'(varlist,varopt, Seq'(vars_to_set @[box_set_helper exprlist need_boxing_list])))
        |Seq'(exprlist)->Seq'(List.map (fun(x)->box_set_helper x need_boxing_list) exprlist)
        |Set'(Var'(a),b)->(match a with
                    |VarFree(name)->Set'(Var'(a),box_set_helper b need_boxing_list)
                    |VarParam(name,minor)->if(List.mem a need_boxing_list)
                                            then(BoxSet'(a,box_set_helper b need_boxing_list))
                                            else(Set'(Var'(a),box_set_helper b need_boxing_list))
                    |VarBound(name,major,minor)-> if(List.mem a need_boxing_list)
                                                  then(BoxSet'(a,box_set_helper b need_boxing_list))
                                                  else(Set'(Var'(a),box_set_helper b need_boxing_list))
                    )
        |_->raise X_syntax_error
        in (matcher e need_boxing_list)

      and lambda_helper varlist_full varlist exprlist vars_to_set need_boxing_list =
        match varlist with
        |[]-> vars_to_set,need_boxing_list
        |var::rest -> (
          if(need_boxing var exprlist)
          then(
            let minor_index = _find_minor_index_ var varlist_full in
            let vars_to_set = vars_to_set@[Set'(Var'(VarParam(var,minor_index)),Box'(VarParam(var,minor_index)))] in
            let current = VarParam(var,minor_index) in
            let need_boxing_list = need_boxing_list@[current] in
            (lambda_helper varlist_full rest exprlist vars_to_set need_boxing_list)
          )
          else (lambda_helper varlist_full rest exprlist vars_to_set need_boxing_list)
        )

      and check_read var body counter =
        match body with
        |Const'(a)->[]
        |Var'(a)->(match a with
                  |VarParam(name,mn)->if(name=var) then (if ((!counter)=0) then [0] else [-1]) else []
                  |VarBound(name,mj,mn)->if(name=var) then (if ((!counter)=0) then [0] else [-1]) else []
                  |_->[])
        |Applic'(expr,exprlist)-> (check_read var expr counter)@(List.flatten (List.map (fun(x)-> check_read var x counter) exprlist))
        |ApplicTP'(expr,exprlist)->(check_read var expr counter)@(List.flatten (List.map (fun(x)-> check_read var x counter) exprlist))
        |Or'(exprlist)->(List.flatten (List.map (fun(x)-> check_read var x counter) exprlist))
        |If'(test,dit,dif)-> (check_read var test counter)@(check_read var dit counter)@(check_read var dif counter)
        |Def'(a,b)->(check_read var a counter)@(check_read var b counter)
        |LambdaSimple'(varlist,exprlist)-> counter := (!counter)+1 ;
                                            if((check_read var exprlist counter) = [])
                                            then []
                                            else [(!counter)]
        |LambdaOpt'(varlist,varopt,exprlist)-> counter := (!counter)+1 ;
                                            if((check_read var exprlist counter) = [])
                                            then []
                                            else [(!counter)]
        |Seq'(exprlist)->(List.flatten (List.map (fun(x)-> check_read var x counter) exprlist))
        |Set'(a,b)->(check_read var b counter)
        |_->raise X_syntax_error

      and check_write var body counter =
        match body with
        |Const'(a)->[]
        |Set'(Var'(a),b)-> (match a with
                            |VarParam(name,mn)->if(name=var) then (if ((!counter)=0) then [0] else [-1]) else []
                            |VarBound(name,mj,mn)-> if(name=var) then (if ((!counter)=0) then [0] else [-1]) else []
                            |_->[])
        |Applic'(expr,exprlist)-> (check_write var expr counter)@(List.flatten (List.map (fun(x)-> check_write var x counter) exprlist))
        |ApplicTP'(expr,exprlist)->(check_write var expr counter)@(List.flatten (List.map (fun(x)-> check_write var x counter) exprlist))
        |Or'(exprlist)->(List.flatten (List.map (fun(x)-> check_write var x counter) exprlist))
        |If'(test,dit,dif)-> (check_write var test counter)@(check_write var dit counter)@(check_write var dif counter)
        |Def'(a,b)->(check_write var a counter)@(check_write var b counter)
        |LambdaSimple'(varlist,exprlist)-> counter := (!counter)+1 ;
                                            if((check_write var exprlist counter) = [])
                                            then []
                                            else [(!counter)]
        |LambdaOpt'(varlist,varopt,exprlist)->counter := (!counter)+1 ;
                                            if((check_write var exprlist counter) = [])
                                            then []
                                            else [(!counter)]
        |Seq'(exprlist)->(List.flatten (List.map (fun(x)-> check_write var x counter) exprlist))
        |Var'(a)->[]
        |_->raise X_syntax_error

      and need_boxing var body=
        let read_counter = ref 0 in
        let write_counter = ref 0 in
        let read_list = check_read var body read_counter in
        let write_list = check_write var body write_counter in
        if (not((read_list = [])&&(write_list = [])))
        then(
          let cart = List.flatten (List.map (fun(x)-> (List.map (fun(y)-> [x;y]) write_list)) read_list) in
          let mapped = (List.map (fun(x)-> match x with
                                          |[a;b]-> a=b
                                          |_->false) cart) in
          if (List.mem false mapped)
          then true
          else false
        )
        else false;;

let box_set e = box_set_helper e [];;

let run_semantics expr =
  box_set
    (annotate_tail_calls
       (annotate_lexical_addresses expr));;

end;; (* struct Semantics *)