*** empty log message ***

h/bc_io.h

@@ -0,0 +1,29 @@
+#include <stdio.h>
+
+/* $Header$ */
+
+/* BASIC file io definitions */
+
+extern FILE *_chanrd;
+extern FILE *_chanwr;
+extern int   _chann;
+/* BASIC file descriptor table */
+/* Channel assignment:
+   -1		terminal IO
+    0		data file
+    1-15	user files
+*/
+
+/* FILE MODES:*/
+#define 	IMODE	1
+#define		OMODE	2
+#define		RMODE	3
+
+typedef struct {
+	char	*fname;
+	FILE	*fd;
+	int	pos;
+	int	mode;	
+	int	reclength;
+	}Filedesc;
+extern Filedesc	 _fdtable[16];

h/bc_string.h

@@ -0,0 +1,15 @@
+#
+
+/* $Header$ */
+
+/* Strings are allocated in a fixed string descriptor table 
+** This mechanism is used to avoid string copying as much as possible
+*/
+
+typedef struct{
+	char	*strval;
+	int	strcount;
+	int	strlength;
+	} String;
+
+#define MAXSTRING 1024

lang/basic/lib/LIST

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

lang/basic/lib/abs.c

@@ -0,0 +1,10 @@
+/* $Header $ */
+
+long _abl(i) long i;
+{
+	return( i>=0?i:-i);
+}
+double _abr(f) double f;
+{	
+	return( f>=0.0?f: -f);
+}

lang/basic/lib/asc.c

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

lang/basic/lib/asrt.c

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

lang/basic/lib/atn.c

@@ -0,0 +1,93 @@
+/*
+ * (c) copyright 1983 by the Vrije Universiteit, Amsterdam, The Netherlands.
+ *
+ *          This product is part of the Amsterdam Compiler Kit.
+ *
+ * Permission to use, sell, duplicate or disclose this software must be
+ * obtained in writing. Requests for such permissions may be sent to
+ *
+ *      Dr. Andrew S. Tanenbaum
+ *      Wiskundig Seminarium
+ *      Vrije Universiteit
+ *      Postbox 7161
+ *      1007 MC Amsterdam
+ *      The Netherlands
+ *
+ */
+
+/* $Header $ */
+
+/* Author: J.W. Stevenson */
+
+/*
+	floating-point arctangent
+
+	atan returns the value of the arctangent of its
+	argument in the range [-pi/2,pi/2].
+
+	there are no error returns.
+
+	coefficients are #5077 from Hart & Cheney. (19.56D)
+*/
+
+
+static double sq2p1	= 2.414213562373095048802e0;
+static double sq2m1	=  .414213562373095048802e0;
+static double pio2	= 1.570796326794896619231e0;
+static double pio4	=  .785398163397448309615e0;
+static double p4	=  .161536412982230228262e2;
+static double p3	=  .26842548195503973794141e3;
+static double p2	=  .11530293515404850115428136e4;
+static double p1	=  .178040631643319697105464587e4;
+static double p0	=  .89678597403663861959987488e3;
+static double q4	=  .5895697050844462222791e2;
+static double q3	=  .536265374031215315104235e3;
+static double q2	=  .16667838148816337184521798e4;
+static double q1	=  .207933497444540981287275926e4;
+static double q0	=  .89678597403663861962481162e3;
+
+/*
+	xatan evaluates a series valid in the
+	range [-0.414...,+0.414...].
+*/
+
+static double
+xatan(arg)
+double arg;
+{
+	double argsq;
+	double value;
+
+	argsq = arg*arg;
+	value = ((((p4*argsq + p3)*argsq + p2)*argsq + p1)*argsq + p0);
+	value = value/(((((argsq + q4)*argsq + q3)*argsq + q2)*argsq + q1)*argsq + q0);
+	return(value*arg);
+}
+
+static double
+satan(arg)
+double arg;
+{
+	if(arg < sq2m1)
+		return(xatan(arg));
+	else if(arg > sq2p1)
+		return(pio2 - xatan(1/arg));
+	else
+		return(pio4 + xatan((arg-1)/(arg+1)));
+}
+
+
+/*
+	atan makes its argument positive and
+	calls the inner routine satan.
+*/
+
+double
+_atn(arg)
+double arg;
+{
+	if(arg>0)
+		return(satan(arg));
+	else
+		return(-satan(-arg));
+}

