godzil/tack
1
0
Fork 0
Code Issues Pull Requests Actions Packages Projects Releases Wiki Activity

fixup commit for tag 'llgen-1-0'

Browse Source
This commit is contained in:
cvs2hg
2006-02-04 00:57:05 +00:00
parent 84701a5c29
commit 22d8b82972
7762 changed files with 0 additions and 664261 deletions
Download Patch File Download Diff File Expand all files Collapse all files

3
lang/basic/.distr
View File

@@ -1,3 +0,0 @@
lib
src
test

2
lang/basic/lib/.distr
View File

@@ -1,2 +0,0 @@
LIST
tail_bc.a

34
lang/basic/lib/LIST
View File

@@ -1,34 +0,0 @@
tail_bc.a
abs.c
asc.c
asrt.c
atn.c
chr.c
conversion.c
hlt.c
mki.c
oct.c
peek.c
power.c
exp.c
log.c
print.c
io.c
random.c
read.c
return.c
sgn.c
sin.c
fif.e
sqt.c
fef.e
stop.c
string.c
salloc.c
swap.c
trace.c
write.c
file.c
error.c
trap.c
setline.e

15
lang/basic/lib/abs.c
View File

@@ -1,15 +0,0 @@
/* $Id$ */
/*
* (c) copyright 1987 by the Vrije Universiteit, Amsterdam, The Netherlands.
* See the copyright notice in the ACK home directory, in the file "Copyright".
*/
long _abl(i) long i;
{
return( i>=0?i:-i);
}
double _abr(f) double f;
{
return( f>=0.0?f: -f);
}

11
lang/basic/lib/asc.c
View File

@@ -1,11 +0,0 @@
#include "bc_string.h"
/* $Id$ */
int _asc(str)
String *str;
{
if(str==0 || str->strval==0)
error(3);
return( *str->strval);
}

9
lang/basic/lib/asrt.c
View File

@@ -1,9 +0,0 @@
/* $Id$ */
asrt(b)
{
if(!b){
printf("ASSERTION ERROR\n");
abort();
}
}

68
lang/basic/lib/atn.c
View File

@@ -1,68 +0,0 @@
/*
* (c) copyright 1988 by the Vrije Universiteit, Amsterdam, The Netherlands.
* See the copyright notice in the ACK home directory, in the file "Copyright".
*
* Author: Ceriel J.H. Jacobs
*/
/* $Id$ */
#define __NO_DEFS
#include <math.h>
double
_atn(x)
double x;
{
/* Algorithm and coefficients from:
"Software manual for the elementary functions"
by W.J. Cody and W. Waite, Prentice-Hall, 1980
*/
static double p[] = {
-0.13688768894191926929e+2,
-0.20505855195861651981e+2,
-0.84946240351320683534e+1,
-0.83758299368150059274e+0
};
static double q[] = {
0.41066306682575781263e+2,
0.86157349597130242515e+2,
0.59578436142597344465e+2,
0.15024001160028576121e+2,
1.0
};
static double a[] = {
0.0,
0.52359877559829887307710723554658381, /* pi/6 */
M_PI_2,
1.04719755119659774615421446109316763 /* pi/3 */
};
int neg = x < 0;
int n;
double g;
if (neg) {
x = -x;
}
if (x > 1.0) {
x = 1.0/x;
n = 2;
}
else n = 0;
if (x > 0.26794919243112270647) { /* 2-sqtr(3) */
n = n + 1;
x = (((0.73205080756887729353*x-0.5)-0.5)+x)/
(1.73205080756887729353+x);
}
/* ??? avoid underflow ??? */
g = x * x;
x += x * g * POLYNOM3(g, p) / POLYNOM4(g, q);
if (n > 1) x = -x;
x += a[n];
return neg ? -x : x;
}

17
lang/basic/lib/chr.c
View File

@@ -1,17 +0,0 @@
#include "bc_string.h"
/* $Id$ */
String *_chr(i)
int i;
{
String *s;
char buf[2];
if( i<0 || i>127)
error(3);
buf[0]=i;
buf[1]=0;
s= _newstr(buf);
return(s);
}

40
lang/basic/lib/conversion.c
View File

@@ -1,40 +0,0 @@
/* $Id$ */
int _cint(f) double f;
{
int r;
if( f<-32768 || f>32767) error(4);
if(f<0)
r= f-0.5;
else r= f+0.5;
return(r);
}
double _trunc(f)
double f;
{
long d;
d=f;
f=d;
return( f );
}
double _fcint(f) double f;
{
long r;
if(f<0){
r= -f;
r= -r -1;
}else r= f;
f=r;
return(f);
}
int _fix(f)
double f;
{
int r;
if( f<-32768.0 || f>32767.0) error(4);
r= _sgn(f) * _fcint((f>0.0? f : -f));
return(r);
}

63
lang/basic/lib/error.c
View File

@@ -1,63 +0,0 @@
/* $Id$ */
/* error takes an error value in the range of 0-255 */
/* and generates a trap */
char *errortable[255]={
/* 0 */ "",
/* 1 */ "RETURN without GOSUB",
/* 2 */ "Out of data",
/* 3 */ "Illegal function call",
/* 4 */ "Overflow",
/* 5 */ "Out of memory",
/* 6 */ "Undefined line ",
/* 7 */ "Subscript out of range",
/* 8 */ "Redimensioned array",
/* 9 */ "Division by zero",
/* 10 */ "Illegal indirect",
/* 11 */ "Type mismatch",
/* 12 */ "Out of string space",
/* 13 */ "String too long",
/* 14 */ "String formula too complex",
/* 15 */ "Can't continue",
/* 16 */ "Undefined user function",
/* 17 */ "No resume",
/* 18 */ "Resume without error",
/* 19 */ "Unprintable error",
/* 20 */ "Missing operand",
/* 21 */ "Line buffer overflow",
/* 22 */ "FOR without NEXT",
/* 23 */ "WHILE without WEND",
/* 24 */ "WEND without WHILE",
/* 25 */ "Field overflow",
/* 26 */ "Internal error",
/* 27 */ "Bad file number",
/* 28 */ "File not found",
/* 29 */ "Bad file mode",
/* 30 */ "File already open",
/* 31 */ "Disk IO error",
/* 32 */ "File already exists",
/* 33 */ "Disk full",
/* 34 */ "Input past end",
/* 35 */ "Bad record number",
/* 36 */ "Bad file name",
/* 37 */ "Direct statement in file",
/* 38 */ "Too many files",
/* 39 */ "File not open",
/* 40 */ "Syntax error in data",
0
};
error(index)
int index;
{
extern int _errsym;
extern int _erlsym;
_setline();
if( index<0 || index >40 )
printf("LINE %d:ERROR %d: Unprintable error\n",_erlsym,index);
else printf("LINE %d:ERROR %d: %s\n",_erlsym,index,errortable[index]);
_errsym= index;
_trap();
}

97
lang/basic/lib/exp.c
View File

@@ -1,97 +0,0 @@
/*
* (c) copyright 1988 by the Vrije Universiteit, Amsterdam, The Netherlands.
* See the copyright notice in the ACK home directory, in the file "Copyright".
*
* Author: Ceriel J.H. Jacobs
*/
/* $Id$ */
#define __NO_DEFS
#include <math.h>
static double
ldexp(fl,exp)
double fl;
int exp;
{
extern double _fef();
int sign = 1;
int currexp;
if (fl<0) {
fl = -fl;
sign = -1;
}
fl = _fef(fl,&currexp);
exp += currexp;
if (exp > 0) {
while (exp>30) {
fl *= (double) (1L << 30);
exp -= 30;
}
fl *= (double) (1L << exp);
}
else {
while (exp<-30) {
fl /= (double) (1L << 30);
exp += 30;
}
fl /= (double) (1L << -exp);
}
return sign * fl;
}
double
_exp(x)
double x;
{
/* Algorithm and coefficients from:
"Software manual for the elementary functions"
by W.J. Cody and W. Waite, Prentice-Hall, 1980
*/
static double p[] = {
0.25000000000000000000e+0,
0.75753180159422776666e-2,
0.31555192765684646356e-4
};
static double q[] = {
0.50000000000000000000e+0,
0.56817302698551221787e-1,
0.63121894374398503557e-3,
0.75104028399870046114e-6
};
double xn, g;
int n;
int negative = x < 0;
if (x <= M_LN_MIN_D) {
return M_MIN_D;
}
if (x >= M_LN_MAX_D) {
if (x > M_LN_MAX_D) error(3);
return M_MAX_D;
}
if (negative) x = -x;
/* ??? avoid underflow ??? */
n = x * M_LOG2E + 0.5; /* 1/ln(2) = log2(e), 0.5 added for rounding */
xn = n;
{
double x1 = (long) x;
double x2 = x - x1;
g = ((x1-xn*0.693359375)+x2) - xn*(-2.1219444005469058277e-4);
}
if (negative) {
g = -g;
n = -n;
}
xn = g * g;
x = g * POLYNOM2(xn, p);
n += 1;
return (ldexp(0.5 + x/(POLYNOM3(xn, q) - x), n));
}

23
lang/basic/lib/fef.e
View File

@@ -1,23 +0,0 @@
#
mes 2,EM_WSIZE,EM_PSIZE
; $Id$
#define FARG 0
#define ERES EM_DSIZE
; _fef is called with two parameters:
; - address of exponent result (ERES)
; - floating point number to be split (FARG)
; and returns an EM_DSIZE-byte floating point number
exp $_fef
pro $_fef,0
lal FARG
loi EM_DSIZE
fef EM_DSIZE
lal ERES
loi EM_PSIZE
sti EM_WSIZE
ret EM_DSIZE
end ?

25
lang/basic/lib/fif.e
View File

@@ -1,25 +0,0 @@
#
mes 2,EM_WSIZE,EM_PSIZE
; $Id$
#define ARG1 0
#define ARG2 EM_DSIZE
#define IRES 2*EM_DSIZE
; _fif is called with three parameters:
; - address of integer part result (IRES)
; - float two (ARG2)
; - float one (ARG1)
; and returns an EM_DSIZE-byte floating point number
exp $_fif
pro $_fif,0
lal 0
loi 2*EM_DSIZE
fif EM_DSIZE
lal IRES
loi EM_PSIZE
sti EM_DSIZE
ret EM_DSIZE
end ?

135
lang/basic/lib/file.c
View File

@@ -1,135 +0,0 @@
#include "bc_string.h"
#include <stdio.h>
#include "bc_io.h"
/* $Id$ */
Filedesc _fdtable[16];
/* BASIC file descriptor table */
/* Channel assignment:
-1 terminal IO
0 data file
1-15 user files
*/
int _chann = -1;
FILE *_chanrd = stdin;
FILE *_chanwr = stdout;
_setchan(index)
int index;
{
#ifdef DEBUG
printf("setchannel %d\n",index);
#endif
fflush(_chanwr);
if( index == -1)
{
_chann= -1;
_chanrd= stdin;
_chanwr= stdout;
return;
}
if( index<0 || index>15)
error(27);
_chann=index;
_chanrd= _chanwr= _fdtable[index].fd;
}
_asschn()
{
#ifdef DEBUG
printf("_asschn %d\n",_chann);
#endif
if( _chann == -1) return;
#ifdef DEBUG
printf(" file %d\n", _fdtable[_chann].fd);
#endif
if( _chann<0 || _chann>15)
error(27);
if( _fdtable[_chann].fd== 0)
error(39);
if( feof( _fdtable[_chann].fd))
error(2);
}
_clochn(nr)
int nr;
{
if( nr<1 || nr >15 || _fdtable[nr].fd==0) error(3);
fclose(_fdtable[nr].fd);
_fdtable[nr].fd=0; _fdtable[nr].fname=0;
}
_opnchn(reclen,fname,mode)
String *mode,*fname;
int reclen;
{
/* channel has been set */
FILE *f;
int m;
#ifdef DEBUG
printf("open %d %s %s \n",reclen,mode->strval,fname->strval);
#endif
/* check for opened/closed file */
if(_fdtable[_chann].fd)
error(30);
switch(*mode->strval)
{
case 'O':
case 'o':
if( (f=fopen(fname->strval,"w")) == NULL)
error(28);
m= OMODE;
break;
case 'I':
case 'i':
if( (f=fopen(fname->strval,"r")) == NULL)
error(28);
m= IMODE;
break;
case 'r':
case 'R':
if( (f=fopen(fname->strval,"a")) == NULL)
error(28);
m= RMODE;
break;
default:
printf("file mode %s\n",mode->strval);
error(29);
}
_chanwr= _chanrd= _fdtable[_chann].fd= f;
_fdtable[_chann].fname= fname->strval;
_fdtable[_chann].reclength= reclen;
_fdtable[_chann].mode= m;
#ifdef DEBUG
printf("file descr %d\n",f);
#endif
}
_ioeof(channel)
int channel;
{
FILE *fd;
char c;
if( channel<0 || channel >15) error(3);
fd= _fdtable[channel].fd;
if( fd==0)
error(3);
c=fgetc(fd);
if( feof(_fdtable[channel].fd) ) return(-1);
ungetc(c,fd);
return(0);
}
_close()
{
/* close all open files */
int i;
for(i=1;i<16;i++)
if( _fdtable[i].fd)
_clochn(i);
}

