diff --git a/Pugs.cabal b/Pugs.cabal --- a/Pugs.cabal +++ b/Pugs.cabal @@ -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, diff --git a/src/Pugs.hs b/src/Pugs.hs --- a/src/Pugs.hs +++ b/src/Pugs.hs @@ -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 = "" @@ -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 diff --git a/src/Pugs/Compile.hs b/src/Pugs/Compile.hs --- a/src/Pugs/Compile.hs +++ b/src/Pugs/Compile.hs @@ -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 diff --git a/src/Pugs/Eval.hs b/src/Pugs/Eval.hs --- a/src/Pugs/Eval.hs +++ b/src/Pugs/Eval.hs @@ -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. diff --git a/src/Pugs/Lexer.hs b/src/Pugs/Lexer.hs --- a/src/Pugs/Lexer.hs +++ b/src/Pugs/Lexer.hs @@ -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 diff --git a/src/Pugs/Parser.hs b/src/Pugs/Parser.hs --- a/src/Pugs/Parser.hs +++ b/src/Pugs/Parser.hs @@ -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 diff --git a/src/Pugs/Prim.hs b/src/Pugs/Prim.hs --- a/src/Pugs/Prim.hs +++ b/src/Pugs/Prim.hs @@ -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)\ diff --git a/src/Pugs/Version.hs b/src/Pugs/Version.hs --- a/src/Pugs/Version.hs +++ b/src/Pugs/Version.hs @@ -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