## oop-rewrite-declaration.pkg
# Compiled by:
# src/lib/compiler/front/typer/typer.sublib# Mythryl classes are lightly modified packages.
# To expand oop constructs into the vanilla non-OOP
# underlying language we must traverse the class
# (package) syntax tree converting everything oop
# into vanilla non-oop form.
#
# In this package we implement the package syntax
# tree dagwalk subtask. This involves a set of
# mutually recursive functions mirroring the
# mutually recursive grammar rules defining package
# syntax:
stipulate
package err = error_message; # error_message is from src/lib/compiler/front/basics/errormsg/error-message.pkg package eos = expand_oop_syntax_junk; # expand_oop_syntax_junk is from src/lib/compiler/front/typer/main/expand-oop-syntax-junk.pkg package mld = module_level_declarations; # module_level_declarations is from src/lib/compiler/front/typer-stuff/modules/module-level-declarations.pkg package raw = raw_syntax; # raw_syntax is from src/lib/compiler/front/parser/raw-syntax/raw-syntax.pkg include package fast_symbol; # fast_symbol is from src/lib/compiler/front/basics/map/fast-symbol.pkg include package raw_syntax; # raw_syntax is from src/lib/compiler/front/parser/raw-syntax/raw-syntax.pkg include package raw_syntax_junk; # raw_syntax_junk is from src/lib/compiler/front/parser/raw-syntax/raw-syntax-junk.pkgherein
package oop_rewrite_declaration
: Oop_Rewrite_Declaration # Oop_Rewrite_Declaration is from src/lib/compiler/front/typer/main/oop-rewrite-declaration.api {
# We get called from
# src/lib/compiler/front/typer/main/expand-oop-syntax.pkg # to rewrite the raw syntax tree
# for a class.
#
# Our tasks are:
# o Remove all 'field my ... ' declarations.
# o Remove all 'message fun ... ' declarations.
# o Remove all 'method fun ... ' declarations.
# o Replace the first of the removed statements
# with the blob of synthesized code implementing
# all the oop stuff.
# o Rewrite object->field syntax into vanilla code.
# this requires us to traverse the full expression
# syntax.
#
# We return the rewritten raw syntax tree.
#
fun rewrite_declaration
{ original_declaration: raw_syntax::Declaration,
synthesized_code: raw_syntax::Declaration,
field_to_offset: symbol::Symbol -> Int
}
=
{
rewritten_synthesized_code = REF synthesized_code;
inserted_synthesized_code = REF FALSE;
fun do_package_expression_bool (package_expression, bool)
=
( do_package_expression package_expression,
bool
)
also
fun do_package_expression_bools (pb ! more, result)
=>
do_package_expression_bools (more, do_package_expression_bool pb ! result);
do_package_expression_bools ([], result)
=>
reverse result;
end
also
fun do_package_expression package_expression
=
case package_expression
PACKAGE_DEFINITION declaration
=>
PACKAGE_DEFINITION (do_the_declaration declaration);
CALL_OF_GENERIC (path, package_expression_bool_list)
=>
CALL_OF_GENERIC
( path,
do_package_expression_bools (package_expression_bool_list, [])
);
INTERNAL_CALL_OF_GENERIC (path, package_expression_bool_list)
=>
INTERNAL_CALL_OF_GENERIC
( path,
do_package_expression_bools (package_expression_bool_list, [])
);
LET_IN_PACKAGE (declaration, package_expression)
=>
LET_IN_PACKAGE (
do_the_declaration declaration,
do_package_expression package_expression
);
PACKAGE_CAST ( package_expression, api_expression)
=>
PACKAGE_CAST (
do_package_expression package_expression,
api_expression
);
SOURCE_CODE_REGION_FOR_PACKAGE( package_expression, region)
=>
SOURCE_CODE_REGION_FOR_PACKAGE(
do_package_expression package_expression,
region
);
PACKAGE_BY_NAME path
=>
package_expression;
esac
also
fun do_package_expressions ([], result)
=>
reverse result;
do_package_expressions (package_expression ! rest, result)
=>
do_package_expressions (rest, (do_package_expression package_expression) ! result);
end
also
fun do_named_package (me as NAMED_PACKAGE { name_symbol, definition => package_expression, constraint, kind })
=>
NAMED_PACKAGE
{ name_symbol,
definition => do_package_expression package_expression,
constraint,
kind
};
do_named_package (SOURCE_CODE_REGION_FOR_NAMED_PACKAGE (named_package, region))
=>
SOURCE_CODE_REGION_FOR_NAMED_PACKAGE
( do_named_package named_package,
region
);
end
also
fun do_named_packages ([], result)
=>
reverse result;
do_named_packages (named_package ! rest, result)
=>
do_named_packages (rest, (do_named_package named_package) ! result);
end
also
fun do_generic_expression (generic_expression as GENERIC_BY_NAME _)
=>
generic_expression;
do_generic_expression (LET_IN_GENERIC (declaration, generic_expression))
=>
LET_IN_GENERIC (
do_the_declaration declaration,
do_generic_expression generic_expression
);
do_generic_expression (GENERIC_DEFINITION { parameters, body => package_expression, constraint })
=>
GENERIC_DEFINITION
{ parameters,
body => do_package_expression package_expression,
constraint
};
do_generic_expression (CONSTRAINED_CALL_OF_GENERIC ( path, package_expression_bools, api_constraint ) )
=>
CONSTRAINED_CALL_OF_GENERIC
( path,
do_package_expression_bools (package_expression_bools, []),
api_constraint
);
do_generic_expression (SOURCE_CODE_REGION_FOR_GENERIC (generic_expression, region))
=>
SOURCE_CODE_REGION_FOR_GENERIC
( do_generic_expression generic_expression,
region
);
end
also
fun do_named_generics ([], result)
=>
reverse result;
do_named_generics (named_generic ! named_generics, result)
=>
do_named_generics (named_generics, (do_named_generic named_generic) ! result)
where
fun do_named_generic (NAMED_GENERIC { name_symbol, definition => generic_expression })
=>
NAMED_GENERIC {
name_symbol,
definition => do_generic_expression generic_expression
};
do_named_generic (SOURCE_CODE_REGION_FOR_NAMED_GENERIC (named_generic, region))
=>
SOURCE_CODE_REGION_FOR_NAMED_GENERIC
( do_named_generic named_generic,
region
);
end;
end;
end
also
fun do_pattern_clause (PATTERN_CLAUSE { patterns, result_type, expression })
=
PATTERN_CLAUSE
{ patterns,
result_type,
expression => do_raw_expression expression
}
also
fun do_pattern_clauses ([], result)
=>
reverse result;
do_pattern_clauses (pattern_clause ! rest, result)
=>
do_pattern_clauses (rest, (do_pattern_clause pattern_clause) ! result);
end
also
fun do_named_function (f as (NAMED_FUNCTION { pattern_clauses, is_lazy, kind, null_or_type }))
=>
{ f = NAMED_FUNCTION
{ pattern_clauses => do_pattern_clauses (pattern_clauses, []),
is_lazy,
kind,
null_or_type
};
# We return NULL to tell caller to remove function from syntax tree.
# We return THE f to tell it to leave it in place:
#
case (kind, null_or_type)
(MESSAGE_FUN, THE type) => { NULL; };
(METHOD_FUN, NULL ) => { NULL; };
(PLAIN_FUN, NULL ) => THE f;
_ => raise exception DIE "expand-oop-syntax.pkg (NAMED_FUNCTION): Impossible"; # XXX SUCKO FIXME what's the correct error protocol?
esac;
};
do_named_function (SOURCE_CODE_REGION_FOR_NAMED_FUNCTION (named_function, region))
=>
case (do_named_function named_function)
THE f => THE (SOURCE_CODE_REGION_FOR_NAMED_FUNCTION (f, region)); # Returning normal function.
NULL => NULL; # Erasing method from syntax tree.
esac;
end
also
fun do_named_functions ([], result)
=>
reverse result;
do_named_functions (named_function ! rest, result)
=>
case (do_named_function named_function)
THE f => do_named_functions (rest, f ! result); # It was a function, leave it in syntax tree.
NULL => do_named_functions (rest, result); # It was a method, erase it from syntax tree.
esac;
end
also
fun do_named_recursive_value (NAMED_RECURSIVE_VALUE { variable_symbol, fixity, expression, null_or_type, is_lazy })
=>
NAMED_RECURSIVE_VALUE
{ variable_symbol,
fixity,
expression => do_raw_expression expression,
null_or_type,
is_lazy
};
do_named_recursive_value (SOURCE_CODE_REGION_FOR_RECURSIVELY_NAMED_VALUE (named_recursive_value, region))
=>
SOURCE_CODE_REGION_FOR_RECURSIVELY_NAMED_VALUE (do_named_recursive_value named_recursive_value, region);
end
also
fun do_named_recursive_values ([], result)
=>
reverse result;
do_named_recursive_values (named_recursive_value ! rest, result)
=>
do_named_recursive_values (rest, (do_named_recursive_value named_recursive_value) ! result);
end
also
fun do_case_rules ([], result)
=>
reverse result;
do_case_rules ((CASE_RULE { pattern, expression }) ! rest, result)
=>
do_case_rules (rest, (CASE_RULE { pattern, expression => do_raw_expression expression }) ! result);
end
also
fun do_raw_expression_fixity_item { item, fixity, source_code_region }
=
{ item => do_raw_expression item,
fixity,
source_code_region
}
also
fun do_raw_expression_fixity_items ([], result)
=>
reverse result;
do_raw_expression_fixity_items (item ! rest, result)
=>
do_raw_expression_fixity_items (rest, (do_raw_expression_fixity_item item) ! result);
end
also
fun do_record_expression_entries ([], result)
=>
reverse result;
do_record_expression_entries ((symbol, expression) ! rest, result)
=>
do_record_expression_entries (rest, (symbol, do_raw_expression expression) ! result);
end
also
fun do_object_field_expression { object, field }
=
{
# We map 'a->b' to be '#3 (get__fields a)'
# if 'b' is the third field in the (sub)object:
# Make symbol naming 'get__fields' function:
#
get_fields_symbol
=
make_value_symbol( raw_symbol( get_fields_hash, get_fields_string ) );
# Set selector_num to 3 if our field
# is third in (sub)object:
#
selector_num
=
(field_to_offset field) + 1; # '+1' because offsets start at 0 but #1 is first field.
# Make (#3 (get__fields object)) or such:
#
APPLY_EXPRESSION
{
function => RECORD_SELECTOR_EXPRESSION (symbol::make_label_symbol (int::to_string selector_num)),
argument => APPLY_EXPRESSION
{
function => VARIABLE_IN_EXPRESSION [ get_fields_symbol ],
argument => object
}
};
}
also
fun do_raw_expression (v as (VARIABLE_IN_EXPRESSION _)) => v;
do_raw_expression (p as (IMPLICIT_THUNK_PARAMETER _)) => p;
do_raw_expression (i as (INT_CONSTANT_IN_EXPRESSION _)) => i;
do_raw_expression (u as (UNT_CONSTANT_IN_EXPRESSION _)) => u;
do_raw_expression (f as (FLOAT_CONSTANT_IN_EXPRESSION _)) => f;
do_raw_expression (s as (STRING_CONSTANT_IN_EXPRESSION _)) => s;
do_raw_expression (c as (CHAR_CONSTANT_IN_EXPRESSION _)) => c;
do_raw_expression (r as (RECORD_SELECTOR_EXPRESSION _)) => r;
do_raw_expression (SEQUENCE_EXPRESSION expressions) => SEQUENCE_EXPRESSION (do_raw_expressions (expressions, []));
do_raw_expression (LIST_EXPRESSION expressions) => LIST_EXPRESSION (do_raw_expressions (expressions, []));
do_raw_expression (TUPLE_EXPRESSION expressions) => TUPLE_EXPRESSION (do_raw_expressions (expressions, []));
do_raw_expression (VECTOR_IN_EXPRESSION expressions) => VECTOR_IN_EXPRESSION (do_raw_expressions (expressions, []));
do_raw_expression (FN_EXPRESSION case_rules)
=>
FN_EXPRESSION (do_case_rules (case_rules, []));
do_raw_expression (CASE_EXPRESSION { expression, rules })
=>
CASE_EXPRESSION
{ expression => do_raw_expression expression,
rules => do_case_rules (rules, [])
};
do_raw_expression (EXCEPT_EXPRESSION { expression, rules })
=>
EXCEPT_EXPRESSION
{ expression => do_raw_expression expression,
rules => do_case_rules (rules, [])
};
do_raw_expression (PRE_FIXITY_EXPRESSION fixity_items)
=>
PRE_FIXITY_EXPRESSION (do_raw_expression_fixity_items (fixity_items, []));
do_raw_expression (RAISE_EXPRESSION expression)
=>
RAISE_EXPRESSION (do_raw_expression expression);
do_raw_expression (APPLY_EXPRESSION { function, argument })
=>
APPLY_EXPRESSION
{ function => do_raw_expression function,
argument => do_raw_expression argument
};
do_raw_expression (OBJECT_FIELD_EXPRESSION object_field)
=>
do_object_field_expression object_field;
do_raw_expression (AND_EXPRESSION (expression1, expression2))
=>
AND_EXPRESSION
( do_raw_expression expression1,
do_raw_expression expression2
);
do_raw_expression (OR_EXPRESSION (expression1, expression2))
=>
OR_EXPRESSION
( do_raw_expression expression1,
do_raw_expression expression2
);
do_raw_expression (WHILE_EXPRESSION { test, expression })
=>
WHILE_EXPRESSION
{ test => do_raw_expression test,
expression => do_raw_expression expression
};
do_raw_expression (IF_EXPRESSION { test_case, then_case, else_case })
=>
IF_EXPRESSION
{ test_case => do_raw_expression test_case,
then_case => do_raw_expression then_case,
else_case => do_raw_expression else_case
};
do_raw_expression (LET_EXPRESSION { declaration, expression })
=>
LET_EXPRESSION
{ declaration => do_the_declaration declaration,
expression => do_raw_expression expression
};
do_raw_expression (TYPE_CONSTRAINT_EXPRESSION { expression, constraint })
=>
TYPE_CONSTRAINT_EXPRESSION
{ expression => do_raw_expression expression,
constraint
};
do_raw_expression (RECORD_IN_EXPRESSION record_expression_entries)
=>
RECORD_IN_EXPRESSION (do_record_expression_entries (record_expression_entries, []));
do_raw_expression (SOURCE_CODE_REGION_FOR_EXPRESSION (expression, region))
=>
SOURCE_CODE_REGION_FOR_EXPRESSION (do_raw_expression expression, region);
end
also
fun do_raw_expressions ([], result)
=>
reverse result;
do_raw_expressions (expression ! rest, result)
=>
do_raw_expressions (rest, (do_raw_expression expression) ! result);
end
also
fun do_named_value (NAMED_VALUE { pattern, expression, is_lazy })
=>
NAMED_VALUE
{ pattern, # We do not (yet?) rewrite Case_Patterns
expression => do_raw_expression expression,
is_lazy
};
do_named_value (SOURCE_CODE_REGION_FOR_NAMED_VALUE (named_value, region))
=>
SOURCE_CODE_REGION_FOR_NAMED_VALUE
( do_named_value named_value,
region
);
end
also
fun do_named_values ([], result)
=>
reverse result;
do_named_values (named_value ! rest, result)
=>
do_named_values (rest, (do_named_value named_value) ! result);
end
also
fun do_the_declaration declaration
=
the (do_declaration declaration)
also
fun do_named_field (NAMED_FIELD { name, type, init })
=>
NAMED_FIELD
{ name,
type,
init => case init
NULL => NULL;
THE expression => THE (do_raw_expression expression);
esac
};
do_named_field (SOURCE_CODE_REGION_FOR_NAMED_FIELD (named_field, region))
=>
SOURCE_CODE_REGION_FOR_NAMED_FIELD
( do_named_field named_field,
region
);
end
also
fun do_named_fields ([], result)
=>
reverse result;
do_named_fields (named_field ! rest, result)
=>
do_named_fields (rest, (do_named_field ! result));
end
also
fun do_declaration declaration
=
case declaration
#
FIELD_DECLARATIONS (named_fields, typevars)
=>
{ named_fields
=
do_named_fields (named_fields, []);
if *inserted_synthesized_code
# Delete from syntax tree:
#
NULL;
else
inserted_synthesized_code := TRUE;
# Replace with synthesized code:
#
THE *rewritten_synthesized_code;
fi;
};
VALUE_DECLARATIONS (named_values, typevars)
=>
THE (VALUE_DECLARATIONS (do_named_values (named_values, []), typevars ));
EXCEPTION_DECLARATIONS named_exceptions => THE declaration;
PACKAGE_DECLARATIONS named_packages => THE (PACKAGE_DECLARATIONS (do_named_packages (named_packages, [])));
TYPE_DECLARATIONS named_types => THE declaration;
GENERIC_DECLARATIONS named_generics
=>
THE (GENERIC_DECLARATIONS (do_named_generics (named_generics, [])));
API_DECLARATIONS named_apis => THE declaration;
GENERIC_API_DECLARATIONS named_generic_apis => THE declaration;
LOCAL_DECLARATIONS (declaration, declaration')
=>
THE (
LOCAL_DECLARATIONS
( do_the_declaration declaration,
do_the_declaration declaration'
)
);
SEQUENTIAL_DECLARATIONS declarations
=>
THE (SEQUENTIAL_DECLARATIONS (do_declarations (declarations, [])));
INCLUDE_DECLARATIONS paths => THE declaration;
OVERLOADED_VARIABLE_DECLARATION _ => THE declaration;
FIXITY_DECLARATIONS { fixity, ops } => THE declaration;
FUNCTION_DECLARATIONS
( named_functions,
typevars # This will nowadays always be NIL; used to be support for start-of-declaration type variables.
)
=>
case named_functions
[] => NULL;
_ => case (do_named_functions (named_functions, []))
[] => if *inserted_synthesized_code
NULL;
else
inserted_synthesized_code := TRUE;
THE *rewritten_synthesized_code;
fi;
other => THE (FUNCTION_DECLARATIONS (other, typevars));
esac;
esac;
RECURSIVE_VALUE_DECLARATIONS (named_recursive_values, typevars)
=>
THE (RECURSIVE_VALUE_DECLARATIONS (do_named_recursive_values (named_recursive_values, []), typevars));
NADA_FUNCTION_DECLARATIONS (nada_named_functions, typevars) => THE declaration;
SUMTYPE_DECLARATIONS { sumtypes, with_types } => THE declaration;
SOURCE_CODE_REGION_FOR_DECLARATION (declaration', source_code_region)
=>
case (do_declaration declaration')
#
THE d => THE (SOURCE_CODE_REGION_FOR_DECLARATION (d, source_code_region));
NULL => NULL;
esac;
PRE_COMPILE_CODE string
=>
raise exception DIE "expand-oop-syntax.pkg (PRE_COMPILE_CODE): Impossible"; # XXX SUCKO FIXME what's the correct error protocol?
esac
also
fun do_declarations ([], result)
=>
reverse result;
do_declarations (declaration ! rest, result)
=>
case (do_declaration declaration)
THE d => do_declarations (rest, d ! result);
NULL => do_declarations (rest, result);
esac;
end;
# Do the object-field expansions
# in the method functions:
#
rewritten_synthesized_code
:=
do_the_declaration *rewritten_synthesized_code;
processed_declaration
=
do_the_declaration original_declaration;
if *inserted_synthesized_code
processed_declaration;
else
# This really isn't supposed to happen,
# so maybe we should be raising an error
# here instead:
#
SEQUENTIAL_DECLARATIONS
[
processed_declaration,
*rewritten_synthesized_code
];
fi;
};
};
end;
## Code by Jeff Prothero Copyright (c) 2010-2015,
## released per terms of SMLNJ-COPYRIGHT.