Selaa lähdekoodia

Initial revision

ceriel 36 vuotta sitten
vanhempi
commit
08fd084d59

+ 20 - 0
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

+ 64 - 0
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

+ 792 - 0
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->dimensions<MAXDIMENSIONS) {
+						s->dimlimit[s->dimensions]=ival;
+						s->dimensions++;
+					} else error("too many dimensions");
+				}
+	  ]* ;
+
+fieldstmt { int intv; }
+	:	FIELDSYM cross intvalue(&intv) 
+					{ setchannel(ival); }
+		',' fieldlist		{ notyetimpl(); }
+        ;
+
+fieldlist { int intv,var; }
+	:	intvalue(&intv) ASSYM variable(&var)
+		[ ',' intvalue(&intv) ASSYM variable(&var) ]*
+	;
+
+forstmt { int exp; }
+	: FORSYM IDENTIFIER		{ forinit(yylval.Sptr); }
+	  '=' expression(&exp)		{ forexpr(exp); }
+	  TOSYM expression(&exp)	{ forlimit(exp); }
+	  step
+	;
+
+step { int exp; }
+	: STEPSYM expression(&exp)	{ forstep(exp); }
+	| /*EMPTY*/			{ 
+                                     		C_loc((arith) 1);
+                                     		forstep(INTTYPE); 
+					}
+	;
+
+nextstmt: [ IDENTIFIER 			{ nextstmt(yylval.Sptr); } 
+	  | /* empty */ 		{ nextstmt((Symbol *)0); }
+	  ]
+          [ ',' IDENTIFIER 		{ nextstmt(yylval.Sptr); } 
+	  ]*
+	  ;
+
+getstmt { char *cp; int intv; }
+	: getput(&cp)
+	  [ /* empty */ 
+				{ C_loc((arith) 0);
+                     		  C_cal(cp);
+                     		  C_asp((arith) BEMINTSIZE);
+				}
+	| ',' intvalue(&intv)
+				{ C_loc((arith) ival);
+                           	  C_cal(cp);
+                           	  C_asp((arith) BEMINTSIZE);
+				}
+	]
+	;
+
+getput(char **cpp;) { int intv; }
+	: GETSYM cross intvalue(&intv)
+	  			{ setchannel(ival); 
+				  *cpp = "$_getrec";
+				}
+	| PUTSYM cross intvalue(&intv)
+	  			{ setchannel(ival); 
+			  	  *cpp = "$_putsym";
+				}
+	;
+
+gosubstmt:	GOSUBSYM INTVALUE	{ gosubstmt(ival); } 
+	 ;
+
+returnstmt:	RETURNSYM		{ returnstmt(); } 
+	  ;
+
+ifstmt { int exp; int d1; }
+	:	IFSYM expression(&exp)  { d1=ifstmt(exp); }
+		thenpart 		{ d1=thenpart(d1); }
+		elsepart 		{ elsepart(d1); }
+	;
+
+thenpart:	THENSYM [ INTVALUE	{ gotostmt(ival); }
+                        | stmts
+			]
+	|	GOTOSYM INTVALUE	{ gotostmt(ival); }
+	;
+
+elsepart:	%prefer ELSESYM 
+			[ INTVALUE  	{ gotostmt(ival); }
+                        | stmts
+			]
+	|	/* empty */
+	;
+
+inputstmt { int intv; }
+	:	INPUTSYM  [ semiprompt  readlist 
+                          | '#' intvalue(&intv)
+		 	    		{ setchannel(ival); }
+		            ',' readlist
+			  ]
+	;
+
+semiprompt { int str; }
+	: semi STRVALUE 	{ str = yylval.integer; }
+          [ ';'			{ loadstr(str); 
+				  prompt(1); 
+				}
+	  | ',' 		{ loadstr(str); 
+				  prompt(0); 
+				}
+          ]
+	| /*EMPTY*/
+	   			{ setchannel(-1);
+                                  C_cal("_qstmark"); 
+				}
+	;
+
+semi	: ';'
+	| /* empty */
+	;
+
+letstmt { int var,exp; }
+	:	LETSYM		
+		variable(&var)		 { save_address(); }
+		'=' expression(&exp)  	 { assign(var,exp); }
+	|
+		variable(&var)		 { save_address(); }
+		'=' expression(&exp)	 { assign(var,exp); }
+	;
+
+lineinputstmt { int var,intv; }
+	: 	LINESYM
+		[ INPUTSYM
+	  	  semiprompt		 { setchannel(-1); }
+	  	  variable(&var)	 { linestmt(var); } 
+		| '#'
+		  intvalue(&intv) 	 { setchannel(ival); }
+		  ','
+		  variable(&var)	 { linestmt(var); }
+		]
+	;
+
+readlist: readelm		
+	  [ ',' readelm ]*
+	  ;
+
+readelm { int var; }
+	: variable(&var)	{ readelm(var); }
+	;
+
+lsetstmt { int var,exp; }
+	:	LSETSYM variable(&var) '=' expression(&exp)
+				{ notyetimpl(); }
+	;
+
+midstmt { int exp; }
+	:	MIDSYM '$'  midparms '=' expression(&exp) 
+				{ C_cal("_midstmt");
+                     		  C_asp((arith) (2*BEMINTSIZE + 2*BEMPTRSIZE));
+				}
+	;
+
+midparms:	'(' midfirst midsec midthird ')' 
+	;
+
+midfirst { int exp; }
+	: expression(&exp) 	{ conversion(exp,STRINGTYPE); } 
+	;
+
+midsec { int exp; }
+	: ',' expression(&exp) 	{ conversion(exp,INTTYPE); } 
+	;
+
+midthird { int exp; }
+	: ',' expression(&exp) 	{ conversion(exp,INTTYPE); }
+	| /* empty */ 		{ C_loc((arith) -1); }
+	;
+
+onstmt : ONSYM 
+	 [ exceptionstmt
+	 | ongotostmt
+	 ]
+	 ;
+
+exceptionstmt:	ERRORSYM GOTOSYM INTVALUE	{ exceptstmt(ival); }
+	     ;
+
+ongotostmt { int exp; }
+	:	expression(&exp) 
+		[ GOSUBSYM constantlist 	{ ongosubstmt(exp); }
+		| GOTOSYM constantlist  	{ ongotostmt(exp); }
+		]
+	;
+	
+constantlist: INTVALUE		{ jumpelm(ival); }
+	      [ ',' INTVALUE	{ jumpelm(ival); } 
+              ]* 
+	    ;
+
+openstmt { int exp; }
+	:	OPENSYM mode openchannel expression(&exp) 
+				{ conversion(exp,STRINGTYPE); }
+		[ /* empty */	{ openstmt(0);  }
+		| INTVALUE	{ openstmt(ival); }
+		]
+	;
+
+openchannel: cross INTVALUE ','	{ setchannel(ival); } 
+	   ;
+
+mode { int exp; }
+	: expression(&exp) ',' 	{ conversion(exp,STRINGTYPE); }
+	| ','	     	        { C_lae_dnam("_iomode",(arith)0); }
+	;
+
+optionstmt { int intv; }
+	:	OPTIONSYM BASESYM intvalue(&intv) { optionbase(ival); }
+	;
+
+printstmt { int plist; }
+	:	PRINTSYM
+		[ /* empty */	{ setchannel(-1);
+                                  C_cal("_nl"); 
+				}
+		| file format printlist(&plist) 
+		  		{ if(plist) 
+                                  C_cal("_nl");            
+				}
+		]
+	;
+
+file { int intv; }
+	: '#' intvalue(&intv) ','	{ setchannel(ival); }
+	| /* empty */			{ setchannel(-1); }
+	;
+
+format { int var ; }
+	: USINGSYM
+          [ STRVALUE 		{ loadstr(yylval.integer); } ';'		
+	  | variable(&var) ';'
+	    			{ if(var!=STRINGTYPE) 
+					error("string variable expected"); 
+				}
+	  ]
+	| /* empty */ 		{ formatstring=0; }
+	;
+
+printlist(int *ip;) { int exp; }
+	: [ expression(&exp)		{ printstmt(exp); *ip=1; }
+	  | ','				{ zone(1); *ip=0; }
+	  | ';'				{ zone(0); *ip=0; }
+	  ]+
+	;
+
+pokestmt { int exp1,exp2 ; }
+	: POKESYM
+	  expression(&exp1)
+	  ','
+	  expression(&exp2)	{ pokestmt(exp1,exp2); }
+	;
+
+randomizestmt { int exp; }
+	:	RANDOMIZESYM 
+		[ /* empty */ 		{ C_cal("_randomi"); }
+		| expression(&exp)
+		  			{ conversion(exp,INTTYPE);
+                       			  C_cal("_setrand");
+                       			  C_asp((arith) BEMINTSIZE);     
+					} 
+		]
+	;
+
+readstmt { int var; }
+	:	READSYM 		{ setchannel(0); }
+                variable(&var)    	{ readelm(var); }
+		[ ',' variable(&var)	{ readelm(var); } 
+		]*
+	;
+
+restorestmt :	RESTORESYM
+		[ INTVALUE	{ restore(ival); }
+		| /* empty */   { restore(0); }
+		]
+	    ;
+	
+swapstmt { int var1,var2; }
+	: SWAPSYM
+	  variable(&var1)
+	  ','
+	  variable(&var2)	{ swapstmt(var1,var2); }
+	;
+
+whilestmt { int exp; }
+	: WHILESYM 	   	 { whilestart(); }
+	  expression(&exp)	 { whiletst(exp); }
+	;
+
+wendstmt :	WENDSYM		 { wend(); }
+	 ;
+
+writestmt:	WRITESYM
+		[ /* empty */		{ setchannel(-1);
+                                          C_cal("_wrnl");    
+					}
+		| file writelist 	{ C_cal("_wrnl");  }
+		]
+	;
+
+writelist { int exp; }
+	: expression(&exp)		{ writestmt(exp,0); }
+	  [ ',' expression(&exp)	{ writestmt(exp,1); } 
+	  ]*
+	;
+
+cross: '#' | /* empty */ ;	
+
+intvalue(int *ip;)
+	: INTVALUE 	{ *ip = yylval.integer; } 
+	;
+
+variable(int *ip;) { Symbol *symp; int exp; }
+	: identifier(&symp)
+	  [ %avoid /* empty */ 		{ *ip = loadaddr(symp); }
+	  | '(' 	                { newarrayload(symp); } 
+	    expression(&exp) 		{ loadarray(exp); }
+	    [ ',' expression(&exp)	{ loadarray(exp); } ]*
+	    ')'				{ *ip = endarrayload(); }
+          ]
+	| ERRSYM			{ C_lae_dnam("_errsym",(arith) 0); 
+					  *ip = INTTYPE; 
+					} 
+	| ERLSYM			{ C_lae_dnam("_erlsym",(arith) 0); 
+					  *ip = INTTYPE; 
+					}
+	;
+
+expression(int *ip;) { int neg; } /* NIEUW */
+	: expression1(&neg)       	{ *ip = neg; } 
+          [
+            IMPSYM
+            expression(&neg)        	{ *ip = boolop(*ip,neg,IMPSYM); }
+          ]?
+        ;
+
+
+expression1(int *ip;) { int neg; }
+	: expression2(&neg)     { *ip = neg; } 
+          [ EQVSYM
+	    expression2(&neg)   { *ip = boolop(*ip,neg,EQVSYM); }
+          ]*
+        ;
+
+expression2(int *ip;) { int neg; } 
+	: expression3(&neg)     { *ip = neg; } 
+          [ XORSYM
+	    expression3(&neg)   { *ip = boolop(*ip,neg,XORSYM); }
+          ]*
+        ;
+
+expression3(int *ip;) { int neg; }
+	: expression4(&neg)     { *ip = neg; } 
+          [ ORSYM
+	    expression4(&neg)   { *ip = boolop(*ip,neg,ORSYM); }
+          ]*
+        ;
+
+expression4(int *ip;) { int neg; }
+	: negation(&neg)     { *ip = neg; } 
+          [ ANDSYM
+	    negation(&neg)   { *ip = boolop(*ip,neg,ANDSYM); }
+          ]*
+        ;
+
+negation(int *ip;) { int comp; }
+	: NOTSYM compare(&comp)		{ *ip=boolop(comp,0,NOTSYM); }
+	| compare(ip)
+	;
+
+compare(int *ip;) { int sum1,sum2,rel; }
+	: sum(&sum1)
+          [ /* empty */      { *ip = sum1; }
+	  | RELOP            { rel=yylval.integer; } 
+            sum(&sum2)       { *ip=relop(sum1,sum2,rel); }
+	  | '=' sum(&sum2)   { *ip=relop(sum1,sum2,'='); }
+          ]
+	;
+
+sum(int *ip;) { int term1; }
+	: term(&term1)       { *ip = term1; }
+          [ %while(1)  
+            '-' term(&term1) { *ip=plusmin(*ip,term1,'-'); }
+	  | '+' term(&term1) { *ip=plusmin(*ip,term1,'+'); }
+	  ]*
+	;
+
+term(int *ip;) { int fac1; }	
+	: factor(&fac1)            { *ip = fac1; }
+	  [ '*'    factor(&fac1)   { *ip=muldiv(*ip,fac1,'*'); }
+	  | '\\'   factor(&fac1)   { *ip=muldiv(*ip,fac1,'\\'); }
+	  | '/'    factor(&fac1)   { *ip=muldiv(*ip,fac1,'/'); }
+	  | MODSYM factor(&fac1)   { *ip=muldiv(*ip,fac1,MODSYM); }
+          ]*
+	;
+
+factor(int *ip;)
+	: '-' factor(ip)         { *ip=negate(*ip); }
+	| factor1(ip)
+        ;
+
+factor1(int *ip;)  { int mant,exp; }
+	: factor2(&mant)
+          [ /* empty */          { *ip = mant; } 
+          | '^' factor1(&exp)    { *ip = power(mant,exp); }
+          ]
+        ;
+
+factor2(int *ip;)
+    { int var,func,expl,funcc,exp,intv,funcn,inpt; int typetable[10]; }
+	: INTVALUE			{ *ip=loadint(ival); }
+	| '(' expression(&exp) ')'      { *ip=exp; }
+	| FLTVALUE			{ *ip=loaddbl(dval); }
+	| STRVALUE		
+	  				{ *ip= STRINGTYPE; 
+					  loadstr(yylval.integer); 
+					}
+	| variable(&var)
+	  				{ *ip=var; 
+					  loadvar(var); 
+					}
+	| INKEYSYM '$' 			{ C_cal("_inkey");
+                                          C_lfr((arith) BEMPTRSIZE);
+					  *ip= STRINGTYPE;
+					}
+	| VARPTR '(' '#' intvalue(&intv) ')'
+	  				{ warning("Not supported"); 
+					  *ip=INTTYPE; 
+					}
+	| FUNCTION    			{ func=yylval.integer; }		
+          [ %avoid /* empty */       	{ *ip= callfcn(yylval.integer,0, typetable); }
+	  | '(' cross exprlist(&expl, typetable) ')' 
+					{ *ip=callfcn(func,expl, typetable); }
+          ]
+	| funcname(&funcn)
+          [ %avoid /* empty */         	{ *ip=fcnend(0); }
+	  | funccall(&funcc) ')'	{ *ip=fcnend(funcc); }
+          ]
+	| MIDSYM '$' midparms  	
+					{ 
+                   			  C_cal("_mid");
+                   			  C_asp((arith) (2*BEMINTSIZE+BEMPTRSIZE));
+                   		 	  C_lfr((arith) BEMPTRSIZE);
+					  *ip= STRINGTYPE;
+					}
+	| INPUTSYM '$' '(' expression(&exp) inputtail(&inpt)
+					{ /*waar worden inpt en  exp gebruikt?*/
+             				  C_cal("_inpfcn");
+             				  C_asp((arith) (2*BEMINTSIZE+BEMPTRSIZE));
+	  				  *ip= STRINGTYPE;
+					}
+	;
+
+inputtail(int *ip;) { int exp; }
+	: ',' cross expression(&exp) ')'
+					{ conversion(exp,INTTYPE); 
+					  *ip= INTTYPE; 
+					}
+	| ')'
+	  				{ C_loc((arith) -1);  
+					  *ip= INTTYPE; 
+					}
+	;
+
+funcname(int *ip;)
+	: FUNCTID		{ *ip=fcncall(yylval.Sptr); }
+        ;
+
+funccall(int *ip;) { int exp; }
+	:  '(' expression(&exp) { callparm(0,exp);*ip=1; }
+	[ ',' expression(&exp)	{ callparm(*ip,exp); 
+			 	  *ip = *ip+1; 
+				} 
+	]*
+	;
+	
+identifier(Symbol **ident;)
+	: IDENTIFIER		{ dcltype(yylval.Sptr); 
+				  *ident=yylval.Sptr; 
+				}
+        ;
+
+exprlist(int *ip; int *typetable;) { int exp; }
+	: expression(&exp)		{ typetable[0]=exp; 
+					  *ip=1; 
+					}
+	  [ ',' expression(&exp)	{ typetable[*ip]=exp;
+					  *ip = *ip+1; 
+					} 
+	  ]*
+	;
+
+{
+#ifndef NORCSID
+static char rcs_id[]	= "$Header$" ;
+#endif
+}

