Changeset 26 for src/Eval.hs

Show
Ignore:
Timestamp:
02/14/05 06:02:18 (4 years ago)
Author:
autrijus
svk:copy_cache_prev:
1041
Message:

* snapshot during monadic refactoring

Files:
1 modified

Legend:

Unmodified
Added
Removed

  • src/Eval.hs

    r25 r26  
    2222import Monad 
    2323 
    24 emptyEnv = Env { envContext = "List" 
    25                , envPad     = [initSyms] 
    26                , envClasses = initTree 
    27                , envEval    = evaluate 
    28                } 
    29  
    30 addSym :: Symbols -> StateEnv () 
    31 addSym syms = modify doAddSyms 
    32     where 
    33     doAddSyms env@Env{ envPad = (pad:outer) } = env{ envPad = ((syms++pad):outer) } 
    34  
    35 pushPad :: Symbols -> StateEnv () 
    36 pushPad syms = modify (\env -> env{ envPad = tail $ envPad env }) 
    37  
    38 popPad :: StateEnv () 
    39 popPad = modify (\env -> env{ envPad = tail $ envPad env }) 
    40  
    41 evaluate :: Exp -> StateEnv Val 
     24emptyEnv :: (MonadIO m) => m Env 
     25emptyEnv = do 
     26    uniq <- liftIO newUnique 
     27    return $ Env 
     28        { envContext = "List" 
     29        , envPad     = initSyms 
     30        , envClasses = initTree 
     31        , envEval    = evaluate 
     32        , envCC      = return 
     33        , envDepth   = 0 
     34        , envID      = uniq 
     35        , envBody    = Val VUndef 
     36        } 
     37 
     38evaluate :: Exp -> Eval Val 
    4239evaluate exp = do 
    43     val <- reduce exp 
     40    val <- local (\e -> e { envBody = exp }) reduce 
    4441    return $ case val of 
    4542        Val v       -> v 
    4643        otherwise   -> VError "Invalid expression" exp 
    4744 
     45evalEnv :: Exp -> Eval Val 
     46evalEnv exp = do 
     47    evl <- asks envEval 
     48    evl exp 
     49 
     50evalEnvWithContext :: Cxt -> Exp -> Eval Val 
     51evalEnvWithContext cxt exp = do 
     52    local (\e -> e { envContext = cxt }) $ evalEnv exp 
     53 
     54-- addSym :: Pad -> Eval () 
     55addSym syms f = local doAddSyms f 
     56    where 
     57    doAddSyms env@Env{ envPad = pad } = env{ envPad = syms++pad } 
     58 
    4859-- OK... Now let's implement the hideously clever autothreading algorithm. 
    4960-- First pass - thread thru all() and none() 
    5061-- Second pass - thread thru any() and one() 
    5162 
    52 chainFun :: Params -> Exp -> Params -> Exp -> [Val] -> StateEnv Val 
     63chainFun :: Params -> Exp -> Params -> Exp -> [Val] -> Eval Val 
    5364chainFun p1 f1 p2 f2 (v1:v2:vs) = do 
    5465    val <- applyFun (chainArgs p1 [v1, v2]) f1 
    … …  
    6071    chainArg (p, v) = ApplyArg (paramName p) v False 
    6172 
    62 applyFun :: [ApplyArg] -> Exp -> StateEnv Val 
     73applyFun :: [ApplyArg] -> Exp -> Eval Val 
    6374applyFun bound (Prim f) 
    6475    = f [ argValue arg | arg <- bound, (argName arg !! 1) /= '_' ] 
    6576applyFun bound body = do 
    66     pushPad formal 
    67     exp <- reduce body 
    68     return $ case exp of 
    69         Val val     -> val 
    70         otherwise   -> VError "Invalid expression" exp 
     77    -- pushPad formal 
     78    evalEnv body 
    7179    where 
    7280    formal = filter (not . null . symName) $ map argNameValue bound 
    7381    argNameValue (ApplyArg name val _) = Symbol SMy name val 
    7482 
    75 apply :: VSub -> [Exp] -> [Exp] -> StateEnv Exp 
     83apply :: VSub -> [Exp] -> [Exp] -> Eval Exp 
    7684apply sub invs args = do 
    77     env <- get 
     85    env <- ask 
    7886    doApply env sub invs args 
    7987 
    80 doApply :: Env -> VSub -> [Exp] -> [Exp] -> StateEnv Exp 
     88doApply :: Env -> VSub -> [Exp] -> [Exp] -> Eval Exp 
    8189doApply env@Env{ envClasses = cls } Sub{ subParams = prms, subFun = fun } invs args = 
    8290    case bindParams prms invs args of 
    … …  
    100108        | otherwise                     = False 
    101109 
    102 evalEnv exp = do 
    103     evl <- gets envEval 
    104     evl exp 
    105  
    106 evalEnvWithContext newCxt exp = do 
    107     Env{ envContext = cxt, envEval = evl } <- get 
    108     modify (\env -> env{ envContext = newCxt }) 
    109     val <- evl exp 
    110     modify (\env -> env{ envContext = cxt }) 
    111     return val 
    112  
    113110toGlobal name 
    114111    | (sigil, identifier) <- break (\x -> isAlpha x || x == '_') name 
    … …  
    117114    | otherwise = name 
    118115 
    119 retVal :: Val -> StateEnv Exp 
     116retVal :: Val -> Eval Exp 
    120117retVal val = return $ Val val 
    121118 
    … …  
    123120isGlobalExp _ = False 
    124121 
    125 findSym :: String -> [Symbols] -> Maybe Val 
     122findSym :: String -> Pad -> Maybe Val 
    126123findSym name pad 
    127     | Just s <- find ((== name) . symName) (concat pad) 
     124    | Just s <- find ((== name) . symName) pad 
    128125    = Just $ symValue s 
    129126    | otherwise 
    130127    = Nothing 
    131128 
    132 reduce :: Exp -> StateEnv Exp 
    133 reduce exp = do 
    134     env <- get 
    135     doReduce env exp 
     129reduce :: Eval Exp 
     130reduce = do 
     131    env@Env{ envBody = body } <- ask 
     132    doReduce env body 
    136133 
    137134doReduce Env{ envPad = pad } exp@(Var var _) 
    … …  
    152149        let [Var var _, exp] = exps 
    153150        val     <- evalEnv exp 
    154         addSym [Symbol SMy var val] -- XXX scope 
     151        -- addSym [Symbol SMy var val] -- XXX scope 
    155152        retVal val 
    156153    "::=" -> do -- XXX wrong 
    157154        let [Var var _, exp] = exps 
    158155        val     <- evalEnv exp 
    159         addSym [Symbol SMy var val] -- XXX scope 
     156        -- addSym [Symbol SMy var val] -- XXX scope 
    160157        retVal VUndef 
    161158    "=>" -> do 
    … …  
    234231        , fromJust fun 
    235232        ) 
    236         | ((Symbol _ n val), order) <- concat pad `zip` [0..] 
     233        | ((Symbol _ n val), order) <- pad `zip` [0..] 
    237234        , let sub@(Sub{ subType = subT, subReturns = ret, subParams = prms }) = vCast val 
    238235        , (n ==) `any` [name, toGlobal name] 
    … …  
    250247    deltaFromScalar x       = deltaType cls x "Scalar" 
    251248 
    252 doReduce _ (Parens exp) = reduce exp 
     249doReduce env (Parens exp) = doReduce env exp 
    253250doReduce _ other = return other 
    254251