12
lang/basic/lib/hlt.c
View File

@@ -1,12 +0,0 @@
/* $Id$ */
_hlt(nr)
int nr;
{
exit(nr);
}
_goto_err()
{
error(3);
}

97
lang/basic/lib/io.c
View File

@@ -1,97 +0,0 @@
#include "bc_io.h"
#include <sgtty.h>
/* $Id$ */
struct sgttyb _ttydef;
/* BASIC has some nasty io characteristics */
#define MAXWIDTH 255
int _width = 75, _pos=0, _zonewidth=15;
_out(str)
char *str;
{
int pos;
if( _chann== -1) pos= _pos;
else pos= _fdtable[_chann].pos;
while( *str)
{
if( pos>= _width){ _outnl(); pos=0;}
fputc(*str++, _chanwr);
pos++;
}
if( _chann== -1) _pos=pos;
else _fdtable[_chann].pos= pos;
}
_outnl()
{
fputc('\n',_chanwr);
if( _chann == -1)
_pos=0;
else
_fdtable[_chann].pos=0;
}
_zone()
{
/* go to next zone */
int pos;
if( _chann == -1)
pos= _pos;
else pos= _fdtable[_chann].pos;
do{
fputc(' ',_chanwr);
pos++;
if( pos==_width)
{
_outnl();
pos=0;
break;
}
} while( pos % _zonewidth != 0);
if( _chann== -1) _pos=pos;
else _fdtable[_chann].pos= pos;
}
_in(buf)
char *buf;
{
register int holder ;
char *c;
int pos;
if( _chann == -1)
{
pos= _pos;
gtty(0,_ttydef);
_ttydef.sg_flags &= ~ECHO;
stty(0,_ttydef);
}else pos= _fdtable[_chann].pos;
c= buf;
while( (holder = fgetc(_chanrd)) != EOF && holder != '\n'){
*c= holder ;
if( _chann == -1) putchar(holder);
c++; pos++;
}
*c= 0;
if( _chann== -1)
{
_pos=pos;
_ttydef.sg_flags |= ECHO;
stty(0,_ttydef);
} else _fdtable[_chann].pos= pos;
}
_tab(x)
int x;
{
if( x> _width) error(3);
if( x< _pos) _outnl();
_spc(x-_pos);
}
_spc(x)
int x;
{
while(x-->0) _out(" ");
}

57
lang/basic/lib/log.c
View File

@@ -1,57 +0,0 @@
/*
* (c) copyright 1988 by the Vrije Universiteit, Amsterdam, The Netherlands.
* See the copyright notice in the ACK home directory, in the file "Copyright".
*
* Author: Ceriel J.H. Jacobs
*/
/* $Id$ */
#define __NO_DEFS
#include <math.h>
double
_log(x)
double x;
{
/* Algorithm and coefficients from:
"Software manual for the elementary functions"
by W.J. Cody and W. Waite, Prentice-Hall, 1980
*/
static double a[] = {
-0.64124943423745581147e2,
0.16383943563021534222e2,
-0.78956112887491257267e0
};
static double b[] = {
-0.76949932108494879777e3,
0.31203222091924532844e3,
-0.35667977739034646171e2,
1.0
};
extern double _fef();
double znum, zden, z, w;
int exponent;
if (x <= 0) {
error(3);
return -HUGE;
}
x = _fef(x, &exponent);
if (x > M_1_SQRT2) {
znum = (x - 0.5) - 0.5;
zden = x * 0.5 + 0.5;
}
else {
znum = x - 0.5;
zden = znum * 0.5 + 0.5;
exponent--;
}
z = znum/zden; w = z * z;
x = z + z * w * (POLYNOM2(w,a)/POLYNOM3(w,b));
z = exponent;
x += z * (-2.121944400546905827679e-4);
return x + z * 0.693359375;
}

34
lang/basic/lib/mki.c
View File

@@ -1,34 +0,0 @@
#include "bc_string.h"
/* $Id$ */
String *_mki(i)
long i;
{
char *buffer =" ";
String *s;
s= _newstr(buffer);
* ( (long *)s->strval ) = i ;
return(s);
}
String *_mkd(d)
double d;
{
char *buffer =" ";
String *s;
s= _newstr(buffer);
* ( (double *)s->strval ) = d ;
return(s);
}
long _cvi(s)
String *s;
{
return *( (long *) s->strval) ;
}
double _cvd(s)
String *s;
{
return *( (double *) s->strval) ;
}

29
lang/basic/lib/oct.c
View File

@@ -1,29 +0,0 @@
#include "bc_string.h"
/* $Id$ */
String *_oct(i)
int i;
{
char buffer[30];
sprintf(buffer,"%o",i);
return( (String *)_newstr(buffer));
}
String *_hex(i)
int i;
{
char buffer[30];
sprintf(buffer,"%x",i);
return( (String *)_newstr(buffer));
}
String *_nstr(f)
double f;
{
char buffer[80];
_str(f, buffer);
return (String *) _newstr(buffer);
}

26
lang/basic/lib/peek.c
View File

@@ -1,26 +0,0 @@
/* $Id$ */
int peek(addr)
int addr;
{
/* this can not work properly for machines in which the
POINTERSIZE differs from the integer size
*/
char *p;
int i;
p= (char *)addr;
i= *p;
#ifdef DEBUG
printf("peek %d = %d\n",addr,i);
#endif
return(i);
}
_poke(i,j)
int i,j;
{
char *p;
p= (char *) i;
*p=j;
}

32
lang/basic/lib/power.c
View File

@@ -1,32 +0,0 @@
/* $Id$ */
/*
computes a^b.
uses log and exp
*/
double _log(), _exp();
double
_power(base,pownr)
double pownr, base;
{
double temp;
long l;
if(pownr <= 0.0) {
if(pownr == 0.0) {
if(base <= 0.0)
error(3);
return(0.0);
}
l = base;
if(l != base)
error(3);
temp = _exp(base * _log(-pownr));
if(l & 1)
temp = -temp;
return(temp);
}
return(_exp(base * _log(pownr)));
}

79
lang/basic/lib/print.c
View File

@@ -1,79 +0,0 @@
#include "bc_string.h"
#include "bc_io.h"
/* $Id$ */
/* Here all routine to generate terminal oriented output is located */
_qstmark()
{
/* prompt for terminal input */
putchar('?');
}
_nl()
{
_asschn();
_outnl();
}
_prinum(i)
int i;
{
char buffer[40];
_asschn();
if(i>=0)
sprintf(buffer," %d ",i);
else sprintf(buffer,"-%d ",-i);
_out(buffer);
}
_str(f,buffer)
double f;
char *buffer;
{
register char *c = buffer;
int eformat = 0;
if( f>=0){
if( f> 1.0e8) {
eformat = 1;
sprintf(buffer," %e",f);
}
else sprintf(buffer," %f",f);
c++;
}else {
if(-f> 1.0e8) {
eformat = 1;
sprintf(buffer,"-%e",-f);
}
else sprintf(buffer,"-%f",-f);
}
if (! eformat) {
for( ; *c && *c!= ' ';c++) ;
c--;
while( c>buffer && *c== '0')
{
*c= 0;c--;
}
if( *c=='.') *c=0;
}
}
_prfnum(f)
double f;
{
/* BASIC strings trailing zeroes */
char buffer[100];
char *c;
_asschn();
c= buffer;
_str(f,c);
strcat(buffer," ");
_out(buffer);
}
_prstr(str)
String *str;
{
_asschn();
if( str==0) _out("<null>");
else _out(str->strval);
}

31
lang/basic/lib/random.c
View File

@@ -1,31 +0,0 @@
/* $Id$ */
#if !defined(EM_WSIZE)
#define EM_WSIZE _EM_WSIZE
#endif
_randomi()
{
int i;
_setchan(-1);
printf("Random number seed (-32768 to 32767) ? ");
_readint(&i);
_setrand(i);
}
_setrand(i)
int i;
{
srand(i);
}
double _rnd(d) double d;
{
double f; f= (int) rand();
return(f/
#if EM_WSIZE == 4
2147483647.0
#else
32767.0
#endif
);
}

174
lang/basic/lib/read.c
View File

@@ -1,174 +0,0 @@
#include "bc_string.h"
#include "bc_io.h"
#include <ctype.h>
/* $Id$ */
_readln()
{
register int c;
while( (c=fgetc(_chanrd)) != EOF && c!= '\n')
;
}
readskip()
{
register int c;
#ifdef DEBUG
printf("readskip\n");
#endif
while( (c=fgetc(_chanrd)) != EOF && c!= ',' && c!= '\n')
;
}
_readint(addr)
int *addr;
{
int i;
char buf[1024];
#ifdef DEBUG
printf("read int from %d\n",_chann);
#endif
_asschn();
if( fscanf(_chanrd,"%d",&i) != 1)
{
if( ferror(_chanrd)) error(29);
if( feof(_chanrd)) error(2);
if( _chann == -1)
{
_asschn(); /* may be closed by now */
fgets(buf,1024,_chanrd);
printf("?Redo ");
_readint(addr);
return;
}
error(40);
}else { readskip(); *addr=i;}
}
_readflt(addr)
double *addr;
{
double f;
char buf[1024];
#ifdef DEBUG
printf("read flt from %d\n",_chann);
#endif
_asschn();
if( fscanf(_chanrd,"%lf",&f) != 1)
{
if( ferror(_chanrd)) error(29);
if( feof(_chanrd)) error(2);
if( _chann == -1)
{
fgets(buf,1024,_chanrd);
printf("?Redo ");
_readflt(addr);
return;
}
error(40);
}else { readskip(); *addr=f;}
}
_readstr(s)
String **s;
{
char buffer[1024];
register int kar ;
char *c;
#ifdef DEBUG
printf("read str from %d\n",_chann);
#endif
_asschn();
c= buffer;
kar= fgetc(_chanrd);
while(isspace(kar) && kar!= EOF)
kar= fgetc(_chanrd);
*c=kar ;
if( kar== '"')
{
/* read quoted string */
#ifdef DEBUG
printf("qouted string\n");
#endif
while ( (kar= fgetc(_chanrd)) != EOF && kar!='"' ) *c++ = kar ;
ungetc(kar,_chanrd);
*c=0;
}else
if( isalpha(*c))
{
/* read normal string */
c++;
#ifdef DEBUG
printf("non-qouted string\n");
#endif
while( (kar= fgetc(_chanrd)) != ',' && kar!= EOF &&
!isspace(kar) && kar!='\n')
*c++= kar ;
ungetc(kar,_chanrd);
*c=0;
}else{
if( ferror(_chanrd)) error(29);
if( feof(_chanrd)) error(2);
if( _chann == -1)
{
fgets(buffer,1024,_chanrd);
printf("?Redo ");
_rdline(s);
return;
}
error(40);
}
#ifdef DEBUG
printf("string read: %s\n",buffer);
#endif
readskip();
/* save value read */
_decstr(*s);
*s= (String *) _newstr(buffer);
}
extern int _seektab[];
_restore(line)
int line;
{
int nr;
char buffer[1024];
#ifdef DEBUG
printf("seek to %d",line);
#endif
fseek(_chanrd,0l,0);
if( line)
{
/* search number of lines to skip */
for(nr=0; _seektab[nr] && _seektab[nr]< line; nr+=2)
#ifdef DEBUG
printf("test %d %d\n",_seektab[nr], _seektab[nr+1]);
#endif
;
nr /= 2;
#ifdef DEBUG
printf(" %d lines to skip\n",nr);
#endif
while(nr-- >0 ) fgets(buffer,1024,_chanrd);
}
}
_rdline(s)
String **s;
{
char buffer[1024];
if( fgets(buffer,1024,_chanrd) == 0)
{
if( _chann == -1)
{
printf("?Redo ");
_rdline(s);
return;
}
error(40);
}
_decstr(*s);
*s= (String *) _newstr(buffer);
}

29
lang/basic/lib/return.c
View File

@@ -1,29 +0,0 @@
/* $Id$ */
#define MAXNESTING 1000
int _gotable[MAXNESTING];
int topstk=0;
_gosub(x)
int x;
{
/* administer gosub */
#ifdef DEBUG
printf("store %d in %d\n",x,topstk);
#endif
if( topstk== MAXNESTING) error(26);
_gotable[topstk]= x;
topstk++;
}
_retstmt()
{
/* make sure that a return label index is on top
of the stack */
#ifdef DEBUG
printf("return to %d %d\n",_gotable[topstk-1],topstk-1);
#endif
if( topstk==0 || topstk==MAXNESTING)
error(1);
return( _gotable[--topstk]);
}

20
lang/basic/lib/salloc.c
View File

@@ -1,20 +0,0 @@
/* $Id$ */
extern char *malloc() ;
char * salloc(length)
unsigned length;
{
char *c, *s;
c= malloc(length);
if( !c ) error(5);
for(s=c;s<c+length;s++) *s = 0;
return(c);
}
sfree(c)
char *c;
{
if( !c ) return;
free(c);
}

11
lang/basic/lib/setline.e
View File

@@ -1,11 +0,0 @@
#
mes 2,EM_WSIZE,EM_PSIZE
; $Id$
; Save the line where the error occurred
exp $_setline
pro $_setline,0
exa _erlsym
loe 0
ste _erlsym
ret 0
end

16
lang/basic/lib/sgn.c
View File

@@ -1,16 +0,0 @@
/* $Id$ */
_sgn(v)
double v;
{
if( v>0) return(1);
if( v<0) return(-1);
return(0);
}
_forsgn(v)
double v;
{
if (v >= 0) return 1;
return -1;
}

105
lang/basic/lib/sin.c
View File

@@ -1,105 +0,0 @@
/*
* (c) copyright 1988 by the Vrije Universiteit, Amsterdam, The Netherlands.
* See the copyright notice in the ACK home directory, in the file "Copyright".
*
* Author: Ceriel J.H. Jacobs
*/
/* $Id$ */
#define __NO_DEFS
#include <math.h>
static double
sinus(x, cos_flag)
double x;
{
/* Algorithm and coefficients from:
"Software manual for the elementary functions"
by W.J. Cody and W. Waite, Prentice-Hall, 1980
*/
static double r[] = {
-0.16666666666666665052e+0,
0.83333333333331650314e-2,
-0.19841269841201840457e-3,
0.27557319210152756119e-5,
-0.25052106798274584544e-7,
0.16058936490371589114e-9,
-0.76429178068910467734e-12,
0.27204790957888846175e-14
};
double xsqr;
double y;
int neg = 0;
if (x < 0) {
x = -x;
neg = 1;
}
if (cos_flag) {
neg = 0;
y = M_PI_2 + x;
}
else y = x;
/* ??? avoid loss of significance, if y is too large, error ??? */
y = y * M_1_PI + 0.5;
/* Use extended precision to calculate reduced argument.
Here we used 12 bits of the mantissa for a1.
Also split x in integer part x1 and fraction part x2.
*/
#define A1 3.1416015625
#define A2 -8.908910206761537356617e-6
{
double x1, x2;
extern double _fif();
_fif(y, 1.0, &y);
if (_fif(y, 0.5, &x1)) neg = !neg;
if (cos_flag) y -= 0.5;
x2 = _fif(x, 1.0, &x1);
x = x1 - y * A1;
x += x2;
x -= y * A2;
#undef A1
#undef A2
}
if (x < 0) {
neg = !neg;
x = -x;
}
/* ??? avoid underflow ??? */
y = x * x;
x += x * y * POLYNOM7(y, r);
return neg ? -x : x;
}
double
_sin(x)
double x;
{
return sinus(x, 0);
}
double
_cos(x)
double x;
{
if (x < 0) x = -x;
return sinus(x, 1);
}
/* EXTENSION */
double
_tan(x)
double x;
{
return _sin(x)/_cos(x);
}

71
lang/basic/lib/sqt.c
View File

@@ -1,71 +0,0 @@
/*
* (c) copyright 1988 by the Vrije Universiteit, Amsterdam, The Netherlands.
* See the copyright notice in the ACK home directory, in the file "Copyright".
*
* Author: Ceriel J.H. Jacobs
*/
/* $Id$ */
#define __NO_DEFS
#include <math.h>
#define NITER 5
static double
ldexp(fl,exp)
double fl;
int exp;
{
extern double _fef();
int sign = 1;
int currexp;
if (fl<0) {
fl = -fl;
sign = -1;
}
fl = _fef(fl,&currexp);
exp += currexp;
if (exp > 0) {
while (exp>30) {
fl *= (double) (1L << 30);
exp -= 30;
}
fl *= (double) (1L << exp);
}
else {
while (exp<-30) {
fl /= (double) (1L << 30);
exp += 30;
}
fl /= (double) (1L << -exp);
}
return sign * fl;
}
double
_sqt(x)
double x;
{
extern double _fef();
int exponent;
double val;
if (x <= 0) {
if (x < 0) error(3);
return 0;
}
val = _fef(x, &exponent);
if (exponent & 1) {
exponent--;
val *= 2;
}
val = ldexp(val + 1.0, exponent/2 - 1);
/* was: val = (val + 1.0)/2.0; val = ldexp(val, exponent/2); */
for (exponent = NITER - 1; exponent >= 0; exponent--) {
val = (val + x / val) / 2.0;
}
return val;
}

10
lang/basic/lib/stop.c
View File

@@ -1,10 +0,0 @@
/* $Id$ */
_stop()
{
extern int _erlsym;
_setline();
printf("Break in %d\n", _erlsym);
exit(0);
}

182
lang/basic/lib/string.c
View File

@@ -1,182 +0,0 @@
#include "bc_string.h"
/* $Id$ */
#define ok(X) if( X ==0) return;
#define okr(X) if( X ==0) return(0);
extern char *salloc() ;
_length(str)
String *str;
{
okr(str);
return(str->strlength);
}
String *_newstr(str)
char *str;
{
String *s;
okr(str);
s= (String *) salloc(sizeof(String));
s->strcount=1;
s->strlength= strlen(str);
s->strval= salloc(s->strlength+1);
strcpy(s->strval,str);
return(s);
}
_incstr(src)
String *src;
{
/* one more variable uses the string */
ok(src);
src->strcount++;
}
_decstr(str)
String *str;
{
ok(str);
/* Strings in ROM are initialized with this count */
if ( str->strcount==9999 ) return ;
str->strcount--;
if(str->strcount<=0) _delstr(str);
}
_strcpy(dst,src)
String *src,*dst;
{
ok(src);
ok(dst);
_decstr(dst);
*dst = *src;
_incstr(src);
}
_delstr(src)
String *src;
{
ok(src);
sfree(src->strval);
sfree((char *)src);
}
String *_concat(s1,s2)
String *s1,*s2;
{
String *s;
int length;
okr(s1); okr(s2);
s= (String *) salloc(sizeof(String));
s->strlength= _length(s1)+_length(s2);
s->strval= salloc(s->strlength+1);
s->strcount = 1;
strcpy(s->strval,s2->strval);
strcat(s->strval,s1->strval);
return(s);
}
_strcomp(s1,s2)
String *s1,*s2;
{
okr(s1);okr(s2);
return(strcmp(s2->strval,s1->strval));
}
String *_left(size,s)
String *s;
int size;
{
String *ns;
int i;
okr(s);
if( size <0 || size >s->strlength) error(3);
ns= (String *) salloc(sizeof(String));
ns->strval= salloc(size+1);
ns->strcount=1;
for(i=0; i<size && s->strval[i];i++)
ns->strval[i]= s->strval[i];
ns->strval[i]=0;
ns->strlength= i;
return(ns);
}
String *_space(d)
int d;
{
String *s;
int i,len;
len= d;
s= (String *) salloc(sizeof(String));
s->strlength= len;
s->strcount=1;
s->strval= salloc(len+1);
for(i=0;i<len;i++)
s->strval[i]= ' ';
s->strval[i]=0;
return(s);
}
String *_strascii()
{
}
String *_string(f, d)
double d,f;
{
int i,j;
String *s;
i=d;j=f;
if( i<0 || i>MAXSTRING) error(3);
s= (String *) salloc(sizeof(String));
s->strlength= i;
s->strcount=1;
s->strval= salloc(i+1);
s->strval[i--]=0;
for(; i>=0;i--)
s->strval[i]= j;
return(s);
}
_midstmt(s2,i1,i2,s)
int i1,i2;
String *s, *s2;
{
int l;
/*printf("mid called %d %d %s %s\n",i1,i2,s->strval, s2->strval);*/
if (i2 < 0 || i1 < -1) error(3);
if( s->strlength<i2 || s2->strlength < i1) error(3); /* source string too short */
if( i1== -1) i1= s2->strlength;
l= s->strlength - i2+1;
if( i1>l ) i1=l;
strncpy(s->strval+i2-1,s2->strval,i1);
}
String *_mid(i1,i2,s)
int i1,i2;
String *s;
{
int l;
String *s2;
/* printf("mid fcn called %d %d %s\n",i1,i2,s->strval);*/
if (i2 < 0 || i1 < -1) return(s2); /* or error? */
if( i1 == -1) i1= s->strlength;
s2= _newstr(s->strval);
s2->strval[0]=0;
if( s->strlength<i2) return(s2); /* source string too short */
l= s->strlength - i2+1;
if( i1>l ) i1=l;
strncpy(s2->strval,s->strval+i2-1,i1);
s2->strval[i1]=0;
return(s2);
}
String *_right(length,str)
String *str;
int length;
{
String *s;
int i;
i= _length(str)-length;
if(i<0) i=0;
s= _newstr(str->strval+i);
return(s);
}

30
lang/basic/lib/swap.c
View File

@@ -1,30 +0,0 @@
#include "bc_string.h"
/* $Id$ */
_intswap(i1,i2)
int *i1,*i2;
{
int i3;
i3= *i1;
*i1= *i2;
*i2=i3;
}
_fltswap(i1,i2)
double *i1,*i2;
{
double i3;
i3= *i1;
*i1= *i2;
*i2=i3;
}
_strswap(s1,s2)
String **s1,**s2;
{
String *s;
s= *s1;
*s1= *s2;
*s2 = s;
}

7
lang/basic/lib/trace.c
View File

@@ -1,7 +0,0 @@
/* $Id$ */
_trace(i)
int i;
{
printf("[%d]",i);
}

60
lang/basic/lib/trap.c
View File

@@ -1,60 +0,0 @@
#include <signal.h>
#include <setjmp.h>
#ifndef NSIG
#define NSIG _NSIG
#endif
/* $Id$ */
/* Trap handling */
int _trpline; /* BASIC return label */
jmp_buf trpbuf;
_trpset(nr)
int nr;
{
/*debug printf("trap set to %d\n",nr);*/
_trpline=nr;
}
void
_trpfatal(i)
int i;
{
extern int _errsym,_erlsym;
_errsym= i;
_setline();
if( _trpline == 0)
printf("LINE %d: FATAL ERROR: trap %d\n",_erlsym,i);
#ifdef DEBUG
printf("trap occurred %d return %d\n",i,_trpline);
#endif
_trap();
}
_ini_trp()
{
/* initialize trap routines */
int i;
for(i=0;i<NSIG;i++)
signal(i,_trpfatal);
}
_settrap(nr)
int nr;
{
_trpline=nr;
}
_trap()
{
int line;
if( _trpline==0) exit(-1);
line=_trpline;
_trpline=0; /* should be reset by user */
_ini_trp();
longjmp(trpbuf,line);
}

35
lang/basic/lib/write.c
View File

@@ -1,35 +0,0 @@
#include "bc_string.h"
#include "bc_io.h"
/* $Id$ */
/* assume that the channel has been set */
_wrnl()
{
if( fputc('\n',_chanwr) == EOF) error(29);
}
_wrcomma()
{
if( fputc(',',_chanwr) == EOF) error(29);
}
_wrint(i)
int i;
{
if(i>0)
if( fputc(' ',_chanwr)==EOF) error(29);
fprintf(_chanwr,"%d",i);
if( ferror(_chanwr) ) error(29);
}
_wrflt(f)
double f;
{
fprintf(_chanwr,"%f",f);
if( ferror(_chanwr) ) error(29);
}
_wrstr(s)
String *s;
{
fprintf(_chanwr,"\"%s\"",s->strval);
if( ferror(_chanwr) ) error(29);
}

20
lang/basic/src/.distr
View File

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

64
lang/basic/src/Makefile
View File

@@ -1,64 +0,0 @@
# $Header$
EMHOME=../../..
h=$(EMHOME)/h
m=$(EMHOME)/modules/h
LIBDIR= $(EMHOME)/modules/lib
LIBDIR2= $(EMHOME)/lib
CFLAGS = -I$h -I$m -O
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)/libemk.a \
$(LIBDIR2)/em_data.a $(LIBDIR)/libprint.a \
$(LIBDIR)/liballoc.a \
$(LIBDIR)/libsystem.a $(LIBDIR)/libstring.a
LINTLIBFILES= $(LIBDIR)/llib-lem_mes.ln $(LIBDIR)/llib-lemk.ln \
$(LIBDIR)/llib-lprint.ln \
$(LIBDIR)/llib-lalloc.ln \
$(LIBDIR)/llib-lsystem.ln $(LIBDIR)/llib-lstring.ln
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: dummy $(CFILES) tokentab.h
lint -b $(CFLAGS) $(CFILES) $(LINTLIBFILES)
clean:
rm -f *.o
rm -f basic.c Lpars.h Lpars.c dummy tokentab.h bem

792
lang/basic/src/basic.g
View File

@@ -1,792 +0,0 @@
/*
* (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; int 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; int exp; }
: LETSYM
variable(&var) { save_address(); }
'=' expression(&exp) { assign(var,exp); }
|
variable(&var) { save_address(); }
'=' expression(&exp) { assign(var,exp); }
;
lineinputstmt { int var; int 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; int 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; int 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; int 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[] = "$Id$" ;
#endif
}

613
lang/basic/src/basic.lex
View File

@@ -1,613 +0,0 @@
/*
* (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[] = "$Id$" ;
#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(0); /* 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) == 0)
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++);
}

53
lang/basic/src/bem.c
View File

@@ -1,53 +0,0 @@
/*
* (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[] = "$Id$" ;
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 *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 */
}

82
lang/basic/src/bem.h
View File

