From a17ee033932df2351eae0d86940bd5adb19a3222 Mon Sep 17 00:00:00 2001 From: Adam Sampson Date: Thu, 3 May 2007 17:44:26 +0000 Subject: [PATCH] Rework how array contexts are handled in actuals --- fco2/Parse.hs | 73 ++++++++++++++++---------------- fco2/Types.hs | 14 ++++++ fco2/testcases/array-context.occ | 16 +++++++ 3 files changed, 67 insertions(+), 36 deletions(-) create mode 100644 fco2/testcases/array-context.occ diff --git a/fco2/Parse.hs b/fco2/Parse.hs index 2f8c7ac..793e797 100644 --- a/fco2/Parse.hs +++ b/fco2/Parse.hs @@ -487,16 +487,6 @@ inTypeContext ctx body -- inside some bit of an expression that means we can't tell what the type is). noTypeContext :: OccParser a -> OccParser a noTypeContext = inTypeContext Nothing - --- | Push a type context that's a simple subscript of the existing one. -pushSubscriptTypeContext :: (PSM m, Die m) => m () -pushSubscriptTypeContext - = do ps <- get - case psTypeContext ps of - (Just t@(A.Array _ _)):_ -> - do subT <- trivialSubscriptType t - pushTypeContext $ Just subT - _ -> pushTypeContext Nothing --}}} --{{{ name scoping @@ -687,8 +677,9 @@ isValidLiteralType defT' realT' checkValidLiteralType :: A.Type -> A.Type -> OccParser () checkValidLiteralType defT t = do isValid <- isValidLiteralType defT t + ps <- get when (not isValid) $ - fail $ "type given/inferred for literal (" ++ show t ++ ") is not valid for this sort of literal (" ++ show defT ++ ")" + fail $ "type given/inferred for literal (" ++ show t ++ ") is not valid for this sort of literal (" ++ show defT ++ ")" ++ " ctx = " ++ show (psTypeContext ps) -- | Apply dimensions from one type to another as far as possible. -- This should only be used when you know the two types are compatible first @@ -761,43 +752,53 @@ byte return c "byte literal" --- i.e. array literal +-- | Parse a table -- an array literal which might be subscripted or sliced. +-- (The implication of this is that the type of the expression this parses +-- isn't necessarily an array type -- it might be something like +-- @[1, 2, 3][1]@.) table :: OccParser A.Expression table - = maybeSubscripted "table" table' A.SubscriptedExpr typeOfExpression + = do e <- maybeSubscripted "table" table' A.SubscriptedExpr typeOfExpression + defT <- typeOfExpression e + t <- getTypeContext defT + checkValidLiteralType defT t + fixTableType e (applyDimensions defT t) + where + -- | Apply the actual type that we've figured out to the expression, handling + -- subscripts. + fixTableType :: A.Expression -> A.Type -> OccParser A.Expression + fixTableType (A.Literal m _ lr) t = return $ A.Literal m t lr + fixTableType (A.SubscriptedExpr m sub e) t + = do innerDefT <- typeOfExpression e + innerT <- unsubscriptType sub t + liftM (A.SubscriptedExpr m sub) $ fixTableType e (applyDimensions innerDefT innerT) table' :: OccParser A.Expression table' = do m <- md - (s, dim) <- stringLiteral - let defT = A.Array [dim] A.Byte + (lr, defT) <- tableElems t <- do sLeftR t <- dataType sRightR - return t - <|> getTypeContext defT - checkValidLiteralType defT t - return $ A.Literal m (applyDimensions defT t) s - <|> do m <- md - pushSubscriptTypeContext - es <- tryXVX sLeft (sepBy1 expression sComma) sRight - popTypeContext - - ets <- mapM typeOfExpression es - defT <- listType m ets - - array <- liftM (A.ArrayLiteral m) $ mapM collapseArrayElem es - - t <- do sLeftR - t <- dataType - sRightR - return t - <|> getTypeContext defT - checkValidLiteralType defT t - return $ A.Literal m (applyDimensions defT t) array + checkValidLiteralType defT t + return (applyDimensions defT t) + <|> return defT + return $ A.Literal m t lr <|> maybeSliced table A.SubscriptedExpr typeOfExpression "table'" +tableElems :: OccParser (A.LiteralRepr, A.Type) +tableElems + = do (lr, dim) <- stringLiteral + return (lr, A.Array [dim] A.Byte) + <|> do m <- md + es <- tryXVX sLeft (noTypeContext $ sepBy1 expression sComma) sRight + ets <- mapM typeOfExpression es + defT <- listType m ets + lr <- liftM (A.ArrayLiteral m) $ mapM collapseArrayElem es + return (lr, defT) + "table elements" + -- | Collapse nested array literals. collapseArrayElem :: A.Expression -> OccParser A.ArrayElem collapseArrayElem e diff --git a/fco2/Types.hs b/fco2/Types.hs index 4344313..90c0e7f 100644 --- a/fco2/Types.hs +++ b/fco2/Types.hs @@ -104,6 +104,20 @@ subscriptType (A.SubscriptField m tag) t = typeOfRecordField m t tag subscriptType (A.Subscript m sub) t = plainSubscriptType m sub t subscriptType _ t = die $ "unsubscriptable type: " ++ show t +-- | The inverse of 'subscriptType': given a type that we know is the result of +-- a subscript, return what the type being subscripted is. +unsubscriptType :: (PSM m, Die m) => A.Subscript -> A.Type -> m A.Type +unsubscriptType (A.SubscriptFromFor _ _ _) t + = return t +unsubscriptType (A.SubscriptFrom _ _) t + = return t +unsubscriptType (A.SubscriptFor _ _) t + = return t +unsubscriptType (A.SubscriptField _ _) t + = die $ "unsubscript of record type (but we can't tell which one)" +unsubscriptType (A.Subscript _ sub) t + = return $ makeArrayType A.UnknownDimension t + -- | Just remove the first dimension from an array type -- like doing -- subscriptType with constant 0 as a subscript, but without the checking. -- This is used for the couple of cases where we know it's safe and don't want diff --git a/fco2/testcases/array-context.occ b/fco2/testcases/array-context.occ new file mode 100644 index 0000000..266d615 --- /dev/null +++ b/fco2/testcases/array-context.occ @@ -0,0 +1,16 @@ +-- Check that the type context is manipulated correctly when dealing with a +-- subscript of an array literal. + +PROC Q () + SEQ + PROC P (VAL INT v) + ASSERT (v = 3) + : + P ([1, 2, 3, 4][2]) + + DATA TYPE FOO IS INT: + PROC P (VAL []FOO foos) + SKIP + : + P ([1, 2, 3, 4]) +: