DECS a68 lang CONTEXT VOID
USE standard, gccaliens:
{
Algol 68 frontend for GCC.
(At the moment a brainfuck frontend)
Copyright (C) 2011 Jose E. Marchesi
This program is free software; you can redistribute it and/or modify
it under the terms of the GNU General Public License as published by
the Free Software Foundation; either version 3 of the License, or
(at your option) any later version.
This program is distributed in the hope that it will be useful, but
WITHOUT ANY WARRANTY; without even the implied warranty of
MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU
General Public License for more details.
You should have received a copy of the GNU General Public License
along with this program. If not, see
.
}
{
Written by Jose E. Marchesi
}
PROC algol68 init = BOOL:
BEGIN
{ Create nodes for all integer types. }
build common tree nodes (FALSE, FALSE);
{ Set the type of the internal equivalent of size_t. It may be
"unsigned long" or "unsigned long long". }
IF type mode (long unsigned type node) = ptr mode THEN
size type node := long unsigned type node
ELIF type mode (long long unsigned type node) = ptr mode THEN
size type node := long long unsigned type node
ELSE
size type node := long unsigned type node
FI;
set sizetype (size type node);
{ Create few more tree types. }
build common tree nodes 2 (0);
build common builtin nodes;
void list node := build tree list (null tree,
void type node);
TRUE
END; { algol68 init }
PROC algol68 langhook init options = (INT argc, REF CSTR argv) INT:
BEGIN
cl algol68
END;
PROC algol68 langhook handle option =
(INT scode, CSTR arg, INT value) INT: ( 0 );
PROC algol68 langhook post options = (REF CSTR pfilename) BOOL:
BEGIN
set flag excess precision cmdline (excess precision fast);
FALSE
END;
PROC in = (TREE pointer) TREE:
BEGIN
TREE res;
TREE fntype := build function type list 1 (integer type node);
TREE declf := build decl (unknown location,
function decl,
get identifier ("getchar"),
fntype);
TREE in tree;
set tree public (declf, TRUE);
set decl external (declf, TRUE);
in tree := fold convert (char type node, pointer);
res := build call expr (declf);
build2 (modify expr,
char type node,
in tree,
fold convert (char type node, res))
END; { in }
PROC out = (TREE pointer) TREE:
BEGIN
TREE fntype := build function type list 2 (integer type node,
integer type node);
TREE declf := build decl (unknown location,
function decl,
get identifier ("putchar"),
fntype);
TREE p := fold convert (integer type node, pointer);
build call expr 1 (declf, p)
END; { out }
PROC add ptr = (TREE data, INT delta) TREE:
BEGIN
TREE cst = build int cst (tree type (data), delta);
build2 (preincrement expr, tree type (data), data, cst)
END;
PROC add = (TREE data, INT delta) TREE:
BEGIN
TREE cst = build int cst (tree type (data), delta);
build2 (preincrement expr, tree type (data), data, cst)
END;
PROC read tree = (REF FILE input file,
TREE header, deref,
REF BOOL eof) TREE:
{
Read a brainfuck tree from a given file and return it.
'input file' shall be a book accessed through the stand in
channel. Note that it is not closed by this function.
}
BEGIN
CHAR c;
TREE child;
TREE func := null tree,
body := null tree,
exit;
on logical file end (input file,
(REF FILE f) BOOL: (eof := TRUE; GOTO end; FALSE));
WHILE
get (input file, c); c /= "]" AND NOT eof
DO
IF c = ">" THEN
append to statement list (add ptr (header, 1), func)
ELIF c = "<" THEN
append to statement list (add ptr (header, -1), func)
ELIF c = "+" THEN
append to statement list (add (deref, 1), func)
ELIF c = "-" THEN
append to statement list (add (deref, -1), func)
ELIF c = "." THEN
append to statement list (out (deref), func)
ELIF c = "," THEN
append to statement list (in (deref), func)
ELIF c = "[" THEN
child := read tree (input file, header, deref, eof);
exit := build1 (exit expr, char type node,
build3 (cond expr, char type node, deref,
build int cst (char type node, 0),
build int cst (char type node, 1)));
body := build2 (compound expr, char type node,
exit, child);
append to statement list (build1 (loop expr, char type node, body),
func)
FI
OD;
end: func
END; { read tree }
PROC algol68 langhook parse file = (INT set yy debug) VOID:
{
Parse the input files to the compiler.
If 'set yy debug' is nonzero then debug messages should be
dumped to the standard error.
}
BEGIN
FILE finput;
TREE func := null tree,
decl := build decl (input location, function decl,
get identifier ("main"),
build function type (integer type node,
void list node)),
data := build decl (input location, var decl, get identifier ("data"),
build vector type (char type node, 32768)),
header := build decl (input location, var decl, get identifier ("header"),
build pointer type (char type node)),
deref := fold build 1 (indirect ref, char type node, header),
assign := build2 (init expr, build pointer type (char type node), header,
fold build1 (addr expr,
build pointer type (char type node),
data));
append to statement list (assign, func);
IF main input filename = "" THEN
finput := stand in
ELIF open (finput, main input filename, stand in channel) /= 0 THEN
put (stand error, ("error: cannot open file ",
main input filename,
newline));
exit (1)
FI;
BOOL eof := FALSE;
append to statement list (read tree (finput, header, deref, eof), func);
close (finput);
varpool finalize decl (header);
varpool finalize decl (data);
set decl artificial (decl, TRUE);
set decl result (decl,
build decl (input location, result decl, null tree,
integer type node));
set tree public (decl, TRUE);
set tree used (decl, TRUE);
set decl saved tree (decl, func);
set decl uninlinable (decl, TRUE);
set tree static (header, TRUE);
set tree static (data, TRUE);
set decl initial (decl, make node (block));
set tree used (data, TRUE);
{ Emit code. }
allocate struct function (decl, FALSE);
current function decl := decl;
gimplify function tree (decl);
cgraph finalize function (decl, TRUE);
cgraph finalize compilation unit
END; { algol68 langhook parse file }
PROC algol68 langhook write globals = VOID:
BEGIN
SKIP
END;
PROC algol68 convert = (TREE type, TREE expr) TREE:
BEGIN
expr
END;
PROC algol68 langhook pushdecl = (TREE decl)TREE:
BEGIN
gcc unreachable;
null tree
END;
PROC algol68 langhook global bindings p = INT:
BEGIN
INT res;
IF tree is null (current function decl) THEN
res := 1
ELSE
res := 0
FI;
res
END;
PROC algol68 langhook type for size = (INT bits, INT unsignedp) TREE:
BEGIN
integer type node
END;
PROC algol68 langhook builtin function = (TREE decl) TREE:
BEGIN
decl
END;
PROC algol68 langhook getdecls = TREE:
BEGIN
null
END;
PROC algol68 langhook type for mode = (MACHINEMODE mode, INT unsignedp) TREE:
BEGIN
TREE res := null tree;
IF get mode class (mode) = mode int THEN
res := integer type node
FI;
res
END;
PROC finish file = VOID:
BEGIN
SKIP
END;
PROC algol68 gimplify expr = (REF TREE expr p,
REF GIMPLESEQ pre p,
REF GIMPLESEQ post p) INT:
{
This hook is called for every GENERIC tree that gets gimplified.
Its purpose is to gimplify language specific trees.
At the moment we are not supporting any Algol 68 specific tree, so
we just return FALSE.
}
BEGIN
0
END;
PROC algol68 printable name = (TREE decl, INT kind) VECTOR[]CHAR:
{
This function shall return the printable name of the
language.
}
BEGIN
Z MAKERVC "algol68"
END
KEEP
algol68 init,
finish file,
algol68 printable name,
algol68 gimplify expr,
algol68 langhook init options,
algol68 langhook handle option,
algol68 langhook post options,
algol68 langhook parse file,
algol68 langhook write globals,
algol68 langhook pushdecl,
algol68 langhook global bindings p,
algol68 langhook type for size,
algol68 langhook builtin function,
algol68 langhook getdecls,
algol68 langhook type for mode,
algol68 convert
FINISH