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

Initial revision

Browse source
This commit is contained in:
ceriel 1988-07-04 11:45:41 +00:00
parent bd5583311e
commit c39c666834
20 changed files with 4338 additions and 0 deletions
Show stats Download patch file Download diff file Expand all files Collapse all files

20
lang/basic/src/.distr Normal file
View file

@ -0,0 +1,20 @@
Makefile
README
basic.g
basic.lex
bem.c
bem.h
compile.c
eval.c
func.c
gencode.c
graph.c
graph.h
initialize.c
llmess.c
maketokentab
parsepar.c
symbols.c
symbols.h
util.c
yylexp.c

64
lang/basic/src/Makefile Normal file
View file

@ -0,0 +1,64 @@
# $Header$
EMHOME=../../..
h=$(EMHOME)/h
m=$(EMHOME)/modules/h
LIBDIR= $(EMHOME)/modules/lib
LIBDIR2= $(EMHOME)/lib
CFLAGS = -I$h -I$m
FILES= bem.o symbols.o initialize.o compile.o \
parsepar.o gencode.o util.o graph.o \
eval.o func.o basic.o Lpars.o
CSRCFILES= bem.c symbols.c initialize.c compile.c \
parsepar.c gencode.c util.c graph.c \
eval.c func.c
CGENFILES= basic.c Lpars.c
CFILES=$(CSRCFILES) $(CGENFILES)
LIBFILES= $(LIBDIR)/libem_mes.a $(LIBDIR)/libeme.a \
$(LIBDIR2)/em_data.a $(LIBDIR)/libprint.a \
$(LIBDIR)/liballoc.a \
$(LIBDIR)/libsystem.a $(LIBDIR)/libstring.a
LINTLIBFILES= $(LIBDIR)/llib-lem_mes.a $(LIBDIR)/llib-leme.a \
$(LIBDIR)/llib-lprint.a \
$(LIBDIR)/llib-lalloc.a \
$(LIBDIR)/llib-lsystem.a $(LIBDIR)/llib-lstring.a
all: dummy bem
dummy: basic.g
LLgen basic.g
touch dummy
install: all
cp bem $(EMHOME)/lib/em_bem
cmp: all
cmp bem $(EMHOME)/lib/em_bem
pr:
@pr Makefile maketokentab bem.h symbols.h graph.h basic.g basic.lex $(CSRCFILES)
opr:
make pr | opr
bem: $(FILES) $(LIBFILES)
$(CC) -o bem $(FILES) $(LIBFILES)
basic.o : basic.c basic.lex Lpars.h llmess.c tokentab.h
$(CC) $(CFLAGS) -c basic.c
$(FILES): bem.h symbols.h graph.h
tokentab.h: Lpars.h
maketokentab
lint: $(CFILES)
lint -b $(CFLAGS) $(CFILES) $(LINTLIBFILES)
clean:
rm -f *.o
rm -f basic.c Lpars.h Lpars.c dummy tokentab.h bem

792
lang/basic/src/basic.g Normal file
View file

