nilopaim
/
tinycobol
1
0
Fork 0
Code Issues Pull Requests Packages Projects Releases Wiki Activity
tinycobol/compiler/htcobgen.c

6252 lines
153 KiB
C
Raw Permalink Blame History

/*
* Copyright (C) 2005, David Essex, Rildo Pragana.
* Copyright (C) 2003, Rildo Pragana, Bernard Giroud.
* Copyright (C) 2002, 2001, 2000, 1999, Rildo Pragana, Jim Noeth,
* David Essex, Glen Colbert, Andrew Cameron.
* Copyright (C) 1993, 1991 Rildo Pragana.
*
* This program 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 2, or (at your option)
* any later version.
*
* This program 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 this software; see the file COPYING. If not, write to
* the Free Software Foundation, Inc., 59 Temple Place, Suite 330,
* Boston, MA 02111-1307 USA
*/
/*
* Assembler Code Generator for Cobol Compiler
*/
#include "htconfig.h"
#include "htversion.h"
#include "htcoboly.h"
#include "htcoblib.h"
#include "htglobals.h"
#include "mwindows.h"
//unsigned int gen_move_first(struct sym *sy, unsigned int loc, unsigned int size, unsigned int *idx); // walter 13-12-05
void gen_loaddesc2(struct sym *sy, int variable_length);
int pgm_segment = 0; /* # of program in source file */
int screen_io_enable = 0; /* use screen routines or not for accept/display */
int decimal_comma = 0; /* decimal char 1 = ',' ; 0 ='.' */
#define decimal_char() (decimal_comma ? ',' : '.')
char currency_symbol = '$';
char sch_convert_buf[512];
struct sym *screen_status_field = NULL; /* variable of crt status */
struct sym *cursor_field = NULL; /* variable of cursor */
struct lit *program_name_literal = NULL; /* literal thar holds the program name */
int stabs_on_sw = 0;
extern struct lextab literal;
extern int yydebug;
extern struct sym *curr_file;
struct sym *curr_paragr = NULL, *curr_section = NULL;
struct sym *curr_field;
short curr_call_mode = 0;
short curr_call_convention = 0;
unsigned stack_offset = 0; /* offset for variables on the stack */
/*#define SAVED_EBX_OFFSET 4*/ /* relative to %ebp */
unsigned stack_plus = 0;
unsigned global_offset = 4; /* offset for global variables (DATA) */
/*unsigned file_offset=0;*/
unsigned literal_offset = 0;
unsigned data_offset = 0;
/*#define data_offset global_offset*/
unsigned linkage_offset = 0;
unsigned using_offset = 8;
/* tmpvar_offset: for storage of temporary variables,
with space reclaimed after the current instruction*/
unsigned tmpvar_offset = 0;
unsigned tmpvar_max = 0;
unsigned last_lineno = 0;
short at_procedure = 0;
short refmod_slots = 0;
static char name_buf[MAXNAMEBUF];
struct lit *spe_lit_ZE = NULL; /* figurative constant ZERO */
struct lit *spe_lit_SP = NULL; /* figurative constant SPACE */
struct lit *spe_lit_LV = NULL; /* figurative constant LOW-VALUE */
struct lit *spe_lit_HV = NULL; /* figurative constant HIGH-VALUE */
struct lit *spe_lit_QU = NULL; /* figurative constant QUOTE */
static char init_ctype; /* hold homogenous type */
static short init_val; /* hold homogenous value */
static struct init_str_tab *istrp;
static unsigned curr_01_location; /* hold current root father when set_field_location */
struct list *expr_list = NULL;
struct list *files_list = NULL;
struct list *disp_list = NULL;
struct parm_list *parameter_list = NULL;
struct list *fields_list = NULL;
struct list *last_field = NULL;
struct index_to_table_list *index2table = NULL;
struct named_sect *named_sect_list = NULL;
struct list *switches_list = NULL;
struct list *vars_list = NULL;
short next_available_sec_no = SEC_FIRST_NAMED;
short default_sec_no = SEC_WORKING;
short curr_sec_no = SEC_WORKING;
struct parm_list *chaining_list = NULL; /* chaining variables */
int screen_label = 0;
int para_label = 0;
int block_label = 0;
int line_label = 0;
int paragr_num = 1;
int loc_label = 1;
unsigned char picture[100]; /* for max 50 signs and counts */
int picix, piccnt, decimals, sign, v_flag, n_flag, digits, pscale;
int filler_num = 1;
int active[37];
int at_linkage = 0;
int stackframe_cnt = 0;
int inner_stack_size = 0;
#if !defined(__WINDOWS__)
char program_id[120] = "main";
char *pgm_label = "main";
#else
char program_id[120] = "_main";
char *pgm_label = "_main";
#endif
int initial_flag = 0;
struct list *report_list = NULL;
static int need_desc_length_cleanup = 0;
extern int stabs_started;
extern int main_flag; /* Does it have an main entry point */
extern int main_entry_flag; /* Specify main entry point */
extern char main_entry_buf[]; /* main entry point name */
int module_flag = 1; /* All (sub)programs are modules (routines) */
int nested_flag = 0; /* Is this program nested inside another program */
int has_linkage = 0; /* Has linkage section ? */
/*
** Symbol table management routines
*/
struct sym *vartab[ HASHLEN ] = {NULL};
struct sym *labtab[ HASHLEN ] = {NULL};
struct lit *littab[ HASHLEN ] = {NULL};
int
hash(char *s)
{
int val;
for (val = 0; *s != '\0';)
val += (unsigned char) toupper(*s++); // walter coloquei (unsigned char)
return ( val % HASHLEN);
}
char *
savename(char *s)
{
char *ap;
if ((ap = (char *) malloc(strlen(s) + 1)) != NULL)
strcpy(ap, s);
return ( ap);
}
char *
upcase(char *s, char *buf)
{
char *t;
int n = SYMBUF_SIZE - 1;
t = buf;
while (*s && n--)
{
*t++ = toupper(*s++);
}
if (n <= 0)
{
yyerror("Too large symbol");
}
*t = 0;
return buf;
}
void
update_xreflist(struct sym *as)
{
if ((as->xrefs.pos > 0) &&
(as->xrefs.lineno[as->xrefs.pos - 1] == source_lineno))
return;
if (as->xrefs.size <= as->xrefs.pos)
{
as->xrefs.size += 10;
as->xrefs.lineno = realloc(as->xrefs.lineno, sizeof (int) * as->xrefs.size);
}
as->xrefs.lineno[as->xrefs.pos] = source_lineno;
as->xrefs.pos++;
}
struct sym *
lookup(char *s, int tab)
{
char sbuf[SYMBUF_SIZE];
if (tab == SYTB_LIT)
{ /* literals tab */
struct lit *as;
for (as = littab[ hash(s) ]; as != NULL; as = as->next)
if (strcmp(s, as->name) == 0)
return ( (struct sym *) as);
return ( NULL);
}
else
{
struct sym *as;
s = upcase(s, sbuf);
if (tab == SYTB_VAR)
as = vartab[ hash(s) ];
else
as = labtab[ hash(s) ];
for (; as != NULL; as = as->next)
if (strcmp(s, as->name) == 0)
return ( as);
return ( NULL);
}
}
struct sym *
install(char *name, int tab, int cloning)
{
char sbuf[SYMBUF_SIZE];
struct sym *clone;
struct sym *as;
struct lit *al;
int val;
if (tab == SYTB_LIT)
{
al = (struct lit *) malloc(sizeof (struct lit));
if (al == NULL)
return NULL;
if ((al->name = savename(name)) == NULL)
return NULL;
val = hash(al->name);
al->next = littab[ val ];
littab[ val ] = al;
al->type = 0;
al->all = 0;
al->litflag = 1;
al->nick = NULL;
al->len = strlen(name);
return ( (struct sym *) al);
}
else
{
name = upcase(name, sbuf);
if ((as = lookup(name, tab)) == NULL)
{
as = (struct sym *) malloc(sizeof (struct sym));
memset(as, 0, sizeof (struct sym));
if (as == NULL)
return NULL;
if ((as->name = savename(name)) == NULL)
return NULL;
val = hash(as->name);
if (tab == SYTB_VAR)
{
/* fprintf(stderr,"install: creating %s -> 0x%x\n",as->name,as); */
as->next = vartab[ val ];
vartab[ val ] = as;
}
else
{
as->next = labtab[ val ];
labtab[ val ] = as;
}
as->type = 0;
as->flags.is_pointer = 0;
as->flags.just_r = 0;
as->flags.separate_sign = 0;
as->flags.leading_sign = 0;
as->flags.blank = 0;
as->flags.sync = 0;
as->slack = 0;
as->pscale = 0;
as->defined = 0;
as->value = as->sort_data = NULL;
as->linkage_flg = 0;
as->litflag = 0;
as->scr = NULL;
as->clone = as->parent = NULL;
as->son = NULL;
as->occurs = NULL;
as->xrefs.size = 1;
as->xrefs.pos = 0;
as->xrefs.lineno = malloc(sizeof (int));
as->xrefs.lineno[0] = 0;
}
else if ((cloning && (as->defined == 1)) || (cloning == 2))
{
/* install clone (cloning==2 -> force) */
/* fprintf(stderr,"install: cloning %s -> 0x%x\n",as->name,as); */
clone = (struct sym *) malloc(sizeof (struct sym));
memset(clone, 0, sizeof (struct sym));
if (clone == NULL)
return NULL;
clone->name = as->name;
clone->type = 0;
clone->flags.is_pointer = 0;
clone->flags.just_r = 0;
clone->flags.separate_sign = 0;
clone->flags.leading_sign = 0;
clone->flags.blank = 0;
clone->flags.sync = 0;
clone->slack = 0;
clone->pscale = 0;
clone->defined = 0;
clone->value = as->sort_data = NULL;
clone->linkage_flg = 0;
clone->litflag = 0;
clone->scr = NULL;
clone->parent = NULL;
clone->occurs = NULL;
clone->clone = as->clone;
as->clone = clone;
as = clone;
}
return ( as);
}
}
struct lit *
install_lit(char *name, int length, int all)
{
struct lit *al;
int val;
/* if length was not given, take the length from the name string */
if (length == 0)
{
length = strlen(name);
}
al = (struct lit *) malloc(sizeof (struct lit));
if (al == NULL)
return NULL;
/* it is safer to null terminate it, so alloc one char more */
al->name = malloc(length + 1);
if (al->name == NULL)
{
return NULL;
}
memcpy(al->name, name, length);
*(al->name + length) = 0;
val = hash(al->name);
al->next = littab[ val ];
littab[ val ] = al;
al->type = 0;
al->all = all;
al->litflag = 1;
al->nick = NULL;
al->len = length;
return al;
}
struct sym *
lookup_label(struct sym *sy, struct sym *parent)
{
#if 0
#ifdef DEBUG_COMPILER
fprintf(stderr, "lookup_label: %s", sy->name);
#endif
#endif
while (sy->clone && (sy->parent != parent))
sy = sy->clone;
if (sy->parent == parent)
{
#if 0
#ifdef DEBUG_COMPILER
if (sy->parent != NULL)
fprintf(stderr, " found -> %s\n", sy->parent->name);
else
fprintf(stderr, " found\n");
#endif
#endif
return sy;
}
else
{
#if 0
#ifdef DEBUG_COMPILER
fprintf(stderr, " not found\n");
#endif
#endif
return NULL;
}
}
struct sym *
lookup_variable(struct sym *sy, struct sym *parent)
{
struct sym *tmp;
/* sy = lookup(sy->name,SYTB_VAR); */
if (parent->litflag == 2)
{
parent = (struct sym *) ((struct vref *) parent)->sym;
}
while (1)
{
tmp = sy;
while (tmp && tmp->parent != parent)
tmp = tmp->parent;
if (tmp && tmp->parent == parent)
break;
if (sy->clone == NULL)
break;
sy = sy->clone;
}
return sy;
}
struct sym *
lookup_parent(struct sym *sy, struct sym *parent)
{
struct sym *tmp;
if (parent->litflag == 2)
{
parent = (struct sym *) ((struct vref *) parent)->sym;
}
while (sy)
{
tmp = sy;
while (tmp && tmp->parent != parent)
tmp = tmp->parent;
if (tmp && tmp->parent == parent)
break;
sy = sy->clone;
}
return sy;
}
struct sym *
lookup_for_redefines(struct sym *sy)
{
struct sym *tmp;
if (curr_field->parent == NULL)
{
tmp = lookup(sy->name, SYTB_VAR);
}
else
{
tmp = lookup_variable(sy, curr_field->parent);
}
return tmp;
}
void
clear_symtab()
{
struct sym *sy, *sy1, *tmp;
/* struct lit *lt,*lt1,*ltmp; */
int i;
for (i = 0; i < HASHLEN; i++)
{
for (sy1 = vartab[i]; sy1 != NULL;)
{
for (sy = sy1->clone; sy;)
{
if (sy)
{
tmp = sy;
sy = sy->clone;
free(tmp);
}
}
tmp = sy1;
sy1 = sy1->next;
free(tmp);
}
vartab[i] = NULL;
}
for (i = 0; i < HASHLEN; i++)
{
for (sy1 = labtab[i]; sy1 != NULL;)
{
for (sy = sy1->clone; sy;)
{
if (sy)
{
tmp = sy;
sy = sy->clone;
free(tmp);
}
}
tmp = sy1;
sy1 = sy1->next;
free(tmp);
}
labtab[i] = NULL;
}
/*for (i=0;i<HASHLEN;i++) {
for (lt1=littab[i];lt1!=NULL;) {
ltmp = lt1;
lt1 = lt1->next;
free(ltmp);
}
littab[i] = NULL;
}*/
}
/* clear_offset() is called when starting a new program segment */
void
clear_offsets()
{
stack_offset = 0;
global_offset = 4;
literal_offset = 0;
data_offset = 0;
linkage_offset = 0;
using_offset = 8;
refmod_slots = 0;
free_list(fields_list);
fields_list = NULL;
free_list(files_list);
files_list = NULL;
/* clear all current paragraphs/sections and fields */
curr_paragr = NULL;
curr_section = NULL;
curr_field = NULL;
/* free tmpvar storage */
tmpvar_offset = 0;
tmpvar_max = 0;
stabs_started = 0;
}
/*** we need this because the literal string is already stored ***/
char
sign_to_char(int digit)
{
char cDigit;
if (!digit)
cDigit = '}';
else if (digit == 0x80)
cDigit = '{';
else if (digit > 0)
cDigit = (char) ('A' + digit - 1);
else
cDigit = (char) ('J' - digit - 1);
return cDigit;
}
void
invert_literal_sign(struct lit *sy)
{
char *s = sy->name;
int off = strlen(sy->name) - 1;
s[off] = sign_to_char(-(s[off] - '0'));
}
void
check_decimal_point(struct lit *lit)
{
char *s = lit->name;
if ((decimal_comma && strchr(s, '.')) ||
(!decimal_comma && strchr(s, ',')))
{
yyerror("wrong decimal point character in numeric literal");
}
}
int
is_variable(struct sym *sy)
{
int r = 0;
if (sy->litflag == 0)
{
switch (sy->type)
{
case '8': /* 88 field */
case DTYPE_DISPLAY: /* numeric */
case DTYPE_ALPHA: /* alpha */
case DTYPE_BININT: /* binary (comp/computational) */
case DTYPE_PACKED: /* compacted (comp-3/comptational-3) */
case DTYPE_ACCEPT_DISPLAY: /* screen data */
case DTYPE_EDITED: /* edited */
case DTYPE_GROUP: /* group */
case DTYPE_FLOAT: /* float(comp-1 4 bytes) / double(comp-2 8 bytes) */
case DTYPE_ALPHANUMERIC: /* alphanum */
r = 1;
break;
default:
r = 0;
break;
}
}
return r;
}
int
is_subscripted(struct sym *sy)
{
if (sy->occurs_flg) /* the item itself "occurs" */
return 1;
while (sy->parent != NULL)
{ /* some parenr "occurs" */
sy = sy->parent;
if (sy->occurs_flg)
return 1;
}
return 0;
}
int
adjust_linkage_vars(int start_offset)
{
struct sym *sy, *sy1;
int i;
int offset = start_offset;
for (i = 0; i < HASHLEN; i++)
{
for (sy1 = vartab[i]; sy1 != NULL; sy1 = sy1->next)
{
for (sy = sy1; sy; sy = sy->clone)
{
if (sy->parent == NULL && sy->linkage_flg == 1)
{
sy->linkage_flg = -offset;
offset += 4;
}
}
}
}
return offset;
}
/*
* Put a field to its initial value.
* It can be a value specified by 'value' or an initialization value
* If it is a group field, initialize all the fields under it.
*/
static void
set_initial_value(struct sym *sy)
{
int j, nb_fields;
struct init_str init_templ;
if (sy->redefines) return;
#ifdef DEBUG_COMPILER
if (sy->value)
fprintf(o_src, "# initial value to field '%s' = '%s' \n",
sy->name, sy->value->name);
else
fprintf(o_src, "# initial value to field '%s', INITIALIZED \n",
sy->name);
#endif
/* Initialize a non-group field */
if (sy->level == 77 || (sy->level == 1 && sy->son == NULL))
{
if (sy->value)
gen_move_init((struct sym *) sy->value, sy); /* initial value */
else
gen_initialize(sy, 0); /* initialize at spaces or 0 */
return;
}
/* Initialize a group to zero or blank */
init_ctype = ' ';
init_val = -1;
nb_fields = get_nb_fields(sy, 1);
if (init_ctype != '&' && init_ctype != ' ' && init_val > 1)
{
gen_init_str(sy, init_ctype, symlen(sy));
return;
}
/* Initialize a group's fields one by one */
#ifdef DEBUG_COMPILER
fprintf(o_src, "# istrp = malloc(%d) nb_fields = %d\n",
nb_fields * sizeof (init_templ), nb_fields);
#endif
istrp = malloc(nb_fields * sizeof (init_templ));
build_init_str(sy, nb_fields);
for (j = 0; j < nb_fields; j++)
{
if (istrp->ent[j].value != NULL)
{
unsigned saved_loc = istrp->ent[j].sy->location;
istrp->ent[j].sy->location = istrp->ent[j].location;
gen_move_init((struct sym *) istrp->ent[j].sy->value
, istrp->ent[j].sy);
istrp->ent[j].sy->location = saved_loc;
}
}
free(istrp);
istrp = NULL;
return;
}
/*
* Initialize all the variables at the beginig of the program
*/
void
do_init_val()
{
struct sym *sy, *sy1, *v;
int i;
char typ;
for (i = 0; i < HASHLEN; i++)
for (sy1 = vartab[i]; sy1 != NULL; sy1 = sy1->next)
for (sy = sy1; sy != NULL; sy = sy->clone)
if (sy->type != 'F' && sy->type != '8' &&
sy->type != 'K' && sy->type != 'J')
{
v = sy;
typ = v->type;
if (typ == 'F' || typ == 'R' || typ == 'K' || typ == 'J'
|| typ == '8')
continue;
/* Here only work with level 1 and 77 */
if (v->level != 1 && v->level != 77) continue;
/* Don't initialize fields in linkage */
if (v->linkage_flg) continue;
set_initial_value(v);
}
}
void
save_field_in_list(struct sym *sy)
{
struct list *list;
if (fields_list == NULL)
{
list = (struct list *) malloc(sizeof (struct list));
last_field = fields_list = list;
list->next = NULL;
list->var = sy;
}
else
{
list = (struct list *) malloc(sizeof (struct list));
list->var = sy;
list->next = NULL;
last_field->next = list;
last_field = list;
}
}
void
save_literal(struct lit *v, int type)
{
char *s;
char *dp;
int piclen;
/* if (v->type) return; */ /* already saved */
s = v->name;
piclen = 3; /* assume 'X'-only literal */
if ((type == DTYPE_DISPLAY) && (*(v->name + v->len - 1) > '9'))
{
piclen += 2; /* we need space for the sign picture char */
}
if (type != DTYPE_ALPHANUMERIC && (dp = strchr(s, decimal_char())) != NULL)
{
piclen += 4; /* reserve space for 'V' and decimal part */
v->decimals = v->len - (int) (dp - s) - 1;
}
else v->decimals = 0;
/* v->pscale=0; */
if (type == DTYPE_ALPHANUMERIC && v->len > 255)
{
piclen += (v->len / 255)*2;
}
v->type = type;
/****** save literal in fields list for later *******/
save_field_in_list((struct sym *) v);
/******** save address of const string ************/
v->location = literal_offset;
v->sec_no = SEC_CONST;
if (v->decimals)
literal_offset += v->len;
/* it's already one chr larger (decimal point) */
else
literal_offset += v->len + 1;
/******** save address of field descriptor ********/
v->descriptor = literal_offset;
literal_offset += HTG_fld_desc_len + piclen;
/* printf("save_literal: name=%s, type=%c, offset=%x, piclen=%d\n",
v->name, v->type, v->descriptor, piclen); */
}
void
save_named_sect(struct sym *sy)
{
/*char *s;
char *dp;*/
struct named_sect *nsp;
nsp = (struct named_sect *) malloc(sizeof (struct named_sect));
sy->flags.external = 1;
nsp->sec_no = next_available_sec_no++;
/* nsp->os_name = sy->name; walter...why these ??? */
nsp->os_name = (char *) malloc(strlen(nsp->os_name) + 1);
strcpy(nsp->os_name, sy->name);
chg_underline(nsp->os_name);
nsp->next = named_sect_list;
named_sect_list = nsp;
curr_sec_no = nsp->sec_no;
sy->sec_no = curr_sec_no;
}
struct lit *
save_special_literal(char val, char picc, char *nick)
{
struct lit *v;
v = (struct lit *) install(nick, SYTB_LIT, 0);
if (v->type) return NULL; /* already saved */
v->decimals = 0;
/* v->pscale=0; */
v->type = picc;
v->nick = (char *) malloc(2);
v->nick[0] = val;
v->nick[1] = 0;
v->len = 1;
v->all = 0;
save_field_in_list((struct sym *) v);
v->location = literal_offset;
v->sec_no = SEC_CONST;
literal_offset += 2; /* we have only 1-char special literals */
v->descriptor = literal_offset;
literal_offset += (HTG_fld_desc_len + 3);
return v;
}
void
define_switch_field(struct sym *sy, struct sym *sy2)
{
curr_field = NULL;
define_field(77, sy);
curr_field->len = 2;
curr_field->type = DTYPE_BININT;
curr_field->decimals = 0;
picture[0] = '9';
picture[1] = 4;
picture[2] = 0;
curr_field->ix_desc = sy2;
update_field(curr_field);
sy2->defined = 1; /* switch number is implicitly defined */
switches_list = insert_list(switches_list, sy);
}
struct lit *
define_num_lit(int value)
{
char tblmax[21];
struct lit *v;
sprintf(tblmax, "%d", value);
v = (struct lit *) install(tblmax, SYTB_LIT, 0);
save_literal(v, DTYPE_DISPLAY);
return v;
}
void
save_switch_value(struct sym *sy, int value)
{
struct lit *v;
v = define_num_lit(value);
define_field(88, sy);
sy->value = v;
sy->value2 = v;
}
void
put_disp_list(struct sym *sy)
{
struct list *list, *tmp;
#if 0
if ((!(sy->defined)) && (sy->litflag != 1))
{
yyerror("variable %s not defined", sy->name);
}
#endif
/* fprintf(o_src,"# put_disp_list: %s\n",sy->name); */
list = (struct list *) malloc(sizeof (struct list));
list->var = sy;
list->next = NULL;
if (disp_list == NULL)
disp_list = list;
else
{
tmp = disp_list;
while (tmp->next != NULL) tmp = tmp->next;
tmp->next = list;
}
}
int
pic_digits(struct sym *sy, char target)
{
char *p = NULL;
int len = 0;
if (sy == NULL)
return 0;
if (sy->litflag)
{
len = strlen(sy->name);
if (strchr(sy->name, decimal_char())) len--;
if (strchr(sy->name, '+')) len--;
if (strchr(sy->name, '-')) len--;
/* printf("pic_digits: %s -> %d\n",sy->name,len); */
return len;
}
else
{
p = sy->picstr;
while (*p)
{
if (*p++ == target)
{
len += *p++;
}
else
p++;
}
}
/* printf("pic_digits: %s -> %d\n",sy->name,len); */
return len;
}
/* Return the maximum length which might be occupied by a corresponding value */
int
get_max_edt_len(struct sym * sy)
{
int plen;
/*walter*/
if (sy->type == DTYPE_BININT)
return (sy->len * 3);
/*fimwalter*/
if (sy->type == DTYPE_ALPHANUMERIC || sy->type == DTYPE_ALPHA ||
sy->type == DTYPE_EDITED || sy->type == DTYPE_GROUP ||
sy->type == DTYPE_ALPHANUMERICL || sy->type == DTYPE_ACCEPT_DISPLAY)
{
plen = sy->len;
}
else
{
plen = pic_digits(sy, '9');
if (sy->picstr[0] == 'S') plen++;
if (sy->decimals > 0) plen++;
if (sy->pscale != 0) plen = plen + abs(sy->pscale);
}
return plen;
}
int
query_comp_len(struct sym * sy)
{
int plen;
// char target = '9';
if (sy->stype == 'X')
{
// target = 'X';
plen = pic_digits(sy, 'X');
/* for the time being, picture is altered just before output
in htcobemt.c */
/* strcpy(sy->picstr,"9\xa"); */ /* max picture for 4 bytes */
return plen;
}
else
{
if ((plen = pic_digits(sy, '9')) <= 2)
return 1;
if (plen <= 4)
return 2;
if (plen <= 9)
return 4;
return 8;
}
}
int
symlen(struct sym *sy)
{
/*int plen;*/
if (sy->type == DTYPE_PACKED)
return sy->len / 2 + 1;
else if (sy->litflag == 1)
return ((struct lit *) sy)->len;
return sy->len;
}
/* Returns the minimum number of 9 to hold a complete value */
int
sym_min_pic(struct sym *sy)
{
if (sy->type != DTYPE_BININT)
return sy->len;
if (sy->stype != 'X')
return pic_digits(sy, '9');
switch (symlen(sy))
{
case 1: return 3;
case 2: return 5;
case 4: return 10;
case 8: return 19;
}
return pic_digits(sy, '9');
}
void
add_alternate_key(struct sym *sy, int duplicates)
{
struct sym *f = curr_file;
struct alternate_list *alt, *new;
alt = (struct alternate_list *) f->alternate;
new = malloc(sizeof (struct alternate_list));
new->next = alt;
new->key = sy;
new->duplicates = duplicates;
f->alternate = (struct sym *) new;
}
struct list *
insert_list(struct list *l, void *item)
{
struct list *tmp;
if (l == NULL)
{
l = malloc(sizeof (struct list));
l->var = item;
l->next = NULL;
}
else
{
for (tmp = l; tmp->next != NULL; tmp = tmp->next);
tmp->next = malloc(sizeof (struct list));
tmp->next->var = item;
tmp->next->next = NULL;
}
return l;
}
struct gvar_list *
gvar_list_append(struct gvar_list *l, struct sym *item, int linenum)
{
struct gvar_list *tmp;
if (l == NULL)
{
tmp = malloc(sizeof (struct gvar_list));
l = tmp;
}
else
{
for (tmp = l; tmp->next != NULL; tmp = tmp->next);
tmp->next = malloc(sizeof (struct gvar_list));
tmp = tmp->next;
}
tmp->u.sym = item;
tmp->attribute = linenum;
tmp->next = NULL;
return l;
}
void
sort_keys_append(struct sym *fname, struct gvar_list *l)
{
struct gvar_list *gvar_w1, *gvar_w2;
struct sym *sym_wk;
for (gvar_w1 = l; gvar_w1 != NULL; gvar_w1 = gvar_w1->next)
{
for (gvar_w2 = gvar_w1->u.gvar; gvar_w2 != NULL; gvar_w2 = gvar_w2->next)
{
sym_wk = gvar_w2->u.sym;
sym_wk->direction = gvar_w1->attribute;
sym_wk->sort_data = fname->sort_data;
/* fname->sort_data = sym_wk; */
fname->sort_data = (void *) sym_wk;
}
}
}
struct gvar_list *
sort_key_list_create(struct gvar_list *item, int atrbt)
{
struct gvar_list *l;
l = malloc(sizeof (struct gvar_list));
l->u.gvar = item;
l->attribute = atrbt;
l->next = NULL;
return l;
}
struct gvar_list *
sort_keys_list_append(struct gvar_list *l, struct gvar_list *item)
{
struct gvar_list *tmp;
if (l == NULL)
{
l = item;
}
else
{
for (tmp = l; tmp->next != NULL; tmp = tmp->next);
tmp->next = item;
}
return l;
}
void
free_list(struct list *l)
{
struct list *tmp;
while (l != NULL)
{
tmp = l->next;
free(l);
l = tmp;
}
l = NULL;
}
void
mark_decl_list(struct list *l)
{
struct list *tmp;
while (l != NULL)
{
((struct sym *) l->var)->refmod_redef.declarative = curr_section;
tmp = l->next;
free(l);
l = tmp;
}
}
struct scr_info *
alloc_scr_info()
{
struct scr_info *new;
struct scr_info *parent_info = NULL;
if (curr_field && curr_field->parent)
parent_info = curr_field->parent->scr;
new = malloc(sizeof (struct scr_info));
new->attr = 0;
new->line = 0;
new->column = 0;
new->foreground = NULL;
new->background = NULL;
new->color = NULL;
new->line_var = NULL;
new->column_var = NULL;
new->from = NULL;
new->to = NULL;
new->line_sign = 0;
new->column_sign = 0;
new->size = NULL;
if (parent_info) /* If exists copy information from parent field */
{
new->attr = parent_info->attr;
new->foreground = parent_info->foreground;
new->background = parent_info->background;
new->color = parent_info->color;
/* new->line = parent_info->line; */
/* new->column = parent_info->column; */
/* new->line_var = parent_info->line_var; */
/* new->column_var = parent_info->column_var; */
/* new->line_sign = parent_info->line_sign; */
/* new->column_sign = parent_info->column_sign; */
}
if (parent_info && curr_field->parent->son != curr_field)
{
new->line = new->column = 0;
new->line_var = new->column_var = NULL;
new->line_sign = new->column_sign = 0;
}
return new;
}
struct inspect_before_after *
alloc_inspect_before_after(struct inspect_before_after *ba,
int before_after, struct sym *var)
{
if (ba == NULL)
{
ba = malloc(sizeof (struct inspect_before_after));
ba->before = ba->after = NULL;
}
if (before_after == 1)
{ /* before given */
if (ba->before)
{
yyerror("only one BEFORE phrase can be given");
}
else
{
ba->before = var;
}
}
else if (before_after == 2)
{ /* after given */
if (ba->after)
{
yyerror("only one AFTER phrase can be given");
}
else
{
ba->after = var;
}
}
return ba;
}
struct converting_struct *
alloc_converting_struct(struct sym *fromvar, struct sym *tovar,
struct inspect_before_after *ba)
{
struct converting_struct *new;
new = malloc(sizeof (struct converting_struct));
new->fromvar = fromvar;
new->tovar = tovar;
new->before_after = ba;
return new;
}
struct tallying_list *
alloc_tallying_list(struct tallying_list *tl, struct sym *count,
struct tallying_for_list *tfl)
{
struct tallying_list *new;
new = malloc(sizeof (struct tallying_list));
new->next = tl;
new->tflist = tfl;
new->count = count;
return new;
}
struct tallying_for_list *
alloc_tallying_for_list(struct tallying_for_list *tfl, int options,
struct sym *forvar, struct inspect_before_after *ba)
{
struct tallying_for_list *new;
new = malloc(sizeof (struct tallying_for_list));
new->next = tfl;
new->options = options;
new->forvar = forvar;
new->before_after = ba;
return new;
}
struct replacing_list *
alloc_replacing_list(struct replacing_list *rl, int options,
struct replacing_by_list *rbl, struct sym *byvar,
struct inspect_before_after *ba)
{
struct replacing_list *new;
new = malloc(sizeof (struct replacing_list));
new->next = rl;
new->options = options;
new->replbylist = rbl;
new->byvar = byvar;
new->before_after = ba;
return new;
}
struct replacing_by_list *
alloc_replacing_by_list(struct replacing_by_list *rbl,
struct sym *replvar, struct sym *byvar,
struct inspect_before_after *ba)
{
struct replacing_by_list *new;
new = malloc(sizeof (struct replacing_by_list));
new->next = rbl;
new->replvar = replvar;
new->byvar = byvar;
new->before_after = ba;
return new;
}
struct unstring_delimited *
alloc_unstring_delimited(short int all, struct sym *var)
{
struct unstring_delimited *ud;
ud = malloc(sizeof (struct unstring_delimited));
ud->next = NULL;
ud->var = var;
ud->all = all;
return ud;
}
struct unstring_destinations *
alloc_unstring_dest(struct sym *var, struct sym *delim, struct sym *count)
{
struct unstring_destinations *ud;
ud = malloc(sizeof (struct unstring_destinations));
ud->next = NULL;
ud->var = var;
ud->delim = delim;
ud->count = count;
return ud;
}
struct string_from *
alloc_string_from(struct sym *var, struct sym *delim)
{
struct string_from *sf;
sf = malloc(sizeof (struct string_from));
sf->next = NULL;
sf->var = var;
sf->delim = delim;
return sf;
}
void
gen_unstring(struct sym *var, struct unstring_delimited *delim,
struct unstring_destinations *dest, struct sym *ptr,
struct sym *tally)
{
struct unstring_destinations *dest1;
struct unstring_delimited *delim1;
fprintf(o_src, "# UNSTRING %s\n", var->name);
gen_loadvar((struct sym *) NULL); /* mark the end of destinations */
while (dest)
{
gen_loadvar(dest->count);
gen_loadvar(dest->delim);
gen_loadvar(dest->var);
dest1 = dest;
dest = dest->next;
free(dest1);
}
gen_loadvar((struct sym *) NULL); /* mark the end of delimiters */
while (delim)
{
push_immed(delim->all); /* push "all" flag */
gen_loadvar(delim->var);
delim1 = delim;
delim = delim->next;
free(delim1);
}
gen_loadvar(tally);
gen_loadvar(ptr);
gen_loadvar(var);
asm_call("tcob_unstring");
}
void
gen_stringcmd(struct string_from *sf, struct sym *sy, struct sym *ptr)
{
struct string_from *sf1;
fprintf(o_src, "# STRING into %s\n", sy->name);
gen_loadvar((struct sym *) NULL); /* mark the end of variables */
/* DELIMITED BY SIZE implied at end of source list */
if (sf && (sf->delim == (struct sym *) - 1))
sf->delim = (struct sym *) NULL;
/* Load the string_from source list */
while (sf)
{
gen_loadvar(sf->delim);
gen_loadvar(sf->var);
sf1 = sf;
sf = sf->next;
/* Delimiter of -1 means use previous delimiter */
if (sf && (sf->delim == (struct sym *) - 1))
sf->delim = sf1->delim;
free(sf1);
}
gen_loadvar(ptr);
gen_loadvar(sy);
asm_call("tcob_stringcmd");
}
/* walter acrescentei cor */
static
void
gen_display_screen_item(struct sym *sy, int main, int color)
{
struct sym *tmp, *var = sy;
struct list *tmpl;
if (var->litflag == 2 || var->litflag == 4)
{
var = ((struct vref *) var)->sym;
if (var->litflag == 2)
var = ((struct vref *) var)->sym;
}
if ((!(var->defined)) && (var->litflag != 1))
{
yyerror("variable %s not defined", var->name);
}
if (main)
{
fprintf(o_src, "# Screen Section: %s\n", var->name);
}
if (var->son == NULL)
{
fprintf(o_src, "# Screen Field: %s\n", var->name);
gen_call_scr_process(var);
}
else
{
for (tmp = var->son; tmp != NULL; tmp = tmp->brother)
{
gen_display_screen_item(tmp, 0, color);
}
}
if (main)
{
asm_call("tcob_display_screen");
if (disp_list->next)
{
yyerror("we do not handle more than one screen");
}
tmpl = disp_list;
disp_list = disp_list->next;
free(tmpl);
}
}
/* walter acrescentei cor */
void
gen_display_screen(int nl, int color)
{
gen_display_line(1, nl, color);
}
/* walter acrescentei cor */
void
gen_display_line(int dupon, int nl, int color)
{
struct list *tmp;
/*int len;*/
int dspflags;
int first = 1;
struct sym *sy;
if (disp_list)
{
/* separate screen displays from display of regular variables */
sy = (struct sym *) disp_list->var;
if (disp_list && sy->litflag != 1)
{
if (sy->litflag != 4 && sy->litflag != 2 && sy->scr)
{
gen_display_screen_item(disp_list->var, 1, color);
return;
}
}
/* continue w/a regular variable display */
if (nl & SCR_ERASE_EOL)
{
if (screen_io_enable == 0)
{
push_immed(dupon);
asm_call("tcob_display_erase");
}
}
}
while (disp_list)
{
sy = disp_list->var;
if ((!(sy->defined)) && (sy->litflag == 0))
{
yyerror("variable %s not defined,%d", sy->name, sy->litflag);
}
if (screen_io_enable == 0)
{
push_immed(dupon);
gen_loadvar(sy);
asm_call("tcob_display");
}
else
{
dspflags = nl;
if (first)
{
first = 0;
}
else
{
dspflags &= ~2; /* avoid erasing from now on */
}
if (disp_list->next != NULL)
{
dspflags |= 1; /* allow newline only at the last item */
}
push_immed(color); /* walter */
push_immed(dspflags);
gen_loadvar(sy);
asm_call("tcob_display_curses");
}
tmp = disp_list;
disp_list = disp_list->next;
free(tmp);
tmp = NULL;
}
if (!(nl & SCR_NO_ADVANCING))
{
if (screen_io_enable == 0)
{
push_immed(dupon);
asm_call("tcob_newline");
}
}
stabs_line();
}
/*
* Call the function to set the display or accept position
*/
void
gen_gotoxy_expr()
{
stackframe_cnt += 16; /* eliminate the coords expressions */
asm_call("tcob_goxy_expr");
}
void
gen_gotox_expr()
{
stackframe_cnt += 8; /* eliminate the coord expressions */
asm_call("tcob_gox_expr");
}
void
gen_gotoy_expr()
{
stackframe_cnt += 8; /* eliminate the coord expressions */
asm_call("tcob_goy_expr");
}
/* walter
main sempre 1, o unico caso que e 0 e qdo usa recursividade
echo 0 - stop literal (forcado) e qdo vem do parse traz valor
acrescentei color */
void
gen_accept(struct sym *sy, int echo, int main, int color)
{
struct sym *tmp, *var = sy;
int not_screen_mask = SCR_ERASE_EOL | SCR_ERASE_EOS | SCR_NO_ADVANCING;
if ((echo & not_screen_mask) != echo)
{ /* determine if the options require curses */
screen_io_enable = 1;
HTG_prg_uses_term = 1;
}
if (var->litflag == 2 || var->litflag == 4)
{
var = ((struct vref *) var)->sym;
if (var->litflag == 2)
{
var = ((struct vref *) var)->sym;
}
}
if (sy->litflag == 4)
{
echo |= SCR_IS_REFMOD;
}
if (var->scr)
{ /* screen or screen-item accept */
if (main)
{
fprintf(o_src, "# Screen Section: %s\n",
var->name);
}
if (var->son == NULL)
{
fprintf(o_src, "# Screen Field: %s\n",
var->name);
gen_call_scr_process(var);
}
else
{
for (tmp = var->son; tmp != NULL; tmp = tmp->brother)
{
gen_accept(tmp, echo, 0, color);
}
}
if (main)
asm_call("tcob_accept_screen");
}
else
{
push_immed(color); /* walter */
push_immed(echo);
/* why this? Why not the standard code generating
function, gen_loaddesc()??? */
/*fprintf(o_src,"\tmovl\t$c_base%d+%u, %%eax\n",
pgm_segment,var->descriptor);
push_eax();*/
gen_loaddesc2(sy, 1);
/* this work better with the original symbol (sy),
because it will be interpreted as a refmod
or subscripted variable. */
/* gen_loadloc( var ); */
gen_loadloc(sy);
if (screen_io_enable == 0)
asm_call("tcob_accept_std");
else
asm_call("tcob_accept_curses");
}
stabs_line();
}
void
gen_accept_from_chron(struct sym *sy, int date_fmt, int is_yyyy)
{
push_immed(is_yyyy);
push_immed(date_fmt);
gen_loadvar(sy);
asm_call("tcob_accept_chron");
}
void
gen_accept_from_inkey(struct sym *sy)
{
gen_loadloc(sy);
asm_call("tcob_accept_inkey");
}
/* walter */
void
gen_accept_from_escapekey(struct sym *sy)
{
gen_loadloc(sy);
asm_call("tcob_accept_escapekey");
}
void
gen_accept_from_cmdline(struct sym *sy)
{
struct sym *sy1;
gen_loadvar(sy);
/*
fprintf(o_src,"\tmovl\t12(%%ebp), %%eax\n");
push_eax();
fprintf(o_src,"\tmovl\t8(%%ebp), %%eax\n");
push_eax();
*/
asm_call("tcob_accept_cmd_line");
/* Set RETURN-CODE with the value returned by
* the "accept_cmd_line" function, which is stored
* in register %eax
*/
if ((sy1 = lookup(SVAR_RETURN_CODE, SYTB_VAR)) != NULL)
{
if (sy1->sec_no == SEC_STACK)
{
fprintf(o_src, "\tleal\t-%d(%%ebp), %%edx\n", sy1->location);
}
else
{
fprintf(o_src, "\tleal\tw_base%d+%d, %%edx\n",
pgm_segment, sy1->location);
}
fprintf(o_src, "\tmovl\t%%eax, (%%edx)\n");
}
}
void
gen_accept_env_var(struct sym *sy, struct lit *v)
{
struct sym *sy1, *sy2;
sy1 = (struct sym *) v;
/* gen_loadloc( sy ); */
/* fprintf(o_src,"\tmovl\t$c_base+%u, %%eax\n",sy->descriptor); */
/* push_eax(); */
gen_loadloc(sy1);
gen_loadvar(sy);
asm_call("tcob_accept_env_var");
/* Set RETURN-CODE with the value returned by
* the "accept_env_var" function, which is stored
* in register %eax
*/
if ((sy2 = lookup(SVAR_RETURN_CODE, SYTB_VAR)) != NULL)
{
if (sy2->sec_no == SEC_STACK)
{
fprintf(o_src, "\tleal\t-%d(%%ebp), %%edx\n", sy2->location);
}
else
{
fprintf(o_src, "\tleal\tw_base%d+%d, %%edx\n",
pgm_segment, sy2->location);
}
fprintf(o_src, "\tmovl\t%%eax, (%%edx)\n");
}
/* void save_literal( struct lit *v, int type ) */
/* currency_symbol = $<lval>4->name[0]; */
/* char *name; */ /* name (value) of literal */
/* gen_loadloc( sy ); */
/* gen_loaddesc( sy ); */
}
/******** structure allocation for perform info(s) ***********/
struct perf_info *
create_perf_info(struct sym *sy1, struct sym *sy2, unsigned long lj, unsigned long le)
{
struct perf_info *rf;
rf = malloc(sizeof (struct perf_info));
rf->pname1 = sy1;
rf->pname2 = sy2;
rf->ljmp = lj;
rf->lend = le;
return rf;
}
struct perform_info *
create_perform_info(void)
{
struct perform_info *rf;
rf = malloc(sizeof (struct perform_info));
rf->pf[0] = NULL;
rf->pf[1] = NULL;
rf->pf[2] = NULL;
rf->pf[3] = NULL;
rf->pf[4] = NULL;
rf->pf[5] = NULL;
return rf;
}
char *
check_perform_variables(struct sym *sy1, struct perform_info *pi1)
{
int i, j, k;
j = 0;
for (i = 0; i < 6; i++)
{
if (pi1->pf[i] != NULL)
{
j++;
#if 0
#ifdef DEBUG_COMPILER
fprintf(stderr,
"debug trace: check_perform_variables: var(%d:%d) '%s'\n",
i, j, pi1->pf[i]->pname2->name);
#endif
#endif
}
}
for (i = 0; i < j; i++)
{
#if 0
#ifdef DEBUG_COMPILER
fprintf(stderr,
"debug trace: check_perform_variables: var1='%s' var2(%d)='%s'\n",
sy1->name,
i, pi1->pf[i]->pname2->name);
#endif
#endif
if (strcmp(sy1->name, pi1->pf[i]->pname2->name) == 0)
{
return sy1->name;
}
}
for (i = 0; i < j; i++)
{
for (k = i + 1; k < j; k++)
{
#if 0
#ifdef DEBUG_COMPILER
fprintf(stderr,
"debug trace: check_perform_variables: var1(%d)='%s' var2(%d)='%s'\n",
i, pi1->pf[i]->pname2->name,
k, pi1->pf[k]->pname2->name);
#endif
#endif
if (strcmp(pi1->pf[i]->pname2->name, pi1->pf[k]->pname2->name) == 0)
{
return pi1->pf[i]->pname2->name;
}
}
}
return NULL;
}
/******** structure allocation for math verbs variables ***********/
struct expr *
create_expr(char op, struct expr *left, struct expr *right)
{
struct expr *e = malloc(sizeof (struct expr));
struct list *list = (struct list *) malloc(sizeof (struct list));
e->litflag = 5;
#ifdef DEBUG_COMPILER
fprintf(o_src, "#create_expr: [0x%x] %c ", (int) e, op);
if (left->litflag < 2)
{
fprintf(o_src, "%s ", ((struct sym *) left)->name);
}
else
{
fprintf(o_src, "0x%x ", (int) left);
}
if (right->litflag < 2)
{
fprintf(o_src, "%s\n", ((struct sym *) right)->name);
}
else
{
fprintf(o_src, "0x%x\n", (int) right);
}
#endif
e->op = op;
e->left = left;
e->right = right;
expr_list = list;
list->next = NULL;
list->var = e;
return e;
}
void
free_expr(struct expr *e)
{
if ((e != NULL) && (e->litflag == 5))
{
#ifdef DEBUG_COMPILER
fprintf(o_src, "#free_expr: %c (%d,%d) ", e->op,
e->left->litflag, e->right->litflag);
if (e->left->litflag < 2)
{
fprintf(o_src, "%s ", ((struct sym *) e->left)->name);
}
else
{
fprintf(o_src, "0x%x ", (int) e->left);
}
if (e->right->litflag < 2)
{
fprintf(o_src, "%s\n", ((struct sym *) e->right)->name);
}
else
{
fprintf(o_src, "0x%x\n", (int) e->right);
}
#endif
free_expr(e->right);
free_expr(e->left);
free(e);
}
e = NULL;
}
void
free_expr_list()
{
struct list *list;
struct expr *e;
for (list = expr_list; list != NULL; list = list->next)
{
e = (struct expr *) list->var;
free_expr(e);
}
expr_list = NULL;
}
struct math_var *
create_mathvar_info(struct math_var *mv, struct sym *sy, unsigned int opt)
{
struct math_var *rf, *tmp1, *tmp2;
/* if (is_numeric_sy(sy) == 0) {
yyerror("invalid (non numeric) variable or literal \'%s\' used in arithmetic verb", sy->name);
return mv;
}
*/
rf = malloc(sizeof (struct math_var));
rf->sname = sy;
/* rf->rounded = opt; */
rf->opts = opt;
rf->next = NULL;
#if 0
#ifdef DEBUG_COMPILER
fprintf(stderr,
"debug trace : create_mathvar_info 0: sy->name=%s;\n",
sy->name);
fprintf(stderr,
"debug trace : create_mathvar_info 1: rf->sname->name=%s;\n",
rf->sname->name);
#endif
#endif
if (mv == NULL)
{
tmp2 = rf;
tmp1 = rf;
}
else
{
tmp1 = mv;
tmp2 = mv;
while (tmp1->next != NULL)
{
#if 0
#ifdef DEBUG_COMPILER
fprintf(stderr,
"debug trace : create_mathvar_info 2: tmp1->sname->name=%s;\n",
tmp1->sname->name);
#endif
#endif
tmp1 = tmp1->next;
}
tmp1->next = rf;
}
#if 0
#ifdef DEBUG_COMPILER
fprintf(stderr,
"debug trace : create_mathvar_info 3: tmp1->sname->name=%s;\n",
tmp1->sname->name);
#endif
#endif
#if 0
#ifdef DEBUG_COMPILER
tmp1 = tmp2;
while (tmp1 != NULL)
{
fprintf(stderr,
"debug trace : create_mathvar_info 4: tmp1->sname->name=%s;\n",
tmp1->sname->name);
tmp1 = tmp1->next;
}
#endif
#endif
return tmp2;
}
void
delete_mathvar_info(struct math_var *mv)
{
struct math_var *tmp1, *tmp2;
tmp1 = mv;
while (tmp1 != NULL)
{
#if 0
#ifdef DEBUG_COMPILER
fprintf(stderr,
"debug trace : delete_mathvar_info 1: tmp1->sname->name=%s;\n",
tmp1->sname->name);
#endif
#endif
tmp2 = tmp1->next;
tmp1->next = NULL;
tmp1->sname = NULL;
free(tmp1);
tmp1 = tmp2;
}
}
struct invalid_key_element *
gen_before_invalid_key()
{
struct invalid_key_element *p = malloc(sizeof (struct invalid_key_element));
p->lbl1 = loc_label++;
p->lbl2 = loc_label++;
p->lbl3 = loc_label++;
gen_jmplabel(p->lbl1);
gen_dstlabel(p->lbl2);
return p;
}
struct invalid_key_element *
gen_after_invalid_key(struct invalid_key_element *p)
{
gen_jmplabel(p->lbl3);
return p;
}
struct invalid_keys *
gen_invalid_keys(struct invalid_key_element *p1, struct invalid_key_element *p2)
{
struct invalid_keys *p = malloc(sizeof (struct invalid_keys));
p->invalid_key = p1;
p->not_invalid_key = p2;
if (p1) gen_dstlabel(p1->lbl1);
if (p2) gen_dstlabel(p2->lbl1);
return p;
}
/******** functions to generate math verbs ***********/
void
gen_add(struct sym *s1, struct sym *s2, int rnd)
{
push_immed(rnd);
gen_loadvar(s2);
gen_loadvar(s1);
asm_call("tcob_add");
}
void
gen_subtract(struct sym *s1, struct sym *s2, int rnd)
{
push_immed(rnd);
gen_loadvar(s2);
gen_loadvar(s1);
asm_call("tcob_subtract");
}
void
gen_multiply(struct sym *s1, struct sym *s2, struct sym *s3, int rnd)
{
push_immed(rnd);
gen_loadvar(s3);
gen_loadvar(s2);
gen_loadvar(s1);
asm_call("tcob_multiply");
}
void
gen_compute1(struct math_var *vl1, struct sym *sy1)
{
push_expr(sy1);
while (vl1->next != NULL)
{
assign_expr(vl1->sname, vl1->opts, '0');
vl1 = vl1->next;
}
assign_expr(vl1->sname, vl1->opts, '1');
}
void
gen_compute2(struct math_var *vl1, struct sym *sy1, struct math_ose *v1)
{
/* option flags: 1=rounded, 2=on_size_error */
int opts;
opts = vl1->opts | MATH_OPT_ON_SIZE_ERROR;
gen_dstlabel(v1->lbl4); /* generate bypass jump label */
push_expr(sy1);
while (vl1->next != NULL)
{
assign_expr(vl1->sname, opts, '0');
math_on_size_error3(v1);
vl1 = vl1->next;
}
assign_expr(vl1->sname, opts, '1');
math_on_size_error3(v1);
math_on_size_error5(v1);
}
void
gen_add1(struct math_var *vl0, struct math_var *vl2, struct math_ose *v1)
{
struct math_var *vl1;
/* option flags: 1=rounded, 2=on_size_error */
int opts;
/* ON SIZE ERROR option only */
if (v1 != NULL)
{
/* generate bypass jump label */
gen_dstlabel(v1->lbl4);
}
while (vl2 != NULL)
{
push_expr(vl2->sname);
vl1 = vl0;
while (vl1 != NULL)
{
push_expr(vl1->sname);
add_expr();
vl1 = vl1->next;
}
if (v1 != NULL)
{
opts = vl2->opts | MATH_OPT_ON_SIZE_ERROR;
}
else
{
opts = vl2->opts;
}
assign_expr(vl2->sname, opts, '1');
/* ON SIZE ERROR option only */
math_on_size_error3(v1);
vl2 = vl2->next;
}
math_on_size_error5(v1);
}
void
gen_add2(struct math_var *vl1, struct math_var *vl2, struct sym *sy1, struct math_ose *v1)
{
int i = 0;
/* option flags: 1=rounded, 2=on_size_error */
int opts;
/* ON SIZE ERROR option only */
if (v1 != NULL)
{
/* generate bypass jump label */
gen_dstlabel(v1->lbl4); /* generate bypass jump label */
}
if (sy1 != NULL)
{
push_expr(sy1);
while (vl1 != NULL)
{
push_expr(vl1->sname);
add_expr();
vl1 = vl1->next;
}
}
else
{
push_expr(vl1->sname);
vl1 = vl1->next;
i = 1;
while (vl1 != NULL)
{
push_expr(vl1->sname);
add_expr();
vl1 = vl1->next;
i++;
}
if (i < 2)
{
yyerror("At least 2 variables and/or numeric literals required in ADD statement");
}
}
while (vl2->next != NULL)
{
if (v1 != NULL)
{
opts = vl2->opts | MATH_OPT_ON_SIZE_ERROR;
}
else
{
opts = vl2->opts;
}
assign_expr(vl2->sname, opts, '0');
/* ON SIZE ERROR option only */
math_on_size_error3(v1);
vl2 = vl2->next;
}
if (v1 != NULL)
{
opts = vl2->opts | MATH_OPT_ON_SIZE_ERROR;
}
else
{
opts = vl2->opts;
}
assign_expr(vl2->sname, opts, '1');
/* ON SIZE ERROR option only */
math_on_size_error3(v1);
math_on_size_error5(v1);
}
void
gen_add3(struct math_var *vl0, struct math_var *vl2, struct math_ose *v1)
{
struct math_var *vl1;
/* option flags: 1=rounded, 2=on_size_error */
int opts;
while (vl2 != NULL)
{
push_expr(vl2->sname);
vl1 = vl0;
while (vl1 != NULL)
{
push_expr(vl1->sname);
add_expr();
vl1 = vl1->next;
}
if (v1 != NULL)
{
opts = vl2->opts | MATH_OPT_ON_SIZE_ERROR;
}
else
{
opts = vl2->opts;
}
assign_expr(vl2->sname, opts, '1');
/* ON SIZE ERROR option only */
math_on_size_error3(v1);
vl2 = vl2->next;
}
}
void
gen_subtract1(struct math_var *vl0, struct math_var *vl2, struct math_ose *v1)
{
struct math_var *vl1;
/* option flags: 1=rounded, 2=on_size_error */
int opts;
/* ON SIZE ERROR option only */
if (v1 != NULL)
{
/* generate bypass jump label */
gen_dstlabel(v1->lbl4);
}
while (vl2 != NULL)
{
push_expr(vl2->sname);
vl1 = vl0;
while (vl1 != NULL)
{
push_expr(vl1->sname);
subtract_expr();
vl1 = vl1->next;
}
if (v1 != NULL)
{
opts = vl2->opts | MATH_OPT_ON_SIZE_ERROR;
}
else
{
opts = vl2->opts;
}
assign_expr(vl2->sname, opts, '1');
/* ON SIZE ERROR option only */
math_on_size_error3(v1);
vl2 = vl2->next;
}
math_on_size_error5(v1);
}
void
gen_subtract2(struct math_var *vl1, struct math_var *vl2, struct sym *sy1, struct math_ose *v1)
{
/* option flags: 1=rounded, 2=on_size_error */
int opts;
/* ON SIZE ERROR option only */
if (v1 != NULL)
{
/* generate bypass jump label */
gen_dstlabel(v1->lbl4);
}
push_expr(sy1);
while (vl1 != NULL)
{
push_expr(vl1->sname);
subtract_expr();
vl1 = vl1->next;
}
while (vl2->next != NULL)
{
if (v1 != NULL)
{
opts = vl2->opts | MATH_OPT_ON_SIZE_ERROR;
}
else
{
opts = vl2->opts;
}
assign_expr(vl2->sname, opts, '0');
/* ON SIZE ERROR option only */
math_on_size_error3(v1);
vl2 = vl2->next;
}
if (v1 != NULL)
{
opts = vl2->opts | MATH_OPT_ON_SIZE_ERROR;
}
else
{
opts = vl2->opts;
}
assign_expr(vl2->sname, opts, '1');
/* ON SIZE ERROR option only */
math_on_size_error3(v1);
math_on_size_error5(v1);
}
void
gen_subtract3(struct math_var *vl0, struct math_var *vl2, struct math_ose *v1)
{
struct math_var *vl1;
/* option flags: 1=rounded, 2=on_size_error */
int opts;
while (vl2 != NULL)
{
push_expr(vl2->sname);
vl1 = vl0;
while (vl1 != NULL)
{
push_expr(vl1->sname);
subtract_expr();
vl1 = vl1->next;
}
if (v1 != NULL)
{
opts = vl2->opts | MATH_OPT_ON_SIZE_ERROR;
}
else
{
opts = vl2->opts;
}
assign_expr(vl2->sname, opts, '1');
/* ON SIZE ERROR option only */
math_on_size_error3(v1);
vl2 = vl2->next;
}
}
void
gen_multiply1(struct math_var *vl1, struct sym *sy1, struct math_ose *v1)
{
/* option flags: 1=rounded, 2=on_size_error */
int opts;
/* ON SIZE ERROR option only */
if (v1 != NULL)
{
/* generate bypass jump */
gen_dstlabel(v1->lbl4);
}
while (vl1->next != NULL)
{
push_expr(sy1);
push_expr(vl1->sname);
multiply_expr();
if (v1 != NULL)
{
opts = vl1->opts | MATH_OPT_ON_SIZE_ERROR;
}
else
{
opts = vl1->opts;
}
assign_expr(vl1->sname, opts, '1');
/* ON SIZE ERROR option only */
math_on_size_error3(v1);
vl1 = vl1->next;
}
push_expr(sy1);
push_expr(vl1->sname);
multiply_expr();
if (v1 != NULL)
{
opts = vl1->opts | MATH_OPT_ON_SIZE_ERROR;
}
else
{
opts = vl1->opts;
}
assign_expr(vl1->sname, opts, '1');
/* ON SIZE ERROR option only */
math_on_size_error3(v1);
math_on_size_error5(v1);
}
void
gen_multiply2(struct math_var *vl1, struct sym *sy1, struct sym *sy2, struct math_ose *v1)
{
/* option flags: 1=rounded, 2=on_size_error */
int opts;
/* ON SIZE ERROR option only */
if (v1 != NULL)
{
/* generate bypass jump label */
gen_dstlabel(v1->lbl4);
}
push_expr(sy1);
push_expr(sy2);
multiply_expr();
while (vl1->next != NULL)
{
if (v1 != NULL)
{
opts = vl1->opts | MATH_OPT_ON_SIZE_ERROR;
}
else
{
opts = vl1->opts;
}
assign_expr(vl1->sname, opts, '0');
/* ON SIZE ERROR option only */
math_on_size_error3(v1);
vl1 = vl1->next;
}
if (v1 != NULL)
{
opts = vl1->opts | MATH_OPT_ON_SIZE_ERROR;
}
else
{
opts = vl1->opts;
}
assign_expr(vl1->sname, opts, '1');
/* ON SIZE ERROR option only */
math_on_size_error3(v1);
math_on_size_error5(v1);
}
void
gen_divide1(struct math_var *vl1, struct sym *sy1, struct math_ose *v1)
{
/* option flags: 1=rounded, 2=on_size_error */
int opts;
/* ON SIZE ERROR option only */
if (v1 != NULL)
{
/* generate bypass jump */
gen_dstlabel(v1->lbl4);
}
while (vl1 != NULL)
{
push_expr(vl1->sname);
push_expr(sy1);
divide_expr();
if (v1 != NULL)
{
opts = vl1->opts | MATH_OPT_ON_SIZE_ERROR;
}
else
{
opts = vl1->opts;
}
assign_expr(vl1->sname, opts, '1');
/* ON SIZE ERROR option only */
math_on_size_error3(v1);
vl1 = vl1->next;
}
math_on_size_error5(v1);
}
void
gen_divide2(struct math_var *vl1, struct sym *sy1, struct sym *sy2, struct math_ose *v1)
{
/* option flags: 1=rounded, 2=on_size_error */
int opts;
/* ON SIZE ERROR option only */
if (v1 != NULL)
{
/* generate bypass jump label */
gen_dstlabel(v1->lbl4);
}
push_expr(sy1);
push_expr(sy2);
divide_expr();
while (vl1->next != NULL)
{
if (v1 != NULL)
{
opts = vl1->opts | MATH_OPT_ON_SIZE_ERROR;
}
else
{
opts = vl1->opts;
}
assign_expr(vl1->sname, opts, '0');
/* ON SIZE ERROR option only */
math_on_size_error3(v1);
vl1 = vl1->next;
}
if (v1 != NULL)
{
opts = vl1->opts | MATH_OPT_ON_SIZE_ERROR;
}
else
{
opts = vl1->opts;
}
assign_expr(vl1->sname, opts, '1');
/* ON SIZE ERROR option only */
math_on_size_error3(v1);
math_on_size_error5(v1);
}
void
gen_divide4(struct sym *s1, struct sym *s2, struct sym *s3, struct sym *s4, int rnd, struct math_ose *v1)
{
/* [NOT]ON SIZE ERROR option */
if (v1 != NULL)
{
/* generate bypass jump */
gen_dstlabel(v1->lbl4);
}
push_immed(rnd);
gen_loadvar(s4);
gen_loadvar(s3);
gen_loadvar(s2);
gen_loadvar(s1);
asm_call("tcob_divide1");
math_on_size_error3(v1);
math_on_size_error5(v1);
}
/******** functions for subscripted var manipulation ***********/
struct vref *
create_subscripted_var(struct sym * sy, struct vref *subs)
{
struct vref *ref;
ref = malloc(sizeof (struct vref));
ref->litflag = 2;
ref->sym = sy;
ref->next = subs;
return ref;
}
struct vref *
create_subscript(struct sym *sy)
{
struct vref *ref;
ref = malloc(sizeof (struct vref));
ref->litflag = ','; /* the end of subscript is here */
ref->sym = sy; /* this is the actual variable */
ref->next = NULL;
return ref;
}
struct vref *
add_subscript_item(struct vref *subs, char op, struct sym *item)
{
struct vref *ref, *tmp;
ref = malloc(sizeof (struct vref));
tmp = subs;
while (tmp->next) tmp = tmp->next;
tmp->next = ref;
ref->litflag = ',';
ref->sym = item;
ref->next = NULL;
tmp->litflag = op;
return subs;
}
struct vref *
add_subscript(struct vref *ref, struct vref *subs)
{
struct vref *tmp;
tmp = subs;
while (tmp->next) tmp = tmp->next;
tmp->next = ref;
return subs;
}
int
check_subscripts(struct sym *subs)
{
struct vref *ref;
struct sym *sy;
sy = ((struct vref *) subs)->sym;
for (ref = (struct vref *) subs; ref; ref = ref->next)
{
#ifdef DEBUG_COMPILER
fprintf(o_src, "#check_subscripts: symbol: %s, op: '%c'\n",
((struct sym *) ref->sym)->name,
ref->litflag == 2 ? 2 : ref->litflag);
#endif
if (ref->litflag == ',')
{
while (sy && !sy->occurs_flg)
{
#ifdef DEBUG_COMPILER
fprintf(o_src, "#check_subscripts: symbol: %s\n",
sy->name);
#endif
sy = sy->parent;
}
if (!sy)
{
hterror(102, 4, "check_subscripts: no parent found");
return 0; /* excess subscripts, error */
}
sy = sy->parent;
}
}
while (sy && !sy->occurs_flg) /* any other subscripts needed ? */
sy = sy->parent;
return (sy == NULL) ? 1 : 0;
}
void
create_occurs_info(int min, int max, struct sym *depend)
{
curr_field->occurs = (struct occurs *) malloc(sizeof (struct occurs));
curr_field->occurs->min = min;
curr_field->occurs->max = max;
curr_field->occurs->depend = depend;
curr_field->times = max;
curr_field->occurs_flg++;
}
/******** functions for refmoded var manipulation ***********/
struct refmod *
create_refmoded_var(struct sym * sy, struct sym *syoff, struct sym *sylen)
{
struct refmod *ref;
ref = malloc(sizeof (struct refmod));
ref->litflag = 4;
ref->sym = sy;
ref->off = syoff;
ref->len = sylen;
ref->slot = refmod_slots++;
return ref;
}
int
check_refmods(struct sym *var)
{
struct refmod *ref = (struct refmod *) var;
struct sym *sy = ref->sym;
if (sy->litflag == 2) sy = ((struct vref *) sy)->sym;
return (sy == NULL) ? 1 : 0;
}
struct sym *
get_variable_item(struct sym *sy)
{
struct sym *son, *item;
if (sy->litflag != 0)
return NULL;
if (sy->occurs != NULL)
return sy;
for (son = sy->son; son != NULL; son = son->brother)
{
if ((item = get_variable_item(son)))
return item;
}
return NULL;
}
void
adjust_desc_length(struct sym *sy)
{
int stack_save = stackframe_cnt;
struct sym *item;
stackframe_cnt = 0;
item = get_variable_item(sy);
/* push_immed(0); */
gen_temp_storage(sizeof (struct fld_desc));
gen_loaddesc1(item, 0);
gen_loaddesc1(sy, 0);
push_immed(item->occurs->max);
push_immed(item->occurs->min);
gen_loadvar(item->occurs->depend);
asm_call("tcob_adjust_length");
stackframe_cnt = stack_save;
need_desc_length_cleanup = 1;
}
void
gen_loadloc(struct sym *sy_p)
{
loadloc_to_eax(sy_p);
push_eax();
}
void
gen_loaddesc(struct sym *sy)
{
gen_loaddesc1(sy, 1);
}
void
gen_loadvar(struct sym *sy)
{
struct sym *var;
if (sy == NULL)
{
push_immed(0);
}
else
{
var = sy;
if (var->litflag == 2 || var->litflag == 4)
{
var = ((struct vref *) var)->sym;
if (var->litflag == 2)
var = ((struct vref *) var)->sym;
}
if (!HTG_libcob)
gen_loadloc(sy);
gen_loaddesc(sy);
}
}
int
is_numeric_sy(struct sym *sy)
{
char type;
if (sy->litflag == 2)
{ /* subscripted ? */
sy = ((struct vref *) sy)->sym;
}
type = sy->type;
if ((type == DTYPE_DISPLAY) || (type == DTYPE_BININT)
|| (type == DTYPE_PACKED) || (type == DTYPE_FLOAT))
return 1;
return 0;
}
int
is_numeric_dest_sy(struct sym *sy)
{
char type;
if (sy->litflag == 2)
{ /* subscripted ? */
sy = ((struct vref *) sy)->sym;
}
type = sy->type;
if ((type == DTYPE_DISPLAY)
|| (type == DTYPE_BININT)
|| (type == DTYPE_PACKED)
|| (type == DTYPE_FLOAT)
|| (type == DTYPE_EDITED))
return 1;
return 0;
}
void
gen_class_check(struct sym *sy, int class)
{
int invert = 0;
class &= ~(COND_UNARY | COND_CLASS);
if (class & 4)
{ /* was it inverted (NOT) ? */
class ^= 7;
invert++;
}
if (class == CLASS_NUMERIC)
{
/*if (!sy || is_numeric_sy(sy)) {
*/
if (sy) /* don't save already pushed variable */
gen_loadvar(sy);
else
stackframe_cnt += 8;
asm_call("tcob_check_numeric");
fprintf(o_src, "\tand\t%%eax,%%eax\n");
/*}
else {
yyerror("invalid NUMERIC class check");
}*/
}
else
{
/* from now on, only alphabetic tests are allowed */
/*if (is_numeric_sy(sy)) {
yyerror("invalid ALPHABETIC class check");
}*/
gen_loadvar(sy);
switch (class)
{
case CLASS_ALPHABETIC:
asm_call("tcob_check_alphabetic");
break;
case CLASS_ALPHABETIC_UPPER:
asm_call("tcob_check_upper");
break;
case CLASS_ALPHABETIC_LOWER:
asm_call("tcob_check_lower");
break;
default:
yyerror("unknown class condition");
break;
}
fprintf(o_src, "\tand\t%%eax,%%eax\n");
}
if (invert)
gen_not();
}
void
gen_inspect(struct sym *var, void *list, int operation)
{
/*struct inspect_before_after *ba,*ba1;*/
struct tallying_list *tl, *tl1;
struct tallying_for_list *tfl, *tfl1;
struct replacing_list *rl, *rl1;
struct replacing_by_list *rbl, *rbl1;
struct converting_struct *cv;
if (!operation)
{
if (!list) return;
fprintf(o_src, "# INSPECT TALLYING %s\n", var->name);
gen_loadvar((struct sym *) NULL);
tl = (struct tallying_list *) list;
while (tl)
{
tfl = tl->tflist;
push_immed(0);
while (tfl)
{
gen_loadvar(tfl->before_after->after);
gen_loadvar(tfl->before_after->before);
if (tfl->options != INSPECT_CHARACTERS)
{
gen_loadvar(tfl->forvar);
}
push_immed(tfl->options);
free(tfl->before_after);
tfl1 = tfl;
tfl = tfl->next;
free(tfl1);
}
gen_loadvar(tl->count);
tl1 = tl;
tl = tl->next;
free(tl1);
tl1 = NULL;
}
gen_loadvar(var);
asm_call("tcob_inspect_tallying");
}
else if (operation == 1)
{
if (!list) return;
fprintf(o_src, "# INSPECT REPLACING %s\n", var->name);
rl = (struct replacing_list *) list;
push_immed(0);
while (rl)
{
if (rl->options == INSPECT_CHARACTERS)
{
gen_loadvar(rl->before_after->after);
gen_loadvar(rl->before_after->before);
gen_loadvar(rl->byvar);
push_immed(rl->options);
}
else
{
rbl = rl->replbylist;
while (rbl)
{
gen_loadvar(rbl->before_after->after);
gen_loadvar(rbl->before_after->before);
gen_loadvar(rbl->byvar);
gen_loadvar(rbl->replvar);
free(rbl->before_after);
rbl1 = rbl;
rbl = rbl->next;
free(rbl1);
push_immed(rl->options);
}
}
rl1 = rl;
rl = rl->next;
free(rl1);
rl1 = NULL;
}
gen_loadvar(var);
asm_call("tcob_inspect_replacing");
}
else
{
fprintf(o_src, "# INSPECT CONVERTING %s\n", var->name);
cv = (struct converting_struct *) list;
gen_loadvar(cv->before_after->after);
gen_loadvar(cv->before_after->before);
gen_loadvar(cv->tovar);
gen_loadvar(cv->fromvar);
gen_loadvar(var);
asm_call("tcob_inspect_converting");
}
}
void
gen_tcob_proto1(struct sym *sy)
{
gen_loadvar(sy);
asm_call("tcob_proto1");
}
void
gen_tcob_proto2(struct sym *sy1, struct sym *sy2)
{
gen_loadvar(sy2);
gen_loadvar(sy1);
asm_call("tcob_proto2");
}
void
gen_moves(struct sym *sy_src, struct gvar_list *gsylst)
{
struct gvar_list *sy_dst;
for (sy_dst = gsylst; sy_dst->next != NULL; sy_dst = sy_dst->next)
{
gen_move(sy_src, sy_dst->u.sym);
}
gen_move(sy_src, sy_dst->u.sym);
}
void
gen_move(struct sym *sy_src, struct sym *sy_dst)
{
long tmplabel = 0;
struct sym *var;
#ifdef DEBUG_COMPILER
{
struct sym *esys = sy_src, *esyd = sy_dst;
if (esys->litflag == 4)
esys = ((struct refmod *) esys)->sym;
if (esyd->litflag == 4)
esyd = ((struct refmod *) esyd)->sym;
fprintf(o_src, "# MOVE %s --> ", sch_convert(esys->name));
fprintf(o_src, " %s\n", sch_convert(esyd->name));
}
#endif
/* Make sure BLANK test is done on a sym struct, and not a vref struct */
var = sy_dst;
if (var->litflag == 2 || var->litflag == 4)
{
var = ((struct vref *) var)->sym;
if (var->litflag == 2)
var = ((struct vref *) var)->sym;
}
/* A blank when zero field is treated here instead of the RTS */
if (var->flags.blank)
{
tmplabel = loc_label++;
gen_compare(sy_src, EQUAL, (struct sym *) spe_lit_ZE);
fprintf(o_src, "\tjnz\t.L%ld\n", tmplabel);
gen_loadvar(sy_dst);
gen_loadvar((struct sym *) spe_lit_SP);
asm_call("tcob_move_x_x");
gen_jmplabel(tmplabel + 1);
fprintf(o_src, ".L%ld:\n", tmplabel);
}
/* default move */
gen_loadvar(sy_dst);
gen_loadvar(sy_src);
/* an initial value of a literal X field into an numeric edited field
should move straight instead of going thru an edition */
/* if (sy_src->type == DTYPE_ALPHANUMERIC && sy_dst->type == DTYPE_EDITED) {
asm_call("tcob_move_x_x");
}
else { */
RTL_CALL("move");
/* } */
#ifdef TODO
if (sy_src->type == DTYPE_ALPHANUMERIC && sy_dst->type == DTYPE_EDITED)
{
asm_call("tcob_move_x_x");
}
else
{
asm_call("tcob_move");
}
#endif
if (tmplabel)
{
tmplabel = loc_label++;
fprintf(o_src, ".L%ld:\n", tmplabel);
}
}
void
gen_movelength(struct sym *sy1, struct sym *sy2)
{
if (sy1->litflag == 1)
{
push_immed(((struct lit *) sy1)->len);
}
else
{
push_immed(sy1->len);
}
gen_loadvar(sy2);
asm_call("tcob_assign_int");
}
void
gen_move_init(struct sym *sy_src, struct sym *sy_dst)
{
#ifdef DEBUG_COMPILER
{
struct sym *esys = sy_src, *esyd = sy_dst;
fprintf(o_src, "# MOVE_INIT %s --> ", sch_convert(esys->name));
fprintf(o_src, " %s\n", sch_convert(esyd->name));
}
#endif
/* default move */
gen_loadvar(sy_dst);
gen_loadvar(sy_src);
/* an initial value of a literal X field into an numeric edited field
should move straight instead of going thru an edition */
if (sy_src->type == DTYPE_ALPHANUMERIC && sy_dst->type == DTYPE_EDITED)
{
asm_call("tcob_move_x_x");
}
else
{
RTL_CALL("move");
}
}
void
gen_movecorr(struct sym *sy1, struct sym *sy2)
{
struct sym *t1, *t2;
if (sy1->litflag || sy2->litflag)
{
yyerror("sorry we don't handle this case yet!");
return;
}
#ifdef DEBUG_COMPILER
fprintf(o_src, "# MOVE CORR %s --> %s\n", sy1->name, sy2->name);
#endif
t1 = sy1->son;
/* repeat for all sons of sy1 */
while (t1 != NULL)
{
if (!t1->redefines && t1->times == 1)
{
t2 = sy2->son;
/* repeat for all sons of sy2 */
while (t2 != NULL)
{
if (!t2->redefines && t2->times == 1)
{
if (strcmp(t1->name, t2->name) == 0)
{
if ((t1->type != DTYPE_GROUP)
|| (t2->type != DTYPE_GROUP))
{
gen_move(t1, t2);
}
else
{
gen_movecorr(t1, t2);
}
}
}
t2 = t2->brother;
}
}
t1 = t1->brother;
}
}
struct sym *
define_label(struct sym *lab, int lab_type,
struct sym *parent, int parent_type)
{
struct sym *tlab = lab;
struct lit *tlit;
struct sym *tparent;
if (parent == NULL)
{
tparent = curr_section;
}
else
{
tparent = parent;
}
if (lab_type == 1)
{
tlit = (struct lit *) lab;
tlab = install(tlit->name, SYTB_LAB, 0);
}
else
{
tlab = lab;
}
if (tlab->defined == 0)
{
tlab->defined = 2;
tlab->parent = tparent;
}
else
{
if (parent_type == 1)
{
tlit = (struct lit *) parent;
tlab = install(tlit->name, SYTB_LAB, 0);
}
if ((tlab = lookup_label(tlab, tparent)) == NULL)
{
tlab = install(tlab->name, SYTB_LAB, 2);
tlab->defined = 2;
tlab->parent = tparent;
}
}
return tlab;
}
void
gen_addcorr(struct sym *sy1, struct sym *sy2, int rnd)
{
struct sym *t1, *t2;
if (sy1->litflag || sy2->litflag)
{
yyerror("sorry we don't handle this case yet!");
}
#ifdef DEBUG_COMPILER
fprintf(o_src, "# ADD CORR %s --> %s\n", sy1->name, sy2->name);
#endif
t1 = sy1->son;
/* repeat for all sons of sy1 */
while (t1 != NULL)
{
if (!t1->redefines && t1->times == 1)
{
t2 = sy2->son;
/* repeat for all sons of sy2 */
while (t2 != NULL)
{
if (!t2->redefines && t2->times == 1)
{
if (strcmp(t1->name, t2->name) == 0)
{
if ((t1->type != DTYPE_GROUP)
&& (t2->type != DTYPE_GROUP))
{
gen_add(t1, t2, rnd);
}
else
{
gen_addcorr(t1, t2, rnd);
}
}
}
t2 = t2->brother;
}
}
t1 = t1->brother;
}
}
void
gen_addcorr1(struct math_var *mv1, struct math_var *mv2, int rnd, struct math_ose
*v1)
{
struct sym *sy1, *sy2;
struct sym *t1, *t2;
struct math_var *tmv1, *tmv2;
static int addcorr_level = 0;
if (mv1->sname->litflag || mv2->sname->litflag)
{
yyerror("sorry we don't handle this case yet!");
}
#ifdef DEBUG_COMPILER
fprintf(o_src, "# ADD CORR %s --> %s, lv %d\n",
mv1->sname->name, mv2->sname->name, addcorr_level);
#endif
/* ON SIZE ERROR option only */
if (addcorr_level == 0 && v1 != NULL)
{
/* generate bypass jump label */
gen_dstlabel(v1->lbl4);
}
addcorr_level++;
sy1 = mv1->sname;
sy2 = mv2->sname;
t1 = sy1->son;
/* repeat for all sons of sy1 */
while (t1 != NULL)
{
if (!t1->redefines && t1->times == 1)
{
t2 = sy2->son;
/* repeat for all sons of sy2 */
while (t2 != NULL)
{
if (!t2->redefines && t2->times == 1)
{
if (strcmp(t1->name, t2->name) == 0)
{
tmv1 = create_mathvar_info(NULL, t1, 0);
tmv2 = create_mathvar_info(NULL, t2, 0);
if ((t1->type != DTYPE_GROUP)
&& (t2->type != DTYPE_GROUP))
{
gen_add3(tmv1, tmv2, v1);
}
else
{
gen_addcorr1(tmv1, tmv2, rnd, v1);
}
delete_mathvar_info(tmv1);
delete_mathvar_info(tmv2);
}
}
t2 = t2->brother;
}
}
t1 = t1->brother;
}
addcorr_level--;
if (addcorr_level == 0)
{
math_on_size_error5(v1);
}
}
void
gen_subtractcorr(struct sym *sy1, struct sym *sy2, int rnd)
{
struct sym *t1, *t2;
if (sy1->litflag || sy2->litflag)
{
yyerror("sorry we don't handle this case yet!");
}
#ifdef DEBUG_COMPILER
fprintf(o_src, "# SUB CORR %s --> %s\n", sy1->name, sy2->name);
#endif
t1 = sy1->son;
/* repeat for all sons of sy1 */
while (t1 != NULL)
{
if (!t1->redefines && t1->times == 1)
{
t2 = sy2->son;
/* repeat for all sons of sy2 */
while (t2 != NULL)
{
if (!t2->redefines && t2->times == 1)
{
if (strcmp(t1->name, t2->name) == 0)
{
if ((t1->type != DTYPE_GROUP)
&& (t2->type != DTYPE_GROUP))
{
gen_subtract(t1, t2, rnd);
}
else
{
gen_subtractcorr(t1, t2, rnd);
}
}
}
t2 = t2->brother;
}
}
t1 = t1->brother;
}
}
void
gen_subtractcorr1(struct math_var *mv1, struct math_var *mv2, int rnd,
struct math_ose *v1)
{
struct sym *sy1, *sy2;
struct sym *t1, *t2;
struct math_var *tmv1, *tmv2;
static int subcorr_level = 0;
if (mv1->sname->litflag || mv2->sname->litflag)
{
yyerror("sorry we don't handle this case yet!");
}
#ifdef DEBUG_COMPILER
fprintf(o_src, "# SUB CORR %s --> %s, lv %d\n",
mv1->sname->name, mv2->sname->name, subcorr_level);
#endif
/* ON SIZE ERROR option only */
if (subcorr_level == 0 && v1 != NULL)
{
/* generate bypass jump label */
gen_dstlabel(v1->lbl4);
}
subcorr_level++;
sy1 = mv1->sname;
sy2 = mv2->sname;
t1 = sy1->son;
/* repeat for all sons of sy1 */
while (t1 != NULL)
{
if (!t1->redefines && t1->times == 1)
{
t2 = sy2->son;
/* repeat for all sons of sy2 */
while (t2 != NULL)
{
if (!t2->redefines && t2->times == 1)
{
if (strcmp(t1->name, t2->name) == 0)
{
tmv1 = create_mathvar_info(NULL, t1, 0);
tmv2 = create_mathvar_info(NULL, t2, 0);
if ((t1->type != DTYPE_GROUP)
&& (t2->type != DTYPE_GROUP))
{
gen_subtract3(tmv1, tmv2, v1);
}
else
{
gen_subtractcorr1(tmv1, tmv2, rnd, v1);
delete_mathvar_info(tmv1);
delete_mathvar_info(tmv2);
}
}
}
t2 = t2->brother;
}
}
t1 = t1->brother;
}
subcorr_level--;
if (subcorr_level == 0)
{
math_on_size_error5(v1);
}
}
void
gen_set_complex(struct sym *idx, int which, struct sym * var)
{
#ifdef DEBUG_COMPILER
fprintf(o_src, "# set complex %s to %s\n", idx ? idx->name : "(null)",
var ? var->name : "(null)");
#endif
switch (which)
{
case SET_TO: /* just move this value */
gen_move(idx, var);
break;
case SET_UP_BY: /* we need to add this value to the index */
gen_add(idx, (struct sym *) define_num_lit(1), 0);
break;
case SET_DOWN_BY:
gen_subtract(idx, (struct sym *) define_num_lit(1), 0);
break;
default:
yyerror("SET option unavailable");
}
}
void
gen_set_list(struct list *idx, int which, struct sym *var,
int adrof_idx, int adrof_var)
{
struct sym * svar;
while (idx != NULL)
{
svar = idx->var;
fprintf(o_src, "# SET %s \n", svar->name);
gen_set(idx->var, which, var, adrof_idx, adrof_var);
idx = idx->next;
}
vars_list = NULL;
}
/******* short-circuit conditional evaluators ********/
int
gen_evaluate_start()
{
int i = loc_label++;
fprintf(o_src, "# EVALUATE statement\n");
return i;
}
int
subject_set_size(struct selsubject *ssbj)
{
int size = 0;
while (ssbj != NULL)
{
size++;
ssbj = ssbj->next;
}
return size;
}
int
selection_object_size(int type)
{
switch (type)
{
case SOBJ_EXPR:
case SOBJ_NEGEXPR:
return 8;
case SOBJ_RANGE:
case SOBJ_NEGRANGE:
return 16;
default:
return 0;
}
}
int
selection_subject_type(int level, struct selsubject *ssbj)
{
while (level--)
{
ssbj = ssbj->next;
}
return ssbj->type;
}
void
gen_perform(struct sym *sy)
{
gen_perform_thru(sy, sy);
}
void
set_usage(struct sym *sy, int usage)
{
sy->stype = ' ';
switch (usage)
{
case USAGE_COMP1:
sy->len = 4;
sy->decimals = 7;
sy->type = 'U';
sy->sign = 1;
/* default picture is 14 digits "S9(7)V9(7)" */
strcpy((char *) picture, "S\x01\x39\x07\x56\x01\x39\x07");
break;
case USAGE_COMP2:
sy->len = 8;
sy->decimals = 15;
sy->type = 'U';
sy->sign = 1;
/* default picture is 30 digits "S9(15)V9(15)" */
strcpy((char *) picture, "S\x01\x39\x0f\x56\x01\x39\x0f");
break;
case USAGE_COMP3:
sy->type = 'C';
break;
case USAGE_COMP:
sy->stype = 'B';
/* field length computed by query_comp_length() */
sy->len = 0;
sy->type = 'B'; /* binary field */
break;
case USAGE_COMP5:
sy->stype = '5';
sy->len = 0;
sy->type = 'B'; /* binary field */
break;
case USAGE_COMPX:
sy->stype = 'X';
sy->len = 0;
sy->type = 'B'; /* binary field */
break;
case USAGE_POINTER: /* POINTER */
sy->len = 4;
sy->decimals = 0;
sy->type = 'B'; /* pointers are binary fields */
/* pointer default picture: "9(10)" */
strcpy((char *) picture, "9\x0a");
sy->flags.is_pointer = 1;
break;
case USAGE_BINARY_CHAR:
sy->len = 1;
sy->type = 'B';
break;
case USAGE_BINARY_SHORT:
sy->len = 2;
sy->type = 'B';
break;
case USAGE_BINARY_LONG:
sy->len = 4;
sy->type = 'B';
break;
case USAGE_BINARY_DOUBLE:
sy->len = 8;
sy->type = 'B';
break;
case USAGE_INDEX:
sy->len = 4;
sy->type = 'B';
sy->decimals = 0;
break;
}
}
void
gen_picture(void)
{
if (curr_field->type != DTYPE_GROUP)
{
curr_field->picstr = (char *) malloc(strlen((char *) picture) + 1);
strcpy(curr_field->picstr, (char *) picture);
}
}
int
save_pic_char(char c, int i)
{
char c1 = (char) toupper(c);
unsigned int n;
switch (c1)
{
case 'A':
piccnt += i;
if (curr_field->type != DTYPE_ALPHANUMERIC
&& curr_field->type != DTYPE_EDITED)
curr_field->type = DTYPE_ALPHA;
break;
case 'X':
piccnt += i;
if (curr_field->type == DTYPE_DISPLAY)
curr_field->type = DTYPE_ALPHANUMERIC;
break;
case 'Z':
curr_field->type = DTYPE_EDITED;
case '9':
piccnt += i;
if (v_flag) decimals += i;
n_flag = 1;
break;
case 'V':
if (v_flag)
yyerror("invalid picture: V already given");
v_flag = 1;
break;
case 'P':
piccnt += i;
if (!n_flag)
v_flag = 1; /* implicit V just before the first P */
if (v_flag)
{
decimals += i;
pscale += i;
}
else
pscale -= i;
break;
case 'S':
sign = 1;
break;
case '.':
case ',':
case '0':
case 'B':
case '/':
case '+':
case '-':
case '*':
case 'C':
case 'R':
case 'D':
curr_field->type = DTYPE_EDITED;
piccnt += i;
break;
default:
if (c1 == currency_symbol)
{
curr_field->type = DTYPE_EDITED;
piccnt += i;
break;
}
else
return 0;
} /* switch(c1) */
if (picture[picix] == 0)
{ /* first char in PIC string? */
picture[picix] = c1;
picture[picix + 1] = 0;
}
if (((char) picture[picix] != c1) || (picture[picix + 1] == 255))
{
picix += 2;
picture[picix] = c1;
picture[picix + 1] = 0;
}
for (n = i + picture[picix + 1]; n > 255; n -= 255)
{
picture[picix + 1] = 255;
picture[picix + 2] = picture[picix];
picix += 2;
}
picture[picix + 1] = n;
return 1;
}
void
define_special_fields()
{
struct sym *sy, *tmp;
struct lit *ly;
sy = install(SVAR_RETURN_CODE, SYTB_VAR, 0);
spe_lit_SP = save_special_literal(' ', 'X', "%SPACES%");
spe_lit_LV = save_special_literal('\0', 'X', "%LOW-VALUES%");
spe_lit_HV = save_special_literal('\xff', 'X', "%HIGH-VALUES%");
spe_lit_ZE = save_special_literal('0', '9', "%ZEROS%");
spe_lit_QU = save_special_literal('"', 'X', "%QUOTES%");
spe_lit_SP->all = 1;
spe_lit_LV->all = 1;
spe_lit_HV->all = 1;
spe_lit_ZE->all = 1;
spe_lit_QU->all = 1;
ly = spe_lit_ZE;
/* sy->len=5; */
sy->len = 4;
sy->decimals = 0;
sy->pscale = 0;
sy->level = 1;
sy->defined = 1;
sy->type = DTYPE_BININT; /* assume numeric "usage is comp" item */
sy->redefines = NULL;
sy->linkage_flg = at_linkage;
sy->sec_no = SEC_RETURN_CODE;
sy->times = 1;
sy->occurs_flg = 0;
sy->flags.just_r = 0;
sy->flags.separate_sign = 0;
sy->flags.leading_sign = 0;
sy->flags.blank = 0;
sy->flags.value = 1;
sy->son = sy->brother = NULL;
picture[0] = 'S';
picture[1] = 1;
picture[2] = '9';
picture[3] = 6;
picture[4] = 0;
tmp = curr_field;
curr_field = sy;
curr_field->value = ly;
curr_field->value2 = ly;
update_field(curr_field);
close_fields();
curr_field = tmp;
tmp = NULL;
ly = NULL;
}
/*
* Define a temp field of the desired type and desired lenght
*/
struct sym *
define_temp_field(char desired_type, int desired_len)
{
struct sym *sy, *tmp;
/* fprintf(stderr,"begin define temp %c\n",desired_type); */
#ifdef DEBUG_COMPILER
fprintf(o_src, "#define_temp_field:%c,%d,SO:%d\n",
desired_type, desired_len, stack_offset);
#endif
sy = malloc(sizeof (struct sym));
memset(sy, 0, sizeof (struct sym));
sy->litflag = 0;
sy->name = "%noname%";
sy->len = desired_len;
sy->decimals = 0; /* suppose no decimals yet */
sy->pscale = 0;
sy->level = 1;
sy->type = desired_type;
sy->redefines = NULL;
sy->parent = NULL;
sy->linkage_flg = 0;
sy->sec_no = SEC_DATA; /* not optimal; should be in stack */
/* sy->sec_no=SEC_STACK; */
sy->times = 1;
sy->occurs_flg = 0;
sy->occurs = NULL;
sy->flags.just_r = 0;
sy->flags.separate_sign = 0;
sy->flags.leading_sign = 0;
sy->flags.blank = 0;
sy->son = sy->brother = NULL;
switch (desired_type)
{
case DTYPE_ALPHANUMERIC:
picture[0] = 'X';
picture[1] = (char) sy->len; /* this make the max 255 */
picture[2] = 0;
break;
case DTYPE_BININT: /* Make it signed */
picture[0] = 'S';
picture[1] = 1;
picture[2] = '9';
picture[3] = 9;
picture[4] = 0;
break;
default:
picture[0] = '9';
picture[1] = (char) sy->len; /* this make the max 255 */
picture[2] = 0;
break;
}
tmp = curr_field;
curr_field = sy;
piccnt = sy->len;
update_field(curr_field);
close_fields();
curr_field = tmp;
tmp = NULL;
/* fprintf(stderr,"end define_temp_field: %c\n",desired_type); */
return sy;
}
int
define_implicit_field(struct sym *sy, struct sym *sykey, int idxlen)
{
int i = 1, /*m=0, d,*/ r = 0;
struct sym *tmp = NULL;
char tmp_picture[3];
struct index_to_table_list *i2t;
/* Fix me:
* This is a fix to ensure that indexes are defined as int (4 bytes)
* For some reason if defined otherwise (1, 2 bytes) the search all
* will not work.
*/
#if 0
for (i = 1; i < idxlen; i = i * 10)
{
m++;
}
d = idxlen;
while (d != 0)
{
m++;
i = i * 10;
d = idxlen / i;
}
#endif
/* Fix me:
* This is a fix to ensure that indexes are defined as int (4 bytes)
*/
/* sy->len=m; */
sy->len = 4;
sy->decimals = 0; /* suppose no decimals yet */
sy->pscale = 0;
sy->level = 1;
sy->type = DTYPE_BININT; /* assume numeric "usage is comp" item */
sy->redefines = NULL;
sy->linkage_flg = 0; /* should not go in the linkage section, never! */
/* sy->sec_no=SEC_STACK; */
sy->sec_no = default_sec_no;
sy->times = 1;
sy->occurs_flg = 0;
sy->son = sy->brother = NULL;
sy->flags.is_pointer = 0;
sy->flags.blank = 0;
memcpy(tmp_picture, picture, 3);
picture[0] = '9';
/* Fix me:
* This is a fix to ensure that indexes are defined as int (4 bytes)
*/
/* picture[1] = (char)m; */
picture[1] = (char) 8;
picture[2] = 0;
tmp = curr_field;
curr_field = sy;
update_field(curr_field);
close_fields();
curr_field = tmp;
memcpy(picture, tmp_picture, 3);
tmp = NULL;
i2t = malloc(sizeof (struct index_to_table_list));
if (i2t == NULL)
{
return 0;
}
i2t->next = NULL;
i = strlen(sy->name);
i2t->idxname = malloc(i + 1);
if (i2t->idxname == NULL)
{
free(i2t);
i2t = NULL;
return 0;
}
strcpy(i2t->idxname, sy->name);
i = strlen(curr_field->name);
i2t->tablename = malloc(i + 1);
if (i2t->tablename == NULL)
{
free(i2t->idxname);
free(i2t);
i2t = NULL;
return 0;
}
strcpy(i2t->tablename, curr_field->name);
i2t->seq = '0'; /* no sort sequence is yet defined for the table */
i2t->keyname = NULL;
if (sykey != NULL)
{
if (sykey->level == -1)
{
i2t->seq = '1';
}
if (sykey->level == -2)
{
i2t->seq = '2';
}
i = strlen(sykey->name);
i2t->keyname = malloc(i + 1);
if (i2t->keyname == NULL)
{
free(i2t->idxname);
free(i2t->tablename);
free(i2t);
return 0;
}
strcpy(i2t->keyname, sykey->name);
}
if (index2table == NULL)
{
index2table = i2t;
}
else
{
i2t->next = index2table;
index2table = i2t;
}
#ifdef DEBUG_COMPILER
fprintf(o_src, "#trace (define_implicit_field): index '%s' table '%s' tablekey '%s' sequence '%c'\n",
i2t->idxname,
i2t->tablename,
i2t->keyname,
i2t->seq
);
#endif
i2t = NULL;
return r;
}
struct sym*
determine_table_index_name(struct sym *sy)
{
struct sym *rsy = NULL;
struct index_to_table_list *i2t;
i2t = index2table;
while (i2t != NULL)
{
if (strcmp(i2t->tablename, sy->name) == 0)
{
rsy = lookup(i2t->idxname, SYTB_VAR);
i2t = NULL;
}
else
{
i2t = i2t->next;
}
}
#ifdef DEBUG_COMPILER
if (rsy == NULL)
{
fprintf(o_src, "#trace (determine_table_index_name): table name '%s' index name '(NULL)'\n",
sy->name
);
}
else
{
fprintf(stderr, "trace (determine_table_index_name): table name '%s' index name '%s'\n",
sy->name,
rsy->name
);
}
#endif
return rsy;
}
/* walter
verify if the variable is in the occurs */
int
in_occurs(struct sym *syfield)
{
struct sym *sy;
sy = syfield;
while (sy && sy->occurs_flg == 0)
{
sy = sy->parent;
}
if (!sy) return 0;
return 1;
}
void
define_field(int level, struct sym *sy)
{
struct sym *tmp;
struct sym *tmp1 = sy;
struct sym *tmp2;
if (sy == NULL)
{
sy = malloc(sizeof (struct sym));
sy->name = "%noname%";
}
if (level == 88)
{
sy->type = '8';
sy->defined = 1;
sy->len = 0;
sy->decimals = 0;
sy->pscale = 0;
sy->level = level;
sy->linkage_flg = at_linkage;
sy->sec_no = 0;
sy->times = 1;
sy->occurs_flg = 0;
sy->flags.just_r = 0;
sy->flags.separate_sign = 0;
sy->flags.leading_sign = 0;
sy->flags.blank = 0;
sy->son = sy->brother = NULL;
if (curr_field->level == 88)
{
curr_field->brother = sy;
sy->parent = curr_field->parent;
}
else
sy->parent = curr_field;
curr_field = sy;
check_fields(sy);
return;
}
if (level == 1 || level == 77 || level == 66)
curr_sec_no = default_sec_no;
sy->len = 0;
sy->decimals = 0; /* suppose no decimals yet */
sy->pscale = 0;
sy->level = level;
sy->redefines = NULL;
sy->linkage_flg = at_linkage;
sy->sec_no = (at_linkage ? SEC_ARGS : curr_sec_no);
sy->times = 1;
sy->occurs_flg = 0;
sy->flags.just_r = 0;
sy->flags.blank = 0;
sy->son = sy->brother = NULL;
sy->picstr = NULL;
/* Determine location in hierarchy */
tmp = curr_field;
if (tmp && ((level == 1) || (level == 77) || (level == 66)))
close_fields();
if (!tmp && (level > 1) && (level < 49))
{
yyerror("data field hierarchy broken");
}
if (level != 77 && level != 66)
{
while (tmp != NULL && tmp->level > level)
{
tmp1 = tmp;
tmp = tmp->parent;
}
if (tmp == NULL)
sy->parent = NULL;
else if (tmp->level < level)
{
sy->parent = tmp;
if (tmp->son == NULL)
tmp->son = sy;
/*else
yyerror("malformed data hierarchy");*/
else
{
tmp1->brother = sy;
sy->parent = tmp;
sy->level = tmp1->level;
}
}
else
{
tmp->brother = sy;
sy->parent = tmp->parent;
}
}
/* is it already defined ? */
if ((tmp2 = lookup(sy->name, SYTB_VAR)) != NULL)
{
if (tmp2 != sy && tmp2->parent == NULL && sy->parent == NULL)
yyerror("Variable %s already defined", tmp2->name);
}
/* Set initial values of inheritable fields */
if (sy->parent)
{
struct sym *syp = sy->parent;
sy->type = syp->type;
sy->flags.separate_sign = syp->flags.separate_sign;
sy->flags.leading_sign = syp->flags.leading_sign;
}
else
{
sy->type = DTYPE_DISPLAY;
sy->flags.separate_sign = 0;
sy->flags.leading_sign = 0;
}
curr_field = sy;
}
void
update_renames_field(struct sym *sy1, struct sym *sy2)
{
struct sym *sy = curr_field;
sy->son = NULL;
sy->parent = sy1->parent;
sy->redefines = sy1;
if (sy2 == NULL)
{
sy->type = sy1->type;
sy->location = sy1->location;
sy->len = sy1->len;
if (sy1->type == DTYPE_GROUP)
{
sy->pic = 0;
sy->descriptor = literal_offset;
literal_offset += FLD_DESC_SIZE0;
}
else
{
/* We should really reuse the original descriptor */
/* sy->descriptor = sy1->descriptor; */
sy->picstr = sy1->picstr;
sy->descriptor = literal_offset;
literal_offset += FLD_DESC_SIZE1;
sy->pic = literal_offset;
literal_offset += (strlen(sy1->picstr) + 1);
}
}
else
{
sy->type = DTYPE_GROUP;
sy->location = sy1->location;
sy->len = sy2->location - sy1->location + sy2->len;
sy->pic = 0;
sy->descriptor = literal_offset;
literal_offset += FLD_DESC_SIZE0;
}
save_field_in_list(sy);
curr_field = NULL; /* so that close_fields won't be invoked */
}
struct sym *
alloc_filler(void)
{
char s[15];
struct sym *sy;
sprintf(s, "FIL$%05d", filler_num++);
sy = install(s, SYTB_VAR, 0);
sy->defined = 1;
return sy;
}
struct selsubject *
save_sel_subject(int type, struct selsubject *ssubj, struct sym *sy)
{
struct selsubject *tmp = malloc(sizeof (struct selsubject));
struct selsubject *tmp1;
tmp->type = type;
tmp->var = sy;
tmp->next = NULL;
if (ssubj != NULL)
{
tmp1 = ssubj;
while (tmp1->next)
tmp1 = tmp1->next;
tmp1->next = tmp;
return ssubj;
}
return tmp;
}
void
compute_subject_set_size(struct selsubject *ssbj)
{
int stack_adjust = 0;
while (ssbj != NULL)
{
if (ssbj->type == SSUBJ_EXPR)
{
stack_adjust += 8;
}
else if (ssbj->type == SSUBJ_COND)
{
stack_adjust += 4;
}
ssbj = ssbj->next;
}
inner_stack_size += stack_adjust;
}
void
release_sel_subject(int label, struct selsubject *ssbj)
{
struct selsubject *tmp;
int stack_adjust = 0;
fprintf(o_src, ".L%d:\t# EVALUATE end\n", label);
while (ssbj != NULL)
{
if (ssbj->type == SSUBJ_EXPR)
{
stack_adjust += 8;
}
else if (ssbj->type == SSUBJ_COND)
{
stack_adjust += 4;
}
tmp = ssbj;
ssbj = ssbj->next;
free(tmp);
}
if (stack_adjust)
fprintf(o_src, "\taddl\t$%d, %%esp\n", stack_adjust);
/* we're leaving this level of stack frame */
inner_stack_size -= stack_adjust;
}
int
check_fields(struct sym *sy)
{
struct sym *tmp;
// int len;
int elen;
char *p; /* walter */
int sylen, i, isd; /* walter */
/* Only fields that are signed, class numeric, and usage DISPLAY may
* leave the sign flags on. */
if ((sy->type != DTYPE_DISPLAY) || (sy->picstr[0] != 'S'))
{
sy->flags.separate_sign = 0;
sy->flags.leading_sign = 0;
}
/* Recursively check children */
if (sy->son != NULL)
{
// len = 0;
for (tmp = sy->son; tmp != NULL; tmp = tmp->brother)
{
check_fields(tmp);
}
}
/*
These tests are done in YACC
if (sy->type == DTYPE_DISPLAY && sy->len > 18) {
yyerror("Maximum elementary numeric item size of %s > 18 digits exceeded", sy->name);
}
if (sy->type == DTYPE_ALPHANUMERIC && sy->len > 12750)
yyerror("Maximum elementary alphanumeric item size of %s > 12750 exceeded", sy->name);
*/
if (sy->level == 88)
{
if (sy->parent->len == 0)
yyerror("Parent variable of 88 has no storage");
}
if (sy->value != NULL)
{
sylen = sy->value->len; /* walter */
switch (sy->type)
{ /* test if numbers initiates with 0 and correct the error below walter */
case DTYPE_DISPLAY:
case DTYPE_BININT:
case DTYPE_PACKED:
case DTYPE_EDITED:
case DTYPE_FLOAT:
p = sy->value->name;
i = sylen;
sylen = 0;
isd = 0;
while (i)
{
switch (*p++)
{
case '0': if (isd) sylen++;
break;
default: sylen++;
isd = 1;
break;
}
i--;
}
break;
}
if (sylen > (elen = get_max_edt_len(sy)))
{
HTG_temporary_severity = 4;
yyerror("Value (length %d) of symbol %s is greater than it's picture (%d)", sylen, sy->name, elen);
HTG_temporary_severity = 8;
}
if (sy->value->type == DTYPE_ALPHANUMERIC &&
(sy->type == DTYPE_DISPLAY || sy->type == DTYPE_BININT))
if (!sy->flags.blank)
yyerror("Invalid value type for symbol %s", sy->name);
}
return 0;
}
int
set_field_value_sw(struct sym *sy, int times)
{
struct sym *tmp;
unsigned int res;
struct
{
unsigned int v : 1, sv : 1, tmpv : 1, tmpsv : 1;
} f;
f.v = 0;
f.sv = 0;
if (sy->son != NULL)
{
for (tmp = sy->son; tmp != NULL; tmp = tmp->brother)
{
res = set_field_value_sw(tmp, times);
f.v = f.v || res;
}
}
sy->flags.value = f.v = f.v || sy->value != NULL;
sy->flags.spec_value = f.sv = f.v;
/* fprintf(stderr,"set_field_value_sw: %s -> %d,%d\n",sy->name,f.v,f.sv); */
/* return f.v*2 + f.sv; */
return f.v;
}
int
set_field_length(struct sym *sy, int times)
{
struct sym *tmp;
int len, tmplen;
if (sy->son != NULL)
{
len = 0;
sy->type = DTYPE_GROUP;
for (tmp = sy->son; tmp != NULL; tmp = tmp->brother)
{
tmplen = tmp->times * set_field_length(tmp, times);
if (tmp->redefines == NULL)
len += tmplen;
}
sy->len = len;
}
len = symlen(sy) + sy->slack;
/* fprintf(stderr,"set_field_length: %s -> %d\n",sy->name,len*times); */
return len * times;
}
unsigned
field_alignment(struct sym *sy, unsigned location)
{
unsigned slack_bytes = 0, mod_loc;
if (sy->flags.sync == 0) return 0;
switch (sy->type)
{
case DTYPE_BININT:
mod_loc = (location - curr_01_location) % symlen(sy);
slack_bytes = (mod_loc == 0 ? 0 : symlen(sy) - mod_loc);
break;
}
#if 0
#ifdef DEBUG_COMPILER
fprintf(o_src, "#fa: %d, %d, %d, %d, %d\n", curr_01_location, location, symlen(sy), mod_loc, slack_bytes);
#endif
#endif
return slack_bytes;
}
void
set_field_location(struct sym *sy, unsigned location)
{
struct sym *tmp;
/* fprintf(stderr,"set_field_location: %s -> %d\n",sy->name,location); */
if (sy->level == 1) curr_01_location = location;
/********* allocate field descriptor *************/
sy->descriptor = literal_offset;
if (HTG_libcob)
{
literal_offset += (sy->type == DTYPE_GROUP ? CFLD_DESC_SIZE0 : CFLD_DESC_SIZE1);
}
else
{
literal_offset += (sy->type == DTYPE_GROUP ? FLD_DESC_SIZE0 : FLD_DESC_SIZE1);
}
/********* generate picture for field ************/
if (sy->type != DTYPE_GROUP)
{
sy->pic = literal_offset;
literal_offset += (strlen(sy->picstr) + 1);
}
else
sy->decimals = sy->pic = 0;
save_field_in_list(sy);
if (sy->redefines != NULL)
{
location = sy->redefines->location;
sy->slack = 0;
sy->flags.in_redefinition = 1;
}
else
{
sy->slack = field_alignment(sy, location);
location += sy->slack;
sy->flags.in_redefinition = 0;
}
if (sy->parent != NULL && sy->parent->flags.in_redefinition) sy->flags.in_redefinition = 1;
sy->location = location;
for (tmp = sy->son; tmp != NULL; tmp = tmp->brother)
{
set_field_location(tmp, location);
if (tmp->redefines == NULL)
{
if (tmp->sec_no == SEC_STACK)
{
location -= (symlen(tmp) + tmp->slack) * tmp->times;
/* negative for it's at the stack */
}
else
{
location += (symlen(tmp) + tmp->slack) * tmp->times;
}
}
}
}
void
scr_set_column(struct scr_info *si, struct sym *sy, int plus_minus)
{
int val;
si->column = 0;
si->column_var = NULL;
si->column_sign = plus_minus;
if (sy->litflag == 1)
{
si->column_var = NULL;
val = atoi(sy->name);
if (val == 0)
yyerror("line could not be 0");
si->column = val;
}
else
{
if (!(sy->defined))
yyerror("variable not defined %s ", sy->name);
if (sy->type == DTYPE_ALPHANUMERIC)
yyerror("variable %s must be numeric", sy->name);
si->column_var = sy;
}
}
void
scr_set_line(struct scr_info *si, struct sym *sy, int plus_minus)
{
int val;
si->line = 0;
si->line_var = NULL;
si->line_sign = plus_minus;
if (sy->litflag == 1)
{
si->line_var = NULL;
val = atoi(sy->name);
if (val == 0)
yyerror("line could not be 0");
si->line = val;
}
else
{
if (!(sy->defined))
yyerror("variable not defined %s ", sy->name);
if (sy->type == DTYPE_ALPHANUMERIC)
yyerror("variable %s must be numeric", sy->name);
si->line_var = sy;
}
}
/*void scr_push_display_position(struct lit *lit)*/
void
scr_push_display_position(struct sym *sy)
{
int len = 0, pos, lin, col;
struct lit *literal;
if (sy->litflag)
{
/* is a literal */
literal = (struct lit *) sy;
len = strlen(literal->name);
switch (len)
{
case 4:
pos = atoi(literal->name);
lin = pos / 100;
col = pos - (100 * lin);
push_immed(lin);
push_immed(col);
asm_call("tcob_goxy");
break;
case 6:
pos = atoi(literal->name);
lin = pos / 1000;
col = pos - (1000 * lin);
push_immed(lin);
push_immed(col);
asm_call("tcob_goxy");
break;
default:
yyerror("DISPLAY AT must be followed by a 4 digits or 6 digits integer");
break;
}
}
else
{
/* is a variable */
switch (sy->len)
{
case 4:
push_immed(4);
gen_loadloc(sy);
asm_call("tcob_goxy_variable");
break;
case 6:
push_immed(6);
gen_loadloc(sy);
asm_call("tcob_goxy_variable");
break;
default:
yyerror("DISPLAY AT must be followed by a 4 digits or 6 digits variable");
break;
}
}
}
/*************** report section ******************/
void
save_report(struct sym *rep, struct sym *file)
{
struct rd *rd = (struct rd *) rep;
struct list *item = malloc(sizeof (struct list));
item->var = rd;
item->next = report_list;
report_list = item;
rd->file = file;
rd->type = 'W';
rd->controls = rd->items = NULL;
rd->page_limit = 66;
rd->heading = 1;
rd->footing = 66;
rd->first_detail = rd->last_detail = 1;
}
void
update_report_field(struct sym *sy)
{
update_field(curr_field);
sy->type = 'Q';
}
void
update_screen_field(struct sym *sy, struct scr_info *si)
{
struct sym *tmp;
char *pic;
update_field(curr_field);
sy->type = DTYPE_ACCEPT_DISPLAY;
sy->scr = si;
si->label = screen_label++;
/* if picture is empty (implicit filler), and there is a
value declared, create its picture from value literal. */
if (*(sy->picstr) == 0 && sy->value != NULL)
{
tmp = (struct sym *) sy->value;
pic = sy->picstr = malloc(3);
*pic++ = 'X';
*pic++ = strlen(tmp->name);
*pic = 0;
sy->len = strlen(tmp->name);
}
}
void
update_field(struct sym *sy)
{
if (sy->level != 88 && sy->level != 66)
{
gen_picture();
}
/* printf("upd_flds:symbol: %s, %d, piccnt: %d, %d\n", sy->name,
sy->len, piccnt,pscale); */
/* Physical sizes for BINARY and FLOAT types are not (generally)
* affected by the PICTURE. */
if ((sy->type != DTYPE_BININT)
&& (sy->type != DTYPE_FLOAT))
{
if (piccnt == 1 && abs(pscale) == 1)
sy->len = 1; /* only one P in the picture */
else
sy->len = piccnt - abs(pscale);
}
/* SIGN IS ... SEPARATE only affects field length when class is numeric,
* usage is DISPLAY, and field is signed. However, sign flags must be
* temporarily retained in case this is a group item. */
if ((sy->type == DTYPE_DISPLAY)
&& (sy->picstr[0] == 'S')
&& (sy->flags.separate_sign))
{
sy->len++;
}
/* fprintf(stderr,"symbol: %s, piccnt: %d, %d\n", sy->name,
piccnt,pscale); */
/* update COMP field length (but not BINARY-<something>) */
if ((sy->type == DTYPE_BININT)
&& (sy->len == 0))
{
sy->len = query_comp_len(sy);
}
}
void
close_fields(void)
{
struct sym *sy;
int saved_length;
int ns_offset = 0;
if (curr_field == NULL) return;
/* printf("close: %s, %d\n", curr_field->name, curr_field->len); */
/********** locate level 01 field **************/
for (sy = curr_field; sy->parent != NULL; sy = sy->parent);
if (sy->level != 1 && sy->level != 77 && sy->level != 66)
{
yyerror("field not subordinate to any other: %s", sy->name);
}
/********** propagate value flags *************/
sy->flags.spec_value = set_field_value_sw(sy, 1);
/********** update length of fields *************/
if (sy->linkage_flg)
{
linkage_offset += (set_field_length(sy, 1) * sy->times);
set_field_location(sy, linkage_offset);
}
else if (sy->sec_no == SEC_DATA)
{
saved_length = (set_field_length(sy, 1) * sy->times);
set_field_location(sy, data_offset);
data_offset += saved_length;
}
else if (sy->sec_no >= SEC_FIRST_NAMED)
{
saved_length = (set_field_length(sy, 1) * sy->times);
set_field_location(sy, ns_offset);
ns_offset += saved_length;
}
else
{
stack_offset += (set_field_length(sy, 1) * sy->times);
set_field_location(sy, stack_offset);
}
check_fields(sy);
curr_field = NULL;
}
/*int
show_labels() {
struct sym *sy,*sy1,*sy2;
int i,j=0;
FILE *f;
f = fopen("show.labels","w");
for (i=0;i<HASHLEN;i++) {
for (sy=labtab[i];sy!=NULL;sy=sy->next) {
if (sy->type == 'f') continue;
sy1 = sy;
while (sy1) {
fprintf(f,"Label: %s, defined: %d, type: %c, parent: %s\n",
sy1->name, sy1->defined, sy1->type,
sy1->parent ? sy1->parent->name : "(NULL)");
j++;
sy1=sy1->clone;
}
}
}
fclose(f);
return j;
}*/
char *
var_name(struct sym *sy)
{
unsigned int n;
n = MAXNAMEBUF;
strcpy(name_buf, "");
while (n > strlen(sy->name) + 4)
{
if (n < MAXNAMEBUF)
strcat(name_buf, " OF ");
strcat(name_buf, sy->name);
n -= strlen(sy->name) + 4;
if ((lookup(sy->name, SYTB_VAR)->clone == NULL)
|| (sy->parent == NULL))
break;
sy = sy->parent;
}
return name_buf;
}
/* save variable values, including 88-var range/values list */
void
set_variable_values(struct lit *v1, struct lit *v2)
{
struct vrange /**vr,*/*new;
if (curr_field->value == NULL)
{
curr_field->refmod_redef.vr = NULL;
curr_field->value = v1;
curr_field->value2 = v2;
curr_field->flags.value = 1;
curr_field->flags.spec_value = 1;
}
else
{
new = malloc(sizeof (struct vrange));
new->value = v1;
new->value2 = v2;
/* spec_value is not used for 88 */
new->next = curr_field->refmod_redef.vr;
curr_field->refmod_redef.vr = new;
}
}
void
assign_expr(struct sym *sy, int opt, char end)
{
push_immed(opt);
gen_loadvar(sy);
if (end == '1')
{
stackframe_cnt += sizeof (double); /* value to be poped too */
}
asm_call("tcob_assign_double");
}
int
push_expr(struct sym *sy)
{
int retcode;
#ifdef DEBUG_COMPILER
fprintf(o_src, "##### push_expr begin\n");
#endif
retcode = push_subexpr(sy);
#ifdef DEBUG_COMPILER
fprintf(o_src, "##### push_expr end\n");
#endif
return retcode;
}
void
alloc_file_entry(struct sym *f)
{
f->record = stack_offset;
f->sort_file = 0;
#ifdef DEBUG_COMPILER
fprintf(o_src, "# Allocate space for file '%s' Stack Addr: %d\n",
f->name, stack_offset);
#endif
}
/*
** define a file, but don't generate code yet.
** (will be done later at dump_fdesc())
*/
void
gen_fdesc(struct sym *f, struct sym *r)
{
int len;
struct list *list, *templist;
struct alternate_list *alt;
list = (struct list *) malloc(sizeof (struct list));
if (files_list == NULL)
{
files_list = list;
}
else
{
templist = files_list;
while (templist->next != NULL)
{
templist = templist->next;
}
templist->next = list;
}
list->var = f;
list->next = NULL;
f->recordsym = r;
while (r != NULL)
{
r->ix_desc = f;
r = r->redefines;
}
len = sizeof (struct file_desc) - 10; /* suppose without indexes */
/* f->location = file_offset; */
if (f->organization == 1)
{ /* indexed file */
len += 10 + 2;
/* 10 -> remaining of struct file_desc (only for indexed files)
2 --> size of terminating "word -1| */
/* now count each alternate description size */
alt = (struct alternate_list *) f->alternate;
while (alt)
{
len += sizeof (struct altkey_desc);
alt = alt->next;
}
}
f->fdesc = global_offset;
global_offset += len;
/* file_offset += len; */
}
void
gen_status(struct sym *f)
{
if (f->parent)
{
push_eax();
gen_loadloc(f->parent);
asm_call("tcob_save_status");
}
}
void
gen_perform_decl(struct sym *f)
{
struct sym *decl_sym = f->refmod_redef.declarative;
int tmplabel;
if (decl_sym)
{
#ifdef DEBUG_COMPILER
fprintf(o_src, "# decl: on %s\n", decl_sym->name);
#endif
tmplabel = gen_check_zero();
gen_perform(decl_sym);
gen_dstlabel(tmplabel);
}
}
/****** sort statement related functions *******/
struct sortfile_node *
alloc_sortfile_node(struct sym *sy)
{
struct sortfile_node *sn;
if (sy->type != 'F')
{
yyerror("only files can be found here");
return NULL;
}
sn = malloc(sizeof (struct sortfile_node));
sn ->next = NULL;
sn->sy = sy;
return sn;
}
struct sym *
create_status_register(char *name)
{
struct sym *sy;
char pic[] = {'9', 2, 0};
sy = install(name, SYTB_VAR, 0);
if (sy->type) return sy; /* it already exists */
sy->type = DTYPE_DISPLAY;
sy->picstr = malloc(strlen(pic) + 1);
strcpy(sy->picstr, pic);
sy->defined = 1;
sy->occurs_flg = 0;
sy->times = 1;
sy->len = 2;
sy->son = sy->brother = NULL;
sy->linkage_flg = 0;
sy->sec_no = SEC_DATA;
sy->location = data_offset;
data_offset += 2;
sy->descriptor = literal_offset;
literal_offset += FLD_DESC_SIZE1;
sy->pic = literal_offset;
literal_offset += strlen(pic) + 1;
save_field_in_list(sy);
return sy;
}
void
gen_sort_using(struct sym *f, struct sortfile_node *sn)
{
struct sym *vstatus = create_status_register("SORT-RETURN");
gen_save_sort_fields(f, NULL);
push_immed(0);
while (sn)
{
gen_loadloc(sn->sy->filenamevar);
gen_save_filedesc(sn->sy);
sn = sn->next;
}
asm_call("tcob_sort_using");
/* save status returned by operation */
push_eax();
gen_loadloc(vstatus);
asm_call("tcob_save_status");
}
void
gen_sort_giving(struct sym *f, struct sortfile_node *sn)
{
struct sym *vstatus = create_status_register("SORT-RETURN");
gen_save_sort_fields(f, NULL);
push_immed(0);
while (sn)
{
gen_loadloc(sn->sy->filenamevar);
gen_save_filedesc(sn->sy);
sn = sn->next;
}
asm_call("tcob_sort_giving");
/* save status returned by operation */
push_eax();
gen_loadloc(vstatus);
asm_call("tcob_save_status");
}
void
gen_sort(struct sym *f)
{
struct sym *datafld;
if ((f->recordsym))
{
gen_loadloc(f->filenamevar);
gen_save_filevar(f, NULL);
asm_call("tcob_sort_open");
gen_status(f);
gen_perform_decl(f);
gen_close_sort(f);
}
else
{ /* walter */
push_immed(0);
if (f->sort_data)
{
datafld = (struct sym *) f->sort_data;
while (datafld != NULL)
{
gen_loadloc(datafld); /* value of field */
push_immed((int) datafld->direction);
gen_loaddesc2(datafld, 1); /* field struct */
datafld = (struct sym *) (datafld->sort_data);
if (datafld == (struct sym *) f->sort_data)
datafld = NULL;
}
}
if (f->occurs)
{
gen_loaddesc(f->occurs->depend); /* depending on */
gen_loadloc(f->occurs->depend);
push_immed((int) f->occurs->max); /* occurs n times */
push_immed((int) f->occurs->min); /* occurs initial times */
}
else
{
push_immed(0);
push_immed(0);
push_immed((int) f->times); /* occurs n times */
push_immed(1); /* occurs initial times */
}
push_immed((int) f->len);
gen_loadloc(f);
gen_loaddesc2(f, 1);
asm_call("tcob_sort_mem");
}
}
void
gen_open(int mode, struct sym *f)
{
push_immed(mode);
gen_loadloc(f->filenamevar);
gen_save_filevar(f, NULL);
asm_call("tcob_open");
gen_status(f);
gen_perform_decl(f);
}
void
gen_close_sort(struct sym *f)
{
struct sym *sortf;
/********** allocate memory for SORT descriptor ***********/
save_field_in_list(f);
f->descriptor = literal_offset;
sortf = (struct sym *) (f->sort_data);
while (sortf != NULL)
{
literal_offset += 2;
sortf = (struct sym *) (sortf->sort_data);
}
literal_offset++;
}
void
gen_close(struct sym *f)
{
gen_save_filevar(f, NULL);
asm_call("tcob_close");
gen_status(f);
gen_perform_decl(f);
}
void
gen_return_stmt(struct sym *f, struct sym *buf)
{
gen_save_filevar(f, buf);
asm_call("tcob_sort_return");
gen_status(f);
gen_perform_decl(f);
}
int
gen_reads(struct sym *f, struct sym *buf, struct sym *key,
int next_prev, int sel, int withlock)
{
int r = 0;
int t_next_prev = next_prev;
/* NOTE:
* While this is functional, it requires to be updated to trap more syntax errors
*/
if (f->type != 'F')
{
yyerror("invalid variable \'%s\', file name expected", f->name);
r++;
return r;
}
#if 0
/* READ w/o [NOT] AT END or [NOT] INVALID KEY clauses */
if (sel == 0)
{
if ((next_prev != 0) && (key != NULL))
{
yyerror("invalid clause NEXT found in READ statement with KEY IS data-name option");
r++;
}
else
{
}
}
/* READ with [NOT] AT END clauses */
if (sel == 1)
{
}
/* READ with [NOT] INVALID KEY clauses */
if (sel == 2)
{
if (next_prev != 0)
{
yyerror("invalid clause NEXT found in READ statement with INVALID KEY option");
r++;
}
else
{
}
}
/* RETURN w/o [NOT] AT END clauses */
if (sel == 4)
{
}
/* RETURN with [NOT] AT END clauses */
if (sel == 5)
{
}
#endif
if (r == 0)
{
/* fprintf(stderr, "sel %d, np %d\n", sel, next_prev); */
if (f->access_mode == ACC_SEQUENTIAL &&
f->sort_file == 1)
{
gen_return_stmt(f, buf);
return r;
}
if ((f->access_mode == ACC_SEQUENTIAL || f->access_mode == ACCEV_SEQUENTIAL) &&
f->organization != ORG_LINESEQUENTIAL)
{
if (t_next_prev == 0) t_next_prev = 1;
gen_read_next(f, buf, t_next_prev, withlock);
return r;
}
if ((sel > -1) && (sel < 4))
{
/* if (sel == 1) t_next_prev = 1; */ /* AT END implies read next */
if (t_next_prev > 0
&& (f->organization == ORG_INDEXED || f->organization == ORG_RELATIVE)
&& (f->access_mode == ACC_DYNAMIC || f->access_mode == ACC_SEQUENTIAL || f->access_mode == ACCEV_SEQUENTIAL
|| f->access_mode == ACCEV_DYNAMIC)
)
{
gen_read_next(f, buf, t_next_prev, withlock);
}
else
{
gen_read(f, buf, key, withlock);
}
}
else
{
if (f->organization != ORG_SEQUENTIAL)
gen_read_next(f, buf, next_prev, withlock);
else
gen_return_stmt(f, buf);
}
}
return r;
}
void
gen_unlock(struct sym *f)
{
if (f->type != 'F')
{
yyerror("invalid variable \'%s\', file expected", f->name);
return;
}
gen_save_filevar(f, NULL);
asm_call("tcob_unlock");
}
void
gen_read(struct sym *f, struct sym *buf, struct sym *key,
int withlock)
{
struct rec_varying *rv = (struct rec_varying *) f->rec_varying;
/* gen_check_varying(f); */
if (f->organization == ORG_RELATIVE)
{
/*gen_loadloc( f->ix_desc );
fprintf(o_src,"\tmovl\t$c_base+%u, %%eax\n",
f->ix_desc->descriptor);
push_eax();*/
gen_loadvar(f->ix_desc);
asm_call("tcob_get_index");
push_eax();
}
if (f->organization == ORG_INDEXED)
{
gen_loadvar(key);
}
/* pass the desc/address of reclen, if VARYING ... */
if (rv != NULL)
gen_loadvar(rv->reclen);
else
gen_loadvar(NULL);
gen_save_filevar(f, buf);
if (withlock == 1)
asm_call1("tcob_setlock");
else
if (withlock == 2)
asm_call1("tcob_ignorelock");
asm_call("tcob_read");
gen_status(f);
/* gen_perform_decl(f); */ /* must be generated after At End or Invalid Key */
}
void
gen_read_next(struct sym *f, struct sym *buf, int next_prev,
int withlock)
{
struct rec_varying *rv = (struct rec_varying *) f->rec_varying;
if (rv != NULL)
gen_loadvar(rv->reclen);
else
gen_loadvar(NULL);
gen_save_filevar(f, buf);
if (next_prev == 1)
{
if (withlock == 1)
asm_call1("tcob_setlock");
else
if (withlock == 2)
asm_call1("tcob_ignorelock");
asm_call("tcob_read_next");
}
else
{
if (withlock == 1)
asm_call1("tcob_setlock");
else
if (withlock == 2)
asm_call1("tcob_ignorelock");
asm_call("tcob_read_prev");
}
gen_status(f);
/* gen_perform_decl(f); */ /* must be generated after At End or Invalid Key */
}
void
gen_release(struct sym *r, struct sym *buf)
{
struct sym *f;
f = r->ix_desc;
if (buf != NULL)
{
gen_move(buf, r);
}
gen_save_sort_fields(f, buf);
asm_call("tcob_sort_release");
gen_status(f);
gen_perform_decl(f);
}
void
gen_write(struct sym *r, struct sym *advar, struct sym *buf, int opt)
{
struct sym *f = r->ix_desc;
struct rec_varying *rv = (struct rec_varying *) f->rec_varying;
gen_check_varying(f);
if (opt)
{
if (buf != NULL)
{
gen_move(buf, r);
}
if (advar != NULL)
gen_loadvar(advar);
if (rv != NULL)
gen_loadvar(rv->reclen);
else
gen_loadvar(NULL);
push_immed(opt);
/* gen_save_filevar( f,buf ); */
/* Is this code correct ??? It works but ... */
gen_save_filevar(f, r);
asm_call("tcob_write_adv");
#if 0
/* This code does not work !!! */
if (rv != NULL)
gen_loadvar(rv->reclen);
else
gen_loadvar(NULL);
push_immed(opt);
gen_save_filevar(f, buf);
if (buf == NULL)
asm_call("tcob_write_adv");
else
{
gen_move(buf, r);
/* asm_call("tcob_write_adv_from"); */
asm_call("tcob_write_adv");
}
#endif
}
else
{
if (f->organization == ORG_RELATIVE)
{
/*gen_loadloc( f->ix_desc );
fprintf(o_src,"\tmovl\t$c_base+%u, %%eax\n",
f->ix_desc->descriptor);
push_eax();*/
gen_loadvar(f->ix_desc);
asm_call("tcob_get_index");
push_eax();
}
/* Handle Write From by moving the data and then setting Buf to NULL
* only if it is not a relative record.
*/
if ((buf != NULL) && (f->organization != ORG_RELATIVE))
{
gen_move(buf, r);
buf = NULL;
}
if (rv != NULL)
gen_loadvar(rv->reclen);
else
gen_loadvar(NULL);
gen_save_filevar(f, buf);
asm_call("tcob_write");
}
gen_status(f);
gen_perform_decl(f);
}
void
gen_rewrite(struct sym *r, struct sym *buf)
{
struct sym *f = r->ix_desc;
struct rec_varying *rv = (struct rec_varying *) f->rec_varying;
gen_check_varying(f);
if (f->organization == ORG_RELATIVE)
{
/*gen_loadloc( f->ix_desc );
fprintf(o_src,"\tmovl\t$c_base+%u, %%eax\n",
f->ix_desc->descriptor);
push_eax();*/
gen_loadvar(f->ix_desc);
asm_call("tcob_get_index");
push_eax();
}
if (rv != NULL)
gen_loadvar(rv->reclen);
else
gen_loadvar(NULL);
gen_save_filevar(f, buf);
asm_call("tcob_rewrite");
gen_status(f);
gen_perform_decl(f);
}
void
gen_start(struct sym *f, int cond, struct sym *key)
{
gen_check_varying(f);
if (f->organization == ORG_RELATIVE)
{
/*gen_loadloc( f->ix_desc );
fprintf(o_src,"\tmovl\t$c_base+%u, %%eax\n",
f->ix_desc->descriptor);
push_eax();*/
gen_loadvar(f->ix_desc);
asm_call("tcob_get_index");
push_eax();
}
else
{
gen_loadvar(key);
}
push_immed(cond);
gen_save_filevar(f, NULL);
asm_call("tcob_start");
gen_status(f);
gen_perform_decl(f);
}
void
gen_delete(struct sym *f)
{
gen_check_varying(f);
if (f->organization == ORG_RELATIVE)
{
/*gen_loadloc( f->ix_desc );
fprintf(o_src,"\tmovl\t$c_base+%u, %%eax\n",
f->ix_desc->descriptor);
push_eax();*/
gen_loadvar(f->ix_desc);
asm_call("tcob_get_index");
push_eax();
}
gen_save_filevar(f, NULL);
asm_call("tcob_delete");
gen_status(f);
gen_perform_decl(f);
}
void
set_rec_varying_info(struct sym *f, struct lit *lmin,
struct lit *lmax, struct sym *reclen)
{
struct rec_varying *rv = malloc(sizeof (struct rec_varying));
f->rec_varying = (char *) rv;
rv->lmin = lmin;
rv->lmax = lmax;
rv->reclen = reclen;
}
void
gen_check_varying(struct sym *f)
{
struct rec_varying *rv = (struct rec_varying *) f->rec_varying;
if (rv != NULL)
{
gen_loadvar(rv->reclen);
gen_loadvar((struct sym *) rv->lmax);
gen_loadvar((struct sym *) rv->lmin);
gen_save_filedesc(f);
asm_call("tcob_check_varying");
}
}
int
get_switch_number(struct sym *sy)
{
return (sy->name[2] - '0');
}
void
gen_get_switches()
{
struct list *l = switches_list;
struct sym *svar;
while (l != NULL)
{
svar = l->var;
push_immed(get_switch_number(svar->ix_desc));
gen_loadvar(svar);
asm_call("tcob_get_switch");
l = l-> next;
}
}
void
gen_set_switch(struct sym *var, struct sym *sy)
{
gen_move(var, sy);
push_immed(get_switch_number(sy->ix_desc));
gen_loadvar(sy);
asm_call("tcob_set_switch");
}
struct list *
chain_var(struct sym *sy)
{
vars_list = insert_list(vars_list, sy);
return vars_list;
}
void
gen_push_using(struct sym *sy)
{
struct parm_list *list;
if (sy->type == 'F')
yyerror("file could not be used as parameter in a CALL");
list = (struct parm_list *) malloc(sizeof (struct parm_list));
list->var = (void *) sy;
list->next = parameter_list;
list->location = 0;
list->sec_no = 0;
parameter_list = list;
}
void
gen_save_usings(struct gvar_list *gsylst)
{
struct gvar_list *gl;
for (gl = gsylst; gl->next != NULL; gl = gl->next)
{
gen_save_using(gl->u.sym);
}
gen_save_using(gl->u.sym);
}
void
gen_save_using(struct sym *sy)
{
sy->linkage_flg = using_offset;
using_offset += 4;
}
void
gen_save_chainings(struct gvar_list *gsylst)
{
struct gvar_list *gl;
for (gl = gsylst; gl->next != NULL; gl = gl->next)
{
gen_save_chaining(gl->u.sym);
}
gen_save_chaining(gl->u.sym);
}
void
gen_save_chaining(struct sym *sy)
{
struct parm_list *list;
if (sy->type == 'F')
yyerror("only variables could be used as parameter in CHAINING");
list = (struct parm_list *) malloc(sizeof (struct parm_list));
list->var = (void *) sy;
list->next = chaining_list;
list->location = 0;
list->sec_no = 0;
chaining_list = list;
}
void
gen_chain(struct sym *v, int stack_size, int exceplabel)
{
struct parm_list *list, *tmp;
struct sym *cp;
#ifdef DEBUG_COMPILER
fprintf(o_src, "#chain %s\n", v->name);
#endif
push_immed(0);
for (list = parameter_list; list != NULL; list = tmp)
{
cp = (struct sym *) list->var;
gen_loadvar(cp);
tmp = list->next;
free(list);
}
parameter_list = NULL;
gen_loadvar(v);
asm_call("tcob_chain");
}
short
get_std_val(struct sym *sy)
{
if (sy->value == NULL)
{
return 0;
}
else if (sy->value == spe_lit_ZE)
{
return 2;
}
else if (sy->value == spe_lit_SP)
{
return 3;
}
else if (sy->value == spe_lit_LV)
{
return 4;
}
else if (sy->value == spe_lit_HV)
{
return 5;
}
else
{
return 1;
}
}
/*
* Count the number of items under the field sy
* if (sw_val) ???
*/
int
get_nb_fields(struct sym *sy_org, int sw_val)
{
struct sym *tmp;
int nb_fields = 1, tmpnf;
char ftype;
short val;
/* walter 13-12-05 */
// char ftype = sy->type;
struct sym *sy;
int oc;
sy = sy_org;
oc = 0;
if (sy->litflag == 2)
{
oc = 1;
sy = ((struct vref *) sy)->sym;
if (sy->litflag == 2)
sy = ((struct vref *) sy)->sym;
}
/* fim walter */
ftype = sy->type;
if (sy->type == DTYPE_GROUP)
{
for (tmp = sy->son; tmp != NULL; tmp = tmp->brother)
{
tmpnf = get_nb_fields(tmp, sw_val);
if (tmp->redefines == NULL)
nb_fields += tmpnf;
}
/* if(oc) // walter 13-12-05
return nb_fields;*/
}
else
{
/* Packed fields are presently considered non-homogenous */
if (ftype == DTYPE_PACKED) ftype = '&';
if (ftype == DTYPE_DISPLAY && sy->picstr[0] == 'S') ftype = '&';
if (init_ctype == ' ') init_ctype = ftype;
if (ftype != init_ctype && init_ctype != '&')
init_ctype = '&';
if (sw_val)
{
val = get_std_val(sy);
if (init_val == -1) init_val = val;
if (ftype == init_ctype && init_ctype != '&' &&
val != init_val)
init_ctype = '&';
}
}
if (oc) return nb_fields;
else
return nb_fields * sy->times;
}
/*
* sy : field
* initp : 0
* init_loc : initial location
* nb_fields : number of fields
*/
static int
_build_init_str(struct sym *sy, int initp,
unsigned *init_loc, int nb_fields,
struct sym *fsy, struct vref *ref)
{ // walter 13-12-05
char mem_warn[] = "**** WARNING invading end of malloced memory";
struct sym *tmp;
int stidx = -1, endidx = -1;
int i, j;
struct sym *sy_org = NULL; //walter 13-12-05
struct vref *refa; // walter 13-12-05
if (initp >= nb_fields)
{
fprintf(stderr, "%s, f,sym: %s\n", mem_warn, sy->name);
return initp;
}
// walter 13-12-05
if (ref)
{
sy_org = malloc(sizeof (struct sym));
refa = (struct vref *) sy_org;
//sy_org=(struct sym*)create_subscripted_var( sy, ref );
refa->litflag = 2;
refa->sym = sy;
refa->next = ref->next;
//create_subscripted_var( struct sym * sy, struct vref *subs )
}
else
sy_org = sy;
// fim walter
stidx = initp;
istrp->ent[initp].sy = sy_org; // walter 13-12-05
istrp->ent[initp].type = sy->type;
istrp->ent[initp].value = sy->value;
istrp->ent[initp].len = symlen(sy);
istrp->ent[initp].location = *init_loc;
if (sy->type != DTYPE_GROUP)
{
*init_loc += istrp->ent[initp].len;
}
initp++;
if (sy->type == DTYPE_GROUP)
{
for (tmp = sy->son; tmp != NULL; tmp = tmp->brother)
{
if (tmp->redefines == NULL)
initp = _build_init_str(tmp, initp, init_loc, nb_fields, fsy, ref); // walter 13-12-05
}
}
endidx = initp;
if (ref && fsy && fsy == sy) // only for these ocorrency walter 13-12-05
return initp;
for (i = 1; i < sy->times; i++)
{
if (initp >= nb_fields)
{
fprintf(stderr, "%s, i,sym: %s\n", mem_warn, sy->name);
break;
}
for (j = stidx; j < endidx; j++)
{
if (initp >= nb_fields)
{
fprintf(stderr, "%s, j,sym: %s\n", mem_warn, sy->name);
break;
}
istrp->ent[initp].sy = istrp->ent[j].sy;
istrp->ent[initp].type = istrp->ent[j].type;
istrp->ent[initp].value = istrp->ent[j].value;
istrp->ent[initp].len = istrp->ent[j].len;
istrp->ent[initp].location = *init_loc;
if (istrp->ent[j].type != DTYPE_GROUP)
*init_loc += istrp->ent[initp].len;
initp++;
}
}
return initp;
}
int
build_init_str(struct sym *sy_org, int nb_fields)
{
unsigned init_loc;
/* walter 13-12-05 */
struct sym *sy = NULL, *ref = NULL;
struct vref *ref1 = NULL;
int i;
sy = sy_org;
init_loc = sy->location;
i = 0;
if (sy->litflag == 2)
{
ref1 = ((struct vref *) sy);
ref = ((struct vref *) sy)->next->sym;
sy = ((struct vref *) sy)->sym;
if (sy->litflag == 2)
sy = ((struct vref *) sy)->sym;
if (ref->litflag == 1)
{ // index by literal
i = atoi(ref->name);
init_loc = ((i - 1) * sy->len) + sy->location;
ref = NULL;
}
}
/* fim walter */
return _build_init_str(sy, 0, &init_loc, nb_fields, sy, ref1);
}
void
gen_from_init_str(int nb_fields)
{
int i;
for (i = 0; i < nb_fields; i++)
{
unsigned temp_loc = istrp->ent[i].sy->location;
istrp->ent[i].sy->location = istrp->ent[i].location;
gen_init_str(istrp->ent[i].sy, istrp->ent[i].type, istrp->ent[i].len);
istrp->ent[i].sy->location = temp_loc;
}
}
/*
* Initialize field 'sy' of type 'init_ctype' and of length 'len'
*
*/
void
gen_init_str(struct sym *sy, char init_ctype, int len)
{
#ifdef DEBUG_COMPILER
fprintf(o_src, "# init_str %s, type %c, len %d, loc %d\n", sy->name, init_ctype, len, sy->location);
#endif
switch (init_ctype)
{
case DTYPE_DISPLAY:
case DTYPE_PACKED:
if (sy->value != NULL)
gen_move_init((struct sym *) sy->value, sy); /* initial value */
else
gen_move((struct sym *) spe_lit_ZE, sy);
break;
case DTYPE_BININT:
if (sy->type == DTYPE_BININT)
{
if (sy->value != NULL)
gen_move_init((struct sym *) sy->value, sy); /* initial value */
else
gen_move((struct sym *) spe_lit_ZE, sy);
}
else
{
if (sy->value != NULL)
gen_move_init((struct sym *) sy->value, sy); /* initial value */
else
gen_move((struct sym *) spe_lit_LV, sy);
}
break;
default:
if (sy->value != NULL)
gen_move_init((struct sym *) sy->value, sy); /* initial value */
else
gen_move((struct sym *) spe_lit_SP, sy);
break;
}
}
/*
* Generate an initialize field
*
*/
void
gen_initializes(struct gvar_list *gsylst)
{
struct gvar_list *gl;
for (gl = gsylst; gl->next != NULL; gl = gl->next)
{
gen_initialize(gl->u.sym, 1);
}
gen_initialize(gl->u.sym, 1);
}
/* walter 13-12-05
void gen_initializes_verb(struct gvar_list *gsylst, struct lit *init_alphab, struct lit *init_alpha, struct lit *init_alphaedt, struct lit *init_num, struct lit *init_numedt) {
struct gvar_list *gl;
unsigned int idx=0;
for(gl=gsylst; gl->next!=NULL; gl=gl->next) {
gen_move_first(gl->u.sym, 0, 0, &idx);
}
gen_move_first(gl->u.sym, 0, 0, &idx);
return;
}
unsigned int gen_move_first(struct sym *sy, unsigned int loc, unsigned int size, unsigned int *idx) {
struct sym *var, *tmp, *cop, *ref;
int subs, i, ntimes, bSign=0;
unsigned char cDigit;
char *valor;
unsigned int loc_cop=0;
if(sy==NULL) return loc;
var=sy; // Make sure BLANK test is done on a sym struct, and not a vref struct
// litflag
// 1-literal
// 2-variable
// 4-refmod
// 5-expr
// ,-end of subscripted
// + - -subscript arith
//
if(var->litflag==4 || var->litflag==2 || var->litflag==4) {
gen_subscripted( (struct vref *)var );
// ref=((struct vref *)var)->next->sym;
// valor=ref->name;
// if(!ref->litflag)
// valor=ref->value->name;
// integer's name is just it's value in ascii
// if(*valor!='%') { // eca
// for(i=0; (cDigit = valor[i]); i++) {
// if(cDigit=='}') {
// cDigit=0;
// } else if(cDigit=='{') {
// cDigit=0;
// bSign=1;
// } else if((cDigit>='A') && (cDigit<='I')) {
// cDigit-='A'-1;
// } else if ((cDigit>='J') && (cDigit<='R')) {
// cDigit-='J'-1;
// bSign=1;
// } else if(isdigit(cDigit)){
// cDigit-='0';
// } else
// cDigit=0;
// *idx=(*idx * 10) + cDigit;
// }
// }
var=((struct vref *)var)->sym;
if(var->litflag==2)
var=((struct vref *)var)->sym;
}
if(var->flags.external) return loc;
if(var->type == DTYPE_GROUP) {
if(loc==0) loc=var->location;
ntimes=var->times;
if(*idx) ntimes=1;
do {
tmp=var->son;
while(tmp!=NULL) {
if(tmp->redefines) {
loc=gen_move_first(tmp, tmp->location, var->len, idx);
} else {
loc=gen_move_first(tmp, loc, var->len, idx);
}
tmp=tmp->brother;
}
ntimes--;
} while(ntimes);
return loc;
} else {
if(loc==0) {
loc=var->location;
ntimes=var->times;
}
}
cop = malloc(sizeof(struct sym));
memcpy(cop, var, sizeof(struct sym));
if(*idx) (*idx)--;
while(*idx) {
loc+=size;
(*idx)--;
}
i = cop->times;
while(i--) {
cop->location=loc;
gen_init_str(cop, cop->type, 1);
loc += cop->len;
}
free(cop);
return loc;
}
fim walter */
void
gen_initialize(struct sym *sy_start, int from_initializes)
{
/*struct sym *sy;*/
int nb_fields;
struct init_str init_templ;
/* Possible optimization:
* 1) Compress the init sequence to reduce the number
* of elementary moves.
*/
if (sy_start == NULL) return;
if (sy_start->flags.external && !from_initializes) return; // walter 13-12-05
#ifdef DEBUG_COMPILER
fprintf(o_src, "# INITIALIZE %s, type %c\n", sy_start->name, sy_start->type);
#endif
init_ctype = ' ';
nb_fields = get_nb_fields(sy_start, 0);
if (init_ctype != '&' && init_ctype != ' ')
{
gen_init_str(sy_start, init_ctype, symlen(sy_start));
return;
}
#ifdef DEBUG_COMPILER
fprintf(o_src, "# (2) istrp = malloc(%d) nb_fields = %d\n",
nb_fields * sizeof (init_templ), nb_fields);
#endif
istrp = malloc(nb_fields * sizeof (init_templ));
build_init_str(sy_start, nb_fields);
gen_from_init_str(nb_fields);
free(istrp);
istrp = NULL;
#ifdef DEBUG_COMPILER
fprintf(o_src, "# END_INITIALIZE\n");
#endif
}
/*
* Cancel statement
* The parameter is the field or literal containing the name of the routine to cancel
* if the parameter is NULL, a is a CACNEL ALL
*/
void
gen_cancel(struct sym *routine_name)
{
if (routine_name)
{
gen_loadvar(routine_name);
asm_call("tcob_cancel");
}
else
{
asm_call("tcob_cancel_all");
}
}
/*
* GOBACK statement.
* If is a module generate EXIT PROGRAM, else STOP RUN
*/
void
gen_goback()
{
if (module_flag) /* If is a module generate EXIT PROGRAM, else STOP RUN */
gen_exit(1);
else
gen_stoprun();
}
/* ok nao achei nenhuma referencia para esta funcao
void mark_actives( int first, int last ) {
int i;
if (last<first) last=first;
if (first<0 || first>36) first=0;
if (last<0 || last>36) last=0;
for (i=first;i<=last;i++) active[i]=1;
}
ok
used with qsort
return: strncmp from *z1 and *z2
see man qsort for more explanation */
int
sort_exref_compare(const void *z1, const void *z2)
{
char ss1[256], ss2[256];
strncpy(ss1, var_name(*(struct sym **) z1), sizeof (ss1));
strncpy(ss2, var_name(*(struct sym **) z2), sizeof (ss2));
return strncmp(ss1, ss2, sizeof (ss1));
}
void
dump_symbols()
{
int i, j, k, arsize, slen;
struct sym *sy, *sy1, **sytable;
char t, *s, *str1, sa1[256];
if (!HTG_list_flag)
return;
fprintf(o_lst,
"\n=======================================================================");
fprintf(o_lst, "\n\nSymbols of module:%20.20s\n", pgm_label);
fprintf(o_lst, "--------------------------------------\n");
for (i = 0; i < HASHLEN; i++)
{
/* for (sy=labtab[i];sy!=NULL;sy=sy->next) { */
for (sy = vartab[i]; sy != NULL; sy = sy->next)
{
t = sy->type;
sy1 = sy;
while (sy1)
{
/* check if any variables (excluding intrinsic functions)
are undefined */
if ((sy1->defined == 0) && (sy->type == 0))
{
yyerror("Declared but undefined variable \'%s\' found.", sy1->name);
/* fprintf(stderr, "Undefined variable \'%s\', defined=%d, type=%c, line=%d;\n",
sy1->name, sy1->defined, sy1->type, sy1->xrefs.lineno[0]); */
}
#if 0
else
{
fprintf(stderr, "Defined variable \'%s\', defined=%d, type=%c, line=%d;\n",
sy1->name, sy1->defined, sy1->type, sy1->xrefs.lineno[0]);
}
#endif
sy1 = sy1->clone;
}
}
}
if (!HTG_list_flag)
{
return;
}
/* Determine size of tree */
for (i = 0, j = 0; i < HASHLEN; i++)
{
for (sy1 = vartab[i]; sy1 != NULL; sy1 = sy1->next)
{
for (sy = sy1; sy; sy = sy->clone)
{
if (sy->xrefs.lineno[0] != 0)
{
j++;
}
}
}
}
arsize = j;
/* Allocate sort array */
sytable = (struct sym**) malloc(sizeof (struct sym *) * (arsize));
/* Initialize sort array from hash tree */
for (i = 0, j = 0; i < HASHLEN; i++)
{
for (sy1 = vartab[i]; sy1 != NULL; sy1 = sy1->next)
{
for (sy = sy1; sy; sy = sy->clone)
{
if (sy->xrefs.lineno[0] != 0)
{
sytable[j] = sy;
str1 = var_name(sytable[j]);
j++;
}
}
}
}
/* Sort array using the quick sort function */
qsort(sytable, arsize, sizeof (struct sym *), sort_exref_compare);
if (HTG_xref_flag)
{
fprintf(o_lst, "\n---------------------------------------------------- Cross Refrence Listing --------------------------------------------------------\n\n");
fprintf(o_lst, "Variable Symbol ( Qualifiers ) Locations\n");
fprintf(o_lst, "-----------------------------------------+------------------------------------------------------------------------------------------\n");
for (i = 0; i < arsize; i++)
{
sy = sytable[i];
if (sy->xrefs.lineno[0] != 0)
{
s = var_name(sy);
strcpy(sa1, "");
j = 0;
k = 0;
slen = strlen(s);
if (slen > 40)
{
for (j = 0; j < (slen - 40); j = j + k)
{
str1 = strstr(s + j, " OF ");
k = strlen(str1 + 4);
k = slen - j - k;
strncpy(sa1, s + j, k);
sa1[k] = '\0';
fprintf(o_lst, "%-40s\n", sa1);
}
strcpy(sa1, s + j);
}
else
{
strcpy(sa1, s);
}
fprintf(o_lst, "%-40s ", sa1);
for (j = 0; j < sy->xrefs.pos; j++)
{
if ((j % 8 == 0) && (j > 0))
{
fprintf(o_lst, "\n%-40s ", "");
}
fprintf(o_lst, "%06d ", sy->xrefs.lineno[j]);
}
fprintf(o_lst, "\n");
}
}
}
if (!HTG_list_flag)
{
return;
}
fprintf(o_lst, "\n---------------------------------------------------------------+-----------------\n");
fprintf(o_lst, "Symbol ( Variables ) Type Level Len Dec Mul | Desc Loc Pic S\n");
fprintf(o_lst, "---------------------------------------------------------------+-----------------\n");
for (i = 0; i < arsize; i++)
{
sy = sytable[i];
s = var_name(sy);
strcpy(sa1, "");
j = 0;
k = 0;
slen = strlen(s);
if (slen > 40)
{
for (j = 0; j < (slen - 40); j = j + k)
{
str1 = strstr(s + j, " OF ");
k = strlen(str1 + 4);
k = slen - j - k;
strncpy(sa1, s + j, k);
sa1[k] = '\0';
fprintf(o_lst, "%-40s\n", sa1);
}
strcpy(sa1, s + j);
}
else
{
strcpy(sa1, s);
}
fprintf(o_lst,
"%-40s%4c%1c%3d %5d %3d %3d%c| %04X %04X%c%04X %1d\n",
sa1,
/* sy->type, */
sy->type ? sy->type : '0',
sy->flags.just_r ? 'R' : ' ',
sy->level,
sy->len,
sy->decimals,
sy->times,
sy->occurs_flg ? '*' : ' ',
sy->descriptor,
sy->location,
sy->linkage_flg ? '*' : ' ',
sy->pic,
sy->sec_no);
}
fprintf(o_lst, "\n\n");
fprintf(o_lst, "\n-----------------------------------------------\n");
fprintf(o_lst, "Symbol ( 88-condition ) Variable tested");
fprintf(o_lst, "\n-----------------------------------------------\n");
for (i = 0; i < HASHLEN; i++)
{
for (sy = vartab[i]; sy != NULL; sy = sy->next)
{
t = sy->type;
if (t == '8')
fprintf(o_lst, "%22.22s %22.22s\n",
sy->name,
sy->parent->name);
}
}
fprintf(o_lst,
"\n-----------------------------------------------------------------------\n");
fprintf(o_lst, "%s%s%s",
" Paragraph ",
" Section ", " Type");
fprintf(o_lst,
"\n-----------------------------------------------------------------------\n");
for (i = 0; i < HASHLEN; i++)
{
for (sy = labtab[i]; sy != NULL; sy = sy->next)
{
t = sy->type;
sy1 = sy;
while (sy1)
{
if ((sy1->type == 'P') || (sy1->type == 'S'))
{
fprintf(o_lst, "%32.32s %32.32s %c\n",
(sy1->type == 'P') ? sy1->name : "",
(sy1->type == 'S') ? sy1->name :
(sy1->parent ? sy1->parent->name : ""),
sy1->type);
}
sy1 = sy1->clone;
}
}
}
fprintf(o_lst, "\n\nTinyCOBOL compile audit summary:\n");
fprintf(o_lst, "Total lines compiled : %4d\n", source_lineno);
fprintf(o_lst, "Total number of warnings : %4d\n", wrncnt);
fprintf(o_lst, "Total number of errors found : %4d\n", errcnt);
}
/* ok
search for "-" caracter in *s and replace it with _
enter: char *
return: void */
void
chg_underline(char *s)
{
char *s1;
s1 = s; /* walter */
while (*s1)
{
if (*s1 == '-') *s1 = '_';
s1++;
}
/* while ((s1=strchr(s,'-'))!=NULL) *s1='_'; */
}
void
gen_enter_runelement(int type)
{
/* this should be cleaned if we are going to load it */
fprintf(o_src, "\tmovl\t$s_base%d+0, %%eax\n", pgm_segment);
push_eax();
push_immed(type);
push_immed(program_name_literal->len);
loadloc_to_eax((struct sym *) program_name_literal);
push_eax();
asm_call("tcob_enter_runelement");
}
/* end of HTCOBGEN.C */
Reference in New Issue View Git Blame Copy Permalink