5.34. The type registry

Flx supports algebraic type expressions. For some of these, we need to construct a C++ class type. To ensure the same name is provided for each such class, we use a registry which maps the (bound) type expression to an integer.

The routine register_type_rn is a non-recursive registration procedure.

The routine register_type_r registers types recursively. The 'exclude' argument is a list of types which should not be registered, this is used to break potential infinite recursions. Note carefully that components are always registered before the type, so that they'll be defined before they're used. There two exceptions: for a pointer an incomplete type is sufficient, and sometimes necessary to break type recursion; and, unions may be recursive, but are represented by pointers anyhow.

Note that a function may accept an argument tuple one of whose arguments is a pointer to a function of the same type.

Note that the types of implicitly declared tuples will be caught here, since the only thing you can do with a tuple is make it the argument of a function.

Start ocaml section to src/flx_treg.mli[1 /1 ]
     1: # 31 "./lpsrc/flx_treg.ipk"
     2: open Flx_types
     3: open Flx_ast
     4: open Flx_mtypes2
     5: 
     6: val register_type_nr:
     7:   sym_state_t ->
     8:   btypecode_t ->
     9:   unit
    10: 
    11: val register_tuple:
    12:   sym_state_t ->
    13:   btypecode_t ->
    14:   unit
    15: 
    16: val register_type_r:
    17:   (int -> btypecode_t list -> unit) ->
    18:   sym_state_t ->
    19:   fully_bound_symbol_table_t ->
    20:   btypecode_t list ->
    21:   range_srcref ->
    22:   btypecode_t ->
    23:   unit
    24: 