@@ -1,82 +0,0 @@
/*
* (c) copyright 1987 by the Vrije Universiteit, Amsterdam, The Netherlands.
* See the copyright notice in the ACK home directory, in the file "Copyright".
*/
#include <ctype.h>
#include <signal.h>
#include <system.h>
#include <print.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 "$Id$"
#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 */
#ifndef __STDC__
#define void int /* Some C compilers don't know void */
#endif
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 File *emfile; /* EM output file */
extern File *datfile; /* data file */
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 *strcpy();
extern char *strcat();
#if __STDC__
#include <stdlib.h>
#else
extern char *malloc();
#endif

30
lang/basic/src/compile.c
View File

@@ -1,30 +0,0 @@
/*
* (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[] = "$Id$" ;
#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();
sys_close(yyin);
}

536
lang/basic/src/eval.c
View File

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

269
lang/basic/src/func.c
View File

@@ -1,269 +0,0 @@
/*
* (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[] = "$Id$" ;
#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("_length");
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);
}

705
lang/basic/src/gencode.c
View File

@@ -1,705 +0,0 @@
/*
* (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[] = "$Id$" ;
#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;
extern long sys_filesize();
/* NOSTRICT */ l= (List *) salloc(sizeof(List));
l->linenr= currline->linenr;
l->emlabel = sys_filesize(datfname);
if ( datalist==0)
{
datalist=l;
} else {
l1= datalist;
while (l1->nextlist) l1= l1->nextlist;
l1->nextlist=l;
}
}
datatable()
{
List *l;
int line=0;
/* called at end to generate the data seek table */
C_exa_dnam("_seektab");
C_df_dnam("_seektab"); /* VRAAGTEKEN */
l= datalist;
while (l)
{
C_rom_cst((arith)(l->linenr));
C_rom_cst((arith)(line++));
l= l->nextlist;
}
C_rom_cst((arith)0);
C_rom_cst((arith)0);
}
/* ERROR and exception handling */
exceptstmt(lab)
int lab;
{
/* exceptions to subroutines are supported only */
extern int gosubcnt;
List *l;
C_loc((arith)gosubcnt);
l= (List *) gosublabel();
l->emlabel= gotolabel(lab);
C_cal("_trpset");
C_asp((arith)BEMINTSIZE);
}
errorstmt(exprtype)
int exprtype;
{
/* convert expression to a valid error number */
/* obtain the message and print it */
C_cal("error");
C_asp((arith)typesize(exprtype));
}
/* BASIC IO */
openstmt(recsize)
int recsize;
{
C_loc((arith)recsize);
C_cal("_opnchn");
C_asp((arith)(2*BEMPTRSIZE+BEMINTSIZE));
}
printstmt(exprtype)
int exprtype;
{
switch(exprtype)
{
case INTTYPE:
C_cal("_prinum");
C_asp((arith)typestring(INTTYPE));
break;
case FLOATTYPE:
case DOUBLETYPE:
C_cal("_prfnum");
C_asp((arith)typestring(DOUBLETYPE));
break;
case STRINGTYPE:
C_cal("_prstr");
C_asp((arith)BEMPTRSIZE);
break;
case 0: /* result of tab function etc */
break;
default:
error("printstmt:unexpected");
}
}
zone(i)
int i;
{
if ( i) C_cal("_zone");
}
writestmt(exprtype,comma)
int exprtype,comma;
{
if ( comma) C_cal("_wrcomma");
switch(exprtype)
{
case INTTYPE:
C_cal("_wrint");
break;
case FLOATTYPE:
case DOUBLETYPE:
C_cal("_wrflt");
break;
case STRINGTYPE:
C_cal("_wrstr");
break;
default:
error("printstmt:unexpected");
}
C_asp((arith)BEMPTRSIZE);
}
restore(lab)
int lab;
{
/* save this information too */
C_loc((arith)0);
C_cal("_setchan");
C_asp((arith)BEMINTSIZE);
C_loc((arith)lab);
C_cal("_restore");
C_asp((arith)BEMINTSIZE);
}
prompt(qst)
int qst;
{
setchannel(-1);
C_cal("_prstr");
C_asp((arith)BEMPTRSIZE);
if (qst) C_cal("_qstmark");
}
linestmt(type)
int type;
{
if ( type!= STRINGTYPE)
error("String variable expected");
C_cal("_rdline");
C_asp((arith)BEMPTRSIZE);
}
readelm(type)
int type;
{
switch(type)
{
case INTTYPE:
C_cal("_readint");
break;
case FLOATTYPE:
case DOUBLETYPE:
C_cal("_readflt");
break;
case STRINGTYPE:
C_cal("_readstr");
break;
default:
error("readelm:unexpected type");
}
C_asp((arith)BEMPTRSIZE);
}
/* Swap exchanges the variable values */
swapstmt(ltype,rtype)
int ltype, rtype;
{
if ( ltype!= rtype)
error("Type mismatch");
else
switch(ltype)
{
case INTTYPE:
C_cal("_intswap");
break;
case FLOATTYPE:
case DOUBLETYPE:
C_cal("_fltswap");
break;
case STRINGTYPE:
C_cal("_strswap");
break;
default:
error("swap:unexpected");
}
C_asp((arith)(2*BEMPTRSIZE));
}
/* input/output handling */
setchannel(val)
int val;
{ /* obtain file descroption */
C_loc((arith)val);
C_cal("_setchan");
C_asp((arith)BEMINTSIZE);
}
/* The if-then-else statements */
ifstmt(type)
int type;
{
/* This BASIC follows the True= -1 rule */
int nr;
nr= genlabel();
if ( type == INTTYPE)
C_zeq((label)nr);
else
if ( type == FLOATTYPE || type == DOUBLETYPE )
{
C_lae_dnam("fltnull",(arith)0);
C_loi((arith)BEMFLTSIZE);
C_cmf((arith)BEMFLTSIZE);
C_zeq((label)nr);
}
else error("Integer or Float expected");
return(nr);
}
thenpart( elselab)
int elselab;
{
int nr;
nr=genlabel();
C_bra((label)nr);
C_df_ilb((label)elselab);
return(nr);
}
elsepart(lab)int lab;
{
C_df_ilb((label)lab);
}
/* generate code for the for-statement */
#define MAXFORDEPTH 20
struct FORSTRUCT{
Symbol *loopvar; /* loop variable */
int initaddress;
int limitaddress;
int stepaddress;
int fortst; /* variable limit test */
int forinc; /* variable increment code */
int forout; /* end of loop */
} fortable[MAXFORDEPTH];
int forcnt= -1;
forinit(s)
Symbol *s;
{
int type;
struct FORSTRUCT *f;
dcltype(s);
type= s->symtype;
forcnt++;
if ( (type!=INTTYPE && type!=FLOATTYPE && type!=DOUBLETYPE) ||
s->dimensions)
error("Illegal loop variable");
if ( forcnt >=MAXFORDEPTH)
error("too many for statements");
else {
f=fortable+forcnt;
f->loopvar=s;
f->fortst=genlabel();
f->forinc=genlabel();
f->forout=genlabel();
/* generate space for temporary objects */
f->initaddress= dclspace(type);
f->limitaddress= dclspace(type);
f->stepaddress= dclspace(type);
}
}
forexpr(type)
int type;
{
/* save start value of loop variable in a save place*/
/* to avoid clashing with final value and step expression */
int result;
result= fortable[forcnt].loopvar->symtype;
conversion(type,result);
storevar(fortable[forcnt].initaddress, result);
}
forlimit(type)
int type;
{
/* save the limit value too*/
int result;
result= fortable[forcnt].loopvar->symtype;
conversion(type,result);
storevar(fortable[forcnt].limitaddress, result);
}
forskipped(f)
struct FORSTRUCT *f;
{
int type;
type= f->loopvar->symtype;
/* evaluate lower bound times sign of step */
C_lae_dlb((label)f->initaddress,(arith)0);
loadvar(type);
conversion(type,DOUBLETYPE);
C_lae_dlb((label)f->stepaddress,(arith)0);
loadvar(type);
conversion(type,DOUBLETYPE);
C_cal("_forsgn");
C_asp((arith)BEMFLTSIZE);
C_lfr((arith)BEMINTSIZE);
conversion(INTTYPE,DOUBLETYPE);
C_mlf((arith)BEMFLTSIZE);
/* evaluate higher bound times sign of step */
C_lae_dlb((label)f->limitaddress,(arith)0);
loadvar(type);
conversion(type,DOUBLETYPE);
C_lae_dlb((label)f->stepaddress,(arith)0);
loadvar(type);
conversion(type,DOUBLETYPE);
C_cal("_forsgn");
C_asp((arith)BEMFLTSIZE);
C_lfr((arith)BEMINTSIZE);
conversion(INTTYPE,DOUBLETYPE);
C_mlf((arith)BEMFLTSIZE);
/* skip condition */
C_cmf((arith)BEMFLTSIZE);
C_zgt((label)f->forout);
}
forstep(type)
int type;
{
int result;
int varaddress;
struct FORSTRUCT *f;
f= fortable+forcnt;
result= f->loopvar->symtype;
varaddress= f->loopvar->symalias;
conversion(type,result);
storevar(f->stepaddress, result);
/* all information available, generate for-loop head */
/* test for ingoring loop */
forskipped(f);
/* set initial value */
C_lae_dlb((label)f->initaddress,(arith)0);
loadvar(result);
C_lae_dlb((label)varaddress,(arith)0);
C_sti((arith)typestring(result));
C_bra((label)f->fortst);
/* increment loop variable */
C_df_ilb((label)f->forinc);
C_lae_dlb((label)varaddress,(arith)0);
loadvar(result);
C_lae_dlb((label)f->stepaddress,(arith)0);
loadvar(result);
if (result == INTTYPE)
C_adi((arith)BEMINTSIZE);
else C_adf((arith)BEMFLTSIZE);
C_lae_dlb((label)varaddress,(arith)0);
C_sti((arith)typestring(result));
/* test boundary */
C_df_ilb((label)f->fortst);
C_lae_dlb((label)varaddress,(arith)0);
loadvar(result);
/* Start of NEW code */
C_lae_dlb((label)f->stepaddress,(arith)0);
loadvar(result);
conversion(result,DOUBLETYPE);
C_cal("_forsgn");
C_asp((arith)BEMFLTSIZE);
C_lfr((arith)BEMINTSIZE);
conversion(INTTYPE,result);
if ( result == INTTYPE )
C_mli((arith)BEMINTSIZE);
else C_mlf((arith)BEMFLTSIZE);
/* End of NEW code */
C_lae_dlb((label)f->limitaddress,(arith)0);
loadvar(result);
/* Start NEW code */
C_lae_dlb((label)f->stepaddress,(arith)0);
loadvar(result);
conversion(result,DOUBLETYPE);
C_cal("_forsgn");
C_asp((arith)BEMFLTSIZE);
C_lfr((arith)BEMINTSIZE);
conversion(INTTYPE,result);
if ( result == INTTYPE )
C_mli((arith)BEMINTSIZE);
else C_mlf((arith)BEMFLTSIZE);
/* End NEW code */
if (result == INTTYPE)
C_cmi((arith)BEMINTSIZE);
else C_cmf((arith)BEMFLTSIZE);
C_zgt((label)f->forout);
}
nextstmt(s)
Symbol *s;
{
if (forcnt>MAXFORDEPTH || forcnt<0 ||
(s && s!= fortable[forcnt].loopvar))
error("NEXT without FOR");
else {
/* address of variable is on top of stack ! */
C_bra((label)fortable[forcnt].forinc);
C_df_ilb((label)fortable[forcnt].forout);
forcnt--;
}
}
pokestmt(type1,type2)
int type1,type2;
{
conversion(type1,INTTYPE);
conversion(type2,INTTYPE);
C_asp((arith)(2*BEMINTSIZE));
}
/* generate code for the while statement */
#define MAXDEPTH 20
int whilecnt, whilelabels[MAXDEPTH][2]; /*0=head,1=out */
whilestart()
{
whilecnt++;
if ( whilecnt==MAXDEPTH)
fatal("too many nestings");
/* gendummy label in graph */
newblock(-1);
whilelabels[whilecnt][0]= currline->emlabel;
whilelabels[whilecnt][1]= genlabel();
C_df_ilb((label)whilelabels[whilecnt][0]);
}
whiletst(exprtype)
int exprtype;
{
/* test expression type */
conversion(exprtype,INTTYPE);
C_zeq((label)whilelabels[whilecnt][1]);
}
wend()
{
if ( whilecnt<1)
error("not part of while statement");
else {
C_bra((label)whilelabels[whilecnt][0]);
C_df_ilb((label)whilelabels[whilecnt][1]);
whilecnt--;
}
}
/* generate code for the final version */
prologcode()
{
/* generate the EM prolog code */
C_df_dnam("fltnull");
C_con_cst((arith)0);
C_con_cst((arith)0);
C_con_cst((arith)0);
C_con_cst((arith)0);
C_df_dnam("dummy2");
C_con_cst((arith)0);
C_con_cst((arith)0);
C_con_cst((arith)0);
C_con_cst((arith)0);
/* NEW variable we make */
C_df_dnam("dummy3");
C_bss_dnam((arith)BEMPTRSIZE,"dummy3",(arith)0,0);
C_df_dnam("tronoff");
C_con_cst((arith)0);
C_df_dnam("dummy1");
C_con_cst((arith)0);
C_con_cst((arith)0);
C_con_cst((arith)0);
C_con_cst((arith)0);
C_exa_dnam("_iomode");
C_df_dnam("_iomode");
C_rom_scon("O",(arith)2);
C_exa_dnam("_errsym");
C_df_dnam("_errsym");
C_bss_cst((arith)BEMINTSIZE,(arith)0,1);
C_exa_dnam("_erlsym");
C_df_dnam("_erlsym");
C_bss_cst((arith)BEMINTSIZE,(arith)0,1);
}
prolog2()
{
int result;
label l = genlabel(), l2;
err_goto_label = genlabel();
C_exp("main");
C_pro("main",(arith)0);
C_ms_par((arith)0);
/* Trap handling */
C_cal("_ini_trp");
l2 = genemlabel();
C_rom_ilb(l);
C_lae_dlb(l2, (arith) 0);
C_loi((arith) BEMPTRSIZE);
C_exa_dnam("trpbuf");
C_lae_dnam("trpbuf",(arith)0);
C_cal("setjmp");
C_df_ilb(l);
C_asp((arith)(BEMPTRSIZE+BEMPTRSIZE));
C_lfr((arith)BEMINTSIZE);
C_dup((arith)BEMINTSIZE);
C_zeq((label)0);
C_lae_dnam("returns",(arith)0);
C_csa((arith)BEMINTSIZE);
C_df_ilb((label)0);
C_asp((arith)BEMINTSIZE);
result= sys_open(datfname, OP_WRITE, &datfile);
if ( result==0 ) fatal("improper file creation permission");
gendata();
}
/* NEW */
gendata()
{
C_loc((arith)0);
C_cal("_setchan");
C_asp((arith)BEMINTSIZE);
C_df_dnam("datfname");
C_rom_scon(datfname,(arith)strlen(datfname) + 1); /* EHB */
C_df_dnam("dattyp");
C_rom_scon("i\\0",(arith)4);
C_df_dnam("datfdes");
C_rom_dnam("datfname",(arith)0);
C_rom_cst((arith)1);
C_rom_cst((arith)(itoa(strlen(datfname))));
C_df_dnam("dattdes");
C_rom_dnam("dattyp",(arith)0);
C_rom_cst((arith)1);
C_rom_cst((arith)1);
C_lae_dnam("dattdes",(arith)0);
C_lae_dnam("datfdes",(arith)0);
C_loc((arith)0);
C_cal("_opnchn");
C_asp((arith)(2*BEMPTRSIZE+BEMINTSIZE));
}
epilogcode()
{
/* finalization code */
int nr;
nr= genlabel();
C_bra((label)nr);
genreturns();
C_df_ilb((label)nr);
datatable(); /* NEW */
C_loc((arith)0);
C_cal("_hlt");
C_df_ilb(err_goto_label);
C_cal("_goto_err");
C_end((arith)0);
}

