[project @ 2001-06-20 13:08:14 by sewardj]

Command-line enhancements:
* Restrict the run to specific test(s).
* Allow variables to be set at the command line.

testsuite/driver/CmdSemantics.hs

@@ -199,28 +199,38 @@ initialEnv global_env macro_env
 ---------------------------------------------------------------------
 -- Run all the tests defined in a parsed .T file.
 
-processParsedTFile :: FilePath
+processParsedTFile :: Maybe [String]	-- which tests to run
+                   -> FilePath
                    -> [(Var,String)]
                    -> [TopDef]
                    -> IO [(TestID, Maybe (Result, Result))]
 
-processParsedTFile tfilepath initial_global_env topdefs
-   = do putStr "\n"   
-        officialMsg ("=== running tests in: " ++ tfilepath ++ " ===")
-        let tests     = filter isTTest     topdefs
-        let macs      = filter isTMacroDef topdefs
-        let incls     = filter isTInclude  topdefs -- should be []
-        let topbinds  = [(var,expr) | TAssign var expr <- topdefs]
-        let macro_env = map (\(TMacroDef mnm mrhs) -> (mnm,mrhs)) macs
-        ei_global_env <- evalTopBinds initial_global_env topbinds
-        case ei_global_env of
-           Left barfage
-              -> do officialMsg barfage
-                    return [(TestID tfilepath tname, Nothing)
-                            | TTest tname trhs <- tests]
-           Right global_env
-              -> do all_done <- mapM (doOne global_env macro_env) tests
-                    return all_done
+processParsedTFile test_filter tfilepath initial_global_env topdefs
+   = do { let raw_tests = filter isTTest topdefs
+        ; when (null raw_tests) 
+               (officialMsg ("=== WARNING: no tests defined in: " ++ tfilepath))
+        ; let tests = getApplicableTests test_filter raw_tests
+        ; if null tests
+           then return []
+           else
+
+     do { putStr "\n"   
+        ; officialMsg ("=== running tests in: " ++ tfilepath ++ " ===")
+
+        ; let macs      = filter isTMacroDef topdefs
+        ; let incls     = filter isTInclude  topdefs -- should be []
+        ; let topbinds  = [(var,expr) | TAssign var expr <- topdefs]
+        ; let macro_env = map (\(TMacroDef mnm mrhs) -> (mnm,mrhs)) macs
+        ; ei_global_env <- evalTopBinds initial_global_env topbinds
+        ; case ei_global_env of
+             Left barfage
+                -> do officialMsg barfage
+                      return [(TestID tfilepath tname, Nothing)
+                              | TTest tname trhs <- tests]
+             Right global_env
+                -> do all_done <- mapM (doOne global_env macro_env) tests
+                      return all_done
+     }}
      where
         doOne global_env macro_env (TTest tname stmts)
            = do putStr "\n"
@@ -234,6 +244,14 @@ processParsedTFile tfilepath initial_global_env topdefs
                    Right res -> return (test_id, Just res)
 
 