End ocaml section to src/flx_treg.mli[1]
Start ocaml section to src/flx_treg.ml[1 /1 ]
     1: # 56 "./lpsrc/flx_treg.ipk"
     2: open Flx_types
     3: open Flx_mtypes2
     4: open Flx_typing
     5: open Flx_unify
     6: open Flx_print
     7: open Flx_exceptions
     8: open Flx_util
     9: open Flx_srcref
    10: open Flx_name
    11: open List
    12: open Flx_maps
    13: 
    14: let register_type_nr syms t =
    15:   (*
    16:   let t' = Flx_maps.reduce_type t in
    17:   if t <> t' then print_endline ("UNREDUCED TYPE! " ^ sbt syms.dfns t ^ " <> " ^ sbt syms.dfns t');
    18:   *)
    19:   match t with
    20:   | `BTYP_fix _
    21:   | `BTYP_tuple []
    22:     -> ()
    23:   | _
    24:     ->
    25:     let t = lstrip syms.dfns (fold syms.dfns t) in
    26:     if not (Hashtbl.mem syms.registry t)
    27:     then begin
    28:       let () = check_recursion t in
    29:       let n = !(syms.counter) in
    30:       incr syms.counter;
    31:       if syms.compiler_options.print_flag then
    32:       print_endline ("//Register type " ^ si n ^ ": " ^ string_of_btypecode syms.dfns t);
    33:       Hashtbl.add syms.registry t n
    34:     end
    35: 
    36: let register_tuple syms t =
    37:   let t = lstrip syms.dfns (fold syms.dfns t) in
    38:   match t with
    39:   | `BTYP_tuple [] -> ()
    40:   | `BTYP_tuple [_] -> assert false
    41: 
    42:   | `BTYP_tuple ts ->
    43:     let t = `BTYP_tuple (map reduce_type ts) in
    44:     register_type_nr syms t
    45: 
    46:   | `BTYP_array (t',`BTYP_unitsum n) ->
    47:     let t' = reduce_type t' in
    48:     let ts = rev_map (fun _ -> t') (nlist n) in
    49:     register_type_nr syms (`BTYP_tuple ts)
    50: 
    51:   | `BTYP_record ts ->
    52:     let t = reduce_type t in
    53:     begin match t with
    54:     | `BTYP_tuple [] -> ()
    55:     | _ -> register_type_nr syms t
    56:     end
    57: 
    58:   | `BTYP_variant ts ->
    59:     let t = reduce_type t in
    60:     begin match t with
    61:     | `BTYP_void -> ()
    62:     | _ -> register_type_nr syms t
    63:     end
    64: 
    65:   | _ -> assert false
    66: 
    67: let rec register_type_r ui syms bbdfns exclude sr t =
    68:   let t = reduce_type (lower (lstrip syms.dfns t)) in
    69:   (*
    70:   let sp = String.make (length exclude * 2) ' ' in
    71:   print_endline (sp ^ "Register type " ^ string_of_btypecode syms.dfns t);
    72:   if (mem t exclude) then print_endline (sp ^ "Excluded ..");
    73:   *)
    74:   if not (Hashtbl.mem syms.registry t) then
    75:   if not (mem t exclude) then
    76:   let rr t' = register_type_r ui syms bbdfns (t :: exclude) sr t' in
    77:   let rnr t = register_type_nr syms t in
    78:   let t' = unfold syms.dfns t in
    79:   (*
    80:   print_endline (sp ^ "Unfolded type " ^ string_of_btypecode syms.dfns t');
    81:   *)
    82:   match t' with
    83:   | `BTYP_void -> ()
    84:   | `BTYP_fix i -> clierr sr ("[register_type_r] Fixpoint "^si i^" encountered")
    85:   | `BTYP_var (i,mt) -> clierr sr ("Attempt to register type variable " ^ si i ^":"^sbt syms.dfns mt)
    86:   | `BTYP_function (ps,ret) -> rr ps; rr ret; rnr t
    87:   | `BTYP_cfunction (ps,ret) -> rr ps; rr ret; rnr t
    88:   | `BTYP_array (ps,ret) ->
    89:     rr ps; rr ret; rnr t
    90:     (*
    91:     ;
    92:     begin match ret with
    93:     | `BTYP_unitsum k ->
    94:       let tt = `BTYP_tuple (map (fun _ -> ps) (nlist k)) in
    95:       rnr tt
    96: 
    97:     | _ -> clierr sr "Array of non-integer not supported"
    98:     end
    99:     *)
   100: 
   101:   | `BTYP_tuple ps -> iter rr ps; rnr t
   102: 
   103:   | `BTYP_record ps -> iter (fun (s,t)->rr t) ps; rnr t
   104:   | `BTYP_variant ps -> iter (fun (s,t)->rr t) ps; rnr t
   105: 
   106:   | `BTYP_sum ps ->
   107:     (* iter rr ps; *) (* should be driven by constructors *)
   108:     rnr t
   109: 
   110:   | `BTYP_unitsum k -> rnr t
   111: 
   112:   (* NOTE: pointer type is registered before the type it points
   113:     to because it can be incomplete, whereas the type it
   114:     points to may need a complete pointer type: this
   115:     is always the case for recursion under a pointer
   116:   *)
   117: 
   118:   | `BTYP_pointer ts -> rnr t; rr ts
   119:   | `BTYP_inst (i,ts)->
   120:     iter rr ts;
   121: 
   122:     let id, parent, sr,entry =
   123:       try Hashtbl.find bbdfns i
   124:       with Not_found ->
   125:         try match Hashtbl.find syms.dfns i with
   126:         { id=id; sr=sr; parent=parent; symdef=entry } ->
   127:         clierr sr
   128:         (
   129:           "register_type_r Can't find " ^
   130:           id ^ "[" ^ si i ^ "]" ^
   131:           " in fully bound symbol table: " ^
   132:           short_string_of_src sr
   133:         )
   134:         with Not_found -> failwith ("[register_type_r] Can't find index " ^ si i)
   135:     in
   136:     begin match entry with
   137:     | `BBDCL_union (vs,cs) ->
   138:       (*
   139:       let cts = map snd cs in
   140:       let cts = map (tsubst vs ts) cts in
   141:       iter rr cts;
   142:       *)
   143:       rnr t
   144: 
   145:     | `BBDCL_class vs -> rnr t
   146: 
   147:     | `BBDCL_cclass (vs,cs) ->
   148:        let cts = map (function
   149:          | `BMemberVal (_,t)
   150:          | `BMemberVar (_,t)
   151:          | `BMemberCtor (_,t) -> t,[]
   152:          | `BMemberFun (_,mvs,t)
   153:          | `BMemberProc (_,mvs,t) -> t,mvs
   154:          ) cs
   155:        in
   156:       (* I THINK THIS IS WRONG NOW .. only register
   157:          the interface if it is used .. we need
   158:          the method instance type variables too!
   159:       *)
   160:       (*
   161:       let cts = map (fun (t,ts') -> tsubst vs ts t) cts in
   162:       iter rr cts;
   163:       *)
   164:       rnr t
   165:       (* NO CONSTRUCTOR! *)
   166: 
   167:     | `BBDCL_cstruct (vs,cs)
   168:     | `BBDCL_struct (vs,cs) ->
   169:       let cts = map snd cs in
   170:       let cts = map (tsubst vs ts) cts in
   171:       iter rr cts;
   172: 
   173:       (* HACKERY HERE... We should NOT need to register
   174:         constructors, etc, unless they're actually used
   175:       *)
   176:       (*
   177:       if length cts > 1 then rnr (`BTYP_tuple cts);
   178:       *)
   179: 
   180:       (*
   181:       let argt = typeoflist cts in
   182:       rnr argt;                             (* argument tuple *)
   183:       *)
   184:       rnr t;
   185:       (*
   186:       rnr (`BTYP_function (argt,t))         (* constructor as function *)
   187:       *)
   188: 
   189:     | `BBDCL_abs _ -> ui i ts; rnr t  (* instantiate the type too *)
   190: 
   191:     | _ ->
   192:       clierr sr
   193:       (
   194:         "[register_type_r] expected type declaration, got " ^
   195:         string_of_bbdcl syms.dfns entry i
   196:       )
   197:     end
   198: 
   199:   | _ ->
   200:     clierr sr
   201:     (
   202:       "Unexpected kind in register type: " ^
   203:       string_of_btypecode syms.dfns t
   204:     )
   205: 
End ocaml section to src/flx_treg.ml[1]
Start ocaml section to src/flx_tconstraint.mli[1 /1 ]
     1: # 3 "./lpsrc/flx_tconstraint.ipk"
     2: open Flx_ast
     3: open Flx_types
     4: open Flx_mtypes2
     5: 
     6: val build_type_constraints:
     7:   sym_state_t ->
     8:   (typecode_t -> btypecode_t) -> (* bind type *)
     9:   range_srcref ->
    10:   (string * int * tpattern_t) list -> (* local vs list *)
    11:   btypecode_t
    12: 
End ocaml section to src/flx_tconstraint.mli[1]
Start ocaml section to src/flx_tconstraint.ml[1 /1 ]
     1: # 16 "./lpsrc/flx_tconstraint.ipk"
     2: open Flx_ast
     3: open Flx_types
     4: open Flx_mtypes1
     5: open Flx_mtypes2
     6: open Flx_tpat
     7: open Flx_exceptions
     8: open List
     9: open Flx_print
    10: open Flx_util
    11: 
    12: (* A type constraint written in a vs list is a simplification.
    13:    The form
    14: 
    15:    v:p
    16: 
    17:    is short for
    18: 
    19:    typematch v with | p -> 1 | _ -> 0 endmatch
    20: 
    21: *)
    22: 
    23: let build_constraint_element syms bt sr i p1 =
    24:   (* special case, no constraint, represent by just 'true' (unit type) *)
    25:   if p1 = `TPAT_any then `BTYP_tuple [] else
    26: 
    27:   (* more general cases *)
    28:   let p1,explicit_vars1,any_vars1, as_vars1, eqns1 = type_of_tpattern syms p1 in
    29: 
    30:   (* check the pattern doesn't introduce any named variables *)
    31:   (* later we may allow them as additional 'vs' variables .. but
    32:     it is tricky because they'd have to be introduced 'in scope':
    33:   *)
    34:   (*
    35:   if eqns1 <> [] then clierr sr
    36:     "Type variable constraint may not have 'as' terms"
    37:   ;
    38:   if explicit_vars1 <> [] then clierr sr
    39:     "Type variable constraint may not have named pattern variables"
    40:   ;
    41:   *)
    42:   let varset1 =
    43:     fold_left (fun s i -> IntSet.add i s)
    44:     IntSet.empty any_vars1
    45:   in
    46:     let varset1 =
    47:     fold_left (fun s (i,_) -> IntSet.add i s)
    48:     varset1 as_vars1
    49:   in
    50:   let varset1 =
    51:     fold_left (fun s (i,_) -> IntSet.add i s)
    52:     varset1 explicit_vars1
    53:   in
    54:   let un = `BTYP_tuple [] in (* the 'true' value of the type system *)
    55:   let elt = `BTYP_var (i,`BTYP_type) in
    56:   let p1 = bt p1 in
    57:   let tm =
    58:   match p1 with
    59:   | `BTYP_typeset ls ->
    60:     let e = IntSet.empty in
    61:     let un = `BTYP_tuple [] in
    62:     let lss = rev_map (fun t -> {pattern=t; pattern_vars=e; assignments=[]},un) ls in
    63:     let fresh = !(syms.counter) in incr (syms.counter);
    64:     let dflt =
    65:       {
    66:         pattern=`BTYP_var (fresh,`BTYP_type);
    67:         pattern_vars = IntSet.singleton fresh;
    68:         assignments=[]
    69:       },
    70:       `BTYP_void
    71:     in
    72:     let lss = rev (dflt :: lss) in
    73:     `BTYP_type_match (elt, lss)
    74: 
    75:   | _ ->
    76:     let t1 = `BTYP_tuple [] in
    77:     let newvar = !(syms.counter) in incr (syms.counter);
    78:     let p2 = `BTYP_var (newvar,`BTYP_type) in
    79:     let t2 = `BTYP_void in
    80:     let varset2 = IntSet.singleton newvar in
    81:     (*
    82:     print_endline ("Bound matching is " ^ sbt syms.dfns p1 ^ " => " ^ sbt syms.dfns t1);
    83:     *)
    84:     let pt1 = ({pattern=p1; pattern_vars=varset1; assignments=[]},t1) in
    85:     let pt2 = ({pattern=p2; pattern_vars=varset2; assignments=[]},t2) in
    86:     let pts = [pt1; pt2] in
    87:     `BTYP_type_match (`BTYP_var (i,`BTYP_type), pts)
    88:   in
    89:     (* print_endline ("Bound typematch is " ^ sbt syms.dfns tm); *)
    90:     tm
    91: 
    92: let build_type_constraints syms bt sr vs =
    93:   let type_constraints =
    94:     map (fun (s,i,tp) ->
    95:       let tp = build_constraint_element syms bt sr i tp in
    96:       (*
    97:       if tp <> `BTYP_tuple [] then
    98:         print_endline (
    99:         " vs entry " ^ s ^ ", var " ^ si i ^
   100:         " constraint " ^ sbt syms.dfns tp)
   101:       ;
   102:       *)
   103:       tp
   104:     )
   105:     vs
   106:   in
   107:     `BTYP_intersect type_constraints
   108: 
   109: 
End ocaml section to src/flx_tconstraint.ml[1]