Changeset 2968

Show
Ignore:
Timestamp:
05/11/05 16:19:49 (4 years ago)
Author:
bsmith
svk:copy_cache_prev:
4536
Message:

Misc refactoring within Pugs.Prim and Pugs.AST. Factored eval primitives
to Pugs.Prim.Eval. Removed Pugs.Cont from Pugs.Internals.

Location:
src
Files:
1 added
9 modified

Legend:

Unmodified
Added
Removed

  • src/Main.hs

    r2790 r2968  
    2828import Pugs.Pretty 
    2929import Pugs.Compile 
     30import Pugs.Embed 
    3031import qualified Data.Map as Map 
    3132import Data.IORef 

  • src/Pugs/AST.hs

    r2962 r2968  
    4040    -- MonadEval(..), 
    4141 
    42     runEvalSTM, runEvalIO, shiftT, resetT, runEvalMain, 
     42    runEvalSTM, runEvalIO, shiftT, resetT, callCC, 
    4343    evalExp, 
    4444    undef, defined, 
    … …  
    6868) where 
    6969import Pugs.Internals 
     70import Pugs.Cont (callCC) 
     71import qualified Data.Map as Map 
    7072 
    7173import Pugs.AST.Internals 
    … …  
    117119    evl <- asks envEval 
    118120    evl exp 
     121 
     122-- |Create a 'Pad'-transforming transaction that will install a symbol 
     123-- definition in the 'Pad' it is applied to, /alongside/ any other mappings 
     124-- of the same name. This is to allow for overloaded (i.e. multi) subs, 
     125-- where one sub name actually maps to /all/ the different multi subs. 
     126-- (Is this correct?) 
     127genMultiSym :: MonadSTM m => String -> VRef -> m (Pad -> Pad) 
     128genMultiSym name ref = do 
     129    tvar    <- liftSTM $ newTVar ref 
     130    fresh   <- liftSTM $ newTVar True 
     131    return $ \(MkPad map) -> MkPad $ 
     132        Map.insertWith (++) name [(fresh, tvar)] map 
     133 
     134-- |Create a 'Pad'-transforming transaction that will install a symbol 
     135-- mapping from a name to a thing, in the 'Pad' it is applied to. 
     136-- Unlike 'genMultiSym', this version just installs a single definition 
     137-- (right?), shadowing any earlier or outer definition. 
     138genSym :: MonadSTM m => String -> VRef -> m (Pad -> Pad) 
     139genSym name ref = do 
     140    tvar    <- liftSTM $ newTVar ref 
     141    fresh   <- liftSTM $ newTVar True 
     142    return $ \(MkPad map) -> MkPad $ Map.insert name [(fresh, tvar)] map 

  • src/Pugs/AST/Internals.hs

    r2962 r2968  
    77import Pugs.Rule 
    88import Pugs.Types 
     9import Pugs.Cont hiding (shiftT, resetT) 
    910import qualified Data.Set       as Set 
    1011import qualified Data.Map       as Map 
    … …  
    861862unionPads (MkPad map1) (MkPad map2) = MkPad $ Map.union map1 map2 
    862863 
    863 -- |Create a 'Pad'-transforming transaction that will install a symbol 
    864 -- definition in the 'Pad' it is applied to, /alongside/ any other mappings 
    865 -- of the same name. This is to allow for overloaded (i.e. multi) subs, 
    866 -- where one sub name actually maps to /all/ the different multi subs. 
    867 -- (Is this correct?) 
    868 genMultiSym :: MonadSTM m => String -> VRef -> m (Pad -> Pad) 
    869 genMultiSym name ref = do 
    870     tvar    <- liftSTM $ newTVar ref 
    871     fresh   <- liftSTM $ newTVar True 
    872     return $ \(MkPad map) -> MkPad $ 
    873         Map.insertWith (++) name [(fresh, tvar)] map 
    874  
    875 -- |Create a 'Pad'-transforming transaction that will install a symbol 
    876 -- mapping from a name to a thing, in the 'Pad' it is applied to. 
    877 -- Unlike 'genMultiSym', this version just installs a single definition 
    878 -- (right?), shadowing any earlier or outer definition. 
    879 genSym :: MonadSTM m => String -> VRef -> m (Pad -> Pad) 
    880 genSym name ref = do 
    881     tvar    <- liftSTM $ newTVar ref 
    882     fresh   <- liftSTM $ newTVar True 
    883     return $ \(MkPad map) -> MkPad $ Map.insert name [(fresh, tvar)] map 
    884  
    885864type Eval x = EvalT (ContT Val (ReaderT Env SIO)) x 
    886865type EvalMonad = EvalT (ContT Val (ReaderT Env SIO)) 
    … …  
    927906    ask       = lift ask 
    928907    local f m = EvalT $ local f (runEvalT m) 
    929  
    930 runEvalMain :: Env -> Eval Val -> IO Val 
    931 runEvalMain env eval = withSocketsDo $ do 
    932     my_perl <- initPerl5 "" 
    933     val     <- runEvalIO env eval 
    934     freePerl5 my_perl 
    935     return val 
    936908 
    937909findSymRef :: (MonadSTM m) => String -> Pad -> m VRef 

  • src/Pugs/Eval.hs

    r2956 r2968  
    3737import Pugs.Prim 
    3838import Pugs.Prim.Match (op2Match) 
     39import Pugs.Prim.List (op0Zip) 
    3940import Pugs.Context 
    4041import Pugs.Monads 
    4142import Pugs.Pretty 
    4243import Pugs.Types 
     44import Pugs.Prim.Eval (retEvalResult) 
     45import Pugs.External 
    4346 
    4447-- |Construct a new, initially empty 'Env' (evaluation environment). 
    … …  
    568571            { '-' -> "__"; _ | isAlphaNum v -> [v] ; _ -> "_" } 
    569572#endif 
    570         op1 "require_haskell" (VStr $ file ++ ".o") 
     573        externRequire "Haskell" (file ++ ".o") 
    571574        retEmpty 
    572575    syn | last syn == '=' -> do 
    … …  
    615618reduce (App (Var "&zip") invs args) = do 
    616619    vals <- mapM (enterRValue . enterEvalContext (cxtItem "Array")) (invs ++ args) 
    617     val  <- op0 "Y" vals 
     620    val  <- op0Zip vals 
    618621    retVal val 
    619622 

  • src/Pugs/Internals.hs

    r2943 r2968  
    1717    module UTF8, 
    1818    module Unicode, 
    19     module Pugs.Embed, 
    2019    module Pugs.Compat, 
    21     module Pugs.Cont, 
    2220    module RRegex, 
    2321    module RRegex.Syntax, 
    … …  
    7169import UTF8 
    7270import Unicode 
    73 import Pugs.Cont hiding (shiftT, resetT) 
    74 import Pugs.Embed 
    7571import Pugs.Compat 
    7672import RRegex 

  • src/Pugs/Monads.hs

    r2966 r2968  
    1616import Pugs.Types 
    1717 
     18headVal :: [Val] -> Eval Val 
    1819headVal []    = retEmpty 
    1920headVal (v:_) = return v 
    … …  
    9293        , subBody = Prim ((esc =<<) . headVal) 
    9394        } 
    94    
     95 
    9596enterSub :: VCode -> Eval Val -> Eval Val 
    9697enterSub sub action 

  • src/Pugs/Prim.hs

    r2957 r2968  
    1111-} 
    1212 
    13 module Pugs.Prim where 
     13module Pugs.Prim ( 
     14    primOp, 
     15    primDecl, 
     16    initSyms, 
     17    op2DefinedOr, 
     18    op2ChainedList, 
     19    op1Exit, 
     20    -- used by Pugs.Compile.Haskell 
     21    op0, op1, op2, 
     22) where 
    1423import Pugs.Internals 
    1524import Pugs.Junc 
    … …  
    1726import Pugs.Types 
    1827import Pugs.Pretty 
    19 import Pugs.Parser 
     28import Text.Printf 
    2029import Pugs.External 
    21 import Text.Printf 
     30import Pugs.Embed 
    2231import qualified Data.Map as Map 
    2332 
    … …  
    2938import Pugs.Prim.Numeric 
    3039import Pugs.Prim.Lifts 
     40import Pugs.Prim.Eval 
    3141 
    3242op0 :: Ident -> [Val] -> Eval Val 
    … …  
    4454op0 "not" = const retEmpty 
    4555op0 "so" = const (return $ VBool True) 
    46 op0 "¥" = fmap (VList . concat . op0Zip) . mapM fromVal 
     56op0 "¥" = op0Zip 
    4757op0 "Y" = op0 "¥" 
    4858op0 "File::Spec::cwd" = const $ do 
    … …  
    235245    strs <- fromVal v 
    236246    fail (concat strs) 
    237 op1 "exit" = \v -> do 
    238     rv <- fromVal v 
    239     if rv /= 0 
    240         then shiftT . const . return . VControl . ControlExit . ExitFailure $ rv 
    241         else shiftT . const . return . VControl . ControlExit $ ExitSuccess 
     247op1 "exit" = op1Exit 
    242248op1 "readlink" = \v -> do 
    243249    str  <- fromVal v 
    … …  
    427433op1 other   = \_ -> fail ("Unimplemented unaryOp: " ++ other) 
    428434 
    429 op1EvalHaskell :: Val -> Eval Val 
    430 op1EvalHaskell cv = do 
    431     str     <- fromVal cv :: Eval String 
    432     ret     <- liftIO (evalHaskell str) 
    433     glob    <- askGlobal 
    434     errSV   <- findSymRef "$!" glob 
    435     case ret of 
    436         Right str -> do 
    437             writeRef errSV VUndef 
    438             return $ VStr str 
    439         Left  err -> do 
    440             writeRef errSV (VStr err) 
    441             retEmpty 
     435op1Exit v = do 
     436    rv <- fromVal v 
     437    if rv /= 0 
     438        then shiftT . const . return . VControl . ControlExit . ExitFailure $ rv 
     439        else shiftT . const . return . VControl . ControlExit $ ExitSuccess 
    442440 
    443441op1StrFirst :: (Char -> Char) -> Val -> Eval Val 
    … …  
    490488        f x y 
    491489        return (VBool True) 
    492  
    493 opEval :: Bool -> String -> String -> Eval Val 
    494 opEval fatal name str = do 
    495     env <- ask 
    496     let env' = runRule env id ruleProgram name str 
    497     val <- resetT $ local (const env') $ do 
    498         evl <- asks envEval 
    499         evl (envBody env') 
    500     retEvalResult fatal val 
    501  
    502 retEvalResult :: Bool -> Val -> Eval Val 
    503 retEvalResult fatal val = do 
    504     glob <- askGlobal 
    505     errSV <- findSymRef "$!" glob 
    506     case val of 
    507         VError str _ | not fatal  -> do 
    508             writeRef errSV (VStr str) 
    509             retEmpty 
    510         _ -> do 
    511             writeRef errSV VUndef 
    512             return val 
    513490 
    514491mapStr :: (Word8 -> Word8) -> [Word8] -> String 

  • src/Pugs/Prim/List.hs

    r2961 r2968  
    1111import Pugs.Prim.Numeric 
    1212 
    13 op0Zip :: [[Val]] -> [[Val]] 
    14 op0Zip lists | all null lists = [] 
    15 op0Zip lists = (map zipFirst lists):(op0Zip (map zipRest lists)) 
     13op0Zip = fmap (VList . concat . op0Zip') . mapM fromVal 
     14 
     15op0Zip' :: [[Val]] -> [[Val]] 
     16op0Zip' lists | all null lists = [] 
     17op0Zip' lists = (map zipFirst lists):(op0Zip' (map zipRest lists)) 
    1618    where 
    1719    zipFirst []     = undef 

  • src/Pugs/Run.hs

    r2926 r2968  
    1818import Pugs.Eval 
    1919import Pugs.Prim 
     20import Pugs.Embed 
    2021import qualified Data.Map as Map 
    2122 
    … …  
    2324    args <- getArgs 
    2425    f $ canonicalArgs args 
     26 
     27runEvalMain :: Env -> Eval Val -> IO Val 
     28runEvalMain env eval = withSocketsDo $ do 
     29    my_perl <- initPerl5 "" 
     30    val     <- runEvalIO env eval 
     31    freePerl5 my_perl 
     32    return val 
    2533 
    2634runEnv :: Env -> IO Val 
    … …  
    7987#endif 
    8088    let subExit = \x -> case x of 
    81             [x] -> op1 "exit" x 
    82             _   -> op1 "exit" undef 
     89            [x] -> op1Exit x     -- needs refactoring (out of Prim) 
     90            _   -> op1Exit undef 
    8391    emptyEnv name $ 
    8492        [ genSym "@*ARGS"       $ MkRef argsAV