+ 613 - 0
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->name<i+'a';k++);
+		if ( *k->name!=i+'a') continue;
+		kex[*k->name-'a']=k-keywords;
+		for(;k->name && *k->name==i+'a';k++);
+		kex[*(k-1)->name-'a'+1]=k-keywords;
+	}
+	if (debug)
+	{
+		for(i=0;i<27;i++)
+		print("%c:%d\n",'a'+i,kex[i]);
+	}
+}
+
+#include <ctype.h>
+
+/* Get each line separately into the buffer */
+/* Lines too long are terminated and flagged illegal */
+
+#define MAXLINELENGTH	1024
+
+char	inputline[MAXLINELENGTH];	/* current source line */
+char	*cptr;				/* next character to decode */
+int	yylineno=0;			/* source line counter */
+
+#define GETSBUFSIZE 1024
+
+char fgets_buf[GETSBUFSIZE];
+
+
+
+char *our_fgets(buffer,n_char,stream)
+char *buffer;
+int n_char;
+File *stream;
+{
+    /* Read one line or n_char */
+    static int characters_left = 0;
+    static char *internal_bufp = fgets_buf;
+    char *external_bufp;
+
+    external_bufp = buffer;  /* Moves through the external buffer */
+    while ( 1 ) {
+        if ( characters_left ) { /* There is still something buffered */
+            if ( n_char > 1 ) { /* More characters have to be copied  */
+                if ( *internal_bufp == '\n' ) {
+                    *external_bufp++ = *internal_bufp++;
+                    characters_left--;
+                    *external_bufp = '\0';
+                    return(buffer); /* One line is read */
+                } else {
+                    *external_bufp++ = *internal_bufp++;
+                    characters_left--;
+                    n_char--;  /* One character is copied */
+                }
+            } else { /* Enough characters read */
+                *external_bufp = '\0';
+                return(buffer);
+            }
+        } else { /* Read new block */
+            sys_read(stream,fgets_buf,GETSBUFSIZE,&characters_left);
+            internal_bufp = fgets_buf;
+                /* Move pointer  back to the beginning */
+            if ( characters_left == 0 ) { /* Nothing read */
+                if ( external_bufp == buffer ) {
+                    *external_bufp = '\0';
+                    return(NULL);  /* EOF */
+                } else { /* Something was already copied */
+                    *external_bufp = '\0';
+                    return(buffer);
+                }
+            }
+        }
+    }
+}
+
+extern char *strindex();
+
+getline()
+{
+	/* get next input line */
+
+	if ( our_fgets(inputline,MAXLINELENGTH,yyin) == NULL)
+		return(FALSE);
+	yylineno ++;
+	if ( strindex(inputline,'\n') == 0)
+		error("source line too long");
+	inputline[MAXLINELENGTH-1]=0;
+	if ( listing)
+		fprint(STDERR, inputline);
+	cptr= inputline;
+	return(TRUE);
+}
+
+
+
+
+
+typechar()
+{
+	switch(*cptr)
+	{
+	case '$':
+		cptr++; return( STRINGTYPE);
+	case '%':
+		cptr++; return( INTTYPE);
+	case '!':
+		cptr++; return( FLOATTYPE);
+	case '#':
+		cptr++; return( DOUBLETYPE);
+	}
+	return(0);
+}
+
+
+/* symbols in Microsoft are significant for the first 40 characters */
+#define SIGNIFICANT 40
+char name[SIGNIFICANT+1];
+
+
+lookup()
+{
+	Key *k;
+	Symbol *Sym;
+	char *c;
+	int i, typech;
+
+	sval= name;
+	for(c=cptr; *c && isalnum(*c);c++) 
+	if ( isupper(*c) )
+		*c= tolower(*c);
+	for (k= keywords+kex[*cptr-'a']; k->name != 0 && *(k->name)== *cptr;k++)
+		if ( strncmp(cptr,k->name,k->length)==0)
+		{
+			/* if ( isalnum( *(cptr+k->length) )) *//* EHB */
+			if ( isalnum( *(cptr+k->length) ) &&	/* EHB */
+				k->token == FUNCTION)		/* EHB */
+				continue; 
+                                /* keywords door delimiters gescheiden */
+			cptr += k->length;
+			yylval.integer= k->classvalue;
+			if (debug) print("lookup:%d %d\n",
+					 k->classvalue,k->token);
+			if ( k->token == FUNCTION)
+			{
+				/* stripp type character */
+				typech=typechar();
+			}
+				/* illegals + rem */
+				if ( k->token == REMSYM || k->token==ILLEGAL)
+					while ( *cptr && *cptr!=':' && 
+                                                *cptr!='\n')
+						cptr++;
+				return( k->token);
+		}
+	/* Is it  a function  name ? */
+	c=cptr;
+	/* Identifier found, update the symbol table */
+	i=0;
+	while (( isalnum(*c) || *c == '.') && i < SIGNIFICANT)
+		name[i++]= *c++;
+	while (isalnum(*c) || *c == '.') c++; /* skip rest */
+	name[i]=0;
+	cptr=c;
+	Sym= srchsymbol(name);
+	yylval.Sptr = Sym;
+	typech= typechar();
+	if (Sym->symtype!=DEFAULTTYPE) 
+	{
+		if (typech && typech!=Sym->symtype && wflag)
+			warning("type re-declared,ignored");
+	}
+	if ( typech)
+		Sym->symtype=typech;
+	if (debug) print("lookup:%d Identifier\n",Sym);
+	if ( (name[0]=='f' || name[0]=='F') &&
+	     (name[1]=='n' || name[1]=='N') )
+		return(FUNCTID);
+	return(IDENTIFIER);
+}
+
+
+
+/* Parsing unsigned numbers */
+readconstant()
+{
+	/* read HEX and OCTAL numbers */
+	char *c;
+	cptr++;
+	if ( *cptr == 'H' || *cptr=='h')
+	{
+		/* HEX */
+		cptr++;
+		c=cptr;
+		while (  isdigit(*cptr) || 
+			(*cptr>='a' && *cptr<='f' ) ||
+			(*cptr>='A' && *cptr<='F' ) ) cptr++;
+		(void) sscanf(c,"%x",&ival);
+	} else 
+	if ( *cptr == 'O' || *cptr == 'o')
+	{
+		/* OCTAL */
+		cptr++;
+		c=cptr;
+		while ( isdigit(*cptr) ) cptr++;
+		(void) sscanf(c,"%o",&ival);
+	} else error("H or O expected");
+	return(INTVALUE);
+}
+
+
+
+#ifdef ____
+/* Computes base to the power exponent. This was not done in the old
+   compiler                                                          */
+double powr(base,exp)
+double base;
+int exp;
+{
+	int i;
+	double result;
+	int abs_exp;
+
+	if ( exp < 0 )
+		abs_exp = -exp;
+	else
+		abs_exp = exp;
+		
+	result = 1.0;
+	for ( i = 1; i <= abs_exp; i++ ) {
+		result = result * base;
+	}
+
+	if ( exp < 0 )
+		return ( 1.0 / result );
+	else
+		return ( result );
+}
+#endif
+
+
+number()
+{
+	long	i1;
+	int overflow = 0;
+	register char *c;
+	static char	numbuf[256];
+	register char *d = numbuf;
+
+	dval = numbuf;
+	i1=0;
+	c=cptr;
+	while (*c == '0') c++;
+	while (isdigit(*c)){
+		i1= i1*10 + *c-'0';
+		if (i1 < 0) overflow = 1;
+		if (d < &numbuf[255]) *d++ = *c;
+		c++;
+	}
+	if (d == numbuf) *d++ = '0';
+	cptr=c;
+	if ( *c != '.'  && *c != 'e' && *c != 'E'
+			&& *c != 'd' && *c != 'D' ){
+		if ( i1> MAXINT || i1<MININT || overflow) {
+			*d = 0;
+			return(FLTVALUE);
+		}
+		/*NOSTRICT*/ ival= i1;
+#ifdef YYDEBUG
+		if (yydebug) print("number:INTVALUE %d",i1);
+#endif
+		return(INTVALUE);
+	}
+	/* handle floats */
+	if (*c == '.') {
+		if (d < &numbuf[255]) *d++ = *c;
+		c++;
+		while ( isdigit(*c)){
+			if (d < &numbuf[255]) *d++ = *c;
+			c++;
+		}
+	}
+	/* handle exponential part */
+	if ( *c == 'e' || *c == 'E' || *c == 'd' || *c == 'D' ){
+		if (d < &numbuf[254]) *d++ = 'e';
+		c++;
+		if ( *c=='-' || *c=='+') {
+			if (d < &numbuf[255]) *d++ = *c;
+			c++;
+		}
+		while (isdigit(*c)){
+			if (d < &numbuf[255]) *d++ = *c;
+			c++;
+		}
+		if (*(d-1) == 'e') *d++ = '0';
+	}
+	*d = 0;
+	cptr=c;
+#ifdef YYDEBUG
+	if (yydebug) print("number:FLTVALUE %s",dval);
+#endif
+	return(FLTVALUE);
+}
+
+
+
+/* Maximale grootte van een chunk; >= 4 */
+#define CHUNKSIZE 123
+
+
+
+scanstring()
+{
+	int i,length=0;
+	char firstchar = *cptr;
+	char buffer[CHUNKSIZE],*bufp = buffer;
+
+	/* generate label here */
+	if (! in_data) yylval.integer= genemlabel();
+	if ( *cptr== '"') cptr++;
+	sval= cptr;
+	while ( *cptr !='"')
+	{
+		switch(*cptr)
+		{
+		case 0:
+		case '\n': 
+#ifdef YYDEBUG
+			if (yydebug) print("STRVALUE\n");
+#endif
+			if ( firstchar == '"')
+				error("non-terminated string");
+			return(STRVALUE);
+		/*
+		case '\'':
+		case '\\':
+			*bufp++ = '\\';
+			*bufp++ = *cptr;
+			if ( bufp >= buffer + CHUNKSIZE - 4 ) {
+				if (! in_data) 
+					C_con_scon(buffer,(arith)(bufp-buffer));
+				bufp = buffer;
+			}
+			break;
+		*/
+		default:
+			*bufp++ = *cptr;
+			if ( bufp >= buffer + CHUNKSIZE - 4 ) {
+				if (! in_data) 
+					C_con_scon(buffer,(arith)(bufp-buffer));
+				bufp = buffer;
+			}
+		}
+		cptr++;
+		length++;
+	}
+	*cptr = 0;
+	*bufp++ = 0;
+	cptr++;
+	if (! in_data) {
+		C_con_scon(buffer,(arith)(bufp-buffer));
+		i=yylval.integer;
+		yylval.integer= genemlabel();
+		C_rom_dlb((label)i,(arith)0);
+		C_rom_icon("9999",(arith)BEMINTSIZE);
+		C_rom_icon(itoa(length),(arith)BEMINTSIZE);
+	}
+#ifdef YYDEBUG
+	if (yydebug) print("STRVALUE found\n");
+#endif
+	return(STRVALUE);
+}
+
+
+
+yylex()
+{
+	char *c;
+
+	/* Here is the big switch */
+	c= cptr;
+	switch(*c){
+		case 'a': case 'b': case 'c': case 'd': case 'e':
+		case 'f': case 'g': case 'h': case 'i': case 'j':
+		case 'k': case 'l': case 'm': case 'n': case 'o':
+		case 'p': case 'q': case 'r': case 's': case 't':
+		case 'u': case 'v': case 'w': case 'x': case 'y':
+		case 'z': case 'A': case 'B': case 'C': case 'D':
+		case 'E': case 'F': case 'G': case 'H': case 'I':
+		case 'J': case 'K': case 'L': case 'M': case 'N':
+		case 'O': case 'P': case 'Q': case 'R': case 'S':
+		case 'T': case 'U': case 'V': case 'W': case 'X':
+		case 'Y': case 'Z': case '_': 
+			return(lookup());
+	
+		case '0': case '1': case '2': case '3': case '4':
+		case '5': case '6': case '7': case '8': case '9':
+		case '.':
+			return(number());
+
+		case '\'':
+			/* comment at end of line */
+			while ( *cptr != '\n' && *cptr) cptr++;
+		case '\n':
+			cptr++;
+			return(EOLN);
+		case 0:
+#ifdef YYDEBUG
+			if ( yydebug) print("end of buffer");
+#endif
+			return(0);
+		case '"':
+			return(scanstring());
+		/* handle double operators */
+		case ' ':
+		case '\t':
+			cptr++;
+			return(yylex());
+		case '&':
+			return(readconstant());
+		case '?':
+			cptr++;
+			return(PRINTSYM);
+		case '>':
+			if ( *(c+1)=='='){
+				c++; c++;
+				cptr=c;
+				yylval.integer= GESYM;
+				return(RELOP);
+			}
+			yylval.integer= '>';
+			cptr++;
+			return(RELOP);
+		case '<':
+			if ( *(c+1)=='='){
+				c++; c++; 
+				cptr=c; 
+				yylval.integer=LESYM; 
+				return(RELOP);
+			} else
+				if ( *(c+1)=='>'){
+					c++; c++; 
+					cptr=c; 
+					yylval.integer=NESYM; 
+					return(RELOP);
+				} 
+			yylval.integer= '<';
+			cptr++;
+			return(RELOP);
+	}
+	return(*cptr++);
+}

