Commit 4be4a982 authored by Bernd Brassel's avatar Bernd Brassel
Browse files

some more external functions integrated

parent 6ed00464
......@@ -2,17 +2,8 @@
.curry/
# generated by ghc or cc
src/*.hi
src/*.o
src/tools/*.hi
src/tools/*.o
src/oracle/*.hi
src/oracle/*.o
src/MetaProgramming/*.hi
src/MetaProgramming/*.o
src/lib/External*.hi
src/lib/External*.o
src/lib/coracle.o
*.hi
*.o
libdyncoracle.so
src/lib/libcoracle.a
......
......@@ -51,10 +51,9 @@ Library
Build-Depends:
syb
Other-Modules:
Store,
BaseCurry,
RunTimeCurry,
Curry
Curry.RunTimeSystem.Store,
Curry.RunTimeSystem.BaseCurry,
Curry.RunTimeSystem
......
......@@ -47,7 +47,7 @@ all: $(SRC)InstallDir.hs $(BIN)kicslib $(BIN)kics \
$(BIN)kicsi libs cpns www tools
.PHONY: tools
tools: $(SRC)InstallDir.hs $(BIN)makeExternalInterface $(BIN)prettyflat\
tools: $(SRC)InstallDir.hs $(BIN)prettyflat\
$(BIN)currytest $(BIN)prettyacy
$(SRC)InstallDir.hs: prerequisites
......@@ -100,7 +100,7 @@ $(BIN)kics: $(BIN)kicslib $(SRC)kics.hi
.PHONY: runtime
runtime: $(SRC)InstallDir.hs
$(GHC) -fno-cse $(SRC)Curry.hs
$(GHC) -fno-cse Curry.RunTimeSystem
.PHONY: libs
libs: $(BIN)kics runtime $(BIN)makeacy
......@@ -207,9 +207,10 @@ depend : $(SRC)MyReadline.hs
%.hi: %.o %.hs
$(GHC) --make $(HC_OPTS) $*.hs
# DO NOT DELETE: Beginning of Haskell dependencies
src/MyReadline.o : src/MyReadline.hs
src/InstallDir.o : src/InstallDir.hs
src/SafeCalls.o : src/SafeCalls.hs
src/KicsSubdir.o : src/KicsSubdir.hs
src/MetaProgramming/FlatCurry.o : src/MetaProgramming/FlatCurry.hs
src/MetaProgramming/FlatCurry.o : src/KicsSubdir.hi
......@@ -232,7 +233,6 @@ src/ShowFunctionalProg.o : src/Brace.hi
src/ShowFunctionalProg.o : src/FunctionalProg.hi
src/Names.o : src/Names.hs
src/Names.o : src/ShowFunctionalProg.hi
src/SafeCalls.o : src/SafeCalls.hs
src/Config.o : src/Config.hs
src/Config.o : src/KicsSubdir.hi
src/Config.o : src/Names.hi
......@@ -251,10 +251,7 @@ src/CurryToHaskell.o : src/ShowFunctionalProg.hi
src/CurryToHaskell.o : src/FunctionalProg.hi
src/CurryToHaskell.o : src/MetaProgramming/FlatCurryGoodies.hi
src/CurryToHaskell.o : src/MetaProgramming/FlatCurry.hi
src/kicslib.o : src/kicslib.hs
src/kicslib.o : src/Config.hi
src/kicsi.o : src/kicsi.hs
src/kicsi.o : src/MyReadline.hi
src/kicsi.o : src/Names.hi
src/kicsi.o : src/Config.hi
src/kicsi.o : src/ShowFlatCurry.hi
......@@ -262,8 +259,4 @@ src/kicsi.o : src/MetaProgramming/FlatCurryGoodies.hi
src/kicsi.o : src/MetaProgramming/FlatCurry.hi
src/kicsi.o : src/SafeCalls.hi
src/kicsi.o : src/CurryToHaskell.hi
src/kics.o : src/kics.hs
src/kics.o : src/SafeCalls.hi
src/kics.o : src/CurryToHaskell.hi
src/kics.o : src/Config.hi
# DO NOT DELETE: End of Haskell dependencies
......@@ -233,7 +233,7 @@ transform typeMapping aux opts0 (Prog name imports types funcs _)
-- import lists
newImports = map modName imports
allIImports = ["Curry"] ++ newImports
allIImports = [curryModule] ++ newImports
{-
-- this is the only special prelude treatment:
......@@ -277,7 +277,7 @@ generateAuxNames fs = (genNewName "aux1" fns,genNewName "aux2" fns)
mainMod (_,aux2) m opts = let aux = (m,snd (funName ("",aux2))) in
C.Prog "Main" ["Curry",modName "Prelude",m]
C.Prog "Main" [curryModule,modName "Prelude",m]
[] [] []
[C.Func (m,"main") public untyped
(Just [C.Rule []
......@@ -401,7 +401,7 @@ inst newModName name vars classname =
curryInstance opts t@(Type origName vis vars consdecls)
= inst newModName name vars "Curry"
= inst newModName name vars curryClass
[strEq,eq,propagate,foldCurry,typeName,showFunction True opts t] --toTerm,fromTerm
where
(newModName,name) = consName opts origName
......@@ -642,7 +642,7 @@ transFType _ _ (TVar (-42)) = Nothing
transFType opts arity t = Just $
C.TConstr
[C.TypeClass c [toTVar tv] | tv <- nub (allVarsInTypeExpr t),
c <- [("Curry","Curry")]]
c <- [(curryModule,"Curry")]]
(addStateType (transFTypeExpr opts arity t))
transFTypeExpr opts 0 t = transTypeExprF opts t
......@@ -932,7 +932,7 @@ failName opts = N.failName . consName opts
orName opts = N.orName . consName opts
suspName opts = N.suspName . consName opts
curryName s = ("Curry",s)
curryName s = (curryModule,s)
curryTCons = C.TCons . curryName
----------------------------------------
......@@ -978,7 +978,8 @@ funcupresym = sym . funName . addPre
concupresym opts = sym . consName opts . addPre
-- symbols from Curry library
curryModule = "Curry"
curryModule = "Curry.RunTimeSystem"
curryClass = "Curry"
cu = (,) curryModule
cusym = sym . cu
......
......@@ -8,7 +8,7 @@ import System.IO
import System.Directory (doesFileExist)
import Control.Monad (unless,when)
import System.FilePath
import System.Console.Readline
import CurryToHaskell
import SafeCalls
......@@ -17,7 +17,7 @@ import MetaProgramming.FlatCurryGoodies
import ShowFlatCurry
import Config
import Names
import MyReadline
allFiles = map snd . files
loadedFiles = map snd . filter fst . files
......@@ -69,7 +69,6 @@ main = do
home <- getEnv "HOME"
(options,state) <- getOptions
mapM_ (safe . put 1 options) welcome
unless (verbosity options==0) initializeReadline
let files = case filename options of
"" -> ["Prelude"]
fn -> [fn]
......
......@@ -4,4 +4,29 @@
,ForFunction "curryRuntime"
,ForFunction "curryRuntimeMajorVersion"
,ForFunction "curryRuntimeMinorVersion"
,ForFunction "installDir"]
,ForFunction "installDir"
]
import qualified InstallDir as ID
curryCompiler :: Result C_String
curryCompiler _ = toCurry "kics"
curryCompilerMajorVersion :: Result C_Int
curryCompilerMajorVersion _ = 0
curryCompilerMinorVersion :: Result C_Int
curryCompilerMinorVersion _ = 9854
installDir :: Result C_String
installDir _ = toCurry (ID.installDir)
curryRuntime :: Result C_String
curryRuntime _ = toCurry "ghc"
curryRuntimeMajorVersion :: Result C_Int
curryRuntimeMajorVersion _ = 6
curryRuntimeMinorVersion :: Result C_Int
curryRuntimeMinorVersion _ = 8
module ExternalDataSocket (module ExternalDataSocket) where
import Curry
import CurryPrelude
import Network
type C_Socket = Prim Socket
instance Read Socket where
instance Generate Socket where
genFree = error "no random sockets"
maxArity = error "no narrowing on sockets"
module ExternalFunctionsDistribution where
import Curry
import CurryPrelude
import qualified InstallDir as ID
curryCompiler :: Result C_String
curryCompiler _ = toCurry "kics"
curryCompilerMajorVersion :: Result C_Int
curryCompilerMajorVersion _ = 0
curryCompilerMinorVersion :: Result C_Int
curryCompilerMinorVersion _ = 9854
installDir :: Result C_String
installDir _ = toCurry (ID.installDir)
curryRuntime :: Result C_String
curryRuntime _ = toCurry "ghc"
curryRuntimeMajorVersion :: Result C_Int
curryRuntimeMajorVersion _ = 6
curryRuntimeMinorVersion :: Result C_Int
curryRuntimeMinorVersion _ = 8
module ExternalFunctionsSocket (module ExternalFunctionsSocket) where
import Curry
import CurryPrelude hiding (return, (>>=))
import ExternalDataSocket
import CurryIO
import Network
import Network.Socket
import Control.Concurrent
import System.IO (Handle)
instance ConvertCH C_Int PortID where
toCurry (PortNumber i) = toCurry (toInteger i)
fromCurry i = PortNumber (fromInteger (fromCurry i))
prim_listenOn :: C_Int -> Result (C_IO C_Socket)
prim_listenOn = CurryPrelude.ioFunc1 listenOn
listenOnFresh :: Result (C_IO (T2 C_Int C_Socket))
listenOnFresh = CurryPrelude.ioFunc0 listenOnFreshPort
listenOnFreshPort :: IO (PortID,Socket)
listenOnFreshPort = do
s <- listenOn (PortNumber aNY_PORT)
p <- Network.socketPort s
return (p,s)
prim_socketListen :: C_Socket -> C_Int -> Result (C_IO T0)
prim_socketListen = CurryPrelude.ioFunc2 listen
prim_socketAccept :: C_Socket -> Result (C_IO (T2 (List C_Char) C_Handle))
prim_socketAccept = ioFunc1 (\ s -> Network.accept s >>= \ (h,s,_) -> return (s,One h))
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,IOHandle))
wait s t = do
mv <- newEmptyMVar
tacc <- forkIO (Network.accept s >>= \ (h,s,_) -> putMVar mv (Just (s,One h)))
ttim <- forkIO (threadDelay (t*1000) >> putMVar mv Nothing)
res <- takeMVar mv
maybe (killThread tacc) (\_ -> killThread ttim) res
return res
prim_connectToSocket :: List C_Char -> C_Int -> Result (C_IO C_Handle)
prim_connectToSocket = ioFunc2 (\ s i -> connectTo s i >>= return . One)
{-# LANGUAGE RankNTypes,
ScopedTypeVariables,
MultiParamTypeClasses,
FlexibleInstances #-}
module ExternalInstancesPrelude (
module AutoGenerated2,
module ExternalInstancesPrelude) where
import Curry
import DataPrelude
import Char
import List
import System.IO.Unsafe
import Data.IORef
import AutoGenerated2
trace s x = unsafePerformIO (putStrLn s >> return x)
-----------------------------------------------------------------
-- type classes to extend BaseCurry to full Curry
-----------------------------------------------------------------
type StrEqResult = C_Bool
class (BaseCurry a,Show a,Read a) => Curry a where
-- basic equalities
strEq :: a -> a -> Result StrEqResult
eq :: a -> a -> Result C_Bool
-- some generics
propagate :: (forall b. Curry b => Int -> b -> Result b) -> a -> Result a
foldCurry :: (forall c. Curry c => c -> b -> Result b) -> b -> a -> Result b
-- name of the type
typeName :: a -> String
-- show qualified terms
showQ :: Int -> a -> String -> String
showQ = showsPrec
showQList :: [a] -> String -> String
showQList = showQStandardList
-- generic programming
--toC_Term :: HNFMode -> State -> a -> C_Data
--fromC_Term :: C_Data -> a
class Generate a where
genFree :: Int -> [a]
maxArity :: a -> Int
-----------------------------------------------------------------
-- external Show instances
-----------------------------------------------------------------
instance (Show t0) => Show (IOVal t0) where
showsPrec d (IOVal x1) = showParen (d>10) showStr
where
showStr = showString "IOVal" . showsPrec 11 x1
showsPrec _ (IOValOr i _) = showString ('_':show (deref i))
instance Show (IO (IOVal a)) where
show _ = "IO"
instance Show (C_IO a) where
show _ = "IO"
instance Show C_Success where
showsPrec _ C_Success = showString "success"
showsPrec _ (C_SuccessOr ref _) = showString ('_':show (deref ref))
instance Show (a->b) where
show _ = "FUNCTION"
instance Show a => Show (Prim a) where
show (PrimValue x) = show x
show (PrimOr r _) = "_"++show (deref r)
instance Show a => Show (List a) where
showsPrec = showsPrecList (showsPrec 0) (showsPrec 0)
showsPrecList :: (a -> ShowS) -> ([a] -> ShowS) -> Int -> List a -> ShowS
showsPrecList recursiveCall listCall _ (ListOr r _) =
showString ('_':show (deref r))
showsPrecList recursiveCall listCall _ xs
| isFreeList xs = showChar '(' . showFreel xs
| otherwise = listCall (toHaskellList xs)
where
isFreeList List = False
isFreeList (ListOr _ _) = True
isFreeList (_ :< xs) = isFreeList xs
isFreeList _ = True
showFreel (x:<xs) = recursiveCall x . showChar ':' . showFreel xs
showFreel (ListOr r _) = showString ('_':show (deref r)++")")
showQStandardList :: Curry a => [a] -> ShowS
showQStandardList xs = showChar '[' .
foldr (.) (showChar ']')
(intersperse (showChar ',') (map (showQ 0) xs))
fourToInt :: C_Four -> Either String Int
fourToInt C_F0 = Right 0
fourToInt C_F1 = Right 1
fourToInt C_F2 = Right 2
fourToInt C_F3 = Right 3
fourToInt x@(C_FourOr _ _) = Left (show x)
intToFour :: Int -> C_Four
intToFour 0 = C_F0
intToFour 1 = C_F1
intToFour 2 = C_F2
intToFour 3 = C_F3
scToChar :: C_Four -> C_Four -> C_Four -> C_Four -> Either String Char
scToChar f1 f2 f3 f4
= chr' ((fourToInt f1**64)+++(fourToInt f2**16)+++(fourToInt f3**4)+++fourToInt f4)
where
Left s ** _ = Left s
Right i ** j = Right (i*j)
Left s +++ _ = Left s
Right i +++ Left s = Left s
Right i +++ Right j = Right (i+j)
chr' (Right i) = Right (chr i)
chr' (Left s) = Left s
charToSc :: Char -> C_Char
charToSc c = SearchChar (intToFour d64) (intToFour d16) (intToFour d4) (intToFour m4)
where
o = ord c
(d64,m64) = divMod o 64
(d16,m16) = divMod m64 16
(d4,m4) = divMod m16 4
instance Show C_Four where
showsPrec d (C_FourOr r _) = showChar '_' . showsPrec d (deref r)
showsPrec _ _ = error "probably due to usage of ($#) instead of ($##) \
\for an external function with argument type string or character"
instance Show C_Char where
show (C_Char c) = show c
show (SearchChar f1 f2 f3 f4)
= either id show (scToChar f1 f2 f3 f4)
show (C_CharOr r _) = '_':show (deref r)
showList cs = if any isFreeChar cs
then showChar '[' . showFreel cs
else showChar '"' . showl cs -- "
where
showl [] = showChar '"'
showl (C_Char '"':cs) = showString "\\\"" . showl cs
showl (C_Char c:cs)
| oc <= 7 = showString "\\00" . shows oc . showl cs
| oc <= 10 = showLitChar c . showl cs
| oc <= 12 = showString "\\0" . shows oc . showl cs
| oc <= 13 = showLitChar c . showl cs
| oc <= 31 = showString "\\0" . shows oc . showl cs
| oc <= 126 = showLitChar c . showl cs
| otherwise = showString "\\" . shows oc . showl cs
where oc = ord c
showl (SearchChar f1 f2 f3 f4:cs) =
either showString showLitChar (scToChar f1 f2 f3 f4) . showl cs
showFreel [] = showString "]"
showFreel [c] = showString (show c) . showString "]"
showFreel (c:cs) = showString (show c++",") . showFreel cs
isFreeChar (SearchChar f1 f2 f3 f4) =
any ((==Branching) . consKind) [f1,f2,f3,f4]
isFreeChar _ = False
protectEsc p f = f . cont
where cont s@(c:_) | p c = "\\&" ++ s
cont s = s
asciiTab = zip ['\NUL'..' ']
["NUL", "SOH", "STX", "ETX", "EOT", "ENQ", "ACK", "BEL",
"BS", "HT", "LF", "VT", "FF", "CR", "SO", "SI",
"DLE", "DC1", "DC2", "DC3", "DC4", "NAK", "SYN", "ETB",
"CAN", "EM", "SUB", "ESC", "FS", "GS", "RS", "US",
"SP"]
instance Show C_Nat where
showsPrec d x | isFreeNat x = showsPrecNat d x
| otherwise = showsPrec d (fromCurry x::Integer)
isFreeNat :: C_Nat -> Bool
isFreeNat (C_NatOr _ _) = True
isFreeNat C_IHi = False
isFreeNat (C_I n) = isFreeNat n
isFreeNat (C_O n) = isFreeNat n
showsPrecNat :: Int -> C_Nat -> ShowS
showsPrecNat _ DataPrelude.C_IHi = Prelude.showString((:)('I')((:)('H')((:)('i')([]))))
showsPrecNat d (DataPrelude.C_O x1) = Prelude.showParen((Prelude.>)(d)(Prelude.fromInteger((10))))(showStr)
where
showStr = (Prelude..)(Prelude.showString((:)('O')((:)(' ')([]))))(showsPrecNat(Prelude.fromInteger((11)))(x1))
showsPrecNat d (DataPrelude.C_I x1) = Prelude.showParen((Prelude.>)(d)(Prelude.fromInteger((10))))(showStr)
where
showStr = (Prelude..)(Prelude.showString((:)('I')((:)(' ')([]))))(showsPrecNat(Prelude.fromInteger((11)))(x1))
showsPrecNat _ (DataPrelude.C_NatOr i _) = Prelude.showString((:)('_')(Prelude.show(deref i)))
instance Show C_Int where
showsPrec _ C_Zero = showChar '0'
showsPrec d x@(C_Pos n)
| isFreeNat n = showParen (d>10) (showString "Pos " . showsPrecNat 11 n)
| otherwise = showsPrec d (fromCurry x::Integer)
showsPrec d x@(C_Neg n)
| isFreeNat n = showParen (d>10) (showString "Neg " . showsPrecNat 11 n)
| otherwise = showsPrec d (fromCurry x::Integer)
showsPrec _ (C_IntOr i _) = showChar '_' . shows (deref i)
-----------------------------------------------------------------
-- external Read instances
-----------------------------------------------------------------
instance Read C_Four where
readsPrec _ _ = error "I won't read four"
instance (Read t0) => Read (IOVal t0) where
readsPrec d r = readParen (d>10)
(\ r -> [ (IOVal x1,r1) | (_,r0) <- readQualified "Prelude" "IOVal" r,
(x1,r1) <- readsPrec 11 r0]) r
instance Read (IO (IOVal a)) where
readsPrec = error "no reading IO"
instance Read (C_IO a) where
readsPrec = error "no reading IO"
instance Read C_Success where
readsPrec d r = Prelude.readParen(Prelude.False)
(\ r -> [(,)(C_Success)(r0) |
(_,r0) <- readQualified "Prelude" "Success" r])(r)
instance Read a => Read (Prim a) where
readsPrec p s = map (\(x,y) -> (PrimValue x,y)) (readsPrec p s)
instance Read a => Read (List a) where
readsPrec p = map (\ (x,y) -> (fromHaskellList x,y)) . readsPrec p
instance Read C_Char where
readsPrec p s = map (\ (x,y) -> (toCurry x,y))
(((readsPrec p)::ReadS Char) s)
readList s = map (\ (x,y) -> (map toCurry x,y))
((readList::ReadS String) s)
instance Read (a->b) where
readsPrec = error "reading FUNCTION"
instance Read DataPrelude.C_Nat where
readsPrec d r =
readParen False (\ r -> [(C_IHi,r0) | (_ ,r0) <- readQualified "Prelude" "IHi" r]) r
++ readParen (d>10) (\ r -> [(C_O x1,r1) | (_ ,r0) <- readQualified "Prelude" "O" r,
(x1,r1) <- readsPrec 11 r0]) r
++ readParen (d>10) (\ r -> [(C_I x1,r1) | (_ ,r0) <- readQualified "Prelude" "I" r,
(x1,r1) <- readsPrec 11 r0]) r
++ [(toCurry i,r0) | (i::Integer,r0) <- reads r]
instance Read DataPrelude.C_Int where
readsPrec d r =
readParen (d>10) (\ r -> [(C_Neg x1,r1) | (_ ,r0) <- readQualified "Prelude" "Neg" r,
(x1,r1) <- readsPrec 11 r0]) r
++ readParen False (\ r -> [(C_Zero,r0) | (_ ,r0) <- readQualified "Prelude" "Zero" r]) r
++ readParen (d>10) (\ r -> [(C_Pos x1,r1) | (_ ,r0) <- readQualified "Prelude" "Pos" r,
(x1,r1) <- readsPrec 11 r0]) r
++ [(toCurry i,r0) | (i::Integer,r0) <- reads r]
-----------------------------------------------------------------
-- external BaseCurry instances
-----------------------------------------------------------------
instance (BaseCurry t0) => BaseCurry (IOVal t0) where
nf f (IOVal x1) state0 = nfCTC(\ v1 state1 -> f(IOVal(v1)) (state1))(x1) (state0)
nf f x state = f(x) (state)
gnf f (IOVal x1) state0 = gnfCTC(\ v1 state1 -> f(IOVal(v1)) (state1))(x1) (state0)
gnf f x state = f(x) (state)
generator i = IOVal (generator i)
failed = IOValFail
branching r bs = IOValOr r (map return bs)
consKind (IOValOr _ _) = Branching
consKind (IOValFail _) = Failed
consKind _ = Val
exceptions (IOValFail x) = x
orRef (IOValOr x _) = x
branches (IOValOr _ bs) = map unsafePerformIO bs