lang/basic/lib/tail_bc.a

   1 e�abs.c\0\0\0\0\0\0\0\0\0\0\0\0\0\ 2\ 2�\ 1\0\0B\ 1/* $Id: abs.c,v 2.4 1994/06/24 11:27:24 ceriel Exp $ */
   2
   3 /*
   4  * (c) copyright 1987 by the Vrije Universiteit, Amsterdam, The Netherlands.
   5  * See the copyright notice in the ACK home directory, in the file "Copyright".
   6  */
   7
   8 long _abl(i) long i;
   9 {
  10         return( i>=0?i:-i);
  11 }
  12 double _abr(f) double f;
  13 {
  14         return( f>=0.0?f: -f);
  15 }
  16 asc.c\0\0\0\0\0\0\0\0\0\0\0\0\0\ 2\ 2�\ 1\0\0�\0#include "bc_string.h"
  17
  18 /* $Id: asc.c,v 2.4 1994/06/24 11:27:29 ceriel Exp $ */
  19
  20 int _asc(str)
  21 String *str;
  22 {
  23         if(str==0 || str->strval==0)
  24                 error(3);
  25         return( *str->strval);
  26 }
  27 asrt.c\0\0\0\0\0\0\0\0\0\0\0\0\ 2\ 2�\ 1\0\0|\0/* $Id: asrt.c,v 2.3 1994/06/24 11:27:33 ceriel Exp $ */
  28
  29 asrt(b)
  30 {
  31         if(!b){
  32                 printf("ASSERTION ERROR\n");
  33                 abort();
  34         }
  35 }
  36 atn.c\0\0\0\0\0\0\0\0\0\0\0\0\0\ 2\ 2�\ 1\0\0*\ 5/*
  37  * (c) copyright 1988 by the Vrije Universiteit, Amsterdam, The Netherlands.
  38  * See the copyright notice in the ACK home directory, in the file "Copyright".
  39  *
  40  * Author: Ceriel J.H. Jacobs
  41  */
  42
  43 /* $Id: atn.c,v 2.7 1994/06/24 11:27:37 ceriel Exp $ */
  44
  45 #define __NO_DEFS
  46 #include <math.h>
  47
  48 double
  49 _atn(x)
  50         double x;
  51 {
  52         /*      Algorithm and coefficients from:
  53                         "Software manual for the elementary functions"
  54                         by W.J. Cody and W. Waite, Prentice-Hall, 1980
  55         */
  56
  57         static double p[] = {
  58                 -0.13688768894191926929e+2,
  59                 -0.20505855195861651981e+2,
  60                 -0.84946240351320683534e+1,
  61                 -0.83758299368150059274e+0
  62         };
  63         static double q[] = {
  64                  0.41066306682575781263e+2,
  65                  0.86157349597130242515e+2,
  66                  0.59578436142597344465e+2,
  67                  0.15024001160028576121e+2,
  68                  1.0
  69         };
  70         static double a[] = {
  71                 0.0,
  72                 0.52359877559829887307710723554658381,  /* pi/6 */
  73                 M_PI_2,
  74                 1.04719755119659774615421446109316763   /* pi/3 */
  75         };
  76
  77         int     neg = x < 0;
  78         int     n;
  79         double  g;
  80
  81         if (neg) {
  82                 x = -x;
  83         }
  84         if (x > 1.0) {
  85                 x = 1.0/x;
  86                 n = 2;
  87         }
  88         else    n = 0;
  89
  90         if (x > 0.26794919243112270647) {       /* 2-sqtr(3) */
  91                 n = n + 1;
  92                 x = (((0.73205080756887729353*x-0.5)-0.5)+x)/
  93                         (1.73205080756887729353+x);
  94         }
  95
  96         /* ??? avoid underflow ??? */
  97
  98         g = x * x;
  99         x += x * g * POLYNOM3(g, p) / POLYNOM4(g, q);
 100         if (n > 1) x = -x;
 101         x += a[n];
 102         return neg ? -x : x;
 103 }
 104 chr.c\0\0\0\0\0\0\0\0\0\0\0\0\0\ 2\ 2�\ 1\0\0�\0#include "bc_string.h"
 105
 106 /* $Id: chr.c,v 2.5 1994/06/24 11:27:42 ceriel Exp $ */
 107
 108 String *_chr(i)
 109 int i;
 110 {
 111         String  *s;
 112         char    buf[2];
 113
 114         if( i<0 || i>127)
 115                 error(3);
 116         buf[0]=i;
 117         buf[1]=0;
 118         s= _newstr(buf);
 119         return(s);
 120 }
 121 conversion.c\0\0\0\0\0\0\ 2\ 2�\ 1\0\0�\ 1/* $Id: conversion.c,v 2.3 1994/06/24 11:27:47 ceriel Exp $ */
 122
 123 int _cint(f) double f;
 124 {
 125         int r;
 126         if( f<-32768 || f>32767) error(4);
 127         if(f<0)
 128                 r= f-0.5;
 129         else    r= f+0.5;
 130         return(r);
 131 }
 132
 133 double _trunc(f)
 134 double f;
 135 {
 136         long d;
 137         d=f;
 138         f=d;
 139         return( f );
 140 }
 141
 142 double _fcint(f) double f;
 143 {
 144         long r;
 145         if(f<0){
 146                 r= -f;
 147                 r= -r -1;
 148         }else   r= f;
 149         f=r;
 150         return(f);
 151 }
 152 int _fix(f)
 153 double f;
 154 {
 155         int r;
 156
 157         if( f<-32768.0 || f>32767.0) error(4);
 158         r= _sgn(f) * _fcint((f>0.0? f : -f));
 159         return(r);
 160 }
 161 hlt.c\0sion.c\0\0\0\0\0\0\ 2\ 2�\ 1\0\0u\0/* $Id: hlt.c,v 2.4 1994/06/24 11:28:11 ceriel Exp $ */
 162
 163 _hlt(nr)
 164 int nr;
 165 {
 166         exit(nr);
 167 }
 168
 169 _goto_err()
 170 {
 171         error(3);
 172 }
 173 2mki.c\0sion.c\0\0\0\0\0\0\ 2\ 2�\ 1\0\0�\ 1#include "bc_string.h"
 174
 175 /* $Id: mki.c,v 2.7 1994/06/24 11:28:26 ceriel Exp $ */
 176
 177 String *_mki(i)
 178 long i;
 179 {
 180         char *buffer ="    ";
 181         String *s;
 182
 183         s= _newstr(buffer);
 184         * ( (long *)s->strval ) = i ;
 185         return(s);
 186 }
 187 String *_mkd(d)
 188 double d;
 189 {
 190         char *buffer ="        ";
 191         String *s;
 192
 193         s= _newstr(buffer);
 194         * ( (double *)s->strval ) = d ;
 195         return(s);
 196 }
 197 long _cvi(s)
 198 String *s;
 199 {
 200         return *( (long *) s->strval) ;
 201 }
 202 double _cvd(s)
 203 String *s;
 204 {
 205         return *( (double *) s->strval) ;
 206 }
 207 roct.c\0sion.c\0\0\0\0\0\0\ 2\ 2�\ 1\0\0\93\ 1#include "bc_string.h"
 208
 209 /* $Id: oct.c,v 2.6 1994/06/24 11:28:30 ceriel Exp $ */
 210
 211 String *_oct(i)
 212 int i;
 213 {
 214         char buffer[30];
 215         sprintf(buffer,"%o",i);
 216         return( (String *)_newstr(buffer));
 217 }
 218
 219 String *_hex(i)
 220 int i;
 221 {
 222         char buffer[30];
 223
 224         sprintf(buffer,"%x",i);
 225         return( (String *)_newstr(buffer));
 226 }
 227
 228 String *_nstr(f)
 229         double f;
 230 {
 231         char buffer[80];
 232
 233         _str(f, buffer);
 234         return (String *) _newstr(buffer);
 235 }
 236
 237 peek.c\0ion.c\0\0\0\0\0\0\ 2\ 2�\ 1\0\0l\ 1/* $Id: peek.c,v 2.3 1994/06/24 11:28:34 ceriel Exp $ */
 238
 239 int peek(addr)
 240 int addr;
 241 {
 242         /* this can not work properly for machines in which the
 243            POINTERSIZE differs from the integer size
 244         */
 245         char    *p;
 246         int i;
 247
 248         p= (char *)addr;
 249         i= *p;
 250 #ifdef DEBUG
 251         printf("peek %d = %d\n",addr,i);
 252 #endif
 253         return(i);
 254 }
 255
 256 _poke(i,j)
 257 int i,j;
 258 {
 259         char *p;
 260         p= (char *) i;
 261         *p=j;
 262 }
 263 power.c\0on.c\0\0\0\0\0\0\ 2\ 2�\ 1\0\0�\ 1/* $Id: power.c,v 2.3 1994/06/24 11:28:38 ceriel Exp $ */
 264
 265 /*
 266         computes a^b.
 267         uses log and exp
 268 */
 269
 270 double _log(), _exp();
 271
 272 double
 273 _power(base,pownr)
 274 double pownr, base;
 275 {
 276         double temp;
 277         long l;
 278
 279         if(pownr <= 0.0) {
 280                 if(pownr == 0.0) {
 281                         if(base <= 0.0)
 282                                 error(3);
 283                         return(0.0);
 284                 }
 285                 l = base;
 286                 if(l != base)
 287                         error(3);
 288                 temp = _exp(base * _log(-pownr));
 289                 if(l & 1)
 290                         temp = -temp;
 291                 return(temp);
 292         }
 293         return(_exp(base * _log(pownr)));
 294 }
 295 eexp.c\0c\0on.c\0\0\0\0\0\0\ 2\ 2�\ 1\0\0�\ 6/*
 296  * (c) copyright 1988 by the Vrije Universiteit, Amsterdam, The Netherlands.
 297  * See the copyright notice in the ACK home directory, in the file "Copyright".
 298  *
 299  * Author: Ceriel J.H. Jacobs
 300  */
 301
 302 /* $Id: exp.c,v 2.7 1994/06/24 11:27:56 ceriel Exp $ */
 303
 304 #define __NO_DEFS
 305 #include <math.h>
 306
 307 static double
 308 ldexp(fl,exp)
 309         double fl;
 310         int exp;
 311 {
 312         extern double _fef();
 313         int sign = 1;
 314         int currexp;
 315
 316         if (fl<0) {
 317                 fl = -fl;
 318                 sign = -1;
 319         }
 320         fl = _fef(fl,&currexp);
 321         exp += currexp;
 322         if (exp > 0) {
 323                 while (exp>30) {
 324                         fl *= (double) (1L << 30);
 325                         exp -= 30;
 326                 }
 327                 fl *= (double) (1L << exp);
 328         }
 329         else    {
 330                 while (exp<-30) {
 331                         fl /= (double) (1L << 30);
 332                         exp += 30;
 333                 }
 334                 fl /= (double) (1L << -exp);
 335         }
 336         return sign * fl;
 337 }
 338
 339 double
 340 _exp(x)
 341         double  x;
 342 {
 343         /*      Algorithm and coefficients from:
 344                         "Software manual for the elementary functions"
 345                         by W.J. Cody and W. Waite, Prentice-Hall, 1980
 346         */
 347
 348         static double p[] = {
 349                 0.25000000000000000000e+0,
 350                 0.75753180159422776666e-2,
 351                 0.31555192765684646356e-4
 352         };
 353
 354         static double q[] = {
 355                 0.50000000000000000000e+0,
 356                 0.56817302698551221787e-1,
 357                 0.63121894374398503557e-3,
 358                 0.75104028399870046114e-6
 359         };
 360         double  xn, g;
 361         int     n;
 362         int     negative = x < 0;
 363
 364         if (x <= M_LN_MIN_D) {
 365                 return M_MIN_D;
 366         }
 367         if (x >= M_LN_MAX_D) {
 368                 if (x > M_LN_MAX_D) error(3);
 369                 return M_MAX_D;
 370         }
 371         if (negative) x = -x;
 372
 373         /* ??? avoid underflow ??? */
 374
 375         n = x * M_LOG2E + 0.5;  /* 1/ln(2) = log2(e), 0.5 added for rounding */
 376         xn = n;
 377         {
 378                 double  x1 = (long) x;
 379                 double  x2 = x - x1;
 380
 381                 g = ((x1-xn*0.693359375)+x2) - xn*(-2.1219444005469058277e-4);
 382         }
 383         if (negative) {
 384                 g = -g;
 385                 n = -n;
 386         }
 387         xn = g * g;
 388         x = g * POLYNOM2(xn, p);
 389         n += 1;
 390         return (ldexp(0.5 + x/(POLYNOM3(xn, q) - x), n));
 391 }
 392 log.c\0c\0on.c\0\0\0\0\0\0\ 2\ 2�\ 1\0\0t\ 4/*
 393  * (c) copyright 1988 by the Vrije Universiteit, Amsterdam, The Netherlands.
 394  * See the copyright notice in the ACK home directory, in the file "Copyright".
 395  *
 396  * Author: Ceriel J.H. Jacobs
 397  */
 398
 399 /* $Id: log.c,v 2.6 1994/06/24 11:28:20 ceriel Exp $ */
 400
 401 #define __NO_DEFS
 402 #include <math.h>
 403
 404 double
 405 _log(x)
 406         double x;
 407 {
 408         /*      Algorithm and coefficients from:
 409                         "Software manual for the elementary functions"
 410                         by W.J. Cody and W. Waite, Prentice-Hall, 1980
 411         */
 412         static double a[] = {
 413                 -0.64124943423745581147e2,
 414                  0.16383943563021534222e2,
 415                 -0.78956112887491257267e0
 416         };
 417         static double b[] = {
 418                 -0.76949932108494879777e3,
 419                  0.31203222091924532844e3,
 420                 -0.35667977739034646171e2,
 421                  1.0
 422         };
 423
 424         extern double _fef();
 425         double  znum, zden, z, w;
 426         int     exponent;
 427
 428         if (x <= 0) {
 429                 error(3);
 430                 return -HUGE;
 431         }
 432
 433         x = _fef(x, &exponent);
 434         if (x > M_1_SQRT2) {
 435                 znum = (x - 0.5) - 0.5;
 436                 zden = x * 0.5 + 0.5;
 437         }
 438         else {
 439                 znum = x - 0.5;
 440                 zden = znum * 0.5 + 0.5;
 441                 exponent--;
 442         }
 443         z = znum/zden; w = z * z;
 444         x = z + z * w * (POLYNOM2(w,a)/POLYNOM3(w,b));
 445         z = exponent;
 446         x += z * (-2.121944400546905827679e-4);
 447         return x + z * 0.693359375;
 448 }
 449 print.c\0on.c\0\0\0\0\0\0\ 2\ 2�\ 1\0\0b\ 4#include "bc_string.h"
 450 #include "bc_io.h"
 451
 452 /* $Id: print.c,v 2.6 1994/06/24 11:28:42 ceriel Exp $ */
 453
 454 /* Here all routine to generate terminal oriented output is located */
 455
 456 _qstmark()
 457 {
 458         /* prompt for terminal input */
 459         putchar('?');
 460 }
 461
 462 _nl()
 463 {
 464         _asschn();
 465         _outnl();
 466 }
 467 _prinum(i)
 468 int i;
 469 {
 470         char    buffer[40];
 471
 472         _asschn();
 473         if(i>=0)
 474                 sprintf(buffer," %d ",i);
 475         else    sprintf(buffer,"-%d ",-i);
 476         _out(buffer);
 477 }
 478 _str(f,buffer)
 479 double f;
 480 char *buffer;
 481 {
 482         register char *c = buffer;
 483         int eformat = 0;
 484         if( f>=0){
 485                 if( f> 1.0e8) {
 486                         eformat = 1;
 487                         sprintf(buffer," %e",f);
 488                 }
 489                 else sprintf(buffer," %f",f);
 490                 c++;
 491         }else {
 492                 if(-f> 1.0e8) {
 493                         eformat = 1;
 494                         sprintf(buffer,"-%e",-f);
 495                 }
 496                 else sprintf(buffer,"-%f",-f);
 497         }
 498         if (! eformat) {
 499                 for( ; *c && *c!= ' ';c++) ;
 500                 c--;
 501                 while( c>buffer && *c== '0')
 502                 {
 503                         *c= 0;c--;
 504                 }
 505                 if( *c=='.') *c=0;
 506         }
 507 }
 508 _prfnum(f)
 509 double f;
 510 {
 511         /* BASIC strings trailing zeroes */
 512         char    buffer[100];
 513         char    *c;
 514
 515         _asschn();
 516         c= buffer;
 517         _str(f,c);
 518         strcat(buffer," ");
 519         _out(buffer);
 520 }
 521 _prstr(str)
 522 String *str;
 523 {
 524         _asschn();
 525         if( str==0)     _out("<null>");
 526         else            _out(str->strval);
 527 }
 528 io.c\0.c\0on.c\0\0\0\0\0\0\ 2\ 2�\ 1\0\0�\ 5#include "bc_io.h"
 529 #include <sgtty.h>
 530
 531 /* $Id: io.c,v 2.5 1994/06/24 11:28:16 ceriel Exp $ */
 532
 533 struct sgttyb _ttydef;
 534
 535 /* BASIC has some nasty io characteristics */
 536
 537 #define MAXWIDTH 255
 538
 539 int     _width = 75, _pos=0, _zonewidth=15;
 540
 541 _out(str)
 542 char *str;
 543 {
 544         int pos;
 545
 546         if( _chann== -1) pos= _pos;
 547         else pos= _fdtable[_chann].pos;
 548         while( *str)
 549         {
 550                 if( pos>= _width){ _outnl(); pos=0;}
 551                 fputc(*str++, _chanwr);
 552                 pos++;
 553         }
 554         if( _chann== -1) _pos=pos;
 555         else _fdtable[_chann].pos= pos;
 556 }
 557
 558 _outnl()
 559 {
 560         fputc('\n',_chanwr);
 561         if( _chann == -1)
 562                 _pos=0;
 563         else
 564                 _fdtable[_chann].pos=0;
 565 }
 566 _zone()
 567 {
 568         /* go to next zone */
 569         int pos;
 570         if( _chann == -1)
 571                 pos= _pos;
 572         else pos= _fdtable[_chann].pos;
 573         do{
 574                 fputc(' ',_chanwr);
 575                 pos++;
 576                 if( pos==_width)
 577                 {
 578                         _outnl();
 579                         pos=0;
 580                         break;
 581                 }
 582         } while( pos % _zonewidth != 0);
 583         if( _chann== -1) _pos=pos;
 584         else _fdtable[_chann].pos= pos;
 585 }
 586 _in(buf)
 587 char *buf;
 588 {
 589         register int holder ;
 590         char *c;
 591         int pos;
 592         if( _chann == -1)
 593         {
 594                 pos= _pos;
 595                 gtty(0,_ttydef);
 596                 _ttydef.sg_flags &= ~ECHO;
 597                 stty(0,_ttydef);
 598         }else pos= _fdtable[_chann].pos;
 599         c= buf;
 600         while( (holder = fgetc(_chanrd)) != EOF && holder != '\n'){
 601                 *c= holder ;
 602                 if( _chann == -1) putchar(holder);
 603                 c++; pos++;
 604         }
 605         *c= 0;
 606         if( _chann== -1)
 607         {
 608                 _pos=pos;
 609                 _ttydef.sg_flags |= ECHO;
 610                 stty(0,_ttydef);
 611         } else _fdtable[_chann].pos= pos;
 612 }
 613 _tab(x)
 614 int x;
 615 {
 616         if( x> _width) error(3);
 617         if( x< _pos) _outnl();
 618         _spc(x-_pos);
 619 }
 620 _spc(x)
 621 int x;
 622 {
 623         while(x-->0) _out(" ");
 624 }
 625 orandom.c\0n.c\0\0\0\0\0\0\ 2\ 2�\ 1\0\0\91\ 1/* $Id: random.c,v 2.6 1994/06/24 11:28:45 ceriel Exp $ */
 626
 627 #if !defined(EM_WSIZE)
 628 #define EM_WSIZE _EM_WSIZE
 629 #endif
 630
 631 _randomi()
 632 {
 633         int i;
 634         _setchan(-1);
 635         printf("Random number seed (-32768 to 32767) ? ");
 636         _readint(&i);
 637         _setrand(i);
 638 }
 639
 640 _setrand(i)
 641         int i;
 642 {
 643         srand(i);
 644 }
 645 double _rnd(d) double d;
 646 {
 647         double f; f= (int) rand();
 648         return(f/
 649 #if EM_WSIZE == 4
 650                 2147483647.0
 651 #else
 652                 32767.0
 653 #endif
 654         );
 655 }
 656 aread.c\0c\0n.c\0\0\0\0\0\0\ 2\ 2�\ 1\0\08\v#include "bc_string.h"
 657 #include "bc_io.h"
 658 #include <ctype.h>
 659
 660 /* $Id: read.c,v 2.6 1994/06/24 11:28:49 ceriel Exp $ */
 661
 662 _readln()
 663 {
 664         register int c;
 665         while( (c=fgetc(_chanrd)) != EOF && c!= '\n')
 666                 ;
 667 }
 668
 669 readskip()
 670 {
 671         register int c;
 672 #ifdef DEBUG
 673         printf("readskip\n");
 674 #endif
 675         while( (c=fgetc(_chanrd)) != EOF && c!= ',' && c!= '\n')
 676                 ;
 677 }
 678 _readint(addr)
 679 int *addr;
 680 {
 681         int i;
 682         char    buf[1024];
 683
 684 #ifdef DEBUG
 685         printf("read int from %d\n",_chann);
 686 #endif
 687         _asschn();
 688         if( fscanf(_chanrd,"%d",&i) != 1)
 689         {
 690                 if( ferror(_chanrd)) error(29);
 691                 if( feof(_chanrd)) error(2);
 692                 if( _chann == -1)
 693                 {
 694                         _asschn();      /* may be closed by now */
 695                         fgets(buf,1024,_chanrd);
 696                         printf("?Redo ");
 697                         _readint(addr);
 698                         return;
 699                 }
 700                 error(40);
 701         }else  { readskip(); *addr=i;}
 702 }
 703 _readflt(addr)
 704 double *addr;
 705 {
 706         double f;
 707         char buf[1024];
 708
 709 #ifdef DEBUG
 710         printf("read flt from %d\n",_chann);
 711 #endif
 712         _asschn();
 713         if( fscanf(_chanrd,"%lf",&f) != 1)
 714         {
 715                 if( ferror(_chanrd)) error(29);
 716                 if( feof(_chanrd)) error(2);
 717                 if( _chann == -1)
 718                 {
 719                         fgets(buf,1024,_chanrd);
 720                         printf("?Redo ");
 721                         _readflt(addr);
 722                         return;
 723                 }
 724                 error(40);
 725         }else  { readskip(); *addr=f;}
 726 }
 727 _readstr(s)
 728 String **s;
 729 {
 730         char buffer[1024];
 731         register int kar ;
 732         char *c;
 733
 734 #ifdef DEBUG
 735         printf("read str from %d\n",_chann);
 736 #endif
 737         _asschn();
 738         c= buffer;
 739         kar= fgetc(_chanrd);
 740         while(isspace(kar) && kar!= EOF)
 741                 kar= fgetc(_chanrd);
 742         *c=kar ;
 743         if( kar== '"')
 744         {
 745                 /* read quoted string */
 746 #ifdef DEBUG
 747                 printf("qouted string\n");
 748 #endif
 749                 while ( (kar= fgetc(_chanrd)) != EOF && kar!='"' ) *c++ = kar ;
 750                 ungetc(kar,_chanrd);
 751                 *c=0;
 752         }else
 753         if( isalpha(*c))
 754         {
 755                 /* read normal string */
 756                 c++;
 757 #ifdef DEBUG
 758                 printf("non-qouted string\n");
 759 #endif
 760                 while( (kar= fgetc(_chanrd)) != ',' && kar!= EOF &&
 761                        !isspace(kar) && kar!='\n')
 762                        *c++= kar ;
 763                 ungetc(kar,_chanrd);
 764                 *c=0;
 765         }else{
 766                 if( ferror(_chanrd)) error(29);
 767                 if( feof(_chanrd)) error(2);
 768                 if( _chann == -1)
 769                 {
 770                         fgets(buffer,1024,_chanrd);
 771                         printf("?Redo ");
 772                         _rdline(s);
 773                         return;
 774                 }
 775                 error(40);
 776         }
 777 #ifdef DEBUG
 778         printf("string read: %s\n",buffer);
 779 #endif
 780         readskip();
 781         /* save value read */
 782         _decstr(*s);
 783         *s= (String *) _newstr(buffer);
 784 }
 785
 786 extern int _seektab[];
 787
 788 _restore(line)
 789 int line;
 790 {
 791         int nr;
 792         char buffer[1024];
 793
 794 #ifdef DEBUG
 795         printf("seek to %d",line);
 796 #endif
 797         fseek(_chanrd,0l,0);
 798         if( line)
 799         {
 800                 /* search number of lines to skip */
 801                 for(nr=0; _seektab[nr] && _seektab[nr]< line; nr+=2)
 802 #ifdef DEBUG
 803                 printf("test %d %d\n",_seektab[nr], _seektab[nr+1]);
 804 #endif
 805                 ;
 806                 nr /= 2;
 807 #ifdef DEBUG
 808                 printf(" %d lines to skip\n",nr);
 809 #endif
 810                 while(nr-- >0 ) fgets(buffer,1024,_chanrd);
 811         }
 812 }
 813 _rdline(s)
 814 String **s;
 815 {
 816         char buffer[1024];
 817         if( fgets(buffer,1024,_chanrd) == 0)
 818         {
 819                 if( _chann == -1)
 820                 {
 821                         printf("?Redo ");
 822                         _rdline(s);
 823                         return;
 824                 }
 825                 error(40);
 826         }
 827         _decstr(*s);
 828         *s= (String *) _newstr(buffer);
 829 }
 830 return.c\0n.c\0\0\0\0\0\0\ 2\ 2�\ 1\0\0"\ 2/* $Id: return.c,v 2.3 1994/06/24 11:28:54 ceriel Exp $ */
 831
 832 #define MAXNESTING      1000
 833
 834 int _gotable[MAXNESTING];
 835 int topstk=0;
 836
 837 _gosub(x)
 838 int x;
 839 {
 840         /* administer gosub */
 841 #ifdef DEBUG
 842         printf("store %d in %d\n",x,topstk);
 843 #endif
 844         if( topstk== MAXNESTING)        error(26);
 845         _gotable[topstk]= x;
 846         topstk++;
 847 }
 848 _retstmt()
 849 {
 850         /* make sure that a return label index is on top
 851           of the stack */
 852 #ifdef DEBUG
 853         printf("return to %d %d\n",_gotable[topstk-1],topstk-1);
 854 #endif
 855           if( topstk==0 || topstk==MAXNESTING)
 856                 error(1);
 857           return( _gotable[--topstk]);
 858 }
 859 sgn.c\0.c\0n.c\0\0\0\0\0\0\ 2\ 2�\ 1\0\0�\0/* $Id: sgn.c,v 2.4 1994/06/24 11:29:08 ceriel Exp $ */
 860
 861 _sgn(v)
 862 double v;
 863 {
 864         if( v>0) return(1);
 865         if( v<0) return(-1);
 866         return(0);
 867 }
 868
 869 _forsgn(v)
 870 double v;
 871 {
 872         if (v >= 0) return 1;
 873         return -1;
 874 }
 875 esin.c\0.c\0n.c\0\0\0\0\0\0\ 2\ 2�\ 1\0\0�\ 6/*
 876  * (c) copyright 1988 by the Vrije Universiteit, Amsterdam, The Netherlands.
 877  * See the copyright notice in the ACK home directory, in the file "Copyright".
 878  *
 879  * Author: Ceriel J.H. Jacobs
 880  */
 881
 882 /* $Id: sin.c,v 2.6 1994/06/24 11:29:12 ceriel Exp $ */
 883
 884 #define __NO_DEFS
 885 #include <math.h>
 886
 887 static double
 888 sinus(x, cos_flag)
 889         double x;
 890 {
 891         /*      Algorithm and coefficients from:
 892                         "Software manual for the elementary functions"
 893                         by W.J. Cody and W. Waite, Prentice-Hall, 1980
 894         */
 895
 896         static double r[] = {
 897                 -0.16666666666666665052e+0,
 898                  0.83333333333331650314e-2,
 899                 -0.19841269841201840457e-3,
 900                  0.27557319210152756119e-5,
 901                 -0.25052106798274584544e-7,
 902                  0.16058936490371589114e-9,
 903                 -0.76429178068910467734e-12,
 904                  0.27204790957888846175e-14
 905         };
 906
 907         double  xsqr;
 908         double  y;
 909         int     neg = 0;
 910
 911         if (x < 0) {
 912                 x = -x;
 913                 neg = 1;
 914         }
 915         if (cos_flag) {
 916                 neg = 0;
 917                 y = M_PI_2 + x;
 918         }
 919         else    y = x;
 920
 921         /* ??? avoid loss of significance, if y is too large, error ??? */
 922
 923         y = y * M_1_PI + 0.5;
 924
 925         /*      Use extended precision to calculate reduced argument.
 926                 Here we used 12 bits of the mantissa for a1.
 927                 Also split x in integer part x1 and fraction part x2.
 928         */
 929 #define A1 3.1416015625
 930 #define A2 -8.908910206761537356617e-6
 931         {
 932                 double x1, x2;
 933                 extern double   _fif();
 934
 935                 _fif(y, 1.0,  &y);
 936                 if (_fif(y, 0.5, &x1)) neg = !neg;
 937                 if (cos_flag) y -= 0.5;
 938                 x2 = _fif(x, 1.0, &x1);
 939                 x = x1 - y * A1;
 940                 x += x2;
 941                 x -= y * A2;
 942 #undef A1
 943 #undef A2
 944         }
 945
 946         if (x < 0) {
 947                 neg = !neg;
 948                 x = -x;
 949         }
 950
 951         /* ??? avoid underflow ??? */
 952
 953         y = x * x;
 954         x += x * y * POLYNOM7(y, r);
 955         return neg ? -x : x;
 956 }
 957
 958 double
 959 _sin(x)
 960         double x;
 961 {
 962         return sinus(x, 0);
 963 }
 964
 965 double
 966 _cos(x)
 967         double x;
 968 {
 969         if (x < 0) x = -x;
 970         return sinus(x, 1);
 971 }
 972
 973 /* EXTENSION */
 974 double
 975 _tan(x)
 976         double x;
 977 {
 978         return _sin(x)/_cos(x);
 979 }
 980 ifif.e\0.c\0n.c\0\0\0\0\0\0\ 2\ 2�\ 1\0\0�\ 1#
 981  mes 2,EM_WSIZE,EM_PSIZE
 982
 983 ; $Id: fif.e,v 2.2 1994/06/24 11:28:04 ceriel Exp $
 984
 985 #define ARG1    0
 986 #define ARG2    EM_DSIZE
 987 #define IRES    2*EM_DSIZE
 988
 989 ; _fif is called with three parameters:
 990 ;       - address of integer part result (IRES)
 991 ;       - float two (ARG2)
 992 ;       - float one (ARG1)
 993 ; and returns an EM_DSIZE-byte floating point number
 994
 995  exp $_fif
 996  pro $_fif,0
 997  lal 0
 998  loi 2*EM_DSIZE
 999  fif EM_DSIZE
