Commit 109a4f7e authored by László Domoszlai's avatar László Domoszlai

- fix array handling in Clean SAPL

- enable again cylic let definitions 
- small fixes

git-svn-id: https://svn.cs.ru.nl/repos/clean-sapl/branches/hierarchical@427 cb785ff4-4565-4a15-8565-04c4fcf96d79
parent 36b12cb3
......@@ -55,3 +55,11 @@ charIndexBackwards :: !String !Int !Char -> (!Bool,!Int)
*/
matchAt :: !String !String !Int -> Bool
/**
* Count the number of characters in a sequence from the end of the string
* E.g.: counCharBackwards '.' ".a.a..." gives 3
*
* @param The char that is being searched.
* @param The string that is being searched.
*/
countCharBackwards :: !Char !String -> Int
......@@ -60,3 +60,12 @@ matchAt s1 s2 p
= False
= and [s1.[i] == s2.[p + i] \\ i <- [0..((size s1) - 1)]]
countCharBackwards :: !Char !String -> Int
countCharBackwards chr str
= count ((size str)-1)
where
count -1
= 0
count pos | str.[pos] == chr
= 1 + count (pos-1)
= 0
......@@ -291,7 +291,8 @@ mergeParserStates pst1 (Just pst2)
= {pst1 &
ps_constructors = mergeMaps pst2.ps_constructors pst1.ps_constructors,
ps_functions = mergeMaps pst2.ps_functions pst1.ps_functions,
ps_CAFs = mergeMaps pst2.ps_CAFs pst1.ps_CAFs}
ps_CAFs = mergeMaps pst2.ps_CAFs pst1.ps_CAFs,
ps_genFuns = []}
where
mergeMaps m1 m2 = putList (toList m2) m1
......
......@@ -2,9 +2,9 @@ implementation module Sapl.Target.JS.CodeGeneratorJS
/* TODO:
*
* 1. Cyclical let definitions are not allowed. Putting the reference o the later binding into
* an anonymous function as a closure cannot work all the time. It can easily break
* when tail recursion is involved around the let expression (scoping problem).
* - Cyclical let definitions are not handled correctly:
* 1. strictness should be removed from the definition which references the later one
* 2. tail recursion optimization shouldn't be used in the function which has cyclical let definitions (scoping problem)
*
*/
......@@ -17,7 +17,7 @@ from Data.List import elem_by, partition
:: 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 // for finding out about let-rec
, cs_futuredefs :: ![SaplVar] // for finding out about let-rec and let bindings defined later
, cs_incaseexpr :: !Bool
, cs_current_vars :: ![SaplVar] // Strict, Normal
, cs_constructors :: !Map String ConstructorDef
......@@ -33,7 +33,7 @@ newState :: !Flavour !Bool !ParserState -> CoderState
newState f tramp p =
{ cs_inbody = Nothing
, cs_intrfunc = Nothing
, cs_inletdef = Nothing
, cs_futuredefs = []
, cs_incaseexpr = False
, cs_current_vars = []
, cs_constructors = p.ps_constructors
......@@ -227,7 +227,7 @@ constructorCoder :: !SaplVar !Int ![SaplVar] CoderState !StringAppender -> Strin
// A zero argument data constructor is a CAF
constructorCoder name id [] s a
= a <++ "var " <++ escapeName s.cs_prefix (unpackVar name) <++ " = [" <++ id <++ ",'" <++ unpackVar name <++ "'];"
= 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
......@@ -244,7 +244,7 @@ constructorCoder name id args s a
= a <++ "," <++ termArrayCoder newargs "," s
# a = a <++ "];};"
= a <++ "var " <++ termCoder name s <++ "$n = " <++ "'" <++ unpackVar name <++ "';"
= a <++ "var " <++ termCoder name s <++ "$n = \"" <++ unpackVar name <++ "\";"
constructorInliner :: !SaplVar !ConstructorDef ![SaplTerm] !CoderState !StringAppender -> StringAppender
constructorInliner name def [] s a
......@@ -407,7 +407,7 @@ where
= a <++ escapeName s.cs_prefix name <++ "$eval"
// else (TODO: probably bogus in tail-recursion...)
| isJust s.cs_inletdef && eqVarByNameLevel t (fromJust s.cs_inletdef)
| any (eqVarByNameLevel t) s.cs_futuredefs
= a <++ "[function(){return " <++ force var_name <++ ";},[]]"
// else: use the defined name if its a built-in function, otherwise its a variable...
......@@ -447,17 +447,25 @@ where
* {s & cs_intrfunc = Nothing}
*/
letDefCoder :: ![SaplLetDef] !CoderState !StringAppender -> StringAppender
letDefCoder [t] s a = termCoder t {s & cs_intrfunc = Nothing} a
letDefCoder [t:ts] s a
= a <++ termCoder t {s & cs_intrfunc = Nothing} <++ "," <++ letDefCoder ts {s & cs_current_vars=[unpackBindVar t: s.cs_current_vars]}
letDefCoder [t] s a = termCoder t {s & cs_intrfunc = Nothing, cs_futuredefs=[toNormalVar (unpackBindVar t)]} a
letDefCoder all=:[t:ts] s a
= a <++ termCoder t {s & cs_intrfunc = Nothing, cs_futuredefs=fvs} <++ ","
<++ letDefCoder ts {s & cs_current_vars=[unpackBindVar t: s.cs_current_vars]}
where
fvs = map (toNormalVar o unpackBindVar) all
letDefCoder [] _ a = a
isDependent :: ![SaplVar] !SaplTerm -> Bool
isDependent vs (SApplication f as) = any (isDependent vs) [SVar f:as]
isDependent vs (SVar v) = elem_by eqVarByNameLevel v vs
isDependent _ _ = False
instance TermCoder SaplLetDef
where
termCoder (SaplLetDef name body) s a
= a <++ termCoder name {s & cs_inletdef = Nothing} <++ "="
<++ (if (isStrictVar name) forceTermCoder termCoder) body {s & cs_inletdef = Just name}
= a <++ termCoder name {s & cs_futuredefs = []} <++ "="
<++ (if (isStrictVar name) forceTermCoder termCoder) body s
forceTermCoder t s a = termCoder t s a
trampolineCoder t s a = termCoder t s a
......@@ -660,7 +668,8 @@ where
where
newdefs = case sortBindings defs of
Just ds = ds
Nothing = abort ("Cycle in let definitions is detected in function "+++toString (fromJust s.cs_inbody)+++"\n") // This is not supported currently
Nothing = defs
//Nothing = abort ("Cycle in let definitions is detected in function "+++toString (fromJust s.cs_inbody)+++"\n") // This is not supported currently
defnames = map unpackBindVar newdefs
......@@ -686,5 +695,4 @@ exprGenerateJS f tramp saplsrc mbPst out
# out = foldl (\a curr = a <++ funcCoder curr state) out s.ps_genFuns
= Ok (toString a, out, newpst)
Error msg = Error msg
\ No newline at end of file
......@@ -3,5 +3,5 @@ definition module Sapl.Transform.Let
import Data.Maybe
from Sapl.SaplStruct import :: SaplVar, :: SaplLetDef
// Topological sort of the let definitions. Return Nothing if a cycle is detected
// Topological sort of the let definitions. Returns Nothing if a cycle is detected
sortBindings :: ![SaplLetDef] -> Maybe [SaplLetDef]
......@@ -288,31 +288,31 @@
"sapl_fun":"array_select_lazy",
"arity":2,
"ext_fun":"_array_select_lazy",
"inline_exp":"Sapl.feval(:!1:[:!2:])"
"inline_exp":"Sapl.feval(:!1:[:!2:+2])"
},
{
"sapl_fun":"array_select",
"arity":2,
"ext_fun":"_array_select",
"inline_exp":":!1:[:!2:]"
"inline_exp":":!1:[:!2:+2]"
},
{
"sapl_fun":"array_uselect",
"arity":2,
"ext_fun":"_array_uselect",
"inline_exp":"[0, '_Tuple2',:!1:[:!2:],:1:]"
"inline_exp":"[0, '_Tuple2',:!1:[:!2:+2],:1:]"
},
{
"sapl_fun":"array_size",
"arity":1,
"ext_fun":"_array_size",
"inline_exp":":!1:.length"
"inline_exp":":!1:.length-2"
},
{
"sapl_fun":"array_usize",
"arity":1,
"ext_fun":"_array_usize",
"inline_exp":"[0, '_Tuple2',:!1:.length,:1:]"
"inline_exp":"[0, '_Tuple2',:!1:.length-2,:1:]"
},
{
"sapl_fun":"abort",
......
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