d0p1/ack
1
0
Fork 0
Code Issues Pull requests Packages Projects Releases Wiki Activity

The version of basic copied from Martin Kerstens directory.

Browse source
This commit is contained in:
em 1984-11-27 22:11:59 +00:00
parent 502a7a86af
commit 4301dfb7bf
16 changed files with 3076 additions and 0 deletions
Show stats Download patch file Download diff file Expand all files Collapse all files

14
lang/basic/src.old/Makefile Normal file
View file

@ -0,0 +1,14 @@
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

464
lang/basic/src.old/basic.lex Normal file
View file

@ -0,0 +1,464 @@
/* 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++);
}

461
lang/basic/src.old/basic.yacc Normal file
View file

@ -0,0 +1,461 @@
%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"

38
lang/basic/src.old/bem.c Normal file
View file

@ -0,0 +1,38 @@
#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();
}

59
lang/basic/src.old/bem.h Normal file
View file

@ -0,0 +1,59 @@
#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();

13
lang/basic/src.old/compile.c Normal file
View file

@ -0,0 +1,13 @@
#include "bem.h"
/* compile the next program in the list */
FILE *yyin;
compileprogram()
{
while( getline())
yyparse();
fclose(yyin);
}

437
lang/basic/src.old/eval.c Normal file
View file

@ -0,0 +1,437 @@
#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));
}

214
lang/basic/src.old/func.c Normal file
View file

@ -0,0 +1,214 @@
#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);
}

561
lang/basic/src.old/gencode.c Normal file
View file

@ -0,0 +1,561 @@
#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");
}

279
lang/basic/src.old/graph.c Normal file
View file

@ -0,0 +1,279 @@
#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);
}

23
lang/basic/src.old/initialize.c Normal file
View file

@ -0,0 +1,23 @@
#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 */
}

51
lang/basic/src.old/parsepar.c Normal file
View file

@ -0,0 +1,51 @@
#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];
}
}

86
lang/basic/src.old/split.c Normal file
View file

@ -0,0 +1,86 @@
#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();
}

285
lang/basic/src.old/symbols.c Normal file
View file

@ -0,0 +1,285 @@
#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]);
}

74
lang/basic/src.old/util.c Normal file
View file

@ -0,0 +1,74 @@
#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);
}

17
lang/basic/src.old/yywrap.c Normal file
View file

@ -0,0 +1,17 @@
#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);
}