54 val freeze: term -> term |
54 val freeze: term -> term |
55 |
55 |
56 (*matching and unification*) |
56 (*matching and unification*) |
57 exception TYPE_MATCH |
57 exception TYPE_MATCH |
58 type tyenv = (sort * typ) Vartab.table |
58 type tyenv = (sort * typ) Vartab.table |
59 val lookup: tyenv * (indexname * sort) -> typ option |
59 val lookup: tyenv -> indexname * sort -> typ option |
60 val typ_match: tsig -> typ * typ -> tyenv -> tyenv |
60 val typ_match: tsig -> typ * typ -> tyenv -> tyenv |
61 val typ_instance: tsig -> typ * typ -> bool |
61 val typ_instance: tsig -> typ * typ -> bool |
|
62 val typ_of_sort: Sorts.algebra -> typ -> sort |
|
63 -> sort Vartab.table -> sort Vartab.table |
62 val raw_match: typ * typ -> tyenv -> tyenv |
64 val raw_match: typ * typ -> tyenv -> tyenv |
63 val raw_matches: typ list * typ list -> tyenv -> tyenv |
65 val raw_matches: typ list * typ list -> tyenv -> tyenv |
64 val raw_instance: typ * typ -> bool |
66 val raw_instance: typ * typ -> bool |
65 exception TUNIFY |
67 exception TUNIFY |
66 val unify: tsig -> typ * typ -> tyenv * int -> tyenv * int |
68 val unify: tsig -> typ * typ -> tyenv * int -> tyenv * int |
335 |
337 |
336 fun tvar_clash ixn S S' = raise TYPE ("Type variable " ^ |
338 fun tvar_clash ixn S S' = raise TYPE ("Type variable " ^ |
337 quote (Term.string_of_vname ixn) ^ " has two distinct sorts", |
339 quote (Term.string_of_vname ixn) ^ " has two distinct sorts", |
338 [TVar (ixn, S), TVar (ixn, S')], []); |
340 [TVar (ixn, S), TVar (ixn, S')], []); |
339 |
341 |
340 fun lookup (tye, (ixn, S)) = |
342 fun lookup tye (ixn, S) = |
341 (case Vartab.lookup tye ixn of |
343 (case Vartab.lookup tye ixn of |
342 NONE => NONE |
344 NONE => NONE |
343 | SOME (S', T) => if S = S' then SOME T else tvar_clash ixn S S'); |
345 | SOME (S', T) => if S = S' then SOME T else tvar_clash ixn S S'); |
344 |
346 |
345 |
347 |
346 (* matching *) |
348 (* matching *) |
347 |
349 |
348 exception TYPE_MATCH; |
350 exception TYPE_MATCH; |
349 |
351 |
|
352 fun typ_of_sort algebra = |
|
353 let |
|
354 val inters = Sorts.inter_sort algebra; |
|
355 fun of_sort _ [] = I |
|
356 | of_sort (TVar (v, S)) S' = Vartab.map_default (v, []) |
|
357 (fn S'' => inters (S, inters (S', S''))) |
|
358 | of_sort (TFree (_, S)) S' = if Sorts.sort_le algebra (S, S') then I |
|
359 else raise Sorts.CLASS_ERROR (Sorts.NoSubsort (S, S')) |
|
360 | of_sort (Type (a, Ts)) S = |
|
361 fold2 of_sort Ts (Sorts.mg_domain algebra a S) |
|
362 in of_sort end; |
|
363 |
350 fun typ_match tsig = |
364 fun typ_match tsig = |
351 let |
365 let |
352 fun match (TVar (v, S), T) subs = |
366 fun match (TVar (v, S), T) subs = |
353 (case lookup (subs, (v, S)) of |
367 (case lookup subs (v, S) of |
354 NONE => |
368 NONE => |
355 if of_sort tsig (T, S) then Vartab.update_new (v, (S, T)) subs |
369 if of_sort tsig (T, S) then Vartab.update_new (v, (S, T)) subs |
356 else raise TYPE_MATCH |
370 else raise TYPE_MATCH |
357 | SOME U => if U = T then subs else raise TYPE_MATCH) |
371 | SOME U => if U = T then subs else raise TYPE_MATCH) |
358 | match (Type (a, Ts), Type (b, Us)) subs = |
372 | match (Type (a, Ts), Type (b, Us)) subs = |
368 fun typ_instance tsig (T, U) = |
382 fun typ_instance tsig (T, U) = |
369 (typ_match tsig (U, T) Vartab.empty; true) handle TYPE_MATCH => false; |
383 (typ_match tsig (U, T) Vartab.empty; true) handle TYPE_MATCH => false; |
370 |
384 |
371 (*purely structural matching*) |
385 (*purely structural matching*) |
372 fun raw_match (TVar (v, S), T) subs = |
386 fun raw_match (TVar (v, S), T) subs = |
373 (case lookup (subs, (v, S)) of |
387 (case lookup subs (v, S) of |
374 NONE => Vartab.update_new (v, (S, T)) subs |
388 NONE => Vartab.update_new (v, (S, T)) subs |
375 | SOME U => if U = T then subs else raise TYPE_MATCH) |
389 | SOME U => if U = T then subs else raise TYPE_MATCH) |
376 | raw_match (Type (a, Ts), Type (b, Us)) subs = |
390 | raw_match (Type (a, Ts), Type (b, Us)) subs = |
377 if a <> b then raise TYPE_MATCH |
391 if a <> b then raise TYPE_MATCH |
378 else raw_matches (Ts, Us) subs |
392 else raw_matches (Ts, Us) subs |
396 let |
410 let |
397 fun occ (Type (_, Ts)) = exists occ Ts |
411 fun occ (Type (_, Ts)) = exists occ Ts |
398 | occ (TFree _) = false |
412 | occ (TFree _) = false |
399 | occ (TVar (w, S)) = |
413 | occ (TVar (w, S)) = |
400 eq_ix (v, w) orelse |
414 eq_ix (v, w) orelse |
401 (case lookup (tye, (w, S)) of |
415 (case lookup tye (w, S) of |
402 NONE => false |
416 NONE => false |
403 | SOME U => occ U); |
417 | SOME U => occ U); |
404 in occ end; |
418 in occ end; |
405 |
419 |
406 (*chase variable assignments; if devar returns a type var then it must be unassigned*) |
420 (*chase variable assignments; if devar returns a type var then it must be unassigned*) |
407 fun devar tye (T as TVar v) = |
421 fun devar tye (T as TVar v) = |
408 (case lookup (tye, v) of |
422 (case lookup tye v of |
409 SOME U => devar tye U |
423 SOME U => devar tye U |
410 | NONE => T) |
424 | NONE => T) |
411 | devar tye T = T; |
425 | devar tye T = T; |
412 |
426 |
413 (*order-sorted unification*) |
427 (*order-sorted unification*) |