1776 lines
42 KiB
C
1776 lines
42 KiB
C
/*
|
|
|
|
YABASIC --- a simple Basic Interpreter
|
|
written by Marc-Oliver Ihm 1995-2004
|
|
homepage: www.yabasic.de
|
|
|
|
symbol.c --- code for control structures, symbol and stack management
|
|
|
|
This file is part of yabasic and may be copied only
|
|
under the terms of either the Artistic License or
|
|
the GNU General Public License (GPL), both of which
|
|
can be found at www.yabasic.de
|
|
|
|
*/
|
|
|
|
/* ------------- includes ---------------- */
|
|
|
|
#ifndef YABASIC_INCLUDED
|
|
#include "yabasic.h" /* all prototypes and structures */
|
|
#endif
|
|
|
|
|
|
/* ------------- external references ---------------- */
|
|
|
|
extern int mylineno; /* current line number */
|
|
extern int yyparse(); /* call bison parser */
|
|
|
|
|
|
/* ------------- local defines ---------------- */
|
|
struct switch_id {
|
|
int id;
|
|
int depth;
|
|
struct switch_id *next;
|
|
struct switch_id *prev;
|
|
};
|
|
|
|
|
|
/* ------------- local functions ---------------- */
|
|
|
|
static struct symbol *create_symbol(int,char *); /* create a new symbol */
|
|
static void link_label(struct command *); /* link label into list of labels */
|
|
static int count_args(int); /* count number of arguments on stack */
|
|
static void stackdesc(int,char *); /* give back string describing stackentry */
|
|
static void freesym(struct symbol *); /* free contents of symbol */
|
|
static int ind_to_off(int *,int *); /* convert array of indices to single offset */
|
|
static void off_to_ind(int,int *,int *); /* convert a single offset to an array of indices */
|
|
|
|
|
|
/* ------------- global variables ---------------- */
|
|
|
|
static struct symstack *symroot=NULL; /* first element in symbol list */
|
|
static struct symstack *symhead=NULL; /* last element ind symbol list */
|
|
struct stackentry *stackroot; /* lowest element in stack */
|
|
struct stackentry *stackhead; /* topmost element in stack */
|
|
static struct command *labelroot=NULL; /* first label among commands */
|
|
static struct command *labelhead=NULL; /* last label seen so far */
|
|
extern char *current_function; /* name of currently defined function */
|
|
struct command *lastref; /* last command in UDS referencing a symbol */
|
|
struct command *firstref; /* first command in UDS referencing a symbol */
|
|
int labelcount=0; /* count self-generated labels */
|
|
int in_switch=0; /* true, if in switch (at compile-time) */
|
|
struct switch_id *switch_id_stackhead=NULL; /* topmost (and valid) element of switch_id stack */
|
|
struct switch_id *switch_id_stackroot=NULL; /* bottommost element of switch_id stack */
|
|
|
|
|
|
/* ------------- subroutines ---------------- */
|
|
|
|
|
|
void pushsymlist(void) /* push a new list of symbols on symbol stack */
|
|
{
|
|
struct symstack *new;
|
|
|
|
new=my_malloc(sizeof(struct symstack));
|
|
if (symhead)
|
|
symhead->next_in_stack=new;
|
|
else
|
|
symroot=new; /* first time called */
|
|
new->prev_in_stack=symhead;
|
|
new->next_in_stack=NULL;
|
|
new->next_in_list=NULL;
|
|
symhead=new;
|
|
}
|
|
|
|
|
|
void popsymlist(void) /* pop list of symbols and free symbol contents */
|
|
{
|
|
struct symstack *prevstack;
|
|
struct symbol *currsym,*nextsym;
|
|
int count=0;
|
|
|
|
currsym=symhead->next_in_list;
|
|
while(currsym) { /* loop through symbol list */
|
|
freesym(currsym);
|
|
count++;
|
|
nextsym=currsym->next_in_list;
|
|
my_free(currsym);
|
|
currsym=nextsym;
|
|
}
|
|
if (infolevel>=DEBUG) {
|
|
sprintf(string,"removed symbol list with %d symbols",count);
|
|
error(DEBUG,string);
|
|
}
|
|
prevstack=symhead->prev_in_stack;
|
|
my_free(symhead);
|
|
prevstack->next_in_stack=NULL;
|
|
symhead=prevstack;
|
|
}
|
|
|
|
|
|
static void freesym(struct symbol *s) /* free contents of symbol */
|
|
{
|
|
int i;
|
|
int total;
|
|
|
|
struct array *ar;
|
|
if (s->link) { /* it's a link, don't remove memory */
|
|
sprintf(string,"removing linked symbol '%s'",s->name);
|
|
error(DEBUG,string);
|
|
my_free(s->name);
|
|
return;
|
|
}
|
|
if (s->type==sySTRING) {
|
|
if (infolevel>=DEBUG) {
|
|
sprintf(string,"removing string symbol '%s'",s->name);
|
|
error(DEBUG,string);
|
|
}
|
|
my_free(s->pointer);
|
|
} else if (s->type==syARRAY) {
|
|
if (infolevel>=DEBUG) {
|
|
sprintf(string,"removing array symbol '%s()'",s->name);
|
|
error(DEBUG,string);
|
|
}
|
|
ar=s->pointer;
|
|
if (ar->dimension>0) {
|
|
/* count total amount of memory */
|
|
total=1;
|
|
for(i=0;i<ar->dimension;i++) total*=(ar->bounds)[i];
|
|
if (ar->type=='s') { /* string array */
|
|
for(i=0;i<total;i++) my_free(*((char **)ar->pointer+i));
|
|
}
|
|
my_free(ar->pointer);
|
|
}
|
|
my_free(ar);
|
|
} else if (s->type==syNUMBER) {
|
|
if (infolevel>=DEBUG) {
|
|
sprintf(string,"removing numeric symbol '%s'",s->name);
|
|
error(DEBUG,string);
|
|
}
|
|
}
|
|
my_free(s->name);
|
|
return;
|
|
}
|
|
|
|
|
|
void clearrefs(struct command *cmd) /* clear references for commands within function */
|
|
{
|
|
struct command *curr;
|
|
int n=0;
|
|
|
|
curr=cmd->nextref;
|
|
while(curr) {
|
|
n++;
|
|
curr->symbol=NULL;
|
|
curr=curr->nextref;
|
|
}
|
|
sprintf(string,"removed references from %d symbols",n);
|
|
error(DEBUG,string);
|
|
}
|
|
|
|
|
|
struct symbol *get_sym(char *name,int type,int add)
|
|
/* get the value of a symbol, or create it with given type */
|
|
{
|
|
struct symstack *currstack;
|
|
struct symbol **currsym;
|
|
struct symbol *prelink;
|
|
struct symbol *new;
|
|
int stackcount=0;
|
|
int symbolcount=0;
|
|
int linked=FALSE;
|
|
|
|
if (!name) return NULL;
|
|
/* go through all lists */
|
|
currstack=symhead; /* start with symhead */
|
|
if (add==amSEARCH_PRE && symhead->prev_in_stack) currstack=symhead->prev_in_stack;
|
|
while(TRUE) {
|
|
stackcount++;
|
|
currsym=&(currstack->next_in_list);
|
|
while(*currsym) {
|
|
prelink=*currsym;
|
|
symbolcount++;
|
|
if ((*currsym)->type==type && !strcmp(name,(*currsym)->name)) { /* do the types and names match ? */
|
|
if ((*currsym)->link) {
|
|
currsym=&((*currsym)->link);
|
|
linked=TRUE;
|
|
}
|
|
if (infolevel>=DEBUG) {
|
|
if (linked)
|
|
sprintf(string,"found symbol '%s%s', linked to %s after searching %d symbol(s) in %d stack(s)",
|
|
name,(type==syARRAY)?"()":"",(*currsym)->name,symbolcount,stackcount);
|
|
else
|
|
sprintf(string,"found symbol '%s%s' after searching %d symbol(s) in %d stack(s)",
|
|
name,(type==syARRAY)?"()":"",symbolcount,stackcount);
|
|
error(DEBUG,string);
|
|
}
|
|
return *currsym; /* give back address */
|
|
}
|
|
currsym=&((*currsym)->next_in_list); /* try next entry */
|
|
}
|
|
/* not found in first list */
|
|
if (add==amSEARCH_VERY_LOCAL) return NULL;
|
|
if (add==amADD_LOCAL) {
|
|
new=create_symbol(type,name);
|
|
(*currsym)=new;
|
|
if (infolevel>=DEBUG) {
|
|
sprintf(string,"created local symbol %s%s",name,(type==syARRAY)?"()":"");
|
|
error(DEBUG,string);
|
|
}
|
|
return new;
|
|
}
|
|
if (currstack!=symroot)
|
|
currstack=symroot;
|
|
else
|
|
break;
|
|
}
|
|
if (add==amADD_GLOBAL) {
|
|
new=create_symbol(type,name);
|
|
(*currsym)=new;
|
|
if (infolevel>=DEBUG) {
|
|
sprintf(string,"created global symbol %s%s",name,(type==syARRAY)?"()":"");
|
|
error(DEBUG,string);
|
|
}
|
|
return new;
|
|
}
|
|
return NULL;
|
|
}
|
|
|
|
|
|
void link_symbols(struct symbol *from,struct symbol *to) { /* link one symbol to the other */
|
|
from->link=to;
|
|
if (infolevel>=DEBUG) {
|
|
sprintf(string,"linking symbol '%s' to '%s'",from->name,to->name);
|
|
error(DEBUG,string);
|
|
}
|
|
}
|
|
|
|
|
|
void create_retval(int is,int should) /* create command 'cRETVAL' */
|
|
{
|
|
struct command *cmd;
|
|
|
|
cmd=add_command(cRETVAL,NULL);
|
|
cmd->args=is;
|
|
cmd->tag=should;
|
|
}
|
|
|
|
|
|
void retval(struct command *cmd) /* check return value of function */
|
|
{
|
|
int is,should;
|
|
struct stackentry *s;
|
|
|
|
is=cmd->args;
|
|
should=cmd->tag;
|
|
if (is==should) {
|
|
/* okay, function returns expected type */
|
|
} else if (is==ftNONE) { /* no element on stack, create one */
|
|
s=push();
|
|
if (should==ftNUMBER) {
|
|
s->type=stNUMBER;
|
|
s->value=0.0;
|
|
} else {
|
|
s->type=stSTRING;
|
|
s->pointer=my_strdup("");
|
|
}
|
|
} else {
|
|
sprintf(string,"subroutine returns %s but should return %s",
|
|
(is==ftSTRING)?"a string":"a number",(should==ftSTRING)?"a string":"a number");
|
|
error(ERROR,string);
|
|
}
|
|
if (infolevel>=DEBUG) {
|
|
s=stackhead->prev;
|
|
if (s->type==stNUMBER)
|
|
sprintf(string,"subroutine returns number %g",s->value);
|
|
else if (s->type==stSTRING)
|
|
sprintf(string,"subroutine returns string '%s'",(char *)s->pointer);
|
|
else
|
|
sprintf(string,"subroutine returns something strange (%d)",s->type);
|
|
error(DEBUG,string);
|
|
}
|
|
swap();
|
|
}
|
|
|
|
|
|
void create_endfunction(void) /* create command cEND_FUNCTION */
|
|
{
|
|
struct command *cmd;
|
|
|
|
cmd=add_command(cEND_FUNCTION,NULL);
|
|
link_label(cmd);
|
|
}
|
|
|
|
|
|
void dump_sym(void) /* dump the stack of lists of symbols */
|
|
{
|
|
struct symstack *currstack;
|
|
struct symbol **currsym;
|
|
|
|
/* go through all lists */
|
|
error(DUMP,"head of symbol stack");
|
|
currstack=symhead;
|
|
while(currstack) { /* search 'til last element of stack */
|
|
currsym=&(currstack->next_in_list);
|
|
string[0]='\0';
|
|
while(*currsym) {
|
|
switch((*currsym)->type) {
|
|
case sySTRING: strcat(string," STRING:"); break;
|
|
case syNUMBER: strcat(string," NUMBER:"); break;
|
|
case syFREE: strcat(string," FREE:"); break;
|
|
case syARRAY: strcat(string," ARRAY:"); break;
|
|
default:sprintf(string," UNKNOWN:"); break;
|
|
}
|
|
strcat(string,(*currsym)->name);
|
|
|
|
currsym=&((*currsym)->next_in_list); /* try next entry */
|
|
}
|
|
error(DUMP,string);
|
|
currstack=currstack->prev_in_stack;
|
|
}
|
|
error(DUMP,"root of symbol stack");
|
|
return;
|
|
}
|
|
|
|
|
|
void dump_sub(int short_dump) /* dump the stack of subroutine calls */
|
|
{
|
|
struct stackentry *st=stackhead;
|
|
struct command *cmd;
|
|
int first=TRUE;
|
|
do {
|
|
if (st->type==stRETADDCALL) {
|
|
cmd=st->pointer;
|
|
if (cmd->type==cCALL || cmd->type==cQCALL) {
|
|
char *dot;
|
|
dot=strchr(cmd->pointer,'.');
|
|
if (first && !short_dump) error(DUMP,"Executing in:");
|
|
sprintf(string,"sub %s() called in %s,%d",dot ? (dot+1):cmd->pointer,cmd->lib->l,cmd->line);
|
|
error(DUMP,string);
|
|
first=FALSE;
|
|
}
|
|
}
|
|
st=st->prev;
|
|
} while(st && st!=stackroot);
|
|
if (first && !short_dump) {
|
|
if (!short_dump) error(DUMP,"Executing in:");
|
|
}
|
|
if (!short_dump) error(DUMP,"main program");
|
|
|
|
return;
|
|
}
|
|
|
|
|
|
static struct symbol *create_symbol(int type,char *name) /* create a new symbol */
|
|
{
|
|
struct symbol *new;
|
|
|
|
new=my_malloc(sizeof(struct symbol));
|
|
new->type=type;
|
|
new->next_in_list=NULL;
|
|
new->name=my_strdup(name);
|
|
new->pointer=NULL;
|
|
new->args=NULL;
|
|
new->value=0.0;
|
|
new->link=NULL;
|
|
|
|
return new;
|
|
}
|
|
|
|
|
|
void function_or_array(struct command *cmd) /* decide whether to perform function or array */
|
|
{
|
|
struct command *fu;
|
|
|
|
fu=search_label(cmd->name,smSUB|smLINK);
|
|
if (fu) {
|
|
cmd->type=cCALL;
|
|
cmd->pointer=cmd->name;
|
|
cmd->name=NULL;
|
|
error(DEBUG,"converting FUNCTION_OR_ARRAY to FUNCTION");
|
|
} else {
|
|
if (cmd->type==cFUNCTION_OR_ARRAY)
|
|
cmd->tag=CALLARRAY;
|
|
else
|
|
cmd->tag=CALLSTRINGARRAY;
|
|
cmd->type=cDOARRAY;
|
|
cmd->args=-1;
|
|
error(DEBUG,"converting FUNCTION_OR_ARRAY to ARRAY");
|
|
}
|
|
}
|
|
|
|
|
|
void swap() /* swap topmost elements on stack */
|
|
{
|
|
struct stackentry *a,*b;
|
|
|
|
if ((a=stackhead->prev)==NULL || (b=a->prev)==NULL) {
|
|
error(ERROR,"Nothing to swap on stack !");
|
|
return;
|
|
}
|
|
a->prev=b->prev;b->next=a->next; /* just swap the pointers */
|
|
a->next=b;b->prev=a;
|
|
stackhead->prev=b;
|
|
(a->prev)->next=a;
|
|
}
|
|
|
|
|
|
struct stackentry *push()
|
|
/* push element on stack and enlarge stack it */
|
|
{
|
|
struct stackentry *new;
|
|
|
|
if (!stackhead->next) { /* no next element */
|
|
/* create new element */
|
|
new=(struct stackentry *)my_malloc(sizeof(struct stackentry));
|
|
/* and initialize it */
|
|
new->next=NULL;
|
|
new->value=0.0;
|
|
new->type=stFREE;
|
|
new->prev=stackhead;
|
|
new->pointer=NULL;
|
|
stackhead->next=new;
|
|
} else if (stackhead->pointer!=NULL && (stackhead->type==stSTRING || stackhead->type==stSTRINGARRAYREF || stackhead->type==stNUMBERARRAYREF || stackhead->type==stLABEL)) {
|
|
/* any content is set free */
|
|
my_free(stackhead->pointer);
|
|
stackhead->pointer=NULL;
|
|
}
|
|
stackhead=stackhead->next; /* advance head */
|
|
return stackhead->prev;
|
|
}
|
|
|
|
|
|
struct stackentry *pop(int etype)
|
|
/* pops element to memory and looks for pop-error */
|
|
{
|
|
static char expected[50];
|
|
static char found[50];
|
|
int ftype;
|
|
struct stackentry *s;
|
|
|
|
/* test if there is something on the stack */
|
|
if (stackhead==stackroot) {
|
|
error(FATAL,"Popped too much.");
|
|
return stackhead;
|
|
}
|
|
stackhead=stackhead->prev; /* move down in stack */
|
|
ftype=stackhead->type;
|
|
if (etype==ftype || etype==stANY ||
|
|
(etype==stSTRING_OR_NUMBER && (ftype==stNUMBER || ftype==stSTRING)) ||
|
|
(etype==stSTRING_OR_NUMBER_ARRAYREF && (ftype==stSTRINGARRAYREF || ftype==stNUMBERARRAYREF)))
|
|
return stackhead; /* this is your value; use it quickly ! */
|
|
|
|
/* expected and found don't match */
|
|
stackdesc(etype,expected);
|
|
stackdesc(ftype,found);
|
|
sprintf(string,"expected %s but found %s",expected,found);
|
|
if (etype==stNUMBER || etype==stSTRING || etype==stSTRING_OR_NUMBER) {
|
|
s=push();
|
|
if (etype==stNUMBER) {
|
|
s->type=stNUMBER;
|
|
s->value=0.0;
|
|
} else {
|
|
s->type=stSTRING;
|
|
s->pointer=my_strdup("");
|
|
}
|
|
error(ERROR,string);
|
|
return s;
|
|
} else {
|
|
error(FATAL,string);
|
|
}
|
|
return stackhead;
|
|
}
|
|
|
|
|
|
static void stackdesc(int type,char *desc) /* give back string describing stackentry */
|
|
{
|
|
switch(type) {
|
|
case stGOTO: strcpy(desc,"a goto");break;
|
|
case stSTRING: strcpy(desc,"a string");break;
|
|
case stSTRINGARRAYREF: strcpy(desc,"a reference to a string array");break;
|
|
case stNUMBER: strcpy(desc,"a number");break;
|
|
case stNUMBERARRAYREF: strcpy(desc,"a reference to a numeric array");break;
|
|
case stLABEL: strcpy(desc,"a label");break;
|
|
case stRETADD: strcpy(desc,"a return address for gosub");break;
|
|
case stRETADDCALL: strcpy(desc,"a return address for a subroutine");break;
|
|
case stFREE: strcpy(desc,"nothing");break;
|
|
case stROOT: strcpy(desc,"the root of the stack");break;
|
|
case stANY: strcpy(desc,"anything");break;
|
|
case stSTRING_OR_NUMBER: strcpy(desc,"a string or a number");break;
|
|
case stSTRING_OR_NUMBER_ARRAYREF: strcpy(desc,"reference to a string or an array");break;
|
|
case stSWITCH_STRING: strcpy(desc,"number for switch");break;
|
|
case stSWITCH_NUMBER: strcpy(desc,"string for switch");break;
|
|
default: sprintf(desc,"type %d",type);break;
|
|
}
|
|
}
|
|
|
|
|
|
void pushname(char *name) /* bison: push a name on stack */
|
|
{
|
|
struct stackentry *s;
|
|
|
|
s=push();
|
|
s->pointer=my_strdup(name);
|
|
s->type=stSTRING;
|
|
}
|
|
|
|
|
|
void pushlabel() /* bison: generate goto and push label on stack */
|
|
{
|
|
char *st;
|
|
struct stackentry *en;
|
|
|
|
st=(char *) my_malloc(sizeof(char)*20);
|
|
sprintf(st,"***%d",labelcount);
|
|
labelcount++;
|
|
create_goto(st);
|
|
en=push();
|
|
en->type=stLABEL;
|
|
en->pointer=st;
|
|
}
|
|
|
|
|
|
void poplabel() /* bison: pops a label and generates the matching command */
|
|
{
|
|
create_label(pop(stLABEL)->pointer,cLABEL); /* and create it */
|
|
}
|
|
|
|
|
|
void pushgoto() /* bison: generate label and push goto on stack */
|
|
{
|
|
char *st;
|
|
struct stackentry *en;
|
|
|
|
st=(char *) my_malloc(sizeof(char)*20);
|
|
sprintf(st,"***%d",labelcount);
|
|
labelcount++;
|
|
create_label(st,cLABEL);
|
|
en=push();
|
|
en->type=stGOTO;
|
|
en->pointer=st;
|
|
}
|
|
|
|
|
|
void popgoto() /* bison: pops a goto and generates the matching command */
|
|
{
|
|
create_goto(pop(stGOTO)->pointer); /* and create it */
|
|
}
|
|
|
|
|
|
void storelabel() /* bison: push label on stack */
|
|
{
|
|
char *st;
|
|
struct stackentry *en;
|
|
|
|
st=(char *)my_malloc(sizeof(char)*20);
|
|
sprintf(st,"***%d",labelcount);
|
|
labelcount++;
|
|
en=push();
|
|
en->type=stLABEL;
|
|
en->pointer=st;
|
|
}
|
|
|
|
|
|
void matchgoto() /* bison: generate goto matching label on stack */
|
|
{
|
|
create_goto(stackhead->prev->pointer);
|
|
}
|
|
|
|
|
|
void create_pushdbl(double value) /* create command 'cPUSHDBL' */
|
|
{
|
|
struct command *cmd;
|
|
|
|
cmd=add_command(cPUSHDBL,NULL);
|
|
cmd->pointer=my_malloc(sizeof(double));
|
|
*(double *)(cmd->pointer)=value;
|
|
}
|
|
|
|
|
|
void pushdbl(struct command *cmd)
|
|
{
|
|
/* push double onto stack */
|
|
struct stackentry *p;
|
|
|
|
p=push();
|
|
p->value= *(double *)cmd->pointer;
|
|
p->type=stNUMBER;
|
|
}
|
|
|
|
|
|
void pushdblsym(struct command *cmd)
|
|
{
|
|
/* push double symbol onto stack */
|
|
struct stackentry *p;
|
|
|
|
p=push();
|
|
if (!cmd->name) error(WARNING,"invalid pushdblsym");
|
|
|
|
if (!cmd->symbol) cmd->symbol=&(get_sym(cmd->name,syNUMBER,amADD_GLOBAL)->value);
|
|
p->value=*(double *)cmd->symbol;
|
|
p->type=stNUMBER;
|
|
}
|
|
|
|
|
|
void popdblsym(struct command *cmd) /* pop double from stack */
|
|
{
|
|
double d;
|
|
|
|
d=pop(stNUMBER)->value;
|
|
if (!cmd->symbol) cmd->symbol=&(get_sym(cmd->name,syNUMBER,amADD_GLOBAL)->value);
|
|
*(double *)(cmd->symbol)=d;
|
|
}
|
|
|
|
|
|
void create_makelocal(char *name,int type) /* create command 'cMAKELOCAL' */
|
|
{
|
|
struct command *cmd;
|
|
|
|
cmd=add_command(cMAKELOCAL,name);
|
|
cmd->args=type;
|
|
}
|
|
|
|
|
|
void makelocal(struct command *cmd) /* makes symbol local */
|
|
{
|
|
if (get_sym(cmd->name,cmd->args,amSEARCH_VERY_LOCAL)) {
|
|
sprintf(string,"local variable '%s' already defined within this subroutine",strip(cmd->name));
|
|
error(ERROR,string);
|
|
return;
|
|
}
|
|
get_sym(cmd->name,cmd->args,amADD_LOCAL);
|
|
}
|
|
|
|
|
|
void create_numparam(void) /* create command 'cNUMPARAM' */
|
|
{
|
|
struct command *cmd;
|
|
|
|
/* dotifying numparams at compiletime (as opposed to runtime) is essential,
|
|
because the function name is not known at runtime */
|
|
cmd=add_command(cNUMPARAM,dotify("numparams",FALSE));
|
|
}
|
|
|
|
|
|
void numparam(struct command *cmd) /* count number of function parameters */
|
|
{
|
|
struct symbol *sym;
|
|
|
|
sym=get_sym(cmd->name,syNUMBER,amADD_LOCAL);
|
|
sym->value=abs(count_args(FALSE));
|
|
}
|
|
|
|
|
|
void create_makestatic(char *name,int type) /* create command 'cMAKESTATIC' */
|
|
{
|
|
struct command *cmd;
|
|
|
|
cmd=add_command(cMAKESTATIC,name);
|
|
cmd->args=type;
|
|
}
|
|
|
|
|
|
void makestatic(struct command *cmd) /* makes symbol static */
|
|
{
|
|
struct symbol *l,*g;
|
|
char *at=NULL;
|
|
|
|
|
|
/* mask function name */
|
|
if ((at=strchr(cmd->name,'@'))!=NULL) *at='\0';
|
|
|
|
if (get_sym(cmd->name,cmd->args,amSEARCH_VERY_LOCAL)) {
|
|
sprintf(string,"static variable '%s' already defined within this subroutine",strip(cmd->name));
|
|
error(ERROR,string);
|
|
return;
|
|
}
|
|
|
|
/* create global variable with unique name */
|
|
if (at) *at='@';
|
|
g=get_sym(cmd->name,cmd->args,amADD_GLOBAL);
|
|
if (at) *at='\0';
|
|
|
|
/* create local variable */
|
|
l=get_sym(cmd->name,cmd->args,amADD_LOCAL);
|
|
if (at) *at='@';
|
|
/* link those two together */
|
|
link_symbols(l,g);
|
|
}
|
|
|
|
|
|
void create_arraylink(char *name,int type) /* create command 'cARRAYLINK' */
|
|
{
|
|
struct command *cmd;
|
|
|
|
cmd=add_command(cARRAYLINK,name);
|
|
cmd->pointer=current_function;
|
|
cmd->args=type;
|
|
}
|
|
|
|
|
|
void arraylink(struct command *cmd) /* link a local symbol to a global array */
|
|
{
|
|
struct symbol *l,*g;
|
|
struct array *ar;
|
|
|
|
if (get_sym(cmd->name,cmd->args,amSEARCH_VERY_LOCAL)) {
|
|
sprintf(string,"'%s()' already defined within this subroutine",strip(cmd->name));
|
|
error(ERROR,string);
|
|
return;
|
|
}
|
|
/* get globally defined array */
|
|
g=get_sym(pop(cmd->args)->pointer,syARRAY,amSEARCH_PRE);
|
|
/* create local array */
|
|
l=get_sym(cmd->name,syARRAY,amADD_LOCAL);
|
|
if (!l) return;
|
|
if (!g || !g->pointer) { /* no global array supplied, create one */
|
|
error(DEBUG,"creating dummy array");
|
|
ar=create_array((cmd->args==stNUMBERARRAYREF)?'d':'s',0);
|
|
l->pointer=ar;
|
|
if (infolevel>=DEBUG) {
|
|
sprintf(string,"creating 0-dimensional dummy array '%s()'",cmd->name);
|
|
error(DEBUG,string);
|
|
}
|
|
} else {
|
|
/* link those two together */
|
|
link_symbols(l,g);
|
|
}
|
|
}
|
|
|
|
|
|
void create_pusharrayref(char *name,int type) /* create command 'cPUSHARRAYREF' */
|
|
{
|
|
struct command *cmd;
|
|
|
|
cmd=add_command(cPUSHARRAYREF,name);
|
|
cmd->args=type;
|
|
}
|
|
|
|
|
|
void pusharrayref(struct command *cmd) /* push an array reference onto stack */
|
|
{
|
|
struct stackentry *s;
|
|
s=push();
|
|
s->type=cmd->args;
|
|
s->pointer=my_strdup(cmd->name);
|
|
}
|
|
|
|
|
|
void create_require(int type) /* create command 'cREQUIRE' */
|
|
{
|
|
struct command *cmd;
|
|
|
|
cmd=add_command(cREQUIRE,NULL);
|
|
cmd->args=type;
|
|
}
|
|
|
|
|
|
void require(struct command *cmd) /* check, that item on stack has right type */
|
|
{
|
|
char *expected,*supplied;
|
|
struct stackentry *s;
|
|
|
|
if (stackhead->prev->type==cmd->args) return; /* okay, they match */
|
|
|
|
if (stackhead->prev->type==stFREE) { /* no argument supplied, create it */
|
|
s=push();
|
|
if (cmd->args==stSTRING) {
|
|
s->type=stSTRING;
|
|
s->pointer=my_strdup("");
|
|
return;
|
|
} else if (cmd->args==stNUMBER) {
|
|
s->type=stNUMBER;
|
|
s->value=0.0;
|
|
return;
|
|
} else {
|
|
/* create array */
|
|
s->type=cmd->args;
|
|
s->pointer=NULL;
|
|
return;
|
|
}
|
|
}
|
|
|
|
s=stackhead->prev;
|
|
if (s->type==stSTRING)
|
|
supplied="string";
|
|
else if (s->type==stNUMBER)
|
|
supplied="number";
|
|
else if (s->type==stSTRINGARRAYREF)
|
|
supplied="string array";
|
|
else if (s->type==stNUMBERARRAYREF)
|
|
supplied="numeric array";
|
|
else if (s->type==stFREE)
|
|
supplied="nothing";
|
|
else
|
|
supplied="something strange";
|
|
|
|
if (cmd->args==stSTRING)
|
|
expected="string";
|
|
else if (cmd->args==stNUMBER)
|
|
expected="number";
|
|
else if (cmd->args==stSTRINGARRAYREF)
|
|
expected="string array";
|
|
else if (cmd->args==stNUMBERARRAYREF)
|
|
expected="numeric array";
|
|
else if (cmd->args==stFREE)
|
|
expected="nothing";
|
|
else
|
|
expected="something strange";
|
|
|
|
sprintf(string,"invalid subroutine call: %s expected, %s supplied",expected,supplied);
|
|
error(ERROR,string);
|
|
}
|
|
|
|
|
|
void create_dblbin(char c) /* create command for binary double operation */
|
|
{
|
|
switch(c) {
|
|
case '+':add_command(cDBLADD,NULL);break;
|
|
case '-':add_command(cDBLMIN,NULL);break;
|
|
case '*':add_command(cDBLMUL,NULL);break;
|
|
case '/':add_command(cDBLDIV,NULL);break;
|
|
case '^':add_command(cDBLPOW,NULL);break;
|
|
}
|
|
/* no specific information needed */
|
|
}
|
|
|
|
|
|
void dblbin(struct command *cmd) /* compute with two numbers from stack */
|
|
{
|
|
struct stackentry *d;
|
|
double a,b,c;
|
|
|
|
b=pop(stNUMBER)->value;
|
|
a=pop(stNUMBER)->value;
|
|
d=push();
|
|
switch(cmd->type) {
|
|
case(cDBLADD):c=a+b; break;
|
|
case(cDBLMIN):c=a-b; break;
|
|
case(cDBLMUL):c=a*b; break;
|
|
case(cDBLDIV):
|
|
if (fabs(b)<DBL_MIN) {
|
|
sprintf(string,"Division by zero, set to %g",DBL_MAX);
|
|
error(NOTE,string);
|
|
c=DBL_MAX;}
|
|
else
|
|
c=a/b;
|
|
break;
|
|
case(cDBLPOW):
|
|
if ((a==0 && b<=0) || (a<0 && b!=(int)b)) {
|
|
error(ERROR,"result is not a real number");
|
|
return;
|
|
} else {
|
|
c=pow(a,b);
|
|
}
|
|
break;
|
|
}
|
|
d->value=c;
|
|
d->type=stNUMBER;
|
|
}
|
|
|
|
|
|
void negate() /* negates top of stack */
|
|
{
|
|
stackhead->prev->value=-stackhead->prev->value;
|
|
}
|
|
|
|
|
|
void pushstrptr(struct command *cmd) /* push string-pointer onto stack */
|
|
{
|
|
struct stackentry *p;
|
|
|
|
p=push();
|
|
if (!cmd->symbol) cmd->symbol=&(get_sym(cmd->name,sySTRING,amADD_GLOBAL)->pointer);
|
|
p->pointer=*(char **)cmd->symbol;
|
|
if (!p->pointer) p->pointer=my_strdup("");
|
|
p->type=stSTRING;
|
|
}
|
|
|
|
|
|
void pushstrsym(struct command *cmd) /* push string-symbol onto stack */
|
|
{
|
|
struct stackentry *p;
|
|
|
|
p=push();
|
|
if (!cmd->symbol) cmd->symbol=&(get_sym(cmd->name,sySTRING,amADD_GLOBAL)->pointer);
|
|
p->pointer=my_strdup(*(char **)cmd->symbol);
|
|
p->type=stSTRING;
|
|
}
|
|
|
|
|
|
void popstrsym(struct command *cmd) /* pop string from stack */
|
|
{
|
|
if (!cmd->name) return;
|
|
if (!cmd->symbol) cmd->symbol= &(get_sym(cmd->name,sySTRING,amADD_GLOBAL)->pointer);
|
|
if (*(char **)cmd->symbol!=NULL) my_free(*(char **)cmd->symbol);
|
|
*(char **)cmd->symbol=my_strdup(pop(stSTRING)->pointer);
|
|
}
|
|
|
|
|
|
void create_pushstr(char *s) /* creates command pushstr */
|
|
{
|
|
struct command *cmd;
|
|
|
|
cmd=add_command(cPUSHSTR,NULL);
|
|
cmd->pointer=my_strdup(s); /* store string */
|
|
}
|
|
|
|
|
|
void pushstr(struct command *cmd)
|
|
{
|
|
/* push string onto stack */
|
|
struct stackentry *p;
|
|
|
|
p=push();
|
|
p->pointer=my_strdup((char *)cmd->pointer);
|
|
p->type=stSTRING;
|
|
}
|
|
|
|
|
|
void duplicate(void) /* duplicate topmost element of stack */
|
|
{
|
|
struct stackentry *s;
|
|
double actual;
|
|
|
|
actual=stackhead->prev->value;
|
|
s=push();
|
|
s->type=stNUMBER;
|
|
s->value=actual;
|
|
}
|
|
|
|
|
|
void create_goto(char *label) /* creates command goto */
|
|
{
|
|
struct command *cmd;
|
|
|
|
cmd=add_command(cGOTO,NULL);
|
|
/* specific info */
|
|
cmd->pointer=my_strdup(label);
|
|
}
|
|
|
|
|
|
void create_gosub(char *label) /* creates command gosub */
|
|
{
|
|
struct command *cmd;
|
|
|
|
cmd=add_command(cGOSUB,NULL);
|
|
/* specific info */
|
|
cmd->pointer=my_strdup(label);
|
|
}
|
|
|
|
|
|
void create_call(char *label) /* creates command function call */
|
|
{
|
|
struct command *cmd;
|
|
|
|
cmd=add_command(cCALL,NULL);
|
|
/* specific info */
|
|
cmd->pointer=my_strdup(label);
|
|
}
|
|
|
|
|
|
static void link_label(struct command *cmd) /* link label into list of labels */
|
|
{
|
|
if (!labelroot)
|
|
labelroot=cmd;
|
|
else
|
|
labelhead->nextassoc=cmd;
|
|
labelhead=cmd;
|
|
}
|
|
|
|
|
|
struct command *search_label(char *name,int type) /* search label */
|
|
{
|
|
struct command *curr;
|
|
char *at=NULL;
|
|
|
|
curr=labelroot;
|
|
if (type&smGLOBAL) {
|
|
at=strchr(name,'@');
|
|
if (at) *at='\0';
|
|
}
|
|
while(curr) {
|
|
if ((type&smSUB) && curr->type==cUSER_FUNCTION && !strcmp(curr->pointer,name)) {
|
|
if (at) *at='@';
|
|
return curr;
|
|
}
|
|
if ((type&smLINK) && curr->type==cSUBLINK && !strcmp(curr->pointer,name)) {
|
|
if (at) *at='@';
|
|
return curr->next;
|
|
}
|
|
if ((type&smLABEL) && curr->type==cLABEL && !strcmp(curr->pointer,name)) {
|
|
if (at) *at='@';
|
|
return curr;
|
|
}
|
|
curr=curr->nextassoc;
|
|
}
|
|
return NULL;
|
|
}
|
|
|
|
|
|
void jump(struct command *cmd)
|
|
/* jump to specific Label; used as goto, gosub or function call */
|
|
{
|
|
struct command *label;
|
|
struct stackentry *ret;
|
|
int type;
|
|
char *dot;
|
|
|
|
type=cmd->type;
|
|
if (type==cGOSUB || type==cQGOSUB || type==cCALL || type==cQCALL) {
|
|
/* leave return address for return */
|
|
ret=push();
|
|
ret->pointer=current;
|
|
if (type==cGOSUB || type==cQGOSUB) {
|
|
ret->type=stRETADD;
|
|
} else {
|
|
ret->type=stRETADDCALL;
|
|
reshufflestack(ret);
|
|
}
|
|
}
|
|
|
|
if (type==cQGOSUB || type==cQGOTO || type==cQCALL) {
|
|
current=(struct command *)cmd->jump; /* use remembered address */
|
|
return;
|
|
}
|
|
label=search_label(cmd->pointer,smSUB|smLINK|smLABEL);
|
|
if (!label && type==cCALL && (dot=strchr(cmd->pointer,'.'))) {
|
|
strcpy(string,"main");
|
|
strcat(string,dot);
|
|
label=search_label(string,smLINK);
|
|
}
|
|
if (label) {
|
|
/* found right label */
|
|
current=label; /* jump to new location */
|
|
/* use the address instead of the name next time */
|
|
cmd->jump=label;
|
|
switch(cmd->type) {
|
|
case cGOTO: cmd->type=cQGOTO; break;
|
|
case cGOSUB: cmd->type=cQGOSUB; break;
|
|
case cCALL: cmd->type=cQCALL; break;
|
|
}
|
|
} else {
|
|
/* label not found */
|
|
sprintf(string,"can't find %s '%s'",(type==cCALL)?"subroutine":"label",strip((char *)cmd->pointer));
|
|
if (strchr(cmd->pointer,'@')) strcat(string," (not in this sub)");
|
|
error(ERROR,string);
|
|
}
|
|
|
|
/* check, if goto enters or leaves a switch_statement */
|
|
if (cmd->type==cQGOTO) {
|
|
if (label->switch_id && !cmd->switch_id)
|
|
error(ERROR,"cannot jump into switch-statement");
|
|
else if (!label->switch_id && cmd->switch_id)
|
|
error(ERROR,"cannot jump out of switch-statement");
|
|
else if (label->switch_id!=cmd->switch_id)
|
|
error(ERROR,"cannot jump between switch statements");
|
|
}
|
|
}
|
|
|
|
|
|
void reshufflestack(struct stackentry *ret) /* reorganize stack for function call */
|
|
{
|
|
struct stackentry *a,*b,*c;
|
|
struct stackentry *top,*bot;
|
|
struct stackentry *ttop,*bbot;
|
|
int args;
|
|
|
|
|
|
/* this is a function call; revert stack and shuffle return address to bottom */
|
|
/* push address below parameters */
|
|
args=0;
|
|
top=a=ret->prev;
|
|
while(a->type!=stFREE) {
|
|
a=a->prev;
|
|
args++;
|
|
}
|
|
bot=a->next;
|
|
b=a->prev;
|
|
/* remove ret */
|
|
ret->prev->next=ret->next;
|
|
ret->next->prev=ret->prev;
|
|
/* squeeze ret between a and b */
|
|
ret->next=a;
|
|
a->prev=ret;
|
|
b->next=ret;
|
|
ret->prev=b;
|
|
/* revert stack between top and bot */
|
|
if (args>1) {
|
|
a=bot;
|
|
b=a->next;
|
|
bbot=bot->prev;
|
|
ttop=top->next;
|
|
for(;args>1;args--) {
|
|
a->prev=b;
|
|
c=b->next;
|
|
b->next=a;
|
|
a=b;
|
|
b=c;
|
|
}
|
|
bot->next=ttop;
|
|
bot->next->prev=bot;
|
|
top->prev=bbot;
|
|
top->prev->next=top;
|
|
}
|
|
}
|
|
|
|
|
|
void myreturn(struct command *cmd) /* return from gosub of function call */
|
|
{
|
|
struct stackentry *address;
|
|
|
|
address=pop(stANY);
|
|
if (cmd->type==cRET_FROM_FUN) {
|
|
if (address->type!=stRETADDCALL) {
|
|
error(ERROR,"RETURN from a subroutine without CALL");
|
|
return;
|
|
}
|
|
} else {
|
|
if (address->type!=stRETADD) {
|
|
error(ERROR,"RETURN without GOSUB");
|
|
return;
|
|
}
|
|
}
|
|
current=(struct command *)address->pointer;
|
|
return;
|
|
}
|
|
|
|
|
|
void create_label(char *label,int type) /* creates command label */
|
|
{
|
|
struct command *cmd;
|
|
|
|
/* check, if label is duplicate */
|
|
if (search_label(label,smSUB|smLINK|smLABEL)) {
|
|
sprintf(string,"duplicate %s '%s'",(type==cLABEL)?"label":"subroutine",strip(label));
|
|
error(ERROR,string);
|
|
return;
|
|
}
|
|
|
|
cmd=add_command(type,NULL);
|
|
/* store label */
|
|
cmd->pointer=my_strdup(label);
|
|
link_label(cmd);
|
|
}
|
|
|
|
|
|
void create_sublink(char *label) /* create link to subroutine */
|
|
{
|
|
char global[200];
|
|
char *dot;
|
|
struct command *cmd;
|
|
|
|
if (!inlib) return;
|
|
dot=strchr(label,'.');
|
|
strcpy(global,"main");
|
|
strcat(global,dot);
|
|
|
|
/* check, if label is duplicate */
|
|
if (search_label(global,smSUB|smLINK|smLABEL)) {
|
|
sprintf(string,"duplicate subroutine '%s'",strip(global));
|
|
error(ERROR,string);
|
|
return;
|
|
}
|
|
|
|
cmd=add_command(cSUBLINK,NULL);
|
|
/* store label */
|
|
cmd->pointer=my_strdup(global);
|
|
link_label(cmd);
|
|
}
|
|
|
|
|
|
void decide() /* skips next command, if not 0 on stack */
|
|
{
|
|
if (pop(stNUMBER)->value!=0) current=current->next; /* skip one command */
|
|
}
|
|
|
|
|
|
void create_dim(char *name,char type) /* create command 'dim' */
|
|
/* type can be 's'=string or 'd'=double Array */
|
|
{
|
|
struct command *cmd;
|
|
|
|
cmd=add_command(cDIM,name);
|
|
cmd->tag=type; /* type: string or double */
|
|
cmd->args=-1;
|
|
}
|
|
|
|
|
|
void dim(struct command *cmd) /* get room for array */
|
|
{
|
|
struct array *nar,*oar;
|
|
char *nul;
|
|
int ntotal,ototal,esize,i,j;
|
|
int ind[10],nbounds[10],larger;
|
|
struct symbol *s;
|
|
int local;
|
|
|
|
local=((cmd->tag==tolower(cmd->tag))?TRUE:FALSE);
|
|
if (cmd->args<0) cmd->args=count_args(FALSE);
|
|
if (cmd->args<0) {
|
|
error(ERROR,"only numerical indices allowed for arrays");
|
|
return;
|
|
}
|
|
s=get_sym(cmd->name,syARRAY,local?amADD_LOCAL:amADD_GLOBAL);
|
|
if (search_label(cmd->name,smSUB|smLINK)) {
|
|
sprintf(string,"array '%s()' conflicts with user subroutine",strip(cmd->name));
|
|
error(ERROR,string);
|
|
return;
|
|
}
|
|
|
|
/* check for dimensions */
|
|
if (cmd->args>10) {
|
|
error(ERROR,"more than 10 indices");
|
|
return;
|
|
}
|
|
oar=s->pointer;
|
|
if (oar) {
|
|
/* check, if old and new array are compatible */
|
|
if (cmd->args!=oar->dimension) {
|
|
sprintf(string,"cannot change dimension of '%s()' from %d to %d",
|
|
strip(cmd->name),oar->dimension,cmd->args);
|
|
error(ERROR,string);
|
|
}
|
|
}
|
|
/* check, if redim is actually needed */
|
|
for(i=0;i<10;i++) nbounds[i]=0;
|
|
larger=FALSE;
|
|
for(i=0;i<cmd->args;i++) {
|
|
nbounds[i]=1+(int)pop(stNUMBER)->value;
|
|
if (nbounds[i]<=1) {
|
|
sprintf(string,"array index %d is less or equal zero",cmd->args-i);
|
|
error(ERROR,string);
|
|
return;
|
|
}
|
|
if (oar) {
|
|
if (nbounds[i]>oar->bounds[i])
|
|
larger=TRUE;
|
|
else
|
|
nbounds[i]=oar->bounds[i];
|
|
}
|
|
}
|
|
pop(stFREE); /* remove left over stFREE */
|
|
if (oar && !larger) return; /* new array won't be larger than old one */
|
|
|
|
/* create array */
|
|
nar=create_array(tolower(cmd->tag),cmd->args);
|
|
|
|
/* count needed memory */
|
|
ntotal=1;
|
|
for(i=0;i<nar->dimension;i++) {
|
|
(nar->bounds)[i]=nbounds[i];
|
|
ntotal*=nbounds[i];
|
|
}
|
|
esize=(nar->type=='s')?sizeof(char *):sizeof(double); /* size of one array element */
|
|
nar->pointer=my_malloc(ntotal*esize);
|
|
|
|
if (oar) { /* array already exists, get its size */
|
|
ototal=1;
|
|
for(i=0;i<oar->dimension;i++) ototal*=(oar->bounds)[i];
|
|
}
|
|
|
|
/* initialize Array */
|
|
for(i=0;i<ntotal;i++) {
|
|
if (nar->type=='s') {
|
|
nul=my_malloc(sizeof(char));
|
|
*nul='\0';
|
|
((char **)nar->pointer)[i]=nul;
|
|
} else {
|
|
((double *)nar->pointer)[i]=0.0;
|
|
}
|
|
}
|
|
|
|
if (oar) { /* copy contents of old array onto new */
|
|
for(i=0;i<ototal;i++) {
|
|
off_to_ind(i,oar->bounds,ind);
|
|
j=ind_to_off(ind,nar->bounds);
|
|
if (nar->type=='s') {
|
|
my_free(((char **)nar->pointer)[j]);
|
|
((char **)nar->pointer)[j]= ((char **)oar->pointer)[i];
|
|
} else {
|
|
((double *)nar->pointer)[j]= ((double *)oar->pointer)[i];
|
|
}
|
|
}
|
|
my_free(oar->pointer);
|
|
my_free(oar);
|
|
}
|
|
|
|
s->pointer=nar;
|
|
cmd->symbol=nar;
|
|
}
|
|
|
|
|
|
static int ind_to_off(int *ind,int *bound) /* convert array of indices to single offset */
|
|
{
|
|
int i;
|
|
int cur,off;
|
|
|
|
off=0;
|
|
cur=1;
|
|
for(i=0;i<10 && bound[i];i++) {
|
|
off+=ind[i]*cur;
|
|
cur*=bound[i];
|
|
}
|
|
return off;
|
|
}
|
|
|
|
|
|
static void off_to_ind(int off,int *bound,int *ind) /* convert a single offset to an array of indices */
|
|
{
|
|
int i;
|
|
int cur;
|
|
|
|
cur=1;
|
|
for(i=0;i<10;i++) {
|
|
if (bound[i]) cur*=bound[i];
|
|
ind[i]=0;
|
|
}
|
|
for(i=9;i>=0;i--) {
|
|
if (bound[i]) {
|
|
cur/=bound[i];
|
|
ind[i]=off/cur;
|
|
off-=ind[i]*cur;
|
|
} else {
|
|
ind[i]=0;
|
|
}
|
|
}
|
|
}
|
|
|
|
|
|
void query_array(struct command *cmd) /* query array */
|
|
{
|
|
int index;
|
|
struct stackentry *s;
|
|
struct array *ar;
|
|
struct symbol *sym;
|
|
|
|
if (cmd->type==cARSIZE) index=(int)pop(stNUMBER)->value;
|
|
|
|
s=pop(stSTRING_OR_NUMBER_ARRAYREF);
|
|
|
|
if (!cmd->symbol) {
|
|
sym=get_sym(s->pointer,syARRAY,amSEARCH);
|
|
if (!sym || !sym->pointer) {
|
|
sprintf(string,"array '%s()' is not defined",strip(s->pointer));
|
|
error(ERROR,string);
|
|
return;
|
|
}
|
|
cmd->symbol=sym;
|
|
}
|
|
|
|
ar=((struct symbol *)cmd->symbol)->pointer;
|
|
|
|
if (cmd->type==cARSIZE && (index<1 || index>ar->dimension)) {
|
|
sprintf(string,"only indices between 1 and %d allowed",ar->dimension);
|
|
error(ERROR,string);
|
|
return;
|
|
}
|
|
s=push();
|
|
s->type=stNUMBER;
|
|
if (cmd->type==cARSIZE)
|
|
s->value=ar->bounds[ar->dimension-index]-1;
|
|
else
|
|
s->value=ar->dimension;
|
|
|
|
return;
|
|
}
|
|
|
|
|
|
void create_doarray(char *symbol,int command) /* creates array-commands */
|
|
{
|
|
struct command *cmd;
|
|
|
|
cmd=add_command(cDOARRAY,symbol);
|
|
cmd->tag=command; /* operation to perform */
|
|
cmd->args=-1;
|
|
}
|
|
|
|
|
|
void doarray(struct command *cmd) /* call an array */
|
|
{
|
|
struct array *ar;
|
|
struct stackentry *stack;
|
|
struct symbol *sym;
|
|
void *p;
|
|
char **str;
|
|
double *dbl;
|
|
int i,j,bnd,index,cur,rval;
|
|
|
|
|
|
if (!cmd->symbol) {
|
|
sym=get_sym(cmd->name,syARRAY,amSEARCH);
|
|
if (!sym || !sym->pointer) {
|
|
sprintf(string,"'%s()' is neither array nor subroutine",strip(cmd->name));
|
|
error(ERROR,string);
|
|
return;
|
|
}
|
|
cmd->symbol=sym;
|
|
}
|
|
rval=(current->tag==CALLARRAY || current->tag==CALLSTRINGARRAY || current->tag==GETSTRINGPOINTER);
|
|
if (cmd->args<0) cmd->args=count_args(!rval);
|
|
if (cmd->args<0) {
|
|
error(ERROR,"only numerical indices allowed for arrays");
|
|
return;
|
|
}
|
|
cmd->args=abs(cmd->args);
|
|
if (!cmd->args) { /* no indizes supplied, create a reference to an array */
|
|
pop(stFREE); /* remove left over stFREE */
|
|
stack=push();
|
|
if (cmd->tag==CALLARRAY)
|
|
stack->type=stNUMBERARRAYREF;
|
|
else
|
|
stack->type=stSTRINGARRAYREF;
|
|
stack->pointer=my_strdup(cmd->name);
|
|
return;
|
|
}
|
|
|
|
ar=((struct symbol *)cmd->symbol)->pointer;
|
|
|
|
if (!ar->dimension) {
|
|
sprintf(string,"array parameter '%s()' has not been supplied",strip(cmd->name));
|
|
error(ERROR,string);
|
|
return;
|
|
}
|
|
if (cmd->args!=ar->dimension) {
|
|
sprintf(string,"%d indices supplied, %d expected for '%s()'",cmd->args,ar->dimension,strip(cmd->name));
|
|
error(ERROR,string);
|
|
return;
|
|
}
|
|
|
|
if (!rval) stack=pop(stSTRING_OR_NUMBER);
|
|
index=0;
|
|
cur=1;
|
|
for(i=0;i<ar->dimension;i++) {
|
|
bnd=(ar->bounds[i]);
|
|
j=(int)pop(stNUMBER)->value;
|
|
if (j<0 || j>=bnd) {
|
|
sprintf(string,"index %d (=%d) out of range",ar->dimension-i,j);
|
|
error(ERROR,string);
|
|
return;
|
|
}
|
|
index+=j*cur;
|
|
cur*=bnd;
|
|
}
|
|
|
|
pop(stFREE); /* remove left over stFREE */
|
|
if (rval) stack=push();
|
|
|
|
p=ar->pointer;
|
|
switch(current->tag) {
|
|
case CALLARRAY:
|
|
dbl=(double *)p+index;
|
|
stack->value= *dbl;
|
|
stack->type=stNUMBER;
|
|
break;
|
|
case ASSIGNARRAY:
|
|
dbl=(double *)p+index;
|
|
*dbl=stack->value;
|
|
break;
|
|
case CALLSTRINGARRAY:
|
|
str=((char **)p+index);
|
|
stack->pointer=my_strdup(*str);
|
|
stack->type=stSTRING;
|
|
break;
|
|
case ASSIGNSTRINGARRAY:
|
|
str=((char **)p+index);
|
|
if (*str!=NULL)my_free(*str);
|
|
*str=my_strdup(stack->pointer);
|
|
break;
|
|
case GETSTRINGPOINTER:
|
|
str=((char **)p+index);
|
|
stack->pointer=*str;
|
|
stack->type=stSTRING;
|
|
break;
|
|
}
|
|
}
|
|
|
|
|
|
struct array *create_array(int type,int dimension) /* create an array */
|
|
{
|
|
int i;
|
|
struct array *ar;
|
|
|
|
ar=my_malloc(sizeof(struct array));
|
|
ar->type=type;
|
|
ar->dimension=dimension;
|
|
ar->pointer=NULL;
|
|
for(i=0;i<10;i++) ar->bounds[i]=0;
|
|
|
|
return ar;
|
|
}
|
|
|
|
|
|
static int count_args(int skipfirst) /* count number of numeric arguments on stack */
|
|
{
|
|
int i=0;
|
|
int sign=1;
|
|
struct stackentry *curr;
|
|
|
|
curr=stackhead->prev;
|
|
if (skipfirst) curr=curr->prev;
|
|
while(curr) {
|
|
if (curr->type==stFREE) return i*sign;
|
|
if (curr->type!=stNUMBER) sign=-1;
|
|
curr=curr->prev;
|
|
i++;
|
|
}
|
|
return -1;
|
|
}
|
|
|
|
|
|
void skipper()
|
|
/* used for on_goto/gosub, skip specified number of commands */
|
|
{
|
|
int i,len;
|
|
struct command *ahead; /* command to follow */
|
|
|
|
len=(int)pop(stNUMBER)->value;
|
|
i=1;
|
|
current=current->next; /* advance to first goto/gosub */
|
|
for(i=1;i<len;i++) {
|
|
ahead=current->next->next; /* skip interleaving findnop statement */
|
|
if (ahead->type==cNOP)
|
|
break;
|
|
else
|
|
current=ahead;
|
|
}
|
|
}
|
|
|
|
|
|
void skiponce(struct command *cmd) /* skip next command exectly once */
|
|
{
|
|
if (cmd->tag) current=current->next;
|
|
cmd->tag=0;
|
|
}
|
|
|
|
|
|
void resetskiponce(struct command *cmd) /* find and reset next skip */
|
|
{
|
|
struct command *c;
|
|
|
|
c=cmd;
|
|
while(c->type!=cSKIPONCE) c=c->next;
|
|
c->tag=1;
|
|
}
|
|
|
|
void create_break_mark(int minor,int major) /* create marks for break */
|
|
{
|
|
struct command *cmd;
|
|
|
|
in_loop+=major;
|
|
cmd=add_command(cBREAK_MARK,NULL);
|
|
cmd->tag=(major+2)*16+minor+2;
|
|
}
|
|
|
|
|
|
void next_case(void) /* go to next case in switch statement */
|
|
{
|
|
if (stackhead->prev->type==stSTRING || stackhead->prev->type==stSWITCH_STRING)
|
|
stackhead->prev->type=stSWITCH_STRING;
|
|
else
|
|
stackhead->prev->type=stSWITCH_NUMBER;
|
|
}
|
|
|
|
|
|
void push_switch_id(void) /* generate a new switch id */
|
|
{
|
|
static int max_switch_id=0;
|
|
static int switch_stack_depth=1;
|
|
|
|
struct switch_id *new_id;
|
|
if (switch_id_stackhead==NULL || switch_id_stackhead->next==NULL) {
|
|
if (switch_id_stackroot && switch_id_stackhead==NULL) {
|
|
new_id=switch_id_stackroot;
|
|
} else {
|
|
new_id=my_malloc(sizeof(struct switch_id));
|
|
new_id->next=NULL;
|
|
new_id->depth=switch_stack_depth++;
|
|
}
|
|
} else {
|
|
new_id=switch_id_stackhead->next;
|
|
}
|
|
max_switch_id++;
|
|
new_id->id=max_switch_id;
|
|
if (switch_id_stackhead==NULL) {
|
|
switch_id_stackhead=new_id;
|
|
switch_id_stackhead->prev=NULL;
|
|
} else {
|
|
switch_id_stackhead->next=new_id;
|
|
new_id->prev=switch_id_stackhead;
|
|
switch_id_stackhead=new_id;
|
|
}
|
|
}
|
|
|
|
|
|
void pop_switch_id(void) /* get previous switch id */
|
|
{
|
|
if (switch_id_stackhead) switch_id_stackhead=switch_id_stackhead->prev;
|
|
}
|
|
|
|
|
|
int get_switch_id(void) /* get current switch id */
|
|
{
|
|
return switch_id_stackhead ? switch_id_stackhead->id : 0;
|
|
}
|
|
|
|
|
|
int get_switch_depth(void) /* get current depth of switch id stack */
|
|
{
|
|
return switch_id_stackhead ? switch_id_stackhead->depth : 0;
|
|
}
|
|
|
|
|
|
void push_switch_mark(void) /* push a switch mark */
|
|
{
|
|
push()->type=stSWITCH_MARK;
|
|
}
|
|
|
|
|
|
void create_clean_switch_mark(int keep,int ret) /* add command clean_switch_mark */
|
|
{
|
|
struct command *cmd;
|
|
|
|
cmd=add_command(cCLEAN_SWITCH_MARK,NULL);
|
|
cmd->args=keep;
|
|
cmd->tag=ret;
|
|
}
|
|
|
|
|
|
void clean_switch_mark(struct command *cmd) /* pop everything up to (and including) first switch_mark from stack */
|
|
{
|
|
struct stackentry *t,*tt,*b,*bb,*s;
|
|
int keep,k,ret;
|
|
|
|
k=keep=cmd->args;
|
|
ret=cmd->tag;
|
|
s=stackhead->prev;
|
|
while(k && s!=stackroot) {
|
|
k--;
|
|
s=s->prev;
|
|
}
|
|
t=s;
|
|
tt=s->next;
|
|
while(((ret && s->type!=stRETADDCALL) || (!ret && s->type!=stSWITCH_MARK)) && s!=stackroot) {
|
|
s=s->prev;
|
|
}
|
|
if (ret) {
|
|
bb=s;
|
|
b=s->next;
|
|
} else {
|
|
b=s;
|
|
bb=s->prev;
|
|
}
|
|
|
|
/* cut part between (and including) b and t out of stack */
|
|
bb->next=tt;
|
|
tt->prev=bb;
|
|
/* insert cut-out part between stackhead and stackhead->prev */
|
|
stackhead->prev->next=b;
|
|
b->prev=stackhead->prev;
|
|
t->next=stackhead;
|
|
stackhead->prev=t;
|
|
if (keep)
|
|
stackhead=tt->next;
|
|
else
|
|
stackhead=bb->next;
|
|
}
|
|
|
|
|
|
void mybreak(struct command *cmd) /* find break_here statement */
|
|
{
|
|
struct command *curr;
|
|
int major,minor;
|
|
int major_nesting=0;
|
|
int minor_nesting=0;
|
|
|
|
if (cmd->type==cBREAK)
|
|
major_nesting=1;
|
|
else
|
|
minor_nesting=0;
|
|
curr=cmd;
|
|
while(curr->type!=cBREAK_HERE || major_nesting || minor_nesting) {
|
|
if (curr->type==cBREAK_MARK) {
|
|
minor=(curr->tag&15)-2;
|
|
major=((curr->tag&240)/16)-2;
|
|
if (!major_nesting) minor_nesting+=minor;
|
|
major_nesting+=major;
|
|
if (infolevel>=DEBUG) {
|
|
sprintf(string,"searching break-mark: diff(%d,%d), total(%d,%d)",minor,major,minor_nesting,major_nesting);
|
|
error(DEBUG,string);
|
|
}
|
|
}
|
|
curr=curr->next;
|
|
if (!curr) error(FATAL,"break has left program");
|
|
}
|
|
cmd->type=cQGOTO;
|
|
if (infolevel>=DEBUG) error(DEBUG,"converting cBREAK to cQGOTO");
|
|
cmd->jump=current=curr;
|
|
}
|
|
|
|
|
|
void mycontinue(struct command *cmd) /* find continue_here statement */
|
|
{
|
|
struct command *curr;
|
|
int major;
|
|
int major_nesting=-1;
|
|
|
|
curr=cmd;
|
|
while(curr->type!=cCONTINUE_HERE || major_nesting) {
|
|
if (curr->type==cBREAK_MARK) {
|
|
major=((curr->tag&240)>>4)-2;
|
|
major_nesting+=major;
|
|
}
|
|
if (curr->type==cCONTINUE_CORRECTION) major_nesting--;
|
|
curr=curr->prev;
|
|
if (!curr) error(FATAL,"continue has left program");
|
|
}
|
|
cmd->type=cQGOTO;
|
|
if (infolevel>=DEBUG) error(DEBUG,"converting cCONTINUE to cQGOTO");
|
|
cmd->jump=current=curr;
|
|
}
|
|
|
|
|
|
void findnop()
|
|
/* used for on_gosub, find trailing nop command */
|
|
{
|
|
while(current->type!=cNOP) {
|
|
current=current->next; /* next label */
|
|
}
|
|
}
|
|
|
|
|
|
void forcheck(void) /* check, if for-loop is done */
|
|
{
|
|
double start,bound,step,val;
|
|
|
|
val=pop(stNUMBER)->value;
|
|
step=pop(stNUMBER)->value;
|
|
bound=pop(stNUMBER)->value;
|
|
start=stackhead->prev->value;
|
|
if ((val<=bound && val>=start && step>=0) || (val<=start && val>=bound && step<=0))
|
|
stackhead->prev->value=1.;
|
|
else
|
|
stackhead->prev->value=0.;
|
|
}
|
|
|
|
|
|
void forincrement(void) /* increment value on stack */
|
|
{
|
|
/* expecting on stack: BOUND,STEP,VAL,stackhead
|
|
where for VAL=START to BOUND step STEP */
|
|
stackhead->prev->value+=stackhead->prev->prev->value;
|
|
}
|
|
|
|
|
|
void startfor(void) /* compute initial value of for-variable */
|
|
{
|
|
struct stackentry *p;
|
|
|
|
p=push();
|
|
p->value=stackhead->prev->prev->prev->prev->value-stackhead->prev->prev->value;
|
|
p->type=stNUMBER;
|
|
|
|
return;
|
|
}
|
|
|
|
|