Commit 0fab97cb authored by Michael Hanus 's avatar Michael Hanus
Browse files

analysis Makefile improved

parent 1a8aa318
......@@ -41,12 +41,14 @@ data AnalysisServerMessage =
--- Main function to start the server.
--- Without any program arguments, the server is started on a socket.
--- Otherwise, it is started in batch mode to analyze a module.
main :: IO ()
main = do
debugMessage 1 systemBanner
initializeAnalysisSystem
args <- getArgs
processArgs False args
processArgs :: Bool -> [String] -> IO ()
processArgs enforce args = case args of
[] -> mainServer Nothing
["-p",port] -> maybe showError
......@@ -77,6 +79,7 @@ processArgs enforce args = case args of
initializeAnalysisSystem :: IO ()
initializeAnalysisSystem = updateRCFile
showHelp :: IO ()
showHelp = putStrLn $
"Usage: cass <options> [-p <port>] :\n" ++
" start analysis system in server mode\n\n"++
......@@ -231,6 +234,7 @@ startWorkers number workersocket serveraddress workerport handles = do
else return handles
-- stop all workers at server stop
stopWorkers :: [Handle] -> IO ()
stopWorkers [] = done
stopWorkers (handle:whandles) = do
hPutStrLn handle (showQTerm StopWorker)
......@@ -239,6 +243,7 @@ stopWorkers (handle:whandles) = do
--------------------------------------------------------------------------
-- server loop to answer analysis requests over network
serverLoop :: Socket -> [Handle] -> IO ()
serverLoop socket1 whandles = do
--debugMessage 3 "SERVER: serverLoop"
connection <- waitForSocketAccept socket1 waitTime
......@@ -260,6 +265,7 @@ hGetLineUntilEOF h = do
else do cs <- hGetLineUntilEOF h
return (c:cs)
serverLoopOnHandle :: Socket -> [Handle] -> Handle -> IO ()
serverLoopOnHandle socket1 whandles handle = do
eof <- hIsEOF handle
if eof
......@@ -311,6 +317,7 @@ serverLoopOnHandle socket1 whandles handle = do
-- Send a server result in the format "ok <n>\n<result text>" where <n>
-- is the number of lines of the <result text>.
sendServerResult :: Handle -> String -> IO ()
sendServerResult handle resultstring = do
let resultlines = lines resultstring
hPutStrLn handle ("ok " ++ show (length resultlines))
......@@ -318,6 +325,7 @@ sendServerResult handle resultstring = do
hFlush handle
-- Send a server error in the format "error <error message>\n".
sendServerError :: Handle -> String -> IO ()
sendServerError handle errstring = do
debugMessage 1 errstring
hPutStrLn handle ("error "++errstring)
......
......@@ -127,7 +127,8 @@ typeInfos2ProgInfo prog infos = lists2ProgInfo $
in (tname, fromJust (lookup tname infos)))
(partition isVisibleType (progTypes prog))
map2 f (list1,list2) = (map f list1,map f list2)
map2 :: (a -> b) -> ([a], [a]) -> ([b], [b])
map2 f (xs,ys) = (map f xs, map f ys)
--- Update a given value list (second argument) w.r.t. new values given
--- in the first argument list.
......@@ -240,7 +241,7 @@ executeAnalysis (DependencyFuncAnalysis _ _ anaFunc) prog
importInfos sccstartvals)
(listToFM (<) startvals)
(reverse sccDecls)
_ -> errorUnknownFixpoint
_ -> error unknownFixpointMessage
executeAnalysis (DependencyTypeAnalysis _ _ anaType) prog
importInfos startvals fpmethod = case fpmethod of
......@@ -264,10 +265,10 @@ executeAnalysis (DependencyTypeAnalysis _ _ anaType) prog
importInfos sccstartvals)
(listToFM (<) startvals)
(reverse sccDecls)
_ -> errorUnknownFixpoint
_ -> error unknownFixpointMessage
errorUnknownFixpoint =
error "Unknown value for 'fixpoint' in configuration file!"
unknownFixpointMessage :: String
unknownFixpointMessage = "Unknown value for 'fixpoint' in configuration file!"
--- Add the directly called functions to each function declaration.
addCalledFunctions :: FuncDecl -> (FuncDecl,[QName])
......@@ -278,6 +279,7 @@ addUsedTypes :: TypeDecl -> (TypeDecl,[QName])
addUsedTypes tdecl = (tdecl, dependsDirectlyOnTypes tdecl)
--- Gets all constructors of datatype declaration.
consDeclsOfType :: TypeDecl -> [ConsDecl]
consDeclsOfType (Type _ _ _ consDecls) = consDecls
consDeclsOfType (TypeSyn _ _ _ _) = []
......
......@@ -91,6 +91,7 @@ daFuncRule calledFuncs (Rule args rhs) =
then absEvalBindings bs (i:bvs)
else absEvalBindings bs bvs
prelude :: String
prelude = "Prelude"
------------------------------------------------------------------------------
......@@ -95,6 +95,7 @@ extraVarInExpr (Case _ e bs) = extraVarInExpr e || any extraVarInBranch bs
where extraVarInBranch (Branch _ be) = extraVarInExpr be
extraVarInExpr (Typed e _) = extraVarInExpr e
pre :: String -> QName
pre n = ("Prelude",n)
------------------------------------------------------------------------------
......@@ -23,7 +23,7 @@ hoOr HO _ = HO
hoOr FO x = x
------------------------------------------------------------------------
-- higher-order datatype analysis
-- higher-order data type analysis
hiOrdType :: Analysis Order
hiOrdType = dependencyTypeAnalysis "HiOrderType" FO orderOfType
......@@ -69,6 +69,7 @@ orderOfFunc :: ProgInfo Order -> FuncDecl-> Order
orderOfFunc orderMap func =
orderOfFuncTypeArity orderMap (funcType func) (funcArity func)
orderOfFuncTypeArity :: ProgInfo Order -> TypeExpr -> Int -> Order
orderOfFuncTypeArity orderMap functype arity =
if arity==0
then
......@@ -76,7 +77,7 @@ orderOfFuncTypeArity orderMap functype arity =
FuncType _ _ -> HO
TVar (-42) -> HO
TCons x (y:ys) -> hoOr (orderOfFuncTypeArity orderMap y 0)
(orderOfFuncTypeArity orderMap (TCons x ys) 0)
(orderOfFuncTypeArity orderMap (TCons x ys) 0)
TCons tc [] -> fromMaybe FO (lookupProgInfo tc orderMap)
_ -> FO
else let (FuncType x y) = functype
......
# Makefile for cleaning analysis files
# Makefile for analysis files (used in CASS)
ANALYSES = $(wildcard *.curry)
ANA_FCY = $(ANALYSES:%.curry=.curry/%.fcy)
CASS = ../CASS
.PHONY: all compile install clean uninstall
......@@ -8,7 +9,7 @@ CASS = ../CASS
all: install
compile:
for a in $(ANALYSES); do $(REPL) $(REPL_OPTS) :set path $(CASS) :load $$a :quit; done
for a in $(ANA_FCY); do $(MAKE) $$a; done
install: compile
......@@ -16,3 +17,7 @@ clean:
$(CLEANCURRY)
uninstall: clean
# compile a source program:
.curry/%.fcy: %.curry $(CASS)/Analysis.curry $(CASS)/GenericProgInfo.curry
"$(REPL)" $(REPL_OPTS) :set path $(CASS) :load $* :quit
......@@ -253,6 +253,7 @@ viewFuncDepGraphs fdecls =
map (\(f,fgraph)->(f,showDGraph f (isExternal fdecls) fgraph))
(dependencyGraphs fdecls)
isExternal :: [FuncDecl] -> QName -> Bool
isExternal [] _ = True -- this case should not occur
isExternal (Func g _ _ _ rule : gs) f = if f==g then isExternalRule rule
else isExternal gs f
......
Markdown is supported
0% or .
You are about to add 0 people to the discussion. Proceed with caution.
Finish editing this message first!
Please register or to comment