civicaml/phases/context_analysis.ml

open Printf
open Ast
open Util

type nametype = Varname of string | Funcname of string

let type2str = function Funcname _ -> "function" | Varname _ -> "variable"

let mapfind name tbl =
    if Hashtbl.mem tbl name then Some (Hashtbl.find tbl name) else None

let check_in_scope name errnode scope =
    let (vars, funs) = scope in
    let (name, tbl, other_map, desired_type) = match name with
        | Varname  name -> (name, vars, funs, "variable")
        | Funcname name -> (name, funs, vars, "function")
    in
    match mapfind name tbl with
    | Some (decl, dec_depth, _) ->
        (decl, dec_depth)
    | None ->
        let msg = match mapfind name other_map with
            | Some _ -> sprintf "\"%s\" is not a %s" name desired_type
            | None   -> sprintf "undefined %s \"%s\"" desired_type name
        in
        raise (NodeError (errnode, msg))

let rec analyse scope depth args node =
    (* add_to_scope uses args, so it needs to be defined here *)
    let add_to_scope name decl depth scope =
        let (vars, funs) = scope in
        let (name, tbl, name_type) = match name with
            | Varname name  -> (name, vars, "variable")
            | Funcname name -> (name, funs, "function")
        in
        match mapfind name tbl with
        (* Identifiers of lower depth may be overwritten, but idenetifiers at
         * the same depth must be unique for consistency *)
        | Some (orig, orig_depth, _) when orig_depth >= depth ->
            let msg = sprintf "Error: cannot redeclare %s \"%s\"" name_type name in
            prerr_loc_msg (locof decl) msg args.verbose;
            prerr_loc_msg (locof orig) "Previously declared here:" args.verbose;
            raise EmptyError
        | Some _ ->
            Hashtbl.replace tbl name (decl, depth, name_type)
        | None ->
            Hashtbl.add tbl name (decl, depth, name_type)
    in

    let rec collect node = match node with
        (* Add node reference for this varname to vars map *)
        | VarDec (ctype, name, init, loc) ->
            let node = match init with
                | Some value -> VarDec (ctype, name, Some (collect value), loc)
                | None -> node
            in
            add_to_scope (Varname name) node depth scope;
            node

        (* For global vars, only add the name *)
        | GlobalDec (_, name, _)
        | GlobalDef (_, _, name, _, _) ->
            add_to_scope (Varname name) node depth scope;
            node

        (* Functions are traversed later on, for now only add the name *)
        | FunDec (_, name, _, _)
        | FunDef (_, _, name, _, _, _) ->
            add_to_scope (Funcname name) node depth scope;
            node

        (* For a variable or function call, look for its declaration in the
         * current scope and save a its type/depth information  *)
        | Var (name, _) ->
            let (decl, dec_depth) = check_in_scope (Varname name) node scope in
            VarUse (node, ctypeof decl, depth - dec_depth)

        | FunCall (name, args, loc) ->
            let (decl, dec_depth) = check_in_scope (Funcname name) node scope in
            let node = FunCall (name, transform_all collect args, loc) in
            FunUse (node, decl, depth - dec_depth)

        (* Assign statements are wrapped in VarLet nodes, which stores the type
         * and depth of the assigned variable are *)
        | Assign (name, value, loc) ->
            let (decl, dec_depth) = check_in_scope (Varname name) node scope in
            let assign = Assign (name, collect value, loc) in
            VarLet (assign, ctypeof decl, depth - dec_depth)

        | _ -> transform_children collect node
    in

    (*let print_scope () =
        let (vars, funs) = scope in
        let print_key key value = prerr_string (" " ^ key) in
        prerr_string "vars: ";
        Hashtbl.iter print_key vars;
        prerr_endline "";
        prerr_string "funs: ";
        Hashtbl.iter print_key funs;
        prerr_endline "";
    in*)

    let rec traverse scope depth node =
        match node with
        (* Increase nesting level when entering function *)
        | FunDef (export, ret_type, name, params, body, loc) ->
            let (vars, funs) = scope in
            let local_scope = (Hashtbl.copy vars, Hashtbl.copy funs) in
            let params = List.map (traverse local_scope (depth + 1)) params in
            let body = analyse local_scope (depth + 1) args body in
            FunDef (export, ret_type, name, params, body, loc)

        | Param (ArrayDec (_, dims), name, _) as node ->
            let rec add_dims = function
                | [] -> ()
                | Dim (name, _) as dim :: tail ->
                    add_to_scope (Varname name) (DimDec dim) depth scope;
                    add_dims tail
                | _ -> raise InvalidNode
            in
            add_dims dims;
            add_to_scope (Varname name) node depth scope;
            node

        | Param (_, name, _) ->
            add_to_scope (Varname name) node depth scope;
            node

        (* Do not traverse into external function declarations, since their
         * parameters must not be added to the namespace *)
        | FunDec _ -> node

        | _ -> transform_children (traverse scope depth) node
    in

    (*
     * First collect all definitions at the current depth. Then, traverse into
     * functions with a copy of the current scope. This is needed because
     * functions can access all identifiers in their surrounding scope.
     * E.g., the following is allowed:
     *
     * void foo() { glob = 1; }
     * int glob;
     *)
    (*prerr_endline "";
    prerr_endline ("node:----\n" ^ Stringify.node2str node);
    prerr_endline "----";*)
    let node = collect node in
    (*prerr_endline "collected";
    print_scope ();
    prerr_endline "\ntraversing";*)

    let node = traverse scope depth node in
    (*prerr_endline "traversed";
    print_scope ();
    prerr_endline "";*)
    node

let analyse_context args program =
    let scope = (Hashtbl.create 20, Hashtbl.create 20) in
    analyse scope 0 args program

let rec phase input =
    prerr_endline "- Context analysis";
    match input with
    | Ast (node, args) ->
        Ast (analyse_context args node, args)
    | _ -> raise (InvalidInput "context analysis")