Commit 82ddf17d authored by bbr's avatar bbr
Browse files

Merge branch 'HO_revision'

* HO_revision:
  interemediate message before io action
  a new concept for translating higher order
parents b4faf975 058097cf
......@@ -703,21 +703,20 @@ transExpr opts (Comb combType fname args)
= newExpr
where
newArgs = map (transExpr opts) args
partArgs i = newArgs ++ map (toVar' "v") [i,i-1 .. 1]
call = case combType of
ConsCall -> symApp (consName opts fname) newArgs
FuncCall -> symApp (funName fname) (addStateArg newArgs)
FuncPartCall i -> symApp (funName fname) (addStateArg (partArgs i))
ConsPartCall i -> symApp (consName opts fname) (partArgs i)
FuncPartCall i -> symApp (funName fname) newArgs
ConsPartCall i -> symApp (consName opts fname) newArgs
symApp s xs = fapp (C.Symbol s) xs
newExpr = case combType of
ConsCall -> call
FuncCall -> call
FuncPartCall i -> part opts i call
ConsPartCall i -> part opts i call
FuncPartCall i -> pf opts i call
ConsPartCall i -> pc opts i call
transExpr _ (Case _ _ _) = error "unlifted case"
......@@ -726,10 +725,6 @@ transLit opts (Charc c) = toChar opts c
transLit opts (Floatc f) = toFloat opts f
transLit opts (Intc i) = toInt opts i
part opts i e =
if i<2
then primValue opts (C.Lambda (addStatePat [toPVar' "v" 1]) e)
else primValue opts (C.Lambda [toPVar' "v" i, _x] (part opts (i-1) e))
transBranching :: CaseType -> ([VarIndex],[VarIndex]) -> Options -> QName ->
(QName -> QName) -> QName -> [BranchExpr] -> [C.Rule]
......@@ -1026,6 +1021,42 @@ addGlobalDefs opts gs [(s,b,prog)] = [(s,b,prog{C.funcDecls=gs'++C.funcDecls pro
-- constants and abbreviations for flat, resp. abstract curry
----------------------------------------------------------------
part opts i e =
if i<2
then primValue opts (C.Lambda (addStatePat [toPVar' "v" 1]) e)
else primValue opts (C.Lambda [toPVar' "v" i, _x] (part opts (i-1) e))
isPrelude :: Options -> Bool
isPrelude opts = currentModule opts=="Prelude"
-- partial function call, one argument missing
pf :: Options -> Int -> C.Expr -> C.Expr
pf opts = app . partial opts (fapp (extFuncPresym opts "pf"))
-- partial constructor call, one argument missing
pc :: Options -> Int -> C.Expr -> C.Expr
pc opts = app . partial opts (fapp (extFuncPresym opts "pc"))
-- partial application, more than one argument
pa :: Options -> [C.Expr] -> C.Expr
pa opts = fapp (extFuncPresym opts "pa")
-- function compostition (.)
cp :: Options -> [C.Expr] -> C.Expr
cp opts = fapp (extFuncPresym opts "cp")
partial :: Options -> ([C.Expr] -> C.Expr) -> Int -> C.Expr
partial opts part n
= foldr1 (\f g -> cp opts [f,g])
. map (\ (k,p) -> dotted opts (k-1) (p []))
$ reverse (zip (reverse [1..n]) (part:repeat (pa opts)))
-- add a lot of dots to compose part call functions
dotted :: Options -> Int -> C.Expr -> C.Expr
dotted opts n p
| n == 0 = p
| otherwise = dotted opts (n-1) (cp opts [p])
prelPCons opts s = C.PComb (consName opts ("Prelude",s))
pO opts x = prelPCons opts "O" [x]
......@@ -1141,11 +1172,6 @@ toList (x:xs) = app2 (C.Symbol ("",":")) x (toList xs)
toPList [] = C.PComb ("","[]") []
toPList (x:xs) = C.PComb ("",":") [x,toPList xs]
presym s = sym (pre s)
pre s = (instModName "Prelude",s)
hasPresym s = sym (has s)
has s = ("Prelude",s)
......@@ -1262,6 +1288,11 @@ qname_ (m,f) = string_ (m++'.':f)
extInstPresym True s = sym (extInstModName "Prelude",s)
extInstPresym False s = sym (modName "Prelude",s)
extFuncPresym opts s
| isPrelude opts = sym (extFuncModName "Prelude",s)
| otherwise = sym (modName "Prelude",s)
_x = C.PVar "_"
st = C.Var "st"
......
......@@ -405,6 +405,20 @@ apply (PrimOr r bs) x st = mapOr (\ f -> apply f x) r bs st
apply (PrimSusp r susp) x st = treatSusp (\ f -> apply f x) r susp st
apply cont _ st = patternFail "Prelude.apply" cont
-- these functions are employed for higher order
pf :: Curry b => (a -> Result b) -> Prim (a -> Result b)
pf = PrimValue
pc :: Curry b => (a -> b) -> (Prim (a -> Result b))
pc f = PrimValue (\ x _ -> f x)
pa :: Curry c => (a -> Prim (b -> Result c)) -> Prim (a -> Result (Prim (b -> Result c)))
pa f = PrimValue (\ x _ -> f x)
cp :: (b -> c) -> (a -> b) -> a -> c
cp f g x = f (g x)
cond :: Curry a => C_Success -> a -> Result a
cond C_Success x _ = x
cond s@(C_SuccessFreeVar _) x st = narrowCTC s (\_ _ -> x) st
......
......@@ -702,7 +702,6 @@ strEqFail s = C_False --C_SuccessFail (ErrorCall ("(=:=) for type "++s))
strEqSuccess :: StrEqResult
strEqSuccess = C_True
--hcAppend [] ys = ys
--hcAppend (x:xs) ys = x:< hcAppend xs ys
......
......@@ -291,6 +291,9 @@ ioLoop action = do state <- get
put $ state { past = emptyBoolStack,
stepmode = StepInteractive}
Prim term act <- action
liftIO $ putStrLn "initial action computed \
\press any key to execute." >>
getChar
b <- act
endState <- get
if sum (past endState) == 0
......
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