From: ceriel Date: Mon, 4 Jul 1988 11:45:41 +0000 (+0000) Subject: Initial revision X-Git-Tag: release-5-5~3115 X-Git-Url: https://git.ndcode.org/public/gitweb.cgi?a=commitdiff_plain;h=c39c6668343e25fde4ee01f517b38aae1390fe92;p=ack.git Initial revision --- diff --git a/lang/basic/src/.distr b/lang/basic/src/.distr new file mode 100644 index 000000000..7fdce9cd0 --- /dev/null +++ b/lang/basic/src/.distr @@ -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 diff --git a/lang/basic/src/Makefile b/lang/basic/src/Makefile new file mode 100644 index 000000000..61052c553 --- /dev/null +++ b/lang/basic/src/Makefile @@ -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 diff --git a/lang/basic/src/basic.g b/lang/basic/src/basic.g new file mode 100644 index 000000000..576177481 --- /dev/null +++ b/lang/basic/src/basic.g @@ -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->dimensionsdimlimit[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 +} diff --git a/lang/basic/src/basic.lex b/lang/basic/src/basic.lex new file mode 100644 index 000000000..e9e11180c --- /dev/null +++ b/lang/basic/src/basic.lex @@ -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->namename!=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 + +/* 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= 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++); +} diff --git a/lang/basic/src/bem.c b/lang/basic/src/bem.c new file mode 100644 index 000000000..fe747dc6c --- /dev/null +++ b/lang/basic/src/bem.c @@ -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 */ +} diff --git a/lang/basic/src/bem.h b/lang/basic/src/bem.h new file mode 100644 index 000000000..124a42053 --- /dev/null +++ b/lang/basic/src/bem.h @@ -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 +#include +#include +#include +#include +#include + +/* 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(); diff --git a/lang/basic/src/compile.c b/lang/basic/src/compile.c new file mode 100644 index 000000000..f008dffd1 --- /dev/null +++ b/lang/basic/src/compile.c @@ -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); +} diff --git a/lang/basic/src/eval.c b/lang/basic/src/eval.c new file mode 100644 index 000000000..f0447ca5a --- /dev/null +++ b/lang/basic/src/eval.c @@ -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': 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 ( dimtopdimensions==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]++; +} + + + diff --git a/lang/basic/src/func.c b/lang/basic/src/func.c new file mode 100644 index 000000000..324bba737 --- /dev/null +++ b/lang/basic/src/func.c @@ -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); +} + diff --git a/lang/basic/src/gencode.c b/lang/basic/src/gencode.c new file mode 100644 index 000000000..6dfc2ef06 --- /dev/null +++ b/lang/basic/src/gencode.c @@ -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); +} diff --git a/lang/basic/src/graph.c b/lang/basic/src/graph.c new file mode 100644 index 000000000..1de5aa39d --- /dev/null +++ b/lang/basic/src/graph.c @@ -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 */ + + diff --git a/lang/basic/src/graph.h b/lang/basic/src/graph.h new file mode 100644 index 000000000..cc785a110 --- /dev/null +++ b/lang/basic/src/graph.h @@ -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(); diff --git a/lang/basic/src/initialize.c b/lang/basic/src/initialize.c new file mode 100644 index 000000000..7a347fd6b --- /dev/null +++ b/lang/basic/src/initialize.c @@ -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 + +#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 */ +} diff --git a/lang/basic/src/llmess.c b/lang/basic/src/llmess.c new file mode 100644 index 000000000..ec96261ef --- /dev/null +++ b/lang/basic/src/llmess.c @@ -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; + } +} diff --git a/lang/basic/src/maketokentab b/lang/basic/src/maketokentab new file mode 100755 index 000000000..9524ece56 --- /dev/null +++ b/lang/basic/src/maketokentab @@ -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 ++ diff --git a/lang/basic/src/parsepar.c b/lang/basic/src/parsepar.c new file mode 100644 index 000000000..f27fb9ff9 --- /dev/null +++ b/lang/basic/src/parsepar.c @@ -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 \n", + argv[0]); + sys_stop(S_EXIT); + } + + for(i=1;isymname,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;idimensions;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;idimensions;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;idimensions;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 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]); +} diff --git a/lang/basic/src/symbols.h b/lang/basic/src/symbols.h new file mode 100644 index 000000000..a2ea965a1 --- /dev/null +++ b/lang/basic/src/symbols.h @@ -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(); diff --git a/lang/basic/src/util.c b/lang/basic/src/util.c new file mode 100644 index 000000000..8f59c3c37 --- /dev/null +++ b/lang/basic/src/util.c @@ -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); +} + + + diff --git a/lang/basic/src/yylexp.c b/lang/basic/src/yylexp.c new file mode 100644 index 000000000..a1b1ba01d --- /dev/null +++ b/lang/basic/src/yylexp.c @@ -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); + } +} +