+ 54 - 0
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 */
+}

+ 79 - 0
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 <stdio.h>
+#include <ctype.h>
+#include <signal.h>
+#include <system.h>
+#include <em.h>
+#include <em_mes.h>
+
+/* Author: M.L. Kersten
+** Here all the global objects are defined.
+*/
+#include "symbols.h"
+#include "graph.h"
+#include "Lpars.h"
+
+#ifndef NORCSID
+# define RCS_BEM	"$Header$"
+#endif
+
+#define MAXINT		32768
+#define MININT		-32767
+/* #define EMINTSIZE	"EM_WSIZE" */
+/* #define EMPTRSIZE	"EM_PSIZE" */
+/* #define EMFLTSIZE	"EM_DSIZE" */
+
+#define EMINTSIZE 4
+#define EMPTRSIZE 4
+#define EMFLTSIZE 8
+
+#define MAXPIECES	100
+#define MAXFILENAME	200
+
+#define CHANNEL		0
+#define THRESHOLD	40		/* for splitting blocks */
+
+#define void		int		/* Some C compilers don't know void */
+
+extern int	BEMINTSIZE, BEMPTRSIZE, BEMFLTSIZE;
+extern char	*program;		/* name of source program */
+extern char	*inpfile;		/* input tko compiler */
+extern char	*outfile;		/* output from compiler */
+
+extern char	datfname[MAXFILENAME];	/* data statements file */
+extern char	tmpfname[MAXFILENAME];	/* temporary statements file */
+
+extern File	*emfile;		/* EM output file */
+extern File	*datfile;		/* data file */
+extern File	*tmp_file;		/* compiler temporary */
+extern File	*yyin;			/* Compiler input */
+
+extern int	endofinput;
+extern int 	wflag;
+extern int	hflag;
+extern int	traceflag;
+extern int	yydebug;
+extern int	yylineno;
+extern int	listing;
+extern int	nolins;
+extern int	threshold;
+extern int	debug;
+extern int 	tronoff;
+extern label	err_goto_label;
+
+extern int 	dataused;
+
+extern Linerecord *currline;
+
+
+extern char *itoa();
+extern char *salloc();
+
+extern char *sprintf();
+extern char *strcpy();
+extern char *strcat();
+extern char *malloc();