@ -0,0 +1,792 @@
/*
* (c) copyright 1987 by the Vrije Universiteit, Amsterdam, The Netherlands.
* See the copyright notice in the ACK home directory, in the file "Copyright".
*/
%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 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 IMPSYM ;
%token EQVSYM ;
%token XORSYM ;
%token VARPTR ;
/* Those were originally %left */
%token BOOLOP ;
%token NOTSYM ;
%token RELOP ;
%token MODSYM ;
/* Some contstant declared as tokens (?) */
%token LESYM ;
%token GESYM ;
%token NESYM ;
%token UNARYMINUS ;
{
#define YYDEBUG
#include "bem.h"
#include "llmess.c"
typedef union {
int integer ;
Symbol *Sptr ;
char *cptr ;
} YYSTYPE ;
int basicline;
int yydebug;
YYSTYPE yylval;
int ival;
char *dval;
char *sval;
int in_data = 0; /* set if processing DATA statement */
char *formatstring; /* formatstring used for printing */
Symbol *s; /* Symbol dummy */
#include "yylexp.c"
#include "basic.lex"
}
%lexical yylexp;
%start LLparse,programline ;
programline
: INTVALUE
{ basicline = ival;newblock(ival); newemblock(ival); }
stmts EOLN
| '#' INTVALUE STRVALUE EOLN
| EOLN
;
stmts : singlestmt
[ %while ( LLsymb == ':' ) ':' singlestmt ]*
;
singlestmt { int d2 ; }
: callstmt
| clearstmt
| CLOSESYM closestmt
| datastmt
| defstmt
| defvarstmt
| dimstmt
| ERRORSYM expression(&d2) { errorstmt(d2); }
| fieldstmt
| forstmt
| getstmt
| gosubstmt
| onstmt
| ifstmt
| illegalstmt
| inputstmt
| letstmt
| lineinputstmt
| lsetstmt
| midstmt
| NEXTSYM nextstmt
| GOTOSYM INTVALUE { gotostmt(ival); }
| openstmt
| optionstmt
| pokestmt
| printstmt
| randomizestmt
| readstmt
| REMSYM
| restorestmt
| returnstmt
| ENDSYM { C_loc((arith) 0 );
C_cal("_hlt");
C_asp((arith) BEMINTSIZE);
}
| STOPSYM { C_cal("_stop"); }
| swapstmt
| TRONOFFSYM { tronoff=yylval.integer; }
| whilestmt
| wendstmt
| writestmt
| /* EMPTY STATEMENT */
;
illegalstmt: ILLEGAL { illegalcmd(); }
;
callstmt { Symbol *id; int i; }
: CALLSYM
IDENTIFIER { id = yylval.Sptr; }
[ parmlist(&i)
{ C_cal(id->symname);
C_asp((arith) (i*BEMPTRSIZE));
}
| /* empty */
{ C_cal(id->symname); }
]
;
parmlist(int *ip;) { int var ; }
: '('
variable(&var) { *ip = 1; }
[ ',' variable(&var) { *ip = *ip + 1; } ]*
')'
;
clearstmt { int exp; }
: CLEARSYM [ ',' expression(&exp) ]*2
{ warning("statement ignored"); }
;
closestmt: filelist
| /* empty */ { C_cal("_close"); }
;
filelist { int intv; }
: cross
intvalue(&intv)
{ C_loc((arith) ival);
C_cal("_clochn");
C_asp((arith) BEMINTSIZE);
}
[ ','
cross
intvalue(&intv)
{ C_loc((arith) ival);
C_cal("_clochn");
C_asp((arith) BEMINTSIZE);
}
]* ;
datastmt: DATASYM { datastmt(); in_data = 1;}
datalist { fprint(datfile,"\n"); in_data = 0; }
;
dataelm : INTVALUE { fprint(datfile,"%d",ival); }
| '-' [ INTVALUE { fprint(datfile,"%d",-ival); }
| FLTVALUE { fprint(datfile,"-%s",dval); }
]
| FLTVALUE { fprint(datfile,dval); }
| STRVALUE { fprint(datfile,"\"%s\"",sval); }
| IDENTIFIER { fprint(datfile,"\"%s\"",sval); }
;
datalist: dataelm
[ ',' { fprint(datfile,","); }
dataelm ]*
;
defstmt : DEFSYM
[ deffnstmt
| defusrstmt
]
;
deffnstmt { int exp; }
: heading '=' expression(&exp)
{ endscope(exp); }
;
heading : FUNCTID { newscope(yylval.Sptr); }
[ '(' idlist ')' ]? { heading(); }
;
idlist : IDENTIFIER { dclparm(yylval.Sptr); }
[ ',' IDENTIFIER { dclparm(yylval.Sptr); }
]*
;
defvarstmt: DEFINTSYM { setdefaulttype( INTTYPE); }
| DEFSNGSYM { setdefaulttype( FLOATTYPE); }
| DEFDBLSYM { setdefaulttype( DOUBLETYPE); }
| DEFSTRSYM { setdefaulttype( STRINGTYPE); }
;
defusrstmt: USRSYM ':' { illegalcmd(); }
;
dimstmt { Symbol *symp; }
: DIMSYM arraydcl(&symp) ')' { dclarray(symp); }
[ ',' arraydcl(&symp) ')' { dclarray(symp); }
]*
;
arraydcl(Symbol **sympp;)
: IDENTIFIER { *sympp = s = yylval.Sptr; }
'('
INTVALUE
{
s->dimlimit[s->dimensions]=ival;
s->dimensions++;
}
[ ','
INTVALUE
{
if(s->dimensions<MAXDIMENSIONS) {
s->dimlimit[s->dimensions]=ival;
s->dimensions++;
} else error("too many dimensions");
}
]* ;
fieldstmt { int intv; }
: FIELDSYM cross intvalue(&intv)
{ setchannel(ival); }
',' fieldlist { notyetimpl(); }
;
fieldlist { int intv,var; }
: intvalue(&intv) ASSYM variable(&var)
[ ',' intvalue(&intv) ASSYM variable(&var) ]*
;
forstmt { int exp; }
: FORSYM IDENTIFIER { forinit(yylval.Sptr); }
'=' expression(&exp) { forexpr(exp); }
TOSYM expression(&exp) { forlimit(exp); }
step
;
step { int exp; }
: STEPSYM expression(&exp) { forstep(exp); }
| /*EMPTY*/ {
C_loc((arith) 1);
forstep(INTTYPE);
}
;
nextstmt: [ IDENTIFIER { nextstmt(yylval.Sptr); }
| /* empty */ { nextstmt((Symbol *)0); }
]
[ ',' IDENTIFIER { nextstmt(yylval.Sptr); }
]*
;
getstmt { char *cp; int intv; }
: getput(&cp)
[ /* empty */
{ C_loc((arith) 0);
C_cal(cp);
C_asp((arith) BEMINTSIZE);
}
| ',' intvalue(&intv)
{ C_loc((arith) ival);
C_cal(cp);
C_asp((arith) BEMINTSIZE);
}
]
;
getput(char **cpp;) { int intv; }
: GETSYM cross intvalue(&intv)
{ setchannel(ival);
*cpp = "$_getrec";
}
| PUTSYM cross intvalue(&intv)
{ setchannel(ival);
*cpp = "$_putsym";
}
;
gosubstmt: GOSUBSYM INTVALUE { gosubstmt(ival); }
;
returnstmt: RETURNSYM { returnstmt(); }
;
ifstmt { int exp; int d1; }
: IFSYM expression(&exp) { d1=ifstmt(exp); }
thenpart { d1=thenpart(d1); }
elsepart { elsepart(d1); }
;
thenpart: THENSYM [ INTVALUE { gotostmt(ival); }
| stmts
]
| GOTOSYM INTVALUE { gotostmt(ival); }
;
elsepart: %prefer ELSESYM
[ INTVALUE { gotostmt(ival); }
| stmts
]
| /* empty */
;
inputstmt { int intv; }
: INPUTSYM [ semiprompt readlist
| '#' intvalue(&intv)
{ setchannel(ival); }
',' readlist
]
;
semiprompt { int str; }
: semi STRVALUE { str = yylval.integer; }
[ ';' { loadstr(str);
prompt(1);
}
| ',' { loadstr(str);
prompt(0);
}
]
| /*EMPTY*/
{ setchannel(-1);
C_cal("_qstmark");
}
;
semi : ';'
| /* empty */
;
letstmt { int var,exp; }
: LETSYM
variable(&var) { save_address(); }
'=' expression(&exp) { assign(var,exp); }
|
variable(&var) { save_address(); }
'=' expression(&exp) { assign(var,exp); }
;
lineinputstmt { int var,intv; }
: LINESYM
[ INPUTSYM
semiprompt { setchannel(-1); }
variable(&var) { linestmt(var); }
| '#'
intvalue(&intv) { setchannel(ival); }
','
variable(&var) { linestmt(var); }
]
;
readlist: readelm
[ ',' readelm ]*
;
readelm { int var; }
: variable(&var) { readelm(var); }
;
lsetstmt { int var,exp; }
: LSETSYM variable(&var) '=' expression(&exp)
{ notyetimpl(); }
;
midstmt { int exp; }
: MIDSYM '$' midparms '=' expression(&exp)
{ C_cal("_midstmt");
C_asp((arith) (2*BEMINTSIZE + 2*BEMPTRSIZE));
}
;
midparms: '(' midfirst midsec midthird ')'
;
midfirst { int exp; }
: expression(&exp) { conversion(exp,STRINGTYPE); }
;
midsec { int exp; }
: ',' expression(&exp) { conversion(exp,INTTYPE); }
;
midthird { int exp; }
: ',' expression(&exp) { conversion(exp,INTTYPE); }
| /* empty */ { C_loc((arith) -1); }
;
onstmt : ONSYM
[ exceptionstmt
| ongotostmt
]
;
exceptionstmt: ERRORSYM GOTOSYM INTVALUE { exceptstmt(ival); }
;
ongotostmt { int exp; }
: expression(&exp)
[ GOSUBSYM constantlist { ongosubstmt(exp); }
| GOTOSYM constantlist { ongotostmt(exp); }
]
;
constantlist: INTVALUE { jumpelm(ival); }
[ ',' INTVALUE { jumpelm(ival); }
]*
;
openstmt { int exp; }
: OPENSYM mode openchannel expression(&exp)
{ conversion(exp,STRINGTYPE); }
[ /* empty */ { openstmt(0); }
| INTVALUE { openstmt(ival); }
]
;
openchannel: cross INTVALUE ',' { setchannel(ival); }
;
mode { int exp; }
: expression(&exp) ',' { conversion(exp,STRINGTYPE); }
| ',' { C_lae_dnam("_iomode",(arith)0); }
;
optionstmt { int intv; }
: OPTIONSYM BASESYM intvalue(&intv) { optionbase(ival); }
;
printstmt { int plist; }
: PRINTSYM
[ /* empty */ { setchannel(-1);
C_cal("_nl");
}
| file format printlist(&plist)
{ if(plist)
C_cal("_nl");
}
]
;
file { int intv; }
: '#' intvalue(&intv) ',' { setchannel(ival); }
| /* empty */ { setchannel(-1); }
;
format { int var ; }
: USINGSYM
[ STRVALUE { loadstr(yylval.integer); } ';'
| variable(&var) ';'
{ if(var!=STRINGTYPE)
error("string variable expected");
}
]
| /* empty */ { formatstring=0; }
;
printlist(int *ip;) { int exp; }
: [ expression(&exp) { printstmt(exp); *ip=1; }
| ',' { zone(1); *ip=0; }
| ';' { zone(0); *ip=0; }
]+
;
pokestmt { int exp1,exp2 ; }
: POKESYM
expression(&exp1)
','
expression(&exp2) { pokestmt(exp1,exp2); }
;
randomizestmt { int exp; }
: RANDOMIZESYM
[ /* empty */ { C_cal("_randomi"); }
| expression(&exp)
{ conversion(exp,INTTYPE);
C_cal("_setrand");
C_asp((arith) BEMINTSIZE);
}
]
;
readstmt { int var; }
: READSYM { setchannel(0); }
variable(&var) { readelm(var); }
[ ',' variable(&var) { readelm(var); }
]*
;
restorestmt : RESTORESYM
[ INTVALUE { restore(ival); }
| /* empty */ { restore(0); }
]
;
swapstmt { int var1,var2; }
: SWAPSYM
variable(&var1)
','
variable(&var2) { swapstmt(var1,var2); }
;
whilestmt { int exp; }
: WHILESYM { whilestart(); }
expression(&exp) { whiletst(exp); }
;
wendstmt : WENDSYM { wend(); }
;
writestmt: WRITESYM
[ /* empty */ { setchannel(-1);
C_cal("_wrnl");
}
| file writelist { C_cal("_wrnl"); }
]
;
writelist { int exp; }
: expression(&exp) { writestmt(exp,0); }
[ ',' expression(&exp) { writestmt(exp,1); }
]*
;
cross: '#' | /* empty */ ;
intvalue(int *ip;)
: INTVALUE { *ip = yylval.integer; }
;
variable(int *ip;) { Symbol *symp; int exp; }
: identifier(&symp)
[ %avoid /* empty */ { *ip = loadaddr(symp); }
| '(' { newarrayload(symp); }
expression(&exp) { loadarray(exp); }
[ ',' expression(&exp) { loadarray(exp); } ]*
')' { *ip = endarrayload(); }
]
| ERRSYM { C_lae_dnam("_errsym",(arith) 0);
*ip = INTTYPE;
}
| ERLSYM { C_lae_dnam("_erlsym",(arith) 0);
*ip = INTTYPE;
}
;
expression(int *ip;) { int neg; } /* NIEUW */
: expression1(&neg) { *ip = neg; }
[
IMPSYM
expression(&neg) { *ip = boolop(*ip,neg,IMPSYM); }
]?
;
expression1(int *ip;) { int neg; }
: expression2(&neg) { *ip = neg; }
[ EQVSYM
expression2(&neg) { *ip = boolop(*ip,neg,EQVSYM); }
]*
;
expression2(int *ip;) { int neg; }
: expression3(&neg) { *ip = neg; }
[ XORSYM
expression3(&neg) { *ip = boolop(*ip,neg,XORSYM); }
]*
;
expression3(int *ip;) { int neg; }
: expression4(&neg) { *ip = neg; }
[ ORSYM
expression4(&neg) { *ip = boolop(*ip,neg,ORSYM); }
]*
;
expression4(int *ip;) { int neg; }
: negation(&neg) { *ip = neg; }
[ ANDSYM
negation(&neg) { *ip = boolop(*ip,neg,ANDSYM); }
]*
;
negation(int *ip;) { int comp; }
: NOTSYM compare(&comp) { *ip=boolop(comp,0,NOTSYM); }
| compare(ip)
;
compare(int *ip;) { int sum1,sum2,rel; }
: sum(&sum1)
[ /* empty */ { *ip = sum1; }
| RELOP { rel=yylval.integer; }
sum(&sum2) { *ip=relop(sum1,sum2,rel); }
| '=' sum(&sum2) { *ip=relop(sum1,sum2,'='); }
]
;
sum(int *ip;) { int term1; }
: term(&term1) { *ip = term1; }
[ %while(1)
'-' term(&term1) { *ip=plusmin(*ip,term1,'-'); }
| '+' term(&term1) { *ip=plusmin(*ip,term1,'+'); }
]*
;
term(int *ip;) { int fac1; }
: factor(&fac1) { *ip = fac1; }
[ '*' factor(&fac1) { *ip=muldiv(*ip,fac1,'*'); }
| '\\' factor(&fac1) { *ip=muldiv(*ip,fac1,'\\'); }
| '/' factor(&fac1) { *ip=muldiv(*ip,fac1,'/'); }
| MODSYM factor(&fac1) { *ip=muldiv(*ip,fac1,MODSYM); }
]*
;
factor(int *ip;)
: '-' factor(ip) { *ip=negate(*ip); }
| factor1(ip)
;
factor1(int *ip;) { int mant,exp; }
: factor2(&mant)
[ /* empty */ { *ip = mant; }
| '^' factor1(&exp) { *ip = power(mant,exp); }
]
;
factor2(int *ip;)
{ int var,func,expl,funcc,exp,intv,funcn,inpt; int typetable[10]; }
: INTVALUE { *ip=loadint(ival); }
| '(' expression(&exp) ')' { *ip=exp; }
| FLTVALUE { *ip=loaddbl(dval); }
| STRVALUE
{ *ip= STRINGTYPE;
loadstr(yylval.integer);
}
| variable(&var)
{ *ip=var;
loadvar(var);
}
| INKEYSYM '$' { C_cal("_inkey");
C_lfr((arith) BEMPTRSIZE);
*ip= STRINGTYPE;
}
| VARPTR '(' '#' intvalue(&intv) ')'
{ warning("Not supported");
*ip=INTTYPE;
}
| FUNCTION { func=yylval.integer; }
[ %avoid /* empty */ { *ip= callfcn(yylval.integer,0, typetable); }
| '(' cross exprlist(&expl, typetable) ')'
{ *ip=callfcn(func,expl, typetable); }
]
| funcname(&funcn)
[ %avoid /* empty */ { *ip=fcnend(0); }
| funccall(&funcc) ')' { *ip=fcnend(funcc); }
]
| MIDSYM '$' midparms
{
C_cal("_mid");
C_asp((arith) (2*BEMINTSIZE+BEMPTRSIZE));
C_lfr((arith) BEMPTRSIZE);
*ip= STRINGTYPE;
}
| INPUTSYM '$' '(' expression(&exp) inputtail(&inpt)
{ /*waar worden inpt en exp gebruikt?*/
C_cal("_inpfcn");
C_asp((arith) (2*BEMINTSIZE+BEMPTRSIZE));
*ip= STRINGTYPE;
}
;
inputtail(int *ip;) { int exp; }
: ',' cross expression(&exp) ')'
{ conversion(exp,INTTYPE);
*ip= INTTYPE;
}
| ')'
{ C_loc((arith) -1);
*ip= INTTYPE;
}
;
funcname(int *ip;)
: FUNCTID { *ip=fcncall(yylval.Sptr); }
;
funccall(int *ip;) { int exp; }
: '(' expression(&exp) { callparm(0,exp);*ip=1; }
[ ',' expression(&exp) { callparm(*ip,exp);
*ip = *ip+1;
}
]*
;
identifier(Symbol **ident;)
: IDENTIFIER { dcltype(yylval.Sptr);
*ident=yylval.Sptr;
}
;
exprlist(int *ip; int *typetable;) { int exp; }
: expression(&exp) { typetable[0]=exp;
*ip=1;
}
[ ',' expression(&exp) { typetable[*ip]=exp;
*ip = *ip+1;
}
]*
;
{
#ifndef NORCSID
static char rcs_id[] = "$Header$" ;
#endif
}

