static Node initialization_proc(Symbol proc_name, Symbol type_name,
Tuple formals, Tuple stmts) /*;initialization_proc*/
{
/* Build procedure with given formals and statement list. */
Node proc_node;
int i, n;
Tuple tup;
NATURE (proc_name) = na_procedure;
n = tup_size(formals);
tup = tup_new(n);
for (i = 1; i <= n; i++)
tup[i] = (char *) N_UNQ((Node)formals[i]);
SIGNATURE(proc_name) = tup;
generate_object(proc_name);
/*
* Create as_subprogram_tr node with statements node as N_AST1
* instead of N_AST3 as it is with as_subprogram.
*/
proc_node = new_node(as_subprogram_tr);
N_UNQ(proc_node) = proc_name;
N_AST1(proc_node) = new_statements_node(stmts);
N_AST2(proc_node) = OPT_NODE;
N_AST4(proc_node) = OPT_NODE;
return proc_node;
}
std::vector<std::string> generate_objects()
{
std::vector<std::string> obj_names;
for (auto const m : modules) {
assert(m);
obj_names.push_back(generate_object(*m));
}
return obj_names;
}
Node build_proc_init_rec(Symbol type_name) /*;build_proc_init_rec*/
{
/*
* This is the main procedure for building default initialization
* procedures for record types. Those initialization procedures are
* built if the type given contains some subcomponent for which a
* default initialization exists (at any level of nesting), or if it
* has determinants.
* Note that scalar objects are not initialized at all, which implies
* that they get whatever initial value is in that location in memory
* This saves some time in object creation.
*
* All init. procedures have an 'out' parameter that designates the
* object begin initialized (the space has already been allocated).
*
*/
int side_effect;
Node invar_node; /* TBSL: is invar_node local??*/
Tuple stmts, tup, nstmts, formals, invariant_fields;
Tuple discr_list; /* is this local ?? TBSL */
Fortup ft1;
Symbol d, proc_name;
Node param, var_node, out_param;
Node node, node1, node2, discr_value_node;
#ifdef TRACE
if (debug_flag)
gen_trace_symbol("BUILD_PROC_INIT_REC", type_name);
#endif
side_effect = FALSE; /* Let's hope... TBSL */
/*
* The initialization procedure for records has the usual out param.,
* and one in parameter per discriminant. The CONSTRAINED flag is the
* first of the discriminants
*/
proc_name = new_unique_name("Init_ type_name");
out_param = new_param_node("param_type_name", proc_name, type_name, na_out);
generate_object(proc_name);
generate_object(N_UNQ(out_param));
tup = SIGNATURE(type_name);
invar_node = (Node) tup[1];
var_node = (Node) tup[2];
discr_list = (Tuple) tup[3];
invariant_fields = build_comp_names(invar_node);
stmts = tup_new(0);
if (tup_size(discr_list)) {
/* Generate formal parameters for each. The body of the procedure */
/* assigns them to the field of the object. */
/* Note: the 'constrained' field is part of the discriminants. */
formals = tup_new(0);
FORTUP(d=(Symbol), discr_list, ft1);
param = new_param_node("param_type_name", proc_name, TYPE_OF(d),
na_in);
generate_object(N_UNQ(param));
formals = tup_with(formals, (char *) param );
stmts = tup_with(stmts,
(char *) new_assign_node(new_selector_node(out_param, d), param));
discr_value_node = new_selector_node (out_param, d);
/* generate code in order to test if the value of discriminant is
* compatible with its subtype
*/
node1 = new_attribute_node(ATTR_T_FIRST, new_name_node(TYPE_OF(d)),
OPT_NODE, TYPE_OF(d));
node2 = new_attribute_node(ATTR_T_LAST, new_name_node(TYPE_OF(d)),
OPT_NODE, TYPE_OF(d));
node = node_new (as_list);
make_if_node(node,
tup_new1((char *) new_cond_stmts_node( new_binop_node(symbol_or,
new_binop_node(symbol_lt, discr_value_node, node1,
symbol_boolean),
new_binop_node(symbol_gt, discr_value_node, node2,
symbol_boolean),
symbol_boolean),
new_raise_node(symbol_constraint_error))), OPT_NODE);
stmts = tup_with(stmts, (char *) node);
ENDFORTUP(ft1);
formals = tup_with(formals, (char *) out_param );
/* if there are default expressions for any other components, */
/* further initialization steps are needed. */
tup = proc_init_rec(type_name, invariant_fields, var_node, out_param);
/*stmts += proc_init_rec(invariant_fields, var_node, out_param);*/
nstmts = tup_add(stmts, tup);
tup_free(stmts);
tup_free(tup);
stmts = nstmts;
}
else {
/* record without discriminants. There may still be default values */
/* for some components. */
formals = tup_new1((char *) out_param);
stmts = proc_init_rec(type_name,invariant_fields,var_node, out_param);
}
if (tup_size(stmts)) {
INIT_PROC(type_name) = proc_name;
return initialization_proc(proc_name, type_name, formals, stmts);
}
else {
return OPT_NODE;
}
}
Node build_proc_init_ara(Symbol type_name) /*;build_proc_init_ara*/
{
/*
* This is the main procedure for building default initialization
* procedures for array types. Those initialization procedures are
* built if the type given contains some subcomponent for which a
* default initialization exists (at any level of nesting), or if it
* has determinants.
* Note that scalar objects are not initialized at all, which implies
* that they get whatever initial value is in that location in memory
* This saves some time in object creation.
*
* All init. procedures have an 'out' parameter that designates the
* object being initialized (the space has already been allocated).
*
*/
int side_effect;
Tuple tup, formals, subscripts;
Symbol c_type, ip, index_t, proc_name, index_sym;
Node one_component, init_stmt, out_param, i_nodes, d_node, iter_node;
Fortup ft1;
Node iterator, index_node;
#ifdef TRACE
if (debug_flag) {
gen_trace_symbol("BUILD_PROC_INIT_ARR", type_name);
}
#endif
side_effect = FALSE; /* Let's hope... TBSL */
tup = SIGNATURE(type_name);
c_type = (Symbol) tup[2];
one_component = new_node(as_index);
ip = INIT_PROC(base_type(c_type));
if (ip != (Symbol)0 ){
/* Use the initialization procedure for the component type */
init_stmt = (Node) build_init_call(one_component, ip, c_type, OPT_NODE);
}
else if (is_task_type(c_type)) {
/* initialization is task creation. */
init_stmt =
new_assign_node(one_component, new_create_task_node(c_type));
}
else if (is_access_type(c_type)) {
/* default value is the null pointer. */
init_stmt = new_assign_node(one_component, new_null_node(c_type));
}
else {
init_stmt = (Node) 0;
}
if (init_stmt != (Node)0) {
/* body of initialization procedure is a loop over the indices */
/* allocating each component. Generate loop variables and code */
/* for iteration, using the attributes of the type. */
proc_name = new_unique_name("type_name+INIT");
out_param = new_param_node("param_type_name", proc_name,
type_name, na_out);
generate_object(N_UNQ(out_param));
formals = tup_new1((char *) out_param);
subscripts = tup_new(0);
FORTUP(index_t=(Symbol), index_types(type_name), ft1);
/*index = index_t + 'INDEX';*/
index_sym = new_unique_name("index_t+INDEX");
NATURE (index_sym) = na_obj;
TYPE_OF(index_sym) = index_t;
subscripts = tup_with(subscripts, (char *)new_name_node(index_sym));
ENDFORTUP(ft1);
i_nodes = new_node(as_list);
/* need tup_copy since subscripts used destructively below */
N_LIST(i_nodes) = tup_copy(subscripts);
/* Build the tree for the one_component of the array. */
N_AST1(one_component) = out_param;
N_AST2(one_component) = i_nodes;
N_TYPE(one_component) = c_type;
while (tup_size(subscripts)) {
/* Build loop from innermost index outwards. The iterations */
/* span the ranges of the array being initialized. */
/* dimension spanned by this loop: */
d_node = new_ivalue_node(int_const(tup_size(subscripts)),
symbol_integer);
iterator = new_attribute_node(ATTR_O_RANGE,
new_name_node(N_UNQ(out_param)), d_node, type_name);
index_node = (Node) tup_frome(subscripts);
iter_node = new_node(as_for);
N_AST1(iter_node) = index_node;
N_AST2(iter_node) = iterator;
init_stmt = new_loop_node(OPT_NODE, iter_node,
tup_new1((char *)init_stmt));
}
INIT_PROC(type_name) = proc_name;
return initialization_proc(proc_name, type_name,
formals, tup_new1((char *) init_stmt));
}
else {
return OPT_NODE;
}
}
ENTRYPOINT void
init_glblur (ModeInfo *mi)
{
glblur_configuration *bp;
int wire = MI_IS_WIREFRAME(mi);
MI_INIT (mi, bps);
bp = &bps[MI_SCREEN(mi)];
bp->glx_context = init_GL(mi);
reshape_glblur (mi, MI_WIDTH(mi), MI_HEIGHT(mi));
clear_gl_error(); /* WTF? sometimes "invalid op" from glViewport! */
if (!wire)
{
GLfloat gamb[4]= {0.2, 0.2, 0.2, 1.0};
GLfloat pos[4] = {0.0, 5.0, 10.0, 1.0};
GLfloat amb[4] = {0.2, 0.2, 0.2, 1.0};
GLfloat dif[4] = {0.3, 0.3, 0.3, 1.0};
GLfloat spc[4] = {0.8, 0.8, 0.8, 1.0};
GLfloat shiny = 128;
glEnable(GL_LIGHTING);
glEnable(GL_LIGHT0);
glEnable(GL_DEPTH_TEST);
glEnable(GL_CULL_FACE);
glEnable(GL_NORMALIZE);
glShadeModel(GL_SMOOTH);
glLightModelfv (GL_LIGHT_MODEL_AMBIENT, gamb);
glLightfv(GL_LIGHT0, GL_POSITION, pos);
glLightfv(GL_LIGHT0, GL_AMBIENT, amb);
glLightfv(GL_LIGHT0, GL_DIFFUSE, dif);
glLightfv(GL_LIGHT0, GL_SPECULAR, spc);
glEnable(GL_LIGHTING);
glEnable(GL_LIGHT0);
glMaterialf(GL_FRONT, GL_SHININESS, shiny);
}
{
Bool spinx=False, spiny=False, spinz=False;
double spin_speed = 0.9;
double wander_speed = 0.06;
char *s = do_spin;
while (*s)
{
if (*s == 'x' || *s == 'X') spinx = True;
else if (*s == 'y' || *s == 'Y') spiny = True;
else if (*s == 'z' || *s == 'Z') spinz = True;
else if (*s == '0') ;
else
{
fprintf (stderr,
"%s: spin must contain only the characters X, Y, or Z (not \"%s\")\n",
progname, do_spin);
exit (1);
}
s++;
}
bp->rot = make_rotator (spinx ? spin_speed : 0,
spiny ? spin_speed : 0,
spinz ? spin_speed : 0,
1.0,
do_wander ? wander_speed : 0,
False);
bp->trackball = gltrackball_init (True);
}
if (blursize < 0) blursize = 0;
if (blursize > 200) blursize = 200;
bp->ncolors = 128;
bp->colors0 = (XColor *) calloc(bp->ncolors, sizeof(XColor));
bp->colors1 = (XColor *) calloc(bp->ncolors, sizeof(XColor));
bp->colors2 = (XColor *) calloc(bp->ncolors, sizeof(XColor));
bp->colors3 = (XColor *) calloc(bp->ncolors, sizeof(XColor));
make_smooth_colormap (0, 0, 0, bp->colors0, &bp->ncolors, False, 0, False);
make_smooth_colormap (0, 0, 0, bp->colors1, &bp->ncolors, False, 0, False);
make_smooth_colormap (0, 0, 0, bp->colors2, &bp->ncolors, False, 0, False);
make_smooth_colormap (0, 0, 0, bp->colors3, &bp->ncolors, False, 0, False);
bp->ccolor = 0;
bp->obj_dlist0 = glGenLists (1);
bp->obj_dlist1 = glGenLists (1);
bp->obj_dlist2 = glGenLists (1);
bp->obj_dlist3 = glGenLists (1);
bp->scene_dlist1 = glGenLists (1);
bp->scene_dlist2 = glGenLists (1);
init_texture (mi);
generate_object (mi);
}
