Changeset 14637 for src/Pugs/Eval.hs

Timestamp:

11/05/06 18:31:43 (2 years ago)

Author:

audreyt

svk:copy_cache_prev:

41990

Message:

* Pugs.Eval: Support for "let" directives that works with

"fail", so the example in ProgrammersHeaven? FAQ now actually
works (if you move "our $state" to the top of the file).

Suggested by: lizr++

Files:

• src/Pugs/Eval.hs (modified) (1 diff)

src/Pugs/Eval.hs

@@ -356 +356 @@
     isn <- liftSTM $ readTVar isNonLocal
     (if isn then retShift else return) val
+
+reducePad SLet lex exp = do
+    tmps <- mapM (\(sym, _) -> evalExp $ App (_Var "&TEMP") (Just $ Var sym) []) $ padToList lex
+    -- default to nonlocal exit
+    isNonLocal  <- liftSTM $ newTVar True
+    val <- tryT $ do
+        -- if the liftSTM is reached, exp evaluated without error; no need to shift out
+        evalExp exp `finallyM` liftSTM (writeTVar isNonLocal False)
+    isn <- liftSTM $ readTVar isNonLocal
+    if isn
+        then do
+            when (isFailure val) $ do
+                mapM_ (\tmp -> evalExp $ App (Val tmp) Nothing []) tmps
+            retShift val
+        else return val
+    where
+    isFailure (VControl (ControlLeave{ leaveValue = v }))
+        | VUndef <- v = True
+        | VRef r <- v = refType r == mkType "Failure"
+        | otherwise   = False
+    isFailure VControl{}    = True
+    isFailure _             = False
+
+
 
 reducePad _ lex exp = do