This is stat.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 "segment.h"
#include "setprots.h"
#include "genprots.h"
#include "exprprots.h"
#include "namprots.h"
#include "procprots.h"
#include "maincaseprots.h"
#include "miscprots.h"
#include "gmiscprots.h"
#include "gutilprots.h"
#include "statprots.h"
static void select_move(Node, Symbol);
static Tuple sort_case(Tuple);
static int tcompar(Tuple *, Tuple *);
void compile_body(Node, Node, Node, int);
static int jump_false_code(Symbol);
static int jump_true_code(Symbol);
static Symbol jump_table_get(Tuple, int);
static Tuple jump_table_put(Tuple, int, Symbol);
/* Chapter 5: statements
* 5.2: Assignment statement
*/
void select_assign(Node var_node, Node expr_node, Symbol type_name)
/*;select_assign*/
{
Symbol var_name, expr_name;
var_name = N_UNQ(var_node);
expr_name = N_UNQ(expr_node);
if (is_simple_type(type_name) && is_simple_name(var_node)
&& !is_renaming(var_name) ) {
if ((is_simple_name(expr_node) && N_KIND(expr_node) != as_null
&& !is_renaming(expr_name))
|| (N_KIND(expr_node) == as_selector
|| N_KIND(expr_node) == as_index
|| N_KIND(expr_node) == as_all)) {
gen_address(expr_node);
gen_ks(I_INDIRECT_POP, kind_of(type_name), var_name);
}
else {
gen_value(expr_node);
gen_ks(I_POP, kind_of(type_name), var_name);
}
}
else {
gen_address(var_node);
select_move(expr_node, type_name);
}
}
static void select_move(Node node, Symbol type_name) /*;select_move*/
{
if (is_simple_type(type_name)) {
if ((N_KIND(node) != as_null
&& is_simple_name(node) && !is_renaming(N_UNQ(node)))
|| (N_KIND(node) == as_selector || N_KIND(node) == as_index
|| N_KIND(node) == as_all)) {
gen_address(node);
gen_k(I_INDIRECT_MOVE, kind_of(type_name));
}
else {
gen_value(node);
gen_k(I_MOVE, kind_of(type_name));
}
}
else {
if (is_array_type(type_name)) {
gen_value(node);
gen(I_ARRAY_MOVE);
}
else {
gen_value(node);
gen_s(I_RECORD_MOVE, type_name);
}
}
}
/* 5.4: Case statement */
Tuple make_case_table(Node cases_node) /*;make_case_table*/
{
/* Function : takes a set of alternatives, and produces a linear table
* suitable for jump table, of case ranges sorted in ascending
* order. Some optimisation is done, to merge contiguous
* ranges and to fill missing ranges with "others" case
* Input : case_node ::= {case_statements}
* case_statements ::= [choice_list, body]
* choice_list ::= { choice }
* choice ::= simple_choice | range_choice
* | others_choice
* simple_choice ::= [ value ]
* range_choice ::= [ subtype ]
* Output : [table, bodies, others_body]
* table ::= [ [ lower_bound, index ] ]
* - an extra pair is added with a "lower_bound" one step
* higher than necessary
* - "index" is an index in the tuple "bodies", and
* index = 0 means "others"
*/
Node case_statements_node, choice_list_node, body_node, choice_node,
lbd_node, ubd_node, others_body;
Tuple result, tup, bodies, triplets;
int index, a1, a2, a3, b1, b2, b3, lbd_int, ubd_int;
int empty;
Fortup ft1, ft2;
#ifdef TRACE
if (debug_flag)
gen_trace_node("MAKE_CASE_TABLE", cases_node);
#endif
/* 1. build a set of triples [lowerbound, upperbound, index] */
index = 0;
bodies = tup_new(0);
triplets = tup_new(0);
others_body = OPT_NODE;
FORTUP(case_statements_node = (Node), N_LIST(cases_node), ft1);
choice_list_node = N_AST1(case_statements_node);
body_node = N_AST2(case_statements_node);
index += 1;
empty = TRUE; /* may be we have an empty branch */
FORTUP(choice_node = (Node), N_LIST(choice_list_node), ft2);
switch (N_KIND(choice_node)) {
case (as_range):
lbd_node = N_AST1(choice_node);
ubd_node = N_AST2(choice_node);
lbd_int = get_ivalue_int(lbd_node);
ubd_int = get_ivalue_int(ubd_node);
if (lbd_int <= ubd_int) {
tup = tup_new(3);
tup[1] = (char *) lbd_int;
tup[2] = (char *) ubd_int;
tup[3] = (char *) index;
triplets = tup_with(triplets, (char *) tup);
empty = FALSE;
}
break;
case (as_others_choice):
others_body = body_node;
break;
default:
compiler_error( "Unknown kind of choice: ");
}
ENDFORTUP(ft2);
if (empty)
index -= 1;
else
bodies = tup_with(bodies, (char *) body_node);
ENDFORTUP(ft1);
result = tup_new(0);
if (tup_size(triplets) != 0) { /* We may have a completely empty case */
/* 2. sort the set of triples, giving a tuple */
triplets = sort_case(triplets);
/* 3. build the case table, filling gaps and merging adjacent cases */
tup = (Tuple) tup_fromb(triplets);
a1 = (int) tup[1];
a2 = (int) tup[2];
a3 = (int) tup[3];
while(tup_size(triplets) != 0) {
tup = (Tuple) tup_fromb(triplets);
b1 = (int) tup[1];
b2 = (int) tup[2];
b3 = (int) tup[3];
if (a2 != b1-1) { /* gap */
tup = tup_new(2);
tup[1] = (char *) a1;
tup[2] = (char *) a3;
result = tup_with(result, (char *) tup);
tup = tup_new(2);
tup[1] = (char *) (a2+1);
tup[2] = (char *) 0;
result = tup_with(result, (char *) tup);
a1 = b1;
a2 = b2;
a3 = b3;
}
else if (a3 == b3) { /* merge */
a2 = b2;
a3 = b3;
}
else {
tup = tup_new(2);
tup[1] = (char *) a1;
tup[2] = (char *) a3;
result = tup_with(result, (char *) tup);
a1 = b1;
a2 = b2;
a3 = b3;
}
}
tup = tup_new(2);
tup[1] = (char *) a1;
tup[2] = (char *) a3;
result = tup_with(result, (char *) tup);
tup = tup_new(2);
if (a2 != MAX_INTEGER) {
tup[1] = (char *) a2+1;
tup[2] = (char *) 0;
}
else {
tup[1] = (char *) 0; /* does not really matter */
tup[2] = (char *) a3;/* merge with the preceeding */
}
result = tup_with(result, (char *) tup);
}
tup = tup_new(3);
tup[1] = (char *) result;
tup[2] = (char *) bodies;
tup[3] = (char *) others_body;
return tup;
}
static Tuple sort_case(Tuple tuple_to_sort) /*;sort_case*/
{
/*
* Takes a set of case triples, and returns a tuple of those triple,
* sorted by ascending lower bounds. Quick sort algorithm.
* (sorry, this is not efficient, but was very easy to write)
*/
qsort((char *) &tuple_to_sort[1], tup_size(tuple_to_sort), sizeof (char *),
(int (*)(const void *, const void *))tcompar);
return tuple_to_sort;
}
static int tcompar(Tuple *ptup1, Tuple *ptup2) /*;tcompar*/
{
Tuple tup1, tup2;
int n1, n2;
tup1 = *ptup1;
tup2 = *ptup2;
/* called from sort_case to compare two elements in the case list */
n1 = (int) tup1[1];
n2 = (int) tup2[1];
if (n1 == n2) return 0;
else if (n1 < n2) return -1;
else return 1;
}
void gen_case(Tuple case_table, Tuple bodies_arg, Node others_body,int mem_unit)
/*;gen_case*/
{
/* Generates the code to select the right alternative and the bodies */
int index, lower_bound, i, n;
Node body_node;
Symbol end_case, jumpsym;
Tuple jump_table, tup;
Fortup ft1;
Tuple bodies;
bodies = tup_copy(bodies_arg); /* copy needed since used in tup_fromb */
end_case = new_unique_name("end_case");
gen_k(I_CASE, mem_unit);
/* The SETL jump_table map is represented as a 'tuple map' in C, with
* procedures jump_table_get() and jump_table_put() (defined below) used
* to retrieve and insert values in this map.
*/
jump_table = tup_new(0);
jump_table = jump_table_put(jump_table, 0, new_unique_name("case"));
gen_ks(I_CASE_TABLE, tup_size(case_table), jump_table_get(jump_table, 0) );
FORTUP(tup = (Tuple), case_table, ft1);
lower_bound = (int) tup[1];
index = (int) tup[2];
jumpsym = jump_table_get(jump_table, index);
if (jumpsym == (Symbol)0) { /* if no entry yet, make new one */
jumpsym = new_unique_name("case");
jump_table = jump_table_put(jump_table, index, jumpsym);
}
gen_ks(I_CASE_TABLE, lower_bound, jumpsym);
ENDFORTUP(ft1);
index = 0;
bodies = tup_exp(bodies, tup_size(bodies) + 1);
n = tup_size(bodies);
for (i = n; i > 1; i--) {
bodies[i] = bodies[i-1];
}
bodies[1] = (char *) others_body;
while (tup_size(bodies) != 0) {
body_node = (Node) tup_fromb(bodies);
gen_s(I_LABEL, jump_table_get(jump_table, index));
compile(body_node);
if (tup_size(bodies) != 0) { /* to avoid useless "jump $+1" */
gen_s(I_JUMP, end_case );
}
index += 1;
}
gen_s(I_LABEL, end_case);
tup_free(bodies);
}
/* 5.6: block statement (compile_body) */
void compile_body(Node decls_node, Node stmts_node, Node handler_node,
int is_block_statement) /*;compile_body*/
{
int save_last_offset;
/* stack frame offset for local variables */
/* will overlap for blocks at the same nesting level */
int save_tasks_declared;
Symbol start_handler, end_handler;
CURRENT_LEVEL += 1;
save_last_offset = LAST_OFFSET;
save_tasks_declared = TASKS_DECLARED;
TASKS_DECLARED = FALSE;
gen(I_ENTER_BLOCK);
compile(decls_node);
if (handler_node != OPT_NODE) {
start_handler = new_unique_name("handler");
gen_s(I_INSTALL_HANDLER, start_handler);
}
if (TASKS_DECLARED) {
gen(I_ACTIVATE);
}
compile(stmts_node);
if (handler_node != OPT_NODE) {
if (is_block_statement) {
/* use label allocated if return in accept else allocate
* a label for end of block (cf. comments in gen_accept)
*/
if (symbol_accept_return != (Symbol)0) {
end_handler = symbol_accept_return;
}
else {
end_handler = new_unique_name("end_handler");
}
gen_s(I_JUMP, end_handler);
gen_s(I_LABEL, start_handler);
compile(handler_node);
gen_s(I_LABEL, end_handler);
}
else {
gen_s(I_LABEL, start_handler);
compile(handler_node);
}
}
/*MAX_OFFSET max= abs LAST_OFFSET;*/
MAX_OFFSET = offset_max(MAX_OFFSET, LAST_OFFSET);
LAST_OFFSET = save_last_offset;
TASKS_DECLARED = save_tasks_declared;
CURRENT_LEVEL -= 1;
}
void gen_condition(Node node, Symbol destination, int branch_cond)
/*;gen_condition*/
{
/* IMPORTANT WARNING: destination is where to go when expression is
* equal to branch_cond
*/
/* These maps are realized in procedures immediately following.
* const
* jump_false_code = {
* ['=', I_JUMP_IF_FALSE],
* ['!=', I_JUMP_IF_TRUE],
* ['<', I_JUMP_IF_GREATER_OR_EQUAL],
* ['>', I_JUMP_IF_LESS_OR_EQUAL],
* ['<=', I_JUMP_IF_GREATER],
* ['>=', I_JUMP_IF_LESS] },
*
* jump_true_code = {
* ['=', I_JUMP_IF_TRUE],
* ['<', I_JUMP_IF_LESS],
* ['>', I_JUMP_IF_GREATER],
* ['<=', I_JUMP_IF_LESS_OR_EQUAL],
* ['>=', I_JUMP_IF_GREATER_OR_EQUAL] };
*/
Tuple tup;
Node opnode, args, op1, op2;
Symbol opcode, optype;
#ifdef TRACE
if (debug_flag)
gen_trace_node("GEN_CONDITION", node);
#endif
if (N_KIND(node) == as_op) {
opnode = N_AST1(node);
args = N_AST2(node);
opcode = N_UNQ(opnode);
if (opcode == symbol_eq || opcode == symbol_ne || opcode == symbol_lt
|| opcode == symbol_gt || opcode == symbol_le || opcode == symbol_ge){
tup = N_LIST(args);
op1 = (Node) tup[1];
op2 = (Node) tup[2];
gen_value(op1);
gen_value(op2);
optype = get_type(op1);
if (is_simple_type(optype)) {
if (is_float_type(optype))
gen_k(I_FLOAT_COMPARE, kind_of(optype));
else
gen_k(I_COMPARE, kind_of(optype));
}
else {
if (is_record_type(optype)) {
gen_s(I_PUSH_EFFECTIVE_ADDRESS, optype);
}
if (is_array_type(optype) &&
(opcode != symbol_eq) && (opcode != symbol_ne)) {
gen(I_COMPARE_ARRAYS);
}
else {
gen(I_COMPARE_STRUC);
}
}
}
else {
gen_value(node);
opcode = symbol_eq;
}
}
else {
gen_value(node);
opcode = symbol_eq;
}
if (branch_cond)
gen_s(jump_true_code(opcode), destination);
else
gen_s(jump_false_code(opcode), destination);
}
static int jump_false_code(Symbol op) /*;jump_false_code*/
{
if (op == symbol_eq) return I_JUMP_IF_FALSE;
else if (op == symbol_ne) return I_JUMP_IF_TRUE;
else if (op == symbol_lt) return I_JUMP_IF_GREATER_OR_EQUAL;
else if (op == symbol_gt) return I_JUMP_IF_LESS_OR_EQUAL;
else if (op == symbol_le) return I_JUMP_IF_GREATER;
else if (op == symbol_ge) return I_JUMP_IF_LESS;
else chaos("jump_false_code bad op");
return I_JUMP_IF_TRUE; /* return junk value */
}
static int jump_true_code(Symbol op) /*;jump_true_code*/
{
if (op == symbol_eq) return I_JUMP_IF_TRUE;
else if (op == symbol_ne) return I_JUMP_IF_FALSE;
else if (op == symbol_lt) return I_JUMP_IF_LESS;
else if (op == symbol_gt) return I_JUMP_IF_GREATER;
else if (op == symbol_le) return I_JUMP_IF_LESS_OR_EQUAL;
else if (op == symbol_ge) return I_JUMP_IF_GREATER_OR_EQUAL;
else chaos("jump_true_code");
return I_JUMP_IF_TRUE; /* return junk value for lint's sake */
}
void gen_loop(Node node) /*;gen_loop*/
{
/* Generate loop stratements */
Node id_node, iter_node, stmt_node, while_cond_node, var_node,
exp1_node, exp2_node;
Symbol label_name, start_loop, start_while, end_while, var_name,
end_for, for_body, for_start, void_loop;
int end_inst;
int kind_var;
int needs_check;
Const val1, val2;
#ifdef TRACE
if (debug_flag)
gen_trace_node("GEN_LOOP", node);
#endif
id_node = N_AST1(node);
iter_node = N_AST2(node);
stmt_node = N_AST3(node);
if (id_node != OPT_NODE) {
label_name = N_UNQ(id_node);
labelmap_put(label_name, LABEL_STATIC_DEPTH, (char *) CURRENT_LEVEL);
next_local_reference(label_name);
gen_s(I_SAVE_STACK_POINTER, label_name);
}
if (iter_node == OPT_NODE) { /* simple loop */
start_loop = new_unique_name("loop");
gen_s(I_LABEL, start_loop);
compile(stmt_node);
gen_s(I_JUMP, start_loop );
if (id_node != OPT_NODE)
gen_s(I_LABEL, label_name);
}
else if (N_KIND(iter_node) == as_while) { /* while loop */
while_cond_node = N_AST1(iter_node);
start_while = new_unique_name("start_while");
end_while = new_unique_name("end_while");
gen_sc(I_JUMP, end_while, "Test better at end of loop");
gen_s(I_LABEL, start_while);
compile(stmt_node);
gen_s(I_LABEL, end_while);
gen_condition(while_cond_node, start_while, TRUE);
if (id_node != OPT_NODE)
gen_s(I_LABEL, label_name);
}
else { /* for loop */
var_node = N_AST1(iter_node);
exp1_node = N_AST2(iter_node);
exp2_node = N_AST3(iter_node);
var_name = N_UNQ(var_node);
next_local_reference(var_name);
kind_var = kind_of(TYPE_OF(var_name));
val1 = get_ivalue(exp1_node);
val2 = get_ivalue(exp2_node);
end_inst = ((N_KIND(iter_node) == as_for)) ?
I_END_FOR_LOOP : I_END_FORREV_LOOP;
/* Static null range already checked by expander */
if (val1->const_kind != CONST_OM && val2->const_kind != CONST_OM
&& get_ivalue_int(exp1_node) == get_ivalue_int(exp2_node)) {
/* Loop executed only once, remove loop */
gen_value(exp1_node);
gen_k(I_CREATE_COPY, kind_var);
gen_s(I_UPDATE_AND_DISCARD, var_name);
compile(stmt_node);
if (id_node != OPT_NODE)
gen_s(I_LABEL, label_name);
gen_s(I_PUSH_EFFECTIVE_ADDRESS, var_name);
gen(I_UNCREATE);
}
else {
needs_check = (val1->const_kind == CONST_OM
|| val2->const_kind == CONST_OM );
if (N_KIND(iter_node) == as_for) {
gen_value(exp2_node);
if (needs_check) {
gen_k(I_DUPLICATE, kind_var);
}
gen_value(exp1_node);
if (needs_check) {
gen_k(I_DUPLICATE, kind_var);
}
}
else {
gen_value(exp1_node);
if (needs_check) {
gen_k(I_DUPLICATE, kind_var);
}
gen_value(exp2_node);
if (needs_check) {
gen_k(I_DUPLICATE, kind_var);
}
}
for_start = new_unique_name("for_start");
for_body = new_unique_name("for_body");
end_for = new_unique_name("end_for");
if (needs_check) {
void_loop = new_unique_name("void");
gen_k(I_CREATE_COPY, kind_var);
gen_s(I_UPDATE_AND_DISCARD, var_name);
gen_k(I_COMPARE, kind_var);
if (N_KIND(iter_node) == as_for) {
gen_s(I_JUMP_IF_GREATER_OR_EQUAL, for_start);
}
else {
gen_s(I_JUMP_IF_LESS_OR_EQUAL, for_start);
}
gen_ks(I_POP, kind_var, var_name);
gen_s(I_JUMP, void_loop);
gen_s(I_LABEL, for_start);
gen_s(I_PUSH_EFFECTIVE_ADDRESS, var_name);
}
else
{ /* loop executed at least once, no need for check */
gen_k(I_CREATE_COPY, kind_var);
gen_s(I_UPDATE, var_name);
}
gen_s(I_LABEL, for_body);
compile(stmt_node);
gen_s(I_LABEL, end_for);
gen_ks(end_inst, kind_var, for_body );
if (id_node != OPT_NODE) {
gen_s(I_LABEL, label_name);
}
if (needs_check) {
gen_s(I_LABEL, void_loop);
}
gen_s(I_PUSH_EFFECTIVE_ADDRESS, var_name);
gen(I_UNCREATE);
} /* static null loop */
}
}
static Symbol jump_table_get(Tuple jtab, int ndx) /*;jump_table_get()*/
{
int i, n;
n = tup_size(jtab);
for (i = 1; i <= n; i += 2) {
if ((int) jtab[i] == ndx)
return (Symbol) jtab[i+1];
}
return (Symbol)0;
}
static Tuple jump_table_put(Tuple jtab, int ndx, Symbol sym) /*;jump_table_put*/
{
/* set value of jump_table jtab for int ndx to be sym. jtab is a map
* kept as tuple.
*/
int i, n;
n = tup_size(jtab);
for (i = 1; i <= n; i += 2) {
if ((int) jtab[i] == ndx) {
jtab[i+1] = (char *) sym;
return jtab;
}
}
/* here to add new entry */
jtab = tup_exp(jtab, n+2);
jtab[n+1] = (char *) ndx;
jtab[n+2] = (char *) sym;
return jtab;
}
These are the contents of the former NiCE NeXT User Group NeXTSTEP/OpenStep software archive, currently hosted by Netfuture.ch.