civicaml/phases/extern_vars.ml

open Types
open Util

let create_param ctype name =
    let param = Param (ctype, name, [Depth 1]) in
    let value = VarUse (param, None, [Type ctype; Depth 1]) in
    (param, value)

let call node args depth = match node with
    | FunDec (ctype, name, _, _) as dec ->
        FunUse (dec, args, [Type ctype; Depth depth])
    | _ -> raise InvalidNode

let process globals = function
    | GlobalDef (true, Array (ctype, dims), name, None, ann) as dec ->
        (* Getters for array variable: crate getter for given index Note that
         * getters and setters for dimensions are automatically generated,
         * because they have been put into new global variables during the
         * desugarin phase *)
        let (param, index) = create_param Int (fresh_var "index") in
        let var = VarUse (dec, Some [index], [Type ctype; Depth 1]) in
        let body = Block [Return (var, [])] in
        let getter = FunDef (true, ctype, name ^ "$get", [param], body, []) in

        (* Setters for array variable: create setter for given index *)
        let (param1, index) = create_param Int (fresh_var "index") in
        let (param2, value) = create_param ctype (fresh_var "value") in
        let body = Block [VarLet (dec, Some [index], value, [])] in
        let setter = FunDef (true, Void, name ^ "$set", [param1; param2], body, []) in

        [getter; setter]

    | GlobalDef (true, ctype, name, None, ann) as dec ->
        (* Getter for basic variable type: return the variable *)
        let var = VarUse (dec, None, [Type ctype; Depth 1]) in
        let body = [Return (var, [])] in
        let getter = FunDef (true, ctype, name ^ "$get", [], Block body, []) in

        (* Setter for basic variable type: assign the variable *)
        let (param, value) = create_param ctype (fresh_var "value") in
        let body = [VarLet (dec, None, value, [])] in
        let setter = FunDef (true, Void, name ^ "$set", [param], Block body, []) in

        [getter; setter]

    | GlobalDec (Array (ctype, dims), name, ann) ->
        (* Getters for external array variable: create getter for a given index *)
        (* Setters for external array variable:
         * - define setter for a given index
         * - define setter for each dimension*)
        let (param, _) = create_param Int "index" in
        let rec process_dims i = function
            | [] -> []
            | Dim (oldname, _) :: tl ->
                let dimname = name ^ "$" ^ string_of_int i in

                let getter = FunDec (Void, dimname ^ "$get", [], []) in

                let (param, _) = create_param ctype "value" in
                let setter = FunDec (Void, dimname ^ "$set", [param], []) in

                Hashtbl.add globals oldname (call getter, call setter);
                getter :: setter :: (process_dims (i + 1) tl)
            | _ -> raise InvalidNode
        in

        let getter = FunDec (ctype, name ^ "$get", [param], []) in

        let (param1, index) = create_param Int "index" in
        let (param2, value) = create_param ctype "value" in
        let setter = FunDec (Void, name ^ "$set", [param1; param2], []) in

        Hashtbl.add globals name (call getter, call setter);
        getter :: setter :: (process_dims 1 dims)

    (* Getter for basic variable type: return the variable *)
    | GlobalDec (ctype, name, ann) ->
        let getter = FunDec (ctype, name ^ "$get", [], []) in

        let (param, _) = create_param ctype "value" in
        let setter = FunDec (Void, name ^ "$set", [param], []) in

        Hashtbl.add globals name (call getter, call setter);
        [getter; setter]

    | _ -> raise InvalidNode

let rec create_funcs globals = function
    | Program (decls, ann) ->
        let decls = List.map (create_funcs globals) decls in
        Program (flatten_blocks (List.map (create_funcs globals) decls), ann)

    | GlobalDef (true, ctype, name, None, ann) as node ->
        Block (GlobalDef (false, ctype, name, None, ann) ::
               (process globals node))

    | GlobalDec (ctype, name, ann) as node ->
        Block (process globals node)

    | node -> transform_children (create_funcs globals) node

let rec replace_vars scope depth = function
    | (VarDec (_, name, _, _) as node)
    | (Param (_, name, _) as node)
            when Hashtbl.mem scope name ->
        Hashtbl.remove scope name;
        node

    | FunDef (export, ret_type, name, params, body, ann) ->
        let local_scope = Hashtbl.copy scope in
        let trav = replace_vars local_scope (depth + 1) in
        let params = List.map trav params in
        FunDef (export, ret_type, name, params, trav body, ann)

    | VarUse (dec, None, _) when Hashtbl.mem scope (nameof dec) ->
        let (get, _) = Hashtbl.find scope (nameof dec) in
        get [] depth

    | VarLet (dec, dims, value, _) when Hashtbl.mem scope (nameof dec) ->
        let dims = optmapl (replace_vars scope depth) dims in
        let (_, set) = Hashtbl.find scope (nameof dec) in
        Expr (set (dims @ [replace_vars scope depth value]) depth)

    | node -> transform_children (replace_vars scope depth) node

let rec phase input =
    log_line 2 "- Create getters and setters for extern variables";
    match input with
    | Types node ->
        let globals = Hashtbl.create 20 in
        let node = create_funcs globals node in
        Types (replace_vars globals 0 node)
    | _ -> raise (InvalidInput "extern vars")