613
lang/basic/src/basic.lex Normal file
View file

@ -0,0 +1,613 @@
/*
* (c) copyright 1987 by the Vrije Universiteit, Amsterdam, The Netherlands.
* See the copyright notice in the ACK home directory, in the file "Copyright".
*/
#ifndef NORSCID
static char rcs_lex[] = "$Header$" ;
#endif
/* This file contains the new lexical analizer */
typedef struct {
char *name;
int token, classvalue,length;
} Key;
Key keywords [] ={
"abs", FUNCTION, ABSSYM, 0,
"and", ANDSYM, 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", CLOSESYM, 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,
"eqv", EQVSYM, EQVSYM, 0,
"erase", ILLEGAL, 0, 0,
"error", ERRORSYM, 0, 0,
"err", ERRSYM, 0, 0,
"erl", ERLSYM, 0, 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", IMPSYM, 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", ORSYM, 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", XORSYM, 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++)
print("%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 */
#define GETSBUFSIZE 1024
char fgets_buf[GETSBUFSIZE];
char *our_fgets(buffer,n_char,stream)
char *buffer;
int n_char;
File *stream;
{
/* Read one line or n_char */
static int characters_left = 0;
static char *internal_bufp = fgets_buf;
char *external_bufp;
external_bufp = buffer; /* Moves through the external buffer */
while ( 1 ) {
if ( characters_left ) { /* There is still something buffered */
if ( n_char > 1 ) { /* More characters have to be copied */
if ( *internal_bufp == '\n' ) {
*external_bufp++ = *internal_bufp++;
characters_left--;
*external_bufp = '\0';
return(buffer); /* One line is read */
} else {
*external_bufp++ = *internal_bufp++;
characters_left--;
n_char--; /* One character is copied */
}
} else { /* Enough characters read */
*external_bufp = '\0';
return(buffer);
}
} else { /* Read new block */
sys_read(stream,fgets_buf,GETSBUFSIZE,&characters_left);
internal_bufp = fgets_buf;
/* Move pointer back to the beginning */
if ( characters_left == 0 ) { /* Nothing read */
if ( external_bufp == buffer ) {
*external_bufp = '\0';
return(NULL); /* EOF */
} else { /* Something was already copied */
*external_bufp = '\0';
return(buffer);
}
}
}
}
}
extern char *strindex();
getline()
{
/* get next input line */
if ( our_fgets(inputline,MAXLINELENGTH,yyin) == NULL)
return(FALSE);
yylineno ++;
if ( strindex(inputline,'\n') == 0)
error("source line too long");
inputline[MAXLINELENGTH-1]=0;
if ( listing)
fprint(STDERR, inputline);
cptr= inputline;
return(TRUE);
}
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 *Sym;
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 != 0 && *(k->name)== *cptr;k++)
if ( strncmp(cptr,k->name,k->length)==0)
{
/* if ( isalnum( *(cptr+k->length) )) *//* EHB */
if ( isalnum( *(cptr+k->length) ) && /* EHB */
k->token == FUNCTION) /* EHB */
continue;
/* keywords door delimiters gescheiden */
cptr += k->length;
yylval.integer= k->classvalue;
if (debug) print("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 == '.') && i < SIGNIFICANT)
name[i++]= *c++;
while (isalnum(*c) || *c == '.') c++; /* skip rest */
name[i]=0;
cptr=c;
Sym= srchsymbol(name);
yylval.Sptr = Sym;
typech= typechar();
if (Sym->symtype!=DEFAULTTYPE)
{
if (typech && typech!=Sym->symtype && wflag)
warning("type re-declared,ignored");
}
if ( typech)
Sym->symtype=typech;
if (debug) print("lookup:%d Identifier\n",Sym);
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++;
(void) sscanf(c,"%x",&ival);
} else
if ( *cptr == 'O' || *cptr == 'o')
{
/* OCTAL */
cptr++;
c=cptr;
while ( isdigit(*cptr) ) cptr++;
(void) sscanf(c,"%o",&ival);
} else error("H or O expected");
return(INTVALUE);
}
#ifdef ____
/* Computes base to the power exponent. This was not done in the old
compiler */
double powr(base,exp)
double base;
int exp;
{
int i;
double result;
int abs_exp;
if ( exp < 0 )
abs_exp = -exp;
else
abs_exp = exp;
result = 1.0;
for ( i = 1; i <= abs_exp; i++ ) {
result = result * base;
}
if ( exp < 0 )
return ( 1.0 / result );
else
return ( result );
}
#endif
number()
{
long i1;
int overflow = 0;
register char *c;
static char numbuf[256];
register char *d = numbuf;
dval = numbuf;
i1=0;
c=cptr;
while (*c == '0') c++;
while (isdigit(*c)){
i1= i1*10 + *c-'0';
if (i1 < 0) overflow = 1;
if (d < &numbuf[255]) *d++ = *c;
c++;
}
if (d == numbuf) *d++ = '0';
cptr=c;
if ( *c != '.' && *c != 'e' && *c != 'E'
&& *c != 'd' && *c != 'D' ){
if ( i1> MAXINT || i1<MININT || overflow) {
*d = 0;
return(FLTVALUE);
}
/*NOSTRICT*/ ival= i1;
#ifdef YYDEBUG
if (yydebug) print("number:INTVALUE %d",i1);
#endif
return(INTVALUE);
}
/* handle floats */
if (*c == '.') {
if (d < &numbuf[255]) *d++ = *c;
c++;
while ( isdigit(*c)){
if (d < &numbuf[255]) *d++ = *c;
c++;
}
}
/* handle exponential part */
if ( *c == 'e' || *c == 'E' || *c == 'd' || *c == 'D' ){
if (d < &numbuf[254]) *d++ = 'e';
c++;
if ( *c=='-' || *c=='+') {
if (d < &numbuf[255]) *d++ = *c;
c++;
}
while (isdigit(*c)){
if (d < &numbuf[255]) *d++ = *c;
c++;
}
if (*(d-1) == 'e') *d++ = '0';
}
*d = 0;
cptr=c;
#ifdef YYDEBUG
if (yydebug) print("number:FLTVALUE %s",dval);
#endif
return(FLTVALUE);
}
/* Maximale grootte van een chunk; >= 4 */
#define CHUNKSIZE 123
scanstring()
{
int i,length=0;
char firstchar = *cptr;
char buffer[CHUNKSIZE],*bufp = buffer;
/* generate label here */
if (! in_data) yylval.integer= genemlabel();
if ( *cptr== '"') cptr++;
sval= cptr;
while ( *cptr !='"')
{
switch(*cptr)
{
case 0:
case '\n':
#ifdef YYDEBUG
if (yydebug) print("STRVALUE\n");
#endif
if ( firstchar == '"')
error("non-terminated string");
return(STRVALUE);
/*
case '\'':
case '\\':
*bufp++ = '\\';
*bufp++ = *cptr;
if ( bufp >= buffer + CHUNKSIZE - 4 ) {
if (! in_data)
C_con_scon(buffer,(arith)(bufp-buffer));
bufp = buffer;
}
break;
*/
default:
*bufp++ = *cptr;
if ( bufp >= buffer + CHUNKSIZE - 4 ) {
if (! in_data)
C_con_scon(buffer,(arith)(bufp-buffer));
bufp = buffer;
}
}
cptr++;
length++;
}
*cptr = 0;
*bufp++ = 0;
cptr++;
if (! in_data) {
C_con_scon(buffer,(arith)(bufp-buffer));
i=yylval.integer;
yylval.integer= genemlabel();
C_rom_dlb((label)i,(arith)0);
C_rom_icon("9999",(arith)BEMINTSIZE);
C_rom_icon(itoa(length),(arith)BEMINTSIZE);
}
#ifdef YYDEBUG
if (yydebug) print("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) print("end of buffer");
#endif
return(0);
case '"':
return(scanstring());
/* handle double operators */
case ' ':
case '\t':
cptr++;
return(yylex());
case '&':
return(readconstant());
case '?':
cptr++;
return(PRINTSYM);
case '>':
if ( *(c+1)=='='){
c++; c++;
cptr=c;
yylval.integer= GESYM;
return(RELOP);
}
yylval.integer= '>';
cptr++;
return(RELOP);
case '<':
if ( *(c+1)=='='){
c++; c++;
cptr=c;
yylval.integer=LESYM;
return(RELOP);
} else
if ( *(c+1)=='>'){
c++; c++;
cptr=c;
yylval.integer=NESYM;
return(RELOP);
}
yylval.integer= '<';
cptr++;
return(RELOP);
}
return(*cptr++);
}

54
lang/basic/src/bem.c Normal file
View file

@ -0,0 +1,54 @@
/*
* (c) copyright 1987 by the Vrije Universiteit, Amsterdam, The Netherlands.
* See the copyright notice in the ACK home directory, in the file "Copyright".
*/
#include "bem.h"
#ifndef NORSCID
static char rcs_id[] = "$Header$" ;
static char rcs_bem[] = RCS_BEM ;
static char rcs_symb[] = RCS_SYMB ;
static char rcs_graph[] = RCS_GRAPH ;
#endif
/* 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;
int BEMINTSIZE = EMINTSIZE;
int BEMPTRSIZE = EMPTRSIZE;
int BEMFLTSIZE = EMFLTSIZE;
main(argc,argv)
int argc;
char **argv;
{
extern int errorcnt;
/* parseparams */
parseparams(argc,argv);
/* initialize the system */
initialize();
/* compile source programs */
compileprogram();
linewarnings();
C_close();
if( errorcnt) sys_stop(S_EXIT);
/* process em object files */
sys_stop(S_END); /* This was not done in the old compiler */
}