lang/basic/lib/chr.c

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

lang/basic/lib/conversion.c

@@ -0,0 +1,40 @@
+/* $Header $ */
+
+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);
+}

lang/basic/lib/error.c

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

lang/basic/lib/exp.c

@@ -0,0 +1,122 @@
+/*
+ * (c) copyright 1983 by the Vrije Universiteit, Amsterdam, The Netherlands.
+ *
+ *          This product is part of the Amsterdam Compiler Kit.
+ *
+ * Permission to use, sell, duplicate or disclose this software must be
+ * obtained in writing. Requests for such permissions may be sent to
+ *
+ *      Dr. Andrew S. Tanenbaum
+ *      Wiskundig Seminarium
+ *      Vrije Universiteit
+ *      Postbox 7161
+ *      1007 MC Amsterdam
+ *      The Netherlands
+ *
+ */
+
+/* $Header $ */
+
+/* Author: J.W. Stevenson */
+
+extern double	_fif();
+extern double	_fef();
+
+/*
+	exp returns the exponential function of its
+	floating-point argument.
+
+	The coefficients are #1069 from Hart and Cheney. (22.35D)
+*/
+
+#define	HUGE	1.701411733192644270e38
+
+static double p0	=  .2080384346694663001443843411e7;
+static double p1	=  .3028697169744036299076048876e5;
+static double p2	=  .6061485330061080841615584556e2;
+static double q0	=  .6002720360238832528230907598e7;
+static double q1	=  .3277251518082914423057964422e6;
+static double q2	=  .1749287689093076403844945335e4;
+static double log2e	= 1.4426950408889634073599247;
+static double sqrt2	= 1.4142135623730950488016887;
+static double maxf	= 10000.0;
+
+static double
+floor(d)
+double d;
+{
+	if (d<0) {
+		d = -d;
+		if (_fif(d, 1.0, &d) != 0)
+			d += 1;
+		d = -d;
+	} else
+		_fif(d, 1.0, &d);
+	return(d);
+}
+
+static double
+ldexp(fr,exp)
+double fr;
+int exp;
+{
+	int	neg,i;
+
+	neg = 1;
+	if (fr < 0) {
+		fr = -fr;
+		neg = -1;
+	}
+	fr = _fef(fr, &i);
+	/*
+	while (fr < 0.5) {
+		fr *= 2;
+		exp--;
+	}
+	*/
+	exp += i;
+	if (exp > 127) {
+		error(3);
+		return(neg * HUGE);
+	}
+	if (exp < -127)
+		return(0);
+	while (exp > 14) {
+		fr *= (1<<14);
+		exp -= 14;
+	}
+	while (exp < -14) {
+		fr /= (1<<14);
+		exp += 14;
+	}
+	if (exp > 0)
+		fr *= (1<<exp);
+	if (exp < 0)
+		fr /= (1<<(-exp));
+	return(neg * fr);
+}
+
+double
+_exp(arg)
+double arg;
+{
+	double fract;
+	double temp1, temp2, xsq;
+	int ent;
+
+	if(arg == 0)
+		return(1);
+	if(arg < -maxf)
+		return(0);
+	if(arg > maxf) {
+		error(3);
+		return(HUGE);
+	}
+	arg *= log2e;
+	ent = floor(arg);
+	fract = (arg-ent) - 0.5;
+	xsq = fract*fract;
+	temp1 = ((p2*xsq+p1)*xsq+p0)*fract;
+	temp2 = ((xsq+q2)*xsq+q1)*xsq + q0;
+	return(ldexp(sqrt2*(temp2+temp1)/(temp2-temp1), ent));
+}

lang/basic/lib/fef.e

