Skip to content
GitLab
Projects
Groups
Snippets
/
Help
Help
Support
Community forum
Keyboard shortcuts
?
Submit feedback
Contribute to GitLab
Sign in
Toggle navigation
Menu
Open sidebar
clean-compiler-and-rts
compiler
Commits
db332604
Commit
db332604
authored
Oct 04, 2000
by
Martin Wierich
Browse files
-added position information for let bindings for better error messages
(changes are commented with "MW0")
parent
0d6d1318
Changes
13
Expand all
Hide whitespace changes
Inline
Side-by-side
backend/backendconvert.icl
View file @
db332604
...
...
@@ -535,13 +535,17 @@ instance declareVars FreeVar where
declareVars
freeVar
(_,
varHeap
)
=
declareVariable
BELhsNodeId
freeVar
.
fv_info_ptr
freeVar
.
fv_name
.
id_name
varHeap
instance
declareVars
(
Bind
Expression
FreeVar
)
where
declareVars
::
(
Bind
Expression
FreeVar
)
!
DeclVarsInput
->
BackEnder
declareVars
{
bind_src
=
App
{
app_symb
,
app_args
=[
Var
_:_]},
bind_dst
=
freeVar
}
(
aliasDummyId
,
varHeap
)
// MW0instance declareVars (Bind Expression FreeVar) where
instance
declareVars
LetBind
where
// MW0 declareVars :: (Bind Expression FreeVar) !DeclVarsInput -> BackEnder
declareVars
::
LetBind
!
DeclVarsInput
->
BackEnder
// MW0 declareVars {bind_src=App {app_symb, app_args=[Var _:_]}, bind_dst=freeVar} (aliasDummyId, varHeap)
declareVars
{
lb_src
=
App
{
app_symb
,
app_args
=[
Var
_:_]},
lb_dst
=
freeVar
}
(
aliasDummyId
,
varHeap
)
|
app_symb
.
symb_name
==
aliasDummyId
=
identity
// we have an alias. Don't declare the same variable twice
=
declareVariable
BERhsNodeId
freeVar
.
fv_info_ptr
freeVar
.
fv_name
.
id_name
varHeap
declareVars
{
bind_dst
=
freeVar
}
(_,
varHeap
)
// MW0 declareVars {bind_dst=freeVar} (_, varHeap)
declareVars
{
lb_dst
=
freeVar
}
(_,
varHeap
)
=
declareVariable
BERhsNodeId
freeVar
.
fv_info_ptr
freeVar
.
fv_name
.
id_name
varHeap
declareVariable
::
Int
(
Ptr
VarInfo
)
{#
Char
}
VarHeap
->
BackEnder
...
...
@@ -1244,13 +1248,15 @@ defineLhsNodeDef freeVar pattern nodeDefs varHeap
(
beNodeDef
variable_sequence_number
(
convertPattern
pattern
varHeap
))
(
return
nodeDefs
)
be
collectNodeDefs
::
Ident
Expression
->
[
Bind
Expression
FreeVar
]
// MW0 collectNodeDefs :: Ident Expression -> [Bind Expression FreeVar]
collectNodeDefs
::
Ident
Expression
->
[
LetBind
]
collectNodeDefs
aliasDummyId
(
Let
{
let_strict_binds
,
let_lazy_binds
})
=
filterStrictAlias
let_strict_binds
let_lazy_binds
where
filterStrictAlias
[]
let_lazy_binds
=
let_lazy_binds
filterStrictAlias
[
strict_bind
=:{
bind_src
=
App
app
}:
strict_binds
]
let_lazy_binds
// MW0 filterStrictAlias [strict_bind=:{bind_src=App app}:strict_binds] let_lazy_binds
filterStrictAlias
[
strict_bind
=:{
lb_src
=
App
app
}:
strict_binds
]
let_lazy_binds
|
app
.
app_symb
.
symb_name
==
aliasDummyId
// the compiled source was a strict alias like "#! x = y"
=
case
hd
app
.
app_args
of
...
...
@@ -1259,7 +1265,8 @@ collectNodeDefs aliasDummyId (Let {let_strict_binds, let_lazy_binds})
->
filterStrictAlias
strict_binds
let_lazy_binds
hd_app_args
// the node is not an alias anymore: remove just the _dummyForStrictAlias call
->
[{
strict_bind
&
bind_src
=
hd_app_args
}
:
filterStrictAlias
strict_binds
let_lazy_binds
]
// MW0 -> [{ strict_bind & bind_src = hd_app_args } : filterStrictAlias strict_binds let_lazy_binds]
->
[{
strict_bind
&
lb_src
=
hd_app_args
}
:
filterStrictAlias
strict_binds
let_lazy_binds
]
filterStrictAlias
[
strict_bind
:
strict_binds
]
let_lazy_binds
=
[
strict_bind
:
filterStrictAlias
strict_binds
let_lazy_binds
]
collectNodeDefs
_
_
...
...
@@ -1269,18 +1276,22 @@ convertRhsNodeDefs :: Ident Expression Int VarHeap -> BEMonad BENodeDefP
convertRhsNodeDefs
aliasDummyId
expr
main_dcl_module_n
varHeap
=
convertNodeDefs
(
collectNodeDefs
aliasDummyId
expr
)
varHeap
where
convertNodeDefs
::
[
Bind
Expression
FreeVar
]
VarHeap
->
BEMonad
BENodeDefP
// MW0 convertNodeDefs :: [Bind Expression FreeVar] VarHeap -> BEMonad BENodeDefP
convertNodeDefs
::
[
LetBind
]
VarHeap
->
BEMonad
BENodeDefP
convertNodeDefs
binds
varHeap
=
sfoldr
(
beNodeDefs
o
flip
convertNodeDef
varHeap
)
beNoNodeDefs
binds
where
convertNodeDef
::
!(
Bind
Expression
FreeVar
)
VarHeap
->
BEMonad
BENodeDefP
convertNodeDef
{
bind_src
=
expr
,
bind_dst
=
freeVar
}
varHeap
// MW0 convertNodeDef :: !(Bind Expression FreeVar) VarHeap -> BEMonad BENodeDefP
convertNodeDef
::
!
LetBind
VarHeap
->
BEMonad
BENodeDefP
// MW0 convertNodeDef {bind_src=expr, bind_dst=freeVar} varHeap
convertNodeDef
{
lb_src
=
expr
,
lb_dst
=
freeVar
}
varHeap
=
\
be0
->
let
(
variable_sequence_number
,
be
)
=
getVariableSequenceNumber
freeVar
.
fv_info_ptr
varHeap
be0
in
beNodeDef
variable_sequence_number
(
convertExpr
expr
main_dcl_module_n
varHeap
)
be
collectStrictNodeIds
::
Expression
->
[
FreeVar
]
collectStrictNodeIds
(
Let
{
let_strict_binds
,
let_expr
})
=
[
bind_dst
\\
{
bind_dst
}
<-
let_strict_binds
]
// MW0 = [bind_dst \\ {bind_dst} <- let_strict_binds]
=
[
lb_dst
\\
{
lb_dst
}
<-
let_strict_binds
]
collectStrictNodeIds
_
=
[]
...
...
backend/backendpreprocess.icl
View file @
db332604
...
...
@@ -113,11 +113,15 @@ instance sequence Selection where
sequence
(
DictionarySelection
dictionaryVar
dictionarySelections
_
index
)
=
sequence
index
instance
sequence
(
Bind
Expression
FreeVar
)
where
sequence
{
bind_src
=
App
app
,
bind_dst
}
=
sequence`
app
bind_dst
// MW0 instance sequence (Bind Expression FreeVar) where
instance
sequence
LetBind
where
// MW0 sequence {bind_src=App app , bind_dst}
sequence
{
lb_src
=
App
app
,
lb_dst
}
// MW0 = sequence` app bind_dst
=
sequence`
app
lb_dst
where
sequence`
{
app_symb
,
app_args
}
bind_dst
sequenceState
=:{
ss_aliasDummyId
}
// MW0 sequence` {app_symb, app_args} bind_dst sequenceState=:{ss_aliasDummyId}
sequence`
{
app_symb
,
app_args
}
lb_dst
sequenceState
=:{
ss_aliasDummyId
}
|
app_symb
.
symb_name
==
ss_aliasDummyId
// the compiled source was a strict alias like "#! x = y"
=
case
hd
app_args
of
...
...
@@ -126,13 +130,17 @@ instance sequence (Bind Expression FreeVar) where
non_alias_bound_var
=
case
vi
of
VI_SequenceNumber
_
->
bound_var
VI_Alias
alias_bound_var
->
alias_bound_var
ss_varHeap
=
writePtr
bind_dst
.
fv_info_ptr
(
VI_Alias
non_alias_bound_var
)
ss_varHeap
// MW0 ss_varHeap = writePtr bind_dst.fv_info_ptr (VI_Alias non_alias_bound_var) ss_varHeap
ss_varHeap
=
writePtr
lb_dst
.
fv_info_ptr
(
VI_Alias
non_alias_bound_var
)
ss_varHeap
->
{
sequenceState
&
ss_varHeap
=
ss_varHeap
}
_
->
sequence
bind_dst
sequenceState
=
sequence
bind_dst
sequenceState
// MW0 -> sequence bind_dst sequenceState
->
sequence
lb_dst
sequenceState
// MW0 = sequence bind_dst sequenceState
=
sequence
lb_dst
sequenceState
sequence
bind
=
sequence
bind
.
bind_dst
// MW0 = sequence bind.bind_dst
=
sequence
bind
.
lb_dst
instance
sequence
FunctionPattern
where
sequence
(
FP_Algebraic
_
subpatterns
optionalVar
)
...
...
frontend/check.icl
View file @
db332604
This diff is collapsed.
Click to expand it.
frontend/comparedefimp.icl
View file @
db332604
...
...
@@ -742,8 +742,6 @@ instance e_corresponds DefinedSymbol where
instance
e_corresponds
FunctionBody
where
// both bodies are either CheckedBodies or TransformedBodies
e_corresponds
dclDef
iclDef
// | False--->("compare", from_body dclDef, from_body iclDef)
// = undef
=
e_corresponds
(
from_body
dclDef
)
(
from_body
iclDef
)
where
from_body
(
TransformedBody
{
tb_args
,
tb_rhs
})
=
(
tb_args
,
[
tb_rhs
])
...
...
@@ -824,6 +822,11 @@ instance e_corresponds Let where
o`
e_corresponds
dclLet
.
let_lazy_binds
iclLet
.
let_lazy_binds
o`
e_corresponds
dclLet
.
let_expr
iclLet
.
let_expr
instance
e_corresponds
LetBind
where
e_corresponds
dcl
icl
=
e_corresponds
dcl
.
lb_src
icl
.
lb_src
o`
e_corresponds
dcl
.
lb_dst
icl
.
lb_dst
instance
e_corresponds
(
Bind
a
b
)
|
e_corresponds
a
&
e_corresponds
b
where
e_corresponds
dcl
icl
=
e_corresponds
dcl
.
bind_src
icl
.
bind_src
...
...
@@ -941,6 +944,13 @@ e_corresponds_app_symb dcl_app_symb=:{symb_kind=SK_Function dcl_glob_index}
ec_state
=
continuation_for_possibly_twice_defined_funs
dcl_app_symb
dcl_glob_index
icl_app_symb
icl_glob_index
ec_state
e_corresponds_app_symb
dcl_app_symb
=:{
symb_kind
=
SK_LocalMacroFunction
dcl_index
}
icl_app_symb
=:{
symb_kind
=
SK_LocalMacroFunction
icl_index
}
ec_state
#!
main_dcl_module_n
=
ec_state
.
ec_tc_state
.
tc_main_dcl_module_n
=
continuation_for_possibly_twice_defined_funs
dcl_app_symb
{
glob_module
=
main_dcl_module_n
,
glob_object
=
dcl_index
}
icl_app_symb
{
glob_module
=
main_dcl_module_n
,
glob_object
=
icl_index
}
ec_state
e_corresponds_app_symb
dcl_app_symb
=:{
symb_kind
=
SK_OverloadedFunction
dcl_glob_index
}
icl_app_symb
=:{
symb_kind
=
SK_OverloadedFunction
icl_glob_index
}
ec_state
...
...
frontend/convertDynamics.icl
View file @
db332604
...
...
@@ -101,6 +101,13 @@ where
convertDynamics
_
_
_
No
ci
=
(
No
,
ci
)
instance
convertDynamics
LetBind
where
convertDynamics
::
!
ConversionInput
!
BoundVariables
!
DefaultExpression
!
LetBind
!*
ConversionInfo
->
(!
LetBind
,
!*
ConversionInfo
)
convertDynamics
cinp
bound_vars
default_expr
binding
=:{
lb_src
}
ci
#
(
lb_src
,
ci
)
=
convertDynamics
cinp
bound_vars
default_expr
lb_src
ci
=
({
binding
&
lb_src
=
lb_src
},
ci
)
instance
convertDynamics
(
Bind
a
b
)
|
convertDynamics
a
where
convertDynamics
::
!
ConversionInput
!
BoundVariables
!
DefaultExpression
!(
Bind
a
b
)
!*
ConversionInfo
->
(!
Bind
a
b
,
!*
ConversionInfo
)
|
convertDynamics
a
...
...
@@ -135,7 +142,8 @@ where
=
(
expr
@
exprs
,
ci
)
convertDynamics
cinp
bound_vars
default_expr
(
Let
letje
=:{
let_strict_binds
,
let_lazy_binds
,
let_expr
,
let_info_ptr
})
ci
#
(
let_types
,
ci
)
=
determine_let_types
let_info_ptr
ci
bound_vars
=
bindVarsToTypes
[
bind
.
bind_dst
\\
bind
<-
let_strict_binds
++
let_lazy_binds
]
let_types
bound_vars
// MW0 bound_vars = bindVarsToTypes [ bind.bind_dst \\ bind <- let_strict_binds ++ let_lazy_binds ] let_types bound_vars
bound_vars
=
bindVarsToTypes
[
bind
.
lb_dst
\\
bind
<-
let_strict_binds
++
let_lazy_binds
]
let_types
bound_vars
(
let_strict_binds
,
ci
)
=
convertDynamics
cinp
bound_vars
default_expr
let_strict_binds
ci
(
let_lazy_binds
,
ci
)
=
convertDynamics
cinp
bound_vars
default_expr
let_lazy_binds
ci
(
let_expr
,
ci
)
=
convertDynamics
cinp
bound_vars
default_expr
let_expr
ci
...
...
@@ -205,7 +213,9 @@ where
let_expr
=
App
{
app_symb
=
twoTuple_symb
,
app_args
=
[
dyn_expr
,
dyn_type_code
],
app_info_ptr
=
nilPtr
},
let_info_ptr
=
let_info_ptr
},
ci
)
// MW0 let_info_ptr = let_info_ptr,}, ci)
let_info_ptr
=
let_info_ptr
,
let_expr_position
=
NoPos
},
ci
)
convertDynamics
cinp
bound_vars
default_expr
(
TypeCodeExpression
type_code
)
ci
=
abort
"convertDynamics cinp bound_vars default_expr (TypeCodeExpression"
//convertTypecode cinp type_code ci
convertDynamics
cinp
bound_vars
default_expr
EE
ci
...
...
@@ -358,13 +368,14 @@ where
=
[{
tv_free_var
=
{
fv_def_level
=
NotALevel
,
fv_name
=
a_ij_var_name
,
fv_info_ptr
=
var_info_ptr
,
fv_count
=
0
},
tv_type
=
empty_attributed_type
}
:
bound_vars
]
open_dynamic
::
Expression
!*
ConversionInfo
->
(
OpenedDynamic
,
Bind
Expression
FreeVar
,
!*
ConversionInfo
)
open_dynamic
::
Expression
!*
ConversionInfo
->
(
OpenedDynamic
,
Let
Bind
,
!*
ConversionInfo
)
open_dynamic
dynamic_expr
ci
#
(
twotuple
,
ci
)
=
getTupleSymbol
2
ci
(
dynamicType_var
,
ci
)
=
newVariable
"dt"
VI_Empty
ci
dynamicType_fv
=
varToFreeVar
dynamicType_var
1
=
(
{
opened_dynamic_expr
=
TupleSelect
twotuple
0
dynamic_expr
,
opened_dynamic_type
=
Var
dynamicType_var
},
{
bind_src
=
TupleSelect
twotuple
1
dynamic_expr
,
bind_dst
=
dynamicType_fv
},
// MW0 { bind_src = TupleSelect twotuple 1 dynamic_expr, bind_dst = dynamicType_fv },
{
lb_src
=
TupleSelect
twotuple
1
dynamic_expr
,
lb_dst
=
dynamicType_fv
,
lb_position
=
NoPos
},
{
ci
&
ci_new_variables
=
[
dynamicType_fv
:
ci
.
ci_new_variables
]})
/**************************************************************************************************/
...
...
@@ -395,7 +406,8 @@ convertDynamicPatterns cinp=:{cinp_st_args} bound_vars {case_expr, case_guards =
#
bound_vars
=
addToBoundVars
(
freeVarToVar
dt_bind
.
bind_dst
)
empty_attributed_type
(
addToBoundVars
ind_0
empty_attributed_type
// MW0 bound_vars = addToBoundVars (freeVarToVar dt_bind.bind_dst) empty_attributed_type (addToBoundVars ind_0 empty_attributed_type
bound_vars
=
addToBoundVars
(
freeVarToVar
dt_bind
.
lb_dst
)
empty_attributed_type
(
addToBoundVars
ind_0
empty_attributed_type
(
addToBoundVars
c_1
result_type
(
add_dynamic_bound_vars
patterns
bound_vars
)))
// c_1 ind_0
...
...
@@ -407,14 +419,17 @@ convertDynamicPatterns cinp=:{cinp_st_args} bound_vars {case_expr, case_guards =
#
(
tc_binds
,
ci
)
=
foldSt
remove_non_used_arg
tc_binds
([],
ci
)
=
(
Let
{
let_strict_binds
=
[],
let_lazy_binds
=
[
dt_bind
:
binds
]
++
tc_binds
,
let_expr
=
expr
,
let_info_ptr
=
let_info_ptr
},
ci
)
// MW0 = (Let {let_strict_binds = [], let_lazy_binds = [ dt_bind : binds ] ++ tc_binds, let_expr = expr, let_info_ptr = let_info_ptr}, ci)
=
(
Let
{
let_strict_binds
=
[],
let_lazy_binds
=
[
dt_bind
:
binds
]
++
tc_binds
,
let_expr
=
expr
,
let_info_ptr
=
let_info_ptr
,
let_expr_position
=
NoPos
},
ci
)
where
remove_non_used_arg
::
(
Bind
Expression
FreeVar
)
([
Bind
Expression
FreeVar
],*
ConversionInfo
)
->
([
Bind
Expression
FreeVar
],*
ConversionInfo
)
remove_non_used_arg
tc_bind
=:{
bind_dst
={
fv_info_ptr
}}
(
l
,
ci
=:{
ci_var_heap
})
// MW0 remove_non_used_arg :: (Bind Expression FreeVar) ([Bind Expression FreeVar],*ConversionInfo) -> ([Bind Expression FreeVar],*ConversionInfo)
remove_non_used_arg
::
LetBind
([
LetBind
],*
ConversionInfo
)
->
([
LetBind
],*
ConversionInfo
)
remove_non_used_arg
tc_bind
=:{
lb_dst
={
fv_info_ptr
}}
(
l
,
ci
=:{
ci_var_heap
})
#
(
VI_Indirection
ref_count
,
ci_var_heap
)
=
readPtr
fv_info_ptr
ci_var_heap
|
ref_count
>
0
#!
tc_bind
=
{
tc_bind
&
b
ind
_dst
=
{
tc_bind
.
b
ind
_dst
&
fv_count
=
ref_count
}
}
=
{
tc_bind
&
l
b_dst
=
{
tc_bind
.
l
b_dst
&
fv_count
=
ref_count
}
}
=
([
tc_bind
:
l
],{
ci
&
ci_var_heap
=
ci_var_heap
})
=
(
l
,{
ci
&
ci_var_heap
=
ci_var_heap
})
...
...
@@ -440,15 +455,19 @@ where
=
addToBoundVars
placeholder_var
empty_attributed_type
bound_vars
=
(
bind
,(
bound_vars2
,
ci
));
where
create_variable
::
!
Ident
VarInfoPtr
!*
ConversionInfo
->
(
Bind
Expression
FreeVar
,
!*
ConversionInfo
)
// MW0 create_variable :: !Ident VarInfoPtr !*ConversionInfo -> (Bind Expression FreeVar, !*ConversionInfo)
create_variable
::
!
Ident
VarInfoPtr
!*
ConversionInfo
->
(
LetBind
,
!*
ConversionInfo
)
create_variable
var_name
var_info_ptr
ci
#
(
placeholder_symb
,
ci
)
=
getSymbol
PD_variablePlaceholder
SK_Constructor
3
ci
cyclic_var
=
{
var_name
=
var_name
,
var_info_ptr
=
var_info_ptr
,
var_expr_ptr
=
nilPtr
}
cyclic_fv
=
varToFreeVar
cyclic_var
1
=
({
bind_src
=
App
{
app_symb
=
placeholder_symb
,
app_args
=
[
Var
cyclic_var
,
Var
cyclic_var
],
app_info_ptr
=
nilPtr
},
bind_dst
=
varToFreeVar
cyclic_var
1
// MW0 = ({ bind_src = App { app_symb = placeholder_symb,
=
({
lb_src
=
App
{
app_symb
=
placeholder_symb
,
app_args
=
[
Var
cyclic_var
,
Var
cyclic_var
],
app_info_ptr
=
nilPtr
},
// MW0 bind_dst = varToFreeVar cyclic_var 1
lb_dst
=
varToFreeVar
cyclic_var
1
,
lb_position
=
NoPos
},
{
ci
&
ci_new_variables
=
[
cyclic_fv
:
ci
.
ci_new_variables
]}
/*ci*/
)
...
...
@@ -508,12 +527,17 @@ where
#
let_expr
=
Let
{
let_strict_binds
=
[]
,
let_lazy_binds
=
(
if
(
isNo
this_default
)
[]
[
{
bind_src
=
opt
opt_expr
,
bind_dst
=
c_inc_i_fv
}])
++
[
{
bind_src
=
App
{
app_symb
=
coerce_symb
,
app_args
=
[
Var
a_ij_var
,
Var
a_ij_tc_var
],
app_info_ptr
=
nilPtr
},
bind_dst
=
coerce_result_fv
}
// MW0 , let_lazy_binds = (if (isNo this_default) [] [ {bind_src = opt opt_expr , bind_dst = c_inc_i_fv }]) ++ [
// MW0 { bind_src = App { app_symb = coerce_symb, app_args = [Var a_ij_var, Var a_ij_tc_var], app_info_ptr = nilPtr },
// MW0 bind_dst = coerce_result_fv }
,
let_lazy_binds
=
(
if
(
isNo
this_default
)
[]
[
{
lb_src
=
opt
opt_expr
,
lb_dst
=
c_inc_i_fv
,
lb_position
=
NoPos
}])
++
[
{
lb_src
=
App
{
app_symb
=
coerce_symb
,
app_args
=
[
Var
a_ij_var
,
Var
a_ij_tc_var
],
app_info_ptr
=
nilPtr
},
lb_dst
=
coerce_result_fv
,
lb_position
=
NoPos
}
,
{
bind_src
=
TupleSelect
twotuple
0
(
Var
coerce_result_var
),
bind_dst
=
coerce_bool_fv
}
:
let_binds
// MW0 { bind_src = TupleSelect twotuple 0 (Var coerce_result_var),
// MW0 bind_dst = coerce_bool_fv } : let_binds
{
lb_src
=
TupleSelect
twotuple
0
(
Var
coerce_result_var
),
lb_dst
=
coerce_bool_fv
,
lb_position
=
NoPos
}
:
let_binds
],
let_expr
=
Case
{
case_expr
=
Var
coerce_bool_var
,
...
...
@@ -524,6 +548,7 @@ where
case_info_ptr
=
case_info_ptr
,
case_default_pos
=
NoPos
}
// MW4++
,
let_info_ptr
=
let_info_ptr
,
let_expr_position
=
NoPos
// MW0++
}
// dp_rhs
...
...
@@ -532,7 +557,8 @@ where
opt
(
Yes
x
)
=
x
convert_dynamic_pattern
::
!
ConversionInput
!
BoundVariables
DefaultExpression
Int
OpenedDynamic
AType
(
Optional
Expression
)
![
DynamicPattern
]
*
ConversionInfo
->
(
Env
Expression
FreeVar
,
Expression
,
*
ConversionInfo
)
/// MW0 -> (Env Expression FreeVar, Expression, *ConversionInfo)
->
([
LetBind
],
Expression
,
*
ConversionInfo
)
convert_dynamic_pattern
cinp
bound_vars
this_default
pattern_number
opened_dynamic
result_type
last_default
[{
dp_var
,
dp_type_patterns_vars
,
dp_type_code
,
dp_rhs
}
:
patterns
]
ci
#
/*** The last case may not have a default ***/
...
...
@@ -609,10 +635,14 @@ where
a_ij_binds
=
add_x_i_bind
opened_dynamic
.
opened_dynamic_expr
dp_var
a_ij_binds
let_expr
=
Let
{
let_strict_binds
=
[],
let_lazy_binds
=
[{
bind_src
=
App
{
app_symb
=
unify_symb
,
app_args
=
[
opened_dynamic
.
opened_dynamic_type
,
type_code
],
app_info_ptr
=
nilPtr
},
bind_dst
=
unify_result_fv
},
{
bind_src
=
TupleSelect
twotuple
0
(
Var
unify_result_var
),
bind_dst
=
unify_bool_fv
}
:
let_binds
// MW0 let_lazy_binds = [{ bind_src = App { app_symb = unify_symb, app_args = [opened_dynamic.opened_dynamic_type, type_code], app_info_ptr = nilPtr },
// MW0 bind_dst = unify_result_fv },
// MW0 { bind_src = TupleSelect twotuple 0 (Var unify_result_var),
// MW0 bind_dst = unify_bool_fv } : let_binds
let_lazy_binds
=
[{
lb_src
=
App
{
app_symb
=
unify_symb
,
app_args
=
[
opened_dynamic
.
opened_dynamic_type
,
type_code
],
app_info_ptr
=
nilPtr
},
lb_dst
=
unify_result_fv
,
lb_position
=
NoPos
},
{
lb_src
=
TupleSelect
twotuple
0
(
Var
unify_result_var
),
lb_dst
=
unify_bool_fv
,
lb_position
=
NoPos
}
:
let_binds
],
let_expr
=
Case
{
case_expr
=
Var
unify_bool_var
,
// MW was: case_guards = BasicPatterns BT_Bool [{bp_value = BVB True, bp_expr = dp_rhs}],
...
...
@@ -621,13 +651,17 @@ where
case_ident
=
No
,
case_info_ptr
=
case_info_ptr
,
case_default_pos
=
NoPos
},
// MW4++
let_info_ptr
=
let_info_ptr
}
// MW0 let_info_ptr = let_info_ptr }
let_info_ptr
=
let_info_ptr
,
let_expr_position
=
NoPos
}
=
(
a_ij_binds
++
binds
,
let_expr
,
{
ci
&
ci_new_variables
=
[
unify_result_fv
,
unify_bool_fv
:
ci
.
ci_new_variables
]})
where
add_x_i_bind
bind_src
bind_dst
=:{
fv_count
}
binds
// MW0 add_x_i_bind bind_src bind_dst=:{fv_count} binds
add_x_i_bind
lb_src
lb_dst
=:{
fv_count
}
binds
|
fv_count
>
0
=
[
{
bind_src
=
bind_src
,
bind_dst
=
bind_dst
}
:
binds
]
// MW0 = [ { bind_src = bind_src, bind_dst = bind_dst } : binds ]
=
[
{
lb_src
=
lb_src
,
lb_dst
=
lb_dst
,
lb_position
=
NoPos
}
:
binds
]
=
binds
isLastDynamicPattern
dp_rhs
=:(
Case
keesje
=:{
case_guards
=
DynamicPatterns
_})
...
...
@@ -643,7 +677,8 @@ where
// other alternatives
convert_other_patterns
::
ConversionInput
BoundVariables
DefaultExpression
Int
OpenedDynamic
AType
!(
Optional
Expression
)
![
DynamicPattern
]
!*
ConversionInfo
->
(
Env
Expression
FreeVar
,
*
ConversionInfo
)
// MW0 -> (Env Expression FreeVar, *ConversionInfo)
->
([
LetBind
],
*
ConversionInfo
)
convert_other_patterns
_
_
_
_
_
_
No
[]
ci
// no default and no alternatives left
=
([],
ci
)
...
...
@@ -669,7 +704,8 @@ bind_indirection_var var=:{var_info_ptr} unify_result_var twotuple ci=:{ci_var_h
#
(
VI_Indirection
ref_count
,
ci_var_heap
)
=
readPtr
var_info_ptr
ci_var_heap
|
ref_count
>
0
#
ind_fv
=
varToFreeVar
var
ref_count
=
([{
bind_src
=
TupleSelect
twotuple
1
(
Var
unify_result_var
),
bind_dst
=
ind_fv
}],
// MW0 = ([{ bind_src = TupleSelect twotuple 1 (Var unify_result_var), bind_dst = ind_fv }],
=
([{
lb_src
=
TupleSelect
twotuple
1
(
Var
unify_result_var
),
lb_dst
=
ind_fv
,
lb_position
=
NoPos
}],
{
ci
&
ci_var_heap
=
ci_var_heap
,
ci_new_variables
=
[
ind_fv
:
ci_new_variables
]})
=
([],
{
ci
&
ci_var_heap
=
ci_var_heap
})
...
...
@@ -679,12 +715,14 @@ bind_indirection_var var=:{var_info_ptr} unify_result_var twotuple ci=:{ci_var_h
it is converted into a function. The references are replaced by an appropriate function application.
*/
generateBinding
::
!
ConversionInput
BoundVariables
BoundVar
Expression
AType
!*
ConversionInfo
->
*(
Bind
Expression
FreeVar
,
*
ConversionInfo
)
// MW0 generateBinding :: !ConversionInput BoundVariables BoundVar Expression AType !*ConversionInfo -> *(Bind Expression FreeVar, *ConversionInfo)
generateBinding
::
!
ConversionInput
BoundVariables
BoundVar
Expression
AType
!*
ConversionInfo
->
*(
LetBind
,
*
ConversionInfo
)
generateBinding
cinp
bound_vars
var
bind_expr
result_type
ci
#
(
ref_count
,
ci
)
=
get_reference_count
var
ci
|
ref_count
==
0
#
free_var
=
varToFreeVar
var
1
=
({
bind_src
=
bind_expr
,
bind_dst
=
free_var
},
{
ci
&
ci_new_variables
=
[
free_var
:
ci
.
ci_new_variables
]})
// MW0 = ({ bind_src = bind_expr, bind_dst = free_var }, { ci & ci_new_variables = [ free_var : ci.ci_new_variables ]})
=
({
lb_src
=
bind_expr
,
lb_dst
=
free_var
,
lb_position
=
NoPos
},
{
ci
&
ci_new_variables
=
[
free_var
:
ci
.
ci_new_variables
]})
#
(
saved_defaults
,
ci_var_heap
)
=
foldSt
save_default
bound_vars
([],
ci
.
ci_var_heap
)
(
act_args
,
free_typed_vars
,
local_free_vars
,
tb_rhs
,
ci_var_heap
)
=
copyExpression
bound_vars
bind_expr
ci_var_heap
#
...
...
@@ -696,10 +734,13 @@ generateBinding cinp bound_vars var bind_expr result_type ci
=
newFunction
No
(
TransformedBody
{
tb_args
=
tb_args
,
tb_rhs
=
tb_rhs
})
local_free_vars
arg_types
result_type
cinp
.
cinp_group_index
(
ci
.
ci_next_fun_nr
,
ci
.
ci_new_functions
,
ci
.
ci_fun_heap
)
free_var
=
varToFreeVar
var
(
inc
ref_count
)
=
({
bind_src
=
App
{
app_symb
=
fun_symb
,
app_args
=
act_args
,
app_info_ptr
=
nilPtr
},
bind_dst
=
free_var
},
// MW0 = ({ bind_src = App { app_symb = fun_symb,
=
({
lb_src
=
App
{
app_symb
=
fun_symb
,
app_args
=
act_args
,
app_info_ptr
=
nilPtr
},
// MW0 bind_dst = free_var },
lb_dst
=
free_var
,
lb_position
=
NoPos
},
{
ci
&
ci_var_heap
=
ci_var_heap
,
ci_next_fun_nr
=
ci_next_fun_nr
,
ci_new_functions
=
ci_new_functions
,
ci_fun_heap
=
ci_fun_heap
,
ci_new_variables
=
[
free_var
:
ci_new_variables
]
})
where
...
...
@@ -732,19 +773,24 @@ generateBinding cinp bound_vars var bind_expr result_type ci
/**************************************************************************************************/
createVariables
::
[
VarInfoPtr
]
!(
Env
Expression
FreeVar
)
!*
ConversionInfo
->
(!
Env
Expression
FreeVar
,
!*
ConversionInfo
)
// MW0 createVariables :: [VarInfoPtr] !(Env Expression FreeVar) !*ConversionInfo -> (!Env Expression FreeVar, !*ConversionInfo)
createVariables
::
[
VarInfoPtr
]
![
LetBind
]
!*
ConversionInfo
->
(![
LetBind
],
!*
ConversionInfo
)
createVariables
var_info_ptrs
binds
ci
=
mapAppendSt
(
create_variable
a_ij_var_name
)
var_info_ptrs
binds
ci
create_variable
::
!
Ident
VarInfoPtr
!*
ConversionInfo
->
(
Bind
Expression
FreeVar
,
!*
ConversionInfo
)
// MW0create_variable :: !Ident VarInfoPtr !*ConversionInfo -> (Bind Expression FreeVar, !*ConversionInfo)
create_variable
::
!
Ident
VarInfoPtr
!*
ConversionInfo
->
(
LetBind
,
!*
ConversionInfo
)
create_variable
var_name
var_info_ptr
ci
#
(
placeholder_symb
,
ci
)
=
getSymbol
PD_variablePlaceholder
SK_Constructor
3
ci
cyclic_var
=
{
var_name
=
var_name
,
var_info_ptr
=
var_info_ptr
,
var_expr_ptr
=
nilPtr
}
cyclic_fv
=
varToFreeVar
cyclic_var
1
=
({
bind_src
=
App
{
app_symb
=
placeholder_symb
,
// MW0 = ({ bind_src = App { app_symb = placeholder_symb,
=
({
lb_src
=
App
{
app_symb
=
placeholder_symb
,
app_args
=
[
Var
cyclic_var
,
Var
cyclic_var
],
app_info_ptr
=
nilPtr
},
bind_dst
=
varToFreeVar
cyclic_var
1
// MW0 bind_dst = varToFreeVar cyclic_var 1
lb_dst
=
varToFreeVar
cyclic_var
1
,
lb_position
=
NoPos
},
{
ci
&
ci_new_variables
=
[
cyclic_fv
:
ci
.
ci_new_variables
]})
...
...
frontend/convertcases.icl
View file @
db332604
...
...
@@ -28,6 +28,12 @@ where
convertCases
bound_vars
group_index
common_defs
t
ci
=
app2St
(
convertCases
bound_vars
group_index
common_defs
,
convertCases
bound_vars
group_index
common_defs
)
t
ci
instance
convertCases
LetBind
where
convertCases
bound_vars
group_index
common_defs
bind
=:{
lb_src
}
ci
#
(
lb_src
,
ci
)
=
convertCases
bound_vars
group_index
common_defs
lb_src
ci
=
({
bind
&
lb_src
=
lb_src
},
ci
)
instance
convertCases
(
Bind
a
b
)
|
convertCases
a
where
convertCases
bound_vars
group_index
common_defs
bind
=:{
bind_src
}
ci
...
...
@@ -55,8 +61,10 @@ where
_
->
abort
"convertCases [Let] (convertcases 53)"
// <<- let_info
addLetVars
[{
bind_dst
}
:
binds
]
[
bind_type
:
bind_types
]
bound_vars
=
addLetVars
binds
bind_types
[
(
bind_dst
,
bind_type
)
:
bound_vars
]
// MW0 addLetVars [{bind_dst} : binds] [bind_type : bind_types] bound_vars
// MW0 = addLetVars binds bind_types [ (bind_dst, bind_type) : bound_vars ]
addLetVars
[{
lb_dst
}
:
binds
]
[
bind_type
:
bind_types
]
bound_vars
=
addLetVars
binds
bind_types
[
(
lb_dst
,
bind_type
)
:
bound_vars
]
addLetVars
[]
_
bound_vars
=
bound_vars
...
...
@@ -805,8 +813,10 @@ where
#
(
let_expr
,
cp_info
)
=
copy
let_expr
cp_info
=
(
Let
{
lad
&
let_strict_binds
=
let_strict_binds
,
let_lazy_binds
=
let_lazy_binds
,
let_expr
=
let_expr
},
cp_info
)
where
bind_let_var
{
bind_dst
}
(
local_vars
,
var_heap
)
=
([
bind_dst
:
local_vars
],
var_heap
<:=
(
bind_dst
.
fv_info_ptr
,
VI_LocalVar
))
// MW0 bind_let_var {bind_dst} (local_vars, var_heap)
// MW0 = ([bind_dst : local_vars], var_heap <:= (bind_dst.fv_info_ptr, VI_LocalVar))
bind_let_var
{
lb_dst
}
(
local_vars
,
var_heap
)
=
([
lb_dst
:
local_vars
],
var_heap
<:=
(
lb_dst
.
fv_info_ptr
,
VI_LocalVar
))
copy
(
Case
case_expr
)
cp_info
#
(
case_expr
,
cp_info
)
=
copy
case_expr
cp_info
=
(
Case
case_expr
,
cp_info
)
...
...
@@ -947,6 +957,12 @@ instance copy (a,b) | copy a & copy b
where
copy
t
cp_info
=
app2St
(
copy
,
copy
)
t
cp_info
instance
copy
LetBind
where
copy
bind
=:{
lb_src
}
cp_info
#
(
lb_src
,
cp_info
)
=
copy
lb_src
cp_info
=
({
bind
&
lb_src
=
lb_src
},
cp_info
)
instance
copy
(
Bind
a
b
)
|
copy
a
where
copy
bind
=:{
bind_src
}
cp_info
...
...
@@ -1027,7 +1043,8 @@ where
where
remove_variable
([],
var_heap
)
let_bind
=
([],
var_heap
)
remove_variable
([
var_ptr
:
var_ptrs
],
var_heap
)
bind
=:{
bind_dst
={
fv_name
,
fv_info_ptr
}}
// MW0 remove_variable ([var_ptr : var_ptrs], var_heap) bind=:{bind_dst={fv_name,fv_info_ptr}}
remove_variable
([
var_ptr
:
var_ptrs
],
var_heap
)
bind
=:{
lb_dst
={
fv_name
,
fv_info_ptr
}}
|
fv_info_ptr
==
var_ptr
#
(
VI_LetVar
{
lvi_count
,
lvi_depth
},
var_heap
)
=
readPtr
fv_info_ptr
var_heap
=
(
var_ptrs
,
var_heap
)
...
...
@@ -1035,11 +1052,14 @@ where
#
(
var_ptrs
,
var_heap
)
=
remove_variable
(
var_ptrs
,
var_heap
)
bind
=
([
var_ptr
:
var_ptrs
],
var_heap
)
store_binding
{
bind_dst
={
fv_name
,
fv_info_ptr
},
bind_src
}
var_heap
// MW0 store_binding {bind_dst={fv_name,fv_info_ptr},bind_src} var_heap
store_binding
{
lb_dst
={
fv_name
,
fv_info_ptr
},
lb_src
}
var_heap
=
var_heap
<:=
(
fv_info_ptr
,
VI_LetVar
{
lvi_count
=
0
,
lvi_depth
=
depth
,
lvi_previous
=
[],
lvi_new
=
True
,
lvi_expression
=
bind_src
,
lvi_var
=
fv_name
})
// MW0 lvi_new = True, lvi_expression = bind_src, lvi_var = fv_name})
lvi_new
=
True
,
lvi_expression
=
lb_src
,
lvi_var
=
fv_name
})
get_ref_count
{
bind_dst
={
fv_name
,
fv_info_ptr
}}
var_heap
// MW0 get_ref_count {bind_dst={fv_name,fv_info_ptr}} var_heap
get_ref_count
{
lb_dst
={
fv_name
,
fv_info_ptr
}}
var_heap
#
(
VI_LetVar
{
lvi_count
},
var_heap
)
=
readPtr
fv_info_ptr
var_heap
=
(
lvi_count
,
var_heap
)
// ==> (fv_name,fv_info_ptr,lvi_count)
...
...
@@ -1227,6 +1247,11 @@ instance weightedRefCount (a,b) | weightedRefCount a & weightedRefCount b
where
weightedRefCount
dcl_functions
common_defs
depth
(
x
,
y
)
rc_info
=
weightedRefCount
dcl_functions
common_defs
depth
y
(
weightedRefCount
dcl_functions
common_defs
depth
x
rc_info
)
instance
weightedRefCount
LetBind
where
weightedRefCount
dcl_functions
common_defs
depth
{
lb_src
}
rc_info
=
weightedRefCount
dcl_functions
common_defs
depth
lb_src
rc_info
instance
weightedRefCount
(
Bind
a
b
)
|
weightedRefCount
a
where
weightedRefCount
dcl_functions
common_defs
depth
bind
=:{
bind_src
}
rc_info
...
...
@@ -1324,15 +1349,23 @@ where
_
->
(
Let
{
lad
&
let_strict_binds
=
let_strict_binds
,
let_expr
=
let_expr
,
let_lazy_binds
=
[]},
{
dl_info
&
di_expr_heap
=
dl_info
.
di_expr_heap
<:=
(
let_info_ptr
,
EI_LetType
(
take
nr_of_strict_lets
let_type
))})
where
/* MW0
set_let_expression_info depth [(let_strict, {bind_src,bind_dst}):binds][ref_count:ref_counts][type:types] var_heap
# (new_info_ptr, var_heap) = newPtr VI_Empty var_heap
lei = { lei_count = ref_count, lei_depth = depth, lei_var = { bind_dst & fv_info_ptr = new_info_ptr },
lei_expression = bind_src, lei_type = type, lei_status = LES_Untouched }
= set_let_expression_info depth binds ref_counts types (var_heap <:= (bind_dst.fv_info_ptr, VI_LetExpression lei))
*/
set_let_expression_info
depth
[(
let_strict
,
{
lb_src
,
lb_dst
}):
binds
][
ref_count
:
ref_counts
][
type
:
types
]
var_heap
#
(
new_info_ptr
,
var_heap
)
=
newPtr
VI_Empty
var_heap
lei
=
{
lei_count
=
ref_count
,
lei_depth
=
depth
,
lei_var
=
{
lb_dst
&
fv_info_ptr
=
new_info_ptr
},
lei_expression
=
lb_src
,
lei_type
=
type
,
lei_status
=
LES_Untouched
}
=
set_let_expression_info
depth
binds
ref_counts
types
(
var_heap
<:=
(
lb_dst
.
fv_info_ptr
,
VI_LetExpression
lei
))
set_let_expression_info
depth
[]
_
_
var_heap
=
var_heap
distribute_lets_in_non_distributed_let
depth
{
bind_dst
={
fv_name
,
fv_info_ptr
}}
dl_info
=:{
di_var_heap
}
// MW0 distribute_lets_in_non_distributed_let depth {bind_dst={fv_name,fv_info_ptr}} dl_info=:{di_var_heap}
distribute_lets_in_non_distributed_let
depth
{
lb_dst
={
fv_name
,
fv_info_ptr
}}
dl_info
=:{
di_var_heap
}
#
(
VI_LetExpression
lei
=:{
lei_depth
,
lei_count
,
lei_status
},
di_var_heap
)
=
readPtr
fv_info_ptr
di_var_heap
|
lei_count
>
0
// | not lei_moved && lei_count > 0
...
...
@@ -1475,10 +1508,14 @@ buildLetExpr let_vars let_expr (var_heap, expr_heap)
->
(
Let
{
inner_let
&
let_lazy_binds
=
lazy_binds
},
(
var_heap
,
expr_heap
))
_
#
(
let_info_ptr
,
expr_heap
)
=
newPtr
(
EI_LetType
lazy_binds_types
)
expr_heap
->
(
Let
{
let_strict_binds
=
[],
let_lazy_binds
=
lazy_binds
,
let_expr
=
let_expr
,
let_info_ptr
=
let_info_ptr
},
(
var_heap
,
expr_heap
))
// MW0 -> (Let { let_strict_binds = [], let_lazy_binds = lazy_binds, let_expr = let_expr, let_info_ptr = let_info_ptr }, (var_heap, expr_heap))
->
(
Let
{
let_strict_binds
=
[],
let_lazy_binds
=
lazy_binds
,
let_expr
=
let_expr
,
let_info_ptr
=
let_info_ptr
,
let_expr_position
=
NoPos
},
(
var_heap
,
expr_heap
))
where
build_bind
::
!
VarInfoPtr
!(!
Env
Expression
FreeVar
,
![
AType
],
!*
VarHeap
)
->
(!
Env
Expression
FreeVar
,
![
AType
],
!*
VarHeap
)
// MW0 build_bind :: !VarInfoPtr !(!Env Expression FreeVar, ![AType], !*VarHeap)
// MW0 -> (!Env Expression FreeVar, ![AType], !*VarHeap)
build_bind
::
!
VarInfoPtr
!(![
LetBind
],
![
AType
],
!*
VarHeap
)
->
(![
LetBind
],
![
AType
],
!*
VarHeap
)
build_bind
info_ptr
(
lazy_binds
,
lazy_binds_types
,
var_heap
)
#
(
let_info
,
var_heap
)
=
readPtr
info_ptr
var_heap
#
(
VI_LetExpression
lei
=:{
lei_var
,
lei_expression
,
lei_status
,
lei_type
})
=
let_info
...
...
@@ -1486,7 +1523,8 @@ where
(
new_info_ptr
,
var_heap
)
=
newPtr
VI_Empty
var_heap
var_heap
=
var_heap
<:=
(
info_ptr
,
VI_LetExpression
{
lei
&
lei_status
=
LES_Untouched
,
lei_var
=
{
lei_var
&
fv_info_ptr
=
new_info_ptr
}})
// ==> (lei_var.fv_name, info_ptr, new_info_ptr)
=
([{
bind_src
=
updated_expr
,
bind_dst
=
lei_var
}
:
lazy_binds
],
[
lei_type
:
lazy_binds_types
],
var_heap