diff --git a/h/bc_io.h b/h/bc_io.h new file mode 100644 index 000000000..fe0df8827 --- /dev/null +++ b/h/bc_io.h @@ -0,0 +1,29 @@ +#include + +/* $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]; diff --git a/h/bc_string.h b/h/bc_string.h new file mode 100644 index 000000000..1e35bbf97 --- /dev/null +++ b/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 diff --git a/lang/basic/lib/LIST b/lang/basic/lib/LIST new file mode 100644 index 000000000..a9b6af0a7 --- /dev/null +++ b/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 diff --git a/lang/basic/lib/abs.c b/lang/basic/lib/abs.c new file mode 100644 index 000000000..45071d4cc --- /dev/null +++ b/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); +} diff --git a/lang/basic/lib/asc.c b/lang/basic/lib/asc.c new file mode 100644 index 000000000..aa3f3ff74 --- /dev/null +++ b/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); +} diff --git a/lang/basic/lib/asrt.c b/lang/basic/lib/asrt.c new file mode 100644 index 000000000..8175437a2 --- /dev/null +++ b/lang/basic/lib/asrt.c @@ -0,0 +1,9 @@ +/* $Header $ */ + +asrt(b) +{ + if(!b){ + printf("ASSERTION ERROR\n"); + abort(); + } +} diff --git a/lang/basic/lib/atn.c b/lang/basic/lib/atn.c new file mode 100644 index 000000000..0fd3043f4 --- /dev/null +++ b/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)); +} diff --git a/lang/basic/lib/chr.c b/lang/basic/lib/chr.c new file mode 100644 index 000000000..decc2be04 --- /dev/null +++ b/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); +} diff --git a/lang/basic/lib/conversion.c b/lang/basic/lib/conversion.c new file mode 100644 index 000000000..1411e3a2d --- /dev/null +++ b/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); +} diff --git a/lang/basic/lib/error.c b/lang/basic/lib/error.c new file mode 100644 index 000000000..ea68f24ce --- /dev/null +++ b/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(); +} diff --git a/lang/basic/lib/exp.c b/lang/basic/lib/exp.c new file mode 100644 index 000000000..469df9eea --- /dev/null +++ b/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< 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)); +} diff --git a/lang/basic/lib/fef.e b/lang/basic/lib/fef.e new file mode 100644 index 000000000..5a296c249 --- /dev/null +++ b/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 ? diff --git a/lang/basic/lib/fif.e b/lang/basic/lib/fif.e new file mode 100644 index 000000000..fb96dee41 --- /dev/null +++ b/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 ? diff --git a/lang/basic/lib/file.c b/lang/basic/lib/file.c new file mode 100644 index 000000000..cd85c93b6 --- /dev/null +++ b/lang/basic/lib/file.c @@ -0,0 +1,135 @@ +#include "string.h" +#include +#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); +} diff --git a/lang/basic/lib/hlt.c b/lang/basic/lib/hlt.c new file mode 100644 index 000000000..f3dee6de7 --- /dev/null +++ b/lang/basic/lib/hlt.c @@ -0,0 +1,7 @@ +/* $Header $ */ + +_hlt(nr) +int nr; +{ + exit(nr); +} diff --git a/lang/basic/lib/io.c b/lang/basic/lib/io.c new file mode 100644 index 000000000..150e5bc4a --- /dev/null +++ b/lang/basic/lib/io.c @@ -0,0 +1,95 @@ +#include "io.h" +#include + +/* $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(" "); +} diff --git a/lang/basic/lib/log.c b/lang/basic/lib/log.c new file mode 100644 index 000000000..bca606342 --- /dev/null +++ b/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(xstrval,&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); +} diff --git a/lang/basic/lib/oct.c b/lang/basic/lib/oct.c new file mode 100644 index 000000000..d63586e7a --- /dev/null +++ b/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)); +} diff --git a/lang/basic/lib/peek.c b/lang/basic/lib/peek.c new file mode 100644 index 000000000..348dcfcb8 --- /dev/null +++ b/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; +} diff --git a/lang/basic/lib/power.c b/lang/basic/lib/power.c new file mode 100644 index 000000000..40e52a853 --- /dev/null +++ b/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))); +} diff --git a/lang/basic/lib/print.c b/lang/basic/lib/print.c new file mode 100644 index 000000000..5f8d647aa --- /dev/null +++ b/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(""); + else _out(str->strval); +} diff --git a/lang/basic/lib/random.c b/lang/basic/lib/random.c new file mode 100644 index 000000000..07aeae1cf --- /dev/null +++ b/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); +} diff --git a/lang/basic/lib/read.c b/lang/basic/lib/read.c new file mode 100644 index 000000000..26e7d24a7 --- /dev/null +++ b/lang/basic/lib/read.c @@ -0,0 +1,172 @@ +#include "string.h" +#include "io.h" +#include + +/* $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); +} diff --git a/lang/basic/lib/return.c b/lang/basic/lib/return.c new file mode 100644 index 000000000..1a3e93e2e --- /dev/null +++ b/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]); +} diff --git a/lang/basic/lib/salloc.c b/lang/basic/lib/salloc.c new file mode 100644 index 000000000..4b00b2a38 --- /dev/null +++ b/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;s0) return(1); + if( v<0) return(-1); + return(0); +} diff --git a/lang/basic/lib/sin.c b/lang/basic/lib/sin.c new file mode 100644 index 000000000..0473bcf37 --- /dev/null +++ b/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)); +} diff --git a/lang/basic/lib/sqt.c b/lang/basic/lib/sqt.c new file mode 100644 index 000000000..aaa161fa8 --- /dev/null +++ b/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); +} diff --git a/lang/basic/lib/stop.c b/lang/basic/lib/stop.c new file mode 100644 index 000000000..ec8d5561c --- /dev/null +++ b/lang/basic/lib/stop.c @@ -0,0 +1,10 @@ +/* $Header $ */ + +_stop() +{ + extern int _erlsym; + + _setline(); + printf("Break in %d\n", _erlsym); + exit(0); +} diff --git a/lang/basic/lib/string.c b/lang/basic/lib/string.c new file mode 100644 index 000000000..8808b93eb --- /dev/null +++ b/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; istrval[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;istrval[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->strlengthstrlength - 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->strlengthstrlength - 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); +} diff --git a/lang/basic/lib/swap.c b/lang/basic/lib/swap.c new file mode 100644 index 000000000..9d944e5d2 --- /dev/null +++ b/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; +} diff --git a/lang/basic/lib/trace.c b/lang/basic/lib/trace.c new file mode 100644 index 000000000..a1c54864e --- /dev/null +++ b/lang/basic/lib/trace.c @@ -0,0 +1,7 @@ +/* $Header $ */ + +_trace() +{ +int i; +printf("[%d]",i); +} diff --git a/lang/basic/lib/trap.c b/lang/basic/lib/trap.c new file mode 100644 index 000000000..23491c401 --- /dev/null +++ b/lang/basic/lib/trap.c @@ -0,0 +1,55 @@ +#include +#include + +/* $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;i0) + 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); +}