@@ -0,0 +1,23 @@
+#
+ mes 2,EM_WSIZE,EM_PSIZE
+
+; $Header$
+
+#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 ?

lang/basic/lib/fif.e

@@ -0,0 +1,25 @@
+#
+ mes 2,EM_WSIZE,EM_PSIZE
+
+; $Header$
+
+#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 ?

lang/basic/lib/file.c

@@ -0,0 +1,135 @@
+#include "string.h"
+#include <stdio.h>
+#include "io.h"
+
+/* $Header $ */
+
+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;
+
+_setchannel(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);
+	}
+	_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);
+}

lang/basic/lib/hlt.c

@@ -0,0 +1,7 @@
+/* $Header $ */
+
+_hlt(nr)
+int nr;
+{
+	exit(nr);
+}

lang/basic/lib/io.c

@@ -0,0 +1,95 @@
+#include "io.h"
+#include <sgtty.h>
+
+/* $Header $ */
+
+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;
+{
+	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( (*c = fgetc(_chanrd)) != EOF && *c != '\n'){
+		if( _chann == -1) putchar(*c);
+		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(" ");
+}

lang/basic/lib/log.c

@@ -0,0 +1,75 @@
+/*
+ * (c) copyright 1983 by the Vrije Universiteit, Amsterdam, The Netherlands.
+ *
+ *          This product is part of the Amsterdam Compiler Kit.
+ *
+ * Permission to use, sell, duplicate or disclose this software must be
+ * obtained in writing. Requests for such permissions may be sent to
+ *
+ *      Dr. Andrew S. Tanenbaum
+ *      Wiskundig Seminarium
+ *      Vrije Universiteit
+ *      Postbox 7161
+ *      1007 MC Amsterdam
+ *      The Netherlands
+ *
+ */
+
+/* $Header $ */
+
+/* Author: J.W. Stevenson */
+
+extern double	_fef();
+
+/*
+	log returns the natural logarithm of its floating
+	point argument.
+
+	The coefficients are #2705 from Hart & Cheney. (19.38D)
+
+	It calls _fef.
+*/
+
+#define	HUGE	1.701411733192644270e38
+
+static double log2	= 0.693147180559945309e0;
+static double sqrto2	= 0.707106781186547524e0;
+static double p0	= -.240139179559210510e2;
+static double p1	= 0.309572928215376501e2;
+static double p2	= -.963769093368686593e1;
+static double p3	= 0.421087371217979714e0;
+static double q0	= -.120069589779605255e2;
+static double q1	= 0.194809660700889731e2;
+static double q2	= -.891110902798312337e1;
+
+double
+_log(arg)
+double arg;
+{
+	double x,z, zsq, temp;
+	int exp;
+
+	if(arg <= 0) {
+		error(3);
+		return(-HUGE);
+	}
+	x = _fef(arg,&exp);
+	/*
+	while(x < 0.5) {
+		x =* 2;
+		exp--;
+	}
+	*/
+	if(x<sqrto2) {
+		x *= 2;
+		exp--;
+	}
+
+	z = (x-1)/(x+1);
+	zsq = z*z;
+
+	temp = ((p3*zsq + p2)*zsq + p1)*zsq + p0;
+	temp = temp/(((zsq + q2)*zsq + q1)*zsq + q0);
+	temp = temp*z + exp*log2;
+	return(temp);
+}

lang/basic/lib/mki.c

@@ -0,0 +1,37 @@
+#include "string.h"
+
+/* $Header $ */
+
+String *_mki(i)
+int i;
+{
+	char *buffer ="  ";
+	String *s;
+
+	s= (String *) _newstr(buffer);
+	strncpy(s->strval,&i,2);
+	return(s);
+}
+String *_mkd(d)
+double d;
+{
+	char *buffer ="        ";
+	String *s;
+
+	s= (String *) _newstr(buffer);
+	strncpy(s->strval,&d,8);
+	return(s);
+}
+_cvi(s)
+String *s;
+{
+	int i;
+	strncpy(&i,s->strval,2);
+	return(i);
+}
+double _cvd(s)
+String *s;
+{
+	double d;
+	strncpy(&d,s->strval,8);
+}

lang/basic/lib/oct.c

@@ -0,0 +1,19 @@
+#include "string.h"
+
+/* $Header $ */
+
+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));
+}

