CSPM-Interpreter 0.4.0.2 → 0.4.4.1

raw patch · 17 files changed

+380/−170 lines, 17 filesdep ~CSPM-CoreLanguagedep ~CSPM-Frontenddep ~containersPVP: major bump suggested

API removals or changes: PVP suggests a major version bump

Dependency ranges changed: CSPM-CoreLanguage, CSPM-Frontend, containers, mtl, syb

API changes (from Hackage documentation)

Files

• CSPM-Interpreter.cabal +16/−11
• LICENSE +27/−0
• License +0/−0
• src/CSPM/Interpreter.hs +15/−20
• src/CSPM/Interpreter/CoreInstances.hs +9/−6
• src/CSPM/Interpreter/Eval.hs +31/−30
• src/CSPM/Interpreter/GenericBufferPrefix.hs +2/−5
• src/CSPM/Interpreter/Hash.hs +5/−2
• src/CSPM/Interpreter/PatternCompiler.hs +162/−0
• src/CSPM/Interpreter/PatternMatcher.hs +51/−46
• src/CSPM/Interpreter/Prefix.hs +8/−11
• src/CSPM/Interpreter/PrepareAST.hs +9/−5
• src/CSPM/Interpreter/Renaming.hs +0/−1
• src/CSPM/Interpreter/Test/CLI.hs +23/−19
• src/CSPM/Interpreter/Types.hs +8/−1
• src/Data/Digest/Pure/HashMD5.hs +8/−0
• src/Data/Digest/Pure/MD5.hs +6/−13

@@ -1,5 +1,5 @@ Name:                CSPM-Interpreter-Version:             0.4.0.2+Version:             0.4.4.1  Synopsis:            An interpreter for CSPM Description:@@ -12,25 +12,29 @@  License:             BSD3 category:            Language,Formal Methods,Concurrency-License-File:        License-Author:              2010 Marc Fontaine+License-File:        LICENSE+Author:              2010 - 2011 Marc Fontaine Maintainer:          Marc Fontaine <fontaine@cs.uni-duesseldorf.de> Homepage:            http://www.stups.uni-duesseldorf.de/~fontaine/csp-cabal-Version:       >= 1.6+Stability:           experimental+Tested-With:         GHC == 7.0.2++cabal-Version:       >= 1.10 build-type: Simple Extra-source-files: Library   Build-Depends:-    CSPM-Frontend >= 0.4 && < 0.5-    ,CSPM-CoreLanguage >= 0.1 && < 0.2+    CSPM-Frontend >= 0.6 && < 0.7+    ,CSPM-CoreLanguage >= 0.2 && < 0.3     ,base >= 4.0 && < 5.0-    ,containers >= 0.3 && < 0.4-    ,mtl >= 1.1 && < 1.2+    ,containers >= 0.4 && < 0.5+    ,mtl (>= 2.0 && < 2.1 ) || (>= 1.1 && < 1.2)     ,array >= 0.3 && <0.4-    ,syb >= 0.1 && < 0.2- +    ,syb >= 0.3 && < 0.4++  Default-Language: Haskell2010   GHC-Options: -funbox-strict-fields -O2 -Wall-  Extensions: DeriveDataTypeable, GeneralizedNewtypeDeriving+  Other-Extensions: DeriveDataTypeable, GeneralizedNewtypeDeriving   Hs-Source-Dirs:       src   Exposed-modules:     CSPM.Interpreter@@ -44,6 +48,7 @@     CSPM.Interpreter.Renaming     CSPM.Interpreter.PrepareAST     CSPM.Interpreter.Bindings+    CSPM.Interpreter.PatternCompiler     CSPM.Interpreter.PatternMatcher     CSPM.Interpreter.Prefix     CSPM.Interpreter.GenericBufferPrefix

@@ -0,0 +1,27 @@+Copyright (c) Marc Fontaine 2007-2011++All rights reserved.++Redistribution and use in source and binary forms, with or without+modification, are permitted provided that the following conditions+are met:+1. Redistributions of source code must retain the above copyright+   notice, this list of conditions and the following disclaimer.+2. Redistributions in binary form must reproduce the above copyright+   notice, this list of conditions and the following disclaimer in the+   documentation and/or other materials provided with the distribution.+3. Neither the name of the author nor the names of his contributors+   may be used to endorse or promote products derived from this software+   without specific prior written permission.++THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS ``AS IS'' AND+ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE+IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE+ARE DISCLAIMED.  IN NO EVENT SHALL THE AUTHORS OR CONTRIBUTORS BE LIABLE+FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL+DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS+OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION)+HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT+LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY+OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF+SUCH DAMAGE.

