--- /dev/null
+CFLAGS = -c
+
+FILES= bem.o y.tab.o symbols.o initialize.o compile.o \
+ parseparams.o yywrap.o gencode.o util.o graph.o \
+ eval.o func.o split.o
+
+../bem: $(FILES)
+ cc -o ../bem $(FILES)
+
+y.tab.o : y.tab.c lex.c
+ cc $(CFLAGS) y.tab.c
+
+y.tab.c : basic.yacc
+ yacc -d basic.yacc
--- /dev/null
+/* This file contains the new lexical analizer */
+typedef struct {
+ char *name;
+ int token, classvalue,length;
+} Key;
+
+Key keywords [] ={
+"abs", FUNCTION, ABSSYM, 0,
+"and", BOOLOP, ANDSYM, 0,
+"asc", FUNCTION, ASCSYM, 0,
+"as", ASSYM, 0, 0,
+"atn", FUNCTION, ATNSYM, 0,
+"auto", ILLEGAL, 0, 0,
+"base", BASESYM, 0, 0,
+"call", CALLSYM, 0, 0,
+"cdbl", FUNCTION, CDBLSYM, 0,
+"chain", ILLEGAL, 0, 0,
+"chr", FUNCTION, CHRSYM, 0,
+"cint", FUNCTION, CINTSYM, 0,
+"clear", CLEARSYM, 0, 0,
+"cload", ILLEGAL, 0, 0,
+"close", ILLEGAL, 0, 0,
+"common", ILLEGAL, 0, 0,
+"cont", ILLEGAL, 0, 0,
+"cos", FUNCTION, COSSYM, 0,
+"csng", FUNCTION, CSNGSYM, 0,
+"csave", ILLEGAL, 0, 0,
+"cvi", FUNCTION, CVISYM, 0,
+"cvs", FUNCTION, CVSSYM, 0,
+"cvd", FUNCTION, CVDSYM, 0,
+"data", DATASYM, 0, 0,
+"defint", DEFINTSYM, 0, 0,
+"defsng", DEFSNGSYM, 0, 0,
+"defdbl", DEFDBLSYM, 0, 0,
+"defstr", DEFSTRSYM, 0, 0,
+"def", DEFSYM, 0, 0,
+"delete", ILLEGAL, 0, 0,
+"dim", DIMSYM, 0, 0,
+"edit", ILLEGAL, 0, 0,
+"else", ELSESYM, 0, 0,
+"end", ENDSYM, 0, 0,
+"eof", FUNCTION, EOFSYM, 0,
+"erase", ILLEGAL, 0, 0,
+"error", ERRORSYM, 0, 0,
+"err", ERRSYM, 0, 0,
+"erl", ERLSYM, 0, 0,
+"else", ELSESYM, 0, 0,
+"eqv", BOOLOP, EQVSYM, 0,
+"exp", FUNCTION, EXPSYM, 0,
+"field", FIELDSYM, 0, 0,
+"fix", FUNCTION, FIXSYM, 0,
+"for", FORSYM, 0, 0,
+"fre", FUNCTION, FRESYM, 0,
+"get", GETSYM, 0, 0,
+"gosub", GOSUBSYM, 0, 0,
+"goto", GOTOSYM, 0, 0,
+"hex", FUNCTION, HEXSYM, 0,
+"if", IFSYM, 0, 0,
+"imp", BOOLOP, IMPSYM, 0,
+"inkey", INKEYSYM, 0, 0,
+"input", INPUTSYM, 0, 0,
+"inp", FUNCTION, INPSYM, 0,
+"instr", FUNCTION, INSTRSYM, 0,
+"int", FUNCTION, INTSYM, 0,
+"kill", ILLEGAL, 0, 0,
+"left", FUNCTION, LEFTSYM, 0,
+"len", FUNCTION, LENSYM, 0,
+"let", LETSYM, 0, 0,
+"line", LINESYM, 0, 0,
+"list", LISTSYM, 0, 0,
+"llist", ILLEGAL, 0, 0,
+"load", LOADSYM, 0, 0,
+"loc", FUNCTION, LOCSYM, 0,
+"log", FUNCTION, LOGSYM, 0,
+"lpos", FUNCTION, LPOSSYM, 0,
+"lprint", ILLEGAL, 0, 0,
+"lset", LSETSYM, 0, 0,
+"merge", MERGESYM, 0, 0,
+"mid", MIDSYM, 0, 0,
+"mki", FUNCTION, MKISYM, 0,
+"mks", FUNCTION, MKSSYM, 0,
+"mkd", FUNCTION, MKDSYM, 0,
+"mod", MODSYM, 0, 0,
+"name", ILLEGAL, 0, 0,
+"new", ILLEGAL, 0, 0,
+"next", NEXTSYM, 0, 0,
+"not", NOTSYM, 0, 0,
+"null", ILLEGAL, 0, 0,
+"on", ONSYM, 0, 0,
+"oct", FUNCTION, OCTSYM, 0,
+"open", OPENSYM, 0, 0,
+"option", OPTIONSYM, 0, 0,
+"or", BOOLOP, ORSYM, 0,
+"out", FUNCTION, OUTSYM, 0,
+"peek", PEEKSYM, 0, 0,
+"poke", POKESYM, 0, 0,
+"print", PRINTSYM, 0, 0,
+"pos", FUNCTION, POSSYM, 0,
+"put", PUTSYM, 0, 0,
+"randomize", RANDOMIZESYM, 0, 0,
+"read", READSYM, 0, 0,
+"rem", REMSYM, 0, 0,
+"renum", ILLEGAL, 0, 0,
+"ren", ILLEGAL, 0, 0,
+"restore", RESTORESYM, 0, 0,
+"resume", ILLEGAL, 0, 0,
+"return", RETURNSYM, 0, 0,
+"right", FUNCTION, RIGHTSYM, 0,
+"rnd", FUNCTION, RNDSYM, 0,
+"run", ILLEGAL, 0, 0,
+"save", ILLEGAL, 0, 0,
+"step", STEPSYM, 0, 0,
+"sgn", FUNCTION, SGNSYM, 0,
+"sin", FUNCTION, SINSYM, 0,
+"space", FUNCTION, SPACESYM, 0,
+"spc", FUNCTION, SPCSYM, 0,
+"sqr", FUNCTION, SQRSYM, 0,
+"stop", STOPSYM, 0, 0,
+"string", FUNCTION, STRINGSYM, 0,
+"str", FUNCTION, STRSYM, 0,
+"swap", SWAPSYM, 0, 0,
+"tab", FUNCTION, TABSYM, 0,
+"tan", FUNCTION, TANSYM, 0,
+"then", THENSYM, 0, 0,
+"to", TOSYM, 0, 0,
+"tron", TRONOFFSYM, TRONSYM, 0,
+"troff", TRONOFFSYM, TROFFSYM, 0,
+"using", USINGSYM, 0, 0,
+"usr", FUNCTION, USRSYM, 0,
+"val", FUNCTION, VALSYM, 0,
+"varptr", FUNCTION, VARPTRSYM, 0,
+"wait", ILLEGAL, 0, 0,
+"while", WHILESYM, 0, 0,
+"wend", WENDSYM, 0, 0,
+"width", ILLEGAL, 0, 0,
+"write", WRITESYM, 0, 0,
+"xor", BOOLOP, XORSYM, 0,
+0, 0, 0, 0
+};
+
+/* Keyword index table */
+
+int kex[27];
+
+/* Initialize the keyword table */
+fillkex()
+{
+ Key *k;
+ int i;
+ for(k=keywords;k->name;k++)
+ k->length= strlen(k->name);
+ k=keywords;
+ for(i=0;k->name && i<='z'-'a';i++)
+ {
+ for(;k->name && *k->name<i+'a';k++);
+ if( *k->name!=i+'a') continue;
+ kex[*k->name-'a']=k-keywords;
+ for(;k->name && *k->name==i+'a';k++);
+ kex[*(k-1)->name-'a'+1]=k-keywords;
+ }
+ if(debug)
+ {
+ for(i=0;i<27;i++)
+ printf("%c:%d\n",'a'+i,kex[i]);
+ }
+}
+
+#include <ctype.h>
+
+/* Get each line separately into the buffer */
+/* Lines too long are terminated and flagged illegal */
+
+#define MAXLINELENGTH 1024
+
+char inputline[MAXLINELENGTH]; /* current source line */
+char *cptr; /* next character to decode */
+int yylineno=0; /* source line counter */
+
+getline()
+{
+ /* get next input line */
+
+ if( fgets(inputline,MAXLINELENGTH,yyin) == NULL)
+ return(FALSE);
+ yylineno ++;
+ if( index(inputline,'\n') == 0)
+ error("source line too long");
+ inputline[MAXLINELENGTH-1]=0;
+ if( listing)
+ fputs(inputline,stdout);
+ cptr= inputline;
+ return(TRUE);
+}
+yyerror(str)
+char *str;
+{
+ error("Syntax error");
+}
+
+typechar()
+{
+ switch(*cptr)
+ {
+ case '$':
+ cptr++; return( STRINGTYPE);
+ case '%':
+ cptr++; return( INTTYPE);
+ case '!':
+ cptr++; return( FLOATTYPE);
+ case '#':
+ cptr++; return( DOUBLETYPE);
+ }
+ return(0);
+}
+
+/* symbols in Microsoft are significant for the first 40 characters */
+#define SIGNIFICANT 40
+char name[SIGNIFICANT+1];
+
+lookup()
+{
+ Key *k;
+ Symbol *s;
+ char *c;
+ int i, typech;
+
+ sval= name;
+ for(c=cptr; *c && isalnum(*c);c++)
+ if( isupper(*c) )
+ *c= tolower((*c));
+ for(k= keywords+kex[*cptr-'a']; *(k->name)== *cptr;k++)
+ if( strncmp(cptr,k->name,k->length)==0)
+ {
+ /* check functions first*/
+ if( isalnum( *(cptr+k->length) ) &&
+ k->token==FUNCTION) continue;
+ cptr += k->length;
+ yylval= k->classvalue;
+ if(debug) printf("lookup:%d %d\n",
+ k->classvalue,k->token);
+ if( k->token == FUNCTION)
+ {
+ /* stripp type character */
+ typech=typechar();
+ }
+ /* illegals + rem */
+ if( k->token == REMSYM || k->token==ILLEGAL)
+ while( *cptr && *cptr!=':' && *cptr!='\n')
+ cptr++;
+ return( k->token);
+ }
+ /* Is it a function name ? */
+ c=cptr;
+ /* Identifier found, update the symbol table */
+ i=0;
+ while( isalnum(*c) || *c == '.')
+ if( i<SIGNIFICANT) name[i++]= *c++;
+ name[i]=0;
+ cptr=c;
+ s= (Symbol *) srchsymbol(name);
+ yylval = (YYSTYPE) s;
+ typech= typechar();
+ if(s->symtype!=DEFAULTTYPE)
+ {
+ if(typech && typech!=s->symtype && wflag)
+ warning("type re-declared,ignored");
+ }
+ if( typech)
+ s->symtype=typech;
+ if(debug) printf("lookup:%d Identifier\n",s);
+ if( (name[0]=='f' || name[0]=='F') &&
+ (name[1]=='n' || name[1]=='N') )
+ return(FUNCTID);
+ return(IDENTIFIER);
+}
+
+/* Parsing unsigned numbers */
+readconstant()
+{
+ /* read HEX and OCTAL numbers */
+ char *c;
+ cptr++;
+ if( *cptr == 'H' || *cptr=='h')
+ {
+ /* HEX */
+ cptr++;
+ c=cptr;
+ while( isdigit(*cptr) ||
+ (*cptr>='a' && *cptr<='f' ) ||
+ (*cptr>='A' && *cptr<='F' ) )cptr++;
+ sscanf(c,"%x",&ival);
+ } else
+ if( *cptr == 'O' || *cptr == 'o')
+ {
+ /* OCTAL */
+ cptr++;
+ c=cptr;
+ while( isdigit(*cptr) ) cptr++;
+ sscanf(c,"%o",&ival);
+ } else
+ error("H or O expected");
+ return(INTVALUE);
+}
+
+number()
+{
+ long i1;
+ double f,dec;
+ int minflag;
+ register char *c;
+
+ i1=0;
+ c=cptr;
+ while(isdigit(*c)){
+ i1= i1*10 + *c-'0';
+ c++;
+ }
+ cptr=c;
+ if( *c != '.'){
+ if( i1> MAXINT || i1<MININT) {
+ dval= i1;
+ return(FLTVALUE);
+ }
+ ival= i1;
+#ifdef YYDEBUG
+ if(yydebug) printf("number:INTVALUE %d",i1);
+#endif
+ return(INTVALUE);
+ }
+ /* handle floats */
+ f= i1; dec=0.1;
+ c++;
+ while( isdigit(*c)){
+ f= f + dec * (*c - '0');
+ dec /= 10.0;
+ c++;
+ }
+ /* handle exponential part */
+ if( *c =='e' || *c == 'E'){
+ c++;
+ minflag= (*c== '-')? -1: 1;
+ if( *c=='-' || *c=='+') c++;
+ while(isdigit(*c)){
+ f *= 10.0;
+ c++;
+ }
+ if(minflag== -1) f= 1.0/f;
+ }
+ dval= f;
+ cptr=c;
+#ifdef YYDEBUG
+ if(yydebug) printf("number:FLTVALUE %f",f);
+#endif
+ return(FLTVALUE);
+}
+scanstring()
+{
+ int i,length;
+ char firstchar;
+ /* skip this string value, you might as well copy it to
+ the EM file as well, because it is not used internally
+ */
+ /* generate label here */
+ yylval= genrom();
+ length=0;
+ if( fputc('"',emfile) == EOF) fatal("scanstring");
+ sval= cptr;
+ firstchar = *cptr;
+ if( *cptr== '"') cptr++;
+ while( *cptr !='"')
+ {
+ switch(*cptr)
+ {
+ case 0:
+ case '\n':
+#ifdef YYDEBUG
+ if(yydebug) printf("STRVALUE\n");
+#endif
+ if( firstchar == '"')
+ error("non-terminated string");
+ return(STRVALUE);
+ default:
+ fputc(*cptr,emfile);
+ }
+ cptr++;
+ length++;
+ }
+ *cptr=0;
+ cptr++;
+ fprintf(emfile,"\\000\"\n");
+ i=yylval;
+ yylval= genrom();
+ fprintf(emfile,"l%d,1,%d\n",i,length);
+#ifdef YYDEBUG
+ if(yydebug) printf("STRVALUE found\n");
+#endif
+ return(STRVALUE);
+}
+yylex()
+{
+ char *c;
+
+ /* Here is the big switch */
+ c= cptr;
+ switch(*c){
+ case 'a': case 'b': case 'c': case 'd': case 'e':
+ case 'f': case 'g': case 'h': case 'i': case 'j':
+ case 'k': case 'l': case 'm': case 'n': case 'o':
+ case 'p': case 'q': case 'r': case 's': case 't':
+ case 'u': case 'v': case 'w': case 'x': case 'y':
+ case 'z': case 'A': case 'B': case 'C': case 'D':
+ case 'E': case 'F': case 'G': case 'H': case 'I':
+ case 'J': case 'K': case 'L': case 'M': case 'N':
+ case 'O': case 'P': case 'Q': case 'R': case 'S':
+ case 'T': case 'U': case 'V': case 'W': case 'X':
+ case 'Y': case 'Z': case '_':
+ return(lookup());
+
+ case '0': case '1': case '2': case '3': case '4':
+ case '5': case '6': case '7': case '8': case '9':
+ case '.':
+ return(number());
+ case '\'':
+ /* comment at end of line */
+ while( *cptr != '\n' && *cptr) cptr++;
+ case '\n':
+ cptr++;
+ return(EOLN);
+ case 0:
+#ifdef YYDEBUG
+ if( yydebug) printf("end of buffer");
+#endif
+ return(0);
+ case '"':
+ return(scanstring());
+ /* handle double operators */
+ case ' ':
+ case '\t':
+ cptr++;
+ return(yylex());
+ case '&':
+ return(readconstant());
+ case '?': return(PRINTSYM);
+ case '>':
+ if( *(c+1)=='='){
+ c++;c++;cptr=c; yylval= GESYM;return(RELOP);
+ }
+ yylval= '>';
+ cptr++;
+ return(RELOP);
+ break;
+ case '<':
+ if( *(c+1)=='='){
+ c++; c++; cptr=c; yylval=LESYM; return(RELOP);
+ } else
+ if( *(c+1)=='>'){
+ c++; c++; cptr=c; yylval=NESYM; return(RELOP);
+ }
+ yylval= '<';
+ cptr++;
+ return(RELOP);
+ }
+ return(*cptr++);
+}
--- /dev/null
+%token ILLEGAL
+%token ASSYM
+%token BASESYM
+%token CALLSYM
+%token CLEARSYM
+%token CLOSESYM
+%token DATASYM
+%token DEFINTSYM
+%token DEFSNGSYM
+%token DEFDBLSYM
+%token DEFSTRSYM
+%token DEFSYM
+%token DIMSYM
+%token ELSESYM
+%token ERRSYM
+%token ERLSYM
+%token ERRORSYM
+%token ELSESYM
+%token FIELDSYM
+%token FORSYM
+%token FUNCTION
+%token FUNCTID
+%token INKEYSYM
+%token GETSYM
+%token GOSUBSYM
+%token GOTOSYM
+%token IFSYM
+%token INPUTSYM
+%token LETSYM
+%token LINESYM
+%token LSETSYM
+%token MIDSYM
+%token NEXTSYM
+%token ONSYM
+%token OPENSYM
+%token OPTIONSYM
+%token PRINTSYM
+%token POKESYM
+%token PUTSYM
+%token RANDOMIZESYM
+%token READSYM
+%token REMSYM
+%token RESTORESYM
+%token RETURNSYM
+%token ENDSYM
+%token STOPSYM
+%token STEPSYM
+%token SWAPSYM
+%token THENSYM
+%token TOSYM
+%token TRONOFFSYM
+%token USINGSYM
+%token USRSYM
+%token WHILESYM
+%token WENDSYM
+%token WRITESYM
+/* special tokens */
+%token EOLN
+%token INTVALUE
+%token FLTVALUE
+%token DBLVALUE
+%token STRVALUE
+%token UNARYSYM
+%token IDENTIFIER
+%token ANDSYM
+%token ORSYM
+%token VARPTR
+
+%left BOOLOP
+%left NOTSYM
+%left RELOP '=' '<' '>' LESYM GESYM NESYM
+%left '+' '-'
+%left '*' '/' '\\' MODSYM
+%left '^'
+%left UNARYMINUS
+
+%{
+#define YYDEBUG
+#include "bem.h"
+
+int ival; /* parser temporary values */
+double dval;
+char *sval;
+int e1,e2;
+int chann; /* input/output channel */
+int deftype; /* predefined type declarer */
+
+char *formatstring; /* formatstring used for printing */
+Symbol *s; /* Symbol dummy */
+%}
+%%
+programline : INTVALUE {newblock(ival); newemblock(ival);} stmts EOLN
+ | '#' INTVALUE STRVALUE EOLN
+ | EOLN
+ ;
+
+
+stmts : singlestmt
+ | stmts ':' singlestmt
+ ;
+
+singlestmt : callstmt
+ | clearstmt
+ | closestmt
+ | datastmt
+ | deffnstmt
+ | defvarstmt
+ | defusrstmt
+ | dimstmt
+ | ERRORSYM expression {errorstmt($2);}
+ | fieldstmt
+ | forstmt
+ | getstmt
+ | gosubstmt
+ | ongotostmt
+ | ifstmt
+ | illegalstmt
+ | inputstmt
+ | letstmt
+ | lineinputstmt
+ | lsetstmt
+ | midstmt
+ | exceptionstmt
+ | nextstmt
+ | GOTOSYM INTVALUE {gotostmt(ival);}
+ | openstmt
+ | optionstmt
+ | pokestmt
+ | printstmt
+ | randomizestmt
+ | readstmt
+ | REMSYM
+ | restorestmt
+ | returnstmt
+ | ENDSYM { emcode("loc","0");
+ emcode("cal","$_hlt");
+ emcode("asp",EMINTSIZE);}
+ | STOPSYM { emcode("cal","$_stop");}
+ | swapstmt
+ | TRONOFFSYM { tronoff=$1;}
+ | whilestmt
+ | wendstmt
+ | writestmt
+ | /* EMPTY STATEMENT */
+ ;
+
+illegalstmt: ILLEGAL {illegalcmd();}
+
+callstmt: CALLSYM IDENTIFIER parmlist ')'
+ {
+ emcode("cal",proclabel(((Symbol *) $2)->symname));
+ while($3 -- >0) emcode("asp",EMPTRSIZE);
+ }
+ | CALLSYM IDENTIFIER
+ { emcode("cal",proclabel(((Symbol *) $2)->symname));}
+
+parmlist: '(' variable { $$=1;}
+ | parmlist ',' variable { $$= $1+1;}
+
+clearstmt: CLEARSYM {warning("statement ignored");}
+ | CLEARSYM ',' expression {warning("statement ignored");}
+ | CLEARSYM ',' expression ',' expression {warning("statement ignored");}
+closestmt: CLOSESYM filelist
+ | CLOSESYM {emcode("cal","$_close");}
+
+filelist: cross intvalue { emcode("loc",$2);
+ emcode("cal","$_clochn");
+ emcode("asp",EMINTSIZE);}
+ | filelist ',' cross intvalue { emcode("loc",$4);
+ emcode("cal","$_clochn");
+ emcode("asp",EMINTSIZE);}
+
+datastmt: DATASYM {datastmt();} datalist {fprintf(datfile,"\n");}
+
+dataelm : INTVALUE {fprintf(datfile,"%d",ival);}
+ | '-' INTVALUE {fprintf(datfile,"%d",-ival);}
+ | FLTVALUE {fprintf(datfile,"%f",dval);}
+ | '-' FLTVALUE {fprintf(datfile,"%f",-dval);}
+ | STRVALUE {fprintf(datfile,"\"%s\"",sval);}
+ | IDENTIFIER {fprintf(datfile,"\"%s\"",sval);}
+ ;
+
+datalist: dataelm
+ | datalist ',' {fputc(',',datfile);} dataelm
+ ;
+
+deffnstmt: DEFSYM heading '=' expression {endscope($4);}
+
+heading : FUNCTID { newscope($1); heading();}
+ | FUNCTID {newscope($1);} '(' idlist ')' { heading();}
+
+idlist : IDENTIFIER { dclparm($1);}
+ | idlist ',' IDENTIFIER { dclparm($3);}
+ ;
+
+defvarstmt: DEFINTSYM { setdefaulttype( INTTYPE);}
+ | DEFSNGSYM { setdefaulttype( FLOATTYPE);}
+ | DEFDBLSYM { setdefaulttype( DOUBLETYPE);}
+ | DEFSTRSYM { setdefaulttype( STRINGTYPE);}
+
+defusrstmt: DEFSYM USRSYM error ':' {illegalcmd();}
+
+dimstmt: DIMSYM arraydcl ')' {dclarray($2);}
+ | dimstmt ',' arraydcl ')' {dclarray($3);}
+ ;
+
+arraydcl : IDENTIFIER '(' INTVALUE {$$=$1; s= (Symbol *) $1;
+ s->dimlimit[s->dimensions]=ival;
+ s->dimensions++;
+ }
+ | arraydcl ',' INTVALUE {$$=$1; s=(Symbol *) $1;
+ if(s->dimensions<MAXDIMENSIONS)
+ {
+ s->dimlimit[s->dimensions]=ival;
+ s->dimensions++;
+ } else
+ error("too many dimensions");
+ }
+
+
+
+fieldstmt: FIELDSYM cross intvalue {setchannel(ival);} ',' fieldlist {notyetimpl();}
+
+fieldlist: intvalue ASSYM variable
+ | fieldlist ',' intvalue ASSYM variable
+ ;
+
+forstmt: FORSYM IDENTIFIER {forinit($2);} '=' expression {forexpr($5);}
+ TOSYM expression {forlimit($8);} step
+ ;
+
+step : STEPSYM expression {forstep($2);}
+ | /*EMPTY*/ {emcode("loc","1"); forstep(INTTYPE);}
+ ;
+
+nextstmt: NEXTSYM IDENTIFIER {nextstmt($2);}
+ | NEXTSYM { nextstmt(0);}
+ | nextstmt ',' IDENTIFIER { nextstmt($3);}
+
+getstmt: getput {emcode("loc",itoa(0));
+ emcode("cal",$1);
+ emcode("asp",EMINTSIZE);}
+ | getput ',' intvalue
+ { /* position seek pointer first*/
+ emcode("loc",itoa(ival));
+ emcode("cal",$1);
+ emcode("asp",EMINTSIZE);
+ }
+getput: GETSYM cross intvalue { setchannel(ival); $$= (YYSTYPE)"$_getrec";}
+ | PUTSYM cross intvalue { setchannel(ival); $$= (YYSTYPE)"$_putsym";}
+
+gosubstmt: GOSUBSYM INTVALUE {gosubstmt(ival);}
+
+returnstmt: RETURNSYM {returnstmt();}
+
+ifstmt: IFSYM expression {$1=ifstmt($2);} thenpart
+ {$1=thenpart($1);} elsepart {elsepart($1);}
+ ;
+
+thenpart: THENSYM INTVALUE {gotostmt(ival);}
+ | THENSYM stmts
+ | GOTOSYM INTVALUE {gotostmt(ival);}
+ ;
+elsepart: ELSESYM INTVALUE {gotostmt(ival);}
+ | ELSESYM stmts
+ | /* empty */
+ ;
+
+inputstmt: INPUTSYM semiprompt readlist
+ | INPUTSYM '#' intvalue {setchannel(ival);}',' readlist
+ ;
+
+semiprompt : semi STRVALUE ';' { loadstr($2); prompt(1);}
+ | semi STRVALUE ',' { loadstr($2); prompt(0);}
+ | /*EMPTY*/ { setchannel(-1);
+ emcode("cal","$_qstmark");}
+
+semi : ';' | /* empty */ ;
+
+letstmt: LETSYM {e1=where();} variable {e2=where();}
+ '=' expression {assign($3,$6);}
+ | {e1=where();} variable {e2=where();}
+ '=' expression {assign($2,$5);}
+
+lineinputstmt: LINESYM INPUTSYM semiprompt {setchannel(-1);} variable {linestmt($5);}
+ | LINESYM '#' intvalue {setchannel(ival);} ',' variable {linestmt($6);}
+ ;
+
+readlist: readelm
+ | readlist ',' readelm
+ ;
+readelm: variable {readelm($1);}
+
+lsetstmt: LSETSYM variable '=' expression {notyetimpl();}
+
+midstmt: MIDSYM '$' midparms '=' expression
+ { emcode("cal","$_midstmt");
+ emcode("asp",EMINTSIZE);
+ emcode("asp",EMINTSIZE);
+ emcode("asp",EMPTRSIZE);
+ emcode("asp",EMPTRSIZE);}
+
+midparms: '(' midfirst midsec midthird ')'
+
+midfirst: expression { conversion($1,STRINGTYPE); }
+midsec: ',' expression { conversion($2,INTTYPE); }
+midthird: ',' expression { conversion($2,INTTYPE); }
+ | /* empty */ { emcode("loc","-1");}
+
+exceptionstmt: ONSYM ERRORSYM GOTOSYM INTVALUE {exceptstmt(ival);}
+
+ongotostmt: ONSYM expression
+ GOSUBSYM constantlist {ongosubstmt($2);}
+ | ONSYM expression
+ GOTOSYM constantlist {ongotostmt($2);}
+
+constantlist: INTVALUE {jumpelm(ival);}
+ | constantlist ',' INTVALUE { jumpelm(ival);}
+
+openstmt: OPENSYM mode openchannel expression
+ { conversion($4,STRINGTYPE); openstmt(0);}
+ | OPENSYM mode openchannel
+ expression {conversion($4,STRINGTYPE);}
+ INTVALUE { openstmt(ival);}
+
+openchannel: cross INTVALUE ',' { setchannel(ival);}
+
+mode : expression ',' {conversion($1,STRINGTYPE);}
+ | ',' { emcode("lae","_iomode");}
+ ;
+
+optionstmt: OPTIONSYM BASESYM intvalue { optionbase($3);}
+
+printstmt: PRINTSYM {setchannel(-1);emcode("cal","$_nl");}
+ | PRINTSYM file format printlist
+ { if( $4) emcode("cal","$_nl");}
+file : '#' intvalue ',' {setchannel(ival);}
+ | /* empty */ {setchannel(-1);}
+ ;
+format : USINGSYM STRVALUE ';' { loadstr($2);}
+ | USINGSYM variable ';' {
+ if($2!=STRINGTYPE) error("string variable expected");}
+ | /* empty */ {formatstring=0;}
+
+printlist: expression { printstmt($1); $$=1;}
+ | ',' { zone(0); $$=0;}
+ | ';' { zone(1); $$=0;}
+ | printlist expression { printstmt($2); $$=1;}
+ | printlist ',' { zone(1);$$=0;}
+ | printlist ';' { zone(0);$$=0;}
+ ;
+pokestmt: POKESYM expression ',' expression {pokestmt($2,$4);}
+ ;
+randomizestmt: RANDOMIZESYM
+ { emcode("cal","$_randomize");}
+ | RANDOMIZESYM expression
+ { conversion($2,INTTYPE);
+ emcode("cal","$_setrandom");
+ emcode("asp",EMINTSIZE);}
+
+readstmt: READSYM {setchannel(0);} variable { readelm($3);}
+ | readstmt ',' variable { readelm($3);}
+
+restorestmt: RESTORESYM INTVALUE { restore(ival);}
+ | RESTORESYM { restore(0);}
+
+swapstmt: SWAPSYM variable ',' variable { swapstmt($2,$4);}
+
+whilestmt: WHILESYM {whilestart();} expression {whiletst($3);}
+ ;
+
+wendstmt : WENDSYM {wend();}
+
+writestmt: WRITESYM {setchannel(-1);emcode("cal","$_wrnl");}
+ | WRITESYM file writelist {emcode("cal","$_wrnl");}
+ ;
+
+writelist: expression {writestmt($1,0);}
+ | writelist ',' expression {writestmt($3,1);}
+ ;
+
+cross: '#' | /* empty */
+
+intvalue: INTVALUE
+ ;
+
+variable: identifier { $$=loadaddr($1);}
+ | indexed ')' {$$=endarrayload();}
+ | ERRSYM {emcode("lae","_errsym"); $$= INTTYPE;}
+ | ERLSYM {emcode("lae","_erlsym"); $$= INTTYPE;}
+ ;
+indexed : identifier '(' {newarrayload($1);}
+ expression {loadarray($4); $$=$1;}
+ | indexed ',' expression {loadarray($3); $$=$1;}
+ ;
+
+
+expression: negation
+ | negation BOOLOP expression {$$=boolop($1,$3,$2);}
+
+negation: NOTSYM compare {$$=boolop($2,0,NOTSYM);}
+ | compare
+ ;
+compare : sum
+ | sum RELOP sum {$$=relop($1,$3,$2);}
+ | sum '=' sum {$$=relop($1,$3,'=');}
+
+sum : term
+ | term '-' sum {$$=plusmin($1,$3,'-');}
+ | term '+' sum {$$=plusmin($1,$3,'+');}
+term : factor
+ | factor '^' factor {$$=power($1,$3);}
+ | factor '*' term {$$=muldiv($1,$3,'*');}
+ | factor '\\' term {$$=muldiv($1,$3,'\\');}
+ | factor '/' term {$$=muldiv($1,$3,'/');}
+ | factor MODSYM term {$$=muldiv($1,$3,MODSYM);}
+factor : INTVALUE {$$=loadint(ival);}
+ | '(' expression ')' {$$=$2;}
+ | '-' factor { $$=negate($2);}
+ | FLTVALUE {$$=loaddbl(dval);}
+ | STRVALUE {$$=loadstr($1);}
+ | variable {$$=loadvar($1);}
+ | INKEYSYM '$' { emcode("cal","$_inkey");
+ emcode("lfr",EMPTRSIZE);
+ $$= STRINGTYPE;
+ }
+ | VARPTR '(' '#' intvalue ')' { warning("Not supported"); $$=INTTYPE;}
+ | FUNCTION {$$= callfcn($1,0);}
+ | FUNCTION '(' cross exprlist')' {$$=callfcn($1,$4);}
+ | funcname { $$=fcnend($1);}
+ | funcname funccall ')' { $$=fcnend($1,$2);}
+ | MIDSYM '$' midparms
+ { emcode("cal","$_mid");
+ emcode("asp",itoa($3));
+ emcode("lfr",EMPTRSIZE);
+ $$= STRINGTYPE;
+ }
+ | INPUTSYM '$' '(' expression inputtail
+ {
+ emcode("cal","$_inpfcn");
+ emcode("asp",EMINTSIZE);
+ emcode("asp",EMINTSIZE);
+ emcode("asp",EMPTRSIZE);
+ $$= STRINGTYPE;
+ }
+inputtail: ',' expression ')' { conversion($2,INTTYPE); $$= INTTYPE;}
+ | ',' '#' expression ')' { conversion($3,INTTYPE); $$= INTTYPE;}
+ | ')' { emcode("loc","-1"); $$= INTTYPE;}
+
+funcname: FUNCTID {$$=fcncall($1);}
+
+funccall: '(' expression { callparm(0,$2); $$=1;}
+ | funccall ',' expression { callparm($1,$3); $$=$1+1;}
+
+identifier: IDENTIFIER { dcltype($1); $$=$1;}
+
+exprlist: expression { typetable[0]= $1; $$=1;}
+ | exprlist ',' expression { typetable[$1]=$3;$$=$1+1;}
+
+%%
+#include "lex.c"
--- /dev/null
+#include "bem.h"
+
+/* Author: M.L. Kersten
+**
+** This is the main routine for the BASIC-EM frontend.
+** Program parameters are decoded, the BASIC program is parsed
+** and compiled to an executable program
+**
+** Bem expects at least three parameters. One ending with '.i' is considered
+** the input to the compiler, '.e' denotes the file to be generated,
+** and the last name denotes the name of the user supplied file name.
+** The latter is used to store the data entries.
+** Additional flags may be supplied, see parseparms.
+*/
+
+char *program;
+
+char datfname[MAXFILENAME] ;
+char tmpfname[MAXFILENAME] ;
+
+char *inpfile, *outfile;
+main(argc,argv)
+int argc;
+char **argv;
+{
+ extern int errorcnt;
+
+ /* parseparams */
+ parseparams(argc,argv);
+ /* initialize the system */
+ initialize();
+ /* compile source programs */
+ compileprogram(program);
+ linewarnings();
+ if( errorcnt) exit(-1);
+ /* process em object files */
+ simpleprogram();
+}
--- /dev/null
+#include <stdio.h>
+#include <ctype.h>
+#include <signal.h>
+
+/* Author: M.L. Kersten
+** Here all the global objects are defined.
+*/
+#include "symbols.h"
+#include "graph.h"
+#include "y.tab.h"
+
+#define POINTERSIZE 4
+#define MAXINT 32768
+#define MININT -32767
+#define EMINTSIZE "EM_WSIZE"
+#define EMPTRSIZE "EM_PSIZE"
+#define EMFLTSIZE "EM_DSIZE"
+
+#define MAXPIECES 100
+#define MAXFILENAME 200
+
+#define CHANNEL 0
+#define THRESHOLD 40 /* for splitting blocks */
+
+extern char *program; /* name of source program */
+extern char *inpfile; /* input tko compiler */
+extern char *outfile; /* output from compiler */
+
+extern char datfname[MAXFILENAME]; /* data statements file */
+extern char tmpfname[MAXFILENAME]; /* temporary statements file */
+
+extern FILE *emfile; /* EM output file */
+extern FILE *datfile; /* data file */
+extern FILE *tmpfile; /* compiler temporary */
+extern FILE *yyin; /* Compiler input */
+
+extern int endofinput;
+extern int wflag;
+extern int hflag;
+extern int traceflag;
+extern int yydebug;
+extern int yylineno;
+extern int listing;
+extern int nolins;
+extern int threshold;
+extern int debug;
+extern int tronoff;
+
+extern int emlinecount; /* counts lines on tmpfile */
+extern int dataused;
+extern int typetable[10]; /* parameters to standard functions */
+
+extern Linerecord *currline;
+
+
+extern char *itoa();
+extern char *datalabel();
+extern char *instrlabel();
+extern char *typesize();
--- /dev/null
+#include "bem.h"
+
+/* compile the next program in the list */
+
+FILE *yyin;
+
+compileprogram()
+{
+
+ while( getline())
+ yyparse();
+ fclose(yyin);
+}
--- /dev/null
+#include "bem.h"
+
+/* Here you find all routines to evaluate expressions and
+ generate code for assignment statements
+*/
+
+exprtype(ltype,rtype)
+int ltype,rtype;
+{
+ /* determine the result type of an expression */
+ if( ltype== STRINGTYPE || rtype==STRINGTYPE)
+ {
+ if( ltype!=rtype)
+ error("type conflict, string expected");
+ return( STRINGTYPE);
+ }
+ /* take maximum */
+ if( ltype<rtype) return(rtype);
+ return(ltype);
+}
+
+conversion(oldtype,newtype)
+int oldtype,newtype;
+{
+ /* the value on top of the stack should be converted */
+ if( oldtype==newtype) return;
+ switch( oldtype)
+ {
+ case INTTYPE:
+ if( newtype==FLOATTYPE || newtype==DOUBLETYPE)
+ {
+ emcode("loc",EMINTSIZE);
+ emcode("loc",EMFLTSIZE);
+ emcode("cif","");
+ }else{
+ if(debug)
+ printf("type n=%d o=%d\n",newtype,oldtype);
+ error("conversion error");
+ }
+ break;
+ case FLOATTYPE:
+ case DOUBLETYPE:
+ if( newtype==INTTYPE)
+ {
+ /* rounded ! */
+ emcode("cal","$_cint");
+ emcode("asp",EMFLTSIZE);
+ emcode("lfr",EMINTSIZE);
+ break;
+ }else
+ if( newtype== FLOATTYPE || newtype==DOUBLETYPE)
+ break;
+ default:
+ if(debug)
+ printf("type n=%d o=%d\n",newtype,oldtype);
+ error("conversion error");
+ }
+}
+extraconvert(oldtype,newtype,topstack)
+int oldtype,newtype,topstack;
+{
+ /* the value below the top of the stack should be converted */
+ if( oldtype==newtype ) return;
+ if( debug) printf("extra convert %d %d %d\n",oldtype,newtype,topstack);
+ /* save top in dummy */
+ switch( topstack)
+ {
+ case INTTYPE:
+ emcode("ste","dummy1");
+ break;
+ case FLOATTYPE:
+ case DOUBLETYPE:
+ /* rounded ! */
+ emcode("lae","dummy1");
+ emcode("sti",EMFLTSIZE);
+ break;
+ default:
+ error("conversion error");
+ return;
+ }
+ /* now its on top of the stack */
+ conversion(oldtype,newtype);
+ /* restore top */
+ switch( topstack)
+ {
+ case INTTYPE:
+ emcode("loe","dummy1");
+ break;
+ case FLOATTYPE:
+ case DOUBLETYPE:
+ /* rounded ! */
+ emcode("lae","dummy1");
+ emcode("loi",EMFLTSIZE);
+ }
+}
+
+boolop(ltype,rtype,operator)
+int ltype,rtype,operator;
+{
+ if( operator != NOTSYM)
+ {
+ extraconvert(ltype,INTTYPE,rtype);
+ conversion(rtype,INTTYPE);
+ } else conversion(ltype,INTTYPE);
+ switch( operator)
+ {
+ case NOTSYM: emcode("com",EMINTSIZE); break;
+ case ANDSYM: emcode("and",EMINTSIZE); break;
+ case ORSYM: emcode("ior",EMINTSIZE); break;
+ case XORSYM: emcode("xor",EMINTSIZE); break;
+ case EQVSYM:
+ emcode("xor",EMINTSIZE);
+ emcode("com",EMINTSIZE);
+ break;
+ case IMPSYM:
+ /* implies */
+ emcode("com",EMINTSIZE);
+ emcode("and",EMINTSIZE);
+ emcode("com",EMINTSIZE);
+ break;
+ default: error("boolop:unexpected");
+ }
+ return(INTTYPE);
+}
+genbool(opcode)
+char *opcode;
+{
+ int l1,l2;
+ l1= genlabel();
+ l2= genlabel();
+ emcode(opcode,instrlabel(l1));
+ emcode("loc",itoa(0));
+ emcode("bra",instrlabel(l2));
+ fprintf(tmpfile,"%d\n",l1); emlinecount++;
+ emcode("loc",itoa(-1));
+ fprintf(tmpfile,"%d\n",l2); emlinecount++;
+}
+relop( ltype,rtype,operator)
+int ltype,rtype,operator;
+{
+ int result;
+ if(debug) printf("relop %d %d op=%d\n",ltype,rtype,operator);
+ result= exprtype(ltype,rtype);
+ extraconvert(ltype,result,rtype);
+ conversion(rtype,result);
+ /* compare the objects */
+ if( result== INTTYPE)
+ emcode("cmi", EMINTSIZE);
+ else
+ if( result==FLOATTYPE || result==DOUBLETYPE)
+ emcode("cmf",EMFLTSIZE);
+ else
+ if( result==STRINGTYPE)
+ {
+ emcode("cal","$_strcompare");
+ emcode("asp",EMPTRSIZE);
+ emcode("asp",EMPTRSIZE);
+ emcode("lfr",EMINTSIZE);
+ } else error("relop:unexpected");
+ /* handle the relational operators */
+ switch(operator)
+ {
+ case '<': genbool("zlt"); break;
+ case '>': genbool("zgt"); break;
+ case '=': genbool("zeq"); break;
+ case NESYM: genbool("zne"); break;
+ case LESYM: genbool("zle"); break;
+ case GESYM: genbool("zge"); break;
+ default: error("relop:unexpected operator");
+ }
+ return(INTTYPE);
+}
+plusmin(ltype,rtype,operator)
+int ltype,rtype,operator;
+{
+ int result;
+ result= exprtype(ltype,rtype);
+
+ if( result== STRINGTYPE)
+ {
+ if( operator== '+')
+ {
+ emcode("cal","$_concat");
+ emcode("asp",EMPTRSIZE);
+ emcode("asp",EMPTRSIZE);
+ emcode("lfr",EMPTRSIZE);
+ } else error("illegal operator");
+ } else {
+ extraconvert(ltype,result,rtype);
+ conversion(rtype,result);
+ if( result== INTTYPE)
+ {
+ if( operator=='+')
+ emcode("adi",EMINTSIZE);
+ else emcode("sbi",EMINTSIZE);
+ } else{
+ if( operator=='+')
+ emcode("adf",EMFLTSIZE);
+ else emcode("sbf",EMFLTSIZE);
+ }
+ }
+ return(result);
+}
+muldiv(ltype,rtype,operator)
+int ltype,rtype,operator;
+{
+ int result;
+
+ result= exprtype(ltype,rtype);
+ if(operator==MODSYM || operator== '\\') result=INTTYPE;
+ extraconvert(ltype,result,rtype);
+ conversion(rtype,result);
+ if( result== INTTYPE)
+ {
+ if( operator=='/')
+ {
+ result= DOUBLETYPE;
+ extraconvert(ltype,result,rtype);
+ conversion(rtype,result);
+ emcode("dvf",EMFLTSIZE);
+ } else
+ if( operator=='\\')
+ emcode("dvi",EMINTSIZE);
+ else
+ if( operator=='*')
+ emcode("mli",EMINTSIZE);
+ else
+ if( operator==MODSYM)
+ emcode("rmi",EMINTSIZE);
+ else error("illegal operator");
+ } else{
+ if( operator=='/')
+ emcode("dvf",EMFLTSIZE);
+ else
+ if( operator=='*')
+ emcode("mlf",EMFLTSIZE);
+ else error("illegal operator");
+ }
+ return(result);
+}
+negate(type)
+int type;
+{
+ switch(type)
+ {
+ case INTTYPE:
+ emcode("ngi",EMINTSIZE); break;
+ case DOUBLETYPE:
+ case FLOATTYPE:
+ emcode("ngf",EMFLTSIZE); break;
+ default:
+ error("Illegal operator");
+ }
+ return(type);
+}
+power(ltype,rtype)
+int ltype,rtype;
+{
+ extraconvert(ltype,DOUBLETYPE,rtype);
+ conversion(rtype,DOUBLETYPE);
+ emcode("cal","$_power");
+ emcode("asp",EMFLTSIZE);
+ emcode("asp",EMFLTSIZE);
+ emcode("lfr",EMFLTSIZE);
+ return(DOUBLETYPE);
+}
+char *typesize(ltype)
+int ltype;
+{
+ switch( ltype)
+ {
+ case INTTYPE:
+ return(EMINTSIZE);
+ case FLOATTYPE:
+ case DOUBLETYPE:
+ return(EMFLTSIZE);
+ case STRINGTYPE:
+ return(EMPTRSIZE);
+ default:
+ error("typesize:unexpected");
+ if(debug) printf("type received %d\n",ltype);
+ }
+ return(EMINTSIZE);
+}
+/*
+loadptr(s)
+Symbol *s;
+{
+ if( POINTERSIZE==WORDSIZE)
+ fprintf(tmpfile," loe l%d\n",s->symalias);
+ else
+ if( POINTERSIZE== 2*WORDSIZE)
+ fprintf(tmpfile," lde l%d\n",s->symalias);
+ else error("loadptr:unexpected pointersize");
+}
+*/
+char *typestring(type)
+int type;
+{
+ switch(type)
+ {
+ case INTTYPE:
+ return(EMINTSIZE);
+ case FLOATTYPE:
+ case DOUBLETYPE:
+ return(EMFLTSIZE);
+ case STRINGTYPE:
+ return(EMPTRSIZE);
+ default:
+ error("typestring: unexpected type");
+ }
+ return("0");
+}
+loadvar(type)
+int type;
+{
+ /* load a simple variable its address is on the stack*/
+ emcode("loi",typestring(type));
+ return(type);
+}
+loadint(value)
+int value;
+{
+ emcode("loc",itoa(value));
+ return(INTTYPE);
+}
+loaddbl(value)
+double value;
+{
+ int index;
+ index= genlabel();
+ fprintf(emfile,"l%d\n bss 8,%fF8,1\n",index,value);
+ emcode("lae",datalabel(index));
+ emcode("loi",EMFLTSIZE);
+ return(DOUBLETYPE);
+}
+loadstr(value)
+int value;
+{
+ emcode("lae",datalabel(value));
+ return(STRINGTYPE);
+}
+loadaddr(s)
+Symbol *s;
+{
+ extern Symbol *fcn;
+ int i,j;
+
+ if(debug) printf("load %s %d\n",s->symname,s->symtype);
+ if( s->symalias>0)
+ emcode("lae",datalabel(s->symalias));
+ else{
+ j= -s->symalias;
+ if(debug) printf("load parm %d\n",j);
+ fprintf(tmpfile," lal ");
+ for(i=fcn->dimensions;i>j;i--)
+ fprintf(tmpfile,"%s+",typesize(fcn->dimlimit[i-1]));
+ fprintf(tmpfile,"0\n");
+ emlinecount++;
+ /*
+ emcode("lal",datalabel(fcn->dimalias[-s->symalias]));
+ */
+ }
+ return(s->symtype);
+}
+assign(type,lt)
+int type,lt;
+{
+ extern int e1,e2;
+ conversion(lt,type);
+ exchange(e1,e2);
+ /* address is on stack already */
+ emcode("sti",typestring(type) );
+}
+storevar(lab,type)
+int lab,type;
+{
+ /*store value back */
+ emcode("lae",datalabel(lab));
+ emcode("sti",typestring(type));
+}
+
+/* maintain a stack of array references */
+int dimstk[MAXDIMENSIONS], dimtop= -1;
+Symbol *arraystk[MAXDIMENSIONS];
+
+newarrayload(s)
+Symbol *s;
+{
+ if( dimtop<MAXDIMENSIONS) dimtop++;
+ if( s->dimensions==0)
+ {
+ s->dimensions=1;
+ defarray(s);
+ }
+ dimstk[dimtop]= s->dimensions;
+ arraystk[dimtop]= s;
+ emcode("lae",datalabel(s->symalias));
+}
+endarrayload()
+{
+ return(arraystk[dimtop--]->symtype);
+}
+loadarray(type)
+int type;
+{
+ int dim;
+ Symbol *s;
+
+ if( dimtop<0 || dimtop>=MAXDIMENSIONS)
+ fatal("too many nested array references");
+ /* index expression is on top of stack */
+ s=arraystk[dimtop];
+ dim= dimstk[dimtop];
+ if( dim==0)
+ {
+ error("too many indices");
+ dimstk[dim--]=0;
+ return;
+ }
+ conversion(type,INTTYPE);
+ dim--;
+ /* first check index range */
+ fprintf(tmpfile," lae r%d\n",s->dimalias[dim]);
+ emlinecount++;
+ emcode("rck",EMINTSIZE);
+ emcode("lae",datalabel(s->dimalias[dim]));
+ emcode("aar",EMINTSIZE);
+ dimstk[dimtop]--;
+}
+storearray(type)
+{
+ /* used only in let statement */
+ extern int e1,e2;
+ exchange(e1,e2);
+ emcode("sti",typestring(type));
+}
--- /dev/null
+#include "bem.h"
+
+/* expression types for predefined functions are assembled */
+int typetable[10];
+int exprlimit;
+
+/* handle all predefined functions */
+#define cv(X) conversion(type,X); pop=X
+#define cl(X) emcode("cal",X);
+
+parm(cnt)
+int cnt;
+{
+ if( cnt> exprlimit)
+ error("Not enough arguments");
+ if( cnt < exprlimit)
+ error("Too many arguments");
+}
+
+callfcn(fcnnr,cnt)
+int fcnnr,cnt;
+{
+ int pop=DOUBLETYPE;
+ int res=DOUBLETYPE;
+ int type;
+
+
+ type= typetable[0];
+ exprlimit=cnt;
+ if(debug) printf("fcn=%d\n",fcnnr);
+ switch(fcnnr)
+ {
+ case ABSSYM: cv(DOUBLETYPE);
+ cl("$_abr");
+ parm(1);
+ break;
+ case ASCSYM: cv(STRINGTYPE);
+ cl("$_asc"); res=INTTYPE;
+ parm(1);
+ break;
+ case ATNSYM: cv(DOUBLETYPE);
+ cl("$_atn");
+ parm(1);
+ break;
+ case CDBLSYM: cv(DOUBLETYPE); return(DOUBLETYPE);;
+ case CHRSYM: cv(INTTYPE);
+ cl("$_chr"); res=STRINGTYPE;
+ parm(1);
+ break;
+ case CSNGSYM:
+ cv(DOUBLETYPE); return(DOUBLETYPE);
+ case CINTSYM: cv(INTTYPE); return(INTTYPE);
+ case COSSYM: cv(DOUBLETYPE);
+ cl("$_cos");
+ parm(1);
+ break;
+ case CVISYM: cv(STRINGTYPE);
+ cl("$_cvi"); res=INTTYPE;
+ parm(1);
+ break;
+ case CVSSYM: cv(STRINGTYPE);
+ cl("$_cvd"); res=DOUBLETYPE;
+ parm(1);
+ break;
+ case CVDSYM: cv(STRINGTYPE);
+ cl("$_cvd"); res=DOUBLETYPE;
+ parm(1);
+ break;
+ case EOFSYM:
+ if( cnt==0)
+ {
+ res= INTTYPE;
+ pop= INTTYPE;
+ emcode("loc","-1");
+ } else cv(INTTYPE);
+ cl("$_ioeof"); res=INTTYPE;
+ break;
+ case EXPSYM: cv(DOUBLETYPE);
+ cl("$_exp");
+ parm(1);
+ break;
+ case FIXSYM: cv(DOUBLETYPE);
+ cl("$_fix"); res=INTTYPE;
+ parm(1);
+ break;
+ case INPSYM:
+ case LPOSSYM:
+ case FRESYM: pop=0;
+ warning("function not supported");
+ parm(1);
+ break;
+ case HEXSYM: cv(INTTYPE);
+ cl("$_hex"); res=STRINGTYPE;
+ parm(1);
+ break;
+ case OUTSYM:
+ case INSTRSYM: cv(DOUBLETYPE);
+ cl("$_instr"); res=STRINGTYPE;
+ parm(1);
+ break;
+ case INTSYM: cv(DOUBLETYPE);
+ cl("$_fcint");
+ parm(1);
+ break;
+ case LEFTSYM: parm(2);
+ extraconvert(type, STRINGTYPE,typetable[1]);
+ type= typetable[1];
+ cv(INTTYPE);
+ cl("$_left"); res=STRINGTYPE;
+ emcode("asp",EMPTRSIZE);
+ emcode("asp",EMINTSIZE);
+ emcode("lfr",EMPTRSIZE);
+ return(STRINGTYPE);
+ case LENSYM: cv(STRINGTYPE);
+ cl("$_len"); res=INTTYPE;
+ parm(1);
+ break;
+ case LOCSYM: cv(INTTYPE);
+ cl("$_loc"); res=INTTYPE;
+ parm(1);
+ break;
+ case LOGSYM: cv(DOUBLETYPE);
+ cl("$_log");
+ parm(1);
+ break;
+ case MKISYM: cv(INTTYPE);
+ cl("$_mki"); res=STRINGTYPE;
+ parm(1);
+ break;
+ case MKSSYM: cv(DOUBLETYPE);
+ cl("$_mkd"); res=STRINGTYPE;
+ parm(1);
+ break;
+ case MKDSYM: cv(DOUBLETYPE);
+ cl("$_mkd"); res=STRINGTYPE;
+ parm(1);
+ break;
+ case OCTSYM: cv(INTTYPE);
+ cl("$_oct"); res=STRINGTYPE;
+ parm(1);
+ break;
+ case PEEKSYM: cv(INTTYPE);
+ cl("$_peek"); res=INTTYPE;
+ parm(1);
+ break;
+ case POSSYM: emcode("asp",typestring(type));
+ emcode("exa","_pos");
+ emcode("loe","_pos");
+ return(INTTYPE);
+ case RIGHTSYM: parm(2);
+ extraconvert(type, STRINGTYPE,typetable[1]);
+ type= typetable[1];
+ cv(INTTYPE);
+ cl("$_right"); res=STRINGTYPE;
+ emcode("asp",EMINTSIZE);
+ emcode("asp",EMPTRSIZE);
+ emcode("lfr",EMPTRSIZE);
+ return(STRINGTYPE);
+ case RNDSYM: if( cnt==1) pop=type; else pop=0;
+ cl("$_rnd"); res= DOUBLETYPE;
+ break;
+ case SGNSYM: cv(DOUBLETYPE);
+ cl("$_sgn"); res=INTTYPE;
+ parm(1);
+ break;
+ case SINSYM: cv(DOUBLETYPE);
+ cl("$_sin");
+ parm(1);
+ break;
+ case SPACESYM: cv(INTTYPE);
+ cl("$_space"); res=STRINGTYPE;
+ parm(1);
+ break;
+ case SPCSYM: cv(INTTYPE);
+ cl("$_spc"); res=0;
+ parm(1);
+ break;
+ case SQRSYM: cv(DOUBLETYPE);
+ cl("$_sqt");
+ parm(1);
+ break;
+ case STRSYM: cv(DOUBLETYPE);
+ cl("$_str");
+ parm(1);
+ break;
+ case STRINGSYM: cv(STRINGTYPE);
+ cl("$_string"); res=STRINGTYPE;
+ parm(1);
+ break;
+ case TABSYM: cv(INTTYPE);
+ cl("$_tab"); res=0;
+ parm(1);
+ break;
+ case TANSYM: cv(DOUBLETYPE);
+ cl("$_tan");
+ parm(1);
+ break;
+ case VALSYM: cv(STRINGTYPE);
+ cl("$atol"); res=INTTYPE;
+ parm(1);
+ break;
+ case VARPTRSYM: cv(DOUBLETYPE);
+ cl("$_valptr");
+ parm(1);
+ break;
+ default: error("unknown function");
+ }
+ if(pop)
+ emcode("asp",typestring(pop));
+ if(res)
+ emcode("lfr",typestring(res));
+ return(res);
+}
+
--- /dev/null
+#include "bem.h"
+
+/* Here we find all routines dealing with pure EM code generation */
+
+static int emlabel=1;
+genlabel() { return(emlabel++);}
+
+
+genemlabel()
+{
+ int l;
+
+ l=genlabel();
+ fprintf( emfile,"l%d\n",l);
+ return(l);
+}
+genrom()
+{
+ int l;
+ l= genemlabel();
+ fprintf(emfile," rom ");
+ return(l);
+}
+
+where()
+{
+ return(emlinecount);
+}
+exchange(blk1,blk2)
+int blk1,blk2;
+{
+ /* exchange assembler blocks */
+ if(debug) printf("exchange %d %d %d\n",blk1,blk2,emlinecount);
+ fprintf(tmpfile," exc %d,%d\n",blk2-blk1,emlinecount-blk2);
+ emlinecount++;
+}
+
+/* routines to manipulate the tmpfile */
+int emlinecount; /* count number of lines generated */
+ /* this value can be used to generate EXC */
+int tronoff=0;
+newemblock(nr)
+int nr;
+{
+ /* save location on tmpfile */
+ currline->offset= ftell(tmpfile);
+ fprintf(tmpfile,"%d\n",currline->emlabel);
+ fprintf(tmpfile," lin %d\n",nr);
+ emlinecount += 2;
+ if( tronoff || traceflag) emcode("cal","$_trace");
+}
+
+emcode(operation,params)
+char *operation,*params;
+{
+ fprintf(tmpfile," %s %s\n",operation,params);
+ emlinecount++;
+}
+/* Handle data statements */
+int dataused=0;
+List *datalist=0;
+datastmt()
+{
+ List *l,*l1;
+ l= (List *) salloc(sizeof(List));
+ l->linenr= currline->linenr;
+ l->emlabel= (long) ftell(datfile);
+ if( datalist==0)
+ {
+ datalist=l;
+ datfile= fopen(datfname,"w");
+ if( datfile==NULL) fatal("improper file creation permission");
+ }else{
+ l1= datalist;
+ while(l1->nextlist) l1= l1->nextlist;
+ l1->nextlist=l;
+ }
+
+ dataused=1;
+}
+datatable()
+{
+ List *l;
+ int line=0;
+
+ /* called at end to generate the data seek table */
+ fprintf(emfile," exa _seektable\n");
+ fprintf(emfile,"_seektable\n");
+ l= datalist;
+ while(l)
+ {
+ fprintf(emfile," rom %d,%d\n", l->linenr,line++);
+ l= l->nextlist;
+ }
+ fprintf(emfile," rom 0,0\n");
+}
+
+/* ERROR and exception handling */
+exceptstmt(lab)
+int lab;
+{
+ /* exceptions to subroutines are supported only */
+ extern int gosubcnt;
+ List *l;
+
+ emcode("loc",itoa(gosubcnt));
+ l= (List *) gosublabel();
+ l->emlabel= gotolabel(lab);
+ emcode("cal","$_trpset");
+ emcode("asp",EMINTSIZE);
+}
+
+errorstmt(exprtype)
+int exprtype;
+{
+ /* convert expression to a valid error number */
+ /* obtain the message and print it */
+ emcode("cal","$error");
+ emcode("asp",typesize(exprtype));
+}
+
+/* BASIC IO */
+openstmt(recsize)
+int recsize;
+{
+ emcode("loc",itoa(recsize));
+ emcode("cal","$_opnchn");
+ emcode("asp",EMPTRSIZE);
+ emcode("asp",EMPTRSIZE);
+ emcode("asp",EMINTSIZE);
+}
+
+
+printstmt(exprtype)
+int exprtype;
+{
+ switch(exprtype)
+ {
+ case INTTYPE:
+ emcode("cal","$_prinum");
+ emcode("asp",typestring(INTTYPE));
+ break;
+ case FLOATTYPE:
+ case DOUBLETYPE:
+ emcode("cal","$_prfnum");
+ emcode("asp",typestring(DOUBLETYPE));
+ break;
+ case STRINGTYPE:
+ emcode("cal","$_prstr");
+ emcode("asp",EMPTRSIZE);
+ break;
+ case 0: /* result of tab function etc */
+ break;
+ default:
+ error("printstmt:unexpected");
+ }
+}
+zone(i)
+int i;
+{
+ if( i)emcode("cal","$_zone");
+}
+writestmt(exprtype,comma)
+int exprtype,comma;
+{
+ if( comma) emcode("cal","$_wrcomma");
+ switch(exprtype)
+ {
+ case INTTYPE:
+ emcode("cal","$_wrint");
+ break;
+ case FLOATTYPE:
+ case DOUBLETYPE:
+ emcode("cal","$_wrint");
+ break;
+ case STRINGTYPE:
+ emcode("cal","$_wrstr");
+ break;
+ default:
+ error("printstmt:unexpected");
+ }
+ emcode("asp",EMPTRSIZE);
+}
+restore(lab)
+int lab;
+{
+ /* save this information too */
+
+ emcode("loc",itoa(0));
+ emcode("cal","$_setchannel");
+ emcode("asp",EMINTSIZE);
+ emcode("loc",itoa(lab));
+ emcode("cal","$_restore");
+ emcode("asp",EMINTSIZE);
+}
+prompt(qst)
+int qst;
+{
+ setchannel(-1);
+ emcode("cal","$_prstr");
+ emcode("asp",EMPTRSIZE);
+ if(qst) emcode("cal","$_qstmark");
+}
+linestmt(type)
+int type;
+{
+ if( type!= STRINGTYPE)
+ error("String variable expected");
+ emcode("cal","$_rdline");
+ emcode("asp",EMPTRSIZE);
+}
+readelm(type)
+int type;
+{
+ switch(type)
+ {
+ case INTTYPE:
+ emcode("cal","$_readint");
+ break;
+ case FLOATTYPE:
+ case DOUBLETYPE:
+ emcode("cal","$_readflt");
+ break;
+ case STRINGTYPE:
+ emcode("cal","$_readstr");
+ break;
+ default:
+ error("readelm:unexpected type");
+ }
+ emcode("asp",EMPTRSIZE);
+}
+
+/* Swap exchanges the variable values */
+swapstmt(ltype,rtype)
+int ltype, rtype;
+{
+ if( ltype!= rtype)
+ error("Type mismatch");
+ else
+ switch(ltype)
+ {
+ case INTTYPE:
+ emcode("cal","$_intswap");
+ break;
+ case FLOATTYPE:
+ case DOUBLETYPE:
+ emcode("cal","$_fltswap");
+ break;
+ case STRINGTYPE:
+ emcode("cal","$_strswap");
+ break;
+ default:
+ error("swap:unexpected");
+ }
+ emcode("asp",EMPTRSIZE);
+ emcode("asp",EMPTRSIZE);
+}
+
+/* input/output handling */
+setchannel(val)
+int val;
+{ /* obtain file descroption */
+ emcode("loc",itoa(val));
+ emcode("cal","$_setchannel");
+ emcode("asp",EMINTSIZE);
+}
+/* The if-then-else statements */
+ifstmt(type)
+int type;
+{
+ /* This BASIC follows the True= -1 rule */
+ int nr;
+
+ nr= genlabel();
+ if( type == INTTYPE)
+ emcode("zeq",instrlabel(nr));
+ else
+ if( type == FLOATTYPE)
+ {
+ emcode("lae","fltnull");
+ emcode("loi",EMFLTSIZE);
+ emcode("cmf",EMFLTSIZE);
+ emcode("zeq",instrlabel(nr));
+ }
+ else error("Integer or Float expected");
+ return(nr);
+}
+thenpart( elselab)
+int elselab;
+{
+ int nr;
+
+ nr=genlabel();
+ emcode("bra",instrlabel(nr));
+ fprintf(tmpfile,"%d\n",elselab);
+ emlinecount++;
+ return(nr);
+}
+elsepart(lab)int lab;
+{
+ fprintf(tmpfile,"%d\n",lab); emlinecount++;
+}
+/* generate code for the for-statement */
+#define MAXFORDEPTH 20
+struct FORSTRUCT{
+ Symbol *loopvar; /* loop variable */
+ int initaddress;
+ int limitaddress;
+ int stepaddress;
+ int fortst; /* variable limit test */
+ int forinc; /* variable increment code */
+ int forout; /* end of loop */
+} fortable[MAXFORDEPTH];
+int forcnt= -1;
+
+forinit(s)
+Symbol *s;
+{
+ int type;
+ struct FORSTRUCT *f;
+
+ dcltype(s);
+ type= s->symtype;
+ forcnt++;
+ if( (type!=INTTYPE && type!=FLOATTYPE && type!=DOUBLETYPE) ||
+ s->dimensions)
+ error("Illegal loop variable");
+ if( forcnt >=MAXFORDEPTH)
+ error("too many for statements");
+ else{
+ f=fortable+forcnt;
+ f->loopvar=s;
+ f->fortst=genlabel();
+ f->forinc=genlabel();
+ f->forout=genlabel();
+ /* generate space for temporary objects */
+ f->initaddress= dclspace(type);
+ f->limitaddress= dclspace(type);
+ f->stepaddress= dclspace(type);
+ }
+}
+forexpr(type)
+int type;
+{
+ /* save start value of loop variable in a save place*/
+ /* to avoid clashing with final value and step expression */
+ int result;
+ result= fortable[forcnt].loopvar->symtype;
+ conversion(type,result);
+ storevar(fortable[forcnt].initaddress, result);
+}
+forlimit(type)
+int type;
+{
+ /* save the limit value too*/
+ int result;
+ result= fortable[forcnt].loopvar->symtype;
+ conversion(type,result);
+ storevar(fortable[forcnt].limitaddress, result);
+}
+forskipped(f)
+struct FORSTRUCT *f;
+{
+ int type;
+ type= f->loopvar->symtype;
+ /* evaluate lower bound times sign of step */
+ emcode("lae",datalabel(f->initaddress));
+ loadvar(type);
+ conversion(type,DOUBLETYPE);
+ emcode("lae",datalabel(f->stepaddress));
+ loadvar(type);
+ conversion(type,DOUBLETYPE);
+ emcode("cal","$_sgn");
+ emcode("asp",EMFLTSIZE);
+ emcode("lfr",EMINTSIZE);
+ conversion(INTTYPE,DOUBLETYPE);
+ emcode("mlf",EMFLTSIZE);
+ /* evaluate higher bound times sign of step */
+ emcode("lae",datalabel(f->limitaddress));
+ loadvar(type);
+ conversion(type,DOUBLETYPE);
+ emcode("lae",datalabel(f->stepaddress));
+ loadvar(type);
+ conversion(type,DOUBLETYPE);
+ emcode("cal","$_sgn");
+ emcode("asp",EMFLTSIZE);
+ emcode("lfr",EMINTSIZE);
+ conversion(INTTYPE,DOUBLETYPE);
+ emcode("mlf",EMFLTSIZE);
+ /* skip condition */
+ emcode("cmf",EMFLTSIZE);
+ emcode("zgt",instrlabel(f->forout));
+}
+forstep(type)
+int type;
+{
+ int result;
+ int varaddress;
+ struct FORSTRUCT *f;
+
+ f= fortable+forcnt;
+ result= f->loopvar->symtype;
+ varaddress= f->loopvar->symalias;
+ conversion(type,result);
+ storevar(f->stepaddress, result);
+ /* all information available, generate for-loop head */
+ /* test for ingoring loop */
+ forskipped(f);
+ /* set initial value */
+ emcode("lae",datalabel(f->initaddress));
+ loadvar(result);
+ emcode("lae",datalabel(varaddress));
+ emcode("sti",typestring(result));
+ emcode("bra",instrlabel(f->fortst));
+ /* increment loop variable */
+ fprintf(tmpfile,"%d\n",f->forinc);
+ emlinecount++;
+ emcode("lae",datalabel(varaddress));
+ loadvar(result);
+ emcode("lae",datalabel(f->stepaddress));
+ loadvar(result);
+ if(result == INTTYPE)
+ emcode("adi",EMINTSIZE);
+ else emcode("adf",EMFLTSIZE);
+ emcode("lae",datalabel(varaddress));
+ emcode("sti",typestring(result));
+ /* test boundary */
+ fprintf(tmpfile,"%d\n",f->fortst);
+ emlinecount++;
+ emcode("lae",datalabel(varaddress));
+ loadvar(result);
+ emcode("lae",datalabel(f->limitaddress));
+ loadvar(result);
+ if(result == INTTYPE)
+ emcode("cmi",EMINTSIZE);
+ else emcode("cmf",EMFLTSIZE);
+ emcode("zgt",instrlabel(f->forout));
+}
+nextstmt(s)
+Symbol *s;
+{
+ if(forcnt>MAXFORDEPTH || forcnt<0 ||
+ ( s && s!= fortable[forcnt].loopvar))
+ error("NEXT without FOR");
+ else{
+ /* address of variable is on top of stack ! */
+ emcode("bra",instrlabel(fortable[forcnt].forinc));
+ fprintf(tmpfile,"%d\n",fortable[forcnt].forout);
+ forcnt--;
+ }
+}
+
+pokestmt(type1,type2)
+int type1,type2;
+{
+ conversion(type1,INTTYPE);
+ conversion(type2,INTTYPE);
+ emcode("cal","$_poke");
+ emcode("asp",EMINTSIZE);
+ emcode("asp",EMINTSIZE);
+}
+
+/* generate code for the while statement */
+#define MAXDEPTH 20
+
+int whilecnt, whilelabels[MAXDEPTH][2]; /*0=head,1=out */
+
+whilestart()
+{
+ whilecnt++;
+ if( whilecnt==MAXDEPTH)
+ fatal("too many nestings");
+ /* gendummy label in graph */
+ newblock(-1);
+ whilelabels[whilecnt][0]= currline->emlabel;
+ whilelabels[whilecnt][1]= genlabel();
+ fprintf(tmpfile,"%d\n", whilelabels[whilecnt][0]);
+ emlinecount++;
+}
+whiletst(exprtype)
+int exprtype;
+{
+ /* test expression type */
+ conversion(exprtype,INTTYPE);
+ fprintf(tmpfile," zeq *%d\n",whilelabels[whilecnt][1]);
+ emlinecount++;
+}
+wend()
+{
+ if( whilecnt<1)
+ error("not part of while statement");
+ else{
+ fprintf(tmpfile," bra *%d\n",whilelabels[whilecnt][0]);
+ fprintf(tmpfile,"%d\n",whilelabels[whilecnt][1]);
+ emlinecount++;
+ emlinecount++;
+ whilecnt--;
+ }
+}
+
+/* generate code for the final version */
+prologcode()
+{
+ /* generate the EM prolog code */
+ fprintf(emfile,"fltnull\n con 0,0,0,0\n");
+ fprintf(emfile,"dummy2\n con 0,0,0,0\n");
+ fprintf(emfile,"tronoff\n con 0\n");
+ fprintf(emfile,"dummy1\n con 0,0,0,0\n");
+ fprintf(emfile," exa _iomode\n_iomode\n rom \"O\"\n");
+ fprintf(emfile," exa _errsym\n");
+ fprintf(emfile,"_errsym\n bss 2,0,1\n");
+ fprintf(emfile," exa _erlsym\n");
+ fprintf(emfile,"_erlsym\n bss 2,0,1\n");
+}
+
+prolog2()
+{
+ fprintf(emfile," exp $main\n");
+ fprintf(emfile," pro $main,0\n");
+ fprintf(emfile," mes 3\n");
+ fprintf(emfile," mes 9,0\n");
+ /* Trap handling */
+ fprintf(emfile," cal $_ini_trp\n");
+ fprintf(emfile," exa trpbuf\n");
+ fprintf(emfile," lae trpbuf\n");
+ fprintf(emfile," cal $setjmp\n");
+ fprintf(emfile," asp 4\n");
+ fprintf(emfile," lfr %s\n",EMINTSIZE);
+ fprintf(emfile," dup %s\n",EMINTSIZE);
+ fprintf(emfile," zeq *0\n");
+ fprintf(emfile," lae returns\n");
+ fprintf(emfile," csa %s\n",EMINTSIZE);
+ fprintf(emfile,"0\n");
+ fprintf(emfile," asp EM_WSIZE\n");
+ /* when data lists are used open its file */
+ if( dataused)
+ {
+ fprintf(emfile," loc 0\n");
+ fprintf(emfile," cal $_setchannel\n");
+ fprintf(emfile," asp EM_WSIZE\n");
+ fprintf(emfile,"datfname\n rom \"%s\"\n", datfname);
+ fprintf(emfile," lae datfname\n");
+ fprintf(emfile," cal $_opnchn\n");
+ fprintf(emfile," asp EM_PSIZE\n");
+ }
+ datatable();
+}
+
+epilogcode()
+{
+ /* finalization code */
+ int nr;
+ nr= genlabel();
+ fprintf(emfile," bra *%d\n",nr);
+ genreturns();
+ fprintf(emfile,"%d\n",nr);
+ fprintf(emfile," loc 0\n");
+ fprintf(emfile," cal $_hlt\n");
+ fprintf(emfile," end 0\n");
+ fprintf(emfile," mes 4,4\n");
+}
--- /dev/null
+#include "bem.h"
+
+List *forwardlabel=0;
+
+/* Line management is handled here */
+
+Linerecord *srchline(nr)
+int nr;
+{
+ Linerecord *l;
+ for(l=firstline;l && l->linenr<=nr;l= l->nextline)
+ if( l->linenr== nr) return(l);
+ return(0);
+}
+List *srchforward(nr)
+int nr;
+{
+ List *l;
+ for(l=forwardlabel;l ;l=l->nextlist)
+ if( l->linenr== nr) return(l);
+ return(0);
+}
+linewarnings()
+{
+ List *l;
+ extern int errorcnt;
+ l= forwardlabel;
+ while(l)
+ {
+ if( !srchline(l->linenr))
+ {
+ printf("ERROR: line %d not defined\n",l->linenr);
+ errorcnt++;
+ }
+ l=l->nextlist;
+ }
+}
+
+newblock(nr)
+int nr;
+{
+ Linerecord *l;
+ List *frwrd;
+
+ if( debug) printf("newblock at %d\n",nr);
+ if( nr>0 && currline && currline->linenr>= nr)
+ {
+ if( debug) printf("old line:%d\n",currline->linenr);
+ error("Lines out of sequence");
+ }
+
+ frwrd=srchforward(nr);
+ if( frwrd && debug) printf("forward found %d\n",frwrd->emlabel);
+ l= srchline(nr);
+ if( l)
+ {
+ error("Line redefined");
+ nr= -genlabel();
+ }
+
+ /* make new EM block structure */
+ l= (Linerecord *) salloc(sizeof(*l));
+ l->emlabel= frwrd? frwrd->emlabel: genlabel();
+ l->linenr= nr;
+ /* save offset into tmpfile too */
+ l->offset = (long) ftell(tmpfile);
+ l->codelines= emlinecount;
+
+ /* insert this record */
+ if( firstline)
+ {
+ currline->nextline=l;
+ l->prevline= currline;
+ lastline= currline=l;
+ } else
+ firstline = lastline =currline=l;
+}
+
+gotolabel(nr)
+int nr;
+{
+ /* simulate a goto statement in the line record table */
+ Linerecord *l1;
+ List *ll;
+
+ if(debug) printf("goto label %d\n",nr);
+ /* update currline */
+ ll= (List *) salloc( sizeof(*ll));
+ ll-> linenr=nr;
+ ll-> nextlist= currline->gotos;
+ currline->gotos= ll;
+
+ /* try to generate code */
+ l1= srchline(nr);
+ if( (ll=srchforward(nr))!=0)
+ nr= ll->emlabel;
+ else
+ if( l1==0)
+ {
+ /* declare forward label */
+ if(debug) printf("declare forward %d\n",nr);
+ ll= (List *) salloc( sizeof(*ll));
+ ll->emlabel= genlabel();
+ ll-> linenr=nr;
+ ll->nextlist= forwardlabel;
+ forwardlabel= ll;
+ nr= ll->emlabel;
+ } else
+ nr= l1->emlabel;
+ return(nr);
+}
+gotostmt(nr)
+int nr;
+{
+ emcode("bra",instrlabel(gotolabel(nr)));
+}
+/* GOSUB-return, assume that proper entries are made to subroutines
+ only. The return statement is triggered by a fake constant label */
+
+List *gosubhead, *gotail;
+int gosubcnt=1;
+
+List *gosublabel()
+{
+ List *l;
+ int n;
+
+ l= (List *) salloc(sizeof(List));
+ l->nextlist=0;
+ l->emlabel=genlabel();
+ if( gotail){
+ gotail->nextlist=l;
+ gotail=l;
+ } else gotail= gosubhead=l;
+ gosubcnt++;
+ return(l);
+}
+gosubstmt(lab)
+int lab;
+{
+ List *l;
+ int nr,n;
+
+ n=gosubcnt;
+ l= gosublabel();
+ nr=gotolabel(lab);
+ emcode("loc",itoa(n)); /*return index */
+ emcode("cal","$_gosub"); /* administer legal return */
+ emcode("asp",EMINTSIZE);
+ emcode("bra",instrlabel(nr));
+ fprintf(tmpfile,"%d\n",l->emlabel);
+ emlinecount++;
+}
+genreturns()
+{
+ int nr;
+ nr= genlabel();
+ fprintf(emfile,"returns\n");
+ fprintf(emfile," rom *%d,1,%d\n",nr,gosubcnt-1);
+ while( gosubhead)
+ {
+ fprintf(emfile," rom *%d\n",gosubhead->emlabel);
+ gosubhead= gosubhead->nextlist;
+ }
+ fprintf(emfile,"%d\n",nr);
+ fprintf(emfile," loc 1\n");
+ fprintf(emfile," cal $error\n");
+}
+returnstmt()
+{
+ emcode("cal","$_retstmt"); /* ensure legal return*/
+ emcode("lfr",EMINTSIZE);
+ fprintf(tmpfile," lae returns\n");
+ emlinecount++;
+ emcode("csa",EMINTSIZE);
+}
+/* compound goto-gosub statements */
+List *jumphead,*jumptail;
+int jumpcnt;
+
+jumpelm(nr)
+int nr;
+{
+ List *l;
+
+ l= (List *) salloc(sizeof(List));
+ l->emlabel= gotolabel(nr);
+ l->nextlist=0;
+ if( jumphead==0) jumphead= jumptail= l;
+ else {
+ jumptail->nextlist=l;
+ jumptail=l;
+ }
+ jumpcnt++;
+}
+ongotostmt(type)
+int type;
+{
+ /* generate the code itself, index in on top of the stack */
+ /* blurh, store the number of entries in the descriptor */
+ int firstlabel;
+ int descr;
+ List *l;
+ /* create descriptor first */
+ descr= genlabel();
+ firstlabel=genlabel();
+ fprintf(tmpfile,"l%d\n",descr); emlinecount++;
+ fprintf(tmpfile," rom *%d,1,%d\n",firstlabel,jumpcnt); emlinecount++;
+ l= jumphead;
+ while( l)
+ {
+ fprintf(tmpfile," rom *%d\n",l->emlabel); emlinecount++;
+ l= l->nextlist;
+ }
+ jumphead= jumptail=0; jumpcnt=0;
+ if(debug) printf("ongotst:%d labels\n", jumpcnt);
+ conversion(type,INTTYPE);
+ emcode("lae",datalabel(descr));
+ emcode("csa",EMINTSIZE);
+ fprintf(tmpfile,"%d\n",firstlabel); emlinecount++;
+}
+ongosubstmt(type)
+int type;
+{
+ List *l;
+ int firstlabel;
+ int descr;
+ /* create descriptor first */
+ descr= genlabel();
+ firstlabel=genlabel();
+ fprintf(tmpfile,"l%d\n",descr); emlinecount++;
+ fprintf(tmpfile," rom *%d,1,%d\n",firstlabel,jumpcnt); emlinecount++;
+ l= jumphead;
+ while( l)
+ {
+ fprintf(tmpfile," rom *%d\n",l->emlabel); emlinecount++;
+ l= l->nextlist;
+ }
+ jumphead= jumptail=0; jumpcnt=0;
+
+ l= (List *) salloc(sizeof(List));
+ l->nextlist=0;
+ l->emlabel=firstlabel;
+ if( gotail){
+ gotail->nextlist=l;
+ gotail=l;
+ } else gotail= gosubhead=l;
+ /* save the return point of the gosub */
+ emcode("loc",itoa(gosubcnt));
+ emcode("cal","$_gosub");
+ emcode("asp",EMINTSIZE);
+ gosubcnt++;
+ /* generate gosub */
+ conversion(type,INTTYPE);
+ emcode("lae",datalabel(descr));
+ emcode("csa",EMINTSIZE);
+ fprintf(tmpfile,"%d\n",firstlabel);
+ emlinecount++;
+}
+
+/* REGION ANALYSIS and FINAL VERSION GENERATION */
+
+simpleprogram()
+{
+ char buf[512];
+ int length;
+
+ /* a small EM programs has been found */
+ prologcode();
+ prolog2();
+ fclose(tmpfile);
+ tmpfile= fopen(tmpfname,"r");
+ if( tmpfile==NULL)
+ fatal("tmp file disappeared");
+ while( (length=fread(buf,1,512,tmpfile)) != 0)
+ fwrite(buf,1,length,emfile);
+ epilogcode();
+ unlink(tmpfname);
+}
--- /dev/null
+#include "bem.h"
+
+/* generate temporary files etc */
+
+FILE *emfile;
+FILE *tmpfile;
+FILE *datfile;
+
+initialize()
+{
+ sprintf(tmpfname,"/tmp/abc%d",getpid());
+ strcpy(datfname,program);
+ strcat(datfname,".d");
+ yyin= fopen(inpfile,"r");
+ emfile= fopen(outfile,"w");
+ tmpfile= fopen(tmpfname,"w");
+ if( yyin==NULL || emfile== NULL || tmpfile== NULL )
+ fatal("Improper file permissions");
+ fillkex(); /* initialize symbol table */
+ fprintf(emfile,"#\n");
+ fprintf(emfile," mes 2,EM_WSIZE,EM_PSIZE\n");
+ initdeftype(); /* set default symbol declarers */
+}
--- /dev/null
+#include "bem.h"
+
+int listing; /* -l listing required */
+int debug; /* -d compiler debugging */
+int wflag=1; /* -w no warnings */
+int hflag=0; /* -h<number> to split EM program */
+int traceflag=0; /* generate line tracing code */
+int nolins=0; /* generate no LIN statements */
+
+parseparams(argc,argv)
+int argc;
+char **argv;
+{
+ int i,j,k;
+ char *ext;
+
+ j=k=0;
+ if(argc< 4)
+ {
+ fprintf(stderr,"usage %s <flags> <file>.i <file>.e <source>\n", argv[0]);
+ exit(-1);
+ }
+ for(i=1;i<argc;i++)
+ if( argv[i][0]=='-')
+ switch(argv[i][1])
+ {
+ case 'D': yydebug++; break; /* parser debugging */
+ case 't': traceflag++; break; /* line tracing */
+ case 'h':/* split EM file */
+ hflag=0;
+ threshold= (long) atol(argv[i][2]);
+ if( threshold==0)
+ threshold= THRESHOLD;
+ break;
+ case 'd': debug++; break;
+ case 'l': nolins++; break; /* no EM lin statements */
+ case 'E': listing++; break; /* generate full listing */
+ } else {
+ /* new input file */
+ ext= argv[i]+strlen(argv[i])-1;
+ if( *(ext-1) != '.')
+ /* should be the source file name */
+ program= argv[i];
+ else
+ if( *ext == 'i')
+ inpfile= argv[i];
+ else
+ if( *ext == 'e')
+ outfile= argv[i];
+ }
+}
--- /dev/null
+#include "bem.h"
+
+/* Split the intermediate code into procedures.
+ This is necessary to make the EM code fit on
+ smaller machines. (for the Peephole optimizer!)
+*/
+
+/* Heuristic is to collect all basic blocks of more then THRESHOLD
+ em instructions into a procedure
+*/
+
+int procnum;
+int threshold; /* can be set by the user */
+
+
+fix(lnr)
+int lnr;
+{
+ /* this block may not be moved to a procedure */
+ Linerecord *lr;
+
+ if(debug) printf("fixate %d\n",lnr);
+ for(lr= firstline;lr; lr=lr->nextline)
+ if( lr->linenr == lnr)
+ lr->fixed=1;
+}
+
+fixblock(l)
+List *l;
+{
+ while(l)
+ {
+ fix(l->linenr);
+ l=l->nextlist;
+ }
+}
+phase1()
+{
+ /* copy all offloaded blocks */
+ Linerecord *lr, *lf,*lr2;
+ int blksize;
+
+ lf= lr= firstline;
+ blksize= lr->codelines;
+ while( lr)
+ {
+ if( lr->fixed){
+ if( !lf->fixed && blksize>threshold)
+ {
+ /*move block */
+ if(debug) printf("%d %d->%d moved\n",
+ blksize,lf->linenr, lr->linenr);
+ }
+ lf= lr;
+ blksize= lr->codelines;
+ }
+ lr= lr->nextline;
+ }
+}
+phase2()
+{
+ /* copy main procedure */
+ prolog2();
+ epilogcode();
+}
+split()
+{
+ /* selectively copy the intermediate code to procedures */
+ Linerecord *lr;
+
+ if( debug) printf("split EM code using %d\n",threshold);
+
+ /* First consolidate the goto's and caller's */
+ lr= firstline;
+ while(lr)
+ {
+ fixblock(lr->callers);
+ fixblock(lr->gotos);
+ lr= lr->nextline;
+ }
+
+ /* Copy the temporary file piecewise */
+ prologcode();
+ phase1();
+ phase2();
+}
--- /dev/null
+#include "bem.h"
+/* Symboltable management module */
+
+int deftype[128]; /* default type declarer */
+ /* which may be set by OPTION BASE */
+
+initdeftype()
+{
+ int i;
+ for(i='a';i<='z';i++) deftype[i]= DOUBLETYPE;
+ for(i='A';i<='Z';i++) deftype[i]= DOUBLETYPE;
+}
+
+int indexbase=0; /* start of array subscripting */
+
+Symbol *firstsym = NIL;
+Symbol *alternate = NIL;
+
+Symbol *srchsymbol(str)
+char *str;
+{
+ Symbol *s;
+ /* search symbol table entry or create it */
+ if(debug) printf("srchsymbol %s\n",str);
+ s=firstsym;
+ while(s)
+ {
+ if( strcmp(s->symname,str)==0) return(s);
+ s= s->nextsym;
+ }
+ /* search alternate list */
+ s=alternate;
+ while(s)
+ {
+ if( strcmp(s->symname,str)==0) return(s);
+ s= s->nextsym;
+ }
+ /* not found, create an emty slot */
+ s= (Symbol *) salloc(sizeof(Symbol));
+ s->symtype= DEFAULTTYPE;
+ s->nextsym= firstsym;
+ s->symname= (char *) salloc(strlen(str)+1);
+ strcpy(s->symname,str);
+ firstsym= s;
+ if(debug) printf("%s allocated\n",str);
+ return(s);
+}
+
+dcltype(s)
+Symbol *s;
+{
+ /* type declarer */
+ int type;
+ if( s->isparam) return;
+ type=s->symtype;
+ if(type==DEFAULTTYPE)
+ /* use the default rule */
+ type= deftype[*s->symname];
+ /* generate the emlabel too */
+ if( s->symalias==0)
+ s->symalias= dclspace(type);
+ s->symtype= type;
+ if(debug) printf("symbol set to %d\n",type);
+}
+dclarray(s)
+Symbol *s;
+{
+ int i; int size;
+
+ if( s->symtype==DEFAULTTYPE) s->symtype= DOUBLETYPE;
+ if(debug) printf("generate space and descriptors for %d\n",s->symtype);
+ if(debug) printf("dim %d\n",s->dimensions);
+ s->symalias= genlabel();
+ /* generate descriptors */
+ size=1;
+ for(i=0;i<s->dimensions;i++)
+ s->dimalias[i]= genlabel();
+ for(i=s->dimensions-1;i>=0;i--)
+ {
+ fprintf(emfile,"l%d\n rom %d,%d,%d*%s\n",
+ s->dimalias[i],
+ indexbase,
+ s->dimlimit[i]-indexbase,
+ size, typesize(s->symtype));
+ size = size* (s->dimlimit[i]+1-indexbase);
+ }
+ if(debug) printf("size=%d\n",size);
+ /* size of stuff */
+ fprintf(emfile,"l%d\n bss %d*%s,0,1\n",
+ s->symalias,size,typesize(s->symtype));
+ /* Generate the range check descriptors */
+ for( i= 0; i<s->dimensions;i++)
+ fprintf(emfile,"r%d\n rom %d,%d\n",
+ s->dimalias[i],
+ indexbase,
+ s->dimlimit[i]);
+
+}
+defarray(s)
+Symbol *s;
+{
+ /* array is used without dim statement, set default limits */
+ int i;
+ for(i=0;i<s->dimensions;i++) s->dimlimit[i]=10;
+ dclarray(s);
+}
+dclspace(type)
+{
+ int nr;
+ nr= genemlabel();
+ switch( type)
+ {
+ case STRINGTYPE:
+ fprintf(emfile," bss %s,0,1\n",EMPTRSIZE);
+ break;
+ case INTTYPE:
+ fprintf(emfile," bss %s,0,1\n",EMINTSIZE);
+ break;
+ case FLOATTYPE:
+ case DOUBLETYPE:
+ fprintf(emfile," bss 8,0.0F %s,1\n",EMFLTSIZE);
+ break;
+ }
+ return(nr);
+}
+
+/* SOME COMPILE TIME OPTIONS */
+optionbase(ival)
+int ival;
+{
+ if( ival<0 || ival>1)
+ error("illegal option base value");
+ else indexbase=ival;
+}
+
+setdefaulttype(type)
+int type;
+{
+ extern char *cptr;
+ char first,last,i;
+
+ /* handcrafted parser for letter ranges */
+ if(debug) printf("deftype:%s\n",cptr);
+ while( isspace(*cptr)) cptr++;
+ if( !isalpha(*cptr))
+ error("letter expected");
+ first= *cptr++;
+ if(*cptr=='-')
+ {
+ /* letter range */
+ cptr++;
+ last= *cptr;
+ if( !isalpha(last))
+ error("letter expected");
+ else for(i=first;i<=last;i++) deftype[i]= type;
+ cptr++;
+ } else deftype[first]=type;
+ if( *cptr== ',')
+ {
+ cptr++;
+ setdefaulttype(type); /* try again */
+ }
+}
+
+Symbol *fcn;
+
+newscope(s)
+Symbol *s;
+{
+ if(debug) printf("new scope for %s\n",s->symname);
+ alternate= firstsym;
+ firstsym = NIL;
+ fcn=s;
+ s->isfunction=1;
+ if( fcn->dimensions)
+ error("Array redeclared");
+ if( fcn->symtype== DEFAULTTYPE)
+ fcn->symtype=DOUBLETYPE;
+}
+/* User defined functions */
+heading( )
+{
+ char procname[50];
+ sprintf(procname,"$_%s",fcn->symname);
+ emcode("pro",procname);
+ if( fcn->symtype== DEFAULTTYPE)
+ fcn->symtype= DOUBLETYPE;
+}
+fcnsize(s)
+Symbol *s;
+{
+ /* generate portable function size */
+ int i;
+ for(i=0;i<fcn->dimensions;i++)
+ fprintf(tmpfile,"%s+",typesize(fcn->dimlimit[i]));
+ fprintf(tmpfile,"0\n"); emlinecount++;
+}
+endscope(type)
+int type;
+{
+ Symbol *s;
+
+ if( debug) printf("endscope");
+ conversion(type,fcn->symtype);
+ emcode("ret", typestring(fcn->symtype));
+ /* generate portable EM code */
+ fprintf(tmpfile," end ");
+ fcnsize(fcn);
+ s= firstsym;
+ while(s)
+ {
+ firstsym = s->nextsym;
+ free(s);
+ s= firstsym;
+ }
+ firstsym= alternate;
+ alternate = NIL;
+ fcn=NIL;
+}
+
+dclparm(s)
+Symbol *s;
+{
+ int i,size=0;
+ if( s->symtype== DEFAULTTYPE)
+ s->symtype= DOUBLETYPE;
+ s->isparam=1;
+ fcn->dimlimit[fcn->dimensions]= s->symtype;
+ fcn->dimensions++;
+ /*
+ OLD STUFF
+ for(i=fcn->dimensions;i>0;i--)
+ fcn->dimalias[i]= fcn->dimalias[i-1];
+ */
+ /*fcn->parmsize += typesize(s->symtype);*/
+ /* fcn->dimalias[0]= -typesize(s->symtype)-fcn->dimalias[1];*/
+ s->symalias= -fcn->dimensions;
+ if( debug) printf("parameter %d offset %d\n",fcn->dimensions-1,-size);
+}
+/* unfortunately function calls have to be stacked as well */
+#define MAXNESTING 50
+Symbol *fcntable[MAXNESTING];
+int fcnindex= -1;
+
+fcncall(s)
+Symbol *s;
+{
+ if( !s->isfunction)
+ error("Function not declared");
+ else{
+ fcn= s;
+ fcnindex++;
+ fcntable[fcnindex]=s;
+ }
+}
+fcnend(fcntype, parmcount)
+int fcntype, parmcount;
+{
+ int type;
+ /* check number of arguments */
+ if( parmcount <fcn->dimensions)
+ error("not enough parameters");
+ if( parmcount >fcn->dimensions)
+ error("too many parameters");
+ fprintf(tmpfile," cal $_%s\n",fcn->symname);
+ emlinecount++;
+ fprintf(tmpfile," asp ");
+ fcnsize(fcn);
+ emcode("lfr",typestring(fcn->symtype));
+ type= fcn->symtype;
+ fcnindex--;
+ if( fcnindex>=0)
+ fcn= fcntable[fcnindex];
+ return(type);
+}
+callparm(ind,type)
+int ind,type;
+{
+ if( fcnindex<0) error("unexpected parameter");
+
+ if( ind >= fcn->dimensions)
+ error("too many parameters");
+ else
+ conversion(type,fcn->dimlimit[ind]);
+}
--- /dev/null
+#include "bem.h"
+
+#define abs(X) (X>=0?X:-X)
+/* Miscelaneous routines can be found here */
+
+int errorcnt;
+
+warning(str)
+char *str;
+{
+ printf("WARNING:%s\n",str);
+}
+error(str)
+char *str;
+{
+ extern int listing,yylineno;
+ if( !listing) printf("LINE %d:",yylineno);
+ printf("ERROR:%s\n",str);
+ errorcnt++;
+}
+fatal(str)
+char *str;
+{
+ printf("FATAL:%s\n",str);
+ exit(-1);
+}
+notyetimpl()
+{
+ printf("WARNING: not yet implemented\n");
+}
+illegalcmd()
+{
+ printf("WARNING: illegal command\n");
+}
+char *itoa(i)
+int i;
+{
+ static char buf[30];
+ sprintf(buf,"%d",i);
+ return(buf);
+}
+char *instrlabel(i)
+int i;
+{
+ static char buf[30];
+ sprintf(buf,"*%d",i);
+ return(buf);
+}
+char *datalabel(i)
+int i;
+{
+ static char buf[30];
+ if( i>0)
+ sprintf(buf,"l%d",i);
+ else sprintf(buf,"%d",-i);
+ return(buf);
+}
+
+char *salloc(length)
+int length;
+{
+ char *s,*c;
+ s=c= (char *) malloc(length);
+ while(length-->0)*c++ =0;
+ return(s);
+}
+
+char * proclabel(str)
+char *str;
+{
+ static char buf[50];
+ sprintf(buf,"$%s",str);
+ return(buf);
+}
--- /dev/null
+#include "bem.h"
+
+/* Author: M.L. Kersten
+** yywrap is called upon encountering endoffile on yyin.
+** when more input files are present, it moves to the next
+** otherwise -1 is returned and simultaneous endofinput is set
+*/
+int endofinput =0;
+
+
+yywrap()
+{
+ if( fclose(yyin) == EOF)
+ fatal("fclose problems ");
+ /* check for next input file */
+ return(-1);
+}
public / ack.git / commitdiff