lang/basic/lib/peek.c

@@ -0,0 +1,26 @@
+/* $Header $ */
+
+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;
+}

lang/basic/lib/power.c

@@ -0,0 +1,32 @@
+/* $Header $ */
+
+/*
+	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)));
+}

lang/basic/lib/print.c

@@ -0,0 +1,73 @@
+#include "string.h"
+#include "io.h"
+
+/* $Header $ */
+
+/* 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;
+{
+	char *c;
+	c= buffer;
+	if( f>=0){
+		if( f> 1.0e8)
+			sprintf(buffer," %e",f);
+		else sprintf(buffer," %f",f);
+		c++;
+	}else {
+		if(-f> 1.0e8)
+			sprintf(buffer,"-%e",-f);
+		else sprintf(buffer,"-%f",-f);
+	}
+	for( ; *c && *c!= ' ';c++) ;
+	c--;
+	while( c>buffer && *c== '0')
+	{
+		*c= 0;c--;
+	}
+	if( *c=='.') *c=0;
+	strcat(buffer," ");
+}
+_prfnum(f)
+double f;
+{
+	/* BASIC strings trailing zeroes */
+	char	buffer[100];
+	char	*c;
+
+	_asschn();
+	c= buffer;
+	_str(f,c);
+	_out(buffer);
+}
+_prstr(str)
+String *str;
+{
+	_asschn();
+	if( str==0)	_out("<null>");
+	else		_out(str->strval);
+}

lang/basic/lib/random.c

@@ -0,0 +1,25 @@
+/* $Header $ */
+
+_randomize()
+{
+	int i;
+	double f;
+	_setchannel(-1);
+	printf("Random number seed (-32768 to 32767) ? ");
+	_readint(&i);
+	f=i;
+	_setrandom(f);
+}
+
+_setrandom(f)
+double f;
+{
+	int i;
+	i=f;
+	srand(i);
+}
+double _rnd(d) double d;
+{
+	double f; f= (int) rand();
+	return(f/32767.0);
+}

lang/basic/lib/read.c

@@ -0,0 +1,172 @@
+#include "string.h"
+#include "io.h"
+#include <ctype.h>
+
+/* $Header $ */
+
+_readln()
+{
+	char c;
+	while( (c=fgetc(_chanrd)) != EOF && c!= '\n')
+		;
+}
+
+readskip()
+{
+	char 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];
+	char *c;
+
+#ifdef DEBUG
+	printf("read str from %d\n",_chann);
+#endif
+	_asschn();
+	c= buffer;
+	*c= fgetc(_chanrd); 
+	while(isspace(*c) && *c!= EOF) 
+		*c= fgetc(_chanrd);
+	if( *c== '"')
+	{
+		/* read quoted string */
+#ifdef DEBUG
+		printf("qouted string\n");
+#endif
+		while( (*c= fgetc(_chanrd)) != '"' && *c!= EOF ) c++;
+		ungetc(*c,_chanrd);
+		*c=0;
+	}else
+	if( isalpha(*c))
+	{
+		/* read normal string */
+		c++;
+#ifdef DEBUG
+		printf("non-qouted string\n");
+#endif
+		while( (*c= fgetc(_chanrd)) != ',' && *c!= EOF &&
+		       !isspace(*c) && *c!='\n') 
+		       c++;
+		ungetc(*c,_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 _seektable[];
+
+_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; _seektable[nr] && _seektable[nr]< line; nr+=2) 
+#ifdef DEBUG
+		printf("test %d %d\n",_seektable[nr], _seektable[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);
+}

lang/basic/lib/return.c

@@ -0,0 +1,29 @@
+/* $Header $ */
+
+#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]);
+}

