From b21491def4a9ec982a4de1525e9bc8f43c9da920 Mon Sep 17 00:00:00 2001 From: Adam Chlipala Date: Sun, 16 Dec 2007 19:35:03 +0000 Subject: [PATCH] Unused environment variable analysis --- src/ast.sml | 2 +- src/errormsg.sig | 1 + src/errormsg.sml | 12 +++-- src/main.sml | 6 ++- src/sources | 3 ++ src/unused.sig | 25 +++++++++++ src/unused.sml | 112 +++++++++++++++++++++++++++++++++++++++++++++++ 7 files changed, 154 insertions(+), 7 deletions(-) create mode 100644 src/unused.sig create mode 100644 src/unused.sml diff --git a/src/ast.sml b/src/ast.sml index 6668b4b..d4c5727 100644 --- a/src/ast.sml +++ b/src/ast.sml @@ -1,5 +1,5 @@ (* HCoop Domtool (http://hcoop.sourceforge.net/) - * Copyright (c) 2006, Adam Chlipala + * Copyright (c) 2006-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 diff --git a/src/errormsg.sig b/src/errormsg.sig index 5404f2e..12dbb6e 100644 --- a/src/errormsg.sig +++ b/src/errormsg.sig @@ -16,6 +16,7 @@ signature ERRORMSG = val linePos : int list ref val error : (int * int) option -> string -> unit + val warning : (int * int) option -> string -> unit val dummyLoc : int * int diff --git a/src/errormsg.sml b/src/errormsg.sml index 25b7161..5c04589 100644 --- a/src/errormsg.sml +++ b/src/errormsg.sml @@ -6,6 +6,7 @@ structure ErrorMsg :> ERRORMSG = struct (* Initial values of compiler state variables *) val anyErrors = ref false + val anyWarnings = ref false val errorText = ref "" val fileName = ref "" val lineNum = ref 1 @@ -17,14 +18,14 @@ structure ErrorMsg :> ERRORMSG = (* Reset compiler to initial state *) fun reset() = (anyErrors:=false; + anyWarnings:=false; errorText:=""; fileName:=""; lineNum:=1; linePos:=[1]; sourceStream:=TextIO.stdIn) - (* Print the given error message *) - fun error posopt (msg:string) = + fun notify f prefix posopt (msg:string) = let val (startpos, endpos) = Option.getOpt (posopt, (0, 0)) fun look(pos,a::rest,n) = @@ -34,13 +35,16 @@ structure ErrorMsg :> ERRORMSG = else look(pos,rest,n-1) | look _ = print "0.0" in - anyErrors := true; + f (); print (!fileName); print ":"; look(startpos, !linePos, !lineNum); if startpos=endpos then () else (print "-"; look(endpos, !linePos, !lineNum)); - app print [":error: ", msg, "\n"] + app print [":", prefix, ": ", msg, "\n"] end + val error = notify (fn () => anyErrors := true) "error" + val warning = notify (fn () => anyWarnings := true) "warning" + val dummyLoc = (0, 0) exception Error diff --git a/src/main.sml b/src/main.sml index feaab16..9bc87cd 100644 --- a/src/main.sml +++ b/src/main.sml @@ -33,7 +33,8 @@ fun check' G fname = if !ErrorMsg.anyErrors then G else - Tycheck.checkFile G (Defaults.tInit ()) prog + (Option.app (Unused.check G) (#3 prog); + Tycheck.checkFile G (Defaults.tInit ()) prog) end fun basis () = @@ -87,7 +88,8 @@ fun check fname = if !ErrorMsg.anyErrors then raise ErrorMsg.Error else - (G', #3 prog) + (Option.app (Unused.check b) (#3 prog); + (G', #3 prog)) end end end diff --git a/src/sources b/src/sources index b01f76f..1538dd4 100644 --- a/src/sources +++ b/src/sources @@ -136,5 +136,8 @@ htmlPrint.sml autodoc.sig autodoc.sml +unused.sig +unused.sml + main.sig main.sml diff --git a/src/unused.sig b/src/unused.sig new file mode 100644 index 0000000..f1a5180 --- /dev/null +++ b/src/unused.sig @@ -0,0 +1,25 @@ +(* 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 *) + +signature UNUSED = sig + + val check : Env.env -> Ast.exp -> unit + +end diff --git a/src/unused.sml b/src/unused.sml new file mode 100644 index 0000000..ad8c1c4 --- /dev/null +++ b/src/unused.sml @@ -0,0 +1,112 @@ +(* 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 -- 2.20.1