Skip to content

GitLab

C
clean-sapl
Commit 9f0a3584 authored by Laszlo Domoszlai's avatar Laszlo Domoszlai
Browse files
Options

compiler to the new SAPL

parent 484fb866
Hide whitespace changes
Inline Side-by-side
Showing with 281 additions and 133 deletions
src/Sapl/Optimization/StrictnessPropagation.icl
View file @ 9f0a3584
......@@ -47,8 +47,13 @@ propBody ps flavour sd body = walk sd body
where
walk sd t=:(SVar var) = (insert (unpackVar var) sd, t)
walk sd t=:(SApplication var args)
// We can skip the new args, cannot contain let definitions...
// We can skip the new expr, cannot contain let definitions...
walk sd t=:(SSelect expr idx)
# (sd, _) = walk sd expr
= (sd, t)
// We can skip the new args, cannot contain let definitions...
walk sd t=:(SApplication (SVar var) args)
# nsds = map fst (map (walk newSet) strictArgs)
= (unions [sd:nsds], t)
where
......@@ -57,16 +62,17 @@ where
checkArg (arg, i) = isStrictArg ps flavour varName nr_args i
strictArgs = map fst (filter checkArg (zip2 args [0..]))
walk sd (SIf c l r)
# (sdl, nl) = walk newSet l
# (sdr, nr) = walk newSet r
# (sdc, nc) = walk sd c
= (union sdc (intersection sdl sdr), SIf nc nl nr)
// We can skip the new expr, cannot contain let definitions...
// Args cannot be checked, we do not know the function defiition...
walk sd t=:(SApplication expr args)
// expr is always strict
# (sd, _) = walk sd expr
= (sd, t)
walk sd (SSelect p cases)
walk sd (SCase p cases)
# (sdp, np) = walk sd p
# (sdcs, ncases) = unzip (map walkcase cases)
= (union sdp (intersections sdcs), SSelect np ncases)
= (union sdp (intersections sdcs), SCase np ncases)
where
walkcase (p, c)
# (sd, nc) = walk newSet c
......@@ -89,7 +95,7 @@ where
where
vn = unpackVar (unpackBindVar bnd)
// Delete itself, it dosn'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 (NormalVar vn _) _) body) = delete vn sd
......
src/Sapl/SaplParser.dcl
View file @ 9f0a3584
......@@ -49,4 +49,3 @@ parseExpr :: [PosToken] -> MaybeError ErrorMsg (SaplTerm, ParserState)
* @return merged parser state
*/
mergeParserStates :: ParserState (Maybe ParserState) -> ParserState
src/Sapl/SaplParser.icl
View file @ 9f0a3584
......@@ -63,98 +63,110 @@ where
addTupleCons _ = returnS Void
factor [TIdentifier name:ts] = getLevel >>= \level = returnS (Just (SVar (NormalVar name level)), ts)
factor [TLit lit:ts] = returnS (Just (SLit lit), ts)
factor [TOpenParenthesis:ts] =
application ts
read_int [TLit (LInt lit):ts] = returnS (Just lit, ts)
read_int ts = returnS (Nothing, ts)
expr [TOpenParenthesis:ts] =
mexpr ts
>>= \(t, ts) = case hd ts of
TCloseParenthesis = returnS (Just t, tl ts)
= returnE (ts, "Missing close parenthesis")
factor ts = returnS (Nothing, ts)
= returnE (ts, "Missing close parenthesisx")
application [TOpenParenthesis:ts] =
application ts
>>= \(t, ts) = case hd ts of
TCloseParenthesis = returnS (t, tl ts)
= returnE (ts, "Missing close parenthesis")
expr [TLit lit:ts] = returnS (Just (SLit lit), ts)
application [TIdentifier name:ts] =
expr [TIdentifier name:ts] =
getLevel
>>= \level = returnS (NormalVar name level)
>>= \t = addTupleCons name
>>= \_ = args_factor ts
>>= \_ = args_expr ts
>>= \(as, ts) = case as of
[] = returnS (SVar t, ts) // !!!
= returnS (SApplication t as, ts)
application [TLit lit:ts] = returnS (SLit lit, ts)
application ts = returnE (ts, "Invalid application")
selectexpr [TIfKeyword:ts] =
arg_adv ts
>>= mandatory "Missing predicate"
>>= \(pred, ts) = arg_adv ts
>>= mandatory "Missing left hand side"
>>= \(lhs, ts) = arg_adv ts
>>= mandatory "Missing right hand side"
>>= \(rhs, ts) = returnS (Just (SIf pred lhs rhs), ts)
selectexpr [TSelectKeyword:ts] =
arg_adv ts
>>= mandatory "Missing select expression"
>>= \(expr, ts) = args_pattern ts
>>= \(ps, ts) = if (isEmpty ps)
(returnE (ts, "Missing select patterns"))
(returnS (Just (SSelect expr ps), ts))
selectexpr ts = returnS (Nothing, ts)
[] = returnS (Just (SVar t), ts)
= returnS (Just (SApplication (SVar t) as), ts)
expr [TSelectKeyword:ts] =
sexpr ts
>>= mandatory "Missing select expression"
>>= \(expr, ts) = read_int ts
>>= mandatory "Missing select index"
>>= \(idx, ts) = args_expr ts
>>= \(as, ts) = case as of
[] = returnS (Just (SSelect expr idx), ts)
= returnS (Just (SApplication (SSelect expr idx) as), ts)
expr ts = returnS (Nothing, ts)
sexpr [TOpenParenthesis:ts] =
mexpr ts
>>= \(t, ts) = case hd ts of
TCloseParenthesis = returnS (Just t, tl ts)
= returnE (ts, "Missing close parenthesisx")
mainexpr ts = selectexpr ts
>>= \(t, ts) = case t of
Just t = returnS (t, ts)
= application ts
sexpr [TLit lit:ts] = returnS (Just (SLit lit), ts)
sexpr [TIdentifier name:ts] =
getLevel
>>= \level = returnS (NormalVar name level)
>>= \t = addTupleCons name
>>= \_ = returnS (Just (SVar t), ts)
sexpr ts = returnS (Nothing, ts)
mexpr ts = expr ts >>= mandatory "Missing expression"
letdefinitions ts = letdef_1 ts []
where
letdef_1 [TIdentifier name, TTypeDef, TIdentifier type, TAssignmentOp:ts] as =
getLevel
>>= \level = application ts
>>= \level = body False ts
>>= \(t, ts) = letdef_2 ts [SaplLetDef (TypedVar (NormalVar name level) (Type type)) t:as]
letdef_1 [TIdentifier name, TAssignmentOp:ts] as =
getLevel
>>= \level = application ts
>>= \level = body False ts
>>= \(t, ts) = letdef_2 ts [SaplLetDef (TypedVar (NormalVar name level) NoType) t:as]
letdef_1 [TStrictIdentifier name, TTypeDef, TIdentifier type, TAssignmentOp:ts] as =
getLevel
>>= \level = application ts
>>= \level = body False ts
>>= \(t, ts) = letdef_2 ts [SaplLetDef (TypedVar (StrictVar name level) (Type type)) t:as]
letdef_1 [TStrictIdentifier name, TAssignmentOp:ts] as =
getLevel
>>= \level = application ts
>>= \level = body False ts
>>= \(t, ts) = letdef_2 ts [SaplLetDef (TypedVar (StrictVar name level) NoType) t:as]
letdef_1 ts as = returnE (ts, "Invalid \"let\" definition")
letdef_2 [TColon: ts] as = letdef_1 ts as
letdef_2 ts as = returnS (reverse as, ts)
body [TLetKeyword:ts] =
body simple [TOpenParenthesis:ts] =
body False ts
>>= \(t, ts) = case hd ts of
TCloseParenthesis = returnS (t, tl ts)
= returnE (ts, "Missing close parenthesis")
body simple [TLetKeyword:ts] =
incLevel ts
>>= \ts = letdefinitions ts
>>= \(ds, ts) = case hd ts of
TInKeyword = returnS (tl ts)
= returnE (ts, "Missing \"in\" keyword")
>>= \ts = mainexpr ts
>>= \ts = body False ts
>>= \(t, ts) = returnS (SLet t ds, ts)
>>= decLevel
body simple [TCaseKeyword:ts] =
body True ts
>>= \(expr, ts) = args_pattern ts
>>= \(ps, ts) = if (isEmpty ps)
(returnE (ts, "Missing case patterns"))
(returnS (SCase expr ps, ts))
body [TOpenBracket:ts] = skip ts // ABC code: skip it
body simple [TOpenBracket:ts] = skip ts // ABC code: skip it
where
skip [TCloseBracket:ts] = returnS (SAbortBody, ts)
skip [] = returnE ([], "Missing close bracket in ABC code definition")
skip [t:ts] = skip ts
body ts = mainexpr ts
body simple ts = ((if simple sexpr expr) ts) >>= mandatory "Missing expression"
args_factor ts = args_ factor ts
args_expr ts = args_ sexpr ts
args_pattern ts = args_ arg_pattern ts
args_ f ts = args` ts []
......@@ -166,36 +178,28 @@ where
arg_pattern [TOpenParenthesis:TLit lit:ts] =
case hd ts of
TSelectAssignmentOp = body (tl ts)
TCaseAssignmentOp = body False (tl ts)
= returnE (ts, "Missing select assignment operator")
>>= \(t, ts) = case hd ts of
TCloseParenthesis = returnS (Just (PLit lit, t), tl ts)
= returnE (ts, "Missing close parenthesis")
= returnE (ts, "Missing close parenthesis3")
arg_pattern [TOpenParenthesis:TIdentifier cons:ts] =
incLevel ts
>>= \ts = addTupleCons cons
>>= \_ = args ts
>>= \(as, ts) = case hd ts of
TSelectAssignmentOp = body (tl ts)
TCaseAssignmentOp = body False (tl ts)
= returnE (ts, "Missing select assignment operator")
>>= \(t, ts) = case hd ts of
TCloseParenthesis = returnS (Just (mbCons as, t), tl ts)
= returnE (ts, "Missing close parenthesis")
= returnE (ts, "Missing close parenthesis4")
>>= decLevel
where
mbCons as = if (cons=="_") PDefault (PCons cons as)
arg_pattern ts = returnS (Nothing, ts)
arg_adv [TOpenParenthesis:ts] =
body ts >>= \(t, ts) = returnS (Just t, ts)
>>= \(t, ts) = case hd ts of
TCloseParenthesis = returnS (t, tl ts)
= returnE (ts, "Missing close parenthesis")
arg_adv ts = factor ts
args ts = args_ ts []
where
args_ [TIdentifier name:ts] as = getLevel >>= \level = args_ ts [NormalVar name level:as]
......@@ -258,7 +262,7 @@ func ts = returnE (ts, "Not a function or type definition")
typed_caf name type ts =
getLevel
>>= \level = body ts
>>= \level = body False ts
>>= \(t, ts) = addCAF (NormalVar name level) >>= \tname = returnS (FTCAF (TypedVar tname type) t, ts)
typed_fun name type ts =
......@@ -268,7 +272,7 @@ typed_fun name type ts =
TAssignmentOp = returnS (True, tl ts)
TMacroAssignmentOp = returnS (False, tl ts)
= returnE (ts, "Missing assignment operator")
>>= \(func, ts) = body ts
>>= \(func, ts) = body False ts
>>= \(t, ts) = if func
(addFunction (NormalVar name level) as >>= \tname = returnS (FTFunc (TypedVar tname type) t as, ts))
(addFunction (NormalVar name level) as >>= \tname = returnS (FTMacro (TypedVar tname type) t as, ts))
......@@ -297,7 +301,7 @@ where
parseExpr :: [PosToken] -> MaybeError ErrorMsg (SaplTerm,ParserState)
parseExpr pts
# ts = map (\(PosToken _ _ t) = t) pts
= case (body ts) defaultState of
= case (body False ts) defaultState of
Ok ((fts, _),ps) = Ok (fts,ps)
Error (ts, msg) = let (lp, cp) = findpos ts in Error (msg+++" at line "+++toString lp+++" before charachter "+++toString cp)
where
......
src/Sapl/SaplStruct.dcl
View file @ 9f0a3584
......@@ -17,11 +17,10 @@ import Data.Maybe
:: SaplTerm = SLit Literal
| SVar SaplVar
| SApplication SaplVar [SaplTerm]
| SIf SaplTerm SaplTerm SaplTerm
| SSelector SaplTerm
| SSelect SaplTerm [(SaplPattern, SaplTerm)]
| SApplication SaplTerm [SaplTerm]
| SCase SaplTerm [(SaplPattern, SaplTerm)]
| SLet SaplTerm [SaplLetDef]
| SSelect SaplTerm Int
| SAbortBody
:: SaplLetDef = SaplLetDef SaplTypedVar SaplTerm
......@@ -67,6 +66,7 @@ instance unpackVar SaplVar
instance unpackVar SaplTypedVar
unpackBindVar :: !SaplLetDef -> SaplTypedVar
unpackBindExpr :: !SaplLetDef -> SaplTerm
unpackConsName :: !SaplPattern -> Maybe String
toStrictBind :: !SaplLetDef -> SaplLetDef
......
src/Sapl/SaplStruct.icl
View file @ 9f0a3584
......@@ -86,6 +86,9 @@ where
unpackBindVar :: !SaplLetDef -> SaplTypedVar
unpackBindVar (SaplLetDef typedVar _) = typedVar
unpackBindExpr :: !SaplLetDef -> SaplTerm
unpackBindExpr (SaplLetDef _ expr) = expr
unpackConsName :: !SaplPattern -> Maybe String
unpackConsName (PCons cons _) = Just cons
unpackConsName _ = Nothing
......
src/Sapl/SaplTokenizer.dcl
View file @ 9f0a3584
......@@ -10,7 +10,7 @@ import StdString, Text.Unicode
| TComment String
| TInlineAnnotation
| TAssignmentOp
| TSelectAssignmentOp
| TCaseAssignmentOp
| TMacroAssignmentOp
| TCAFAssignmentOp
| TLambda
......@@ -22,8 +22,8 @@ import StdString, Text.Unicode
| TCloseBracket
| TTypeDef
| TLit Literal
| TSelectKeyword
| TIfKeyword
| TCaseKeyword
| TSelectKeyword
| TLetKeyword
| TInKeyword
| TEndOfLine
......
src/Sapl/SaplTokenizer.icl
View file @ 9f0a3584
......@@ -101,7 +101,7 @@ read_token base line
| matchAt ":==" line start
= rnoarg TMacroAssignmentOp 3
| matchAt "->" line start
= rnoarg TSelectAssignmentOp 2
= rnoarg TCaseAssignmentOp 2
| matchCharAt '\\' line start
= rnoarg TLambda 1
| matchCharAt ',' line start
......@@ -136,8 +136,8 @@ read_token base line
"false" = return (TLit (LBool False), stop)
"True" = return (TLit (LBool True), stop)
"true" = return (TLit (LBool True), stop)
"case" = return (TCaseKeyword, stop)
"select" = return (TSelectKeyword, stop)
"if" = return (TIfKeyword, stop)
"let" = return (TLetKeyword, stop)
"in" = return (TInKeyword, stop)
str = if (str.[0] == '!')
......@@ -225,8 +225,8 @@ where
toString TCloseBracket = "}"
toString TTypeDef = "::"
toString (TLit lit) = toString lit
toString TCaseKeyword = "case"
toString TSelectKeyword = "select"
toString TIfKeyword = "if"
toString TLetKeyword = "let"
toString TInKeyword = "in"
toString TEndOfLine = "\n"
......
src/Sapl/Target/JS/CodeGeneratorJS.icl
View file @ 9f0a3584
......@@ -14,12 +14,14 @@ import qualified Data.Map as DM
import Text.Unicode.Encodings.JS
import Sapl.SaplTokenizer, Sapl.SaplParser, Sapl.Target.Flavour, Sapl.Optimization.StrictnessPropagation
import Sapl.Transform.Let
import Sapl.Target.JS.Lifting
import Sapl.Transform.AddSelectors
from Data.List import elem_by, partition
:: CoderState = { cs_inbody :: !Maybe SaplTypedVar // The body of the function which is being generated (not signature)
, cs_intrfunc :: !Maybe SaplTypedVar // The name of the currently generated function if it is tail recursive
, cs_inletbind :: !Maybe SaplTypedVar // The name of the let binding we are in
, cs_futuredefs :: ![SaplTypedVar] // for finding out about let-rec and let bindings defined later
, cs_incaseexpr :: !Bool
, cs_current_vars :: ![SaplTypedVar]
......@@ -36,6 +38,7 @@ newState :: !Flavour !Bool !ParserState -> CoderState
newState f tramp p =
{ cs_inbody = Nothing
, cs_intrfunc = Nothing
, cs_inletbind = Nothing
, cs_futuredefs = []
, cs_incaseexpr = False
, cs_current_vars = []
......@@ -48,13 +51,6 @@ newState f tramp p =
, cs_prefix = f.fun_prefix
}
// Returns True if a term can be inlined, i.e. no separate statement is needed
inline :: !SaplTerm -> Bool
inline (SLet _ _) = False
inline (SSelect _ _) = False
inline (SIf _ _ _) = False
inline _ = True
pushArgs :: !CoderState ![SaplTypedVar] -> CoderState
pushArgs s [t:ts] = pushArgs {s & cs_current_vars = [t:s.cs_current_vars]} ts
pushArgs s [] = s
......@@ -99,6 +95,8 @@ callWrapper :: !SaplTerm !CoderState !StringAppender -> StringAppender
callWrapper t s a
| not (inline t)
= termCoder t s a
| isJust s.cs_inletbind
= a <++ "var " <++ termCoder (fromJust s.cs_inletbind) {s & cs_futuredefs = []} <++ "=" <++ forceTermCoder t s <++ ";"
| isJust s.cs_intrfunc && isTailRecursive (fromJust s.cs_intrfunc) t
= forceTermCoder t s a
| s.cs_trampoline
......@@ -106,9 +104,8 @@ callWrapper t s a
= a <++ "return " <++ forceTermCoder t s <++ ";"
isTailRecursive :: !SaplTypedVar !SaplTerm -> Bool
isTailRecursive var (SSelect _ patterns) = any (isTailRecursive var o snd) patterns
isTailRecursive var (SIf pred lhs rhs) = isTailRecursive var lhs || isTailRecursive var rhs
isTailRecursive var (SApplication avar _) = unpackVar var == unpackVar avar
isTailRecursive var (SCase _ patterns) = any (isTailRecursive var o snd) patterns
isTailRecursive var (SApplication (SVar avar) _) = unpackVar var == unpackVar avar
isTailRecursive var (SLet body _) = isTailRecursive var body
isTailRecursive _ _ = False
......@@ -305,8 +302,7 @@ splitDefaultPattern patterns
containsUnsafeSelect :: !CoderState !SaplTerm -> Bool
containsUnsafeSelect s (SApplication _ ts) = any (containsUnsafeSelect s) ts
containsUnsafeSelect s (SIf _ tb fb) = containsUnsafeSelect s tb || containsUnsafeSelect s fb
containsUnsafeSelect s (SSelect _ ps) = isUnsafeSelect s ps || any (containsUnsafeSelect s) (map snd ps)
containsUnsafeSelect s (SCase _ ps) = isUnsafeSelect s ps || any (containsUnsafeSelect s) (map snd ps)
containsUnsafeSelect s (SLet b _) = containsUnsafeSelect s b
containsUnsafeSelect s _ = False
......@@ -455,26 +451,38 @@ where
* A let definition is not the spine of the function, avoid tail recursion optimization:
* {s & cs_intrfunc = Nothing}
*/
letDefCoder :: ![SaplLetDef] !CoderState !StringAppender -> StringAppender
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]}
letDefCoder :: ![SaplLetDef] !Bool !CoderState !StringAppender -> StringAppender
letDefCoder [t] needsvar s a | inline (unpackBindExpr t)
= a <++ if needsvar "var " "," <++ termCoder t {s & cs_intrfunc = Nothing, cs_futuredefs=[toNormalVar (unpackBindVar t)]} <++ ";\n "
= a <++ if needsvar "" ";\n" <++ termCoder t {s & cs_intrfunc = Nothing, cs_futuredefs=[toNormalVar (unpackBindVar t)]} <++ ";\n "
letDefCoder all=:[t:ts] needsvar s a | inline (unpackBindExpr t)
= a <++ if needsvar "var " "," <++ termCoder t {s & cs_intrfunc = Nothing, cs_futuredefs=fvs}
<++ letDefCoder ts False {s & cs_current_vars=[unpackBindVar t: s.cs_current_vars]}
where
fvs = map (toNormalVar o unpackBindVar) all
letDefCoder all=:[t:ts] needsvar s a
= a <++ if needsvar "" ";\n" <++ termCoder t {s & cs_intrfunc = Nothing, cs_futuredefs=fvs} <++ ";\n"
<++ letDefCoder ts True {s & cs_current_vars=[unpackBindVar t: s.cs_current_vars]}
where
fvs = map (toNormalVar o unpackBindVar) all
letDefCoder [] _ a = a
letDefCoder [] _ _ a = a
isDependent :: ![SaplVar] !SaplTerm -> Bool
isDependent vs (SApplication f as) = any (isDependent vs) [SVar f:as]
isDependent vs (SApplication (SVar 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
termCoder (SaplLetDef name body) s a | inline body
= a <++ termCoder name {s & cs_futuredefs = []} <++ "="
<++ (if (isStrictVar name) forceTermCoder termCoder) body s
termCoder (SaplLetDef name body) s a
= a <++ (if (isStrictVar name) forceTermCoder termCoder) body {s & cs_inletbind = Just name}
forceTermCoder t s a = termCoder t s a
trampolineCoder t s a = termCoder t s a
......@@ -488,7 +496,7 @@ where
forceTermCoder :: !SaplTerm !CoderState !StringAppender -> StringAppender
forceTermCoder t=:(SVar var) s a = forceTermCoder var s a
forceTermCoder t=:(SApplication name args) s a
forceTermCoder t=:(SApplication (SVar name) args) s a
| isJust mbConstructor && constructor.nr_args == length args
= constructorInliner name constructor args s a
......@@ -504,7 +512,7 @@ where
// more arguments than needed: split it
| isJust mbFunction && functionArity < length args
= forceApp (\a -> a <++ forceTermCoder (SApplication name (take functionArity args)) s <++ ",["
= forceApp (\a -> a <++ forceTermCoder (SApplication (SVar name) (take functionArity args)) s <++ ",["
<++ termArrayCoder (drop functionArity args) "," {s & cs_intrfunc = Nothing} <++ "]") a
| isJust mbInlineFun && inlineFun.arity == length args
......@@ -561,13 +569,21 @@ where
= a <++ escapeName s.cs_prefix (unpackVar fa) <++ "=t" <++ i <++ ";" <++ mta_2 fargs (i+1) s // skip level information for TR!
mta_2 [] i s a = a
forceTermCoder (SApplication sel=:(SSelect _ _) args) s a
= a <++ "Sapl.fapp(" <++ forceTermCoder sel s <++ ",["
<++ termArrayCoder args "," s
<++ "])"
forceTermCoder t=:(SSelect expr idx) s a
= a <++ "Sapl.feval(" <++ forceTermCoder expr {s & cs_intrfunc = Nothing} <++ "[" <++ idx + 2 <++ "])"
forceTermCoder t s a = termCoder t s a
// During trampolining, in only very special cases the expressions are forced in tail call
trampolineCoder :: !SaplTerm !CoderState !StringAppender -> StringAppender
trampolineCoder t=:(SVar var) s a = trampolineCoder var s a
trampolineCoder t=:(SApplication name args) s a
trampolineCoder t=:(SApplication (SVar name) args) s a
| isJust mbConstructor && constructor.nr_args == length args
= constructorInliner name constructor args s a
......@@ -588,12 +604,10 @@ where
termCoder :: !SaplTerm !CoderState !StringAppender -> StringAppender
termCoder t=:(SVar var) s a = termCoder var s a
termCoder t=:(SSelector (SSelect expr [(PCons _ vs, SVar x)])) s a
# (idx, _) = foldl (\(idx, cnt) v -> if (eqVarByName x v) (cnt, cnt) (idx, cnt + 1)) (0, 0) vs
= a <++ "Sapl.feval(" <++ forceTermCoder expr {s & cs_intrfunc = Nothing} <++ "[" <++ idx + 2 <++ "])"
termCoder t=:(SSelector x) s a = termCoder x s a
termCoder t=:(SSelect expr idx) s a
= a <++ "[Sapl.select,[" <++ termCoder expr {s & cs_intrfunc = Nothing} <++ ", " <++ idx + 2 <++ "]]"
termCoder t=:(SSelect expr patterns) s a | any (isConsPattern o fst) patterns
termCoder t=:(SCase expr patterns) s a | any (isConsPattern o fst) patterns
# a = a <++ "var ys=" <++ forceTermCoder expr {s & cs_intrfunc = Nothing} <++ ";"
= if (containsUnsafeSelect s t) (unsafe a) (safe a)
where
......@@ -627,8 +641,14 @@ where
= case d of
(Just d) = a <++ termCoder (defp d False) s <++ ";"
= a
termCoder t=:(SCase expr [(PLit (LBool True), true_expr),(PLit (LBool False), false_expr)]) s a
= termCodeIf expr true_expr false_expr s a
termCoder t=:(SCase expr [(PLit (LBool False), false_expr),(PLit (LBool True), true_expr)]) s a
= termCodeIf expr true_expr false_expr s a
termCoder t=:(SSelect expr patterns) s a