79
lang/basic/src/bem.h Normal file
View file

@ -0,0 +1,79 @@
/*
* (c) copyright 1987 by the Vrije Universiteit, Amsterdam, The Netherlands.
* See the copyright notice in the ACK home directory, in the file "Copyright".
*/
#include <stdio.h>
#include <ctype.h>
#include <signal.h>
#include <system.h>
#include <em.h>
#include <em_mes.h>
/* Author: M.L. Kersten
** Here all the global objects are defined.
*/
#include "symbols.h"
#include "graph.h"
#include "Lpars.h"
#ifndef NORCSID
# define RCS_BEM "$Header$"
#endif
#define MAXINT 32768
#define MININT -32767
/* #define EMINTSIZE "EM_WSIZE" */
/* #define EMPTRSIZE "EM_PSIZE" */
/* #define EMFLTSIZE "EM_DSIZE" */
#define EMINTSIZE 4
#define EMPTRSIZE 4
#define EMFLTSIZE 8
#define MAXPIECES 100
#define MAXFILENAME 200
#define CHANNEL 0
#define THRESHOLD 40 /* for splitting blocks */
#define void int /* Some C compilers don't know void */
extern int BEMINTSIZE, BEMPTRSIZE, BEMFLTSIZE;
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 *tmp_file; /* 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 label err_goto_label;
extern int dataused;
extern Linerecord *currline;
extern char *itoa();
extern char *salloc();
extern char *sprintf();
extern char *strcpy();
extern char *strcat();
extern char *malloc();

30
lang/basic/src/compile.c Normal file
View file

@ -0,0 +1,30 @@
/*
* (c) copyright 1987 by the Vrije Universiteit, Amsterdam, The Netherlands.
* See the copyright notice in the ACK home directory, in the file "Copyright".
*/
#include "bem.h"
#ifndef NORSCID
static char rcs_id[] = "$Header$" ;
#endif
/* compile the next program in the list */
/* Here we should open the input file. (for the future) */
File *yyin;
compileprogram()
{
extern int basicline;
prologcode();
prolog2(); /* Some statements are moved from prolog2 to
epilogcode in the new version of the compiler */
while( basicline = 0, getline())
(void) LLparse();
epilogcode();
(void) sys_close(yyin);
}

536
lang/basic/src/eval.c Normal file
View file

@ -0,0 +1,536 @@
/*
* (c) copyright 1987 by the Vrije Universiteit, Amsterdam, The Netherlands.
* See the copyright notice in the ACK home directory, in the file "Copyright".
*/
#include "bem.h"
#ifndef NORSCID
static char rcs_id[] = "$Header$" ;
#endif
/* 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)
{
C_loc((arith)BEMINTSIZE);
C_loc((arith)BEMFLTSIZE);
C_cif ();
} else {
if (debug)
print("type n=%d o=%d\n",newtype,oldtype);
error("conversion error");
}
break;
case FLOATTYPE:
case DOUBLETYPE:
if ( newtype==INTTYPE)
{
/* rounded ! */
C_cal("_cint");
C_asp((arith)BEMFLTSIZE);
C_lfr((arith)BEMINTSIZE);
break;
} else if ( newtype==FLOATTYPE || newtype==DOUBLETYPE)
break;
default:
if (debug)
print("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) print("extra convert %d %d %d\n",oldtype,newtype,topstack);
/* save top in dummy */
switch( topstack)
{
case INTTYPE:
C_ste_dnam("dummy1",(arith)0);
break;
case FLOATTYPE:
case DOUBLETYPE:
/* rounded ! */
C_lae_dnam("dummy1",(arith)0);
C_sti((arith)BEMFLTSIZE);
break;
default:
error("conversion error");
return;
}
/* now its on top of the stack */
conversion(oldtype,newtype);
/* restore top */
switch( topstack)
{
case INTTYPE:
C_loe_dnam("dummy1",(arith)0);
break;
case FLOATTYPE:
case DOUBLETYPE:
/* rounded ! */
C_lae_dnam("dummy1",(arith)0);
C_loi((arith)BEMFLTSIZE);
}
}
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:
C_com((arith)BEMINTSIZE);
break;
case ANDSYM:
C_and((arith)BEMINTSIZE);
break;
case ORSYM:
C_ior((arith)BEMINTSIZE);
break;
case XORSYM:
C_xor((arith)BEMINTSIZE);
break;
case EQVSYM:
C_xor((arith)BEMINTSIZE);
C_com((arith)BEMINTSIZE);
break;
case IMPSYM:
/* implies */
C_com((arith)BEMINTSIZE);
C_and((arith)BEMINTSIZE);
C_com((arith)BEMINTSIZE);
break;
default:
error("boolop:unexpected");
}
return(INTTYPE);
}
genbool(operator)
int operator;
{
int l1,l2;
l1= genlabel();
l2= genlabel();
switch(operator)
{
case '<': C_zlt((label)l1); break;
case '>': C_zgt((label)l1); break;
case '=': C_zeq((label)l1); break;
case NESYM: C_zne((label)l1); break;
case LESYM: C_zle((label)l1); break;
case GESYM: C_zge((label)l1); break;
default: error("relop:unexpected operator");
}
C_loc((arith)0);
C_bra((label)l2);
C_df_ilb((label)l1);
C_loc((arith)-1);
C_df_ilb((label)l2);
}
relop( ltype,rtype,operator)
int ltype,rtype,operator;
{
int result;
if (debug) print("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)
C_cmi((arith)BEMINTSIZE);
else if ( result==FLOATTYPE || result==DOUBLETYPE)
C_cmf((arith)BEMFLTSIZE);
else if ( result==STRINGTYPE)
{
C_cal("_strcomp");
C_asp((arith)(2*BEMPTRSIZE));
C_lfr((arith)BEMINTSIZE);
} else error("relop:unexpected");
/* handle the relational operators */
genbool(operator);
return(INTTYPE);
}
plusmin(ltype,rtype,operator)
int ltype,rtype,operator;
{
int result;
result= exprtype(ltype,rtype);
if ( result== STRINGTYPE)
{
if ( operator== '+')
{
C_cal("_concat");
C_asp((arith)(2*BEMPTRSIZE));
C_lfr((arith)BEMPTRSIZE);
} else error("illegal operator");
} else {
extraconvert(ltype,result,rtype);
conversion(rtype,result);
if ( result== INTTYPE)
{
if ( operator=='+')
C_adi((arith)BEMINTSIZE);
else C_sbi((arith)BEMINTSIZE);
} else {
if ( operator=='+')
C_adf((arith)BEMFLTSIZE);
else C_sbf((arith)BEMFLTSIZE);
}
}
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);
C_dvf((arith)BEMFLTSIZE);
} else
if ( operator=='\\')
C_dvi((arith)BEMINTSIZE);
else
if ( operator=='*')
C_mli((arith)BEMINTSIZE);
else
if ( operator==MODSYM)
C_rmi((arith)BEMINTSIZE);
else error("illegal operator");
} else {
if ( operator=='/')
C_dvf((arith)BEMFLTSIZE);
else
if ( operator=='*')
C_mlf((arith)BEMFLTSIZE);
else error("illegal operator");
}
return(result);
}
negate(type)
int type;
{
switch(type)
{
case INTTYPE:
C_ngi((arith)BEMINTSIZE);
break;
case DOUBLETYPE:
case FLOATTYPE:
C_ngf((arith)BEMFLTSIZE);
break;
default:
error("Illegal operator");
}
return(type);
}
#ifdef ___
power(ltype,rtype)
int ltype,rtype;
{
int resulttype = exprtype(ltype, rtype);
extraconvert(ltype,resulttype,rtype);
conversion(rtype,resulttype);
switch(resulttype) {
case INTTYPE:
C_cal("_ipower");
break;
case DOUBLETYPE:
case FLOATTYPE:
C_cal("_power");
break;
default:
error("Illegal operator");
}
C_asp((arith)(2*typestring(resulttype)));
C_lfr((arith)typestring(resulttype));
return(resulttype);
}
#else
power(ltype,rtype)
int ltype,rtype;
{
extraconvert(ltype,DOUBLETYPE,rtype);
conversion(rtype,DOUBLETYPE);
C_cal("_power");
C_asp((arith)(2*BEMFLTSIZE));
C_lfr((arith)BEMFLTSIZE);
return(DOUBLETYPE);
}
#endif
int typesize(ltype)
int ltype;
{
switch( ltype)
{
case INTTYPE:
return(BEMINTSIZE);
case FLOATTYPE:
case DOUBLETYPE:
return(BEMFLTSIZE);
case STRINGTYPE:
return(BEMPTRSIZE);
default:
error("typesize:unexpected");
if (debug) print("type received %d\n",ltype);
}
return(BEMINTSIZE);
}
int typestring(type)
int type;
{
switch(type)
{
case INTTYPE:
return(BEMINTSIZE);
case FLOATTYPE:
case DOUBLETYPE:
return(BEMFLTSIZE);
case STRINGTYPE:
return(BEMPTRSIZE);
default:
error("typestring: unexpected type");
}
return(0);
}
loadvar(type)
int type;
{
/* load a simple variable its address is on the stack*/
C_loi((arith)typestring(type));
}
loadint(value)
int value;
{
C_loc((arith)value);
return(INTTYPE);
}
loaddbl(value)
char *value;
{
int index;
index=genlabel();
C_df_dlb((label)index);
C_bss_fcon((arith)BEMFLTSIZE,value,(arith)BEMFLTSIZE,1);
C_lae_dlb((label)index,(arith)0);
C_loi((arith)BEMFLTSIZE);
return(DOUBLETYPE);
}
loadstr(value)
int value;
{
C_lae_dlb((label)value,(arith)0);
}
loadaddr(s)
Symbol *s;
{
extern Symbol *fcn;
int i,j;
arith sum;
if (debug) print("load %s %d\n",s->symname,s->symtype);
if ( s->symalias>0)
C_lae_dlb((label)s->symalias,(arith)0);
else {
j= -s->symalias;
if (debug) print("load parm %d\n",j);
/* first count the sizes. */
sum = 0;
for(i=fcn->dimensions;i>j;i--)
sum += typesize(fcn->dimlimit[i-1]);
C_lal(sum);
}
return(s->symtype);
}
/* This is a new routine */
save_address()
{
C_lae_dnam("dummy3",(arith)0);
C_sti((arith)BEMPTRSIZE);
}
assign(type,lt)
int type,lt;
{
extern int e1,e2;
conversion(lt,type);
C_lae_dnam("dummy3",(arith)0); /* Statement added by us */
C_loi((arith)BEMPTRSIZE);
/* address is on stack already */
C_sti((arith)typestring(type));
}
storevar(lab,type)
int lab,type;
{
/*store value back */
C_lae_dlb((label)lab,(arith)0);
C_sti((arith)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]= 0;
arraystk[dimtop]= s;
C_lae_dlb((label)s->symalias,(arith)0);
}
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>=s->dimensions)
{
error("too many indices");
dimstk[dimtop]=0;
return;
}
conversion(type,INTTYPE);
C_lae_dlb((label)s->dimalias[dim],(arith)0);
C_aar((arith)BEMINTSIZE);
dimstk[dimtop]++;
}

