## map-raw-syntax.pkg
# Compiled by:
# src/lib/compiler/front/parser/parser.sublib# Here we accept a Raw_Expression argument together
# with a user-supplied Raw_Expression -> Raw_Expression
# transform, and apply the transform in post-order to
# all type-appropriate sub/expressions of the argument.
#
# The argument is not modified; all necessary parts of
# it are copied.
#
# We also allow the transform functions to add to a
# list of results, if desired.
#
# There's nothing subtle here; just a matter of grinding
# through all the relevant phrase-structure rules.
#
# (You'd think there would be a way of automating this kind of coding.)
#
# At present this is only used to implement implicit thunk
# parameters by converting IMPLICIT_THUNK_PARAMETER nodes
# to VARIABLE_IN_EXPRESSION nodes while building up a list
# of all such variables seen:
### "One's intellectual and aesthetic life
### cannot be complete unless it includes
### an appreciation of the power and the
### beauty of mathematics.
###
### "Simply put, aesthetic and intellectual
### fullfillment requires that you know
### about mathematics."
###
### -- J. P. King
package map_raw_syntax {
include package raw_syntax;
fun map_raw_expression
(
x, # raw expression
y # resultlist
)
user_transform # User-supplied map from Raw_Expression to Raw_Expression
=
map_raw_expression' (x, y)
where
fun map_raw_expression' (x, y)
=
user_transform (x, y)
where
my (x, y)
=
case x
#
x as VARIABLE_IN_EXPRESSION path => (x, y);
x as IMPLICIT_THUNK_PARAMETER path => (x, y);
#
x as INT_CONSTANT_IN_EXPRESSION literal => (x, y);
x as UNT_CONSTANT_IN_EXPRESSION literal => (x, y);
#
x as FLOAT_CONSTANT_IN_EXPRESSION string => (x, y);
x as STRING_CONSTANT_IN_EXPRESSION string => (x, y);
x as CHAR_CONSTANT_IN_EXPRESSION string => (x, y);
#
x as RECORD_SELECTOR_EXPRESSION symbol => (x, y);
#
x as FN_EXPRESSION [ ] => (x, y);
x as PRE_FIXITY_EXPRESSION [ ] => (x, y);
x as SEQUENCE_EXPRESSION [ ] => (x, y);
x as RECORD_IN_EXPRESSION [ ] => (x, y);
x as LIST_EXPRESSION [ ] => (x, y);
x as TUPLE_EXPRESSION [ ] => (x, y);
x as VECTOR_IN_EXPRESSION [ ] => (x, y);
x as FN_EXPRESSION case_rules
=>
{ (map_case_rules (case_rules, y))
->
(case_rules, y);
( FN_EXPRESSION case_rules, y );
};
x as CASE_EXPRESSION { expression, rules } # Raw_Expression, [ Case_Rule ]
=>
{ (map_raw_expression' (expression, y)) -> (expression, y);
(map_case_rules (rules, y)) -> (rules, y);
#
(CASE_EXPRESSION { expression, rules }, y);
};
x as EXCEPT_EXPRESSION { expression, rules }
=>
{ (map_raw_expression' (expression, y)) -> (expression, y);
(map_case_rules (rules, y)) -> (rules, y);
#
(EXCEPT_EXPRESSION { expression, rules }, y);
};
x as SOURCE_CODE_REGION_FOR_EXPRESSION (raw_expression, source_code_region) # For error messages.
=>
{ (map_raw_expression' (raw_expression, y))
->
(raw_expression, y);
(SOURCE_CODE_REGION_FOR_EXPRESSION ( raw_expression, source_code_region ), y);
};
x as TYPE_CONSTRAINT_EXPRESSION { expression, constraint } # Raw_Expression, Any_Type, respectively
=>
{ (map_raw_expression' (expression, y))
->
(expression, y);
(TYPE_CONSTRAINT_EXPRESSION { expression, constraint }, y);
};
x as RAISE_EXPRESSION expression
=>
{ (map_raw_expression' (expression, y))
->
(expression, y);
(RAISE_EXPRESSION expression, y);
};
x as APPLY_EXPRESSION { function, argument }
=>
{ (map_raw_expression' (function, y)) -> (function, y);
(map_raw_expression' (argument, y)) -> (argument, y);
#
(APPLY_EXPRESSION { function, argument }, y);
};
x as OBJECT_FIELD_EXPRESSION { object, field }
=>
{ (map_raw_expression' (object, y))
->
(object, y);
(OBJECT_FIELD_EXPRESSION { object, field }, y);
};
x as WHILE_EXPRESSION { test, expression } # Both Raw_Expression
=>
{ (map_raw_expression' (test, y)) -> (test, y);
(map_raw_expression' (expression, y)) -> (expression, y);
#
(WHILE_EXPRESSION { test, expression }, y);
};
x as AND_EXPRESSION (raw_expression1, raw_expression2) # 'and' (derived form).
=>
{ (map_raw_expression' (raw_expression1, y)) -> (raw_expression1, y);
(map_raw_expression' (raw_expression2, y)) -> (raw_expression2, y);
#
(AND_EXPRESSION (raw_expression1, raw_expression2), y);
};
x as OR_EXPRESSION (raw_expression1, raw_expression2) # 'or' (derived form).
=>
{ (map_raw_expression' (raw_expression1, y)) -> (raw_expression1, y);
(map_raw_expression' (raw_expression2, y)) -> (raw_expression2, y);
#
(OR_EXPRESSION (raw_expression1, raw_expression2), y);
};
x as IF_EXPRESSION { test_case, then_case, else_case } # All Raw_Expression
=>
{ (map_raw_expression' (test_case, y)) -> (test_case, y);
(map_raw_expression' (then_case, y)) -> (then_case, y);
(map_raw_expression' (else_case, y)) -> (else_case, y);
#
(IF_EXPRESSION { test_case, then_case, else_case }, y);
};
x as SEQUENCE_EXPRESSION raw_expressions
=>
{ (map_raw_expressions (raw_expressions, [], y))
->
(raw_expressions, y);
(SEQUENCE_EXPRESSION raw_expressions, y);
};
x as LIST_EXPRESSION raw_expressions
=>
{ (map_raw_expressions (raw_expressions, [], y))
->
(raw_expressions, y);
(LIST_EXPRESSION raw_expressions, y);
};
x as TUPLE_EXPRESSION raw_expressions
=>
{ (map_raw_expressions (raw_expressions, [], y))
->
(raw_expressions, y);
(TUPLE_EXPRESSION raw_expressions, y);
};
x as VECTOR_IN_EXPRESSION raw_expressions
=>
{ (map_raw_expressions (raw_expressions, [], y))
->
(raw_expressions, y);
(VECTOR_IN_EXPRESSION raw_expressions, y);
};
x as RECORD_IN_EXPRESSION elements
=>
{ (map_record_elements (elements, [], y))
->
(elements, y);
(RECORD_IN_EXPRESSION elements, y);
};
x as PRE_FIXITY_EXPRESSION pre_fixity_expressions
=>
{ (map_pre_fixity_expressions (pre_fixity_expressions, [], y))
->
(pre_fixity_expressions, y);
(PRE_FIXITY_EXPRESSION pre_fixity_expressions, y);
};
x as LET_EXPRESSION { declaration, expression } # Respectively Declaration, Raw_Expression
=>
{ (map_declaration (declaration, y)) -> (declaration, y);
(map_raw_expression' (expression, y)) -> (expression, y);
#
(LET_EXPRESSION { declaration, expression }, y);
};
esac;
end
also
fun map_pre_fixity_expressions ([], results, y)
=>
(reverse results, y);
map_pre_fixity_expressions ( { item, fixity, source_code_region } ! more, results, y)
=>
{ (map_raw_expression' (item, y))
->
(item, y);
map_pre_fixity_expressions (more, { item, fixity, source_code_region } ! results, y);
};
end
also
fun map_raw_expressions ([], results, y)
=>
(reverse results, y);
map_raw_expressions (expression ! rest, results, y)
=>
{ (map_raw_expression' (expression, y))
->
(expression, y);
map_raw_expressions (rest, expression ! results, y);
};
end
also
fun map_record_elements ([], results, y)
=>
(reverse results, y);
map_record_elements ((symbol, expression) ! rest, results, y)
=>
{ (map_raw_expression' (expression, y))
->
(expression, y);
map_record_elements (rest, (symbol, expression) ! results, y);
};
end
also
fun map_case_rules (rule_list, y)
=
map_case_rules' (rule_list, [], y)
where
fun map_case_rules' ([], results, y)
=>
(reverse results, y);
map_case_rules' ((case_rule ! rest), results, y)
=>
{ (map_case_rule (case_rule, y))
->
(case_rule, y);
map_case_rules' (rest, case_rule ! results, y);
};
end
also
fun map_case_rule (CASE_RULE { pattern, expression }, y)
=
{ (map_raw_expression' (expression, y))
->
(expression, y);
( CASE_RULE { pattern, expression },
y
);
};
end
also
fun map_declaration (x, y)
=
case x
#
# These cannot contain Raw_Expression subexpressions,
# hence we can just return them intact:
#
x as TYPE_DECLARATIONS _ => (x, y);
x as EXCEPTION_DECLARATIONS _ => (x, y); # List( Named_Exception ) # Exception.
x as API_DECLARATIONS _ => (x, y); # List( Named_Api ) # APIs.
x as GENERIC_API_DECLARATIONS _ => (x, y); # List( Named_Generic_Api ) # generic apis.
x as INCLUDE_DECLARATIONS _ => (x, y); # List( Path ) # 'include's of other packages.
x as FIXITY_DECLARATIONS _ => (x, y); # { fixity: Fixity, ops: List( Symbol ) } # Operator fixities.
x as SUMTYPE_DECLARATIONS _ => (x, y); # { sumtypes: List( Sumtype ), with_types: List( Named_Type ) }
x as VALUE_DECLARATIONS (a, b) # ((List( Named_Value ), List( Typevar_Ref )) ) # Values.
=>
{ (map_named_values (a, y))
->
(a, y);
(VALUE_DECLARATIONS (a, b), y);
};
x as FIELD_DECLARATIONS (a, b) # ((List( Named_Field ), List( Typevar_Ref )) ) # OOP Fields.
=>
{ (map_named_fields (a, y))
->
(a, y);
(FIELD_DECLARATIONS (a, b), y);
};
x as PACKAGE_DECLARATIONS a # List( Named_Package ) # Packages.
=>
{ (map_named_packages (a, y))
->
(a, y);
(PACKAGE_DECLARATIONS a, y);
};
x as GENERIC_DECLARATIONS a # List( Named_Generic ) # Generics.
=>
{ (map_named_generics (a, y))
->
(a, y);
(GENERIC_DECLARATIONS a, y);
};
x as LOCAL_DECLARATIONS (a, b) # (Declaration, Declaration) # Local declarations.
=>
{ (map_declaration (a, y)) -> (a, y);
(map_declaration (b, y)) -> (b, y);
#
(LOCAL_DECLARATIONS (a, b), y);
};
x as SEQUENTIAL_DECLARATIONS a # List( Declaration ) # Sequences of declarations.
=>
{ (map_declarations (a, y))
->
(a, y);
(SEQUENTIAL_DECLARATIONS a, y);
};
x as OVERLOADED_VARIABLE_DECLARATION (a, b, c, d) # (Symbol, Any_Type, List(Raw_Expression), Bool) # Overloading.
=>
{ (map_raw_expressions (c, [], y))
->
(c, y);
(OVERLOADED_VARIABLE_DECLARATION (a, b, c, d), y);
};
x as FUNCTION_DECLARATIONS (a, b) # ((List Named_Function, List Typevar_Ref)) # Mutually recursive functions.
=>
{ (map_named_functions (a, y))
->
(a, y);
(FUNCTION_DECLARATIONS (a, b), y);
};
x as NADA_FUNCTION_DECLARATIONS _ # ((List Nada_Named_Function, List Typevar_Ref)) # Mutually recursive functions.
=>
{ # None of the 'nada' stuff
# is used or usable, so punt:
#
exception IMPOSSIBLE;
raise exception IMPOSSIBLE;
};
x as RECURSIVE_VALUE_DECLARATIONS (a, b) # ( (List( Named_Recursive_Value ), List( Typevar_Ref))) # Recursive values.
=>
{ (map_named_recursive_values (a, y))
->
(a, y);
#
(RECURSIVE_VALUE_DECLARATIONS (a, b), y);
};
#
# )
x as SOURCE_CODE_REGION_FOR_DECLARATION (a, b) # (Declaration, Source_Code_Region) # For error messages etc.
=>
{ (map_declaration (a, y))
->
(a, y);
#
(SOURCE_CODE_REGION_FOR_DECLARATION (a, b), y);
};
x as PRE_COMPILE_CODE string
=>
(x, y);
esac
also
fun map_named_recursive_values (x, y)
=
map_named_recursive_values' (x, [], y)
where
fun map_named_recursive_value (a, y)
=
case a
SOURCE_CODE_REGION_FOR_RECURSIVELY_NAMED_VALUE (a, b) # (Named_Recursive_Value, Source_Code_Region)
=>
{ my (a, y) = map_named_recursive_value (a, y);
(SOURCE_CODE_REGION_FOR_RECURSIVELY_NAMED_VALUE (a, b), y);
};
NAMED_RECURSIVE_VALUE
{ variable_symbol, # : Symbol,
fixity, # : Null_Or( (Symbol, Source_Code_Region) ),
expression, # : Raw_Expression,
null_or_type, # : Null_Or( Any_Type ),
is_lazy # : Bool
}
=>
{ my (expression, y) = map_raw_expression' (expression, y);
( NAMED_RECURSIVE_VALUE
{
variable_symbol, # : Symbol,
fixity, # : Null_Or( (Symbol, Source_Code_Region) ),
expression, # : Raw_Expression,
null_or_type, # : Null_Or( Any_Type ),
is_lazy # : Bool
},
y
);
};
esac
also
fun map_named_recursive_values' ([], results, y)
=>
(reverse results, y);
map_named_recursive_values' (a ! rest, results, y)
=>
{ my (a, y) = map_named_recursive_value (a, y);
map_named_recursive_values' (rest, a ! results, y);
};
end;
end
also
fun map_named_functions (x, y)
=
map_named_functions' (x, [], y)
where
fun map_named_function (a, y)
=
case a
SOURCE_CODE_REGION_FOR_NAMED_FUNCTION (a, b) # (Named_Function, Source_Code_Region)
=>
{ my (a, y) = map_named_function (a, y);
(SOURCE_CODE_REGION_FOR_NAMED_FUNCTION (a, b), y);
};
NAMED_FUNCTION { pattern_clauses, is_lazy, kind, null_or_type } # ((List( Pattern_Clause ), Bool))
=>
{ my (pattern_clauses, y)
=
map_pattern_clauses (pattern_clauses, [], y);
( NAMED_FUNCTION { pattern_clauses, is_lazy, kind, null_or_type }, y);
};
esac
also
fun map_named_functions' ([], results, y)
=>
(reverse results, y);
map_named_functions' (a ! rest, results, y)
=>
{ my (a, y) = map_named_function (a, y);
map_named_functions' (rest, a ! results, y);
};
end
also
fun map_pattern_clauses ([], results, y)
=>
(reverse results, y);
map_pattern_clauses (a ! rest, results, y)
=>
{ my (a, y) = map_pattern_clause (a, y);
map_pattern_clauses (rest, a ! results, y);
};
end
also
fun map_pattern_clause (a, y)
=
case a
PATTERN_CLAUSE
{
patterns, # : List( Fixity_Item( Case_Pattern ) ),
result_type, # : Null_Or( Any_Type ),
expression # : Raw_Expression
}
=>
{ my (expression, y) = map_raw_expression' (expression, y);
( PATTERN_CLAUSE { patterns, result_type, expression },
y
);
};
esac;
end
also
fun map_declarations (x, y)
=
map_declarations' (x, [], y)
where
fun map_declarations' ([], results, y)
=>
(reverse results, y);
map_declarations' (a ! rest, results, y)
=>
{ my (a, y) = map_declaration (a, y);
map_declarations' (rest, a ! results, y);
};
end;
end
also
fun map_named_values (x, y)
=
map_named_values' (x, [], y)
where
fun map_named_value (a, y)
=
case a
SOURCE_CODE_REGION_FOR_NAMED_VALUE (a, b) # (Mythryl_Named_Value, Source_Code_Region)
=>
{ my (a, y) = map_named_value (a, y);
(SOURCE_CODE_REGION_FOR_NAMED_VALUE (a, b), y);
};
NAMED_VALUE
{ pattern, # : Case_Pattern,
expression, # : Raw_Expression,
is_lazy # : Bool
}
=>
{ my (expression, y) = map_raw_expression' (expression, y);
( NAMED_VALUE { pattern, expression, is_lazy },
y
);
};
esac
also # XXX BUGGO FIXME These functions are boilerplate, should write one general version.
fun map_named_values' ([], results, y)
=>
(reverse results, y);
map_named_values' (a ! rest, results, y)
=>
{ my (a, y) = map_named_value (a, y);
map_named_values' (rest, a ! results, y);
};
end;
end
also
fun map_named_fields (x, y)
=
map_named_fields' (x, [], y)
where
fun map_named_field (a, y)
=
case a
SOURCE_CODE_REGION_FOR_NAMED_FIELD (a, b) # (Named_Field, Source_Code_Region)
=>
{ my (a, y) = map_named_field (a, y);
(SOURCE_CODE_REGION_FOR_NAMED_FIELD (a, b), y);
};
NAMED_FIELD
symbol
=>
( NAMED_FIELD symbol,
y
);
esac
also # XXX BUGGO FIXME These functions are boilerplate, should write one general version.
fun map_named_fields' ([], results, y)
=>
(reverse results, y);
map_named_fields' (a ! rest, results, y)
=>
{ my (a, y) = map_named_field (a, y);
map_named_fields' (rest, a ! results, y);
};
end;
end
also
fun map_package_expression (x, y)
=
case x
x as PACKAGE_BY_NAME _ # Path # Variable package.
=>
(x, y);
x as PACKAGE_DEFINITION a # Declaration # Defined package.
=>
{ my (a, y) = map_declaration (a, y);
(PACKAGE_DEFINITION a, y);
};
x as CALL_OF_GENERIC (a, b) # (Path, List ((Package_Expression, Bool))) # Application (user-generated).
=>
{ my (b, y) = map_package_expression_bools (b, [], y);
(CALL_OF_GENERIC (a, b), y);
};
x as INTERNAL_CALL_OF_GENERIC (a, b) # (Path, List ((Package_Expression, Bool))) # Application (compiler-generated).
=>
{ my (b, y) = map_package_expression_bools (b, [], y);
(INTERNAL_CALL_OF_GENERIC (a, b), y);
};
x as LET_IN_PACKAGE (a, b) # (Declaration, Package_Expression) # 'let' in package.
=>
{ my (a, y) = map_declaration (a, y);
my (b, y) = map_package_expression (b, y);
(LET_IN_PACKAGE (a, b), y);
};
x as PACKAGE_CAST (a, b) # (Package_Expression, Package_Cast( Api_Expression )) # Api constrained.
=>
{ my (a, y) = map_package_expression (a, y);
(PACKAGE_CAST (a, b), y);
};
x as SOURCE_CODE_REGION_FOR_PACKAGE (a, b) # (Package_Expression, Source_Code_Region) # For error msgs etc.
=>
{ my (a, y) = map_package_expression (a, y);
(SOURCE_CODE_REGION_FOR_PACKAGE (a, b), y);
};
esac
also # XXX BUGGO FIXME These functions are boilerplate, should write one general version.
fun map_package_expression_bools ([], results, y)
=>
(reverse results, y);
map_package_expression_bools ((a,b) ! rest, results, y)
=>
{ my (a, y) = map_package_expression (a, y);
map_package_expression_bools (rest, (a, b) ! results, y);
};
end
also
fun map_named_packages (x, y)
=
map_named_packages' (x, [], y)
where
fun map_named_package (a, y)
=
case a
SOURCE_CODE_REGION_FOR_NAMED_PACKAGE (a, b) # (Mythryl_Named_Package, Source_Code_Region)
=>
{ my (a, y) = map_named_package (a, y);
(SOURCE_CODE_REGION_FOR_NAMED_PACKAGE (a, b), y);
};
NAMED_PACKAGE
{ name_symbol, # : Symbol
definition, # : Package_Expression
constraint, # : Apit_Constraint( Api_Expression )
kind
}
=>
{ my (definition, y) = map_package_expression (definition, y);
( NAMED_PACKAGE { name_symbol, definition, constraint, kind },
y
);
};
esac
also # XXX BUGGO FIXME These functions are boilerplate, should write one general version.
fun map_named_packages' ([], results, y)
=>
(reverse results, y);
map_named_packages' (a ! rest, results, y)
=>
{ my (a, y) = map_named_package (a, y);
map_named_packages' (rest, a ! results, y);
};
end;
end
also
fun map_named_generics (x, y)
=
map_named_generics' (x, [], y)
where
fun map_named_generic (a, y)
=
case a
SOURCE_CODE_REGION_FOR_NAMED_GENERIC (a, b) # (Named_Generic, Source_Code_Region)
=>
{ my (a, y) = map_named_generic (a, y);
(SOURCE_CODE_REGION_FOR_NAMED_GENERIC (a, b), y);
};
NAMED_GENERIC
{ name_symbol, # : Symbol
definition # : Generic_Expression
}
=>
{ my (definition, y) = map_generic_expression (definition, y);
( NAMED_GENERIC { name_symbol, definition },
y
);
};
esac
also # XXX BUGGO FIXME These functions are boilerplate, should write one general version.
fun map_named_generics' ([], results, y)
=>
(reverse results, y);
map_named_generics' (a ! rest, results, y)
=>
{ my (a, y) = map_named_generic (a, y);
map_named_generics' (rest, a ! results, y);
};
end
also
fun map_generic_expression (x, y)
=
case x
x as GENERIC_BY_NAME _ => (x, y); # (Path, Package_Cast( Generic_Api_Expression )) # Generic variable.
x as SOURCE_CODE_REGION_FOR_GENERIC (a, b) # (Generic_Expression, Source_Code_Region) # For debugging msgs etc.
=>
{ my (a, y) = map_generic_expression (a, y);
( SOURCE_CODE_REGION_FOR_GENERIC (a, b),
y
);
};
x as LET_IN_GENERIC (a, b) # (Declaration, Generic_Expression)
=>
{ my (a, y) = map_declaration (a, y);
my (b, y) = map_generic_expression (b, y);
( LET_IN_GENERIC (a, b),
y
);
};
x as GENERIC_DEFINITION { # Explicit generic definition.
parameters, # : List ((Null_Or( Symbol ), Api_Expression)),
body, # : Package_Expression,
constraint # : Package_Cast( Api_Expression )
}
=>
{ my (body, y) = map_package_expression (body, y);
( GENERIC_DEFINITION { parameters, body, constraint },
y
);
};
x as CONSTRAINED_CALL_OF_GENERIC
( a, # Path, # Application.
b, # List ((Package_Expression, Bool)), # Parameter (s).
c # Package_Cast( Generic_Api_Expression )) # Api constraint.
)
=>
{ my (b, y) = map_package_expression_bools (b, [], y);
( CONSTRAINED_CALL_OF_GENERIC (a, b, c),
y
);
};
esac;
end; # 'where'
end; # 'where' for fun map_raw_expression
};
## Copyright 2008 Jeffrey S Prothero
## Subsequent changes by Jeff Prothero Copyright (c) 2010-2015,
## released per terms of SMLNJ-COPYRIGHT.