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
61588872
Commit
61588872
authored
Apr 27, 2001
by
Martin Wierich
Browse files
new error message for "instance c U":
U is unique but instantiates class variable x that is non uniquely used.
parent
42a497e8
Changes
5
Hide whitespace changes
Inline
Side-by-side
frontend/check.dcl
View file @
61588872
...
...
@@ -9,7 +9,8 @@ checkModule :: !ScannedModule !IndexRange ![FunDef] !Int !Int !(Optional Scanned
checkFunctions
::
!
Index
!
Level
!
Index
!
Index
!*{#
FunDef
}
!*
ExpressionInfo
!*
Heaps
!*
CheckState
->
(!*{#
FunDef
},
!*
ExpressionInfo
,
!*
Heaps
,
!*
CheckState
)
determineTypeOfMemberInstance
::
!
SymbolType
![
TypeVar
]
!
InstanceType
!
Specials
!*
TypeHeaps
!(
Optional
*
ErrorAdmin
)
->
(!
SymbolType
,
!
Specials
,
!*
TypeHeaps
,
!
Optional
*
ErrorAdmin
)
determineTypeOfMemberInstance
::
!
SymbolType
![
TypeVar
]
!
InstanceType
!
Specials
!*
TypeHeaps
!
u
:(
Optional
(
v
:{#
DclModule
},
w
:{#
CheckedTypeDef
},
Index
))
!(
Optional
*
ErrorAdmin
)
->
(!
SymbolType
,
!
Specials
,
!*
TypeHeaps
,
!
u
:
Optional
(
v
:{#
DclModule
},
w
:{#
CheckedTypeDef
}),
!
Optional
*
ErrorAdmin
)
arrayFunOffsetToPD_IndexTable
::
!
w
:{#
MemberDef
}
!
v
:{#
PredefinedSymbol
}
->
(!{#
Index
},
!
x
:{#
MemberDef
},
!
v
:{#
PredefinedSymbol
})
,
[
w
<=
x
]
...
...
frontend/check.icl
View file @
61588872
...
...
@@ -386,9 +386,12 @@ where
=
check_member_instances
module_index
member_mod_index
(
inc
mem_offset
)
class_size
ins_members
class_members
class_name
ins_pos
ins_type
instance_types
member_defs
type_defs
modules
var_heap
type_heaps
{
cs
&
cs_error
=
checkError
class_member
.
ds_ident
"used with wrong arity"
cs
.
cs_error
}
#
({
me_type
,
me_class_vars
,
me_pos
},
member_defs
,
modules
)
=
getMemberDef
member_mod_index
class_member
.
ds_index
module_index
member_defs
modules
(
instance_type
,
_,
type_heaps
,
Yes
cs_error
)
=
determineTypeOfMemberInstance
me_type
me_class_vars
ins_type
SP_None
type_heaps
(
Yes
cs
.
cs_error
)
(
type_defs
,
modules
,
cs_error
)
=
checkTopLevelKinds
x_main_dcl_module_n
True
ins_pos
class_name
instance_type
type_defs
modules
cs_error
#
({
me_symb
,
me_type
,
me_class_vars
,
me_pos
},
member_defs
,
modules
)
=
getMemberDef
member_mod_index
class_member
.
ds_index
module_index
member_defs
modules
cs_error
=
pushErrorAdmin
(
newPosition
class_name
ins_pos
)
cs
.
cs_error
(
instance_type
,
_,
type_heaps
,
Yes
(
modules
,
type_defs
),
Yes
cs_error
)
=
determineTypeOfMemberInstance
me_type
me_class_vars
ins_type
SP_None
type_heaps
(
Yes
(
modules
,
type_defs
,
x_main_dcl_module_n
))
(
Yes
cs_error
)
(
type_defs
,
modules
,
cs_error
)
=
checkTopLevelKinds
x_main_dcl_module_n
True
me_symb
instance_type
type_defs
modules
cs_error
cs_error
=
popErrorAdmin
cs_error
(
st_context
,
var_heap
)
=
initializeContextVariables
instance_type
.
st_context
var_heap
=
check_member_instances
module_index
member_mod_index
(
inc
mem_offset
)
class_size
ins_members
class_members
class_name
ins_pos
ins_type
[
(
ins_member
.
ds_index
,
{
instance_type
&
st_context
=
st_context
})
:
instance_types
]
member_defs
type_defs
modules
var_heap
type_heaps
{
cs
&
cs_error
=
cs_error
}
...
...
@@ -447,6 +450,7 @@ instantiateTypes old_type_vars old_attr_vars types type_contexts attr_env {ss_en
->
Yes
(
checkError
"instance type incompatible with class type"
""
error_admin
)
// e.g.:class c a :: (a Int); instance c Real
=
(
inst_vars
,
inst_attr_vars
,
inst_types
,
inst_contexts
++
new_ss_context
,
inst_attr_env
,
special_subst_list
,
{
type_heaps
&
th_vars
=
th_vars
},
opt_error
)
where
clear_vars
type_vars
type_var_heap
=
foldSt
(\
tv
->
writePtr
tv
.
tv_info_ptr
TVI_Empty
)
type_vars
type_var_heap
...
...
@@ -494,14 +498,16 @@ hasTypeVariables [TV tvar : types]
hasTypeVariables
[
_
:
types
]
=
hasTypeVariables
types
determineTypeOfMemberInstance
::
!
SymbolType
![
TypeVar
]
!
InstanceType
!
Specials
!*
TypeHeaps
!(
Optional
*
ErrorAdmin
)
->
(!
SymbolType
,
!
Specials
,
!*
TypeHeaps
,
!
Optional
*
ErrorAdmin
)
determineTypeOfMemberInstance
mem_st
class_vars
{
it_types
,
it_vars
,
it_attr_vars
,
it_context
}
specials
type_heaps
opt_error
determineTypeOfMemberInstance
::
!
SymbolType
![
TypeVar
]
!
InstanceType
!
Specials
!*
TypeHeaps
!
u
:(
Optional
(
v
:{#
DclModule
},
w
:{#
CheckedTypeDef
},
Index
))
!(
Optional
*
ErrorAdmin
)
->
(!
SymbolType
,
!
Specials
,
!*
TypeHeaps
,
!
u
:
Optional
(
v
:{#
DclModule
},
w
:{#
CheckedTypeDef
}),
!
Optional
*
ErrorAdmin
)
determineTypeOfMemberInstance
mem_st
class_vars
{
it_types
,
it_vars
,
it_attr_vars
,
it_context
}
specials
type_heaps
opt_modules
opt_error
#
env
=
{
ss_environ
=
foldl2
(\
binds
var
type
->
[
{
bind_src
=
type
,
bind_dst
=
var
}
:
binds
])
[]
class_vars
it_types
,
ss_context
=
it_context
,
ss_vars
=
it_vars
,
ss_attrs
=
it_attr_vars
}
(
st
,
specials
,
type_heaps
,
opt_error
)
=
determine_type_of_member_instance
mem_st
env
specials
type_heaps
opt_error
=
(
st
,
specials
,
type_heaps
,
opt_error
)
(
type_heaps
,
opt_modules
,
opt_error
)
=
check_attribution_consistency
mem_st
type_heaps
opt_modules
opt_error
=
(
st
,
specials
,
type_heaps
,
opt_modules
,
opt_error
)
where
determine_type_of_member_instance
mem_st
=:{
st_context
}
env
(
SP_Substitutions
substs
)
type_heaps
opt_error
#
(
mem_st
,
substs
,
type_heaps
,
opt_error
)
...
...
@@ -518,6 +524,59 @@ where
=
({
st
&
st_vars
=
st_vars
,
st_args
=
st_args
,
st_result
=
st_result
,
st_attr_vars
=
st_attr_vars
,
st_context
=
st_context
,
st_attr_env
=
st_attr_env
},
specials
,
type_heaps
,
opt_error
)
check_attribution_consistency
{
st_args
,
st_result
}
type_heaps
No
No
=
(
type_heaps
,
No
,
No
)
check_attribution_consistency
{
st_args
,
st_result
}
type_heaps
=:{
th_vars
}
(
Yes
(
modules
,
type_defs
,
x_main_dcl_module_n
))
(
Yes
error
)
// it is assumed that all type vars bindings done in instantiateTypes are still valid
#
(_,
th_vars
,
modules
,
type_defs
,
error
)
=
foldSt
(
foldATypeSt
(
check_it
x_main_dcl_module_n
)
(\_
st
->
st
))
[
st_result
:
st_args
]
(
False
,
th_vars
,
modules
,
type_defs
,
error
)
=
({
type_heaps
&
th_vars
=
th_vars
},
Yes
(
modules
,
type_defs
),
Yes
error
)
check_it
_
{
at_attribute
}
(
error_already_given
,
th_vars
,
modules
,
type_defs
,
error
)
|
at_attribute
==
TA_Unique
||
error_already_given
=
(
error_already_given
,
th_vars
,
modules
,
type_defs
,
error
)
// otherwise GOTO next alternative
check_it
x_main_dcl_module_n
{
at_type
=
TV
tv
}
(_,
th_vars
,
modules
,
type_defs
,
error
)
=
must_not_be_essentially_unique
x_main_dcl_module_n
tv
th_vars
modules
type_defs
error
check_it
x_main_dcl_module_n
{
at_type
=
(
CV
tv
)
:@:
_}
(_,
th_vars
,
modules
,
type_defs
,
error
)
=
must_not_be_essentially_unique
x_main_dcl_module_n
tv
th_vars
modules
type_defs
error
check_it
_
_
state
=
state
must_not_be_essentially_unique
x_main_dcl_module_n
{
tv_name
,
tv_info_ptr
}
th_vars
modules
type_defs
error
#
(
TVI_Type
type
,
th_vars
)
=
readPtr
tv_info_ptr
th_vars
=
case
type
of
TA
{
type_name
,
type_index
}
_
#
(
type_def
,
type_defs
,
modules
)
=
getTypeDef
x_main_dcl_module_n
type_index
type_defs
modules
->
case
type_def
.
td_attribute
of
TA_Unique
->
(
True
,
th_vars
,
modules
,
type_defs
,
checkError
type_name
(
"is unique but instanciates class variable "
+++
tv_name
.
id_name
+++
" that is non uniquely used in a member type"
)
error
)
_
->
(
False
,
th_vars
,
modules
,
type_defs
,
error
)
_
->
(
False
,
th_vars
,
modules
,
type_defs
,
error
)
getTypeDef
::
!
Index
!(
Global
Index
)
!
v
:{#
CheckedTypeDef
}
!
w
:{#
DclModule
}
->
(!
CheckedTypeDef
,
!
v
:{#
CheckedTypeDef
},
!
w
:{#
DclModule
})
getTypeDef
x_main_dcl_module_n
{
glob_module
,
glob_object
}
type_defs
modules
|
glob_module
==
x_main_dcl_module_n
#
(
type_def
,
type_defs
)
=
type_defs
![
glob_object
]
=
(
type_def
,
type_defs
,
modules
)
#
(
type_def
,
modules
)
=
modules
![
glob_module
].
dcl_common
.
com_type_defs
.[
glob_object
]
=
(
type_def
,
type_defs
,
modules
)
determineTypesOfInstances
::
!
Index
!
Index
!*{#
ClassInstance
}
!*{#
ClassDef
}
!*{#
MemberDef
}
!*{#
DclModule
}
!*
TypeHeaps
!*
VarHeap
!*
CheckState
->
(![
FunType
],
!
Index
,
![
ClassInstance
],
!*{#
ClassInstance
},
!*{#
ClassDef
},
!*{#
MemberDef
},
!*{#
DclModule
},
!*
TypeHeaps
,
!*
VarHeap
,
!*
CheckState
)
...
...
@@ -565,8 +624,13 @@ where
=
([],
[],
member_defs
,
modules
,
type_heaps
,
var_heap
,
cs_error
)
#
class_member
=
class_members
.[
mem_offset
]
({
me_symb
,
me_type
,
me_priority
,
me_class_vars
},
member_defs
,
modules
)
=
getMemberDef
member_mod_index
class_member
.
ds_index
module_index
member_defs
modules
(
instance_type
,
new_ins_specials
,
type_heaps
,
Yes
cs_error
)
=
determineTypeOfMemberInstance
me_type
me_class_vars
ins_type
ins_specials
type_heaps
(
Yes
cs_error
)
(_,
modules
,
cs_error
)
=
checkTopLevelKinds
x_main_dcl_module_n
False
ins_pos
class_name
instance_type
cDummyArray
modules
cs_error
cs_error
=
pushErrorAdmin
(
newPosition
class_name
ins_pos
)
cs_error
(
instance_type
,
new_ins_specials
,
type_heaps
,
Yes
(
modules
,
_),
Yes
cs_error
)
=
determineTypeOfMemberInstance
me_type
me_class_vars
ins_type
ins_specials
type_heaps
(
Yes
(
modules
,
{},
cUndef
))
(
Yes
cs_error
)
(_,
modules
,
cs_error
)
=
checkTopLevelKinds
x_main_dcl_module_n
False
me_symb
instance_type
cDummyArray
modules
cs_error
cs_error
=
popErrorAdmin
cs_error
(
new_info_ptr
,
var_heap
)
=
newPtr
VI_Empty
var_heap
inst_def
=
MakeNewFunctionType
me_symb
me_type
.
st_arity
me_priority
instance_type
ins_pos
new_ins_specials
new_info_ptr
(
inst_symbols
,
memb_inst_defs
,
member_defs
,
modules
,
type_heaps
,
var_heap
,
cs_error
)
...
...
@@ -603,21 +667,24 @@ where
=
(
tc_types
,
error
)
checkTopLevelKinds
::
!
Index
!
Bool
!
Position
Ident
!
SymbolType
n
:{#
CheckedTypeDef
}
!
r
:{#
DclModule
}
!*
ErrorAdmin
checkTopLevelKinds
::
!
Index
!
Bool
Ident
!
SymbolType
n
:{#
CheckedTypeDef
}
!
r
:{#
DclModule
}
!*
ErrorAdmin
->
(!
n
:{#
CheckedTypeDef
},
!
r
:{#
DclModule
},
!*
ErrorAdmin
)
checkTopLevelKinds
x_main_dcl_module_n
is_icl_module
ins_pos
class_ident
st
=:{
st_args
,
st_result
}
type_defs
modules
cs_error
#!
ok
=
all
(\{
at_type
}
->
kind_is_ok
x_main_dcl_module_n
is_icl_module
type_defs
modules
0
at_type
)
[
st_result
:
st_args
]
checkTopLevelKinds
x_main_dcl_module_n
is_icl_module
me_symb
st
=:{
st_args
,
st_result
}
type_defs
modules
cs_error
#!
first_wrong
=
firstIndex
(\{
at_type
}
->
not
(
kind_is_ok
x_main_dcl_module_n
is_icl_module
type_defs
modules
0
at_type
)
)
[
st_result
:
st_args
]
#
cs_error
=
case
ok
of
True
=
case
first_wrong
of
(
-1
)
->
cs_error
_
#
cs_error
=
pushErrorAdmin
(
newPosition
class_ident
ins_pos
)
cs_error
cs_error
=
checkError
"instance types have wrong kind"
""
cs_error
->
popErrorAdmin
cs_error
=
(
type_defs
,
modules
,
cs_error
)
->
checkError
"instance type has wrong kind"
(
"(e.g. "
+++
arg_string
first_wrong
+++
" of member "
+++
toString
me_symb
+++
")"
)
cs_error
=
(
type_defs
,
modules
,
cs_error
)
where
kind_is_ok
x_main_dcl_module_n
is_icl_module
type_defs
modules
demanded_kind
type
=:(
TA
{
type_index
={
glob_object
,
glob_module
}}
args
)
#
{
td_arity
}
...
...
@@ -1744,7 +1811,7 @@ check_module2 mod_name mod_imported_objects mod_imports mod_type icl_global_func
=
checkInstanceBodies
icl_instance_range
icl_functions
e_info
heaps
cs
(
icl_functions
,
hp_type_heaps
,
cs_error
)
=
//
foldSt checkSpecifiedInstanceType instance_types
=
foldSt
checkSpecifiedInstanceType
instance_types
(
icl_functions
,
heaps
.
hp_type_heaps
,
cs_error
)
heaps
...
...
@@ -2780,6 +2847,9 @@ Ste_Empty :== STE_Empty
dummy_decl
=:
{
decl_ident
=
{
id_name
=
""
,
id_info
=
nilPtr
},
decl_pos
=
NoPos
,
decl_kind
=
STE_Empty
,
decl_index
=
cUndef
}
arg_string
0
=
"result"
arg_string
arg_nr
=
toString
arg_nr
+++
". arg"
possibly_write_expl_imports_of_main_dcl_mod_to_file
imports_ikh
dcl_modules
cs
|
switch_port_to_new_syntax
False
True
=
abort
"possibly_write_expl_imports_of_main_dcl_mod_to_file is only used for portToNewSyntax"
...
...
@@ -2791,3 +2861,4 @@ possibly_write_expl_imports_of_main_dcl_mod_to_file imports_ikh dcl_modules cs
->
(
dcl_modules
,
cs
)
Yes
{
si_explicit
}
->
writeExplImportsToFile
"dcl.txt"
si_explicit
dcl_modules
cs
frontend/generics.icl
View file @
61588872
...
...
@@ -1172,8 +1172,8 @@ determineMemberTypes module_index ins_index
// determine type of the member instance
#
(
symbol_type
,
_,
hp_type_heaps
,
_)
=
determineTypeOfMemberInstance
me_type
me_class_vars
ins_type
SP_None
hp_type_heaps
No
#
(
symbol_type
,
_,
hp_type_heaps
,
_,
_)
=
determineTypeOfMemberInstance
me_type
me_class_vars
ins_type
SP_None
hp_type_heaps
No
No
#
(
st_context
,
hp_var_heap
)
=
initializeContextVariables
symbol_type
.
st_context
hp_var_heap
#
symbol_type
=
{
symbol_type
&
st_context
=
st_context
}
...
...
frontend/typesupport.dcl
View file @
61588872
...
...
@@ -135,3 +135,30 @@ accAttrVarHeap f type_heaps :== let (r, th_attrs) = f type_heaps.th_attrs in (r,
class
removeAnnotations
a
::
!
a
->
(!
Bool
,
!
a
)
instance
removeAnnotations
Type
,
SymbolType
foldATypeSt
on_atype
on_type
type
st
:==
fold_atype_st
type
st
where
fold_type_st
type
=:(
TA
type_symb_ident
args
)
st
#!
st
=
foldSt
fold_atype_st
args
st
=
on_type
type
st
fold_type_st
type
=:(
l
-->
r
)
st
#!
st
=
fold_atype_st
r
(
fold_atype_st
l
st
)
=
on_type
type
st
fold_type_st
type
=:(_
:@:
args
)
st
#!
st
=
foldSt
fold_atype_st
args
st
=
on_type
type
st
fold_type_st
type
=:(
TB
_)
st
=
on_type
type
st
fold_type_st
type
=:(
GTV
_)
st
=
on_type
type
st
fold_type_st
type
=:(
TV
_)
st
=
on_type
type
st
fold_atype_st
atype
=:{
at_type
}
st
#!
st
=
fold_type_st
at_type
st
=
on_atype
atype
st
frontend/typesupport.icl
View file @
61588872
...
...
@@ -1718,3 +1718,29 @@ appTypeVarHeap f type_heaps :== let th_vars = f type_heaps.th_vars in { type_hea
accTypeVarHeap
f
type_heaps
:==
let
(
r
,
th_vars
)
=
f
type_heaps
.
th_vars
in
(
r
,
{
type_heaps
&
th_vars
=
th_vars
})
accAttrVarHeap
f
type_heaps
:==
let
(
r
,
th_attrs
)
=
f
type_heaps
.
th_attrs
in
(
r
,
{
type_heaps
&
th_attrs
=
th_attrs
})
foldATypeSt
on_atype
on_type
type
st
:==
fold_atype_st
type
st
where
fold_type_st
type
=:(
TA
type_symb_ident
args
)
st
#!
st
=
foldSt
fold_atype_st
args
st
=
on_type
type
st
fold_type_st
type
=:(
l
-->
r
)
st
#!
st
=
fold_atype_st
r
(
fold_atype_st
l
st
)
=
on_type
type
st
fold_type_st
type
=:(_
:@:
args
)
st
#!
st
=
foldSt
fold_atype_st
args
st
=
on_type
type
st
fold_type_st
type
=:(
TB
_)
st
=
on_type
type
st
fold_type_st
type
=:(
GTV
_)
st
=
on_type
type
st
fold_type_st
type
=:(
TV
_)
st
=
on_type
type
st
fold_atype_st
atype
=:{
at_type
}
st
#!
st
=
fold_type_st
at_type
st
=
on_atype
atype
st
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