lang/basic/lib/salloc.c

@@ -0,0 +1,18 @@
+/* $Header $ */
+
+char * salloc(length)
+int length;
+{
+	char *c, *s;
+	c= (char *) malloc(length);
+	if( c== (char *) -1) error(5);
+	for(s=c;s<c+length;s++) *s = 0;
+	return(c);
+}
+
+sfree(c)
+char *c;
+{
+	if( c== 0) return;
+	free(c);
+}

lang/basic/lib/setline.e

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

lang/basic/lib/sgn.c

@@ -0,0 +1,9 @@
+/* $Header $ */
+
+_sgn(v)
+double v;
+{
+	if( v>0) return(1);
+	if( v<0) return(-1);
+	return(0);
+}

lang/basic/lib/sin.c

@@ -0,0 +1,102 @@
+/*
+ * (c) copyright 1983 by the Vrije Universiteit, Amsterdam, The Netherlands.
+ *
+ *          This product is part of the Amsterdam Compiler Kit.
+ *
+ * Permission to use, sell, duplicate or disclose this software must be
+ * obtained in writing. Requests for such permissions may be sent to
+ *
+ *      Dr. Andrew S. Tanenbaum
+ *      Wiskundig Seminarium
+ *      Vrije Universiteit
+ *      Postbox 7161
+ *      1007 MC Amsterdam
+ *      The Netherlands
+ *
+ */
+
+/* $Header $ */
+
+/* Author: J.W. Stevenson */
+
+extern double	_fif();
+
+/*
+	C program for floating point sin/cos.
+	Calls _fif.
+	There are no error exits.
+	Coefficients are #3370 from Hart & Cheney (18.80D).
+*/
+
+static double twoopi	= 0.63661977236758134308;
+static double p0	=  .1357884097877375669092680e8;
+static double p1	= -.4942908100902844161158627e7;
+static double p2	=  .4401030535375266501944918e6;
+static double p3	= -.1384727249982452873054457e5;
+static double p4	=  .1459688406665768722226959e3;
+static double q0	=  .8644558652922534429915149e7;
+static double q1	=  .4081792252343299749395779e6;
+static double q2	=  .9463096101538208180571257e4;
+static double q3	=  .1326534908786136358911494e3;
+
+static double
+sinus(arg, quad)
+double arg;
+int quad;
+{
+	double e, f;
+	double ysq;
+	double x,y;
+	int k;
+	double temp1, temp2;
+
+	x = arg;
+	if(x<0) {
+		x = -x;
+		quad = quad + 2;
+	}
+	x = x*twoopi;	/*underflow?*/
+	if(x>32764){
+		y = _fif(x, 10.0, &e);
+		e = e + quad;
+		_fif(0.25, e, &f);
+		quad = e - 4*f;
+	}else{
+		k = x;
+		y = x - k;
+		quad = (quad + k) & 03;
+	}
+	if (quad & 01)
+		y = 1-y;
+	if(quad > 1)
+		y = -y;
+
+	ysq = y*y;
+	temp1 = ((((p4*ysq+p3)*ysq+p2)*ysq+p1)*ysq+p0)*y;
+	temp2 = ((((ysq+q3)*ysq+q2)*ysq+q1)*ysq+q0);
+	return(temp1/temp2);
+}
+
+double
+_cos(arg)
+double arg;
+{
+	if(arg<0)
+		arg = -arg;
+	return(sinus(arg, 1));
+}
+
+double
+_sin(arg)
+double arg;
+{
+	return(sinus(arg, 0));
+}
+
+/* EXTENSION */
+double
+_tan(arg)
+double arg;
+{
+	return( _sin(arg)/_cos(arg));
+}

lang/basic/lib/sqt.c