+ 30 - 0
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);
+}

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

+ 269 - 0
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);
+}
+

+ 704 - 0
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);
+}

+ 340 - 0
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 */
+
+

+ 37 - 0
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();

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

+ 62 - 0
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;
+    }
+}

+ 17 - 0
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
++

+ 85 - 0
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 <flags> <file> <file> <source>\n", 
+			argv[0]);
+		sys_stop(S_EXIT);
+	}
+
+	for(i=1;i<argc;i++)
+		if( argv[i][0]=='-')
+			switch(argv[i][1])
+			{
+				case 'D': yydebug++;
+					  break;	/* parser debugging */
+				case 't': traceflag++; 
+					  break;	/* line tracing */
+				case 'h': /* split EM file */
+					  (void) fprint(STDERR,
+                                                 "h option not implemented\n");
+					  break;
+				case 'd': debug++; 
+					  break;
+				case 'L': nolins++; 
+					  break; /* no EM lin statements */
+				case 'E': listing++; 
+					  break; /* generate full listing */
+				case 'w': wflag++;
+					  break; /* no warnings */
+				case 'V':
+					  p = &argv[i][2];
+					  while (*p) switch(*p++) {
+					  case 'w':
+						BEMINTSIZE = *p++ - '0';
+						break;
+					  case 'p':
+						BEMPTRSIZE = *p++ - '0';
+						break;
+					  case 'f':
+						BEMFLTSIZE = *p++ - '0';
+						break;
+					  default:
+						p++;
+						break;
+					  }
+			} else {
+				/* new input file */
+				switch ( files++ ) {
+					case 0: inpfile= argv[i]; break;
+					case 1: outfile= argv[i]; break;
+					case 2: /* should be the source file 
+						   name */
+						program= argv[i]; 
+						break;
+					default:fatal("Too many file arguments") ;
+				}
+			}
+		if (files < 3) fatal("Too few file arguments");
+}

