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
285a4f20
Commit
285a4f20
authored
Dec 01, 1999
by
Sjaak Smetsers
Browse files
Several bug fixes:
- dictionary arguments added properly - coercion of function types
parent
b3caffdb
Changes
9
Expand all
Hide whitespace changes
Inline
Side-by-side
frontend/check.icl
View file @
285a4f20
...
...
@@ -1537,7 +1537,7 @@ where
checkExpression
free_vars
(
PE_Ident
id
)
e_input
e_state
e_info
cs
=
checkIdentExpression
cIsNotInExpressionList
free_vars
id
e_input
e_state
e_info
cs
checkExpression
free_vars
expr
e_input
e_state
e_info
cs
=
abort
"checkExpression (check.icl, line 1433)"
<<-
expr
=
abort
"checkExpression (check.icl, line 1433)"
//
<<- expr
::
LastSelection
=
LS_Update
|
LS_Selction
|
LS_UniqueSelection
...
...
@@ -2128,7 +2128,7 @@ where
=
(
fun_defs
,
symbol_table
)
get_calls
(
STE_FunctionOrMacro
[
x
:
xs
])
=
(
x
,
xs
)
get_calls
ste_kind
=
abort
"get_calls (check.icl)"
<<-
ste_kind
get_calls
ste_kind
=
abort
"get_calls (check.icl)"
//
<<- ste_kind
checkFunctions
::
!
Index
!
Level
!
Index
!
Index
!*{#
FunDef
}
!*
ExpressionInfo
!*
Heaps
!*
CheckState
->
(!*{#
FunDef
},
!*
ExpressionInfo
,
!*
Heaps
,
!*
CheckState
)
...
...
@@ -2375,7 +2375,7 @@ where
#
({
ste_kind
,
ste_index
},
cs_symbol_table
)
=
readPtr
ds_ident
.
id_info
cs
.
cs_symbol_table
|
ste_kind
==
req_kind
=
({
ds
&
ds_index
=
ste_index
},
{
cs
&
cs_symbol_table
=
cs_symbol_table
})
#
cs_error
=
checkError
"definition module"
(
"conflicting definition in implementation module"
->>(
"ste_kind"
,
ste_kind
,
ptrToInt
ds_ident
.
id_info
))
#
cs_error
=
checkError
"definition module"
"conflicting definition in implementation module"
(
setErrorAdmin
(
newPosition
ds_ident
pos
)
cs
.
cs_error
)
=
({
ds
&
ds_index
=
ste_index
},
{
cs
&
cs_error
=
cs_error
,
cs_symbol_table
=
cs_symbol_table
})
...
...
frontend/convertcases.icl
View file @
285a4f20
...
...
@@ -50,7 +50,7 @@ where
#
((
let_binds
,
let_expr
),
ci
)
=
convertCases
(
addLetVars
let_binds
let_type
bound_vars
)
group_index
common_defs
(
let_binds
,
let_expr
)
ci
->
({
lad
&
let_binds
=
let_binds
,
let_expr
=
let_expr
},
ci
)
_
->
abort
"convertCases [Let] (convertcases 53)"
<<-
let_info
->
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
]
...
...
@@ -760,7 +760,7 @@ where
{
cp_info
&
cp_free_vars
=
[
(
var_info_ptr
,
type
)
:
cp_info
.
cp_free_vars
],
cp_var_heap
=
cp_var_heap
<:=
(
var_info_ptr
,
VI_FreeVar
var_name
new_info_ptr
1
type
)
})
_
->
abort
"copy [BoundVar] (convertcases, 612)"
<<-
(
var_info
--->
(
var_name
,
ptrToInt
var_info_ptr
))
->
abort
"copy [BoundVar] (convertcases, 612)"
//
<<- (var_info ---> (var_name, ptrToInt var_info_ptr))
instance
copy
Expression
where
...
...
@@ -1274,9 +1274,8 @@ where
#
(
let_info
,
di_expr_heap
)
=
readPtr
let_info_ptr
di_expr_heap
ok
=
case
let_info
of
EI_LetTypeAndRefCounts
let_type
ref_counts
->
True
x
->
abort
(
"abort [distributeLets (EI_LetTypeAndRefCounts)]"
->>
x
)
x
->
abort
(
"abort [distributeLets (EI_LetTypeAndRefCounts)]"
)
//
->> x)
|
ok
// ---> ("distributeLets", ptrToInt let_info_ptr, [ x.bind_dst \\ x <- let_binds])
#
(
EI_LetTypeAndRefCounts
let_type
ref_counts
)
=
let_info
di_var_heap
=
set_let_expression_info
depth
let_strict
let_binds
ref_counts
let_type
di_var_heap
(
let_expr
,
dl_info
)
=
distributeLets
depth
let_expr
{
dl_info
&
di_var_heap
=
di_var_heap
,
di_expr_heap
=
di_expr_heap
}
...
...
frontend/overloading.icl
View file @
285a4f20
This diff is collapsed.
Click to expand it.
frontend/syntax.dcl
View file @
285a4f20
...
...
@@ -471,6 +471,7 @@ cIsALocalVar :== False
VI_Alias
!
BoundVar
/* used for resolving aliases just before type checking (in transform) */
|
/* used during elimination and lifting of cases */
VI_FreeVar
!
Ident
!
VarInfoPtr
!
Int
!
AType
|
VI_BoundVar
!
AType
|
VI_LocalVar
|
VI_ClassVar
!
Ident
!
VarInfoPtr
!
Int
/* used to hold dictionary variables during overloading */
|
VI_Forward
!
BoundVar
|
VI_LetVar
!
LetVarInfo
|
VI_LetExpression
!
LetExpressionInfo
|
VI_CaseVar
!
VarInfoPtr
|
VI_CorrespondenceNumber
!
Int
|
VI_SequenceNumber
!
Int
|
VI_Used
|
/* for indicating that an imported function has been used */
...
...
@@ -601,7 +602,8 @@ cNonRecursiveAppl :== False
|
EI_Overloaded
!
OverloadedCall
/* initial, set by the type checker */
|
EI_Instance
!(
Global
DefinedSymbol
)
![
Expression
]
/* intermedediate, used during resolving of overloading */
|
EI_Selection
![
Selection
]
!
BoundVar
![
Expression
]
/* intermedediate, used during resolving of overloading */
// | EI_Selection ![Selection] !BoundVar ![Expression] /* intermedediate, used during resolving of overloading */
|
EI_Selection
![
Selection
]
!
VarInfoPtr
![
Expression
]
/* intermedediate, used during resolving of overloading */
|
EI_Context
![
Expression
]
/* intermedediate, used during resolving of overloading */
/* For handling dynamics */
...
...
@@ -983,8 +985,6 @@ cIsNotStrict :== False
|
(@)
infixl
9
!
Expression
![
Expression
]
|
Let
!
Let
|
Case
!
Case
// | RecordSelect !SelectorKind !(Global DefinedSymbol) !Int !Expression
// | ArraySelect !SelectorKind !ArraySelector !Expression !Expression
|
Selection
!(
Optional
(
Global
DefinedSymbol
))
!
Expression
![
Selection
]
|
Update
!
Expression
![
Selection
]
Expression
|
RecordUpdate
!(
Global
DefinedSymbol
)
!
Expression
![
Bind
Expression
(
Global
FieldSymbol
)]
...
...
@@ -999,7 +999,8 @@ cIsNotStrict :== False
|
MatchExpr
!(
Optional
(
Global
DefinedSymbol
))
!(
Global
DefinedSymbol
)
!
Expression
|
FreeVar
FreeVar
|
Constant
!
SymbIdent
!
Int
!
Priority
!
Bool
/* auxiliary clause used during checking */
|
Constant
!
SymbIdent
!
Int
!
Priority
!
Bool
/* auxiliary clause used during checking */
|
ClassVariable
!
VarInfoPtr
/* auxiliary clause used during overloading */
|
DynamicExpr
!
DynamicExpr
// | TypeCase !TypeCase
...
...
frontend/syntax.icl
View file @
285a4f20
...
...
@@ -427,6 +427,7 @@ cIsALocalVar :== False
VI_Alias
!
BoundVar
/* used for resolving aliases just before type checking (in transform) */
|
/* used during elimination and lifting of cases */
VI_FreeVar
!
Ident
!
VarInfoPtr
!
Int
!
AType
|
VI_BoundVar
!
AType
|
VI_LocalVar
|
VI_ClassVar
!
Ident
!
VarInfoPtr
!
Int
/* used to hold dictionary variables during overloading */
|
VI_Forward
!
BoundVar
|
VI_LetVar
!
LetVarInfo
|
VI_LetExpression
!
LetExpressionInfo
|
VI_CaseVar
!
VarInfoPtr
|
VI_CorrespondenceNumber
!
Int
|
VI_SequenceNumber
!
Int
|
VI_Used
|
/* for indicating that an imported function has been used */
...
...
@@ -547,7 +548,7 @@ cNotVarNumber :== -1
|
EI_Overloaded
!
OverloadedCall
/* initial, set by the type checker */
|
EI_Instance
!(
Global
DefinedSymbol
)
![
Expression
]
/* intermedediate, used during resolving of overloading */
|
EI_Selection
![
Selection
]
!
BoundVa
r
![
Expression
]
/* intermedediate, used during resolving of overloading */
|
EI_Selection
![
Selection
]
!
VarInfoPt
r
![
Expression
]
/* intermedediate, used during resolving of overloading */
|
EI_Context
![
Expression
]
/* intermedediate, used during resolving of overloading */
/* For handling dynamics */
...
...
@@ -936,7 +937,8 @@ cIsNotStrict :== False
|
MatchExpr
!(
Optional
(
Global
DefinedSymbol
))
!(
Global
DefinedSymbol
)
!
Expression
|
FreeVar
FreeVar
|
Constant
!
SymbIdent
!
Int
!
Priority
!
Bool
/* auxiliary clause used during checking */
|
Constant
!
SymbIdent
!
Int
!
Priority
!
Bool
/* auxiliary clause used during checking */
|
ClassVariable
!
VarInfoPtr
/* auxiliary clause used during overloading */
|
DynamicExpr
!
DynamicExpr
// | TypeCase !TypeCase
...
...
@@ -1375,7 +1377,9 @@ where
(<<<)
file
(
AnyCodeExpr
input
output
code_sequence
)
=
file
<<<
"code
\n
"
<<<
input
<<<
"
\n
"
<<<
output
<<<
"
\n
"
<<<
code_sequence
(<<<)
file
(
FreeVar
{
fv_name
})
=
file
<<<
"FREEVAR "
<<<
fv_name
(<<<)
file
expr
=
abort
(
"<<< (Expression) [line 1290]"
<<-
expr
)
(<<<)
file
(
ClassVariable
_)
=
file
<<<
"ClassVariable "
(<<<)
file
expr
=
abort
(
"<<< (Expression) [line 1290]"
)
//<<- expr)
instance
<<<
TypeCase
where
...
...
frontend/trans.icl
View file @
285a4f20
...
...
@@ -207,7 +207,7 @@ where
ai_cur_ref_counts
=
{
ai_cur_ref_counts
&
[
arg_position
]=
min
(
ref_count
+1
)
2
}
=
(
temp_var
,
False
,
{
ai
&
ai_cur_ref_counts
=
ai_cur_ref_counts
})
continuation
var_info
ai
=:{
ai_cur_ref_counts
}
=
abort
(
"consumerRequirements"
--->
(
var_name
<<-
var_info
))
=
abort
(
"consumerRequirements"
--->
(
var_name
))
//
<<- var_info))
// continuation vi ai
// = (cPassive, ai)
...
...
@@ -280,7 +280,7 @@ instance consumerRequirements Expression where
consumerRequirements
EE
_
ai
=
(
cPassive
,
False
,
ai
)
consumerRequirements
expr
_
ai
=
abort
(
"consumerRequirements "
<<-
expr
)
=
abort
(
"consumerRequirements "
)
//
<<- expr)
requirementsOfSelectors
selectors
common_defs
ai
=
foldSt
(
reqs_of_selector
common_defs
)
selectors
ai
...
...
frontend/transform.icl
View file @
285a4f20
...
...
@@ -1373,7 +1373,7 @@ where
->
(
var
,
[{
fv_name
=
var_name
,
fv_info_ptr
=
var_info_ptr
,
fv_def_level
=
NotALevel
,
fv_count
=
0
}
:
free_vars
],
{
cos
&
cos_var_heap
=
writePtr
var_info_ptr
(
VI_Count
1
is_global
)
cos
.
cos_var_heap
})
_
->
abort
"collectVariables [BoundVar] (transform, 1227)"
<<-
(
var_info
--->
var_name
)
->
abort
"collectVariables [BoundVar] (transform, 1227)"
//
<<- (var_info ---> var_name)
// XXX
instance
<<<
FreeVar
...
...
frontend/typesupport.icl
View file @
285a4f20
implementation
module
typesupport
import
StdEnv
,
StdCompare
import
syntax
,
parse
,
check
,
unitype
,
utilities
,
RWSDebug
import
syntax
,
parse
,
check
,
unitype
,
utilities
//
, RWSDebug
// MW: this switch is used to en(dis)able the fusion algorithm
SwitchFusion
fuse
dont_fuse
:==
dont_fuse
...
...
@@ -799,7 +799,7 @@ where
=
file
<<<
'*'
|
isNonUniqueAttribute
av_number
coercions
=
file
=
file
<<<
'.'
=
file
<<<
'.'
<<<
"[["
<<<
av_number
<<<
"]]"
instance
<::
Type
where
...
...
frontend/unitype.icl
View file @
285a4f20
...
...
@@ -2,7 +2,7 @@ implementation module unitype
import
StdEnv
import
syntax
,
analunitypes
,
type
,
utilities
import
syntax
,
analunitypes
,
type
,
utilities
// , RWSDebug
import
cheat
...
...
@@ -64,6 +64,16 @@ determineAttributeCoercions off_type dem_type coercible position subst coercions
No
->
(
subst
,
crc_coercions
,
crc_td_infos
,
crc_type_heaps
,
error
)
/*
No
# (crc_coercions, copy_crc_coercions) = uniqueCopy crc_coercions
format = { form_properties = cMarkAttribute, form_attr_position = Yes ([], copy_crc_coercions) }
| file_to_true (stderr <:: (format, exp_off_type) <:: (format, exp_dem_type) <<< '\n')
---> ("determineAttributeCoercions", exp_off_type, exp_dem_type)
-> (subst, crc_coercions, crc_td_infos, crc_type_heaps, error)
-> undef
*/
NotChecked
:==
-1
DummyAttrNumber
:==
-1
::
AttributeGroups
:==
{!
[
Int
]}
...
...
@@ -525,6 +535,7 @@ makeNonUnique attr {coer_demanded, coer_offered}
#
(
dem_coercions
,
coer_demanded
)
=
replace
coer_demanded
attr
CT_Empty
coer_offered
=
{
coer_offered
&
[
attr
]
=
CT_NonUnique
}
=
make_non_unique
dem_coercions
{
coer_offered
=
coer_offered
,
coer_demanded
=
coer_demanded
}
// ---> ("makeNonUnique", attr)
where
make_non_unique
(
CT_Node
this_attr
ct_less
ct_greater
)
coercions
#
coercions
=
makeNonUnique
this_attr
coercions
...
...
@@ -549,8 +560,8 @@ Success (Yes _) = False
instance
coerce
AType
where
coerce
sign
defs
cons_vars
tpos
at1
=:{
at_attribute
=
attr1
,
at_type
=
type1
}
at2
=:{
at_attribute
=
attr2
,
at_type
=
type2
}
cs
=:{
crc_coercions
}
#
sign
=
adjust_sign
sign
type1
cons_vars
(
succ
,
crc_coercions
)
=
coerceAttributes
attr1
attr2
sign
crc_coercions
#
attr_
sign
=
adjust_sign
sign
type1
cons_vars
(
succ
,
crc_coercions
)
=
coerceAttributes
attr1
attr2
attr_
sign
crc_coercions
|
succ
#
(
succ
,
cs
)
=
coerce
sign
defs
cons_vars
tpos
type1
type2
{
cs
&
crc_coercions
=
crc_coercions
}
|
Success
succ
...
...
@@ -651,7 +662,8 @@ where
=
coerce
sign
defs
cons_vars
tpos
dem_type
off_type
{
cs
&
crc_type_heaps
=
crc_type_heaps
,
crc_td_infos
=
crc_td_infos
}
=
(
No
,
{
cs
&
crc_type_heaps
=
crc_type_heaps
,
crc_td_infos
=
crc_td_infos
})
coerce
sign
defs
cons_vars
tpos
(
arg_type1
-->
res_type1
)
(
arg_type2
-->
res_type2
)
cs
#
(
succ
,
cs
)
=
coerce
(
NegativeSign
*
sign
)
defs
cons_vars
[
0
:
tpos
]
arg_type1
arg_type2
cs
#
arg_sign
=
NegativeSign
*
sign
#
(
succ
,
cs
)
=
coerce
arg_sign
defs
cons_vars
[
0
:
tpos
]
arg_type1
arg_type2
cs
|
Success
succ
=
coerce
sign
defs
cons_vars
[
1
:
tpos
]
res_type1
res_type2
cs
=
(
succ
,
cs
)
...
...
@@ -731,4 +743,12 @@ where
|
del_char
==
ident
.[
del_pos
]
=
del_pos
=
find_delimiter
del_char
(
inc
del_pos
)
ident
file_to_true
::
!
File
->
Bool
file_to_true
file
=
code {
.inline
file_to_true
pop_b
2
pushB
TRUE
.end
}
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