## adl-rewrite-raw-syntax-parsetree.pkg
#
# See overview comments at top of:
# src/lib/compiler/back/low/tools/adl-syntax/adl-rewrite-raw-syntax-parsetree.api# Compiled by:
# src/lib/compiler/back/low/tools/sml-ast.lib### "Science is built up of facts,
### as a house is with stones.
### But a collection of facts
### is no more a science than
### a heap of stones is a house."
###
### -- Henri Poincare
stipulate
package raw = adl_raw_syntax_form; # adl_raw_syntax_form is from src/lib/compiler/back/low/tools/adl-syntax/adl-raw-syntax-form.pkgherein
# This package is used in:
# src/lib/compiler/back/low/tools/arch/make-sourcecode-for-backend-packages.pkg #
package adl_rewrite_raw_syntax_parsetree
: (weak) Adl_Rewrite_Raw_Syntax_Parsetree # Adl_Rewrite_Raw_Syntax_Parsetree is from src/lib/compiler/back/low/tools/adl-syntax/adl-rewrite-raw-syntax-parsetree.api {
stipulate
package error = adl_error; # adl_error is from src/lib/compiler/back/low/tools/line-number-db/adl-error.pkg herein
# This is the type of a client-supplied function
# performing some application-specific transform
# on raw syntax tree nodes of a given type:
#
Node_Rewrite_Fn(X) # X will be one of raw::Expression, raw::Declaration, raw::Package_Exp, raw::Pattern, raw::Type
=
(X -> X) # Recursive parsetree-rewriter function synthesized by our package.
-> X # The parsetree to transform.
-> X; # The transformed parsetree.
Rewrite_Node_Fn
= REWRITE_EXPRESSION_NODE Node_Rewrite_Fn( raw::Expression )
| REWRITE_DECLARATION_NODE Node_Rewrite_Fn( raw::Declaration )
| REWRITE_STATEMENT_NODE Node_Rewrite_Fn( raw::Package_Exp )
| REWRITE_PATTERN_NODE Node_Rewrite_Fn( raw::Pattern )
| REWRITE_TYPE_NODE Node_Rewrite_Fn( raw::Type )
;
Rewrite_Parsetree_Fns
=
{ rewrite_expression_parsetree: raw::Expression -> raw::Expression,
rewrite_declaration_parsetree: raw::Declaration -> raw::Declaration,
rewrite_statement_parsetree: raw::Package_Exp -> raw::Package_Exp,
rewrite_pattern_parsetree: raw::Pattern -> raw::Pattern,
rewrite_type_parsetree: raw::Type -> raw::Type
};
# No-op node-fn:
#
fun null_transform_on_raw_syntax_parsetree_element _ e # '_' is the recursive syntax-tree rewriter we synthesize below for raw syntax parsetree nodes of this type.
=
e;
fun null_or f (THE e) => THE (f e);
null_or f NULL => NULL;
end;
fun make_raw_syntax_parsetree_rewriters' # Given fns which rewrite individual parsetree nodes, produce fns which recursively rewrite complete parsetrees.
{
rewrite_expression_node,
rewrite_declaration_node,
rewrite_pattern_node,
rewrite_statement_node,
rewrite_type_node
}
=
{ fun rewrite_expression_parsetree e
=
rewrite_expression_node rewrite_expression_parsetree e
where
e = case e
#
raw::CONSTRUCTOR_IN_EXPRESSION (id, THE e) => raw::CONSTRUCTOR_IN_EXPRESSION (id, THE (rewrite_expression_parsetree e));
raw::LIST_IN_EXPRESSION (es, e) => raw::LIST_IN_EXPRESSION (map rewrite_expression_parsetree es, null_or rewrite_expression_parsetree e);
#
raw::TUPLE_IN_EXPRESSION es => raw::TUPLE_IN_EXPRESSION (map rewrite_expression_parsetree es);
raw::VECTOR_IN_EXPRESSION es => raw::VECTOR_IN_EXPRESSION (map rewrite_expression_parsetree es);
raw::RECORD_IN_EXPRESSION es => raw::RECORD_IN_EXPRESSION (map (\\ (l, e) = (l, rewrite_expression_parsetree e)) es);
#
raw::SEQUENTIAL_EXPRESSIONS es => raw::SEQUENTIAL_EXPRESSIONS (map rewrite_expression_parsetree es);
raw::APPLY_EXPRESSION (f, x) => raw::APPLY_EXPRESSION (rewrite_expression_parsetree f, rewrite_expression_parsetree x);
raw::IF_EXPRESSION (x, y, z) => raw::IF_EXPRESSION (rewrite_expression_parsetree x, rewrite_expression_parsetree y, rewrite_expression_parsetree z);
#
raw::RAISE_EXPRESSION e => raw::RAISE_EXPRESSION (rewrite_expression_parsetree e);
raw::EXCEPT_EXPRESSION (e, c) => raw::EXCEPT_EXPRESSION (rewrite_expression_parsetree e, map clause c);
#
raw::CASE_EXPRESSION (e, c) => raw::CASE_EXPRESSION (rewrite_expression_parsetree e, map clause c);
raw::FN_IN_EXPRESSION c => raw::FN_IN_EXPRESSION (map clause c);
raw::LET_EXPRESSION (d, e) => raw::LET_EXPRESSION (map rewrite_declaration_parsetree d, map rewrite_expression_parsetree e);
#
raw::TYPED_EXPRESSION (e, t) => raw::TYPED_EXPRESSION (rewrite_expression_parsetree e, rewrite_type_parsetree t);
raw::TYPE_IN_EXPRESSION t => raw::TYPE_IN_EXPRESSION (rewrite_type_parsetree t);
#
raw::REGISTER_IN_EXPRESSION (id, e, region) => raw::REGISTER_IN_EXPRESSION (id, rewrite_expression_parsetree e, region);
raw::BITFIELD_IN_EXPRESSION (e, slices) => raw::BITFIELD_IN_EXPRESSION (rewrite_expression_parsetree e, slices);
#
raw::MATCH_FAIL_EXCEPTION_IN_EXPRESSION (e, x) # Some odd extension -- 'Id' names an exception 'FOO', from surface syntax <pattern> <guard> exception FOO => <expression>;
=>
raw::MATCH_FAIL_EXCEPTION_IN_EXPRESSION (rewrite_expression_parsetree e, x);
#
raw::SOURCE_CODE_REGION_FOR_EXPRESSION (l, e)
=>
{ error::set_loc l;
#
raw::SOURCE_CODE_REGION_FOR_EXPRESSION (l, rewrite_expression_parsetree e);
};
#
e => e;
esac;
end
also
fun rewrite_declaration_parsetree d
=
rewrite_declaration_node rewrite_declaration_parsetree d
where
d = case d
#
raw::SUMTYPE_DECL (dbs, tbs) => raw::SUMTYPE_DECL (map dbind dbs, map tbind tbs);
raw::FUN_DECL fbs => raw::FUN_DECL (map fbind fbs);
raw::RTL_DECL (p, e, l) => raw::RTL_DECL (rewrite_pattern_parsetree p, rewrite_expression_parsetree e, l);
#
raw::RTL_SIG_DECL (id, t) => raw::RTL_SIG_DECL (id, rewrite_type_parsetree t);
raw::VAL_DECL vbs => raw::VAL_DECL (map vbind vbs);
raw::VALUE_API_DECL (id, t) => raw::VALUE_API_DECL (id, rewrite_type_parsetree t);
#
raw::TYPE_API_DECL (id, tvs) => raw::TYPE_API_DECL (id, tvs);
raw::LOCAL_DECL (d1, d2) => raw::LOCAL_DECL (map rewrite_declaration_parsetree d1, map rewrite_declaration_parsetree d2);
raw::SEQ_DECL ds => raw::SEQ_DECL (map rewrite_declaration_parsetree ds);
#
raw::PACKAGE_DECL(id, ds, s, se) => raw::PACKAGE_DECL (id, map rewrite_declaration_parsetree ds, sigconopt s, rewrite_statement_parsetree se);
raw::GENERIC_DECL(id, ds, s, se) => raw::GENERIC_DECL (id, map rewrite_declaration_parsetree ds, sigconopt s, rewrite_statement_parsetree se);
#
raw::INCLUDE_API_DECL s => raw::INCLUDE_API_DECL (api_expression s);
raw::OPEN_DECL ids => raw::OPEN_DECL ids;
#
raw::API_DECL (id, s) => raw::API_DECL (id, api_expression s);
raw::PACKAGE_API_DECL (id, s) => raw::PACKAGE_API_DECL (id, api_expression s);
#
raw::GENERIC_ARG_DECL (id, se) => raw::GENERIC_ARG_DECL (id, sigcon se);
raw::EXCEPTION_DECL ebs => raw::EXCEPTION_DECL (map ebind ebs);
#
raw::SOURCE_CODE_REGION_FOR_DECLARATION (l, d)
=>
{ error::set_loc l;
#
raw::SOURCE_CODE_REGION_FOR_DECLARATION (l, rewrite_declaration_parsetree d);
};
d => d;
esac;
end
also
fun sigcon { abstract, api_expression => se }
=
{ abstract,
api_expression => api_expression se
}
also
fun sigconopt s = null_or::map sigcon s
also
fun ebind (b as raw::EXCEPTION (id, NULL)) => b;
ebind ( raw::EXCEPTION (id, THE t)) => raw::EXCEPTION (id, THE (rewrite_type_parsetree t));
ebind (b as raw::EXCEPTION_ALIAS _) => b;
end
also
fun api_expression se
=
se
where
se = case se
#
raw::ID_API _ => se;
raw::WHERE_API (se, ident, s) => raw::WHERE_API (api_expression se, ident, rewrite_statement_parsetree s);
raw::WHERETYPE_API (se, ident, t) => raw::WHERETYPE_API (api_expression se, ident, rewrite_type_parsetree t);
raw::DECLARATIONS_API ds => raw::DECLARATIONS_API (map rewrite_declaration_parsetree ds);
esac;
end
also
fun rewrite_statement_parsetree se
=
{ se = case se
#
raw::APPSEXP (a, se) => raw::APPSEXP (rewrite_statement_parsetree a, rewrite_statement_parsetree se);
raw::DECLSEXP ds => raw::DECLSEXP (map rewrite_declaration_parsetree ds);
raw::CONSTRAINEDSEXP (s, si) => raw::CONSTRAINEDSEXP (rewrite_statement_parsetree s, api_expression si);
raw::IDSEXP _ => se;
esac;
rewrite_statement_node rewrite_statement_parsetree se;
}
also
fun rewrite_type_parsetree t
=
rewrite_type_node rewrite_type_parsetree t
where
t = case t
#
raw::IDTY _ => t;
raw::TYVARTY _ => t;
raw::INTVARTY _ => t;
raw::REGISTER_TYPE _ => t;
#
raw::TYPEVAR_TYPE (_, _, _, REF NULL ) => t;
raw::TYPEVAR_TYPE (_, _, _, REF (THE t)) => rewrite_type_parsetree t;
#
raw::TYPESCHEME_TYPE (ts, t) => raw::TYPESCHEME_TYPE (map rewrite_type_parsetree ts, rewrite_type_parsetree t);
#
raw::APPTY (f, ts) => raw::APPTY (f, map rewrite_type_parsetree ts);
raw::FUNTY (a, b) => raw::FUNTY (rewrite_type_parsetree a, rewrite_type_parsetree b);
#
raw::TUPLETY ts => raw::TUPLETY (map rewrite_type_parsetree ts);
raw::RECORDTY lts => raw::RECORDTY (map (\\ (l, t) = (l, rewrite_type_parsetree t)) lts);
raw::LAMBDATY (ts, t) => raw::LAMBDATY (map rewrite_type_parsetree ts, rewrite_type_parsetree t);
esac;
end
also
fun rewrite_pattern_parsetree p
=
rewrite_pattern_node rewrite_pattern_parsetree p
where
p = case p
#
raw::IDPAT id => p;
raw::WILDCARD_PATTERN => p;
raw::LITPAT l => p;
#
raw::CONSPAT (id, NULL) => p;
raw::CONSPAT (id, THE p) => raw::CONSPAT (id, THE (rewrite_pattern_parsetree p));
#
raw::ASPAT (id, p) => raw::ASPAT (id, rewrite_pattern_parsetree p);
raw::LISTPAT (ps, p) => raw::LISTPAT (map rewrite_pattern_parsetree ps, null_or rewrite_pattern_parsetree p);
raw::TUPLEPAT ps => raw::TUPLEPAT (map rewrite_pattern_parsetree ps);
#
raw::RECORD_PATTERN (lps, flex) => raw::RECORD_PATTERN (map (\\ (l, p) = (l, rewrite_pattern_parsetree p)) lps, flex);
#
raw::VECTOR_PATTERN ps => raw::VECTOR_PATTERN (map rewrite_pattern_parsetree ps);
raw::TYPEDPAT (p, t) => raw::TYPEDPAT (rewrite_pattern_parsetree p, rewrite_type_parsetree t);
raw::OR_PATTERN ps => raw::OR_PATTERN (map rewrite_pattern_parsetree ps);
raw::ANDPAT ps => raw::ANDPAT (map rewrite_pattern_parsetree ps);
raw::NOTPAT p => raw::NOTPAT (rewrite_pattern_parsetree p);
raw::WHEREPAT (p, e) => raw::WHEREPAT (rewrite_pattern_parsetree p, rewrite_expression_parsetree e);
raw::NESTEDPAT (p, e, p') => raw::NESTEDPAT (rewrite_pattern_parsetree p, rewrite_expression_parsetree e, rewrite_pattern_parsetree p');
esac;
end
also
fun fbind (raw::FUN (id, c))
=
raw::FUN (id, map clause c)
also
fun clause (raw::CLAUSE (ps, g, e))
=
raw::CLAUSE (map rewrite_pattern_parsetree ps, guard g, rewrite_expression_parsetree e)
also
fun guard (THE e) => THE (rewrite_expression_parsetree e);
guard NULL => NULL;
end
also
fun vbind (raw::NAMED_VARIABLE (p, e))
=
raw::NAMED_VARIABLE (rewrite_pattern_parsetree p, rewrite_expression_parsetree e)
also
fun dbind db = db
also
fun tbind (raw::TYPE_ALIAS (x, tvs, t))
=
raw::TYPE_ALIAS (x, tvs, rewrite_type_parsetree t);
{ rewrite_expression_parsetree,
rewrite_declaration_parsetree,
rewrite_statement_parsetree,
rewrite_pattern_parsetree,
rewrite_type_parsetree
};
}; # fun make_raw_syntax_parsetree_rewriters'
fun make_raw_syntax_parsetree_rewriters node_fns # Given fns which rewrite individual parsetree nodes, produce fns which recursively rewrite complete parsetrees.
=
# Here we just convert our node_fns list to a record
# and then pass it to make_raw_syntax_parsetree_rewriters':
#
{ rewrite_expression_node = REF null_transform_on_raw_syntax_parsetree_element;
rewrite_declaration_node = REF null_transform_on_raw_syntax_parsetree_element;
rewrite_pattern_node = REF null_transform_on_raw_syntax_parsetree_element;
rewrite_statement_node = REF null_transform_on_raw_syntax_parsetree_element;
rewrite_type_node = REF null_transform_on_raw_syntax_parsetree_element;
apply note_node_fn node_fns
where
fun note_node_fn (REWRITE_EXPRESSION_NODE node_fn) => rewrite_expression_node := node_fn;
note_node_fn (REWRITE_DECLARATION_NODE node_fn) => rewrite_declaration_node := node_fn;
note_node_fn (REWRITE_PATTERN_NODE node_fn) => rewrite_pattern_node := node_fn;
note_node_fn (REWRITE_STATEMENT_NODE node_fn) => rewrite_statement_node := node_fn;
note_node_fn (REWRITE_TYPE_NODE node_fn) => rewrite_type_node := node_fn;
end;
end;
make_raw_syntax_parsetree_rewriters'
{
rewrite_expression_node => *rewrite_expression_node,
rewrite_declaration_node => *rewrite_declaration_node,
rewrite_pattern_node => *rewrite_pattern_node,
rewrite_statement_node => *rewrite_statement_node,
rewrite_type_node => *rewrite_type_node
};
};
end; # stipulate
}; # package adl_rewrite_raw_syntax_parsetree
end; # stipulate