+ 376 - 0
lang/basic/src/symbols.c

@@ -0,0 +1,376 @@
+/*
+ * (c) copyright 1987 by the Vrije Universiteit, Amsterdam, The Netherlands.
+ * See the copyright notice in the ACK home directory, in the file "Copyright".
+ */
+
+#include "bem.h"
+
+#ifndef NORSCID
+static char rcs_id[] = "$Header$" ;
+#endif
+
+/* Symboltable management module */
+
+int	deftype[128];		/* default type declarer */
+				/* which may be set by OPTION BASE */
+
+
+initdeftype()
+{
+	int i;
+
+	for(i='a';i<='z';i++) deftype[i]= DOUBLETYPE;
+	for(i='A';i<='Z';i++) deftype[i]= DOUBLETYPE;
+}
+
+
+int indexbase=0;		/* start of array subscripting */
+
+Symbol	*firstsym = NIL;
+Symbol *alternate = NIL;
+
+
+
+Symbol *srchsymbol(str)
+char *str;
+{
+	Symbol *s;
+
+	/* search symbol table entry or create it */
+	if (debug) print("srchsymbol %s\n",str);
+	s=firstsym;
+
+	while (s)
+	{
+		if ( strcmp(s->symname,str)==0) return(s);
+		s= s->nextsym;
+	}
+
+	/* search alternate list */
+	s=alternate;
+
+	while (s)
+	{
+		if ( strcmp(s->symname,str)==0) return(s);
+		s= s->nextsym;
+	}
+
+	/* not found, create an empty slot */
+	s = (Symbol *) salloc(sizeof(Symbol));
+	s->symtype= DEFAULTTYPE;
+	s->nextsym= firstsym;
+	s->symname= (char *) salloc((unsigned) strlen(str)+1);
+	strcpy(s->symname,str);
+	firstsym= s;
+	if (debug) print("%s allocated\n",str);
+	return(s);
+}
+
+
+
+dcltype(s)
+Symbol *s;
+{
+	/* type declarer */
+	int type;
+
+	if ( s->isparam) return;
+	type=s->symtype;
+	if (type==DEFAULTTYPE)
+		/* use the default rule */
+		type= deftype[*s->symname];
+	/* generate the emlabel too */
+	if ( s->symalias==0)
+		s->symalias= dclspace(type);
+	s->symtype= type;
+	if (debug) print("symbol set to %d\n",type);
+}
+
+
+
+dclarray(s)
+Symbol *s;
+{
+	int i; int size;
+
+	if ( s->symtype==DEFAULTTYPE) s->symtype= DOUBLETYPE;
+	if (debug) print("generate space and descriptors for %d\n",s->symtype);
+	if (debug) print("dim %d\n",s->dimensions);
+	s->symalias= genlabel();
+	/* generate descriptors */
+	size=1;
+
+	for(i=0;i<s->dimensions;i++) {
+		s->dimalias[i]= genlabel();
+	}
+
+	for(i=s->dimensions-1;i>=0;i--)
+	{
+		C_df_dlb((label)(s->dimalias[i]));
+		C_rom_cst((arith)indexbase);
+		C_rom_cst((arith)(s->dimlimit[i]-indexbase));
+		C_rom_cst((arith)(size*typesize(s->symtype)));
+		size = size* (s->dimlimit[i]+1-indexbase);
+	}
+
+	if (debug) print("size=%d\n",size);
+	/* size of stuff */
+	C_df_dlb((label)s->symalias);
+	get_space(s->symtype,size); /* Van ons. */
+}
+
+
+
+get_space(type,size)
+int type,size;
+{
+
+	switch ( type ) {
+		case INTTYPE:
+			C_bss_cst((arith)BEMINTSIZE*size,
+			   	(arith)0,
+			   	1);
+			break;
+		case FLOATTYPE:
+		case DOUBLETYPE:
+			C_bss_fcon((arith)BEMFLTSIZE*size,
+			   	"0.0",
+			   	(arith)BEMFLTSIZE,
+			   	1);
+			break;
+		case STRINGTYPE: /* Note: this is ugly. Gertjan */
+			C_bss_icon((arith)BEMPTRSIZE*size,
+			   	"0",
+                            	(arith)BEMPTRSIZE,
+			    	1);
+			break;
+		default:
+			error("Space allocated for unknown type. Coredump.");
+			abort(); /* For debugging purposes */
+		}
+}
+
+
+
+defarray(s)
+Symbol *s;
+{
+	/* array is used without dim statement, set default limits */
+	int i;
+	for(i=0;i<s->dimensions;i++) s->dimlimit[i]=10;
+	dclarray(s);
+}
+
+
+
+dclspace(type)
+{
+	int nr;
+
+	nr= genemlabel();
+
+	switch( type)
+	{
+		case STRINGTYPE:
+			C_bss_icon((arith)BEMPTRSIZE,"0",(arith)BEMPTRSIZE,1);
+			break;
+		case INTTYPE:
+			C_bss_cst((arith)BEMINTSIZE,(arith)0,1);
+			break;
+		case FLOATTYPE:
+		case DOUBLETYPE:
+			C_bss_fcon((arith)BEMFLTSIZE,"0.0",(arith)BEMFLTSIZE,1);
+			break;
+	}
+	return(nr);
+}
+
+
+
+/* SOME COMPILE TIME OPTIONS */
+optionbase(ival)
+int	ival;
+{
+	if ( ival<0 || ival>1)
+		error("illegal option base value");
+	else indexbase=ival;
+}
+
+
+
+setdefaulttype(type)
+int	type;
+{
+	extern char *cptr;
+	char	first,last,i;
+
+	/* handcrafted parser for letter ranges */
+	if (debug) print("deftype:%s\n",cptr);
+	while ( isspace(*cptr)) cptr++;
+	if ( !isalpha(*cptr))
+		error("letter expected");
+	first= *cptr++;
+	if (*cptr=='-')
+	{
+		/* letter range */
+		cptr++;
+		last= *cptr;
+		if ( !isalpha(last))
+			error("letter expected");
+		else for(i=first;i<=last;i++) deftype[i]= type;
+		cptr++;
+	} else deftype[first]=type;
+	if ( *cptr== ',') 
+	{
+		cptr++;
+		setdefaulttype(type);	/* try again */
+	}
+}
+
+
+Symbol *fcn;
+
+
+
+newscope(s)
+Symbol *s;
+{
+	if (debug) print("new scope for %s\n",s->symname);
+	alternate= firstsym;
+	firstsym = NIL;
+	fcn=s;
+	s->isfunction=1;
+	if ( fcn->dimensions)
+		error("Array redeclared");
+	if ( fcn->symtype== DEFAULTTYPE)
+		fcn->symtype=DOUBLETYPE;
+}
+
+
+
+/* User defined functions */
+
+
+
+heading( )
+{
+	char procname[50];
+
+	sprint(procname,"_%s",fcn->symname);
+        C_pro_narg(procname);
+	if ( fcn->symtype== DEFAULTTYPE)
+		fcn->symtype= DOUBLETYPE;
+}
+
+
+
+int fcnsize()
+{
+	/* generate portable function size */
+	int	i,sum;  /* sum is NEW */
+
+	sum = 0;
+	for(i=0;i<fcn->dimensions;i++)
+		sum += typesize(fcn->dimlimit[i]);
+	return(sum);
+}
+
+
+
+endscope(type)
+int type;
+{
+	Symbol *s;
+
+	if ( debug) print("endscope");
+	conversion(type,fcn->symtype);
+        C_ret((arith) typestring(fcn->symtype));
+	/* generate portable EM code */
+	C_end( (arith)fcnsize() );
+	s= firstsym;
+
+	while (s)
+	{
+		firstsym = s->nextsym;
+		(void) free((char *)s);
+		s= firstsym;
+	}
+
+	firstsym= alternate;
+	alternate = NIL;
+	fcn=NIL;
+}
+
+
+
+dclparm(s)
+Symbol	*s;
+{
+	int size=0;
+
+	if ( s->symtype== DEFAULTTYPE)
+		s->symtype= DOUBLETYPE;
+	s->isparam=1;
+	fcn->dimlimit[fcn->dimensions]= s->symtype;
+	fcn->dimensions++;
+	s->symalias= -fcn->dimensions;
+	if ( debug) print("parameter %d offset %d\n",fcn->dimensions-1,-size);
+}
+
+
+
+/* unfortunately function calls have to be stacked as  well */
+#define MAXNESTING	50
+Symbol	*fcntable[MAXNESTING];
+int	fcnindex= -1;
+
+
+
+fcncall(s)
+Symbol *s;
+{
+	if ( !s->isfunction)
+		error("Function not declared");
+	else{
+		fcn= s;
+		fcnindex++;
+		fcntable[fcnindex]=s;
+	}
+	return(s->symtype);
+}
+
+
+
+fcnend(parmcount)
+int parmcount;
+{
+	int type;
+	static char concatbuf[50]; /* NEW */
+
+	/* check number of arguments */
+	if ( parmcount <fcn->dimensions)
+		error("not enough parameters");
+	if ( parmcount >fcn->dimensions)
+		error("too many parameters");
+	(void) sprint(concatbuf,"_%s",fcn->symname);
+	C_cal(concatbuf);
+	C_asp((arith)fcnsize());
+        C_lfr((arith) typestring(fcn->symtype));
+	type= fcn->symtype;
+	fcnindex--;
+	if ( fcnindex>=0)
+		fcn= fcntable[fcnindex];
+	return(type);
+}
+
+
+
+callparm(ind,type)
+int ind,type;
+{
+	if ( fcnindex<0) error("unexpected parameter");
+	if ( ind >= fcn->dimensions)
+		error("too many parameters");
+	else 
+		conversion(type,fcn->dimlimit[ind]);
+}

+ 88 - 0
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();

+ 98 - 0
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);
+}
+
+
+

+ 22 - 0
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);
+	}
+}
+