269
lang/basic/src/func.c Normal file
View file

@ -0,0 +1,269 @@
/*
* (c) copyright 1987 by the Vrije Universiteit, Amsterdam, The Netherlands.
* See the copyright notice in the ACK home directory, in the file "Copyright".
*/
#include "bem.h"
#ifndef NORSCID
static char rcs_id[] = "$Header$" ;
#endif
/* expression types for predefined functions are assembled */
int typetable[10];
int exprlimit;
/* handle all predefined functions */
#define cv(X) conversion(type,X); pop=X
parm(cnt)
int cnt;
{
if( cnt> exprlimit)
error("Not enough arguments");
if( cnt < exprlimit)
error("Too many arguments");
}
callfcn(fcnnr,cnt,typetable)
int fcnnr,cnt;
int *typetable;
{
int pop=DOUBLETYPE;
int res=DOUBLETYPE;
int type;
type= typetable[0];
exprlimit=cnt;
if(debug) print("fcn=%d\n",fcnnr);
switch(fcnnr)
{
case ABSSYM: cv(DOUBLETYPE);
C_cal("_abr");
parm(1);
break;
case ASCSYM: cv(STRINGTYPE);
C_cal("_asc");
res=INTTYPE;
parm(1);
break;
case ATNSYM: cv(DOUBLETYPE);
C_cal("_atn");
parm(1);
break;
case CDBLSYM: cv(DOUBLETYPE);
return(DOUBLETYPE);;
case CHRSYM: cv(INTTYPE);
C_cal("_chr");
res=STRINGTYPE;
parm(1);
break;
case CSNGSYM: cv(DOUBLETYPE);
return(DOUBLETYPE);
case CINTSYM: cv(INTTYPE);
return(INTTYPE);
case COSSYM: cv(DOUBLETYPE);
C_cal("_cos");
parm(1);
break;
case CVISYM: cv(STRINGTYPE);
C_cal("_cvi");
res=INTTYPE;
parm(1);
break;
case CVSSYM: cv(STRINGTYPE);
C_cal("_cvd");
res=DOUBLETYPE;
parm(1);
break;
case CVDSYM: cv(STRINGTYPE);
C_cal("_cvd");
res=DOUBLETYPE;
parm(1);
break;
case EOFSYM:
if( cnt==0)
{
res= INTTYPE;
pop= INTTYPE;
C_loc((arith) -1);
} else cv(INTTYPE);
C_cal("_ioeof");
res=INTTYPE;
break;
case EXPSYM: cv(DOUBLETYPE);
C_cal("_exp");
parm(1);
break;
case FIXSYM: cv(DOUBLETYPE);
C_cal("_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);
C_cal("_hex"); res=STRINGTYPE;
parm(1);
break;
case OUTSYM:
case INSTRSYM: cv(DOUBLETYPE);
C_cal("_instr");
res=STRINGTYPE;
parm(1);
break;
case INTSYM: cv(DOUBLETYPE);
C_cal("_fcint");
parm(1);
break;
case LEFTSYM: parm(2);
extraconvert(type, STRINGTYPE,typetable[1]);
type= typetable[1];
cv(INTTYPE);
C_cal("_left");
res=STRINGTYPE;
C_asp((arith) BEMPTRSIZE);
C_asp((arith) BEMINTSIZE);
C_lfr((arith) BEMPTRSIZE);
return(STRINGTYPE);
case LENSYM: cv(STRINGTYPE);
C_cal("_len");
res=INTTYPE;
parm(1);
break;
case LOCSYM: cv(INTTYPE);
C_cal("_loc");
res=INTTYPE;
parm(1);
break;
case LOGSYM: cv(DOUBLETYPE);
C_cal("_log");
parm(1);
break;
case MKISYM: cv(INTTYPE);
C_cal("_mki");
res=STRINGTYPE;
parm(1);
break;
case MKSSYM: cv(DOUBLETYPE);
C_cal("_mkd");
res=STRINGTYPE;
parm(1);
break;
case MKDSYM: cv(DOUBLETYPE);
C_cal("_mkd");
res=STRINGTYPE;
parm(1);
break;
case OCTSYM: cv(INTTYPE);
C_cal("_oct");
res=STRINGTYPE;
parm(1);
break;
case PEEKSYM: cv(INTTYPE);
C_cal("_peek");
res=INTTYPE;
parm(1);
break;
case POSSYM: C_asp((arith) typestring(type));
C_exa_dnam("_pos");
C_loe_dnam("_pos",(arith) 0);
return(INTTYPE);
case RIGHTSYM: parm(2);
extraconvert(type, STRINGTYPE,typetable[1]);
type= typetable[1];
cv(INTTYPE);
C_cal("_right");
res=STRINGTYPE;
C_asp((arith) BEMINTSIZE);
C_asp((arith) BEMPTRSIZE);
C_lfr((arith) BEMPTRSIZE);
return(STRINGTYPE);
case RNDSYM: if( cnt==1) pop=type;
else pop=0;
C_cal("_rnd");
res= DOUBLETYPE;
break;
case SGNSYM: cv(DOUBLETYPE);
C_cal("_sgn");
res=INTTYPE;
parm(1);
break;
case SINSYM: cv(DOUBLETYPE);
C_cal("_sin");
parm(1);
break;
case SPACESYM: cv(INTTYPE);
C_cal("_space");
res=STRINGTYPE;
parm(1);
break;
case SPCSYM: cv(INTTYPE);
C_cal("_spc");
res=0;
parm(1);
break;
case SQRSYM: cv(DOUBLETYPE);
C_cal("_sqt");
parm(1);
break;
case STRSYM: cv(DOUBLETYPE);
C_cal("_nstr");
res=STRINGTYPE; /* NEW */
parm(1);
break;
case STRINGSYM:
parm(2); /* 2 is NEW */
if (typetable[1] == STRINGTYPE) {
C_cal("_asc");
C_asp((arith)BEMPTRSIZE);
C_lfr((arith)BEMINTSIZE);
typetable[1] = INTTYPE;
}
extraconvert(type,
DOUBLETYPE,
typetable[1]); /* NEW */
type= typetable[1];
cv(DOUBLETYPE); /* NEW */
C_cal("_string");
res=STRINGTYPE;
C_asp((arith)typestring(DOUBLETYPE)); /*NEW*/
break;
case TABSYM: cv(INTTYPE);
C_cal("_tab");
res=0;
parm(1);
break;
case TANSYM: cv(DOUBLETYPE);
C_cal("_tan");
parm(1);
break;
case VALSYM: cv(STRINGTYPE);
C_loi((arith)BEMPTRSIZE);
C_cal("atoi");
res=INTTYPE;
parm(1);
break;
case VARPTRSYM: cv(DOUBLETYPE);
C_cal("_valptr");
parm(1);
break;
default: error("unknown function");
}
if(pop) C_asp((arith) typestring(pop));
if(res) C_lfr((arith) typestring(res));
return(res);
}

704
lang/basic/src/gencode.c Normal file
View file

@ -0,0 +1,704 @@
/*
* (c) copyright 1987 by the Vrije Universiteit, Amsterdam, The Netherlands.
* See the copyright notice in the ACK home directory, in the file "Copyright".
*/
#include "bem.h"
#ifndef NORSCID
static char rcs_id[] = "$Header$" ;
#endif
/* Here we find all routines dealing with pure EM code generation */
static int emlabel=1;
label err_goto_label;
genlabel()
{
return(emlabel++);
}
genemlabel()
{
int l;
l=genlabel();
C_df_dlb((label)l);
return(l);
}
int tronoff=0;
newemblock(nr)
int nr;
{
C_df_ilb((label)currline->emlabel);
C_lin((arith)nr);
if ( tronoff || traceflag) {
C_loc((arith)nr);
C_cal("_trace");
C_asp((arith)BEMINTSIZE);
}
}
/* Handle data statements */
List *datalist=0;
datastmt()
{
List *l,*l1;
/* NOSTRICT */ l= (List *) salloc(sizeof(List));
l->linenr= currline->linenr;
l->emlabel = sys_filesize(datfname);
if ( datalist==0)
{
datalist=l;
} else {
l1= datalist;
while (l1->nextlist) l1= l1->nextlist;
l1->nextlist=l;
}
}
datatable()
{
List *l;
int line=0;
/* called at end to generate the data seek table */
C_exa_dnam("_seektab");
C_df_dnam("_seektab"); /* VRAAGTEKEN */
l= datalist;
while (l)
{
C_rom_cst((arith)(l->linenr));
C_rom_cst((arith)(line++));
l= l->nextlist;
}
C_rom_cst((arith)0);
C_rom_cst((arith)0);
}
/* ERROR and exception handling */
exceptstmt(lab)
int lab;
{
/* exceptions to subroutines are supported only */
extern int gosubcnt;
List *l;
C_loc((arith)gosubcnt);
l= (List *) gosublabel();
l->emlabel= gotolabel(lab);
C_cal("_trpset");
C_asp((arith)BEMINTSIZE);
}
errorstmt(exprtype)
int exprtype;
{
/* convert expression to a valid error number */
/* obtain the message and print it */
C_cal("error");
C_asp((arith)typesize(exprtype));
}
/* BASIC IO */
openstmt(recsize)
int recsize;
{
C_loc((arith)recsize);
C_cal("_opnchn");
C_asp((arith)(2*BEMPTRSIZE+BEMINTSIZE));
}
printstmt(exprtype)
int exprtype;
{
switch(exprtype)
{
case INTTYPE:
C_cal("_prinum");
C_asp((arith)typestring(INTTYPE));
break;
case FLOATTYPE:
case DOUBLETYPE:
C_cal("_prfnum");
C_asp((arith)typestring(DOUBLETYPE));
break;
case STRINGTYPE:
C_cal("_prstr");
C_asp((arith)BEMPTRSIZE);
break;
case 0: /* result of tab function etc */
break;
default:
error("printstmt:unexpected");
}
}
zone(i)
int i;
{
if ( i) C_cal("_zone");
}
writestmt(exprtype,comma)
int exprtype,comma;
{
if ( comma) C_cal("_wrcomma");
switch(exprtype)
{
case INTTYPE:
C_cal("_wrint");
break;
case FLOATTYPE:
case DOUBLETYPE:
C_cal("_wrflt");
break;
case STRINGTYPE:
C_cal("_wrstr");
break;
default:
error("printstmt:unexpected");
}
C_asp((arith)BEMPTRSIZE);
}
restore(lab)
int lab;
{
/* save this information too */
C_loc((arith)0);
C_cal("_setchan");
C_asp((arith)BEMINTSIZE);
C_loc((arith)lab);
C_cal("_restore");
C_asp((arith)BEMINTSIZE);
}
prompt(qst)
int qst;
{
setchannel(-1);
C_cal("_prstr");
C_asp((arith)BEMPTRSIZE);
if (qst) C_cal("_qstmark");
}
linestmt(type)
int type;
{
if ( type!= STRINGTYPE)
error("String variable expected");
C_cal("_rdline");
C_asp((arith)BEMPTRSIZE);
}
readelm(type)
int type;
{
switch(type)
{
case INTTYPE:
C_cal("_readint");
break;
case FLOATTYPE:
case DOUBLETYPE:
C_cal("_readflt");
break;
case STRINGTYPE:
C_cal("_readstr");
break;
default:
error("readelm:unexpected type");
}
C_asp((arith)BEMPTRSIZE);
}
/* Swap exchanges the variable values */
swapstmt(ltype,rtype)
int ltype, rtype;
{
if ( ltype!= rtype)
error("Type mismatch");
else
switch(ltype)
{
case INTTYPE:
C_cal("_intswap");
break;
case FLOATTYPE:
case DOUBLETYPE:
C_cal("_fltswap");
break;
case STRINGTYPE:
C_cal("_strswap");
break;
default:
error("swap:unexpected");
}
C_asp((arith)(2*BEMPTRSIZE));
}
/* input/output handling */
setchannel(val)
int val;
{ /* obtain file descroption */
C_loc((arith)val);
C_cal("_setchan");
C_asp((arith)BEMINTSIZE);
}
/* The if-then-else statements */
ifstmt(type)
int type;
{
/* This BASIC follows the True= -1 rule */
int nr;
nr= genlabel();
if ( type == INTTYPE)
C_zeq((label)nr);
else
if ( type == FLOATTYPE || type == DOUBLETYPE )
{
C_lae_dnam("fltnull",(arith)0);
C_loi((arith)BEMFLTSIZE);
C_cmf((arith)BEMFLTSIZE);
C_zeq((label)nr);
}
else error("Integer or Float expected");
return(nr);
}
thenpart( elselab)
int elselab;
{
int nr;
nr=genlabel();
C_bra((label)nr);
C_df_ilb((label)elselab);
return(nr);
}
elsepart(lab)int lab;
{
C_df_ilb((label)lab);
}
/* 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 */
C_lae_dlb((label)f->initaddress,(arith)0);
loadvar(type);
conversion(type,DOUBLETYPE);
C_lae_dlb((label)f->stepaddress,(arith)0);
loadvar(type);
conversion(type,DOUBLETYPE);
C_cal("_forsgn");
C_asp((arith)BEMFLTSIZE);
C_lfr((arith)BEMINTSIZE);
conversion(INTTYPE,DOUBLETYPE);
C_mlf((arith)BEMFLTSIZE);
/* evaluate higher bound times sign of step */
C_lae_dlb((label)f->limitaddress,(arith)0);
loadvar(type);
conversion(type,DOUBLETYPE);
C_lae_dlb((label)f->stepaddress,(arith)0);
loadvar(type);
conversion(type,DOUBLETYPE);
C_cal("_forsgn");
C_asp((arith)BEMFLTSIZE);
C_lfr((arith)BEMINTSIZE);
conversion(INTTYPE,DOUBLETYPE);
C_mlf((arith)BEMFLTSIZE);
/* skip condition */
C_cmf((arith)BEMFLTSIZE);
C_zgt((label)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 */
C_lae_dlb((label)f->initaddress,(arith)0);
loadvar(result);
C_lae_dlb((label)varaddress,(arith)0);
C_sti((arith)typestring(result));
C_bra((label)f->fortst);
/* increment loop variable */
C_df_ilb((label)f->forinc);
C_lae_dlb((label)varaddress,(arith)0);
loadvar(result);
C_lae_dlb((label)f->stepaddress,(arith)0);
loadvar(result);
if (result == INTTYPE)
C_adi((arith)BEMINTSIZE);
else C_adf((arith)BEMFLTSIZE);
C_lae_dlb((label)varaddress,(arith)0);
C_sti((arith)typestring(result));
/* test boundary */
C_df_ilb((label)f->fortst);
C_lae_dlb((label)varaddress,(arith)0);
loadvar(result);
/* Start of NEW code */
C_lae_dlb((label)f->stepaddress,(arith)0);
loadvar(result);
conversion(result,DOUBLETYPE);
C_cal("_forsgn");
C_asp((arith)BEMFLTSIZE);
C_lfr((arith)BEMINTSIZE);
conversion(INTTYPE,result);
if ( result == INTTYPE )
C_mli((arith)BEMINTSIZE);
else C_mlf((arith)BEMFLTSIZE);
/* End of NEW code */
C_lae_dlb((label)f->limitaddress,(arith)0);
loadvar(result);
/* Start NEW code */
C_lae_dlb((label)f->stepaddress,(arith)0);
loadvar(result);
conversion(result,DOUBLETYPE);
C_cal("_forsgn");
C_asp((arith)BEMFLTSIZE);
C_lfr((arith)BEMINTSIZE);
conversion(INTTYPE,result);
if ( result == INTTYPE )
C_mli((arith)BEMINTSIZE);
else C_mlf((arith)BEMFLTSIZE);
/* End NEW code */
if (result == INTTYPE)
C_cmi((arith)BEMINTSIZE);
else C_cmf((arith)BEMFLTSIZE);
C_zgt((label)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 ! */
C_bra((label)fortable[forcnt].forinc);
C_df_ilb((label)fortable[forcnt].forout);
forcnt--;
}
}
pokestmt(type1,type2)
int type1,type2;
{
conversion(type1,INTTYPE);
conversion(type2,INTTYPE);
C_asp((arith)(2*BEMINTSIZE));
}
/* 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();
C_df_ilb((label)whilelabels[whilecnt][0]);
}
whiletst(exprtype)
int exprtype;
{
/* test expression type */
conversion(exprtype,INTTYPE);
C_zeq((label)whilelabels[whilecnt][1]);
}
wend()
{
if ( whilecnt<1)
error("not part of while statement");
else {
C_bra((label)whilelabels[whilecnt][0]);
C_df_ilb((label)whilelabels[whilecnt][1]);
whilecnt--;
}
}
/* generate code for the final version */
prologcode()
{
/* generate the EM prolog code */
C_df_dnam("fltnull");
C_con_cst((arith)0);
C_con_cst((arith)0);
C_con_cst((arith)0);
C_con_cst((arith)0);
C_df_dnam("dummy2");
C_con_cst((arith)0);
C_con_cst((arith)0);
C_con_cst((arith)0);
C_con_cst((arith)0);
/* NEW variable we make */
C_df_dnam("dummy3");
C_bss_dnam((arith)BEMPTRSIZE,"dummy3",(arith)0,0);
C_df_dnam("tronoff");
C_con_cst((arith)0);
C_df_dnam("dummy1");
C_con_cst((arith)0);
C_con_cst((arith)0);
C_con_cst((arith)0);
C_con_cst((arith)0);
C_exa_dnam("_iomode");
C_df_dnam("_iomode");
C_rom_scon("O",(arith)2);
C_exa_dnam("_errsym");
C_df_dnam("_errsym");
C_bss_cst((arith)BEMINTSIZE,(arith)0,1);
C_exa_dnam("_erlsym");
C_df_dnam("_erlsym");
C_bss_cst((arith)BEMINTSIZE,(arith)0,1);
}
prolog2()
{
int result;
label l = genlabel(), l2;
err_goto_label = genlabel();
C_exp("main");
C_pro("main",(arith)0);
C_ms_par((arith)0);
/* Trap handling */
C_cal("_ini_trp");
l2 = genemlabel();
C_rom_ilb(l);
C_lae_dlb(l2, (arith) 0);
C_loi((arith) BEMPTRSIZE);
C_exa_dnam("trpbuf");
C_lae_dnam("trpbuf",(arith)0);
C_cal("setjmp");
C_df_ilb(l);
C_asp((arith)(BEMPTRSIZE+BEMPTRSIZE));
C_lfr((arith)BEMINTSIZE);
C_dup((arith)BEMINTSIZE);
C_zeq((label)0);
C_lae_dnam("returns",(arith)0);
C_csa((arith)BEMINTSIZE);
C_df_ilb((label)0);
C_asp((arith)BEMINTSIZE);
result= sys_open(datfname, OP_WRITE, &datfile);
if ( result==0 ) fatal("improper file creation permission");
gendata();
}
/* NEW */
gendata()
{
C_loc((arith)0);
C_cal("_setchan");
C_asp((arith)BEMINTSIZE);
C_df_dnam("datfname");
C_rom_scon(datfname,(arith)strlen(datfname) + 1); /* EHB */
C_df_dnam("dattyp");
C_rom_scon("i\\0",(arith)4);
C_df_dnam("datfdes");
C_rom_dnam("datfname",(arith)0);
C_rom_cst((arith)1);
C_rom_cst((arith)(itoa(strlen(datfname))));
C_df_dnam("dattdes");
C_rom_dnam("dattyp",(arith)0);
C_rom_cst((arith)1);
C_rom_cst((arith)1);
C_lae_dnam("dattdes",(arith)0);
C_lae_dnam("datfdes",(arith)0);
C_loc((arith)0);
C_cal("_opnchn");
C_asp((arith)(2*BEMPTRSIZE+BEMINTSIZE));
}
epilogcode()
{
/* finalization code */
int nr;
nr= genlabel();
C_bra((label)nr);
genreturns();
C_df_ilb((label)nr);
datatable(); /* NEW */
C_loc((arith)0);
C_cal("_hlt");
C_df_ilb(err_goto_label);
C_cal("_goto_err");
C_end((arith)0);
}

