Changeset 202

Show
Ignore:
Timestamp:
02/23/05 17:00:46 (4 years ago)
Author:
autrijus
svk:copy_cache_prev:
1041
Message:

* Support for Test.pm landed!

Files:
2 added
6 modified

Legend:

Unmodified
Added
Removed

  • src/AST.hs

    r196 r202  
    195195    vCast _             = Just undefined 
    196196 
    197 instance Value Int   where doCast = intCast 
     197instance Value Int   where 
     198    doCast = intCast 
     199    castV = VInt . fromIntegral 
    198200instance Value Word  where doCast = intCast 
    199201instance Value Word8 where doCast = intCast 
    … …  
    356358    | Sym Symbol 
    357359    | Prim ([Val] -> Eval Val) 
    358 --  | MVal MVal 
    359360    | Val Val 
    360361    | Var Var 
    361362    | Parens Exp 
    362363    | NonTerm SourcePos 
    363     | Parser (CharParser Env Exp) 
     364    | Statements [(Exp, SourcePos)] 
    364365    deriving (Show, Eq, Ord) 
    365366 

  • src/Eval.hs

    r201 r202  
    6060evaluateMain :: Exp -> Eval Val 
    6161evaluateMain exp = do 
    62     val <- evaluate exp 
    63     evalVar "$*END" 
     62    val     <- evaluate exp 
     63    endAV   <- evalVar "@*END" 
     64    subs    <- readMVal endAV 
     65    enterContext "Void" $ do 
     66        mapM_ evalExp [ Syn "()" [Val sub, Syn "invs" [], Syn "args" []] | sub <- vCast subs ] 
    6467    return val 
    6568 
    … …  
    138141        writeIORef glob (sym:syms) 
    139142 
    140 reduceStatements :: ([Exp], Exp) -> Eval Val 
     143reduceStatements :: ([(Exp, SourcePos)], Exp) -> Eval Val 
    141144reduceStatements ([], exp) = reduceExp exp 
    142 reduceStatements ((exp:rest), lastVal) 
     145reduceStatements (((exp, pos):rest), lastVal) 
    143146    | Syn "sym" (Sym sym@(Symbol _ _ vexp@(Syn "sub" [sub])):other) <- exp = do 
    144147        (VSub sub) <- enterEvalContext "Code" vexp 
    145148        lex <- asks envLexical 
    146         reduceStatements ((Syn "sym" (other ++ [Sym sym{ symExp = Val $ VSub sub{ subPad = lex } }]):rest), lastVal) 
     149        reduceStatements (((Syn "sym" (other ++ [Sym sym{ symExp = Val $ VSub sub{ subPad = lex } }]), pos):rest), lastVal) 
    147150    | Syn "sym" (Sym sym@(Symbol _ name (Syn "mval" [_, vexp])):other) <- exp = do 
    148151        val <- enterEvalContext (cxtOfSigil $ head name) vexp 
    149152        mval <- newMVal val 
    150         reduceStatements ((Syn "sym" (other ++ [Sym sym{ symExp = Val mval }]):rest), Val mval) 
     153        reduceStatements (((Syn "sym" (other ++ [Sym sym{ symExp = Val mval }]), pos):rest), Val mval) 
    151154    | Syn "sym" [Sym sym@(Symbol SGlobal _ vexp)] <- exp = do 
    152155        addGlobalSym sym 
    … …  
    173176        -- bare Block in statement level; run it! 
    174177        let app = Syn "()" [exp, Syn "invs" [], Syn "args" []] 
    175         reduceStatements (app:rest, lastVal) 
     178        reduceStatements ((app, pos):rest, lastVal) 
    176179    | null rest = do 
    177180        cxt <- asks envContext 
    178         val <- reduceExp exp 
     181        val <- enterLex (posSyms pos) $ reduceExp exp 
    179182        retVal val 
    180183    | otherwise = do 
    181         val <- enterContext "Void" $ evalExp exp 
     184        val <- enterContext "Void" $ do 
     185            enterLex (posSyms pos) $ do 
     186                reduceExp exp 
    182187        processVal val $ do 
    183188            reduceStatements (rest, Val val) 
    184     where 
     189    where  
    185190    processVal val action = case val of 
    186191        VError str exp  -> retError str exp 
    187192        _               -> action 
     193 
     194posSyms pos = [ Symbol SMy n (Val v) | (n, v) <- syms ] 
     195    where 
     196    file = sourceName pos 
     197    line = show $ sourceLine pos 
     198    col  = show $ sourceColumn pos 
     199    syms = 
     200        [ ("$?FILE", castV file) 
     201        , ("$?LINE", castV line) 
     202        , ("$?POSITION", castV $ file ++ " at line " ++ line ++ ", column " ++ col) 
     203        ] 
    188204 
    189205evalVar name = do 
    … …  
    203219 
    204220findVar name 
    205     | (sig:"CALLER", name') <- breakOnGlue "::" name = do 
     221    | (package, name') <- breakOnGlue "::" name 
     222    , (sig, "CALLER") <- breakOnGlue "CALLER" package = do 
    206223        rv <- asks envCaller 
    207224        case rv of 
    208             Just caller -> findVar' caller (sig:(drop 2 name')) 
     225            Just caller -> findVar' caller (sig ++ (drop 2 name')) 
    209226            Nothing -> retError "cannot access CALLER:: in top level" (Var name) 
    210227    | otherwise = do 
    … …  
    249266        _ -> retError ("Undefined variable " ++ name) exp 
    250267 
     268reduce env (Statements stmts) = do 
     269    let (global, local) = partition isGlobalExp stmts 
     270    reduceStatements (global ++ local, Val VUndef) 
     271    where 
     272    isGlobalExp (Syn name _, _) = name `elem` (words "::=") 
     273    isGlobalExp _ = False 
     274     
    251275-- Reduction for syntactic constructs 
    252276reduce env@Env{ envContext = cxt } exp@(Syn name exps) = case name of 
    253     ";" -> do 
    254         let (global, local) = partition isGlobalExp exps 
    255         reduceStatements (global ++ local, Val VUndef) 
    256277    "sub" -> do 
    257278        let [exp] = exps 
    … …  
    280301        let [pre, cond, post, body] = exps 
    281302        evalExp pre 
    282         -- enter the block 
    283         -- first, run pre and enter its lexical context 
    284         -- reduceStatements (pre:, Val VUndef) 
    285303        let runBody = do 
    286304            valBody <- evalExp body 
    … …  
    521539    | otherwise = name 
    522540 
    523 isGlobalExp (Syn name _) = name `elem` (words "::=") 
    524 isGlobalExp _ = False 
    525541 
    526542findSym :: String -> Pad -> Maybe Exp 

  • src/Internals.hs

    r167 r202  
    1717    module Cont, 
    1818    module Posix, 
     19    module Rule.Pos, 
    1920    module Data.Dynamic, 
    2021    module Data.Unique, 
    … …  
    7172import Data.IORef 
    7273import Debug.Trace 
     74import Rule.Pos 
    7375 
    7476-- Instances. 

  • src/Main.hs

    r200 r202  
    7474doParse prog = do 
    7575    env <- emptyEnv [] 
    76     runRule env (putStrLn . pretty) ruleProgram prog 
     76    runRule env (putStrLn . pretty) ruleProgram "<interactive>" prog 
    7777 
    7878doEval :: [String] -> String -> IO () 
    … …  
    9797runProgramWith fenv f name args prog = do 
    9898    environ <- getEnvironment 
     99    progSV  <- newMVal $ VStr name 
     100    endAV   <- newMVal $ VList [] 
     101    incAV   <- newMVal $ VList [] 
     102    argsAV  <- newMVal $ VList (map VStr args) 
     103    inGV    <- newMVal $ VHandle stdin 
     104    outGV   <- newMVal $ VHandle stdout 
     105    errGV   <- newMVal $ VHandle stderr 
    99106    env <- emptyEnv 
    100         [ Symbol SGlobal "@*ARGS" (Val $ VList $ map VStr args) 
    101         , Symbol SGlobal "@*INC" (Val $ VList []) 
    102         , Symbol SGlobal "$*PROGNAME" (Val $ VStr name) 
    103 --        , Symbol SGlobal "$*STDIN" (Val $ VStr str) 
    104         , Symbol SGlobal "@*END" (Val VUndef) 
     107        [ Symbol SGlobal "@*ARGS"       $ Val argsAV 
     108        , Symbol SGlobal "@*INC"        $ Val incAV 
     109        , Symbol SGlobal "$*PROGNAME"   $ Val progSV 
     110        , Symbol SGlobal "@*END"        $ Val endAV 
     111        , Symbol SGlobal "$*IN"         $ Val inGV 
     112        , Symbol SGlobal "$*OUT"        $ Val outGV 
     113        , Symbol SGlobal "$*ERR"        $ Val errGV 
    105114        , Symbol SGlobal "%*ENV" (Val . VHash . MkHash . listToFM $ [ (VStr k, VStr v) | (k, v) <- environ ]) 
    106115        ] 
    107116--    str <- return "" -- getContents 
    108     let env' = runRule (fenv env) id ruleProgram prog 
     117    let env' = runRule (fenv env) id ruleProgram name prog 
    109118    val <- (`runReaderT` env') $ do 
    110119        (`runContT` return) $ resetT $ do 

  • src/Parser.hs

    r200 r202  
    2828    eof 
    2929    env <- getState 
    30     return $ env { envBody = Syn ";" statements } 
     30    return $ env { envBody = Statements statements } 
    3131 
    3232ruleBlock :: RuleParser Exp 
    … …  
    3636    statements <- option [] ruleStatementList 
    3737    many (symbol ";") 
    38     retSyn ";" statements 
    39  
    40 ruleStatementList :: RuleParser [Exp] 
     38    return $ Statements statements 
     39 
     40ruleStatementList :: RuleParser [(Exp, SourcePos)] 
    4141ruleStatementList = rule "statements" $ choice 
    4242    [ nonSep  ruleDeclaration 
    … …  
    4848    semiSep = doSep many1 
    4949    doSep count rule = do 
     50        pos         <- getPosition 
    5051        statement   <- rule 
    5152        rest        <- option [] $ try $ do { count (symbol ";"); ruleStatementList } 
    52         return (statement:rest) 
     53        return ((statement, pos):rest) 
    5354 
    5455-- Declarations ------------------------------------------------ 
    … …  
    9293        , ruleSubGlobal 
    9394        ] 
    94     cxt2    <- option cxt1 $ ruleBareTrait "returns" 
    9595    formal  <- option Nothing $ return . Just =<< parens ruleSubParameters 
     96    cxt2    <- option cxt1 $ try $ ruleBareTrait "returns" 
    9697    traits  <- many $ ruleTrait 
    9798    body    <- ruleBlock 
    … …  
    209210                  , subFun        = fun 
    210211                  } 
    211     return $ App "&prefix:push" [Var "@*END"] [Syn "sub" [Val $ VSub sub]] 
     212    return $ App "&prefix:unshift" [] [Syn "," [Var "@*END", Syn "sub" [Val $ VSub sub]]] 
    212213 
    213214rulePackageDeclaration = rule "package declaration" $ fail "" 
    … …  
    615616ternOps _ = [] 
    616617 
    617 runRule :: Env -> (Env -> a) -> RuleParser Env -> String -> a 
    618 runRule env f p str = f $ case ( runParser ruleProgram env progName str ) of 
     618runRule :: Env -> (Env -> a) -> RuleParser Env -> FilePath -> String -> a 
     619runRule env f p name str = f $ case ( runParser ruleProgram env name str ) of 
    619620    Left err    -> env { envBody = Val $ VError (showErr err) (NonTerm $ errorPos err) } 
    620621    Right env'  -> env' 
    621     where 
    622     glob = unsafePerformIO $ readIORef $ envGlobal env 
    623     progName 
    624         | Just Symbol{ symExp = Val (VStr str) } <- find ((== "$*PROGNAME") . symName) glob 
    625         = str 
    626         | otherwise 
    627         = "-" 
    628622 
    629623showErr err =  
    … …  
    636630    return $ Syn sym args 
    637631 
    638 retParser :: RuleParser Exp -> RuleParser Exp 
    639 retParser parser = do 
    640     return $ Parser parser 
    641  

  • src/Prim.hs

    r200 r202  
    8989    rand <- liftIO $ randomRIO (0, if x == 0 then 1 else x) 
    9090    return $ VNum rand 
    91 op1 "print" = \v -> do 
    92     v <- readMVal v 
    93     vals <- mapM readMVal (vCast v) 
    94     liftIO . putStr . concatMap vCast $ vals 
    95     return $ VBool True 
    96 op1 "say" = \v -> do 
    97     op1 "print" v 
    98     liftIO $ putStrLn "" 
    99     return $ VBool True 
     91op1 "print" = op1Print hPutStr 
     92op1 "say" = op1Print hPutStrLn 
    10093op1 "join"= \v -> do 
    10194    v <- readMVal v 
    … …  
    163156op1 s      = return . (\x -> VError ("unimplemented unaryOp: " ++ s) (Val x)) 
    164157 
     158op1Print f v = do 
     159    val <- readMVal v 
     160    vals <- mapM readMVal (vCast val) 
     161    let (handle, vs) = case vals of 
     162                        (VHandle h:vs)  -> (h, vs) 
     163                        _               -> (stdout, vals) 
     164    liftIO . f handle . concatMap vCast $ vs 
     165    return $ VBool True 
     166 
    165167bool2n v = if v 
    166168  then 1 
    … …  
    186188opEval str = do 
    187189    env <- ask 
    188     let env' = runRule env id ruleProgram str 
     190    let env' = runRule env id ruleProgram "<eval>" str 
    189191    val <- resetT $ local (\_ -> env') $ do 
    190192        evl <- asks envEval 
    … …  
    261263op2 "grep"= op2Grep 
    262264op2 "map"= op2Map 
     265op2 "unshift" = op2Push (flip (++)) 
     266op2 "push" = op2Push (++) 
    263267op2 "split"= \x y -> return $ split (vCast x) (vCast y) 
    264268    where 
    … …  
    276280        | otherwise = (x:piece, rest') where (piece, rest') = breakOnGlue glue xs 
    277281op2 s    = \x y -> return $ VError ("unimplemented binaryOp: " ++ s) (App s [] [Val x, Val y]) 
     282 
     283op2Push f list _ = do 
     284    let (array:rest) = vCast list 
     285    old <- readMVal array 
     286    new <- mapM readMVal rest 
     287    let vals = vCast old `f` concatMap vCast new 
     288    liftIO $ writeIORef (vCast array) $ VList vals 
     289    return $ VInt $ genericLength vals 
    278290 
    279291op2Grep list sub@(VSub _) = op2Grep sub list 
    … …  
    447459\\n   List      pre     map     (List: Code)\ 
    448460\\n   List      pre     grep    (List: Code)\ 
    449 \\n   Int       pre     push    (rw!Array: List)\ 
    450 \\n   Int       pre     unshift (rw!Array: List)\ 
     461\\n   Int       pre     push    (rw!Array, List)\ 
     462\\n   Int       pre     unshift (rw!Array, List)\ 
    451463\\n   Scalar    pre     pop     (rw!Array)\ 
    452464\\n   Scalar    pre     shift   (rw!Array)\ 
    … …  
    465477\\n   Num       pre     time    ()\ 
    466478\\n   Action    pre     print   (List)\ 
     479\\n   Action    pre     say     (IO: List)\ 
    467480\\n   Action    pre     say     (List)\ 
    468481\\n   Action    pre     die     (List)\