Changeset 16488

Timestamp:

05/21/07 21:51:00 (18 months ago)

Author:

audreyt

Message:

* Introduce the envPosStack abstraction to cleanup the

stack-trace generaion; "fail" now also generates trace.

Location:

src/Pugs

Files:

• AST.hs (modified) (2 diffs)
• Prim.hs (modified) (2 diffs)

src/Pugs/AST.hs

@@ -19 +19 @@
     newPackage, newType, newMetaType, typeMacro, isScalarLValue,
     filterPrim, filterUserDefinedPad, typeOfParam, listVal, isImmediateMatchContext,
-    (./), defaultScalarPad,
+    (./), defaultScalarPad, envPosStack,
 
     module Pugs.AST.Internals,
@@ -506 +506 @@
 defaultScalarPad = mkPad [(varTopic, PELexical anyType defaultScalarRef mempty defaultScalarPadStore)]
 
+envPosStack :: Env -> [Pos]
+envPosStack env = envPos env : maybe [] envPosStack (envCaller env)
+

src/Pugs/Prim.hs

@@ -379 +379 @@
     return $ VBool True
 op1 "die" = \v -> do
-    v'  <- fromVal $! v
-    env <- ask
-    retShift $! VError (errmsg $! v') (collectPos (Just env))
+    v'      <- fromVal $! v
+    poss    <- asks envPosStack
+    retShift $! VError (errmsg $! v') poss
     where
     errmsg VUndef      = VStr "Died"
@@ -389 +389 @@
     errmsg (VList [x]) = x
     errmsg x           = x
-    collectPos Nothing    = []
-    collectPos (Just env) = (envPos env:collectPos (envCaller env))
 op1 "warn" = \v -> do
     strs <- fromVal v
     errh <- readVar $ cast "$*ERR"
-    env  <- ask
-    op2 "IO::say" errh $ VList [ VStr $ pretty (VError (errmsg strs) (collectPos (Just env))) ]
+    poss    <- asks envPosStack
+    op2 "IO::say" errh $ VList [ VStr $ pretty (VError (errmsg strs) poss) ]
     where
     errmsg "" = VStr "Warning: something's wrong"
     errmsg x  = VStr x
-    collectPos Nothing    = []
-    collectPos (Just env) = (envPos env:collectPos (envCaller env))
 op1 "fail" = op1 "fail_" -- XXX - to be replaced by Prelude later
 op1 "fail_" = \v -> do
     throw <- fromVal =<< readVar (cast "$*FAIL_SHOULD_DIE")
     if throw then op1 "die" (errmsg v) else do
-    pos   <- asks envPos
-    let die = retShift $ VError (errmsg v) [pos]
+    poss    <- asks envPosStack
+    let die = retShift $ VError (errmsg v) poss
         dieThunk = VRef . thunkRef $ MkThunk die (mkType "Failure")
     op1Return (retControl (ControlLeave (<= SubRoutine) 0 dieThunk))