civicaml/phases/context_analysis.ml

open Printf
open Types
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 (dec, dec_depth, _) ->
        (dec, 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 dec 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 dec) msg args.verbose;
            prerr_loc_msg (locof orig) "Previously declared here:" args.verbose;
            raise EmptyError
        | Some _ ->
            Hashtbl.replace tbl name (dec, depth, name_type)
        | None ->
            Hashtbl.add tbl name (dec, depth, name_type)
    in

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

        (* For global vars, only the name and array dimensions *)
        | GlobalDec (Array (ctype, dims), name, ann) ->
            add_to_scope (Varname name) node depth scope;
            GlobalDec (Array (ctype, List.map collect dims), name, ann)

        | Dim (name, ann) ->
            add_to_scope (Varname name) node depth scope;
            Dim (name, Depth depth :: ann)

        | GlobalDec (ctype, name, ann) ->
            add_to_scope (Varname name) node depth scope;
            GlobalDec (ctype, name, Depth depth :: ann)

        | GlobalDef (export, ctype, name, init, ann) ->
            add_to_scope (Varname name) node depth scope;
            GlobalDef (export, ctype, name, init, Depth depth :: ann)

        (* Functions are traversed later on, for now only add the name *)
        | FunDec (ret_type, name, params, ann) ->
            add_to_scope (Funcname name) node depth scope;
            FunDec (ret_type, name, params, Depth depth :: ann)

        | FunDef (export, ret_type, name, params, body, ann) ->
            add_to_scope (Funcname name) node depth scope;
            FunDef (export, ret_type, name, params, body, Depth depth :: ann)

        (* For a variable or function call, look for its declaration in the
         * current scope and save a its type/depth information  *)
        | Var (name, dims, ann) ->
            let (dec, dec_depth) = check_in_scope (Varname name) node scope in
            VarUse (dec, optmap collect dims, Depth depth :: ann)

        | FunCall (name, args, ann) ->
            let (dec, dec_depth) = check_in_scope (Funcname name) node scope in
            FunUse (dec, List.map collect args, Depth depth :: ann)

        (* Assign statements are replaced with VarLet nodes, which stores the type
         * and depth of the assigned variable are *)
        | Assign (name, dims, value, ann) ->
            let (dec, dec_depth) = check_in_scope (Varname name) node scope in
            VarLet (dec, optmap collect dims, collect value, Depth depth :: ann)

        | _ -> transform_children collect node
    in

    let rec traverse scope depth node =
        match node with
        (* Increase nesting level when entering function *)
        | FunDef (export, ret_type, name, params, body, ann) ->
            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, ann)

        | Param (Array (ctype, dims), name, ann) as node ->
            let _ = List.map (traverse scope depth) dims in
            add_to_scope (Varname name) node depth scope;
            node

        | Dim (name, _) as dim ->
            add_to_scope (Varname name) dim 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;
     *)
    let node = collect node in

    let node = traverse scope depth node in
    node

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

let rec phase input =
    log_line 2 "- Context analysis";
    match input with
    | Types node -> Types (analyse_context args node)
    | _ -> raise (InvalidInput "context analysis")