+(* HCoop Domtool (http://hcoop.sourceforge.net/)
+ * Copyright (c) 2007, Adam Chlipala
+ *
+ * This program is free software; you can redistribute it and/or
+ * modify it under the terms of the GNU General Public License
+ * as published by the Free Software Foundation; either version 2
+ * of the License, or (at your option) any later version.
+ *
+ * This program is distributed in the hope that it will be useful,
+ * but WITHOUT ANY WARRANTY; without even the implied warranty of
+ * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
+ * GNU General Public License for more details.
+ *
+ * You should have received a copy of the GNU General Public License
+ * along with this program; if not, write to the Free Software
+ * Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301, USA.
+ *)
+
+(* Domtool configuration language unused environment variable setting analysis *)
+
+structure Unused :> UNUSED = struct
+
+open Ast
+structure SM = StringMap
+structure SS = StringSet
+
+fun check G e =
+ let
+ fun used vars x =
+ (#1 (SM.remove (vars, x)))
+ handle NotFound => vars
+
+ fun unused loc x =
+ ErrorMsg.warning (SOME loc) ("Unused setting of environment variable " ^ x)
+
+ fun writing vars x loc =
+ (Option.app (fn loc' => unused loc' x) (SM.find (vars, x));
+ SM.insert (vars, x, loc))
+
+ fun findHead (e, _) =
+ case e of
+ EVar x => SOME x
+ | EApp (e, _) => findHead e
+ | _ => NONE
+
+ fun processTy f default loc t =
+ case #1 (Describe.ununify t) of
+ TArrow (_, t) => processTy f default loc t
+ | TNested (_, t) => processTy f default loc t
+
+ | TAction (_, reads, writes) => f (reads, writes)
+
+ | _ => default
+
+ fun writes (e, _) =
+ case e of
+ ESet (x, _) => SS.singleton x
+ | EGet (_, _, _, e) => writes e
+ | ESeq es => foldl (fn (e, s) => SS.union (writes e, s)) SS.empty es
+ | ELocal (_, e) => writes e
+ | EWith (e, _) => writes e
+ | _ => SS.empty
+
+ fun chk (eAll as (e, loc), vars) =
+ case e of
+ EInt _ => vars
+ | EString _ => vars
+ | EList es => vars
+ | ELam _ => vars
+ | ESkip => vars
+
+ | ESet (x, _) => writing vars x loc
+ | EGet (_, _, x, e) => chk (e, used vars x)
+ | ESeq es => foldl chk vars es
+ | ELocal (e1, e2) =>
+ let
+ val vars = chk (e2, chk (e1, vars))
+ val writes1 = writes e1
+ val writes2 = writes e2
+ in
+ SM.foldli (fn (x, _, vars') =>
+ if SS.member (writes1, x)
+ andalso not (SS.member (writes2, x)) then
+ SM.insert (vars', x, valOf (SM.find (vars, x)))
+ else
+ vars') vars vars
+ end
+ | EWith (e1, e2) => chk (e2, chk (e1, vars))
+ | EALam _ => vars
+ | EIf _ => vars
+
+ | _ =>
+ let
+ val processTy = processTy (fn (reads, writes) =>
+ let
+ val vars = SM.foldli (fn (x, _, vars) => used vars x) vars reads
+ in
+ SM.foldli (fn (x, _, vars) => writing vars x loc) vars writes
+ end)
+ vars
+ in
+ case findHead eAll of
+ NONE => raise Fail "Couldn't find the head"
+ | SOME head =>
+ case Env.lookupVal G head of
+ NONE => vars
+ | SOME t => processTy loc t
+ end
+ in
+ SM.appi (fn (x, loc) => unused loc x) (chk (e, SM.empty))
+ end
+end