Changeset 14491 for src/Pugs/Eval.hs

Timestamp:

10/24/06 17:19:32 (2 years ago)

Author:

audreyt

Message:

* Implement maybe {...} maybe {...} STM round-robin retry chains.

Files:

• src/Pugs/Eval.hs (modified) (2 diffs)

src/Pugs/Eval.hs

@@ -109 +109 @@
         return val
     when (length val > 100) $ do
-        liftIO $ putStrLn "*** Warning: deep recursion"
-    liftIO $ putStrLn ("***" ++ val ++ str ++ encodeUTF8 (pretty a))
+        liftSTM . unsafeIOToSTM $ putStrLn "*** Warning: deep recursion"
+    liftSTM . unsafeIOToSTM $ putStrLn ("***" ++ val ++ str ++ encodeUTF8 (pretty a))
 
 evaluateMain :: Exp -> Eval Val
@@ -462 +462 @@
 reduceSyn "but" [obj, block] = do
     evalExp $ App (_Var "&Pugs::Internals::but_block") Nothing [obj, block]
+
+reduceSyn "maybe" blocks = do
+    env     <- ask
+    subs    <- mapM fromCodeExp blocks
+    let runInSTM sub = runEvalSTM env (apply sub Nothing [])
+    guardSTM $ foldl1 orElse (map runInSTM subs)
 
 reduceSyn "if" [cond, bodyIf, bodyElse] = do