Skip to content

GitLab

C
clean-sapl
Commit 2d912c78 authored by Laszlo Domoszlai's avatar Laszlo Domoszlai
Browse files
Options

"update" syntax

parent 8de10300
Hide whitespace changes
Inline Side-by-side
Showing with 258 additions and 102 deletions
src/Sapl/Optimization/StrictnessPropagation.icl
View file @ 2d912c78
......@@ -49,7 +49,13 @@ where
walk sd t=:(SVar var) = (insert (unpackVar var) sd, t)
// We can skip the new expr, cannot contain let definitions...
walk sd t=:(SSelect expr idx)
walk sd t=:(SUpdate expr _ updates)
# (sd, _) = walk sd expr
// TODO: updates
= (sd, t)
// We can skip the new expr, cannot contain let definitions...
walk sd t=:(SSelect expr _ idx)
# (sd, _) = walk sd expr
= (sd, t)
......@@ -64,7 +70,7 @@ where
strictArgs = map fst (filter checkArg (zip2 args [0..]))
// We can skip the new expr, cannot contain let definitions...
// Args cannot be checked, we do not know the function defiition...
// Args cannot be checked, we do not know the function definition...
walk sd t=:(SApplication expr args)
// expr is always strict
# (sd, _) = walk sd expr
......
src/Sapl/SaplParser.icl
View file @ 2d912c78
......@@ -66,6 +66,9 @@ addTupleCons _ = returnS Void
read_int [TLit (LInt lit):ts] = returnS (Just lit, ts)
read_int ts = returnS (Nothing, ts)
type [TTypeDef, TIdentifier type:ts] = returnS (Type type, ts)
type ts = returnS (NoType, ts)
expr [TOpenParenthesis:ts] =
mexpr ts
>>= \(t, ts) = case hd ts of
......@@ -86,12 +89,35 @@ expr [TIdentifier name:ts] =
expr [TSelectKeyword:ts] =
sexpr ts
>>= mandatory "Missing select expression"
>>= \(expr, ts) = read_int ts
>>= \(expr, ts) = type ts
>>= \(ty, 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)
[] = returnS (Just (SSelect expr ty idx), ts)
= returnS (Just (SApplication (SSelect expr ty idx) as), ts)
expr [TUpdateKeyword:ts] =
sexpr ts
>>= mandatory "Missing update expression"
>>= \(expr, ts) = type ts
>>= \(ty, ts) = upd_list ts
>>= \(upds, ts) = returnS (Just (SUpdate expr ty upds), ts)
where
upd_list [TOpenSquareBracket:ts] =
update_1 ts []
>>= \(us, ts) = case hd ts of
TCloseSquareBracket = returnS (us, tl ts)
= returnE (ts, "Missing close square bracket")
upd_list ts = returnE (ts, "Missing open bracket")
update_1 [TLit (LInt idx),TColon:ts] as =
expr ts
>>= mandatory "Missing field update expression"
>>= \(expr, ts) = update_2 ts [(idx, expr):as]
update_1 ts as = returnE (ts, "Invalid field \"update\"")
update_2 [TComma: ts] as = update_1 ts as
update_2 ts as = returnS (reverse as, ts)
expr ts = returnS (Nothing, ts)
......@@ -132,7 +158,7 @@ where
>>= \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 [TComma: ts] as = letdef_1 ts as
letdef_2 ts as = returnS (reverse as, ts)
body simple [TOpenParenthesis:ts] =
......@@ -220,7 +246,7 @@ where
args_1 [TStrictIdentifier name,TTypeDef,TIdentifier type:ts] as = getLevel >>= \level = args_2 ts [TypedVar (StrictVar name level) (Type type):as]
args_1 [TStrictIdentifier name:ts] as = getLevel >>= \level = args_2 ts [TypedVar (StrictVar name level) NoType:as]
args_1 ts as = returnE (ts, "Missing argument")
args_2 [TColon:ts] as = args_1 ts as
args_2 [TComma:ts] as = args_1 ts as
args_2 ts as = returnS (reverse as, ts)
args_adt ts = args_1 ts [] 0
......@@ -291,7 +317,7 @@ parse pts
# ts = map (\(PosToken _ _ t) = t) pts
= case (program ts []) defaultState of
Ok ((fts, _),ps) = Ok (ps.ps_genFuns ++ fts,ps)
Error (ts, msg) = let (lp, cp) = findpos ts in Error (msg+++" at line "+++toString lp+++" before charachter "+++toString cp)
Error (ts, msg) = let (lp, cp) = findpos ts in Error (msg+++" at line "+++toString lp+++" before character "+++toString cp)
where
findpos rest_ts
# rest_pts = drop ((length pts)-(length rest_ts)-1) pts
......@@ -303,7 +329,7 @@ parseExpr pts
# ts = map (\(PosToken _ _ t) = t) pts
= 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)
Error (ts, msg) = let (lp, cp) = findpos ts in Error (msg+++" at line "+++toString lp+++" before character "+++toString cp)
where
findpos rest_ts
# rest_pts = drop ((length pts)-(length rest_ts)-1) pts
......
src/Sapl/SaplStruct.dcl
View file @ 2d912c78
......@@ -20,7 +20,8 @@ import Data.Maybe
| SApplication SaplTerm [SaplTerm]
| SCase SaplTerm [(SaplPattern, SaplTerm)]
| SLet SaplTerm [SaplLetDef]
| SSelect SaplTerm Int
| SSelect SaplTerm SaplType Int
| SUpdate SaplTerm SaplType [(Int, SaplTerm)]
| SAbortBody
:: SaplLetDef = SaplLetDef SaplTypedVar SaplTerm
......
src/Sapl/SaplTokenizer.dcl
View file @ 2d912c78
......@@ -14,16 +14,20 @@ import StdString, Text.Unicode
| TMacroAssignmentOp
| TCAFAssignmentOp
| TLambda
| TComma
| TColon
| TVerticalBar
| TOpenParenthesis
| TCloseParenthesis
| TOpenBracket
| TCloseBracket
| TOpenSquareBracket
| TCloseSquareBracket
| TTypeDef
| TLit Literal
| TCaseKeyword
| TSelectKeyword
| TSelectKeyword
| TUpdateKeyword
| TLetKeyword
| TInKeyword
| TEndOfLine
......
src/Sapl/SaplTokenizer.icl
View file @ 2d912c78
......@@ -10,7 +10,7 @@ is_stopchar :: !Char -> Bool
is_stopchar char
= (char == '=') || (char == ':') || (char == ')') || (char == '(') ||
(char == '|') || (char == '{') || (char == '}') || (char == ',') ||
(char == ';') || isSpace char
(char == '[') || (char == ']') || isSpace char
not_stopchar = not o is_stopchar
is_space c = isSpace c && not_eol c
......@@ -78,7 +78,7 @@ read_token :: !Int !String -> (!Int, !Int, !Token)
read_token base line
| start > ((size line)-1)
= rnoarg TEndOfLine 0
| matchCharAt ';' line start || matchCharAt '\n' line start
| matchCharAt '\n' line start
= rnoarg TEndOfLine 1
// Skip <{ and }> from the identifier. It's to help parsing "strange" function names
| matchAt "!<{" line start
......@@ -102,10 +102,10 @@ read_token base line
= rnoarg TMacroAssignmentOp 3
| matchAt "->" line start
= rnoarg TCaseAssignmentOp 2
| matchCharAt '\\' line start
= rnoarg TLambda 1
| matchCharAt ',' line start
= rnoarg TColon 1
= rnoarg TComma 1
| matchCharAt ':' line start
= rnoarg TColon 1
| matchCharAt '(' line start
= rnoarg TOpenParenthesis 1
| matchCharAt ')' line start
......@@ -114,6 +114,10 @@ read_token base line
= rnoarg TOpenBracket 1
| matchCharAt '}' line start
= rnoarg TCloseBracket 1
| matchCharAt '[' line start
= rnoarg TOpenSquareBracket 1
| matchCharAt ']' line start
= rnoarg TCloseSquareBracket 1
| matchCharAt '"' line start
# (nextbase,ustr) = read_string_lit '"' (start+1) line
= return (TLit (LString ustr), nextbase)
......@@ -138,6 +142,7 @@ read_token base line
"true" = return (TLit (LBool True), stop)
"case" = return (TCaseKeyword, stop)
"select" = return (TSelectKeyword, stop)
"update" = return (TUpdateKeyword, stop)
"let" = return (TLetKeyword, stop)
"in" = return (TInKeyword, stop)
str = if (str.[0] == '!')
......@@ -216,8 +221,8 @@ where
toString TAssignmentOp = "="
toString TMacroAssignmentOp = ":=="
toString TCAFAssignmentOp = "=:"
toString TLambda = "\\"
toString TColon = ","
toString TComma = ","
toString TColon = ":"
toString TVerticalBar = "|"
toString TOpenParenthesis = "("
toString TCloseParenthesis = ")"
......
src/Sapl/Target/JS/CodeGeneratorJS.icl
View file @ 2d912c78
......@@ -16,6 +16,7 @@ import Sapl.SaplTokenizer, Sapl.SaplParser, Sapl.Target.Flavour, Sapl.Optimizati
import Sapl.Transform.Let
import Sapl.Target.JS.Lifting
import Sapl.Transform.AddSelectors
import StdDebug
from Data.List import elem_by, partition
......@@ -109,6 +110,17 @@ isTailRecursive var (SApplication (SVar avar) _) = unpackVar var == unpackVar av
isTailRecursive var (SLet body _) = isTailRecursive var body
isTailRecursive _ _ = False
strictnessMap :: !SaplType !CoderState -> Int
strictnessMap NoType _ = 0
strictnessMap (Type cons) {cs_constructors}
= case get cons cs_constructors of
Nothing = 0
(Just {args}) = toInt args 0
where
toInt [] _ = 0
toInt [TypedVar (StrictVar _ _) _:as] i = (toInt as (i+1)) bitor (2 << i)
toInt [TypedVar (NormalVar _ _) _:as] i = toInt as (i+1)
funcCoder :: !FuncType !CoderState !StringAppender -> StringAppender
funcCoder (FTFunc name body args) s a = normalFunc name (addSelectors body) args s a
funcCoder (FTMacro name body args) s a = normalFunc name body args s a
......@@ -569,13 +581,32 @@ 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
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=:(SSelect expr type idx) s a
| isStrict idx
= a <++ forceTermCoder expr {s & cs_intrfunc = Nothing} <++ "[" <++ idx + 2 <++ "]"
= a <++ "Sapl.feval(" <++ forceTermCoder expr {s & cs_intrfunc = Nothing} <++ "[" <++ idx + 2 <++ "])"
where
strictness = strictnessMap type s
isStrict idx = (strictness bitand (2 << idx)) > 0
// It is always in a strict let bind
forceTermCoder t=:(SUpdate expr type updates) s a
= a <++ "var " <++ termCoder var {s & cs_inletbind = Nothing, cs_futuredefs = []} <++ "=" <++ forceTermCoder expr {s & cs_inletbind = Nothing} <++ ".slice(0);" <++ genUpd updates;
where
var = fromJust s.cs_inletbind
strictness = strictnessMap type s
isStrict idx = (strictness bitand (2 << idx)) > 0
genUpd [] a = a
genUpd [(idx, expr):us] a
= a <++ termCoder var {s & cs_inletbind = Nothing, cs_futuredefs = []} <++ "[" <++ idx + 2 <++ "]=" <++
(if (isStrict idx) forceTermCoder termCoder) expr {s & cs_inletbind = Nothing} <++ ";" <++ genUpd us
forceTermCoder t s a = termCoder t s a
......@@ -604,8 +635,17 @@ where
termCoder :: !SaplTerm !CoderState !StringAppender -> StringAppender
termCoder t=:(SVar var) s a = termCoder var s a
termCoder t=:(SSelect expr idx) s a
= a <++ "[Sapl.select,[" <++ termCoder expr {s & cs_intrfunc = Nothing} <++ ", " <++ idx + 2 <++ "]]"
termCoder t=:(SSelect expr type idx) s a
| isStrict idx
= a <++ "[Sapl.sselect,[" <++ termCoder expr {s & cs_intrfunc = Nothing} <++ ", " <++ idx + 2 <++ "]]"
= a <++ "[Sapl.select,[" <++ termCoder expr {s & cs_intrfunc = Nothing} <++ ", " <++ idx + 2 <++ "]]"
where
strictness = strictnessMap type s
isStrict idx = (strictness bitand (2 << idx)) > 0
// Should not happen, at thi spoint "update" is always at strict position
termCoder t=:(SUpdate _ _ _) s a
= a <++ "/* UPD */"
termCoder t=:(SCase expr patterns) s a | any (isConsPattern o fst) patterns
# a = a <++ "var ys=" <++ forceTermCoder expr {s & cs_intrfunc = Nothing} <++ ";"
......@@ -680,7 +720,7 @@ where
inlineFun = fromJust mbInlineFun
// Dynamic application: fun part is always strict
termCoder (SApplication sel=:(SSelect _ _) args) s a
termCoder (SApplication sel=:(SSelect _ _ _) args) s a
= a <++ "[" <++ forceTermCoder sel s <++ ",["
<++ termArrayCoder args "," s
<++ "]]"
......@@ -724,18 +764,31 @@ generateJS f tramp saplsrc mbPst
# state = newState f tramp newpst
# a = newAppender <++ "\"use strict\";"
# a = a <++ "/*Trampoline: "
# a = if tramp (a <++ "ON") (a <++ "OFF")
# a = foldl (\a curr = a <++ funcCoder curr state) (a <++ "*/") (map prepareFun funcs)
# a = if tramp (a <++ "ON") (a <++ "OFF")
// Lift + generated update functions
# (funcs, genfuns) = foldl (upd (isStrictArgFlavour f newpst)) ([], newMap) funcs
# funcs = reverse funcs ++ elems genfuns
# a = foldl (\a curr = a <++ funcCoder curr state) (a <++ "*/") funcs
= Ok (a, newpst)
Error msg = Error msg
Error msg = Error msg
where
upd :: (!String !Int !Int -> Bool) ([FuncType], Map String FuncType) FuncType -> ([FuncType], Map String FuncType)
upd sf (nfs, genfuns) fun
= let (nfun, ngenfuns) = prepareFun sf fun genfuns in ([nfun:nfs], union genfuns ngenfuns)
exprGenerateJS :: !Flavour !Bool !String !(Maybe ParserState) !StringAppender -> (MaybeErrorString (String, StringAppender, ParserState))
exprGenerateJS f tramp saplsrc mbPst out
# pts = tokensWithPositions saplsrc
= case parseExpr pts of
Ok (body, s) # newpst = mergeParserStates s mbPst
# state = newState f tramp newpst
# a = termCoder (prepareExpr body) {state & cs_inbody=Just (TypedVar (NormalVar "__dummy" 0) NoType)} newAppender
// Lift + generated update functions. TODO: do not skip generated functions
# (body, _) = prepareExpr (isStrictArgFlavour f newpst) body newMap
# a = termCoder body {state & cs_inbody=Just (TypedVar (NormalVar "__dummy" 0) NoType)} newAppender
# out = foldl (\a curr = a <++ funcCoder curr state) out s.ps_genFuns
= Ok (toString a, out, newpst)
Error msg = Error msg
......
src/Sapl/Target/JS/Lifting.dcl
View file @ 2d912c78
definition module Sapl.Target.JS.Lifting
import Sapl.SaplStruct
import Data.Map
// Returns True if a term can be inlined, i.e. no separate statement is needed
inline :: !SaplTerm -> Bool
prepareFun :: !FuncType -> FuncType
prepareExpr :: !SaplTerm -> SaplTerm
// First function: decide on strictness. See doStrictnessPropagation
// Map: generated functions
prepareFun :: (!String !Int !Int -> Bool) !FuncType (Map String FuncType) -> (FuncType, Map String FuncType)
prepareExpr :: (!String !Int !Int -> Bool) !SaplTerm (Map String FuncType) -> (SaplTerm, Map String FuncType)
src/Sapl/Target/JS/Lifting.icl
View file @ 2d912c78
......@@ -2,89 +2,146 @@ implementation module Sapl.Target.JS.Lifting
import StdEnv
import Sapl.SaplStruct
import Data.Map
inline :: !SaplTerm -> Bool
inline (SLet _ _) = False
inline (SUpdate _ _ _) = False
inline (SCase cond [(PLit (LBool true), case1),(PLit (LBool false), case2)]) = inline cond && inline case1 && inline case2
inline (SCase cond [(PLit (LBool false), case1),(PLit (LBool true), case2)]) = inline cond && inline case1 && inline case2
inline (SCase _ _) = False
inline _ = True
prepareFun :: !FuncType -> FuncType
prepareFun (FTFunc name body args) = FTFunc name (prepareExpr body) args
prepareFun (FTCAF name body) = FTCAF name (prepareExpr body)
prepareFun ftype = ftype
:: LiftingState = {varidx :: Int}
prepareExpr :: !SaplTerm -> SaplTerm
prepareExpr t
# (t, st, defs) = walkTerm t {varidx = 1}
= case defs of
[] = t
defs = SLet t defs
walkTerm :: !SaplTerm !LiftingState -> (!SaplTerm, !LiftingState, ![SaplLetDef])
walkTerm (SCase cond patterns) st | not (inline cond)
# (letvar, st) = genVar st
# casevar = SVar (removeTypeInfo letvar)
# (patterns, st, pdefs) = walkPatterns patterns st
# defs = [SaplLetDef letvar cond:pdefs]
= case defs of
[] = (SCase casevar patterns, st, [])
defs = (SLet (SCase casevar patterns) defs, st, [])
prepareFun :: (!String !Int !Int -> Bool) !FuncType (Map String FuncType) -> (FuncType, Map String FuncType)
prepareFun sf (FTFunc name body args) genfuns
# (body, genfuns) = prepareExpr sf body genfuns
= (FTFunc name body args,genfuns)
prepareFun sf (FTCAF name body) genfuns
# (body, genfuns) = prepareExpr sf body genfuns
= (FTCAF name body, genfuns)
prepareFun _ ftype genfuns = (ftype, genfuns)
:: LiftingState = {varidx :: Int, genfuns :: Map String FuncType}
genUpdateFun :: SaplTerm -> FuncType
genUpdateFun (SUpdate _ ty updates)
= FTFunc (TypedVar (NormalVar funName 0) NoType)
(SUpdate (SVar (NormalVar "e" 0)) ty
[(idx, SVar (NormalVar ("a" +++ toString i) 0)) \\ i <- [1..length updates] & idx <- map fst updates])
[TypedVar (NormalVar "e" 0) NoType:[TypedVar (NormalVar ("a" +++ toString i) 0) NoType \\ i <- [1..length updates]]]
where
genVar {varidx} = (TypedVar (StrictVar ("$g"+++toString varidx) 0) (Type "B"), {varidx = varidx + 1})
walkTerm c=:(SCase cond patterns) st
# (cond, st, cdefs) = walkTerm cond st
# (patterns, st, pdefs) = walkPatterns patterns st
# defs = cdefs ++ pdefs
funName = case ty of
NoType = "update$" +++ toString (mask updates 0)
(Type tn) = "update$" +++ tn +++ "_" +++ toString (mask updates 0)
mask [] bits = bits
mask [(idx,_):us] bits = mask us ((1 << idx) bitor bits)
prepareExpr :: (!String !Int !Int -> Bool) !SaplTerm (Map String FuncType) -> (SaplTerm, Map String FuncType)
prepareExpr sf t genfuns
# (t, st, defs) = walkTerm t False True {varidx = 1, genfuns = genfuns}
= case defs of
[] = (SCase cond patterns, st, []) // TODO: move to pattern
defs = (SLet (SCase cond patterns) defs, st, [])
// TODO: bindings (insert) strict?
walkTerm (SLet expr bindings) st
# (expr, st, defs) = walkTerm expr st
= case defs of
[] = (SLet expr bindings, st, [])
defs = (SLet expr (bindings ++ defs), st, [])
walkTerm (SSelect expr idx) st
# (expr, st, defs) = walkTerm expr st
= (SSelect expr idx, st, defs)
/*
walkTerm (SApplication sel=:(SSelect sexpr _) args) st
# (letvar, st) = genVar st
# selvar = SVar (removeTypeInfo letvar)
# (args, st, defs) = walkArgs args st
= (SApplication selvar args, st, [SaplLetDef letvar sel:defs])
[] = (t, st.genfuns)
defs = (SLet t defs, st.genfuns)
where
genVar {varidx} = (TypedVar (StrictVar ("$g"+++toString varidx) 0) NoType, {varidx = varidx + 1})
*/
walkTerm :: !SaplTerm !Bool !Bool !LiftingState -> (!SaplTerm, !LiftingState, ![SaplLetDef])
walkTerm (SCase cond patterns) _ _ st | not (inline cond)
# (cond, st, cdefs) = walkTerm cond True True st
# (letvar, st) = genVar st
# casevar = SVar (removeTypeInfo letvar)
# (patterns, st) = walkPatterns patterns st
# defs = [SaplLetDef letvar cond:cdefs]
= case defs of
[] = (SCase casevar patterns, st, [])
defs = (SLet (SCase casevar patterns) defs, st, [])
where
genVar st=:{varidx} = (TypedVar (StrictVar ("$g"+++toString varidx) 0) (Type "B"), {st & varidx = varidx + 1})
walkTerm c=:(SCase cond patterns) doNotLift _ st
# (cond, st, cdefs) = walkTerm cond False True st
# (patterns, st) = walkPatterns patterns st
# defs = cdefs
= case defs of
[] = (SCase cond patterns, st, []) // TODO: move to pattern?
defs = (SLet (SCase cond patterns) defs, st, [])
walkTerm (SLet expr bindings) doNotLift _ st
# (expr, st, edefs) = walkTerm expr False True st
# (bindings, st, bdefs) = walkBindings bindings st
# defs = edefs ++ bdefs
= case defs of
[] = (SLet expr (bindings ++ defs), st, [])
defs = (SLet expr (bindings ++ defs), st, [])
walkTerm (SSelect expr ty idx) doNotLift strictPosition st
# (expr, st, defs) = walkTerm expr False strictPosition st
= (SSelect expr ty idx, st, defs)
walkTerm (SUpdate expr ty updates) False True st
# (letvar, st) = genVar st
# updvar = SVar (removeTypeInfo letvar)
# (updates, st, udefs) = walkUpdates updates st
# (expr, st, edefs) = walkTerm expr False True st
= (updvar, st, [SaplLetDef letvar (SUpdate expr ty updates):edefs++udefs])
where
genVar st=:{varidx} = (TypedVar (StrictVar ("$g"+++toString varidx) 0) NoType, {st & varidx = varidx + 1})
walkTerm (SUpdate expr ty updates) False False st
# (expr, st, edefs) = walkTerm expr False False st
# (updates, st, udefs) = walkUpdates updates st
// Generate new fun and lift it in the same time
# (genfun, _) = prepareFun sf (genUpdateFun (SUpdate expr ty updates)) newMap
# funname = extractName genfun
= (SApplication (SVar funname) [expr:map snd updates],
{st & genfuns = put (unpackVar funname) genfun st.genfuns}, edefs ++ udefs)
where
extractName (FTFunc (TypedVar name _) _ _) = name
walkTerm (SUpdate expr ty updates) _ strictPosition st
# (expr, st, edefs) = walkTerm expr False strictPosition st
# (updates, st, udefs) = walkUpdates updates st
= (SUpdate expr ty updates, st, edefs ++ udefs)
walkTerm (SApplication v=:(SVar name) args) doNotLift strictPosition st
# (args, st, defs) = walkArgs [sf (unpackVar name) (length args) i \\ i <- [0..]] args st
= (SApplication v args, st, defs)
walkTerm (SApplication name args) doNotLift strictPosition st
# (args, st, defs) = walkArgs (repeat False) args st
= (SApplication name args, st, defs)
walkTerm t _ _ st = (t, st, [])
walkArgs _ [] st = ([], st, [])
walkArgs [isStrict:si] [t:ts] st
# (t, st, def) = walkTerm t False isStrict st
# (ts, st, defs) = walkArgs si ts st
= ([t:ts], st, def ++ defs)
walkPatterns [] st = ([], st)
walkPatterns [(p, t):ps] st
# (t, st, defs) = walkTerm t False True st
# t = case defs of
[] = t
defs = SLet t defs
# (ps, st) = walkPatterns ps st
= ([(p,t):ps], st)
walkBindings [] st = ([], st, [])
walkBindings [SaplLetDef var expr:bs] st
# (expr, st, def) = walkTerm expr True (isStrictVar var) st
# (bs, st, defs) = walkBindings bs st
= ([SaplLetDef var expr:bs], st, def ++ defs)
walkTerm (SApplication name args) st
# (args, st, defs) = walkArgs args st
= (SApplication name args, st, defs)
walkUpdates [] st = ([], st, [])
walkUpdates [(idx,expr):us] st
# (expr, st, def) = walkTerm expr True False st
# (us, st, defs) = walkUpdates us st
= ([(idx, expr):us], st, def ++ defs)
walkTerm t st = (t, st, [])
walkArgs [] st = ([], st, [])
walkArgs [t:ts] st
# (t, st, def) = walkTerm t st
# (ts, st, defs) = walkArgs ts st
= ([t:ts], st, def ++ defs)
walkPatterns [] st = ([], st, [])
walkPatterns [(p, t):ps] st
# (t, st, def) = walkTerm t st
# (ts, st, defs) = walkPatterns ps st
= ([(p, t):ts], st, def ++ defs)
src/Sapl/Transform/AddSelectors.icl
View file @ 2d912c78
......@@ -8,10 +8,10 @@ import StdBool, StdList
instance addSelectors SaplTerm where
addSelectors (SApplication v ts) = SApplication v (map addSelectors ts)
addSelectors st=:(SCase t ps=:[(PCons _ vs, SVar x)])
addSelectors st=:(SCase t ps=:[(PCons cons vs, SVar x)])
| foldr (\v acc -> acc || eqVarByName v x) False vs
# (idx, _) = foldl (\(idx, cnt) v -> if (eqVarByName x v) (cnt, cnt) (idx, cnt + 1)) (0, 0) vs
= SSelect t idx
= SSelect t (Type cons) idx
| otherwise
= SCase t ps
......
src/Sapl/Transform/Let.icl
View file @ 2d912c78
......@@ -19,7 +19,8 @@ where
genGraph :: !(Set SaplVar) ![SaplLetDef] -> (!Set (SaplVar,SaplVar), !Set SaplVar)
genGraph binds defs = foldl (\s (SaplLetDef (TypedVar bv _) body) -> gen binds bv s body) ('Data.Set'.newSet,binds) defs
where
gen vs bv s (SSelect expr idx) = gen vs bv s expr
gen vs bv s (SSelect expr _ idx) = gen vs bv s expr
gen vs bv s (SUpdate expr _ updates) = foldl (gen vs bv) (gen vs bv s expr) (map snd updates)
gen vs bv s (SApplication (SVar f) as) = foldl (gen vs bv) s [SVar f:as]
gen vs bv s (SApplication expr as) = foldl (gen vs bv) (gen vs bv s expr) as
gen vs bv (es,is) (SVar v)
......
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