30 val subsort: tsig -> sort * sort -> bool |
30 val subsort: tsig -> sort * sort -> bool |
31 val of_sort: tsig -> typ * sort -> bool |
31 val of_sort: tsig -> typ * sort -> bool |
32 val cert_class: tsig -> class -> class |
32 val cert_class: tsig -> class -> class |
33 val cert_sort: tsig -> sort -> sort |
33 val cert_sort: tsig -> sort -> sort |
34 val witness_sorts: tsig -> sort list -> sort list -> (typ * sort) list |
34 val witness_sorts: tsig -> sort list -> sort list -> (typ * sort) list |
35 val cert_typ: tsig -> typ -> typ * int |
35 val cert_typ: tsig -> typ -> typ |
36 val cert_typ_syntax: tsig -> typ -> typ * int |
36 val cert_typ_syntax: tsig -> typ -> typ |
37 val cert_typ_raw: tsig -> typ -> typ * int |
37 val cert_typ_raw: tsig -> typ -> typ |
38 |
38 |
39 (*special treatment of type vars*) |
39 (*special treatment of type vars*) |
40 val strip_sorts: typ -> typ |
40 val strip_sorts: typ -> typ |
41 val no_tvars: typ -> typ |
41 val no_tvars: typ -> typ |
42 val varifyT: typ -> typ |
42 val varifyT: typ -> typ |
142 (* certified types *) |
142 (* certified types *) |
143 |
143 |
144 fun bad_nargs t = "Bad number of arguments for type constructor: " ^ quote t; |
144 fun bad_nargs t = "Bad number of arguments for type constructor: " ^ quote t; |
145 fun undecl_type c = "Undeclared type constructor: " ^ quote c; |
145 fun undecl_type c = "Undeclared type constructor: " ^ quote c; |
146 |
146 |
147 local |
|
148 |
|
149 fun inst_typ env = Term.map_type_tvar (fn (var as (v, _)) => |
|
150 (case Library.assoc_string_int (env, v) of |
|
151 Some U => inst_typ env U |
|
152 | None => TVar var)); |
|
153 |
|
154 fun certify_typ normalize syntax tsig ty = |
147 fun certify_typ normalize syntax tsig ty = |
155 let |
148 let |
156 val TSig {classes, types, ...} = tsig; |
149 val TSig {classes, types, ...} = tsig; |
157 fun err msg = raise TYPE (msg, [ty], []); |
150 fun err msg = raise TYPE (msg, [ty], []); |
158 |
151 |
159 val maxidx = Term.maxidx_of_typ ty; |
152 fun inst_typ env (Type (c, Ts)) = Type (c, map (inst_typ env) Ts) |
160 val idx = maxidx + 1; |
153 | inst_typ env (T as TFree (x, _)) = if_none (Library.assoc_string (env, x)) T |
|
154 | inst_typ _ T = T; |
|
155 |
161 |
156 |
162 val check_syntax = |
157 val check_syntax = |
163 if syntax then K () |
158 if syntax then K () |
164 else fn c => err ("Illegal occurrence of syntactic type: " ^ quote c); |
159 else fn c => err ("Illegal occurrence of syntactic type: " ^ quote c); |
165 |
160 |
170 in |
165 in |
171 (case Symtab.lookup (types, c) of |
166 (case Symtab.lookup (types, c) of |
172 Some (LogicalType n, _) => (nargs n; Type (c, Ts')) |
167 Some (LogicalType n, _) => (nargs n; Type (c, Ts')) |
173 | Some (Abbreviation (vs, U, syn), _) => (nargs (length vs); |
168 | Some (Abbreviation (vs, U, syn), _) => (nargs (length vs); |
174 if syn then check_syntax c else (); |
169 if syn then check_syntax c else (); |
175 if normalize then |
170 if normalize then inst_typ (vs ~~ Ts') U |
176 inst_typ (map (rpair idx) vs ~~ Ts') (Term.incr_tvar idx U) |
|
177 else Type (c, Ts')) |
171 else Type (c, Ts')) |
178 | Some (Nonterminal, _) => (nargs 0; check_syntax c; T) |
172 | Some (Nonterminal, _) => (nargs 0; check_syntax c; T) |
179 | None => err (undecl_type c)) |
173 | None => err (undecl_type c)) |
180 end |
174 end |
181 | cert (TFree (x, S)) = TFree (x, Sorts.certify_sort classes S) |
175 | cert (TFree (x, S)) = TFree (x, Sorts.certify_sort classes S) |
182 | cert (TVar (xi as (_, i), S)) = |
176 | cert (TVar (xi as (_, i), S)) = |
183 if i < 0 then err ("Malformed type variable: " ^ quote (Term.string_of_vname xi)) |
177 if i < 0 then |
|
178 err ("Malformed type variable: " ^ quote (Term.string_of_vname xi)) |
184 else TVar (xi, Sorts.certify_sort classes S); |
179 else TVar (xi, Sorts.certify_sort classes S); |
185 |
180 |
186 val ty' = cert ty; |
181 val ty' = cert ty; |
187 val ty' = if ty = ty' then ty else ty'; (*avoid copying of already normal type*) |
182 in if ty = ty' then ty else ty' end; (*avoid copying of already normal type*) |
188 in (ty', maxidx) end; |
|
189 |
|
190 in |
|
191 |
183 |
192 val cert_typ = certify_typ true false; |
184 val cert_typ = certify_typ true false; |
193 val cert_typ_syntax = certify_typ true true; |
185 val cert_typ_syntax = certify_typ true true; |
194 val cert_typ_raw = certify_typ false true; |
186 val cert_typ_raw = certify_typ false true; |
195 |
187 |
196 end; |
|
197 |
188 |
198 |
189 |
199 (** special treatment of type vars **) |
190 (** special treatment of type vars **) |
200 |
191 |
201 (* strip_sorts *) |
192 (* strip_sorts *) |
277 |
268 |
278 (** matching and unification of types **) |
269 (** matching and unification of types **) |
279 |
270 |
280 (* instantiation *) |
271 (* instantiation *) |
281 |
272 |
282 fun type_of_sort pp tsig (T, S) = |
|
283 if of_sort tsig (T, S) then T |
|
284 else raise TYPE ("Type not of sort " ^ Pretty.string_of_sort pp S, [T], []); |
|
285 |
|
286 fun inst_typ_tvars pp tsig tye = |
273 fun inst_typ_tvars pp tsig tye = |
287 let |
274 let |
288 fun inst (var as (v, S)) = |
275 fun inst (var as (v, S)) = |
289 (case assoc_string_int (tye, v) of |
276 (case assoc_string_int (tye, v) of |
290 Some U => type_of_sort pp tsig (U, S) |
277 Some U => |
|
278 if of_sort tsig (U, S) then U |
|
279 else raise TYPE ("Type not of sort " ^ Pretty.string_of_sort pp S, [U], []) |
291 | None => TVar var); |
280 | None => TVar var); |
292 in map_type_tvar inst end; |
281 in map_type_tvar inst end; |
293 |
282 |
294 fun inst_term_tvars _ _ [] t = t |
283 fun inst_term_tvars _ _ [] t = t |
295 | inst_term_tvars pp tsig tye t = map_term_types (inst_typ_tvars pp tsig tye) t; |
284 | inst_term_tvars pp tsig tye t = map_term_types (inst_typ_tvars pp tsig tye) t; |
301 |
290 |
302 fun typ_match tsig = |
291 fun typ_match tsig = |
303 let |
292 let |
304 fun match (subs, (TVar (v, S), T)) = |
293 fun match (subs, (TVar (v, S), T)) = |
305 (case Vartab.lookup (subs, v) of |
294 (case Vartab.lookup (subs, v) of |
306 None => (Vartab.update_new ((v, type_of_sort Pretty.pp_undef tsig (T, S)), subs) |
295 None => |
307 handle TYPE _ => raise TYPE_MATCH) |
296 if of_sort tsig (T, S) then Vartab.update ((v, T), subs) |
|
297 else raise TYPE_MATCH |
308 | Some U => if U = T then subs else raise TYPE_MATCH) |
298 | Some U => if U = T then subs else raise TYPE_MATCH) |
309 | match (subs, (Type (a, Ts), Type (b, Us))) = |
299 | match (subs, (Type (a, Ts), Type (b, Us))) = |
310 if a <> b then raise TYPE_MATCH |
300 if a <> b then raise TYPE_MATCH |
311 else foldl match (subs, Ts ~~ Us) |
301 else foldl match (subs, Ts ~~ Us) |
312 | match (subs, (TFree x, TFree y)) = |
302 | match (subs, (TFree x, TFree y)) = |
550 |
540 |
551 fun add_abbr (a, vs, rhs) tsig = tsig |> change_types (fn types => |
541 fun add_abbr (a, vs, rhs) tsig = tsig |> change_types (fn types => |
552 let |
542 let |
553 fun err msg = |
543 fun err msg = |
554 error (msg ^ "\nThe error(s) above occurred in type abbreviation: " ^ quote a); |
544 error (msg ^ "\nThe error(s) above occurred in type abbreviation: " ^ quote a); |
555 val rhs' = strip_sorts (varifyT (no_tvars (#1 (cert_typ_syntax tsig rhs)))) |
545 val rhs' = strip_sorts (no_tvars (cert_typ_syntax tsig rhs)) |
556 handle TYPE (msg, _, _) => err msg; |
546 handle TYPE (msg, _, _) => err msg; |
557 in |
547 in |
558 (case duplicates vs of |
548 (case duplicates vs of |
559 [] => [] |
549 [] => [] |
560 | dups => err ("Duplicate variables on lhs: " ^ commas_quote dups)); |
550 | dups => err ("Duplicate variables on lhs: " ^ commas_quote dups)); |