340
lang/basic/src/graph.c
View File

@@ -1,340 +0,0 @@
/*
* (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[] = "$Id$" ;
#endif
List *forwardlabel=0;
Linerecord *firstline,
*currline,
*lastline;
List *newlist()
{
List *l;
/* NOSTRICT */ l = (List *) salloc(sizeof(List));
return(l);
}
/* Line management is handled here */
Linerecord *srchline(nr)
int nr;
{
Linerecord *l;
for(l=firstline;l && l->linenr<=nr;l= l->nextline)
if ( l->linenr== nr) return(l);
return(0);
}
List *srchforward(nr)
int nr;
{
List *l;
for(l=forwardlabel;l ;l=l->nextlist)
if ( l->linenr== nr) return(l);
return(0);
}
linewarnings()
{
List *l;
extern int errorcnt;
l= forwardlabel;
while (l)
{
if ( !srchline(l->linenr))
{
fprint(STDERR, "ERROR: line %d not defined\n",l->linenr);
errorcnt++;
}
l=l->nextlist;
}
}
newblock(nr)
int nr;
{
Linerecord *l;
List *frwrd;
if ( debug) print("newblock at %d\n",nr);
if ( nr>0 && currline && currline->linenr>= nr)
{
if ( debug) print("old line:%d\n",currline->linenr);
error("Lines out of sequence");
}
frwrd=srchforward(nr);
if ( frwrd && debug) print("forward found %d\n",frwrd->emlabel);
l= srchline(nr);
if ( l)
{
error("Line redefined");
nr= -genlabel();
}
/* make new EM block structure */
/* NOSTRICT */ l= (Linerecord *) salloc(sizeof(*l));
l->emlabel= frwrd ? frwrd->emlabel : genlabel();
l->linenr= nr;
/* insert this record */
if ( firstline)
{
currline->nextline=l;
l->prevline= currline;
lastline= currline=l;
} else
firstline = lastline =currline=l;
}
gotolabel(nr)
int nr;
{
/* simulate a goto statement in the line record table */
Linerecord *l1;
List *ll;
if (debug) print("goto label %d\n",nr);
/* update currline */
ll= newlist();
ll-> linenr=nr;
ll-> nextlist= currline->gotos;
currline->gotos= ll;
/* try to generate code */
l1= srchline(nr);
if ( (ll=srchforward(nr))!=0)
nr= ll->emlabel;
else
if ( l1==0)
{
/* declare forward label */
if (debug) print("declare forward %d\n",nr);
ll= newlist();
ll->emlabel= genlabel();
ll-> linenr=nr;
ll->nextlist= forwardlabel;
forwardlabel= ll;
nr= ll->emlabel;
} else nr= l1->emlabel;
return(nr);
}
gotostmt(nr)
int nr;
{
C_bra((label) gotolabel(nr));
}
/* GOSUB-return, assume that proper entries are made to subroutines
only. The return statement is triggered by a fake constant label */
List *gosubhead, *gotail;
int gosubcnt=1;
List *gosublabel()
{
List *l;
l= newlist();
l->nextlist=0;
l->emlabel=genlabel();
if ( gotail){
gotail->nextlist=l;
gotail=l;
} else gotail= gosubhead=l;
gosubcnt++;
return(l);
}
gosubstmt(lab)
int lab;
{
List *l;
int nr,n;
n=gosubcnt;
l= gosublabel();
nr=gotolabel(lab);
/*return index */
C_loc((arith) n);
/* administer legal return */
C_cal("_gosub");
C_asp((arith) BEMINTSIZE);
C_bra((label) nr);
C_df_ilb((label)l->emlabel);
}
genreturns()
{
int nr;
nr= genlabel();
C_df_dnam("returns");
C_rom_ilb((label) nr);
C_rom_cst((arith)1);
C_rom_cst((arith) (gosubcnt-1));
while ( gosubhead)
{
C_rom_ilb((label) gosubhead->emlabel);
gosubhead= gosubhead->nextlist;
}
C_df_ilb((label) nr);
C_loc((arith) 1);
C_cal("error");
}
returnstmt()
{
C_cal("_retstmt");
C_lfr((arith) BEMINTSIZE);
C_lae_dnam("returns",(arith)0);
C_csa((arith) BEMINTSIZE);
}
/* compound goto-gosub statements */
List *jumphead,*jumptail;
int jumpcnt;
jumpelm(nr)
int nr;
{
List *l;
l= newlist();
l->emlabel= gotolabel(nr);
l->nextlist=0;
if ( jumphead==0) jumphead = jumptail = l;
else {
jumptail->nextlist=l;
jumptail=l;
}
jumpcnt++;
}
ongotostmt(type)
int type;
{
/* generate the code itself, index in on top of the stack */
/* blurh, store the number of entries in the descriptor */
int firstlabel;
int descr;
List *l;
/* create descriptor first */
descr= genlabel();
firstlabel=genlabel();
C_df_dlb((label)descr);
C_rom_ilb((label)firstlabel);
C_rom_cst((arith) 1);
C_rom_cst((arith)(jumpcnt-1));
l= jumphead;
while (l)
{
C_rom_ilb((label)l->emlabel);
l= l->nextlist;
}
jumphead= jumptail=0; jumpcnt=0;
if (debug) print("ongotst:%d labels\n", jumpcnt);
conversion(type,INTTYPE);
C_dup((arith) BEMINTSIZE);
C_zlt(err_goto_label);
C_lae_dlb((label) descr,(arith) 0);
C_csa((arith) BEMINTSIZE);
C_df_ilb((label)firstlabel);
}
ongosubstmt(type)
int type;
{
List *l;
int firstlabel;
int descr;
/* create descriptor first */
descr= genlabel();
firstlabel=genlabel();
C_df_dlb((label)descr);
C_rom_ilb((label)firstlabel);
C_rom_cst((arith)1);
C_rom_cst((arith)(jumpcnt-1));
l= jumphead;
while (l)
{
C_rom_ilb((label)l->emlabel);
l= l->nextlist;
}
jumphead= jumptail=0;
jumpcnt=0;
l= newlist();
l->nextlist=0;
l->emlabel=firstlabel;
if ( gotail){
gotail->nextlist=l;
gotail=l;
} else gotail=gosubhead=l;
/* save the return point of the gosub */
C_loc((arith) gosubcnt);
C_cal("_gosub");
C_asp((arith) BEMINTSIZE);
gosubcnt++;
/* generate gosub */
conversion(type,INTTYPE);
C_dup((arith) BEMINTSIZE);
C_zlt(err_goto_label);
C_lae_dlb((label) descr,(arith) 0);
C_csa((arith) BEMINTSIZE);
C_df_ilb((label)firstlabel);
}
/* REGION ANALYSIS and FINAL VERSION GENERATION */

37
lang/basic/src/graph.h
View File

@@ -1,37 +0,0 @@
/*
* (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 "$Id$"
#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();

49
lang/basic/src/initialize.c
View File

@@ -1,49 +0,0 @@
/*
* (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[] = "$Id$";
#endif
/* generate temporary files etc */
File *datfile;
initialize()
{
register char *cindex, *cptr;
int result1, result2;
/* 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);
if ( result1==0 || result2== 0 )
fatal("Improper file permissions");
C_magic();
fillkex(); /* initialize symbol table */
C_ms_emx((arith)BEMINTSIZE,(arith)BEMPTRSIZE);
initdeftype(); /* set default symbol declarers */
}

62
lang/basic/src/llmess.c
View File

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

16
lang/basic/src/maketokentab
View File

@@ -1,16 +0,0 @@
ed -s Lpars.h <<'+'
1d
1,$s/# *define //
1,$s/ ...$//
1,$s/^/ "/
1,$-1s/$/",/
$s/$/"/
0a
char *tokentab[] = {
.
$a
};
.
w tokentab.h
q
+

85
lang/basic/src/parsepar.c
View File

@@ -1,85 +0,0 @@
/*
* (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[] = "$Id$" ;
#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 */
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");
}

59
lang/basic/src/proto.main
View File

@@ -1,59 +0,0 @@
# $Id$
# C compilation part. Not to be called directly.
# Instead, it is to be called by the Makefile.
# SRC_DIR, UTIL_HOME, TARGET_HOME, CC, COPTIONS, LINT, LINTOPTIONS, LDOPTIONS,
# CC_AND_MKDEP, SUF, LIBSUF should be set here.
#PARAMS do not remove this line!
# PRODUCE is either e (readable EM) or k (compact EM)
PRODUCE = k
MDIR = $(TARGET_HOME)/modules
LIBDIR = $(MDIR)/lib
LINTLIBDIR = $(UTIL_HOME)/modules/lib
MALLOC = $(LIBDIR)/malloc.$(SUF)
EMLIB = $(LIBDIR)/libem_mes.$(LIBSUF) \
$(LIBDIR)/libem$(PRODUCE).$(LIBSUF) \
$(TARGET_HOME)/lib.bin/em_data.$(LIBSUF)
MODLIB = $(LIBDIR)/liballoc.$(LIBSUF) \
$(MALLOC) \
$(LIBDIR)/libprint.$(LIBSUF) \
$(LIBDIR)/libstring.$(LIBSUF) \
$(LIBDIR)/libsystem.$(LIBSUF)
LIBS = $(EMLIB) $(MODLIB)
LINTLIBS = $(LINTLIBDIR)/$(LINTPREF)em_mes.$(LINTSUF) \
$(LINTLIBDIR)/$(LINTPREF)emk.$(LINTSUF) \
$(LINTLIBDIR)/$(LINTPREF)alloc.$(LINTSUF) \
$(LINTLIBDIR)/$(LINTPREF)print.$(LINTSUF) \
$(LINTLIBDIR)/$(LINTPREF)string.$(LINTSUF) \
$(LINTLIBDIR)/$(LINTPREF)system.$(LINTSUF)
PROFILE =
INCLUDES = -I$(TARGET_HOME)/modules/h -I. -I$(SRC_DIR) -I$(TARGET_HOME)/h -I$(TARGET_HOME)/modules/pkg
CFLAGS = $(PROFILE) $(INCLUDES) $(COPTIONS)
LINTFLAGS = $(INCLUDES) $(LINTOPTIONS)
LDFLAGS = $(PROFILE) $(LDOPTIONS)
# C_SRC and OBJ should be set here.
#LISTS do not remove this line!
all: main
clean:
rm -f *.$(SUF) main
lint:
$(LINT) $(LINTFLAGS) $(C_SRC) $(LINTLIBS)
main: $(OBJ)
$(CC) $(LDFLAGS) $(OBJ) $(LIBS) -o main
# do not remove the next line; it is used for generating dependencies
#DEPENDENCIES

