Commit e318b073 authored by Steffen Michels's avatar Steffen Michels

fix bug

parent e6552907
...@@ -38,6 +38,7 @@ where ...@@ -38,6 +38,7 @@ where
(ds, nbody) = (propBody ps isStrictArg newSet body) (ds, nbody) = (propBody ps isStrictArg newSet body)
nargs = map addStrictness args nargs = map addStrictness args
addStrictness var=:(TypedVar (GlobalVar _) _) = var
addStrictness var=:(TypedVar (StrictVar _ _) _) = var addStrictness var=:(TypedVar (StrictVar _ _) _) = var
addStrictness var=:(TypedVar (NormalVar vn _) _) = if (member vn ds) (toStrictVar var) var addStrictness var=:(TypedVar (NormalVar vn _) _) = if (member vn ds) (toStrictVar var) var
...@@ -105,6 +106,7 @@ where ...@@ -105,6 +106,7 @@ where
// Delete itself, it doesn't need any more // Delete itself, it doesn't need any more
walkbnd sd (SaplLetDef (TypedVar (StrictVar vn _) _) body) = delete vn (fst (walk sd body)) // skip new body, it cannot be a let definition walkbnd sd (SaplLetDef (TypedVar (StrictVar vn _) _) body) = delete vn (fst (walk sd body)) // skip new body, it cannot be a let definition
walkbnd sd (SaplLetDef (TypedVar (NormalVar vn _) _) body) = delete vn sd walkbnd sd (SaplLetDef (TypedVar (NormalVar vn _) _) body) = delete vn sd
walkbnd sd (SaplLetDef (TypedVar (GlobalVar vn) _) body) = delete vn sd
walk sd t = (sd, t) walk sd t = (sd, t)
......
...@@ -2,6 +2,7 @@ implementation module Sapl.SaplParser ...@@ -2,6 +2,7 @@ implementation module Sapl.SaplParser
import StdEnv, Data.Error import StdEnv, Data.Error
import Sapl.SaplTokenizer, Sapl.SaplStruct, Sapl.FastString import Sapl.SaplTokenizer, Sapl.SaplStruct, Sapl.FastString
import Sapl.Transform.VarReferences
from Data.Map import :: Map from Data.Map import :: Map
import qualified Data.Map as DM import qualified Data.Map as DM
...@@ -316,7 +317,7 @@ parse :: [PosToken] -> MaybeError ErrorMsg ([FuncType],ParserState) ...@@ -316,7 +317,7 @@ parse :: [PosToken] -> MaybeError ErrorMsg ([FuncType],ParserState)
parse pts parse pts
# ts = map (\(PosToken _ _ t) = t) pts # ts = map (\(PosToken _ _ t) = t) pts
= case (program ts []) defaultState of = case (program ts []) defaultState of
Ok ((fts, _),ps) = Ok (ps.ps_genFuns ++ fts,ps) Ok ((fts, _),ps) = Ok (fixReferences (ps.ps_genFuns ++ fts),ps)
Error (ts, msg) = let (lp, cp) = findpos ts in Error (msg+++" at line "+++toString lp+++" before character "+++toString cp) Error (ts, msg) = let (lp, cp) = findpos ts in Error (msg+++" at line "+++toString lp+++" before character "+++toString cp)
where where
findpos rest_ts findpos rest_ts
......
...@@ -30,6 +30,7 @@ import Data.Maybe ...@@ -30,6 +30,7 @@ import Data.Maybe
:: SaplVar = NormalVar SaplName Int :: SaplVar = NormalVar SaplName Int
| StrictVar SaplName Int | StrictVar SaplName Int
| GlobalVar SaplName
:: SaplTypedVar = TypedVar SaplVar SaplType :: SaplTypedVar = TypedVar SaplVar SaplType
......
...@@ -18,6 +18,7 @@ ltVarByNameLevel a b = unpackVar a < unpackVar b || (unpackVar a == unpackVar b ...@@ -18,6 +18,7 @@ ltVarByNameLevel a b = unpackVar a < unpackVar b || (unpackVar a == unpackVar b
unpackLevel (NormalVar _ level) = level unpackLevel (NormalVar _ level) = level
unpackLevel (StrictVar _ level) = level unpackLevel (StrictVar _ level) = level
unpackLevel (GlobalVar _) = 0
instance toString SaplVar instance toString SaplVar
where where
...@@ -25,6 +26,7 @@ where ...@@ -25,6 +26,7 @@ where
toString (NormalVar name level) = name +++ "_" +++ toString level toString (NormalVar name level) = name +++ "_" +++ toString level
toString (StrictVar name 0) = "!" +++ name toString (StrictVar name 0) = "!" +++ name
toString (StrictVar name level) = "!" +++ name +++ "_" +++ toString level toString (StrictVar name level) = "!" +++ name +++ "_" +++ toString level
toString (GlobalVar name) = name
removeTypeInfo :: !SaplTypedVar -> SaplVar removeTypeInfo :: !SaplTypedVar -> SaplVar
removeTypeInfo (TypedVar var _) = var removeTypeInfo (TypedVar var _) = var
...@@ -78,6 +80,7 @@ where ...@@ -78,6 +80,7 @@ where
unpackVar :: !SaplVar -> String unpackVar :: !SaplVar -> String
unpackVar (NormalVar name _) = name unpackVar (NormalVar name _) = name
unpackVar (StrictVar name _) = name unpackVar (StrictVar name _) = name
unpackVar (GlobalVar name) = name
instance unpackVar SaplTypedVar instance unpackVar SaplTypedVar
where where
......
...@@ -394,6 +394,8 @@ where ...@@ -394,6 +394,8 @@ where
instance TermCoder SaplVar instance TermCoder SaplVar
where where
forceTermCoder t=:(GlobalVar name) s a = forceTermCoder (NormalVar name 0) s a
forceTermCoder t=:(NormalVar name level) s a forceTermCoder t=:(NormalVar name level) s a
// Strict let definitions, strict arguments ... // Strict let definitions, strict arguments ...
| any (eqStrictVar name) s.cs_current_vars | any (eqStrictVar name) s.cs_current_vars
...@@ -416,6 +418,8 @@ where ...@@ -416,6 +418,8 @@ where
forceTermCoder (StrictVar name level) s a = forceTermCoder (NormalVar name level) s a forceTermCoder (StrictVar name level) s a = forceTermCoder (NormalVar name level) s a
trampolineCoder t=:(GlobalVar name) s a = forceTermCoder (NormalVar name 0) s a
trampolineCoder t=:(NormalVar name _) s a trampolineCoder t=:(NormalVar name _) s a
| isJust mbConstructor && constructor.nr_args == 0 | isJust mbConstructor && constructor.nr_args == 0
= constructorInliner t constructor [] s a = constructorInliner t constructor [] s a
...@@ -426,6 +430,8 @@ where ...@@ -426,6 +430,8 @@ where
trampolineCoder (StrictVar name level) s a = trampolineCoder (NormalVar name level) s a trampolineCoder (StrictVar name level) s a = trampolineCoder (NormalVar name level) s a
termCoder t=:(GlobalVar name) s a = forceTermCoder (NormalVar name 0) s a
termCoder t=:(NormalVar name level) s a termCoder t=:(NormalVar name level) s a
| isJust s.cs_inbody && not isLocalVar && isJust mbConstructor && constructor.nr_args == 0 | isJust s.cs_inbody && not isLocalVar && isJust mbConstructor && constructor.nr_args == 0
= constructorInliner t constructor [] s a = constructorInliner t constructor [] s a
...@@ -588,9 +594,9 @@ where ...@@ -588,9 +594,9 @@ where
Nothing Nothing
# (tr_function_args, args) = unzip setters # (tr_function_args, args) = unzip setters
= a <++ "var " <++ mta_1 tr_function_args args 0 s <++ ";" = a <++ "var " <++ mta_1 tr_function_args args 0 s <++ ";"
<++ mta_2 tr_function_args 0 s <++ "continue;" <++ mta_2 tr_function_args 0 s <++ "continue; /* 1 */"
// Reverse topological order is probably safe // Reverse topological order is probably safe
(Just ordered) = a <++ gen_setters (reverse ordered) s <++ "continue;" (Just ordered) = a <++ gen_setters (reverse ordered) s <++ "continue; /* 2 */"
where where
mta_1 [TypedVar (StrictVar _ _) _:fargs] [aa:aargs] i s a mta_1 [TypedVar (StrictVar _ _) _:fargs] [aa:aargs] i s a
......
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