Changeset 16378

Timestamp:

05/17/07 23:41:38 (18 months ago)

Author:

audreyt

Message:

* Fix trait blocks and their interactions.

Location:

src/Pugs

Files:

• AST/Internals.hs (modified) (2 diffs)
• AST/SIO.hs (modified) (2 diffs)
• Eval.hs (modified) (1 diff)
• Monads.hs (modified) (4 diffs)
• Parser.hs (modified) (2 diffs)
• Parser/Program.hs (modified) (1 diff)

src/Pugs/AST/Internals.hs

@@ -42 +42 @@
 
     IVar(..), -- uses *Class and V*
-    IArray, IArraySlice, IHash, IScalar, IScalarProxy,
+    IArray(..), IArraySlice, IHash, IScalar, IScalarProxy,
     IScalarLazy, IPairHashSlice, IRule, IHandle, IHashEnv(..),
     IScalarCwd(..),
@@ -1463 +1463 @@
 refreshPad pad = do
     fmap listToPad $ forM (padToList pad) $ \(name, entry) -> do
+        -- warn "Refreshing pad entry" (name, entry)
         entry' <- case entry of
             PELexical{ pe_proto = proto } -> stm $ do

src/Pugs/AST/SIO.hs

@@ -54 +54 @@
     liftSIO :: SIO a -> m a
     liftSIO = fail "liftSIO not detailed for this monad"
+    {-# SPECIALISE liftSTM :: STM a -> STM a #-}
+    {-# SPECIALISE liftSTM :: STM a -> IO a #-}
+    {-# SPECIALISE liftSTM :: STM a -> SIO a #-}
     liftSTM :: STM a -> m a
 
@@ -71 +74 @@
     liftIO io = MkIO io
 
+{-# INLINE stm #-}
 stm :: (MonadSTM m) => STM a -> m a
 stm = liftSTM

src/Pugs/Eval.hs

@@ -451 +451 @@
 
 reduceSyn "sub" [exp] = do
-    (VCode sub) <- enterEvalContext (cxtItem "Code") exp
+    sub  <- fromCodeExp exp
     env  <- ask
     cont <- if subType sub /= SubCoroutine then return Nothing else stm $ do

src/Pugs/Monads.hs

@@ -26 +26 @@
     reclosePad, recloseCode,
     
-    MaybeT, runMaybeT,
+    MaybeT, runMaybeT
 ) where
 import Pugs.Internals
@@ -278 +278 @@
                 local doFix runAction
         runBlocks (filter (rejectKeepUndo rv . subName) . subLeaveBlocks)
-
     when (rv == VControl (ControlLoop LoopLast)) $
         -- We won't have a chance to run the LAST block
         -- once we exit outside the lexical block, so do it now
         runBlocks subLastBlocks
-
     assertBlocks subPostBlocks "POST"
     case rv of
@@ -311 +309 @@
         rv <- fromVal =<< (evalExp . Syn "block" . (:[]) . Syn "sub" . (:[]) . Val . castV $ cv)
         if rv then return () else die (name ++ " assertion failed") (subName sub)
+    runBlocks' f = mapM_ (evalExp . Syn "block'" . (:[]) . Syn "sub" . (:[]) . Val . castV) (f (subTraitBlocks sub))
+    assertBlocks' f name = forM_ (f (subTraitBlocks sub)) $ \cv -> do
+        rv <- fromVal =<< (evalExp . Syn "block'" . (:[]) . Syn "sub" . (:[]) . Val . castV $ cv)
+        if rv then return () else die (name ++ " assertion failed") (subName sub)
     typ = subType sub
     doCC :: (Val -> Eval b) -> [Val] -> Eval b
@@ -328 +330 @@
             return $ \e -> e
                 { envLexical = subRec (envLexical env `mappend` pad)
+                , envPackage = subPackage sub
+                , envLexPads = (PRuntime pad:envLexPads env)
+                }
+        | AKInline <- appKind = do
+            -- Entering an inline call.
+            subRec    <- genRecSym
+            return $ \e -> e
+                { envLexical = subRec (pad `mappend` envLexical env)
                 , envPackage = subPackage sub
                 , envLexPads = (PRuntime pad:envLexPads env)

src/Pugs/Parser.hs

@@ -1038 +1038 @@
 
 vcode2initBlock :: Val -> RuleParser Exp
-vcode2initBlock code = do
-    body    <- vcode2startBlock code
-    let fstcode = Syn "sub" [ Val $ VCode mkSub { subBody = body } ]
+vcode2initBlock ~(VCode code) = do
+    code'   <- vcode2memoized code
     Val res <- unsafeEvalExp $
-        App (_Var "&push") (Just $ _Var "@*INIT") [ fstcode ]
-    return (res `seq` App fstcode Nothing [])
+        App (_Var "&push") (Just $ _Var "@*INIT") [ Val (VCode code') ]
+    return (res `seq` App (Val (VCode code')) Nothing [])
 
 vcode2checkBlock :: Val -> RuleParser Exp
@@ -1050 +1049 @@
     let fstcode = Syn "sub" [ checkForIOLeak mkSub{ subBody = body } ]
     Val res <- unsafeEvalExp $
-        App (_Var "&unshift") (Just $ _Var "@*CHECK") [ fstcode ]
-    return (res `seq` App fstcode Nothing [])
+        App (_Var "&unshift") (Just $ _Var "@*CHECK") [ Val (VCode code') ]
+    return (res `seq` App (Val (VCode code')) Nothing [])
 
 -- Constructs ------------------------------------------------

src/Pugs/Parser/Program.hs

@@ -195 +195 @@
         { envBody       = App (Syn "block" [main']) Nothing (replicate (length $ subParams vc) (_Var "$*_")) -- _Var "@*ARGS"]
         , envPackage    = envPackage env
+        , envCompPad    = Nothing
         }