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
27472f84
Commit
27472f84
authored
Aug 15, 2000
by
Martin Wierich
Browse files
improved typing error messages: type variables are printed like "a" instead
of "v314", case defaults and guards now also have file position information.
parent
46ed5ee5
Changes
17
Hide whitespace changes
Inline
Side-by-side
frontend/StdCompare.dcl
View file @
27472f84
...
...
@@ -14,7 +14,7 @@ instance =< Int, Expression, {# Char}, Ident, [a] | =< a, BasicType //, (Global
instance
=<
Type
,
SymbIdent
instance
==
BasicType
,
TypeVar
,
TypeSymbIdent
,
DefinedSymbol
,
TypeContext
,
BasicValue
,
FunKind
,
(
Global
a
)
|
==
a
,
Priority
,
Assoc
FunKind
,
(
Global
a
)
|
==
a
,
Priority
,
Assoc
,
Type
instance
<
MemberDef
frontend/StdCompare.icl
View file @
27472f84
...
...
@@ -74,6 +74,14 @@ where
=
type1
==
type2
&&
types1
==
types2
equal_constructor_args
(
TQV
varid1
)
(
TQV
varid2
)
=
varid1
==
varid2
// MW4..
equal_constructor_args
(
GTV
varid1
)
(
GTV
varid2
)
=
varid1
==
varid2
equal_constructor_args
(
TempQV
varid1
)
(
TempQV
varid2
)
=
varid1
==
varid2
equal_constructor_args
(
TLifted
varid1
)
(
TLifted
varid2
)
=
varid1
==
varid2
// ..MW4
equal_constructor_args
type1
type2
=
True
...
...
frontend/check.icl
View file @
27472f84
...
...
@@ -1867,19 +1867,19 @@ where
check_default_expr
free_vars
No
e_input
e_state
e_info
cs
=
(
No
,
free_vars
,
e_state
,
e_info
,
cs
)
convert_guards_to_cases
[(
let_binds
,
guard
,
expr
)]
result_expr
es_expr_heap
convert_guards_to_cases
[(
let_binds
,
guard
,
expr
,
guard_ident
)]
result_expr
es_expr_heap
#
(
case_expr_ptr
,
es_expr_heap
)
=
newPtr
EI_Empty
es_expr_heap
basic_pattern
=
{
bp_value
=
(
BVB
True
),
bp_expr
=
expr
,
bp_position
=
NoPos
}
case_expr
=
Case
{
case_expr
=
guard
,
case_guards
=
BasicPatterns
BT_Bool
[
basic_pattern
],
case_default
=
result_expr
,
case_ident
=
No
,
case_info_ptr
=
case_expr_ptr
,
case_default_pos
=
NoPos
}
case_default
=
result_expr
,
case_ident
=
Yes
guard_ident
,
case_info_ptr
=
case_expr_ptr
,
case_default_pos
=
NoPos
}
=
build_sequential_lets
let_binds
case_expr
es_expr_heap
convert_guards_to_cases
[(
let_binds
,
guard
,
expr
)
:
rev_guarded_exprs
]
result_expr
es_expr_heap
convert_guards_to_cases
[(
let_binds
,
guard
,
expr
,
guard_ident
)
:
rev_guarded_exprs
]
result_expr
es_expr_heap
#
(
case_expr_ptr
,
es_expr_heap
)
=
newPtr
EI_Empty
es_expr_heap
basic_pattern
=
{
bp_value
=
(
BVB
True
),
bp_expr
=
expr
,
bp_position
=
NoPos
}
case_expr
=
Case
{
case_expr
=
guard
,
case_guards
=
BasicPatterns
BT_Bool
[
basic_pattern
],
case_default
=
result_expr
,
case_ident
=
No
,
case_info_ptr
=
case_expr_ptr
,
case_default_pos
=
NoPos
}
case_default
=
result_expr
,
case_ident
=
Yes
guard_ident
,
case_info_ptr
=
case_expr_ptr
,
case_default_pos
=
NoPos
}
(
result_expr
,
es_expr_heap
)
=
build_sequential_lets
let_binds
case_expr
es_expr_heap
=
convert_guards_to_cases
rev_guarded_exprs
(
Yes
result_expr
)
es_expr_heap
...
...
@@ -1890,14 +1890,14 @@ where
check_guarded_expressions
free_vars
[]
let_vars_list
rev_guarded_exprs
{
ei_expr_level
}
e_state
e_info
cs
=
(
let_vars_list
,
rev_guarded_exprs
,
ei_expr_level
,
free_vars
,
e_state
,
e_info
,
cs
)
check_guarded_expression
free_vars
{
alt_nodes
,
alt_guard
,
alt_expr
}
check_guarded_expression
free_vars
{
alt_nodes
,
alt_guard
,
alt_expr
,
alt_ident
}
let_vars_list
rev_guarded_exprs
e_input
=:{
ei_expr_level
,
ei_mod_index
}
e_state
e_info
cs
#
(
let_binds
,
let_vars_list
,
ei_expr_level
,
free_vars
,
e_state
,
e_info
,
cs
)
=
check_sequential_lets
free_vars
alt_nodes
let_vars_list
{
e_input
&
ei_expr_level
=
inc
ei_expr_level
}
e_state
e_info
cs
e_input
=
{
e_input
&
ei_expr_level
=
ei_expr_level
}
(
guard
,
free_vars
,
e_state
,
e_info
,
cs
)
=
checkExpression
free_vars
alt_guard
e_input
e_state
e_info
cs
(
expr
,
free_vars
,
e_state
,
e_info
,
cs
)
=
check_opt_guarded_alts
free_vars
alt_expr
e_input
e_state
e_info
cs
=
(
let_vars_list
,
[(
let_binds
,
guard
,
expr
)
:
rev_guarded_exprs
],
ei_expr_level
,
free_vars
,
e_state
,
e_info
,
cs
)
=
(
let_vars_list
,
[(
let_binds
,
guard
,
expr
,
alt_ident
)
:
rev_guarded_exprs
],
ei_expr_level
,
free_vars
,
e_state
,
e_info
,
cs
)
// JVG: added type
check_unguarded_expression
::
[
FreeVar
]
ExprWithLocalDefs
ExpressionInput
*
ExpressionState
*
ExpressionInfo
*
CheckState
->
*(!
Expression
,![
FreeVar
],!*
ExpressionState
,!*
ExpressionInfo
,!*
CheckState
);
...
...
frontend/frontend.dcl
View file @
27472f84
...
...
@@ -22,5 +22,5 @@ import checksupport, transform, overloading
|
FrontEndPhaseConvertModules
|
FrontEndPhaseAll
frontEndInterface
::
!
FrontEndPhase
!
Ident
!
SearchPaths
!*
PredefinedSymbols
!*
HashTable
!*
Files
!*
File
!*
File
!*
File
->
(!*
PredefinedSymbols
,
!*
HashTable
,
!*
Files
,
!*
File
,
!*
File
,
!*
File
,
!
Optional
*
FrontEndSyntaxTree
)
// upToPhase name paths predefs files error io out
\ No newline at end of file
frontEndInterface
::
!
FrontEndPhase
!
Ident
!
SearchPaths
!
Bool
!*
PredefinedSymbols
!*
HashTable
!*
Files
!*
File
!*
File
!*
File
->
(!*
PredefinedSymbols
,
!*
HashTable
,
!*
Files
,
!*
File
,
!*
File
,
!*
File
,
!
Optional
*
FrontEndSyntaxTree
)
// upToPhase name paths list_inferred_types predefs files error io out
\ No newline at end of file
frontend/frontend.icl
View file @
27472f84
...
...
@@ -72,8 +72,8 @@ instance == FrontEndPhase where
(==)
a
b
=
equal_constructor
a
b
frontEndInterface
::
!
FrontEndPhase
!
Ident
!
SearchPaths
!*
PredefinedSymbols
!*
HashTable
!*
Files
!*
File
!*
File
!*
File
->
(!*
PredefinedSymbols
,
!*
HashTable
,
!*
Files
,
!*
File
,
!*
File
,
!*
File
,
!
Optional
*
FrontEndSyntaxTree
)
frontEndInterface
upToPhase
mod_ident
search_paths
predef_symbols
hash_table
files
error
io
out
frontEndInterface
::
!
FrontEndPhase
!
Ident
!
SearchPaths
!
Bool
!*
PredefinedSymbols
!*
HashTable
!*
Files
!*
File
!*
File
!*
File
->
(!*
PredefinedSymbols
,
!*
HashTable
,
!*
Files
,
!*
File
,
!*
File
,
!*
File
,
!
Optional
*
FrontEndSyntaxTree
)
frontEndInterface
upToPhase
mod_ident
search_paths
list_inferred_types
predef_symbols
hash_table
files
error
io
out
#
(
ok
,
mod
,
hash_table
,
error
,
predef_symbols
,
files
)
=
wantModule
cWantIclFile
mod_ident
NoPos
(
hash_table
-*->
(
"Parsing:"
,
mod_ident
))
error
search_paths
predef_symbols
files
|
not
ok
...
...
@@ -101,8 +101,9 @@ frontEndInterface upToPhase mod_ident search_paths predef_symbols hash_table fil
=
frontSyntaxTree
predef_symbols
hash_table
files
error
io
out
icl_mod
dcl_mods
fun_defs
components
array_instances
var_heap
optional_dcl_icl_conversions
global_fun_range
#
(
ok
,
fun_defs
,
array_instances
,
type_code_instances
,
common_defs
,
imported_funs
,
heaps
,
predef_symbols
,
error
)
=
typeProgram
(
components
-*->
"Typing"
)
fun_defs
icl_specials
icl_common
icl_declared
.
dcls_import
dcl_mods
heaps
predef_symbols
error
#
(
ok
,
fun_defs
,
array_instances
,
type_code_instances
,
common_defs
,
imported_funs
,
heaps
,
predef_symbols
,
error
,
out
)
=
typeProgram
(
components
-*->
"Typing"
)
fun_defs
icl_specials
list_inferred_types
icl_common
icl_declared
.
dcls_import
dcl_mods
heaps
predef_symbols
error
out
|
not
ok
=
(
predef_symbols
,
hash_table
,
files
,
error
,
io
,
out
,
No
)
...
...
@@ -227,4 +228,4 @@ where
#
(
fun_def
,
fun_defs
)
=
fun_defs
![
fun
]
#
properties
=
{
form_properties
=
cAttributed
bitor
cAnnotated
,
form_attr_position
=
No
}
(
Yes
ftype
)
=
fun_def
.
fun_type
=
show_types
funs
fun_defs
(
file
<<<
fun_def
.
fun_symb
<<<
" :: "
<::
(
properties
,
ftype
)
<<<
'\n'
)
=
show_types
funs
fun_defs
(
file
<<<
fun_def
.
fun_symb
<<<
" :: "
<::
(
properties
,
ftype
,
No
)
<<<
'\n'
)
frontend/main.icl
View file @
27472f84
...
...
@@ -147,7 +147,7 @@ compileModule mod_name ms
loadModule
mod_ident
predef_symbols
hash_table
ms
=:{
ms_files
,
ms_error
,
ms_io
,
ms_out
,
ms_paths
}
#
(
predef_symbols
,
hash_table
,
ms_files
,
ms_error
,
ms_io
,
ms_out
,
optional_syntax_tree
)
=
frontEndInterface
FrontEndPhaseAll
mod_ident
{
sp_locations
=
[],
sp_paths
=
ms_paths
}
predef_symbols
hash_table
ms_files
ms_error
ms_io
ms_out
=
frontEndInterface
FrontEndPhaseAll
mod_ident
{
sp_locations
=
[],
sp_paths
=
ms_paths
}
False
predef_symbols
hash_table
ms_files
ms_error
ms_io
ms_out
ms
=
{
ms
&
ms_files
=
ms_files
,
ms_error
=
ms_error
,
ms_io
=
ms_io
,
ms_out
=
ms_out
}
=
case
optional_syntax_tree
of
...
...
frontend/overloading.icl
View file @
27472f84
...
...
@@ -93,19 +93,24 @@ where
instanceError
symbol
types
err
#
err
=
errorHeading
"Overloading error"
err
format
=
{
form_properties
=
cNoProperties
,
form_attr_position
=
No
}
=
{
err
&
ea_file
=
err
.
ea_file
<<<
"
\"
"
<<<
symbol
<<<
"
\"
no instance available of type "
<::
(
format
,
types
)
<<<
'\n'
}
// MW4 was: = { err & ea_file = err.ea_file <<< " \"" <<< symbol <<< "\" no instance available of type " <:: (format, types) <<< '\n' }
=
{
err
&
ea_file
=
err
.
ea_file
<<<
"
\"
"
<<<
symbol
<<<
"
\"
no instance available of type "
<::
(
format
,
types
,
Yes
initialTypeVarBeautifulizer
)
<<<
'\n'
}
uniqueError
symbol
types
err
#
err
=
errorHeading
"Overloading/Uniqueness error"
err
format
=
{
form_properties
=
cAnnotated
,
form_attr_position
=
No
}
=
{
err
&
ea_file
=
err
.
ea_file
<<<
"
\"
"
<<<
symbol
<<<
"
\"
uniqueness specification of instance conflicts with current application "
<::
(
format
,
types
)
<<<
'\n'
}
// MW4 was: <<< "\" uniqueness specification of instance conflicts with current application " <:: (format, types) <<< '\n'}
<<<
"
\"
uniqueness specification of instance conflicts with current application "
<::
(
format
,
types
,
Yes
initialTypeVarBeautifulizer
)
<<<
'\n'
}
unboxError
type
err
#
err
=
errorHeading
"Overloading error of Array class"
err
format
=
{
form_properties
=
cNoProperties
,
form_attr_position
=
No
}
=
{
err
&
ea_file
=
err
.
ea_file
<<<
' '
<::
(
format
,
type
)
<<<
" instance cannot be unboxed
\n
"
}
// MW4 was: = { err & ea_file = err.ea_file <<< ' ' <:: (format, type) <<< " instance cannot be unboxed\n"}
=
{
err
&
ea_file
=
err
.
ea_file
<<<
' '
<::
(
format
,
type
,
Yes
initialTypeVarBeautifulizer
)
<<<
" instance cannot be unboxed
\n
"
}
overloadingError
op_symb
err
#
err
=
errorHeading
"Overloading error"
err
...
...
frontend/parse.icl
View file @
27472f84
...
...
@@ -115,7 +115,9 @@ stringToIdent ident ident_class pState=:{ps_hash_table}
internalIdent
::
!
String
!*
ParseState
->
(!
Ident
,
!*
ParseState
)
internalIdent
prefix
pState
#
({
fp_line
,
fp_col
},
pState
=:{
ps_hash_table
})
=
getPosition
pState
case_string
=
prefix
+++
toString
fp_line
+++
"_"
+++
toString
fp_col
// MW4 was: (changed to make it compatible with conventions used in postparse)
// case_string = prefix +++ toString fp_line +++ "_" +++ toString fp_col
case_string
=
prefix
+++
";"
+++
toString
fp_line
+++
";"
+++
toString
fp_col
(
case_ident
,
ps_hash_table
)
=
putIdentInHashTable
case_string
IC_Expression
ps_hash_table
=
(
case_ident
,
{
pState
&
ps_hash_table
=
ps_hash_table
}
)
...
...
@@ -643,7 +645,8 @@ where
want_FunctionBody
::
!
Token
![
NodeDefWithLocals
]
![
GuardedExpr
]
!(
Token
->
Bool
)
!
ParseState
->
(!
OptGuardedAlts
,
!
ParseState
)
want_FunctionBody
BarToken
nodeDefs
alts
sep
pState
// # (lets, pState) = want_StrictLet pState // removed from 2.0
#
(
token
,
pState
)
=
nextToken
FunctionContext
pState
#
(
guard_position
,
pState
)
=
getPosition
pState
// MW4++
(
token
,
pState
)
=
nextToken
FunctionContext
pState
|
token
==
OtherwiseToken
#
(
token
,
pState
)
=
nextToken
FunctionContext
pState
(
nodeDefs2
,
token
,
pState
)
=
want_LetBefores
token
pState
...
...
@@ -663,16 +666,25 @@ where
offside
=
position
.
fp_col
(
expr
,
pState
)
=
want_FunctionBody
token
nodeDefs2
[]
sep
pState
pState
=
wantEndNestedGuard
(
default_found
expr
)
offside
pState
alt
=
{
alt_nodes
=
nodeDefs
,
alt_guard
=
guard
,
alt_expr
=
expr
}
// MW4 was: alt = { alt_nodes = nodeDefs, alt_guard = guard, alt_expr = expr }
alt
=
{
alt_nodes
=
nodeDefs
,
alt_guard
=
guard
,
alt_expr
=
expr
,
alt_ident
=
guard_ident
guard_position
.
fp_line
}
(
token
,
pState
)
=
nextToken
FunctionContext
pState
(
nodeDefs
,
token
,
pState
)
=
want_LetBefores
token
pState
=
want_FunctionBody
token
nodeDefs
[
alt
:
alts
]
sep
pState
// otherwise
#
(
expr
,
pState
)
=
root_expression
True
token
nodeDefs2
[]
sep
pState
alt
=
{
alt_nodes
=
nodeDefs
,
alt_guard
=
guard
,
alt_expr
=
expr
}
// MW4 was: alt = { alt_nodes = nodeDefs, alt_guard = guard, alt_expr = expr }
alt
=
{
alt_nodes
=
nodeDefs
,
alt_guard
=
guard
,
alt_expr
=
expr
,
alt_ident
=
guard_ident
guard_position
.
fp_line
}
(
token
,
pState
)
=
nextToken
FunctionContext
pState
(
nodeDefs
,
token
,
pState
)
=
want_LetBefores
token
pState
=
want_FunctionBody
token
nodeDefs
[
alt
:
alts
]
sep
pState
// MW4..
where
guard_ident
line_nr
=
{
id_name
=
"_g;"
+++
toString
line_nr
+++
";"
,
id_info
=
nilPtr
}
// ..MW4
want_FunctionBody
token
nodeDefs
alts
sep
pState
=
root_expression
localsExpected
token
nodeDefs
(
reverse
alts
)
sep
pState
...
...
frontend/postparse.icl
View file @
27472f84
...
...
@@ -565,14 +565,17 @@ makeComprehensions [{tq_generators, tq_filter, tq_end, tq_call, tq_lhs_args, tq_
failure
=
continue
rhs
=
build_rhs
generators
success
optional_filter
failure
end
// MW4 was: = build_rhs generators success optional_filter failure end
=
build_rhs
generators
success
optional_filter
failure
end
fun_pos
parsed_def
// MW3 was: = MakeNewParsedDef fun_ident lhsArgs rhs
=
MakeNewParsedDef
fun_ident
lhsArgs
rhs
fun_pos
=
(
PE_Let
cIsStrict
(
LocalParsedDefs
[
parsed_def
])
call_comprehension
,
ca
)
build_rhs
::
[
TransformedGenerator
]
ParsedExpr
(
Optional
ParsedExpr
)
ParsedExpr
ParsedExpr
->
Rhs
build_rhs
[
generator
:
generators
]
success
optional_filter
failure
end
// MW4 was: build_rhs :: [TransformedGenerator] ParsedExpr (Optional ParsedExpr) ParsedExpr ParsedExpr -> Rhs
build_rhs
::
[
TransformedGenerator
]
ParsedExpr
(
Optional
ParsedExpr
)
ParsedExpr
ParsedExpr
Position
->
Rhs
// MW4 was: build_rhs [generator : generators] success optional_filter failure end
build_rhs
[
generator
:
generators
]
success
optional_filter
failure
end
fun_pos
=
case_with_default
generator
.
tg_case1
generator
.
tg_case_end_expr
generator
.
tg_case_end_pattern
(
foldr
(
case_end
end
)
(
case_with_default
generator
.
tg_case2
generator
.
tg_element
generator
.
tg_pattern
...
...
@@ -585,9 +588,12 @@ makeComprehensions [{tq_generators, tq_filter, tq_end, tq_call, tq_lhs_args, tq_
Yes
filter
->
optGuardedAltToRhs
(
GuardedAlts
[
{
alt_nodes
=
[],
alt_guard
=
filter
,
alt_expr
=
UnGuardedExpr
{
ewl_nodes
=
[],
ewl_expr
=
success
,
ewl_locals
=
LocalParsedDefs
[]}}]
No
)
// MW4 was: {ewl_nodes = [], ewl_expr = success, ewl_locals = LocalParsedDefs []}}] No)
{
ewl_nodes
=
[],
ewl_expr
=
success
,
ewl_locals
=
LocalParsedDefs
[]},
alt_ident
=
{
id_name
=
"_f;"
+++
toString
line_nr
+++
";"
,
id_info
=
nilPtr
}}]
No
)
No
->
exprToRhs
success
(
LinePos
_
line_nr
)
=
fun_pos
/* +++ remove code duplication (bug in 2.0 with nested cases)
case_end :: TransformedGenerator Rhs -> Rhs
...
...
frontend/syntax.dcl
View file @
27472f84
...
...
@@ -55,7 +55,7 @@ instance toString Ident
|
STE_DictCons
!
ConsDef
|
STE_DictField
!
SelectorDef
|
STE_Called
![
Index
]
/* used during macro expansion to indicate that this function is called */
::
Global
object
=
{
glob_object
::
!
object
,
glob_module
::
!
Index
...
...
@@ -876,6 +876,7 @@ cNonRecursiveAppl :== False
{
alt_nodes
::
![
NodeDefWithLocals
]
,
alt_guard
::
!
ParsedExpr
,
alt_expr
::
!
OptGuardedAlts
,
alt_ident
::
!
Ident
}
::
ExprWithLocalDefs
=
...
...
@@ -1126,7 +1127,7 @@ cIsNotStrict :== False
::
CoercionPosition
=
CP_Expression
!
Expression
|
CP_FunArg
!
Ident
!
Int
// Function symbol, argument position (>=1)
::
IdentPos
=
{
ip_ident
::
!
Ident
,
ip_line
::
!
Int
...
...
@@ -1148,7 +1149,7 @@ instance <<< (Module a) | <<< a, ParsedDefinition, InstanceType, AttributeVar, T
Position
,
CaseAlt
,
AType
,
FunDef
,
ParsedExpr
,
TypeAttribute
,
(
Bind
a
b
)
|
<<<
a
&
<<<
b
,
ParsedConstructor
,
(
TypeDef
a
)
|
<<<
a
,
TypeVarInfo
,
BasicValue
,
ATypeVar
,
TypeRhs
,
FunctionPattern
,
(
Import
from_symbol
)
|
<<<
from_symbol
,
ImportDeclaration
,
ImportedIdent
,
CasePatterns
,
(
Optional
a
)
|
<<<
a
,
ConsVariable
,
BasicType
,
Annotation
,
Selection
,
SelectorDef
,
ConsDef
,
LocalDefs
,
FreeVar
,
ClassInstance
,
SignClassification
,
TypeCodeExpression
TypeCodeExpression
,
CoercionPosition
instance
==
TypeAttribute
instance
==
Annotation
...
...
frontend/syntax.icl
View file @
27472f84
...
...
@@ -840,6 +840,7 @@ cNotVarNumber :== -1
{
alt_nodes
::
![
NodeDefWithLocals
]
,
alt_guard
::
!
ParsedExpr
,
alt_expr
::
!
OptGuardedAlts
,
alt_ident
::
!
Ident
}
::
ExprWithLocalDefs
=
...
...
@@ -1762,6 +1763,44 @@ where
(<<<)
file
(
ID_Record
ident
optIdents
)
=
file
<<<
ident
<<<
" { "
<<<
optIdents
<<<
" } "
(<<<)
file
(
ID_Instance
i1
i2
tup
)
=
file
<<<
"instance "
<<<
i1
<<<
i2
<<<
tup
// !ImportedIdent !Ident !(![Type],![TypeContext])
instance
<<<
CoercionPosition
where
(<<<)
file
(
CP_FunArg
fun_name
arg_nr
)
=
file
<<<
"argument "
<<<
arg_nr
<<<
" of "
<<<
readable
fun_name
(<<<)
file
(
CP_Expression
expression
)
=
show_expression
file
expression
where
show_expression
file
(
Var
{
var_name
})
=
file
<<<
var_name
show_expression
file
(
FreeVar
{
fv_name
})
=
file
<<<
fv_name
show_expression
file
(
App
{
app_symb
={
symb_name
},
app_args
})
|
symb_name
.
id_name
==
"_dummyForStrictAlias"
=
show_expression
file
(
hd
app_args
)
=
file
<<<
readable
symb_name
show_expression
file
(
fun
@
fun_args
)
=
show_expression
file
fun
show_expression
file
(
Case
{
case_ident
=
No
})
=
file
<<<
"(case ... )"
show_expression
file
(
Selection
_
expr
selectors
)
=
file
<<<
"selection"
show_expression
file
(
Update
expr1
selectors
expr2
)
=
file
<<<
"update"
show_expression
file
(
TupleSelect
{
ds_arity
}
elem_nr
expr
)
=
file
<<<
"argument"
<<<
(
elem_nr
+
1
)
<<<
" of "
<<<
ds_arity
<<<
"-tuple"
show_expression
file
(
BasicExpr
bv
_)
=
file
<<<
bv
show_expression
file
(
MatchExpr
_
_
expr
)
=
file
<<<
"match expression"
show_expression
file
_
=
file
readable
::
!
Ident
->
String
// somewhat hacky
readable
{
id_name
}
|
id_name
==
"_cons"
||
id_name
==
"_nil"
=
"list constructor"
|
id_name
%
(
0
,
5
)
==
"_tuple"
=
"tuple"
=
id_name
instance
<<<
ImportedIdent
where
(<<<)
file
{
ii_ident
,
ii_extended
}
=
file
<<<
ii_ident
<<<
' '
<<<
ii_extended
...
...
frontend/type.dcl
View file @
27472f84
...
...
@@ -3,6 +3,9 @@ definition module type
import
StdArray
import
syntax
,
check
/* MW4 was:
typeProgram ::!{! Group} !*{# FunDef} !IndexRange !CommonDefs ![Declaration] !{# DclModule} !*Heaps !*PredefinedSymbols !*File
-> (!Bool, !*{# FunDef}, !IndexRange, {! GlobalTCType}, !{# CommonDefs}, !{# {# FunType} }, !*Heaps, !*PredefinedSymbols, !*File)
*/
typeProgram
::!{!
Group
}
!*{#
FunDef
}
!
IndexRange
!
Bool
!
CommonDefs
![
Declaration
]
!{#
DclModule
}
!*
Heaps
!*
PredefinedSymbols
!*
File
!*
File
->
(!
Bool
,
!*{#
FunDef
},
!
IndexRange
,
{!
GlobalTCType
},
!{#
CommonDefs
},
!{#
{#
FunType
}
},
!*
Heaps
,
!*
PredefinedSymbols
,
!*
File
,
!*
File
)
frontend/type.icl
View file @
27472f84
...
...
@@ -19,6 +19,7 @@ import RWSDebug
,
ts_expr_heap
::
!.
ExpressionHeap
,
ts_td_infos
::
!.
TypeDefInfos
,
ts_error
::
!.
ErrorAdmin
,
ts_out
::
!.
File
// MW4++
}
::
TypeCoercion
=
...
...
@@ -167,12 +168,84 @@ where
contains_var
var_id
_
=
False
type_error
=:
"Type error"
// MW4++
type_error_format
=:
{
form_properties
=
cNoProperties
,
form_attr_position
=
No
}
// MW4++
/* MW4 was:
cannotUnify t1 t2 position err
# err = errorHeading "Type error" err
format = { form_properties = cNoProperties, form_attr_position = No }
= { err & ea_file = err.ea_file <<< optionalFrontPosition position <<< " cannot unify " <:: (format, t1)
<<< " with " <:: (format, t2) <<< position <<< '\n' }
*/
cannotUnify
t1
t2
position
=:(
CP_Expression
expr
)
err
=:{
ea_loc
=[
ip
:_]}
=
case
tryToOptimizePosition
expr
ip
of
Yes
ident_pos
#
err
=
pushErrorAdmin
ident_pos
err
err
=
errorHeading
type_error
err
err
=
popErrorAdmin
err
->
{
err
&
ea_file
=
err
.
ea_file
<<<
" cannot unify "
<::
(
type_error_format
,
t1
,
Yes
initialTypeVarBeautifulizer
)
<<<
" with "
<::
(
type_error_format
,
t2
,
Yes
initialTypeVarBeautifulizer
)
<<<
'\n'
}
_
->
cannot_unify
t1
t2
position
err
cannotUnify
t1
t2
position
err
=
cannot_unify
t1
t2
position
err
cannot_unify
t1
t2
position
err
#
(
err
=:{
ea_file
})
=
errorHeading
type_error
err
ea_file
=
case
position
of
CP_FunArg
_
_
->
ea_file
<<<
"
\"
"
<<<
position
<<<
"
\"
"
_
->
ea_file
ea_file
=
ea_file
<<<
" cannot unify "
<::
(
type_error_format
,
t1
,
Yes
initialTypeVarBeautifulizer
)
<<<
" with "
<::
(
type_error_format
,
t2
,
Yes
initialTypeVarBeautifulizer
)
ea_file
=
case
position
of
CP_FunArg
_
_
->
ea_file
_
->
ea_file
<<<
" near "
<<<
position
=
{
err
&
ea_file
=
ea_file
<<<
'\n'
}
// MW4..
tryToOptimizePosition
(
Case
{
case_ident
=
Yes
{
id_name
}})
ip
=
tryToOptimizePositionFromString
id_name
ip
tryToOptimizePosition
(
App
{
app_symb
={
symb_name
}})
ip
=
tryToOptimizePositionFromString
symb_name
.
id_name
ip
tryToOptimizePosition
(
fun
@
_)
ip
=
tryToOptimizePosition
fun
ip
tryToOptimizePositionFromString
id_name
ip
#
fst_semicolon_index
=
searchlArrElt
((==)
';'
)
id_name
0
|
fst_semicolon_index
<
size
id_name
#
snd_semicolon_index
=
searchlArrElt
((==)
';'
)
id_name
(
fst_semicolon_index
+1
)
prefix
=
id_name
%
(
0
,
fst_semicolon_index
-1
)
line
=
toInt
(
id_name
%
(
fst_semicolon_index
+1
,
snd_semicolon_index
-1
))
=
Yes
{
ip
&
ip_ident
=
{
id_name
=
prefix_to_readable_name
prefix
,
id_info
=
nilPtr
},
ip_line
=
line
}
=
No
where
prefix_to_readable_name
"_c"
=
"case"
prefix_to_readable_name
"_g"
=
"guard"
prefix_to_readable_name
"_f"
=
"filter"
prefix_to_readable_name
prefix
|
prefix
.[
0
]
==
'c'
=
"comprehension"
|
prefix
.[
0
]
==
'g'
=
"generator"
prefix_to_readable_name
_
=
abort
"fatal error 21 in type.icl"
// search for an element in an array
searchlArrElt
p
s
i
:==
searchl
s
i
where
searchl
s
i
|
i
>=
size
s
=
i
|
p
s
.[
i
]
=
i
=
searchl
s
(
i
+1
)
// ..MW4
class
unify
a
::
!
a
!
a
!
TypeInput
!*{!
Type
}
!*
TypeHeaps
->
(!
Bool
,
!*{!
Type
},
!*
TypeHeaps
)
...
...
@@ -1438,18 +1511,24 @@ where
specification_error
type
err
#
err
=
errorHeading
"Type error"
err
format
=
{
form_properties
=
cAttributed
,
form_attr_position
=
No
}
=
{
err
&
ea_file
=
err
.
ea_file
<<<
" specified type conflicts with derived type "
<::
(
format
,
type
)
<<<
'\n'
}
// MW4 was: = { err & ea_file = err.ea_file <<< " specified type conflicts with derived type " <:: (format, type) <<< '\n' }
=
{
err
&
ea_file
=
err
.
ea_file
<<<
" specified type conflicts with derived type "
<::
(
format
,
type
,
Yes
initialTypeVarBeautifulizer
)
<<<
'\n'
}
cleanUpAndCheckFunctionTypes
[]
_
_
start_index
defs
type_contexts
coercion_env
attr_partition
type_var_env
attr_var_env
(
fun_defs
,
ts
)
// MW4 was:cleanUpAndCheckFunctionTypes [] _ _ start_index defs type_contexts coercion_env attr_partition type_var_env attr_var_env (fun_defs, ts)
cleanUpAndCheckFunctionTypes
[]
_
_
start_index
_
defs
type_contexts
coercion_env
attr_partition
type_var_env
attr_var_env
(
fun_defs
,
ts
)
=
(
fun_defs
,
ts
)
cleanUpAndCheckFunctionTypes
[
fun
:
funs
]
[
{
fe_requirements
=
{
req_case_and_let_exprs
}}
:
reqs
]
dict_types
start_index
defs
type_contexts
coercion_env
// MW4 was:cleanUpAndCheckFunctionTypes [fun : funs] [ {fe_requirements = {req_case_and_let_exprs}} : reqs] dict_types start_index defs type_contexts coercion_env
cleanUpAndCheckFunctionTypes
[
fun
:
funs
]
[
{
fe_requirements
=
{
req_case_and_let_exprs
}}
:
reqs
]
dict_types
start_index
list_inferred_types
defs
type_contexts
coercion_env
attr_partition
type_var_env
attr_var_env
(
fun_defs
,
ts
)
#
(
fd
,
fun_defs
)
=
fun_defs
![
fun
]
dict_ptrs
=
get_dict_ptrs
fun
dict_types
(
type_var_env
,
attr_var_env
,
ts
)
=
clean_up_and_check_function_type
fd
fun
(
start_index
==
fun
)
defs
type_contexts
// MW4 was: (type_var_env, attr_var_env, ts) = clean_up_and_check_function_type fd fun (start_index == fun) defs type_contexts
(
type_var_env
,
attr_var_env
,
ts
)
=
clean_up_and_check_function_type
fd
fun
(
start_index
==
fun
)
list_inferred_types
defs
type_contexts
(
dict_ptrs
++
req_case_and_let_exprs
)
coercion_env
attr_partition
type_var_env
attr_var_env
ts
=
cleanUpAndCheckFunctionTypes
funs
reqs
dict_types
start_index
defs
type_contexts
coercion_env
attr_partition
type_var_env
attr_var_env
(
fun_defs
,
ts
)
// MW4 was: = cleanUpAndCheckFunctionTypes funs reqs dict_types start_index defs type_contexts coercion_env attr_partition type_var_env attr_var_env (fun_defs, ts)
=
cleanUpAndCheckFunctionTypes
funs
reqs
dict_types
start_index
list_inferred_types
defs
type_contexts
coercion_env
attr_partition
type_var_env
attr_var_env
(
fun_defs
,
ts
)
where
get_dict_ptrs
fun_index
[]
=
[]
...
...
@@ -1458,7 +1537,8 @@ where
=
ptrs
=
get_dict_ptrs
fun_index
dict_types
clean_up_and_check_function_type
{
fun_symb
,
fun_pos
,
fun_type
=
opt_fun_type
}
fun
is_start_rule
defs
type_contexts
type_ptrs
// MW4 was: clean_up_and_check_function_type {fun_symb,fun_pos,fun_type = opt_fun_type} fun is_start_rule defs type_contexts type_ptrs
clean_up_and_check_function_type
{
fun_symb
,
fun_pos
,
fun_type
=
opt_fun_type
}
fun
is_start_rule
list_inferred_types
defs
type_contexts
type_ptrs
coercion_env
attr_partition
type_var_env
attr_var_env
ts
#
(
env_type
,
ts
)
=
ts
!
ts_fun_env
.[
fun
]
#
ts
=
{
ts
&
ts_error
=
setErrorAdmin
(
newPosition
fun_symb
fun_pos
)
ts
.
ts_error
}
...
...
@@ -1476,11 +1556,22 @@ where
#
(
clean_fun_type
,
type_var_env
,
attr_var_env
,
ts_type_heaps
,
ts_var_heap
,
ts_expr_heap
,
ts_error
)
=
cleanUpSymbolType
is_start_rule
cDerivedType
exp_fun_type
type_contexts
type_ptrs
coercion_env
attr_partition
type_var_env
attr_var_env
ts
.
ts_type_heaps
ts
.
ts_var_heap
ts
.
ts_expr_heap
ts
.
ts_error
// MW4..
ts_out
=
ts
.
ts_out
ts_out
=
case
list_inferred_types
of
False
->
ts_out
_
#
form
=
{
form_properties
=
cNoProperties
,
form_attr_position
=
No
}
->
ts_out
<<<
fun_symb
<<<
" :: "
<::
(
form
,
clean_fun_type
,
Yes
initialTypeVarBeautifulizer
)
<<<
'\n'
// ..MW4
ts_fun_env
=
{
ts
.
ts_fun_env
&
[
fun
]
=
CheckedType
clean_fun_type
}
->
(
type_var_env
,
attr_var_env
,
{
ts
&
ts_type_heaps
=
ts_type_heaps
,
ts_var_heap
=
ts_var_heap
,
ts_expr_heap
=
ts_expr_heap
,
ts_fun_env
=
ts_fun_env
,
ts_error
=
ts_error
})
// MW4 was: -> (type_var_env, attr_var_env, { ts & ts_type_heaps = ts_type_heaps, ts_var_heap = ts_var_heap, ts_expr_heap = ts_expr_heap, ts_fun_env = ts_fun_env, ts_error = ts_error })
->
(
type_var_env
,
attr_var_env
,
{
ts
&
ts_type_heaps
=
ts_type_heaps
,
ts_var_heap
=
ts_var_heap
,
ts_expr_heap
=
ts_expr_heap
,
ts_fun_env
=
ts_fun_env
,
ts_error
=
ts_error
,
ts_out
=
ts_out
})
check_function_type
fun_type
tmp_fun_type
=:{
tst_lifted
}
clean_fun_type
=:{
st_arity
,
st_args
,
st_vars
,
st_attr_vars
,
st_context
}
type_ptrs
defs
fun_env
attr_var_env
type_heaps
expr_heap
error
defs
fun_env
attr_var_env
type_heaps
expr_heap
error
#
(
equi
,
attr_var_env
,
type_heaps
)
=
equivalent
clean_fun_type
tmp_fun_type
(
length
fun_type
.
st_context
)
defs
attr_var_env
type_heaps
|
equi
#
type_with_lifted_arg_types
=
addLiftedArgumentsToSymbolType
fun_type
tst_lifted
st_args
st_vars
st_attr_vars
st_context
...
...
@@ -1507,12 +1598,14 @@ addLiftedArgumentsToSymbolType st=:{st_arity,st_args,st_vars,st_attr_vars,st_con
,
fe_location
::
!
IdentPos
}
typeProgram
::!{!
Group
}
!*{#
FunDef
}
!
IndexRange
!
CommonDefs
![
Declaration
]
!{#
DclModule
}
!*
Heaps
!*
PredefinedSymbols
!*
File
->
(!
Bool
,
!*{#
FunDef
},
!
IndexRange
,
{!
GlobalTCType
},
!{#
CommonDefs
},
!{#
{#
FunType
}
},
!*
Heaps
,
!*
PredefinedSymbols
,
!*
File
)
typeProgram
comps
fun_defs
specials
icl_defs
imports
modules
{
hp_var_heap
,
hp_expression_heap
,
hp_type_heaps
}
predef_symbols
file
// MW4 was:typeProgram ::!{! Group} !*{# FunDef} !IndexRange !CommonDefs ![Declaration] !{# DclModule} !*Heaps !*PredefinedSymbols !*File
typeProgram
::!{!
Group
}
!*{#
FunDef
}
!
IndexRange
!
Bool
!
CommonDefs
![
Declaration
]
!{#
DclModule
}
!*
Heaps
!*
PredefinedSymbols
!*
File
!*
File
// MW4 was: -> (!Bool, !*{# FunDef}, !IndexRange, {! GlobalTCType}, !{# CommonDefs}, !{# {# FunType} }, !*Heaps, !*PredefinedSymbols, !*File)
->
(!
Bool
,
!*{#
FunDef
},
!
IndexRange
,
{!
GlobalTCType
},
!{#
CommonDefs
},
!{#
{#
FunType
}
},
!*
Heaps
,
!*
PredefinedSymbols
,
!*
File
,
!*
File
)
// MW4 was:typeProgram comps fun_defs specials icl_defs imports modules {hp_var_heap, hp_expression_heap, hp_type_heaps} predef_symbols file
typeProgram
comps
fun_defs
specials
list_inferred_types
icl_defs
imports
modules
{
hp_var_heap
,
hp_expression_heap
,
hp_type_heaps
}
predef_symbols
file
out
#!
fun_env_size
=
size
fun_defs
#
ts_error
=
{
ea_file
=
file
,
ea_loc
=
[],
ea_ok
=
True
}
ti_common_defs
=
{{
dcl_common
\\
{
dcl_common
}
<-:
modules
}
&
[
cIclModIndex
]
=
icl_defs
}
ti_functions
=
{
dcl_functions
\\
{
dcl_functions
}
<-:
modules
}
...
...
@@ -1526,19 +1619,24 @@ typeProgram comps fun_defs specials icl_defs imports modules {hp_var_heap, hp_ex
(_,
ts_error
,
class_instances
,
th_vars
,
td_infos
)
=
collect_and_check_instances
(
size
icl_defs
.
com_instance_defs
)
ti_common_defs
state
ts
=
{
ts_fun_env
=
InitFunEnv
fun_env_size
,
ts_var_heap
=
hp_var_heap
,
ts_expr_heap
=
hp_expression_heap
,
ts_var_store
=
0
,
ts_attr_store
=
FirstAttrVar
,
ts_type_heaps
=
{
hp_type_heaps
&
th_vars
=
th_vars
},
ts_td_infos
=
td_infos
,
ts_error
=
ts_error
}
// MW4 was: ts_type_heaps = { hp_type_heaps & th_vars = th_vars }, ts_td_infos = td_infos, ts_error = ts_error }
ts_type_heaps
=
{
hp_type_heaps
&
th_vars
=
th_vars
},
ts_td_infos
=
td_infos
,
ts_error
=
ts_error
,
ts_out
=
out
}
ti
=
{
ti_common_defs
=
ti_common_defs
,
ti_functions
=
ti_functions
}
special_instances
=
{
si_next_array_member_index
=
fun_env_size
,
si_array_instances
=
[],
si_next_TC_member_index
=
0
,
si_TC_instances
=
[]
}
#
(
type_error
,
fun_defs
,
predef_symbols
,
special_instances
,
ts
)
=
type_components
0
comps
class_instances
ti
(
False
,
fun_defs
,
predef_symbols
,
special_instances
,
ts
)
// MW4 was: # (type_error, fun_defs, predef_symbols, special_instances, ts) = type_components 0 comps class_instances ti (False, fun_defs, predef_symbols, special_instances, ts)
#
(
type_error
,
fun_defs
,
predef_symbols
,
special_instances
,
ts
)
=
type_components
list_inferred_types
0
comps
class_instances
ti
(
False
,
fun_defs
,
predef_symbols
,
special_instances
,
ts
)
(
fun_defs
,
ts_fun_env
)
=
update_function_types
0
comps
ts
.
ts_fun_env
fun_defs
(
type_error
,
fun_defs
,
predef_symbols
,
special_instances
,
{
ts_fun_env
,
ts_error
,
ts_var_heap
,
ts_expr_heap
,
ts_type_heaps
})
=
type_instances
specials
.
ir_from
specials
.
ir_to
class_instances
ti
(
type_error
,
fun_defs
,
predef_symbols
,
special_instances
,
{
ts
&
ts_fun_env
=
ts_fun_env
})
// MW4 was: (type_error, fun_defs, predef_symbols, special_instances, {ts_fun_env,ts_error,ts_var_heap, ts_expr_heap, ts_type_heaps})
(
type_error
,
fun_defs
,
predef_symbols
,
special_instances
,
{
ts_fun_env
,
ts_error
,
ts_var_heap
,
ts_expr_heap
,
ts_type_heaps
,
ts_out
})
// MW4 was: = type_instances specials.ir_from specials.ir_to class_instances ti (type_error, fun_defs, predef_symbols, special_instances,
=
type_instances
list_inferred_types
specials
.
ir_from
specials
.
ir_to
class_instances
ti
(
type_error
,
fun_defs
,
predef_symbols
,
special_instances
,
{
ts
&
ts_fun_env
=
ts_fun_env
})
{
si_array_instances
,
si_next_array_member_index
,
si_next_TC_member_index
,
si_TC_instances
}=
special_instances
(
fun_defs
,
predef_symbols
,
ts_type_heaps
)
=
convert_array_instances
si_array_instances
ti_common_defs
fun_defs
predef_symbols
ts_type_heaps
type_code_instances
=
{
createArray
si_next_TC_member_index
GTT_Function
&
[
gtci_index
]
=
gtci_type
\\
{
gtci_index
,
gtci_type
}
<-
si_TC_instances
}
=
(
not
type_error
,
fun_defs
,
{
ir_from
=
fun_env_size
,
ir_to
=
si_next_array_member_index
},
type_code_instances
,
ti_common_defs
,
ti_functions
,
{
hp_var_heap
=
ts_var_heap
,
hp_expression_heap
=
ts_expr_heap
,
hp_type_heaps
=
ts_type_heaps
},
predef_symbols
,
ts_error
.
ea_file
)
// MW4 was: {hp_var_heap = ts_var_heap, hp_expression_heap = ts_expr_heap, hp_type_heaps = ts_type_heaps }, predef_symbols, ts_error.ea_file)
{
hp_var_heap
=
ts_var_heap
,
hp_expression_heap
=
ts_expr_heap
,
hp_type_heaps
=
ts_type_heaps
},
predef_symbols
,
ts_error
.
ea_file
,
ts_out
)
// ---> ("typeProgram", array_inst_types)
where
collect_imported_instances
imports
common_defs
dummy
error
class_instances
type_var_heap
td_infos
...
...
@@ -1611,18 +1709,24 @@ where
=
(
error
,
IT_Node
ins
it_less
it_greater
)
=
(
checkError
ins_types
" instance is overlapping"
error
,
IT_Node
ins
it_less
it_greater
)
type_instances
ir_from
ir_to
class_instances
ti
funs_and_state
// MW4 was: type_instances ir_from ir_to class_instances ti funs_and_state