*** empty log message ***
This commit is contained in:
parent
0c0c3b7892
commit
ae1e81adb1
29
h/bc_io.h
Normal file
29
h/bc_io.h
Normal file
|
@ -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];
|
15
h/bc_string.h
Normal file
15
h/bc_string.h
Normal file
|
@ -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
|
33
lang/basic/lib/LIST
Normal file
33
lang/basic/lib/LIST
Normal file
|
@ -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
|
10
lang/basic/lib/abs.c
Normal file
10
lang/basic/lib/abs.c
Normal file
|
@ -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);
|
||||||
|
}
|
11
lang/basic/lib/asc.c
Normal file
11
lang/basic/lib/asc.c
Normal file
|
@ -0,0 +1,11 @@
|
||||||
|
#include "string.h"
|
||||||
|
|
||||||
|
/* $Header $ */
|
||||||
|
|
||||||
|
int _asc(str)
|
||||||
|
String *str;
|
||||||
|
{
|
||||||
|
if(str==0 || str->strval==0)
|
||||||
|
error(3);
|
||||||
|
return( *str->strval);
|
||||||
|
}
|
9
lang/basic/lib/asrt.c
Normal file
9
lang/basic/lib/asrt.c
Normal file
|
@ -0,0 +1,9 @@
|
||||||
|
/* $Header $ */
|
||||||
|
|
||||||
|
asrt(b)
|
||||||
|
{
|
||||||
|
if(!b){
|
||||||
|
printf("ASSERTION ERROR\n");
|
||||||
|
abort();
|
||||||
|
}
|
||||||
|
}
|
93
lang/basic/lib/atn.c
Normal file
93
lang/basic/lib/atn.c
Normal file
|
@ -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));
|
||||||
|
}
|
17
lang/basic/lib/chr.c
Normal file
17
lang/basic/lib/chr.c
Normal file
|
@ -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);
|
||||||
|
}
|
40
lang/basic/lib/conversion.c
Normal file
40
lang/basic/lib/conversion.c
Normal file
|
@ -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);
|
||||||
|
}
|
63
lang/basic/lib/error.c
Normal file
63
lang/basic/lib/error.c
Normal file
|
@ -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();
|
||||||
|
}
|
122
lang/basic/lib/exp.c
Normal file
122
lang/basic/lib/exp.c
Normal file
|
@ -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));
|
||||||
|
}
|
23
lang/basic/lib/fef.e
Normal file
23
lang/basic/lib/fef.e
Normal file
|
@ -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 ?
|
25
lang/basic/lib/fif.e
Normal file
25
lang/basic/lib/fif.e
Normal file
|
@ -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 ?
|
135
lang/basic/lib/file.c
Normal file
135
lang/basic/lib/file.c
Normal file
|
@ -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);
|
||||||
|
}
|
7
lang/basic/lib/hlt.c
Normal file
7
lang/basic/lib/hlt.c
Normal file
|
@ -0,0 +1,7 @@
|
||||||
|
/* $Header $ */
|
||||||
|
|
||||||
|
_hlt(nr)
|
||||||
|
int nr;
|
||||||
|
{
|
||||||
|
exit(nr);
|
||||||
|
}
|
95
lang/basic/lib/io.c
Normal file
95
lang/basic/lib/io.c
Normal file
|
@ -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(" ");
|
||||||
|
}
|
75
lang/basic/lib/log.c
Normal file
75
lang/basic/lib/log.c
Normal file
|
@ -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);
|
||||||
|
}
|
37
lang/basic/lib/mki.c
Normal file
37
lang/basic/lib/mki.c
Normal file
|
@ -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);
|
||||||
|
}
|
19
lang/basic/lib/oct.c
Normal file
19
lang/basic/lib/oct.c
Normal file
|
@ -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));
|
||||||
|
}
|
26
lang/basic/lib/peek.c
Normal file
26
lang/basic/lib/peek.c
Normal file
|
@ -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;
|
||||||
|
}
|
32
lang/basic/lib/power.c
Normal file
32
lang/basic/lib/power.c
Normal file
|
@ -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)));
|
||||||
|
}
|
73
lang/basic/lib/print.c
Normal file
73
lang/basic/lib/print.c
Normal file
|
@ -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);
|
||||||
|
}
|
25
lang/basic/lib/random.c
Normal file
25
lang/basic/lib/random.c
Normal file
|
@ -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);
|
||||||
|
}
|
172
lang/basic/lib/read.c
Normal file
172
lang/basic/lib/read.c
Normal file
|
@ -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);
|
||||||
|
}
|
29
lang/basic/lib/return.c
Normal file
29
lang/basic/lib/return.c
Normal file
|
@ -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]);
|
||||||
|
}
|
18
lang/basic/lib/salloc.c
Normal file
18
lang/basic/lib/salloc.c
Normal file
|
@ -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);
|
||||||
|
}
|
11
lang/basic/lib/setline.e
Normal file
11
lang/basic/lib/setline.e
Normal file
|
@ -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
|
9
lang/basic/lib/sgn.c
Normal file
9
lang/basic/lib/sgn.c
Normal file
|
@ -0,0 +1,9 @@
|
||||||
|
/* $Header $ */
|
||||||
|
|
||||||
|
_sgn(v)
|
||||||
|
double v;
|
||||||
|
{
|
||||||
|
if( v>0) return(1);
|
||||||
|
if( v<0) return(-1);
|
||||||
|
return(0);
|
||||||
|
}
|
102
lang/basic/lib/sin.c
Normal file
102
lang/basic/lib/sin.c
Normal file
|
@ -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));
|
||||||
|
}
|
76
lang/basic/lib/sqt.c
Normal file
76
lang/basic/lib/sqt.c
Normal file
|
@ -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);
|
||||||
|
}
|
10
lang/basic/lib/stop.c
Normal file
10
lang/basic/lib/stop.c
Normal file
|
@ -0,0 +1,10 @@
|
||||||
|
/* $Header $ */
|
||||||
|
|
||||||
|
_stop()
|
||||||
|
{
|
||||||
|
extern int _erlsym;
|
||||||
|
|
||||||
|
_setline();
|
||||||
|
printf("Break in %d\n", _erlsym);
|
||||||
|
exit(0);
|
||||||
|
}
|
175
lang/basic/lib/string.c
Normal file
175
lang/basic/lib/string.c
Normal file
|
@ -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);
|
||||||
|
}
|
30
lang/basic/lib/swap.c
Normal file
30
lang/basic/lib/swap.c
Normal file
|
@ -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;
|
||||||
|
}
|
7
lang/basic/lib/trace.c
Normal file
7
lang/basic/lib/trace.c
Normal file
|
@ -0,0 +1,7 @@
|
||||||
|
/* $Header $ */
|
||||||
|
|
||||||
|
_trace()
|
||||||
|
{
|
||||||
|
int i;
|
||||||
|
printf("[%d]",i);
|
||||||
|
}
|
55
lang/basic/lib/trap.c
Normal file
55
lang/basic/lib/trap.c
Normal file
|
@ -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);
|
||||||
|
}
|
32
lang/basic/lib/write.c
Normal file
32
lang/basic/lib/write.c
Normal file
|
@ -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);
|
||||||
|
}
|
Loading…
Reference in a new issue