Changeset 3724
- Timestamp:
- 05/23/05 13:09:12 (4 years ago)
- svk:copy_cache_prev:
- 5313
- Location:
- src
- Files:
-
- 5 modified
-
Main.hs (modified) (2 diffs)
-
Pugs/AST/Internals.hs (modified) (3 diffs)
-
Pugs/Eval.hs (modified) (12 diffs)
-
Pugs/Monads.hs (modified) (2 diffs)
-
Pugs/Run.hs (modified) (5 diffs)
Legend:
- Unmodified
- Added
- Removed
-
src/Main.hs
r3675 r3724 32 32 import Data.IORef 33 33 34 -- |Pugs' entry point. Uses 'Pugs.Run.runWithArgs' to normalise the command-line 35 -- arguments and pass them to 'run'. 34 {-| 35 Pugs' entry point. Uses 'Pugs.Run.runWithArgs' to normalise the command-line 36 arguments and pass them to 'run'. 37 -} 36 38 main :: IO () 37 39 main = do … … 135 137 CmdReset -> tabulaRasa >>= (liftSTM . writeTVar env) >> loop 136 138 137 -- |Create a \'blank\' 'Env' for our program to execute in. Of course, 138 -- 'prepareEnv' actually declares quite a few symbols in the environment, 139 -- e.g. \'\@\*ARGS\', \'\$\*PID\', \'\$\*ERR\' etc. 140 -- ('Tabula rasa' is Latin for 'a blank slate'.) 139 {-| 140 Create a \'blank\' 'Env' for our program to execute in. Of course, 141 'prepareEnv' actually declares quite a few symbols in the environment, 142 e.g. \'\@\*ARGS\', \'\$\*PID\', \'\$\*ERR\' etc. 143 144 ('Tabula rasa' is Latin for 'a blank slate'.) 145 -} 141 146 tabulaRasa :: IO Env 142 147 tabulaRasa = prepareEnv "<interactive>" [] -
src/Pugs/AST/Internals.hs
r3690 r3724 287 287 doFrom $ concat list 288 288 where 289 doFrom :: [Val] -> Eval [VPair] 289 290 doFrom [] = return [] 290 291 doFrom (k:v:list) = do … … 574 575 , juncDup :: !(Set Val) 575 576 -- ^ Only used for @one()@ junctions. Contains those values 576 -- that appear more than once (the actual count is577 -- irrelevant), since matching any of these would578 -- automatically violate the 'match /only/ one value'579 -- junctive semantics.577 -- that appear more than once (the actual count is 578 -- irrelevant), since matching any of these would 579 -- automatically violate the 'match /only/ one value' 580 -- junctive semantics. 580 581 , juncSet :: !(Set Val) 581 582 -- ^ Set of values that make up the junction. In @one()@ 582 -- junctions, contains the set of values that appear exactly583 -- /once/.583 -- junctions, contains the set of values that appear exactly 584 -- /once/. 584 585 } deriving (Eq, Ord) 585 586 … … 1088 1089 -- askGlobal :: m Pad 1089 1090 1091 {-| 1092 Retrieve the global 'Pad' from the current evaluation environment. 1093 1094 'Env' stores the global 'Pad' in an STM variable, so we have to @asks@ 1095 'Eval'\'s @ReaderT@ for the variable, then extract the pad itself from the 1096 STM var. 1097 -} 1090 1098 askGlobal :: Eval Pad 1091 1099 askGlobal = do -
src/Pugs/Eval.hs
r3709 r3724 58 58 => String -- ^ Name associated with the environment 59 59 -> [STM (Pad -> Pad)] -- ^ List of 'Pad'-mutating transactions used 60 -- to declare an initial set of global vars60 -- to declare an initial set of global vars 61 61 -> m Env 62 62 emptyEnv name genPad = do … … 224 224 | otherwise = doFindVarRef name 225 225 where 226 doFindVarRef :: Var -> Eval (Maybe (TVar VRef)) 226 227 doFindVarRef name = do 227 228 callCC $ \foundIt -> do … … 665 666 _ -> retError "Unknown syntactic construct" exp 666 667 where 668 doCond :: (Bool -> Bool) -> Eval Val 667 669 doCond f = do 668 670 let [cond, bodyIf, bodyElse] = exps … … 673 675 else reduce bodyElse 674 676 -- XXX This treatment of while/until loops probably needs work 677 doWhileUntil :: (Bool -> Bool) -> Eval Val 675 678 doWhileUntil f = do 676 679 let [cond, body] = exps … … 722 725 shiftT $ const (retVal val) 723 726 where 727 callerEnv :: Env -> Env 724 728 callerEnv env = let caller = maybe env id (envCaller env) in 725 729 env{ envCaller = envCaller caller … … 750 754 where 751 755 err = retError "No compatible subroutine found" name 756 applySub :: VCode -> [Exp] -> [Exp] -> Eval Val 752 757 applySub sub invs args 753 758 -- list-associativity … … 770 775 | otherwise 771 776 = apply sub invs args 777 mungeChainSub :: VCode -> [Exp] -> Eval Val 772 778 mungeChainSub sub invs = do 773 779 let MkCode{ subAssoc = "chain", subParams = (p:_) } = sub … … 777 783 Just sub' -> applyChainSub sub invs sub' invs' args' rest 778 784 Nothing -> apply sub{ subParams = (length invs) `replicate` p } invs [] -- XXX Wrong 785 applyChainSub :: VCode -> [Exp] -> VCode -> [Exp] -> [a] -> [Exp] -> Eval Val 779 786 applyChainSub sub invs sub' invs' args' rest 780 787 | MkCode{ subAssoc = "chain", subBody = fun, subParams = prm } <- sub … … 1044 1051 -- XXX - faking application of lexical contexts 1045 1052 -- XXX - what about defaulting that depends on a junction? 1046 -- |Apply a sub (or other code) to lists of invocants 1047 -- and arguments, in the specified context. 1053 {-| 1054 Apply a sub (or other code) to lists of invocants and arguments, in the 1055 specified context. 1056 -} 1048 1057 doApply :: Env -- ^ Environment to evaluate in 1049 1058 -> VCode -- ^ Code to apply … … 1078 1087 | typ >= SubBlock = id 1079 1088 | otherwise = resetT 1089 fixEnv :: Env -> Env 1080 1090 fixEnv env 1081 1091 | typ >= SubBlock = env … … 1117 1127 return (VRef ref) 1118 1128 return (val, (isSlurpyCxt cxt || isCollapsed (typeOfCxt cxt))) 1129 checkSlurpyLimit :: (VInt, Exp) -> Eval [Val] 1119 1130 checkSlurpyLimit (n, exp) = do 1120 1131 listVal <- enterLValue $ enterEvalContext (cxtItem "Array") exp … … 1122 1133 elms <- mapM fromVal list -- flatten 1123 1134 return $ genericDrop n (concat elms :: [Val]) 1135 isCollapsed :: Type -> Bool 1124 1136 isCollapsed typ 1125 1137 | isaType (envClasses env) "Bool" typ = True -
src/Pugs/Monads.hs
r3464 r3724 169 169 where 170 170 typ = subType sub 171 doCC :: (Val -> Eval b) -> [Val] -> Eval b 171 172 doCC cc [v] = cc =<< evalVal v 172 173 doCC _ _ = internalError "enterSub: doCC list length /= 1" 174 orig :: VCode -> VCode 173 175 orig sub = sub { subBindings = [], subParams = (map fst (subBindings sub)) } 176 fixEnv :: (Val -> Eval Val) -> Env -> Eval (Env -> Env) 174 177 fixEnv cc env 175 178 | typ >= SubBlock = do … … 191 194 , envOuter = maybe Nothing envOuter (subEnv sub) 192 195 } 196 ccSub :: (Val -> Eval Val) -> Env -> VCode 193 197 ccSub cc env = mkPrim 194 198 { subName = "CALLER_CONTINUATION" -
src/Pugs/Run.hs
r3663 r3724 21 21 import qualified Data.Map as Map 22 22 23 -- |Run 'Main.run' with command line args. 24 -- See 'Main.main' and 'Pugs.Run.Args.canonicalArgs' 23 {-| 24 Run 'Main.run' with command line args. 25 26 See 'Main.main' and 'Pugs.Run.Args.canonicalArgs' 27 -} 25 28 runWithArgs :: ([String] -> IO t) -> IO t 26 29 runWithArgs f = do … … 38 41 runEnv env = runEvalMain env $ evaluateMain (envBody env) 39 42 40 -- | Run for 'Pugs.Compile.Pugs' backend43 -- | Run for 'Pugs.Compile.Pugs' backend 41 44 runAST :: Pad -> Exp -> IO Val 42 45 runAST glob ast = do … … 50 53 runEnv env{ envBody = ast, envGlobal = globRef, envDebug = Nothing } 51 54 52 -- | Run for 'Pugs.Compile.Haskell' backend55 -- | Run for 'Pugs.Compile.Haskell' backend 53 56 runComp :: Eval Val -> IO Val 54 57 runComp comp = do … … 59 62 runEvalMain env{ envDebug = Nothing } comp 60 63 61 -- | Initialize globals and install primitives in an 'Env'64 -- | Initialize globals and install primitives in an 'Env' 62 65 prepareEnv :: VStr -> [VStr] -> IO Env 63 66 prepareEnv name args = do … … 133 136 ] 134 137 135 -- |Combine @%*ENV\<PERL6LIB\>@, -I, 'Pugs.Config.config' values and \".\" into 136 -- the @\@*INC@ list for 'Main.printConfigInfo' 138 {-| 139 Combine @%*ENV\<PERL6LIB\>@, -I, 'Pugs.Config.config' values and \".\" into 140 the @\@*INC@ list for 'Main.printConfigInfo' 141 -} 137 142 getLibs :: IO [String] 138 143 getLibs = do
