From d4a119ecf42ec56df597b296f05a09f050b5cf9d Mon Sep 17 00:00:00 2001 From: Neil Brown Date: Mon, 13 Apr 2009 14:57:03 +0000 Subject: [PATCH] Added lexing, parsing and type-checking support for FORKING and FORK --- common/ShowCode.hs | 6 +++++- common/Types.hs | 1 + frontends/LexOccam.x | 2 +- frontends/OccamTypes.hs | 2 ++ frontends/ParseOccam.hs | 40 ++++++++++++++++++++++++++++++++-------- 5 files changed, 41 insertions(+), 10 deletions(-) diff --git a/common/ShowCode.hs b/common/ShowCode.hs index 85b24e7..9dcbeb8 100644 --- a/common/ShowCode.hs +++ b/common/ShowCode.hs @@ -241,7 +241,6 @@ instance ShowOccam A.Type where showOccamM A.Any = tell ["ANY"] showOccamM (A.Timer _) = tell ["TIMER"] showOccamM A.Time = tell ["TIME"] - showOccamM A.Infer = tell ["inferred-type"] showOccamM (A.UnknownVarType _ en) = do tell ["(inferred type for: "] either showName (tell . (:[]) . show) en @@ -472,6 +471,8 @@ instance ShowOccam A.Specification where = showOccamLine $ (maybeVal am) >> showOccamM t >> space >> showName n >> tell [" IS "] >> showOccamM v >> colon showOccamM (A.Specification _ n (A.DataType _ t)) = showOccamLine $ tell ["DATA TYPE "] >> showName n >> tell [" IS "] >> showOccamM t >> colon + showOccamM (A.Specification _ n (A.Forking _)) + = showOccamLine $ tell ["FORKING --"] >> showName n showOccamM (A.Specification _ n (A.RecordType _ attr fields)) = do (showOccamLine $ tell ["DATA TYPE "] >> showName n) occamIndent @@ -624,6 +625,9 @@ instance ShowOccam A.Process where --TODO gettime and wait ? showOccamM (A.ProcCall _ n params) = showOccamLine $ showName n >> tell [" ( "] >> showWithCommas params >> tell [" ) "] + showOccamM (A.Fork _ Nothing p) = showOccamLine $ tell ["FORK "] >> showOccamM p + showOccamM (A.Fork _ (Just n) p) = showOccamLine $ tell ["FORK "] >> showOccamM p + >> tell [" --"] >> showName n showOccamM (A.IntrinsicProcCall _ n params) = showOccamLine $ tell [n, " ( "] >> showWithCommas params >> tell [" ) "] showOccamM (A.While _ e p) = (showOccamLine $ tell ["WHILE "] >> showOccamM e) >> occamIndent >> showOccamM p >> occamOutdent showOccamM (A.Case _ e s) = (showOccamLine $ tell ["CASE "] >> showOccamM e) >> occamBlock (showOccamM s) diff --git a/common/Types.hs b/common/Types.hs index 1daf5c0..b344003 100644 --- a/common/Types.hs +++ b/common/Types.hs @@ -127,6 +127,7 @@ typeOfSpec' st A.List t' -> return $ Just (t', error "typeOfSpec'") A.Array _ t' -> return $ Just (t', error "typeOfSpec'") _ -> return Nothing + A.Forking m -> return $ Just (A.Barrier, const $ A.Forking m) _ -> return Nothing typeOfSpec :: (CSMR m, Die m) => A.SpecType -> m (Maybe A.Type) diff --git a/frontends/LexOccam.x b/frontends/LexOccam.x index 8860b0f..101c577 100644 --- a/frontends/LexOccam.x +++ b/frontends/LexOccam.x @@ -60,7 +60,7 @@ $vertSpace = [\r\n] | "CASE" | "CHAN" | "CLAIM" | "CLONE" | "DATA" | "DEFINED" | "ELSE" - | "FALSE" | "FOR" | "FROM" | "FUNCTION" + | "FALSE" | "FOR" | "FORK" | "FORKING" | "FROM" | "FUNCTION" | "IF" | "IN" | "INITIAL" | "INLINE" | "INT" | "INT16" | "INT32" | "INT64" | "IS" | "MINUS" | "MOBILE" | "MOSTNEG" | "MOSTPOS" diff --git a/frontends/OccamTypes.hs b/frontends/OccamTypes.hs index 96e841d..410b0b6 100644 --- a/frontends/OccamTypes.hs +++ b/frontends/OccamTypes.hs @@ -1414,6 +1414,7 @@ checkSpecTypes = checkDepthM doSpecType doSpecType :: Check A.SpecType doSpecType (A.Place _ e) = checkExpressionInt e doSpecType (A.Declaration _ _) = ok + doSpecType (A.Forking _) = ok doSpecType (A.Is m am t (A.ActualVariable v)) = do tv <- astTypeOf v checkType (findMeta v) t tv @@ -1564,6 +1565,7 @@ checkProcesses = checkDepthM doProcess doProcess (A.ProcCall m n as) = do fs <- checkProc m n checkActuals m n fs as + doProcess (A.Fork _ _ p) = doProcess p doProcess (A.IntrinsicProcCall m n as) = case lookup n intrinsicProcs of Just args -> diff --git a/frontends/ParseOccam.hs b/frontends/ParseOccam.hs index 9ca0f1d..ed10dc5 100644 --- a/frontends/ParseOccam.hs +++ b/frontends/ParseOccam.hs @@ -140,14 +140,13 @@ sSemi = reserved ";" sAFTER, sALT, sAND, sANY, sAT, sBITAND, sBITNOT, sBITOR, sBOOL, sBYTE, sBYTESIN, sCASE, sCHAN, sCLAIM, sCLONE, sDATA, sDEFINED, sELSE, sFALSE, - sFOR, sFROM, sFUNCTION, sIF, sINLINE, sIN, sINITIAL, sINT, sINT16, sINT32, - sINT64, sIS, sMINUS, sMOBILE, sMOSTNEG, sMOSTPOS, sNOT, sOF, sOFFSETOF, sOR, - sPACKED, sPAR, sPLACE, sPLACED, sPLUS, sPORT, sPRI, sPROC, sPROCESSOR, - sPROTOCOL, sREAL32, sREAL64, sRECORD, sREC_RECURSIVE, sREM, sRESHAPES, - sRESULT, sRETYPES, sROUND, sSEQ, sSHARED, sSIZE, sSKIP, sSTEP, sSTOP, - sTIMER, sTIMES, sTRUE, sTRUNC, sTYPE, sVAL, sVALOF, sWHILE, sWORKSPACE, - sVECSPACE - :: OccParser () + sFOR, sFORK, sFORKING, sFROM, sFUNCTION, sIF, sINLINE, sIN, sINITIAL, sINT, + sINT16, sINT32, sINT64, sIS, sMINUS, sMOBILE, sMOSTNEG, sMOSTPOS, sNOT, sOF, + sOFFSETOF, sOR, sPACKED, sPAR, sPLACE, sPLACED, sPLUS, sPORT, sPRI, sPROC, + sPROCESSOR, sPROTOCOL, sREAL32, sREAL64, sRECORD, sREC_RECURSIVE, sREM, + sRESHAPES, sRESULT, sRETYPES, sROUND, sSEQ, sSHARED, sSIZE, sSKIP, sSTEP, + sSTOP, sTIMER, sTIMES, sTRUE, sTRUNC, sTYPE, sVAL, sVALOF, sWHILE, + sWORKSPACE, sVECSPACE :: OccParser () sAFTER = reserved "AFTER" sALT = reserved "ALT" @@ -169,6 +168,8 @@ sDEFINED = reserved "DEFINED" sELSE = reserved "ELSE" sFALSE = reserved "FALSE" sFOR = reserved "FOR" +sFORK = reserved "FORK" +sFORKING = reserved "FORKING" sFROM = reserved "FROM" sFUNCTION = reserved "FUNCTION" sIF = reserved "IF" @@ -1545,6 +1546,29 @@ process <|> intrinsicProc <|> handleSpecs (allocation <|> specification <|> claimSpec) process (\m s p -> A.Seq m (A.Spec m s (A.Only m p))) + <|> do m <- md + sFORKING + eol + indent + p <- process + outdent + n <- makeNonce m "fork" >>* A.Name m + let spec = A.Specification m n $ A.Forking m + let nd = A.NameDef { + A.ndMeta = m, + A.ndName = A.nameName n, + A.ndOrigName = "FORKING", + A.ndSpecType = A.Forking m, + A.ndAbbrevMode = A.Original, + A.ndNameSource = A.NameNonce, + A.ndPlacement = A.Unplaced + } + defineName n nd + return $ A.Seq m $ A.Spec m spec $ A.Only m p + <|> do m <- md + sFORK + p <- procInstance + return $ A.Fork m Nothing p "process" claimSpec :: OccParser ([NameSpec], OccParser ())