5.35. 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:   ivs_list_t * ivs_list_t
    10: 
    11: val find_vs:
    12:   sym_state_t ->
    13:   int ->
    14:   ivs_list_t
    15: 
    16: val adjust_ts:
    17:   sym_state_t ->
    18:   range_srcref ->
    19:   int ->
    20:   btypecode_t list ->
    21:   btypecode_t list
    22: 
    23: val make_params:
    24:   sym_state_t ->
    25:   range_srcref ->
    26:   int ->
    27:   btypecode_t list ->
    28:   (string * btypecode_t) list
    29: 
    30: val make_varmap:
    31:   sym_state_t ->
    32:   range_srcref ->
    33:   int ->
    34:   btypecode_t list ->
    35:   (int, btypecode_t) Hashtbl.t
    36: 
End ocaml section to src/flx_generic.mli[1]
Start ocaml section to src/flx_generic.ml[1 /1 ]
     1: # 41 "./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: 
    10: (* Adjustment of type argument lists works much
    11: like the activation record display, so well call
    12: it the type display: it is just a list of all
    13: the type variables bound by upscope quantifiers
    14: (which should be all of them :-)
    15: 
    16: For a name without any subscripts, a sibling call,
    17: or upscope call is possible, and just takes the head of the
    18: type display corresponding to the call depth.
    19: 
    20: For a downscope call (eg referencing an element of
    21: a contained module ..) additional type must be given.
    22: 
    23: However, sibling and upscope calls can also be made
    24: with subscripts, replacing the trailing default
    25: values of the current display.
    26: 
    27: So: the given subscripts can vary from 0 to the number
    28: of variables at the call level, with the remaining head
    29: variables defaulted from the calling environment, unless
    30: the call depth is deeper in which case the trailing
    31: values must be given
    32: 
    33: Actually the algorithm is simpler: just get
    34: the default display for the target, and splice
    35: its head with the given subscript list to get a
    36: list the same length, if the target is longer
    37: than the list, otherwise just take the head of the
    38: subscript list -- this can happen when an instantiated
    39: call calls upscope using an unindexed name.
    40: *)
    41: 
    42: let rec find_vs syms i =
    43:   match Hashtbl.find syms.dfns i with
    44:   {parent=parent;vs=vs} ->
    45:   match parent with
    46:   | Some i -> find_vs syms i @ vs
    47:   | None -> vs
    48: 
    49: let rec find_func_vs syms vs j =
    50:   match Hashtbl.find syms.dfns j with
    51:   | {parent=parent; vs=vs'; symdef=`SYMDEF_module } ->
    52:     begin match parent with
    53:     | None -> [],vs' @ vs
    54:     | Some j -> find_func_vs syms (vs' @ vs) j
    55:     end
    56: 
    57:   | _ ->
    58:     find_vs syms j,vs
    59: 
    60:   (*
    61:   | {parent=parent; id=name; vs=vs'; symdef = symdef}->
    62:     begin match parent with
    63:     | None -> [],vs' @ vs
    64:     | Some j -> find_func_vs syms (vs' @ vs) j
    65:     end
    66:   *)
    67:     (*
    68:     failwith
    69:     (
    70:       "find_func_vs: parent must be module or function, got:" ^
    71:       Flx_print.string_of_symdef symdef name vs'
    72:     )
    73:     *)
    74: 
    75: let find_split_vs syms i =
    76:   match Hashtbl.find syms.dfns i with
    77:   {symdef=`SYMDEF_typevar _} -> [],[]
    78: 
    79:   | {parent=parent; vs=vs} ->
    80:   match parent with
    81:   | None -> [],vs
    82:   | Some j -> find_func_vs syms vs j
    83: 
    84: let print_ivs vs = catmap ", " (fun (s,i,_) -> s ^ "<" ^ si i ^ ">") vs
    85: 
    86: let adjust_ts syms sr index ts =
    87:   let pvs,vs = find_split_vs syms index in
    88:   let k = length pvs in
    89:   let m = length vs in
    90:   let n = length ts in
    91:   if n>m then begin
    92:     match Hashtbl.find syms.dfns index with {id=id} ->
    93:     clierr sr
    94:     (
    95:       "For "^ id^ "<" ^ si index ^
    96:       "> Too many type subscripts, expected " ^
    97:       si m ^ " got " ^ si n ^
    98:       "=["^catmap "," (sbt syms.dfns) ts ^ "]"^
    99:       "\nparent vs="^print_ivs pvs ^
   100:       "\nvs="^print_ivs vs
   101:     )
   102:   end;
   103:   if n<m then begin
   104:     match Hashtbl.find syms.dfns index with {id=id} ->
   105:     clierr sr
   106:     (
   107:       "For "^id^"<" ^ si index ^
   108:       "> Not enough type subscripts, expected " ^
   109:       si m ^ " got " ^ si n ^
   110:       "\nparent vs="^print_ivs pvs ^
   111:       "\nvs=" ^ print_ivs vs
   112:     )
   113:   end;
   114: 
   115:   map (fun (_,i,_) -> `BTYP_var (i,`BTYP_type)) pvs @ ts
   116: 
   117: 
   118: let make_params syms sr i ts =
   119:   let vs = find_vs syms i in
   120:   let ts = adjust_ts syms sr i ts in
   121:   assert (length vs = length ts);
   122:   map2 (fun (s,i,_) t -> s,t) vs ts
   123: 
   124: (* full ts required *)
   125: let make_varmap syms sr i ts =
   126:   let vs = find_vs syms i in
   127:   assert (length ts = length vs);
   128:   let vars = map2 (fun (s,i,_) t -> i,t) vs ts in
   129:   hashtable_of_list vars
   130: 
End ocaml section to src/flx_generic.ml[1]