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

some more external functions integrated

parent 6ed00464
...@@ -2,17 +2,8 @@ ...@@ -2,17 +2,8 @@
.curry/ .curry/
# generated by ghc or cc # generated by ghc or cc
src/*.hi *.hi
src/*.o *.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
libdyncoracle.so libdyncoracle.so
src/lib/libcoracle.a src/lib/libcoracle.a
......
...@@ -51,10 +51,9 @@ Library ...@@ -51,10 +51,9 @@ Library
Build-Depends: Build-Depends:
syb syb
Other-Modules: Other-Modules:
Store, Curry.RunTimeSystem.Store,
BaseCurry, Curry.RunTimeSystem.BaseCurry,
RunTimeCurry, Curry.RunTimeSystem
Curry
......
...@@ -47,7 +47,7 @@ all: $(SRC)InstallDir.hs $(BIN)kicslib $(BIN)kics \ ...@@ -47,7 +47,7 @@ all: $(SRC)InstallDir.hs $(BIN)kicslib $(BIN)kics \
$(BIN)kicsi libs cpns www tools $(BIN)kicsi libs cpns www tools
.PHONY: tools .PHONY: tools
tools: $(SRC)InstallDir.hs $(BIN)makeExternalInterface $(BIN)prettyflat\ tools: $(SRC)InstallDir.hs $(BIN)prettyflat\
$(BIN)currytest $(BIN)prettyacy $(BIN)currytest $(BIN)prettyacy
$(SRC)InstallDir.hs: prerequisites $(SRC)InstallDir.hs: prerequisites
...@@ -100,7 +100,7 @@ $(BIN)kics: $(BIN)kicslib $(SRC)kics.hi ...@@ -100,7 +100,7 @@ $(BIN)kics: $(BIN)kicslib $(SRC)kics.hi
.PHONY: runtime .PHONY: runtime
runtime: $(SRC)InstallDir.hs runtime: $(SRC)InstallDir.hs
$(GHC) -fno-cse $(SRC)Curry.hs $(GHC) -fno-cse Curry.RunTimeSystem
.PHONY: libs .PHONY: libs
libs: $(BIN)kics runtime $(BIN)makeacy libs: $(BIN)kics runtime $(BIN)makeacy
...@@ -207,9 +207,10 @@ depend : $(SRC)MyReadline.hs ...@@ -207,9 +207,10 @@ depend : $(SRC)MyReadline.hs
%.hi: %.o %.hs %.hi: %.o %.hs
$(GHC) --make $(HC_OPTS) $*.hs $(GHC) --make $(HC_OPTS) $*.hs
# DO NOT DELETE: Beginning of Haskell dependencies # DO NOT DELETE: Beginning of Haskell dependencies
src/MyReadline.o : src/MyReadline.hs
src/InstallDir.o : src/InstallDir.hs src/InstallDir.o : src/InstallDir.hs
src/SafeCalls.o : src/SafeCalls.hs
src/KicsSubdir.o : src/KicsSubdir.hs src/KicsSubdir.o : src/KicsSubdir.hs
src/MetaProgramming/FlatCurry.o : src/MetaProgramming/FlatCurry.hs src/MetaProgramming/FlatCurry.o : src/MetaProgramming/FlatCurry.hs
src/MetaProgramming/FlatCurry.o : src/KicsSubdir.hi src/MetaProgramming/FlatCurry.o : src/KicsSubdir.hi
...@@ -232,7 +233,6 @@ src/ShowFunctionalProg.o : src/Brace.hi ...@@ -232,7 +233,6 @@ src/ShowFunctionalProg.o : src/Brace.hi
src/ShowFunctionalProg.o : src/FunctionalProg.hi src/ShowFunctionalProg.o : src/FunctionalProg.hi
src/Names.o : src/Names.hs src/Names.o : src/Names.hs
src/Names.o : src/ShowFunctionalProg.hi src/Names.o : src/ShowFunctionalProg.hi
src/SafeCalls.o : src/SafeCalls.hs
src/Config.o : src/Config.hs src/Config.o : src/Config.hs
src/Config.o : src/KicsSubdir.hi src/Config.o : src/KicsSubdir.hi
src/Config.o : src/Names.hi src/Config.o : src/Names.hi
...@@ -251,10 +251,7 @@ src/CurryToHaskell.o : src/ShowFunctionalProg.hi ...@@ -251,10 +251,7 @@ src/CurryToHaskell.o : src/ShowFunctionalProg.hi
src/CurryToHaskell.o : src/FunctionalProg.hi src/CurryToHaskell.o : src/FunctionalProg.hi
src/CurryToHaskell.o : src/MetaProgramming/FlatCurryGoodies.hi src/CurryToHaskell.o : src/MetaProgramming/FlatCurryGoodies.hi
src/CurryToHaskell.o : src/MetaProgramming/FlatCurry.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/kicsi.hs
src/kicsi.o : src/MyReadline.hi
src/kicsi.o : src/Names.hi src/kicsi.o : src/Names.hi
src/kicsi.o : src/Config.hi src/kicsi.o : src/Config.hi
src/kicsi.o : src/ShowFlatCurry.hi src/kicsi.o : src/ShowFlatCurry.hi
...@@ -262,8 +259,4 @@ src/kicsi.o : src/MetaProgramming/FlatCurryGoodies.hi ...@@ -262,8 +259,4 @@ src/kicsi.o : src/MetaProgramming/FlatCurryGoodies.hi
src/kicsi.o : src/MetaProgramming/FlatCurry.hi src/kicsi.o : src/MetaProgramming/FlatCurry.hi
src/kicsi.o : src/SafeCalls.hi src/kicsi.o : src/SafeCalls.hi
src/kicsi.o : src/CurryToHaskell.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 # DO NOT DELETE: End of Haskell dependencies
...@@ -233,7 +233,7 @@ transform typeMapping aux opts0 (Prog name imports types funcs _) ...@@ -233,7 +233,7 @@ transform typeMapping aux opts0 (Prog name imports types funcs _)
-- import lists -- import lists
newImports = map modName imports newImports = map modName imports
allIImports = ["Curry"] ++ newImports allIImports = [curryModule] ++ newImports
{- {-
-- this is the only special prelude treatment: -- this is the only special prelude treatment:
...@@ -277,7 +277,7 @@ generateAuxNames fs = (genNewName "aux1" fns,genNewName "aux2" fns) ...@@ -277,7 +277,7 @@ generateAuxNames fs = (genNewName "aux1" fns,genNewName "aux2" fns)
mainMod (_,aux2) m opts = let aux = (m,snd (funName ("",aux2))) in 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 [C.Func (m,"main") public untyped
(Just [C.Rule [] (Just [C.Rule []
...@@ -401,7 +401,7 @@ inst newModName name vars classname = ...@@ -401,7 +401,7 @@ inst newModName name vars classname =
curryInstance opts t@(Type origName vis vars consdecls) 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 [strEq,eq,propagate,foldCurry,typeName,showFunction True opts t] --toTerm,fromTerm
where where
(newModName,name) = consName opts origName (newModName,name) = consName opts origName
...@@ -642,7 +642,7 @@ transFType _ _ (TVar (-42)) = Nothing ...@@ -642,7 +642,7 @@ transFType _ _ (TVar (-42)) = Nothing
transFType opts arity t = Just $ transFType opts arity t = Just $
C.TConstr C.TConstr
[C.TypeClass c [toTVar tv] | tv <- nub (allVarsInTypeExpr t), [C.TypeClass c [toTVar tv] | tv <- nub (allVarsInTypeExpr t),
c <- [("Curry","Curry")]] c <- [(curryModule,"Curry")]]
(addStateType (transFTypeExpr opts arity t)) (addStateType (transFTypeExpr opts arity t))
transFTypeExpr opts 0 t = transTypeExprF opts t transFTypeExpr opts 0 t = transTypeExprF opts t
...@@ -932,7 +932,7 @@ failName opts = N.failName . consName opts ...@@ -932,7 +932,7 @@ failName opts = N.failName . consName opts
orName opts = N.orName . consName opts orName opts = N.orName . consName opts
suspName opts = N.suspName . consName opts suspName opts = N.suspName . consName opts
curryName s = ("Curry",s) curryName s = (curryModule,s)
curryTCons = C.TCons . curryName curryTCons = C.TCons . curryName
---------------------------------------- ----------------------------------------
...@@ -978,7 +978,8 @@ funcupresym = sym . funName . addPre ...@@ -978,7 +978,8 @@ funcupresym = sym . funName . addPre
concupresym opts = sym . consName opts . addPre concupresym opts = sym . consName opts . addPre
-- symbols from Curry library -- symbols from Curry library
curryModule = "Curry" curryModule = "Curry.RunTimeSystem"
curryClass = "Curry"
cu = (,) curryModule cu = (,) curryModule
cusym = sym . cu cusym = sym . cu
......
...@@ -8,7 +8,7 @@ import System.IO ...@@ -8,7 +8,7 @@ import System.IO
import System.Directory (doesFileExist) import System.Directory (doesFileExist)
import Control.Monad (unless,when) import Control.Monad (unless,when)
import System.FilePath import System.FilePath
import System.Console.Readline
import CurryToHaskell import CurryToHaskell
import SafeCalls import SafeCalls
...@@ -17,7 +17,7 @@ import MetaProgramming.FlatCurryGoodies ...@@ -17,7 +17,7 @@ import MetaProgramming.FlatCurryGoodies
import ShowFlatCurry import ShowFlatCurry
import Config import Config
import Names import Names
import MyReadline
allFiles = map snd . files allFiles = map snd . files
loadedFiles = map snd . filter fst . files loadedFiles = map snd . filter fst . files
...@@ -69,7 +69,6 @@ main = do ...@@ -69,7 +69,6 @@ main = do
home <- getEnv "HOME" home <- getEnv "HOME"
(options,state) <- getOptions (options,state) <- getOptions
mapM_ (safe . put 1 options) welcome mapM_ (safe . put 1 options) welcome
unless (verbosity options==0) initializeReadline
let files = case filename options of let files = case filename options of
"" -> ["Prelude"] "" -> ["Prelude"]
fn -> [fn] fn -> [fn]
......
...@@ -4,4 +4,29 @@ ...@@ -4,4 +4,29 @@
,ForFunction "curryRuntime" ,ForFunction "curryRuntime"
,ForFunction "curryRuntimeMajorVersion" ,ForFunction "curryRuntimeMajorVersion"
,ForFunction "curryRuntimeMinorVersion" ,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