civicaml/phases/extern.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, 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")