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-compiler-and-rts
compiler
Commits
6bd1fd28
Commit
6bd1fd28
authored
Dec 17, 2001
by
John van Groningen
Browse files
implement pattern matching of strict, unboxed and overloaded lists
in let, with and where expressions
parent
f9248303
Changes
5
Hide whitespace changes
Inline
Side-by-side
backend/backendconvert.icl
View file @
6bd1fd28
...
...
@@ -1866,7 +1866,17 @@ where
convertExpr
(
TupleSelect
{
ds_arity
}
n
expr
)
=
beTupleSelectNode
ds_arity
n
(
convertExpr
expr
)
convertExpr
(
MatchExpr
{
glob_module
,
glob_object
={
ds_index
,
ds_arity
}}
expr
)
=
beMatchNode
ds_arity
(
beConstructorSymbol
glob_module
ds_index
)
(
convertExpr
expr
)
|
glob_module
==
cPredefinedModuleIndex
&&
(
let
pd_cons_index
=
ds_index
+
FirstConstructorPredefinedSymbolIndex
in
pd_cons_index
==
PD_UnboxedConsSymbol
||
pd_cons_index
==
PD_UnboxedTailStrictConsSymbol
||
pd_cons_index
==
PD_OverloadedConsSymbol
)
=
case
expr
of
App
{
app_args
=[
src_expr
],
app_symb
={
symb_kind
=
SK_Function
{
glob_module
=
decons_module
,
glob_object
=
deconsindex
}}}
->
beMatchNode
ds_arity
(
beOverloadedConsSymbol
glob_module
ds_index
decons_module
deconsindex
)
(
convertExpr
src_expr
)
_
->
convertExpr
expr
=
beMatchNode
ds_arity
(
beConstructorSymbol
glob_module
ds_index
)
(
convertExpr
expr
)
convertExpr
(
Conditional
{
if_cond
=
cond
,
if_then
,
if_else
=
Yes
else
})
=
beIfNode
(
convertExpr
cond
)
(
convertExpr
if_then
)
(
convertExpr
else
)
...
...
backendC/CleanCompilerSources/codegen1.c
View file @
6bd1fd28
...
...
@@ -2374,6 +2374,9 @@ SymbDef create_match_function (SymbolP constructor_symbol,int constructor_arity,
if
(
strict_constructor
){
struct
arg
**
rhs_arg_p
,
*
lhs_arg
;
StateP
constructor_arg_state_p
;
#if STRICT_LISTS
StateS
head_and_tail_states
[
2
];
#endif
lhs_function_arg
=
NewArgument
(
constructor_node
);
lhs_function_arg
->
arg_state
=
StrictState
;
...
...
@@ -2381,6 +2384,26 @@ SymbDef create_match_function (SymbolP constructor_symbol,int constructor_arity,
rhs_root
=
NewNode
(
TupleSymbol
,
NULL
,
constructor_arity
);
rhs_arg_p
=&
rhs_root
->
node_arguments
;
#if STRICT_LISTS
if
(
constructor_symbol
->
symb_kind
==
cons_symb
&&
constructor_symbol
->
symb_head_strictness
>
1
||
constructor_symbol
->
symb_tail_strictness
){
constructor_symbol
->
symb_def
->
sdef_constructor
->
cl_state_p
;
if
(
constructor_symbol
->
symb_head_strictness
>
1
){
if
(
constructor_symbol
->
symb_head_strictness
==
4
)
head_and_tail_states
[
0
]
=*
constructor_symbol
->
symb_state_p
;
else
head_and_tail_states
[
0
]
=
StrictState
;
}
else
head_and_tail_states
[
0
]
=
LazyState
;
if
(
constructor_symbol
->
symb_tail_strictness
)
head_and_tail_states
[
1
]
=
StrictState
;
else
head_and_tail_states
[
1
]
=
LazyState
;
constructor_arg_state_p
=
head_and_tail_states
;
}
else
#endif
constructor_arg_state_p
=
constructor_symbol
->
symb_def
->
sdef_constructor
->
cl_state_p
;
for_l
(
lhs_arg
,
constructor_node
->
node_arguments
,
arg_next
){
...
...
backendC/CleanCompilerSources/codegen2.c
View file @
6bd1fd28
...
...
@@ -2754,7 +2754,7 @@ LabDef *unboxed_cons_label (SymbolP cons_symbol_p)
if
(
cons_symbol_p
->
symb_unboxed_cons_state_p
->
state_type
==
SimpleState
&&
BETWEEN
(
IntObj
,
FileObj
,
cons_symbol_p
->
symb_unboxed_cons_state_p
->
state_object
))
return
&
unboxed_cons_labels
[
cons_symbol_p
->
symb_unboxed_cons_state_p
->
state_object
-
IntObj
][
cons_symbol_p
->
symb_tail_strictness
];
else
if
(
cons_symbol_p
->
symb_unboxed_cons_state_p
->
state_type
==
RecordState
){
unboxed_record_cons_lab
.
lab_mod
=
NULL
;
unboxed_record_cons_lab
.
lab_mod
=
ExportLocalLabels
?
CurrentModule
:
NULL
;
unboxed_record_cons_lab
.
lab_pref
=
cons_symbol_p
->
symb_tail_strictness
?
"r_Cons#!"
:
"r_Cons#"
;
unboxed_record_cons_lab
.
lab_issymbol
=
False
;
unboxed_record_cons_lab
.
lab_name
=
cons_symbol_p
->
symb_unboxed_cons_state_p
->
state_record_symbol
->
sdef_ident
->
ident_name
;
...
...
@@ -3901,9 +3901,13 @@ void FillMatchNode (Node node,int *asp_p,int *bsp_p,NodeId update_node_id,CodeGe
}
}
if
(
!
symbol_arity_eq_one
)
if
(
!
symbol_arity_eq_one
){
#if STRICT_LISTS
if
(
symbol
->
symb_kind
==
cons_symb
&&
symbol
->
symb_head_strictness
>
1
||
symbol
->
symb_tail_strictness
)
strict_constructor
=
1
;
#endif
new_match_sdef
=
create_match_function
(
symbol
,
node
->
node_arity
,
strict_constructor
);
else
}
else
new_match_sdef
=
create_select_and_match_function
(
symbol
,
strict_constructor
);
ConvertSymbolToDandNLabel
(
&
name
,
&
codelab
,
new_match_sdef
);
...
...
@@ -4009,7 +4013,42 @@ void FillMatchNode (Node node,int *asp_p,int *bsp_p,NodeId update_node_id,CodeGe
*
bsp_p
+=
b_size
;
AdjustTuple
(
a_size
,
b_size
,
asp_p
,
bsp_p
,
arity
,
demanded_state_array
,
constructor_args_state_p
,
a_size
,
b_size
);
}
else
{
}
else
#if STRICT_LISTS
if
(
symbol
->
symb_kind
==
cons_symb
&&
(
symbol
->
symb_head_strictness
>
1
||
symbol
->
symb_tail_strictness
)){
StateS
head_and_tail_states
[
2
];
if
(
symbol
->
symb_head_strictness
>
1
){
if
(
symbol
->
symb_head_strictness
==
4
)
head_and_tail_states
[
0
]
=*
symbol
->
symb_state_p
;
else
head_and_tail_states
[
0
]
=
StrictState
;
}
else
head_and_tail_states
[
0
]
=
LazyState
;
if
(
symbol
->
symb_tail_strictness
)
head_and_tail_states
[
1
]
=
StrictState
;
else
head_and_tail_states
[
1
]
=
LazyState
;
if
(
symbol
->
symb_head_strictness
==
4
){
DetermineSizeOfState
(
head_and_tail_states
[
0
],
&
a_size
,
&
b_size
);
++
a_size
;
GenReplRArgs
(
a_size
,
b_size
);
*
asp_p
-=
1
-
a_size
;
*
bsp_p
+=
b_size
;
AdjustTuple
(
a_size
,
b_size
,
asp_p
,
bsp_p
,
2
,
demanded_state_array
,
head_and_tail_states
,
a_size
,
b_size
);
}
else
{
GenReplArgs
(
2
,
2
);
*
asp_p
-=
1
-
2
;
AdjustTuple
(
2
,
0
,
asp_p
,
bsp_p
,
2
,
demanded_state_array
,
head_and_tail_states
,
2
,
0
);
}
}
else
#endif
{
*
asp_p
-=
1
;
UnpackTuple
(
*
asp_p
,
asp_p
,
bsp_p
,
True
,
demanded_state_arity
,
demanded_state_array
);
}
...
...
frontend/checkFunctionBodies.icl
View file @
6bd1fd28
...
...
@@ -58,9 +58,9 @@ get_unboxed_list_indices_and_decons_u_ident :: *CheckState -> (!Index,!Index,!In
get_unboxed_list_indices_and_decons_u_ident
cs
=:{
cs_predef_symbols
,
cs_x
}
#
(
stdStrictLists_index
,
cs_predef_symbols
)=
cs_predef_symbols
![
PD_StdStrictLists
].
pds_def
#
(
cons_u_index
,
cs_predef_symbols
)=
cs_predef_symbols
![
PD_cons_u
].
pds_def
#
(
nil_u_index
,
cs_predef_symbols
)=
cs_predef_symbols
![
PD_nil_u
].
pds_def
#
(
decons_u_symbol
,
cs_predef_symbols
)=
cs_predef_symbols
![
PD_decons_u
]
#
decons_u_index
=
decons_u_symbol
.
pds_def
#
(
nil_u_index
,
cs_predef_symbols
)=
cs_predef_symbols
![
PD_nil_u
].
pds_def
#
cs
={
cs
&
cs_predef_symbols
=
cs_predef_symbols
,
cs_x
.
x_needed_modules
=
cs_x
.
x_needed_modules
bitor
cNeedStdStrictLists
}
=
(
stdStrictLists_index
,
cons_u_index
,
decons_u_index
,
nil_u_index
,
predefined_idents
.[
PD_decons_u
],
cs
)
...
...
@@ -71,18 +71,18 @@ make_unboxed_list type_symbol expr_heap cs
#
decons_expr
=
App
{
app_symb
={
symb_name
=
decons_u_ident
,
symb_kind
=
SK_OverloadedFunction
{
glob_object
=
decons_u_index
,
glob_module
=
stdStrictLists_index
}},
app_args
=[],
app_info_ptr
=
new_info_ptr
}
=
(
unboxed_list
,
decons_expr
,
expr_heap
,
cs
)
get_unboxed_tail_strict_list_indices_and_decons_u_ident
::
*
CheckState
->
(!
Index
,!
Index
,!
Index
,!
Index
,!
Ident
,!*
CheckState
);
get_unboxed_tail_strict_list_indices_and_decons_u_ident
cs
=:{
cs_predef_symbols
,
cs_x
}
get_unboxed_tail_strict_list_indices_and_decons_u
ts
_ident
::
*
CheckState
->
(!
Index
,!
Index
,!
Index
,!
Index
,!
Ident
,!*
CheckState
);
get_unboxed_tail_strict_list_indices_and_decons_u
ts
_ident
cs
=:{
cs_predef_symbols
,
cs_x
}
#
(
stdStrictLists_index
,
cs_predef_symbols
)=
cs_predef_symbols
![
PD_StdStrictLists
].
pds_def
#
(
cons_uts_index
,
cs_predef_symbols
)=
cs_predef_symbols
![
PD_cons_uts
].
pds_def
#
(
nil_uts_index
,
cs_predef_symbols
)=
cs_predef_symbols
![
PD_nil_uts
].
pds_def
#
(
decons_uts_symbol
,
cs_predef_symbols
)=
cs_predef_symbols
![
PD_decons_uts
]
#
decons_uts_index
=
decons_uts_symbol
.
pds_def
#
(
nil_uts_index
,
cs_predef_symbols
)=
cs_predef_symbols
![
PD_nil_uts
].
pds_def
#
cs
={
cs
&
cs_predef_symbols
=
cs_predef_symbols
,
cs_x
.
x_needed_modules
=
cs_x
.
x_needed_modules
bitor
cNeedStdStrictLists
}
=
(
stdStrictLists_index
,
cons_uts_index
,
decons_uts_index
,
nil_uts_index
,
predefined_idents
.[
PD_decons_uts
],
cs
)
make_unboxed_tail_strict_list
type_symbol
expr_heap
cs
#
(
stdStrictLists_index
,
cons_uts_index
,
decons_uts_index
,
nil_uts_index
,
decons_uts_ident
,
cs
)
=
get_unboxed_tail_strict_list_indices_and_decons_u_ident
cs
#
(
stdStrictLists_index
,
cons_uts_index
,
decons_uts_index
,
nil_uts_index
,
decons_uts_ident
,
cs
)
=
get_unboxed_tail_strict_list_indices_and_decons_u
ts
_ident
cs
#
unboxed_list
=
UnboxedTailStrictList
type_symbol
stdStrictLists_index
decons_uts_index
nil_uts_index
#
(
new_info_ptr
,
expr_heap
)
=
newPtr
EI_Empty
expr_heap
#
decons_expr
=
App
{
app_symb
={
symb_name
=
decons_uts_ident
,
symb_kind
=
SK_OverloadedFunction
{
glob_object
=
decons_uts_index
,
glob_module
=
stdStrictLists_index
}},
app_args
=[],
app_info_ptr
=
new_info_ptr
}
...
...
@@ -92,9 +92,9 @@ get_overloaded_list_indices_and_decons_ident :: *CheckState -> (!Index,!Index,!I
get_overloaded_list_indices_and_decons_ident
cs
=:{
cs_predef_symbols
,
cs_x
}
#
(
stdStrictLists_index
,
cs_predef_symbols
)=
cs_predef_symbols
![
PD_StdStrictLists
].
pds_def
#
(
cons_index
,
cs_predef_symbols
)=
cs_predef_symbols
![
PD_cons
].
pds_def
#
(
nil_index
,
cs_predef_symbols
)=
cs_predef_symbols
![
PD_nil
].
pds_def
#
(
decons_symbol
,
cs_predef_symbols
)=
cs_predef_symbols
![
PD_decons
]
#
decons_index
=
decons_symbol
.
pds_def
#
(
nil_index
,
cs_predef_symbols
)=
cs_predef_symbols
![
PD_nil
].
pds_def
#
cs
={
cs
&
cs_predef_symbols
=
cs_predef_symbols
,
cs_x
.
x_needed_modules
=
cs_x
.
x_needed_modules
bitor
cNeedStdStrictLists
}
=
(
stdStrictLists_index
,
cons_index
,
decons_index
,
nil_index
,
predefined_idents
.[
PD_decons
],
cs
)
...
...
@@ -1808,7 +1808,28 @@ transfromPatternIntoBind mod_index def_level (AP_Algebraic cons_symbol=:{glob_mo
position
var_store
expr_heap
e_info
cs
->
(
opt_var_bind
++
binds
,
var_store
,
expr_heap
,
e_info
,
cs
)
#
(
tuple_cons
,
cs
)
=
getPredefinedGlobalSymbol
(
GetTupleConsIndex
ds_arity
)
PD_PredefinedModule
STE_Constructor
ds_arity
cs
(
match_var
,
match_bind
,
var_store
,
expr_heap
)
#
(
src_expr
,
expr_heap
,
cs
)
=
add_decons_call_for_overloaded_lists
src_expr
expr_heap
cs
with
add_decons_call_for_overloaded_lists
src_expr
expr_heap
cs
|
glob_module
==
cPredefinedModuleIndex
#
pd_cons_index
=
ds_index
+
FirstConstructorPredefinedSymbolIndex
|
pd_cons_index
==
PD_UnboxedConsSymbol
#
(
stdStrictLists_index
,_,
decons_u_index
,_,
decons_u_ident
,
cs
)
=
get_unboxed_list_indices_and_decons_u_ident
cs
#
(
new_info_ptr
,
expr_heap
)
=
newPtr
EI_Empty
expr_heap
#
decons_u_expr
=
App
{
app_symb
={
symb_name
=
decons_u_ident
,
symb_kind
=
SK_OverloadedFunction
{
glob_object
=
decons_u_index
,
glob_module
=
stdStrictLists_index
}},
app_args
=[
src_expr
],
app_info_ptr
=
new_info_ptr
}
=
(
decons_u_expr
,
expr_heap
,
cs
)
|
pd_cons_index
==
PD_UnboxedTailStrictConsSymbol
#
(
stdStrictLists_index
,_,
decons_uts_index
,_,
decons_uts_ident
,
cs
)
=
get_unboxed_tail_strict_list_indices_and_decons_uts_ident
cs
#
(
new_info_ptr
,
expr_heap
)
=
newPtr
EI_Empty
expr_heap
#
decons_uts_expr
=
App
{
app_symb
={
symb_name
=
decons_uts_ident
,
symb_kind
=
SK_OverloadedFunction
{
glob_object
=
decons_uts_index
,
glob_module
=
stdStrictLists_index
}},
app_args
=[
src_expr
],
app_info_ptr
=
new_info_ptr
}
=
(
decons_uts_expr
,
expr_heap
,
cs
)
|
pd_cons_index
==
PD_OverloadedConsSymbol
#
(
stdStrictLists_index
,_,
decons_index
,_,
decons_ident
,
cs
)
=
get_overloaded_list_indices_and_decons_ident
cs
#
(
new_info_ptr
,
expr_heap
)
=
newPtr
EI_Empty
expr_heap
#
decons_expr
=
App
{
app_symb
={
symb_name
=
decons_ident
,
symb_kind
=
SK_OverloadedFunction
{
glob_object
=
decons_index
,
glob_module
=
stdStrictLists_index
}},
app_args
=[
src_expr
],
app_info_ptr
=
new_info_ptr
}
=
(
decons_expr
,
expr_heap
,
cs
)
=
(
src_expr
,
expr_heap
,
cs
)
#
(
match_var
,
match_bind
,
var_store
,
expr_heap
)
=
bind_match_expr
(
MatchExpr
cons_symbol
src_expr
)
opt_var_bind
position
var_store
expr_heap
->
transform_sub_patterns
mod_index
def_level
args
tuple_cons
.
glob_object
0
match_var
match_bind
position
var_store
expr_heap
e_info
cs
...
...
frontend/type.icl
View file @
6bd1fd28
...
...
@@ -1547,17 +1547,23 @@ where
attributedBasicType
{
box
=
type
}
ts
=:{
ts_attr_store
}
=
({
at_annotation
=
AN_None
,
at_attribute
=
TA_TempVar
ts_attr_store
,
at_type
=
type
},
{
ts
&
ts_attr_store
=
inc
ts_attr_store
})
requirements
ti
(
MatchExpr
{
glob_object
={
ds_arity
,
ds_index
},
glob_module
}
expr
)
(
reqs
,
ts
)
#
cp
=
CP_Expression
expr
({
tst_result
,
tst_args
,
tst_attr_env
},
ts
)
=
standardLhsConstructorType
cp
ds_index
glob_module
ds_arity
ti
ts
(
e_type
,
opt_expr_ptr
,
(
reqs
,
ts
))
=
requirements
ti
expr
(
reqs
,
ts
)
reqs
=
{
reqs
&
req_attr_coercions
=
tst_attr_env
++
reqs
.
req_attr_coercions
,
req_type_coercions
=
[{
tc_demanded
=
tst_result
,
tc_offered
=
e_type
,
tc_position
=
cp
,
tc_coercible
=
True
}
:
reqs
.
req_type_coercions
]
}
ts
=
{
ts
&
ts_expr_heap
=
storeAttribute
opt_expr_ptr
tst_result
.
at_attribute
ts
.
ts_expr_heap
}
|
ds_arity
<>
1
#
tuple_type
=
MakeTypeSymbIdent
{
glob_object
=
PD_Arity2TupleTypeIndex
+(
ds_arity
-2
),
glob_module
=
cPredefinedModuleIndex
}
predefined_idents
.[
PD_Arity2TupleType
+(
ds_arity
-2
)]
ds_arity
=
({
at_type
=
TA
tuple_type
tst_args
,
at_attribute
=
TA_Unique
,
at_annotation
=
AN_None
},
No
,
(
reqs
,
ts
))
=
(
hd
tst_args
,
No
,
(
reqs
,
ts
))
requirements
ti
(
MatchExpr
{
glob_object
={
ds_arity
,
ds_index
},
glob_module
}
expr
)
reqs_ts
=:(
reqs
,
ts
)
|
glob_module
==
cPredefinedModuleIndex
&&
(
let
pd_cons_index
=
ds_index
+
FirstConstructorPredefinedSymbolIndex
in
pd_cons_index
==
PD_UnboxedConsSymbol
||
pd_cons_index
==
PD_UnboxedTailStrictConsSymbol
||
pd_cons_index
==
PD_OverloadedConsSymbol
)
=
requirements
ti
expr
reqs_ts
#
cp
=
CP_Expression
expr
({
tst_result
,
tst_args
,
tst_attr_env
},
ts
)
=
standardLhsConstructorType
cp
ds_index
glob_module
ds_arity
ti
ts
(
e_type
,
opt_expr_ptr
,
(
reqs
,
ts
))
=
requirements
ti
expr
(
reqs
,
ts
)
reqs
=
{
reqs
&
req_attr_coercions
=
tst_attr_env
++
reqs
.
req_attr_coercions
,
req_type_coercions
=
[{
tc_demanded
=
tst_result
,
tc_offered
=
e_type
,
tc_position
=
cp
,
tc_coercible
=
True
}
:
reqs
.
req_type_coercions
]
}
ts
=
{
ts
&
ts_expr_heap
=
storeAttribute
opt_expr_ptr
tst_result
.
at_attribute
ts
.
ts_expr_heap
}
|
ds_arity
<>
1
#
tuple_type
=
MakeTypeSymbIdent
{
glob_object
=
PD_Arity2TupleTypeIndex
+(
ds_arity
-2
),
glob_module
=
cPredefinedModuleIndex
}
predefined_idents
.[
PD_Arity2TupleType
+(
ds_arity
-2
)]
ds_arity
=
({
at_type
=
TA
tuple_type
tst_args
,
at_attribute
=
TA_Unique
,
at_annotation
=
AN_None
},
No
,
(
reqs
,
ts
))
=
(
hd
tst_args
,
No
,
(
reqs
,
ts
))
requirements
_
(
AnyCodeExpr
_
_
_)
(
reqs
,
ts
)
#
(
fresh_v
,
ts
)
=
freshAttributedVariable
ts
...
...
Write
Preview
Supports
Markdown
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