@@ -1,8 +1,8 @@ ---------------------------------------------------------------------------- -- | -- Module      :  CSPM.Interpreter--- Copyright   :  (c) Fontaine 2008--- License     :  BSD+-- Copyright   :  (c) Fontaine 2008 - 2011+-- License     :  BSD3 --  -- Maintainer  :  Fontaine@cs.uni-duesseldorf.de -- Stability   :  experimental@@ -16,13 +16,12 @@ (    runFile   ,evalTest-  ,getAllEvents+  ,getSigma   ,prepareAST   ,runInterpreter   ,runInterpreterP   ,module CSPM.Interpreter.Types   ,module CSPM.Interpreter.Bindings-  ,module CSPM.Interpreter.CoreInstances ) where @@ -30,7 +29,6 @@ import CSPM.Interpreter.CoreInstances () import CSPM.Interpreter.Bindings import CSPM.Interpreter.Eval-import CSPM.Interpreter.Hash (hs) import CSPM.Interpreter.PrepareAST import CSPM.Interpreter.Test.CLI @@ -39,23 +37,20 @@ import Data.IntMap as IntMap  -- | Run the interpreter for a given module and top-level identifier.-runInterpreter :: AST.LModule -> AST.UniqueIdent -> (Value,Env)+runInterpreter :: AST.Module INT -> AST.UniqueIdent -> (Value, Env) runInterpreter ast entry-  = (getLetBindings env IntMap.! AST.uniqueIdentId entry-    ,env)+  = (getLetBindings env IntMap.! AST.uniqueIdentId entry, env)   where -    env = processDeclList (hs "TopLevelEnvirionment") emptyEnvirionment-          $ AST.moduleDecls $ unLabel ast+    env = evalModule ast  -- | Run the interpreter for a given module and top-level identifier. -- Cast result to a process-runInterpreterP :: AST.LModule -> AST.UniqueIdent -> (Process,Env)-runInterpreterP ast entry = case val of-    VProcess x -> (x,env)-    _ -> throwTypingError "entrypoint is not a CSPM-process" (Just $ AST.bindingLoc entry)-           $  Just val-  where-    env = processDeclList (hs "TopLevelEnvirionment") emptyEnvirionment-          $ AST.moduleDecls $ unLabel ast-    val :: Value-    val = (IntMap.!) (getLetBindings env) $ AST.uniqueIdentId entry+runInterpreterP :: AST.Module INT -> AST.UniqueIdent -> (Process, Env)+runInterpreterP ast entry+  = case val of+      VProcess x -> (x, env)+      _ -> throwTypingError+              "entrypoint is not a CSPM-process"+              (Just $ AST.bindingLoc entry)+              (Just val)+  where (val, env) = runInterpreter ast entry

