Commit e318b073 authored by Steffen Michels's avatar Steffen Michels

fix bug

parent e6552907
......@@ -38,6 +38,7 @@ where
(ds, nbody) = (propBody ps isStrictArg newSet body)
nargs = map addStrictness args
addStrictness var=:(TypedVar (GlobalVar _) _) = var
addStrictness var=:(TypedVar (StrictVar _ _) _) = var
addStrictness var=:(TypedVar (NormalVar vn _) _) = if (member vn ds) (toStrictVar var) var
......@@ -105,6 +106,7 @@ where
// 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 (NormalVar vn _) _) body) = delete vn sd
walkbnd sd (SaplLetDef (TypedVar (GlobalVar vn) _) body) = delete vn sd
walk sd t = (sd, t)
......
......@@ -2,6 +2,7 @@ implementation module Sapl.SaplParser
import StdEnv, Data.Error
import Sapl.SaplTokenizer, Sapl.SaplStruct, Sapl.FastString
import Sapl.Transform.VarReferences
from Data.Map import :: Map
import qualified Data.Map as DM
......@@ -316,7 +317,7 @@ parse :: [PosToken] -> MaybeError ErrorMsg ([FuncType],ParserState)
parse pts
# ts = map (\(PosToken _ _ t) = t) pts
= 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)
where
findpos rest_ts
......
......@@ -30,6 +30,7 @@ import Data.Maybe
:: SaplVar = NormalVar SaplName Int
| StrictVar SaplName Int
| GlobalVar SaplName
:: SaplTypedVar = TypedVar SaplVar SaplType
......
......@@ -18,6 +18,7 @@ ltVarByNameLevel a b = unpackVar a < unpackVar b || (unpackVar a == unpackVar b
unpackLevel (NormalVar _ level) = level
unpackLevel (StrictVar _ level) = level
unpackLevel (GlobalVar _) = 0
instance toString SaplVar
where
......@@ -25,6 +26,7 @@ where
toString (NormalVar name level) = name +++ "_" +++ toString level
toString (StrictVar name 0) = "!" +++ name
toString (StrictVar name level) = "!" +++ name +++ "_" +++ toString level
toString (GlobalVar name) = name
removeTypeInfo :: !SaplTypedVar -> SaplVar
removeTypeInfo (TypedVar var _) = var
......@@ -78,6 +80,7 @@ where
unpackVar :: !SaplVar -> String
unpackVar (NormalVar name _) = name
unpackVar (StrictVar name _) = name
unpackVar (GlobalVar name) = name
instance unpackVar SaplTypedVar
where
......
......@@ -394,6 +394,8 @@ where
instance TermCoder SaplVar
where
forceTermCoder t=:(GlobalVar name) s a = forceTermCoder (NormalVar name 0) s a
forceTermCoder t=:(NormalVar name level) s a
// Strict let definitions, strict arguments ...
| any (eqStrictVar name) s.cs_current_vars
......@@ -416,6 +418,8 @@ where
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
| isJust mbConstructor && constructor.nr_args == 0
= constructorInliner t constructor [] s a
......@@ -426,6 +430,8 @@ where
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
| isJust s.cs_inbody && not isLocalVar && isJust mbConstructor && constructor.nr_args == 0
= constructorInliner t constructor [] s a
......@@ -588,9 +594,9 @@ where
Nothing
# (tr_function_args, args) = unzip setters
= 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
(Just ordered) = a <++ gen_setters (reverse ordered) s <++ "continue;"
(Just ordered) = a <++ gen_setters (reverse ordered) s <++ "continue; /* 2 */"
where
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