Changeset 14150

Show
Ignore:
Timestamp:
10/09/06 17:27:25 (2 years ago)
Author:
audreyt
Message:

* Pugs.Monad, Pugs.AST.Internals: Revamp the dynamic frame

management system. Instead of tracking explicit frames,
we now collect a set of frame markers, such as "FrameRoutine?",
"FrameGather?", "FrameGiven?", "FrameLoop?" etc.

Location:
src/Pugs
Files:
2 modified

Legend:

Unmodified
Added
Removed

  • src/Pugs/AST/Internals.hs

    r14142 r14150  
    12661266    , envOuter   :: !(Maybe Env)         -- ^ Outer block's env 
    12671267    , envBody    :: !Exp                 -- ^ Current AST expression 
    1268     , envDepth   :: ![Frame]             -- ^ Recursion depth 
     1268    , envFrames  :: !(Set Frame)         -- ^ Recursion depth 
    12691269    , envDebug   :: !DebugInfo           -- ^ Debug info map 
    12701270    , envPos     :: !Pos                 -- ^ Source position range 
    … …  
    12791279    = FrameLoop 
    12801280    | FrameGiven 
     1281    | FrameGather 
    12811282    | FrameRoutine 
    12821283    deriving (Show, Eq, Ord, Typeable) -- don't derive YAML for now 
    … …  
    13781379 
    13791380findSymRef :: Var -> Pad -> Eval VRef 
    1380 findSymRef name pad = do 
    1381     case findSym name pad of 
    1382         Just ref -> liftSTM $ readTVar ref 
    1383         Nothing  -> fail $ "Cannot find variable: " ++ show name 
    1384  
    1385 findSym :: Var -> Pad -> Maybe (TVar VRef) 
     1381findSymRef name pad = liftSTM $ do 
     1382    ref <- findSym name pad 
     1383    readTVar ref 
     1384 
     1385{-# SPECIALISE findSym :: Var -> Pad -> Eval (TVar VRef) #-} 
     1386{-# SPECIALISE findSym :: Var -> Pad -> Maybe (TVar VRef) #-} 
     1387findSym :: Monad m => Var -> Pad -> m (TVar VRef) 
    13861388findSym name pad = case lookupPad name pad of 
    1387     Just (x:_)  -> Just x 
    1388     _           -> Nothing 
     1389    Just (x:_)  -> return x 
     1390    _           -> fail $ "Cannot find variable: " ++ show name 
    13891391 
    13901392-- | Look up a symbol in a 'Pad', returning the ref it is bound to. 
    … …  
    14001402-} 
    14011403 
    1402 lookupPad key (MkPad map) = case Map.lookup (possiblyFixOperatorName key) map of 
     1404lookupPad key (MkPad map) = case Map.lookup key map of 
    14031405    Just (MkEntryMulti xs)   -> Just [tvar | (_, tvar) <- xs] 
    14041406    Just (MkEntry (_, tvar)) -> Just [tvar] 
    … …  
    15721574clearRef r = retError "Cannot clearRef" r 
    15731575 
     1576{-# SPECIALISE newObject :: Type -> Eval VRef #-} 
     1577{-# SPECIALISE newObject :: Type -> IO VRef #-} 
    15741578newObject :: (MonadSTM m, MonadIO m) => Type -> m VRef 
    15751579newObject typ = case showType typ of 
    … …  
    18891893        , envCaller  = Nothing 
    18901894        , envOuter   = Nothing 
    1891         , envDepth   = [] 
     1895        , envFrames  = Set.empty 
    18921896        , envBody    = Val undef 
    18931897        , envDebug   = Just ref -- Set to "Nothing" to disable debugging 

  • src/Pugs/Monads.hs

    r14122 r14150  
    1616    enterLValue, enterRValue, 
    1717    enterLex, enterContext, enterEvalContext, enterPackage, enterCaller, 
    18     enterGiven, enterWhen, enterLoop, genSymPrim, genSymCC, 
     18    enterGiven, enterWhen, enterLoop, enterGather, genSymPrim, genSymCC, 
    1919    enterBlock, enterSub, envEnterCaller, 
    2020    evalVal, tempVar, 
     21 
     22    enterFrame, assertFrame, emptyFrames, 
    2123     
    2224    MaybeT, runMaybeT, 
    … …  
    2729import Control.Monad.RWS (MonadPlus(..)) 
    2830import qualified Data.Map as Map 
    29  
     31import qualified Data.Set as Set 
    3032 
    3133newtype MaybeT m a = MaybeT { runMaybeT :: m (Maybe a) } 
    … …  
    106108        { envLexical = MkPad (lex `Map.intersection` envImplicit env) 
    107109        } 
    108     , envDepth = (FrameRoutine:envDepth env) 
     110    , envFrames = FrameRoutine `Set.insert` envFrames env 
    109111    , envImplicit = Map.fromList [(cast "$_", ())] 
    110112    } 
    … …  
    113115 
    114116{-| 
    115 Bind @\$_@ to the given topic value in a new lexical scope, then perform 
    116 the specified evaluation in that scope. 
    117  
    118 Used by "Pugs.Eval"'s implementation of 'Pugs.Eval.reduce' for @\"given\"@. 
    119 -} 
    120 enterGiven :: Eval a -- ^ Action to perform within the new scope 
    121            -> Eval a 
    122 enterGiven = local (\e -> e{ envDepth = (FrameGiven:envDepth e) }) 
     117Register the fact that we are inside a specially marked control block. 
     118-} 
     119enterFrame :: Frame -> Eval a -> Eval a 
     120enterFrame f = local (\e -> e{ envFrames = f `Set.insert` envFrames e}) 
     121 
     122enterGather, enterLoop, enterGiven :: Eval Val -> Eval Val 
     123enterGather = enterFrame FrameGather 
     124enterLoop   = enterFrame FrameLoop 
     125enterGiven  = enterFrame FrameGiven 
     126 
     127assertFrame :: Frame -> Eval a -> Eval a 
     128assertFrame f action = do 
     129    frames <- asks envFrames 
     130    if Set.member f frames 
     131        then action 
     132        else fail ("Cannot use this control structure outside a '" ++ (map toLower (drop 5 (show f))) ++ "' structure") 
     133 
     134emptyFrames :: Set Frame 
     135emptyFrames = Set.empty 
    123136 
    124137{-| 
    … …  
    136149        VControl (ControlGiven GivenBreak)      -> retShiftEmpty 
    137150        _                                       -> retShift rv 
    138  
    139 {-| 
    140 Register the fact that we are inside a loop block. 
    141 -} 
    142 enterLoop :: Eval Val -- ^ Evaluation representing loop test & body 
    143           -> Eval Val 
    144 enterLoop = local (\e -> e{ envDepth = (FrameLoop:envDepth e) }) 
    145151 
    146152{-|