--- /dev/null
+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
--- /dev/null
+# $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
--- /dev/null
+/*
+ * (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
+}
--- /dev/null
+/*
+ * (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++);
+}
--- /dev/null
+/*
+ * (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 */
+}
--- /dev/null
+/*
+ * (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();
--- /dev/null
+/*
+ * (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);
+}
--- /dev/null
+/*
+ * (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]++;
+}
+
+
+
--- /dev/null
+/*
+ * (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);
+}
+
--- /dev/null
+/*
+ * (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);
+}
--- /dev/null
+/*
+ * (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 */
+
+
--- /dev/null
+/*
+ * (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();
--- /dev/null
+/*
+ * (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 */
+}
--- /dev/null
+/*
+ * (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;
+ }
+}
--- /dev/null
+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
++
--- /dev/null
+/*
+ * (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");
+}
--- /dev/null
+/*
+ * (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]);
+}
--- /dev/null
+/*
+ * (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();
--- /dev/null
+/*
+ * (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);
+}
+
+
+
--- /dev/null
+/*
+ * (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);
+ }
+}
+
public / ack.git / commitdiff