+++ /dev/null
-#include <stdio.h>
-
-main ()
-{
- char c[4096];
- int n;
-
- while ((n=fread(c,1,4096,stdin)) > 0) {
- fwrite(c,1,n,stdout);
- }
- exit(0);
-}
-
-/*
--- 8,937,757 bytes/sec ( 600KB input)
--- 12,146,094 bytes/sec ( 9.3MB input)
--- 8,658,233 bytes/sec (25.5MB input)
-*/
+++ /dev/null
-#include <stdio.h>
-
-main ()
-{
- int c;
- while ((c = getchar()) != EOF) {
- putchar(c);
- }
- exit(0);
-}
-
-/*
--- 2,085,477 bytes/sec ( 600KB input)
--- 2,320,718 bytes/sec ( 9.3MB input)
--- 2,130,143 bytes/sec (25.5MB input)
-*/
+++ /dev/null
-main :: IO ()
-main = interact id
-
--- 46,173 bytes/sec (600KB input)
+++ /dev/null
-module Main (main) where
-
-main :: IO ()
-main
- = try getChar >>=
- {-then-}either (\ _ -> return ())
- {-or-} (\ c -> putChar c >>
- main)
-
--- 51,156 bytes/sec (600KB input)
+++ /dev/null
-module Main (main) where
-
-import LibPosix
-
-main :: IO ()
-main = copy standardInput standardOutput
- where
- copy inn out
- = try (readFileDescriptor inn 4096) >>=
- either
- (\ _ -> return ())
- (\ s -> writeFileDescriptor out s >>
- copy inn out)
-
--- 124,879 bytes/sec ( 600KB input)
--- 130,694 bytes/sec ( 9.3MB input)
--- 127,263 bytes/sec (25.5MB input)
+++ /dev/null
-module Main (mainPrimIO) where
-
-import PreludePrimIO
-
-mainPrimIO :: PrimIO ()
-mainPrimIO
- = copy (``stdin'' :: _FILE)
- (``stdout'' :: _FILE)
- where
- copy inn out
- = fread 1 4096 inn
- `thenPrimIO` \ (n, s) ->
- if n <= 0
- then returnPrimIO ()
- else fwrite s 1 n out `seqPrimIO`
- copy inn out
-
--- 4,170,953 bytes/sec ( 600KB input)
--- 7,993,583 bytes/sec ( 9.3MB input)
--- 6,917,175 bytes/sec (25.5MB input)
+++ /dev/null
-module Main (mainPrimIO) where
-
-import PreludePrimIO
-
-mainPrimIO :: PrimIO ()
-mainPrimIO
- = _ccall_ stg_getc (``stdin'' :: _Addr)
- `thenPrimIO` \ (I# ch) ->
- if ch <# 0# then -- SIGH: ch ==# ``EOF''
- returnPrimIO ()
- else
- _ccall_ stg_putc (C# (chr# ch))
- (``stdout'' :: _Addr)
- `seqPrimIO`
- mainPrimIO
-
--- 1,737,897 bytes/sec ( 600KB input)
--- 1,808,993 bytes/sec ( 9.3MB input)
--- 1,711,850 bytes/sec (25.5MB input)
+++ /dev/null
-module Main (mainPrimIO) where
-
-import PreludePrimIO
-
-mainPrimIO :: PrimIO ()
-mainPrimIO
- = _casm_
- ``do { int c;
- while ((c = getchar()) != EOF) {
- putchar(c);
- }} while (0);
- %r = 1;'' -- pretend we have a "result"
- `thenPrimIO` \ (I# _) ->
- returnPrimIO ()
-
--- 1,955,134 bytes/sec ( 600KB input)
--- 1,989,892 bytes/sec ( 9.3MB input)
--- 1,871,706 bytes/sec (25.5MB input)
+++ /dev/null
-#! /usr/local/bin/perl
-
-$InputSize = 0;
-
-while (<>) {
- chop;
-
- if ( m,< /users/fp/partain/bib/comp.bib, ) {
- $InputSize = 625643;
- print "$_\n";
- } elsif ( m,\$bghc/lib/libHS_p.a, ) {
- $InputSize = 9352492;
- print "$_\n";
- } elsif ( m,\$bghca/lib/libHS_p.a, ) {
- $InputSize = 25455204;
- print "$_\n";
-
- } elsif ( /^\s*(\d+\.\d+)u (\d+\.\d+)s / ) {
- $UserSysTime = $1 + $2;
- $BytesPerSec = $InputSize / $UserSysTime;
- printf "%.0f\t%s\n", $BytesPerSec, $_;
- }
-}
+++ /dev/null
-module Main (main) where
-
-import IO
-import Posix
-
-import Directory (setCurrentDirectory)
-import System ( getEnv, exitWith, ExitCode(..) )
-import Char (isSpace)
-
-main :: IO ()
-main =
- do
- initialize
- commandLoop
-
-{-
- Standard shell practice: move std descriptors out of the way so
- it's more convenient to set them up for children. Also set up an
- interrupt handler which will put us back in the main loop.
--}
-
-initialize :: IO ()
-initialize =
- dupTo stdInput myStdin >>
- dupTo stdOutput myStdout >>
- dupTo stdError myStderr >>
- fdClose stdInput >>
- fdClose stdOutput >>
--- fdClose stdError >>
- installHandler sigINT (Catch intr) Nothing >>
- return ()
-
--- some random fd numbers...
-myStdin = intToFd 16
-myStdout = intToFd 17
-myStderr = intToFd 18
-
--- For user interrupts
-
-intr :: IO ()
-intr =
- fdWrite myStdout "\n" >>
- commandLoop
-
-{-
- Simple command loop: print a prompt, read a command, process the command.
- Repeat as necessary.
--}
-
-commandLoop :: IO ()
-commandLoop =
- fdWrite myStdout "$ " >>
- try (readCommand myStdin) >>=
- either
- (\ err ->
- if isEOFError err then
- return ()
- else
- dieHorribly)
- (\ cmd ->
- try (processCommand cmd) >>= either (\ err -> commandLoop) (\ succ -> commandLoop))
- where
- dieHorribly :: IO ()
- dieHorribly =
- do
- errMsg "read failed"
- exitWith (ExitFailure 1)
-
-{-
- Read a command a character at a time (to allow for fancy processing later).
- On newline, you're done, unless the newline was escaped by a backslash.
--}
-
-readCommand :: Fd -> IO String
-readCommand fd =
- accumString "" >>= \ cmd ->
- return cmd
- where
- accumString :: String -> IO String
- accumString s =
- myGetChar fd >>= \ c ->
- case c of
- '\\' ->
- myGetChar fd >>= \ c' ->
- accumString (c':c:s)
- '\n' -> return (reverse s)
- ch -> accumString (ch:s)
-
-myGetChar :: Fd -> IO Char
-myGetChar chan =
- do
- (s,len) <- fdRead chan 1
- case len of
- 0 -> myGetChar chan
- 1 -> return (head s)
-
-{-
- To process a command, first parse it into words, then do the necessary
- redirections, and finally perform the desired command. Built-ins are
- checked first, and if none match, we execute an external command.
--}
-
-processCommand :: String -> IO ()
-processCommand "" = return ()
-processCommand s =
- do
- words <- parseCommand s
- (inFile, outFile, words) <- parseRedirection words
- performRedirections inFile outFile
- let
- cmd = head words
- args = tail words
- case builtin cmd of
- Just f ->
- do
- f args
- fdClose stdInput
- fdClose stdOutput
- Nothing -> exec cmd args
-
-{-
- Redirections are a bit of a pain, really. If none are specified, we
- dup our own file descriptors. Otherwise, we try to open the files
- as requested.
--}
-
-performRedirections :: Maybe String -> Maybe String -> IO ()
-performRedirections inFile outFile =
- (case inFile of
- Nothing -> dupTo myStdin stdInput
- Just x ->
- try (openFd x ReadOnly Nothing defaultFileFlags)
- >>=
- either
- (\ err ->
- errMsg ("Can't redirect input from " ++ x) >>
- fail (userError "redirect"))
- (\ succ -> return ())) >>
- (case outFile of
- Nothing ->
- dupTo myStdout stdOutput
- Just x ->
- try (createFile x stdFileMode) >>=
- either
- (\ err ->
- do
- errMsg ("Can't redirect output to " ++ x)
- fdClose stdInput
- fail (userError "redirect"))
- (\ succ -> return ()))
-
-{-
- We parse a command line into words according to the following rules:
- 1) Anything inside pairs of "" or '' is parsed literally.
- 2) Anything (outside of quotes) escaped by \ is taken literally.
- 3) '<' and '>' are words all by themselves, unless escaped or quoted.
- 4) Whitespace separates words
--}
-
-parseCommand :: String -> IO [String]
-parseCommand = getTokens []
- where
- getTokens :: [String] -> String -> IO [String]
- getTokens ts "" = return (reverse ts)
- getTokens ts (c:cs) | isSpace c = getTokens ts cs
- getTokens ts s =
- getToken s >>= \ (t, s') ->
- getTokens (t:ts) s'
-
- getToken :: String -> IO (String, String)
- getToken (c:cs)
- | c == '<' || c == '>' = return ([c], cs)
- | c == '"' || c == '\'' = accumQuote c "" cs
- | otherwise = accumToken [c] cs
-
- accumToken :: [Char] -> String -> IO (String, String)
- accumToken cs "" = return (reverse cs, "")
- accumToken cs ('\\':c:s) = accumToken (c:cs) s
- accumToken cs x@(c:s)
- | isSpace c || c == '<' || c == '>' = return (reverse cs, x)
- | c == '"' || c == '\'' = accumQuote c cs s
- | otherwise = accumToken (c:cs) s
-
- accumQuote :: Char -> [Char] -> String -> IO (String, String)
- accumQuote q cs "" =
- errMsg ("Unmatched " ++ [q]) >>
- fail (userError "unmatched quote")
- accumQuote q cs (c:s)
- | c == q = accumToken cs s
- | otherwise = accumQuote q (c:cs) s
-
-{-
- Here we look for "<" and ">". When we find one, we remove it and the
- following word from the word list. The arguments following the redirection
- symbols and the remaining words are returned to our caller. However, it's
- an error to end a word list with a redirection or for the same redirection
- to appear twice.
--}
-
-parseRedirection :: [String] -> IO (Maybe String, Maybe String, [String])
-parseRedirection = redirect Nothing Nothing []
- where
- redirect inFile outFile args [] =
- return (inFile, outFile, reverse args)
- redirect inFile outFile args [arg]
- | arg == "<" || arg == ">" =
- errMsg "Missing name for redirect" >>
- fail (userError "parse redirect")
- | otherwise =
- return (inFile, outFile, reverse (arg:args))
- redirect inFile outFile args ("<":name:more)
- | inFile == Nothing =
- redirect (Just name) outFile args more
- | otherwise =
- errMsg "Ambiguous input redirect" >>
- fail (userError "parse redirect")
- redirect inFile outFile args (">":name:more)
- | outFile == Nothing =
- redirect inFile (Just name) args more
- | otherwise =
- errMsg "Ambiguous output redirect" >>
- fail (userError "parse redirect")
- redirect inFile outFile args (arg:more) =
- redirect inFile outFile (arg:args) more
-
-{-
- Executing an external command is pretty simple, but what if it fails?
- Fortunately, we don't have any way to redirect stdError just yet,
- so we let it complain and then exit.
--}
-
-exec :: String -> [String] -> IO ()
-exec cmd args =
- forkProcess >>= \ maybe_pid ->
- case maybe_pid of
- Nothing ->
- do
- dupTo myStderr stdError
- fdClose myStdin
- fdClose myStdout
- fdClose myStderr
- executeFile cmd True args Nothing
- `catch`
- (\ err ->
- fdWrite stdError ("command not found: " ++ cmd ++ ".\n") >>
- exitImmediately (ExitFailure 1))
- Just pid ->
- do
- fdClose stdInput
- fdClose stdOutput
--- fdClose stdError
- getProcessStatus True False pid
- return ()
-
-{-
- Builtins:
- cd [arg] -> change directory (default to HOME)
- exit ... -> exit successfully
-
- Builtins must provide their own error messages, since the main command
- loop ignores any errors.
--}
-
-builtin :: String -> Maybe ([String] -> IO ())
-builtin "cd" = Just chdir
-builtin "exit" = Just exit
-builtin _ = Nothing
-
-chdir :: [String] -> IO ()
-chdir [] =
- do
- home <- getEnv "HOME"
- setCurrentDirectory home `catch` \ err -> errMsg "cd: can't go home"
-
-chdir [dir] =
- do
- setCurrentDirectory dir `catch` \ err -> errMsg ("cd: can't chdir to " ++ dir)
-chdir _ = errMsg "cd: too many arguments"
-
-exit :: [String] -> IO ()
-exit _ = exitWith ExitSuccess
-
--- Print an error message to my std error.
-
-errMsg :: String -> IO ()
-errMsg msg =
- fdWrite myStderr ("hsh: " ++ msg ++ ".\n") >>
- return ()
+++ /dev/null
-TOP = ../../..
-include $(TOP)/mk/boilerplate.mk
-SRC_HC_OPTS += -syslib posix
-HS_PROG=hsh
-include $(TOP)/mk/target.mk
-
+++ /dev/null
-main = putStr "Hello, world\n"
+++ /dev/null
-import System (getEnv)
-
-main =
- getEnv "TERM" >>= \ term ->
- putStr term >>
- putChar '\n' >>
- getEnv "One fish, two fish, red fish, blue fish" >>= \ fish ->
- putStr fish >>
- putChar '\n'
-
-
-
+++ /dev/null
-import System (getProgName, getArgs)
-
-main =
- getProgName >>= \ argv0 ->
- putStr argv0 >>
- getArgs >>= \ argv ->
- sequence (map (\ x -> putChar ' ' >> putStr x) argv) >>
- putChar '\n'
-
+++ /dev/null
-import System (exitWith, ExitCode(..))
-
-main = exitWith (ExitFailure 42)
+++ /dev/null
-import System (system, ExitCode(..), exitWith)
-
-main =
- system "cat dog 1>/dev/null 2>&1" >>= \ ec ->
- case ec of
- ExitSuccess -> putStr "What?!?\n" >> fail (userError "dog succeeded")
- ExitFailure _ ->
- system "cat Main.hs 2>/dev/null" >>= \ ec ->
- case ec of
- ExitSuccess -> exitWith ExitSuccess
- ExitFailure _ -> putStr "What?!?\n" >> fail (userError "cat failed")
+++ /dev/null
-import IO -- 1.3
-
-main =
- hClose stderr >>
- hPutStr stderr "junk" `catch` \ err -> if isIllegalOperation err then putStr "Okay\n" else error "Not okay\n"
-
+++ /dev/null
-import IO -- 1.3
-
-main =
- openFile "io007.in" ReadMode >>= \ hIn ->
- hPutStr hIn "test" `catch`
- \ err ->
- if isIllegalOperation err then
- hGetContents hIn >>= \ stuff ->
- hPutStr stdout stuff
- else
- error "Oh dear\n"
+++ /dev/null
-import IO -- 1.3
-import GHCio
-
-import Directory (removeFile)
-
-main =
- openFile "io008.in" ReadMode >>= \ hIn ->
- openFile "io008.out" ReadWriteMode >>= \ hOut ->
- removeFile "io008.out" >>
- hGetPosn hIn >>= \ bof ->
- copy hIn hOut >>
- hSetPosn bof >>
- copy hIn hOut >>
- hSeek hOut AbsoluteSeek 0 >>
- hGetContents hOut >>= \ stuff ->
- putStr stuff
-
-copy :: Handle -> Handle -> IO ()
-copy hIn hOut =
- tryIO (hGetChar hIn) >>=
- either (\ err -> if isEOFError err then return () else error "copy") ( \ x -> hPutChar hOut x >> copy hIn hOut)
+++ /dev/null
-import Directory (getDirectoryContents)
-import QSort (sort)
-
-main =
- getDirectoryContents "." >>= \ names ->
- print (sort names)
+++ /dev/null
-import LibDirectory (getCurrentDirectory, setCurrentDirectory,
- createDirectory, removeDirectory, getDirectoryContents)
-
-main =
- getCurrentDirectory >>= \ oldpwd ->
- createDirectory "foo" >>
- setCurrentDirectory "foo" >>
- getDirectoryContents "." >>= \ [n1, n2] ->
- if dot n1 && dot n2 then
- setCurrentDirectory oldpwd >>
- removeDirectory "foo" >>
- putStr "Okay\n"
- else
- fail "Oops"
-
-
-dot :: String -> Bool
-dot "." = True
-dot ".." = True
-dot _ = False
+++ /dev/null
-import IO -- 1.3
-
-import Directory
-
-main =
- createDirectory "foo" >>
- openFile "foo/bar" WriteMode >>= \ h ->
- hPutStr h "Okay\n" >>
- hClose h >>
- renameFile "foo/bar" "foo/baz" >>
- renameDirectory "foo" "bar" >>
- openFile "bar/baz" ReadMode >>= \ h ->
- hGetContents h >>= \ stuff ->
- putStr stuff >>
- hClose h >>
- removeFile "bar/baz" >>
- removeDirectory "bar"
+++ /dev/null
-import IO -- 1.3
-
-import CPUTime
-
-main =
- openFile "/dev/null" WriteMode >>= \ h ->
- hPrint h (nfib 30) >>
- getCPUTime >>= \ t ->
- print t
-
-nfib :: Integer -> Integer
-nfib n
- | n <= 1 = 1
- | otherwise = (n1 + n2 + 1)
- where
- n1 = nfib (n-1)
- n2 = nfib (n-2)
+++ /dev/null
-import IO -- 1.3
-
-main =
- openFile "io013.in" ReadMode >>= \ h ->
- hFileSize h >>= \ sz ->
- print sz >>
- hSeek h SeekFromEnd (-3) >>
- hGetChar h >>= \ x ->
- putStr (x:"\n") >>
- hSeek h RelativeSeek (-2) >>
- hGetChar h >>= \ w ->
- putStr (w:"\n") >>
- hIsSeekable h >>= \ True ->
- hClose h >>
- openFile "/dev/null" ReadMode >>= \ h ->
- hIsSeekable h >>= \ False ->
- hClose h
+++ /dev/null
-import IO -- 1.3
-
-main =
- accumulate (map hIsOpen [stdin, stdout, stderr]) >>= \ opens ->
- print opens >>
- accumulate (map hIsClosed [stdin, stdout, stderr]) >>= \ closeds ->
- print closeds >>
- accumulate (map hIsReadable [stdin, stdout, stderr]) >>= \ readables ->
- print readables >>
- accumulate (map hIsWritable [stdin, stdout, stderr]) >>= \ writables ->
- print writables >>
- accumulate (map hIsBlockBuffered [stdin, stdout, stderr]) >>= \ buffereds ->
- print buffereds >>
- accumulate (map hIsLineBuffered [stdin, stdout, stderr]) >>= \ buffereds ->
- print buffereds >>
- accumulate (map hIsNotBuffered [stdin, stdout, stderr]) >>= \ buffereds ->
- print buffereds
- where
- -- these didn't make it into 1.3
- hIsBlockBuffered h = hGetBuffering h >>= \ b -> return $ case b of { BlockBuffering _ -> True; _ -> False }
- hIsLineBuffered h = hGetBuffering h >>= \ b -> return $ case b of { LineBuffering -> True; _ -> False }
- hIsNotBuffered h = hGetBuffering h >>= \ b -> return $ case b of { NoBuffering -> True; _ -> False }
+++ /dev/null
-import IO -- 1.3
-
-main =
- isEOF >>= \ eof ->
- if eof then
- return ()
- else
- getChar >>= \ c ->
- putChar c >>
- main
+++ /dev/null
-import IO -- 1.3
-
-import System (getArgs)
-import Char (toUpper)
-
-main = getArgs >>= \ [f1,f2] ->
- openFile f1 ReadMode >>= \ h1 ->
- openFile f2 WriteMode >>= \ h2 ->
- copyFile h1 h2 >>
- hClose h1 >>
- hClose h2
-
-copyFile h1 h2 =
- hIsEOF h1 >>= \ eof ->
- if eof then
- return ()
- else
- hGetChar h1 >>= \ c ->
- hPutChar h2 (toUpper c) >>
- copyFile h1 h2
-
+++ /dev/null
-import IO -- 1.3
-
-main =
- hSetBuffering stdout NoBuffering >>
- putStr "Enter an integer: " >>
- readLine >>= \ x1 ->
- putStr "Enter another integer: " >>
- readLine >>= \ x2 ->
- putStr ("Their sum is " ++ show (read x1+ read x2) ++ "\n")
-
- where readLine = isEOF >>= \ eof ->
- if eof then return []
- else getChar >>= \ c ->
- if c `elem` ['\n','\r'] then
- return []
- else
- readLine >>= \ cs ->
- return (c:cs)
-
+++ /dev/null
-import IO -- 1.3
-
-import System(getArgs)
-
-main = getArgs >>= \ [user,host] ->
- let username = (user ++ "@" ++ host) in
- openFile username ReadWriteMode >>= \ cd ->
- hSetBuffering stdin NoBuffering >>
- hSetBuffering stdout NoBuffering >>
- hSetBuffering cd NoBuffering >>
- hPutStr cd speakString >>
- speak cd
-
-speakString = "Someone wants to speak with you\n"
-
-speak cd =
- (hReady cd >>= \ ready ->
- if ready then (hGetChar cd >>= putChar)
- else return () >>
-
- hReady stdin >>= \ ready ->
- if ready then (getChar >>= hPutChar cd)
- else return ()) >>
-
- speak cd
+++ /dev/null
-import Time
-
-main =
- getClockTime >>= \ time ->
- print time >>
-
- let (CalendarTime year month mday hour min sec psec
- wday yday timezone gmtoff isdst) = toUTCTime time
- in
- putStr (wdays !! wday) >>
- putStr (' ' : months !! month) >>
- putStr (' ' : shows2 mday (' ' : shows2 hour (':' : shows2 min (':' : shows2 sec
- (' ' : timezone ++ ' ' : shows year "\n")))))
-
- where
- wdays = ["Sun", "Mon", "Tue", "Wed", "Thu", "Fri", "Sat"]
- months = ["Jan", "Feb", "Mar", "Apr", "May", "Jun",
- "Jul", "Aug", "Sep", "Oct", "Nov", "Dec"]
- shows2 x = showString (pad2 x)
- pad2 x = case show x of
- c@[_] -> '0' : c
- cs -> cs
+++ /dev/null
-import Time
-
-main =
- getClockTime >>= \ time ->
- let (CalendarTime year month mday hour min sec psec
- wday yday timezone gmtoff isdst) = toUTCTime time
- time' = toClockTime (CalendarTime (year - 1) month mday hour min sec psec
- wday yday timezone gmtoff isdst)
- in
- print time >>
- putChar '\n' >>
- print time' >>
- putChar '\n'
+++ /dev/null
-import IO -- 1.3
-
-main =
- hSetBuffering stdin NoBuffering >>
- hSetBuffering stdout NoBuffering >>
- interact id
+++ /dev/null
-{- server
-
-The purpose of this test driver is to test TCP Stream sockets.
-All values have been hard coded since the BSD library is not used to
-query the databases for the values. In therory this code is thus not
-portable but net007/Main.hs provides a portable version using the BSD
-module.
-
-This creates a stream socket bound to port 5000 and waits for incoming
-messages it then reads all available data before closing the
-connection to that peer.
-
-No form of error checking is provided other than that already provided
-by module SocketPrim.
-
-
-TESTS:
- socket
- bindSocket
- listen
- accept
- readSocket
- sClose
-
--}
-
-
-module Main where
-
-import SocketPrim
-
-
-main =
- socket AF_INET Stream 6 >>= \ s ->
- bindSocket s (SockAddrInet 5000 iNADDR_ANY) >>
- listen s 5 >>
-
- let
- loop =
- accept s >>= \ (s',peerAddr) ->
- putStr "*** Start of Transfer ***\n" >>
- let
- read_all =
- readSocket s' 4 >>= \ (str, nbytes) ->
- if nbytes /= 0 then
- putStr str >>
- read_all
- else
- putStr "\n*** End of Transfer ***\n" >>
- sClose s'
- in
- read_all
- in
- loop
-
+++ /dev/null
-{- client
-
-Client side to net001/Main.hs.
-
-Note that the machine IP numbers have been hard coded into this
-program so it is unlikely that you will be able to run this test if
-you are not at dcs.gla.ac.uk :-(
-
-The reason for this is to aviod using the BSD module at this stage of
-testing.
-
-
-TESTS:
- socket
- connect
- writeSocket
- shutdown
- inet_addr
--}
-
-
-module Main where
-
-import SocketPrim
-
-
-starbuck = "130.209.240.81" -- SunOS 4.1.3 1 sun4c
-marcus = "130.209.247.2" -- SunOS 4.1.3 6 sun4m
-avon = "130.209.247.4" -- OSF1 V2.0 240 alpha
-karkar = "130.209.247.3" -- OSF1 V2.0 240 alpha
-
-message = "Hello World"
-
-
-main =
- socket AF_INET Stream 6 >>= \ s ->
- connect s (SockAddrInet 5000 (inet_addr avon)) >>
-
- writeSocket s message >>
- shutdown s 2 >>
- sClose s
-
+++ /dev/null
-{- server
-
-As for net001 but gets the system to allocate the next free port
-number. It also prints out the IP number of the peer.
-
-TESTS:
- getSocketName
- inet_ntoa
-
--}
-
-module Main where
-
-import SocketPrim
-
-
-main =
- socket AF_INET Stream 6 >>= \ s ->
- bindSocket s (SockAddrInet aNY_PORT iNADDR_ANY) >>
- getSocketName s >>= \ (SockAddrInet port _) ->
- putStr ("Allocated Port Number: " ++ show port ++ "\n") >>
- listen s 5 >>
-
-
- let
- loop =
- accept s >>= \ (s',(SockAddrInet _ haddr)) ->
- putStr ("*** Start of Transfer from: " ++
- (inet_ntoa haddr) ++ "***\n") >>
- let
- read_all =
- readSocket s' 4 >>= \ (str, nbytes) ->
- if nbytes /= 0 then
- putStr str >>
- read_all
- else
- putStr "\n*** End of Transfer ***\n" >>
- sClose s'
- in
- read_all
- in
- loop
-
+++ /dev/null
-{- client
-
-As for net002 but reads port number and message as arguments.
-It also prints out the IP number of the peer machine.
-
-
-
-TESTS:
- getPeerName
--}
-
-
-module Main where
-
-import SocketPrim
-import LibSystem
-
-
-starbuck = "130.209.240.81"
-marcus = "130.209.247.2"
-
-
-main =
- getArgs >>= \ [port, message] ->
- socket AF_INET Stream 6 >>= \ s ->
- connect s (SockAddrInet (read port) (inet_addr starbuck)) >>
-
- getPeerName s >>= \ (SockAddrInet p haddr) ->
- putStr ("Connected to : " ++ (inet_ntoa haddr) ++ "\n") >>
- writeSocket s message >>
- shutdown s 2 >>
- sClose s
-
+++ /dev/null
-{- server
-
-Server as net001 but for Unix Domain Datagram sockets.
-
-TESTS:
- socket
- bindSocket
- readSocket
-
--}
-
-
-module Main where
-
-import SocketPrim
-
-
-main =
- socket AF_UNIX Datagram 0 >>= \ s ->
- bindSocket s (SockAddrUnix "sock") >>
-
- let
- loop =
- putStr "*** Start of Transfer ***\n" >>
- let
- read_all =
- readSocket s 1024 >>= \ (str, nbytes) ->
- if nbytes /= 0 then
- putStr str >>
- read_all
- else
- putStr "\n*** End of Transfer ***\n"
- in
- read_all
- in
- loop
-
+++ /dev/null
-{- client
-
-Client side of net005
-
-TESTS:
- socket
- connect
- writeSocket
- shutdown
- sClose
--}
-
-
-module Main where
-
-import SocketPrim
-
-message = "Hello World"
-
-
-main =
- socket AF_UNIX Datagram 0 >>= \ s ->
- connect s (SockAddrUnix "sock") >>
-
- writeSocket s message >>
- shutdown s 2 >>
- sClose s
+++ /dev/null
-{- server
-
-As net003 but uses the BSD module for portability. Also prints the
-common name of the host rather than its IP number.
-
-TESTS:
- getProtocolNumber
- getSocketName
- getHostByAddr
-
--}
-
-module Main where
-
-import BSD
-import SocketPrim
-
-main =
- getProtocolNumber "tcp" >>= \ proto ->
- socket AF_INET Stream proto >>= \ s ->
- bindSocket s (SockAddrInet aNY_PORT iNADDR_ANY) >>
- getSocketName s >>= \ (SockAddrInet port _) ->
- putStr ("Allocated Port Number: " ++ show port ++ "\n") >>
- listen s 5 >>
-
-
- let
- loop =
- accept s >>= \ (s',(SockAddrInet _ haddr)) ->
- getHostByAddr AF_INET haddr >>= \ (HostEntry hname _ _ _) ->
- putStr ("*** Start of Transfer from: " ++ hname ++ "***\n") >>
- let
- read_all =
- readSocket s' 4 >>= \ (str, nbytes) ->
- if nbytes /= 0 then
- putStr str >>
- read_all
- else
- putStr "\n*** End of Transfer ***\n" >>
- sClose s'
- in
- read_all
- in
- loop
+++ /dev/null
-module Main where
-
-import SocketPrim
-import BSD
-import LibSystem
-
-
-main =
- getArgs >>= \ [host, port, message] ->
- getProtocolNumber "tcp" >>= \ proto ->
- socket AF_INET Stream proto >>= \ s ->
- getHostByName host >>= \ (HostEntry _ _ _ haddrs) ->
- connect s (SockAddrInet (read port)
- (head haddrs)) >>
-
- getPeerName s >>= \ (SockAddrInet _ haddr) ->
- getHostByAddr AF_INET haddr >>= \ (HostEntry hname _ _ _) ->
- putStr ("Connected to : " ++ hname ++ "\n") >>
- writeSocket s message >>
- shutdown s 2 >>
- sClose s
-
+++ /dev/null
-#include <stdio.h>
-
-main ()
-{
- int n;
-
- scanf("%d",&n);
- n = nfib(n);
- printf("nfibs=%d\n",n);
- exit(0);
-}
-
-nfib (n)
-{
- return(n <= 1 ? 1 : nfib(n-1) + nfib(n-2) + 1);
-}
+++ /dev/null
-# WARNING!
-# Note: be careful about running this with an argument > (say) 18 !
-# running this script on '27' will chew up ~80 MB of virtual
-# ram. and its apetite grows per 1.61803 ** $n.
-#
-# Your system admin folk would probably be displeased if you trash
-# other people's work, or disable systems running this script!
-#
-# Usage: perl nfib.prl <number>
-#
-$n = @ARGV[0];
-$f=&fib($n);
-print " $n! = $f\n";
-sub fib {
- local ($n)=$_[0];
- if ($n==0) {return (0);}
- elsif($n==1) {return(1);}
- return (&fib ($n-1) + &fib($n-2));
-}
+++ /dev/null
-module Main where
-
-main = print (nfib 28)
-
-nfib :: Double -> Double
-
-nfib n | n <= 1 = 1
- | otherwise = (n1 + n2 + 1)
- where n1 = nfib (n-1)
- n2 = nfib (n-2)
+++ /dev/null
-module Main where
-
-main = print (nfib 28)
-
-nfib :: Float -> Float
-
-nfib n | n <= 1 = 1
- | otherwise = (n1 + n2 + 1)
- where n1 = nfib (n-1)
- n2 = nfib (n-2)
+++ /dev/null
-module Main where
-
-main = print (nfib 30)
-
-nfib :: Int -> Int
-
-nfib n | n <= 1 = 1
- | otherwise = (n1 + n2 + 1)
- where n1 = nfib (n-1)
- n2 = nfib (n-2)
+++ /dev/null
-module Main where
-
-main = print (nfib 28)
-
-nfib :: Integer -> Integer
-
-nfib n | n <= 1 = 1
- | otherwise = (n1 + n2 + 1)
- where n1 = nfib (n-1)
- n2 = nfib (n-2)
+++ /dev/null
-module Main where
-
-main = print (nfib 28)
-
-nfib :: (Num a, Ord a) => a -> a
-
-nfib n | n <= 1 = 1
- | otherwise = (n1 + n2 + 1)
- where n1 = nfib (n-1)
- n2 = nfib (n-2)
+++ /dev/null
-module Main where
-
-main = print (nfib 20)
-
-nfib :: Rational -> Rational
-
-nfib n | n <= 1 = 1
- | otherwise = (n1 + n2 + 1)
- where n1 = nfib (n-1)
- n2 = nfib (n-2)
+++ /dev/null
-import Posix
-
-main =
- getParentProcessID >>= \ ppid ->
- getProcessID >>= \ pid ->
- putStr "Parent Process ID: " >>
- print ppid >>
- putStr "\nProcess ID: " >>
- print pid >>
- putStr "\nforking ps uxww" >>
- print ppid >>
- putChar '\n' >>
- forkProcess >>= \ child ->
- case child of
- Nothing -> executeFile "ps" True ["uxww" ++ show ppid] Nothing
- Just x -> doParent x pid
-
-doParent cpid pid =
- getProcessStatus True False cpid >>
- putStr "\nChild finished. Now exec'ing ps uxww" >>
- print pid >>
- putChar '\n' >>
- executeFile "ps" True ["uxww" ++ show pid] Nothing
+++ /dev/null
-import Posix
-
-main =
- executeFile "printenv" True [] (Just [("ONE","1"),("TWO","2")])
+++ /dev/null
-import Posix
-
-main =
- openFile "po003.out" WriteMode >>= \ h ->
- runProcess "pwd" [] Nothing (Just "/usr/tmp") Nothing (Just h) Nothing
+++ /dev/null
-import Posix
-import System(ExitCode(..), exitWith)
-
-main =
- forkProcess >>= \ maybe_pid ->
- case maybe_pid of
- Nothing -> raiseSignal floatingPointException
- _ -> doParent
-
-doParent =
- getAnyProcessStatus True False >>= \ (Just (pid, tc)) ->
- case tc of
- Terminated sig | sig == floatingPointException -> forkChild2
- _ -> fail (userError "unexpected termination cause")
-
-forkChild2 =
- forkProcess >>= \ maybe_pid ->
- case maybe_pid of
- Nothing -> exitImmediately (ExitFailure 42)
- _ -> doParent2
-
-doParent2 =
- getAnyProcessStatus True False >>= \ (Just (pid, tc)) ->
- case tc of
- Exited (ExitFailure 42) -> forkChild3
- _ -> fail (userError "unexpected termination cause (2)")
-
-forkChild3 =
- forkProcess >>= \ maybe_pid ->
- case maybe_pid of
- Nothing -> exitImmediately (ExitSuccess)
- _ -> doParent3
-
-doParent3 =
- getAnyProcessStatus True False >>= \ (Just (pid, tc)) ->
- case tc of
- Exited ExitSuccess -> forkChild4
- _ -> fail (userError "unexpected termination cause (3)")
-
-forkChild4 =
- forkProcess >>= \ maybe_pid ->
- case maybe_pid of
- Nothing -> raiseSignal softwareStop
- _ -> doParent4
-
-doParent4 =
- getAnyProcessStatus True True >>= \ (Just (pid, tc)) ->
- case tc of
- Stopped sig | sig == softwareStop -> enoughAlready pid
- _ -> fail (userError "unexpected termination cause (4)")
-
-enoughAlready pid =
- signalProcess killProcess pid >>
- getAnyProcessStatus True True >>= \ (Just (pid, tc)) ->
- case tc of
- Terminated sig | sig == killProcess -> putStr "I'm happy.\n"
- _ -> fail (userError "unexpected termination cause (5)")
-
+++ /dev/null
-import Posix
-
-main =
- getEnvVar "TERM" >>= \ term ->
- putStr term >>
- putChar '\n' >>
- setEnvironment [("one","1"),("two","2")] >>
- getEnvironment >>= \ env ->
- print env >>
- putChar '\n' >>
- setEnvVar "foo" "bar" >>
- getEnvironment >>= \ env ->
- print env >>
- putChar '\n' >>
- setEnvVar "foo" "baz" >>
- getEnvironment >>= \ env ->
- print env >>
- putChar '\n' >>
- setEnvVar "fu" "bar" >>
- getEnvironment >>= \ env ->
- print env >>
- putChar '\n' >>
- removeEnvVar "foo" >>
- getEnvironment >>= \ env ->
- print env >>
- putChar '\n' >>
- setEnvironment [] >>
- getEnvironment >>= \ env ->
- print env >>
- putChar '\n'
+++ /dev/null
-import Posix
-
-main =
- epochTime >>= \ start ->
- sleep 5 >>
- let timeleft = 0 in
- epochTime >>= \ finish ->
- putStr "Started: " >>
- print start >>
- putStr "\nSlept: " >>
- print (5 - timeleft) >>
- putStr "\nFinished: " >>
- print finish >>
- putChar '\n'
+++ /dev/null
-import Posix
-
-main =
- installHandler keyboardSignal (Catch doCtrlC) Nothing >>
- getTerminalAttributes stdInput >>= \ ta ->
- case (controlChar ta Interrupt) of
- Nothing -> fixMe ta
- Just x -> continue x
-
-fixMe ta =
- putStr "Oops...no interrupt character?\nI can fix that...\n" >>
- setTerminalAttributes stdInput (withCC ta (Interrupt, '\ETX')) Immediately >>
- getTerminalAttributes stdInput >>= \ ta ->
- case (controlChar ta Interrupt) of
- Nothing -> putStr "...Then again, maybe I can't\n"
- Just x -> continue x
-
-continue x =
- putStr "Press '" >>
- putStr (ccStr x) >>
- putStr "'.\n" >>
- awaitSignal Nothing >>
- putStr "How did I get here?\n"
-
-doCtrlC =
- putStr "Caught an interrupt.\n"
-
-ccStr '\DEL' = "^?"
-ccStr x
- | x >= ' ' = [x]
- | otherwise = ['^', (toEnum (fromEnum x + fromEnum '@'))]
+++ /dev/null
-import Posix
-
-main =
- installHandler realTimeAlarm (Catch alarmclock) Nothing >>
- putStr "Scheduling an alarm in 5 seconds...\n" >>
- scheduleAlarm 5 >>
- putStr "Sleeping one minute.\n" >>
- sleep 60 >>
- putStr "How did I get here?\n"
-
-alarmclock =
- putStr "The alarm went off.\n"
+++ /dev/null
-import Posix
-
-main =
- putStr "Blocking real time alarms.\n" >>
- blockSignals (addSignal realTimeAlarm emptySignalSet) >>
- putStr "Scheduling an alarm in 2 seconds...\n" >>
- scheduleAlarm 2 >>
- putStr "Sleeping 5 seconds.\n" >>
- sleep 5 >>
- getPendingSignals >>= \ ints ->
- putStr "Checking pending interrupts for RealTimeAlarm\n" >>
- print (inSignalSet realTimeAlarm ints) >>
- putChar '\n'
-
+++ /dev/null
-import Posix
-
-main =
- getUserEntryForName "mattson" >>= \ mattson ->
- getUserEntryForName "partain" >>= \ partain ->
- putStr (ue2String mattson) >>
- putChar '\n' >>
- putStr (ue2String partain) >>
- putChar '\n' >>
- getUserEntryForID (userID mattson) >>= \ muid ->
- getUserEntryForID (userID partain) >>= \ puid ->
- putStr (ue2String muid) >>
- putChar '\n' >>
- putStr (ue2String puid) >>
- putChar '\n'
-
-ue2String ue =
- name ++ (':' : (show uid) ++ (':' : (show gid) ++ (':' : home ++ (':' : shell))))
- where
- name = userName ue
- uid = userID ue
- gid = userGroupID ue
- home = homeDirectory ue
- shell = userShell ue
+++ /dev/null
-import Posix
-
-main =
- getGroupEntryForName "grasp" >>= \ grasp ->
- getGroupEntryForName "staff" >>= \ staff ->
- putStr (ge2String grasp) >>
- putChar '\n' >>
- putStr (ge2String staff) >>
- putChar '\n' >>
- getGroupEntryForID (groupID grasp) >>= \ guid ->
- getGroupEntryForID (groupID staff) >>= \ suid ->
- putStr (ge2String guid) >>
- putChar '\n' >>
- putStr (ge2String suid) >>
- putChar '\n'
-
-ge2String ge =
- name ++ (':' : (show gid) ++ (':' : members))
- where
- name = groupName ge
- gid = groupID ge
- members = foldr (\x y -> x ++ (',' : y)) "" (groupMembers ge)
+++ /dev/null
-import Posix
-import IO -- 1.3
-
-main =
- createFile "po012.out" stdFileMode >>= \ fd ->
- installHandler processStatusChanged (Catch (reap1 fd)) Nothing >>
- ls >>
- awaitSignal Nothing
-
-ls =
- runProcess "ls" ["-l","po012.out"] Nothing Nothing Nothing Nothing Nothing
-
-reap1 fd =
- getAnyProcessStatus True False >>
- installHandler processStatusChanged (Catch (reap2 fd)) Nothing >>
- writeChannel fd (take 666 (repeat 'x')) >>
- ls >>
- awaitSignal Nothing
-
-reap2 fd =
- getAnyProcessStatus True False >>
- installHandler processStatusChanged (Catch (reap3 fd)) Nothing >>
- setFileMode "po012.out"
- (foldr1 unionFileModes [ownerReadMode,ownerWriteMode,groupReadMode,otherReadMode]) >>
- ls >>
- awaitSignal Nothing
-
-reap3 fd =
- getAnyProcessStatus True False >>
- installHandler processStatusChanged (Catch (reap4 fd)) Nothing >>
- setFileTimes "po012.out" 0 0 >>
- ls >>
- awaitSignal Nothing
-
-reap4 fd =
- getAnyProcessStatus True False >>
- installHandler processStatusChanged (Catch (reap5 fd)) Nothing >>
- removeLink "po012.out" >>
- ls >>
- awaitSignal Nothing
-
-reap5 fd =
- getAnyProcessStatus True False >>
- seekChannel fd SeekFromEnd 0 >>= \ bytes ->
- if bytes == 666 then
- seekChannel fd AbsoluteSeek 0 >>
- readChannel fd 1024 >>= \ (str, _) ->
- if str == (take 666 (repeat 'x')) then
- putStr "Okay\n"
- else
- putStr "Read failed\n"
- else
- putStr "Seek returned wrong size\n"
+++ /dev/null
-/*
- Compile this with GCC on a new platform, to learn various
- things about argument-passing, return-returning, stack
- layout, etc. WDP 95/05
-*/
-
-extern long int foo (long int, double, void *, char *, double, long int, char, long int);
-extern double bar (char, float, long int, long int, char *, char **);
-
-long int
-foo (long int a, double b, void *c, char *d, double e, long int f, char g, long int h)
-{
- __asm__ volatile ("--- BEGIN ---");
- bar(*d, (float) b, a, f, d, (char **) d);
- __asm__ volatile ("--- END ---");
-}
-
-double
-bar (char a, float b, long int c, long int d, char *e, char **f)
-{
- __asm__ volatile ("--- BEGIN ---");
- foo(c, (double) b, (void *) 0, e, 0.0, d, a, d);
- __asm__ volatile ("--- END ---");
-}
-
-double
-baz(w)
- int w;
-{
- int x[1000];
- int y;
-
- for(y = 0; y < 1000; y++)
- w += x[y];
-
- return ((double) w);
-}
+++ /dev/null
-#-----------------------------------------------------------------------------
-# $Id: Makefile,v 1.1 2002/01/31 13:46:38 simonmar Exp $
-
-TOP = ../..
-include $(TOP)/mk/boilerplate.mk
-
-include $(TOP)/mk/ghci.mk
+++ /dev/null
-{-# OPTIONS -fglasgow-exts -cpp #-}
--- parser produced by Happy Version 1.11
-
-module Parser where
-
-import Char
-import GlaExts
-import Array
-import IO
-import IOExts
-
-data HappyAbsSyn
- = HappyTerminal Token
- | HappyErrorToken Int
- | HappyAbsSyn4 (Int)
-
-happyActOffsets :: Addr
-happyActOffsets = A# "\x0a\x00\x0a\x00\x00\x00\xff\xff\x0a\x00\x0a\x00\x08\x00\x07\x00\x00\x00"#
-
-happyGotoOffsets :: Addr
-happyGotoOffsets = A# "\x06\x00\x00\x00\x00\x00\x00\x00\x05\x00\x04\x00\x00\x00\x00\x00\x00\x00"#
-
-happyDefActions :: Addr
-happyDefActions = A# "\x00\x00\x00\x00\xfe\xff\x00\x00\x00\x00\x00\x00\xfc\xff\xfd\xff"#
-
-happyCheck :: Addr
-happyCheck = A# "\xff\xff\x02\x00\x03\x00\x04\x00\x00\x00\x00\x00\x00\x00\xff\xff\xff\xff\x02\x00\x02\x00\x01\x00\xff\xff\xff\xff\xff\xff"#
-
-happyTable :: Addr
-happyTable = A# "\x00\x00\x05\x00\x06\x00\xff\xff\x06\x00\x07\x00\x03\x00\x00\x00\x00\x00\x00\x00\x05\x00\x03\x00\x00\x00\x00\x00\x00\x00"#
-
-happyReduceArr = array (1, 3) [
- (1 , happyReduce_1),
- (2 , happyReduce_2),
- (3 , happyReduce_3)
- ]
-
-happy_n_terms = 5 :: Int
-happy_n_nonterms = 1 :: Int
-
-happyReduce_1 = happySpecReduce_1 0# happyReduction_1
-happyReduction_1 _
- = HappyAbsSyn4
- (1
- )
-
-happyReduce_2 = happySpecReduce_3 0# happyReduction_2
-happyReduction_2 _
- _
- _
- = HappyAbsSyn4
- (2
- )
-
-happyReduce_3 = happySpecReduce_3 0# happyReduction_3
-happyReduction_3 _
- _
- _
- = HappyAbsSyn4
- (3
- )
-
-happyNewToken action sts stk [] =
- happyDoAction 4# (error "reading EOF!") action sts stk []
-
-happyNewToken action sts stk (tk:tks) =
- let cont i = happyDoAction i tk action sts stk tks in
- case tk of {
- Tid -> cont 1#;
- Tgreater -> cont 2#;
- Tand -> cont 3#;
- }
-
-happyThen = \m k -> k m
-happyReturn = \a -> a
-happyThen1 = happyThen
-happyReturn1 = \a tks -> a
-
-parser tks = happyThen (happyParse 0# tks) (\x -> case x of {HappyAbsSyn4 z -> happyReturn z; _other -> notHappyAtAll })
-
-data Token = Tid | Tgreater | Tand
- deriving Show
-
-happyError = error "parse error"
-
-lexer :: String -> [Token]
-lexer = l
- where l "" = []
- l ('\n':cs) = l cs
- l ('a':'n':'d':cs) = Tand : l cs
- l (c:cs)
- | isSpace c = l cs
- | isAlpha c = let (_,rs) = span isAlpha (c:cs)
- in Tid : l rs
- l ('>':cs) = Tgreater : l cs
-{-# LINE 1 "GenericTemplate.hs" #-}
-{-# LINE 1 "GenericTemplate.hs" #-}
--- $Id: Parser.hs,v 1.1 2002/01/31 13:46:38 simonmar Exp $
-
-
-
-
-
-
-
-
-
-
-
-
-
-{-# LINE 27 "GenericTemplate.hs" #-}
-
-
-
-data Happy_IntList = HappyCons Int# Happy_IntList
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-happyTrace string expr = unsafePerformIO $ do
- hPutStr stderr string
- return expr
-
-
-
-
-infixr 9 `HappyStk`
-data HappyStk a = HappyStk a (HappyStk a)
-
------------------------------------------------------------------------------
--- starting the parse
-
-happyParse start_state = happyNewToken start_state notHappyAtAll notHappyAtAll
-
------------------------------------------------------------------------------
--- Accepting the parse
-
-happyAccept j tk st sts (HappyStk ans _) = (happyTcHack j
- (happyTcHack st))
- (happyReturn1 ans)
-
------------------------------------------------------------------------------
--- Arrays only: do the next action
-
-
-
-happyDoAction i tk st
- = (happyTrace ("state: " ++ show (I# (st)) ++
- ",\ttoken: " ++ show (I# (i)) ++
- ",\taction: ")) $
- case action of
- 0# -> (happyTrace ("fail.\n")) $
- happyFail i tk st
- -1# -> (happyTrace ("accept.\n")) $
- happyAccept i tk st
- n | (n <# (0# :: Int#)) -> (happyTrace ("reduce (rule " ++ show rule
- ++ ")")) $
- (happyReduceArr ! rule) i tk st
- where rule = (I# ((negateInt# ((n +# (1# :: Int#))))))
- n -> (happyTrace ("shift, enter state "
- ++ show (I# (new_state))
- ++ "\n")) $
- happyShift new_state i tk st
- where new_state = (n -# (1# :: Int#))
- where off = indexShortOffAddr happyActOffsets st
- off_i = (off +# i)
- check = if (off_i >=# (0# :: Int#))
- then (indexShortOffAddr happyCheck off_i ==# i)
- else False
- action | check = indexShortOffAddr happyTable off_i
- | otherwise = indexShortOffAddr happyDefActions st
-
-
-
-
-
-
-
-indexShortOffAddr (A# arr) off =
-#if __GLASGOW_HASKELL__ > 500
- narrow16Int# i
-#elif __GLASGOW_HASKELL__ == 500
- intToInt16# i
-#else
- (i `iShiftL#` 16#) `iShiftRA#` 16#
-#endif
- where
- i = word2Int# ((high `shiftL#` 8#) `or#` low)
- high = int2Word# (ord# (indexCharOffAddr# arr (off' +# 1#)))
- low = int2Word# (ord# (indexCharOffAddr# arr off'))
- off' = off *# 2#
-
-
-
-
-
-
------------------------------------------------------------------------------
--- HappyState data type (not arrays)
-
-{-# LINE 153 "GenericTemplate.hs" #-}
-
-
------------------------------------------------------------------------------
--- Shifting a token
-
-happyShift new_state 0# tk st sts stk@(x `HappyStk` _) =
- let i = (case x of { HappyErrorToken (I# (i)) -> i }) in
--- trace "shifting the error token" $
- happyDoAction i tk new_state (HappyCons (st) (sts)) (stk)
-
-happyShift new_state i tk st sts stk =
- happyNewToken new_state (HappyCons (st) (sts)) ((HappyTerminal (tk))`HappyStk`stk)
-
--- happyReduce is specialised for the common cases.
-
-happySpecReduce_0 i fn 0# tk st sts stk
- = happyFail 0# tk st sts stk
-happySpecReduce_0 nt fn j tk st@((action)) sts stk
- = happyGoto nt j tk st (HappyCons (st) (sts)) (fn `HappyStk` stk)
-
-happySpecReduce_1 i fn 0# tk st sts stk
- = happyFail 0# tk st sts stk
-happySpecReduce_1 nt fn j tk _ sts@((HappyCons (st@(action)) (_))) (v1`HappyStk`stk')
- = happyGoto nt j tk st sts (fn v1 `HappyStk` stk')
-
-happySpecReduce_2 i fn 0# tk st sts stk
- = happyFail 0# tk st sts stk
-happySpecReduce_2 nt fn j tk _ (HappyCons (_) (sts@((HappyCons (st@(action)) (_))))) (v1`HappyStk`v2`HappyStk`stk')
- = happyGoto nt j tk st sts (fn v1 v2 `HappyStk` stk')
-
-happySpecReduce_3 i fn 0# tk st sts stk
- = happyFail 0# tk st sts stk
-happySpecReduce_3 nt fn j tk _ (HappyCons (_) ((HappyCons (_) (sts@((HappyCons (st@(action)) (_))))))) (v1`HappyStk`v2`HappyStk`v3`HappyStk`stk')
- = happyGoto nt j tk st sts (fn v1 v2 v3 `HappyStk` stk')
-
-happyReduce k i fn 0# tk st sts stk
- = happyFail 0# tk st sts stk
-happyReduce k nt fn j tk st sts stk = happyGoto nt j tk st1 sts1 (fn stk)
- where sts1@((HappyCons (st1@(action)) (_))) = happyDrop k (HappyCons (st) (sts))
-
-happyMonadReduce k nt fn 0# tk st sts stk
- = happyFail 0# tk st sts stk
-happyMonadReduce k nt fn j tk st sts stk =
- happyThen1 (fn stk) (\r -> happyGoto nt j tk st1 sts1 (r `HappyStk` drop_stk))
- where sts1@((HappyCons (st1@(action)) (_))) = happyDrop k (HappyCons (st) (sts))
- drop_stk = happyDropStk k stk
-
-happyDrop 0# l = l
-happyDrop n (HappyCons (_) (t)) = happyDrop (n -# (1# :: Int#)) t
-
-happyDropStk 0# l = l
-happyDropStk n (x `HappyStk` xs) = happyDropStk (n -# (1#::Int#)) xs
-
------------------------------------------------------------------------------
--- Moving to a new state after a reduction
-
-
-happyGoto nt j tk st =
- (happyTrace (", goto state " ++ show (I# (new_state)) ++ "\n")) $
- happyDoAction j tk new_state
- where off = indexShortOffAddr happyGotoOffsets st
- off_i = (off +# nt)
- new_state = indexShortOffAddr happyTable off_i
-
-
-
-
------------------------------------------------------------------------------
--- Error recovery (0# is the error token)
-
--- parse error if we are in recovery and we fail again
-happyFail 0# tk old_st _ stk =
--- trace "failing" $
- happyError
-
-
-{- We don't need state discarding for our restricted implementation of
- "error". In fact, it can cause some bogus parses, so I've disabled it
- for now --SDM
-
--- discard a state
-happyFail 0# tk old_st (HappyCons ((action)) (sts))
- (saved_tok `HappyStk` _ `HappyStk` stk) =
--- trace ("discarding state, depth " ++ show (length stk)) $
- happyDoAction 0# tk action sts ((saved_tok`HappyStk`stk))
--}
-
--- Enter error recovery: generate an error token,
--- save the old token and carry on.
-happyFail i tk (action) sts stk =
--- trace "entering error recovery" $
- happyDoAction 0# tk action sts ( (HappyErrorToken (I# (i))) `HappyStk` stk)
-
--- Internal happy errors:
-
-notHappyAtAll = error "Internal Happy error\n"
-
------------------------------------------------------------------------------
--- Hack to get the typechecker to accept our action functions
-
-
-happyTcHack :: Int# -> a -> a
-happyTcHack x y = y
-{-# INLINE happyTcHack #-}
-
-
------------------------------------------------------------------------------
--- Don't inline any functions from the template. GHC has a nasty habit
--- of deciding to inline happyGoto everywhere, which increases the size of
--- the generated parser quite a bit.
-
-
-{-# NOINLINE happyDoAction #-}
-{-# NOINLINE happyTable #-}
-{-# NOINLINE happyCheck #-}
-{-# NOINLINE happyActOffsets #-}
-{-# NOINLINE happyGotoOffsets #-}
-{-# NOINLINE happyDefActions #-}
-
-{-# NOINLINE happyShift #-}
-{-# NOINLINE happySpecReduce_0 #-}
-{-# NOINLINE happySpecReduce_1 #-}
-{-# NOINLINE happySpecReduce_2 #-}
-{-# NOINLINE happySpecReduce_3 #-}
-{-# NOINLINE happyReduce #-}
-{-# NOINLINE happyMonadReduce #-}
-{-# NOINLINE happyGoto #-}
-{-# NOINLINE happyFail #-}
-
--- end of Happy Template.
+++ /dev/null
-:unset +s
-:unset +t
-:set -package lang -fglasgow-exts
-:l Parser
-parser (lexer "a>b")
+++ /dev/null
-Compiling Parser ( Parser.hs, interpreted )
-state: 0, token: 1, action: shift, enter state 2
-state: 2, token: 2, action: reduce (rule 1), goto state 3
-state: 3, token: 2, action: shift, enter state 4
-state: 4, token: 1, action: shift, enter state 2
-state: 2, token: 4, action: reduce (rule 1), goto state 7
-state: 7, token: 4, action: reduce (rule 2), goto state 3
-state: 3, token: 4, action: accept.
+++ /dev/null
- ___ ___ _
- / _ \ /\ /\/ __(_)
- / /_\// /_/ / / | | GHC Interactive, version 5.03, for Haskell 98.
-/ /_\\/ __ / /___| | http://www.haskell.org/ghc/
-\____/\/ /_/\____/|_| Type :? for help.
-
-Loading package std ... linking ... done.
-Loading package lang ... linking ... done.
-Ok, modules loaded: Parser.
-2
-Leaving GHCi.
+++ /dev/null
-#-----------------------------------------------------------------------------
-# $Id: Makefile,v 1.28 2002/02/12 15:17:23 simonmar Exp $
-
-TOP = ../..
-include $(TOP)/mk/boilerplate.mk
-include $(TOP)/mk/should_run.mk
-
-SRC_HC_OPTS += -dcore-lint
-
-packedstring001_HC_OPTS = -package lang
-exceptions001_HC_OPTS = -package lang -fno-warn-missing-methods
-stableptr001_HC_OPTS = -package lang
-stableptr003_HC_OPTS = -package lang
-stableptr004_HC_OPTS = -package lang
-list001_HC_OPTS = -package lang
-uri001_HC_OPTS = -package net
-time001_HC_OPTS = -package lang
-io001_HC_OPTS = -package lang
-io002_HC_OPTS = -package lang
-addr001_HC_OPTS = -package lang
-
-enum01_HC_OPTS = -cpp -package lang -H12m
-enum02_HC_OPTS = -cpp -package lang -H12m
-enum03_HC_OPTS = -cpp -package lang -H12m
-
-stableptr001_RUNTEST_OPTS = +RTS -K4m
-stableptr004_RUNTEST_OPTS = +RTS -K4m
-dynamic001_HC_OPTS = -package lang
-dynamic002_HC_OPTS = -package lang
-
-ioexts001_HC_OPTS = -package lang -O
-ioexts001_RUNTEST_OPTS = +RTS -K16m
-ioexts002_HC_OPTS = -package lang
-
-memo001_HC_OPTS = -package lang -package util
-# stress the garbage collector a bit, to make sure weak pointers are being
-# finalized properly, and stable names are GC'd etc.
-memo001_RUNTEST_OPTS = +RTS -A10k -G1
-
-memo002_HC_OPTS = -package lang -package util
-memo002_RUNTEST_OPTS = 20
-
-weak001_HC_OPTS = -package lang -fglasgow-exts
-
-SRC_MKDEPENDHS_OPTS += -package lang
-
-include $(TOP)/mk/target.mk
-
+++ /dev/null
-module Main where
-
-import Network.URI
-import Data.Maybe
-
-main = sequence_ (map do_test tests)
-
-base = fromJust (parseURI "http://a/b/c/d;p?q")
-
-do_test test = case parseURI test of
- Nothing -> error ("no parse: " ++ test)
- Just uri -> putStr (show (fromJust (uri `relativeTo` base)) ++ "\n")
-
-tests =
- [ "g:h",
- "g",
- "./g",
- "g/",
- "/g",
- "//g",
- "?y",
- "g?y",
- "#s",
- "g#s",
- "g?y#s",
- ";x",
- "g;x",
- "g;x?y#s",
- ".",
- "./",
- "..",
- "../",
- "../g",
- "../..",
- "../../",
- "../../g",
- -- "../../../g" -- should fail
- -- "../../../../g" -- should fail
- "/./g",
- "/../g",
- "g.",
- ".g",
- "g..",
- "..g",
- "./../g",
- "./g/.",
- "g/./h",
- "g/../h",
- "g;x=1/./y",
- "g;x=1/../y",
- "g?y/./x",
- "g?y/../x",
- "g#s/./x",
- "g#s/../x"
- ]
projects / ghc-hetmet.git / commitdiff