1: # 4884 "./lpsrc/flx_types.ipk"
2: open Flx_ast
3: open Flx_types
4: open Flx_srcref
5: open List
6: open Flx_maps
7:
8: let all_voids ls =
9: fold_left
10: (fun acc t -> acc && (t = `BTYP_void))
11: true ls
12:
13: let all_units0 ls =
14: fold_left
15: (fun acc t -> acc && (t = `BTYP_tuple []))
16: true ls
17:
18: let all_units ls = all_units0 ls
19:
20: let is_unitsum (t:btypecode_t) = match t with
21: | `BTYP_unitsum _ -> true
22: | `BTYP_sum ls -> all_units ls
23: | _ -> false
24:
25:
26: let int_of_unitsum t = match t with
27: | `BTYP_tuple [] -> 1
28: | `BTYP_unitsum k -> k
29: | `BTYP_sum ls ->
30: if all_units ls then length ls
31: else raise Not_found
32:
33: | _ -> raise Not_found
34:
35: exception UnificationError of btypecode_t * btypecode_t
36:
37: (* unbound type *)
38: let type_of_argtypes ls = match ls with
39: | [x] -> x
40: | _ -> `TYP_tuple ls
41:
42: let funparamtype x = snd x
43:
44: module FuntypeSet = Set.Make(
45: struct type t=typecode_t let compare = compare end
46: )
47:
48: module FunInstSet = Set.Make(
49: struct
50: type t= bid_t * btypecode_t list
51: let compare = compare
52: end
53: )
54:
55: (* bound type! *)
56: let typeoflist typlist = match typlist with
57: | [] -> `BTYP_tuple []
58: | [t] -> t
59: | h :: t ->
60: try
61: iter
62: (fun t -> if t <> h then raise Not_found)
63: t;
64: `BTYP_array (h,`BTYP_unitsum (length typlist))
65: with Not_found ->
66: `BTYP_tuple typlist
67:
68: let lift t = t
69: let lower t = t (* CHANGE THIS WHEN ABSTRACT TYPES IMPLEMENTED *)
70:
71: let flx_bool = `TYP_unitsum 2
72: let flx_bbool = `BTYP_unitsum 2
73:
74: let qualified_name_of_expr e =
75: match e with
76: | #qualified_name_t as x -> x
77: | _ ->
78: failwith
79: (
80: "Qualified name expected in\n" ^
81: short_string_of_src (src_of_expr e)
82: )
83:
84: (* Note floats are equal iff they're textually identical,
85: we don't make any assumptions about the target machine FP model.
86: OTOH, int comparisons are infinite precision, for the same
87: int kind, even if the underlying machine model is not
88: *)
89:
90: let cmp_literal (l:literal_t) (l':literal_t) = match l, l' with
91: | `AST_int (a,b), `AST_int (a',b') -> a = a' && Big_int.eq_big_int b b'
92: | `AST_float (a,b), `AST_float (a',b') -> a = a' && b = b'
93: | `AST_string s, `AST_string s' -> s = s'
94: | `AST_cstring s, `AST_cstring s' -> s = s'
95: | `AST_wstring s, `AST_wstring s' -> s = s'
96: | `AST_ustring s, `AST_ustring s' -> s = s'
97: | _ -> false
98:
99: (* Note that we don't bother comparing the type subterm:
100: this had better be equal for equal expressions: the value
101: is merely the cached result of a synthetic context
102: independent type calculation
103: *)
104:
105: let rec cmp_tbexpr (a,_) (b,_) =
106: let ecmp = cmp_tbexpr in match a,b with
107: | `BEXPR_parse (e,ii), `BEXPR_parse (e',ii') ->
108: ecmp e e' && ii = ii'
109:
110: | `BEXPR_coerce (e,t),`BEXPR_coerce (e',t') ->
111: (* not really right .. *)
112: ecmp e e'
113:
114: | `BEXPR_record ts,`BEXPR_record ts' ->
115: length ts = length ts' &&
116: let rcmp (s,t) (s',t') = compare s s' in
117: let ts = sort rcmp ts in
118: let ts' = sort rcmp ts' in
119: map fst ts = map fst ts' &&
120: fold_left2 (fun r a b -> r && a = b) true (map snd ts) (map snd ts')
121:
122: | `BEXPR_variant (s,e),`BEXPR_variant (s',e') ->
123: s = s' && ecmp e e'
124:
125: | `BEXPR_deref e,`BEXPR_deref e' -> ecmp e e'
126:
127: | `BEXPR_name (i,ts),`BEXPR_name (i',ts')
128: | `BEXPR_ref (i,ts),`BEXPR_ref (i',ts')
129: | `BEXPR_closure (i,ts),`BEXPR_closure (i',ts') ->
130: i = i' &&
131: fold_left2 (fun r a b -> r && a = b) true ts ts'
132:
133: | `BEXPR_method_closure (e,i,ts),`BEXPR_method_closure (e',i',ts') ->
134: ecmp e e' &&
135: i = i' &&
136: fold_left2 (fun r a b -> r && a = b) true ts ts'
137:
138: | `BEXPR_literal a,`BEXPR_literal a' -> cmp_literal a a'
139:
140: | `BEXPR_apply (a,b),`BEXPR_apply (a',b') -> ecmp a a' && ecmp b b'
141:
142: | `BEXPR_apply_prim (i,ts,b),`BEXPR_apply_prim (i',ts',b')
143: | `BEXPR_apply_direct (i,ts,b),`BEXPR_apply_direct (i',ts',b')
144: | `BEXPR_apply_struct (i,ts,b),`BEXPR_apply_struct (i',ts',b')
145: | `BEXPR_apply_stack (i,ts,b),`BEXPR_apply_stack (i',ts',b') ->
146: i = i' &&
147: fold_left2 (fun r a b -> r && a = b) true ts ts' &&
148: ecmp b b'
149:
150: | `BEXPR_apply_method_direct (e,i,ts,b),`BEXPR_apply_method_direct (e',i',ts',b') ->
151: ecmp e e' &&
152: i = i' &&
153: fold_left2 (fun r a b -> r && a = b) true ts ts' &&
154: ecmp b b'
155:
156: | `BEXPR_apply_method_stack (e,i,ts,b),`BEXPR_apply_method_stack (e',i',ts',b') ->
157: ecmp e e' &&
158: i = i' &&
159: fold_left2 (fun r a b -> r && a = b) true ts ts' &&
160: ecmp b b'
161:
162: | `BEXPR_tuple ls,`BEXPR_tuple ls' ->
163: fold_left2 (fun r a b -> r && ecmp a b) true ls ls'
164:
165: | `BEXPR_case_arg (i,e),`BEXPR_case_arg (i',e')
166:
167: | `BEXPR_match_case (i,e),`BEXPR_match_case (i',e')
168: | `BEXPR_get_n (i,e),`BEXPR_get_n (i',e') ->
169: i = i' && ecmp e e'
170:
171: (* this is probably wrong: says x.y = x'.y' iff x = x && y = y',
172: however, x.y should unify with a simple value .. oh well..
173: hmm .. this should REALLY be a pointer to member, that is,
174: an actual projection function
175: *)
176: | `BEXPR_get_named (i,e),`BEXPR_get_named (i',e') ->
177: i = i' && ecmp e e'
178:
179: | `BEXPR_case_index e,`BEXPR_case_index e' -> ecmp e e'
180:
181: | `BEXPR_case (i,t),`BEXPR_case (i',t') -> i = i' && t = t'
182: | `BEXPR_expr (s,t),`BEXPR_expr (s',t') -> s = s' && t = t'
183: | `BEXPR_range_check (e1,e2,e3), `BEXPR_range_check (e1',e2',e3') ->
184: ecmp e1 e1' && ecmp e2 e2' && ecmp e3 e3'
185:
186: | _ -> false
187:
188:
1: # 5086 "./lpsrc/flx_types.ipk"
2: open Flx_ast
3: open Flx_types
4: open Flx_print
5: open Flx_srcref
6: open Flx_exceptions
7: open List
8:
9: let typeof_list = function
10: | [x] -> x
11: | x -> `TYP_tuple x
12:
13: let paramtype params =
14: let typlist params = map snd params in
15: typeof_list (typlist params)
16:
17: let all_tunits ts =
18: try
19: iter
20: (fun t ->
21: if t <> `TYP_tuple []
22: then raise Not_found
23: )
24: ts;
25: true
26: with Not_found -> false
27:
28: let rec typecode_of_expr (e:expr_t) :typecode_t =
29: let te e = typecode_of_expr e in
30: match e with
31: | `AST_name (_,"TYPE",[]) -> `TYP_type
32: | `AST_ellipsis _ -> `TYP_ellipsis
33: | #suffixed_name_t as x -> (x:>typecode_t)
34: | `AST_tuple (sr,ls) ->
35: `TYP_type_tuple (map te ls)
36: | `AST_record_type (sr,es) -> `TYP_record es
37: | `AST_variant_type (sr,es) -> `TYP_variant es
38:
39: | `AST_product (_,ts) -> `TYP_tuple (map te ts)
40: | `AST_setintersection (_,ts) -> `TYP_setintersection (map te ts)
41: | `AST_setunion (_,ts) -> `TYP_setunion (map te ts)
42: | `AST_arrow (_,(a,b)) -> `TYP_function (te a, te b)
43: | `AST_longarrow (_,(a,b)) -> `TYP_cfunction (te a, te b)
44: | `AST_superscript (_,(a,b)) -> `TYP_array (te a, te b)
45: | `AST_lvalue (sr,e) -> `TYP_lvalue (te e)
46: | `AST_ref (sr,e) -> `TYP_pointer (te e)
47: | `AST_sum (_,ts) ->
48: let ts = map te ts in
49: if all_tunits ts then
50: `TYP_unitsum (length ts)
51: else
52: `TYP_sum ts
53:
54: | `AST_orlist (sr,ts) ->
55: begin match ts with
56: | [] -> assert false
57: | [x] -> assert false
58: | h :: t ->
59: let llor = `AST_name (sr,"lor",[]) in
60: fold_left (fun sum t -> `TYP_apply (llor,`TYP_type_tuple[sum; te t])) (te h) t
61: end
62:
63: | `AST_andlist (sr,ts) ->
64: begin match ts with
65: | [] -> assert false
66: | [x] -> assert false
67: | h :: t ->
68: let lland = `AST_name (sr,"land",[]) in
69: fold_left (fun sum t -> `TYP_apply (lland,`TYP_type_tuple [sum; te t])) (te h) t
70: end
71:
72: | `AST_typeof (_,e) -> `TYP_typeof e
73: | `AST_as (sr,(t,x)) -> `TYP_as (te t,x)
74:
75: | `AST_literal (sr,`AST_int (enc,v)) ->
76: if enc <> "int"
77: then
78: clierr sr
79: (
80: "Only plain integer can be used as a type, code= '" ^
81: enc ^
82: "'"
83: )
84: else
85: let v = ref
86: begin try Big_int.int_of_big_int v
87: with _ -> clierr sr "Integer used as type out of range"
88: end
89: in
90: if !v <0 then clierr sr "Negative int not allowed as type"
91: else if !v = 0 then ((`AST_void sr) :> typecode_t)
92: else if !v = 1 then `TYP_tuple[]
93: else `TYP_unitsum !v
94:
95: (* NOTE SPECIAL NAME HANDLING HACKS!! *)
96: | `AST_apply(sr,(e1,e2)) ->
97: begin match e1 with
98: | `AST_name (_,name,[]) ->
99: let name' = name ^ " " (* 10 chars *) in
100: if name = "typeof" then `TYP_typeof e2
101: else let arg = typecode_of_expr e2 in
102: if name = "_isin" then
103: begin
104: match arg with
105: | `TYP_type_tuple [memt; sett] ->
106: `TYP_isin (memt, sett)
107: | _ ->
108: (* this can be fixed by taking projections but I can't be bothered atm *)
109: failwith
110: "Implementation limitation, 'isin' operator requires two explicit arguments"
111: end
112: else if name = "typesetof" then
113: begin
114: match arg with
115: | `TYP_type_tuple ls -> `TYP_typeset ls
116: | x -> `TYP_typeset [x]
117: end
118: else if name = "compl" then `TYP_dual arg
119: else if String.sub name' 0 5 = "proj_"
120: then
121: begin
122: let acc = ref 0 in
123: for i = 5 to String.length name - 1 do
124: if name.[i] <= '9' && name.[i] >='0'
125: then acc := 10 * !acc + Char.code (name.[i]) - Char.code '0'
126: else
127: clierr sr
128: (
129: "Digits expected in name '" ^ name ^ "' in\n" ^
130: short_string_of_src sr
131: )
132: done;
133: `TYP_proj (!acc, arg)
134: end
135:
136: else if String.sub name' 0 9 = "case_arg_"
137: then
138: begin
139: let acc = ref 0 in
140: for i = 9 to String.length name - 1 do
141: if name.[i] <= '9' && name.[i] >='0'
142: then acc := 10 * !acc + Char.code (name.[i]) - Char.code '0'
143: else
144: clierr sr
145: (
146: "Digits expected in name '" ^ name ^ "' in\n" ^
147: short_string_of_src sr
148: )
149: done;
150: `TYP_case_arg (!acc, arg)
151: end
152: else
153: `TYP_apply (typecode_of_expr e1,arg)
154:
155: | _ ->
156: `TYP_apply (typecode_of_expr e1,typecode_of_expr e2)
157: end
158:
159: | `AST_lambda (sr,(paramss,ret,body)) ->
160: begin match paramss with
161: | [params,traint] ->
162: (* constraint is ignored for now!! *)
163: begin match body with
164: | [`AST_fun_return (_,e)] ->
165: begin
166: try
167: let t = typecode_of_expr e in
168: match paramss,ret with
169: (* special case, allows {t} to mean 1 -> t *)
170: | [[],None],`TYP_none ->
171: `TYP_function (`TYP_tuple [],t)
172: | _ ->
173: `TYP_typefun
174: (
175: params,
176: ret,
177: t
178: )
179: with _ ->
180: clierr sr
181: "Type lambda must return type expression"
182: end
183:
184: | _ ->
185: clierr sr
186: "Type lambda must just be 'return type_expr'"
187: end
188: | _ ->
189: clierr sr
190: "Type lambda only allowed one argument (arity=1)"
191: end
192:
193: | `AST_type_match (sr,(e,ps)) ->
194: `TYP_type_match (e,ps)
195:
196: | `AST_noexpand (sr,e) -> te e
197:
198: | #expr_t ->
199: let sr = src_of_expr e in
200: clierr sr ("Type expression expected, got " ^ string_of_expr e)
201: