Changeset 7035

Timestamp:

09/17/05 22:55:58 (3 years ago)

Author:

gaal

Message:

Lexical pragmas (WIP). See Pugs.AST.Prag. Dominus++.
This doesn't work yet, my pragmas got lost somewhere between the parser
and the evaluator.
TODO after it's fixed:
- throw away the cons list in favor of a primitive [] - it's enough
- figure out how to install other kinds of pragma data, not just Int

And, the fun part:
- use fatal
- use sort 'mergesort'
- no strict :-)
- other ideas from http://perl.plover.com/TPF/Pragmas/PROPOSAL

Files:

• src/Pugs/AST.hs (modified) (2 diffs)
• src/Pugs/AST/Internals.hs (modified) (6 diffs)
• src/Pugs/AST/Prag.hs (added)
• src/Pugs/Eval.hs (modified) (4 diffs)
• src/Pugs/Monads.hs (modified) (1 diff)
• src/Pugs/Parser.hs (modified) (1 diff)
• src/Pugs/Prim.hs (modified) (3 diffs)
• t/packages/lexical_pragmas.t (added)
• t/packages/pragma (added)
• t/packages/pragma/Demo.pm (added)

src/Pugs/AST.hs

@@ -21 +21 @@
 
     module Pugs.AST.Internals,
+    module Pugs.AST.Prag,
     module Pugs.AST.Pos,
     module Pugs.AST.Scope,
@@ -31 +32 @@
 
 import Pugs.AST.Internals
+import Pugs.AST.Prag
 import Pugs.AST.Pos
 import Pugs.AST.Scope

src/Pugs/AST/Internals.hs

@@ -9 +9 @@
     Val(..),   -- uses V.* (which ones?)
     Value(..), -- uses Val, Eval
+    InitDat(..),
 
     EvalT(..), ContT(..),
@@ -79 +80 @@
 
 import Pugs.Parser.Number
+import Pugs.AST.Prag
 import Pugs.AST.Pos
 import Pugs.AST.Scope
@@ -862 +864 @@
     | Cxt !Cxt !Exp                     -- ^ Context
     | Pos !Pos !Exp                     -- ^ Position
+    | Prag !Pragmas !Exp                -- ^ Lexical pragmas
     | Pad !Scope !Pad !Exp              -- ^ Lexical pad
     | Sym !Scope !Var !Exp              -- ^ Symbol declaration
@@ -904 +907 @@
     unwrap (Cxt _ exp)      = unwrap exp
     unwrap (Pos _ exp)      = unwrap exp
+    unwrap (Prag _ exp)     = unwrap exp
     unwrap (Pad _ _ exp)    = unwrap exp
     unwrap (Sym _ _ exp)    = unwrap exp
@@ -954 +958 @@
     | otherwise
     = (Var name, vs)
