Changeset 31

Show
Ignore:
Timestamp:
02/16/05 15:20:15 (4 years ago)
Author:
autrijus
svk:copy_cache_prev:
1041
Message:

* today's.

Files:
10 modified

Legend:

Unmodified
Added
Removed

  • src/AST.hs

    r29 r31  
    266266    = App String [Exp] [Exp] 
    267267    | Syn String [Exp] 
    268     | Sym Scope Var 
     268    | Sym Symbol 
    269269    | Prim ([Val] -> Eval Val) 
    270270    | Val Val 
    271     | Var Var SourcePos 
     271    | Var Var 
    272272    | Parens Exp 
    273273    | NonTerm SourcePos 
    … …  
    287287    where 
    288288    (exps', vs') = foldr extractExp ([], vs) exps 
    289 extract ((Var name pos), vs) 
     289extract ((Var name), vs) 
    290290    | (sigil:'^':identifer) <- name 
    291291    , name' <- (sigil : identifer) 
    292     = (Var name' pos, insert name' vs) 
     292    = (Var name', insert name' vs) 
    293293    | name == "$_" 
    294     = (Var name pos, insert name vs) 
     294    = (Var name, insert name vs) 
    295295    | otherwise 
    296     = (Var name pos, vs) 
     296    = (Var name, vs) 
    297297extract ((Parens exp), vs) = ((Parens exp'), vs') 
    298298    where 
    … …  
    327327 
    328328data Env = Env { envContext :: Cxt 
    329                , envPad     :: Pad 
     329               , envLexical :: Pad 
     330               , envGlobal  :: Pad 
    330331               , envClasses :: ClassTree 
    331332               , envEval    :: Exp -> Eval Val 
    … …  
    341342data Symbol = Symbol { symScope :: Scope 
    342343                     , symName  :: String 
    343                      , symValue :: Val 
     344                     , symExp   :: Exp 
    344345                     } deriving (Show, Eq, Ord) 
    345346 

  • src/Context.hs

    r29 r31  
    9999            [ Node "Class" [] ] ] 
    100100    , Node "Action" [] 
     101    , Node "Void" [] 
    101102    ] 

  • src/Eval.hs

    r29 r31  
    3030    return $ Env 
    3131        { envContext = "List" 
    32         , envPad     = initSyms 
     32        , envLexical = [] 
     33        , envGlobal  = initSyms 
    3334        , envClasses = initTree 
    3435        , envEval    = evaluate 
    … …  
    5657evaluate :: Exp -> Eval Val 
    5758evaluate (Val (VSub sub)) = do 
    58     pad <- asks envPad 
     59    pad <- asks envLexical 
    5960    return $ VSub sub{ subPad = pad } -- closure! 
    6061evaluate (Val val) = return val 
    … …  
    7273    evl exp 
    7374 
     75evalSym :: Symbol -> Eval (String, Val) 
     76evalSym (Symbol _ name vexp) = do 
     77    val <- evalExp vexp 
     78    return (name, val) 
     79 
    7480enterEvalContext cxt = enterContext cxt . evalExp 
    7581 
    … …  
    8086    env@Env{ envBody = body } <- ask 
    8187    doReduce env body 
     88 
     89reduceExp :: Exp -> Eval Exp 
     90reduceExp exp = do 
     91    env <- ask 
     92    doReduce env exp 
    8293 
    8394retVal :: Val -> Eval Exp 
    … …  
    90101    retVal val 
    91102reduceStatements (exp:rest) 
    92     | Syn syn [Var var _, exp'] <- exp 
     103    | Syn "sym" [Sym sym@(Symbol SGlobal _ _)] <- exp = do 
     104        local (\e -> e{ envGlobal = (sym:envGlobal e) }) $ do 
     105            reduceStatements rest 
     106    | Syn "sym" [Sym sym@(Symbol SMy _ _)] <- exp = do 
     107        enterLex [sym] $ do 
     108            reduceStatements rest 
     109    | Syn syn [Var name, exp'] <- exp 
    93110    , (syn == ":=" || syn == "::=") = do 
    94         val <- enterContext (cxtOfSigil $ head var) (evalExp exp) 
    95         processVal val $ do 
    96             enterLex [Symbol SMy var val] $ reduceStatements rest 
     111        lex <- asks envLexical 
     112        case findSym name lex of 
     113            Just _  -> do 
     114                let sym = (Symbol SMy name exp') 
     115                enterLex [sym] $ do 
     116                    reduceStatements rest 
     117            Nothing -> do 
     118                let sym = (Symbol SGlobal name exp') 
     119                local (\e -> e{ envGlobal = (sym:envGlobal e) }) $ do 
     120                    reduceStatements rest 
    97121    | otherwise = do 
    98         val <- enterContext "Any" $ evalExp exp 
     122        val <- enterContext "Void" $ evalExp exp 
    99123        processVal val $ do 
    100124            reduceStatements rest 
    … …  
    107131 
    108132-- Reduction for variables 
    109 doReduce Env{ envPad = pad } exp@(Var var _) 
    110     | Just val <- findSym var pad 
    111     = retVal val 
    112     | Just val <- findSym (toGlobal var) pad 
    113     = retVal val 
     133doReduce Env{ envLexical = lex, envGlobal = glob } exp@(Var var) 
     134    | Just vexp <- findSym var lex 
     135    = reduceExp vexp 
     136    | Just vexp <- findSym var glob 
     137    = reduceExp vexp 
     138    | Just vexp <- findSym (toGlobal var) glob 
     139    = reduceExp vexp 
    114140    | otherwise 
    115141    = retVal $ VError ("Undefined variable " ++ var) exp 
    … …  
    120146        let (global, local) = partition isGlobalExp exps 
    121147        reduceStatements (global ++ local) 
     148    "sym" -> do 
     149        let [Sym (Symbol _ _ exp)] = exps 
     150        val     <- evalExp exp 
     151        retVal val 
    122152    ":=" -> do 
    123         let [Var var _, exp] = exps 
     153        let [Var var, exp] = exps 
    124154        val     <- evalExp exp 
    125155        retVal val 
    126156    "::=" -> do -- XXX wrong 
    127         let [Var var _, exp] = exps 
     157        let [Var var, exp] = exps 
    128158        val     <- evalExp exp 
    129159        retVal VUndef -- XXX wrong 
    … …  
    159189    doSlice _ _ _ = Nothing 
    160190 
    161 doReduce env@Env{ envClasses = cls, envContext = cxt, envPad = pad } exp@(App name invs args) = do 
    162     case findSub name of 
    163         Just sub    -> applySub sub invs args 
     191doReduce env@Env{ envClasses = cls, envContext = cxt, envLexical = lex, envGlobal = glob } exp@(App name invs args) = do 
     192    subSyms <- mapM evalSym [ sym | sym <- lex ++ glob, head (symName sym) == '&' ] 
     193    case findSub subSyms name of 
     194        Just sub    -> applySub subSyms sub invs args 
    164195        otherwise   -> retVal $ VError ("No compatible subroutine found: " ++ name) exp 
    165196    where 
    166     applySub sub invs args 
     197    applySub subSyms sub invs args 
    167198        -- list-associativity 
    168199        | Sub{ subAssoc = "list" }      <- sub 
    … …  
    170201        , name == name' 
    171202        , null invs' 
    172         = applySub sub [] (args' ++ rest) 
     203        = applySub subSyms sub [] (args' ++ rest) 
    173204        -- fix subParams to agree with number of actual arguments 
    174205        | Sub{ subAssoc = "list", subParams = (p:_) }   <- sub 
    … …  
    178209        | Sub{ subAssoc = "chain", subFun = fun, subParams = prm }   <- sub 
    179210        , (App name' invs' args'):rest              <- args 
    180         , Just sub'                                 <- findSub name' 
     211        , Just sub'                                 <- findSub subSyms name' 
    181212        , Sub{ subAssoc = "chain", subFun = fun', subParams = prm' } <- sub' 
    182213        , null invs' 
    183         = applySub sub{ subParams = prm ++ tail prm', subFun = Prim $ chainFun prm' fun' prm fun } [] (args' ++ rest) 
     214        = applySub subSyms sub{ subParams = prm ++ tail prm', subFun = Prim $ chainFun prm' fun' prm fun } [] (args' ++ rest) 
    184215        -- fix subParams to agree with number of actual arguments 
    185216        | Sub{ subAssoc = "chain", subParams = (p:_) }   <- sub 
    … …  
    189220        | otherwise 
    190221        = apply sub invs args 
    191     findSub name 
    192         | ((_, sub):_) <- sort (subs name)  = Just sub 
    193         | otherwise                         = Nothing 
    194     subs name = [ 
     222    findSub subSyms name = case sort (subs subSyms name) of 
     223        ((_, sub):_)    -> Just sub 
     224        _               -> Nothing 
     225    subs subSyms name = [ 
    195226        ( (isGlobal, subT, isMulti sub, bound, distance, order) 
    196227        , fromJust fun 
    197228        ) 
    198         | ((Symbol _ n val), order) <- pad `zip` [0..] 
     229        | ((n, val), order) <- subSyms `zip` [0..] 
    199230        , let sub@(Sub{ subType = subT, subReturns = ret, subParams = prms }) = vCast val 
    200231        , (n ==) `any` [name, toGlobal name] 
    … …  
    237268    where 
    238269    formal = filter (not . null . symName) $ map argNameValue bound 
    239     argNameValue (ApplyArg name val _) = Symbol SMy name val 
     270    argNameValue (ApplyArg name val _) = Symbol SMy name (Val val) 
    240271 
    241272apply :: VSub -> [Exp] -> [Exp] -> Eval Exp 
    … …  
    263294        let name = paramName prm 
    264295            arg = ApplyArg name val coll 
    265         restArgs <- enterLex [Symbol SMy name val] $ do 
     296        restArgs <- enterLex [Symbol SMy name (Val val)] $ do 
    266297            doBind rest 
    267298        return (arg:restArgs) 
    … …  
    281312    | otherwise = name 
    282313 
    283 isGlobalExp (Syn name _) = name `elem` (words ":= ::=") 
     314isGlobalExp (Syn name _) = name `elem` (words "::=") 
    284315isGlobalExp _ = False 
    285316 
    286 findSym :: String -> Pad -> Maybe Val 
     317findSym :: String -> Pad -> Maybe Exp 
    287318findSym name pad 
    288319    | Just s <- find ((== name) . symName) pad 
    289     = Just $ symValue s 
     320    = Just $ symExp s 
    290321    | otherwise 
    291322    = Nothing 

  • src/Lexer.hs

    r29 r31  
    153153 
    154154ruleScope :: RuleParser Scope 
    155 ruleScope = postSpace $ try $ do 
     155ruleScope = tryRule "scope" $ do 
    156156    scope <- choice $ map symbol scopes 
    157157    return (readScope scope) 
    … …  
    165165        = SGlobal 
    166166 
    167 preSpace rule = try $ do 
    168     skipMany1 (satisfy isSpace) 
    169     rule 
    170  
    171167postSpace rule = try $ do 
    172168    rv <- rule 
    173     choice [skipMany1 (satisfy isSpace), eof <?> ""] 
     169    notFollowedBy wordAny 
     170    whiteSpace 
    174171    return rv 
    175172 
    … …  
    195192    return $ (sigil:caret) ++ name 
    196193 
     194tryChoice = choice . map try 

  • src/Main.hs

    r29 r31  
    7575    f val 
    7676    where 
    77     prepare e = e{ envPad = 
    78         [ Symbol SGlobal "@*ARGS" (VList $ map VStr args) 
    79         , Symbol SGlobal "$*PROGNAME" (VStr name) 
    80         ] ++ envPad e } 
     77    prepare e = e{ envGlobal = 
     78        [ Symbol SGlobal "@*ARGS" (Val $ VList $ map VStr args) 
     79        , Symbol SGlobal "$*PROGNAME" (Val $ VStr name) 
     80        ] ++ envGlobal e } 
    8181 

  • src/Monads.hs

    r29 r31  
    1616 
    1717enterLex :: Pad -> Eval a -> Eval a 
    18 enterLex pad = local (\e -> e{ envPad = (pad ++ envPad e) }) 
     18enterLex pad = local (\e -> e{ envLexical = (pad ++ envLexical e) }) 
    1919 
    2020enterContext :: Cxt -> Eval a -> Eval a 
    … …  
    2323main = do 
    2424    uniq <- newUnique 
    25     x <- (`runReaderT` env{ envID = uniq }) $ do 
     25    x <- (`runReaderT` testEnv{ envID = uniq }) $ do 
    2626        y <- (`runContT` return) $ blah 
    2727        return y 
    … …  
    2929    return x 
    3030 
    31 env = Env { envContext = "List" 
    32           , envPad = [] 
     31testEnv = Env { envContext = "List" 
     32          , envLexical = [] 
     33          , envGlobal = [] 
    3334          , envCaller = Nothing 
    3435          , envClasses = initTree 
    … …  
    6768 
    6869enterSub sub@Sub{ subType = typ } action 
    69     | typ > SubRoutine  = action 
     70    | typ >= SubPrim    = action 
    7071    | otherwise         = do 
    7172        cxt <- asks envContext 
    7273        resetT $ do 
    73             local (\e -> e{ envPad = (ret cxt:subPad sub) }) $ do 
     74            local (\e -> e{ envLexical = (ret cxt:subPad sub) }) $ do 
    7475                action 
    7576    where 
    7677    doReturn [v] = do 
    7778        shiftT $ \_ -> return v 
    78     ret cxt = Symbol SMy "&prefix:return" (VSub $ retSub cxt) 
     79    ret cxt = Symbol SMy "&prefix:return" (Val $ VSub $ retSub cxt) 
    7980    retSub cxt = Sub 
    8081        { isMulti = False 
    … …  
    9899{- 
    99100enterSub sub = enterScope $ do 
    100     local (\e -> e { envPad = subPad sub }) $ do 
     101    local (\e -> e { envLexical = subPad sub }) $ do 
    101102        case subName sub of 
    102103            "inner" -> inner 
    … …  
    108109    , subName       = "inner" 
    109110    , subType       = SubRoutine 
    110     , subPad        = [Symbol SMy "$inner" VUndef] 
     111    , subPad        = [Symbol SMy "$inner" (Val VUndef)] 
    111112    , subAssoc      = "left" 
    112113    , subParams     = [] 
    … …  
    119120    , subName       = "sub3" 
    120121    , subType       = SubRoutine 
    121     , subPad        = [Symbol SMy "$inner" VUndef] 
     122    , subPad        = [Symbol SMy "$inner" (Val VUndef)] 
    122123    , subAssoc      = "left" 
    123124    , subParams     = [] 
    … …  
    130131dumpLex :: String -> Eval () 
    131132dumpLex label = do 
    132     pad <- asks envPad 
     133    pad <- asks envLexical 
    133134    depth <- asks envDepth 
    134135    liftIO $ putStrLn ("("++(show depth)++")"++label ++ ": " ++ (show pad)) 
    … …  
    138139blah = do 
    139140    dumpLex ">init" 
    140     rv <- enterLex [Symbol SMy "$x" $ VInt 1] $ do 
     141    rv <- enterLex [Symbol SMy "$x" $ Val $ VInt 1] $ do 
    141142        dumpLex ">lex" 
    142143        rv <- enterScope outer 
    … …  
    147148 
    148149outer :: Eval Val 
    149 outer = enterLex [Symbol SMy "$outer" $ VInt 2] $ do 
     150outer = enterLex [Symbol SMy "$outer" $ Val $ VInt 2] $ do 
    150151    dumpLex ">outer" 
    151152    -- enterSub innerSub 

  • src/Parser.hs

    r29 r31  
    2222    many (symbol ";") 
    2323    statements <- option [] ruleStatementList 
     24    many (symbol ";") 
    2425    eof 
    2526    env <- getState 
    … …  
    3132    many (symbol ";") 
    3233    statements <- option [] ruleStatementList 
     34    many (symbol ";") 
    3335    retSyn ";" statements 
    3436 
    … …  
    4446    doSep count rule = do 
    4547        statement   <- rule 
    46         rest        <- option [] $ do { count (symbol ";"); ruleStatementList } 
     48        rest        <- option [] $ try $ do { count (symbol ";"); ruleStatementList } 
    4749        return (statement:rest) 
    4850 
    … …  
    5355    [ ruleSubDeclaration 
    5456    , rulePackageDeclaration 
    55     ] 
     57    , ruleVarDeclaration 
     58    ] 
     59 
     60ruleSubHead :: RuleParser (Bool, String) 
     61ruleSubHead = rule "subroutine head" $ do 
     62    multi   <- option False $ do { symbol "multi" ; return True } 
     63    symbol "sub" 
     64    name    <- ruleSubName 
     65    return (multi, name) 
     66 
     67ruleSubScopedWithContext = rule "scoped subroutine with context" $ do 
     68    scope   <- ruleScope 
     69    cxt     <- identifier 
     70    (multi, name) <- ruleSubHead 
     71    return (scope, cxt, multi, name) 
     72 
     73ruleSubScoped = rule "scoped subroutine" $ do 
     74    scope <- ruleScope 
     75    (multi, name) <- ruleSubHead 
     76    return (scope, "Any", multi, name) 
     77 
     78ruleSubGlobal = rule "global subroutine" $ do 
     79    (multi, name) <- ruleSubHead 
     80    return (SGlobal, "Any", multi, name) 
    5681 
    5782ruleSubDeclaration :: RuleParser Exp 
    5883ruleSubDeclaration = rule "subroutine declaration" $ do 
    59     (scope, multi, name) <- try $ do 
    60         scope   <- option SGlobal $ ruleScope 
    61         multi   <- option False $ do { symbol "multi" ; return True } 
    62         symbol "sub" 
    63         name    <- ruleSubName 
    64         return (scope, multi, name) 
     84    (scope, cxt1, multi, name) <- tryChoice 
     85        [ ruleSubScopedWithContext 
     86        , ruleSubScoped 
     87        , ruleSubGlobal 
     88        ] 
    6589    pos     <- getPosition 
    66     cxt     <- option "Any" $ ruleBareTrait "returns" 
     90    cxt2    <- option cxt1 $ ruleBareTrait "returns" 
    6791    formal  <- option Nothing $ return . Just =<< parens ruleSubParameters 
    6892    body    <- ruleBlock 
    … …  
    77101                  , subType       = SubRoutine 
    78102                  , subAssoc      = "pre" 
    79                   , subReturns    = cxt 
     103                  , subReturns    = cxt2 
    80104                  , subParams     = if null params then [defaultArrayParam] else params 
    81105                  , subFun        = fun 
    82106                  } 
    83107    -- XXX: user-defined infix operator 
    84     return $ Syn ":=" [Var name pos, Val (VSub sub)] 
     108    return $ Syn "sym" [Sym $ Symbol scope name (Val $ VSub sub)] 
    85109 
    86110ruleSubName = rule "subroutine name" $ do 
    … …  
    120144    ruleExpression 
    121145 
     146ruleVarDeclaration :: RuleParser Exp 
     147ruleVarDeclaration = rule "variable declaration" $ do 
     148    scope   <- ruleScope 
     149    name    <- parseVarName 
     150    return $ Syn "sym" [Sym (Symbol scope name (Val VUndef))] 
     151 
    122152rulePackageDeclaration = rule "package declaration" $ fail "" 
    123153 
    124154-- Constructs ------------------------------------------------ 
    125155 
    126 ruleConstruct = rule "construct" $ choice 
     156ruleConstruct = rule "construct" $ tryChoice 
    127157    [ ruleGatherConstruct 
     158    , ruleBlockConstruct 
    128159    ] 
    129160 
    130161ruleGatherConstruct = rule "gather construct" $ do 
    131162    symbol "gather" 
    132     block   <- ruleBlock 
     163    block <- ruleBlock 
    133164    retSyn "gather" [block] 
    134165 
    135 -- XXX not sure how many of these can be rolled into Prim 
    136 ruleBlockConstruct = rule "block construct" $ fail "" 
     166ruleBlockConstruct = rule "block construct" $ do 
     167    formal <- option Nothing $ choice [ ruleBlockFormalStandard, ruleBlockFormalPointy ] 
     168    block <- ruleBlock 
     169    fail "" 
     170 
     171ruleBlockFormalStandard = rule "standard block parameters" $ do 
     172    symbol "sub" 
     173    return . Just =<< parens ruleSubParameters 
     174 
     175ruleBlockFormalPointy = rule "pointy block parameters" $ do 
     176    symbol "->" 
     177    return . Just =<< ruleSubParameters 
     178 
    137179ruleCondConstruct = rule "conditional construct" $ fail "" 
    138180ruleLoopConstruct = rule "loop construct" $ fail "" 
    … …  
    306348 
    307349parseVar = do 
    308     pos     <- getPosition 
    309350    name    <- parseVarName 
    310     return $ Var name pos 
     351    return $ Var name 
    311352 
    312353nonTerm = do 
    … …  
    322363    , namedLiteral "NaN"    (VNum $ 0/0) 
    323364    , namedLiteral "Inf"    (VNum $ 1/0) 
     365    , dotdotdotLiteral 
    324366    ] 
    325367 
    … …  
    343385 
    344386namedLiteral n v = do { symbol n; return $ Val v } 
     387 
     388dotdotdotLiteral = do 
     389    pos <- getPosition 
     390    symbol "..." 
     391    return . Val $ VError "..." (NonTerm pos) 
    345392 
    346393op_methodPostfix    = [] 
    … …  
    358405    where 
    359406    progName 
    360         | Just Symbol{ symValue = (VStr str) } <- find ((== "$*PROGNAME") . symName) $ envPad env 
     407        | Just Symbol{ symExp = Val (VStr str) } <- find ((== "$*PROGNAME") . symName) $ envGlobal env 
    361408        = str 
    362409        | otherwise 

  • src/Pretty.hs

    r29 r31  
    4646            JNone -> " ! " 
    4747    pretty (VPair x y) = "(" ++ pretty x ++ " => " ++ pretty y ++ ")" 
    48     pretty (VBool x) = if x then "#t" else "#f" 
     48    pretty (VBool x) = if x then "bool::true" else "bool::false" 
    4949    pretty (VNum x) = if x == 1/0 then "Inf" else show x 
    5050    pretty (VInt x) = show x 

  • src/Prim.hs

    r29 r31  
    196196 
    197197primOp :: String -> String -> Params -> String -> Symbol 
    198 primOp sym assoc prms ret = Symbol SOur name sub 
     198primOp sym assoc prms ret = Symbol SOur name (Val sub) 
    199199    where 
    200200    name = '&':'*':fixity ++ ':':sym 

  • t/01basic.t

    r30 r31  
    1212open PUGS, "| $pugs" or die "Cannot pipe out to $pugs: $!"; 
    1313print PUGS << '.'; 
     14    sub cool { fine($_) ~ " # We've got " ~ toys }; 
    1415    sub fine { "ok " ~ $_ }; 
    1516    sub toys { "fun and games!\n" }; 
    16     sub cool { fine($_) ~ " # We've got " ~ toys }; 
    1717    cool 2 
    1818.