mirror of
https://github.com/gcc-mirror/gcc.git
synced 2026-05-06 14:59:39 +02:00
a68: low: modes
Signed-off-by: Jose E. Marchesi <jemarch@gnu.org> gcc/ChangeLog * algol68/a68-low-moids.cc: New file.
This commit is contained in:
Jose E. Marchesi
729
gcc/algol68/a68-low-moids.cc
Normal file
729
gcc/algol68/a68-low-moids.cc
Normal file
@@ -0,0 +1,729 @@
|
||||
/* Lower Algol 68 modes to GCC trees.
|
||||
Copyright (C) 2025 Jose E. Marchesi.
|
||||
|
||||
Written by Jose E. Marchesi.
|
||||
|
||||
GCC 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, or (at your option)
|
||||
any later version.
|
||||
|
||||
GCC 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 GCC; see the file COPYING3. If not see
|
||||
<http://www.gnu.org/licenses/>. */
|
||||
|
||||
#define INCLUDE_MEMORY
|
||||
#include "config.h"
|
||||
#include "system.h"
|
||||
#include "coretypes.h"
|
||||
#include "stringpool.h"
|
||||
#include "tree.h"
|
||||
|
||||
#include "tree.h"
|
||||
#include "fold-const.h"
|
||||
#include "diagnostic.h"
|
||||
#include "langhooks.h"
|
||||
#include "tm.h"
|
||||
#include "function.h"
|
||||
#include "toplev.h"
|
||||
#include "varasm.h"
|
||||
#include "predict.h"
|
||||
#include "stor-layout.h"
|
||||
#include "print-tree.h"
|
||||
|
||||
#include "a68.h"
|
||||
|
||||
static tree a68_lower_mode (MOID_T *m);
|
||||
|
||||
/*
|
||||
* Support routines and definitions.
|
||||
*/
|
||||
|
||||
/* Build a stub TYPE_DECL for a given TYPE.
|
||||
|
||||
This is used for TYPE_STUB_DECL so we can generate debug info for all our
|
||||
modes, so the TYPE_DECL has no name. */
|
||||
|
||||
static void
|
||||
build_stub_type_decl (tree type, tree context)
|
||||
{
|
||||
if (TYPE_STUB_DECL (type))
|
||||
return;
|
||||
|
||||
tree decl = build_decl (UNKNOWN_LOCATION,
|
||||
TYPE_DECL,
|
||||
NULL_TREE /* name */,
|
||||
type);
|
||||
TREE_PUBLIC (decl) = 1;
|
||||
DECL_CONTEXT (decl) = context;
|
||||
TYPE_CONTEXT (type) = DECL_CONTEXT (decl);
|
||||
TYPE_NAME (type) = decl; /* Weird. This is for typedefs! */
|
||||
TYPE_STUB_DECL (type) = decl;
|
||||
}
|
||||
|
||||
/* Builds a record type whose name is NAME. NFIELDS is the number of fields,
|
||||
provided as field ident/type pairs.
|
||||
|
||||
This code is copied from the D front end. */
|
||||
|
||||
static tree
|
||||
make_struct_type (tree type, const char *name, int nfields, ...)
|
||||
{
|
||||
tree fields = NULL_TREE;
|
||||
va_list ap;
|
||||
|
||||
va_start (ap, nfields);
|
||||
|
||||
for (int i = 0; i < nfields; i++)
|
||||
{
|
||||
tree ident = va_arg (ap, tree);
|
||||
tree type = va_arg (ap, tree);
|
||||
tree field = build_decl (BUILTINS_LOCATION, FIELD_DECL, ident, type);
|
||||
DECL_CHAIN (field) = fields;
|
||||
fields = field;
|
||||
}
|
||||
|
||||
va_end (ap);
|
||||
|
||||
if (type == NULL_TREE)
|
||||
type = make_node (RECORD_TYPE);
|
||||
finish_builtin_struct (type, name, fields, NULL_TREE);
|
||||
|
||||
return type;
|
||||
}
|
||||
|
||||
/* Iterate over all the field selectors FIELDS of a structure type and add them
|
||||
as fields to CONTEXT. Returns the number of field selectors found. */
|
||||
|
||||
static size_t
|
||||
chain_struct_fields (PACK_T *fields, tree context)
|
||||
{
|
||||
PACK_T *elem;
|
||||
size_t num_fields;
|
||||
|
||||
for (num_fields = 0, elem = fields;
|
||||
elem != NO_PACK;
|
||||
FORWARD (elem), ++num_fields)
|
||||
{
|
||||
const char *field_name = TEXT (elem);
|
||||
MOID_T *field_mode = MOID (elem);
|
||||
tree field_type = a68_lower_mode (field_mode);
|
||||
|
||||
/* Create the field declaration.
|
||||
The declaration is not a compiler-generated entity.
|
||||
Do not ignore the declaration for symbolic debug purposes. */
|
||||
tree field_decl = build_decl ((NODE (field_mode)
|
||||
? a68_get_node_location (NODE (field_mode))
|
||||
: UNKNOWN_LOCATION),
|
||||
FIELD_DECL,
|
||||
field_name ? get_identifier (field_name) : NULL_TREE,
|
||||
field_type);
|
||||
DECL_ARTIFICIAL (field_decl) = 0;
|
||||
DECL_IGNORED_P (field_decl) = 0;
|
||||
|
||||
/* If the mode of the field is not a ref then references to the field
|
||||
cannot appear in a LHS of an assignment. */
|
||||
TREE_READONLY (field_decl) = IS_REF (field_mode);
|
||||
|
||||
/* Associate the tree field declaration and the front end node. */
|
||||
DECL_LANG_SPECIFIC (field_decl) =
|
||||
(NODE (field_mode) ? a68_build_lang_decl (NODE (field_mode)) : NULL);
|
||||
|
||||
/* Chain the field declaration in its containing context. */
|
||||
DECL_FIELD_CONTEXT (field_decl) = context;
|
||||
TYPE_FIELDS (context) = chainon (TYPE_FIELDS (context), field_decl);
|
||||
}
|
||||
|
||||
return num_fields;
|
||||
}
|
||||
|
||||
/* If the union or struct type TYPE completes the type of any previous field
|
||||
declarations, lay them out now. */
|
||||
|
||||
static void
|
||||
finish_incomplete_fields (tree type)
|
||||
{
|
||||
for (tree fwdref = TYPE_FORWARD_REFERENCES (type); fwdref != NULL_TREE;
|
||||
fwdref = TREE_CHAIN (fwdref))
|
||||
{
|
||||
tree field = TREE_VALUE (fwdref);
|
||||
tree struct_or_union_type = DECL_FIELD_CONTEXT (field);
|
||||
|
||||
relayout_decl (field);
|
||||
bool type_complete = true;
|
||||
for (tree field = TYPE_FIELDS (struct_or_union_type);
|
||||
field;
|
||||
field = DECL_CHAIN (field))
|
||||
{
|
||||
if (!COMPLETE_TYPE_P (TREE_TYPE (field)))
|
||||
{
|
||||
type_complete = false;
|
||||
break;
|
||||
}
|
||||
}
|
||||
|
||||
if (type_complete)
|
||||
{
|
||||
// XXX why this fires
|
||||
// gcc_assert (!COMPLETE_TYPE_P (struct_or_union_type));
|
||||
layout_type (struct_or_union_type);
|
||||
/* Set the back-end type mode now that all fields have had their size
|
||||
set. */
|
||||
compute_record_mode (struct_or_union_type);
|
||||
}
|
||||
};
|
||||
|
||||
/* No more forward references to process. */
|
||||
TYPE_FORWARD_REFERENCES (type) = NULL_TREE;
|
||||
}
|
||||
|
||||
/*
|
||||
* Mode lowering routines.
|
||||
*/
|
||||
|
||||
/* Lower a HIP mode to a GENERIC tree.
|
||||
HIP is the mode of NIL. */
|
||||
|
||||
static tree
|
||||
lower_hip_mode (MOID_T *m)
|
||||
{
|
||||
static tree hip_type;
|
||||
|
||||
if (hip_type == NULL)
|
||||
{
|
||||
hip_type = build_pointer_type (a68_void_type);
|
||||
TYPE_LANG_SPECIFIC (hip_type) = a68_build_lang_type (m);
|
||||
CTYPE (m) = hip_type;
|
||||
}
|
||||
|
||||
return hip_type;
|
||||
}
|
||||
|
||||
/* Lower a standard mode to a GENERIC tree.
|
||||
|
||||
Note that this function only has to handle the standard modes that have not
|
||||
been resolved to some equivalent. */
|
||||
|
||||
static tree
|
||||
lower_standard_mode (MOID_T *m)
|
||||
{
|
||||
tree type = NULL_TREE;
|
||||
|
||||
if (m == M_VOID)
|
||||
type = a68_void_type;
|
||||
else if (m == M_BOOL)
|
||||
type = a68_bool_type;
|
||||
else if (m == M_CHAR)
|
||||
type = a68_char_type;
|
||||
else if (m == M_SHORT_SHORT_INT)
|
||||
type = a68_short_short_int_type;
|
||||
else if (m == M_SHORT_INT)
|
||||
type = a68_short_int_type;
|
||||
else if (m == M_INT)
|
||||
type = a68_int_type;
|
||||
else if (m == M_LONG_INT)
|
||||
type = a68_long_int_type;
|
||||
else if (m == M_LONG_LONG_INT)
|
||||
type = a68_long_long_int_type;
|
||||
else if (m == M_REAL)
|
||||
type = a68_real_type;
|
||||
else if (m == M_LONG_REAL)
|
||||
type = a68_long_real_type;
|
||||
else if (m == M_LONG_LONG_REAL)
|
||||
type = a68_long_long_real_type;
|
||||
else if (m == M_SHORT_SHORT_BITS)
|
||||
type = a68_short_short_bits_type;
|
||||
else if (m == M_SHORT_BITS)
|
||||
type = a68_short_bits_type;
|
||||
else if (m == M_BITS)
|
||||
type = a68_bits_type;
|
||||
else if (m == M_LONG_BITS)
|
||||
type = a68_long_bits_type;
|
||||
else if (m == M_LONG_LONG_BITS)
|
||||
type = a68_long_long_bits_type;
|
||||
else if (m == M_BYTES)
|
||||
type = a68_bytes_type;
|
||||
else if (m == M_LONG_BYTES)
|
||||
type = a68_long_bytes_type;
|
||||
else if (m == M_FILE)
|
||||
/* XXX for now this is a file descriptor. */
|
||||
type = integer_type_node;
|
||||
else if (m == M_CHANNEL)
|
||||
/* XXX for now this is a channel descriptor. */
|
||||
type = integer_type_node;
|
||||
else
|
||||
gcc_unreachable ();
|
||||
|
||||
TYPE_LANG_SPECIFIC (type) = a68_build_lang_type (m);
|
||||
return type;
|
||||
}
|
||||
|
||||
/* Lower a struct mode to a GENERIC tree. */
|
||||
|
||||
static tree
|
||||
lower_struct_mode (MOID_T *m)
|
||||
{
|
||||
/* First make the GENERIC struct. This is needed in case of
|
||||
self-references. */
|
||||
tree struct_type = make_node (RECORD_TYPE);
|
||||
TYPE_NAME (struct_type) = get_identifier ("lalastruct%");
|
||||
TYPE_FIELDS (struct_type) = NULL_TREE;
|
||||
TYPE_CXX_ODR_P (struct_type) = 0;
|
||||
CTYPE (m) = struct_type;
|
||||
TYPE_LANG_SPECIFIC (struct_type) = a68_build_lang_type (m); /* XXX this will get overrided. */
|
||||
|
||||
/* Add field declarations. */
|
||||
chain_struct_fields (PACK (m), struct_type);
|
||||
|
||||
/* Layout all fields. */
|
||||
bool struct_type_complete = true;
|
||||
for (tree field = TYPE_FIELDS (struct_type); field; field = DECL_CHAIN (field))
|
||||
{
|
||||
tree basetype = TREE_TYPE (field);
|
||||
|
||||
if (!COMPLETE_TYPE_P (basetype))
|
||||
{
|
||||
tree field_type = TREE_TYPE (field);
|
||||
tree forward_refs = tree_cons (NULL_TREE, field,
|
||||
TYPE_FORWARD_REFERENCES (field_type));
|
||||
TYPE_FORWARD_REFERENCES (struct_type) = forward_refs;
|
||||
|
||||
struct_type_complete = false;
|
||||
continue;
|
||||
}
|
||||
|
||||
layout_decl (field, 0);
|
||||
gcc_assert (DECL_SIZE (field) != NULL_TREE);
|
||||
}
|
||||
|
||||
/* If all fields have complete types then we can layout the struct type now.
|
||||
Otherwise it will be done in finish_incomplete_types. */
|
||||
if (struct_type_complete)
|
||||
{
|
||||
layout_type (struct_type);
|
||||
/* Set the back-end type mode now that all fields have had their size
|
||||
set. */
|
||||
compute_record_mode (struct_type);
|
||||
}
|
||||
|
||||
/* Finish debugging output for this type. */
|
||||
build_stub_type_decl (struct_type, NULL_TREE /* context */);
|
||||
rest_of_type_compilation (struct_type, TYPE_FILE_SCOPE_P (struct_type));
|
||||
rest_of_decl_compilation (TYPE_NAME (struct_type), 1 /* file scope p */, 0);
|
||||
A68_STRUCT_TYPE_P (struct_type) = 1;
|
||||
return struct_type;
|
||||
}
|
||||
|
||||
/* Lower a ref mode to a GENERIC tree.
|
||||
REF AMODE lowers to a pointer. */
|
||||
|
||||
static tree
|
||||
lower_ref_mode (MOID_T *m)
|
||||
{
|
||||
return build_pointer_type (a68_lower_mode (SUB (m)));
|
||||
}
|
||||
|
||||
/* Lower a flex mode to a GENERIC tree. */
|
||||
|
||||
static tree
|
||||
lower_flex_mode (MOID_T *m)
|
||||
{
|
||||
/* This is basically a qualifier of the parent REF. */
|
||||
return a68_lower_mode (SUB (m));
|
||||
}
|
||||
|
||||
/* Lower a proc mode to a GENERIC tree. */
|
||||
|
||||
static tree
|
||||
lower_proc_mode (MOID_T *m)
|
||||
{
|
||||
tree fnargs = NULL_TREE;
|
||||
tree ret_type;
|
||||
|
||||
/* We have to create the function type in advance because it can appear
|
||||
recursively as the type of arguments and/or of the return value. We
|
||||
cannot use build_function_type, as it doesn't support recursive types. */
|
||||
tree function_type = make_node (FUNCTION_TYPE);
|
||||
tree ptr_function_type = build_pointer_type (function_type);
|
||||
CTYPE (m) = ptr_function_type;
|
||||
|
||||
/* Now add arguments and return value types. */
|
||||
for (PACK_T *p = PACK (m); p != NO_PACK; FORWARD (p))
|
||||
{
|
||||
tree arg_type = a68_lower_mode (MOID (p));
|
||||
fnargs = chainon (fnargs, build_tree_list (0, arg_type));
|
||||
}
|
||||
ret_type = a68_lower_mode (SUB (m));
|
||||
|
||||
/* Complete the function type. Note that there is some code duplication with
|
||||
build_function_type, which we cannot use, but such is life. */
|
||||
TREE_TYPE (function_type) = ret_type; /* THIS */
|
||||
TYPE_ARG_TYPES (function_type) = fnargs;
|
||||
SET_TYPE_STRUCTURAL_EQUALITY (function_type);
|
||||
|
||||
if (!COMPLETE_TYPE_P (function_type))
|
||||
layout_type (function_type);
|
||||
|
||||
return ptr_function_type;
|
||||
}
|
||||
|
||||
/* Lower an union mode to a GENERIC tree.
|
||||
|
||||
overhead% Characterizes the actual mode of the value.
|
||||
value% GENERIC union. */
|
||||
|
||||
static tree
|
||||
lower_union_mode (MOID_T *m)
|
||||
{
|
||||
// XXX make the union type QUAL_UNION_TYPE and relate the fields with the
|
||||
// overhead%. This is necessary for DWARF.
|
||||
tree union_type = make_node (RECORD_TYPE);
|
||||
TYPE_NAME (union_type) = NULL_TREE;
|
||||
TYPE_FIELDS (union_type) = NULL_TREE;
|
||||
TYPE_CXX_ODR_P (union_type) = 0;
|
||||
CTYPE (m) = union_type;
|
||||
|
||||
/* Then the GENERIC union. */
|
||||
tree c_union_type = make_node (UNION_TYPE);
|
||||
TYPE_NAME (c_union_type) = NULL_TREE;
|
||||
TYPE_FIELDS (c_union_type) = NULL_TREE;
|
||||
TYPE_CXX_ODR_P (c_union_type) = 0; // XXX otherwise lto complains. why.
|
||||
SET_TYPE_STRUCTURAL_EQUALITY (c_union_type);
|
||||
|
||||
/* Add field declarations. */
|
||||
chain_struct_fields (PACK (m), c_union_type);
|
||||
|
||||
/* Layout all fields now the type is complete. */
|
||||
bool c_union_type_complete = true;
|
||||
for (tree field = TYPE_FIELDS (c_union_type); field; field = DECL_CHAIN (field))
|
||||
{
|
||||
tree field_type = TREE_TYPE (field);
|
||||
|
||||
if (!COMPLETE_TYPE_P (field_type))
|
||||
{
|
||||
tree field_type = TREE_TYPE (field);
|
||||
tree forward_refs = tree_cons (NULL_TREE, field,
|
||||
TYPE_FORWARD_REFERENCES (field_type));
|
||||
TYPE_FORWARD_REFERENCES (c_union_type) = forward_refs;
|
||||
|
||||
c_union_type_complete = false;
|
||||
continue;
|
||||
}
|
||||
|
||||
layout_decl (field, 0);
|
||||
gcc_assert (DECL_SIZE (field) != NULL_TREE);
|
||||
}
|
||||
|
||||
/* If all fields have complete types then we can layout the c-union type now.
|
||||
Otherwise it will be done in finish_incomplete_types. */
|
||||
if (c_union_type_complete)
|
||||
{
|
||||
layout_type (c_union_type);
|
||||
/* Set the back-end type mode now that all fields have had their size
|
||||
set. */
|
||||
compute_record_mode (c_union_type);
|
||||
}
|
||||
|
||||
/* Finish debugging output for this type. */
|
||||
build_stub_type_decl (c_union_type, NULL_TREE /* context */);
|
||||
rest_of_type_compilation (c_union_type, TYPE_FILE_SCOPE_P (c_union_type));
|
||||
rest_of_decl_compilation (TYPE_NAME (c_union_type), 1 /* file scope p */, 0);
|
||||
|
||||
/* Now the type with the overhead. */
|
||||
TYPE_NAME (union_type) = get_identifier ("union%");
|
||||
tree overhead_field = build_decl (UNKNOWN_LOCATION, FIELD_DECL,
|
||||
get_identifier ("overhead%"), sizetype);
|
||||
tree value_field = build_decl (UNKNOWN_LOCATION, FIELD_DECL,
|
||||
get_identifier ("value%"), c_union_type);
|
||||
DECL_FIELD_CONTEXT (overhead_field) = union_type;
|
||||
DECL_FIELD_CONTEXT (value_field) = union_type;
|
||||
DECL_CHAIN (value_field) = NULL_TREE;
|
||||
DECL_CHAIN (overhead_field) = value_field;
|
||||
TYPE_FIELDS (union_type) = overhead_field;
|
||||
|
||||
if (c_union_type_complete)
|
||||
{
|
||||
layout_type (union_type);
|
||||
/* Set the back-end type mode now that all fields have had their size
|
||||
set. */
|
||||
compute_record_mode (union_type);
|
||||
}
|
||||
else
|
||||
{
|
||||
tree forward_refs = tree_cons (NULL_TREE, value_field,
|
||||
TYPE_FORWARD_REFERENCES (union_type));
|
||||
TYPE_FORWARD_REFERENCES (union_type) = forward_refs;
|
||||
}
|
||||
|
||||
SET_TYPE_STRUCTURAL_EQUALITY (union_type);
|
||||
A68_UNION_TYPE_P (union_type) = 1;
|
||||
return union_type;
|
||||
}
|
||||
|
||||
/* Return the type for an array descriptor triplet. */
|
||||
|
||||
tree
|
||||
a68_triplet_type (void)
|
||||
{
|
||||
static tree triplet_type = NULL_TREE;
|
||||
if (triplet_type == NULL_TREE)
|
||||
{
|
||||
triplet_type = make_struct_type (NULL_TREE, "triplet%", 3,
|
||||
get_identifier ("lb%"),
|
||||
ssizetype,
|
||||
get_identifier ("ub%"),
|
||||
ssizetype,
|
||||
get_identifier ("stride%"),
|
||||
sizetype);
|
||||
}
|
||||
|
||||
return triplet_type;
|
||||
}
|
||||
|
||||
/* Return the lower bound field in an array descriptor triplet. */
|
||||
|
||||
tree
|
||||
a68_triplet_type_lower_bound (tree triplet)
|
||||
{
|
||||
tree lb_field = TYPE_FIELDS (triplet);
|
||||
return lb_field;
|
||||
}
|
||||
|
||||
/* Lower a row mode to a GENERIC tree.
|
||||
|
||||
descriptor%
|
||||
triplets% Value of ARRAY_TYPE with an entry per multiple dimension.
|
||||
{
|
||||
li% Lower bound of dimension.
|
||||
ui% Upper bound of dimension.
|
||||
di% Stride of dimension in bytes.
|
||||
}
|
||||
elements% Pointer to the elements.
|
||||
elements_size% Size of elements% in bytes.
|
||||
*/
|
||||
|
||||
static tree
|
||||
lower_row_mode (MOID_T *m)
|
||||
{
|
||||
int num_dimensions = DIM (m);
|
||||
tree triplet_type = a68_triplet_type ();
|
||||
tree triplets_type = build_array_type (triplet_type,
|
||||
build_index_type (size_int (num_dimensions - 1)));
|
||||
tree element_type = a68_lower_mode (SUB (m));
|
||||
tree row_type = make_struct_type (NULL_TREE, "row%", 3,
|
||||
get_identifier ("triplets%"),
|
||||
triplets_type,
|
||||
get_identifier ("elements%"),
|
||||
build_pointer_type (element_type),
|
||||
get_identifier ("elements_size%"),
|
||||
sizetype);
|
||||
layout_type (row_type);
|
||||
A68_ROW_TYPE_P (row_type) = 1;
|
||||
return row_type;
|
||||
}
|
||||
|
||||
/* Given a row type, return the type of the pointer to its elements. */
|
||||
|
||||
tree
|
||||
a68_row_elements_pointer_type (tree type)
|
||||
{
|
||||
gcc_assert (A68_ROW_TYPE_P (type));
|
||||
/* elements% is the second field. */
|
||||
return TREE_TYPE (TREE_CHAIN (TYPE_FIELDS (type)));
|
||||
}
|
||||
|
||||
/* Given a row type, return the type of its elements. */
|
||||
|
||||
tree
|
||||
a68_row_elements_type (tree type)
|
||||
{
|
||||
return TREE_TYPE (a68_row_elements_pointer_type (type));
|
||||
}
|
||||
|
||||
/* Lower a ROWS mode to a GENERIC tree.
|
||||
|
||||
dim% Number of dimensions.
|
||||
triplets% Pointer to triplets.
|
||||
|
||||
Values of this mode are passed to the operators UPB, LWB and ELEMS, which
|
||||
need only descriptor information. There is no need to store any multiple
|
||||
elements. */
|
||||
|
||||
static tree
|
||||
lower_rows_mode (MOID_T *m ATTRIBUTE_UNUSED)
|
||||
{
|
||||
static tree rows_type = NULL_TREE;
|
||||
|
||||
if (rows_type == NULL_TREE)
|
||||
{
|
||||
rows_type = make_struct_type (NULL_TREE, "rows%", 2,
|
||||
get_identifier ("dim%"),
|
||||
sizetype,
|
||||
get_identifier ("triplets%"),
|
||||
build_pointer_type (a68_triplet_type ()));
|
||||
A68_ROWS_TYPE_P (rows_type) = 1;
|
||||
}
|
||||
return rows_type;
|
||||
}
|
||||
|
||||
/* Lower modes in a series. This is used as the mode of the mode yielded by an
|
||||
enclosed clause that yields a series of united rows, for M_ROWS. */
|
||||
|
||||
static tree
|
||||
lower_series (MOID_T *m)
|
||||
{
|
||||
for (PACK_T *p = PACK (m); p != NO_PACK; FORWARD (p))
|
||||
{
|
||||
if (IS (MOID (p), SERIES_MODE) || IS (MOID (p), STOWED_MODE))
|
||||
lower_series (MOID (p));
|
||||
else
|
||||
(void) a68_lower_mode (MOID (p));
|
||||
}
|
||||
|
||||
return lower_rows_mode (NO_MOID);
|
||||
}
|
||||
|
||||
/* Lower a mode to a GENERIC tree. */
|
||||
|
||||
static tree
|
||||
a68_lower_mode (MOID_T *m)
|
||||
{
|
||||
tree type = NULL_TREE;
|
||||
|
||||
/* If the given mode has already been lowered, return the corresponding
|
||||
tree. */
|
||||
if (CTYPE (m) != NULL)
|
||||
return CTYPE (m);
|
||||
|
||||
if (EQUIVALENT (m) != NO_MOID && EQUIVALENT (m) != m)
|
||||
/* This covers INDICANTs and standard MOIDS having an equivalent mode. */
|
||||
type = a68_lower_mode (EQUIVALENT (m));
|
||||
else if (m == M_VOID)
|
||||
type = a68_void_type;
|
||||
else if (m == M_HIP)
|
||||
type = lower_hip_mode (m);
|
||||
else if (IS (m, STANDARD))
|
||||
type = lower_standard_mode (m);
|
||||
else if (IS_REF (m))
|
||||
type = lower_ref_mode (m);
|
||||
else if (IS_FLEX (m))
|
||||
type = lower_flex_mode (m);
|
||||
else if (IS (m, PROC_SYMBOL))
|
||||
type = lower_proc_mode (m);
|
||||
else if (IS_STRUCT (m))
|
||||
type = lower_struct_mode (m);
|
||||
else if (IS_ROW (m))
|
||||
type = lower_row_mode (m);
|
||||
else if (IS_UNION (m))
|
||||
type = lower_union_mode (m);
|
||||
else if (m == M_SIMPLOUT || m == M_SIMPLIN)
|
||||
type = a68_void_type;
|
||||
else if (IS (m, ROWS_SYMBOL))
|
||||
/* ROWS is a mode that means "any row mode". */
|
||||
type = lower_rows_mode (m);
|
||||
else if (m == M_VACUUM)
|
||||
/* This is a mode that should not survive the parser. */
|
||||
type = a68_void_type;
|
||||
else if (IS (m, SERIES_MODE) || IS (m, STOWED_MODE))
|
||||
{
|
||||
/* When dealing with operators the parser creates some modes that leak
|
||||
SERIES and STOWED "proto-modes" in them, such as for example:
|
||||
|
||||
UNION ((INT, INT), INT, PROC [] CHAR)
|
||||
|
||||
These are not really real Algol 68 modes and are useless by
|
||||
themselves, so when we find them, we traverse them (they ultimately
|
||||
contain valid modes that may show up in other contexts and that
|
||||
require being lowered) and just report them as VOID. */
|
||||
type = lower_series (m);
|
||||
}
|
||||
else
|
||||
{
|
||||
fatal_error (NODE (m) ? a68_get_node_location (NODE (m)) : UNKNOWN_LOCATION,
|
||||
"Cannot lower mode %s",
|
||||
a68_moid_to_string (m, MOID_ERROR_WIDTH, NODE (m)));
|
||||
}
|
||||
|
||||
/* Associate the created tree node with the mode, and vice-versa. */
|
||||
gcc_assert (type != NULL_TREE);
|
||||
TYPE_LANG_SPECIFIC (type) = a68_build_lang_type (m);
|
||||
A68_TYPE_HAS_ROWS_P (type) = HAS_ROWS (m);
|
||||
if (CTYPE (m) == NULL_TREE)
|
||||
CTYPE (m) = type;
|
||||
// printf ("DONE LOWERING %s\n", a68_moid_to_string (m, MOID_ERROR_WIDTH, NODE (m)));
|
||||
return type;
|
||||
}
|
||||
|
||||
/* Lower MOIDs to GENERIC trees. */
|
||||
|
||||
void
|
||||
a68_lower_moids (MOID_T *mode)
|
||||
{
|
||||
/* First pass: all modes but refs. */
|
||||
for (MOID_T *m = mode; m != NO_MOID; FORWARD (m))
|
||||
(void) a68_lower_mode (m);
|
||||
|
||||
/* Try to layout all incomplete types. This is a two-passes process. */
|
||||
|
||||
for (MOID_T *m = mode; m != NO_MOID; FORWARD (m))
|
||||
{
|
||||
if (IS_STRUCT (m))
|
||||
{
|
||||
tree struct_type = CTYPE (m);
|
||||
finish_incomplete_fields (struct_type);
|
||||
}
|
||||
else if (IS_UNION (m))
|
||||
{
|
||||
tree union_type = CTYPE (m);
|
||||
tree c_union_type = TREE_TYPE (TREE_CHAIN (TYPE_FIELDS (union_type)));
|
||||
finish_incomplete_fields (c_union_type);
|
||||
finish_incomplete_fields (union_type);
|
||||
}
|
||||
}
|
||||
|
||||
for (MOID_T *m = mode; m != NO_MOID; FORWARD (m))
|
||||
{
|
||||
if (!COMPLETE_TYPE_P (CTYPE (m)))
|
||||
{
|
||||
if (IS_STRUCT (m))
|
||||
{
|
||||
tree struct_type = CTYPE (m);
|
||||
layout_type (struct_type);
|
||||
compute_record_mode (struct_type);
|
||||
}
|
||||
else if (IS_UNION (m))
|
||||
{
|
||||
tree union_type = CTYPE (m);
|
||||
tree c_union_type = TREE_TYPE (TREE_CHAIN (TYPE_FIELDS (union_type)));
|
||||
|
||||
if (!COMPLETE_TYPE_P (c_union_type))
|
||||
{
|
||||
layout_type (c_union_type);
|
||||
compute_record_mode (c_union_type);
|
||||
}
|
||||
|
||||
layout_type (union_type);
|
||||
compute_record_mode (union_type);
|
||||
}
|
||||
else
|
||||
layout_type (CTYPE (m));
|
||||
}
|
||||
}
|
||||
|
||||
/* Sanity check. */
|
||||
for (MOID_T *m = mode; m != NO_MOID; FORWARD (m))
|
||||
{
|
||||
gcc_assert (COMPLETE_TYPE_P (CTYPE (m)));
|
||||
if (IS_UNION (m))
|
||||
{
|
||||
tree union_type = CTYPE (m);
|
||||
tree c_union_type = TREE_TYPE (TREE_CHAIN (TYPE_FIELDS (union_type)));
|
||||
gcc_assert (COMPLETE_TYPE_P (c_union_type));
|
||||
}
|
||||
}
|
||||
}
|
||||
Reference in New Issue
Block a user