340
lang/basic/src/graph.c Normal file
View file

@ -0,0 +1,340 @@
/*
* (c) copyright 1987 by the Vrije Universiteit, Amsterdam, The Netherlands.
* See the copyright notice in the ACK home directory, in the file "Copyright".
*/
#include "bem.h"
#ifndef NORSCID
static char rcs_id[] = "$Header$" ;
#endif
List *forwardlabel=0;
Linerecord *firstline,
*currline,
*lastline;
List *newlist()
{
List *l;
/* NOSTRICT */ l = (List *) salloc(sizeof(List));
return(l);
}
/* 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))
{
fprint(STDERR, "ERROR: line %d not defined\n",l->linenr);
errorcnt++;
}
l=l->nextlist;
}
}
newblock(nr)
int nr;
{
Linerecord *l;
List *frwrd;
if ( debug) print("newblock at %d\n",nr);
if ( nr>0 && currline && currline->linenr>= nr)
{
if ( debug) print("old line:%d\n",currline->linenr);
error("Lines out of sequence");
}
frwrd=srchforward(nr);
if ( frwrd && debug) print("forward found %d\n",frwrd->emlabel);
l= srchline(nr);
if ( l)
{
error("Line redefined");
nr= -genlabel();
}
/* make new EM block structure */
/* NOSTRICT */ l= (Linerecord *) salloc(sizeof(*l));
l->emlabel= frwrd ? frwrd->emlabel : genlabel();
l->linenr= nr;
/* 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) print("goto label %d\n",nr);
/* update currline */
ll= newlist();
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) print("declare forward %d\n",nr);
ll= newlist();
ll->emlabel= genlabel();
ll-> linenr=nr;
ll->nextlist= forwardlabel;
forwardlabel= ll;
nr= ll->emlabel;
} else nr= l1->emlabel;
return(nr);
}
gotostmt(nr)
int nr;
{
C_bra((label) 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;
l= newlist();
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);
/*return index */
C_loc((arith) n);
/* administer legal return */
C_cal("_gosub");
C_asp((arith) BEMINTSIZE);
C_bra((label) nr);
C_df_ilb((label)l->emlabel);
}
genreturns()
{
int nr;
nr= genlabel();
C_df_dnam("returns");
C_rom_ilb((label) nr);
C_rom_cst((arith)1);
C_rom_cst((arith) (gosubcnt-1));
while ( gosubhead)
{
C_rom_ilb((label) gosubhead->emlabel);
gosubhead= gosubhead->nextlist;
}
C_df_ilb((label) nr);
C_loc((arith) 1);
C_cal("error");
}
returnstmt()
{
C_cal("_retstmt");
C_lfr((arith) BEMINTSIZE);
C_lae_dnam("returns",(arith)0);
C_csa((arith) BEMINTSIZE);
}
/* compound goto-gosub statements */
List *jumphead,*jumptail;
int jumpcnt;
jumpelm(nr)
int nr;
{
List *l;
l= newlist();
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();
C_df_dlb((label)descr);
C_rom_ilb((label)firstlabel);
C_rom_cst((arith) 1);
C_rom_cst((arith)(jumpcnt-1));
l= jumphead;
while (l)
{
C_rom_ilb((label)l->emlabel);
l= l->nextlist;
}
jumphead= jumptail=0; jumpcnt=0;
if (debug) print("ongotst:%d labels\n", jumpcnt);
conversion(type,INTTYPE);
C_dup((arith) BEMINTSIZE);
C_zlt(err_goto_label);
C_lae_dlb((label) descr,(arith) 0);
C_csa((arith) BEMINTSIZE);
C_df_ilb((label)firstlabel);
}
ongosubstmt(type)
int type;
{
List *l;
int firstlabel;
int descr;
/* create descriptor first */
descr= genlabel();
firstlabel=genlabel();
C_df_dlb((label)descr);
C_rom_ilb((label)firstlabel);
C_rom_cst((arith)1);
C_rom_cst((arith)(jumpcnt-1));
l= jumphead;
while (l)
{
C_rom_ilb((label)l->emlabel);
l= l->nextlist;
}
jumphead= jumptail=0;
jumpcnt=0;
l= newlist();
l->nextlist=0;
l->emlabel=firstlabel;
if ( gotail){
gotail->nextlist=l;
gotail=l;
} else gotail=gosubhead=l;
/* save the return point of the gosub */
C_loc((arith) gosubcnt);
C_cal("_gosub");
C_asp((arith) BEMINTSIZE);
gosubcnt++;
/* generate gosub */
conversion(type,INTTYPE);
C_dup((arith) BEMINTSIZE);
C_zlt(err_goto_label);
C_lae_dlb((label) descr,(arith) 0);
C_csa((arith) BEMINTSIZE);
C_df_ilb((label)firstlabel);
}
/* REGION ANALYSIS and FINAL VERSION GENERATION */

