## translate-deep-syntax-pattern-to-lambdacode-junk.pkg
# Compiled by:
# src/lib/compiler/core.sublib### "Never take anything on authority."
###
### -- Guy L. Steele Jr
# TODO: this module requires a api ! XXX BUGGO FIXME
stipulate
package ds = deep_syntax; # deep_syntax is from src/lib/compiler/front/typer-stuff/deep-syntax/deep-syntax.pkg package err = error_message; # error_message is from src/lib/compiler/front/basics/errormsg/error-message.pkg package tdt = type_declaration_types; # type_declaration_types is from src/lib/compiler/front/typer-stuff/types/type-declaration-types.pkg package vac = variables_and_constructors; # variables_and_constructors is from src/lib/compiler/front/typer-stuff/deep-syntax/variables-and-constructors.pkgherein
package translate_deep_syntax_pattern_to_lambdacode_junk {
#
Simp
= VARSIMP vac::Variable
| RECORDSIMP List( (tdt::Label, Simp) )
;
Dconinfo = ( tdt::Valcon, List(tdt::Typoid) );
Path_Constant
= DATAPCON Dconinfo
| INTPCON Int
| INT1PCON one_word_int::Int
| INTEGERPCON multiword_int::Int
| UNTPCON Unt
| UNT1PCON one_word_unt::Unt
| REALPCON String
| STRINGPCON String
| VLENPCON (Int, tdt::Typoid)
;
Path
= RECORD_PATH List( Path )
| PI_PATH (Int, Path)
| VPI_PATH (Int, tdt::Typoid, Path)
| VLEN_PATH (Path, tdt::Typoid)
| DELTA_PATH (Path_Constant, Path)
| ROOT_PATH
;
Dectree
= CASETEST (Path,
varhome::Valcon_Signature,
List ((Path_Constant, Dectree)),
Null_Or( Dectree ))
| ABSTEST0 (Path, Dconinfo, Dectree, Dectree)
| ABSTEST1 (Path, Dconinfo, Dectree, Dectree)
| RHS Int # "RHS" == "Right Hand Side"
| BIND (Path, Dectree);
fun bug s
=
err::impossible ("translate_deep_syntax_pattern_to_lambdacode_junk: " + s);
fun make_recordpat (ds::RECORD_PATTERN { fields, is_incomplete=>FALSE, type_ref, ... } ) pats
=>
ds::RECORD_PATTERN
{
fields => paired_lists::map
(\\((id, _), p) = (id, p))
(fields, pats),
is_incomplete => FALSE,
type_ref
};
make_recordpat (ds::RECORD_PATTERN { is_incomplete => TRUE, ... } ) _
=>
bug "incomplete record passed to mkRECORDpat";
make_recordpat _ _
=>
bug "non record passed to mkRECORDpat";
end;
fun con_eq ( tdt::VALCON { form=>a1, ... },
tdt::VALCON { form=>a2, ... }
)
=
a1 == a2;
fun con_eq' ( ( tdt::VALCON { form=>a1, ... }, _),
( tdt::VALCON { form=>a2, ... }, _)
)
=
a1 == a2;
/*
fun constant_eq (INTcon n, INTcon n') = n == n'
| constant_eq (WORDcon n, WORDcon n') = n == n'
| constant_eq (INT1con n, INT1con n') = n == n'
| constant_eq (WORD32con n, WORD32con n') = n == n'
| constant_eq (REALcon r, REALcon r') = r == r'
| constant_eq (STRINGcon s, STRINGcon s') = s == s'
| constant_eq (VLENcon n, VLENcon n') = n == n'
| constant_eq (Valcon(_, krep, _), Valcon(_, krep', _)) = krep == krep'
| constant_eq _ = FALSE
*/
fun constant_eq (DATAPCON (d1, _), DATAPCON (d2, _)) => con_eq (d1, d2);
constant_eq (INTPCON n, INTPCON n') => n == n';
constant_eq (INT1PCON n, INT1PCON n') => n == n';
constant_eq (INTEGERPCON n, INTEGERPCON n') => n == n';
constant_eq (UNTPCON n, UNTPCON n') => n == n';
constant_eq (UNT1PCON n, UNT1PCON n') => n == n';
constant_eq (REALPCON r, REALPCON r') => r == r';
constant_eq (STRINGPCON s, STRINGPCON s') => s == s';
constant_eq (VLENPCON (n, _), VLENPCON (n', _)) => n == n';
constant_eq _ => FALSE;
end;
fun path_eq (RECORD_PATH (a ! ar), RECORD_PATH (b ! br))
=>
path_eq (a, b) and path_eq (RECORD_PATH ar, RECORD_PATH br);
path_eq (RECORD_PATH NIL, RECORD_PATH NIL) => TRUE;
path_eq (PI_PATH (i1, p1), PI_PATH (i2, p2)) => i1 == i2 and path_eq (p1, p2);
path_eq (VPI_PATH (i1, _, p1), VPI_PATH (i2, _, p2)) => i1 == i2 and path_eq (p1, p2);
path_eq (VLEN_PATH (p1, _), VLEN_PATH (p2, _)) => path_eq (p1, p2);
path_eq (DELTA_PATH (c1, p1), DELTA_PATH (c2, p2)) =>
constant_eq (c1, c2) and path_eq (p1, p2);
path_eq (ROOT_PATH, ROOT_PATH) => TRUE;
path_eq _ => FALSE;
end;
fun get_path (a, (b, c) ! d)
=>
if (path_eq (a, b)) c;
else get_path (a, d);
fi;
get_path _ => bug "unexpected args in get_path";
end;
fun abstract x = FALSE;
fun template x = FALSE;
fun is_an_exception x = FALSE;
fun signature_of_constructor (tdt::VALCON { signature, ... } )
=
signature;
fun unary (tdt::VALCON { is_constant, ... }, _)
=
is_constant; # Constructor takes no arguments, e.g. TRUE, FALSE, NULL ...
}; # package translate_deep_syntax_pattern_to_lambdacode_junk
end;