5.36. Generic support

Start ocaml section to src/flx_generic.mli[1 /1 ]
     1: # 4 "./lpsrc/flx_generic.ipk"
     2: open Flx_types
     3: open Flx_mtypes2
     4: open Flx_ast
     5: 
     6: val find_split_vs:
     7:   sym_state_t ->
     8:   int ->
     9:   plain_ivs_list_t *
    10:   plain_ivs_list_t *
    11:   vs_aux_t
    12: 
    13: val find_vs:
    14:   sym_state_t ->
    15:   int ->
    16:   ivs_list_t
    17: 
    18: val adjust_ts:
    19:   sym_state_t ->
    20:   range_srcref ->
    21:   int ->
    22:   btypecode_t list ->
    23:   btypecode_t list
    24: 
    25: val make_params:
    26:   sym_state_t ->
    27:   range_srcref ->
    28:   int ->
    29:   btypecode_t list ->
    30:   (string * btypecode_t) list
    31: 
    32: val make_varmap:
    33:   sym_state_t ->
    34:   range_srcref ->
    35:   int ->
    36:   btypecode_t list ->
    37:   (int, btypecode_t) Hashtbl.t
    38: 
End ocaml section to src/flx_generic.mli[1]
Start ocaml section to src/flx_generic.ml[1 /1 ]
     1: # 43 "./lpsrc/flx_generic.ipk"
     2: open Flx_types
     3: open Flx_mtypes1
     4: open Flx_mtypes2
     5: open Flx_util
     6: open List
     7: open Flx_exceptions
     8: open Flx_print
     9: open Flx_ast
    10: 
    11: (* Adjustment of type argument lists works much
    12: like the activation record display, so well call
    13: it the type display: it is just a list of all
    14: the type variables bound by upscope quantifiers
    15: (which should be all of them :-)
    16: 
    17: For a name without any subscripts, a sibling call,
    18: or upscope call is possible, and just takes the head of the
    19: type display corresponding to the call depth.
    20: 
    21: For a downscope call (eg referencing an element of
    22: a contained module ..) additional type must be given.
    23: 
    24: However, sibling and upscope calls can also be made
    25: with subscripts, replacing the trailing default
    26: values of the current display.
    27: 
    28: So: the given subscripts can vary from 0 to the number
    29: of variables at the call level, with the remaining head
    30: variables defaulted from the calling environment, unless
    31: the call depth is deeper in which case the trailing
    32: values must be given
    33: 
    34: Actually the algorithm is simpler: just get
    35: the default display for the target, and splice
    36: its head with the given subscript list to get a
    37: list the same length, if the target is longer
    38: than the list, otherwise just take the head of the
    39: subscript list -- this can happen when an instantiated
    40: call calls upscope using an unindexed name.
    41: *)
    42: 
    43: let dfltvs_aux = { raw_type_constraint=`TYP_tuple []; raw_typeclass_reqs=[]}
    44: let dfltvs = [],dfltvs_aux
    45: 
    46: 
    47: let merge_con
    48:   {raw_type_constraint=con1; raw_typeclass_reqs=rtcr1}
    49:   {raw_type_constraint=con2; raw_typeclass_reqs=rtcr2}
    50: : vs_aux_t =
    51:   let t =
    52:     match con1,con2 with
    53:     | `TYP_tuple[],`TYP_tuple[] -> `TYP_tuple[]
    54:     | `TYP_tuple[],b -> b
    55:     | a,`TYP_tuple[] -> a
    56:     | `TYP_intersect a, `TYP_intersect b -> `TYP_intersect (a@b)
    57:     | `TYP_intersect a, b -> `TYP_intersect (a @[b])
    58:     | a,`TYP_intersect b -> `TYP_intersect (a::b)
    59:     | a,b -> `TYP_intersect [a;b]
    60:   and
    61:     rtcr = uniq_list (rtcr1 @ rtcr2)
    62:   in
    63:   { raw_type_constraint=t; raw_typeclass_reqs=rtcr}
    64: 
    65: let merge_ivs (vs1,con1) (vs2,con2) :ivs_list_t =
    66:   vs1 @ vs2, merge_con con1 con2
    67: 
    68: (* finds the complete vs list *)
    69: let rec find_vs syms i : ivs_list_t =
    70:   match Hashtbl.find syms.dfns i with
    71:   {parent=parent;vs=vs} ->
    72:   match parent with
    73:   | Some i -> merge_ivs (find_vs syms i) vs
    74:   | None -> vs
    75: 
    76: let rec find_func_vs syms vs j =
    77:   match Hashtbl.find syms.dfns j with
    78:   | {parent=parent; vs=vs'; symdef=`SYMDEF_module }
    79:   | {parent=parent; vs=vs'; symdef=`SYMDEF_typeclass }
    80:     ->
    81:     begin match parent with
    82:     | None ->
    83:       let vs = merge_ivs vs' vs in
    84:       [],fst vs, snd vs
    85:     | Some j -> find_func_vs syms (merge_ivs vs' vs) j
    86:     end
    87: 
    88:   | _ ->
    89:     let (vs',con) = find_vs syms j in
    90:     vs',fst vs,merge_con con (snd vs)
    91: 
    92: (* finds the triple pvs,vs,con where vs is the entity
    93:    vs INCLUDING module vs. pvs is the vs of
    94:    the ultimately containing function and its ancestors.
    95: *)
    96: 
    97: let find_split_vs syms i =
    98:   match Hashtbl.find syms.dfns i with
    99:   {symdef=`SYMDEF_typevar _} -> [],[],dfltvs_aux
   100: 
   101:   | {parent=parent; vs=vs} ->
   102:   match parent with
   103:   | None -> [],fst vs, snd vs
   104:   | Some j -> find_func_vs syms vs j
   105: 
   106: let print_ivs vs =
   107:   catmap ", " (fun (s,i,_) -> s ^ "<" ^ si i ^ ">") vs
   108: 
   109: let adjust_ts syms sr index ts =
   110:   let pvs,vs,con = find_split_vs syms index in
   111:   let k = length pvs in
   112:   let m = length vs in
   113:   let n = length ts in
   114:   if n>m then begin
   115:     match Hashtbl.find syms.dfns index with {id=id} ->
   116:     clierr sr
   117:     (
   118:       "For "^ id^ "<" ^ si index ^
   119:       "> Too many type subscripts, expected " ^
   120:       si m ^ " got " ^ si n ^
   121:       "=["^catmap "," (sbt syms.dfns) ts ^ "]"^
   122:       "\nparent vs="^print_ivs pvs ^
   123:       "\nvs="^print_ivs vs
   124:     )
   125:   end;
   126:   if n<m then begin
   127:     match Hashtbl.find syms.dfns index with {id=id} ->
   128:     clierr sr
   129:     (
   130:       "For "^id^"<" ^ si index ^
   131:       "> Not enough type subscripts, expected " ^
   132:       si m ^ " got " ^ si n ^
   133:       "\nparent vs="^print_ivs pvs ^
   134:       "\nvs=" ^ print_ivs vs
   135:     )
   136:   end;
   137: 
   138:   map (fun (_,i,_) -> `BTYP_var (i,`BTYP_type 0)) pvs @ ts
   139: 
   140: 
   141: let make_params syms sr i ts =
   142:   let vs,_ = find_vs syms i in
   143:   let ts = adjust_ts syms sr i ts in
   144:   assert (length vs = length ts);
   145:   map2 (fun (s,i,_) t -> s,t) vs ts
   146: 
   147: (* full ts required *)
   148: let make_varmap syms sr i ts =
   149:   let vs,_ = find_vs syms i in
   150:   if length ts != length vs then
   151:     print_endline ("[flx_generic:make_varmap] vs/ts mismatch vs=" ^
   152:     catmap "," (fun (s,_,_) -> s) vs ^
   153:     "; ts = " ^ catmap "," (sbt syms.dfns) ts)
   154:   ;
   155:   assert (length ts = length vs);
   156:   let vars = map2 (fun (s,i,_) t -> i,t) vs ts in
   157:   hashtable_of_list vars
   158: 
End ocaml section to src/flx_generic.ml[1]