1000  lal IRES
1001  loi EM_PSIZE
1002  sti EM_DSIZE
1003  ret EM_DSIZE
1004  end ?
1005 sqt.c\0.c\0n.c\0\0\0\0\0\0\ 2\ 2�\ 1\0\0\90\ 4/*
1006  * (c) copyright 1988 by the Vrije Universiteit, Amsterdam, The Netherlands.
1007  * See the copyright notice in the ACK home directory, in the file "Copyright".
1008  *
1009  * Author: Ceriel J.H. Jacobs
1010  */
1011
1012 /* $Id: sqt.c,v 2.5 1994/06/24 11:29:15 ceriel Exp $ */
1013
1014 #define __NO_DEFS
1015 #include <math.h>
1016
1017 #define NITER   5
1018
1019 static double
1020 ldexp(fl,exp)
1021         double fl;
1022         int exp;
1023 {
1024         extern double _fef();
1025         int sign = 1;
1026         int currexp;
1027
1028         if (fl<0) {
1029                 fl = -fl;
1030                 sign = -1;
1031         }
1032         fl = _fef(fl,&currexp);
1033         exp += currexp;
1034         if (exp > 0) {
1035                 while (exp>30) {
1036                         fl *= (double) (1L << 30);
1037                         exp -= 30;
1038                 }
1039                 fl *= (double) (1L << exp);
1040         }
1041         else    {
1042                 while (exp<-30) {
1043                         fl /= (double) (1L << 30);
1044                         exp += 30;
1045                 }
1046                 fl /= (double) (1L << -exp);
1047         }
1048         return sign * fl;
1049 }
1050
1051 double
1052 _sqt(x)
1053         double x;
1054 {
1055         extern double _fef();
1056         int exponent;
1057         double val;
1058
1059         if (x <= 0) {
1060                 if (x < 0) error(3);
1061                 return 0;
1062         }
1063
1064         val = _fef(x, &exponent);
1065         if (exponent & 1) {
1066                 exponent--;
1067                 val *= 2;
1068         }
1069         val = ldexp(val + 1.0, exponent/2 - 1);
1070         /* was: val = (val + 1.0)/2.0; val = ldexp(val, exponent/2); */
1071         for (exponent = NITER - 1; exponent >= 0; exponent--) {
1072                 val = (val + x / val) / 2.0;
1073         }
1074         return val;
1075 }
1076 fef.e\0.c\0n.c\0\0\0\0\0\0\ 2\ 2�\ 1\0\0�\ 1#
1077  mes 2,EM_WSIZE,EM_PSIZE
1078
1079 ; $Id: fef.e,v 2.2 1994/06/24 11:28:00 ceriel Exp $
1080
1081 #define FARG    0
1082 #define ERES    EM_DSIZE
1083
1084 ; _fef is called with two parameters:
1085 ;       - address of exponent result (ERES)
1086 ;       - floating point number to be split (FARG)
1087 ; and returns an EM_DSIZE-byte floating point number
1088
1089  exp $_fef
1090  pro $_fef,0
1091  lal FARG
1092  loi EM_DSIZE
1093  fef EM_DSIZE
1094  lal ERES
1095  loi EM_PSIZE
1096  sti EM_WSIZE
1097  ret EM_DSIZE
1098  end ?
1099  stop.c\0c\0n.c\0\0\0\0\0\0\ 2\ 2�\ 1\0\0\96\0/* $Id: stop.c,v 2.3 1994/06/24 11:29:19 ceriel Exp $ */
1100
1101 _stop()
1102 {
1103         extern int _erlsym;
1104
1105         _setline();
1106         printf("Break in %d\n", _erlsym);
1107         exit(0);
1108 }
1109 string.c\0n.c\0\0\0\0\0\0\ 2\ 2�\ 1\0\0A\f#include "bc_string.h"
1110
1111 /* $Id: string.c,v 2.10 1996/11/26 15:02:36 ceriel Exp $ */
1112
1113 #define ok(X)   if( X ==0) return;
1114 #define okr(X)  if( X ==0) return(0);
1115
1116 extern char *salloc() ;
1117
1118 _length(str)
1119 String *str;
1120 {
1121         okr(str);
1122         return(str->strlength);
1123 }
1124 String *_newstr(str)
1125 char *str;
1126 {
1127         String *s;
1128         okr(str);
1129         s= (String *) salloc(sizeof(String));
1130         s->strcount=1;
1131         s->strlength= strlen(str);
1132         s->strval= salloc(s->strlength+1);
1133         strcpy(s->strval,str);
1134         return(s);
1135 }
1136 _incstr(src)
1137 String *src;
1138 {
1139         /* one more variable uses the string */
1140         ok(src);
1141         src->strcount++;
1142 }
1143 _decstr(str)
1144 String *str;
1145 {
1146         ok(str);
1147         /* Strings in ROM are initialized with this count */
1148         if ( str->strcount==9999 ) return ;
1149         str->strcount--;
1150         if(str->strcount<=0) _delstr(str);
1151 }
1152 _strcpy(dst,src)
1153 String *src,*dst;
1154 {
1155         ok(src);
1156         ok(dst);
1157         _decstr(dst);
1158         *dst = *src;
1159         _incstr(src);
1160 }
1161 _delstr(src)
1162 String *src;
1163 {
1164         ok(src);
1165         sfree(src->strval);
1166         sfree((char *)src);
1167 }
1168 String *_concat(s1,s2)
1169 String *s1,*s2;
1170 {
1171         String *s;
1172         int length;
1173         okr(s1); okr(s2);
1174         s= (String *) salloc(sizeof(String));
1175         s->strlength= _length(s1)+_length(s2);
1176         s->strval= salloc(s->strlength+1);
1177         s->strcount = 1;
1178         strcpy(s->strval,s2->strval);
1179         strcat(s->strval,s1->strval);
1180         return(s);
1181 }
1182 _strcomp(s1,s2)
1183 String *s1,*s2;
1184 {
1185         okr(s1);okr(s2);
1186         return(strcmp(s2->strval,s1->strval));
1187 }
1188
1189 String *_left(size,s)
1190 String *s;
1191 int     size;
1192 {
1193         String *ns;
1194         int i;
1195
1196         okr(s);
1197         if( size <0 || size >s->strlength) error(3);
1198         ns= (String *) salloc(sizeof(String));
1199         ns->strval= salloc(size+1);
1200         ns->strcount=1;
1201         for(i=0; i<size && s->strval[i];i++)
1202                 ns->strval[i]= s->strval[i];
1203         ns->strval[i]=0;
1204         ns->strlength= i;
1205         return(ns);
1206 }
1207
1208 String *_space(d)
1209 int d;
1210 {
1211         String *s;
1212         int i,len;
1213
1214         len= d;
1215         s= (String *) salloc(sizeof(String));
1216         s->strlength= len;
1217         s->strcount=1;
1218         s->strval= salloc(len+1);
1219         for(i=0;i<len;i++)
1220                 s->strval[i]= ' ';
1221         s->strval[i]=0;
1222         return(s);
1223 }
1224
1225 String *_strascii()
1226 {
1227 }
1228 String *_string(f, d)
1229 double  d,f;
1230 {
1231         int i,j;
1232         String *s;
1233
1234         i=d;j=f;
1235         if( i<0  || i>MAXSTRING) error(3);
1236         s= (String *) salloc(sizeof(String));
1237         s->strlength= i;
1238         s->strcount=1;
1239         s->strval= salloc(i+1);
1240         s->strval[i--]=0;
1241         for(; i>=0;i--)
1242                 s->strval[i]= j;
1243         return(s);
1244 }
1245 _midstmt(s2,i1,i2,s)
1246 int i1,i2;
1247 String *s, *s2;
1248 {
1249         int l;
1250
1251         /*printf("mid called %d %d %s %s\n",i1,i2,s->strval, s2->strval);*/
1252         if (i2 < 0 || i1 < -1) error(3);
1253         if( s->strlength<i2 || s2->strlength < i1) error(3);    /* source string too short */
1254         if( i1== -1) i1= s2->strlength;
1255         l= s->strlength - i2+1;
1256         if( i1>l ) i1=l;
1257         strncpy(s->strval+i2-1,s2->strval,i1);
1258 }
1259 String *_mid(i1,i2,s)
1260 int i1,i2;
1261 String *s;
1262 {
1263         int l;
1264         String *s2;
1265
1266 /*      printf("mid fcn called %d %d %s\n",i1,i2,s->strval);*/
1267         if (i2 < 0 || i1 < -1) return(s2);      /* or error? */
1268         if( i1 == -1) i1= s->strlength;
1269         s2= _newstr(s->strval);
1270         s2->strval[0]=0;
1271         if( s->strlength<i2) return(s2);        /* source string too short */
1272         l= s->strlength - i2+1;
1273         if( i1>l ) i1=l;
1274         strncpy(s2->strval,s->strval+i2-1,i1);
1275         s2->strval[i1]=0;
1276         return(s2);
1277 }
1278
1279 String *_right(length,str)
1280 String *str;
1281 int length;
1282 {
1283         String *s;
1284         int i;
1285
1286         i= _length(str)-length;
1287         if(i<0) i=0;
1288         s= _newstr(str->strval+i);
1289         return(s);
1290 }
1291 \0salloc.c\0n.c\0\0\0\0\0\0\ 2\ 2�\ 1\0\0\16\ 1/* $Id: salloc.c,v 2.4 1994/06/24 11:29:00 ceriel Exp $ */
1292
1293 extern char *malloc() ;
1294
1295 char * salloc(length)
1296 unsigned length;
1297 {
1298         char *c, *s;
1299         c= malloc(length);
1300         if( !c ) error(5);
1301         for(s=c;s<c+length;s++) *s = 0;
1302         return(c);
1303 }
1304
1305 sfree(c)
1306 char *c;
1307 {
1308         if( !c ) return;
1309         free(c);
1310 }
1311 swap.c\0c\0n.c\0\0\0\0\0\0\ 2\ 2�\ 1\0\0:\ 1#include "bc_string.h"
1312
1313 /* $Id: swap.c,v 2.5 1994/06/24 11:29:27 ceriel Exp $ */
1314
1315 _intswap(i1,i2)
1316 int *i1,*i2;
1317 {
1318         int i3;
1319         i3= *i1;
1320         *i1= *i2;
1321         *i2=i3;
1322 }
1323
1324 _fltswap(i1,i2)
1325 double *i1,*i2;
1326 {
1327         double i3;
1328         i3= *i1;
1329         *i1= *i2;
1330         *i2=i3;
1331 }
1332
1333 _strswap(s1,s2)
1334 String **s1,**s2;
1335 {
1336         String *s;
1337         s= *s1;
1338         *s1= *s2;
1339         *s2 = s;
1340 }
1341 trace.c\0\0n.c\0\0\0\0\0\0\ 2\ 2�\ 1\0\0c\0/* $Id: trace.c,v 2.4 1994/06/24 11:29:31 ceriel Exp $ */
1342
1343 _trace(i)
1344 int i;
1345 {
1346 printf("[%d]",i);
1347 }
1348 nwrite.c\0\0n.c\0\0\0\0\0\0\ 2\ 2�\ 1\0\0>\ 2#include "bc_string.h"
1349 #include "bc_io.h"
1350
1351 /* $Id: write.c,v 2.5 1994/06/24 11:29:42 ceriel Exp $ */
1352
1353 /* assume that the channel has been set */
1354
1355 _wrnl()
1356 {
1357         if( fputc('\n',_chanwr) == EOF) error(29);
1358 }
1359 _wrcomma()
1360 {
1361         if( fputc(',',_chanwr) == EOF) error(29);
1362 }
1363 _wrint(i)
1364 int i;
1365 {
1366         if(i>0)
1367                 if( fputc(' ',_chanwr)==EOF) error(29);
1368         fprintf(_chanwr,"%d",i);
1369         if( ferror(_chanwr) ) error(29);
1370 }
1371 _wrflt(f)
1372 double f;
1373 {
1374         fprintf(_chanwr,"%f",f);
1375         if( ferror(_chanwr) ) error(29);
1376 }
1377 _wrstr(s)
1378 String *s;
1379 {
1380         fprintf(_chanwr,"\"%s\"",s->strval);
1381         if( ferror(_chanwr) ) error(29);
1382 }
1383 file.c\0\0\0n.c\0\0\0\0\0\0\ 2\ 2�\ 1\0\0�\b#include "bc_string.h"
1384 #include <stdio.h>
1385 #include "bc_io.h"
1386
1387 /* $Id: file.c,v 2.6 1994/06/24 11:28:08 ceriel Exp $ */
1388
1389 Filedesc        _fdtable[16];
1390 /* BASIC file descriptor table */
1391 /* Channel assignment:
1392    -1           terminal IO
1393     0           data file
1394     1-15        user files
1395 */
1396
1397
1398
1399 int     _chann          = -1;
1400 FILE    *_chanrd        = stdin;
1401 FILE    *_chanwr        = stdout;
1402
1403 _setchan(index)
1404 int index;
1405 {
1406 #ifdef DEBUG
1407         printf("setchannel %d\n",index);
1408 #endif
1409         fflush(_chanwr);
1410         if( index == -1)
1411         {
1412                 _chann= -1;
1413                 _chanrd= stdin;
1414                 _chanwr= stdout;
1415                 return;
1416         }
1417         if( index<0 || index>15)
1418                 error(27);
1419         _chann=index;
1420         _chanrd= _chanwr= _fdtable[index].fd;
1421 }
1422
1423 _asschn()
1424 {
1425 #ifdef DEBUG
1426         printf("_asschn %d\n",_chann);
1427 #endif
1428         if( _chann == -1) return;
1429 #ifdef DEBUG
1430         printf(" file %d\n", _fdtable[_chann].fd);
1431 #endif
1432         if( _chann<0 || _chann>15)
1433                 error(27);
1434         if( _fdtable[_chann].fd== 0)
1435                 error(39);
1436         if( feof( _fdtable[_chann].fd))
1437                 error(2);
1438 }
1439
1440 _clochn(nr)
1441 int nr;
1442 {
1443         if( nr<1 || nr >15 || _fdtable[nr].fd==0) error(3);
1444         fclose(_fdtable[nr].fd);
1445         _fdtable[nr].fd=0; _fdtable[nr].fname=0;
1446 }
1447
1448 _opnchn(reclen,fname,mode)
1449 String *mode,*fname;
1450 int     reclen;
1451 {
1452         /* channel has been set */
1453         FILE *f;
1454         int m;
1455
1456 #ifdef DEBUG
1457         printf("open %d %s %s \n",reclen,mode->strval,fname->strval);
1458 #endif
1459         /* check for opened/closed file */
1460         if(_fdtable[_chann].fd)
1461                 error(30);
1462         switch(*mode->strval)
1463         {
1464                 case 'O':
1465                 case 'o':
1466                         if( (f=fopen(fname->strval,"w")) == NULL)
1467                                 error(28);
1468                         m= OMODE;
1469                         break;
1470                 case 'I':
1471                 case 'i':
1472                         if( (f=fopen(fname->strval,"r")) == NULL)
1473                                 error(28);
1474                         m= IMODE;
1475                         break;
1476                 case 'r':
1477                 case 'R':
1478                         if( (f=fopen(fname->strval,"a")) == NULL)
1479                                 error(28);
1480                         m= RMODE;
1481                         break;
1482                 default:
1483                         printf("file mode %s\n",mode->strval);
1484                         error(29);
1485         }
1486         _chanwr= _chanrd= _fdtable[_chann].fd= f;
1487         _fdtable[_chann].fname= fname->strval;
1488         _fdtable[_chann].reclength= reclen;
1489         _fdtable[_chann].mode= m;
1490 #ifdef DEBUG
1491         printf("file descr %d\n",f);
1492 #endif
1493 }
1494
1495 _ioeof(channel)
1496 int channel;
1497 {
1498         FILE *fd;
1499         char c;
1500         if( channel<0 || channel >15) error(3);
1501         fd= _fdtable[channel].fd;
1502         if( fd==0)
1503                 error(3);
1504         c=fgetc(fd);
1505         if( feof(_fdtable[channel].fd) ) return(-1);
1506         ungetc(c,fd);
1507         return(0);
1508 }
1509
1510 _close()
1511 {
1512         /* close all open files */
1513         int i;
1514         for(i=1;i<16;i++)
1515         if( _fdtable[i].fd)
1516                 _clochn(i);
1517 }
1518 error.c\0\0n.c\0\0\0\0\0\0\ 2\ 2�\ 1\0\0]\ 6/* $Id: error.c,v 2.3 1994/06/24 11:27:52 ceriel Exp $ */
1519
1520 /* error takes an error value in the range of 0-255 */
1521 /* and generates a trap */
1522
1523 char *errortable[255]={
1524 /* 0  */        "",
1525 /* 1  */        "RETURN without GOSUB",
1526 /* 2  */        "Out of data",
1527 /* 3  */        "Illegal function call",
1528 /* 4  */        "Overflow",
1529 /* 5  */        "Out of memory",
1530 /*  6 */        "Undefined line ",
1531 /*  7 */        "Subscript out of range",
1532 /*  8 */        "Redimensioned array",
1533 /*  9 */        "Division by zero",
1534 /* 10 */        "Illegal indirect",
1535 /* 11 */        "Type mismatch",
1536 /* 12 */        "Out of string space",
1537 /* 13 */        "String too long",
1538 /* 14 */        "String formula too complex",
1539 /* 15 */        "Can't continue",
1540 /* 16 */        "Undefined user function",
1541 /* 17 */        "No resume",
1542 /* 18 */        "Resume without error",
1543 /* 19 */        "Unprintable error",
1544 /* 20 */        "Missing operand",
1545 /* 21 */        "Line buffer overflow",
1546 /* 22 */        "FOR without NEXT",
1547 /* 23 */        "WHILE without WEND",
1548 /* 24 */        "WEND without WHILE",
1549 /* 25 */        "Field overflow",
1550 /* 26 */        "Internal error",
1551 /* 27 */        "Bad file number",
1552 /* 28 */        "File not found",
1553 /* 29 */        "Bad file mode",
1554 /* 30 */        "File already open",
1555 /* 31 */        "Disk IO error",
1556 /* 32 */        "File already exists",
1557 /* 33 */        "Disk full",
1558 /* 34 */        "Input past end",
1559 /* 35 */        "Bad record number",
1560 /* 36 */        "Bad file name",
1561 /* 37 */        "Direct statement in file",
1562 /* 38 */        "Too many files",
1563 /* 39 */        "File not open",
1564 /* 40 */        "Syntax error in data",
1565 0
1566 };
1567
1568 error(index)
1569 int     index;
1570 {
1571         extern int _errsym;
1572         extern int _erlsym;
1573
1574         _setline();
1575         if( index<0 || index >40 )
1576                 printf("LINE %d:ERROR %d: Unprintable error\n",_erlsym,index);
1577         else    printf("LINE %d:ERROR %d: %s\n",_erlsym,index,errortable[index]);
1578         _errsym= index;
1579         _trap();
1580 }
1581 8trap.c\0\0\0n.c\0\0\0\0\0\0\ 2\ 2�\ 1\0\0<\ 3#include <signal.h>
1582 #include <setjmp.h>
1583
1584 #ifndef NSIG
1585 #define NSIG _NSIG
1586 #endif
1587
1588 /* $Id: trap.c,v 2.5 1994/06/24 11:29:36 ceriel Exp $ */
1589
1590 /* Trap handling */
1591 int     _trpline;       /* BASIC return label */
1592 jmp_buf trpbuf;
1593
1594 _trpset(nr)
1595 int nr;
1596 {
1597         /*debug  printf("trap set to %d\n",nr);*/
1598         _trpline=nr;
1599 }
1600 void
1601 _trpfatal(i)
1602 int i;
1603 {
1604         extern int _errsym,_erlsym;
1605
1606         _errsym= i;
1607         _setline();
1608         if( _trpline == 0)
1609                 printf("LINE %d: FATAL ERROR: trap %d\n",_erlsym,i);
1610 #ifdef DEBUG
1611         printf("trap occurred %d return %d\n",i,_trpline);
1612 #endif
1613         _trap();
1614 }
1615
1616 _ini_trp()
1617 {
1618         /* initialize trap routines */
1619         int i;
1620
1621         for(i=0;i<NSIG;i++)
1622                 signal(i,_trpfatal);
1623 }
1624
1625
1626 _settrap(nr)
1627 int nr;
1628 {
1629         _trpline=nr;
1630 }
1631 _trap()
1632 {
1633         int line;
1634
1635         if( _trpline==0) exit(-1);
1636         line=_trpline;
1637         _trpline=0;             /* should be reset by user */
1638         _ini_trp();
1639         longjmp(trpbuf,line);
1640 }
1641 setline.e\0.c\0\0\0\0\0\0\ 2\ 2�\ 1\0\0�\0#
1642  mes 2,EM_WSIZE,EM_PSIZE
1643 ; $Id: setline.e,v 2.2 1994/06/24 11:29:04 ceriel Exp $
1644 ; Save the line where the error occurred
1645  exp $_setline
1646  pro $_setline,0
1647  exa _erlsym
1648  loe 0
1649  ste _erlsym
1650  ret 0
1651  end
1652 _