Commit 0e2aef0b authored by bbr's avatar bbr
Browse files

whole system compiles

various external modules had to be changed
parent 3c55f61c
......@@ -10,9 +10,9 @@ data C_OrRef = C_OrRef OrRef
| C_OrRefSusp Curry.SuspRef (Curry.SuspCont C_OrRef)
instance BaseCurry C_OrRef where
nf f state x = f(state)(x)
nf f x state = f(x)(state)
gnf f state x = f(state)(x)
gnf f x state = f(x)(state)
free _ = error "free Variable of type OrRef"
......@@ -45,11 +45,11 @@ instance BaseCurry C_OrRef where
suspCont (C_OrRefSusp _ x) = x
instance Curry C_OrRef where
strEq _ (C_OrRef x1) (C_OrRef y1)
strEq (C_OrRef x1) (C_OrRef y1) _
= if x1 Prelude.== y1 then strEqSuccess else strEqFail "OrRef"
strEq _ x0 _ = CurryPrelude.strEqFail(CurryPrelude.typeName(x0))
strEq x0 _ _ = CurryPrelude.strEqFail(CurryPrelude.typeName(x0))
eq _ (C_OrRef x1) (C_OrRef y1) =
eq (C_OrRef x1) (C_OrRef y1) _ =
if x1 Prelude.== y1 then C_True else C_False
eq _ _ _ = C_False
......
......@@ -8,29 +8,29 @@ import System.Time
import System.Directory
import System.IO
prim_doesFileExist :: Fun C_String (C_IO C_Bool)
prim_doesFileExist :: C_String -> Result (C_IO C_Bool)
prim_doesFileExist = ioFunc1 doesFileExist
prim_doesDirectoryExist :: Fun C_String (C_IO C_Bool)
prim_doesDirectoryExist :: C_String -> Result (C_IO C_Bool)
prim_doesDirectoryExist = ioFunc1 doesDirectoryExist
prim_fileSize :: Fun C_String (C_IO C_Int)
prim_fileSize :: C_String -> Result (C_IO C_Int)
prim_fileSize = ioFunc1 (\s->do h <- openFile s ReadMode
i <- hFileSize h
hClose h
return i)
prim_getModificationTime :: Fun C_String (C_IO C_ClockTime)
prim_getModificationTime :: C_String -> Result (C_IO C_ClockTime)
prim_getModificationTime = ioFunc1 getModificationTime
prim_getDirectoryContents :: Fun C_String (C_IO (List C_String))
prim_getDirectoryContents :: C_String -> Result (C_IO (List C_String))
prim_getDirectoryContents = ioFunc1 getDirectoryContents
getCurrentDirectory :: Const (C_IO C_String)
getCurrentDirectory :: Result (C_IO C_String)
getCurrentDirectory = ioFunc0 System.Directory.getCurrentDirectory
prim_createDirectory :: Fun C_String (C_IO T0)
prim_createDirectory :: C_String -> Result (C_IO T0)
prim_createDirectory = ioFunc1 createDirectory
prim_removeFile :: Fun C_String (C_IO T0)
prim_removeFile :: C_String -> Result (C_IO T0)
prim_removeFile = ioFunc1 removeFile
\ No newline at end of file
......@@ -4,24 +4,24 @@ import Curry
import CurryPrelude
import qualified InstallDir as ID
curryCompiler :: Const C_String
curryCompiler :: Result C_String
curryCompiler _ = toCurry "kics"
curryCompilerMajorVersion :: Const C_Int
curryCompilerMajorVersion :: Result C_Int
curryCompilerMajorVersion _ = 0
curryCompilerMinorVersion :: Const C_Int
curryCompilerMinorVersion :: Result C_Int
curryCompilerMinorVersion _ = 9854
installDir :: Const C_String
installDir :: Result C_String
installDir _ = toCurry (ID.installDir)
curryRuntime :: Const C_String
curryRuntime :: Result C_String
curryRuntime _ = toCurry "ghc"
curryRuntimeMajorVersion :: Const C_Int
curryRuntimeMajorVersion :: Result C_Int
curryRuntimeMajorVersion _ = 6
curryRuntimeMinorVersion :: Const C_Int
curryRuntimeMinorVersion :: Result C_Int
curryRuntimeMinorVersion _ = 4
......@@ -25,85 +25,85 @@ instance Floating C_Float where
instance RealFrac C_Float where
properFraction (PrimValue x) = case properFraction x of (b,a) -> (b,PrimValue a)
prim_Float_plus :: Fun C_Float (C_Float -> C_Float)
prim_Float_plus _ x y = x+y
prim_Float_plus :: C_Float -> C_Float -> Result C_Float
prim_Float_plus x y _ = x+y
prim_Float_minus :: Fun C_Float (C_Float -> C_Float)
prim_Float_minus _ x y = x-y
prim_Float_minus :: C_Float -> C_Float -> Result C_Float
prim_Float_minus x y _ = x-y
prim_Float_times :: Fun C_Float (C_Float -> C_Float)
prim_Float_times _ x y = x*y
prim_Float_times :: C_Float -> C_Float -> Result C_Float
prim_Float_times x y _ = x*y
prim_Float_divide :: Fun C_Float (C_Float -> C_Float)
prim_Float_divide _ x y = x/y
prim_Float_divide :: C_Float -> C_Float -> Result C_Float
prim_Float_divide x y _ = x/y
prim_Float_lt :: Fun C_Float (C_Float -> C_Bool)
prim_Float_lt _ x y = toCurry (x<y)
prim_Float_lt :: C_Float -> C_Float -> Result C_Bool
prim_Float_lt x y _ = toCurry (x<y)
prim_Float_gt :: Fun C_Float (C_Float -> C_Bool)
prim_Float_gt _ x y = toCurry (x>y)
prim_Float_gt :: C_Float -> C_Float -> Result C_Bool
prim_Float_gt x y _ = toCurry (x>y)
prim_Float_leq :: Fun C_Float (C_Float -> C_Bool)
prim_Float_leq _ x y = toCurry (x<=y)
prim_Float_leq :: C_Float -> C_Float -> Result C_Bool
prim_Float_leq x y _ = toCurry (x<=y)
prim_Float_geq :: Fun C_Float (C_Float -> C_Bool)
prim_Float_geq _ x y = toCurry (x>=y)
prim_Float_geq :: C_Float -> C_Float -> Result C_Bool
prim_Float_geq x y _ = toCurry (x>=y)
prim_i2f :: Fun C_Int C_Float
prim_i2f _ x = fromInteger (fromCurry x)
prim_i2f :: C_Int -> Result C_Float
prim_i2f x _ = fromInteger (fromCurry x)
prim_truncate :: Fun C_Float C_Int
prim_truncate _ x = toCurry (truncate x :: Integer)
prim_truncate :: C_Float -> Result C_Int
prim_truncate x _ = toCurry (truncate x :: Integer)
prim_round :: Fun C_Float C_Int
prim_round _ x = toCurry (round x :: Integer)
prim_round :: C_Float -> Result C_Int
prim_round x _ = toCurry (round x :: Integer)
prim_sqrt :: Fun C_Float C_Float
prim_sqrt _ x = sqrt x
prim_sqrt :: C_Float -> Result C_Float
prim_sqrt x _ = sqrt x
prim_log :: Fun C_Float C_Float
prim_log _ x = log x
prim_log :: C_Float -> Result C_Float
prim_log x _ = log x
prim_exp :: Fun C_Float C_Float
prim_exp _ x = exp x
prim_exp :: C_Float -> Result C_Float
prim_exp x _ = exp x
prim_sin :: Fun C_Float C_Float
prim_sin _ x = sin x
prim_sin :: C_Float -> Result C_Float
prim_sin x _ = sin x
prim_cos :: Fun C_Float C_Float
prim_cos _ x = cos x
prim_cos :: C_Float -> Result C_Float
prim_cos x _ = cos x
prim_tan :: Fun C_Float C_Float
prim_tan _ x = tan x
prim_tan :: C_Float -> Result C_Float
prim_tan x _ = tan x
......@@ -23,42 +23,42 @@ instance ConvertCH C_SeekMode SI.SeekMode where
fromCurry C_RelativeSeek = SI.RelativeSeek
fromCurry C_SeekFromEnd = SI.SeekFromEnd
stdin :: Const C_Handle
stdin :: Result C_Handle
stdin _ = PrimValue SI.stdin
stdout :: Const C_Handle
stdout :: Result C_Handle
stdout _ = PrimValue SI.stdout
stderr :: Const C_Handle
stderr :: Result C_Handle
stderr _ = PrimValue SI.stderr
prim_openFile :: Fun (List C_Char) (C_IOMode -> C_IO C_Handle)
prim_openFile :: List C_Char -> C_IOMode -> Result (C_IO C_Handle)
prim_openFile = ioFunc2 SI.openFile
prim_hClose :: Fun C_Handle (C_IO T0)
prim_hClose :: C_Handle -> Result (C_IO T0)
prim_hClose = ioFunc1 SI.hClose
prim_hFlush :: Fun C_Handle (C_IO T0)
prim_hFlush :: C_Handle -> Result (C_IO T0)
prim_hFlush = ioFunc1 SI.hFlush
prim_hIsEOF :: Fun C_Handle (C_IO C_Bool)
prim_hIsEOF :: C_Handle -> Result (C_IO C_Bool)
prim_hIsEOF = ioFunc1 SI.hIsEOF
prim_hSeek :: Fun C_Handle (C_SeekMode -> C_Int -> C_IO T0)
prim_hSeek :: C_Handle -> C_SeekMode -> C_Int -> Result (C_IO T0)
prim_hSeek = ioFunc3 SI.hSeek
prim_hWaitForInput :: Fun C_Handle (C_Int -> C_IO C_Bool)
prim_hWaitForInput :: C_Handle -> C_Int -> Result (C_IO C_Bool)
prim_hWaitForInput = ioFunc2 SI.hWaitForInput
prim_hGetChar :: Fun C_Handle (C_IO C_Char)
prim_hGetChar :: C_Handle -> Result (C_IO C_Char)
prim_hGetChar = ioFunc1 SI.hGetChar
prim_hPutChar :: Fun C_Handle (C_Char -> C_IO T0)
prim_hPutChar :: C_Handle -> C_Char -> Result (C_IO T0)
prim_hPutChar = ioFunc2 SI.hPutChar
prim_hIsReadable :: Fun C_Handle (C_IO C_Bool)
prim_hIsReadable :: C_Handle -> Result (C_IO C_Bool)
prim_hIsReadable = ioFunc1 SI.hIsReadable
prim_hIsWritable :: Fun C_Handle (C_IO C_Bool)
prim_hIsWritable :: C_Handle -> Result (C_IO C_Bool)
prim_hIsWritable = ioFunc1 SI.hIsWritable
......@@ -22,7 +22,7 @@ waitOnHandle h v t mvar = do
ready <- hWaitForInput h t
putMVar mvar (if ready then Just v else Nothing)
prim_hSelectHandle :: Fun C_Int ((List C_Handle) -> C_IO (C_Maybe C_Int))
prim_hSelectHandle :: C_Int -> List C_Handle -> Result (C_IO (C_Maybe C_Int))
prim_hSelectHandle = ioFunc2 selectHandle
......@@ -30,34 +30,34 @@ getAssocs = Ref.readIORef assocs
setAssocs :: Assocs -> IO ()
setAssocs as = Ref.writeIORef assocs as
prim_execCmd :: Fun (List C_Char) (C_IO (T3 C_Handle C_Handle C_Handle))
prim_execCmd :: List C_Char -> Result (C_IO (T3 C_Handle C_Handle C_Handle))
prim_execCmd = ioFunc1 (\s -> do
(h1,h2,h3,_) <- runInteractiveCommand s
return (h1,h2,h3))
prim_connectToCmd = error "connectToCmd not yet implemented"
prim_setAssoc :: Fun (List C_Char) (List C_Char -> C_IO T0)
prim_setAssoc st key val = ioFunc0 (do
prim_setAssoc :: List C_Char -> List C_Char -> Result (C_IO T0)
prim_setAssoc key val = ioFunc0 (do
as <- getAssocs
setAssocs ((key,val):as)) st
setAssocs ((key,val):as))
prim_getAssoc :: Fun (List C_Char) (C_IO (C_Maybe (List C_Char)))
prim_getAssoc _ key = C_IO (\_ -> do
prim_getAssoc :: List C_Char -> Result (C_IO (C_Maybe (List C_Char)))
prim_getAssoc key _ = C_IO (\_ -> do
as <- getAssocs
return (IOVal (maybe C_Nothing C_Just (lookup key as))))
newIORef :: Curry t0 => Fun t0 (C_IO (C_IORef t0))
newIORef st x = ioFunc0 (Ref.newIORef x) st
newIORef :: Curry t0 => t0 -> Result (C_IO (C_IORef t0))
newIORef x = ioFunc0 (Ref.newIORef x)
prim_readIORef :: Curry t0 => Fun (C_IORef t0) (C_IO t0)
prim_readIORef _ (PrimValue ref) =
prim_readIORef :: Curry t0 => C_IORef t0 -> Result (C_IO t0)
prim_readIORef (PrimValue ref) _ =
C_IO (\ _ -> do
v <- Ref.readIORef ref
return (IOVal v))
prim_writeIORef :: Curry t0 => Fun (C_IORef t0) (t0 -> C_IO T0)
prim_writeIORef st (PrimValue ref) x = ioFunc0 (Ref.writeIORef ref x) st
prim_writeIORef :: Curry t0 => C_IORef t0 -> t0 -> Result (C_IO T0)
prim_writeIORef (PrimValue ref) x = ioFunc0 (Ref.writeIORef ref x)
......@@ -37,10 +37,10 @@ headNormalFormIO cont x _ =
searchTree :: Curry a => a -> Result (C_SearchTree a)
searchTree = searchTr
hnfIO x _ = C_IO (hnfCTC (const (return . IOVal)) x)
nfIO x _ = C_IO (nfCTC (const (return . IOVal)) x)
gnfIO x _ = C_IO (ghnfCTC (const (return . IOVal)) x)
ghnfIO x _ = C_IO (ghnfCTC (const (return . IOVal)) x)
hnfIO x _ = C_IO (hnfCTC (\ x _ -> return (IOVal x)) x)
nfIO x _ = C_IO (nfCTC (\ x _ -> return (IOVal x)) x)
gnfIO x _ = C_IO (ghnfCTC (\ x _ -> return (IOVal x)) x)
ghnfIO x _ = C_IO (ghnfCTC (\ x _ -> return (IOVal x)) x)
---------------------------------------------------------------------------------
-- rich search trees
......
......@@ -5,17 +5,17 @@ import CurryPrelude hiding ((==))
import Data.Char
prim_showTerm :: Curry t0 => Fun t0 (List C_Char)
prim_showTerm :: Curry t0 => t0 -> Result (List C_Char)
prim_showTerm = prim_show -- gnf (toCurry . show)
prim_showQTerm :: Curry t0 => Fun t0 (List C_Char)
prim_showQTerm :: Curry t0 => t0 -> Result (List C_Char)
prim_showQTerm = error "showQTerm not yet provided" --extFunc1 show
prim_readsUnqualifiedTerm :: Curry t0 =>
Fun (List C_String) (C_String -> List (T2 t0 C_String))
prim_readsUnqualifiedTerm _ _ =
fromHaskellList . map (\ (x,y) -> T2 x (toCurry y)) . reads . fromCurry
List C_String -> C_String -> Result (List (T2 t0 C_String))
prim_readsUnqualifiedTerm _ x _ =
fromHaskellList $ map (\ (x,y) -> T2 x (toCurry y)) $ reads $ fromCurry x
prim_readsQTerm :: Curry t0 => Fun C_String (List (T2 t0 C_String))
prim_readsQTerm st = prim_readsUnqualifiedTerm st List
prim_readsQTerm :: Curry t0 => C_String -> Result (List (T2 t0 C_String))
prim_readsQTerm = prim_readsUnqualifiedTerm List
......@@ -14,10 +14,10 @@ instance ConvertCH C_Int PortID where
toCurry (PortNumber i) = toCurry (toInteger i)
fromCurry i = PortNumber (fromInteger (fromCurry i))
prim_listenOn :: State -> C_Int -> C_IO C_Socket
prim_listenOn :: C_Int -> Result (C_IO C_Socket)
prim_listenOn = CurryPrelude.ioFunc1 listenOn
listenOnFresh :: State -> C_IO (T2 C_Int C_Socket)
listenOnFresh :: Result (C_IO (T2 C_Int C_Socket))
listenOnFresh = CurryPrelude.ioFunc0 listenOnFreshPort
listenOnFreshPort :: IO (PortID,Socket)
......@@ -27,17 +27,17 @@ listenOnFreshPort = do
return (p,s)
prim_socketListen :: State -> C_Socket -> C_Int -> C_IO T0
prim_socketListen :: C_Socket -> C_Int -> Result (C_IO T0)
prim_socketListen = CurryPrelude.ioFunc2 listen
prim_socketAccept :: State -> C_Socket -> C_IO (T2 (List C_Char) C_Handle)
prim_socketAccept :: C_Socket -> Result (C_IO (T2 (List C_Char) C_Handle))
prim_socketAccept = ioFunc1 (\ s -> Network.accept s >>= \ (h,s,_) -> return (s,h))
prim_waitForSocketAccept :: State -> C_Socket -> C_Int -> C_IO (C_Maybe (T2 (List C_Char) C_Handle))
prim_waitForSocketAccept :: C_Socket -> C_Int -> Result (C_IO (C_Maybe (T2 (List C_Char) C_Handle)))
prim_waitForSocketAccept = CurryPrelude.ioFunc2 wait
wait :: Socket -> Int -> IO (Maybe (String,Handle))
......@@ -52,7 +52,7 @@ wait s t = do
prim_connectToSocket :: State -> (List C_Char) -> C_Int -> C_IO C_Handle
prim_connectToSocket :: List C_Char -> C_Int -> Result (C_IO C_Handle)
prim_connectToSocket = ioFunc2 connectTo
......@@ -16,48 +16,48 @@ instance ConvertCH C_Int ExitCode where
fromCurry i = if hi Prelude.== 0 then ExitSuccess else ExitFailure hi
where hi = fromCurry i
getCPUTime :: Const (C_IO C_Int)
getCPUTime :: Result (C_IO C_Int)
getCPUTime = ioFunc0 (SC.getCPUTime >>= return . (`div` 1000000000))
getElapsedTime :: Const (C_IO C_Int)
getElapsedTime :: Result (C_IO C_Int)
getElapsedTime = error "getElapsedTime not provided"
getArgs :: Const (C_IO (List (List C_Char)))
getArgs :: Result (C_IO (List (List C_Char)))
getArgs = ioFunc0 SE.getArgs
prim_getEnviron :: Fun (List C_Char) (C_IO (List C_Char))
prim_getEnviron :: (List C_Char) -> Result (C_IO (List C_Char))
prim_getEnviron =
ioFunc1 (\s -> SE.getEnvironment >>= (maybe (return "") return . lookup s))
getHostname :: Const (C_IO (List C_Char))
getHostname :: Result (C_IO (List C_Char))
getHostname = ioFunc0 NB.getHostName
getPID :: Const (C_IO C_Int)
getPID :: Result (C_IO C_Int)
getPID = error "getPID not provided"
getProgName :: Const (C_IO (List C_Char))
getProgName :: Result (C_IO (List C_Char))
getProgName = ioFunc0 (Curry.getProgName)
-- conform with haskell would be: SE.getProgName
prim_system :: Fun (List C_Char) (C_IO C_Int)
prim_system :: (List C_Char) -> Result (C_IO C_Int)
prim_system = ioFunc1 system
prim_sleep :: Fun C_Int (C_IO T0)
prim_sleep :: C_Int -> Result (C_IO T0)
prim_sleep = ioFunc1 (\t->system ("sleep "++show (t::Integer)) >> return ())
prim_exitWith :: Curry a => Fun C_Int (C_IO a)
prim_exitWith _ e = C_IO (\ _ -> exitWith (fromCurry e) >>= return . IOVal)
prim_exitWith :: Curry a => C_Int -> Result (C_IO a)
prim_exitWith e _ = C_IO (\ _ -> exitWith (fromCurry e) >>= return . IOVal)
prim_setEnviron :: Fun C_String (C_String -> C_IO T0)
prim_setEnviron :: C_String -> C_String -> Result (C_IO T0)
prim_setEnviron = error "setEnviron not implemented yet"
prim_unsetEnviron :: Fun C_String (C_IO T0)
prim_unsetEnviron :: C_String -> Result (C_IO T0)
prim_unsetEnviron = error "unsetEnviron not implemented yet"
evalSpace :: Fun a a
evalSpace :: a -> Result a
evalSpace = error "evalSpace is a no-no"
evalTime :: Fun a a
evalTime :: a -> Result a
evalTime = error "evalTime is a no-no"
......@@ -12,7 +12,7 @@ instance ConvertCH C_ClockTime ClockTime where
fromCurry (C_CTime i) = TOD (fromCurry i) 0
toCurry (TOD i _) = C_CTime (toCurry i)
getClockTime :: Const (C_IO C_ClockTime)
getClockTime :: Result (C_IO C_ClockTime)
getClockTime = ioFunc0 (System.Time.getClockTime)
prim_toCalendarTime = error "todo"
......
......@@ -7,21 +7,21 @@ import ExternalDataUnsafe
import System.IO.Unsafe
import Data.IORef
prim_isVar :: Curry a => Fun a C_Bool
prim_isVar _ x = case consKind x of
prim_isVar :: Curry a => a -> Result C_Bool
prim_isVar x _ = case consKind x of
Free -> either (const C_True) (const C_False) (binding x)
Val -> C_False
prim_unsafePerformIO :: Curry a => Fun (C_IO a) a
prim_unsafePerformIO st (C_IO action) = unsafe st (unsafePerformIO (action st))
prim_unsafePerformIO :: Curry a => C_IO a -> Result a
prim_unsafePerformIO (C_IO action) st = unsafe (unsafePerformIO (action st)) st
unsafe :: Curry a => Fun (IOVal a) a
unsafe _ (IOVal v) = v
unsafe _ (IOValFail e) = failed e
unsafe st (IOValOr r bs) = mapOr st (\ st x -> unsafe st (unsafePerformIO x)) r bs
unsafe _ (IOValSusp _ _) = error $ "ExternalFunctionsUnsafe.unsafe susp"
unsafe _ (IOValFreeVar _) = error $ "ExternalFunctionsUnsafe.unsafe free"
unsafe :: Curry a => IOVal a -> Result a
unsafe (IOVal v) _ = v
unsafe (IOValFail e) _ = failed e
unsafe (IOValOr r bs) st = mapOr (\ x -> unsafe (unsafePerformIO x)) r bs st
unsafe (IOValSusp _ _) _ = error $ "ExternalFunctionsUnsafe.unsafe susp"
unsafe (IOValFreeVar _) _ = error $ "ExternalFunctionsUnsafe.unsafe free"
{-
-- the main point about unsafe: the value of suspensions has to be stored.
unsafe (IOValSusp _ susp) = let sRef = nextSuspRef () in
......@@ -64,8 +64,8 @@ saveSuspValue sRef cont susp store =
-}
prim_identicalVar :: Curry a => Fun a (a -> C_Bool)
prim_identicalVar _ x y = case (consKind x,consKind y) of
prim_identicalVar :: Curry a => a -> a -> Result C_Bool
prim_identicalVar x y _ = case (consKind x,consKind y) of
(Free,Free) -> toCurry (freeVarRef x Prelude.== freeVarRef y)
_ -> C_False
......@@ -119,12 +119,12 @@ susp v@(C_SuccessFreeVar ref) x = C_SuccessOr ref [(modStore v C_Success,x)]
-}
try :: Curry a => Fun a (C_Either a (T2 C_OrRef (List a)))
try _ x = case consKind x of
try :: Curry a => a -> Result (C_Either a (T2 C_OrRef (List a)))
try x _ = case consKind x of
Val -> C_Left x
Branching -> C_Right (T2 (C_OrRef (orRef x))
(fromHaskellList (branches x)))
c -> error ("try: consKind is "++show c)
ors :: Curry a => Fun C_OrRef (List a -> a)
ors _ (C_OrRef r) xs = branching r (toHaskellList xs)
ors :: Curry a => C_OrRef -> List a -> Result a
ors (C_OrRef r) xs _ = branching r (toHaskellList xs)
Markdown is supported
0% or .
You are about to add 0 people to the discussion. Proceed with caution.
Finish editing this message first!
Please register or to comment