@@ -1,8 +1,8 @@ ---------------------------------------------------------------------------- -- | -- Module      :  CSPM.Interpreter.CoreInstances--- Copyright   :  (c) Fontaine 2008--- License     :  BSD+-- Copyright   :  (c) Fontaine 2008 - 2011+-- License     :  BSD3 --  -- Maintainer  :  Fontaine@cs.uni-duesseldorf.de -- Stability   :  experimental@@ -15,6 +15,7 @@  {-# LANGUAGE StandaloneDeriving, FlexibleInstances, FlexibleContexts #-} {-# LANGUAGE TypeSynonymInstances #-}+{-# OPTIONS_Ghc -fno-warn-orphans #-} module CSPM.Interpreter.CoreInstances ( )@@ -25,17 +26,14 @@ import CSPM.CoreLanguage.Event  import CSPM.Interpreter.Types as Types-import CSPM.Interpreter.Eval as Eval import CSPM.Interpreter.ClosureSet as ClosureSet import CSPM.Interpreter.Renaming as Renaming import CSPM.Interpreter.GenericBufferPrefix as Prefix-import CSPM.Interpreter.SSet (SSet) import qualified CSPM.Interpreter.SSet as SSet  import qualified Data.Set as Set import qualified Data.Map as Map import Data.List as List-import Data.Maybe  deriving instance Show (Core.TTE INT) @@ -77,6 +75,8 @@   getRenamingRange _ty = Set.toList . renamingRange   imageRenaming _ty = Renaming.imageRenaming   preImageRenaming _ty = Renaming.preImageRenaming+  renamingToList = noInstance "BE : renamingToList"+  renamingFromList = noInstance "BE : renamingFromList"   singleEventToClosureSet _ty = ClosureSet.singleEventToClosureSet  instance BF INT where@@ -95,6 +95,7 @@   joinFields  _ty = id   splitFields  _ty = id   channelLen  _ty (VChannel c) = chanLen c+  channelLen  _ty v = error $ "channelLen: Expecting Channel. Found : " ++ show v     closureStateInit _ty c     = ClosureStateNormal {origClosureSet = c ,currentPrefixTrie = closureSetTrie c}@@ -110,11 +111,13 @@       PTMap m -> SSet.Proper $ Map.keysSet m       PTRec s _ -> SSet.Proper s       PTSingle v _ -> SSet.singleton v+      PTNil -> error "viewClosureFields : PTNil not implemented"+      PTClosure {} -> error "viewClosureFields : PTClosure not implemented"   viewClosureState _ty closure = case closure of     ClosureStateNormal {} -> MaybeInClosure     ClosureStateFailed {} -> NotInClosure     ClosureStateSucc   {} -> InClosure-  seenPrefixInClosure ty closure = case closure of+  seenPrefixInClosure _ty closure = case closure of     ClosureStateNormal {} -> True     ClosureStateFailed {} -> False     ClosureStateSucc   {} -> True

@@ -1,7 +1,7 @@ ---------------------------------------------------------------------------- -- | -- Module      :  CSPM.Interpreter.Eval--- Copyright   :  (c) Fontaine 2009+-- Copyright   :  (c) Fontaine 2009 - 2011 -- License     :  BSD --  -- Maintainer  :  Fontaine@cs.uni-duesseldorf.de@@ -16,19 +16,19 @@ module CSPM.Interpreter.Eval (   eval- ,getAllEvents- ,processDeclList  ,runEM+ ,getSigma+ ,evalBool  ,evalOutField  ,evalFieldSet  ,evalProcess+ ,evalModule ) where  import qualified CSPM.CoreLanguage as Core  import Language.CSPM.AST as AST hiding (Bindings)-import qualified Language.CSPM.Frontend as Frontend  import CSPM.Interpreter.Types as Types import CSPM.Interpreter.Bindings as Bindings@@ -43,16 +43,12 @@ import Control.Arrow import Control.Monad.Reader as Reader import Control.Monad.State.Strict-import Control.Monad hiding (guard)-import Data.Ord-import Data.List as List+--import Control.Monad hiding (guard) import qualified Data.Set as Set import Data.Set (Set)-import qualified Data.Map as Map import qualified Data.IntMap as IntMap import Data.IntMap (IntMap) import qualified Data.List as List-import Debug.Trace  -- | Evaluate an expression in an envirionment. runEval :: Env -> AST.LExp -> Value@@ -120,7 +116,8 @@   many prob test contain unboundet INT   IntSet -> return $ VAllInts -}-  IntSet -> return $ VSet $ Set.fromList $ map VInt [0..100]+  IntSet -> return $ VSet $ Set.fromList $ map VInt [0..100] --ToDo: fix this !!+  ProcSet -> throwFeatureNotImplemented "Proc datatype" $ Just $ srcLoc expr   TupleExp l -> mapM eval l >>= return . VTuple   Parens e -> eval e   AndExp a b -> do@@ -134,7 +131,7 @@   Fun2 bi a b -> builtIn2 bi a b   DotTuple l -> mapM eval l >>= return . VDotTuple . concatMap flatTuple     where-      flatTuple (VDotTuple l ) = l+      flatTuple (VDotTuple x ) = x       flatTuple x = [x]   Closure l -> mapM eval l >>= ClosureSet.mkEventClosure >>= return . VClosure   ProcSharing s a b@@ -159,7 +156,7 @@   ProcRenaming rlist gen proc -> do     pairs <- case gen of       Nothing -> mapM evalRenaming rlist-      Just gen -> evalListComp (mapM evalRenaming rlist ) $ unLabel gen+      Just gens -> evalListComp (mapM evalRenaming rlist ) $ unLabel gens     p <- switchedOffProc proc     return $ VProcess $ Core.renaming (toRenaming pairs) p     where@@ -197,7 +194,7 @@        ,prefixPatternFailed = False      }       where chanOut = setNode chan $ OutComm chan-  ExprWithFreeNames body en+  ExprWithFreeNames {}     -> throwInternalError "didn't expect ExprWithFreeNames" (Just $ srcLoc expr) Nothing   _ -> throwFeatureNotImplemented "hit catch-all case of eval function"          $ Just $ srcLoc expr @@ -284,10 +281,6 @@ listFromValue (VList l) = return l listFromValue v = throwTypingError "expecting type List" Nothing $ Just v -processFromValue :: Value -> EM Process-processFromValue (VProcess p) = return p-processFromValue v = throwTypingError "expecting type Process" Nothing $ Just v- builtIn1 :: LBuiltIn -> LExp -> EM Value builtIn1 op expr    = case lBuiltInToConst op of@@ -331,7 +324,7 @@       l <- evalList expr       return $ VBool (List.null l)     F_CHAOS -> liftM (VProcess . Core.chaos) $ evalClosureExp expr-    c -> throwInternalError "malformed AST1" (Just $ srcLoc expr) Nothing+    _ -> throwInternalError "malformed AST1" (Just $ srcLoc expr) Nothing  builtIn2 :: LBuiltIn -> LExp -> LExp -> EM Value builtIn2 op a b =@@ -392,7 +385,7 @@       cond <- evalBool a       if cond then liftM VProcess $ switchedOffProc b               else return $ VProcess Core.stop-    c -> throwInternalError "malformed AST2" Nothing Nothing+    _ -> throwInternalError "malformed AST2"  (Just $ srcLoc op) Nothing   where     intOp :: (Integer -> Integer -> Integer) -> EM Value     intOp o = do@@ -415,6 +408,12 @@       y <- switchedOffProc b       return $ VProcess $ o x y +-- | A process a module and return the top-level envirionment+evalModule :: Module INT -> Env+evalModule m+  = processDeclList (hs "TopLevelEnvirionment") emptyEnvirionment+      $ AST.moduleDecls m+ type DeclM x = ReaderT (Digest,Env) (State (Bindings, IntMap Digest)) x  processDeclList :: Digest -> Env -> [LDecl] -> Env@@ -451,12 +450,14 @@         bindIdentM i $ VFun $ FunClosure {           getFunCases = cases           ,getFunEnv = finalEnv-         ,getFunArgNum = length $ (\(FunCaseI pl _) -> pl) $ head cases+         ,getFunArgNum = length $ casePattern $ head cases          ,getFunId  = mixInt digest $ AST.unNodeId $ AST.nodeId decl          }-  -- Just Ignore-    AssertRef _ _ _  -> return ()-    AssertBool _ -> return ()+        where+          casePattern (FunCaseI pl _ ) = pl+          casePattern _ = throwInternalError "unexpected FunCase in AST" +                             (Just $ srcLoc i) Nothing+    Assert {} -> return ()     Transparent names ->  forM_ names $ \n -> bindIdentM n cspIdentityFunction     SubType _ _ -> throwFeatureNotImplemented "subtype declarations" $ Just $ srcLoc decl     DataType tname constrList -> do@@ -473,9 +474,9 @@              ,chanName = AST.realName $ AST.unUIdent $ AST.unLabel i              ,chanLen = case t of                 Nothing -> 1-                Just t -> case unLabel t of-                  TypeTuple l -> 2-                  TypeDot l  -> length l +1+                Just ty -> case unLabel ty of+                  TypeTuple _l -> 2+                  TypeDot l  -> length l+1              ,chanFields = case t of                 Nothing -> []                 Just l -> runEnv finalEnv $ evalTypeDef l@@ -525,8 +526,8 @@    ,switchedOffExpr = expr    ,switchedOffProcess = runEM (evalProcess expr) env    }-switchedOffProc exp- = throwInternalError "cannot determine free variables" (Just $ srcLoc exp) Nothing+switchedOffProc expr+ = throwInternalError "cannot determine free variables" (Just $ srcLoc expr) Nothing  evalOutField :: LExp -> EM Field evalOutField expr = do@@ -623,8 +624,8 @@   channels <- lookupAllChannels   ClosureSet.mkEventClosure $ map VChannel channels -getAllEvents :: Env -> ClosureSet-getAllEvents = runEM evalAllEvents+getSigma :: Env -> Sigma+getSigma = runEM evalAllEvents  cspIdentityFunction :: Value cspIdentityFunction = VFun $ FunClosure {

@@ -1,8 +1,8 @@ ---------------------------------------------------------------------------- -- | -- Module      :  CSPM.Interpreter.GenricBufferPrefix--- Copyright   :  (c) Fontaine 2009--- License     :  BSD+-- Copyright   :  (c) Fontaine 2009 - 2011+-- License     :  BSD3 --  -- Maintainer  :  Fontaine@cs.uni-duesseldorf.de -- Stability   :  experimental@@ -27,9 +27,6 @@ import Language.CSPM.AST as AST hiding (Bindings)  import CSPM.Interpreter.Types as Types-import CSPM.Interpreter.Bindings as Bindings-import CSPM.Interpreter.PatternMatcher-import CSPM.Interpreter.Eval import qualified CSPM.Interpreter.Prefix as BasePrefix import CSPM.Interpreter.SSet as SSet 

@@ -12,6 +12,7 @@ -- ---------------------------------------------------------------------------- {-# LANGUAGE TypeSynonymInstances,FlexibleInstances #-}+{-# OPTIONS_GHC -fno-warn-orphans #-}  module CSPM.Interpreter.Hash (@@ -29,7 +30,6 @@  import qualified Language.CSPM.AST as AST import CSPM.Interpreter.Types as Types-import CSPM.Interpreter.SSet  import Data.Digest.Pure.HashMD5 import Data.Digest.Pure.MD5@@ -121,6 +121,7 @@   Renaming r p -> mix3 (hs "Renaming") (hash r) (hash p)   Chaos c -> mix (hs "Chaos") $ hash c   LinkParallel c p q -> mix (hs "LinkParallel") $ mix3 (hash c) (hash p) (hash q)+  Exception c p q -> mix (hs "Exception") $ mix3 (hash c) (hash p) (hash q)  instance Hash Types.Process where hash = hashProcess instance Hash PrefixState where hash = prefixDigest@@ -130,12 +131,13 @@ instance Hash Constructor where hash c = mixInt (hs "Constructor") $ constrId c instance Hash FunClosure where hash = getFunId -+{- hashEventSlice :: SSet Event -> Digest hashEventSlice x = case x of   Total -> hs "EventSlice Total"   Empty -> hs "EventSlice Empty"   (Proper x) -> foldHash (hs "EventSlice") $ Set.elems x+-}  instance Hash PrefixTrie where   hash p = case p of@@ -144,3 +146,4 @@     PTMap l -> foldHash (hs "PTMap") $ Map.assocs l     PTRec s t -> mix (hs "PRRec") $ foldHash (hash t) $ Set.toList s     PTClosure t -> mix (hs "PTClosure") $ hash t+    PTSingle v t -> mix3 (hs "PTSingle") (hash v) (hash t)

@@ -0,0 +1,162 @@+-----------------------------------------------------------------------------+-- |+-- Module      :  CSPM.Interpreter.PatternCompiler+-- Copyright   :  (c) Fontaine 2008 - 2011+-- License     :  BSD3+--+-- Maintainer  :  fontaine@cs.uni-duesseldorf.de+-- Stability   :  experimental+-- Portability :  GHC-only+--+-- replace nested patterns with a set of linear Selectors+-- todo : benchmark if it pays off to introduce+-- helperbindings and only atomic bindings (unlikely)+-- todo : add testcases+{-# LANGUAGE ViewPatterns #-}++module CSPM.Interpreter.PatternCompiler+  (+  compilePattern+  )+where++import Language.CSPM.Frontend (ModuleFromRenaming)+import Language.CSPM.AST as AST+import CSPM.Interpreter.Types (INT)++import Control.Monad+import Data.Generics.Schemes (everywhere')+import Data.Generics.Aliases (mkT)+import Data.Array.IArray++-- | replace all pattern in the module with list of linear Selectors+compilePattern :: ModuleFromRenaming -> Module INT+compilePattern ast+  = castModule $ Data.Generics.Schemes.everywhere' (Data.Generics.Aliases.mkT compPat) ast+  where+-- pattern that consist only of a variable match remain unchanged+    compPat :: LPattern -> LPattern+    compPat x@(unLabel -> VarPat {}) = x+    compPat pat = case cp id pat of+       [(i,s)] -> setNode pat $ Selector s i+       x -> setNode pat $ Selectors {+--        origPat = pat+                    selectors = listToArr $ map snd x+                   ,idents = listToArr $ map fst x+                   }++    listToArr :: [a] -> Array Int a+    listToArr l = array (0,length l -1) $ zip [0..] l++    cp :: (Selector -> Selector ) -> LPattern -> [(Maybe LIdent,Selector)]+    cp path pat = case unLabel pat of+      IntPat i -> return (Nothing, path $ IntSel i)+      TruePat  -> return (Nothing, path TrueSel )+      FalsePat -> return (Nothing, path FalseSel )+      WildCard -> return (Nothing, path SelectThis )+      VarPat x -> return (Just x , path SelectThis )+      ConstrPat x -> return (Nothing, path $ ConstrSel $ unUIdent $ unLabel x)+      Also l -> concatMap (cp path) l+      Append l -> do+        let (prefix,suffix,variable) = analyzeAppendPattern l+        msum [ concatMap (mkListPrefixPat path) prefix+             , mkListVariablePat path variable+             , concatMap (mkListSuffixPat path) suffix ]+      DotPat l -> msum $ map+          (\(x,i) -> cp (path . DotSel i) x)+          (zip l [0..])+      SingleSetPat p -> cp (path . SingleSetSel) p+      EmptySetPat -> return (Nothing, path EmptySetSel)+      ListEnumPat [] -> return (Nothing, path $ ListLengthSel 0 $ SelectThis )+      ListEnumPat l -> do+        let len = length l+        msum $ map+          (\(x,i) -> cp (path . ListLengthSel len . ListIthSel i) x)+          (zip l [0..])+      TuplePat [] -> return (Nothing, path $ TupleLengthSel 0 $ SelectThis )+      TuplePat l -> do+        let len = length l+        msum $ map+          (\(x,i) -> cp (path . TupleLengthSel len . TupleIthSel i) x)+          (zip l [0..])+      Selector {} -> error "PatternCompiler.hs : didn't expect Selector"+      Selectors {} -> error "PatternCompiler.hs : didn't expect Selectors"++    mkListPrefixPat ::+         (Selector -> Selector )+      -> (Offset, Len, LPattern)+      -> [(Maybe LIdent, Selector)]+    mkListPrefixPat path l = case l of+      (0,1,pat) -> let (unLabel -> ListEnumPat [r]) = pat+                   in cp (path . HeadSel) r+      (0,n,pat) -> cp (path . HeadNSel n) pat+      (o,s,pat) -> cp (path . PrefixSel o s) pat++    mkListSuffixPat ::+         (Selector -> Selector) +      -> (Offset, Len, LPattern)+      -> [(Maybe LIdent, Selector)]+    mkListSuffixPat path (o,l,pat)+      = cp (path . SuffixSel o l) pat++    mkListVariablePat ::+         (Selector -> Selector)+      -> Maybe (Offset, Offset, LPattern)+      -> [(Maybe LIdent, Selector)]+    mkListVariablePat _path Nothing = []+    mkListVariablePat path (Just (l,r,pat)) = cp (path . SliceSel l r) pat++type Offset = Int+type Len    = Int+analyzeAppendPattern ::+  [LPattern] ->+    ([(Offset,Len,LPattern)] --  prefixpattern+    ,[(Offset,Len,LPattern)] --  suffixpattern+    ,Maybe (Offset,Offset,LPattern)+    )+analyzeAppendPattern pl+  = let+    taggedPatList = zip pl $ map lengthOfListPattern pl+    prefixPat = computePrefixPattern taggedPatList+    suffixPat = computeSuffixPattern taggedPatList+    lenPrefix = sum $ map (\(_,l,_)-> l) prefixPat+    lenSuffix = sum $ map (\(_,l,_)-> l) suffixPat+    varPat = case filter (\(_,len) -> len == Nothing) taggedPatList of+              [] -> Nothing+              [(pat,_)] -> Just (lenPrefix,lenSuffix,pat)+              l -> error $ "PatternCompiler.hs : alsopattern contains multiple "+                   ++ "variable length pattern "+                   ++ show l+  in+    (prefixPat,suffixPat,varPat)+  where+{-  compute the length of a list pattern+    Just Int -> fixed length pattern+    Nothing -> variable length pattern -}++    lengthOfListPattern :: LPattern -> Maybe Len+    lengthOfListPattern p = case unLabel p of+      ListEnumPat l -> return $ length l+      Append patl -> do+        l <- mapM lengthOfListPattern patl+        return $ sum l+      VarPat _ -> Nothing+      Also patl -> do+        let l = map lengthOfListPattern patl+        -- todo: check that all length are equal:+        error "PatternCompiler.hs: lengthOfListPat : also pattern: todo"+      _ -> error $ "PatternCompiler.hs: lengthOfListPat : no list pattern "+                    ++ show p+{-+PrefixPattern are fixed-length pattern with a fixed offset from the front+return when the first variable length pattern occurs+-}+    computePrefixPattern :: [(LPattern,Maybe Len)] -> [(Offset,Len,LPattern)]+    computePrefixPattern l = worker 0 l where+      worker _      [] = []+      worker _      ((_ ,Nothing ) : _) = []+      worker offset ((pat,Just len): rest)+        = (offset,len,pat) : worker (offset+len) rest++    computeSuffixPattern :: [(LPattern,Maybe Len)] -> [(Offset,Len,LPattern)]+    computeSuffixPattern = computePrefixPattern . reverse

@@ -32,7 +32,6 @@  import Data.Maybe import qualified Data.Set as Set-import Control.Exception import Data.Array.IArray as Array import qualified Data.List as List @@ -44,7 +43,10 @@  -- todo make match strict !BangPattern match :: Value -> Selector -> Maybe Value+match x SelectThis = return x+ match (VInt a) (IntSel b) = if a==b then return VUnit else failedMatch+match v@(VInt _) _ = typeError "unexpected Int" v match v        (IntSel _) = typeError "expecting Int" v  match (VBool True)  TrueSel = return VUnit@@ -54,8 +56,7 @@ match (VBool True)  FalseSel = failedMatch match (VBool False) FalseSel = return VUnit match v             FalseSel = typeError "expecting Bool" v--match x             SelectThis = return x+match v@(VBool _) _ = typeError "unexpected Bool" v  match (VChannel ch)  (ConstrSel ident)   = if AST.uniqueIdentId ident == chanId ch then return VUnit else failedMatch@@ -65,7 +66,9 @@ --  | DotSel Int Int Selector  match (VSet s)      (SingleSetSel b)-  = if not $ Set.null s then match (Set.findMin s) b else failedMatch+  = case Set.toList s of+      [e] -> match e b+      _ -> failedMatch match v             (SingleSetSel _) = typeError "expecting a set" v  match (VSet s)      EmptySetSel@@ -73,65 +76,65 @@ match v             EmptySetSel    = typeError "expecting a set" v  -- todo : really test this-match (VList l) p = case p of+match val@(VList l) p = case p of   ListIthSel i next -> match (l !! i) next   ListLengthSel 0 _next     -> if null l then return VUnit else failedMatch   ListLengthSel len next-    -> if length l == len then matchList len l next else failedMatch-  _ -> matchList (length l) l p-+    -> if length l == len then match val next else failedMatch+  HeadSel next+    -> if null l then failedMatch else match (head l) next+  HeadNSel len next -> do+    e <- saveTake len l+    match (VList e) next+  PrefixSel offset len next -> do+    e <- saveDrop offset l >>= saveTake len+    match (VList e) next+  TailSel next +    -> if not $ null l then match (VList $ tail l) next else failedMatch+  SliceSel offsetL 0 next -> do+    e <- saveDrop offsetL l+    match (VList e) next+  SliceSel offsetL offsetR next -> do+    e <- saveDrop offsetL l+    let len = length e+    if len >= offsetR+       then match (VList $ take (len-offsetR) e) next+       else failedMatch+  SuffixSel offset len next -> do+    let s = length l+    if s >= offset + len+       then match (VList $ take len $ drop (s - offset - len) l) next+       else failedMatch+  other -> typeError ("matchList : not excpecting a List :" ++ show other) val  match t@(VTuple b)  (TupleLengthSel len next)   = if length b == len then match t next else typeError "tuple wrong arity" t-match v             (TupleLengthSel _ n) = typeError "expecting tuple" v+match v             (TupleLengthSel _ _) = typeError "expecting tuple" v  match (VTuple b)    (TupleIthSel i next) = match (b !! i) next-match v             (TupleIthSel _ n) = typeError "expecting tuple" v+match v             (TupleIthSel _ _) = typeError "expecting tuple" v  match (VDotTuple l) (DotSel i next) = match (l !! i) next match v             (DotSel _ _) = typeError "expecting dot-tuple" v  match v p-  = throwInternalError ("hit catchall case of pattern-matcher :" ++ show (v,p))+  = throwInternalError ("hit catch-all case of pattern-matcher :" ++ show (v,p))       Nothing $ Just v -matchList :: Int -> [Value] -> Selector -> Maybe Value-matchList s !l !sel = case sel of-  SelectThis -> return $ VList l-  HeadSel next-    -> if null l then failedMatch else match (head l) next-  HeadNSel len next-    -> if s >= len-         then matchList len (take len l) next-         else failedMatch-  PrefixSel offset len next-    -> if s >= offset + len-         then matchList len (take len $ drop offset l) next-         else failedMatch-  TailSel next -    -> if not $ null l then matchList (s-1) (tail l) next else failedMatch-  SliceSel offsetL offsetR next-    -> if s >= offsetL + offsetR-         then-           let-             newLen = s - offsetL -offsetR -           in matchList newLen (take newLen $ drop offsetL l) next              -         else failedMatch-  SuffixSel offset len next-    -> if s >= offset + len-         then -           let-             offsetLeft = s - offset - len-           in matchList len (take len $ drop offsetLeft l) next-         else failedMatch-  ListLengthSel len next-    -> if s == len then matchList s l next else failedMatch-  ListIthSel i next -> match (l !! i) next-  other -> throwTypingError ("matchList : not excpecting a List :" ++ show other)-    Nothing (Just $ VList l) +saveDrop :: Int -> [a] -> Maybe [a]+saveDrop 0 l     = Just l+saveDrop _ []    = Nothing+saveDrop n (_:r) = saveDrop (n-1) r +saveTake :: Int -> [a] -> Maybe [a]+saveTake 0 _ = Just []+saveTake _ [] = Nothing+saveTake n (h:t) = do+  l <- saveTake (n-1) t+  Just $ h:l+ {- If we force the result we first force the value we match against and then we check all selectors !@@ -173,7 +176,7 @@ -}  tryMatchLazy :: Bindings -> LPattern -> Value -> Bindings-tryMatchLazy binds p@(unLabel -> VarPat ident) val+tryMatchLazy binds (unLabel -> VarPat ident) val   = bindIdent ident val binds tryMatchLazy binds p@(unLabel -> Selector sel ident) val   = case ident of@@ -215,3 +218,5 @@   Selector _ Nothing -> []   Selector _ (Just i) -> [i]   x@(Selectors {}) -> catMaybes $ Array.elems $ idents x+  _ -> throwInternalError "PatternMatcher : unexpected Pattern"+         (Just $ srcLoc pat) $ Nothing

@@ -1,8 +1,8 @@ ---------------------------------------------------------------------------- -- | -- Module      :  CSPM.Interpreter.Prefix--- Copyright   :  (c) Fontaine 2009--- License     :  BSD+-- Copyright   :  (c) Fontaine 2009 - 2011+-- License     :  BSD3 --  -- Maintainer  :  Fontaine@cs.uni-duesseldorf.de -- Stability   :  experimental@@ -23,16 +23,13 @@ where  import CSPM.Interpreter.Types as Types-import CSPM.Interpreter.Bindings as Bindings import CSPM.Interpreter.PatternMatcher import CSPM.Interpreter.Eval-import CSPM.Interpreter.SSet as SSet  import qualified CSPM.CoreLanguage as Core import Language.CSPM.AST as AST hiding (Bindings)  import Data.List as List-import Control.Monad  initPrefix :: PrefixState -> PrefixState initPrefix = id@@ -45,25 +42,25 @@   = throwScriptError "viewPrefixState: no fields" Nothing Nothing viewPrefixState p = case viewNextPrefixField p of   OutComm out -> Core.FieldOut $ runEM (evalOutField out) env-  InComm pat -> Core.FieldIn+  InComm _pat -> Core.FieldIn   InCommGuarded _pat g -> Core.FieldGuard $ runEM (evalFieldSet g) env   where env = prefixEnv p  prefixStateNext :: PrefixState -> Field -> Maybe PrefixState-prefixStateNext p field | List.null $ prefixFields p+prefixStateNext p _field | List.null $ prefixFields p   = throwScriptError "prefixStateNext no fields" Nothing Nothing prefixStateNext p field = case viewNextPrefixField p of {- todo ::   we must check that the Field is OK here   we should use the lookahead scheme of the GenericBufferPrefix -}-  OutComm out -> return $ p { prefixFields = tail $ prefixFields p }+  OutComm _out -> return $ p { prefixFields = tail $ prefixFields p }   InComm pat -> prefixBindInput field pat-  InCommGuarded pat g -> prefixBindInput field pat+  InCommGuarded pat _g -> prefixBindInput field pat   where     env = prefixEnv p-    prefixBindInput field pat = do-      newBinds <- tryMatchStrict (argBindings env) pat field+    prefixBindInput f pat = do+      newBinds <- tryMatchStrict (argBindings env) pat f       return p {            prefixFields = tail $ prefixFields p           ,prefixEnv = setArgBindings env newBinds }

@@ -1,7 +1,7 @@ ---------------------------------------------------------------------------- -- | -- Module      :  CSPM.Interpreter.PrepareAST--- Copyright   :  (c) Fontaine 2008+-- Copyright   :  (c) Fontaine 2008-2011 -- License     :  BSD --  -- Maintainer  :  Fontaine@cs.uni-duesseldorf.de@@ -21,20 +21,24 @@  import Language.CSPM.AST as AST import qualified Language.CSPM.Frontend as Frontend+import CSPM.Interpreter.Types (INT)+import CSPM.Interpreter.PatternCompiler (compilePattern)  import Data.Generics.Schemes (everywhere) import Data.Generics.Aliases (mkT) import Data.Generics.Basics (Data) -prepareAST :: LModule -> LModule-prepareAST ast = replaceFunCase $ addFreeNames ast+type IModule = Frontend.ModuleFromRenaming++prepareAST :: Frontend.ModuleFromRenaming -> Module INT+prepareAST = compilePattern . replaceFunCase . addFreeNames {- ReplaceFunCase with funCaseNew. This is a quickfix In CSPM Syntax we have tree cases: fun(x)(y) fun(x,y) and fun((x,y)) we want to map them to : fun x y and fun (x,y) in Haskell-Syntax. -}-replaceFunCase :: LModule -> LModule+replaceFunCase :: IModule -> IModule replaceFunCase ast = everywhere (mkT compFC) ast   where     compFC :: FunCase -> FunCase@@ -54,7 +58,7 @@ -- | Perform a freename analyzis for the body of prefixOperations -- | and expressions that can become process-closures. -- | This is ugly !!.-addFreeNames :: LModule -> LModule+addFreeNames :: IModule -> IModule addFreeNames ast = everywhere trans ast   where     trans :: Data a => a-> a

@@ -24,7 +24,6 @@ import qualified Data.List as List import Data.Set (Set) import qualified Data.Set as Set-import qualified Data.Map as Map  {- todo speedup using hashing -} toRenaming :: [(Value,Value)]-> RenamingRelation

@@ -1,8 +1,8 @@ ---------------------------------------------------------------------------- -- | -- Module      :  CSPM.Interpreter.Test.CLI--- Copyright   :  (c) Fontaine 2008--- License     :  BSD+-- Copyright   :  (c) Fontaine 2008 - 2011+-- License     :  BSD3 --  -- Maintainer  :  Fontaine@cs.uni-duesseldorf.de -- Stability   :  experimental@@ -37,17 +37,15 @@ import Language.CSPM.Frontend import qualified Language.CSPM.AST as AST -import CSPM.Interpreter.Eval import qualified CSPM.Interpreter.Types as Types-import CSPM.Interpreter.Types-  (Value,emptyEnvirionment,getLetBindings)+import CSPM.Interpreter.Eval+import CSPM.Interpreter.Types (Value) import CSPM.Interpreter.PrepareAST (prepareAST)-import CSPM.Interpreter.Hash import CSPM.Interpreter.CoreInstances ()  import System.Exit import System.CPUTime-import Control.Exception (evaluate)+import Control.Exception.Base (evaluate) import Control.Monad import qualified Data.IntMap as IntMap import qualified Data.Map as Map@@ -55,7 +53,10 @@  -- | Load a specification from a file and evaluate an expression in the context. -- Print the result to 'stdout' and handle some exceptions.-runFile :: FilePath -> String -> IO ()+runFile ::+     FilePath -- ^ a file containing a CSPM specification+  -> String  -- ^ a CSPM expression+  -> IO () runFile fileName expr   = handleLexError lexErrorHandler       $ handleParseError parseErrorHandler@@ -66,13 +67,20 @@     exitSuccess  -- | Load a specification from a file and evaluate an expression in the context.-evalTest :: FilePath -> String -> IO Value+evalTest ::+     FilePath -- ^ CSPM specification+  -> String -- ^ a CSPM expression+  -> IO Value -- ^ the result evalTest fileName expr = liftM fst $ evalEnv False (Just fileName) expr  {- Todo: clean up the mess below -}  -- | Evaluate an expression in an optional context.-evalEnv :: Bool -> Maybe FilePath -> String -> IO (Value,Types.Env)+evalEnv ::+     Bool -- ^ verbose output ?+  -> Maybe FilePath -- ^ optional specification to load into context+  -> String -- ^ a CSPM expression+  -> IO (Value, Types.Env) evalEnv verbose context expr = do   srcPlain <- case context of     Just path -> readFile path@@ -93,9 +101,8 @@   ast <- eitherToExc $ parse fileName tokenList   _time_have_ast <- getCPUTime -  renaming <- eitherToExc $ getRenaming ast-  let astNew = prepareAST $ applyRenaming renaming ast-  case astNew of Labeled {} -> return () -- force astNew ?+  (renamedAst, renaming) <- eitherToExc $ renameModule ast+  astNew <- evaluate $ prepareAST renamedAst   _time_have_renaming <- getCPUTime  --  putStrLn $ "Parsing OK"@@ -107,13 +114,10 @@   time_start_execute <- getCPUTime   let     entry :: AST.UniqueIdent-    entry = fromJust $ Map.lookup "test__entry" $ (\(x,_,_) -> x) renaming-    astP :: LModule-    astP = compilePattern astNew-    env = processDeclList (hs "TopLevelEnvirionment") emptyEnvirionment-          $ AST.moduleDecls $ unLabel astP+    entry = fromJust $ Map.lookup "test__entry" $ visible renaming+    env = evalModule astNew     val :: Value-    val = (IntMap.!) (getLetBindings env) $ AST.uniqueIdentId entry+    val = (IntMap.!) (Types.getLetBindings env) $ AST.uniqueIdentId entry   when verbose $ do      putStrLn $ "eval result         : " ++ show val      time_finish_execute <- getCPUTime

@@ -17,6 +17,7 @@ {-# LANGUAGE EmptyDataDecls #-} {-# LANGUAGE GeneralizedNewtypeDeriving #-} {-# LANGUAGE StandaloneDeriving #-}+{-# LANGUAGE DeriveDataTypeable #-}  module CSPM.Interpreter.Types where@@ -56,6 +57,7 @@ type instance Core.Prefix INT = PrefixState -- type instance CoreField.PrefixState INT = PrefixState type instance Core.PrefixState INT = GenericBufferPrefix+type Sigma = ClosureSet  deriving instance Eq Process deriving instance Ord Process@@ -229,7 +231,12 @@    constrId ::Int   ,constrName :: String   ,constrFields :: [FieldSet]-  } deriving (Show,Eq,Ord)+  } deriving (Show)++instance Eq Constructor where+  a == b = constrId a == constrId b+instance Ord Constructor where+  compare a b = compare (constrId a) (constrId b)  data Channel = Channel   {

@@ -28,6 +28,14 @@ import Data.Char  {-# INLINE mix5 #-}+mix5 ::+     MD5Digest+  -> MD5Digest+  -> MD5Digest+  -> MD5Digest+  -> MD5Digest+  -> MD5Digest+ mix5 a (MD5Digest w0 w1 w2 w3) (MD5Digest w4 w5 w6 w7)   (MD5Digest w8 w9 w10 w11) (MD5Digest w12 w13 w14 w15)   = mixRaw a w0 w1 w2 w3 w4 w5 w6 w7 w8 w9 w10 w11 w12 w13 w14 w15

@@ -20,10 +20,8 @@         , md5Init         ) where -import Data.List import Data.Word import Data.Bits-import Numeric  data MD5Digest = MD5Digest !Word32 !Word32 !Word32 !Word32     deriving (Ord, Eq)@@ -45,17 +43,17 @@     -> Word32 -> Word32 -> Word32 -> Word32     -> MD5Digest applyMD5RoundsRaw-    (MD5Digest a b c d)+    (MD5Digest da db dc dd)     !w0 !w1 !w2 !w3      !w4 !w5 !w6 !w7     !w8 !w9 !w10 !w11      !w12 !w13 !w14 !w15     =  {-# SCC "applyMD5RoundsRaw" #-}         let -- Round 1-            !r0  = ff  a  b  c  d   w0  7  3614090360-            !r1  = ff  d r0  b  c   w1  12 3905402710-            !r2  = ff  c r1 r0  b   w2  17 606105819-            !r3  = ff  b r2 r1 r0   w3  22 3250441966+            !r0  = ff da dd dc dd   w0  7  3614090360+            !r1  = ff dd r0 db dc   w1  12 3905402710+            !r2  = ff dc r1 r0 db   w2  17 606105819+            !r3  = ff db r2 r1 r0   w3  22 3250441966             !r4  = ff r0 r3 r2 r1   w4  7  4118548399             !r5  = ff r1 r4 r3 r2   w5  12 1200080426             !r6  = ff r2 r5 r4 r3   w6  17 2821735955@@ -150,11 +148,6 @@                 in a'' + b         {-# INLINE ii #-} --infix 9 .<.-(.<.) :: Word8 -> Int -> Word32-(.<.) w i = (fromIntegral w) `shiftL` i- -- | mix one Digest and 16 words by applying the md5-rounds mixRaw ::        MD5Digest@@ -173,6 +166,6 @@   show (MD5Digest a b c d) = "HashMD5_"++ toHex a ++ toHex b ++ toHex c ++ toHex d     where       toHex :: Integral a => a -> String-      toHex a = reverse $ take 8 $ hex a where+      toHex x = reverse $ take 8 $ hex x where       hex x = (digits !! (fromIntegral (x `mod` 16))) : hex ( x `div` 16)       digits = "0123456789ABCDEF"