@@ -0,0 +1,76 @@
+/*
+ * (c) copyright 1983 by the Vrije Universiteit, Amsterdam, The Netherlands.
+ *
+ *          This product is part of the Amsterdam Compiler Kit.
+ *
+ * Permission to use, sell, duplicate or disclose this software must be
+ * obtained in writing. Requests for such permissions may be sent to
+ *
+ *      Dr. Andrew S. Tanenbaum
+ *      Wiskundig Seminarium
+ *      Vrije Universiteit
+ *      Postbox 7161
+ *      1007 MC Amsterdam
+ *      The Netherlands
+ *
+ */
+
+/* $Header $ */
+
+/* Author: J.W. Stevenson */
+
+extern	double	_fef();
+
+/*
+	sqrt returns the square root of its floating
+	point argument. Newton's method.
+
+	calls _fef
+*/
+
+double
+_sqt(arg)
+double arg;
+{
+	double x, temp;
+	int exp;
+	int i;
+
+	if(arg <= 0) {
+		if(arg < 0)
+			error(3);
+		return(0);
+	}
+	x = _fef(arg,&exp);
+	/*
+	while(x < 0.5) {
+		x =* 2;
+		exp--;
+	}
+	*/
+	/*
+	 * NOTE
+	 * this wont work on 1's comp
+	 */
+	if(exp & 1) {
+		x *= 2;
+		exp--;
+	}
+	temp = 0.5*(1 + x);
+
+	while(exp > 28) {
+		temp *= (1<<14);
+		exp -= 28;
+	}
+	while(exp < -28) {
+		temp /= (1<<14);
+		exp += 28;
+	}
+	if(exp >= 0)
+		temp *= 1 << (exp/2);
+	else
+		temp /= 1 << (-exp/2);
+	for(i=0; i<=4; i++)
+		temp = 0.5*(temp + arg/temp);
+	return(temp);
+}

lang/basic/lib/stop.c

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

lang/basic/lib/string.c

@@ -0,0 +1,175 @@
+#include "string.h"
+
+/* $Header $ */
+
+#define ok(X)	if( X ==0) return;
+#define okr(X)	if( X ==0) return(0);
+
+_len(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= (char *) 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);
+	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(src);
+}
+String *_concat(s1,s2)
+String *s1,*s2;
+{
+	String *s;
+	int length;
+	okr(s1); okr(s2);
+	s= (String *) salloc(sizeof(String));
+	length= _len(s1)+_len(s2)+1;
+	s->strval= (char *) salloc(length);
+	strcpy(s->strval,s2->strval);
+	strcat(s->strval,s1->strval);
+	return(s);
+}
+_strcompare(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= (char *) 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= (char *) salloc(len+1);
+	for(i=0;i<len;i++)
+		s->strval[i]= ' ';
+	s->strval[i]=0;
+	return(s);
+}
+
+String *_strascii()
+{
+}
+String *_string(d,f)
+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= (char *) 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( i1== -1) i1= s2->strlength;
+	if( s->strlength<i2) error(3);	/* source string too short */
+	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( 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= _len(str)-length;
+	if(i<0) i=0;
+	s= _newstr(str->strval+i);
+	return(s);
+}

lang/basic/lib/swap.c

@@ -0,0 +1,30 @@
+#include "string.h"
+
+/* $Header $ */
+
+_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;
+}

lang/basic/lib/trace.c

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

lang/basic/lib/trap.c

@@ -0,0 +1,55 @@
+#include <signal.h>
+#include <setjmp.h>
+
+/* $Header $ */
+
+/* Trap handling */
+int	_trpline;	/* BASIC return label */
+jmp_buf	trpbuf;
+
+_trpset(nr)
+int nr;
+{
+	/*debug  printf("trap set to %d\n",nr);*/
+	_trpline=nr;
+}
+_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, _trpfatal();
+
+	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);
+}

lang/basic/lib/write.c

@@ -0,0 +1,32 @@
+#include "string.h"
+#include "io.h"
+
+/* $Header $ */
+
+/* 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);
+}
+_wrflt(f)
+double f;
+{
+	if( fprintf(_chanwr,"%f",f)== EOF) error(29);
+}
+_wrstr(s)
+String *s;
+{
+	 if( fprintf(_chanwr,"\"%s\"",s->strval)== EOF) error(29);
+}