This is decl.c in view mode; [Download] [Up]
/*
* Copyright (C) 1985-1992 New York University
*
* This file is part of the Ada/Ed-C system. See the Ada/Ed README file for
* warranty (none) and distribution info and also the GNU General Public
* License for more details.
*/
#define GEN
#include "hdr.h"
#include "vars.h"
#include "gvars.h"
#include "ops.h"
#include "setprots.h"
#include "maincaseprots.h"
#include "miscprots.h"
#include "smiscprots.h"
#include "segment.h"
#include "genprots.h"
#include "typeprots.h"
#include "statprots.h"
#include "segmentprots.h"
#include "exprprots.h"
#include "gmiscprots.h"
#include "gutilprots.h"
#include "axqrprots.h"
#include "declprots.h"
static void gen_structured_object(Node, Symbol, int);
void create_object(Tuple id_list_arg, Symbol type_name, Node init_node,
int obj_is_constant) /*;create_object*/
{
/*
* This procedure is used to create objects (const or var).
* id_list is a list (tuple) of name nodes of objects to be created.
* The initialization part cannot have side effect, unless id_list
* contains a single element (transformation by expander)
*
* In order to generate not too bad a code, this procedure is organized
* as a gigantic if ... elseif ... elseif... structure, checking for the
* different configurations. Optimizations may still be added.
*
* The following cases are considered:
*
* 1/ Size of object and initial value are known statically.
* a/ Global object or local constant (promoted to global)
* with static initial value.
* b/ Global object initialized with dynamic value.
* Static part is initialized in data segment.
* c/ Uninitialized global object (variable or deferred
* constant).
* d/ Local constant initialized with dynamic value,
* deferred constant, or local variable.
*
* 2/ Size of object is not known statically
* a/ Global object with variable size (transformed into
* renaming).
* b/ Local array or record with variable size.
*
*/
Node node, id, first_id, last_id, init_call_node, pre_node;
Symbol first_name, obj_name;
int obj_is_global, ikind, i, n;
Fortup ft1;
Segment init_val; /* type should be Ivalue */
Node dyn_node;
Symbol model_name, subtype;
Tuple tup, id_list;
Const ival, small_const;
int special_aggregate;
/* id_list_arg needed since id_list used desctructively 6-25-85 */
id_list = tup_copy(id_list_arg);
#ifdef TRACE
if (debug_flag) {
/*gen_trace("CREATE_OBJECT", id_list);*/
gen_trace("CREATE_OBJECT");
FORTUP(node = (Node), id_list, ft1);
gen_trace_node(" CREATE_OBJECT argument", node);
ENDFORTUP(ft1);
}
#endif
init_val = (Segment)0; /* indicate not yet defined */
obj_is_global = CURRENT_LEVEL == 1;
if (N_KIND(init_node) == as_init_call) {
/* Initialization procedure call */
init_call_node = init_node;
init_node = OPT_NODE;
}
else {
init_call_node = OPT_NODE;
}
while (N_KIND(init_node) == as_insert) {
FORTUP(pre_node = (Node), N_LIST(init_node), ft1);
compile(pre_node);
ENDFORTUP(ft1);
init_node = N_AST1(init_node);
}
if (N_KIND(init_node) == as_raise) {
/* Simplest case, indeed. */
compile(init_node);
init_node = OPT_NODE;
}
if (has_static_size(type_name) && !(is_array_type(type_name)
&&is_unconstrained(type_name))
&& (init_node == OPT_NODE ||has_static_size(get_type(init_node)))) {
/*
* 1- Size of object is known statically(and also size of initial value)
* -------------------------------------
*/
if ((obj_is_global || obj_is_constant) && is_ivalue(init_node)) {
/*
* 1a- Global object or local const (promoted to global)
* with static initial value.
* Generate objects in data seg initialized with value
* Generate only one object for multiple constants.
*/
if (is_fixed_type(type_name)) {
init_val = segment_new(SEGMENT_KIND_DATA, 1);
small_const = small_of(base_type(type_name));
segment_put_long(init_val , rat_tof(get_ivalue(init_node),
small_const, size_of(type_name) ));
}
else if (is_simple_type(type_name)) {
ival = get_ivalue(init_node);
ikind = ival->const_kind;
if(ikind == CONST_INT) {
init_val = segment_new(SEGMENT_KIND_DATA, 1);
segment_put_word(init_val, ival->const_value.const_int);
}
else if(ikind == CONST_REAL) {
init_val = segment_new(SEGMENT_KIND_DATA, 1);
segment_put_real(init_val, ival->const_value.const_real);
}
else {
#ifdef DEBUG
printf("const_kind %d\n", ikind);
#endif
chaos("create_object:unsupported kind");
}
}
else if (is_array_type(type_name)) {
/* build the appropriate vector... */
init_val = array_ivalue(init_node);
}
else if (is_record_type(type_name)) {
init_val = record_ivalue(init_node);
}
else {
compiler_error_k("Unknown type for constant ", init_node);
return;
}
if (obj_is_constant) {
first_name = get_constant_name(init_val);
FORTUP(id = (Node), id_list, ft1);
obj_name = N_UNQ(id);
assign_same_reference(obj_name, first_name);
ENDFORTUP(ft1);
}
else {
FORTUP(id = (Node), id_list, ft1);
obj_name = N_UNQ(id);
next_global_reference_segment(obj_name, init_val);
ENDFORTUP(ft1);
}
}
else if (obj_is_global && init_node != OPT_NODE) {
/*
* 1b- Global object initialized with dynamic value
* Generate first object in data seg with static part
* initialized, compile code to initialize the rest,
* then assign first object to others
*/
if (N_KIND(init_node) == as_array_aggregate) {
init_val = array_ivalue(init_node);
}
else if (N_KIND(init_node) == as_record_aggregate) {
init_val = record_ivalue(init_node);
}
else {
/* TBSL: review translation from SETL */
/* build segment of desired length, initially all zero */
n = size_of(type_name);
init_val = segment_new(SEGMENT_KIND_DATA, n);
for (i = 1; i <= n; i++) {
segment_put_word(init_val, 0);
}
}
FORTUP(id = (Node), id_list, ft1);
obj_name = N_UNQ(id);
next_global_reference_segment(obj_name, init_val);
ENDFORTUP(ft1);
if (is_simple_type(type_name)) {
gen_value(init_node);
last_id = (Node) tup_frome(id_list);
FORTUP(id = (Node), id_list, ft1);
id = (Node) tup_fromb(id_list);
obj_name = (Symbol) N_UNQ(id);
gen_k(I_DUPLICATE, kind_of(type_name));
gen_ks(I_POP, kind_of(type_name), obj_name);
ENDFORTUP(ft1);
obj_name = N_UNQ(last_id);
gen_ks(I_POP, kind_of(type_name), obj_name);
}
else {
first_id = (Node) tup_fromb(id_list);
if (is_aggregate(init_node)) {
init_node = N_AST2(N_AST1(init_node));
compile(init_node);
}
else {
select_assign(first_id, init_node, type_name);
}
FORTUP(id = (Node), id_list, ft1);
select_assign(id, first_id, type_name);
ENDFORTUP(ft1);
}
}
else if (obj_is_global) {
/*
* 1c- Uninitialized global object (Variable or deferred
* constant)
* Generate objects in data segment. If initialization
* procedure, call it on first object, then assign first
* object to others.
*/
/* build a segment, initially all zeros, of desired length */
n = size_of(type_name);
/*
* this is a kludge for deferred const EMPTY in VAR_STRING package.
*/
if (n== 0) n = 3;
init_val = segment_new(SEGMENT_KIND_DATA, n);
for (i = 1; i <= n; i++)
segment_put_word(init_val, 0);
FORTUP(id = (Node), id_list, ft1);
obj_name = N_UNQ(id);
next_global_reference_segment(obj_name, init_val);
ENDFORTUP(ft1);
if (init_call_node != OPT_NODE ) {
compile(init_call_node); /* This initializes 1st object */
first_id = (Node) tup_fromb(id_list);
FORTUP(id = (Node), id_list, ft1); /* Assign it to other objs */
select_assign(id, first_id, type_name);
ENDFORTUP(ft1);
}
}
else {
/*
* 1d- Local constant initialized with dynamic value, deferred
* constant, or local variable, initialized or not.
* Create local references. If no initialization (implicit
* or explicit) create objects, otherwise create and
* initialize first objects, and create copies for others.
*/
FORTUP(id = (Node), id_list, ft1);
next_local_reference(N_UNQ(id));
ENDFORTUP(ft1);
if (is_simple_type(type_name)) {
if (init_node != OPT_NODE) {
gen_value(init_node);
last_id = (Node) tup_frome(id_list);
FORTUP(id = (Node), id_list, ft1);
gen_k(I_DUPLICATE, kind_of(type_name));
gen_k(I_CREATE_COPY, kind_of(type_name));
gen_s(I_UPDATE_AND_DISCARD, N_UNQ(id));
ENDFORTUP(ft1);
gen_k(I_CREATE_COPY, kind_of(type_name));
gen_s(I_UPDATE_AND_DISCARD, N_UNQ(last_id));
}
else{
FORTUP(id = (Node), id_list, ft1);
gen_ks(I_DECLARE, kind_of(type_name), N_UNQ(id));
ENDFORTUP(ft1);
}
}
else { /* Array or record */
if (!local_reference_map_defined(type_name)
&& is_constant (N_UNQ ((Node) set_arb (id_list)))
&& S_SEGMENT(type_name) == -1) {
/* deferred constant: type not elaborated yet */
return;
}
if (init_node != OPT_NODE) {
first_id = (Node) tup_fromb(id_list);
first_name = N_UNQ(first_id);
if (is_aggregate(init_node)) {
/*
* Create a static model containing the static part if
* there is one, then create a copy and initialize
* dynamic part in the copy. Note: the name of the
* aggregate is already first_name.
*/
/*stat_node=N_AST1(init_node); -- not used ds 7-8-85*/
dyn_node = N_AST2(N_AST1(init_node));
/*nam_node=N_AST3(init_node); -- not used ds 7-8-85*/
model_name = new_unique_name("static_");
special_aggregate = FALSE;
/* A special aggregate is an array aggregate whose
* unique name is not defined. In this case we have
* to compile the initialization part of the
* aggregate first : the assignements refer to
* model_name
* This situation occurs when we have an aggregate with
* a qualification that appears as an initiliazation of
* an object. Expand_decl cannot execute the code that
* deals with an aggregate. The qualification is
* removed by the expander and therefore the init part
* is just an aggregate. But the work in expand_decl
* has not be performed...
*/
if (is_array_type(type_name)) {
if (!is_defined (N_UNQ (init_node))) {
special_aggregate = TRUE;
model_name = N_UNQ (init_node);
}
next_global_reference_template(model_name,
array_ivalue(init_node));
}
else {
next_global_reference_template(model_name,
record_ivalue(init_node));
}
if (special_aggregate)
compile(dyn_node);
gen_s(I_PUSH_EFFECTIVE_ADDRESS, model_name);
gen_s(I_PUSH_EFFECTIVE_ADDRESS, type_name);
gen(I_CREATE_COPY_STRUC);
if (is_array_type(type_name))
gen_ks(I_DISCARD_ADDR, 1, type_name);
gen_s(I_UPDATE_AND_DISCARD, first_name);
if (! special_aggregate)
compile(dyn_node);
}
else {
gen_structured_object(init_node, type_name,
obj_is_constant);
if (is_array_type(type_name))
gen_ks(I_DISCARD_ADDR, 1, type_name);
gen_s(I_UPDATE_AND_DISCARD, first_name);
}
if (tup_size(id_list)) {
gen_s(I_PUSH_EFFECTIVE_ADDRESS, first_name);
FORTUP(id = (Node), id_list, ft1);
gen_s(I_PUSH_EFFECTIVE_ADDRESS, type_name);
gen(I_CREATE_COPY_STRUC);
if (is_array_type(type_name)) /* remove type */
gen_ks(I_DISCARD_ADDR, 1, type_name);
gen_s(I_UPDATE, N_UNQ(id));
ENDFORTUP(ft1);
gen_ks(I_DISCARD_ADDR, 1,
N_UNQ((Node) id_list[tup_size(id_list)]));
}
}
else if (init_call_node != OPT_NODE ) {
gen_s(I_PUSH_EFFECTIVE_ADDRESS, type_name);
first_id = (Node) tup_fromb(id_list);
first_name = N_UNQ(first_id);
gen(I_CREATE_STRUC);
if (is_array_type(type_name))
gen_ks(I_DISCARD_ADDR, 1, type_name);
gen_s(I_UPDATE_AND_DISCARD, first_name);
compile(init_call_node); /* First object now initialized */
if (tup_size(id_list)) {
gen_s(I_PUSH_EFFECTIVE_ADDRESS, first_name);
FORTUP(id = (Node), id_list, ft1);
gen_s(I_PUSH_EFFECTIVE_ADDRESS, type_name);
gen(I_CREATE_COPY_STRUC);
if (is_array_type(type_name)) /* remove type */
gen_ks(I_DISCARD_ADDR, 1, type_name);
gen_s(I_UPDATE, N_UNQ(id));
ENDFORTUP(ft1);
gen_ks(I_DISCARD_ADDR, 1,
N_UNQ((Node)id_list[tup_size(id_list)]));
}
}
else { /* Absolutely no initialization */
gen_s(I_PUSH_EFFECTIVE_ADDRESS, type_name);
last_id = (Node) tup_frome(id_list);
FORTUP(id = (Node), id_list, ft1);
obj_name = N_UNQ(id);
gen_k(I_DUPLICATE, mu_addr);
gen(I_CREATE_STRUC);
if (is_array_type(type_name))
gen_ks(I_DISCARD_ADDR, 1, type_name);
gen_s(I_UPDATE_AND_DISCARD, obj_name);
ENDFORTUP(ft1);
obj_name = N_UNQ(last_id);
gen(I_CREATE_STRUC);
if (is_array_type(type_name))
gen_ks(I_DISCARD_ADDR, 1, type_name);
gen_s(I_UPDATE_AND_DISCARD, obj_name);
}
}
}
/* 2- Size of object is not known statically
* -----------------------------------------
* Also some pathological cases where size of initial value is not known
* although size of object is known: V: constrained_type := (F..G => 0);
* No use in optimizing that case: Only JBG can write that.
*/
}
else if (obj_is_global) {
/* 2a- Global object
* Variable size => transformed into renaming
* If initialization, initialize first object and then create
* copies.
*/
if (init_node != OPT_NODE) { /* Explicit initialization */
first_id = (Node) tup_fromb(id_list);
obj_name = N_UNQ(first_id);
next_global_reference_z(obj_name);
#ifdef TBSL
ALIAS(obj_name) = new_unique_name("dyn_global"); /*not used */
#endif
gen_structured_object(init_node, type_name, obj_is_constant);
if (is_array_type(type_name) && is_unconstrained(type_name)) {
/* Completely dynamic unconstrained constant.
* Ex: X: constant STRING := F(..) & V;
*/
subtype = new_unique_name("typeof_");
next_global_reference_z(subtype);
/* Note: no index type list can be given... */
tup = tup_new(2);
tup[1] = (char *) tup_new1((char *) symbol_none);
tup[2] = (char *) COMPONENT_TYPE(type_name);
new_symbol(subtype, na_subtype, type_name,
tup, root_type(type_name));
TYPE_OF(obj_name) = subtype;
type_name = subtype; /* To be used by other obj. */
gen_ks(I_POP, mu_addr, subtype);
gen_ks(I_PUSH, mu_addr, subtype);
}
if (is_record_type(type_name)) {
/* May be useless, but the peep-hole will take care of it */
gen_s(I_PUSH_EFFECTIVE_ADDRESS, type_name);
}
FORTUP(id = (Node), id_list, ft1);
gen_k(I_DUPLICATE, mu_dble);
gen(I_CREATE_COPY_STRUC);
if (is_array_type(type_name))
gen_ks(I_DISCARD_ADDR, 1, type_name);
gen_ks(I_POP, mu_addr, obj_name);
first_id = id;
obj_name = N_UNQ(first_id);
TYPE_OF(obj_name) = type_name; /* May have been changed. */
#ifdef TBSL
ALIAS (obj_name) = new_unique_name("dyn_global"); /*not used */
#endif
ENDFORTUP(ft1);
gen_ks(I_DISCARD_ADDR, 1, type_name);
gen_ks(I_POP, mu_addr, obj_name);
}
else if (init_call_node != OPT_NODE) { /* Implicit initialization */
first_id = (Node) tup_fromb(id_list);
first_name = N_UNQ(first_id);
next_global_reference_z(first_name);
#ifdef TBSL
ALIAS(first_name) = new_unique_name("dyn_global"); /*not used */
#endif
gen_s(I_PUSH_EFFECTIVE_ADDRESS, type_name);
gen(I_CREATE_STRUC);
gen_ks(I_POP, mu_addr, first_name);
compile(init_call_node); /* first object now initialized */
FORTUP(id = (Node), id_list, ft1);
obj_name = N_UNQ(id);
next_global_reference_z(obj_name);
gen_ks(I_PUSH, mu_addr, first_name);
gen_s(I_PUSH_EFFECTIVE_ADDRESS, type_name);
gen(I_CREATE_COPY_STRUC);
if (is_array_type(type_name))
gen_ks(I_DISCARD_ADDR, 1, type_name);
gen_ks(I_POP, mu_addr, obj_name);
#ifdef TBSL
ALIAS(obj_name) = new_unique_name("dyn_global"); /*not used */
#endif
ENDFORTUP(ft1);
}
else { /* No initialization */
last_id = (Node) tup_frome(id_list);
gen_s(I_PUSH_EFFECTIVE_ADDRESS, type_name);
FORTUP(id = (Node), id_list, ft1);
obj_name = N_UNQ(id);
next_global_reference_z(obj_name);
gen_k(I_DUPLICATE, mu_addr);
gen(I_CREATE_STRUC);
gen_ks(I_POP, mu_addr, obj_name);
#ifdef TBSL
ALIAS(obj_name) = new_unique_name("dyn_global"); /*not used */
#endif
ENDFORTUP(ft1);
obj_name = N_UNQ(last_id);
next_global_reference_z(obj_name);
gen(I_CREATE_STRUC);
gen_ks(I_POP, mu_addr, obj_name);
#ifdef TBSL
ALIAS(obj_name) = new_unique_name("dyn_global"); /*not used */
#endif
}
}
else {
/* 2b- Local array or record, variable size
* Create local reference and object.
* TBSL optimization
*/
FORTUP(id = (Node), id_list, ft1);
obj_name = N_UNQ(id);
next_local_reference(obj_name);
if (init_node != OPT_NODE) {
gen_structured_object(init_node, type_name, obj_is_constant);
if (is_array_type(type_name) && is_unconstrained(type_name)) {
/*
* Completely dynamic unconstrained constant.
* Ex: X: constant STRING := F(..) & V;
*/
subtype = new_unique_name("typeof_");
next_local_reference(subtype);
/* Note: no index type list can be given... */
tup = tup_new(2);
tup[1] = (char *) tup_new1((char *) symbol_none);
tup[2] = (char *) COMPONENT_TYPE(type_name);
new_symbol(subtype, na_subtype, type_name,
tup, root_type(type_name));
TYPE_SIZE(subtype) = -1;
TYPE_OF(obj_name) = subtype;
gen_s(I_UPDATE, subtype);
type_name = subtype;
}
}
else {
gen_s(I_PUSH_EFFECTIVE_ADDRESS, type_name);
gen(I_CREATE_STRUC);
}
if (is_array_type(type_name))
gen_ks(I_DISCARD_ADDR, 1, type_name);
gen_s(I_UPDATE_AND_DISCARD, obj_name);
if (init_call_node != OPT_NODE) {
compile(init_call_node);
/* This first object will now serve as initial value for
* other objects
*/
init_node = id;
init_call_node = OPT_NODE;
}
ENDFORTUP(ft1);
}
}
static void gen_structured_object(Node init_node, Symbol type_name,
int obj_is_constant) /*;gen_structured_object*/
{
/*
* This procedure is used in place of GEN_VALUE when it is necessary to
* generate a new object, i.e. making a copy in cases where GEN_VALUE may
* generate the address of an already existing object.
*/
Node expr_node;
Symbol expr_type;
int needs_copy, constrained_obj, val_is_constant, constrained_val;
expr_node = init_node;
expr_type = get_type(init_node);
while (N_KIND(expr_node) == as_qual_discr
|| N_KIND(expr_node) == as_qual_index
|| N_KIND(expr_node) == as_qual_sub) {
expr_node = N_AST1(expr_node);
}
needs_copy = is_object(expr_node) | is_ivalue(expr_node);
gen_value(init_node);
if (needs_copy) {
if (is_record_type(expr_type))
gen_s(I_PUSH_EFFECTIVE_ADDRESS, expr_type);
gen(I_CREATE_COPY_STRUC);
}
if (is_record_type(type_name) ) {/* May need to adjust constrained */
constrained_obj = ! is_unconstrained(type_name) || obj_is_constant;
val_is_constant = is_simple_name(expr_node) &&
(NATURE(N_UNQ(expr_node)) == na_constant);
constrained_val = ! is_unconstrained(expr_type) || val_is_constant;
if (constrained_obj != constrained_val) {
gen_k(I_DUPLICATE, mu_addr);
gen_kic(I_PUSH_IMMEDIATE, kind_of(symbol_boolean),
constrained_obj, "constrained bit");
gen_k(I_MOVE, kind_of(symbol_boolean));
}
}
}
These are the contents of the former NiCE NeXT User Group NeXTSTEP/OpenStep software archive, currently hosted by Netfuture.ch.