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