Unused environment variable analysis

diff --git a/src/ast.sml b/src/ast.sml
index 6668b4b..d4c5727 100644 (file)
--- 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 (file)
--- 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 (file)
--- 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 (file)
--- 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 (file)
--- 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 (file)
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 (file)
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