116
lang/basic/src/proto.make
View File

@@ -1,116 +0,0 @@
# $Id$
# make basic compiler
#PARAMS do not remove this line!
UTIL_BIN = \
$(UTIL_HOME)/bin
SRC_DIR = \
$(SRC_HOME)/lang/basic/src
TABGEN= $(UTIL_BIN)/tabgen
LLGEN = $(UTIL_BIN)/LLgen
LLGENOPTIONS = \
-v
SRC_G = $(SRC_DIR)/basic.g
GEN_G =
GFILES= $(GEN_G) $(SRC_G)
SRC_C = \
$(SRC_DIR)/bem.c \
$(SRC_DIR)/symbols.c \
$(SRC_DIR)/initialize.c \
$(SRC_DIR)/compile.c \
$(SRC_DIR)/parsepar.c \
$(SRC_DIR)/gencode.c \
$(SRC_DIR)/util.c \
$(SRC_DIR)/graph.c \
$(SRC_DIR)/eval.c \
$(SRC_DIR)/func.c
GEN_C = basic.c Lpars.c
CFILES= $(SRC_C) $(GEN_C)
SRC_H = \
$(SRC_DIR)/bem.h \
$(SRC_DIR)/symbols.h \
$(SRC_DIR)/graph.h \
$(SRC_DIR)/llmess.c \
$(SRC_DIR)/yylexp.c
GEN_H = Lpars.h tokentab.h
HFILES= $(GEN_H) $(SRC_H)
all: make.main
make -f make.main main
install: all
@-mkdir $(TARGET_HOME)
@-mkdir $(TARGET_HOME)/lib.bin
cp main $(TARGET_HOME)/lib.bin/em_bem
cmp: all
-cmp main $(TARGET_HOME)/lib.bin/em_bem
opr:
make pr | opr
pr:
@pr $(SRC_DIR)/proto.make $(SRC_DIR)/proto.main \
$(SRC_DIR)/maketokentab $(SRC_DIR)/basic.lex \
$(SRC_G) $(SRC_H) $(SRC_C)
lint: make.main
make -f make.main lint
Cfiles: LLfiles $(GEN_C) $(GEN_H) Makefile
echo $(CFILES) | tr ' ' '\012' > Cfiles
echo $(HFILES) | tr ' ' '\012' >> Cfiles
resolved: Cfiles
CC="$(CC)" UTIL_HOME="$(UTIL_HOME)" do_resolve `cat Cfiles` > Cfiles.new
-if cmp -s Cfiles Cfiles.new ; then rm -f Cfiles.new ; else mv Cfiles.new Cfiles ; fi
touch resolved
# there is no file called "dependencies"; we want dependencies checked
# every time. This means that make.main is made every time. Oh well ...
# it does not take much time.
dependencies: resolved
do_deps `grep '.c$$' Cfiles`
make.main: dependencies make_macros lists $(SRC_DIR)/proto.main
rm_deps $(SRC_DIR)/proto.main | sed -e '/^.PARAMS/r make_macros' -e '/^.LISTS/r lists' > make.main
cat *.dep >> make.main
make_macros: Makefile
echo 'SRC_DIR=$(SRC_DIR)' > make_macros
echo 'UTIL_HOME=$(UTIL_HOME)' >> make_macros
echo 'TARGET_HOME=$(TARGET_HOME)' >> make_macros
echo 'CC=$(CC)' >> make_macros
echo 'COPTIONS=$(COPTIONS)' >> make_macros
echo 'LDOPTIONS=$(LDOPTIONS)' >> make_macros
echo 'LINT=$(LINT)' >> make_macros
echo 'LINTSUF=$(LINTSUF)' >> make_macros
echo 'LINTPREF=$(LINTPREF)' >> make_macros
echo 'LINTOPTIONS=$(LINTOPTIONS)' >> make_macros
echo 'SUF=$(SUF)' >> make_macros
echo 'LIBSUF=$(LIBSUF)' >> make_macros
echo 'CC_AND_MKDEP=$(CC_AND_MKDEP)' >> make_macros
lists: Cfiles
echo "C_SRC = \\" > lists
echo $(CFILES) >> lists
echo "OBJ = \\" >> lists
echo $(CFILES) | sed -e 's|[^ ]*/||g' -e 's/\.c/.$$(SUF)/g' >> lists
clean:
-make -f make.main clean
rm -f $(GEN_C) $(GEN_G) $(GEN_H) $(GEN_L) LLfiles Cfiles LL.output
rm -f resolved *.dep lists make.main make_macros
LLfiles: $(GFILES)
$(LLGEN) $(LLGENOPTIONS) $(GFILES)
@touch LLfiles
tokentab.h: Lpars.h $(SRC_DIR)/maketokentab
$(SRC_DIR)/maketokentab

376
lang/basic/src/symbols.c
View File

@@ -1,376 +0,0 @@
/*
* (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[] = "$Id$" ;
#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];
(void) sprint(procname,"_%s",fcn->symname);
C_pro_narg(procname);
if ( fcn->symtype== DEFAULTTYPE)
fcn->symtype= DOUBLETYPE;
}
int fcnsize()
{
/* generate portable function size */
int i,sum; /* sum is NEW */
sum = 0;
for(i=0;i<fcn->dimensions;i++)
sum += typesize(fcn->dimlimit[i]);
return(sum);
}
endscope(type)
int type;
{
Symbol *s;
if ( debug) print("endscope");
conversion(type,fcn->symtype);
C_ret((arith) typestring(fcn->symtype));
/* generate portable EM code */
C_end( (arith)fcnsize() );
s= firstsym;
while (s)
{
firstsym = s->nextsym;
(void) free((char *)s);
s= firstsym;
}
firstsym= alternate;
alternate = NIL;
fcn=NIL;
}
dclparm(s)
Symbol *s;
{
int size=0;
if ( s->symtype== DEFAULTTYPE)
s->symtype= DOUBLETYPE;
s->isparam=1;
fcn->dimlimit[fcn->dimensions]= s->symtype;
fcn->dimensions++;
s->symalias= -fcn->dimensions;
if ( debug) print("parameter %d offset %d\n",fcn->dimensions-1,-size);
}
/* unfortunately function calls have to be stacked as well */
#define MAXNESTING 50
Symbol *fcntable[MAXNESTING];
int fcnindex= -1;
fcncall(s)
Symbol *s;
{
if ( !s->isfunction)
error("Function not declared");
else{
fcn= s;
fcnindex++;
fcntable[fcnindex]=s;
}
return(s->symtype);
}
fcnend(parmcount)
int parmcount;
{
int type;
static char concatbuf[50]; /* NEW */
/* check number of arguments */
if ( parmcount <fcn->dimensions)
error("not enough parameters");
if ( parmcount >fcn->dimensions)
error("too many parameters");
(void) sprint(concatbuf,"_%s",fcn->symname);
C_cal(concatbuf);
C_asp((arith)fcnsize());
C_lfr((arith) typestring(fcn->symtype));
type= fcn->symtype;
fcnindex--;
if ( fcnindex>=0)
fcn= fcntable[fcnindex];
return(type);
}
callparm(ind,type)
int ind,type;
{
if ( fcnindex<0) error("unexpected parameter");
if ( ind >= fcn->dimensions)
error("too many parameters");
else
conversion(type,fcn->dimlimit[ind]);
}

88
lang/basic/src/symbols.h
View File

