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