+extract (Prag prag ex) vs = ((Prag prag ex'), vs')
+    where
+    (ex', vs') = extract ex vs
 extract (Pos pos ex) vs = ((Pos pos ex'), vs')
     where
@@ -1043 +1050 @@
     , envDebug   :: !DebugInfo           -- ^ Debug info map
     , envPos     :: !Pos                 -- ^ Source position range
+    , envPragmas :: !Pragmas             -- ^ List of pragmas in effect
+    , envInitDat :: !(TVar InitDat)      -- ^ BEGIN result information
+    } deriving (Show, Eq, Ord, Typeable)
+
+{-|
+Module initialization information.
+
+When a module is loaded and initialized (i.e., its &import routine is
+called), it may need to communicate information back to the parser. 
+This information is held in a TVar to which the parser has access.
+Currently we use this for keeping track of lexical pragma change
+requests, but the possiblyExit mechanism may be refactored to use
+this as well.
+-}
+data InitDat = MkInitDat
+    { initPragmas :: [Pragma]            -- ^ Pragma values being installed
     } deriving (Show, Eq, Ord, Typeable)
 

src/Pugs/Eval.hs

@@ -61 +61 @@
     syms <- initSyms
     glob <- newTVar (combine (pad ++ syms) $ mkPad [])
+    init <- newTVar $ MkInitDat { initPragmas=[] }
     return $ MkEnv
         { envContext = CxtVoid
@@ -77 +78 @@
         , envDebug   = Just ref -- Set to "Nothing" to disable debugging
         , envPos     = MkPos name 1 1 1 1
+        , envPragmas = PrNil
+        , envInitDat = init
         }
 
@@ -229 +232 @@
 reduce (Stmts this rest) = reduceStmts this rest
 
+reduce (Prag prag exp) = reducePrag prag exp
+
 reduce (Pos pos exp) = reducePos pos exp
 
@@ -283 +288 @@
             return . VControl $ ControlEnv env
         _ -> reduce rest
+
+reducePrag :: Pragmas -> Exp -> Eval Val
+reducePrag prag exp = do
+    local (\e -> e{ envPragmas = prag }) $ do
+        evalExp exp
 
 {-|

src/Pugs/Monads.hs

@@ -71 +71 @@
 
 {-|
-Evaluate the specified wxpression in the specified (Perl 6) context ('Cxt').
+Evaluate the specified expression in the specified (Perl 6) context ('Cxt').
 
 (Subsequent chained 'Eval's do /not/ see this new scope.)

src/Pugs/Parser.hs

@@ -898 +898 @@
         "BEGIN" -> do
             -- We've to exit if the user has written code like BEGIN { exit }.
-            possiblyExit =<< unsafeEvalExp (checkForIOLeak fun)
+            val <- possiblyExit =<< unsafeEvalExp (checkForIOLeak fun)
+            -- And install any pragmas they've requested.
+            env <- getRuleEnv
+            let idat = unsafePerformIO $ liftSTM $ readTVar $ envInitDat env
+            install $ initPragmas idat
+            return val
         "CHECK" -> vcode2checkBlock code
         "INIT"  -> vcode2initBlock code
         "FIRST" -> vcode2firstBlock code
         _       -> fail ""
+    where
+        install [] = return ()
+        install (x:xs) = do
+            env' <- getRuleEnv
+            let env'' = envCaller env'  -- not sure about this.
+            case env'' of
+                Just target -> do
+                    putRuleEnv target { envPragmas =
+                        PrPrags{ pragma  = x
+                               , pragmas = envPragmas target} }
+                    install xs
+                _ -> fail "no caller env to install pragma in"
 
 {-| Wraps a call to @&Pugs::Internals::check_for_io_leak@ around the input

src/Pugs/Prim.hs

@@ -598 +598 @@
         VRule MkRulePCRE{rxAdverbs=hash} -> return hash
         _ -> fail $ "Not a rule: " ++ show v
+op1 "Pugs::Internals::current_pragma_value" = \v -> do
+    name <- fromVal v
+    prags <- asks envPragmas
+    return $ findPrag name prags
+    where
+        findPrag :: String -> Pragmas -> Val
+        findPrag _ PrNil = VUndef
+        findPrag n PrPrags {pragma=this, pragmas=rest}
+            | n == pragName this = VInt $ toInteger $ pragDat this
+            | otherwise          = findPrag n rest
+op1 "Pugs::Internals::caller_pragma_value" = \v -> do
+    caller <- asks envCaller
+    case caller of
+        Just env -> local (const env) (op1 "Pugs::Internals::current_pragma_value" v)
+        _        -> return $ VUndef
 op1 other   = \_ -> fail ("Unimplemented unaryOp: " ++ other)
 
@@ -927 +942 @@
 op2 "IO::print" = op2Print hPutStr
 op2 "BUILDALL" = op1WalkAll reverse "BUILD"
+op2 "Pugs::Internals::install_pragma_value" = \x y -> do
+    name <- fromVal x
+    val  <- fromVal y
+    idat <- asks envInitDat
+    idatval <- liftSTM $ readTVar idat
+    trace ("installing " ++ name ++ "/" ++ (show val)) $ return ()
+    let prag = initPragmas idatval
+    liftSTM $ writeTVar idat idatval{initPragmas = 
+        prag ++ [MkPrag{ pragName=name, pragDat=val }]}
+    return (VBool True)
 op2 other = \_ _ -> fail ("Unimplemented binaryOp: " ++ other)
 
@@ -1678 +1703 @@
 \\n   Str       pre     Pugs::Internals::rule_pattern safe (Pugs::Internals::VRule)\
 \\n   Hash      pre     Pugs::Internals::rule_adverbs safe (Pugs::Internals::VRule)\
+\\n   Int       pre     Pugs::Internals::install_pragma_value safe (Str, Int)\
+\\n   Bool      pre     Pugs::Internals::current_pragma_value safe (Str)\
+\\n   Bool      pre     Pugs::Internals::caller_pragma_value safe (Str)\
 \\n"