@@ -1,88 +0,0 @@
/*
* (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 "$Id$"
#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();

97
lang/basic/src/util.c
View File

@@ -1,97 +0,0 @@
/*
* (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[] = "$Id$" ;
#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];
sprint(buf,"%d",i);
return(buf);
}
char *salloc(length)
unsigned length;
{
char *s,*c;
s=c=malloc(length);
if ( !s ) fatal("Out of memory") ;
while(length--)*c++ =0;
return(s);
}

22
lang/basic/src/yylexp.c
View File

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

100
lang/basic/test/.distr
View File

@@ -1,100 +0,0 @@
Makefile
Out.std
bull.b
bull.b.g
buzzword.b
buzzword.b.g
checker.b
checker.b.g
creator.b
grafiek.b
grafiek.b.g
gunner.b
gunner.b.g
learn.b
learn.b.g
opg1.b
opg1.b.g
opg2.b
opg2.b.g
opg3.b
opg3.b.g
opg4.b
opg4.b.g
opg5.b
opg5.b.g
opg6.b
opg6.b.g
runcmp
som4.b
som4.b.g
test01.b
test01.b.g
test02.b
test02.b.g
test03.b
test03.b.g
test04.b
test04.b.g
test05.b
test05.b.g
test06.b
test06.b.g
test07.b
test07.b.g
test08.b
test08.b.g
test09.b
test09.b.g
test10.b
test10.b.g
test11.b
test11.b.g
test12.b
test12.b.g
test13.b
test13.b.g
test14.b
test14.b.g
test15.b
test15.b.g
test16.b
test16.b.g
test17.b
test17.b.g
test18.b
test18.b.g
test19.b
test19.b.g
test20.b
test20.b.g
test21.b
test21.b.g
test22.b
test22.b.g
test23.b
test23.b.g
test24.b
test24.b.g
test25.b
test25.b.g
test26.b
test26.b.g
test27.b
test27.b.g
test28.b
test28.b.g
test29.b
test29.b.g
test30.b
test30.b.g
test31.b
test31.b.g
test32.b
test32.b.g
test33.b
test33.b.g
test34.b
test35.b
test35.b.g
tst

15
lang/basic/test/Makefile
View File

@@ -1,15 +0,0 @@
SRC= bull.b buzzword.b checker.b creator.b grafiek.b gunner.b learn.b\
opg1.b opg2.b opg3.b opg4.b opg5.b opg6.b som4.b test01.b test02.b\
test03.b test04.b test05.b test06.b test07.b test08.b test09.b\
test10.b test11.b test12.b test13.b test14.b test15.b test16.b\
test17.b test19.b test20.b test21.b test22.b test23.b\
test24.b test25.b test26.b test27.b test28.b test29.b test30.b\
test31.b test32.b test33.b test34.b test35.b
#FLOATS = -fp
FLOATS =
head:
for i in $(SRC) ; do fp=$(FLOATS); export fp; runcmp $$i ; done
clean:
rm -f *.b.[rx] *.[dekmos]

54
lang/basic/test/Out.std
View File

@@ -1,54 +0,0 @@
for i in bull.b buzzword.b checker.b creator.b grafiek.b gunner.b learn.b opg1.b opg2.b opg3.b opg4.b opg5.b opg6.b som4.b test01.b test02.b test03.b test04.b test05.b test06.b test07.b test08.b test09.b test10.b test11.b test12.b test13.b test14.b test15.b test16.b test17.b test19.b test20.b test21.b test22.b test23.b test24.b test25.b test26.b test27.b test28.b test29.b test30.b test31.b test32.b test33.b test34.b test35.b ; do runcmp $i ; done
bull.b ------- execution error(s)-*- Ok
buzzword.b ------- execution error(s)-*- Ok
checker.b ------- execution error(s)-*- Ok
creator.b Undefined:
__inkey
------- compilation error(s)
grafiek.b -*- Ok
gunner.b ------- execution error(s)-*- Ok
learn.b ------- execution error(s)-*- Ok
opg1.b -*- Ok
opg2.b -*- Ok
opg3.b -*- Ok
opg4.b -*- Ok
opg5.b -*- Ok
opg6.b -*- Ok
som4.b ------- execution error(s)-*- Ok
test01.b -*- Ok
test02.b -*- Ok
test03.b -*- Ok
test04.b -*- Ok
test05.b -*- Ok
test06.b -*- Ok
test07.b ------- execution error(s)-*- Ok
test08.b -*- Ok
test09.b -*- Ok
test10.b -*- Ok
test11.b -*- Ok
test12.b -*- Ok
test13.b -*- Ok
test14.b -*- Ok
test15.b -*- Ok
test16.b -*- Ok
test17.b ------- execution error(s)-*- Ok
test19.b ------- execution error(s)-*- Ok
test20.b -*- Ok
test21.b -*- Ok
test22.b ------- execution error(s)-*- Ok
test23.b ------- execution error(s)-*- Ok
test24.b -*- Ok
test25.b -*- Ok
test26.b -*- Ok
test27.b ------- execution error(s)-*- Ok
test28.b ------- execution error(s)-*- Ok
test29.b -*- Ok
test30.b ------- execution error(s)-*- Ok
test31.b -*- Ok
test32.b -*- Ok
test33.b -*- Ok
test34.b LINE 20:ERROR:too many indices
LINE 30:ERROR:too many indices
LINE 40:ERROR:too many indices
------- compilation error(s)
test35.b -*- Ok

37
lang/basic/test/bull.b
View File

@@ -1,37 +0,0 @@
10 rem *** bullseye
20 print "game of bullseye":print:randomize
30 print "in this game, up to 20 players throw darts at a target"
40 print "with 10,20,30, and 40 point zones. The objective is"
50 print "toget 200 point.":print
60 print "throw","description",,"probable score"
70 print " 1","fast overarm",,"bullseye or complete miss"
80 print " 2","controlled overarm","10,20,30 points"
90 print " 3","underarm",,"anything":print
100 dim a$(20),s(20),w(10):r=0:m=0: for i=1 to 20:s(i)=0:nexti
110 input ;"how many players";n:print
120 for i=1 to n
130 print "name of player" i; : input a$(i)
140 nexti
150 r=r+1:print:print "round" r
160 for i=1 to n
170 print:print a$(i)"'s throw";:input t
180if t<1 or t>3 then print "input 1, 2, or 3":goto 170
190 on t goto 200,210,220
200 p1=.65:p2=.55:p3=.5:p4=.5:goto 230
210p1=.99:p2=.77:p3=.43:p4=.01:goto 230
220 p1=.95:p2=.75:p3=.45:p4=.05
230 u=rnd(0):print "rnd="u
240 if u>=p1 then print "BULLSEYE!! 40 points":b=40:goto 290
250 if u>=p2 then print "30-point zone":b=30:goto 290
260 if u>=p3 then print "20-point zone":b=20:goto 290
270 if u>=p4 then print "WHEH! 10 points":b=10:goto 290
280 print "missed the target. too bad!":b=0
290 s(i)=s(i)+b:print "total score="s(i):next i
300 fori=1 to n
310 if s(i)>=200 then m=m+1:w(m)=i
320 nexti
330 if m=0 then150
340 print :print "We have a winner!!":print
350 print a$(w(m))" scored"s(w(m))"points."
360 for i=1 to m
370 print:print "thanks for the game!":nexti:end

3
lang/basic/test/bull.b.g
View File

@@ -1,3 +0,0 @@
game of bullseye
Random number seed (-32768 to 32767) ? LINE 20:ERROR 2: Out of data

66
lang/basic/test/buzzword.b
View File

@@ -1,66 +0,0 @@
100 print "This computer program demonstration us a new aid for"
110 print "preparing speeches and briefings. It's a buzzword"
120 print "generator which provides you with a set of three higly"
130 print "acceptablewords to work into your material. The words"
140 print "don't actually mean anything, but they sound great."
150 print
160 print "the procedure:"
170 print ,"Think of any three numbers between 0 and 9, enter"
180 print , "them after the '?' separated by commas. your"
190 print ,"buzzword will be printed out. Typing "100" for"
200 print ,"each of your choices stops this program."
210 print "What are your three numbers";
220 goto 260
230 print
240 print
250 print "Three more numbers";
260 input n,m,p
265 if n= 100 then 1290
267 print "continue"
270 if n<0 then 1240
280 if p<0 then 1240
290 if m<0 then 1240
300 if m>9 then 1240
310 if p>9 then 1240
320 if n>9 then 1240
330 print
340 on n+1 goto 640,660,680,700,720,740,760,780,800,820
440 on m+1 goto 840,860,880,900,920,940,960,980,1000,1020
540 on p+1 goto 1040,1060,1080,1100,1120,1140,1160,1180,1200,1220
640 print " integrated";: goto 440
660 print " total";: goto 440
680 print " systematized";: goto 440
700 print " parallel";: goto 440
720 print " functional";: goto 440
740 print " responsive";: goto 440
760 print " optimal";: goto 440
780 print " synchronized";: goto 440
800 print " compatible";: goto 440
820 print " balanced";: goto 440
840 print " management"; : goto 540
860 print " organizational"; : goto 540
880 print " monitored"; : goto 540
900 print " reciprocal"; : goto 540
920 print " digital"; : goto 540
940 print " logistical"; : goto 540
960 print " transitional"; : goto 540
980 print " incremental"; : goto 540
1000 print " fifth-generation"; : goto 540
1020 print " policy"; : goto 540
1040 print " options";: goto 230
1060 print " flexibility";: goto 230
1080 print " capability";: goto 230
1100 print " mobility";: goto 230
1120 print " programming";: goto 230
1140 print " concept";: goto 230
1160 print " time-phase";: goto 230
1180 print " projection";: goto 230
1200 print " hardware";: goto 230
1220 print " contingency";: goto 230
1240 print
1260 print
1270 print "numbers must be between 0 and 9, please select three more."
1280 goto 260
1290 print "Goodbye for now."
1300 print:print:print
1310 end

12
lang/basic/test/buzzword.b.g
View File

@@ -1,12 +0,0 @@
This computer program demonstration us a new aid for
preparing speeches and briefings. It's a buzzword
generator which provides you with a set of three higly
acceptablewords to work into your material. The words
don't actually mean anything, but they sound great.
the procedure:
Think of any three numbers between 0 and 9, enter
them after the '?' separated by commas. your
buzzword will be printed out. Typing 100 for
each of your choices stops this program.
What are your three numbers?LINE 260:ERROR 2: Out of data

192
lang/basic/test/checker.b
View File

@@ -1,192 +0,0 @@
100 print "This program will play checkers. The computer us X,"
110 print "and you are 0. The computer will go first, -note: squares"
120 print "are printed in the form-(X,Y) and sq. 1.1 is the bottom left!"
130 print "do not attempt a double jump or your piece might just"
140 print "disappear (same for triple!)"
150 print " Wait for the computer to move!!!!!!"
700 g=-1
800 dim r(50)
900 let l=-1
1000 dim s(10,10)
1100 data 1,0,1,0,0,0,-1,0,0,1,0,0,0,-1,0,-1,15
1200 for x=1to8
1300 fory=1to8
1400 read j
1500 if j=15 then 1800
1600 s(x,y)=j
1700 goto 2000
1800 restore
1900 reads(x,y)
2000 nexty
2100 nextx
2200 rem
2300 l=-1*l
2400 for x=1to 8
2500 for y=1to8
2600 if s(x,y)=0 then 3500
2700 if g>0 then 3000
2800 if s(x,y)>0 then 3500
2900 goto 3100
3000 if s(x,y)<0 then 3500
3100 if abs(s(x,y))<>1 then 3300
3200 gosub 4300
3300 if abs(s(x,y))<>2 then 3500
3400 gosub 6500
3500 if x<>8 then 3800
3600 if l=1 then 3800
3700 rem return
3800 nexty
3900 nextx
4000 print
4100 gosub 11400
4200 goto 2300
4300 for a=-1 to 1 step2
4400 let u=x+a
4500 let v=y+g
4600 if u<1 then 6300
4700 if u>8 then 6300
4800 if v<1 then 6300
4900 if v>8 then 6300
5000 if s(u,v) <> 0 then 5300
5100 gosub 9100
5200 goto 6300
5300 if s(u,v)=g then 6300
5400 if s(u,v)=2*g then 6300
5500 u=u+a
5600 v=v+g
5700 if u<1 then 6300
5800 if u>8 then 6300
5900 if v<1 then 6300
6000 if v>8 then 6300
6100 if s(u,v)<>0 then 6300
6200 gosub 9100
6300 next a
6400 return
6500 rem king moves
6600 for a=-1 to 1 step2
6700 forb=-1to 1step2
6800 u=x+a
6900 v=y+b
7000 if u<1 then 8700
7100 if u>8 then 8700
7200 if v<1 then 8700
7300 if v>8 then 8700
7400 if s(u,v)<>0 then 7700
7500 gosub 9100
7600 goto 8700
7700 if s(umv)=g then 8700
7800 if s(u,v)=2*g then 8700
7900 u=u+a
8000 v=v+b
8100 if u<1 then 8700
8200 if u>8 then 8700
8300 if v<1 then 8700
8400 if v>8 then 8700
8500 if s(u,v)<>0 then 8700
8600 gosub 9100
8700 next b
8800 next a
8900return
9000 goto 14200
9100 rem
9200 p=p+1
9300 if p=k then 12300
9400 if v<>(4.5+(3.5*g)) then 9600
9500 q=q+2
9600 if x<>(4.5-(3.5*g)) then9800
9700 q=q-2
9800 rem
9900 if u<>1 then 10100
10000 q=q+1
10100 if u<> 8 then 10300
10200 q=q+1
10300 for c=-1 to 1 step 2
10400 if s(u+c,v+g)<1 then 10800
10500 q=q-1
10600 if s(u-c,v-g) <> 0 then 10800
10700 q=q-1
10800 rem this was the evaluation section
10900 rem
11000 next c
11100 r(p)=q
11200 q=0
11300 return
11400 if p=0 then 18800
11500 for j=10to-10step -1
11600for f=1to p
11700 if r(f)=j then 12000
11800 next f
11900 next j
12000 let k=f+p
12100 print "retry": gosub 2300
12200 return
12300 print " I move from ("X Y") to("U;V")"
12400 letf=0
12500 p=0
12600 k=0
12700 if v<>(4.5+(3.5*g)) then 13000
12800 s(u,v)=s*g
12900 goto 13100
13000 let s(u,v)=s(x,y)
13100 let s(x,y)=0
13200 if(abs(x-u))<>2 then 13400
13300 s((x+u)/2,(y+v)/2)=0
13400 print "board";
13500 input d$
13600 if d$<>"yes" then 13900
13700 gosub 14100
13800 return
13900 gosub 15800
14000 return
14100 print
14200 for y=8to1step -1
14300 for x=1to8
14400 i=2*x
14500 if s(x,y)<>0 then14700
14600 print tab(i)".";
14700 if s(x,y)<>1 then 14900
14800 print tab(i)"0"
14900 if s(x,y)<>-1then 15100
15000 print tab(i)"X"
15100 if s(x,y)<>-2 then 15300
15200 print tab(i)"X";tab(I)"*"
15300 if s(x,y)<>2 then 15500
15400 print tab(i)"O";tab(I)"*"
15500 next x
15600 print
15700 next y
15800 print
15900 print "from";
16000 input e,h
16100 x=e
16200 y=h
16300 if s(x,y)<>0 then 16700
16400 print "there is no one occupying that space"
16500 print
16600 goto 15900
16700 print "to";
16800 input a,b
16900 x=a
17000 y=b
17100 if s(x,y)=0 then 17500
17200 print "that space is already occupied"
17300 print
17400 goto 16700
17500 rem
17600 s(a,b)=s(e,h)
17700 s(e,h)=0
17800 t=(4.5-(3.5*g))
17900 if abs(e-a)<>2 then 18100
18000 s((e+a)/2,(h+b)/2)=0
18100 if b<>t then 18300
18200 s(a,b)= -2*g
18300 for x=8to8
18400 for y=8to8
18500 return
18600 nexty
18700 next x
18800 print " very good, you win"
18900 print:print
19100 print " chuck out"
19200 end

10
lang/basic/test/checker.b.g
View File

@@ -1,10 +0,0 @@
This program will play checkers. The computer us X,
and you are 0. The computer will go first, -note: squares
are printed in the form-(X,Y) and sq. 1.1 is the bottom left!
do not attempt a double jump or your piece might just
disappear (same for triple!)
Wait for the computer to move!!!!!!
retry
I move from ( 2 6 ) to( 1 5 )
board?LINE 13500:ERROR 2: Out of data

29
lang/basic/test/creator.b
View File

@@ -1,29 +0,0 @@
10 rem The Creator
20 rem 80 micro jan 1983
80 print"This is the Creator. It will allow you to generate"
90 print"a progam which will create and access a data file."
100 print"For later use. Please type the proposed program name."
110 print"You are limited to 8 alphabetic characters."
120 print" program name=";:lineinputpn$
130 fori=1tolen(pn$):a$=mid$(pn$,i,1):ifa$>"z"ora$<"A"thenprint"alpha characters only!":goto 120
140 nexti
150 iflen(pn$)>8thenprint"too long":goto 120
160 print"when the proposed program is run, which drive contains the"
170 print"data file(0-3)?";
180 an$=inkey$:ifan$="" then 180 elseif(an$>"3"oran$<"0")then170
190 printan$
200 print"which drive do you want the program written on? (0-3)";
210 dn$=inkey$:ifdn$="" then 210 elseif(dn$>"3"ordn$<"0")then200
240 print#1," 1 rem*******Program name:";pn$;"*******"
250 print#1," 2 rem*******Data File name:";df$;"*****"
260 print#1," 3 rem*******Data File is on drive";ans$;"******"
270 input"What is the maximum data file size, in # of records";ms
280 input"What is the record length(1-255)";rr:ifrr<0orrr>255then280 else r%=256/rr
290 ifms*256/r%>85760thenprint"not enough room on a single disk for this.":goto 270
300 print#1,"4 rem ******maximum file size is";ms;"records******"
310 print#1,"5 rem****** record length is";rr;"packed";r%;"per sector"
320 q$=chr$(34)
330 print"please type in a title for your generated program.":lineinputti$
340 ln=ln+10:print#1,ln;"rem change disks reinitialize here"
350 ln=ln+10

55
lang/basic/test/grafiek.b
View File

@@ -1,55 +0,0 @@
0015 print
0020 for f =2 to 72 step 2
0030 print tab (f) "-" ;
0040 next f
0043 print
0045 c= 30
0050 for x=6 to 360 step 12
0060 a=30 +25*sin(x*0.01745329)
0070 b=30+25*cos(x*0.01745329)
0080 if a=c then 0130
0090 if b=c then 0190
0100 if a=b then 0230
0110 if a>c then 0290
0120 if c>a then 0380
0130 if a>b then 0360
0140 ifb>a then 0170
0150 print tab(b) "." tab(a) "*"
0160 goto 0460
0170 print tab(a) "*" tab(b) "."
0180 goto 0460
0190 if a>b then 0210
0200 if b>a then 0220
0210 goto 0150
0220 goto 0170
0230 if a>c then 0250
0240 if c>a then 0270
0250 print tab(c) "I" tab(a) "*"
0260 goto 0460
0270 print tab(a) "*" tab(c) "I"
0280 goto 0460
0290 if b>a then 0340
0300 if a>b then 0302
0302 if c>b then 0320
0305 if b<a then 0360
0310 if b>c then 0360
0320 print tab(b) "." tab(c) "I" tab(a) "*"
0330 goto 0460
0340 print tab(c) "I" tab(a) "*" tab(b) "."
0350 goto 0460
0360 print tab(c) "I" tab(b) "." tab(a) "*"
0370 goto 0460
0380 if a>b then 0430
0385 if c>b then 0410
0387 if b>c then 0450
0395 if a>b then 0410
0400 if b>a then 0450
0410 print tab(a) "*" tab(b) "." tab(c) "I"
0420 goto 0460
0430 print tab(b) "." tab(a) "*" tab(c) "I"
0440 goto 0460
0450 print tab(a) "*" tab(c) "I" tab(b) "."
0460 next x
0470 end

34
lang/basic/test/grafiek.b.g
View File

@@ -1,34 +0,0 @@
- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
I * .
I * .
I * .
I * .
I . *
I . *
I . *
I
. *
. I *
. I *
. I *
. I *
. I *
. I *
. I *
. * I
. * I
. * I
. * I
* . I
* . I
* . I
* .
I
* I .
* I .
* I .
* I .
* I .
* I .
* I .

58
lang/basic/test/gunner.b
View File

@@ -1,58 +0,0 @@
10 rem gunner program
90 randomize
100 print "this program simulates the results "
110 print "of firing a field artillery weapon"
120 print
130 print "you are the officer-in-charge, giving orders to the gun"
140 print "crew, telling them the degrees of elevation you estimate"
150 print "will place the projectile on target. A hit within 100 yards"
160 print "of the target will destroy it. Take more than 5 shots,"
170 print "end the enemy will destroy you!":print
180 print "maximum range of your gun is 46500 yards."
185 z=0
190 print
195 s1=0
200 t= 43000-30000*rnd(x)
210 s=0
220 goto 370
230 print"minimum elevation of the gun is one degree."
240 goto 390
250 print "maximum elevation of gun is 89 degrees."
260 goto 390
270 print "over target by";abs(e);"yards"
280 goto 390
290 print "short of target by";abs(e);"yards"
300 goto 390
310 goto 320
320 print "*****target destroyed ****";s;"rounds of ammunition expended"
322 gosub 600
325 s1=s1+s
330 if z=4 then 490
340 z=z+1
345 print
350 print "the forward observer has sighted more enemy activity."
360 goto 200
370 print " distance to the target is";int(t);"yards...."
380 print
390 print
400 print "elevation";
410 input b
420 if b>89 then 250
430 if b<1 then 230
440 s=s+1
442 if s<6 then 450
444 print:print "BOOM !!! You have been destroyed";
445 gosub 600
446 print "by the enemy":print:print:goto 495
450 b2=2*b/57.3:let i=46500*sin(b2):x=t-i:e=int(x)
460 if abs(e)<100 then 310
470 if e>100 then 290
480 if e<-100 then 270
490 print:print:print "total rounds expended were";s1
491 if s1>15 then 495:print "nice shooting!!":gosub 600:goto 500
495 print "better go back to fort silly for refresher training!"
500 print:print "thank you for playing!"
505 print:print "try again....":print:goto 180
600 rem for n=1 to 10 print chr$(7): rem next n
610 return
999 end

1
lang/basic/test/gunner.b.g
View File

@@ -1 +0,0 @@
Random number seed (-32768 to 32767) ? LINE 90:ERROR 2: Out of data

25
lang/basic/test/learn.b
View File

@@ -1,25 +0,0 @@
10 REM Learning program I
15 dim variable(10), rank(10), varname$(10)
20 input "how many variable have you";v
30 for i=1to v :variable(i)=0:rank(i)=0:next i
40 print "please name these variable"
50 for i=1to v: input "variable name";varname$(i):next i
60 print "Please name the outcomes"
70 input "outcome 1";q1$
80 input "outcome 2"; q2$
90 for i=1 to v:variable(i)=0
100 print "variable ";varname(i);
110 input "is this variable the case";a$
120 if a$="y" then variable(i)=1
130 next i
140 d=0
150 for i=1 to v
160 d=d+variable(i)* rank(i)
170 next i
175 print "conclusion: ";d;
180 if d>=0 then print q1$
190 if d<0 then print q2$
195 input "is this right";a$:if a$="y" then:goto 90
200 if d>=0 and a$="n" then: for i=1 to v:rank(i)=rank(i)-variable(i):next i
210 if d<0 and a$="n" then: for i=1 to v:rank(i)=rank(i)+variable(i):next i
220 goto 90

1
lang/basic/test/learn.b.g
View File

@@ -1 +0,0 @@
how many variable have you?LINE 20:ERROR 2: Out of data

6
lang/basic/test/opg1.b
View File

@@ -1,6 +0,0 @@
100 rem interest rate program page 33
110 read m,d,p,n
300 let r= m * d /(p*(n+1)) * 200
400 print "percent interest is",r
500 data 12, 320, 3000, 36
600 end

1
lang/basic/test/opg1.b.g
View File

@@ -1 +0,0 @@
percent interest is 6.918919

16
lang/basic/test/opg2.b
View File

@@ -1,16 +0,0 @@
100 rem Square root program (47)
110 rem this program uses the newton raphson
120 rem technique to calculate the square root
130 read a,e
140 let x =(a+2)/3
150 let x1= (x+a/x)*.5
160 rem determine absolute value of x1-x
170 let n= x1-x
180 if n>= 0 then 200
190 let n= 0-n
200 if n<e then 230
210 let x=x1
220 goto 150
230 print "square root of",a,"equals",x1
240 end
250 data 81, .01

1
lang/basic/test/opg2.b.g
View File

@@ -1 +0,0 @@
square root of 81 equals 9

12
lang/basic/test/opg3.b
View File

@@ -1,12 +0,0 @@
010 rem values of n using if-then loop
020 print "n","n2","n3","1/n","square root"
030 let n=1
040 let n2= n*n
050 let n3= n*n*n
060 let r= 1/n
070 let s= n^ .5
080 print n,n2,n3,r,s
090 if n>= 20 then 120
100 let n= n+1
110 goto 40
120 end

21
lang/basic/test/opg3.b.g
View File

@@ -1,21 +0,0 @@
n n2 n3 1/n square root
1 1 1 1 1
2 4 8 0.5 1.414214
3 9 27 0.333333 1.732051
4 16 64 0.25 2
5 25 125 0.2 2.236068
6 36 216 0.166667 2.44949
7 49 343 0.142857 2.645751
8 64 512 0.125 2.828427
9 81 729 0.111111 3
10 100 1000 0.1 3.162278
11 121 1331 0.090909 3.316625
12 144 1728 0.083333 3.464102
13 169 2197 0.076923 3.605551
14 196 2744 0.071429 3.741657
15 225 3375 0.066667 3.872983
16 256 4096 0.0625 4
17 289 4913 0.058824 4.123106
18 324 5832 0.055556 4.242641
19 361 6859 0.052632 4.358899
20 400 8000 0.05 4.472136

10
lang/basic/test/opg4.b
View File

@@ -1,10 +0,0 @@
010 rem values of n using for loop (52)
020 print "n","n2","n3","1/n","square root"
030 for n=1 to 20
040 let n2= n*n
050 let n3= n*n*n
060 let r= 1/n
070 let s= n^ .5
080 print n,n2,n3,r,s
090 next n
120 end

21
lang/basic/test/opg4.b.g
View File

@@ -1,21 +0,0 @@
n n2 n3 1/n square root
1 1 1 1 1
2 4 8 0.5 1.414214
3 9 27 0.333333 1.732051
4 16 64 0.25 2
5 25 125 0.2 2.236068
6 36 216 0.166667 2.44949
7 49 343 0.142857 2.645751
8 64 512 0.125 2.828427
9 81 729 0.111111 3
10 100 1000 0.1 3.162278
11 121 1331 0.090909 3.316625
12 144 1728 0.083333 3.464102
13 169 2197 0.076923 3.605551
14 196 2744 0.071429 3.741657
15 225 3375 0.066667 3.872983
16 256 4096 0.0625 4
17 289 4913 0.058824 4.123106
18 324 5832 0.055556 4.242641
19 361 6859 0.052632 4.358899
20 400 8000 0.05 4.472136

13
lang/basic/test/opg5.b
View File

@@ -1,13 +0,0 @@
10 rem find largest number (57)
20 read l
30 let r=0
40 for z=1 to l
50 read a
60 if a<=r then 80
70 let r=a
80 next z
90 print "largest number is",r
100 data 10
110 data 106, 42,-12,111,88,91,3,263,-1042,7
120 end

1
lang/basic/test/opg5.b.g
View File

@@ -1 +0,0 @@
largest number is 263

14
lang/basic/test/opg6.b
View File

@@ -1,14 +0,0 @@
1000 rem Temperature conversion
1010 print "fahrenheit","centrigrade","kelvin","rankin"
1020 for s= 1 to 5
1030 print
1040 next s
1050 for i= 1 to 12
1060 read f
1070 let c= 5/9 *(f-32)
1080 let k = c+273
1090 let r= f+ 460
1100 print f,c,k,r
1110 next i
1120 data 144, 36,110,98,63,26,14,78,66,51,107,2
1130 end

18
lang/basic/test/opg6.b.g
View File

@@ -1,18 +0,0 @@
fahrenheit centrigrade kelvin rankin
144 62.222222 335.222222 604
36 2.222222 275.222222 496
110 43.333333 316.333333 570
98 36.666667 309.666667 558
63 17.222222 290.222222 523
26 -3.333333 269.666667 486
14 -10 263 474
78 25.555556 298.555556 538
66 18.888889 291.888889 526
51 10.555556 283.555556 511
107 41.666667 314.666667 567
2 -16.666667 256.333333 462

23
lang/basic/test/runcmp
View File

@@ -1,23 +0,0 @@
echo -n $1 " "
if abc - -o $1.x $fp $1
then
if $1.x >$1.r
then :; else
echo -n "------- execution error(s)"
fi
if diff $1.g $1.r >$1.d 2>/dev/null
then
echo -*- Ok
else
if test -r $1.g
then
echo ------- differences in executing $1
cat $1.d
else
mv $1.r $1.g
fi
fi
rm $1.[rd]
else
echo "------- compilation error(s)"
fi

17
lang/basic/test/som4.b
View File

@@ -1,17 +0,0 @@
0010 print " beginwaarde =a"
0020 input a
0030 print "eindwaarde =b"
0040 input b
0050 if b<a then 0130
0060 n=a
0070 if n<0 then 0200
0080 print "n=",n;" wortel uit n=",sqr(n)
0090 if n=b then 0120
0100 n=n+1
0110 goto 0070
0120 end
0130 print "b moet groter zijn dan a"
0140 end
0200 print "n=",n,"n is negatief, de oplossing is leeg"
0210 goto 0100

2
lang/basic/test/som4.b.g
View File

@@ -1,2 +0,0 @@
beginwaarde =a
?LINE 20:ERROR 2: Out of data

5
lang/basic/test/test01.b
View File

@@ -1,5 +0,0 @@
100 print "hello world"
110 let s$="a happy 1984"
120 print s
130 s= s+" !! "
140 print s

3
lang/basic/test/test01.b.g
View File

@@ -1,3 +0,0 @@
hello world
a happy 1984
a happy 1984 !!

2
lang/basic/test/test02.b
View File

@@ -1,2 +0,0 @@
110 print 1:print 2
120 print 1+2 ' This is nice

3
lang/basic/test/test02.b.g
View File

@@ -1,3 +0,0 @@
1
2
3

2
lang/basic/test/test03.b
View File

@@ -1,2 +0,0 @@
100 rem this is comment
110 print 1: rem this is skipped : print 2

2
lang/basic/test/test03.b.g
View File

@@ -1,2 +0,0 @@
1
2

5
lang/basic/test/test04.b
View File

@@ -1,5 +0,0 @@
100 let a=1:print a
110 let b%=2:print b
120 let c!= 1.0:print c
125 let d#= 12.0:print d
130 let s$= "hello":prints

5
lang/basic/test/test04.b.g
View File

@@ -1,5 +0,0 @@
1
2
1
12
hello

7
lang/basic/test/test05.b
View File

@@ -1,7 +0,0 @@
100 defint a-c,d
110 defstr s,t
120 defdbl f
125 a=1.13
127 s="hello"
128 print a,s
130 stop

2
lang/basic/test/test05.b.g
View File

@@ -1,2 +0,0 @@
1 hello
Break in 130

5
lang/basic/test/test06.b
View File

@@ -1,5 +0,0 @@
5 print 1<2
10 while i<12
12 print i
14 i= i+1
15 wend

Some files were not shown because too many files have changed in this diff Show More