initial commit in git repository

INSTALL

+1. run make
+
+2. Hopefully, you will get the message that a file 
+.kicsrc has been written to your home directory. 
+You will need to edit this file according to your paths.
+
+3. run make again
\ No newline at end of file

Makefile

+BIN = bin/
+SRC = src/
+LIB = $(SRC)lib/
+DIST = dist/
+THIS = ../kics/
+KGHC = ghc --make -fglasgow-exts -i$(LIBS) -H500m
+GHC  = ghc --make -fglasgow-exts -i$(SRC)  -H500m
+LIBS = $(shell $(BIN)kicslib)
+
+all: $(SRC)InstallDir.hs $(BIN)generate $(BIN)kicslib $(BIN)kics $(BIN)kicsi libs
+
+.PHONY: tools
+tools: $(SRC)InstallDir.hs $(BIN)makeExternalInterface 
+
+$(BIN)generate: $(SRC)InstallDir.hs $(SRC)Generate.hs $(SRC)CurryToHaskell.hs
+	$(GHC) $(SRC)Generate.hs -o $(BIN)generate
+	cd $(SRC)
+	$(BIN)generate $(SRC)
+	cd ..
+
+$(SRC)InstallDir.hs: 
+	echo "module InstallDir where"  >  $(SRC)InstallDir.hs
+	echo "installDir = \""`pwd`"\"" >> $(SRC)InstallDir.hs
+
+$(BIN)kicslib: $(SRC)InstallDir.hs $(SRC)kicslib.hs $(SRC)Config.hs
+	mkdir -p bin 
+	ghc -fglasgow-exts -i$(SRC) --make $(SRC)kicslib -o $(BIN)kicslib
+
+$(BIN)makeExternalInterface: $(SRC)InstallDir.hs $(BIN)kicslib
+	$(KGHC) $(SRC)MakeExternalInterface -o $(BIN)makeExternalInterface
+
+$(BIN)kicsi: $(BIN)kicslib $(SRC)CurryToHaskell.hs $(SRC)kicsi.hs
+ifeq (,$(filter readline%,$(shell ghc-pkg list readline)))
+	@echo no readline package found
+	cp $(SRC)NoReadline.make $(SRC)MyReadline.hs
+else
+	@echo readline package found
+	cp $(SRC)WithReadline.make $(SRC)MyReadline.hs
+endif
+	$(KGHC) $(SRC)kicsi -o $(BIN)kicsi
+
+$(BIN)kics:  $(BIN)kicslib $(SRC)CurryToHaskell.hs
+	$(KGHC) $(SRC)kics -o $(BIN)kics
+
+.PHONY: runtime
+runtime: $(SRC)InstallDir.hs  
+	$(KGHC) --make $(SRC)Curry.hs
+
+.PHONY: libs 
+libs: $(BIN)kics runtime
+	$(BIN)kics -v -make $(LIB)All_Libraries
+
+.PHONY: clean
+clean:
+	rm -f *.o *.hi $(LIB)*.o $(LIB)*.hi $(SRC)*.o $(SRC)*.hi test/*.o test/*.hi
+
+.PHONY: mrproper
+mrproper: clean
+	rm -f $(SRC)InstallDir.hs
+	rm -f $(SRC)AutoGenerated*.hs
+	rm -f $(LIB)Curry*.hs $(LIB)Data*.hs $(LIB)Instances*.hs $(LIB)*.fcy $(LIB)*.fint\
+              test/Curry*.hs  test/Data*.hs  test/Instances*.hs  test/*.fcy  test/*.fint
+
+
+.PHONY: dist
+dist: 
+	mkdir -p dist
+	rm -f $(SRC)InstallDir.hs
+	tar czf $(THIS)$(DIST)kics_src.tgz\
+	  $(THIS)$(LIB)*.curry \
+	  $(THIS)$(LIB)/ExternalData*.hs \
+	  $(THIS)$(LIB)/ExternalInstances*.hs \
+	  $(THIS)$(LIB)/ExternalFunctions*.hs \
+	  $(THIS)$(LIB)/External*.spec \
+	  $(THIS)$(SRC)*.hs\
+	  $(THIS)$(SRC)*.make\
+	  $(THIS)Makefile $(THIS)INSTALL\
+	  $(THIS)$(BIN)kghc
+	cp $(THIS)$(DIST)kics_src.tgz ~/public_html/download/
+	chmod a+r ~/public_html/download/kics_src.tgz
+

bin/kghc

+#!/bin/sh
+
+export KICS_LIB=`kicslib`
+
+ghc  --make -fglasgow-exts -i$KICS_LIB $@
\ No newline at end of file

src/ArrayB.hs

+module ArrayB where 
+
+import GHC.Exts hiding (split)
+
+import Maybe
+-- Implementation of Arrays with Braun Trees
+
+infixl 9  ! 
+
+data ArrayB b = Entry (Maybe b) (ArrayB b) (ArrayB b)
+	      | Empty
+  deriving Eq
+
+emptyArrayB :: ArrayB b
+emptyArrayB = Entry Nothing emptyArrayB emptyArrayB
+
+emptyArrayB' :: Word# -> Word# -> ArrayB b
+emptyArrayB' b o =
+  Entry Nothing 
+	(emptyArrayB' (timesWord# (int2Word# 2#) b) o)
+        (emptyArrayB' (timesWord# (int2Word# 2#) b) (plusWord# o b))
+
+update :: ArrayB b -> Word# -> b -> ArrayB b
+update (Entry v al ar) n v'
+  | eqWord# n (int2Word# 0#) = Entry (Just v') al ar
+  | otherwise    = 
+      let r = and# n (int2Word# (1#)) in
+        if eqWord# (int2Word# 0#) r
+          then Entry v al (update ar (minusWord# (div2 n) (int2Word# 1#)) v')
+          else Entry v (update al (div2 n) v') ar
+
+div2 :: Word# -> Word#
+div2 n = shiftRL# n 1#
+
+(!) :: ArrayB b -> Word# -> (Maybe b)
+(Entry v al ar) !n 
+  | eqWord# n (int2Word# 0#) = v
+  | otherwise = let r = and# n (int2Word# (1#)) in
+        if eqWord# (int2Word# 0#) r
+          then ar!(minusWord# (div2 n) (int2Word# 1#))
+          else al!div2 n
+Empty ! n = Nothing
+
+split :: [a] -> ([a],[a])
+split [] = ([],[])
+split [x] = ([x],[])
+split (x:y:xys) = let (xs,ys) = split xys in
+                    (x:xs,y:ys)
+
+listToArrayB :: [b] -> ArrayB b
+listToArrayB xs = listToArrayB' (int2Word# 1#) (int2Word# 0#) xs
+
+listToArrayB' :: Word# -> Word# -> [b] -> ArrayB b
+listToArrayB' b o [] = Empty -- emptyArrayB' b o
+listToArrayB' b o (x:xs) = let (ys,zs) = split xs in
+                         Entry (Just x) (listToArrayB' (timesWord# (int2Word# 2#) b) o ys)
+                                        (listToArrayB' (timesWord# (int2Word# 2#) b) (plusWord# o b) zs)
+
+rows k [] = []
+rows k xs = let (ys,zs) = splitAt k xs in
+              (k,ys):rows (2*k) zs
+
+built (k,xs) ts = zipWith3 Entry xs ts1 ts2
+  where (ts1,ts2) = splitAt k (ts++repeat Empty)
+
+makeArray = head . foldr built [] . rows 1
+

src/AutoGenerated1.hs

+module AutoGenerated1 (module AutoGenerated1) where
+
+import Curry
+
+data Prim t0 = PrimValue t0
+  | PrimFreeVar (FreeVarRef (Prim t0))
+  | PrimFail C_Exceptions
+  | PrimOr OrRef (Branches (Prim t0))
+  | PrimSusp SuspRef (SuspCont (Prim t0))
+
+data C_Four = C_F0
+  | C_F1
+  | C_F2
+  | C_F3
+  | C_FourFreeVar (FreeVarRef C_Four)
+  | C_FourFail C_Exceptions
+  | C_FourOr OrRef (Branches C_Four)
+  | C_FourSusp SuspRef (SuspCont C_Four)
+  deriving (Eq)
+
+

src/AutoGenerated2.hs

+module AutoGenerated2 (module AutoGenerated2) where
+
+import Curry
+import DataPrelude
+
+instance BaseCurry C_Success where
+  nf f state x = f(state)(x)
+
+  gnf f state x = f(state)(x)
+
+  free _ = orsCTC([C_Success])
+
+  pattern _ = orsCTC([C_Success])
+
+  failed  = C_SuccessFail
+
+  freeVar  = C_SuccessFreeVar
+
+  branching  = C_SuccessOr
+
+  suspend  = C_SuccessSusp
+
+  consKind (C_SuccessFreeVar _) = Free
+  consKind (C_SuccessOr _ _) = Branching
+  consKind (C_SuccessFail _) = Failed
+  consKind (C_SuccessSusp _ _) = Suspended
+  consKind _ = Val
+
+  exceptions (C_SuccessFail x) = x
+
+  freeVarRef (C_SuccessFreeVar x) = x
+
+  orRef (C_SuccessOr x _) = x
+
+  branches (C_SuccessOr _ x) = x
+
+  suspRef (C_SuccessSusp x _) = x
+
+  suspCont (C_SuccessSusp _ x) = x
+
+
+
+
+
+instance BaseCurry C_Bool where
+  nf f state x = f(state)(x)
+
+  gnf f state x = f(state)(x)
+
+  free _ = orsCTC([C_True,C_False])
+
+  pattern _ = orsCTC([C_True,C_False])
+
+  failed  = C_BoolFail
+
+  freeVar  = C_BoolFreeVar
+
+  branching  = C_BoolOr
+
+  suspend  = C_BoolSusp
+
+  consKind (C_BoolFreeVar _) = Free
+  consKind (C_BoolOr _ _) = Branching
+  consKind (C_BoolFail _) = Failed
+  consKind (C_BoolSusp _ _) = Suspended
+  consKind _ = Val
+
+  exceptions (C_BoolFail x) = x
+
+  freeVarRef (C_BoolFreeVar x) = x
+
+  orRef (C_BoolOr x _) = x
+
+  branches (C_BoolOr _ x) = x
+
+  suspRef (C_BoolSusp x _) = x
+
+  suspCont (C_BoolSusp _ x) = x
+
+
+
+
+
+instance BaseCurry C_Four where
+  nf f state x = f(state)(x)
+
+  gnf f state x = f(state)(x)
+
+  free _ = orsCTC([C_F0,C_F1,C_F2,C_F3])
+
+  pattern _ = orsCTC([C_F0,C_F1,C_F2,C_F3])
+
+  failed  = C_FourFail
+
+  freeVar  = C_FourFreeVar
+
+  branching  = C_FourOr
+
+  suspend  = C_FourSusp
+
+  consKind (C_FourFreeVar _) = Free
+  consKind (C_FourOr _ _) = Branching
+  consKind (C_FourFail _) = Failed
+  consKind (C_FourSusp _ _) = Suspended
+  consKind _ = Val
+
+  exceptions (C_FourFail x) = x
+
+  freeVarRef (C_FourFreeVar x) = x
+
+  orRef (C_FourOr x _) = x
+
+  branches (C_FourOr _ x) = x
+
+  suspRef (C_FourSusp x _) = x
+
+  suspCont (C_FourSusp _ x) = x
+
+
+
+
+
+op_38_38 :: State -> C_Bool -> C_Bool -> C_Bool
+op_38_38 st x1@C_True x2 = x2
+op_38_38 st x1@C_False x2 = C_False
+op_38_38 st x@(C_BoolFreeVar ref) x2 = narrowCTC(st)(x)(\ st x -> op_38_38(st)(x)(x2))
+op_38_38 st (C_BoolOr i xs) x2 = mapOr(st)(\ st x -> op_38_38(st)(x)(x2))(i)(xs)
+op_38_38 st (C_BoolSusp ref susp) x2 = treatSusp(st)(\ st x -> op_38_38(st)(x)(x2))(ref)(susp)
+op_38_38 st x x2 = patternFail("Generate.&&")(x)
+
+

src/BaseCurry.hs

+module BaseCurry (module BaseCurry, module Store) where
+
+import Store
+import Data.IORef
+import System.IO.Unsafe
+
+-- On the top level io monad of each program we manage a store.
+-- Because there is unsafe io and because some operations on
+-- stores start out without one, a state might be without store.
+type State = Maybe Store
+
+-- curry data terms are classified into ConsKinds
+data ConsKind = Val | Free | Branching | Suspended | Failed deriving (Show,Eq)
+
+-- computations of (head) normal forms might residuate or not.
+type HNFMode = Bool
+
+-- for free vars
+data FreeVarRef a = FreeVarRef Int (IORef a) deriving Eq
+
+type Branches a = [a]
+
+-- for suspensions
+type SuspRef = Bool
+
+type SuspCont a = IORef (() -> Maybe a)
+
+data Exception 
+  = ErrorCall String
+  | PatternMatchFail String
+  | AssertionFailed String
+  | IOException String deriving Eq
+
+type C_Exceptions = Exception
+
+type Fun a b = State -> a -> b
+type Const a = State -> a
+
+----------------------------------------------------------------
+-- the BaseCurry class
+----------------------------------------------------------------
+
+class BaseCurry a where
+  -- computations of normal forms
+  nf   :: BaseCurry b => (State -> a -> b) -> State -> a -> b
+  gnf  :: BaseCurry b => (State -> a -> b) -> State -> a -> b
+
+  -- constructors
+  free      :: () -> a
+  pattern   :: () -> a
+  failed    :: C_Exceptions          -> a
+  freeVar   :: FreeVarRef a          -> a
+  branching :: OrRef   -> Branches a -> a
+  suspend   :: SuspRef -> SuspCont a -> a
+
+  -- category of given constructor
+  consKind :: a -> ConsKind
+
+  -- selectors
+  exceptions :: a -> C_Exceptions
+  freeVarRef :: a -> FreeVarRef a
+  orRef      :: a -> OrRef
+  branches   :: a -> Branches a
+  suspRef    :: a -> SuspRef
+  suspCont   :: a -> SuspCont a
+
+-----------------------------------------
+-- reading bindings for free variables
+-----------------------------------------
+
+binding :: BaseCurry a => a -> Either a a
+binding v = unsafePerformIO (ioBinding v)
+
+ioBinding :: BaseCurry a => a -> IO (Either a a)
+ioBinding v = do
+      let FreeVarRef _ ref = freeVarRef v
+      b <- readIORef ref
+      case consKind b of
+        Failed -> return (Left v)
+        Free   -> ioBinding b
+        _      -> return (Right b)
+
+bind :: FreeVarRef a -> a -> b -> b
+bind v val res = unsafePerformIO $ do
+  let FreeVarRef _ ref = v
+  writeIORef ref val
+  return res
+
+------------------------------------------------------------------
+-- implementation of call-time choice
+------------------------------------------------------------------
+
+-- This function controls all kinds of evaluations to (head) normal forms
+-- IMPORTANT: if you change anything here, also update ExternalPrelude.prim_do
+ctcStore :: (BaseCurry a,BaseCurry b) => HNFMode -> (State -> a -> b) -> State -> a -> b
+ctcStore mode cont state x = 
+  case consKind x of
+   -- cases solvable without store
+   Val       -> cont state x
+   Failed    -> addException (curryError ("Prelude."++if mode then "$#" else "$!")) x
+   Branching -> let ref = orRef x 
+                    bs  = branches x 
+                 in case state of
+                   Nothing    -> mapOr state (ctcStore mode cont) ref bs
+                   Just store -> case fromStore store ref of 
+                       Nothing -> branching ref 
+                                    (zipWith (ctcBranch contCTC store ref) [0..] bs)
+                       Just i  -> ctcStore mode cont state (bs!!i)
+
+   Free      -> let ref = freeVarRef x in
+                       case binding x of
+                         Left x'  -> if mode then suspCTC Nothing (freeVarRef x') susp
+                                             else cont state x'
+                         Right v  -> ctcStore mode cont state v
+
+   Suspended  -> treatSusp state (ctcStore mode cont) (suspRef x) (suspCont x)
+   {--- now we need to have the store
+   conskind  -> case state of
+     Nothing -> fetchState (\st -> ctcStore mode cont st x)
+     Just store -> case conskind of
+        Suspended -> wakeUp contCTC (suspCont x) store-}
+
+  where
+    contCTC st = ctcStore mode cont (Just st)
+    susp = ctcStore mode cont 
+
+{-
+-- It can happen that computations suspend twice in a row, e.g.:
+-- let x,y free in x=:=1 &> y=:=2 &> (x+y)
+-- that is what the SuspRef is needed for: Newly created suspensions have
+-- a SuspRef=True, old ones a false susp ref. 
+-- Thus, when waking suspensions we need to repeat the process 
+-- until the susp ref is false (or we got a value).
+wakeUp :: (BaseCurry a,BaseCurry b) => (Store -> a -> b) -> (SuspCont a) -> SuspCont b
+wakeUp cont susp store = let x = susp store in
+  case consKind x of
+    Suspended -> if suspRef x then wakeUp cont (suspCont x) store
+                              else suspend False (wakeUp cont (suspCont x))
+    _         -> cont store x
+
+-- if we cannot find a binding in the store its still the old suspension.
+findBind :: (BaseCurry a,BaseCurry b) => (Store -> a -> b) -> a -> SuspCont b
+findBind cont ref store = 
+  either (suspend False . findBind cont) (cont store) (binding ref)
+-}
+suspCTC :: (BaseCurry a,BaseCurry b) => State -> FreeVarRef a -> (State -> a -> b) -> b
+suspCTC st ref cont = unsafePerformIO $ do
+  sr <- newIORef undefined
+  writeIORef sr (susp sr)
+  return (suspend True sr)
+  where
+    susp sr _ = unsafePerformIO $ do
+                b <- ioBinding (freeVar ref)
+                case b of
+                  Left _ -> return Nothing 
+                  Right v -> do
+                    let result = Just (cont st v)
+                    writeIORef sr (const result)
+                    return result
+
+-- TODO: use state! also above! 
+-- maybe look at test susp: new state?
+treatSusp :: (BaseCurry a,BaseCurry b) => State -> (State->a->b) -> SuspRef -> SuspCont a -> b
+treatSusp st cont ref susp = unsafePerformIO $ do
+       waker <- readIORef susp
+       case waker () of
+         Just v  -> return (cont st v)
+         Nothing -> do
+           sr <- newIORef undefined
+           writeIORef sr (testSusp sr)
+           return (suspend ref sr)
+
+  where
+    testSusp sr _ = unsafePerformIO $ do
+       waker <- readIORef susp
+       case waker () of
+         Nothing -> return Nothing
+         Just v  ->  do
+                    let result = Just (cont st v)
+                    writeIORef sr (const result)
+                    return result
+
+{-
+-- retrieve state
+-- As this suspension can directly be lifted upon getting the state, there
+-- is no need to create a "suspend False" in any case.
+fetchState :: BaseCurry a => (State -> a) -> a
+fetchState cont = suspend True (cont . Just)
+-}
+
+-- pulling continuations into each branch of an or
+ctcBranch :: (BaseCurry a, BaseCurry b) => 
+  (Store -> b -> a) -> Store -> OrRef -> Int -> b -> a
+ctcBranch cont store orRef nr x = 
+  let newStore = addToStore store orRef nr in 
+  cont newStore x
+
+-- pull continuations into branches without modifying a store
+-- TODO: add right number to state!
+mapOr :: (BaseCurry a,BaseCurry b) => State -> (State -> a -> b) -> OrRef -> Branches a -> b
+mapOr Nothing f ref bs = mapOr (Just emptyStore) f ref bs
+mapOr st@(Just store) f ref bs = case fromStore store ref of 
+                       Nothing -> branching ref 
+                                    (zipWith (ctcBranch (f . Just) store ref) [0..] bs)
+                       Just i  -> f st (bs!!i)
+
+addException :: (BaseCurry a,BaseCurry b) => Exception -> a -> b
+addException _ x = failed (exceptions x)
+
+curryError :: String -> Exception
+curryError = ErrorCall 
+
+

src/Brace.hs

+module Brace where
+
+import List
+
+separate :: [a] -> [[a]] -> [a] 
+separate s xs = concat (intersperse s (filter (not . null) xs))
+
+brace :: [a] -> [a] -> [a] -> [[a]] -> [a] 
+brace _ _ _ [] = []
+brace begin end sep xs = begin++separate sep xs++end

src/Config.hs

+module Config where
+
+import InstallDir
+import SafeCalls
+import XML
+import Char
+import System.Environment
+import System.Directory hiding (executable)
+import System.Time
+import List
+import FlatCurry(readFlatCurry)
+import Names
+
+getOptions :: IO Options 
+getOptions = do 
+  (opts,_) <- readConfig
+  args <- getArgs
+  let newOpts = parseOptions opts args
+  either usage return newOpts
+
+parseOptions :: Options -> [String] -> Either String Options
+parseOptions opts [] = Left "no file name given" 
+parseOptions opts [x] = Right (opts{filename=x,mainModule=x})
+parseOptions opts ("-or":xs) = parseOptions (opts{cm=OrBased}) xs
+parseOptions opts ("-ctc":xs) = parseOptions (opts{cm=CTC}) xs
+parseOptions opts ("-main":x:xs) = parseOptions (opts{mainFunc=x}) xs
+parseOptions opts ("-frontend":x:xs) = parseOptions (opts{frontend=x}) xs
+parseOptions opts ("-kicspath":x:xs) = parseOptions (opts{kicspath=x}) xs
+parseOptions opts ("-userlibpath":x:xs) = parseOptions (opts{userlibpath=x}) xs
+parseOptions opts ("-ghc":x:xs) = parseOptions (opts{ghc=x}) xs
+parseOptions opts ("-frontendCall":x:xs) = parseOptions (opts{frontendCall=x}) xs
+parseOptions opts ("-make":xs) = parseOptions (opts{make=True}) xs
+parseOptions opts ("-nomake":xs) = parseOptions (opts{make=False}) xs
+parseOptions opts ("-executable":xs) = parseOptions (opts{executable=True}) xs
+parseOptions opts ("-noexecutable":xs) = parseOptions (opts{executable=False}) xs
+parseOptions opts ("-q":xs) = parseOptions (opts{verbose=False}) xs
+parseOptions opts ("-v":xs) = parseOptions (opts{verbose=True}) xs
+parseOptions opts ("-noforce":xs) = parseOptions (opts{force=False}) xs
+parseOptions opts ("-force":xs) = parseOptions (opts{force=True}) xs
+parseOptions opts ("-all":"df":xs) = parseOptions (opts{pm=All DF}) xs
+parseOptions opts ("-all":"bf":xs) = parseOptions (opts{pm=All BF}) xs
+parseOptions opts ("-st":xs) = parseOptions (opts{pm=ST}) xs
+parseOptions opts ("-i":"df":xs) = parseOptions (opts{pm=Interactive DF}) xs
+parseOptions opts ("-i":"bf":xs) = parseOptions (opts{pm=Interactive BF}) xs
+parseOptions opts ("-o":x:xs) = parseOptions (opts{target=x}) xs
+parseOptions _    (x:_) = Left ("unrecognized option: "++x)
+
+usage problem = do
+  putStrLn problem
+  putStrLn "Usage: kics [options] filename"
+  putStrLn "option        | meaning"
+  putStrLn "-rtc          | switch to run  time choice"
+  putStrLn "-ctc          | switch to call time choice"
+  putStrLn "-main         | name of main function "
+  putStrLn "-frontend     | path to frontend"
+  putStrLn "-kicspath     | path to kics compiler"
+  putStrLn "-userlibpath  | path to curry libraries"
+  putStrLn "-ghc          | path to ghc"
+  putStrLn "-frontendCall | name of frontend"
+  putStrLn "-make         | chase imported modules"
+  putStrLn "-nomake       | do not chase imported modules"
+  putStrLn "-executable   | create executable"
+  putStrLn "-noexecutable | do not create executable"
+  putStrLn "-v            | verbose output"
+  putStrLn "-q            | scarce output"
+  putStrLn "-force        | force recompilation"
+  putStrLn "-noforce      | do not force recompilation"