+getApplicableTests :: Maybe [String] -> [TopDef] -> [TopDef]
+
+getApplicableTests Nothing{-no filter-} topdefs
+   = filter isTTest topdefs
+getApplicableTests (Just these) topdefs
+   = [ TTest tname stmts | TTest tname stmts <- topdefs, tname `elem` these]
+
+
 evalTopBinds :: [(Var, String)]		-- pre-set global bindings
              -> [(Var, Expr)] 		-- top-level binds got from script
              -> IO (Either String{-complaint of some kind-}

testsuite/driver/Main.hs

@@ -65,10 +65,16 @@ scrub (c:cs)           = c : scrub cs
 
 
 usage
-   = "usage:\n" ++
-     "runtests --tool=<compiler-to-test>\n" ++   	-- "
-     "         --config=<path_to_config_file>\n" ++ 	-- "
-     "         path_to_root_of_tests_directory"
+   = "\nusage:\n" ++
+     "runtests --tool=<compiler-to-test>\n" ++   		   -- "
+     "         --config=<path_to_config_file>\n" ++ 		   -- "
+     "         --rootdir=<path_to_root_of_tests_directory>\n" ++   -- "
+     "         [--$var=literal-value]\n" ++			   -- "
+     "         [names of tests to run, if you don't want all]\n" ++
+     "\n" ++
+     "         You may not set any of the following vars from the\n" ++
+     "         command line:\n" ++
+     concatMap (\w -> "            $" ++ w ++ "\n") special_var_names
 
 
 main
@@ -76,25 +82,37 @@ main
 imain arg_str
    = main_really (words arg_str)
 test
-   = imain "--tool=ghc --config=../config/msrc/cam-02-unx.T ../tests/codeGen"
+   = imain ("--tool=ghc --config=../config/msrc/cam-02-unx.T " 
+            ++ "--rootdir=../tests/codeGen")
 
 main_really arg_ws0
    = do { let (arg_ws1, maybe_tool) = fish arg_ws0 "--tool="
         ; let (arg_ws2, maybe_conf) = fish arg_ws1 "--config="
-        ; if (length arg_ws2 /= 1 || isNothing maybe_tool 
-                                  || isNothing maybe_conf) 
+        ; let (arg_ws3, maybe_root) = fish arg_ws2 "--rootdir="
+        ; let (arg_ws4, cmd_binds)  = getBinds arg_ws3
+        ; let invalid_binds
+                 = filter (`elem` special_var_names) 
+                          (map fst cmd_binds)
+        ; if (isNothing maybe_tool 
+              || isNothing maybe_conf
+              || isNothing maybe_root
+              || not (null invalid_binds)) 
            then do officialMsg usage
                    exitWith (ExitFailure 1)
            else 
 
      do { let tool = unJust maybe_tool
               conf = unJust maybe_conf
+              root = unJust maybe_root
               (confdir, conffile) = splitPathname conf
-              root_dir = head arg_ws2
               base_genv = [("tool", tool), 
                            ("confdir", confdir), 
                            ("conffilename", conffile)]
 
+              tests_to_run
+                 = if null arg_ws4 then Nothing{-all of them-}
+                                   else Just arg_ws4{-just these-}
+
         ; conf_ok <- doesFileExist conf
         ; if    not conf_ok
            then do officialMsg ("Config file `" ++ conf ++ "' doesn't exist.")
@@ -102,7 +120,7 @@ main_really arg_ws0
            else 
 
      do { -- Find all the .T files
-        ; all_tfiles <- findTFiles root_dir
+        ; all_tfiles <- findTFiles root
         ; putStr "\n"
         ; officialMsg ("Found " ++ show (length all_tfiles) 
                        ++ " test description files:")
@@ -122,6 +140,7 @@ main_really arg_ws0
         -- Run all the tests in each successfully-parsed .T file.
         ; resultss 
              <- mapM ( \ (path,topdefs) -> processParsedTFile 
+                                              tests_to_run
                                               path
                                               (addTVars base_genv path)
                                               topdefs) 
@@ -241,6 +260,28 @@ splitPathname full
      in  if null p_r then (".", reverse f_r)
                      else (reverse p_r, reverse f_r)
 
+-- Extract all the   --$var=value  binds from a bunch of cmd line opts.
+getBinds :: [String] -> ([String], [(Var,String)])
+getBinds cmd_line_opts
+   = f [] [] cmd_line_opts 
+     where
+        f acc_n acc_y []
+           = (reverse acc_n, reverse acc_y)
+        f acc_n acc_y (str:strs)
+           | take 3 str /= "--$" || '=' `notElem` drop 3 str
+           = f (str:acc_n) acc_y strs
+           | otherwise
+           = let varname = takeWhile (/= '=') (drop 3 str)
+                 value   = drop (4 + length varname) str
+             in 
+                 f acc_n ((varname,value):acc_y) strs
+
+-- These vars have special meanings and may not be set from the
+-- command line.
+special_var_names
+   = ["testfilename", "testdir", "conffilename", "confdir", 
+      "tool", "testname"]
+
 
 -- (eg) "foo/bar/xyzzy.ext" --> ("foo/bar", "xyzzy", "ext")
 --splitPathname3 full