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
8e02a38c
Commit
8e02a38c
authored
Nov 24, 2005
by
John van Groningen
Browse files
report error for constructors or records with >32 arguments/fields
parent
b623b4b0
Changes
3
Hide whitespace changes
Inline
Side-by-side
frontend/checksupport.dcl
View file @
8e02a38c
...
...
@@ -146,6 +146,7 @@ newPosition :: !Ident !Position -> IdentPos
checkError
::
!
a
!
b
!*
ErrorAdmin
->
*
ErrorAdmin
|
<<<
a
&
<<<
b
checkWarning
::
!
a
!
b
!*
ErrorAdmin
->
*
ErrorAdmin
|
<<<
a
&
<<<
b
checkErrorWithIdentPos
::
!
IdentPos
!
a
!*
ErrorAdmin
->
.
ErrorAdmin
|
<<<
a
;
checkErrorWithPosition
::
!
Ident
!
Position
!
a
!*
ErrorAdmin
->
.
ErrorAdmin
|
<<<
a
;
checkWarningWithPosition
::
!
Ident
!
Position
!
a
!*
ErrorAdmin
->
.
ErrorAdmin
|
<<<
a
;
class
envLookUp
a
::
!
a
!(
Env
Ident
.
b
)
->
(!
Bool
,.
b
)
...
...
frontend/checksupport.icl
View file @
8e02a38c
...
...
@@ -71,6 +71,11 @@ checkErrorWithIdentPos :: !IdentPos !a !*ErrorAdmin -> .ErrorAdmin | <<< a;
checkErrorWithIdentPos
ident_pos
mess
error
=:{
ea_file
}
=
{
error
&
ea_file
=
ea_file
<<<
"Error "
<<<
ident_pos
<<<
": "
<<<
mess
<<<
'\n'
,
ea_ok
=
False
}
checkErrorWithPosition
::
!
Ident
!
Position
!
a
!*
ErrorAdmin
->
.
ErrorAdmin
|
<<<
a
;
checkErrorWithPosition
ident
pos
mess
error
=:{
ea_file
}
#
ident_pos
=
newPosition
ident
pos
=
{
error
&
ea_file
=
ea_file
<<<
"Error "
<<<
ident_pos
<<<
": "
<<<
mess
<<<
'\n'
,
ea_ok
=
False
}
checkWarningWithPosition
::
!
Ident
!
Position
!
a
!*
ErrorAdmin
->
.
ErrorAdmin
|
<<<
a
;
checkWarningWithPosition
ident
pos
mess
error
=:{
ea_file
}
#
ident_pos
=
newPosition
ident
pos
...
...
frontend/checktypes.icl
View file @
8e02a38c
...
...
@@ -232,13 +232,15 @@ where
[{
at_attribute
=
atv_attribute
,
at_type
=
TV
atv_variable
}
\\
{
atv_variable
,
atv_attribute
}
<-
td_args
]}
ts_ti_cs
=
bind_types_of_constructors
cti
0
[
atv_variable
\\
{
atv_variable
}
<-
td_args
]
attr_vars
type_lhs
conses
ts_ti_cs
=
(
td_rhs
,
ts_ti_cs
)
check_rhs_of_TypeDef
{
td_ident
,
td_arity
,
td_args
,
td_rhs
=
td_rhs
=:
RecordType
{
rt_constructor
=
rec_cons
=:{
ds_index
},
rt_fields
}}
attr_vars
cti
=:{
cti_module_index
,
cti_type_index
,
cti_lhs_attribute
}
ts
_
ti
_
cs
check_rhs_of_TypeDef
{
td_ident
,
td_arity
,
td_args
,
td_rhs
=
td_rhs
=:
RecordType
{
rt_constructor
=
rec_cons
=:{
ds_index
,
ds_arity
},
rt_fields
}}
attr_vars
cti
=:{
cti_module_index
,
cti_type_index
,
cti_lhs_attribute
}
(
ts
,
ti
,
cs
)
#
type_lhs
=
{
at_attribute
=
cti_lhs_attribute
,
at_type
=
TA
(
MakeTypeSymbIdent
{
glob_object
=
cti_type_index
,
glob_module
=
cti_module_index
}
td_ident
td_arity
)
[{
at_attribute
=
atv_attribute
,
at_type
=
TV
atv_variable
}
\\
{
atv_variable
,
atv_attribute
}
<-
td_args
]}
(
ts
,
ti
,
cs
)
=
bind_types_of_constructors
cti
0
[
atv_variable
\\
{
atv_variable
}
<-
td_args
]
attr_vars
type_lhs
[
rec_cons
]
ts_ti_cs
cs
=
if
(
ds_arity
>
32
)
{
cs
&
cs_error
=
checkError
(
"Record has too many fields ("
+++
toString
ds_arity
+++
","
)
"32 are allowed)"
cs
.
cs_error
}
cs
;
(
ts
,
ti
,
cs
)
=
bind_types_of_constructor
cti
0
[
atv_variable
\\
{
atv_variable
}
<-
td_args
]
attr_vars
type_lhs
rec_cons
(
ts
,
ti
,
cs
)
#
(
rec_cons_def
,
ts
)
=
ts
!
ts_cons_defs
.[
ds_index
]
#
{
cons_type
=
{
st_vars
,
st_args
,
st_result
,
st_attr_vars
},
cons_exi_vars
}
=
rec_cons_def
#
(
ts_selector_defs
,
ti_var_heap
,
cs_error
)
=
check_selectors
0
rt_fields
cti_type_index
st_args
st_result
st_vars
st_attr_vars
cons_exi_vars
...
...
@@ -285,26 +287,32 @@ where
=
(
td_rhs
,
ts_ti_cs
)
bind_types_of_constructors
::
!
CurrentTypeInfo
!
Index
![
TypeVar
]
![
AttributeVar
]
!
AType
![
DefinedSymbol
]
!(!*
TypeSymbols
,!*
TypeInfo
,!*
CheckState
)
->
(!*
TypeSymbols
,
!*
TypeInfo
,
!*
CheckState
)
->
(!*
TypeSymbols
,
!*
TypeInfo
,
!*
CheckState
)
bind_types_of_constructors
cti
cons_index
free_vars
free_attrs
type_lhs
[
cons
=:{
ds_arity
,
ds_ident
,
ds_index
}:
conses
]
(
ts
,
ti
,
cs
)
#
(
ts
,
cs
)
=
if
(
ds_arity
>
32
)
(
let
(
cons_pos
,
ts2
)
=
ts
!
ts_cons_defs
.[
ds_index
].
cons_pos
in
(
ts2
,{
cs
&
cs_error
=
checkErrorWithPosition
ds_ident
cons_pos
(
"Constructor has too many arguments ("
+++
toString
ds_arity
+++
", 32 are allowed)"
)
cs
.
cs_error
}))
(
ts
,
cs
);
#
ts_ti_cs
=
bind_types_of_constructor
cti
cons_index
free_vars
free_attrs
type_lhs
cons
(
ts
,
ti
,
cs
)
=
bind_types_of_constructors
cti
(
inc
cons_index
)
free_vars
free_attrs
type_lhs
conses
ts_ti_cs
bind_types_of_constructors
_
_
_
_
_
[]
ts_ti_cs
=
ts_ti_cs
bind_types_of_constructors
cti
=:{
cti_lhs_attribute
}
cons_index
free_vars
free_attrs
type_lhs
[{
ds_index
}:
conses
]
(
ts
=:{
ts_cons_defs
},
ti
=:{
ti_type_heaps
},
cs
)
#
(
cons_def
,
ts_cons_defs
)
=
ts_cons_defs
![
ds_index
]
bind_types_of_constructor
::
!
CurrentTypeInfo
!
Index
![
TypeVar
]
![
AttributeVar
]
!
AType
!
DefinedSymbol
!(!*
TypeSymbols
,!*
TypeInfo
,!*
CheckState
)
->
(!*
TypeSymbols
,
!*
TypeInfo
,
!*
CheckState
)
bind_types_of_constructor
cti
=:{
cti_lhs_attribute
}
cons_index
free_vars
free_attrs
type_lhs
{
ds_index
}
(
ts
,
ti
=:{
ti_type_heaps
},
cs
)
#
(
cons_def
,
ts
)
=
ts
!
ts_cons_defs
.[
ds_index
]
#
(
exi_vars
,
(
ti_type_heaps
,
cs
))
=
addExistentionalTypeVariablesToSymbolTable
cti_lhs_attribute
cons_def
.
cons_exi_vars
ti_type_heaps
cs
(
st_args
,
cons_arg_vars
,
st_attr_env
,
(
ts
,
ti
,
cs
))
=
bind_types_of_cons
cons_def
.
cons_type
.
st_args
cti
free_vars
[]
({
ts
&
ts_cons_defs
=
ts_cons_defs
},
{
ti
&
ti_type_heaps
=
ti_type_heaps
},
cs
)
=
bind_types_of_cons
cons_def
.
cons_type
.
st_args
cti
free_vars
[]
(
ts
,
{
ti
&
ti_type_heaps
=
ti_type_heaps
},
cs
)
cs_symbol_table
=
removeAttributedTypeVarsFromSymbolTable
cGlobalScope
/* cOuterMostLevel */
exi_vars
cs
.
cs_symbol_table
(
ts
,
ti
,
cs
)
=
bind_types_of_constructors
cti
(
inc
cons_index
)
free_vars
free_attrs
type_lhs
conses
(
ts
,
ti
,
{
cs
&
cs_symbol_table
=
cs_symbol_table
})
attr_vars
=
add_universal_attr_vars
st_args
free_attrs
cons_type
=
{
cons_def
.
cons_type
&
st_vars
=
free_vars
,
st_args
=
st_args
,
st_result
=
type_lhs
,
st_attr_vars
=
attr_vars
,
st_attr_env
=
st_attr_env
}
(
new_type_ptr
,
ti_var_heap
)
=
newPtr
VI_Empty
ti
.
ti_var_heap
=
({
ts
&
ts_cons_defs
=
{
ts
.
ts_cons_defs
&
[
ds_index
]
=
{
cons_def
&
cons_type
=
cons_type
,
cons_index
=
cons_index
,
cons_type_index
=
cti
.
cti_type_index
,
cons_exi_vars
=
exi_vars
,
cons_type_ptr
=
new_type_ptr
,
cons_arg_vars
=
cons_arg_vars
}}},
{
ti
&
ti_var_heap
=
ti_var_heap
},
cs
)
// ---> ("bind_types_of_constructors", cons_def.cons_ident, exi_vars, cons_type)
cons_def
=
{
cons_def
&
cons_type
=
cons_type
,
cons_index
=
cons_index
,
cons_type_index
=
cti
.
cti_type_index
,
cons_exi_vars
=
exi_vars
,
cons_type_ptr
=
new_type_ptr
,
cons_arg_vars
=
cons_arg_vars
}
=
({
ts
&
ts_cons_defs
.[
ds_index
]
=
cons_def
},
{
ti
&
ti_var_heap
=
ti_var_heap
},
cs
)
where
bind_types_of_cons
::
![
AType
]
!
CurrentTypeInfo
![
TypeVar
]
![
AttrInequality
]
!(!*
TypeSymbols
,
!*
TypeInfo
,
!*
CheckState
)
->
(![
AType
],
![[
ATypeVar
]],
![
AttrInequality
],
!(!*
TypeSymbols
,
!*
TypeInfo
,
!*
CheckState
))
...
...
Write
Preview
Supports
Markdown
0%
Try again
or
attach a new 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