1: # 43 "./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: open Flx_ast
10:
11: (* Adjustment of type argument lists works much
12: like the activation record display, so well call
13: it the type display: it is just a list of all
14: the type variables bound by upscope quantifiers
15: (which should be all of them :-)
16:
17: For a name without any subscripts, a sibling call,
18: or upscope call is possible, and just takes the head of the
19: type display corresponding to the call depth.
20:
21: For a downscope call (eg referencing an element of
22: a contained module ..) additional type must be given.
23:
24: However, sibling and upscope calls can also be made
25: with subscripts, replacing the trailing default
26: values of the current display.
27:
28: So: the given subscripts can vary from 0 to the number
29: of variables at the call level, with the remaining head
30: variables defaulted from the calling environment, unless
31: the call depth is deeper in which case the trailing
32: values must be given
33:
34: Actually the algorithm is simpler: just get
35: the default display for the target, and splice
36: its head with the given subscript list to get a
37: list the same length, if the target is longer
38: than the list, otherwise just take the head of the
39: subscript list -- this can happen when an instantiated
40: call calls upscope using an unindexed name.
41: *)
42:
43: let dfltvs_aux = { raw_type_constraint=`TYP_tuple []; raw_typeclass_reqs=[]}
44: let dfltvs = [],dfltvs_aux
45:
46:
47: let merge_con
48: {raw_type_constraint=con1; raw_typeclass_reqs=rtcr1}
49: {raw_type_constraint=con2; raw_typeclass_reqs=rtcr2}
50: : vs_aux_t =
51: let t =
52: match con1,con2 with
53: | `TYP_tuple[],`TYP_tuple[] -> `TYP_tuple[]
54: | `TYP_tuple[],b -> b
55: | a,`TYP_tuple[] -> a
56: | `TYP_intersect a, `TYP_intersect b -> `TYP_intersect (a@b)
57: | `TYP_intersect a, b -> `TYP_intersect (a @[b])
58: | a,`TYP_intersect b -> `TYP_intersect (a::b)
59: | a,b -> `TYP_intersect [a;b]
60: and
61: rtcr = uniq_list (rtcr1 @ rtcr2)
62: in
63: { raw_type_constraint=t; raw_typeclass_reqs=rtcr}
64:
65: let merge_ivs (vs1,con1) (vs2,con2) :ivs_list_t =
66: vs1 @ vs2, merge_con con1 con2
67:
68: (* finds the complete vs list *)
69: let rec find_vs syms i : ivs_list_t =
70: match Hashtbl.find syms.dfns i with
71: {parent=parent;vs=vs} ->
72: match parent with
73: | Some i -> merge_ivs (find_vs syms i) vs
74: | None -> vs
75:
76: let rec find_func_vs syms vs j =
77: match Hashtbl.find syms.dfns j with
78: | {parent=parent; vs=vs'; symdef=`SYMDEF_module }
79: | {parent=parent; vs=vs'; symdef=`SYMDEF_typeclass }
80: ->
81: begin match parent with
82: | None ->
83: let vs = merge_ivs vs' vs in
84: [],fst vs, snd vs
85: | Some j -> find_func_vs syms (merge_ivs vs' vs) j
86: end
87:
88: | _ ->
89: let (vs',con) = find_vs syms j in
90: vs',fst vs,merge_con con (snd vs)
91:
92: (* finds the triple pvs,vs,con where vs is the entity
93: vs INCLUDING module vs. pvs is the vs of
94: the ultimately containing function and its ancestors.
95: *)
96:
97: let find_split_vs syms i =
98: match Hashtbl.find syms.dfns i with
99: {symdef=`SYMDEF_typevar _} -> [],[],dfltvs_aux
100:
101: | {parent=parent; vs=vs} ->
102: match parent with
103: | None -> [],fst vs, snd vs
104: | Some j -> find_func_vs syms vs j
105:
106: let print_ivs vs =
107: catmap ", " (fun (s,i,_) -> s ^ "<" ^ si i ^ ">") vs
108:
109: let adjust_ts syms sr index ts =
110: let pvs,vs,con = find_split_vs syms index in
111: let k = length pvs in
112: let m = length vs in
113: let n = length ts in
114: if n>m then begin
115: match Hashtbl.find syms.dfns index with {id=id} ->
116: clierr sr
117: (
118: "For "^ id^ "<" ^ si index ^
119: "> Too many type subscripts, expected " ^
120: si m ^ " got " ^ si n ^
121: "=["^catmap "," (sbt syms.dfns) ts ^ "]"^
122: "\nparent vs="^print_ivs pvs ^
123: "\nvs="^print_ivs vs
124: )
125: end;
126: if n<m then begin
127: match Hashtbl.find syms.dfns index with {id=id} ->
128: clierr sr
129: (
130: "For "^id^"<" ^ si index ^
131: "> Not enough type subscripts, expected " ^
132: si m ^ " got " ^ si n ^
133: "\nparent vs="^print_ivs pvs ^
134: "\nvs=" ^ print_ivs vs
135: )
136: end;
137:
138: map (fun (_,i,_) -> `BTYP_var (i,`BTYP_type 0)) pvs @ ts
139:
140:
141: let make_params syms sr i ts =
142: let vs,_ = find_vs syms i in
143: let ts = adjust_ts syms sr i ts in
144: assert (length vs = length ts);
145: map2 (fun (s,i,_) t -> s,t) vs ts
146:
147: (* full ts required *)
148: let make_varmap syms sr i ts =
149: let vs,_ = find_vs syms i in
150: if length ts != length vs then
151: print_endline ("[flx_generic:make_varmap] vs/ts mismatch vs=" ^
152: catmap "," (fun (s,_,_) -> s) vs ^
153: "; ts = " ^ catmap "," (sbt syms.dfns) ts)
154: ;
155: assert (length ts = length vs);
156: let vars = map2 (fun (s,i,_) t -> i,t) vs ts in
157: hashtable_of_list vars
158: