Pugs 6.2.13.12 → 6.2.13.13
raw patch · 8 files changed
+59/−32 lines, 8 filesdep +control-timeout
Dependencies added: control-timeout
Files
- Pugs.cabal +2/−1
- src/Pugs.hs +17/−5
- src/Pugs/Compile.hs +7/−2
- src/Pugs/Eval.hs +1/−1
- src/Pugs/Lexer.hs +16/−10
- src/Pugs/Parser.hs +3/−3
- src/Pugs/Prim.hs +11/−8
- src/Pugs/Version.hs +2/−2
Pugs.cabal view
@@ -1,5 +1,5 @@ Name : Pugs-Version : 6.2.13.12+Version : 6.2.13.13 license : BSD3 license-file : LICENSE cabal-version : >= 1.2@@ -163,6 +163,7 @@ base, haskell98, filepath, mtl, stm, parsec < 3.0.0, network, pretty, time, random, process, containers, bytestring, array, directory, utf8-string, binary, haskeline >= 0.2.1, FindBin,+ control-timeout >= 0.1.2, MetaObject >= 0.0.4, HsParrot >= 0.0.2,
src/Pugs.hs view
@@ -1,4 +1,4 @@-{-# OPTIONS_GHC -fglasgow-exts -fallow-overlapping-instances #-}+{-# OPTIONS_GHC -fglasgow-exts -fallow-overlapping-instances -fffi #-} {-| Public API for the Pugs system.@@ -39,6 +39,7 @@ import Data.IORef import qualified Data.Map as Map import qualified System.FilePath as FilePath (combine, splitFileName)+import Control.Timeout {-| The entry point of Pugs. Uses 'Pugs.Run.runWithArgs' to normalise the command-line@@ -47,8 +48,16 @@ pugsMain :: IO () pugsMain = do let ?debugInfo = Nothing+ timeout <- getEnv "PUGS_TIMEOUT"+ case timeout of+ Just str | [(t, _)] <- reads str -> do+ addTimeout t (hPutStrLn stderr "*** TIMEOUT" >> _exit 1)+ return ()+ _ -> return () mainWith run +foreign import ccall unsafe _exit :: Int -> IO ()+ defaultProgramName :: String defaultProgramName = "<interactive>" @@ -146,9 +155,9 @@ mainWith :: ([String] -> IO a) -> IO () mainWith run = do- hSetBuffering stdout NoBuffering- when (isJust _DoCompile) $ do- writeIORef (fromJust _DoCompile) doCompile+ hSetBuffering stdout LineBuffering+-- when (isJust _DoCompile) $ do+-- writeIORef (fromJust _DoCompile) doCompile runWithArgs run globalFinalize @@ -402,6 +411,8 @@ (Env -> Env) -> (Val -> IO a) -> VStr -> [VStr] -> String -> IO a runProgramWith fenv f name args prog = do env <- prepareEnv name args+ -- Cache the compilation tree right here.+ -- We only really care about envGlobal and envBody here. val <- runEnv $ parseProgram (fenv env) name prog f val @@ -433,7 +444,8 @@ runPIR prog = do pir <- doCompile "PIR" "-" prog writeFile "a.pir" pir- evalParrotFile "a.pir"+ fail "evalParrotFile is bitrotten."+ -- evalParrotFile "a.pir" {- withInlinedIncludes :: String -> IO String
src/Pugs/Compile.hs view
@@ -25,6 +25,7 @@ import Pugs.PIL1 import Language.PIR import Text.PrettyPrint+import qualified Data.ByteString.Char8 as BS tcVoid, tcLValue :: TCxt tcVoid = TCxtVoid@@ -208,6 +209,7 @@ compile (Ann Prag{} rest) = compile rest -- fmap (PPos pos rest) $ compile rest compile (Ann _ rest) = compile rest compile Noop = return PNoop+ {- compile (Val val) = do cxt <- asks envContext if isVoidCxt cxt@@ -217,6 +219,8 @@ warn "Useless use of a constant in void context" val compile Noop else compile val+ -}+ compile (Val val) = compile val compile (Syn "loop" [exp]) = compile (Syn "loop" $ [emptyExp, Val (VBool True), emptyExp, exp]) compile (Syn "loop" [pre, cond, post, body]) = do@@ -380,6 +384,7 @@ _PVar :: Var -> PIL_LValue _PVar = PVar . cast +addPad stmt entry = PPad{pStmts=stmt,pScope=SMy,pSyms=[((BS.unpack $ cast $ fst entry),PRawName "...")]} {-| Compiles various 'Exp's to 'PIL_Expr's. -} instance Compile Exp PIL_Expr where compile (Ann Pos{} rest) = compile rest -- fmap (PPos pos rest) $ compile rest@@ -395,12 +400,12 @@ cxt <- askTCxt bodyC <- compile body return $ PExp $ PApp cxt (pBlock bodyC) Nothing []- compile (Syn "sub" [Val (VCode sub)]) = do+ compile (Syn "sub" [Val (VCode sub)]) = do bodyC <- enter sub $ compile $ case subBody sub of Syn "block" [exp] -> exp exp -> exp paramsC <- compile $ subParams sub- return $ PCode (subType sub) paramsC (subLValue sub) (isMulti sub) bodyC+ return $ PCode (subType sub) paramsC (subLValue sub) (isMulti sub) (foldl addPad bodyC (padToList $ subInnerPad sub)) compile (Syn "module" _) = compile Noop compile (Syn "match" exp) = compile $ Syn "rx" exp -- wrong compile (Syn "//" exp) = compile $ Syn "rx" exp
src/Pugs/Eval.hs view
@@ -898,7 +898,7 @@ val <- readRef =<< fromVal lhs evalExp $ Syn "=" [Val lhs, App (_Var op) Nothing [Val val, rhsExp]] -reduceSyn "q:code" [ body ] = expToEvalVal body+reduceSyn "quasi" [ body ] = expToEvalVal body reduceSyn "CCallDyn" (Val (VStr quant):methExp:invExp:args) = do -- Experimental support for .*$meth, assuming single inheritance.
src/Pugs/Lexer.hs view
@@ -272,23 +272,29 @@ -- | Backslashed non-alphanumerics (except for @\^@) translate into themselves. escapeCode :: RuleParser String-escapeCode = charNum <|> ch charEsc <|> ch charAscii <|> ch charControl <|> ch anyChar+escapeCode = charNum <|> ch charEsc <|> ch charAscii <|> charControl <|> ch anyChar <?> "escape code" where ch = fmap (:[]) -charControl :: RuleParser Char+charControl :: RuleParser String charControl = do char 'c'- code <- upper <|> oneOf "@["+ code <- upper <|> oneOf "@[" <|> digit case code of '[' -> do- charName <- many (satisfy (/= ']'))+ charNames <- many1 (noneOf ",]") `sepBy1` many1 ruleComma char ']'- case nameToCode charName of- Just c -> return (chr c)- _ -> error $ "Invalid unicode character name: " ++ charName- _ -> return (toEnum (fromEnum code - fromEnum '@'))+ forM charNames $ \charName -> do+ if all isDigit charName+ then return $ chr (read charName)+ else case nameToCode charName of+ Just c -> return (chr c)+ _ -> fail $ "Invalid unicode character name: " ++ charName+ _ | isDigit code -> do+ cs <- many digit+ return [chr $ read (code:cs)]+ _ -> return [toEnum (fromEnum code - fromEnum '@')] -- This is currently the only escape that can return multiples. charNum :: RuleParser String@@ -298,10 +304,10 @@ "0" -> return [0] -- "\08..." and "\09..." are treated as "\0" and then "8..." or "9...". ('0':xs@(x:_)) | x == '8' || x == '9' -> return (0:map (toInteger . ord) xs)- _ -> error ("Error: Invalid escape sequence \\" ++ ds ++ "; write as decimal \\d" ++ ds ++ " or octal \\o" ++ ds ++ " instead") -- return [read ds]+ _ -> error ("Error: Invalid escape sequence \\" ++ ds ++ "; write as decimal \\c" ++ ds ++ " or octal \\o" ++ ds ++ " instead") -- return [read ds] , based 'o' 8 octDigit , based 'x' 16 hexDigit- , based 'd' 10 digit+-- , based 'c' 10 digit ] return $ map (toEnum . fromInteger) codes where
src/Pugs/Parser.hs view
@@ -983,13 +983,13 @@ putRuleEnv target { envPragmas = prag ++ envPragmas target } _ -> fail "no caller env to install pragma in" -{-| Match a @q:code { ... }@ quotation -}+{-| Match a @quasi { ... }@ quotation -} ruleCodeQuotation :: RuleParser Exp ruleCodeQuotation = rule "code quotation" $ do -- XXX - This is entirely kluge; it drops traits in the body too- symbol "q:code" >> optional (symbol "(:COMPILING)")+ symbol "quasi" >> optional (symbol ":COMPILING") block <- ruleBlockBody- return (Syn "q:code" [bi_body block])+ return (Syn "quasi" [bi_body block]) -- | If we've executed code like @BEGIN { exit }@, we've to run all @\@*END@ -- blocks and then exit. Returns the input expression if there's no need to
src/Pugs/Prim.hs view
@@ -238,8 +238,8 @@ externRequire "Haskell" name return $ VBool True op1 "require_parrot" = \v -> do- name <- fromVal v- io $ evalParrotFile name+ -- name <- fromVal v+ fail "evalParrotFile has bitrotten." -- io $ evalParrotFile name return $ VBool True op1 "require_perl5" = \v -> do pkg <- fromVal v@@ -258,7 +258,9 @@ evalExp_ (_Sym SOur (':':'*':lastPart) mempty (Val val) (newMetaType lastPart)) return val op1 "Pugs::Internals::eval_parrot" = \v -> do- code <- fromVal v+ -- code <- fromVal v+ fail "evalParrot has bitrotten." + {- io . evalParrot $ case code of ('.':_) -> code _ -> unlines@@ -267,6 +269,7 @@ , code , ".end" ]+ -} return $ VBool True -- XXX - revert these two to Prelude.pm's ::Disabled version once YAML+Closure is working@@ -515,7 +518,7 @@ fail $ "BEGIN and CHECK blocks may not return IO handles,\n" ++ "as they would be invalid at runtime." return rv-op1 "system" = \v -> do+op1 "run" = \v -> do cmd <- fromVal v exitCode <- tryIO (ExitFailure (-1)) $ system (encodeUTF8 cmd) handleExitCode exitCode@@ -1121,7 +1124,7 @@ VInt i -> printf str i VStr s -> printf str s _ -> fail "should never be reached given the type declared below"-op2 "system" = \x y -> do+op2 "run" = \x y -> do prog <- fromVal x args <- fromVals y exitCode <- tryIO (ExitFailure (-1)) $@@ -2003,7 +2006,7 @@ \\n Any pre redo safe (?Int=1)\ \\n Any pre continue safe (?Int=1)\ \\n Any pre break safe (?Int=1)\-\\n Any pre exit unsafe (?Int=0)\+\\n Any pre exit safe (?Int=0)\ \\n Any pre srand safe (?Num)\ \\n Num pre rand safe (?Num=1)\ \\n Bool pre defined safe (Any)\@@ -2043,8 +2046,8 @@ \\n List pre slurp unsafe (Handle)\ \\n List pre readdir unsafe (Str)\ \\n Bool pre Pugs::Internals::exec unsafe (Str, Bool, List)\-\\n Int pre system unsafe (Str)\-\\n Int pre system unsafe (Str: List)\+\\n Int pre run unsafe (Str)\+\\n Int pre run unsafe (Str: List)\ \\n Bool pre binmode unsafe (IO: ?Int=1)\ \\n Void pre return safe ()\ \\n Void pre return safe (rw!Any)\
src/Pugs/Version.hs view
@@ -14,10 +14,10 @@ -- #include "pugs_version.h" #ifndef PUGS_VERSION-#define PUGS_VERSION "6.2.13.11"+#define PUGS_VERSION "6.2.13.13" #endif #ifndef PUGS_DATE-#define PUGS_DATE "July 31, 2008"+#define PUGS_DATE "December 6, 2008" #endif #ifndef PUGS_SVN_REVISION #define PUGS_SVN_REVISION 0