From af319c36554baf09bc597109f54260fd20e1145c Mon Sep 17 00:00:00 2001 From: Zachary Snow Date: Wed, 1 Jul 2020 17:25:33 -0600 Subject: [PATCH] scoper tracks whether traversal is in procedure --- src/Convert/Scoper.hs | 68 +++++++++++++++++++++++++++++++++++-------- 1 file changed, 56 insertions(+), 12 deletions(-) diff --git a/src/Convert/Scoper.hs b/src/Convert/Scoper.hs index 3902e58..3495726 100644 --- a/src/Convert/Scoper.hs +++ b/src/Convert/Scoper.hs @@ -7,7 +7,8 @@ - - This module provides a series of "scopers" which track the scope of blocks, - generate loops, tasks, and functions, and provides the ability to insert and - - lookup elements in a scope-aware way. + - lookup elements in a scope-aware way. It also provides the ability to check + - whether the current node is within a procedural context. - - The interfaces take in a mappers for each of: Decl, ModuleItem, GenItem, and - Stmt. Note that Function, Task, Always, Initial, and Final are NOT passed @@ -36,9 +37,11 @@ module Convert.Scoper , lookupLHSM , lookupIdentM , lookupAccessesM - , Access + , Access(..) , Scopes , embedScopes + , withinProcedure + , withinProcedureM ) where import Control.Monad.State @@ -77,6 +80,7 @@ data Entry a = Entry data Scopes a = Scopes { sCurrent :: [Tier] , sMapping :: Mapping a + , sProcedure :: Bool } deriving Show embedScopes :: Monad m => (Scopes a -> b -> c) -> b -> ScoperT a m c @@ -103,7 +107,8 @@ enterScope name index = do let entry = Entry existingElement index Map.empty mapping <- gets sMapping let mapping' = setScope current' entry mapping - put $ Scopes current' mapping' + procedure <- gets sProcedure + put $ Scopes current' mapping' procedure where thd3 (_, _, c) = c exitScope :: Monad m => Identifier -> Identifier -> ScoperT a m () @@ -111,11 +116,30 @@ exitScope name index = do let tier = Tier name index current <- gets sCurrent mapping <- gets sMapping + procedure <- gets sProcedure if null current || last current /= tier then error "exitScope invariant violated" else do let current' = init current - put $ Scopes current' mapping + put $ Scopes current' mapping procedure + +enterProcedure :: Monad m => ScoperT a m () +enterProcedure = do + current <- gets sCurrent + mapping <- gets sMapping + procedure <- gets sProcedure + if procedure + then error "enterProcedure invariant failed" + else put $ Scopes current mapping True + +exitProcedure :: Monad m => ScoperT a m () +exitProcedure = do + current <- gets sCurrent + mapping <- gets sMapping + procedure <- gets sProcedure + if not procedure + then error "exitProcedure invariant failed" + else put $ Scopes current mapping False tierToAccess :: Tier -> Access tierToAccess (Tier x "") = Access x Nil @@ -139,9 +163,10 @@ insertElem :: Monad m => Identifier -> a -> ScoperT a m () insertElem name element = do current <- gets sCurrent mapping <- gets sMapping + procedure <- gets sProcedure let entry = Entry (Just element) "" Map.empty let mapping' = setScope (current ++ [Tier name ""]) entry mapping - put $ Scopes current mapping' + put $ Scopes current mapping' procedure type Replacements = Map.Map Identifier Expr @@ -198,6 +223,12 @@ lookupAccesses scopes accesses = do toResult (a, b) = (full, a, b) results = catMaybes $ map try options +withinProcedureM :: Monad m => ScoperT a m Bool +withinProcedureM = gets sProcedure + +withinProcedure :: Scopes a -> Bool +withinProcedure = sProcedure + evalScoper :: MapperM (Scoper a) Decl -> MapperM (Scoper a) ModuleItem @@ -228,7 +259,7 @@ evalScoperT declMapper moduleItemMapper genItemMapper stmtMapper topName items = items' <- mapM fullModuleItemMapper items exitScope topName "" return items' - initialState = Scopes [] Map.empty + initialState = Scopes [] Map.empty False fullStmtMapper :: Stmt -> ScoperT a m Stmt fullStmtMapper (Block kw name decls stmts) = do @@ -269,6 +300,7 @@ evalScoperT declMapper moduleItemMapper genItemMapper stmtMapper topName items = fullModuleItemMapper :: ModuleItem -> ScoperT a m ModuleItem fullModuleItemMapper (MIPackageItem (Function ml t x decls stmts)) = do + enterProcedure t' <- do res <- declMapper $ Variable Local t x [] Nil case res of @@ -278,21 +310,33 @@ evalScoperT declMapper moduleItemMapper genItemMapper stmtMapper topName items = decls' <- mapTFDecls decls stmts' <- mapM fullStmtMapper stmts exitScope x "" + exitProcedure return $ MIPackageItem $ Function ml t' x decls' stmts' fullModuleItemMapper (MIPackageItem (Task ml x decls stmts)) = do + enterProcedure enterScope x "" decls' <- mapTFDecls decls stmts' <- mapM fullStmtMapper stmts exitScope x "" + exitProcedure return $ MIPackageItem $ Task ml x decls' stmts' fullModuleItemMapper (MIPackageItem (Decl decl)) = declMapper decl >>= return . MIPackageItem . Decl - fullModuleItemMapper (AlwaysC kw stmt) = - fullStmtMapper stmt >>= return . AlwaysC kw - fullModuleItemMapper (Initial stmt) = - fullStmtMapper stmt >>= return . Initial - fullModuleItemMapper (Final stmt) = - fullStmtMapper stmt >>= return . Final + fullModuleItemMapper (AlwaysC kw stmt) = do + enterProcedure + stmt' <- fullStmtMapper stmt + exitProcedure + return $ AlwaysC kw stmt' + fullModuleItemMapper (Initial stmt) = do + enterProcedure + stmt' <- fullStmtMapper stmt + exitProcedure + return $ Initial stmt' + fullModuleItemMapper (Final stmt) = do + enterProcedure + stmt' <- fullStmtMapper stmt + exitProcedure + return $ Final stmt' fullModuleItemMapper (Generate genItems) = mapM fullGenItemMapper genItems >>= return . Generate fullModuleItemMapper (MIAttr attr item) =