From f7e114f2fdd8f742e36035fb7abb1e75a07b4f69 Mon Sep 17 00:00:00 2001 From: Neil Brown Date: Sun, 5 Apr 2009 22:54:05 +0000 Subject: [PATCH] Overhauled the Types module and ParseOccam to support the new system of operators-as-functions The idea behind this is to parse unary/binary operators into function calls with 1/2 operands. So the AST actually has a FunctionCall with the name "+". Function names may now be quoted operators, and thus you can also have function declarations with names such as "+". Resolving is *not* done in the parser for these function names, but rather every "+" is left as "+" (no matter what types it operates on, or what is in scope) by the parser (see later patches to InferTypes instead). When parsing an occam source file, we automatically insert a bunch of PRAGMA TOCKEXTERNAL that define the default occam operators (e.g. + on INT) as external C functions (which they are!). The naming scheme for these C functions is standardised, and must be used by functions such as mulExprs (which bases the function on the type of its operands) and the new versions mulExprsInt (which are pegged to INT). The Types module also has some new functions for dealing with operator-functions. --- common/Types.hs | 179 +++++++++++++++++++++++++++++----------- frontends/ParseOccam.hs | 152 +++++++++++++++++++++++----------- 2 files changed, 238 insertions(+), 93 deletions(-) diff --git a/common/Types.hs b/common/Types.hs index 6cc3d1a..dc2fca7 100644 --- a/common/Types.hs +++ b/common/Types.hs @@ -22,11 +22,13 @@ module Types specTypeOfName, typeOfSpec, typeOfSpec', abbrevModeOfName, underlyingType, stripArrayType, abbrevModeOfVariable, abbrevModeOfSpec , isRealType, isIntegerType, isNumericType, isCaseableType, isScalarType, isDataType, isCommunicableType, isSequenceType, isMobileType , resolveUserType, isSafeConversion, isPreciseConversion, isImplicitConversionRain + , isOperator, functionOperator, occamDefaultOperator , returnTypesOfFunction , BytesInResult(..), bytesInType, countReplicator, countStructured, computeStructured - , makeAbbrevAM, makeConstant, makeDimension, specificDimSize, addOne, subOne, addExprs, subExprs, - mulExprs, divExprs + , makeAbbrevAM, makeConstant, makeDimension, specificDimSize + , addOne, subOne, addExprs, subExprs, mulExprs, divExprs + , addOneInt, subOneInt, addExprsInt, subExprsInt, mulExprsInt, divExprsInt , addDimensions, applyDimension, removeFixedDimensions, trivialSubscriptType, subscriptType, unsubscriptType , applyDirection , recordFields, recordAttr, protocolItems, dirAttr @@ -37,6 +39,7 @@ module Types ) where import Control.Monad.State +import Data.Char import Data.Generics import qualified Data.Map as Map import Data.Maybe @@ -198,7 +201,7 @@ subscriptType (A.SubscriptFrom m _ base) (A.Array (d:ds) t) = return $ A.Array (dim : ds) t where dim = case d of - A.Dimension size -> dimensionFromExpr $ A.Dyadic m A.Subtr size base + A.Dimension size -> dimensionFromExpr $ subExprsInt size base _ -> A.UnknownDimension subscriptType (A.SubscriptFor m _ count) (A.Array (_:ds) t) = return $ A.Array (dimensionFromExpr count : ds) t @@ -278,16 +281,6 @@ abbrevModeOfVariable (A.DirectedVariable _ _ v) = abbrevModeOfVariable v abbrevModeOfVariable (A.DerefVariable _ v) = return A.Original abbrevModeOfVariable (A.VariableSizes {}) = return A.Original -dyadicIsBoolean :: A.DyadicOp -> Bool -dyadicIsBoolean A.Eq = True -dyadicIsBoolean A.NotEq = True -dyadicIsBoolean A.Less = True -dyadicIsBoolean A.More = True -dyadicIsBoolean A.LessEq = True -dyadicIsBoolean A.MoreEq = True -dyadicIsBoolean A.After = True -dyadicIsBoolean _ = False - instance ASTTypeable A.Expression where astTypeOf = typeOfExpression @@ -295,18 +288,6 @@ instance ASTTypeable A.Expression where typeOfExpression :: (CSMR m, Die m) => A.Expression -> m A.Type typeOfExpression e = case e of - A.Monadic m op e -> typeOfExpression e - A.Dyadic m op e f -> - if dyadicIsBoolean op then return A.Bool - else - --Need to handle multiplying Time types specially, due to the asymmetry: - if (op == A.Times) - then do tlhs <- typeOfExpression e - trhs <- typeOfExpression f - if (tlhs == A.Time || trhs == A.Time) - then return A.Time - else return tlhs - else typeOfExpression e A.MostPos m t -> return t A.MostNeg m t -> return t A.SizeType m t -> return A.Int @@ -659,8 +640,8 @@ bytesInType a@(A.Array _ _) = bytesInArray 0 a bytesInArray num (A.Array (d:ds) t) = do ts <- bytesInArray (num + 1) (A.Array ds t) case (d, ts) of - (A.Dimension n, BIJust m) -> return $ BIJust (mulExprs n m) - (A.Dimension n, BIOneFree m x) -> return $ BIOneFree (mulExprs n m) x + (A.Dimension n, BIJust m) -> return $ BIJust (mulExprsInt n m) + (A.Dimension n, BIOneFree m x) -> return $ BIOneFree (mulExprsInt n m) x (A.UnknownDimension, BIJust m) -> return $ BIOneFree m num (A.UnknownDimension, BIOneFree _ _) -> return BIManyFree (_, _) -> return ts @@ -678,7 +659,7 @@ bytesInType (A.Record n) = do bi <- bytesInType t br <- bytesInList rest case (bi, br) of - (BIJust a, BIJust b) -> return $ BIJust (addExprs a b) + (BIJust a, BIJust b) -> return $ BIJust (addExprsInt a b) (_, _) -> return BIUnknown bytesInType _ = return $ BIUnknown --}}} @@ -694,46 +675,150 @@ countStructured = computeStructured (\m _ -> makeConstant m 1) -- | Compute an expression over a Structured. computeStructured :: Data a => (Meta -> a -> A.Expression) -> A.Structured a -> A.Expression computeStructured f (A.Spec _ (A.Specification _ _ (A.Rep m rep)) s) - = A.Dyadic m A.Times (countReplicator rep) (computeStructured f s) + = mulExprsInt (countReplicator rep) (computeStructured f s) computeStructured f (A.Spec _ _ s) = computeStructured f s computeStructured f (A.ProcThen _ _ s) = computeStructured f s computeStructured f (A.Only m x) = f m x computeStructured f (A.Several m ss) = case ss of [] -> makeConstant m 0 - _ -> foldl1 (A.Dyadic m A.Plus) (map (computeStructured f) ss) + _ -> foldl1 addExprsInt (map (computeStructured f) ss) specificDimSize :: Int -> A.Variable -> A.Variable specificDimSize n v = A.SubscriptedVariable (findMeta v) (A.Subscript (findMeta v) A.NoCheck $ makeConstant (findMeta v) n) $ A.VariableSizes (findMeta v) v +functionOperator :: (CSMR m, Die m) => A.Name -> m (Maybe String) +functionOperator n + = lookupNameOrError n (dieP (A.nameMeta n) $ "Can't find operator definition for " ++ A.nameName n) + >>* A.ndOrigName + >>* (\op -> if isOperator op then Just op else Nothing) + +isOperator :: String -> Bool +isOperator op = any (== op) operatorNames + +operatorNames :: [String] +operatorNames = + ["??" + ,"@@" + ,"$$" + ,"%" + ,"%%" + ,"&&" + ,"<%" + ,"%>" + ,"<&" + ,"&>" + ,"<]" + ,"[>" + ,"<@" + ,"@>" + ,"@" + ,"++" + ,"!!" + ,"==" + ,"^" + ,"-" + ,"MINUS" + ,"~" + ,"NOT" + ,"+" + ,"*" + ,"/" + ,"\\" + ,"REM" + ,"PLUS" + ,"TIMES" + ,"AFTER" + ,"/\\" + ,"\\/" + ,"><" + ,"<<" + ,">>" + ,"AND" + ,"OR" + ,"=" + ,"<>" + ,"<=" + ,"<" + ,">=" + ,">" + ] + +-- | This gives a default mapping from operator (such as "+") to a valid name string +-- to be used in the backend (i.e. the Tock support headers), such as "add", which +-- will later be suffixed by the types in question. +occamOperatorTranslateDefault :: String -> String +occamOperatorTranslateDefault "+" = "add" +occamOperatorTranslateDefault cs = '_' : concatMap (show . ord) cs + +occamDefaultOperator :: String -> [A.Type] -> String +occamDefaultOperator op ts = "occam_" ++ occamOperatorTranslateDefault op + ++ concatMap (('_':) . showOccam) ts + -- | Add one to an expression. -addOne :: A.Expression -> A.Expression -addOne e = A.Dyadic m A.Add (makeConstant m 1) e +addOne :: (CSMR m, Die m) => A.Expression -> m A.Expression +addOne e = addExprs (makeConstant m 1) e where m = findMeta e -- | Subtrace one from an expression. -subOne :: A.Expression -> A.Expression -subOne e = A.Dyadic m A.Subtr e (makeConstant m 1) +subOne :: (CSMR m, Die m) => A.Expression -> m A.Expression +subOne e = subExprs e (makeConstant m 1) where m = findMeta e --- | Add two expressions. -addExprs :: A.Expression -> A.Expression -> A.Expression -addExprs a b = A.Dyadic m A.Add a b - where m = findMeta a +-- | Add one to an expression. +addOneInt :: A.Expression -> A.Expression +addOneInt e = addExprsInt (makeConstant m 1) e + where m = findMeta e + +-- | Subtrace one from an expression. +subOneInt :: A.Expression -> A.Expression +subOneInt e = subExprsInt e (makeConstant m 1) + where m = findMeta e + +type DyadicExpr = A.Expression -> A.Expression -> A.Expression +type DyadicExprM = (CSMR m, Die m) => A.Expression -> A.Expression -> m A.Expression + +dyadicExpr' :: (A.Type, A.Type) -> String -> DyadicExpr +dyadicExpr' (t0, t1) op a b + = A.FunctionCall m (A.Name m $ occamDefaultOperator op [t0,t1]) [a, b] + where + m = findMeta a + +dyadicExpr :: String -> DyadicExprM +dyadicExpr op a b = do ta <- astTypeOf a + tb <- astTypeOf b + return $ dyadicExpr' (ta, tb) op a b -- | Add two expressions. -subExprs :: A.Expression -> A.Expression -> A.Expression -subExprs a b = A.Dyadic m A.Subtr a b - where m = findMeta a +addExprs :: DyadicExprM +addExprs = dyadicExpr "+" + +-- | Add two expressions. +subExprs :: DyadicExprM +subExprs = dyadicExpr "-" -- | Multiply two expressions. -mulExprs :: A.Expression -> A.Expression -> A.Expression -mulExprs a b = A.Dyadic m A.Mul a b - where m = findMeta a +mulExprs :: DyadicExprM +mulExprs = dyadicExpr "*" -- | Divide two expressions. -divExprs :: A.Expression -> A.Expression -> A.Expression -divExprs a b = A.Dyadic m A.Div a b - where m = findMeta a +divExprs :: DyadicExprM +divExprs = dyadicExpr "/" + +-- | Add two expressions. +addExprsInt :: DyadicExpr +addExprsInt = dyadicExpr' (A.Int,A.Int) "+" + +-- | Add two expressions. +subExprsInt :: DyadicExpr +subExprsInt = dyadicExpr' (A.Int,A.Int) "-" + +-- | Multiply two expressions. +mulExprsInt :: DyadicExpr +mulExprsInt = dyadicExpr' (A.Int,A.Int) "*" + +-- | Divide two expressions. +divExprsInt :: DyadicExpr +divExprsInt = dyadicExpr' (A.Int,A.Int) "/" diff --git a/frontends/ParseOccam.hs b/frontends/ParseOccam.hs index 4495a0f..c57d9d3 100644 --- a/frontends/ParseOccam.hs +++ b/frontends/ParseOccam.hs @@ -21,6 +21,7 @@ module ParseOccam (parseOccamProgram) where import Control.Monad (join, liftM) import Control.Monad.State (MonadState, modify, get, put) +import Data.Char import Data.List import qualified Data.Map as Map import Data.Maybe @@ -518,7 +519,7 @@ timerName = name TimerName variableName = name VariableName newChannelName, newChanBundleName, newDataTypeName, newFunctionName, newPortName, - newProcName, newProtocolName, newRecordName, newTimerName, + newProcName, newProtocolName, newRecordName, newTimerName, newUDOName, newVariableName :: OccParser A.Name @@ -533,6 +534,14 @@ newRecordName = newName RecordName newTimerName = newName TimerName newVariableName = newName VariableName +newUDOName = do m <- md + s <- genToken test + let chs = splitStringLiteral m s + return $ A.Name m $ concat [cs | A.ByteLiteral _ cs <- chs] + where + test (Token _ (TokStringLiteral s)) = Just (chop 1 1 s) + test _ = Nothing + -- | A name that isn't scoped. -- This is for things like record fields: we don't need to track their scope -- because they're only valid with the particular record they're defined in, @@ -751,9 +760,9 @@ expressionList expression :: OccParser A.Expression expression = do m <- md - o <- monadicOperator + o <- udOperator ((`elem` [JustMonadic, EitherDyadicMonadic]) . operatorArity) v <- operand - return $ A.Monadic m o v + return $ A.FunctionCall m o [v] <|> do { m <- md; sMOSTPOS; t <- dataType; return $ A.MostPos m t } <|> do { m <- md; sMOSTNEG; t <- dataType; return $ A.MostNeg m t } <|> do { m <- md; sCLONE; e <- expression; return $ A.CloneMobile m e } @@ -761,9 +770,9 @@ expression <|> do { m <- md; sDEFINED; e <- expression; return $ A.IsDefined m e } <|> sizeExpr <|> do m <- md - (l, o) <- tryVV operand dyadicOperator + (l, o) <- tryVV operand $ udOperator ((`elem` [JustDyadic, EitherDyadicMonadic]) . operatorArity) r <- operand - return $ A.Dyadic m o l r + return $ A.FunctionCall m o [l, r] <|> associativeOpExpression <|> conversion <|> operand @@ -786,9 +795,11 @@ arrayConstructor associativeOpExpression :: OccParser A.Expression associativeOpExpression = do m <- md - (l, o) <- tryVV operand associativeOperator + (l, o) <- tryVV operand $ udOperator + (\op -> (operatorArity op `elem` [JustDyadic, EitherDyadicMonadic]) + && isAssocOperator op) r <- associativeOpExpression <|> operand - return $ A.Dyadic m o l r + return $ A.FunctionCall m o [l, r] "associative operator expression" sizeExpr :: OccParser A.Expression @@ -823,44 +834,71 @@ functionCall Just _ -> return s Nothing -> pzero -monadicOperator :: OccParser A.MonadicOp -monadicOperator - = do { reserved "-"; return A.MonadicSubtr } - <|> do { sMINUS; return A.MonadicMinus } - <|> do { reserved "~" <|> sBITNOT; return A.MonadicBitNot } - <|> do { sNOT; return A.MonadicNot } - "monadic operator" +data OperatorArity = JustDyadic | JustMonadic | EitherDyadicMonadic | NotOperator + deriving (Eq) -dyadicOperator :: OccParser A.DyadicOp -dyadicOperator - = do { reserved "+"; return A.Add } - <|> do { reserved "-"; return A.Subtr } - <|> do { reserved "*"; return A.Mul } - <|> do { reserved "/"; return A.Div } - <|> do { reserved "\\"; return A.Rem } - <|> do { sREM; return A.Rem } - <|> do { sMINUS; return A.Minus } - <|> do { reserved "/\\" <|> sBITAND; return A.BitAnd } - <|> do { reserved "\\/" <|> sBITOR; return A.BitOr } - <|> do { reserved "><"; return A.BitXor } - <|> do { reserved "<<"; return A.LeftShift } - <|> do { reserved ">>"; return A.RightShift } - <|> do { reserved "="; return A.Eq } - <|> do { reserved "<>"; return A.NotEq } - <|> do { reserved "<"; return A.Less } - <|> do { reserved ">"; return A.More } - <|> do { reserved "<="; return A.LessEq } - <|> do { reserved ">="; return A.MoreEq } - <|> do { sAFTER; return A.After } - "dyadic operator" +-- Returns the most operands it can take. +operatorArity :: String -> OperatorArity +operatorArity "??" = EitherDyadicMonadic +operatorArity "@@" = EitherDyadicMonadic +operatorArity "$$" = EitherDyadicMonadic +operatorArity "%" = EitherDyadicMonadic +operatorArity "%%" = EitherDyadicMonadic +operatorArity "&&" = EitherDyadicMonadic +operatorArity "<%" = EitherDyadicMonadic +operatorArity "%>" = EitherDyadicMonadic +operatorArity "<&" = EitherDyadicMonadic +operatorArity "&>" = EitherDyadicMonadic +operatorArity "<]" = EitherDyadicMonadic +operatorArity "[>" = EitherDyadicMonadic +operatorArity "<@" = EitherDyadicMonadic +operatorArity "@>" = EitherDyadicMonadic +operatorArity "@" = EitherDyadicMonadic +operatorArity "++" = EitherDyadicMonadic +operatorArity "!!" = EitherDyadicMonadic +operatorArity "==" = EitherDyadicMonadic +operatorArity "^" = EitherDyadicMonadic +operatorArity "-" = EitherDyadicMonadic +operatorArity "MINUS" = EitherDyadicMonadic +operatorArity "~" = JustMonadic +operatorArity "NOT" = JustMonadic +operatorArity "+" = JustDyadic +operatorArity "*" = JustDyadic +operatorArity "/" = JustDyadic +operatorArity "\\" = JustDyadic +operatorArity "REM" = JustDyadic +operatorArity "PLUS" = JustDyadic +operatorArity "TIMES" = JustDyadic +operatorArity "AFTER" = JustDyadic +operatorArity "/\\" = JustDyadic +operatorArity "\\/" = JustDyadic +operatorArity "><" = JustDyadic +operatorArity "<<" = JustDyadic +operatorArity ">>" = JustDyadic +operatorArity "AND" = JustDyadic +operatorArity "OR" = JustDyadic +operatorArity "=" = JustDyadic +operatorArity "<>" = JustDyadic +operatorArity "<" = JustDyadic +operatorArity "<=" = JustDyadic +operatorArity ">" = JustDyadic +operatorArity ">=" = JustDyadic +operatorArity _ = NotOperator -associativeOperator :: OccParser A.DyadicOp -associativeOperator - = do { sAND; return A.And } - <|> do { sOR; return A.Or } - <|> do { sPLUS; return A.Plus } - <|> do { sTIMES; return A.Times } - "associative operator" +isAssocOperator :: String -> Bool +isAssocOperator "AND" = True +isAssocOperator "OR" = True +isAssocOperator "PLUS" = True +isAssocOperator "TIMES" = True + +udOperator :: (String -> Bool) -> OccParser A.Name +udOperator isOp = do m <- md + n <- genToken test + return $ A.Name m n + where + test (Token _ (TokReserved name)) + = if isOp name then Just name else Nothing + test _ = Nothing conversion :: OccParser A.Expression conversion @@ -1191,7 +1229,7 @@ definition return (A.Specification m n' $ A.Proc m (sm, rm) fs' (Just p), ProcName, normalName) <|> do m <- md (rs, (sm, (rm, _))) <- tryVV (sepBy1 dataType sComma) (specMode $ recMode sFUNCTION) - n <- newFunctionName + n <- newFunctionName <|> newUDOName fs <- formalList let addScope body = do n' <- if rm == A.Recursive @@ -1432,7 +1470,7 @@ pragma = do m <- getPosition >>* sourcePosToMeta n <- newProcName return (n, ProcName, origN, fs, A.Proc m (A.PlainSpec, A.PlainRec) fs Nothing) <|> do ts <- tryVX (sepBy1 dataType sComma) sFUNCTION - origN <- anyName FunctionName + origN <- anyName FunctionName <|> newUDOName fs <- formalList' sEq n <- newFunctionName @@ -1934,8 +1972,30 @@ runTockParser toks prod cs parseOccamProgram :: [Token] -> PassM A.AST parseOccamProgram toks = do cs <- get - (p, cs') <- runTockParser toks sourceFile cs + (p, cs') <- runTockParser (defaultDecl ++ toks) sourceFile cs put cs' return p + +defaultDecl :: [Token] +defaultDecl = concat + [let params = [showOccam $ A.Formal A.ValAbbrev t (A.Name emptyMeta $ "x" ++ + show i) + | (t, i :: Integer) <- zip ts [0..]] + in + [Token emptyMeta $ Pragma $ "TOCKEXTERNAL \"" + ++ showOccam rt + ++ " FUNCTION \"" ++ concatMap doubleStar op ++ "\"(" + ++ concat (intersperse "," params) + ++ ") = " + ++ occamDefaultOperator op ts + ++ "\"" + ,Token emptyMeta EndOfLine + ] + | (op, rt, ts) <- occamIntrinsicOperators + ] + where + doubleStar '*' = "**" + doubleStar c = [c] + --}}}