civicaml/phases/extern.ml

open Types
open Util
open Globals

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, 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, name, ann) ->
        (* Getters for external array variable: create getter and setter for a
         * given index *)
        let (param, _) = create_param Int "index" 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]

    (* 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 phase = function
    | Ast node ->
        let globals = Hashtbl.create 20 in
        let node = create_funcs globals node in
        Ast (replace_vars globals 0 node)
    | _ -> raise (InvalidInput "extern vars")