561 val certify_typ = Type.cert_typ o tsig_of; |
561 val certify_typ = Type.cert_typ o tsig_of; |
562 |
562 |
563 |
563 |
564 (* certify_term *) |
564 (* certify_term *) |
565 |
565 |
566 (*check for duplicate TVars with distinct sorts*) |
566 (*check for duplicate occurrences of TFree/TVar with distinct sorts*) |
567 fun nodup_TVars (tvars, T) = |
567 fun nodup_tvars (env, Type (_, Ts)) = nodup_tvars_list (env, Ts) |
568 (case T of |
568 | nodup_tvars (env as (tfrees, tvars), T as TFree (v as (a, S))) = |
569 Type (_, Ts) => nodup_TVars_list (tvars, Ts) |
569 (case assoc_string (tfrees, a) of |
570 | TFree _ => tvars |
570 Some S' => |
571 | TVar (v as (a, S)) => |
571 if S = S' then env |
|
572 else raise TYPE ("Type variable " ^ quote a ^ |
|
573 " has two distinct sorts", [TFree (a, S'), T], []) |
|
574 | None => (v :: tfrees, tvars)) |
|
575 | nodup_tvars (env as (tfrees, tvars), T as TVar (v as (a, S))) = |
572 (case assoc_string_int (tvars, a) of |
576 (case assoc_string_int (tvars, a) of |
573 Some S' => |
577 Some S' => |
574 if S = S' then tvars |
578 if S = S' then env |
575 else raise TYPE ("Type variable " ^ Syntax.string_of_vname a ^ |
579 else raise TYPE ("Type variable " ^ quote (Syntax.string_of_vname a) ^ |
576 " has two distinct sorts", [TVar (a, S'), T], []) |
580 " has two distinct sorts", [TVar (a, S'), T], []) |
577 | None => v :: tvars)) |
581 | None => (tfrees, v :: tvars)) |
578 (*equivalent to foldl nodup_TVars_list, but 3X faster under Poly/ML*) |
582 (*equivalent to foldl nodup_tvars_list, but 3X faster under Poly/ML*) |
579 and nodup_TVars_list (tvars, []) = tvars |
583 and nodup_tvars_list (env, []) = env |
580 | nodup_TVars_list (tvars, T :: Ts) = |
584 | nodup_tvars_list (env, T :: Ts) = nodup_tvars_list (nodup_tvars (env, T), Ts); |
581 nodup_TVars_list (nodup_TVars (tvars, T), Ts); |
585 |
582 |
586 (*check for duplicate occurrences of Free/Var with distinct types*) |
583 (*check for duplicate Vars with distinct types*) |
587 fun nodup_vars tm = |
584 fun nodup_Vars tm = |
588 let |
585 let |
589 fun nodups (envs as (env as (frees, vars), envT)) tm = |
586 fun nodups vars tvars tm = |
|
587 (case tm of |
590 (case tm of |
588 Const (c, T) => (vars, nodup_TVars (tvars, T)) |
591 Const (c, T) => (env, nodup_tvars (envT, T)) |
589 | Free (a, T) => (vars, nodup_TVars (tvars, T)) |
592 | Free (v as (a, T)) => |
|
593 (case assoc_string (frees, a) of |
|
594 Some T' => |
|
595 if T = T' then (env, nodup_tvars (envT, T)) |
|
596 else raise TYPE ("Variable " ^ quote a ^ |
|
597 " has two distinct types", [T', T], []) |
|
598 | None => ((v :: frees, vars), nodup_tvars (envT, T))) |
590 | Var (v as (ixn, T)) => |
599 | Var (v as (ixn, T)) => |
591 (case assoc_string_int (vars, ixn) of |
600 (case assoc_string_int (vars, ixn) of |
592 Some T' => |
601 Some T' => |
593 if T = T' then (vars, nodup_TVars (tvars, T)) |
602 if T = T' then (env, nodup_tvars (envT, T)) |
594 else raise TYPE ("Variable " ^ Syntax.string_of_vname ixn ^ |
603 else raise TYPE ("Variable " ^ quote (Syntax.string_of_vname ixn) ^ |
595 " has two distinct types", [T', T], []) |
604 " has two distinct types", [T', T], []) |
596 | None => (v :: vars, tvars)) |
605 | None => ((frees, v :: vars), nodup_tvars (envT, T))) |
597 | Bound _ => (vars, tvars) |
606 | Bound _ => envs |
598 | Abs (_, T, t) => nodups vars (nodup_TVars (tvars, T)) t |
607 | Abs (_, T, t) => nodups (env, nodup_tvars (envT, T)) t |
599 | s $ t => |
608 | s $ t => nodups (nodups envs s) t) |
600 let val (vars',tvars') = nodups vars tvars s in |
609 in nodups (([], []), ([], [])) tm; tm end; |
601 nodups vars' tvars' t |
|
602 end); |
|
603 in nodups [] [] tm; () end; |
|
604 |
610 |
605 (*compute and check type of the term*) |
611 (*compute and check type of the term*) |
606 fun type_check sg tm = |
612 fun type_check sg tm = |
607 let |
613 let |
608 val prt = |
614 val prt = |