functor Term
(structure Ctx' : CTX)
: TERM =
struct
structure Ctx = Ctx'
local
open Ctx
infix $
in
type const = string (* Constants c,f *)
type parm = string (* Parameters a *)
type var = string (* Variables x *)
(* Terms *)
datatype term = (* t ::= *)
Parm of parm (* a *)
| Var of var (* | x *)
| Root of const * term list (* | f(t1,...,tn) *)
| EVar of parm Ctx.ctx * (term option) ref (* | X^P<=t> *)
(*
We say "t is closed" if t contains no free variables.
We say "ts is closed" if all terms in ts are closed.
*)
(* Global invariant: If an EVar is instantiated to t,
t is closed and all parameters in t are mentioned in P
Global invariant: For any two EVar's which might be unified,
the parameter context of one is a prefix of the other.
*)
(* subst (t,x) s ===> [t/x] s; t must be closed *)
fun subst (t, x) s =
let fun sbst (s as Parm _) = s
| sbst (s as Var(y)) =
if x = y then t else s
| sbst (Root (g, ss)) =
Root (g, map sbst ss)
| sbst (X as EVar _) = X
in
sbst s
end
(* eq (t, s) ===> true iff t = s; t and s must be closed *)
(* eq' (ts, ss) ===> true iff ts = ss; ts and ss must be closed *)
fun eq (Parm(a), Parm(b)) = (a = b)
| eq (Root(f, ts), Root(g, ss)) =
(f = g) andalso eq' (ts, ss)
| eq (EVar(P, r), EVar(P', r')) = (r = r')
| eq _ = false (* Var(_) not permitted! *)
and eq' (nil, nil) = true
| eq' (t::ts, s::ss) = eq (t, s) andalso eq' (ts, ss)
| eq' _ = false
(* closed P t ===> true iff t closed wrt P *)
(*
t is closed wrt P if it is closed and
all parameters in t are declared in parameter context P.
*)
fun closed P =
let fun cld (Parm(a)) = member (a, P)
| cld (Var _) = false
| cld (Root (f, ts)) = cld' ts
| cld (EVar _) = true
and cld' (nil) = true
| cld' (t::ts) = cld t andalso cld' ts
in cld end
(* legal a ===> true iff a is a legal external parameter *)
(*
External parameters are not allows to start with a digit,
so they cannot conflict with internally generated parameters.
*)
fun legal (x) = not (Char.isDigit (String.sub (x, 0)))
local
(* local counter to guarantee new internal parameters *)
val counter = ref 0
in
(* newParm () ===> a, where a is a new internal parameter *)
(*
Internal parameters are natural numbers,
so they cannot conflict with external parameters.
*)
fun newParm () =
(counter := !counter+1;
Int.toString (!counter))
end
fun parmsToString P = "[" ^ pts P ^ "]"
and pts (Null) = ""
| pts (Null $ p) = p
| pts (ps $ p) = pts ps ^ "," ^ p
local
val evarNames = ref (nil : (term option ref * string) list)
val counter = ref 0
fun getName (r) =
let fun gn (nil) =
let val _ = (counter := !counter+1)
val name = "_" ^ Int.toString (!counter)
val _ = (evarNames := (r,name)::(!evarNames))
in name end
| gn ((r', name)::evn) =
if r = r' then name
else gn evn
in gn (!evarNames) end
in
fun evarName (EVar(P,r)) = getName (r) ^ parmsToString P
end
(* Constants c are printed as c() to distinguish them from variables. *)
(* Parameters a are printed as 'a. *)
(* Variables x are printed simply as x. *)
(* Existential variables are printed as _i[a1,...,an] *)
(* Output may look wrong if variables are named 'x or _i. *)
fun toString (Parm(a)) = "'" ^ a
| toString (Var(x)) = x
| toString (Root(f,ts)) = f ^ "(" ^ toString' ts ^ ")"
| toString (EVar(_,ref(SOME(t)))) = toString t
| toString (X as EVar _) = evarName X
and toString' (nil) = ""
| toString' (t::nil) = toString t
| toString' (t::ts) = toString t ^ "," ^ toString' ts
fun newEVar (P) = EVar (P, ref(NONE))
local
val localTrail = ref (nil : term option ref list)
fun unwind (nil) = ()
| unwind (r::tr') = (r := NONE; unwind tr')
(* all trailed variable should be instantiated *)
in
fun instantiate (r, t) =
(r := SOME(t);
localTrail := (r::(!localTrail)))
fun trail f x =
let val r = f x handle exn => (unwind (!localTrail);
localTrail := nil;
raise exn)
val _ = (localTrail := nil)
in r end
end
(* contained (P', P) => true iff P' is contained in P
Invariant: either P is a prefix of P' or P' a prefix of P
*)
fun contained (Null, _) = true
| contained (P' $ a', P $ a) = contained (P', P)
| contained _ = false
(* restrict (P', P) => P (= intersection of P' and P)
Invariant: P is a prefix of P'
*)
fun restrict (P', P) = P
(* excection Unify(reason) signals failure *)
exception Unify of string
(* check (X^P<>, t) => ()
raises Unify(reason) if X or a parameter not in P occurs in t
Effect: might restrict parameter occurrence in EVars by
instantiation
*)
fun check (EVar(P, r), t) =
let fun chk (Parm(a)) =
if member (a, P) then ()
else raise Unify ("Parameter occurrence")
| chk (Root(f, ts)) = chk' ts
| chk (EVar (P', ref(SOME(t)))) = chk t
| chk (EVar (P', r')) =
if r = r' then raise Unify ("Variable occurrence")
else if contained (P', P) then ()
else instantiate (r', newEVar (restrict (P', P)))
(* Var(x) impossible *)
and chk' (nil) = ()
| chk' (t::ts) = (chk t; chk' ts)
in
chk t
end
(* unifyEVar (X<>, t) => ()
Effect: instantiate EVars due to parameter restrictions
instantiate X
raises Unify (reason) if not unifiable
*)
fun unifyEVar (X as EVar (P, r), t) =
(check (X, t); instantiate (r, t))
(* unify (t, s) => ()
unify' (ts, ss) => ()
t, s, ts, ss closed (but may contain parameters or EVars)
Effect: instantiate EVars
raises Unify (reason) if not unifiable
*)
fun unify (Parm(a), Parm(a')) =
if a = a' then ()
else raise Unify ("Parameter clash")
| unify (Root(f, ts), Root(g, ss)) =
if f = g then unify' (ts, ss)
else raise Unify ("Constant clash")
| unify (EVar(_, ref(SOME(t))), s) = unify (t, s)
| unify (t, EVar(_, ref(SOME(s)))) = unify (t, s)
| unify (X as EVar(_, r), X' as EVar(_, r')) =
if r = r' then () else unifyEVar (X, X')
| unify (X as EVar _, s) = unifyEVar (X, s)
| unify (t, X as EVar _) = unifyEVar (X, t)
(* Var(x) on either side impossible *)
and unify' (nil, nil) = ()
| unify' (t::ts, s::ss) = (unify (t, s); unify' (ts, ss))
| unify' _ = raise Unify ("Argument number")
end (* local ... *)
end; (* functor Term *)