# adl-raw-syntax-unparser.pkg
#
# "Pretty printer for the Raw_Syntax"
# -- Allen Leung (leunga@cs.nyu.edu) (circa 2000?)
#
#
# I've converted this file into a Mythryl-syntax
# code generator.
#
# Our SML-based Architecture description language gets
# parsed and transformed elsewhere, and then we get
# called to write out the resulting Mythryl code.
#
# This file should be renamed.
#
# -- Cynbe, 2014-05-18
# Compiled by:
# src/lib/compiler/back/low/tools/sml-ast.lib### "We build too many walls and not enough bridges."
###
### -- Isaac Newton
#DO set_control "compiler::trap_int_overflow" "TRUE";
stipulate
package err = adl_error; # adl_error is from src/lib/compiler/back/low/tools/line-number-db/adl-error.pkg package lnd = line_number_database; # line_number_database is from src/lib/compiler/back/low/tools/line-number-db/line-number-database.pkg package raw = adl_raw_syntax_form; # adl_raw_syntax_form is from src/lib/compiler/back/low/tools/adl-syntax/adl-raw-syntax-form.pkg package rsj = adl_raw_syntax_junk; # adl_raw_syntax_junk is from src/lib/compiler/back/low/tools/adl-syntax/adl-raw-syntax-junk.pkg package spp = simple_prettyprinter; # simple_prettyprinter is from src/lib/prettyprint/simple/simple-prettyprinter.pkg #
++ = spp::CONS;
alpha = spp::ALPHABETIC;
bool = spp::BOOL;
brackblock = spp::BRACKETED_BLOCK;
char = spp::CHAR;
enter_iblock = spp::ENTER_INDENTED_BLOCK;
enter_iblock' = spp::ENTER_DEEPLY_INDENTED_BLOCK;
leave_iblock = spp::LEAVE_INDENTED_BLOCK;
iblock = spp::INDENTED_BLOCK;
iline = spp::INDENTED_LINE;
in_parens = spp::IN_PARENTHESES;
indent = spp::INDENT;
indentn = spp::INDENT_OFFSET;
int = spp::INT;
one_word_int = spp::INT1;
integer = spp::INTEGER;
maybe_linewrap = spp::MAYBE_LINEWRAP;
nl = spp::NEWLINE;
nop = spp::NOP;
per_mode = spp::PER_MODE;
punct = spp::PUNCTUATION;
sp = spp::MAYBE_BLANK;
string = spp::STRING;
unt = spp::UNT;
one_word_unt = spp::UNT1;
herein
package adl_raw_syntax_unparser
: Adl_Raw_Syntax_Unparser # Adl_Raw_Syntax_Unparser is from src/lib/compiler/back/low/tools/adl-syntax/adl-raw-syntax-unparser.api {
infix my ++ ;
fun error msg
=
err::error ("error while processing " + msg);
good_break = maybe_linewrap { right_margin => 5, indent_offset => 4 }; # if within 5 columns of right margin, start new line and indent by 4.
comma = punct ", ";
semi = punct "; ";
cons = punct "::";
dot = punct ".";
fun record [ ] => punct "{ }" ;
record [element] => enter_iblock' ++ punct "{ " ++ element ++ punct" }" ++ leave_iblock;
record elements => enter_iblock' ++ spp::LIST { elements, leftbracket => punct "{ ", rightbracket => nl ++ indent ++ punct "}" ++ nl, separator => comma ++ nl ++ indentn 2 } ++ leave_iblock;
end;
fun list elements = spp::LIST { elements, leftbracket => punct "[", rightbracket => indent ++ punct "]", separator => comma++good_break };
fun tuple elements = spp::LIST { elements, leftbracket => punct "(", rightbracket => indent ++ punct ")", separator => comma++good_break };
fun vector elements = spp::LIST { elements, leftbracket => punct "#[", rightbracket => indent ++ punct "]", separator => comma++good_break };
fun bars elements = spp::LIST { elements, leftbracket => enter_iblock', rightbracket => leave_iblock, separator => maybe_linewrap { right_margin=>5, indent_offset=>0 } ++ indentn -2 ++ alpha "|" ++ indent};
fun nls elements = spp::LIST { elements, leftbracket => enter_iblock', rightbracket => leave_iblock, separator => maybe_linewrap { right_margin => 5, indent_offset => 0 } ++ indent };
fun alsos elements = spp::LIST { elements, leftbracket => nop, rightbracket => nop, separator => nl ++ nl ++ indent ++ alpha "also" };
fun is_alpha "" => TRUE;
is_alpha s => char::is_alpha (string::get_byte_as_char (s, 0));
end;
fun is_mlsym '\'' => FALSE;
is_mlsym '_' => FALSE;
is_mlsym '.' => FALSE;
is_mlsym c => char::is_punct c;
end;
fun is_complex s
=
loop (string::length_in_bytes s - 1, FALSE, FALSE)
where
fun loop (-1, alpha, symbol)
=>
alpha and symbol;
loop (i, alpha, symbol)
=>
{ c = string::get_byte_as_char (s, i);
loop (i - 1, alpha or char::is_alphanumeric c,
symbol or is_mlsym c);
};
end;
end;
fun encode_char c
=
if (is_mlsym c) "_" + int::to_string (char::to_int c);
else char::to_string c;
fi;
fun encode_name s
=
string::translate encode_char s;
fun name (id: String)
=
if (is_complex id) encode_name id;
else id;
fi;
fun name' (id: String) # Used to generate one_word_int::(<<) instead of one_word_int::<< (which doesn't work).
=
{ id = name id;
#
if (string::has_alpha id) id;
else "(" + id + ")";
fi;
};
fun maybe_keyword keyword
=
if (keyword == "") nop;
else alpha keyword;
fi;
# Handle stuff that got renamed going from SML to Mythryl:
#
fun mixedcase_renamings "Option" => "Null_Or";
mixedcase_renamings "Unit" => "Void";
mixedcase_renamings other => other;
end;
#
fun uppercase_renamings "SOME" => "THE";
uppercase_renamings "NONE" => "NULL";
uppercase_renamings other => other;
end;
#
fun infix_renamings "^" => "+";
infix_renamings "mod" => "%";
infix_renamings "div" => "/";
infix_renamings "=" => "==";
infix_renamings "<>" => "!=";
infix_renamings "||" => "|";
infix_renamings "&&" => "&";
infix_renamings "!" => "*";
infix_renamings other => other;
end;
fun lowercase_ident (raw::IDENT([], id))
=>
if (is_infix id) punct "(" ++ alpha (infix_renamings id) ++ punct ")";
elif (is_alpha id) alpha (string::to_lower (name id));
else sp ++ alpha id;
fi;
lowercase_ident (raw::IDENT (p, id))
=>
spp::LIST
{ leftbracket => nop,
separator => cons,
rightbracket => nop,
elements => (map alpha ((map string::to_lower p) @ [ name' id ])) # We work file by file, so can't know if external identifiers are constructors, so we must "name' id" case untouched. Thpt.
};
end
also
fun mixedcase_ident (raw::IDENT([], id))
=>
if (is_infix id) punct "(" ++ alpha (infix_renamings id) ++ punct ")";
elif (is_alpha id) alpha (mixedcase_renamings (string::to_mixed (name id)));
else sp ++ alpha id;
fi;
mixedcase_ident (raw::IDENT (p, id))
=>
spp::LIST
{ leftbracket => nop,
separator => cons,
rightbracket => nop,
elements => (map alpha ((map string::to_lower p) @ [mixedcase_renamings (string::to_mixed (name id))]))
};
end
also
fun uppercase_ident (raw::IDENT([], id))
=>
if (is_infix id) punct "(" ++ alpha (infix_renamings id) ++ punct ")";
elif (is_alpha id) alpha (uppercase_renamings (string::to_upper (name id)));
else sp ++ alpha id;
fi;
uppercase_ident (raw::IDENT (p, id))
=>
spp::LIST
{ leftbracket => nop,
separator => cons,
rightbracket => nop,
elements => (map alpha ((map string::to_lower p) @ [uppercase_renamings (string::to_upper (name id))]))
};
end
also
fun literal (raw::UNT_LIT w) => unt w;
literal (raw::UNT1_LIT w) => one_word_unt w;
literal (raw::INT_LIT i) => int i;
literal (raw::INT1_LIT i) => one_word_int i;
literal (raw::STRING_LIT s) => string s;
literal (raw::CHAR_LIT c) => char c;
literal (raw::BOOL_LIT b) => bool b;
literal (raw::FLOAT_LIT r) => alpha r;
#
literal (raw::INTEGER_LIT i)
=>
per_mode
#
\\ "code" => { (alpha "(multiword_int::from_int" ++ int (multiword_int::to_int i) ++ punct ")")
except
OVERFLOW = alpha "(null_or::the (IntInt::from_string" ++ string (multiword_int::to_string i) ++ punct "))";
};
_ => integer i;
end;
end
also
fun expression (raw::LITERAL_IN_EXPRESSION l) => literal l;
expression (raw::ID_IN_EXPRESSION id) => lowercase_ident id;
#
expression (raw::CONSTRUCTOR_IN_EXPRESSION (id, NULL)) => uppercase_ident id;
expression (raw::CONSTRUCTOR_IN_EXPRESSION (id, e)) => uppercase_ident id ++ sp ++ expression' e;
expression (raw::LIST_IN_EXPRESSION (es, NULL)) => if (length es >= 10) longlistexp es;
else list (map appexp es);
fi;
expression (raw::LIST_IN_EXPRESSION([], THE e)) => expression e;
expression (raw::LIST_IN_EXPRESSION (es, THE e)) => spp::LIST { leftbracket => nop, separator => cons, rightbracket => cons, elements => map expression es } ++ expression e;
expression (raw::TUPLE_IN_EXPRESSION [e]) => expression e;
expression (raw::TUPLE_IN_EXPRESSION es) => tuple (map appexp es);
expression (raw::VECTOR_IN_EXPRESSION es) => vector (map appexp es);
expression (raw::RECORD_IN_EXPRESSION es) => record (map label_expression es);
expression (raw::SEQUENTIAL_EXPRESSIONS []) => alpha "()";
expression (raw::SEQUENTIAL_EXPRESSIONS [e]) => expression e;
expression (raw::SEQUENTIAL_EXPRESSIONS es)
=>
indent ++
spp::LIST { leftbracket => punct "{ " ++ enter_iblock',
separator => semi ++ nl ++ indent,
rightbracket => semi ++ nl ++ leave_iblock ++ indent ++ alpha "}",
elements => (map appexp es)
};
expression (raw::APPLY_EXPRESSION (e as raw::ID_IN_EXPRESSION (raw::IDENT([], f)), e' as raw::TUPLE_IN_EXPRESSION [x, y]))
=>
if (is_infix f) in_parens (expression x ++ sp ++ alpha (infix_renamings f) ++ sp ++ expression y); # 'f' is non-alphabetic so assume it is infix and format as x f y
else in_parens (expression e ++ punct " " ++ expression e');
fi;
expression (raw::APPLY_EXPRESSION (f, x)) => enter_iblock' ++ in_parens (appexp f ++ punct " " ++ expression x) ++ leave_iblock;
expression (raw::IF_EXPRESSION (x, raw::SEQUENTIAL_EXPRESSIONS ys, raw::SEQUENTIAL_EXPRESSIONS zs)) # Avoid explicit braces around the 'then' and 'else' clauses.
=>
enter_iblock'
++ indent ++ alpha "if " ++ expression x
++ nl ++ indent ++ punct " #"
++ nl ++ indent
++ spp::LIST { leftbracket => enter_iblock ++ indent,
separator => semi ++ nl ++ indent,
rightbracket => semi ++ leave_iblock,
elements => (map appexp ys)
}
++ nl ++ indent ++ alpha "else"
++ nl ++ indent
++ spp::LIST { leftbracket => enter_iblock ++ indent,
separator => semi ++ nl ++ indent,
rightbracket => semi ++ leave_iblock,
elements => (map appexp zs)
}
++ nl ++ indent ++ alpha "fi"
++ leave_iblock;
expression (raw::IF_EXPRESSION (x, raw::SEQUENTIAL_EXPRESSIONS ys, raw::TUPLE_IN_EXPRESSION [])) # Avoid explicit braces around the 'then' clause and drop void 'else' clause.
=>
enter_iblock'
++ indent ++ alpha "if " ++ expression x
++ nl ++ indent ++ punct " #"
++ nl ++ indent
++ spp::LIST { leftbracket => enter_iblock ++ indent,
separator => semi ++ nl ++ indent,
rightbracket => semi ++ leave_iblock,
elements => (map appexp ys)
}
++ nl ++ indent ++ alpha "fi"
++ leave_iblock;
expression (raw::IF_EXPRESSION (x, raw::SEQUENTIAL_EXPRESSIONS ys, z)) # Avoid explicit braces around the 'then' clause.
=>
enter_iblock'
++ indent ++ alpha "if " ++ expression x
++ nl ++ indent ++ punct " #"
++ nl ++ indent
++ spp::LIST { leftbracket => enter_iblock ++ indent,
separator => semi ++ nl ++ indent,
rightbracket => semi ++ leave_iblock,
elements => (map appexp ys)
}
++ nl ++ indent ++ alpha "else"
++ nl ++ indent ++ enter_iblock ++ expression z ++ punct ";" ++ leave_iblock
++ nl ++ indent ++ alpha "fi"
++ leave_iblock;
expression (raw::IF_EXPRESSION (x, y, raw::SEQUENTIAL_EXPRESSIONS zs)) # Avoid explicit braces around the 'else' clause.
=>
enter_iblock'
++ indent ++ alpha "if " ++ expression x
++ nl ++ indent ++ punct " #"
++ nl ++ indent ++ enter_iblock ++ expression y ++ punct ";" ++ leave_iblock
++ nl ++ indent ++ alpha "else"
++ nl ++ indent
++ spp::LIST { leftbracket => enter_iblock ++ indent,
separator => semi ++ nl ++ indent,
rightbracket => semi ++ leave_iblock,
elements => (map appexp zs)
}
++ nl ++ indent ++ alpha "fi"
++ leave_iblock;
expression (raw::IF_EXPRESSION (x, y, raw::TUPLE_IN_EXPRESSION [])) # Suppress void "else" clause.
=>
enter_iblock'
++ indent ++ alpha "if " ++ expression x ++ punct " " ++ expression y ++ punct ";"
++ nl ++ indent ++ alpha "fi"
++ leave_iblock;
expression (raw::IF_EXPRESSION (x, y, z))
=>
enter_iblock'
++ indent ++ alpha "if " ++ expression x ++ punct " " ++ expression y ++ punct ";"
++ nl ++ indent ++ alpha "else" ++ punct " " ++ expression z ++ punct ";"
++ nl ++ indent ++ alpha "fi"
++ leave_iblock;
expression (raw::RAISE_EXPRESSION e) => alpha "raise exception " ++ expression e;
expression (raw::EXCEPT_EXPRESSION (e, [] )) => in_parens (expression e); # I don't think this can happen.
expression (raw::EXCEPT_EXPRESSION (e, [c])) => in_parens (expression e ++ sp ++ alpha "except" ++ sp ++ clause1 c);
expression (raw::EXCEPT_EXPRESSION (e, c )) => in_parens (expression e ++ sp ++ alpha "except" ++ sp ++ clauses c ++ alpha "end");
expression (raw::CASE_EXPRESSION (e, c))
=>
enter_iblock'
++ indent ++ alpha "case"
++ enter_iblock'
++ sp ++ case e raw::ID_IN_EXPRESSION _ => appexp e; # The 'case expression' expression is a bare var -- no parens needed.
raw::TUPLE_IN_EXPRESSION _ => appexp e; # The 'case expression' expression is a tuple -- no parens needed.
_ => punct "(" ++ appexp e ++ indent ++ punct ")"; # The general case-expression case -- parenthesize it.
esac
++ nl ++ indent ++ punct "#"
++ nl ++ indent ++ clauses c
++ leave_iblock
++ indent ++ alpha "esac"
++ leave_iblock;
expression (raw::FN_IN_EXPRESSION [] ) => punct "(" ++ punct "\\\\ " ++ punct ")"; # I don't think this can happen.
expression (raw::FN_IN_EXPRESSION [c]) => punct "(" ++ punct "\\\\ " ++ clause1 c ++ indent ++ punct ")";
expression (raw::FN_IN_EXPRESSION c ) => enter_iblock' ++ punct "\\\\ " ++ enter_iblock' ++ clauses c ++ leave_iblock ++ indent ++ alpha "end" ++ leave_iblock;
expression (raw::LET_EXPRESSION ([], e)) => expseq e;
expression (raw::LET_EXPRESSION (d, e))
=>
indent ++ punct "{ "
++ enter_iblock'
++ decls d
++ nl ++ indent
++ expseq e ++ punct ";"
++ leave_iblock
++ nl ++ indent ++ alpha "}";
expression (raw::TYPED_EXPRESSION (e, t)) => in_parens (expression e ++ sp ++ punct ":" ++ sp ++ type t);
expression (raw::SOURCE_CODE_REGION_FOR_EXPRESSION(_, e)) => expression e;
expression (raw::REGISTER_IN_EXPRESSION (id, e, region)) => locexp (id, e, region);
expression (raw::BITFIELD_IN_EXPRESSION (e, slices))
=>
per_mode
#
\\ "code" => expression (rsj::bitslice (e, slices));
"default" => expression e ++ sp ++ alpha "at" ++ list (map (\\ (i, j) = int i ++ punct ".." ++ int j) slices);
othermode => { error othermode; nop;};
end;
expression (raw::TYPE_IN_EXPRESSION t) => type t;
expression (raw::ASM_IN_EXPRESSION a) => { error "pp::ASM_IN_EXPRESSION"; nop;};
expression (raw::RTL_IN_EXPRESSION r)
=>
per_mode
#
\\ "default" => rtl r;
othermode => { error othermode; nop; };
end;
expression (raw::MATCH_FAIL_EXCEPTION_IN_EXPRESSION (e, x)) # Some odd extension -- 'x' names an exception 'FOO', from surface syntax <pattern> <guard> exception FOO => <expression>;
=>
expression e;
end
also
fun rtl r
=
spp::LIST { leftbracket => alpha "[[",
separator => sp,
rightbracket => alpha "]]",
elements => (map rtlterm r)
}
also
fun rtlterm (raw::LITRTL s) => string s;
rtlterm (raw::IDRTL x) => alpha x;
rtlterm (raw::COMPOSITERTL x) => raise exception DIE "Unsupported case COMPOSITERTL in rtlterm"; # Added 2011-10-06 CrT just to suppress the "nonexhaustive-match" compiler warning.
end
also
fun longlistexp es
=
per_mode
#
\\ "default" => list (map appexp es);
"code" => codelonglistexp es;
other => raise exception DIE ("Unsupported case '" + other + "' in longlistexp"); # Added 2011-10-06 CrT just to suppress the "nonexhaustive-match" compiler warning.
end
also
fun prettylonglistexp es
=
nl ++
indent ++
spp::LIST { leftbracket => alpha "[",
separator => comma ++ nl ++ indent,
rightbracket => alpha "]",
elements => (map appexp es)
}
also
fun codelonglistexp es =
nl
++ iline( alpha "stipulate infix @@ fun x @@ y = y ! x")
++ iline( alpha "herein NIL")
++ iblock (spp::CAT (map (\\ e = iline( alpha "@@" ++ appexp e)) (reverse es)))
++ iline( alpha "end")
also
fun appexp (raw::APPLY_EXPRESSION (e as raw::ID_IN_EXPRESSION (raw::IDENT([], f)), e' as raw::TUPLE_IN_EXPRESSION [x, y]))
=>
if (is_infix f) expression x ++ sp ++ alpha (infix_renamings f) ++ sp ++ expression y; # 'f' is non-alphabetic so assume it is infix and format as x f y
else expression e ++ punct " " ++ expression e';
fi;
appexp (raw::APPLY_EXPRESSION (f, x)) => (appexp f ++ punct " " ++ expression x);
appexp (raw::SEQUENTIAL_EXPRESSIONS [e]) => appexp e;
appexp (raw::TUPLE_IN_EXPRESSION [e]) => appexp e;
#
appexp e => expression e;
end
also
fun expression' NULL => nop;
expression'(THE e) => if (is_parened_expression e) expression e;
else in_parens (expression e);
fi;
end
also
fun is_parened_expression (raw::ID_IN_EXPRESSION _ ) => TRUE;
is_parened_expression (raw::TUPLE_IN_EXPRESSION [] ) => TRUE;
is_parened_expression (raw::TUPLE_IN_EXPRESSION [x]) => is_parened_expression x;
is_parened_expression (raw::TUPLE_IN_EXPRESSION _ ) => TRUE;
is_parened_expression (raw::RECORD_IN_EXPRESSION _ ) => TRUE;
is_parened_expression (raw::LIST_IN_EXPRESSION _ ) => TRUE;
is_parened_expression (raw::VECTOR_IN_EXPRESSION _ ) => TRUE;
is_parened_expression _ => FALSE;
end
also
fun is_infix "+" => TRUE;
is_infix "-" => TRUE;
is_infix "*" => TRUE;
is_infix "mod" => TRUE;
is_infix "div" => TRUE;
is_infix "=" => TRUE;
is_infix "<>" => TRUE;
is_infix "<" => TRUE;
is_infix ">" => TRUE;
is_infix ">=" => TRUE;
is_infix "<=" => TRUE;
is_infix "<<" => TRUE;
is_infix ">>" => TRUE;
is_infix ">>>" => TRUE;
is_infix "||" => TRUE;
is_infix "&&" => TRUE;
is_infix "^" => TRUE;
is_infix ":=" => TRUE;
is_infix "!" => TRUE;
is_infix "@" => TRUE;
is_infix "and" => TRUE;
is_infix "or" => TRUE;
is_infix "o" => TRUE;
is_infix _ => FALSE;
end
also
fun locexp (id, e, region)
=
per_mode
#
\\ "default"
=>
punct "$" ++ alpha id ++ punct"[" ++ expression e
++
case region THE r => alpha ":" ++ alpha r;
NULL => nop;
esac
++
punct "]";
"code" => in_parens (expression e ++ alpha "+" ++ alpha ("offset" + id));
othermode => { error othermode; nop; };
end
also
fun decl (raw::SUMTYPE_DECL (dbs, tbs)) => sumtypedecl (dbs, tbs);
decl (raw::FUN_DECL fbs) => fundecl fbs;
decl (raw::RTL_DECL (p, e, _)) => iline( alpha "rtl " ++ pattern p ++ alpha "=" ++ expression e);
decl (raw::VAL_DECL vbs) => valdecl vbs;
#
decl (raw::VALUE_API_DECL (ids, type)) => valsig("", ids, type); # 2011-05-04 CrT: The "" was "my".
decl (raw::RTL_SIG_DECL (ids, type)) => valsig("rtl", ids, type);
decl (raw::TYPE_API_DECL (id, tvs)) => typesig (id, tvs);
#
decl (raw::LOCAL_DECL([], d2)) => decls d2;
decl (raw::LOCAL_DECL (d1, d2)) => iline( alpha "stipulate") ++ iblock (decls d1) ++ iline( alpha "herein") ++ iblock (decls d2) ++ iline( alpha "end");
decl (raw::SEQ_DECL ds) => decls ds;
#
decl (raw::VERBATIM_CODE ds) => spp::CAT (map iline (map punct ds));
decl (raw::PACKAGE_DECL (id,[], s, se)) => iline( alpha "package" ++ alpha (string::to_lower id) ++ sigcon_opt (s) ++ alpha "=" ++ sexp se ++ punct ";");
decl (raw::PACKAGE_API_DECL (id, se)) => iline( alpha "package" ++ alpha (string::to_lower id) ++ alpha ":" ++ api_expression se ++ punct ";");
decl (raw::PACKAGE_DECL (id, ds, s, se))
=>
iline( alpha "generic package" ++ alpha id ++ enter_iblock' ++ punct "(" ++ enter_iblock' ++
decls ds ++ leave_iblock ++
indent ++ punct ")" ++ leave_iblock ++ sigcon_opt (s) ++
alpha "=" ++ nl ++ sexp se ++ punct ";");
decl (raw::GENERIC_DECL (id,[], s, se))
=>
iline (alpha "generic package" ++ alpha id ++ sigcon_opt (s) ++ alpha "=" ++ nl ++ sexp se);
decl (raw::GENERIC_DECL (id, ds, s, se))
=>
iline( alpha "generic package" ++ alpha id ++ enter_iblock' ++ punct "(" ++ enter_iblock' ++
decls ds ++ leave_iblock ++
indent ++ punct ")" ++ leave_iblock ++ sigcon_opt (s) ++
alpha "=" ++ nl ++ sexp se);
decl (raw::API_DECL (id, se)) => iline( alpha "api" ++ alpha id ++ alpha "=" ++ api_expression se);
decl (raw::OPEN_DECL ids) => iline( alpha "use" ++ spp::LIST { leftbracket => nop, separator => sp, rightbracket => nop, elements => (map lowercase_ident ids) } );
decl (raw::INCLUDE_API_DECL s) => iline( alpha "include " ++ api_expression s);
#
decl (raw::GENERIC_ARG_DECL (id, se)) => alpha id ++ sigcon se;
#
decl (raw::EXCEPTION_DECL ebs) => iline( alpha "exception" ++ alsos (map exception_def ebs));
decl (raw::SHARING_DECL s) => iline( alpha "sharing" ++ alsos (map share s));
#
decl (raw::SOURCE_CODE_REGION_FOR_DECLARATION (l, d)) => nl ++ alpha (lnd::directive l) ++ nl ++ decl d;
#
decl (raw::INFIX_DECL (i, ids)) => iline( alpha "infix" ++ int i ++ spp::CAT (map alpha ids));
decl (raw::INFIXR_DECL (i, ids)) => iline( alpha "infixr" ++ int i ++ spp::CAT (map alpha ids));
decl (raw::NONFIX_DECL ids) => iline( alpha "nonfix" ++ spp::CAT (map alpha ids));
#
decl (raw::ARCHITECTURE_DECL (id, ds)) => iline( alpha "architecture" ++ alpha id ++ alpha "=" ++ decls ds);
decl (raw::BITS_ORDERING_DECL _) => iline( alpha "bitsordering...");
decl (raw::INSTRUCTION_FORMATS_DECL _) => iline( alpha "instruction formats ...");
#
decl (raw::BIG_VS_LITTLE_ENDIAN_DECL raw::LITTLE ) => iline( alpha "little endian");
decl (raw::BIG_VS_LITTLE_ENDIAN_DECL raw::BIG ) => iline( alpha "big endian");
#
decl (raw::REGISTERS_DECL _) => iline( alpha "storage ...");
decl (raw::SPECIAL_REGISTERS_DECL _) => iline( alpha "locations ...");
decl (raw::ARCHITECTURE_NAME_DECL _) => iline( alpha "name ...");
#
decl (raw::ASSEMBLY_CASE_DECL _) => iline( alpha "assembly ...");
decl (raw::BASE_OP_DECL cbs) => iline( alpha "base_op" ++ indentn -6 ++ consbinds cbs);
#
decl (raw::DEBUG_DECL _) => iline( alpha "debug ...");
decl (raw::RESOURCE_DECL _) => iline( alpha "resource ...");
#
decl (raw::CPU_DECL _) => iline( alpha "cpu ...");
decl (raw::PIPELINE_DECL _) => iline( alpha "pipeline ...");
decl (raw::LATENCY_DECL _) => iline( alpha "latency ...");
end
also
fun exception_def (raw::EXCEPTION (id, NULL)) => alpha id;
exception_def (raw::EXCEPTION (id, THE t)) => alpha id ++ alpha "of" ++ type t;
exception_def (raw::EXCEPTION_ALIAS (id, id')) => alpha id ++ alpha "=" ++ uppercase_ident id';
end
also
fun share (raw::TYPE_SHARE ids) => alpha "type" ++ spp::LIST { leftbracket => nop, separator => alpha "=", rightbracket => nop, elements => (map mixedcase_ident ids) };
share (raw::PACKAGE_SHARE ids) => spp::LIST { leftbracket => nop, separator => alpha "=", rightbracket => nop, elements => (map lowercase_ident ids) };
end
also
fun api_expression (raw::ID_API id)
=>
mixedcase_ident id;
api_expression (raw::WHERE_API (se, x, s))
=>
api_expression se ++ alpha "where" ++ lowercase_ident x ++ sp ++ punct "==" ++ sp ++ sexp s;
api_expression (raw::WHERETYPE_API (se, x, t))
=>
api_expression se ++ alpha "where type" ++ mixedcase_ident x ++ punct "=" ++ type t;
api_expression (raw::DECLARATIONS_API ds)
=>
iline( alpha "api {") ++ iblock (decls ds) ++ iline( alpha "}");
end
also
fun sigcon_opt (NULL) => nop;
sigcon_opt (THE s) => sigcon s;
end
also
fun sigcon { abstract=>FALSE, api_expression=>s } => alpha ": (weak)" ++ api_expression s;
sigcon { abstract=>TRUE, api_expression=>s } => alpha ":" ++ api_expression s;
end
also
fun sexp (raw::IDSEXP id) => lowercase_ident id;
#
sexp (raw::APPSEXP (a, raw::DECLSEXP ds)) => sexp a ++ nl ++ iblock (indent ++ (brackblock { leftbracket => "(", body => (decls ds), rightbracket => ")" } ));
sexp (raw::APPSEXP (a, raw::IDSEXP id )) => sexp a ++ in_parens (lowercase_ident id);
sexp (raw::APPSEXP (a, b )) => sexp a ++ nl ++ in_parens (sexp b);
sexp (raw::CONSTRAINEDSEXP (s, si) ) => sexp s ++ alpha ":" ++ api_expression si;
#
sexp (raw::DECLSEXP ds ) => indent ++ alpha "pkg { " ++ iblock (decls ds) ++ indent ++ alpha "};";
end
also
fun decls ds
=
spp::CAT (map decl ds)
also
fun valsig (keyword,[], t)
=>
nop;
valsig (keyword, id ! ids, t)
=>
iline( maybe_keyword keyword ++ alpha (string::to_lower id) ++ punct ":" ++ sp ++ enter_iblock' ++ type t ++ leave_iblock ++ punct ";" ++ nl)
++
valsig (keyword, ids, t);
end
also
fun typesig (id, tvs)
=
iline(alpha id ++ typevars tvs)
also
fun expseq es
=
iblock (spp::LIST { leftbracket => nop,
separator => semi ++ nl ++ indent,
rightbracket => nop,
elements => map appexp es
}
)
also
fun label_expression (id, e as raw::ID_IN_EXPRESSION (raw::IDENT ([], id')))
=>
if (id == id') alpha (string::to_lower id); # Special case: { ..., foo => foo, ... } in favor of more compact (albeit equivalent) { ..., foo, ... }
else alpha (string::to_lower id) ++ punct " => " ++ appexp e;
fi;
label_expression (id, e)
=>
alpha (string::to_lower id) ++ punct " => " ++ appexp e;
end
also
fun type (raw::IDTY id ) => mixedcase_ident id;
type (raw::TYVARTY tv ) => typevar tv;
type (raw::APPTY (id,[t]) ) => mixedcase_ident id ++ punct "(" ++ sp ++ pty t ++ sp ++ punct ")";
type (raw::APPTY (id, tys)) => mixedcase_ident id ++ tuple (map type tys);
type (raw::FUNTY (x, y) ) => enter_iblock' ++ type x ++ indent ++ sp ++ punct "-> " ++ fty y ++ leave_iblock;
type (raw::TUPLETY [] ) => alpha "Void";
type (raw::TUPLETY [t] ) => type t;
type (raw::TUPLETY tys ) => spp::LIST { leftbracket => punct "(", separator => punct ", ", rightbracket => punct ")", elements => (map pty tys) };
type (raw::RECORDTY labtys) => record (map labty labtys);
type (raw::REGISTER_TYPE id) # This (with id=="bar") came from a foo: $bar declaration -- the '$' distinguishes these from regular type declarations.
=>
per_mode
#
\\ "default" => punct "$" ++ alpha id;
#
"code" => if (id == "registerset") alpha "rgk::Codetemplists";
else alpha "rkj::Codetemp_Info";
fi;
#
other_mode => { error other_mode; nop;};
end;
type (raw::TYPEVAR_TYPE (raw::TYPEKIND, i, _, REF NULL))
=>
alpha ("'X" + int::to_string i);
type (raw::TYPEVAR_TYPE (raw::INTKIND, i, _, REF NULL))
=>
per_mode
#
\\ "default" => alpha ("#X" + int::to_string i);
"code" => alpha ("T" + int::to_string i);
othermode => { error othermode; nop; };
end;
type (raw::TYPEVAR_TYPE(_, _, _, REF (THE t))) => type t;
type (raw::TYPESCHEME_TYPE (vars, t)) => type t;
type (raw::INTVARTY i)
=>
per_mode
#
\\ "default" => punct "#" ++ int i;
"code" => int i; # PUSH_MODE "code" appears (only) in src/lib/compiler/back/low/tools/arch/sourcecode-making-junk.pkg # # and src/lib/compiler/back/low/tools/nowhere/nowhere.pkg othermode => { error othermode; nop; };
end;
type (raw::LAMBDATY (vars, t))
=>
punct "\\" ++ tuple (map type vars) ++ punct "." ++ type t;
end
also
fun fty (t as raw::FUNTY _) => type t;
fty t => pty t;
end
also
fun pty (t as raw::FUNTY _ ) => in_parens (type t);
pty ( raw::TUPLETY [t]) => pty t;
pty (t as raw::TUPLETY [] ) => type t;
pty (t as raw::TUPLETY _) => in_parens (type t);
pty (t as raw::RECORDTY _) => type t;
pty (t as raw::IDTY _) => type t;
pty (t as raw::APPTY _) => type t;
pty (t as raw::TYVARTY _) => type t;
#
pty (t as raw::TYPEVAR_TYPE _) => type t;
#
pty t => in_parens (type t);
end
also
fun labty (id, t)
=
alpha (string::to_lower id) ++ punct ":" ++ sp ++ type t
also
fun pattern (raw::IDPAT id) => if (is_infix id) alpha "op" ++ alpha (infix_renamings id); else alpha (name id);fi;
pattern (raw::WILDCARD_PATTERN) => alpha "_";
pattern (raw::ASPAT (id, p)) => in_parens(alpha id ++ alpha "as" ++ sp ++ pattern p);
pattern (raw::LITPAT l) => literal l;
pattern (raw::LISTPAT (ps, NULL)) => list (map pattern ps);
pattern (raw::LISTPAT([], THE p)) => pattern p;
pattern (raw::LISTPAT (ps, THE p)) => spp::LIST { leftbracket => nop, separator => cons, rightbracket => cons, elements => (map pattern ps) } ++ pattern p;
pattern (raw::TUPLEPAT [p]) => pattern p;
pattern (raw::TUPLEPAT ps) => tuple (map pattern ps);
pattern (raw::VECTOR_PATTERN ps) => vector (map pattern ps);
pattern (raw::RECORD_PATTERN (lps, flex)) => record (map labpat lps @ (if flex [alpha "..."]; else [];fi));
pattern (raw::TYPEDPAT (p, t)) => in_parens (pattern p ++ punct ":" ++ type t);
pattern (raw::CONSPAT (id, NULL)) => uppercase_ident id;
pattern (raw::CONSPAT (raw::IDENT([], "::"), THE (raw::TUPLEPAT [x, y]))) => in_parens (pattern x ++ sp ++ punct"::" ++ sp ++ pattern y); # This "::"" probably needs to become "!"
pattern (raw::CONSPAT (id, THE p)) => uppercase_ident id ++ sp ++ ppat p;
pattern (raw::OR_PATTERN [p]) => pattern p;
pattern (raw::OR_PATTERN ps)
=>
if (length ps > 10)
#
nl ++
indent ++
spp::LIST { leftbracket => alpha "(",
separator => alpha "|" ++ nl ++ indent,
rightbracket => indent ++ alpha ")",
elements => (map pattern ps)
};
else
spp::LIST { leftbracket => punct "(",
separator => alpha "|" ++ sp,
rightbracket => indent ++ punct ")",
elements => (map pattern ps)
};
fi;
pattern (raw::ANDPAT [p]) => pattern p;
pattern (raw::ANDPAT ps) => spp::LIST { leftbracket => punct "(",
separator => sp ++ alpha "and" ++ sp,
rightbracket => indent ++ punct ")",
elements => (map pattern ps)
};
pattern (raw::NOTPAT p) => alpha "not" ++ sp ++ pattern p;
pattern (raw::WHEREPAT (p, e)) => pattern p ++ sp ++ alpha "where" ++ sp ++ expression e;
pattern (raw::NESTEDPAT (p, e, p')) => pattern p ++ sp ++ alpha "where" ++ sp ++ expression e ++
sp ++ alpha "in" ++ sp ++ pattern p';
end
also
fun ppat (p as (raw::CONSPAT _ | raw::ASPAT _))
=>
in_parens (pattern p);
ppat p => pattern p;
end
also
fun pats ps
=
spp::CAT (map pattern ps)
also
fun ppats ps
=
spp::CAT (map (\\ p = ppat p ++ sp) ps)
also
fun labpat (id, p as raw::IDPAT id')
=>
if (string::to_lower id == string::to_lower id') alpha (string::to_lower id); # Write just { ..., foo, ... } rather than the ugly { ..., foo=>foo, ... } -- they mean the same thing.
else alpha (string::to_lower id) ++ punct " => " ++ pattern p;
fi;
labpat (id, p)
=>
alpha (string::to_lower id) ++ punct " => " ++ pattern p;
end
also
fun function_def (raw::FUN (id, [])) # I don't think this can happen.
=>
nop;
function_def (raw::FUN (id, [c])) # Single-clause-in-function case -- print with a "=".
=>
nl ++ indent ++ alpha "fun"
++ ((funclause1 id) c)
;
function_def (raw::FUN (id, c as clause ! clauses)) # Multiple-clauses-in-function case -- each gets a "=>" plus extra indentation.
=>
nl ++ indent ++ alpha "fun" ++ sp
++ enter_iblock'
++ nls (map (funclause id) c)
++ leave_iblock
++ indent ++ alpha "end";
end
also
fun function_defs fbs
=
alsos (map function_def fbs) ++ indent ++ punct ";" ++ nl
also
fun funclause id (raw::CLAUSE (ps, g, e)) # This version is for when we have multiple clauses in a function -- each gets a '=>'
=
indent ++ alpha (string::to_lower (name id)) ++ sp ++ ppats ps ++ sp ++ guard g
++ enter_iblock
++ indent ++ punct "=>" ++ sp ++ enter_iblock' ++ appexp e ++ leave_iblock ++ punct ";" ++ nl
++ leave_iblock
also
fun funclause1 id (raw::CLAUSE (ps, g, e)) # This version is for when we have only one clause in a function -- it gets a '='
=
iline (alpha (string::to_lower (name id)) ++ sp ++ ppats ps ++ sp ++ guard g)
++ enter_iblock
++ indent ++ punct "=" ++ nl
++ indent ++ appexp e
++ leave_iblock
also
fun guard NULL => nop;
guard (THE e) => alpha "where" ++ sp ++ appexp e ++ sp;
end
also
fun clauses c
=
iblock (nls (map clause c))
also
fun clause (raw::CLAUSE([p], g, e)) # This version is for when we have multiple clauses in a fn/except -- each gets a '=>'
=>
indent ++ enter_iblock ++ pattern p ++ sp ++ guard g ++ indent ++
alpha "=>" ++ sp ++ enter_iblock' ++ appexp e ++ punct ";" ++ leave_iblock ++ leave_iblock ++ nl;
clause (raw::CLAUSE (ps, g, e))
=>
indent ++ enter_iblock ++ ppats ps ++ sp ++ guard g ++ indent ++
alpha "=>" ++ sp ++ enter_iblock' ++ appexp e ++ punct ";" ++ leave_iblock ++ leave_iblock ++ nl;
end
also
fun clause1 (raw::CLAUSE([p], g, e)) # This version is for when we have a single clause in a fn/except -- it gets a '='
=>
indent ++ enter_iblock' ++ pattern p ++ sp ++ guard g
++ alpha "=" ++ sp ++ good_break ++ appexp e ++ leave_iblock;
clause1 (raw::CLAUSE (ps, g, e))
=>
indent ++ enter_iblock' ++ ppats ps ++ sp ++ guard g
++ alpha "=" ++ sp ++ appexp e ++ leave_iblock;
end
also
fun fundecl [] => nop;
fundecl fbs => function_defs fbs;
end
also
fun named_value (raw::NAMED_VARIABLE (p, e))
=
iline (enter_iblock' ++ pattern p ++ indent ++ punct " = " ++ enter_iblock' ++ appexp e ++ leave_iblock ++ punct ";" ++ leave_iblock)
also
fun named_values [] => nop; # I don't think this should happen.
named_values [vb] => named_value vb; # "vb" == "value binding".
named_values vbs => alsos (map named_value vbs);
end
also
fun valdecl [] => nop; # I don't think this should happen.
#
valdecl [vb as raw::NAMED_VARIABLE (raw::IDPAT _, e)]
=>
named_value vb; # 'my' is not needed when we just have foo = whatever;
valdecl vbs
=>
indent ++ alpha "my" ++ sp ++ named_values vbs;
end
also
fun sumtype (raw::SUMTYPE { name=>id, typevars=>ts, cbs, ... } )
=>
# Here we're doing something like
#
# Operand = IMMED one_word_int::Int
# | IMMED_LABEL tcf::Label_Expression
# ;
#
alpha (string::to_mixed id)
++ case ts [] => nop;
_ => punct "(" ++ typevars ts ++ punct ")";
esac
++ sp
++ enter_iblock'
++ alpha "="
++ sp
++ consbinds cbs
++ indent ++ punct ";"
++ leave_iblock
++ nl
++ nl;
sumtype (raw::SUMTYPE_ALIAS { name=>id, typevars=>ts, type=>t, ... } )
=>
iline (typevars ts ++ alpha (string::to_mixed id) ++ alpha "=" ++ alpha "enum" ++ type t);
end
also
fun sumtypes ds
=
iblock (alsos (map sumtype ds))
also
fun consbinds cbs
=
bars (map consbind cbs)
also
fun consbind (raw::CONSTRUCTOR { name, type=>NULL, ... } )
=>
iline( alpha (string::to_upper name));
#
consbind (raw::CONSTRUCTOR { name, type=>THE t, ... } )
=>
iline( alpha (string::to_upper name)
++
# case t raw::TUPLETY _ => punct "(" ++ sp ++ type t ++ sp ++ indent ++ punct ")";
case t raw::TUPLETY _ => sp ++ type t;
raw::RECORDTY _ => sp ++ type t;
_ => punct "\t" ++ type t;
esac
);
end
also
fun typebind (raw::TYPE_ALIAS (id, ts, t))
=
indent ++ (alpha (string::to_mixed id) ++ typevars ts ++ alpha "=" ++ sp ++ type t)
also
fun typebinds tbs = alsos (map typebind tbs) ++ punct ";"
also
fun typevars [] => nop;
typevars [t] => typevar t;
typevars tvs => tuple (map typevar tvs);
end
also
fun typevar (raw::VARTV tv) => alpha tv;
typevar (raw::INTTV tv) => sp ++ punct "#" ++ alpha tv;
end
also
fun range (x, y)
=
in_parens (int x ++ comma ++ int y)
also
fun sumtypedecl ([], t)
=>
alsos (map typebind t) ++ punct ";" ++ nl;
sumtypedecl (d, t)
=>
indent ++
sumtypes d ++
case t
#
[] => nop;
_ => indent ++ alpha "withtype" ++ typebinds t;
esac;
end;
}; # package adl_raw_syntax_unparser
end; # stipulate