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.
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:
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:
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:
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: