Skip to content
GitLab
Menu
Projects
Groups
Snippets
Help
Help
Support
Community forum
Keyboard shortcuts
?
Submit feedback
Contribute to GitLab
Sign in
Toggle navigation
Menu
Open sidebar
clean-and-itasks
clean-sapl
Commits
e318b073
Commit
e318b073
authored
Feb 05, 2018
by
Steffen Michels
Browse files
fix bug
parent
e6552907
Changes
5
Hide whitespace changes
Inline
Side-by-side
src/Sapl/Optimization/StrictnessPropagation.icl
View file @
e318b073
...
...
@@ -38,6 +38,7 @@ where
(
ds
,
nbody
)
=
(
propBody
ps
isStrictArg
newSet
body
)
nargs
=
map
addStrictness
args
addStrictness
var
=:(
TypedVar
(
GlobalVar
_)
_)
=
var
addStrictness
var
=:(
TypedVar
(
StrictVar
_
_)
_)
=
var
addStrictness
var
=:(
TypedVar
(
NormalVar
vn
_)
_)
=
if
(
member
vn
ds
)
(
toStrictVar
var
)
var
...
...
@@ -105,6 +106,7 @@ where
// 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
walkbnd
sd
(
SaplLetDef
(
TypedVar
(
GlobalVar
vn
)
_)
body
)
=
delete
vn
sd
walk
sd
t
=
(
sd
,
t
)
...
...
src/Sapl/SaplParser.icl
View file @
e318b073
...
...
@@ -2,6 +2,7 @@ implementation module Sapl.SaplParser
import
StdEnv
,
Data
.
Error
import
Sapl
.
SaplTokenizer
,
Sapl
.
SaplStruct
,
Sapl
.
FastString
import
Sapl
.
Transform
.
VarReferences
from
Data
.
Map
import
::
Map
import
qualified
Data
.
Map
as
DM
...
...
@@ -316,7 +317,7 @@ parse :: [PosToken] -> MaybeError ErrorMsg ([FuncType],ParserState)
parse
pts
#
ts
=
map
(\(
PosToken
_
_
t
)
=
t
)
pts
=
case
(
program
ts
[])
defaultState
of
Ok
((
fts
,
_),
ps
)
=
Ok
(
ps
.
ps_genFuns
++
fts
,
ps
)
Ok
((
fts
,
_),
ps
)
=
Ok
(
fixReferences
(
ps
.
ps_genFuns
++
fts
)
,
ps
)
Error
(
ts
,
msg
)
=
let
(
lp
,
cp
)
=
findpos
ts
in
Error
(
msg
+++
" at line "
+++
toString
lp
+++
" before character "
+++
toString
cp
)
where
findpos
rest_ts
...
...
src/Sapl/SaplStruct.dcl
View file @
e318b073
...
...
@@ -30,6 +30,7 @@ import Data.Maybe
::
SaplVar
=
NormalVar
SaplName
Int
|
StrictVar
SaplName
Int
|
GlobalVar
SaplName
::
SaplTypedVar
=
TypedVar
SaplVar
SaplType
...
...
src/Sapl/SaplStruct.icl
View file @
e318b073
...
...
@@ -18,6 +18,7 @@ ltVarByNameLevel a b = unpackVar a < unpackVar b || (unpackVar a == unpackVar b
unpackLevel
(
NormalVar
_
level
)
=
level
unpackLevel
(
StrictVar
_
level
)
=
level
unpackLevel
(
GlobalVar
_)
=
0
instance
toString
SaplVar
where
...
...
@@ -25,6 +26,7 @@ where
toString
(
NormalVar
name
level
)
=
name
+++
"_"
+++
toString
level
toString
(
StrictVar
name
0
)
=
"!"
+++
name
toString
(
StrictVar
name
level
)
=
"!"
+++
name
+++
"_"
+++
toString
level
toString
(
GlobalVar
name
)
=
name
removeTypeInfo
::
!
SaplTypedVar
->
SaplVar
removeTypeInfo
(
TypedVar
var
_)
=
var
...
...
@@ -78,6 +80,7 @@ where
unpackVar
::
!
SaplVar
->
String
unpackVar
(
NormalVar
name
_)
=
name
unpackVar
(
StrictVar
name
_)
=
name
unpackVar
(
GlobalVar
name
)
=
name
instance
unpackVar
SaplTypedVar
where
...
...
src/Sapl/Target/JS/CodeGeneratorJS.icl
View file @
e318b073
...
...
@@ -394,6 +394,8 @@ where
instance
TermCoder
SaplVar
where
forceTermCoder
t
=:(
GlobalVar
name
)
s
a
=
forceTermCoder
(
NormalVar
name
0
)
s
a
forceTermCoder
t
=:(
NormalVar
name
level
)
s
a
// Strict let definitions, strict arguments ...
|
any
(
eqStrictVar
name
)
s
.
cs_current_vars
...
...
@@ -416,6 +418,8 @@ where
forceTermCoder
(
StrictVar
name
level
)
s
a
=
forceTermCoder
(
NormalVar
name
level
)
s
a
trampolineCoder
t
=:(
GlobalVar
name
)
s
a
=
forceTermCoder
(
NormalVar
name
0
)
s
a
trampolineCoder
t
=:(
NormalVar
name
_)
s
a
|
isJust
mbConstructor
&&
constructor
.
nr_args
==
0
=
constructorInliner
t
constructor
[]
s
a
...
...
@@ -426,6 +430,8 @@ where
trampolineCoder
(
StrictVar
name
level
)
s
a
=
trampolineCoder
(
NormalVar
name
level
)
s
a
termCoder
t
=:(
GlobalVar
name
)
s
a
=
forceTermCoder
(
NormalVar
name
0
)
s
a
termCoder
t
=:(
NormalVar
name
level
)
s
a
|
isJust
s
.
cs_inbody
&&
not
isLocalVar
&&
isJust
mbConstructor
&&
constructor
.
nr_args
==
0
=
constructorInliner
t
constructor
[]
s
a
...
...
@@ -588,9 +594,9 @@ where
Nothing
#
(
tr_function_args
,
args
)
=
unzip
setters
=
a
<++
"var "
<++
mta_1
tr_function_args
args
0
s
<++
";"
<++
mta_2
tr_function_args
0
s
<++
"continue;"
<++
mta_2
tr_function_args
0
s
<++
"continue;
/* 1 */
"
// Reverse topological order is probably safe
(
Just
ordered
)
=
a
<++
gen_setters
(
reverse
ordered
)
s
<++
"continue;"
(
Just
ordered
)
=
a
<++
gen_setters
(
reverse
ordered
)
s
<++
"continue;
/* 2 */
"
where
mta_1
[
TypedVar
(
StrictVar
_
_)
_:
fargs
]
[
aa
:
aargs
]
i
s
a
...
...
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