This is 12a.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.
*/
/* chapter 12 - part a*/
#include "hdr.h"
#include "vars.h"
#include "libhdr.h"
#include "attr.h"
#include "unitsprots.h"
#include "errmsgprots.h"
#include "miscprots.h"
#include "smiscprots.h"
#include "setprots.h"
#include "libprots.h"
#include "dclmapprots.h"
#include "nodesprots.h"
#include "chapprots.h"
static Tuple collect_generic_formals(Node);
static void add_implicit_neq(Tuple, Node, Symbol);
static void bind_names(Node);
void generic_subprog_spec(Node node) /*;generic_subprog_spec*/
{
int nat, kind, i;
Node id_node, generic_part_node, ret_node, formals_list;
int f_mode, body_number;
char *obj_id;
Symbol gen_name, form_name, scope;
Tuple gen_list, form_list;
Tuple tup;
Node formal_node, id_list, m_node, type_node, exp_node, init_node;
Symbol type_mark;
Tuple f_ids;
char *id;
Fortup ft1, ft2;
/*
* Build specifications of a generic subprogram. We create a scope for
* it, and define within the names of generics and formal parameters.
* The signature of the generic subprogram includes the generic parameter
* list and the formals. These two are unpacked during instantiation.
*/
if (cdebug2 > 3)
TO_ERRFILE("AT PROC : generic_subprog_spec ");
id_node = N_AST1(node);
generic_part_node = N_AST2(node);
formals_list = N_AST3(node);
ret_node = N_AST4(node);
kind = N_KIND(node);
obj_id = N_VAL(id_node);
new_compunit("ss", id_node);
if (IS_COMP_UNIT) {
/* allocate unit number for body, and mark it obsolete */
body_number = unit_number(strjoin("su", obj_id));
pUnits[body_number]->libInfo.obsolete = string_ds; /*"$D$"*/
}
gen_name = find_new(obj_id);
N_UNQ(id_node) = gen_name;
DECLARED(gen_name) = dcl_new(0);
NATURE(gen_name) = na_generic_part;
formal_decl_tree(gen_name) = (Symbol) formals_list;
newscope(gen_name);
adasem(generic_part_node);
gen_list = collect_generic_formals(generic_part_node);
/*
* Now declared(gen_name) contains the generic parameters: types,
* objects and subprograms.
*
* For the formal parameters, we simply must recognize their names
* and types. Type checking on initialization is repeated on
* instantiation.
*/
NATURE(gen_name) = na_void; /* To catch premature usage. */
form_list = tup_new(0);
FORTUP(formal_node =(Node), N_LIST(formals_list), ft1);
id_list = N_AST1(formal_node);
m_node = N_AST2(formal_node);
type_node = N_AST3(formal_node);
exp_node = N_AST4(formal_node);
type_mark = find_type(copy_tree(type_node));
if (exp_node != OPT_NODE) {
adasem(exp_node);
init_node = copy_tree(exp_node);
normalize(type_mark, init_node);
}
else init_node = OPT_NODE;
current_node = formal_node;
f_ids = tup_new(tup_size(N_LIST(id_list)));
FORTUPI(id_node=(Node), N_LIST(id_list), i, ft2);
f_ids[i] = N_VAL(id_node);
ENDFORTUP(ft2);
f_mode = (int) N_VAL(m_node);
if (f_mode == 0 ) f_mode = na_in;
FORTUP(id=, f_ids, ft2);
form_name = find_new(id);
NATURE(form_name) = f_mode;
TYPE_OF(form_name) = type_mark;
default_expr(form_name) = (Tuple) copy_tree(init_node);
form_list = tup_with(form_list, (char *) form_name);
ENDFORTUP(ft2);
if (f_mode != na_in && kind == as_generic_function) {
#ifdef ERRNUM
l1_errmsgn(nature_str(f_mode),31, 32, formal_node);
#else
errmsg_l(nature_str(f_mode),
" parameter not allowed for functions", "6.5", formal_node);
#endif
}
/* enforce restrictions on usage of out formal parameters given in
* LRM 7.4.4
*/
scope = SCOPE_OF(type_mark);
nat = NATURE(scope);
if (f_mode != na_out || is_access(type_mark))
continue;
else if (TYPE_OF(type_mark) == symbol_limited_private
&& (nat == na_package_spec || nat == na_generic_package_spec
|| nat == na_generic_part )
&& !in_private_part(scope)
&& tup_mem((char *)scope, open_scopes) ) {
/* We are in the visible part of the package that declares
* the type. Its full decl. will have to be given with an
* assignable type.
*/
misc_type_attributes(type_mark) =
(misc_type_attributes(type_mark)) | TA_OUT;
}
else if (is_limited_type(type_mark)) {
#ifdef ERRNUM
id_errmsgn(33, type_mark, 34, formal_node);
#else
errmsg_id("Invalid use of limited type % for out parameter ",
type_mark, "7.4.4", formal_node);
#endif
}
ENDFORTUP(ft1);
/*
* Save signature of generic object, in the format which the
* instantiation procedure requires.
*/
NATURE(gen_name) =
(kind == as_generic_procedure) ? na_generic_procedure_spec
: na_generic_function_spec;
tup = tup_new(4);
tup[1] = (char *) gen_list;
tup[2] = (char *) form_list;
tup[3] = (char *) OPT_NODE;
tup[4] = (char *) tup_new(0);
SIGNATURE(gen_name) = tup;
if (kind == as_generic_function) {
find_old(ret_node);
TYPE_OF(gen_name) = N_UNQ(ret_node);
}
else {
TYPE_OF(gen_name) = symbol_none;
}
popscope();
save_subprog_info(gen_name);
}
void generic_subprog_body(Symbol prog_name, Node node) /*;generic_subprog_body*/
{
/*
* Within its body, the generic subprogram name behaves as a regular
* (i.e. non-generic) subprogram. In particular, it can be called (and
* it cannot be instantiated). Its nature must be set accordingly, prior
* to compilation of the body.
*/
int new_nat, nat, i;
Tuple sig, must_constrain;
Node specs_node, decl_node, formals_node;
char *spec_name;
char *junk;
Tuple specs, tup, gen_list, form_list, decscopes, decmaps, body_specs;
Symbol generic_sym, g_name;
Unitdecl ud;
Fortup ft;
/* if module is a generic subprogram body verify that the generic spec
* appeared in the same file.
*/
if (IS_COMP_UNIT) {
spec_name = strjoin("ss", unit_name_name(unit_name));
if (!streq(lib_unit_get(spec_name), AISFILENAME))
#ifdef ERRNUM
errmsgn(35,10, node);
#else
errmsg("Separately compiled generics not supported", "none", node);
#endif
}
if (NATURE(prog_name) == na_generic_procedure_spec) {
new_nat = na_procedure;
nat = na_generic_procedure; /* Save till end of body. */
}
else {
new_nat = na_function;
nat = na_generic_function;
}
/*
* save and stack the generic symbol for this subprogram to allow the
* detection of recursive instantiations within the generic body
*/
generic_sym = sym_new_noseq(na_void);
sym_copy(generic_sym, prog_name);
NATURE(generic_sym) = nat;
current_instances = tup_with(current_instances, (char *) generic_sym);
NATURE(prog_name) = new_nat;
/*
* The signature of a generic object includes the generic part. During
* compilation of the body, set the signature to contain only the formals
*/
sig = SIGNATURE(prog_name);
gen_list = (Tuple) sig[1];
form_list = (Tuple) sig[2];
SIGNATURE(prog_name) = (Tuple) form_list;
OVERLOADS(prog_name) = set_new1((char *) prog_name);
specs_node = N_AST1(node);
formals_node = N_AST2(specs_node);
decl_node = N_AST2(node);
newscope(prog_name);
reprocess_formals(prog_name, formals_node);
process_subprog_body(node, prog_name);
force_all_types();
popscope();
/*
* If a generic subprogram parameter is an equality operator, we must
* construct the body for the corresponding implicitly defined inequality
*/
add_implicit_neq(gen_list, decl_node, prog_name);
/* Outside of its body, the object is generic again.*/
NATURE(prog_name) = nat;
junk = tup_frome(current_instances);
/* collect all generic types whose '$constrain' attribute is set into the
* tuple must_constrain and save it in the signature of the body
*/
must_constrain = tup_new(0);
FORTUP(tup=(Tuple), gen_list, ft)
g_name = (Symbol)tup[1];
if ((int)misc_type_attributes(g_name) & TA_CONSTRAIN)
must_constrain = tup_with(must_constrain, (char *)g_name);
ENDFORTUP(ft)
sig= tup_new(4);
sig[1] = (char *) gen_list;
sig[2] = (char *) form_list;
sig[3] = (char *) node;
sig[4] = (char *) must_constrain;
SIGNATURE(prog_name) = sig; /* for instantiation */
OVERLOADS(prog_name) = (Set) 0; /* Not a callable object. */
/*
* If the corresponding spec was defined in another compilation unit, it
* must be updated accordingly. If the generic is not itself a compila-
* tion unit, we find the unit in which it appears, and update the info.
* Currently this is done only if both units are in the same compilation.
*/
if (IS_COMP_UNIT) {
pUnits[unit_number(unit_name)]->libInfo.obsolete = string_ok;
/*save it as any subprogram body. */
save_subprog_info(prog_name);
}
else if (streq(unit_name_type(unit_name), "bo") &&
streq(unit_name_name(unit_name), unit_name_names(unit_name)) ) {
spec_name = strjoin("sp", unit_name_name(unit_name));
ud = unit_decl_get(spec_name);
if (streq(lib_unit_get(spec_name), FILENAME) && (ud!=(Unitdecl)0)) {
/* i.e. current compilation, and separate unit, already seen.
* update symbol table information for all entities in body.
* Probably incomplete on unit_nodes, declared, etc.
*/
/* [n, specs, decmap, o, v, c, nodes] := UNIT_DECL(spec_name); */
specs = ud->ud_symbols;
body_specs = unit_symbtab(prog_name, 'u');
/* (for [nam, info] in body_specs)
* specs(nam) := info;
* end for;
*/
for (i = 1; i <= tup_size(body_specs); i++)
specs = sym_save(specs, (Symbol)body_specs[i], 'u');
/* decmap(prog_name) := declared(prog_name); */
decscopes = ud->ud_decscopes;
decmaps = ud->ud_decmaps;
for (i = 1; i<= tup_size(decscopes); i++)
if (prog_name == (Symbol)(decscopes[i]))
break;
decmaps[i] = (char *)dcl_copy(DECLARED(prog_name));
/* is copy necessary ? */
/* UNIT_DECL(spec_name):= [n, specs, decmap, o, v, c,
* nodes + UNIT_NODES];
*/
ud->ud_symbols = specs;
for (i = 1; i <= tup_size(unit_nodes); i++)
ud->ud_nodes = tup_with(ud->ud_nodes, unit_nodes[i]);
}
}
else {
/* If it is a subunit of a subprogram unit, it is only visible within
* this unit, and no update is needed.
*/
#ifdef TBSL
unit_kind : = om;
#endif
}
N_KIND(node) = (nat == na_generic_procedure) ? as_generic_procedure
: as_generic_function;
}
static void add_implicit_neq(Tuple gen_list, Node decl_node, Symbol prog_name)
/*;add_implicit_neq*/
{
/*
* if a generic subprogram parameter is an equality operator, an implicit
* inequality is thus defined, and a symbol table entry for it has been
* constructed at the same time as that for the equality. We place a
* declaration for its body in the declarative part of the generic unit.
* It will thus be instantiated in the same way as other local entity.
*/
Fortup ft1;
Forset fs1;
Tuple tup;
Symbol g_name, neq;
int exists;
Node neq_node;
Set oset;
FORTUP(tup=(Tuple), gen_list, ft1);
g_name = (Symbol) tup[1];
if (NATURE(g_name) != na_function) continue;
if (streq(original_name(g_name), "=") == FALSE) continue;
exists = FALSE;
oset = (Set)OVERLOADS(dcl_get(DECLARED(prog_name), "/="));
FORSET(neq=(Symbol), oset, fs1);
if (same_signature(g_name, neq)) {
exists = TRUE;
break;
}
ENDFORSET(fs1);
if (!exists) continue;
neq_node = new_not_equals(neq, g_name);
#ifdef TBSL
N_LIST(decl_node) :
= [neq_node] + N_LIST(decl_node);
#endif
N_LIST(decl_node) = tup_with(N_LIST(decl_node), (char *)neq_node);
ENDFORTUP(ft1);
}
void generic_pack_spec(Node node) /*;generic_pack_spec*/
{
Node id_node, generic_part_node, decl_node, priv_node;
Tuple tup, gen_list;
if (cdebug2 > 3)
TO_ERRFILE("AT PROC : generic_pack_spec");
id_node = N_AST1(node);
generic_part_node = N_AST2(node);
decl_node = N_AST3(node);
priv_node = N_AST4(node);
new_package(id_node, na_generic_part);
/*
* Process generic parameters. Their definition will appear in
* the scope of the generic package. The list of them is also
* preserved in the signature of the package, for instantiation.
* The signature of the generic package as the format:
*
* [[generic_type_list, visible_decls, private_part, body, must_constrain]
*
* The body will be seen later, its place kept by a null node.
* Must_constrain is the list of generic types that must be constrained upon
* instantiation. It is created by module_body after processing the generic
* package body.
*/
adasem(generic_part_node);
tup = tup_new(5);
gen_list = collect_generic_formals(generic_part_node);
tup[1] = (char *) gen_list;
tup[2] = (char *) decl_node;
tup[3] = (char *) priv_node;
tup[4] = (char *) OPT_NODE;
tup[5] = (char *) tup_new(0);
SIGNATURE(scope_name) = tup;
NATURE(scope_name) = na_generic_package_spec;
/* The rest of the package is processed as in a non-generic case.*/
package_declarations(decl_node, priv_node);
add_implicit_neq(gen_list, decl_node, scope_name);
end_specs(scope_name);
}
void generic_obj_decl(Node node) /*;generic_obj_decl*/
{
Node id_list_node, in_out_node, type_node, init_node, id_node;
Tuple id_nodes;
int kind;
Symbol type_mark, name;
Tuple nam_list;
Fortup ft1;
int i;
if (cdebug2 > 3)
TO_ERRFILE("AT PROC : generic_obj_decl");
id_list_node = N_AST1(node);
in_out_node = N_AST2(node);
type_node = N_AST3(node);
init_node = N_AST4(node);
id_nodes = N_LIST(id_list_node);
nam_list = tup_new(tup_size(id_nodes));
FORTUPI(id_node=(Node), id_nodes, i, ft1);
nam_list[i] = (char *) find_new(N_VAL(id_node));
ENDFORTUP(ft1);
for (i = 1; i <= tup_size(id_nodes); i++)
N_UNQ((Node)id_nodes[i]) = (Symbol) nam_list[i];
kind = (int) N_VAL(in_out_node);
if (kind == 0 ) kind = na_in;
find_type(type_node);
type_mark = N_UNQ(type_node);
if (is_incomplete_type(type_mark))
#ifdef ERRNUM
id_errmsgn(36, type_mark, 37, type_node);
#else
errmsg_id("Premature use of incomplete or private type %",
type_mark, "7.4.1", type_node);
#endif
adasem(init_node);
if (kind == na_in) {
if (is_limited_type(type_mark)) {
#ifdef ERRNUM
l_errmsgn(38, 39, 40, type_node);
#else
errmsg_l("Type of a generic formal object of mode IN must not",
" be a limited type", "12.1.1", type_node);
#endif
}
if (init_node != OPT_NODE) {
/* Type check default value. */
bind_names(init_node);
check_type(type_mark, init_node);
if (is_deferred_constant(init_node) ) {
#ifdef ERRNUM
l_errmsgn(41, 42, 43, init_node);
#else
errmsg_l("Deferred constant cannot be default expression",
" for a generic parameter", "7.4.3", init_node);
#endif
}
}
}
else if (kind == na_inout) {
/* No constraints apply to generic inout formals.*/
type_mark = base_type(type_mark);
if (init_node != OPT_NODE) {
#ifdef ERRNUM
errmsgn(44,40, init_node);
#else
errmsg("Initialization not allowed for IN OUT generic parameters",
"12.1.1", init_node);
#endif
}
}
else if (kind == na_out) {
#ifdef ERRNUM
errmsgn(45, 40, in_out_node);
#else
errmsg("OUT generic formals objects not allowed",
"12.1.1", in_out_node);
#endif
}
FORTUP(name=(Symbol), nam_list, ft1);
if (kind == na_in) NATURE(name) = na_in;
else NATURE(name)= na_inout;
TYPE_OF(name) = type_mark;
SIGNATURE(name) = (Tuple) init_node;
ENDFORTUP(ft1);
}
void generic_type_decl(Node node) /*;generic_type_decl*/
{
Node id_node, def_node, range_node, opt_disc;
char *id, *root_id;
Symbol root;
/*char *attr;*/
Symbol type_name, anon_type, generic_base, t;
Node lo, hi, attr_node, precision, type_node;
Tuple ncon, bounds;
int kind;
if (cdebug2 > 3)
TO_ERRFILE("AT PROC : generic_type_decl");
id_node = N_AST1(node);
opt_disc = N_AST2(node);
def_node = N_AST3(node);
id = N_VAL(id_node);
/*
* In the case of generic array types, anonymous parent array may be
* introduced. They are not generic in themselves, and play no role in
* the instantiated code; they are collected here and discarded.
*/
newtypes = tup_with(newtypes , (char *) tup_new(0));
if (N_KIND(def_node) == as_generic) { /*scalar type*/
type_name = find_new(id);
N_UNQ(id_node) = type_name;
root_id = N_VAL(def_node);
if (streq(root_id, "INTEGER")) root = symbol_integer;
else if (streq(root_id, "discrete_type")) root = symbol_discrete_type;
else if (streq(root_id, "FLOAT")) root = symbol_float;
else if (streq(root_id, "$FIXED")) root = symbol_dfixed;
else chaos("generic_type_decl(12) bad generic type");
/* A generic signature must be constructed for these types, in
* order to verify bounds in instantiations, subtypes, etc.
* These bounds must expressed by means of attributes.
*/
if (root == symbol_integer || root == symbol_discrete_type) {
type_node = new_name_node(type_name);
lo = new_attribute_node(ATTR_T_FIRST,type_node,OPT_NODE, type_name);
type_node = new_name_node(type_name);
hi = new_attribute_node(ATTR_T_LAST, type_node,OPT_NODE, type_name);
/*bounds := ['range', lo, hi];*/
bounds = constraint_new(CONSTRAINT_RANGE);
numeric_constraint_low(bounds) = (char *)lo;
numeric_constraint_high(bounds) = (char *)hi;
range_node = node_new(as_range);
N_AST1(range_node) = lo;
N_AST2(range_node) = hi;
N_AST1(def_node) = range_node;
}
else {
ncon = (Tuple) SIGNATURE(root);
kind = (int)numeric_constraint_kind(ncon);
lo = (Node) numeric_constraint_low(ncon);
hi = (Node) numeric_constraint_high(ncon);
/*[kind, lo, hi, precision] := signature(root);*/
attr_node = node_new(as_number);
/* proper attr code filled in below */
if (kind == CONSTRAINT_DIGITS) {
N_VAL(attr_node) = (char *) ATTR_DIGITS;
}
else {
N_VAL(attr_node) = (char *) ATTR_DELTA;
/* N_VAL(attr_node) = if kind = 'digits' then 'DIGITS'
* else 'DELTA' end;
*/
}
precision = node_new(as_attribute);
type_node = new_name_node(type_name);
N_AST1(precision) = attr_node;
N_AST2(precision) = type_node;
N_AST3(precision) = OPT_NODE;
#ifdef TBSL
-- check this out, SETL seems wrong
N_AST(def_node) :
= precision;
#endif
/*bounds = [kind, lo, hi, precision];*/
bounds = constraint_new(kind);
numeric_constraint_low(bounds) = (char *)lo;
numeric_constraint_high(bounds) = (char *)hi;
numeric_constraint_digits(bounds) = (char *)precision;
}
/* The base type of a generic type is the base of its actual. In
* order to be able to refer to the base type of a generic within
* the object, we introduce an anonymous type that will be instan
* tiated with the base type of the actual.
*/
generic_base = anonymous_type();
NATURE(generic_base) = na_type;
TYPE_OF(generic_base) = root;
SIGNATURE(generic_base) = (Tuple) bounds;
root_type(generic_base) = root_type(root);
misc_type_attributes(generic_base) = TA_GENERIC;
/*SYMBTAB(type_name) := [na_subtype, generic_base, bounds];*/
NATURE(type_name) = na_subtype;
TYPE_OF(type_name) = generic_base;
SIGNATURE(type_name) = bounds;
root_type(type_name) = root_type(root);
}
else { /* array type or access type.*/
type_decl(node);
type_name = N_UNQ(id_node);
if (is_access(type_name))
t = (Symbol) designated_type(type_name);
else t = (Symbol) component_type(type_name);
/* note that a generic type defintion is not a type declaration and
* therefore, the component or designated type of a generic type
* cannot be an incomplete private type.
*/
if (private_ancestor(t) != (Symbol)0 )
#ifdef ERRNUM
id_errmsgn(46, t, 37, node);
#else
errmsg_id("Premature usage of type % before its full declaration",
t, "7.4.1", node);
#endif
}
misc_type_attributes(type_name) =
misc_type_attributes(type_name) | TA_GENERIC;
anon_type = (Symbol)tup_frome( newtypes);
}
void generic_priv_decl(Node node) /*;generic_priv_decl*/
{
Node id_node;
Symbol type_name, discr;
Fortup ft;
if (cdebug2 > 3)
TO_ERRFILE("AT PROC : generic_priv_decl");
private_decl(node);
id_node = N_AST1(node);
type_name = N_UNQ(id_node);
if (type_name == symbol_any) /* previous error */
return;
misc_type_attributes(type_name) = TA_GENERIC;
FORTUP(discr=(Symbol), discriminant_list(type_name), ft)
if (discr == symbol_constrained) continue;
if ((Node)default_expr(discr) != OPT_NODE) {
#ifdef ERRNUM
errmsgn(47, 48, (Node)default_expr(discr));
#else
errmsg(
"generic private type cannot have defaults for discriminants",
"12.1.2", (Node)default_expr(discr) );
#endif
return;
}
ENDFORTUP(ft)
}
void check_generic_usage(Symbol type_mark) /*;check_generic_usage*/
{
/*
* if a private generic type, or a subtype or derived type of it, is used
* in an object declaration, component declaration, or allocator, indicate
* that it must be instantiated with a constrained type.
*/
Symbol t;
t = root_type(type_mark);
if (in_priv_types(TYPE_OF(t)) && is_generic_type(t)
&& (can_constrain(type_mark) || ! has_discriminants(type_mark)) )
misc_type_attributes(t) = misc_type_attributes(t) | TA_CONSTRAIN;
}
void generic_subp_decl(Node node) /*;generic_subp_decl*/
{
Node spec_node, opt_is_node, id_node, formal_list, ret_node;
char *id;
Tuple formals;
Symbol ret, name, anon_subp;
int kind;
if (cdebug2 > 3)
TO_ERRFILE("AT PROC : generic_subp_decl");
spec_node = N_AST1(node) ;
opt_is_node = N_AST2(node) ;
adasem(spec_node);
id_node = N_AST1(spec_node);
formal_list = N_AST2(spec_node);
ret_node = N_AST3(spec_node);
id = N_VAL(id_node);
formals = get_formals(formal_list, id);
if (N_KIND(spec_node) == as_procedure ) {
kind = na_procedure;
ret = symbol_none;
}
else {
kind = na_function;
ret = N_UNQ(ret_node);
}
if (in_op_designators(id )) /* check format, if operator spec */
check_new_op(id_node, formals, ret);
name = chain_overloads(id, kind, ret, formals, (Symbol)0, OPT_NODE);
N_UNQ(id_node) = name;
/* a generic subprogram parameter is treated as a renaming of some
* unspecified subprogram whose actual name will be supplied at
* the point of instantiation
*/
anon_subp = sym_new(kind);
TYPE_OF(anon_subp) = TYPE_OF(name);
SIGNATURE(anon_subp) = SIGNATURE(name);
SCOPE_OF(anon_subp) = scope_name;
dcl_put(DECLARED(scope_name), newat_str(), anon_subp);
ALIAS(name) = anon_subp;
if (N_KIND(opt_is_node) == as_string) /* Default val is an operator name.*/
desig_to_op(opt_is_node);
else
adasem(opt_is_node) ;
if (opt_is_node != OPT_NODE) {
if (N_KIND(opt_is_node) == as_simple_name
/* had 'box' in next line TBSL check type */
&& streq(N_VAL(opt_is_node) , "box")) {
;
}
else {
find_old(opt_is_node);
/* verify that the default has a matching signature */
current_node = opt_is_node;
if (tup_size(find_renamed_entity(kind,
formals, ret, opt_is_node)) == 0)
N_AST2(node) = OPT_NODE; /* renaming error */
if (name == N_UNQ(opt_is_node))
#ifdef ERRNUM
str_errmsgn(49, id, 50, opt_is_node);
#else
errmsg_str("invalid reference to %", id, "8.3(16)", opt_is_node);
#endif
}
}
}
static void bind_names(Node node) /*;bind_names*/
{
Node name, sel, arg_list, arg1, arg2, arg;
Fortup ft1;
int nk;
if (cdebug2 > 3)
TO_ERRFILE("AT PROC : bind_names");
/*
* Perform name resolution for default initializations for generic IN
* parameters and for discriminant specifications.
*/
switch (nk = N_KIND(node)) {
case as_name:
find_old(node);
bind_names(node);
break;
case as_selector:
name = N_AST1(node);
sel = N_AST2(node);
bind_names(name);
break;
case as_call_unresolved:
case as_op:
case as_un_op:
name = N_AST1(node);
arg_list = N_AST2(node);
find_old(name);
FORTUP(arg =(Node), N_LIST(arg_list), ft1);
bind_names(arg);
ENDFORTUP(ft1);
break;
case as_attribute:
arg1 = N_AST2(node);
arg2 = N_AST3(node);
bind_names(arg1);
bind_names(arg2);
break;
} /* End switch */
}
static Tuple collect_generic_formals(Node generic_part_node)
/*;collect_generic_formals*/
{
Tuple gen_list;
Node n, id_list_node, init_node, id_node, spec_node;
int nk;
Fortup ft1, ft2;
Tuple tup;
/*
* Collect names of generic parameters, and defaults when present.
* Return a list of pairs [unique_name, default], which is attached to
* the generic object to simplify instantiation.
*/
if (cdebug2 > 3)
TO_ERRFILE("AT PROC: collect_generic_formals");
gen_list = tup_new(0);
FORTUP(n =(Node), N_LIST(generic_part_node), ft1);
nk = N_KIND(n);
if (nk == as_generic_obj) {
id_list_node = N_AST1(n);
init_node = N_AST4(n);
FORTUP(id_node=(Node), N_LIST(id_list_node), ft2);
tup = tup_new(2);
tup[1] = (char *) N_UNQ(id_node);
tup[2] = (char *) init_node;
gen_list = tup_with(gen_list, (char *) tup);
ENDFORTUP(ft2);
}
else if (nk == as_generic_subp) {
spec_node = N_AST1(n);
init_node = N_AST2(n);
id_node = N_AST1(spec_node);
tup = tup_new(2);
tup[1] = (char *) N_UNQ(id_node);
tup[2] = (char *) init_node;
gen_list = tup_with(gen_list, (char *) tup);
}
else { /*Generic type definition*/
id_node = N_AST1(n);
tup = tup_new(2);
tup[1] = (char *) N_UNQ(id_node);
tup[2] = (char *) OPT_NODE;
gen_list = tup_with(gen_list, (char *) tup);
}
ENDFORTUP(ft1);
return gen_list;
}
void subprog_instance(Node node) /*;subprog_instance*/
{
Node id_node, gen_node, spec_node, instance_node, body_node,stmt_node;
char *new_id, *body_name;
Symbol gen_name;
int kind;
Tuple generics, instance_list;
Tuple formals;
Symbol return_type;
Tuple new_info;
Symbol new_return;
Tuple new_specs;
Symbol proc_name;
Tuple tup;
Fortup ft1;
Symbol new_f, f;
Tuple new_formals;
Symbolmap type_map;
int ii;
int has_default = FALSE;
Tuple newtup;
/*
* Create an instantiation of a generic procedure.
*
* To construct the new instance, we first process the instantiation of
* the generics. This yields a series of renames statements, which map
* the generic parameters into actual types and subprograms. This map
* is used to rename all generic entities within the spec and body of the
* generic object, to yield the AST and SYMBTAB for the instantiated one.
*/
if (cdebug2 > 3)
TO_ERRFILE("AT PROC : subprog_instance");
id_node = N_AST1(node);
gen_node = N_AST2(node);
instance_node = N_AST3(node);
/* instantiate_generics adds to list - don't want to modify OPT_NODE */
if (instance_node == OPT_NODE) {
instance_node = node_new(as_list);
N_LIST(instance_node) = tup_new(0);
N_AST3(node) = instance_node;
}
new_id = N_VAL(id_node);
new_compunit("su", id_node);
find_old(gen_node);
gen_name = N_UNQ(gen_node);
if (gen_name == (Symbol)0) gen_name = symbol_any_id;
/*
* In the case where the instantiation is a compilation unit, the context
* of the generic body needs to be transferred to the instatiation. This
* is done by adding the body of the generic (if it has been seen) to the
* all_vis insuring that the body is loaded and all that it references
* is loaded (transitivly) in INIT_GEN.
*/
if (IS_COMP_UNIT) {
body_name = strjoin("su", ORIG_NAME(gen_name));
if (unitNumberFromLibUnit(body_name))
all_vis = tup_with(all_vis, body_name);
}
kind = ( N_KIND(node) == as_procedure_instance ) ? na_procedure
: na_function;
if ((kind == na_procedure &&
(NATURE(gen_name) != na_generic_procedure
&& NATURE(gen_name) != na_generic_procedure_spec))
|| (kind == na_function && (NATURE(gen_name) != na_generic_function
&& NATURE(gen_name) != na_generic_function_spec))) {
#ifdef ERRNUM
l2_errmsgn(51, nature_str(kind), 52, gen_node);
#else
errmsg_l("not a generic ", nature_str(kind), "12.1, 12.3", gen_node);
#endif
return;
}
#ifdef XREF
TO_XREF(gen_name);
#endif
tup = SIGNATURE(gen_name);
generics = (Tuple) tup[1];
formals = (Tuple) tup[2];
body_node = (Node) tup[3];
return_type = TYPE_OF(gen_name);
/* Now match generic specification with instantiation.*/
node_map = nodemap_new(); /* initialize */
tup = instantiate_generics(generics, instance_node);
instance_list = (Tuple) tup[1];
type_map= (Symbolmap) tup[2];
/*
* Use the instantiated generic types to obtain the actual signature and
* return type of the new procedure.
* Set default expression nodes temporarily to opt_node for the
* call to chain_overloads (so that we avoid reprocessing them
* in process_formals).
* Due to this kludge, we also test here (explicitly) that default
* parameters are not specified for operator symbols.
* They are instantiated upon return from chain_overloads.
*/
new_info = tup_new(tup_size(formals));
FORTUPI(f=(Symbol), formals, ii, ft1);
newtup = tup_new(4);
newtup[1] = (char *)ORIG_NAME(f);
newtup[2] = (char *)NATURE(f);
newtup[3] = (char *)replace(TYPE_OF(f), type_map);
newtup[4] = (char *)OPT_NODE; /* temporarily */
new_info[ii] = (char *) newtup;
if ((Node)default_expr(f) != OPT_NODE)
has_default = TRUE;
ENDFORTUP(ft1);
new_return = replace(return_type, type_map);
new_specs = tup_new(3);
new_specs[1] = (char *) kind;
new_specs[2] = (char *) new_return;
new_specs[3]= (char *) new_info;
if (in_op_designators(new_id )) { /* check format, if operator spec */
check_new_op(id_node, new_info, new_return);
if (has_default)
#ifdef ERRNUM
errmsgn(53, 54, instance_node);
#else
errmsg("Initializations not allowed for operators", "6.7", instance_node);
#endif
}
/* Create new overloadable object with these specs.*/
proc_name = chain_overloads(new_id, kind, new_return, new_info, (Symbol)0,
OPT_NODE);
/*
* in the body of the procedure, replace the generic name with the
* instantiated name. (it appears on the return statement, and of
* course in any recursive call).
* Also, map the names of the formals parameters into the names they
* have in the instantiated procedure (the actual formals ?)
* Instantiate default expressions for formals.
*/
/* map the formals of the generic into the formals of the instantiation.*/
new_formals = SIGNATURE(proc_name);
FORTUPI(new_f=(Symbol), new_formals, ii, ft1);
symbolmap_put(type_map, (Symbol) formals[ii], new_f);
default_expr(new_f) = (Tuple) instantiate_tree(
(Node) default_expr((Symbol)formals[ii]), type_map);
ENDFORTUP(ft1);
/* in the body of the subprogram, the generic name is replaced by the
* instantiated name. (it appears on the return statement, and of
* course in any recursive call).
*/
symbolmap_put(type_map, gen_name, proc_name);
N_UNQ(id_node) = proc_name;
if (body_node == OPT_NODE) {
/* Attach type_map to node for subsequent instantiation (expander).
* For visibility purposes, only the formals of the subprogram are
* needed; the symbol table instantiation will also take place in
* the binder.
*/
/* We must call instantiate_sybmtab here in order to have instantiated
* items placed in appropriate declared maps
*/
newtup = instantiate_symbtab(gen_name, proc_name, type_map);
type_map = (Symbolmap) newtup[1];
newtup = tup_new(2);
newtup[1] = (char *) type_map;
newtup[2] = (char *) TRUE;
N_AST4(node) = new_instance_node(newtup);
/* original instance node not needed further */
if (instance_node != OPT_NODE)
N_KIND(N_AST3(node)) = as_list;
else N_AST3(node) = node_new(as_list);
/* to be included with decls in body */
N_LIST(N_AST3(node)) = instance_list;
}
else {
instantiate_subprog_tree(node, type_map);
/*
* Take the subprogram created by the instantiation and reformat
* the subprogram node to be of a form as_subprogram_tr with the
* specifcation part detached from the tree. Move up the id_node
* (subprogram name) info to the subprogram node. The stmt_node
* needs to be moved to N_AST1 so that N_UNQ field can be used
* to store unique name of subprogram.
*/
spec_node = N_AST1(node);
stmt_node = N_AST3(node);
id_node = N_AST1(spec_node);
N_KIND(node) = as_subprogram_tr;
N_AST1(node) = stmt_node;
N_UNQ(node) = N_UNQ(id_node);
/*
* Emit the code that instantiates the generic parameters in front of
* the subprogram.
*/
if (tup_size(instance_list) > 0)
make_insert_node(node, instance_list, copy_node(node));
}
save_subprog_info(proc_name);
}
void package_instance(Node node) /*;package_instance*/
{
Node id_node, gen_node, instance_node;
Symbol package, gen_name;
Tuple instance_list;
Symbolmap type_map;
Node package_node;
Tuple tup, gen_list;
char *body_name;
int is_comp;
if (cdebug2 > 3)
TO_ERRFILE("AT PROC : package_instance");
/*
* Create an instantiation of a generic package. The renaming and
* instantiation of local objects is done as for subprograms.
*/
is_comp = IS_COMP_UNIT;
id_node = N_AST1(node);
gen_node= N_AST2(node);
instance_node = N_AST3(node);
/* instantiate_generics adds to list - don't want to modify OPT_NODE */
if (instance_node == OPT_NODE) {
instance_node = node_new(as_list);
N_LIST(instance_node) = tup_new(0);
N_AST3(node) = instance_node;
}
new_package(id_node, na_package_spec);
package = scope_name;
find_old(gen_node);
gen_name = N_UNQ(gen_node);
if (gen_name == (Symbol)0) gen_name = symbol_any_id;
/* TBSL: the context of the generic needs to be transferred to the
* instantiation in the case of a compilation unit. (see mod in
* subprogram instance).
*/
if (is_comp) {
body_name = strjoin("bo", ORIG_NAME(gen_name));
if (unitNumberFromLibUnit(body_name))
all_vis = tup_with(all_vis, body_name);
}
/*
* new_compunit will have already been called under the asssumption
* that the current compilation unit is a non-generic package. This
* may be inefficient, but the second calls to new_compunit and
* establish_context will act correctly.
* Build temporary node "package_node" to call new_compunit.
*/
package_node = node_new(as_simple_name);
copy_span(id_node, package_node);
N_VAL(package_node) = N_VAL(id_node);
/* TBSL - SETL has 'spec instance' - I am doing as 'spec' ds 30 jul */
new_compunit("sp", package_node);
if (
/* !is_identifier(gen_name) || */
/* is_identifier will always be true because was set above */
(NATURE(gen_name) !=na_generic_package
&& NATURE(gen_name) !=na_generic_package_spec) ) {
#ifdef ERRNUM
errmsgn(55, 56, gen_node);
#else
errmsg("not a generic package", "12.1", gen_node);
#endif
popscope();
return;
}
else if (in_open_scopes(gen_name)) {
#ifdef ERRNUM
errmsgn(57, 58, gen_node);
#else
errmsg("Recursive instantiation not allowed", "12.3", gen_node);
#endif
popscope();
return;
}
#ifdef XREF
TO_XREF(gen_name);
#endif
tup = SIGNATURE(gen_name);
gen_list = (Tuple) tup[1];
node_map = nodemap_new(); /* initialize */
tup = instantiate_generics(gen_list, instance_node);
instance_list = (Tuple) tup[1];
type_map = (Symbolmap) tup[2];
symbolmap_put(type_map, gen_name, package);
instantiate_pack_tree(node, type_map, instance_list);
end_specs(package);
/*
* The instantiated object is a package, although it appears syntact-
* ically as a package spec.
*/
NATURE(package) = na_package;
}
These are the contents of the former NiCE NeXT User Group NeXTSTEP/OpenStep software archive, currently hosted by Netfuture.ch.