Changeset 6793
- Timestamp:
- 09/06/05 14:11:41 (3 years ago)
- Location:
- src
- Files:
-
- 33 modified
-
DrIFT/Binary.hs (modified) (22 diffs)
-
Main.hs (modified) (2 diffs)
-
Pugs/AST/Internals.hs (modified) (4 diffs)
-
Pugs/Class.hs (modified) (4 diffs)
-
Pugs/Cont/CC_2CPST.hs (modified) (2 diffs)
-
Pugs/Embed/Parrot.hsc (modified) (3 diffs)
-
Pugs/Parser/Program.hs (modified) (1 diff)
-
Pugs/Pretty.hs (modified) (1 diff)
-
Pugs/Prim/List.hs (modified) (2 diffs)
-
Pugs/Prim/Match.hs (modified) (1 diff)
-
Pugs/Rule/Language.hs (modified) (4 diffs)
-
Pugs/Rule/Pos.hs (modified) (1 diff)
-
Pugs/Rule/Prim.hs (modified) (1 diff)
-
Pugs/Types/Scalar.hs (modified) (1 diff)
-
Pugs/Version.hs (modified) (1 diff)
-
RRegex.hs (modified) (3 diffs)
-
RRegex/PCRE.hs (modified) (3 diffs)
-
UTF8/PackedString.hs (modified) (10 diffs)
-
Unicode.hs (modified) (4 diffs)
-
UnicodeC.c (modified) (7 diffs)
-
perl5/perl5.c (modified) (9 diffs)
-
perl5/perlxsi.c (modified) (1 diff)
-
perl5/pugsembed.c (modified) (2 diffs)
-
perl6/Prelude.pm (modified) (5 diffs)
-
perl6/Prelude/PIR.pm (modified) (3 diffs)
-
syck/bytecode.c (modified) (29 diffs)
-
syck/emitter.c (modified) (1 diff)
-
syck/gram.c (modified) (25 diffs)
-
syck/implicit.c (modified) (5 diffs)
-
syck/syck.c (modified) (2 diffs)
-
syck/syck_st.c (modified) (18 diffs)
-
syck/syck_st.h (modified) (1 diff)
-
syck/token.c (modified) (58 diffs)
Legend:
- Unmodified
- Added
- Removed
-
src/DrIFT/Binary.hs
r6359 r6793 44 44 putByteArray, 45 45 46 --getBinFileWithDict, -- :: Binary a => FilePath -> IO a47 --putBinFileWithDict, -- :: Binary a => FilePath -> ModuleName -> a -> IO ()46 --getBinFileWithDict, -- :: Binary a => FilePath -> IO a 47 --putBinFileWithDict, -- :: Binary a => FilePath -> ModuleName -> a -> IO () 48 48 49 49 ) where … … 56 56 import Data.Word 57 57 import Data.IORef 58 import Data.Char ( ord, chr )59 import Control.Monad ( when )60 import Control.Exception ( throwDyn )58 import Data.Char ( ord, chr ) 59 import Control.Monad ( when ) 60 import Control.Exception ( throwDyn ) 61 61 import System.IO as IO 62 import System.IO.Unsafe ( unsafeInterleaveIO )63 import System.IO.Error ( mkIOError, eofErrorType )64 import GHC.Real ( Ratio(..) )62 import System.IO.Unsafe ( unsafeInterleaveIO ) 63 import System.IO.Error ( mkIOError, eofErrorType ) 64 import GHC.Real ( Ratio(..) ) 65 65 import GHC.Exts 66 import GHC.IOBase ( IO(..) )67 import GHC.Word ( Word8(..) )68 import System.IO ( openBinaryFile )66 import GHC.IOBase ( IO(..) ) 67 import GHC.Word ( Word8(..) ) 68 import System.IO ( openBinaryFile ) 69 69 import UTF8.PackedString 70 70 --import Atom … … 93 93 = IOException (IOError maybe_hdl t location "" 94 94 #if __GLASGOW_HASKELL__ > 411 95 maybe_filename95 maybe_filename 96 96 #endif 97 )97 ) 98 98 eofErrorType = EOF 99 99 … … 112 112 type BinArray = IOUArray Int Word8 113 113 --------------------------------------------------------------- 114 -- BinHandle114 -- BinHandle 115 115 --------------------------------------------------------------- 116 116 117 117 data BinHandle 118 = BinMem { -- binary data stored in an unboxed array119 off_r :: !FastMutInt, -- the current offset120 sz_r :: !FastMutInt, -- size of the array (cached)121 arr_r :: !(IORef BinArray) -- the array (bounds: (0,size-1))118 = BinMem { -- binary data stored in an unboxed array 119 off_r :: !FastMutInt, -- the current offset 120 sz_r :: !FastMutInt, -- size of the array (cached) 121 arr_r :: !(IORef BinArray) -- the array (bounds: (0,size-1)) 122 122 } 123 -- XXX: should really store a "high water mark" for dumping out124 -- the binary data to a file.125 126 | BinIO { -- binary data stored in a file127 off_r :: !FastMutInt, -- the current offset (cached)128 hdl :: !IO.Handle -- the file handle (must be seekable)123 -- XXX: should really store a "high water mark" for dumping out 124 -- the binary data to a file. 125 126 | BinIO { -- binary data stored in a file 127 off_r :: !FastMutInt, -- the current offset (cached) 128 hdl :: !IO.Handle -- the file handle (must be seekable) 129 129 } 130 -- cache the file ptr in BinIO; using hTell is too expensive131 -- to call repeatedly. If anyone else is modifying this Handle132 -- at the same time, we'll be screwed.130 -- cache the file ptr in BinIO; using hTell is too expensive 131 -- to call repeatedly. If anyone else is modifying this Handle 132 -- at the same time, we'll be screwed. 133 133 134 134 --getUserData :: BinHandle -> UserData … … 140 140 141 141 --------------------------------------------------------------- 142 -- Bin142 -- Bin 143 143 --------------------------------------------------------------- 144 144 … … 150 150 151 151 --------------------------------------------------------------- 152 -- class Binary152 -- class Binary 153 153 --------------------------------------------------------------- 154 154 … … 202 202 sz <- readFastMutInt sz_r 203 203 if (p >= sz) 204 then do expandBin h p; writeFastMutInt ix_r p205 else writeFastMutInt ix_r p204 then do expandBin h p; writeFastMutInt ix_r p 205 else writeFastMutInt ix_r p 206 206 207 207 isEOFBin :: BinHandle -> IO Bool … … 251 251 return () 252 252 expandBin (BinIO _ _) _ = return () 253 -- no need to expand a file, we'll assume they expand by themselves.253 -- no need to expand a file, we'll assume they expand by themselves. 254 254 255 255 -- ----------------------------------------------------------------------------- … … 260 260 ix <- readFastMutInt ix_r 261 261 sz <- readFastMutInt sz_r 262 -- double the size of the array if it overflows262 -- double the size of the array if it overflows 263 263 if (ix >= sz) 264 264 then do … … 273 273 putWord8 (BinIO ix_r h) w = do 274 274 ix <- readFastMutInt ix_r 275 hPutChar h (chr (fromIntegral w)) -- XXX not really correct275 hPutChar h (chr (fromIntegral w)) -- XXX not really correct 276 276 writeFastMutInt ix_r (ix+1) 277 277 return () … … 282 282 sz <- readFastMutInt sz_r 283 283 when (ix >= sz) $ 284 ioError (mkIOError eofErrorType "Data.Binary.getWord8" Nothing Nothing)284 ioError (mkIOError eofErrorType "Data.Binary.getWord8" Nothing Nothing) 285 285 arr <- readIORef arr_r 286 286 w <- unsafeRead arr ix … … 291 291 c <- hGetChar h 292 292 writeFastMutInt ix_r (ix+1) 293 return $! (fromIntegral (ord c)) -- XXX not really correct293 return $! (fromIntegral (ord c)) -- XXX not really correct 294 294 295 295 {-# INLINE putByte #-} … … 330 330 w4 <- getWord8 h 331 331 return $! ((fromIntegral w1 `shiftL` 24) .|. 332 (fromIntegral w2 `shiftL` 16) .|.333 (fromIntegral w3 `shiftL` 8) .|.334 (fromIntegral w4))332 (fromIntegral w2 `shiftL` 16) .|. 333 (fromIntegral w3 `shiftL` 8) .|. 334 (fromIntegral w4)) 335 335 336 336 … … 355 355 w8 <- getWord8 h 356 356 return $! ((fromIntegral w1 `shiftL` 56) .|. 357 (fromIntegral w2 `shiftL` 48) .|.358 (fromIntegral w3 `shiftL` 40) .|.359 (fromIntegral w4 `shiftL` 32) .|.360 (fromIntegral w5 `shiftL` 24) .|.361 (fromIntegral w6 `shiftL` 16) .|.362 (fromIntegral w7 `shiftL` 8) .|.363 (fromIntegral w8))357 (fromIntegral w2 `shiftL` 48) .|. 358 (fromIntegral w3 `shiftL` 40) .|. 359 (fromIntegral w4 `shiftL` 32) .|. 360 (fromIntegral w5 `shiftL` 24) .|. 361 (fromIntegral w6 `shiftL` 16) .|. 362 (fromIntegral w7 `shiftL` 8) .|. 363 (fromIntegral w8)) 364 364 365 365 -- ----------------------------------------------------------------------------- … … 404 404 put_ bh i = put_ bh (fromIntegral i :: Int32) 405 405 get bh = do 406 x <- get bh407 return $! (fromIntegral (x :: Int32))406 x <- get bh 407 return $! (fromIntegral (x :: Int32)) 408 408 -- #elif SIZEOF_HSINT == 8 409 409 -- put_ bh i = put_ bh (fromIntegral i :: Int64) 410 410 -- get bh = do 411 -- x <- get bh412 -- return $! (fromIntegral (x :: Int64))411 -- x <- get bh 412 -- return $! (fromIntegral (x :: Int64)) 413 413 -- #else 414 414 -- #error "unsupported sizeof(HsInt)" … … 417 417 instance Binary ClockTime where 418 418 put_ bh ct = do 419 let t = toUTCTime ct420 put_ bh (ctYear t)421 put_ bh (fromEnum $ ctMonth t)422 put_ bh (ctDay t)423 put_ bh (ctHour t)424 put_ bh (ctMin t)425 put_ bh (ctSec t)419 let t = toUTCTime ct 420 put_ bh (ctYear t) 421 put_ bh (fromEnum $ ctMonth t) 422 put_ bh (ctDay t) 423 put_ bh (ctHour t) 424 put_ bh (ctMin t) 425 put_ bh (ctSec t) 426 426 get bh = do 427 year <- get bh428 month <- fmap toEnum $ get bh429 day <- get bh430 hour <- get bh431 min <- get bh432 sec <- get bh433 return $ toClockTime $ (toUTCTime epoch) {ctYear = year, ctDay = day, ctMonth = month, ctHour = hour, ctMin = min, ctSec = sec}427 year <- get bh 428 month <- fmap toEnum $ get bh 429 day <- get bh 430 hour <- get bh 431 min <- get bh 432 sec <- get bh 433 return $ toClockTime $ (toUTCTime epoch) {ctYear = year, ctDay = day, ctMonth = month, ctHour = hour, ctMin = min, ctSec = sec} 434 434 epoch = toClockTime $ CalendarTime { ctYear = 1970, ctMonth = January, ctDay = 0, ctHour = 0, ctMin = 0, ctSec = 0, ctTZ = 0, ctPicosec = 0, ctWDay = undefined, ctYDay = undefined, ctTZName = undefined, ctIsDST = undefined} 435 435 … … 564 564 put_ bh (S# i#) = do putByte bh 0; put_ bh (I# i#) 565 565 put_ bh (J# s# a#) = do 566 p <- putByte bh 1;567 put_ bh (I# s#)568 let sz# = sizeofByteArray# a# -- in *bytes*569 put_ bh (I# sz#) -- in *bytes*570 putByteArray bh a# sz#566 p <- putByte bh 1; 567 put_ bh (I# s#) 568 let sz# = sizeofByteArray# a# -- in *bytes* 569 put_ bh (I# sz#) -- in *bytes* 570 putByteArray bh a# sz# 571 571 572 572 get bh = do 573 b <- getByte bh574 case b of575 0 -> do (I# i#) <- get bh576 return (S# i#)577 _ -> do (I# s#) <- get bh578 sz <- get bh579 (BA a#) <- getByteArray bh sz580 return (J# s# a#)573 b <- getByte bh 574 case b of 575 0 -> do (I# i#) <- get bh 576 return (S# i#) 577 _ -> do (I# s#) <- get bh 578 sz <- get bh 579 (BA a#) <- getByteArray bh sz 580 return (J# s# a#) 581 581 582 582 putByteArray :: BinHandle -> ByteArray# -> Int# -> IO () 583 583 putByteArray bh a s# = loop 0# 584 584 where loop n# 585 | n# ==# s# = return ()586 | otherwise = do587 putByte bh (indexByteArray a n#)588 loop (n# +# 1#)585 | n# ==# s# = return () 586 | otherwise = do 587 putByte bh (indexByteArray a n#) 588 loop (n# +# 1#) 589 589 590 590 getByteArray :: BinHandle -> Int -> IO ByteArray … … 592 592 (MBA arr) <- newByteArray sz 593 593 let loop n 594 | n ==# sz = return ()595 | otherwise = do596 w <- getByte bh597 writeByteArray arr n w598 loop (n +# 1#)594 | n ==# sz = return () 595 | otherwise = do 596 w <- getByte bh 597 writeByteArray arr n w 598 loop (n +# 1#) 599 599 loop 0# 600 600 freezeByteArray arr … … 636 636 lazyPut :: Binary a => BinHandle -> a -> IO () 637 637 lazyPut bh a = do 638 -- output the obj with a ptr to skip over it:638 -- output the obj with a ptr to skip over it: 639 639 pre_a <- tellBin bh 640 put_ bh pre_a -- save a slot for the ptr641 put_ bh a -- dump the object642 q <- tellBin bh -- q = ptr to after object643 putAt bh pre_a q -- fill in slot before a with ptr to q644 seekBin bh q -- finally carry on writing at q640 put_ bh pre_a -- save a slot for the ptr 641 put_ bh a -- dump the object 642 q <- tellBin bh -- q = ptr to after object 643 putAt bh pre_a q -- fill in slot before a with ptr to q 644 seekBin bh q -- finally carry on writing at q 645 645 646 646 lazyGet :: Binary a => BinHandle -> IO a 647 647 lazyGet bh = do 648 p <- get bh -- a BinPtr648 p <- get bh -- a BinPtr 649 649 p_a <- tellBin bh 650 650 a <- unsafeInterleaveIO (getAt bh p_a) … … 655 655 {- 656 656 --------------------------------------------------------- 657 -- Reading and writing FastStrings657 -- Reading and writing FastStrings 658 658 --------------------------------------------------------- 659 659 … … 662 662 putByteArray bh ba l 663 663 putFS bh s = error ("Binary.put_(FastString): " ++ unpackFS s) 664 -- Note: the length of the FastString is *not* the same as665 -- the size of the ByteArray: the latter is rounded up to a666 -- multiple of the word size.664 -- Note: the length of the FastString is *not* the same as 665 -- the size of the ByteArray: the latter is rounded up to a 666 -- multiple of the word size. 667 667 668 668 {- -- possible faster version, not quite there yet: … … 682 682 put_ bh f@(FastString id l ba) = 683 683 case getUserData bh of { 684 UserData { ud_next = j_r, ud_map = out_r, ud_dict = dict} -> do684 UserData { ud_next = j_r, ud_map = out_r, ud_dict = dict} -> do 685 685 out <- readIORef out_r 686 686 let uniq = getUnique f 687 687 case lookupUFM out uniq of 688 Just (j,f) -> put_ bh j689 Nothing -> do690 j <- readIORef j_r691 put_ bh j692 writeIORef j_r (j+1)693 writeIORef out_r (addToUFM out uniq (j,f))688 Just (j,f) -> put_ bh j 689 Nothing -> do 690 j <- readIORef j_r 691 put_ bh j 692 writeIORef j_r (j+1) 693 writeIORef out_r (addToUFM out uniq (j,f)) 694 694 } 695 695 put_ bh s = error ("Binary.put_(FastString): " ++ show (unpackFS s)) 696 696 697 697 get bh = do 698 j <- get bh699 return $! (ud_dict (getUserData bh) ! j)698 j <- get bh 699 return $! (ud_dict (getUserData bh) ! j) 700 700 -} 701 701 -} -
src/Main.hs
r5815 r6793 249 249 env <- liftSTM $ readTVar menv 250 250 return $ envBody $ parseProgram env "<interactive>" $ 251 (decodeUTF8 prog)251 (decodeUTF8 prog) 252 252 theEnv = do 253 253 ref <- if runOptSeparately opts … … 327 327 328 328 printConfigInfo (item:_) = do 329 putStrLn $ createConfigLine item329 putStrLn $ createConfigLine item 330 330 331 331 compPIR :: String -> IO () -
src/Pugs/AST/Internals.hs
r6672 r6793 702 702 instance Show VJunc where 703 703 show (MkJunc jtype _ set) = 704 (show jtype) ++ "(" ++705 (foldl (\x y ->706 if x == "" then show y707 else x ++ "," ++ show y)708 "" $ Set.elems set) ++ ")"704 (show jtype) ++ "(" ++ 705 (foldl (\x y -> 706 if x == "" then show y 707 else x ++ "," ++ show y) 708 "" $ Set.elems set) ++ ")" 709 709 710 710 {-| … … 1099 1099 1100 1100 lookupPad key (MkPad map) = case Map.lookup (possiblyFixOperatorName key) map of 1101 Just xs -> Just [tvar | (_, tvar) <- xs]1102 Nothing -> Nothing1101 Just xs -> Just [tvar | (_, tvar) <- xs] 1102 Nothing -> Nothing 1103 1103 1104 1104 {-| … … 1654 1654 , rxGlobal :: !Bool -- ^ Flag indicating \'global\' (match-all) 1655 1655 , rxNumSubs :: !Int -- ^ The number of subpatterns present. 1656 , rxStringify :: !Bool1656 , rxStringify :: !Bool 1657 1657 , rxRuleStr :: !String -- ^ The rule string, for user reference. 1658 1658 , rxAdverbs :: !Val … … 1662 1662 { rxRule :: !String -- ^ The rule string 1663 1663 , rxGlobal :: !Bool -- ^ Flag indicating \'global\' (match-all) 1664 , rxStringify :: !Bool1664 , rxStringify :: !Bool 1665 1665 , rxAdverbs :: !Val 1666 1666 } -
src/Pugs/Class.hs
r5892 r6793 170 170 Package := MetaClass where clsName = "Package" 171 171 Package.clsProperties = 172 { pkgName = MetaProperty { type = Symbol }173 , pkgIsGlobal = MetaProperty { type = Bool }174 , pkgStash = MetaProperty { type = Map (sigil, Symbol) Object }175 }172 { pkgName = MetaProperty { type = Symbol } 173 , pkgIsGlobal = MetaProperty { type = Bool } 174 , pkgStash = MetaProperty { type = Map (sigil, Symbol) Object } 175 } 176 176 177 177 -- Package->has_many("pkgChildren" => Package) 178 178 -- Package->maybe_has_one("pkgParent" => Package) 179 179 Package.clsCats = 180 { pkgChildren =180 { pkgChildren = 181 181 (Public, MetaAssoc 182 182 { catIsComposite = true, … … 188 188 }, 189 189 }) 190 }190 } 191 191 192 192 {- … … 207 207 Module := MetaClass where clsName = "Module" 208 208 Module.clsProperties = 209 { modVersion = MetaProperty { type = Version }210 , modAuthorizer = MetaProperty { type = String }211 }209 { modVersion = MetaProperty { type = Version } 210 , modAuthorizer = MetaProperty { type = String } 211 } 212 212 213 213 Module.clsMethods = 214 { modName = MetaMethod215 { methodInvoke = ( self.pkgName214 { modName = MetaMethod 215 { methodInvoke = ( self.pkgName 216 216 ~ "-" ~ self.modVersion 217 ~ "-" ~ self.modAuthorizer ) }218 }217 ~ "-" ~ self.modAuthorizer ) } 218 } 219 219 220 220 Module.clsAssocs = 221 { modTraits = (Public, MetaAssoc221 { modTraits = (Public, MetaAssoc 222 222 { catIsComposite = true, 223 223 catRange = (Zero, Many), … … 228 228 catRange = (One, One) } ), 229 229 }) 230 }230 } 231 231 232 232 Class := MetaClass where clsName = "Class" -
src/Pugs/Cont/CC_2CPST.hs
r2786 r6793 35 35 instance MonadTrans (CC r) where 36 36 lift m = CC (\ (Cont k) -> 37 MC (\mk -> lift (m >>= (\a -> let MC mc = k a38 in PromptTR.runP (mc mk)))))37 MC (\mk -> lift (m >>= (\a -> let MC mc = k a 38 in PromptTR.runP (mc mk))))) 39 39 40 40 instance (MonadIO m) => MonadIO (CC r m) where … … 76 76 77 77 letSubCont :: Monad m => 78 Prompt r b -> (SubCont r m a b -> CC r m b) -> CC r m a78 Prompt r b -> (SubCont r m a b -> CC r m b) -> CC r m a 79 79 letSubCont p f = 80 80 CC (\k -> MC (\mk -> -
src/Pugs/Embed/Parrot.hsc
r6248 r6793 61 61 let nameStr = escape name 62 62 ruleStr = escape rule 63 hPutStrLn inp $ unwords63 hPutStrLn inp $ unwords 64 64 ["add_rule", show (length nameStr), show (length ruleStr)] 65 hPutStrLn inp nameStr66 hPutStrLn inp ruleStr65 hPutStrLn inp nameStr 66 hPutStrLn inp ruleStr 67 67 let matchStr = escape match 68 68 ruleStr = escape rule … … 74 74 rv <- hGetLine out 75 75 case rv of 76 ('O':'K':' ':sizeStr) -> do77 size <- readIO sizeStr78 rv<- sequence (replicate size (hGetChar out))79 ln<- hGetLine out80 return $ rv ++ ln81 _ -> do82 errMsg <- hGetContents err83 rv <- waitForProcess pid84 writeIORef _ParrotInterp Nothing85 let msg | null errMsg = show rv86 | otherwise = errMsg87 fail $ "*** Running external 'parrot' failed:\n" ++ msg76 ('O':'K':' ':sizeStr) -> do 77 size <- readIO sizeStr 78 rv <- sequence (replicate size (hGetChar out)) 79 ln <- hGetLine out 80 return $ rv ++ ln 81 _ -> do 82 errMsg <- hGetContents err 83 rv <- waitForProcess pid 84 writeIORef _ParrotInterp Nothing 85 let msg | null errMsg = show rv 86 | otherwise = errMsg 87 fail $ "*** Running external 'parrot' failed:\n" ++ msg 88 88 where 89 89 escape "" = "" … …
