Changeset 7 for src/Eval.hs

Show
Ignore:
Timestamp:
02/09/05 06:00:26 (4 years ago)
Author:
autrijus
svk:copy_cache_prev:
1041
Message:

* This be 6.0.2

Files:
1 modified

Legend:

Unmodified
Added
Removed

  • src/Eval.hs

    r1 r7  
    44    Evaluation and reduction engine. 
    55 
    6     Tree and flower and leaf and grass, 
    7     Let them pass! Let them pass! 
    8     Hill and water under sky, 
    9     Pass them by! Pass them by! 
     6    Home is behind, the world ahead, 
     7    And there are many paths to tread 
     8    Through shadows to the edge of night, 
     9    Until the stars are all alight. 
     10    Then world behind and home ahead, 
     11    We'll wander back to home and bed... 
    1012-} 
    1113 
    1214module Eval where 
     15import Internals 
     16 
    1317import AST 
    1418import Prim 
     19import Context 
    1520 
    16 type Env = () 
    17 emptyEnv = () 
     21data Env = Env { cxt :: Cxt 
     22               , sym :: Symbols 
     23               , cls :: ClassTree 
     24               } deriving (Show) 
     25emptyEnv = Env { cxt = "List" 
     26               , sym = initSyms 
     27               , cls = initTree 
     28               } 
     29 
     30addSym :: Env -> [(String, Val)] -> Env 
     31addSym env [] = env 
     32addSym env ((var, val):vs) = env{ sym = (var, val):(sym $ addSym env vs) } 
    1833 
    1934evaluate :: Env -> Exp -> Val 
    20 evaluate env exp 
    21     | Val v <- reduce env exp   = v 
    22     | otherwise                 = VError "invalid expression" exp 
    23  
    24 -- Lazy evaluation for lists. 
    25 -- Context propagation. 
     35evaluate env@Env{ cxt = cxt, cls = cls } exp 
     36    | Val v <- val  = v 
     37    | otherwise     = VError "Invalid expression" exp 
     38    where 
     39    (env', val) = reduce env exp 
     40    isaContext = isaType cls cxt 
    2641 
    2742-- OK... Now let's implement the hideously clever autothreading algorithm. 
    … …  
    4459    = Nothing 
    4560 
    46 reduce :: Env -> Exp -> Exp 
    47 reduce env (Op1 name exp) 
    48     | VError _ _ <- arg 
    49     = Val $ arg 
    50     | VJunc j l <- arg 
    51     = if name == "?" 
    52         then Val $ VBool (vCast arg) 
    53         else Val $ VJunc j [ reval a | a <- l ] 
     61applyFun :: Env -> Exp -> [Val] -> Val 
     62applyFun env (Prim f) vals = f vals 
     63applyFun env body vals 
     64    | Val val   <- exp          = val 
     65    | otherwise                 = VError "Invalid expression" exp 
     66    where 
     67    (fenv, exp) = reduce (env `addSym` [("$_", head vals),("@_", VList vals)]) body 
     68 
     69chainFun :: Env -> Exp -> Exp -> [Val] -> Val 
     70chainFun env f1 f2 (v1:v2:vs) 
     71    | VBool False <- applyFun env f1 [v1, v2] 
     72    = VBool False 
    5473    | otherwise 
    55     = Val $ op1 name (vCast arg) 
     74    = applyFun env f2 (v2:vs) 
     75 
     76apply :: Env -> VSub -> [Exp] -> ((Env -> Env), Exp) 
     77apply env@Env{ cls = cls } Sub{ subParams = prms, subFun = fun } exps 
     78    = retVal $ juncApply eval args 
    5679    where 
    57     arg = evaluate env exp 
    58     reval = evaluate env . Op1 name . Val 
     80    eval = applyFun env fun 
     81    args = map expToVal (prms `zip` exps) 
     82    expToVal (cxt, exp) = (evaluate env{ cxt = cxt } exp, isaType cls cxt "Bool") 
    5983 
    60 reduce env (OpCmp name exp1 exp2) 
    61     | OpCmp _ _ exp1b <- exp1 
    62     = reduce env $ Op2 "&&" exp1 $ Op2 name exp1b exp2 
     84juncApply f args 
     85    | (before, (VJunc j vs, cxt):after) <- break isTotalJunc args 
     86    = VJunc j [ juncApply f (before ++ ((v, cxt):after)) | v <- vs ] 
     87    | (before, (VJunc j vs, cxt):after) <- break isPartialJunc args 
     88    = VJunc j [ juncApply f (before ++ ((v, cxt):after)) | v <- vs ] 
     89    | (val, _):_ <- [ err | err@(VError _ _, _) <- args ] 
     90    = val 
    6391    | otherwise 
    64     = reduce env $ Op2 name exp1 exp2 
     92    = f $ map fst args  
    6593 
    66 {- XXX - this really wants a rewrite with multi subs -} 
    67 reduce env (Op2 name exp1 exp2) 
    68     | name `elem` words " ! & | ^ && || ^^ // and or xor err " -- XXX contextify 
    69     = Val $ op arg1 arg2 
    70     | VError _ _ <- arg1 = Val $ arg1 
    71     | VError _ _ <- arg2 = Val $ arg2 
    72     -- two junctions, all/none at left 
    73     | Just (j1, l1) <- arg1 `juncTypeIs` [JAll, JNone] 
    74     , Just (j2, l2) <- juncType arg2 
    75     = Val $ VJunc j1 [ VJunc j2 [ reval a1 a2 | a2 <- l2 ] | a1 <- l1 ] 
    76     -- two junctions, all/none at right 
    77     | Just (j1, l1) <- juncType arg1 
    78     , Just (j2, l2) <- arg2 `juncTypeIs` [JAll, JNone] 
    79     = Val $ VJunc j2 [ VJunc j1 [ reval a1 a2 | a1 <- l1 ] | a2 <- l2 ] 
    80     -- two junctions with all low prec. 
    81     | Just (j1, l1) <- juncType arg1 
    82     , Just (j2, l2) <- juncType arg2 
    83     = Val $ VJunc j1 [ VJunc j2 [ reval a1 a2 | a2 <- l2 ] | a1 <- l1 ] 
    84     -- one junctions at left 
    85     | Just (j, l) <- juncType arg1 
    86     = Val $ VJunc j [ reval a arg2 | a <- l ] 
    87     -- one junctions at right 
    88     | Just (j, l) <- juncType arg2 
    89     = Val $ VJunc j [ reval arg1 a | a <- l ] 
     94retVal :: Val -> ((Env -> Env), Exp) 
     95retVal val = (id, Val val) 
     96 
     97reduce :: Env -> Exp -> ((Env -> Env), Exp) 
     98reduce env@Env{ sym = sym } exp@(Var var _) 
     99    | Just val <- lookup var sym 
     100    = retVal val 
    90101    | otherwise 
    91     = Val $ op arg1 arg2 
     102    = retVal $ VError ("Undefined variable " ++ var) exp 
     103 
     104reduce env@Env{ cxt = cxt } exp@(Syn name exps) 
     105    | name `isInfix` ";" 
     106    , [left, right]     <- exps 
     107    , (env', exp)       <- runStatement "Any" (env, Val VUndef) left 
     108    , (env', exp)       <- runStatement cxt   (env', exp)       right 
     109    = (const env', exp) 
     110    | name `isInfix` ":=" 
     111    , [Var var _, exp]  <- exps 
     112    , (fenv, Val val)   <- reduce env exp 
     113    = (combineEnv fenv var val, Val val) 
     114    | name `isInfix` "::=" 
     115    , [Var var _, Val val]  <- exps 
     116    = (combineEnv id var val, Val VUndef) 
    92117    where 
    93     op = op2 name 
    94     arg1 = evaluate env exp1 
    95     arg2 = evaluate env exp2 
    96     reval x y = evaluate env $ Op2 name (Val x) (Val y) 
     118    runStatement :: Cxt -> (Env, Exp) -> Exp -> (Env, Exp) 
     119    runStatement cxt (env, (Val val)) exp 
     120        | VError _ _    <- val 
     121        = (env, Val val) 
     122        | (fenv, exp)   <- reduce env{ cxt = cxt } exp 
     123        = (fenv env, exp) 
     124        | otherwise 
     125        = (env, Val $ VError "Unterminated statement" exp) 
     126    combineEnv f var val env = (f env) `addSym` [(var, val)] 
     127    isInfix name s = name == "&infix:" ++ s 
    97128 
    98 reduce env other = other 
     129reduce env@Env{ cxt = cxt, cls = cls } exp@(App name exps) 
     130    | Just sub <- findSub name 
     131    = applySub sub exps 
     132    | otherwise 
     133    = retVal $ VError ("Undefined subroutine " ++ name ++ (show $ sym env)) exp 
     134    where 
     135    applySub sub exps 
     136        -- list-associativity 
     137        | Sub{ subAssoc = "list" }  <- sub 
     138        , (App name' exps'):rest    <- exps 
     139        , name == name' 
     140        = applySub sub (exps' ++ rest) 
     141        -- fix subParams to agree with number of actual arguments 
     142        | Sub{ subAssoc = "list", subParams = (p:_) }   <- sub 
     143        , trace ("meow " ++ (show exps)) True 
     144        = apply env sub{ subParams = (length exps) `replicate` p } exps 
     145        -- chain-associativity 
     146        | Sub{ subAssoc = "chain", subFun = fun }   <- sub 
     147        , (App name' exps'):rest                    <- exps 
     148        , Just sub'                                 <- findSub name' 
     149        , Sub{ subAssoc = "chain", subFun = fun' }  <- sub' 
     150        = applySub sub{ subFun = Prim $ chainFun env fun' fun } (exps' ++ rest) 
     151        -- fix subParams to agree with number of actual arguments 
     152        | Sub{ subAssoc = "chain", subParams = (p:_) }   <- sub 
     153        = apply env sub{ subParams = (length exps) `replicate` p } exps -- XXX Wrong 
     154        -- apply normally 
     155        | Sub{ subParams = [('*':p)] }              <- sub -- XXX Wrong 
     156        = apply env sub{ subParams = (length exps) `replicate` p } exps 
     157        | otherwise 
     158        = apply env sub exps 
     159    findSub name 
     160        | ((_, sub):_) <- sort (subs name)  = Just sub 
     161        | otherwise                         = Nothing 
     162    subs name = [ ((subT, deltaFromCxt ret : map deltaFromScalar prms), sub) 
     163           | (n, val) <- sym env 
     164           , let sub@(Sub{ subType = subT, subReturns = ret, subParams = prms }) = vCast val 
     165           , n == name 
     166           , arityMatch sub prms exps 
     167           , deltaFromCxt ret /= 0 
     168           ] 
     169    deltaFromCxt        = deltaType cls cxt 
     170    deltaFromScalar x   = deltaType cls x "Scalar" 
     171    arityMatch Sub{ subAssoc = assoc, subParams = prms } x y 
     172        | assoc == "list"           = True 
     173        | Just _ <- find ((== '*') . head) prms 
     174        , assoc == "pre"            = True 
     175        | (length x) == (length y)  = True  -- XXX - slurping star 
     176        | otherwise                 = False 
    99177 
     178reduce env (Parens exp) = reduce env exp 
     179reduce env other = (id, other) 
     180