37
lang/basic/src/graph.h Normal file
View file

@ -0,0 +1,37 @@
/*
* (c) copyright 1987 by the Vrije Universiteit, Amsterdam, The Netherlands.
* See the copyright notice in the ACK home directory, in the file "Copyright".
*/
#ifndef NORCSID
# define RCS_GRAPH "$Header$"
#endif
/*
** The control graph is represented by a multi-list structure.
** The em code is stored on the em intermediate file already
** The offset and length is saved only.
** Although this makes code generation mode involved, it allows
** rather large BASIC programs to be processed.
*/
typedef struct LIST {
int emlabel; /* em label used with forwards */
int linenr; /* BASIC line number */
struct LIST *nextlist;
} List;
typedef struct LINERECORD{
int emlabel; /* target label */
int linenr; /* BASIC line number */
List *callers; /* used from where ? */
List *gotos; /* fanout labels */
struct LINERECORD *nextline, *prevline;
int fixed; /* fixation of block */
} Linerecord;
extern Linerecord *firstline,
*currline,
*lastline;
extern List *forwardlabel;
extern List *gosublabel();

52
lang/basic/src/initialize.c Normal file
View file

@ -0,0 +1,52 @@
/*
* (c) copyright 1987 by the Vrije Universiteit, Amsterdam, The Netherlands.
* See the copyright notice in the ACK home directory, in the file "Copyright".
*/
#include "bem.h"
#include <em_path.h>
#ifndef NORSCID
static char rcs_id[] = "$Header$";
#endif
/* generate temporary files etc */
File *tmp_file;
File *datfile;
initialize()
{
register char *cindex, *cptr;
int result1, result2, result3;
(void) sprint(tmpfname,"%s/abc%d",TMP_DIR,getpid());
/* Find the basename */
/* Strip leading directories */
cindex= (char *)0;
for ( cptr=program; *cptr; cptr++ ) if ( *cptr=='/' ) cindex=cptr;
if ( !cindex ) cindex= program;
else {
cindex++;
if ( !*cindex ) {
warning("Null program name, assuming \"basic\"");
cindex= "basic";
}
}
cptr=datfname;
while ( *cptr++ = *cindex++ );
/* Strip trailing suffix */
if ( cptr>datfname+3 && cptr[-3]=='.' ) cptr[-3]=0;
strcat(datfname,".d");
C_init((arith)BEMINTSIZE, (arith)BEMPTRSIZE);
result1 = sys_open(inpfile, OP_READ, &yyin);
result2 = C_open(outfile);
result3 = sys_open(tmpfname,OP_WRITE, &tmp_file);
if ( result1==0 || result2== 0 || result3== 0 )
fatal("Improper file permissions");
fillkex(); /* initialize symbol table */
C_ms_emx((arith)BEMINTSIZE,(arith)BEMPTRSIZE);
initdeftype(); /* set default symbol declarers */
}

62
lang/basic/src/llmess.c Normal file
View file

@ -0,0 +1,62 @@
/*
* (c) copyright 1987 by the Vrije Universiteit, Amsterdam, The Netherlands.
* See the copyright notice in the ACK home directory, in the file "Copyright".
*/
#include "tokentab.h"
/* Mod van gertjan */
extern int LLsymb;
extern int toknum;
error_char(format,ch)
char *format;
char ch;
{
extern int listing,errorcnt;
extern int basicline;
if ( !listing ) fprint(STDERR, "LINE %d:",basicline);
fprint(STDERR, format,ch);
errorcnt++;
}
error_string(format,str)
char *format;
char *str;
{
extern int listing,errorcnt;
extern int basicline;
if ( !listing ) fprint(STDERR, "LINE %d:",basicline);
fprint(STDERR, format,str);
errorcnt++;
}
LLmessage( insertedtok )
int insertedtok;
{
if ( insertedtok < 0 ) {
error("Fatal stack overflow\n");
C_close();
sys_stop( S_EXIT );
}
if ( insertedtok == 0 )
if ( LLsymb < 256 )
error_char("%c deleted\n", (char)LLsymb);
else
error_string("%s deleted\n", tokentab[ LLsymb-256 ]);
else {
if ( insertedtok < 256 )
error_char("%c inserted\n", (char)insertedtok);
else
error_string("%s inserted\n", tokentab[ insertedtok-256 ]);
toknum = insertedtok;
}
}

17
lang/basic/src/maketokentab Executable file
View file

@ -0,0 +1,17 @@
cp Lpars.h tokentab.h
ex tokentab.h 2>&1 > /dev/null <<+
1d
1,\$s/# define //
1,\$s/ ...$//
1,\$s/^/ "/
1,\$-1s/\$/",/
\$s/\$/"/
0a
char *tokentab[] = {
.
\$a
};
.
w
q
+

85
lang/basic/src/parsepar.c Normal file
View file

