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