Commit 5635af47 authored by László Domoszlai's avatar László Domoszlai

- data constructors with zero argument are CAFS now (variables in JS)

- fix a bug with cyclic let definitions 

git-svn-id: https://svn.cs.ru.nl/repos/clean-sapl/branches/hierarchical@383 cb785ff4-4565-4a15-8565-04c4fcf96d79
parent ef4e2631
......@@ -23,7 +23,6 @@ import StdEnv, Data.Maybe, Data.Void, Text.StringAppender, Data.Map, Sapl.FastSt
import Text.Unicode.Encodings.JS
import Sapl.SaplTokenizer, Sapl.SaplParser, Sapl.Target.Flavour
:: CoderState = { cs_inbody :: Maybe SaplVar // The body of the function which is being generated (not signature)
, cs_intrfunc :: Maybe SaplVar // The name of the currently generated function if it is tail recursive
, cs_inletdef :: Maybe [SaplVar] // used for generating cross referencing (e.g. recursive) lets. Normal only!!
......@@ -230,6 +229,11 @@ where
// Data constructor...
constructorCoder :: !SaplVar !Int ![SaplVar] CoderState !StringAppender -> StringAppender
// A zero argument data constructor is a CAF
constructorCoder name id [] s a
= a <++ "var " <++ escapeName s.cs_prefix (unpackVar name) <++ " = [" <++ id <++ ",'" <++ unpackVar name <++ "'];"
constructorCoder name id args s a
// Generate $eval function if any of its arguments is annotated as strict
# a = if (any isStrictVar args)
......@@ -248,11 +252,14 @@ constructorCoder name id args s a
= a <++ "var " <++ termCoder name s <++ "$n = " <++ "'" <++ unpackVar name <++ "';"
constructorInliner :: !SaplVar !ConstructorDef ![SaplTerm] !CoderState !StringAppender -> StringAppender
constructorInliner name def [] s a
= escapeName s.cs_prefix (unpackVar name) a
constructorInliner name def args s a
# a = a <++ "[" <++ def.index <++ "," <++ escapeName s.cs_prefix (unpackVar name) <++ "$n"
# a = case def.nr_args of
0 = a
= a <++ "," <++ argsCoder def.args args "," {s & cs_intrfunc = Nothing}
= a <++ "," <++ argsCoder def.args args "," {s & cs_intrfunc = Nothing}
= a <++ "]"
where
// Formal arguments, actual arguments
......@@ -358,7 +365,7 @@ where
trampolineCoder t=:(NormalVar name _) s a
| isJust mbConstructor && constructor.nr_args == 0
= a <++ escapeName s.cs_prefix name <++ "()"
= constructorInliner t constructor [] s a
= a <++ termCoder t s
where
mbConstructor = get name s.cs_constructors
......@@ -375,7 +382,7 @@ where
= a <++ "(" <++ inlineFun.fun (\t a = termCoder t s a) (\t a = forceTermCoder t s a) [] <++ ")"
| isJust s.cs_inbody && not isLocalVar && isJust mbCAF
= a <++ escapeName s.cs_prefix name
= a <++ escapeName s.cs_prefix name
| isJust s.cs_inbody && not isLocalVar && isStrictFunction
= a <++ escapeName s.cs_prefix name <++ "$eval"
......@@ -423,19 +430,20 @@ where
letDefCoder :: ![SaplLetDef] !CoderState !StringAppender -> StringAppender
letDefCoder [t] s a = termCoder t {s & cs_intrfunc = Nothing} a
letDefCoder [t:ts] s a
= a <++ termCoder newt {s & cs_intrfunc = Nothing} <++ "," <++ letDefCoder ts {s & cs_inletdef = Just rs,
cs_current_vars=[getVar newt: s.cs_current_vars]}
= a <++ termCoder t {s & cs_intrfunc = Nothing} <++ "," <++ letDefCoder ts {s & cs_inletdef = Just rs,
cs_current_vars=[getVar t: s.cs_current_vars]}
where
rs = tl (fromJust s.cs_inletdef) // remaining definitions
newt = deStrictIfNeeded t rs
getVar (SaplLetDef var _) = var
letDefCoder [] _ a = a
deStrictIfNeeded (SaplLetDef var body) vs | isDependent vs body
= SaplLetDef (toNormalVar var) body
deStrictIfNeeded def _ = def
deStrictIfNeeded [] [] = []
deStrictIfNeeded [d=:(SaplLetDef var body):ds] [_:vs]
| isDependent vs body
= [SaplLetDef (toNormalVar var) body:deStrictIfNeeded ds vs]
= [d:deStrictIfNeeded ds vs]
/*
* Determine wheter a given term is dependent on some of the variables given in the first argument.
* Used at let definition. For example:
......@@ -570,7 +578,8 @@ where
= addSwitch (termArrayCoder (map (\(p,b)=(p,b,False)) patterns) "" s) a
where
isSingleton cons = (get_cons_or_die s cons).singleton
addSwitch e a = a <++ "switch(ys[0]){" <++ e <++ "}"
addSwitch e a = a <++ "switch(ys[0]){" <++ e <++ "}"
termCoder (SSelect expr patterns) s a
= a <++ "switch(" <++ forceTermCoder expr {s & cs_intrfunc = Nothing} <++ "){"
<++ termArrayCoder (map (\(p,b)=(p,b,False)) patterns) "" s <++ "}"
......@@ -615,11 +624,12 @@ where
*/
termCoder (SLet body defs) s a
# s = pushArgs s defnames
= a <++ "var " <++ letDefCoder defs {s & cs_inletdef = Just normalnames} <++ ";\n "
= a <++ "var " <++ letDefCoder newdefs {s & cs_inletdef = Just normalnames} <++ ";\n "
<++ callWrapper body {s & cs_current_vars = defnames ++ s.cs_current_vars} <++ ";"
where
newdefs = deStrictIfNeeded defs normalnames
normalnames = map (toNormalVar o unpackBindVar) defs
defnames = map unpackBindVar defs
defnames = map unpackBindVar newdefs
generateJS :: !Flavour !Bool !String -> MaybeErrorString (StringAppender, ParserState)
generateJS f tramp saplsrc
......@@ -642,4 +652,3 @@ exprGenerateJS f tramp saplsrc mbPst
# a = termCoder body {state & cs_inbody=Just (NormalVar "__dummy" 0)} newAppender
= Ok a
Error msg = Error msg
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