@ -0,0 +1,85 @@
/*
* (c) copyright 1987 by the Vrije Universiteit, Amsterdam, The Netherlands.
* See the copyright notice in the ACK home directory, in the file "Copyright".
*/
#include "bem.h"
#ifndef NORSCID
static char rcs_id[] = "$Header$" ;
#endif
int listing; /* -l listing required */
int debug; /* -d compiler debugging */
int wflag=0; /* -w no warnings */
int traceflag=0; /* generate line tracing code */
int nolins=0; /* generate no LIN statements */
parseparams(argc,argv)
int argc;
char **argv;
{
int files=0 ;
int i;
register char *p;
if(argc< 4)
{
fprint(STDERR,"usage %s <flags> <file> <file> <source>\n",
argv[0]);
sys_stop(S_EXIT);
}
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 */
(void) fprint(STDERR,
"h option not implemented\n");
break;
case 'd': debug++;
break;
case 'L': nolins++;
break; /* no EM lin statements */
case 'E': listing++;
break; /* generate full listing */
case 'w': wflag++;
break; /* no warnings */
case 'V':
p = &argv[i][2];
while (*p) switch(*p++) {
case 'w':
BEMINTSIZE = *p++ - '0';
break;
case 'p':
BEMPTRSIZE = *p++ - '0';
break;
case 'f':
BEMFLTSIZE = *p++ - '0';
break;
default:
p++;
break;
}
} else {
/* new input file */
switch ( files++ ) {
case 0: inpfile= argv[i]; break;
case 1: outfile= argv[i]; break;
case 2: /* should be the source file
name */
program= argv[i];
break;
default:fatal("Too many file arguments") ;
}
}
if (files < 3) fatal("Too few file arguments");
}

376
lang/basic/src/symbols.c Normal file
View file

@ -0,0 +1,376 @@
/*
* (c) copyright 1987 by the Vrije Universiteit, Amsterdam, The Netherlands.
* See the copyright notice in the ACK home directory, in the file "Copyright".
*/
#include "bem.h"
#ifndef NORSCID
static char rcs_id[] = "$Header$" ;
#endif
/* 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) print("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 empty slot */
s = (Symbol *) salloc(sizeof(Symbol));
s->symtype= DEFAULTTYPE;
s->nextsym= firstsym;
s->symname= (char *) salloc((unsigned) strlen(str)+1);
strcpy(s->symname,str);
firstsym= s;
if (debug) print("%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) print("symbol set to %d\n",type);
}
dclarray(s)
Symbol *s;
{
int i; int size;
if ( s->symtype==DEFAULTTYPE) s->symtype= DOUBLETYPE;
if (debug) print("generate space and descriptors for %d\n",s->symtype);
if (debug) print("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--)
{
C_df_dlb((label)(s->dimalias[i]));
C_rom_cst((arith)indexbase);
C_rom_cst((arith)(s->dimlimit[i]-indexbase));
C_rom_cst((arith)(size*typesize(s->symtype)));
size = size* (s->dimlimit[i]+1-indexbase);
}
if (debug) print("size=%d\n",size);
/* size of stuff */
C_df_dlb((label)s->symalias);
get_space(s->symtype,size); /* Van ons. */
}
get_space(type,size)
int type,size;
{
switch ( type ) {
case INTTYPE:
C_bss_cst((arith)BEMINTSIZE*size,
(arith)0,
1);
break;
case FLOATTYPE:
case DOUBLETYPE:
C_bss_fcon((arith)BEMFLTSIZE*size,
"0.0",
(arith)BEMFLTSIZE,
1);
break;
case STRINGTYPE: /* Note: this is ugly. Gertjan */
C_bss_icon((arith)BEMPTRSIZE*size,
"0",
(arith)BEMPTRSIZE,
1);
break;
default:
error("Space allocated for unknown type. Coredump.");
abort(); /* For debugging purposes */
}
}
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:
C_bss_icon((arith)BEMPTRSIZE,"0",(arith)BEMPTRSIZE,1);
break;
case INTTYPE:
C_bss_cst((arith)BEMINTSIZE,(arith)0,1);
break;
case FLOATTYPE:
case DOUBLETYPE:
C_bss_fcon((arith)BEMFLTSIZE,"0.0",(arith)BEMFLTSIZE,1);
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) print("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) print("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];
sprint(procname,"_%s",fcn->symname);
C_pro_narg(procname);
if ( fcn->symtype== DEFAULTTYPE)
fcn->symtype= DOUBLETYPE;
}
int fcnsize()
{
/* generate portable function size */
int i,sum; /* sum is NEW */
sum = 0;
for(i=0;i<fcn->dimensions;i++)
sum += typesize(fcn->dimlimit[i]);
return(sum);
}
endscope(type)
int type;
{
Symbol *s;
if ( debug) print("endscope");
conversion(type,fcn->symtype);
C_ret((arith) typestring(fcn->symtype));
/* generate portable EM code */
C_end( (arith)fcnsize() );
s= firstsym;
while (s)
{
firstsym = s->nextsym;
(void) free((char *)s);
s= firstsym;
}
firstsym= alternate;
alternate = NIL;
fcn=NIL;
}
dclparm(s)
Symbol *s;
{
int size=0;
if ( s->symtype== DEFAULTTYPE)
s->symtype= DOUBLETYPE;
s->isparam=1;
fcn->dimlimit[fcn->dimensions]= s->symtype;
fcn->dimensions++;
s->symalias= -fcn->dimensions;
if ( debug) print("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;
}
return(s->symtype);
}
fcnend(parmcount)
int parmcount;
{
int type;
static char concatbuf[50]; /* NEW */
/* check number of arguments */
if ( parmcount <fcn->dimensions)
error("not enough parameters");
if ( parmcount >fcn->dimensions)
error("too many parameters");
(void) sprint(concatbuf,"_%s",fcn->symname);
C_cal(concatbuf);
C_asp((arith)fcnsize());
C_lfr((arith) 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]);
}

88
lang/basic/src/symbols.h Normal file
View file

@ -0,0 +1,88 @@
/*
* (c) copyright 1987 by the Vrije Universiteit, Amsterdam, The Netherlands.
* See the copyright notice in the ACK home directory, in the file "Copyright".
*/
#ifndef NORCSID
# define RCS_SYMB "$Header$"
#endif
#define NIL 0
#define TRUE 1
#define FALSE 0
#define DEFAULTTYPE 500
#define INTTYPE 501
#define FLOATTYPE 502
#define DOUBLETYPE 503
#define STRINGTYPE 504
#define ABSSYM 520
#define ASCSYM 521
#define ATNSYM 522
#define CDBLSYM 524
#define CHRSYM 525
#define CINTSYM 526
#define COSSYM 527
#define CSNGSYM 528
#define CVISYM 529
#define CVSSYM 530
#define CVDSYM 531
#define EOFSYM 532
#define EXPSYM 533
#define FIXSYM 534
#define FRESYM 535
#define HEXSYM 536
#define INPSYM 538
#define INSTRSYM 539
#define LEFTSYM 540
#define LENSYM 541
#define LOCSYM 542
#define LOGSYM 543
#define LPOSSYM 544
#define MKISYM 546
#define MKSSYM 547
#define MKDSYM 548
#define OCTSYM 549
#define PEEKSYM 550
#define POSSYM 551
#define RIGHTSYM 552
#define RNDSYM 553
#define SGNSYM 554
#define SINSYM 555
#define SPACESYM 556
#define SPCSYM 557
#define SQRSYM 558
#define STRSYM 559
#define STRINGSYM 560
#define TABSYM 561
#define TANSYM 562
#define VALSYM 564
#define VARPTRSYM 565
/* some stuff forgotten */
#define INTSYM 567
#define AUTOSYM 568
#define LISTSYM 569
#define LOADSYM 570
#define MERGESYM 571
#define TRONSYM 572
#define TROFFSYM 0 /* NIEUW : was 573, werkte als TRON */
/* IMPSYM, EQVSYM en XORSYM zijn tokens geworden */
#define OUTSYM 577
#define MAXDIMENSIONS 10
typedef struct SYMBOL{
char *symname;
int symalias;
int symtype;
int dimensions; /* dimension array/function */
int dimlimit[MAXDIMENSIONS]; /* type of parameter */
int dimalias[MAXDIMENSIONS];
struct SYMBOL *nextsym;
int isfunction;
int parmsize;
int isparam;
} Symbol;
extern Symbol *srchsymbol();

98
lang/basic/src/util.c Normal file
View file

@ -0,0 +1,98 @@
/*
* (c) copyright 1987 by the Vrije Universiteit, Amsterdam, The Netherlands.
* See the copyright notice in the ACK home directory, in the file "Copyright".
*/
#include "bem.h"
#ifndef NORSCID
static char rcs_id[] = "$Header$" ;
#endif
#define abs(X) (X>=0?X:-X)
/* Miscelaneous routines can be found here */
int errorcnt;
warning(str)
char *str;
{
if (wflag) return;
Xerror("WARNING", str);
}
error(str)
char *str;
{
Xerror("ERROR", str);
errorcnt++;
}
Xerror(type, str)
char *str;
char *type;
{
extern int listing;
extern int basicline;
if( !listing) fprint(STDERR, "LINE %d:",basicline);
fprint(STDERR, "%s:%s\n",type, str);
}
fatal(str)
char *str;
{
Xerror("FATAL",str);
C_close();
sys_stop(S_EXIT);
}
notyetimpl()
{
warning("not yet implemented");
}
illegalcmd()
{
warning("illegal command");
}
char *itoa(i)
int i;
{
static char buf[30];
(void) sprint(buf,"%d",i);
return(buf);
}
char *salloc(length)
unsigned length;
{
char *s,*c;
extern char *malloc() ;
s=c=malloc(length);
if ( !s ) fatal("Out of memory") ;
while(length--)*c++ =0;
return(s);
}

22
lang/basic/src/yylexp.c Normal file
View file

@ -0,0 +1,22 @@
/*
* (c) copyright 1987 by the Vrije Universiteit, Amsterdam, The Netherlands.
* See the copyright notice in the ACK home directory, in the file "Copyright".
*/
int toknum;
yylexp()
{
/* als toknum != 0 dan bevat toknum een door LLmessage back-ge-pushed token */
int t;
if ( toknum == 0 )
return(yylex());
else {
t = toknum;
toknum = 0;
return(t);
}
}