Skip to content
GitLab
Projects
Groups
Snippets
Help
Loading...
Help
What's new
10
Help
Support
Community forum
Keyboard shortcuts
?
Submit feedback
Contribute to GitLab
Sign in
Toggle navigation
Open sidebar
clean-and-itasks
clean-sapl
Commits
08110c68
Commit
08110c68
authored
Jul 02, 2016
by
Laszlo Domoszlai
Browse files
Options
Browse Files
Download
Email Patches
Plain Diff
fix lifting of embedded record updates
parent
3635602c
Changes
4
Hide whitespace changes
Inline
Side-by-side
Showing
4 changed files
with
14 additions
and
13 deletions
+14
-13
src/Sapl/Optimization/StrictnessPropagation.dcl
src/Sapl/Optimization/StrictnessPropagation.dcl
+1
-1
src/Sapl/Target/JS/CodeGeneratorJS.icl
src/Sapl/Target/JS/CodeGeneratorJS.icl
+2
-2
src/Sapl/Target/JS/Lifting.dcl
src/Sapl/Target/JS/Lifting.dcl
+2
-2
src/Sapl/Target/JS/Lifting.icl
src/Sapl/Target/JS/Lifting.icl
+9
-8
No files found.
src/Sapl/Optimization/StrictnessPropagation.dcl
View file @
08110c68
...
...
@@ -2,7 +2,7 @@ definition module Sapl.Optimization.StrictnessPropagation
import
Sapl
.
SaplParser
,
Sapl
.
Target
.
Flavour
::
IsStrictArgFun
:==
!
ParserState
!
String
!
Int
!
Int
->
Bool
::
IsStrictArgFun
:==
ParserState
String
Int
Int
->
Bool
// strict argument checker for Flavour file
isStrictArgFlavour
::
!
Flavour
!
ParserState
!
String
!
Int
!
Int
->
Bool
...
...
src/Sapl/Target/JS/CodeGeneratorJS.icl
View file @
08110c68
...
...
@@ -676,7 +676,7 @@ where
strictness
=
strictnessMap
type
s
isStrict
idx
=
(
strictness
bitand
(
2
<<
idx
))
>
0
// Should not happen, at thi
spoint "update" is always at strict position
// Should not happen, at this
point "update" is always at strict position
termCoder
t
=:(
SUpdate
_
_
_)
s
a
=
a
<++
"/* UPD */"
...
...
@@ -807,7 +807,7 @@ generateJS f tramp saplsrc mbPst
=
Ok
(
a
,
newpst
)
Error
msg
=
Error
msg
where
upd
::
(
!
String
!
Int
!
Int
->
Bool
)
([
FuncType
],
Map
String
FuncType
)
FuncType
->
([
FuncType
],
Map
String
FuncType
)
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
)
...
...
src/Sapl/Target/JS/Lifting.dcl
View file @
08110c68
...
...
@@ -8,7 +8,7 @@ inline :: !SaplTerm -> Bool
// 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
)
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 @
08110c68
...
...
@@ -7,12 +7,12 @@ import Data.Map
inline
::
!
SaplTerm
->
Bool
inline
(
SLet
_
_)
=
False
inline
(
SUpdate
_
_
_)
=
False
inline
(
SCase
cond
[(
PLit
(
LBool
t
rue
),
case1
),(
PLit
(
LBool
f
alse
),
case2
)])
=
inline
cond
&&
inline
case1
&&
inline
case2
inline
(
SCase
cond
[(
PLit
(
LBool
f
alse
),
case1
),(
PLit
(
LBool
t
rue
),
case2
)])
=
inline
cond
&&
inline
case1
&&
inline
case2
inline
(
SCase
cond
[(
PLit
(
LBool
T
rue
),
case1
),(
PLit
(
LBool
F
alse
),
case2
)])
=
inline
cond
&&
inline
case1
&&
inline
case2
inline
(
SCase
cond
[(
PLit
(
LBool
F
alse
),
case1
),(
PLit
(
LBool
T
rue
),
case2
)])
=
inline
cond
&&
inline
case1
&&
inline
case2
inline
(
SCase
_
_)
=
False
inline
_
=
True
prepareFun
::
(
!
String
!
Int
!
Int
->
Bool
)
!
FuncType
(
Map
String
FuncType
)
->
(
FuncType
,
Map
String
FuncType
)
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
)
...
...
@@ -37,7 +37,7 @@ where
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
::
(
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
...
...
@@ -86,8 +86,8 @@ where
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
walkTerm
(
SUpdate
expr
ty
updates
)
doNotLift
False
st
#
(
expr
,
st
,
edefs
)
=
walkTerm
expr
doNotLift
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
...
...
@@ -97,8 +97,9 @@ where
where
extractName
(
FTFunc
(
TypedVar
name
_)
_
_)
=
name
walkTerm
(
SUpdate
expr
ty
updates
)
_
strictPosition
st
#
(
expr
,
st
,
edefs
)
=
walkTerm
expr
False
strictPosition
st
// TODO: is it a real option?
walkTerm
(
SUpdate
expr
ty
updates
)
True
True
st
#
(
expr
,
st
,
edefs
)
=
walkTerm
expr
False
True
st
#
(
updates
,
st
,
udefs
)
=
walkUpdates
updates
st
=
(
SUpdate
expr
ty
updates
,
st
,
edefs
++
udefs
)
...
...
Write
Preview
Markdown
is supported
0%
Try again
or
attach a new file
.
Attach a file
Cancel
You are about to add
0
people
to the discussion. Proceed with caution.
Finish editing this message first!
Cancel
Please
register
or
sign in
to comment