lang/pc/libpc/tail_pc.a

   1 e�abi.c\0\0\0\0\0\0\0\0\0\0\0\0\0\ 2\ 2�\ 1\0\0R\ 2/* $Id: abi.c,v 2.2 1994/06/24 12:30:48 ceriel Exp $ */
   2 /*
   3  * (c) copyright 1983 by the Vrije Universiteit, Amsterdam, The Netherlands.
   4  *
   5  *          This product is part of the Amsterdam Compiler Kit.
   6  *
   7  * Permission to use, sell, duplicate or disclose this software must be
   8  * obtained in writing. Requests for such permissions may be sent to
   9  *
  10  *      Dr. Andrew S. Tanenbaum
  11  *      Wiskundig Seminarium
  12  *      Vrije Universiteit
  13  *      Postbox 7161
  14  *      1007 MC Amsterdam
  15  *      The Netherlands
  16  *
  17  */
  18
  19 /* Author: J.W. Stevenson */
  20
  21 int _abi(i) int i; {
  22         return(i>=0 ? i : -i);
  23 }
  24 abl.c\0\0\0\0\0\0\0\0\0\0\0\0\0\ 2\ 2�\ 1\0\0T\ 2/* $Id: abl.c,v 2.2 1994/06/24 12:30:52 ceriel Exp $ */
  25 /*
  26  * (c) copyright 1983 by the Vrije Universiteit, Amsterdam, The Netherlands.
  27  *
  28  *          This product is part of the Amsterdam Compiler Kit.
  29  *
  30  * Permission to use, sell, duplicate or disclose this software must be
  31  * obtained in writing. Requests for such permissions may be sent to
  32  *
  33  *      Dr. Andrew S. Tanenbaum
  34  *      Wiskundig Seminarium
  35  *      Vrije Universiteit
  36  *      Postbox 7161
  37  *      1007 MC Amsterdam
  38  *      The Netherlands
  39  *
  40  */
  41
  42 /* Author: J.W. Stevenson */
  43
  44 long _abl(i) long i; {
  45         return(i>=0 ? i : -i);
  46 }
  47 abr.c\0\0\0\0\0\0\0\0\0\0\0\0\0\ 2\ 2�\ 1\0\0X\ 2/* $Id: abr.c,v 2.2 1994/06/24 12:30:55 ceriel Exp $ */
  48 /*
  49  * (c) copyright 1983 by the Vrije Universiteit, Amsterdam, The Netherlands.
  50  *
  51  *          This product is part of the Amsterdam Compiler Kit.
  52  *
  53  * Permission to use, sell, duplicate or disclose this software must be
  54  * obtained in writing. Requests for such permissions may be sent to
  55  *
  56  *      Dr. Andrew S. Tanenbaum
  57  *      Wiskundig Seminarium
  58  *      Vrije Universiteit
  59  *      Postbox 7161
  60  *      1007 MC Amsterdam
  61  *      The Netherlands
  62  *
  63  */
  64
  65 /* Author: J.W. Stevenson */
  66
  67 double _abr(r) double r; {
  68         return(r>=0 ? r : -r);
  69 }
  70 arg.c\0\0\0\0\0\0\0\0\0\0\0\0\0\ 2\ 2�\ 1\0\0+\ 4/* $Id: arg.c,v 2.3 1994/06/24 12:30:59 ceriel Exp $ */
  71 /*
  72  * (c) copyright 1983 by the Vrije Universiteit, Amsterdam, The Netherlands.
  73  *
  74  *          This product is part of the Amsterdam Compiler Kit.
  75  *
  76  * Permission to use, sell, duplicate or disclose this software must be
  77  * obtained in writing. Requests for such permissions may be sent to
  78  *
  79  *      Dr. Andrew S. Tanenbaum
  80  *      Wiskundig Seminarium
  81  *      Vrije Universiteit
  82  *      Postbox 7161
  83  *      1007 MC Amsterdam
  84  *      The Netherlands
  85  *
  86  */
  87
  88 /* Author: J.W. Stevenson */
  89
  90 /* function argc:integer; extern; */
  91 /* function argv(i:integer):string; extern; */
  92 /* procedure argshift; extern; */
  93 /* function environ(i:integer):string; extern; */
  94
  95 extern int      _pargc;
  96 extern char     **_pargv;
  97 extern char     **_penvp;
  98
  99 int argc() {
 100         return(_pargc);
 101 }
 102
 103 char *argv(i) {
 104         if (i >= _pargc)
 105                 return(0);
 106         return(_pargv[i]);
 107 }
 108
 109 argshift() {
 110
 111         if (_pargc > 1) {
 112                 --_pargc;
 113                 _pargv++;
 114         }
 115 }
 116
 117 char *environ(i) {
 118         char **p; char *q;
 119
 120         if (p = _penvp)
 121                 while (q = *p++)
 122                         if (i-- < 0)
 123                                 return(q);
 124         return(0);
 125 }
 126 \0ass.c\0\0\0\0\0\0\0\0\0\0\0\0\0\ 2\ 2�\ 1\0\0�\ 2/* $Id: ass.c,v 2.2 1994/06/24 12:31:02 ceriel Exp $ */
 127 /*
 128  * (c) copyright 1983 by the Vrije Universiteit, Amsterdam, The Netherlands.
 129  *
 130  *          This product is part of the Amsterdam Compiler Kit.
 131  *
 132  * Permission to use, sell, duplicate or disclose this software must be
 133  * obtained in writing. Requests for such permissions may be sent to
 134  *
 135  *      Dr. Andrew S. Tanenbaum
 136  *      Wiskundig Seminarium
 137  *      Vrije Universiteit
 138  *      Postbox 7161
 139  *      1007 MC Amsterdam
 140  *      The Netherlands
 141  *
 142  */
 143
 144 /* Author: J.W. Stevenson */
 145
 146 #include        <em_abs.h>
 147 #include        <pc_err.h>
 148
 149 extern char     *_hol0();
 150 extern          _trp();
 151
 152 _ass(line,bool) int line,bool; {
 153
 154         if (bool==0) {
 155                 LINO = line;
 156                 _trp(EASS);
 157         }
 158 }
 159  asz.c\0\0\0\0\0\0\0\0\0\0\0\0\0\ 2\ 2�\ 1\0\0\9d\ 2/* $Id: asz.c,v 2.2 1994/06/24 12:31:05 ceriel Exp $ */
 160 /*
 161  * (c) copyright 1983 by the Vrije Universiteit, Amsterdam, The Netherlands.
 162  *
 163  *          This product is part of the Amsterdam Compiler Kit.
 164  *
 165  * Permission to use, sell, duplicate or disclose this software must be
 166  * obtained in writing. Requests for such permissions may be sent to
 167  *
 168  *      Dr. Andrew S. Tanenbaum
 169  *      Wiskundig Seminarium
 170  *      Vrije Universiteit
 171  *      Postbox 7161
 172  *      1007 MC Amsterdam
 173  *      The Netherlands
 174  *
 175  */
 176
 177 /* Author: J.W. Stevenson */
 178
 179 struct descr {
 180         int     low;
 181         int     diff;
 182         int     size;
 183 };
 184
 185 int _asz(dp) struct descr *dp; {
 186         return(dp->size * (dp->diff + 1));
 187 }
 188 latn.c\0\0\0\0\0\0\0\0\0\0\0\0\0\ 2\ 2�\ 1\0\0T\ 5/*
 189  * (c) copyright 1988 by the Vrije Universiteit, Amsterdam, The Netherlands.
 190  * See the copyright notice in the ACK home directory, in the file "Copyright".
 191  *
 192  * Author: Ceriel J.H. Jacobs
 193  */
 194
 195 /* $Id: atn.c,v 2.7 1994/06/24 12:31:09 ceriel Exp $ */
 196
 197 #define __NO_DEFS
 198 #include <math.h>
 199
 200 #if __STDC__
 201 #include <pc_math.h>
 202 #endif
 203
 204 double
 205 _atn(x)
 206         double x;
 207 {
 208         /*      Algorithm and coefficients from:
 209                         "Software manual for the elementary functions"
 210                         by W.J. Cody and W. Waite, Prentice-Hall, 1980
 211         */
 212
 213         static double p[] = {
 214                 -0.13688768894191926929e+2,
 215                 -0.20505855195861651981e+2,
 216                 -0.84946240351320683534e+1,
 217                 -0.83758299368150059274e+0
 218         };
 219         static double q[] = {
 220                  0.41066306682575781263e+2,
 221                  0.86157349597130242515e+2,
 222                  0.59578436142597344465e+2,
 223                  0.15024001160028576121e+2,
 224                  1.0
 225         };
 226         static double a[] = {
 227                 0.0,
 228                 0.52359877559829887307710723554658381,  /* pi/6 */
 229                 M_PI_2,
 230                 1.04719755119659774615421446109316763   /* pi/3 */
 231         };
 232
 233         int     neg = x < 0;
 234         int     n;
 235         double  g;
 236
 237         if (neg) {
 238                 x = -x;
 239         }
 240         if (x > 1.0) {
 241                 x = 1.0/x;
 242                 n = 2;
 243         }
 244         else    n = 0;
 245
 246         if (x > 0.26794919243112270647) {       /* 2-sqtr(3) */
 247                 n = n + 1;
 248                 x = (((0.73205080756887729353*x-0.5)-0.5)+x)/
 249                         (1.73205080756887729353+x);
 250         }
 251
 252         /* ??? avoid underflow ??? */
 253
 254         g = x * x;
 255         x += x * g * POLYNOM3(g, p) / POLYNOM4(g, q);
 256         if (n > 1) x = -x;
 257         x += a[n];
 258         return neg ? -x : x;
 259 }
 260 bcp.c\0\0\0\0\0\0\0\0\0\0\0\0\0\ 2\ 2�\ 1\0\0�\ 2/* $Id: bcp.c,v 2.3 1994/06/24 12:31:12 ceriel Exp $ */
 261 /*
 262  * (c) copyright 1983 by the Vrije Universiteit, Amsterdam, The Netherlands.
 263  *
 264  *          This product is part of the Amsterdam Compiler Kit.
 265  *
 266  * Permission to use, sell, duplicate or disclose this software must be
 267  * obtained in writing. Requests for such permissions may be sent to
 268  *
 269  *      Dr. Andrew S. Tanenbaum
 270  *      Wiskundig Seminarium
 271  *      Vrije Universiteit
 272  *      Postbox 7161
 273  *      1007 MC Amsterdam
 274  *      The Netherlands
 275  *
 276  */
 277
 278 /* Author: J.W. Stevenson */
 279
 280 int _bcp(sz,y,x) int sz; unsigned char *y,*x; {
 281
 282         while (--sz >= 0) {
 283                 if (*x < *y)
 284                         return(-1);
 285                 if (*x++ > *y++)
 286                         return(1);
 287         }
 288         return(0);
 289 }
 290 3bts.e\0\0\0\0\0\0\0\0\0\0\0\0\0\ 2\ 2�\ 1\0\0�\ 4#
 291 ; $Id: bts.e,v 2.2 1994/06/24 12:31:15 ceriel Exp $
 292 ;
 293 ; (c) copyright 1983 by the Vrije Universiteit, Amsterdam, The Netherlands.
 294 ;
 295 ;          This product is part of the Amsterdam Compiler Kit.
 296 ;
 297 ; Permission to use, sell, duplicate or disclose this software must be
 298 ; obtained in writing. Requests for such permissions may be sent to
 299 ;
 300 ;      Dr. Andrew S. Tanenbaum
 301 ;      Wiskundig Seminarium
 302 ;      Vrije Universiteit
 303 ;      Postbox 7161
 304 ;      1007 MC Amsterdam
 305 ;      The Netherlands
 306 ;
 307 ;
 308
 309 ; Author: J.W. Stevenson */
 310
 311  mes 2,EM_WSIZE,EM_PSIZE
 312
 313 #define SIZE    0
 314 #define HIGH    EM_WSIZE
 315 #define LOWB    2*EM_WSIZE
 316 #define BASE    3*EM_WSIZE
 317
 318 ; _bts is called with four parameters:
 319 ;       - the initial set (BASE)
 320 ;       - low bound of range of bits (LOWB)
 321 ;       - high bound of range of bits (HIGH)
 322 ;       - set size in bytes (SIZE)
 323
 324  exp $_bts
 325  pro $_bts,0
 326  lal BASE       ; address of initial set
 327  lol SIZE
 328  los EM_WSIZE   ; load initial set
 329 1
 330  lol LOWB       ; low bound
 331  lol HIGH       ; high bound
 332  bgt *2         ; while low <= high
 333  lol LOWB
 334  lol SIZE
 335  set ?          ; create [low]
 336  lol SIZE
 337  ior ?          ; merge with initial set
 338  inl LOWB       ; increment low bound
 339  bra *1         ; loop back
 340 2
 341  lal BASE
 342  lol SIZE
 343  sts EM_WSIZE   ; store result over initial set
 344  ret 0
 345  end ?
 346 buff.c\0\0\0\0\0\0\0\0\0\0\0\0\ 2\ 2�\ 1\0\07\ 3/* $Id: buff.c,v 2.3 1994/06/24 12:31:18 ceriel Exp $ */
 347 /*
 348  * (c) copyright 1983 by the Vrije Universiteit, Amsterdam, The Netherlands.
 349  *
 350  *          This product is part of the Amsterdam Compiler Kit.
 351  *
 352  * Permission to use, sell, duplicate or disclose this software must be
 353  * obtained in writing. Requests for such permissions may be sent to
 354  *
 355  *      Dr. Andrew S. Tanenbaum
 356  *      Wiskundig Seminarium
 357  *      Vrije Universiteit
 358  *      Postbox 7161
 359  *      1007 MC Amsterdam
 360  *      The Netherlands
 361  *
 362  */
 363
 364 /* Author: J.W. Stevenson */
 365
 366 #include        <pc_file.h>
 367
 368 extern          _flush();
 369
 370 /* procedure buff(var f:file of ?); */
 371
 372 buff(f) struct file *f; {
 373         int sz;
 374
 375         if ((f->flags & (0377|WRBIT)) != (MAGIC|WRBIT))
 376                 return;
 377         _flush(f);
 378         sz = f->size;
 379         f->count = f->buflen = (sz>PC_BUFLEN ? sz : PC_BUFLEN-PC_BUFLEN%sz);
 380 }
 381
 382 clock.c\0\0\0\0\0\0\0\0\0\0\0\ 2\ 2�\ 1\0\0h\ 3/* $Id: clock.c,v 2.5 1994/06/24 12:31:24 ceriel Exp $ */
 383 /*
 384  * (c) copyright 1983 by the Vrije Universiteit, Amsterdam, The Netherlands.
 385  *
 386  *          This product is part of the Amsterdam Compiler Kit.
 387  *
 388  * Permission to use, sell, duplicate or disclose this software must be
 389  * obtained in writing. Requests for such permissions may be sent to
 390  *
 391  *      Dr. Andrew S. Tanenbaum
 392  *      Wiskundig Seminarium
 393  *      Vrije Universiteit
 394  *      Postbox 7161
 395  *      1007 MC Amsterdam
 396  *      The Netherlands
 397  *
 398  */
 399
 400 /* Author: J.W. Stevenson */
 401
 402 /* function clock:integer; extern; */
 403
 404 extern int      _times();
 405
 406 struct tbuf {
 407         long    utime;
 408         long    stime;
 409         long    cutime;
 410         long    cstime;
 411 };
 412
 413 #ifndef EM_WSIZE
 414 #define EM_WSIZE _EM_WSIZE
 415 #endif
 416
 417 int clock() {
 418         struct tbuf t;
 419
 420         _times(&t);
 421         return( (int)(t.utime + t.stime) &
 422 #if EM_WSIZE <= 2
 423         077777
 424 #else
 425         0x7fffffffL
 426 #endif
 427         );
 428 }
 429 diag.c\0\0\0\0\0\0\0\0\0\0\0\0\ 2\ 2�\ 1\0\0\v\ 3/* $Id: diag.c,v 2.2 1994/06/24 12:31:33 ceriel Exp $ */
 430 /*
 431  * (c) copyright 1983 by the Vrije Universiteit, Amsterdam, The Netherlands.
 432  *
 433  *          This product is part of the Amsterdam Compiler Kit.
 434  *
 435  * Permission to use, sell, duplicate or disclose this software must be
 436  * obtained in writing. Requests for such permissions may be sent to
 437  *
 438  *      Dr. Andrew S. Tanenbaum
 439  *      Wiskundig Seminarium
 440  *      Vrije Universiteit
 441  *      Postbox 7161
 442  *      1007 MC Amsterdam
 443  *      The Netherlands
 444  *
 445  */
 446
 447 /* Author: J.W. Stevenson */
 448
 449 #include        <pc_file.h>
 450
 451 /* procedure diag(var f:text); */
 452
 453 diag(f) struct file *f; {
 454
 455         f->ptr = f->bufadr;
 456         f->flags = WRBIT|EOFBIT|ELNBIT|TXTBIT|MAGIC;
 457         f->fname = "DIAG";
 458         f->ufd = 2;
 459         f->size = 1;
 460         f->count = 1;
 461         f->buflen = 1;
 462 }
 463 rdis.c\0\0\0\0\0\0\0\0\0\0\0\0\0\ 2\ 2�\ 1\0\0�\a/* $Id: dis.c,v 2.2 1994/06/24 12:31:36 ceriel Exp $ */
 464 /*
 465  * (c) copyright 1983 by the Vrije Universiteit, Amsterdam, The Netherlands.
 466  *
 467  *          This product is part of the Amsterdam Compiler Kit.
 468  *
 469  * Permission to use, sell, duplicate or disclose this software must be
 470  * obtained in writing. Requests for such permissions may be sent to
 471  *
 472  *      Dr. Andrew S. Tanenbaum
 473  *      Wiskundig Seminarium
 474  *      Vrije Universiteit
 475  *      Postbox 7161
 476  *      1007 MC Amsterdam
 477  *      The Netherlands
 478  *
 479  */
 480
 481 /* Author: J.W. Stevenson */
 482
 483 #include        <pc_err.h>
 484
 485 #define assert()        /* nothing */
 486
 487 /*
 488  * use circular list of free blocks from low to high addresses
 489  * _highp points to free block with highest address
 490  */
 491 struct adm {
 492         struct adm      *next;
 493         int             size;
 494 };
 495
 496 extern struct adm       *_lastp;
 497 extern struct adm       *_highp;
 498 extern                  _trp();
 499
 500 static int merge(p1,p2) struct adm *p1,*p2; {
 501         struct adm *p;
 502
 503         p = (struct adm *)((char *)p1 + p1->size);
 504         if (p > p2)
 505                 _trp(EFREE);
 506         if (p != p2)
 507                 return(0);
 508         p1->size += p2->size;
 509         p1->next = p2->next;
 510         return(1);
 511 }
 512
 513 _dis(n,pp) int n; struct adm **pp; {
 514         struct adm *p1,*p2;
 515
 516         /*
 517          * NOTE: dispose only objects whose size is a multiple of sizeof(*pp).
 518          *       this is always true for objects allocated by _new()
 519          */
 520         n = ((n+sizeof(*p1)-1) / sizeof(*p1)) * sizeof(*p1);
 521         if (n == 0)
 522                 return;
 523         if ((p1= *pp) == (struct adm *) 0)
 524                 _trp(EFREE);
 525         p1->size = n;
 526         if ((p2 = _highp) == 0)  /*p1 is the only free block*/
 527                 p1->next = p1;
 528         else {
 529                 if (p2 > p1) {
 530                         /*search for the preceding free block*/
 531                         if (_lastp < p1)  /*reduce search*/
 532                                 p2 = _lastp;
 533                         while (p2->next < p1)
 534                                 p2 = p2->next;
 535                 }
 536                 /* if p2 preceeds p1 in the circular list,
 537                  * try to merge them                    */
 538                 p1->next = p2->next; p2->next = p1;
 539                 if (p2 <= p1 && merge(p2,p1))
 540                         p1 = p2;
 541                 p2 = p1->next;
 542                 /* p1 preceeds p2 in the circular list */
 543                 if (p2 > p1) merge(p1,p2);
 544         }
 545         if (p1 >= p1->next)
 546                 _highp = p1;
 547         _lastp = p1;
 548         *pp = (struct adm *) 0;
 549 }
 550 \0efl.c\0\0\0\0\0\0\0\0\0\0\0\0\0\ 2\ 2�\ 1\0\0L\ 3/* $Id: efl.c,v 2.2 1994/06/24 12:31:39 ceriel Exp $ */
 551 /*
 552  * (c) copyright 1983 by the Vrije Universiteit, Amsterdam, The Netherlands.
 553  *
 554  *          This product is part of the Amsterdam Compiler Kit.
 555  *
 556  * Permission to use, sell, duplicate or disclose this software must be
 557  * obtained in writing. Requests for such permissions may be sent to
 558  *
 559  *      Dr. Andrew S. Tanenbaum
 560  *      Wiskundig Seminarium
 561  *      Vrije Universiteit
 562  *      Postbox 7161
 563  *      1007 MC Amsterdam
 564  *      The Netherlands
 565  *
 566  */
 567
 568 /* Author: J.W. Stevenson */
 569
 570 #include        <pc_file.h>
 571 #include        <pc_err.h>
 572
 573 extern struct file      *_curfil;
 574 extern                  _trp();
 575 extern                  _incpt();
 576
 577 int _efl(f) struct file *f; {
 578
 579         _curfil = f;
 580         if ((f->flags & 0377) != MAGIC)
 581                 _trp(EBADF);
 582         if ((f->flags & (WINDOW|WRBIT|EOFBIT)) == 0)
 583                 _incpt(f);
 584         return((f->flags & EOFBIT) != 0);
 585 }
 586 eln.c\0\0\0\0\0\0\0\0\0\0\0\0\0\ 2\ 2�\ 1\0\0�\ 2/* $Id: eln.c,v 2.2 1994/06/24 12:31:42 ceriel Exp $ */
 587 /*
 588  * (c) copyright 1983 by the Vrije Universiteit, Amsterdam, The Netherlands.
 589  *
 590  *          This product is part of the Amsterdam Compiler Kit.
 591  *
 592  * Permission to use, sell, duplicate or disclose this software must be
 593  * obtained in writing. Requests for such permissions may be sent to
 594  *
 595  *      Dr. Andrew S. Tanenbaum
 596  *      Wiskundig Seminarium
 597  *      Vrije Universiteit
 598  *      Postbox 7161
 599  *      1007 MC Amsterdam
 600  *      The Netherlands
 601  *
 602  */
 603
 604 /* Author: J.W. Stevenson */
 605
 606 #include        <pc_file.h>
 607 #include        <pc_err.h>
 608
 609 extern          _trp();
 610 extern          _rf();
 611
 612 int _eln(f) struct file *f; {
 613
 614         _rf(f);
 615         if (f->flags & EOFBIT)
 616                 _trp(EEOF);
 617         return((f->flags & ELNBIT) != 0);
 618 }
 619 encaps.e\0\0\0\0\0\0\0\0\0\0\ 2\ 2�\ 1\0\0[\v#
 620
 621
 622 ; $Id: encaps.e,v 2.2 1994/06/24 12:31:44 ceriel Exp $
 623 ;  (c) copyright 1983 by the Vrije Universiteit, Amsterdam, The Netherlands.
 624 ;
 625 ;           This product is part of the Amsterdam Compiler Kit.
 626 ;
 627 ;  Permission to use, sell, duplicate or disclose this software must be
 628 ;  obtained in writing. Requests for such permissions may be sent to
 629 ;
 630 ;       Dr. Andrew S. Tanenbaum
 631 ;       Wiskundig Seminarium
 632 ;       Vrije Universiteit
 633 ;       Postbox 7161
 634 ;       1007 MC Amsterdam
 635 ;       The Netherlands
 636 ;
 637
 638  mes 2,EM_WSIZE,EM_PSIZE
 639
 640 ; procedure encaps(procedure p; procedure(q(n:integer));
 641 ; {call q if a trap occurs during the execution of p}
 642 ; {if q returns, continue execution of p}
 643
 644
 645  inp $handler
 646
 647 #define PIISZ   2*EM_PSIZE
 648
 649 #define PARG    0
 650 #define QARG    PIISZ
 651 #define E_ELB   -EM_PSIZE
 652 #define E_EHA   -2*EM_PSIZE
 653
 654 ; encaps is called with two parameters:
 655 ;       - procedure instance identifier of q (QARG)
 656 ;       - procedure instance identifier of p (PARG)
 657 ; and two local variables:
 658 ;       - the lb of the previous encaps      (E_ELB)
 659 ;       - the procedure identifier of the previous handler (E_EHA)
 660 ;
 661 ; One static variable:
 662 ;       - the lb of the currently active encaps (enc_lb)
 663
 664 enc_lb
 665         bss EM_PSIZE,0,0
 666
 667  exp $encaps
 668  pro $encaps,PIISZ
 669  ; save lb of previous encaps
 670  lae enc_lb
 671  loi EM_PSIZE
 672  lal E_ELB
 673  sti EM_PSIZE
 674  ; set new lb
 675  lxl 0
 676  lae enc_lb
 677  sti EM_PSIZE
 678  ; save old handler id while setting up the new handler
 679  lpi $handler
 680  sig
 681  lal E_EHA
 682  sti EM_PSIZE
 683  ; handler is ready, p can be called
 684  ; p doesn't expect parameters except possibly the static link
 685  ; always passing the link won't hurt
 686  lal PARG
 687  loi PIISZ
 688  cai
 689  asp EM_PSIZE
 690  ; reinstate old handler
 691  lal E_ELB
 692  loi EM_PSIZE
 693  lae enc_lb
 694  sti EM_PSIZE
 695  lal E_EHA
 696  loi EM_PSIZE
 697  sig
 698  asp EM_PSIZE
 699  ret 0
 700  end ?
 701
 702 #define TRAP    0
 703 #define H_ELB   -EM_PSIZE
 704
 705 ; handler is called with one parameter:
 706 ;       - trap number (TRAP)
 707 ; one local variable
 708 ;       - the current LB of the enclosing encaps (H_ELB)
 709
 710
 711  pro $handler,EM_PSIZE
 712  ; save LB of nearest encaps
 713  lae enc_lb
 714  loi EM_PSIZE
 715  lal H_ELB
 716  sti EM_PSIZE
 717  ; fetch setting for previous encaps via LB of nearest
 718  lal H_ELB
 719  loi EM_PSIZE
 720  adp E_ELB
 721  loi EM_PSIZE   ; LB of previous encaps
 722  lae enc_lb
 723  sti EM_PSIZE
 724  lal H_ELB
 725  loi EM_PSIZE
 726  adp E_EHA
 727  loi EM_PSIZE   ; previous handler
 728  sig
 729  asp EM_PSIZE
 730  ; previous handler is re-instated, time to call Q
 731  lol TRAP       ; the one and only real parameter
 732  lal H_ELB
 733  loi EM_PSIZE
 734  lpb            ; argument base of enclosing encaps
 735  adp QARG
 736  loi PIISZ
 737  exg EM_PSIZE
 738  dup EM_PSIZE   ; The static link is now on top
 739  zer EM_PSIZE
 740  cmp
 741  zeq *1
 742  ; non-zero LB
 743  exg EM_PSIZE
 744  cai
 745  asp EM_WSIZE+EM_PSIZE
 746  bra *2
 747 1
 748  ; zero LB
 749  asp EM_PSIZE
 750  cai
 751  asp EM_WSIZE
 752 2
 753  ; now reinstate handler for continued execution of p
 754  lal H_ELB
 755  loi EM_PSIZE
 756  lae enc_lb
 757  sti EM_PSIZE
 758  lpi $handler
 759  sig
 760  asp EM_PSIZE
 761  rtt
 762  end ?
 763 \0exp.c\0.e\0\0\0\0\0\0\0\0\0\0\ 2\ 2�\ 1\0\0`\b/*
 764  * (c) copyright 1988 by the Vrije Universiteit, Amsterdam, The Netherlands.
 765  * See the copyright notice in the ACK home directory, in the file "Copyright".
 766  *
 767  * Author: Ceriel J.H. Jacobs
 768  */
 769
 770 /* $Id: exp.c,v 2.11 1994/06/24 12:31:48 ceriel Exp $ */
 771 #define __NO_DEFS
 772 #include <math.h>
 773 #include <pc_err.h>
 774 extern  _trp();
 775
 776 #if __STDC__
 777 #include <float.h>
 778 #include <pc_math.h>
 779 #define M_MIN_D DBL_MIN
 780 #define M_MAX_D DBL_MAX
 781 #define M_DMINEXP DBL_MIN_EXP
 782 #endif
 783 #undef HUGE
 784 #define HUGE    1e1000
 785
 786 static double
 787 Ldexp(fl,exp)
 788         double fl;
 789         int exp;
 790 {
 791         extern double _fef();
 792         int sign = 1;
 793         int currexp;
 794
 795         if (fl<0) {
 796                 fl = -fl;
 797                 sign = -1;
 798         }
 799         fl = _fef(fl,&currexp);
 800         exp += currexp;
 801         if (exp > 0) {
 802                 while (exp>30) {
 803                         fl *= (double) (1L << 30);
 804                         exp -= 30;
 805                 }
 806                 fl *= (double) (1L << exp);
 807         }
 808         else    {
 809                 while (exp<-30) {
 810                         fl /= (double) (1L << 30);
 811                         exp += 30;
 812                 }
 813                 fl /= (double) (1L << -exp);
 814         }
 815         return sign * fl;
 816 }
 817
 818 double
 819 _exp(x)
 820         double x;
 821 {
 822         /*      Algorithm and coefficients from:
 823                         "Software manual for the elementary functions"
 824                         by W.J. Cody and W. Waite, Prentice-Hall, 1980
 825         */
 826
 827         static double p[] = {
 828                 0.25000000000000000000e+0,
 829                 0.75753180159422776666e-2,
 830                 0.31555192765684646356e-4
 831         };
 832
 833         static double q[] = {
 834                 0.50000000000000000000e+0,
 835                 0.56817302698551221787e-1,
 836                 0.63121894374398503557e-3,
 837                 0.75104028399870046114e-6
 838         };
 839         double  xn, g;
 840         int     n;
 841         int     negative = x < 0;
 842
 843         if (x <= M_LN_MIN_D) {
 844                 g = M_MIN_D/4.0;
 845
 846                 if (g != 0.0) {
 847                         /* unnormalized numbers apparently exist */
 848                         if (x < (M_LN2 * (M_DMINEXP - 53))) return 0.0;
 849                 }
 850                 else {
 851                         if (x < M_LN_MIN_D) return 0.0;
 852                         return M_MIN_D;
 853                 }
 854         }
 855         if (x >= M_LN_MAX_D) {
 856                 if (x > M_LN_MAX_D) {
 857                         _trp(EEXP);
 858                         return HUGE;
 859                 }
 860                 return M_MAX_D;
 861         }
 862         if (negative) x = -x;
 863
 864         n = x * M_LOG2E + 0.5;  /* 1/ln(2) = log2(e), 0.5 added for rounding */
 865         xn = n;
 866         {
 867                 double  x1 = (long) x;
 868                 double  x2 = x - x1;
 869
 870                 g = ((x1-xn*0.693359375)+x2) - xn*(-2.1219444005469058277e-4);
 871         }
 872         if (negative) {
 873                 g = -g;
 874                 n = -n;
 875         }
 876         xn = g * g;
 877         x = g * POLYNOM2(xn, p);
 878         n += 1;
 879         return (Ldexp(0.5 + x/(POLYNOM3(xn, q) - x), n));
 880 }
 881 get.c\0.e\0\0\0\0\0\0\0\0\0\0\ 2\ 2�\ 1\0\0�\ 2/* $Id: get.c,v 2.3 1994/06/24 12:31:56 ceriel Exp $ */
 882 /*
 883  * (c) copyright 1983 by the Vrije Universiteit, Amsterdam, The Netherlands.
 884  *
 885  *          This product is part of the Amsterdam Compiler Kit.
 886  *
 887  * Permission to use, sell, duplicate or disclose this software must be
 888  * obtained in writing. Requests for such permissions may be sent to
 889  *
 890  *      Dr. Andrew S. Tanenbaum
 891  *      Wiskundig Seminarium
 892  *      Vrije Universiteit
 893  *      Postbox 7161
 894  *      1007 MC Amsterdam
 895  *      The Netherlands
 896  *
 897  */
 898
 899 #include        <pc_file.h>
 900 #include        <pc_err.h>
 901
 902 extern          _rf();
 903 extern          _trp();
 904
 905 _get(f) struct file *f; {
 906
 907         _rf(f);
 908         if (f->flags&EOFBIT)
 909                 _trp(EEOF);
 910         f->flags &= ~WINDOW;
 911 }
 912 igto.e\0.e\0\0\0\0\0\0\0\0\0\0\ 2\ 2�\ 1\0\0�\ 6#
 913 ; $Id: gto.e,v 2.2 1994/06/24 12:31:59 ceriel Exp $
 914 ;  (c) copyright 1983 by the Vrije Universiteit, Amsterdam, The Netherlands.
 915 ;
 916 ;           This product is part of the Amsterdam Compiler Kit.
 917 ;
 918 ;  Permission to use, sell, duplicate or disclose this software must be
 919 ;  obtained in writing. Requests for such permissions may be sent to
 920 ;
 921 ;       Dr. Andrew S. Tanenbaum
 922 ;       Wiskundig Seminarium
 923 ;       Vrije Universiteit
 924 ;       Postbox 7161
 925 ;       1007 MC Amsterdam
 926 ;       The Netherlands
 927 ;
 928
 929 /* Author: J.W. Stevenson */
 930
 931
 932  mes 2,EM_WSIZE,EM_PSIZE
 933
 934 #define TARLB   0
 935 #define DESCR   EM_PSIZE
 936
 937 #define NEWPC   0
 938 #define SAVSP   EM_PSIZE
 939
 940 #define D_PC    0
 941 #define D_SP    EM_PSIZE
 942 #define D_LB    EM_PSIZE+EM_PSIZE
 943
 944 #define LOCLB   -EM_PSIZE
 945
 946 ; _gto is called with two arguments:
 947 ;       - pointer to the label descriptor (DESCR)
 948 ;       - local base (LB) of target procedure (TARLB)
 949 ; the label descriptor contains two items:
 950 ;       - label address i.e. new PC (NEWPC)
 951 ;       - offset in target procedure frame (SAVSP)
 952 ; using this offset and the LB of the target procedure, the address of
 953 ; of local variable of the target procedure is constructed.
 954 ; the target procedure must have stored the correct target SP there.
 955
 956 descr
 957  bss 3*EM_PSIZE,0,0
 958
 959  exp $_gto
 960  pro $_gto,EM_PSIZE
 961  lal DESCR
 962  loi EM_PSIZE
 963  adp NEWPC
 964  loi EM_PSIZE
 965  lae descr+D_PC
 966  sti EM_PSIZE
 967  lal TARLB
 968  loi EM_PSIZE
 969  zer EM_PSIZE
 970  cmp
 971  zeq *1
 972  lal TARLB
 973  loi EM_PSIZE
 974  bra *2
 975 1
 976  lae _m_lb
 977  loi EM_PSIZE
 978 2
 979  lal LOCLB
 980  sti EM_PSIZE
 981  lal LOCLB
 982  loi EM_PSIZE
 983  lal DESCR
 984  loi EM_PSIZE
 985  adp SAVSP
 986  loi EM_WSIZE           ; or EM_PSIZE ?
 987  ads EM_WSIZE           ; or EM_PSIZE ?
 988  loi EM_PSIZE
 989  lae descr+D_SP
 990  sti EM_PSIZE
 991  lal LOCLB
 992  loi EM_PSIZE
 993  lae descr+D_LB
 994  sti EM_PSIZE
 995  gto descr
 996  end ?
 997 _hlt.c\0.e\0\0\0\0\0\0\0\0\0\0\ 2\ 2�\ 1\0\0\e\ 3/* $Id: hlt.c,v 2.4 1994/06/24 12:32:06 ceriel Exp $ */
 998 /*
 999  * (c) copyright 1983 by the Vrije Universiteit, Amsterdam, The Netherlands.
1000  *
1001  *          This product is part of the Amsterdam Compiler Kit.
1002  *
1003  * Permission to use, sell, duplicate or disclose this software must be
1004  * obtained in writing. Requests for such permissions may be sent to
1005  *
1006  *      Dr. Andrew S. Tanenbaum
1007  *      Wiskundig Seminarium
1008  *      Vrije Universiteit
1009  *      Postbox 7161
1010  *      1007 MC Amsterdam
1011  *      The Netherlands
1012  *
1013  */
1014
1015 /* Author: J.W. Stevenson */
1016
1017 #include        <pc_file.h>
1018
1019 extern struct file      **_extfl;
1020 extern int              _extflc;
1021 extern                  _cls();
1022 extern                  _exit();
1023
1024 _hlt(ecode) int ecode; {
1025         int i;
1026
1027         for (i = 0; i < _extflc; i++)
1028                 if (_extfl[i] != (struct file *) 0)
1029                         _cls(_extfl[i]);
1030         _exit(ecode);
1031 }
1032 ;ini.c\0.e\0\0\0\0\0\0\0\0\0\0\ 2\ 2�\ 1\0\0%\a/* $Id: ini.c,v 2.6 1994/06/24 12:32:15 ceriel Exp $ */
1033 /*
1034  * (c) copyright 1983 by the Vrije Universiteit, Amsterdam, The Netherlands.
1035  *
1036  *          This product is part of the Amsterdam Compiler Kit.
1037  *
1038  * Permission to use, sell, duplicate or disclose this software must be
1039  * obtained in writing. Requests for such permissions may be sent to
1040  *
1041  *      Dr. Andrew S. Tanenbaum
1042  *      Wiskundig Seminarium
1043  *      Vrije Universiteit
1044  *      Postbox 7161
1045  *      1007 MC Amsterdam
1046  *      The Netherlands
1047  *
1048  */
1049
1050 /* Author: J.W. Stevenson */
1051
1052 #include        <pc_file.h>
1053 #include        <pc_err.h>
1054
1055 extern          (*_sig())();
1056 extern          _catch();
1057 #ifndef CPM
1058 extern int      _gtty();
1059 #endif
1060
1061 struct file     **_extfl;
1062 int             _extflc;        /* number of external files */
1063 char            *_m_lb;         /* LB of _m_a_i_n */
1064 struct file     *_curfil;       /* points to file struct in case of errors */
1065 int             _pargc;
1066 char            **_pargv;
1067 char            **_penvp;
1068 int             _fp_hook = 1;   /* This is for Minix, but does not harm others */
1069
1070 _ini(args,c,p,mainlb) char *args,*mainlb; int c; struct file **p; {
1071         struct file *f;
1072         char buf[128];
1073
1074         _pargc= *(int *)args; args += sizeof (int);
1075         _pargv= *(char ***)args; args += sizeof (char **);
1076         _penvp= *(char ***)args;
1077         _sig(_catch);
1078         _extfl = p;
1079         _extflc = c;
1080         if( !c ) return;
1081         _m_lb = mainlb;
1082         if ( (f = _extfl[0]) != (struct file *) 0) {
1083                 f->ptr = f->bufadr;
1084                 f->flags = MAGIC|TXTBIT;
1085                 f->fname = "INPUT";
1086                 f->ufd = 0;
1087                 f->size = 1;
1088                 f->count = 0;
1089                 f->buflen = PC_BUFLEN;
1090         }
1091         if ( (f = _extfl[1]) != (struct file *) 0) {
1092                 f->ptr = f->bufadr;
1093                 f->flags = MAGIC|TXTBIT|WRBIT|EOFBIT|ELNBIT;
1094                 f->fname = "OUTPUT";
1095                 f->ufd = 1;
1096                 f->size = 1;
1097 #ifdef CPM
1098                 f->count = 1;
1099 #else
1100                 f->count = (_gtty(1,buf) >= 0 ? 1 : PC_BUFLEN);
1101 #endif
1102                 f->buflen = f->count;
1103         }
1104 }
1105 *catch.c\0\0\0\0\0\0\0\0\0\0\0\ 2\ 2�\ 1\0\0D\r/* $Id: catch.c,v 2.10 1994/11/14 11:46:58 ceriel Exp $ */
1106 /*
1107  * (c) copyright 1983 by the Vrije Universiteit, Amsterdam, The Netherlands.
1108  *
1109  *          This product is part of the Amsterdam Compiler Kit.
1110  *
1111  * Permission to use, sell, duplicate or disclose this software must be
1112  * obtained in writing. Requests for such permissions may be sent to
1113  *
1114  *      Dr. Andrew S. Tanenbaum
1115  *      Wiskundig Seminarium
1116  *      Vrije Universiteit
1117  *      Postbox 7161
1118  *      1007 MC Amsterdam
1119  *      The Netherlands
1120  *
1121  */
1122
1123 #include        <em_abs.h>
1124 #include        <pc_err.h>
1125 #include        <pc_file.h>
1126
1127 /* to make it easier to patch ... */
1128 extern struct file      *_curfil;
1129
1130 static struct errm {
1131         int errno;
1132         char *errmes;
1133 } errors[] = {
1134         { EARRAY,       "array bound error"},
1135         { ERANGE,       "range bound error"},
1136         { ESET,         "set bound error"},
1137         { EIOVFL,       "integer overflow"},
1138         { EFOVFL,       "real overflow"},
1139         { EFUNFL,       "real underflow"},
1140         { EIDIVZ,       "divide by 0"},
1141         { EFDIVZ,       "divide by 0.0"},
1142         { EIUND,        "undefined integer"},
1143         { EFUND,        "undefined real"},
1144         { ECONV,        "conversion error"},
1145
1146         { ESTACK,       "stack overflow"},
1147         { EHEAP,        "heap overflow"},
1148         { EILLINS,      "illegal instruction"},
1149         { EODDZ,        "illegal size argument"},
1150         { ECASE,        "case error"},
1151         { EMEMFLT,      "addressing non existent memory"},
1152         { EBADPTR,      "bad pointer used"},
1153         { EBADPC,       "program counter out of range"},
1154         { EBADLAE,      "bad argument of lae"},
1155         { EBADMON,      "bad monitor call"},
1156         { EBADLIN,      "argument if LIN too high"},
1157         { EBADGTO,      "GTO descriptor error"},
1158
1159         { EARGC,        "more args expected" },
1160         { EEXP,         "error in exp" },
1161         { ELOG,         "error in ln" },
1162         { ESQT,         "error in sqrt" },
1163         { EASS,         "assertion failed" },
1164         { EPACK,        "array bound error in pack" },
1165         { EUNPACK,      "array bound error in unpack" },
1166         { EMOD,         "only positive j in 'i mod j'" },
1167         { EBADF,        "file not yet open" },
1168         { EFREE,        "dispose error" },
1169         { EFUNASS,      "function not assigned" },
1170         { EWIDTH,       "illegal field width" },
1171
1172         { EWRITEF,      "not writable" },
1173         { EREADF,       "not readable" },
1174         { EEOF,         "end of file" },
1175         { EFTRUNC,      "truncated" },
1176         { ERESET,       "reset error" },
1177         { EREWR,        "rewrite error" },
1178         { ECLOSE,       "close error" },
1179         { EREAD,        "read error" },
1180         { EWRITE,       "write error" },
1181         { EDIGIT,       "digit expected" },
1182         { EASCII,       "non-ASCII char read" },
1183         { -1,           0}
1184 };
1185
1186 extern int              _pargc;
1187 extern char             **_pargv;
1188 extern char             **_penvp;
1189
1190 extern char             *_hol0();
1191 extern                  _trp();
1192 extern                  _exit();
1193 extern int              _write();
1194
1195 _catch(erno) unsigned erno; {
1196         register struct errm *ep = &errors[0];
1197         char *p,*q,*s,**qq;
1198         char buf[20];
1199         unsigned i;
1200         int j = erno;
1201         char *pp[11];
1202         char xbuf[100];
1203
1204         qq = pp;
1205         if (p = FILN)
1206                 *qq++ = p;
1207         else
1208                 *qq++ = _pargv[0];
1209
1210         while (ep->errno != erno && ep->errmes != 0) ep++;
1211         p = buf;
1212         s = xbuf;
1213         if (i = LINO) {
1214                 *qq++ = ", ";
1215                 do
1216                         *p++ = i % 10 + '0';
1217                 while (i /= 10);
1218                 while (p > buf) *s++ = *--p;
1219         }
1220         *s++ = ':';
1221         *s++ = ' ';
1222         *s++ = '\0';
1223         *qq++ = xbuf;
1224         if ((erno & ~037) == 0140 && (_curfil->flags&0377)==MAGIC) {
1225                 /* file error */
1226                 *qq++ = "file ";
1227                 *qq++ = _curfil->fname;
1228                 *qq++ = ": ";
1229         }
1230         if (ep->errmes) *qq++ = ep->errmes;
1231         else {
1232                 *qq++ = "error number ";
1233                 *qq++ = s;
1234                 p = buf;
1235                 if (j < 0) {
1236                         j = -j;
1237                         *s++ = '-';
1238                 }
1239                 do
1240                         *p++ = j % 10 + '0';
1241                 while (j /= 10);
1242                 while (p > buf) *s++ = *--p;
1243                 *s = 0;
1244         }
1245         *qq++ = "\n";
1246         *qq = 0;
1247         qq = pp;
1248         while (q = *qq++) {
1249                 p = q;
1250                 while (*p)
1251                         p++;
1252                 if (_write(2,q,(int)(p-q)) < 0)
1253                         ;
1254         }
1255         _exit(erno+1);
1256 error:
1257         _trp(erno);
1258 }
1259 log.c\0c\0\0\0\0\0\0\0\0\0\0\0\ 2\ 2�\ 1\0\0�\ 4/*
1260  * (c) copyright 1988 by the Vrije Universiteit, Amsterdam, The Netherlands.
1261  * See the copyright notice in the ACK home directory, in the file "Copyright".
1262  *
1263  * Author: Ceriel J.H. Jacobs
1264  */
1265
1266 /* $Id: log.c,v 2.8 1994/06/24 12:32:18 ceriel Exp $ */
1267
1268 #define __NO_DEFS
1269 #include <math.h>
1270 #include <pc_err.h>
1271
1272 #if __STDC__
1273 #include <pc_math.h>
1274 #include <float.h>
1275 #endif
1276 #undef HUGE
1277 #define HUGE    1e1000
1278
1279 double
1280 _log(x)
1281         double  x;
1282 {
1283         /*      Algorithm and coefficients from:
1284                         "Software manual for the elementary functions"
1285                         by W.J. Cody and W. Waite, Prentice-Hall, 1980
1286         */
1287         static double a[] = {
1288                 -0.64124943423745581147e2,
1289                  0.16383943563021534222e2,
1290                 -0.78956112887491257267e0
1291         };
1292         static double b[] = {
1293                 -0.76949932108494879777e3,
1294                  0.31203222091924532844e3,
1295                 -0.35667977739034646171e2,
1296                  1.0
1297         };
1298
1299         extern double   _fef();
1300         double  znum, zden, z, w;
1301         int     exponent;
1302
1303         if (x <= 0) {
1304                 _trp(ELOG);
1305                 return -HUGE;
1306         }
1307
1308         x = _fef(x, &exponent);
1309         if (x > M_1_SQRT2) {
1310                 znum = (x - 0.5) - 0.5;
1311                 zden = x * 0.5 + 0.5;
1312         }
1313         else {
1314                 znum = x - 0.5;
1315                 zden = znum * 0.5 + 0.5;
1316                 exponent--;
1317         }
1318         z = znum/zden; w = z * z;
1319         x = z + z * w * (POLYNOM2(w,a)/POLYNOM3(w,b));
1320         z = exponent;
1321         x += z * (-2.121944400546905827679e-4);
1322         return x + z * 0.693359375;
1323 }
1324 Amdi.c\0c\0\0\0\0\0\0\0\0\0\0\0\ 2\ 2�\ 1\0\0�\ 4/* $Id: mdi.c,v 2.4 1994/06/24 12:32:22 ceriel Exp $ */
1325 /*
1326  * (c) copyright 1983 by the Vrije Universiteit, Amsterdam, The Netherlands.
1327  *
1328  *          This product is part of the Amsterdam Compiler Kit.
1329  *
1330  * Permission to use, sell, duplicate or disclose this software must be
1331  * obtained in writing. Requests for such permissions may be sent to
1332  *
1333  *      Dr. Andrew S. Tanenbaum
1334  *      Wiskundig Seminarium
1335  *      Vrije Universiteit
1336  *      Postbox 7161
1337  *      1007 MC Amsterdam
1338  *      The Netherlands
1339  *
1340  */
1341
1342 /* Author: J.W. Stevenson */
1343
1344 #include        <pc_err.h>
1345
1346 extern          _trp();
1347
1348 int _mdi(j,i) int j,i; {
1349
1350         if (j <= 0)
1351                 _trp(EMOD);
1352         i = i % j;
1353         if (i < 0)
1354                 i += j;
1355         return(i);
1356 }
1357
1358 long _mdil(j,i) long j,i; {
1359
1360         if (j <= 0)
1361                 _trp(EMOD);
1362         i = i % j;
1363         if (i < 0)
1364                 i += j;
1365         return(i);
1366 }
1367
1368 int _dvi(j, i) unsigned int j,i; {
1369         int neg = 0;
1370
1371         if ((int)j < 0) {
1372                 j = -(int)j; neg = 1;
1373         }
1374         if ((int)i < 0) {
1375                 i = -(int)i; neg = !neg;
1376         }
1377         i = i / j;
1378         if (neg) return -(int)i;
1379         return i;
1380 }
1381
1382 long _dvil(j, i) unsigned long j,i; {
1383         int neg = 0;
1384
1385         if ((long)j < 0) {
1386                 j = -(long)j; neg = 1;
1387         }
1388         if ((long)i < 0) {
1389                 i = -(long)i; neg = !neg;
1390         }
1391         i = i / j;
1392         if (neg) return -(long)i;
1393         return i;
1394 }
1395 7mdl.c\0c\0\0\0\0\0\0\0\0\0\0\0\ 2\ 2�\ 1\0\0�\ 2/* $Id: mdl.c,v 2.2 1994/06/24 12:32:24 ceriel Exp $ */
1396 /*
1397  * (c) copyright 1983 by the Vrije Universiteit, Amsterdam, The Netherlands.
1398  *
1399  *          This product is part of the Amsterdam Compiler Kit.
1400  *
1401  * Permission to use, sell, duplicate or disclose this software must be
1402  * obtained in writing. Requests for such permissions may be sent to
1403  *
1404  *      Dr. Andrew S. Tanenbaum
1405  *      Wiskundig Seminarium
1406  *      Vrije Universiteit
1407  *      Postbox 7161
1408  *      1007 MC Amsterdam
1409  *      The Netherlands
1410  *
1411  */
1412
1413 /* Author: J.W. Stevenson */
1414
1415 #include        <pc_err.h>
1416
1417 extern          _trp();
1418
1419 long _mdl(j,i) long j,i; {
1420
1421         if (j <= 0)
1422                 _trp(EMOD);
1423         i = i % j;
1424         if (i < 0)
1425                 i += j;
1426         return(i);
1427 }
1428 new.c\0c\0\0\0\0\0\0\0\0\0\0\0\ 2\ 2�\ 1\0\0\9d\ 5/* $Id: new.c,v 2.4 1994/06/24 12:32:28 ceriel Exp $ */
1429 /*
1430  * (c) copyright 1983 by the Vrije Universiteit, Amsterdam, The Netherlands.
1431  *
1432  *          This product is part of the Amsterdam Compiler Kit.
1433  *
1434  * Permission to use, sell, duplicate or disclose this software must be
1435  * obtained in writing. Requests for such permissions may be sent to
1436  *
1437  *      Dr. Andrew S. Tanenbaum
1438  *      Wiskundig Seminarium
1439  *      Vrije Universiteit
1440  *      Postbox 7161
1441  *      1007 MC Amsterdam
1442  *      The Netherlands
1443  *
1444  */
1445
1446 /* Author: J.W. Stevenson */
1447
1448 extern          _sav();
1449 extern          _rst();
1450
1451 #define assert(x)       /* nothing */
1452 #define UNDEF           0x8000
1453
1454 struct adm {
1455         struct adm      *next;
1456         int             size;
1457 };
1458
1459 struct adm      *_lastp = 0;
1460 struct adm      *_highp = 0;
1461
1462 _new(n,pp) int n; struct adm **pp; {
1463         struct adm *p,*q;
1464         int *ptmp;
1465
1466         n = ((n+sizeof(*p)-1) / sizeof(*p)) * sizeof(*p);
1467         if ((p = _lastp) != 0)
1468                 do {
1469                         q = p->next;
1470                         if (q->size >= n) {
1471                                 assert(q->size%sizeof(adm) == 0);
1472                                 if ((q->size -= n) == 0) {
1473                                         if (p == q)
1474                                                 p = 0;
1475                                         else
1476                                                 p->next = q->next;
1477                                         if (q == _highp)
1478                                                 _highp = p;
1479                                 }
1480                                 _lastp = p;
1481                                 p = (struct adm *)((char *)q + q->size);
1482                                 q = (struct adm *)((char *)p + n);
1483                                 goto initialize;
1484                         }
1485                         p = q;
1486                 } while (p != _lastp);
1487         /*no free block big enough*/
1488         _sav(&p);
1489         q = (struct adm *)((char *)p + n);
1490         _rst(&q);
1491 initialize:
1492         *pp = p;
1493         ptmp = (int *)p;
1494         while (ptmp < (int *)q)
1495                 *ptmp++ = UNDEF;
1496 }
1497         nobuff.c\0\0\0\0\0\0\0\0\0\0\ 2\ 2�\ 1\0\0\0\ 3/* $Id: nobuff.c,v 2.2 1994/06/24 12:32:34 ceriel Exp $ */
1498 /*
1499  * (c) copyright 1983 by the Vrije Universiteit, Amsterdam, The Netherlands.
1500  *
1501  *          This product is part of the Amsterdam Compiler Kit.
1502  *
1503  * Permission to use, sell, duplicate or disclose this software must be
1504  * obtained in writing. Requests for such permissions may be sent to
1505  *
1506  *      Dr. Andrew S. Tanenbaum
1507  *      Wiskundig Seminarium
1508  *      Vrije Universiteit
1509  *      Postbox 7161
1510  *      1007 MC Amsterdam
1511  *      The Netherlands
1512  *
1513  */
1514
1515 /* Author: J.W. Stevenson */
1516
1517 #include        <pc_file.h>
1518
1519 extern          _flush();
1520
1521 /* procedure nobuff(var f:file of ?); */
1522
1523 nobuff(f) struct file *f; {
1524
1525         if ((f->flags & (0377|WRBIT)) != (MAGIC|WRBIT))
1526                 return;
1527         _flush(f);
1528         f->count = f->buflen = f->size;
1529 }
1530 notext.c\0\0\0\0\0\0\0\0\0\0\ 2\ 2�\ 1\0\0R\ 2/* $Id: notext.c,v 2.3 1994/06/24 12:32:37 ceriel Exp $ */
1531 /*
1532  * (c) copyright 1983 by the Vrije Universiteit, Amsterdam, The Netherlands.
1533  *
1534  *          This product is part of the Amsterdam Compiler Kit.
1535  *
1536  * Permission to use, sell, duplicate or disclose this software must be
1537  * obtained in writing. Requests for such permissions may be sent to
1538  *
1539  *      Dr. Andrew S. Tanenbaum
1540  *      Wiskundig Seminarium
1541  *      Vrije Universiteit
1542  *      Postbox 7161
1543  *      1007 MC Amsterdam
1544  *      The Netherlands
1545  *
1546  */
1547
1548 #include        <pc_file.h>
1549
1550 notext(f) struct file *f; {
1551         f->flags &= ~TXTBIT;
1552 }
1553 opn.c\0.c\0\0\0\0\0\0\0\0\0\0\ 2\ 2�\ 1\0\0x       /* $Id: opn.c,v 2.6 1994/06/24 12:32:40 ceriel Exp $ */
1554 /*
1555  * (c) copyright 1983 by the Vrije Universiteit, Amsterdam, The Netherlands.
1556  *
1557  *          This product is part of the Amsterdam Compiler Kit.
1558  *
1559  * Permission to use, sell, duplicate or disclose this software must be
1560  * obtained in writing. Requests for such permissions may be sent to
1561  *
1562  *      Dr. Andrew S. Tanenbaum
1563  *      Wiskundig Seminarium
1564  *      Vrije Universiteit
1565  *      Postbox 7161
1566  *      1007 MC Amsterdam
1567  *      The Netherlands
1568  *
1569  */
1570
1571 /* Author: J.W. Stevenson */
1572
1573 #include        <pc_file.h>
1574 #include        <pc_err.h>
1575
1576 extern struct file      **_extfl;
1577 extern int              _extflc;
1578 extern struct file      *_curfil;
1579 extern int              _pargc;
1580 extern char             **_pargv;
1581 extern char             **_penvp;
1582
1583 extern                  _cls();
1584 extern                  _xcls();
1585 extern                  _trp();
1586 extern int              _getpid();
1587 extern int              _creat();
1588 extern int              _open();
1589 extern int              _close();
1590 extern int              _unlink();
1591 extern long             _lseek();
1592
1593 static int tmpfil() {
1594         static char namebuf[] = "/usr/tmp/plf.xxxxx";
1595         int i; char *p,*q;
1596
1597         i = _getpid();
1598         p = namebuf;
1599         q = p + 13;
1600         do
1601                 *q++ = (i & 07) + '0';
1602         while (i >>= 3);
1603         *q = '\0';
1604         if ((i = _creat(p,0644)) < 0)
1605                 if ((i = _creat(p += 4,0644)) < 0)
1606                         if ((i = _creat(p += 5,0644)) < 0)
1607                                 goto error;
1608         if (_close(i) != 0)
1609                 goto error;
1610         if ((i = _open(p,2)) < 0)
1611                 goto error;
1612         if (_unlink(p) != 0)
1613 error:          _trp(EREWR);
1614         return(i);
1615 }
1616
1617 static int initfl(descr,sz,f) int descr; int sz; struct file *f; {
1618         int i;
1619
1620         _curfil = f;
1621         if (sz == 0) {
1622                 sz++;
1623                 descr |= TXTBIT;
1624         }
1625         for (i=0; i<_extflc; i++)
1626                 if (f == _extfl[i])
1627                         break;
1628         if (i >= _extflc) {             /* local file */
1629                 f->fname = "LOCAL";
1630                 if ((descr & WRBIT) == 0 && (f->flags & 0377) == MAGIC) {
1631                         _xcls(f);
1632                         if (_lseek(f->ufd,(long)0,0) == -1)
1633                                 _trp(ERESET);
1634                 } else {
1635                         _cls(f);
1636                         f->ufd = tmpfil();
1637                 }
1638         } else {        /* external file */
1639                 if (--i <= 0)
1640                         return(0);
1641                 if (i >= _pargc)
1642                         _trp(EARGC);
1643                 f->fname = _pargv[i];
1644                 _cls(f);
1645                 if ((descr & WRBIT) == 0) {
1646                         if ((f->ufd = _open(f->fname,0)) < 0)
1647                                 _trp(ERESET);
1648                 } else {
1649                         if ((f->ufd = _creat(f->fname,0644)) < 0)
1650                                 _trp(EREWR);
1651                 }
1652         }
1653         f->buflen = (sz>PC_BUFLEN ? sz : PC_BUFLEN-PC_BUFLEN%sz);
1654         f->size = sz;
1655         f->ptr = f->bufadr;
1656         f->flags = descr;
1657         return(1);
1658 }
1659
1660 _opn(sz,f) int sz; struct file *f; {
1661
1662         if (initfl(MAGIC,sz,f))
1663                 f->count = 0;
1664 }
1665
1666 _cre(sz,f) int sz; struct file *f; {
1667
1668         if (initfl(WRBIT|EOFBIT|ELNBIT|MAGIC,sz,f))
1669                 f->count = f->buflen;
1670 }
1671 hol0.e\0c\0\0\0\0\0\0\0\0\0\0\ 2\ 2�\ 1\0\0x\ 2#
1672
1673 ; $Id: hol0.e,v 2.3 1994/06/24 12:32:09 ceriel Exp $
1674 ;
1675 ; (c) copyright 1983 by the Vrije Universiteit, Amsterdam, The Netherlands.
1676 ;
1677 ;          This product is part of the Amsterdam Compiler Kit.
1678 ;
1679 ; Permission to use, sell, duplicate or disclose this software must be
1680 ; obtained in writing. Requests for such permissions may be sent to
1681 ;
1682 ;      Dr. Andrew S. Tanenbaum
1683 ;      Wiskundig Seminarium
1684 ;      Vrije Universiteit
1685 ;      Postbox 7161
1686 ;      1007 MC Amsterdam
1687 ;      The Netherlands
1688 ;
1689 ;
1690
1691  mes 2,EM_WSIZE,EM_PSIZE
1692
1693 ; _hol0 return the address of the ABS block (hol0)
1694
1695  exp $_hol0
1696  pro $_hol0,0
1697  lae 0
1698  ret EM_PSIZE
1699  end ?
1700 pac.c\0\0c\0\0\0\0\0\0\0\0\0\0\ 2\ 2�\ 1\0\0/\ 5/* $Id: pac.c,v 2.6 1994/06/24 12:32:49 ceriel Exp $ */
1701 /*
1702  * (c) copyright 1983 by the Vrije Universiteit, Amsterdam, The Netherlands.
1703  *
1704  *          This product is part of the Amsterdam Compiler Kit.
1705  *
1706  * Permission to use, sell, duplicate or disclose this software must be
1707  * obtained in writing. Requests for such permissions may be sent to
1708  *
1709  *      Dr. Andrew S. Tanenbaum
1710  *      Wiskundig Seminarium
1711  *      Vrije Universiteit
1712  *      Postbox 7161
1713  *      1007 MC Amsterdam
1714  *      The Netherlands
1715  *
1716  */
1717
1718 /* Author: J.W. Stevenson */
1719
1720 #include        <pc_err.h>
1721
1722 extern          _trp();
1723
1724 #define assert(x)       /* nothing */
1725
1726 #ifndef EM_WSIZE
1727 #define EM_WSIZE _EM_WSIZE
1728 #endif
1729
1730 struct descr {
1731         int     low;
1732         int     diff;
1733         int     size;
1734 };
1735
1736 _pac(ad,zd,zp,i,ap) int i; struct descr *ad,*zd; char *zp,*ap; {
1737
1738         if (zd->diff > ad->diff ||
1739                         (i -= ad->low) < 0 ||
1740                         (i+zd->diff) > ad->diff)
1741                 _trp(EPACK);
1742         ap += (i * ad->size);
1743         i = (zd->diff + 1) * zd->size;
1744         if (zd->size == 1) {
1745                 int *aptmp = (int *)ap;
1746                 assert(ad->size == EM_WSIZE);
1747                 while (--i >= 0)
1748                         *zp++ = *aptmp++;
1749 #if EM_WSIZE > 2
1750         } else if (zd->size == 2) {
1751                 int *aptmp = (int *)ap;
1752                 short *zptmp = (short *) zp;
1753                 assert(ad->size == EM_WSIZE);
1754                 while (--i >= 0)
1755                         *zptmp++ = *aptmp++;
1756 #endif
1757         } else {
1758                 assert(ad->size == zd->size);
1759                 while (--i >= 0)
1760                         *zp++ = *ap++;
1761         }
1762 }
1763  pclose.c\0\0\0\0\0\0\0\0\0\0\ 2\ 2�\ 1\0\0\82\ 2/* $Id: pclose.c,v 2.3 1994/06/24 12:32:54 ceriel Exp $ */
1764 /*
1765  * (c) copyright 1983 by the Vrije Universiteit, Amsterdam, The Netherlands.
1766  *
1767  *          This product is part of the Amsterdam Compiler Kit.
1768  *
1769  * Permission to use, sell, duplicate or disclose this software must be
1770  * obtained in writing. Requests for such permissions may be sent to
1771  *
1772  *      Dr. Andrew S. Tanenbaum
1773  *      Wiskundig Seminarium
1774  *      Vrije Universiteit
1775  *      Postbox 7161
1776  *      1007 MC Amsterdam
1777  *      The Netherlands
1778  *
1779  */
1780
1781 #include        <pc_file.h>
1782
1783 extern          _cls();
1784
1785 /* procedure pclose(var f:file of ??); */
1786
1787 pclose(f) struct file *f; {
1788         _cls(f);
1789 }
1790 pcreat.c\0\0\0\0\0\0\0\0\0\0\ 2\ 2�\ 1\0\0�\ 3/* $Id: pcreat.c,v 2.4 1994/06/24 12:32:59 ceriel Exp $ */
1791 /*
1792  * (c) copyright 1983 by the Vrije Universiteit, Amsterdam, The Netherlands.
1793  *
1794  *          This product is part of the Amsterdam Compiler Kit.
1795  *
1796  * Permission to use, sell, duplicate or disclose this software must be
1797  * obtained in writing. Requests for such permissions may be sent to
1798  *
1799  *      Dr. Andrew S. Tanenbaum
1800  *      Wiskundig Seminarium
1801  *      Vrije Universiteit
1802  *      Postbox 7161
1803  *      1007 MC Amsterdam
1804  *      The Netherlands
1805  *
1806  */
1807
1808 /* Author: J.W. Stevenson */
1809
1810 #include        <pc_file.h>
1811 #include        <pc_err.h>
1812
1813 extern          _cls();
1814 extern          _trp();
1815 extern int      _creat();
1816
1817 /* procedure pcreat(var f:text; s:string); */
1818
1819 pcreat(f,s) struct file *f; char *s; {
1820
1821         _cls(f);        /* initializes _curfil */
1822         f->ptr = f->bufadr;
1823         f->flags = WRBIT|EOFBIT|ELNBIT|TXTBIT|MAGIC;
1824         f->fname = s;
1825         f->size = 1;
1826         f->count = PC_BUFLEN;
1827         f->buflen = PC_BUFLEN;
1828         if ((f->ufd = _creat(s,0644)) < 0)
1829                 _trp(EREWR);
1830 }
1831  pentry.c\0\0\0\0\0\0\0\0\0\0\ 2\ 2�\ 1\0\0�\ 2/* $Id: pentry.c,v 2.3 1994/06/24 12:33:03 ceriel Exp $ */
1832 /*
1833  * (c) copyright 1983 by the Vrije Universiteit, Amsterdam, The Netherlands.
1834  *
1835  *          This product is part of the Amsterdam Compiler Kit.
1836  *
1837  * Permission to use, sell, duplicate or disclose this software must be
1838  * obtained in writing. Requests for such permissions may be sent to
1839  *
1840  *      Dr. Andrew S. Tanenbaum
1841  *      Wiskundig Seminarium
1842  *      Vrije Universiteit
1843  *      Postbox 7161
1844  *      1007 MC Amsterdam
1845  *      The Netherlands
1846  *
1847  */
1848
1849 /* Author: J.W. Stevenson */
1850
1851 #include        <pc_file.h>
1852
1853 extern struct file      **_extfl;
1854 extern                  _wrs();
1855 extern                  _wrz();
1856 extern                  _wln();
1857
1858 procentry(name) char *name; {
1859         struct file *f;
1860
1861         f = _extfl[1];
1862         _wrs(5,"call ",f);
1863         _wrz(name,f);
1864         _wln(f);
1865 }
1866 perrno.c\0\0\0\0\0\0\0\0\0\0\ 2\ 2�\ 1\0\0d\ 2/* $Id: perrno.c,v 2.3 1994/06/24 12:33:08 ceriel Exp $ */
1867 /*
1868  * (c) copyright 1983 by the Vrije Universiteit, Amsterdam, The Netherlands.
1869  *
1870  *          This product is part of the Amsterdam Compiler Kit.
1871  *
1872  * Permission to use, sell, duplicate or disclose this software must be
1873  * obtained in writing. Requests for such permissions may be sent to
1874  *
1875  *      Dr. Andrew S. Tanenbaum
1876  *      Wiskundig Seminarium
1877  *      Vrije Universiteit
1878  *      Postbox 7161
1879  *      1007 MC Amsterdam
1880  *      The Netherlands
1881  *
1882  */
1883
1884 /* function perrno:integer; extern; */
1885
1886 extern int      errno;
1887
1888 int perrno() {
1889         return(errno);
1890 }
1891 pexit.c\0\0\0\0\0\0\0\0\0\0\0\ 2\ 2�\ 1\0\0�\ 2/* $Id: pexit.c,v 2.4 1994/06/24 12:33:14 ceriel Exp $ */
1892 /*
1893  * (c) copyright 1983 by the Vrije Universiteit, Amsterdam, The Netherlands.
1894  *
1895  *          This product is part of the Amsterdam Compiler Kit.
1896  *
1897  * Permission to use, sell, duplicate or disclose this software must be
1898  * obtained in writing. Requests for such permissions may be sent to
1899  *
1900  *      Dr. Andrew S. Tanenbaum
1901  *      Wiskundig Seminarium
1902  *      Vrije Universiteit
1903  *      Postbox 7161
1904  *      1007 MC Amsterdam
1905  *      The Netherlands
1906  *
1907  */
1908
1909 #include        <pc_file.h>
1910
1911 extern struct file      **_extfl;
1912 extern                  _wrs();
1913 extern                  _wrz();
1914 extern                  _wln();
1915
1916 procexit(name) char *name; {
1917         struct file *f;
1918
1919         f = _extfl[1];
1920         _wrs(5,"exit ",f);
1921         _wrz(name,f);
1922         _wln(f);
1923 }
1924 popen.c\0\0\0\0\0\0\0\0\0\0\0\ 2\ 2�\ 1\0\0�\ 3/* $Id: popen.c,v 2.4 1994/06/24 12:33:18 ceriel Exp $ */
1925 /*
1926  * (c) copyright 1983 by the Vrije Universiteit, Amsterdam, The Netherlands.
1927  *
1928  *          This product is part of the Amsterdam Compiler Kit.
1929  *
1930  * Permission to use, sell, duplicate or disclose this software must be
1931  * obtained in writing. Requests for such permissions may be sent to
1932  *
1933  *      Dr. Andrew S. Tanenbaum
1934  *      Wiskundig Seminarium
1935  *      Vrije Universiteit
1936  *      Postbox 7161
1937  *      1007 MC Amsterdam
1938  *      The Netherlands
1939  *
1940  */
1941
1942 /* Author: J.W. Stevenson */
1943
1944 #include        <pc_file.h>
1945 #include        <pc_err.h>
1946
1947 extern          _cls();
1948 extern          _trp();
1949 extern int      _open();
1950
1951 /* procedure popen(var f:text; s:string); */
1952
1953 popen(f,s) struct file *f; char *s; {
1954
1955         _cls(f);        /* initializes _curfil */
1956         f->ptr = f->bufadr;
1957         f->flags = TXTBIT|MAGIC;
1958         f->fname = s;
1959         f->size = 1;
1960         f->count = 0;
1961         f->buflen = PC_BUFLEN;
1962         if ((f->ufd = _open(s,0)) < 0)
1963                 _trp(ERESET);
1964 }
1965 cls.c\0c\0\0\0\0\0\0\0\0\0\0\0\ 2\ 2�\ 1\0\0�\ 4/* $Id: cls.c,v 2.3 1994/06/24 12:31:27 ceriel Exp $ */
1966 /*
1967  * (c) copyright 1983 by the Vrije Universiteit, Amsterdam, The Netherlands.
1968  *
1969  *          This product is part of the Amsterdam Compiler Kit.
1970  *
1971  * Permission to use, sell, duplicate or disclose this software must be
1972  * obtained in writing. Requests for such permissions may be sent to
1973  *
1974  *      Dr. Andrew S. Tanenbaum
1975  *      Wiskundig Seminarium
1976  *      Vrije Universiteit
1977  *      Postbox 7161
1978  *      1007 MC Amsterdam
1979  *      The Netherlands
1980  *
1981  */
1982
1983 /* Author: J.W. Stevenson */
1984
1985 #include        <pc_file.h>
1986 #include        <pc_err.h>
1987
1988 extern struct file      *_curfil;
1989 extern                  _trp();
1990 extern                  _flush();
1991 extern                  _outcpt();
1992 extern int              _close();
1993
1994 _xcls(f) struct file *f; {
1995
1996         if ((f->flags & WRBIT) == 0)
1997                 return;
1998         if ((f->flags & (TXTBIT|ELNBIT)) == TXTBIT) {
1999 #ifdef CPM
2000                 *f->ptr = '\r';
2001                 _outcpt(f);
2002 #endif
2003                 *f->ptr = '\n';
2004                 _outcpt(f);
2005         }
2006         _flush(f);
2007 }
2008
2009 _cls(f) struct file *f; {
2010 #ifdef MAYBE
2011         char *p;
2012 #endif
2013
2014         _curfil = f;
2015         if ((f->flags&0377) != MAGIC)
2016                 return;
2017 #ifdef MAYBE
2018         p = f->bufadr;
2019         if (f->ptr < p)
2020                 return;
2021         if (f->buflen <= 0)
2022                 return;
2023         p += f->buflen;
2024         if (f->ptr >= p)
2025                 return;
2026 #endif
2027         _xcls(f);
2028         if (_close(f->ufd) != 0)
2029                 _trp(ECLOSE);
2030         f->flags = 0;
2031 }
2032 +put.c\0c\0\0\0\0\0\0\0\0\0\0\0\ 2\ 2�\ 1\0\0p\ 2/* $Id: put.c,v 2.3 1994/06/24 12:33:24 ceriel Exp $ */
2033 /*
2034  * (c) copyright 1983 by the Vrije Universiteit, Amsterdam, The Netherlands.
2035  *
2036  *          This product is part of the Amsterdam Compiler Kit.
2037  *
2038  * Permission to use, sell, duplicate or disclose this software must be
2039  * obtained in writing. Requests for such permissions may be sent to
2040  *
2041  *      Dr. Andrew S. Tanenbaum
2042  *      Wiskundig Seminarium
2043  *      Vrije Universiteit
2044  *      Postbox 7161
2045  *      1007 MC Amsterdam
2046  *      The Netherlands
2047  *
2048  */
2049
2050 #include        <pc_file.h>
2051
2052 extern          _wf();
2053 extern          _outcpt();
2054
2055 _put(f) struct file *f; {
2056         _wf(f);
2057         _outcpt(f);
2058 }
2059 rdc.c\0c\0\0\0\0\0\0\0\0\0\0\0\ 2\ 2�\ 1\0\0\95\ 2/* $Id: rdc.c,v 2.3 1994/06/24 12:33:33 ceriel Exp $ */
2060 /*
2061  * (c) copyright 1983 by the Vrije Universiteit, Amsterdam, The Netherlands.
2062  *
2063  *          This product is part of the Amsterdam Compiler Kit.
2064  *
2065  * Permission to use, sell, duplicate or disclose this software must be
2066  * obtained in writing. Requests for such permissions may be sent to
2067  *
2068  *      Dr. Andrew S. Tanenbaum
2069  *      Wiskundig Seminarium
2070  *      Vrije Universiteit
2071  *      Postbox 7161
2072  *      1007 MC Amsterdam
2073  *      The Netherlands
2074  *
2075  */
2076
2077 #include        <pc_file.h>
2078
2079 extern          _rf();
2080 extern          _incpt();
2081
2082 int _rdc(f) struct file *f; {
2083         int c;
2084
2085         _rf(f);
2086         c = *f->ptr;
2087         _incpt(f);
2088         return(c);
2089 }
2090         rdl.c\0c\0\0\0\0\0\0\0\0\0\0\0\ 2\ 2�\ 1\0\0w\ 3/* $Id: rdl.c,v 2.3 1994/06/24 12:33:42 ceriel Exp $ */
2091 /*
2092  * (c) copyright 1983 by the Vrije Universiteit, Amsterdam, The Netherlands.
2093  *
2094  *          This product is part of the Amsterdam Compiler Kit.
2095  *
2096  * Permission to use, sell, duplicate or disclose this software must be
2097  * obtained in writing. Requests for such permissions may be sent to
2098  *
2099  *      Dr. Andrew S. Tanenbaum
2100  *      Wiskundig Seminarium
2101  *      Vrije Universiteit
2102  *      Postbox 7161
2103  *      1007 MC Amsterdam
2104  *      The Netherlands
2105  *
2106  */
2107
2108 /* Author: J.W. Stevenson */
2109
2110 #include        <pc_file.h>
2111
2112 extern          _rf();
2113 extern          _skipsp();
2114 extern int      _getsig();
2115 extern int      _fstdig();
2116 extern int      _nxtdig();
2117
2118 long _rdl(f) struct file *f; {
2119         int is_signed,ch; long l;
2120
2121         _rf(f);
2122         _skipsp(f);
2123         is_signed = _getsig(f);
2124         ch = _fstdig(f);
2125         l = 0;
2126         do
2127                 l = l*10 - ch;
2128         while ((ch = _nxtdig(f)) >= 0);
2129         return(is_signed ? l : -l);
2130 }
2131 prdr.c\0c\0\0\0\0\0\0\0\0\0\0\0\ 2\ 2�\ 1\0\0v\ 5/* $Id: rdr.c,v 2.3 1994/06/24 12:33:48 ceriel Exp $ */
2132 /*
2133  * (c) copyright 1983 by the Vrije Universiteit, Amsterdam, The Netherlands.
2134  *
2135  *          This product is part of the Amsterdam Compiler Kit.
2136  *
2137  * Permission to use, sell, duplicate or disclose this software must be
2138  * obtained in writing. Requests for such permissions may be sent to
2139  *
2140  *      Dr. Andrew S. Tanenbaum
2141  *      Wiskundig Seminarium
2142  *      Vrije Universiteit
2143  *      Postbox 7161
2144  *      1007 MC Amsterdam
2145  *      The Netherlands
2146  *
2147  */
2148
2149 /* Author: J.W. Stevenson */
2150
2151 #include        <pc_file.h>
2152
2153 #define BIG     1e17
2154
2155 extern          _rf();
2156 extern          _incpt();
2157 extern          _skipsp();
2158 extern int      _getsig();
2159 extern int      _getint();
2160 extern int      _fstdig();
2161 extern int      _nxtdig();
2162
2163 static double           r;
2164 static int              pow10;
2165
2166 static dig(ch) int ch; {
2167
2168         if (r>BIG)
2169                 pow10++;
2170         else
2171                 r = r*10.0 + ch;
2172 }
2173
2174 double _rdr(f) struct file *f; {
2175         int i; double e; int is_signed,ch;
2176
2177         r = 0;
2178         pow10 = 0;
2179         _rf(f);
2180         _skipsp(f);
2181         is_signed = _getsig(f);
2182         ch = _fstdig(f);
2183         do
2184                 dig(ch);
2185         while ((ch = _nxtdig(f)) >= 0);
2186         if (*f->ptr == '.') {
2187                 _incpt(f);
2188                 ch = _fstdig(f);
2189                 do {
2190                         dig(ch);
2191                         pow10--;
2192                 } while ((ch = _nxtdig(f)) >= 0);
2193         }
2194         if ((*f->ptr == 'e') || (*f->ptr == 'E')) {
2195                 _incpt(f);
2196                 pow10 += _getint(f);
2197         }
2198         if ((i = pow10) < 0)
2199                 i = -i;
2200         e = 1.0;
2201         while (--i >= 0)
2202                 e *= 10.0;
2203         if (pow10<0)
2204                 r /= e;
2205         else
2206                 r *= e;
2207         return(is_signed? -r : r);
2208 }
2209 rdi.c\0c\0\0\0\0\0\0\0\0\0\0\0\ 2\ 2�\ 1\0\0m\ 5/* $Id: rdi.c,v 2.3 1994/06/24 12:33:38 ceriel Exp $ */
2210 /*
2211  * (c) copyright 1983 by the Vrije Universiteit, Amsterdam, The Netherlands.
2212  *
2213  *          This product is part of the Amsterdam Compiler Kit.
2214  *
2215  * Permission to use, sell, duplicate or disclose this software must be
2216  * obtained in writing. Requests for such permissions may be sent to
2217  *
2218  *      Dr. Andrew S. Tanenbaum
2219  *      Wiskundig Seminarium
2220  *      Vrije Universiteit
2221  *      Postbox 7161
2222  *      1007 MC Amsterdam
2223  *      The Netherlands
2224  *
2225  */
2226
2227 /* Author: J.W. Stevenson */
2228
2229 #include        <pc_file.h>
2230 #include        <pc_err.h>
2231
2232 extern          _trp();
2233 extern          _rf();
2234 extern          _incpt();
2235
2236 _skipsp(f) struct file *f; {
2237         while ((*f->ptr == ' ') || (*f->ptr == '\t'))
2238                 _incpt(f);
2239 }
2240
2241 int _getsig(f) struct file *f; {
2242         int sign;
2243
2244         if ((sign = (*f->ptr == '-')) || *f->ptr == '+')
2245                 _incpt(f);
2246         return(sign);
2247 }
2248
2249 int _fstdig(f) struct file *f; {
2250         int ch;
2251
2252         ch = *f->ptr - '0';
2253         if ((unsigned) ch > 9) {
2254                 _trp(EDIGIT);
2255                 ch = 0;
2256         }
2257         return(ch);
2258 }
2259
2260 int _nxtdig(f) struct file *f; {
2261         int ch;
2262
2263         _incpt(f);
2264         ch = *f->ptr - '0';
2265         if ((unsigned) ch > 9)
2266                 return(-1);
2267         return(ch);
2268 }
2269
2270 int _getint(f) struct file *f; {
2271         int is_signed,i,ch;
2272
2273         is_signed = _getsig(f);
2274         ch = _fstdig(f);
2275         i = 0;
2276         do
2277                 i = i*10 - ch;
2278         while ((ch = _nxtdig(f)) >= 0);
2279         return(is_signed ? i : -i);
2280 }
2281
2282 int _rdi(f) struct file *f; {
2283         _rf(f);
2284         _skipsp(f);
2285         return(_getint(f));
2286 }
2287  rln.c\0c\0\0\0\0\0\0\0\0\0\0\0\ 2\ 2�\ 1\0\0�\ 2/* $Id: rln.c,v 2.3 1994/06/24 12:33:55 ceriel Exp $ */
2288 /*
2289  * (c) copyright 1983 by the Vrije Universiteit, Amsterdam, The Netherlands.
2290  *
2291  *          This product is part of the Amsterdam Compiler Kit.
2292  *
2293  * Permission to use, sell, duplicate or disclose this software must be
2294  * obtained in writing. Requests for such permissions may be sent to
2295  *
2296  *      Dr. Andrew S. Tanenbaum
2297  *      Wiskundig Seminarium
2298  *      Vrije Universiteit
2299  *      Postbox 7161
2300  *      1007 MC Amsterdam
2301  *      The Netherlands
2302  *
2303  */
2304
2305 #include        <pc_file.h>
2306
2307 extern          _rf();
2308 extern          _incpt();
2309
2310 _rln(f) struct file *f; {
2311
2312         _rf(f);
2313         while ((f->flags & ELNBIT) == 0)
2314                 _incpt(f);
2315         f->flags &= ~WINDOW;
2316 }
2317 rf.c\0\0c\0\0\0\0\0\0\0\0\0\0\0\ 2\ 2�\ 1\0\0\e\ 3/* $Id: rf.c,v 2.3 1994/06/24 12:33:52 ceriel Exp $ */
2318 /*
2319  * (c) copyright 1983 by the Vrije Universiteit, Amsterdam, The Netherlands.
2320  *
2321  *          This product is part of the Amsterdam Compiler Kit.
2322  *
2323  * Permission to use, sell, duplicate or disclose this software must be
2324  * obtained in writing. Requests for such permissions may be sent to
2325  *
2326  *      Dr. Andrew S. Tanenbaum
2327  *      Wiskundig Seminarium
2328  *      Vrije Universiteit
2329  *      Postbox 7161
2330  *      1007 MC Amsterdam
2331  *      The Netherlands
2332  *
2333  */
2334
2335 #include        <pc_file.h>
2336 #include        <pc_err.h>
2337
2338 extern struct file      *_curfil;
2339 extern                  _trp();
2340 extern                  _incpt();
2341
2342 _rf(f) struct file *f; {
2343
2344         _curfil = f;
2345         if ((f->flags&0377) != MAGIC)
2346                 _trp(EBADF);
2347         if (f->flags & WRBIT)
2348                 _trp(EREADF);
2349         if ((f->flags & WINDOW) == 0)
2350                 _incpt(f);
2351 }
2352 trnd.c\0c\0\0\0\0\0\0\0\0\0\0\0\ 2\ 2�\ 1\0\0C\ 2/* $Id: rnd.c,v 2.3 1994/06/24 12:33:58 ceriel Exp $ */
2353 /*
2354  * (c) copyright 1983 by the Vrije Universiteit, Amsterdam, The Netherlands.
2355  *
2356  *          This product is part of the Amsterdam Compiler Kit.
2357  *
2358  * Permission to use, sell, duplicate or disclose this software must be
2359  * obtained in writing. Requests for such permissions may be sent to
2360  *
2361  *      Dr. Andrew S. Tanenbaum
2362  *      Wiskundig Seminarium
2363  *      Vrije Universiteit
2364  *      Postbox 7161
2365  *      1007 MC Amsterdam
2366  *      The Netherlands
2367  *
2368  */
2369
2370 double _rnd(r) double r; {
2371         return(r + (r<0 ? -0.5 : 0.5));
2372 }
2373 csav.e\0c\0\0\0\0\0\0\0\0\0\0\0\ 2\ 2�\ 1\0\0\98\ 3#
2374 ; $Id: sav.e,v 2.2 1994/06/24 12:34:01 ceriel Exp $
2375 ;  (c) copyright 1983 by the Vrije Universiteit, Amsterdam, The Netherlands.
2376 ;
2377 ;           This product is part of the Amsterdam Compiler Kit.
2378 ;
2379 ;  Permission to use, sell, duplicate or disclose this software must be
2380 ;  obtained in writing. Requests for such permissions may be sent to
2381 ;
2382 ;       Dr. Andrew S. Tanenbaum
2383 ;       Wiskundig Seminarium
2384 ;       Vrije Universiteit
2385 ;       Postbox 7161
2386 ;       1007 MC Amsterdam
2387 ;       The Netherlands
2388 ;
2389
2390 /* Author: J.W. Stevenson */
2391
2392
2393  mes 2,EM_WSIZE,EM_PSIZE
2394
2395 #define PTRAD   0
2396
2397 #define HP      2
2398
2399 ; _sav called with one parameter:
2400 ;       - address of pointer variable (PTRAD)
2401
2402  exp $_sav
2403  pro $_sav,0
2404  lor HP
2405  lal PTRAD
2406  loi EM_PSIZE
2407  sti EM_PSIZE
2408  ret 0
2409  end ?
2410
2411 ; _rst is called with one parameter:
2412 ;       - address of pointer variable (PTRAD)
2413
2414  exp $_rst
2415  pro $_rst,0
2416  lal PTRAD
2417  loi EM_PSIZE
2418  loi EM_PSIZE
2419  str HP
2420  ret 0
2421  end ?
2422 sig.e\0c\0\0\0\0\0\0\0\0\0\0\0\ 2\ 2�\ 1\0\0?\ 3#define PROC    0
2423
2424 ; $Id: sig.e,v 2.4 1994/06/24 12:34:04 ceriel Exp $
2425 ;
2426 ; (c) copyright 1983 by the Vrije Universiteit, Amsterdam, The Netherlands.
2427 ;
2428 ;          This product is part of the Amsterdam Compiler Kit.
2429 ;
2430 ; Permission to use, sell, duplicate or disclose this software must be
2431 ; obtained in writing. Requests for such permissions may be sent to
2432 ;
2433 ;      Dr. Andrew S. Tanenbaum
2434 ;      Wiskundig Seminarium
2435 ;      Vrije Universiteit
2436 ;      Postbox 7161
2437 ;      1007 MC Amsterdam
2438 ;      The Netherlands
2439 ;
2440 ;
2441
2442  mes 2,EM_WSIZE,EM_PSIZE
2443
2444 ; _sig is called with one parameter:
2445 ;       - procedure instance identifier (PROC)
2446 ; and returns nothing.
2447 ; only the procedure identifier inside the PROC is used.
2448
2449  exp $_sig
2450  pro $_sig,0
2451  lal PROC
2452  loi EM_PSIZE
2453  sig
2454  asp EM_PSIZE
2455  ret 0                  ; ignore the result of sig
2456  end ?
2457 Dsin.c\0c\0\0\0\0\0\0\0\0\0\0\0\ 2\ 2�\ 1\0\0�\ 6/*
2458  * (c) copyright 1988 by the Vrije Universiteit, Amsterdam, The Netherlands.
2459  * See the copyright notice in the ACK home directory, in the file "Copyright".
2460  *
2461  * Author: Ceriel J.H. Jacobs
2462  */
2463
2464 /* $Id: sin.c,v 2.7 1994/06/24 12:34:07 ceriel Exp $ */
2465
2466 #define __NO_DEFS
2467 #include <math.h>
2468
2469 #if __STDC__
2470 #include <pc_math.h>
2471 #endif
2472
2473 static double
2474 sinus(x, cos_flag)
2475         double x;
2476 {
2477         /*      Algorithm and coefficients from:
2478                         "Software manual for the elementary functions"
2479                         by W.J. Cody and W. Waite, Prentice-Hall, 1980
2480         */
2481
2482         static double r[] = {
2483                 -0.16666666666666665052e+0,
2484                  0.83333333333331650314e-2,
2485                 -0.19841269841201840457e-3,
2486                  0.27557319210152756119e-5,
2487                 -0.25052106798274584544e-7,
2488                  0.16058936490371589114e-9,
2489                 -0.76429178068910467734e-12,
2490                  0.27204790957888846175e-14
2491         };
2492
2493         double  xsqr;
2494         double  y;
2495         int     neg = 0;
2496
2497         if (x < 0) {
2498                 x = -x;
2499                 neg = 1;
2500         }
2501         if (cos_flag) {
2502                 neg = 0;
2503                 y = M_PI_2 + x;
2504         }
2505         else    y = x;
2506
2507         /* ??? avoid loss of significance, if y is too large, error ??? */
2508
2509         y = y * M_1_PI + 0.5;
2510
2511         /*      Use extended precision to calculate reduced argument.
2512                 Here we used 12 bits of the mantissa for a1.
2513                 Also split x in integer part x1 and fraction part x2.
2514         */
2515 #define A1 3.1416015625
2516 #define A2 -8.908910206761537356617e-6
2517         {
2518                 double x1, x2;
2519                 extern double   _fif();
2520
2521                 _fif(y, 1.0,  &y);
2522                 if (_fif(y, 0.5, &x1)) neg = !neg;
2523                 if (cos_flag) y -= 0.5;
2524                 x2 = _fif(x, 1.0, &x1);
2525                 x = x1 - y * A1;
2526                 x += x2;
2527                 x -= y * A2;
2528 #undef A1
2529 #undef A2
2530         }
2531
2532         if (x < 0) {
2533                 neg = !neg;
2534                 x = -x;
2535         }
2536
2537         /* ??? avoid underflow ??? */
2538
2539         y = x * x;
2540         x += x * y * POLYNOM7(y, r);
2541         return neg ? -x : x;
2542 }
2543
2544 double
2545 _sin(x)
2546         double x;
2547 {
2548         return sinus(x, 0);
2549 }
2550
2551 double
2552 _cos(x)
2553         double x;
2554 {
2555         if (x < 0) x = -x;
2556         return sinus(x, 1);
2557 }
2558         sqt.c\0c\0\0\0\0\0\0\0\0\0\0\0\ 2\ 2�\ 1\0\0�\ 4/*
2559  * (c) copyright 1988 by the Vrije Universiteit, Amsterdam, The Netherlands.
2560  * See the copyright notice in the ACK home directory, in the file "Copyright".
2561  *
2562  * Author: Ceriel J.H. Jacobs
2563  */
2564
2565 /* $Id: sqt.c,v 2.6 1994/06/24 12:34:10 ceriel Exp $ */
2566 #define __NO_DEFS
2567 #include <math.h>
2568 #include <pc_err.h>
2569 extern  _trp();
2570
2571 #define NITER   5
2572
2573 static double
2574 Ldexp(fl,exp)
2575         double fl;
2576         int exp;
2577 {
2578         extern double _fef();
2579         int sign = 1;
2580         int currexp;
2581
2582         if (fl<0) {
2583                 fl = -fl;
2584                 sign = -1;
2585         }
2586         fl = _fef(fl,&currexp);
2587         exp += currexp;
2588         if (exp > 0) {
2589                 while (exp>30) {
2590                         fl *= (double) (1L << 30);
2591                         exp -= 30;
2592                 }
2593                 fl *= (double) (1L << exp);
2594         }
2595         else    {
2596                 while (exp<-30) {
2597                         fl /= (double) (1L << 30);
2598                         exp += 30;
2599                 }
2600                 fl /= (double) (1L << -exp);
2601         }
2602         return sign * fl;
2603 }
2604
2605 double
2606 _sqt(x)
2607         double x;
2608 {
2609         extern double _fef();
2610         int exponent;
2611         double val;
2612
2613         if (x <= 0) {
2614                 if (x < 0) _trp(ESQT);
2615                 return 0;
2616         }
2617
2618         val = _fef(x, &exponent);
2619         if (exponent & 1) {
2620                 exponent--;
2621                 val *= 2;
2622         }
2623         val = Ldexp(val + 1.0, exponent/2 - 1);
2624         /* was: val = (val + 1.0)/2.0; val = Ldexp(val, exponent/2); */
2625         for (exponent = NITER - 1; exponent >= 0; exponent--) {
2626                 val = (val + x / val) / 2.0;
2627         }
2628         return val;
2629 }
2630 fef.e\0c\0\0\0\0\0\0\0\0\0\0\0\ 2\ 2�\ 1\0\0l\ 3#
2631 ; $Id: fef.e,v 2.3 1994/06/24 12:31:51 ceriel Exp $
2632 ;
2633 ; (c) copyright 1983 by the Vrije Universiteit, Amsterdam, The Netherlands.
2634 ;
2635 ;          This product is part of the Amsterdam Compiler Kit.
2636 ;
2637 ; Permission to use, sell, duplicate or disclose this software must be
2638 ; obtained in writing. Requests for such permissions may be sent to
2639 ;
2640 ;      Dr. Andrew S. Tanenbaum
2641 ;      Wiskundig Seminarium
2642 ;      Vrije Universiteit
2643 ;      Postbox 7161
2644 ;      1007 MC Amsterdam
2645 ;      The Netherlands
2646 ;
2647 ;
2648
2649  mes 2,EM_WSIZE,EM_PSIZE
2650
2651 #define FARG    0
2652 #define ERES    EM_DSIZE
2653
2654 ; _fef is called with two parameters:
2655 ;       - address of exponent result (ERES)
2656 ;       - floating point number to be split (FARG)
2657 ; and returns an EM_DSIZE-byte floating point number
2658
2659  exp $_fef
2660  pro $_fef,0
2661  lal FARG
2662  loi EM_DSIZE
2663  fef EM_DSIZE
2664  lal ERES
2665  loi EM_PSIZE
2666  sti EM_WSIZE
2667  ret EM_DSIZE
2668  end ?
2669 string.c\0\0\0\0\0\0\0\0\0\0\ 2\ 2�\ 1\0\0j\ 4/* $Id: string.c,v 2.3 1994/06/24 12:34:13 ceriel Exp $ */
2670 /*
2671  * (c) copyright 1983 by the Vrije Universiteit, Amsterdam, The Netherlands.
2672  *
2673  *          This product is part of the Amsterdam Compiler Kit.
2674  *
2675  * Permission to use, sell, duplicate or disclose this software must be
2676  * obtained in writing. Requests for such permissions may be sent to
2677  *
2678  *      Dr. Andrew S. Tanenbaum
2679  *      Wiskundig Seminarium
2680  *      Vrije Universiteit
2681  *      Postbox 7161
2682  *      1007 MC Amsterdam
2683  *      The Netherlands
2684  *
2685  */
2686
2687 /* function strbuf(var b:charbuf):string; */
2688
2689 char *strbuf(s) char *s; {
2690         return(s);
2691 }
2692
2693 /* function strtobuf(s:string; var b:charbuf; blen:integer):integer; */
2694
2695 int strtobuf(s,b,l) char *s,*b; {
2696         int i;
2697
2698         i = 0;
2699         while (--l>=0) {
2700                 if ((*b++ = *s++) == 0)
2701                         break;
2702                 i++;
2703         }
2704         return(i);
2705 }
2706
2707 /* function strlen(s:string):integer; */
2708
2709 int strlen(s) char *s; {
2710         int i;
2711
2712         i = 0;
2713         while (*s++)
2714                 i++;
2715         return(i);
2716 }
2717
2718 /* function strfetch(s:string; i:integer):char; */
2719
2720 int strfetch(s,i) char *s; {
2721         return(s[i-1]);
2722 }
2723
2724 /* procedure strstore(s:string; i:integer; c:char); */
2725
2726 strstore(s,i,c) char *s; {
2727         s[i-1] = c;
2728 }
2729 trap.e\0c\0\0\0\0\0\0\0\0\0\0\ 2\ 2�\ 1\0\0\90\ 2#
2730
2731 ; $Id: trap.e,v 2.3 1994/06/24 12:34:16 ceriel Exp $
2732 ;
2733 ; (c) copyright 1983 by the Vrije Universiteit, Amsterdam, The Netherlands.
2734 ;
2735 ;          This product is part of the Amsterdam Compiler Kit.
2736 ;
2737 ; Permission to use, sell, duplicate or disclose this software must be
2738 ; obtained in writing. Requests for such permissions may be sent to
2739 ;
2740 ;      Dr. Andrew S. Tanenbaum
2741 ;      Wiskundig Seminarium
2742 ;      Vrije Universiteit
2743 ;      Postbox 7161
2744 ;      1007 MC Amsterdam
2745 ;      The Netherlands
2746 ;
2747 ;
2748
2749  mes 2,EM_WSIZE,EM_PSIZE
2750
2751 #define TRAP    0
2752
2753 ; trap is called with one parameter:
2754 ;       - trap number (TRAP)
2755
2756  exp $trap
2757  pro $trap,0
2758  lol TRAP
2759  trp
2760  ret 0
2761  end ?
2762 unp.c\0\0c\0\0\0\0\0\0\0\0\0\0\ 2\ 2�\ 1\0\0�\ 5/* $Id: unp.c,v 2.6 1994/06/24 12:34:23 ceriel Exp $ */
2763 /*
2764  * (c) copyright 1983 by the Vrije Universiteit, Amsterdam, The Netherlands.
2765  *
2766  *          This product is part of the Amsterdam Compiler Kit.
2767  *
2768  * Permission to use, sell, duplicate or disclose this software must be
2769  * obtained in writing. Requests for such permissions may be sent to
2770  *
2771  *      Dr. Andrew S. Tanenbaum
2772  *      Wiskundig Seminarium
2773  *      Vrije Universiteit
2774  *      Postbox 7161
2775  *      1007 MC Amsterdam
2776  *      The Netherlands
2777  *
2778  */
2779
2780 /* Author: J.W. Stevenson */
2781
2782 #include        <pc_err.h>
2783
2784 extern          _trp();
2785
2786 #define assert(x)       /* nothing */
2787
2788 #ifndef EM_WSIZE
2789 #define EM_WSIZE _EM_WSIZE
2790 #endif
2791
2792 struct descr {
2793         int     low;
2794         int     diff;
2795         int     size;
2796 };
2797
2798 _unp(ad,zd,i,ap,zp,noext) int i; struct descr *ad,*zd; char *ap,*zp; int noext; {
2799
2800         if (zd->diff > ad->diff ||
2801                         (i -= ad->low) < 0 ||
2802                         (i+zd->diff) > ad->diff)
2803                 _trp(EUNPACK);
2804         ap += (i * ad->size);
2805         i = (zd->diff + 1) * zd->size;
2806         if (zd->size == 1) {
2807                 int *aptmp = (int *) ap;
2808                 assert(ad->size == EM_WSIZE);
2809                 while (--i >= 0)
2810                         if (noext) *aptmp++ = *zp++ & 0377;
2811                         else *aptmp++ = *zp++;
2812 #if EM_WSIZE > 2
2813         } else if (zd->size == 2) {
2814                 int *aptmp = (int *) ap;
2815                 short *zptmp = (short *) zp;
2816                 assert(ad->size == EM_WSIZE);
2817                 while (--i >= 0)
2818                         if (noext) *aptmp++ = *zptmp++ & 0177777;
2819                         else *aptmp++ = *zptmp++;
2820 #endif
2821         } else {
2822                 assert(ad->size == zd->size);
2823                 while (--i >= 0)
2824                         *ap++ = *zp++;
2825         }
2826 }
2827 uread.c\0\0\0\0\0\0\0\0\0\0\0\ 2\ 2�\ 1\0\0\9e\ 2/* $Id: uread.c,v 2.4 1994/06/24 12:34:25 ceriel Exp $ */
2828 /*
2829  * (c) copyright 1983 by the Vrije Universiteit, Amsterdam, The Netherlands.
2830  *
2831  *          This product is part of the Amsterdam Compiler Kit.
2832  *
2833  * Permission to use, sell, duplicate or disclose this software must be
2834  * obtained in writing. Requests for such permissions may be sent to
2835  *
2836  *      Dr. Andrew S. Tanenbaum
2837  *      Wiskundig Seminarium
2838  *      Vrije Universiteit
2839  *      Postbox 7161
2840  *      1007 MC Amsterdam
2841  *      The Netherlands
2842  *
2843  */
2844
2845 /* function uread(fd:integer; var b:buf; n:integer):integer; */
2846
2847 extern int      _read();
2848
2849 int uread(fd,b,n) char *b; int fd,n; {
2850         return(_read(fd,b,n));
2851 }
2852 uwrite.c\0\0\0\0\0\0\0\0\0\0\ 2\ 2�\ 1\0\0�\ 2/* $Id: uwrite.c,v 2.4 1994/06/24 12:34:28 ceriel Exp $ */
2853 /*
2854  * (c) copyright 1983 by the Vrije Universiteit, Amsterdam, The Netherlands.
2855  *
2856  *          This product is part of the Amsterdam Compiler Kit.
2857  *
2858  * Permission to use, sell, duplicate or disclose this software must be
2859  * obtained in writing. Requests for such permissions may be sent to
2860  *
2861  *      Dr. Andrew S. Tanenbaum
2862  *      Wiskundig Seminarium
2863  *      Vrije Universiteit
2864  *      Postbox 7161
2865  *      1007 MC Amsterdam
2866  *      The Netherlands
2867  *
2868  */
2869
2870 /* function uwrite(fd:integer; var b:buf; n:integer):integer; */
2871
2872 extern int      _write();
2873
2874 int uwrite(fd,b,n) char *b; int fd,n; {
2875         return(_write(fd,b,n));
2876 }
2877 twdw.c\0.c\0\0\0\0\0\0\0\0\0\0\ 2\ 2�\ 1\0\0�\ 2/* $Id: wdw.c,v 2.3 1994/06/24 12:34:31 ceriel Exp $ */
2878 /*
2879  * (c) copyright 1983 by the Vrije Universiteit, Amsterdam, The Netherlands.
2880  *
2881  *          This product is part of the Amsterdam Compiler Kit.
2882  *
2883  * Permission to use, sell, duplicate or disclose this software must be
2884  * obtained in writing. Requests for such permissions may be sent to
2885  *
2886  *      Dr. Andrew S. Tanenbaum
2887  *      Wiskundig Seminarium
2888  *      Vrije Universiteit
2889  *      Postbox 7161
2890  *      1007 MC Amsterdam
2891  *      The Netherlands
2892  *
2893  */
2894
2895 #include        <pc_file.h>
2896
2897 extern struct file      *_curfil;
2898 extern                  _incpt();
2899
2900 char *_wdw(f) struct file *f; {
2901
2902         _curfil = f;
2903         if ((f->flags & (WINDOW|WRBIT|0377)) == MAGIC)
2904                 _incpt(f);
2905         return(f->ptr);
2906 }
2907 ;incpt.c\0\0\0\0\0\0\0\0\0\0\0\ 2\ 2�\ 1\0\0\9f\ 5/* $Id: incpt.c,v 2.3 1994/06/24 12:32:12 ceriel Exp $ */
2908 /*
2909  * (c) copyright 1983 by the Vrije Universiteit, Amsterdam, The Netherlands.
2910  *
2911  *          This product is part of the Amsterdam Compiler Kit.
2912  *
2913  * Permission to use, sell, duplicate or disclose this software must be
2914  * obtained in writing. Requests for such permissions may be sent to
2915  *
2916  *      Dr. Andrew S. Tanenbaum
2917  *      Wiskundig Seminarium
2918  *      Vrije Universiteit
2919  *      Postbox 7161
2920  *      1007 MC Amsterdam
2921  *      The Netherlands
2922  *
2923  */
2924
2925 /* Author: J.W. Stevenson */
2926
2927 #include        <pc_file.h>
2928 #include        <pc_err.h>
2929
2930 #define EINTR   4
2931
2932 extern int      errno;
2933 extern          _trp();
2934 extern int      _read();
2935
2936 _incpt(f) struct file *f; {
2937
2938         if (f->flags & EOFBIT)
2939                 _trp(EEOF);
2940         f->flags |= WINDOW;
2941         f->flags &= ~ELNBIT;
2942 #ifdef CPM
2943         do {
2944 #endif
2945         f->ptr += f->size;
2946         if (f->count == 0) {
2947                 f->ptr = f->bufadr;
2948                 for(;;) {
2949                         f->count=_read(f->ufd,f->bufadr,f->buflen);
2950                         if ( f->count<0 ) {
2951                                 if (errno != EINTR) _trp(EREAD) ;
2952                                 continue ;
2953                         }
2954                         break ;
2955                 }
2956                 if (f->count == 0) {
2957                         f->flags |= EOFBIT;
2958                         *f->ptr = '\0';
2959                         return;
2960                 }
2961         }
2962         if ((f->count -= f->size) < 0)
2963                 _trp(EFTRUNC);
2964 #ifdef CPM
2965         } while ((f->flags&TXTBIT) && *f->ptr == '\r');
2966 #endif
2967         if (f->flags & TXTBIT) {
2968                 if (*f->ptr & 0200)
2969                         _trp(EASCII);
2970                 if (*f->ptr == '\n') {
2971                         f->flags |= ELNBIT;
2972                         *f->ptr = ' ';
2973                 }
2974 #ifdef CPM
2975                 if (*f->ptr == 26) {
2976                         f->flags |= EOFBIT;
2977                         *f->ptr = 0;
2978                 }
2979 #endif
2980         }
2981 }
2982
2983 wrc.c\0c\0\0\0\0\0\0\0\0\0\0\0\ 2\ 2�\ 1\0\0,\ 3/* $Id: wrc.c,v 2.3 1994/06/24 12:34:39 ceriel Exp $ */
2984 /*
2985  * (c) copyright 1983 by the Vrije Universiteit, Amsterdam, The Netherlands.
2986  *
2987  *          This product is part of the Amsterdam Compiler Kit.
2988  *
2989  * Permission to use, sell, duplicate or disclose this software must be
2990  * obtained in writing. Requests for such permissions may be sent to
2991  *
2992  *      Dr. Andrew S. Tanenbaum
2993  *      Wiskundig Seminarium
2994  *      Vrije Universiteit
2995  *      Postbox 7161
2996  *      1007 MC Amsterdam
2997  *      The Netherlands
2998  *
2999  */
3000
3001 #include        <pc_file.h>
3002
3003 extern          _wf();
3004 extern          _outcpt();
3005
3006 _wrc(c,f) int c; struct file *f; {
3007         *f->ptr = c;
3008         _wf(f);
3009         _outcpt(f);
3010 }
3011
3012 _wln(f) struct file *f; {
3013 #ifdef CPM
3014         _wrc('\r',f);
3015 #endif
3016         _wrc('\n',f);
3017         f->flags |= ELNBIT;
3018 }
3019
3020 _pag(f) struct file *f; {
3021         _wrc('\014',f);
3022         f->flags |= ELNBIT;
3023 }
3024 wrf.c\0c\0\0\0\0\0\0\0\0\0\0\0\ 2\ 2�\ 1\0\0�\ 5/* $Id: wrf.c,v 2.6 1994/06/24 12:34:42 ceriel Exp $ */
3025 /*
3026  * (c) copyright 1983 by the Vrije Universiteit, Amsterdam, The Netherlands.
3027  *
3028  *          This product is part of the Amsterdam Compiler Kit.
3029  *
3030  * Permission to use, sell, duplicate or disclose this software must be
3031  * obtained in writing. Requests for such permissions may be sent to
3032  *
3033  *      Dr. Andrew S. Tanenbaum
3034  *      Wiskundig Seminarium
3035  *      Vrije Universiteit
3036  *      Postbox 7161
3037  *      1007 MC Amsterdam
3038  *      The Netherlands
3039  *
3040  */
3041
3042 /* Author: J.W. Stevenson */
3043
3044 #include        <pc_err.h>
3045 #include        <pc_file.h>
3046
3047 extern          _wstrin();
3048 extern char     *_fcvt();
3049
3050 #define assert(x)       /* nothing */
3051
3052 #if __STDC__
3053 #include <float.h>
3054 #define HUGE_DIG        DBL_MAX_10_EXP  /* log10(maxreal) */
3055 #else
3056 #define HUGE_DIG        400     /* log10(maxreal) */
3057 #endif
3058 #define PREC_DIG        80      /* the maximum digits returned by _fcvt() */
3059 #define FILL_CHAR       '0'     /* char printed if all of _fcvt() used */
3060 #define BUFSIZE         HUGE_DIG + PREC_DIG + 3
3061
3062 _wrf(n,w,r,f) int n,w; double r; struct file *f; {
3063         char *p,*b; int s,d; char buf[BUFSIZE];
3064
3065         if ( n < 0 || w < 0) _trp(EWIDTH);
3066         p = buf;
3067         if (n > PREC_DIG)
3068                 n = PREC_DIG;
3069         b = _fcvt(r,n,&d,&s);
3070         assert(abs(d) <= HUGE_DIG);
3071         if (s)
3072                 *p++ = '-';
3073         if (d<=0)
3074                 *p++ = '0';
3075         else
3076                 do
3077                         *p++ = (*b ? *b++ : FILL_CHAR);
3078                 while (--d > 0);
3079         if (n > 0)
3080                 *p++ = '.';
3081         while (++d <= 0) {
3082                 if (--n < 0)
3083                         break;
3084                 *p++ = '0';
3085         }
3086         while (--n >= 0) {
3087                 *p++ = (*b ? *b++ : FILL_CHAR);
3088                 assert(p <= buf+BUFSIZE);
3089         }
3090         _wstrin(w,(int)(p-buf),buf,f);
3091 }
3092 wri.c\0c\0\0\0\0\0\0\0\0\0\0\0\ 2\ 2�\ 1\0\04\ 5/* $Id: wri.c,v 2.7 1994/06/24 12:34:45 ceriel Exp $ */
3093 /*
3094  * (c) copyright 1983 by the Vrije Universiteit, Amsterdam, The Netherlands.
3095  *
3096  *          This product is part of the Amsterdam Compiler Kit.
3097  *
3098  * Permission to use, sell, duplicate or disclose this software must be
3099  * obtained in writing. Requests for such permissions may be sent to
3100  *
3101  *      Dr. Andrew S. Tanenbaum
3102  *      Wiskundig Seminarium
3103  *      Vrije Universiteit
3104  *      Postbox 7161
3105  *      1007 MC Amsterdam
3106  *      The Netherlands
3107  *
3108  */
3109
3110 #include        <pc_err.h>
3111 #include        <pc_file.h>
3112
3113 extern          _wstrin();
3114
3115 #ifndef EM_WSIZE
3116 #ifdef _EM_WSIZE
3117 #define EM_WSIZE _EM_WSIZE
3118 #endif
3119 #endif
3120
3121 #if EM_WSIZE==4
3122 #define SZ 11
3123 #define MININT -2147483648
3124 #define STRMININT "-2147483648"
3125 #endif
3126 #if EM_WSIZE==2
3127 #define SZ 6
3128 #define MININT -32768
3129 #define STRMININT "-32768"
3130 #endif
3131 #if EM_WSIZE==1
3132 #define SZ 4
3133 #define MININT -128
3134 #define STRMININT "-128"
3135 #endif
3136
3137 #ifndef STRMININT
3138 Something wrong here!
3139 #endif
3140
3141 _wsi(w,i,f) int w,i; struct file *f; {
3142         char *p; int j; char buf[SZ];
3143
3144         if (w < 0) _trp(EWIDTH);
3145         p = &buf[SZ];
3146         if ((j=i) < 0) {
3147                 if (i == MININT) {
3148                         _wstrin(w,SZ,STRMININT,f);
3149                         return;
3150                 }
3151                 j = -j;
3152         }
3153         do
3154                 *--p = '0' + j%10;
3155         while (j /= 10);
3156         if (i<0)
3157                 *--p = '-';
3158         _wstrin(w,(int)(&buf[SZ]-p),p,f);
3159 }
3160
3161 _wri(i,f) int i; struct file *f; {
3162         _wsi(SZ,i,f);
3163 }
3164 wrl.c\0c\0\0\0\0\0\0\0\0\0\0\0\ 2\ 2�\ 1\0\0\ e\ 4/* $Id: wrl.c,v 2.4 1994/06/24 12:34:49 ceriel Exp $ */
3165 /*
3166  * (c) copyright 1983 by the Vrije Universiteit, Amsterdam, The Netherlands.
3167  *
3168  *          This product is part of the Amsterdam Compiler Kit.
3169  *
3170  * Permission to use, sell, duplicate or disclose this software must be
3171  * obtained in writing. Requests for such permissions may be sent to
3172  *
3173  *      Dr. Andrew S. Tanenbaum
3174  *      Wiskundig Seminarium
3175  *      Vrije Universiteit
3176  *      Postbox 7161
3177  *      1007 MC Amsterdam
3178  *      The Netherlands
3179  *
3180  */
3181
3182 /* Author: J.W. Stevenson */
3183
3184 #include        <pc_err.h>
3185 #include        <pc_file.h>
3186
3187 extern          _wstrin();
3188
3189 #define MAXNEGLONG      -2147483648
3190
3191 _wsl(w,l,f) int w; long l; struct file *f; {
3192         char *p,c; long j; char buf[11];
3193
3194         if (w < 0) _trp(EWIDTH);
3195         p = &buf[11];
3196         if ((j=l) < 0) {
3197                 if (l == MAXNEGLONG) {
3198                         _wstrin(w,11,"-2147483648",f);
3199                         return;
3200                 }
3201                 j = -j;
3202         }
3203         do {
3204                 c = j%10;
3205                 *--p = c + '0';
3206         } while (j /= 10);
3207         if (l<0)
3208                 *--p = '-';
3209         _wstrin(w,(int)(&buf[11]-p),p,f);
3210 }
3211
3212 _wrl(l,f) long l; struct file *f; {
3213         _wsl(11,l,f);
3214 }
3215 wrr.c\0c\0\0\0\0\0\0\0\0\0\0\0\ 2\ 2�\ 1\0\0\ e\ 5/* $Id: wrr.c,v 2.4 1994/06/24 12:34:52 ceriel Exp $ */
3216 /*
3217  * (c) copyright 1983 by the Vrije Universiteit, Amsterdam, The Netherlands.
3218  *
3219  *          This product is part of the Amsterdam Compiler Kit.
3220  *
3221  * Permission to use, sell, duplicate or disclose this software must be
3222  * obtained in writing. Requests for such permissions may be sent to
3223  *
3224  *      Dr. Andrew S. Tanenbaum
3225  *      Wiskundig Seminarium
3226  *      Vrije Universiteit
3227  *      Postbox 7161
3228  *      1007 MC Amsterdam
3229  *      The Netherlands
3230  *
3231  */
3232
3233 /* Author: J.W. Stevenson */
3234
3235 #include        <pc_err.h>
3236 #include        <pc_file.h>
3237
3238 extern          _wstrin();
3239 extern char     *_ecvt();
3240
3241 #define PREC_DIG        80      /* maximum digits produced by _ecvt() */
3242
3243 _wsr(w,r,f) int w; double r; struct file *f; {
3244         char *p,*b; int s,d,i; char buf[PREC_DIG+7];
3245
3246         if (w < 0) _trp(EWIDTH);
3247         p = buf;
3248         if ((i = w-6) < 2)
3249                 i = 2;
3250         b = _ecvt(r,i,&d,&s);
3251         *p++ = s? '-' : ' ';
3252         if (*b == '0')
3253                 d++;
3254         *p++ = *b++;
3255         *p++ = '.';
3256         while (--i > 0)
3257                 *p++ = *b++;
3258         *p++ = 'e';
3259         d--;
3260         if (d < 0) {
3261                 d = -d;
3262                 *p++ = '-';
3263         } else
3264                 *p++ = '+';
3265
3266         if (d >= 1000) {
3267                 *p++ = '*';
3268                 *p++ = '*';
3269                 *p++ = '*';
3270         }
3271         else {
3272                 *p++ = '0' + d/100;
3273                 *p++ = '0' + (d/10) % 10;
3274                 *p++ = '0' + d%10;
3275         }
3276         _wstrin(w,(int)(p-buf),buf,f);
3277 }
3278
3279 _wrr(r,f) double r; struct file *f; {
3280         _wsr(13,r,f);
3281 }
3282 cvt.c\0c\0\0\0\0\0\0\0\0\0\0\0\ 2\ 2�\ 1\0\0H\b/* $Id: cvt.c,v 2.6 1994/06/24 12:31:29 ceriel Exp $ */
3283 #ifndef NOFLOAT
3284
3285 #if __STDC__
3286 #include <float.h>
3287 #else
3288 #include <math.h>
3289 #define DBL_MAX M_MAX_D
3290 #endif
3291
3292 static char *cvt();
3293 #define NDIGITS 128
3294
3295 char *
3296 _ecvt(value, ndigit, decpt, sign)
3297         double value;
3298         int ndigit, *decpt, *sign;
3299 {
3300         return cvt(value, ndigit, decpt, sign, 1);
3301 }
3302
3303 char *
3304 _fcvt(value, ndigit, decpt, sign)
3305         double value;
3306         int ndigit, *decpt, *sign;
3307 {
3308         return cvt(value, ndigit, decpt, sign, 0);
3309 }
3310
3311 static struct powers_of_10 {
3312         double pval;
3313         double rpval;
3314         int exp;
3315 } p10[] = {
3316         1.0e32, 1.0e-32, 32,
3317         1.0e16, 1.0e-16, 16,
3318         1.0e8, 1.0e-8, 8,
3319         1.0e4, 1.0e-4, 4,
3320         1.0e2, 1.0e-2, 2,
3321         1.0e1, 1.0e-1, 1,
3322         1.0e0, 1.0e0, 0
3323 };
3324
3325 static char *
3326 cvt(value, ndigit, decpt, sign, ecvtflag)
3327         double value;
3328         int ndigit, *decpt, *sign;
3329 {
3330         static char buf[NDIGITS+1];
3331         register char *p = buf;
3332         register char *pe;
3333
3334         if (ndigit < 0) ndigit = 0;
3335         if (ndigit > NDIGITS) ndigit = NDIGITS;
3336         pe = &buf[ndigit];
3337         buf[0] = '\0';
3338
3339         *sign = 0;
3340         if (value < 0) {
3341                 *sign = 1;
3342                 value = -value;
3343         }
3344
3345         *decpt = 0;
3346         if (value >= DBL_MAX) {
3347                 value = DBL_MAX;
3348         }
3349         if (value != 0.0) {
3350                 register struct powers_of_10 *pp = &p10[0];
3351
3352                 if (value >= 10.0) do {
3353                         while (value >= pp->pval) {
3354                                 value *= pp->rpval;
3355                                 *decpt += pp->exp;
3356                         }
3357                 } while ((++pp)->exp > 0);
3358
3359                 pp = &p10[0];
3360                 if (value < 1.0) do {
3361                         while (value * pp->pval < 10.0) {
3362                                 value *= pp->pval;
3363                                 *decpt -= pp->exp;
3364                         }
3365                 } while ((++pp)->exp > 0);
3366
3367                 (*decpt)++;     /* because now value in [1.0, 10.0) */
3368         }
3369         if (! ecvtflag) {
3370                 /* for fcvt() we need ndigit digits behind the dot */
3371                 pe += *decpt;
3372                 if (pe > &buf[NDIGITS]) pe = &buf[NDIGITS];
3373         }
3374         while (p <= pe) {
3375                 *p++ = (int)value + '0';
3376                 value = 10.0 * (value - (int)value);
3377         }
3378         if (pe >= buf) {
3379                 p = pe;
3380                 *p += 5;        /* round of at the end */
3381                 while (*p > '9') {
3382                         *p = '0';
3383                         if (p > buf) ++*--p;
3384                         else {
3385                                 *p = '1';
3386                                 ++*decpt;
3387                                 if (! ecvtflag) {
3388                                         /* maybe add another digit at the end,
3389                                            because the point was shifted right
3390                                         */
3391                                         if (pe > buf) *pe = '0';
3392                                         pe++;
3393                                 }
3394                         }
3395                 }
3396                 *pe = '\0';
3397         }
3398         return buf;
3399 }
3400 #endif
3401 fif.e\0c\0\0\0\0\0\0\0\0\0\0\0\ 2\ 2�\ 1\0\0\8f\ 3#
3402 ; $Id: fif.e,v 2.3 1994/06/24 12:31:54 ceriel Exp $
3403 ;
3404 ; (c) copyright 1983 by the Vrije Universiteit, Amsterdam, The Netherlands.
3405 ;
3406 ;          This product is part of the Amsterdam Compiler Kit.
3407 ;
3408 ; Permission to use, sell, duplicate or disclose this software must be
3409 ; obtained in writing. Requests for such permissions may be sent to
3410 ;
3411 ;      Dr. Andrew S. Tanenbaum
3412 ;      Wiskundig Seminarium
3413 ;      Vrije Universiteit
3414 ;      Postbox 7161
3415 ;      1007 MC Amsterdam
3416 ;      The Netherlands
3417 ;
3418 ;
3419
3420  mes 2,EM_WSIZE,EM_PSIZE
3421
3422 #define ARG1    0
3423 #define ARG2    EM_DSIZE
3424 #define IRES    2*EM_DSIZE
3425
3426 ; _fif is called with three parameters:
3427 ;       - address of integer part result (IRES)
3428 ;       - float two (ARG2)
3429 ;       - float one (ARG1)
3430 ; and returns an EM_DSIZE-byte floating point number
3431
3432  exp $_fif
3433  pro $_fif,0
3434  lal 0
3435  loi 2*EM_DSIZE
3436  fif EM_DSIZE
3437  lal IRES
3438  loi EM_PSIZE
3439  sti EM_DSIZE
3440  ret EM_DSIZE
3441  end ?
3442 Gwrz.c\0c\0\0\0\0\0\0\0\0\0\0\0\ 2\ 2�\ 1\0\02\ 3/* $Id: wrz.c,v 2.5 1994/06/24 12:34:58 ceriel Exp $ */
3443 /*
3444  * (c) copyright 1983 by the Vrije Universiteit, Amsterdam, The Netherlands.
3445  *
3446  *          This product is part of the Amsterdam Compiler Kit.
3447  *
3448  * Permission to use, sell, duplicate or disclose this software must be
3449  * obtained in writing. Requests for such permissions may be sent to
3450  *
3451  *      Dr. Andrew S. Tanenbaum
3452  *      Wiskundig Seminarium
3453  *      Vrije Universiteit
3454  *      Postbox 7161
3455  *      1007 MC Amsterdam
3456  *      The Netherlands
3457  *
3458  */
3459
3460 #include        <pc_err.h>
3461 #include        <pc_file.h>
3462
3463 extern          _wss();
3464 extern          _wrs();
3465
3466 _wsz(w,s,f) int w; char *s; struct file *f; {
3467         char *p;
3468
3469         if (w < 0) _trp(EWIDTH);
3470         for (p=s; *p; p++);
3471         _wss(w,(int)(p-s),s,f);
3472 }
3473
3474 _wrz(s,f) char *s; struct file *f; {
3475         char *p;
3476
3477         for (p=s; *p; p++);
3478         _wrs((int)(p-s),s,f);
3479 }
3480 wrs.c\0c\0\0\0\0\0\0\0\0\0\0\0\ 2\ 2�\ 1\0\0-\ 5/* $Id: wrs.c,v 2.3 1994/06/24 12:34:55 ceriel Exp $ */
3481 /*
3482  * (c) copyright 1983 by the Vrije Universiteit, Amsterdam, The Netherlands.
3483  *
3484  *          This product is part of the Amsterdam Compiler Kit.
3485  *
3486  * Permission to use, sell, duplicate or disclose this software must be
3487  * obtained in writing. Requests for such permissions may be sent to
3488  *
3489  *      Dr. Andrew S. Tanenbaum
3490  *      Wiskundig Seminarium
3491  *      Vrije Universiteit
3492  *      Postbox 7161
3493  *      1007 MC Amsterdam
3494  *      The Netherlands
3495  *
3496  */
3497
3498 /* Author: J.W. Stevenson */
3499
3500 #include        <pc_err.h>
3501 #include        <pc_file.h>
3502
3503 extern          _wf();
3504 extern          _outcpt();
3505
3506 _wstrin(width,len,buf,f) int width,len; char *buf; struct file *f; {
3507
3508         _wf(f);
3509         for (width -= len; width>0; width--) {
3510                 *f->ptr = ' ';
3511                 _outcpt(f);
3512         }
3513         while (--len >= 0) {
3514                 *f->ptr = *buf++;
3515                 _outcpt(f);
3516         }
3517 }
3518
3519 _wsc(w,c,f) int w; char c; struct file *f; {
3520
3521         if (w < 0) _trp(EWIDTH);
3522         _wss(w,1,&c,f);
3523 }
3524
3525 _wss(w,len,s,f) int w,len; char *s; struct file *f; {
3526
3527         if (w < 0 || len < 0) _trp(EWIDTH);
3528         if (w < len)
3529                 len = w;
3530         _wstrin(w,len,s,f);
3531 }
3532
3533 _wrs(len,s,f) int len; char *s; struct file *f; {
3534         if (len < 0) _trp(EWIDTH);
3535         _wss(len,len,s,f);
3536 }
3537
3538 _wsb(w,b,f) int w,b; struct file *f; {
3539         if (b)
3540                 _wss(w,4,"true",f);
3541         else
3542                 _wss(w,5,"false",f);
3543 }
3544
3545 _wrb(b,f) int b; struct file *f; {
3546         _wsb(5,b,f);
3547 }
3548 (outcpt.c\0\0\0\0\0\0\0\0\0\0\ 2\ 2�\ 1\0\0�\ 3/* $Id: outcpt.c,v 2.3 1994/06/24 12:32:44 ceriel Exp $ */
3549 /*
3550  * (c) copyright 1983 by the Vrije Universiteit, Amsterdam, The Netherlands.
3551  *
3552  *          This product is part of the Amsterdam Compiler Kit.
3553  *
3554  * Permission to use, sell, duplicate or disclose this software must be
3555  * obtained in writing. Requests for such permissions may be sent to
3556  *
3557  *      Dr. Andrew S. Tanenbaum
3558  *      Wiskundig Seminarium
3559  *      Vrije Universiteit
3560  *      Postbox 7161
3561  *      1007 MC Amsterdam
3562  *      The Netherlands
3563  *
3564  */
3565
3566 /* Author: J.W. Stevenson */
3567
3568 #include        <pc_file.h>
3569 #include        <pc_err.h>
3570
3571 #define EINTR   4
3572
3573 extern int      errno;
3574 extern          _trp();
3575 extern int      _write();
3576
3577 _flush(f) struct file *f; {
3578         int i,n;
3579
3580         f->ptr = f->bufadr;
3581         n = f->buflen - f->count;
3582         if (n <= 0)
3583                 return;
3584         f->count = f->buflen;
3585         if ((i = _write(f->ufd,f->bufadr,n)) < 0 && errno == EINTR)
3586                 return;
3587         if (i != n)
3588                 _trp(EWRITE);
3589 }
3590
3591 _outcpt(f) struct file *f; {
3592
3593         f->flags &= ~ELNBIT;
3594         f->ptr += f->size;
3595         if ((f->count -= f->size) <= 0)
3596                 _flush(f);
3597 }
3598 ;wf.c\0t.c\0\0\0\0\0\0\0\0\0\0\ 2\ 2�\ 1\0\0�\ 2/* $Id: wf.c,v 2.3 1994/06/24 12:34:34 ceriel Exp $ */
3599 /*
3600  * (c) copyright 1983 by the Vrije Universiteit, Amsterdam, The Netherlands.
3601  *
3602  *          This product is part of the Amsterdam Compiler Kit.
3603  *
3604  * Permission to use, sell, duplicate or disclose this software must be
3605  * obtained in writing. Requests for such permissions may be sent to
3606  *
3607  *      Dr. Andrew S. Tanenbaum
3608  *      Wiskundig Seminarium
3609  *      Vrije Universiteit
3610  *      Postbox 7161
3611  *      1007 MC Amsterdam
3612  *      The Netherlands
3613  *
3614  */
3615
3616 #include        <pc_file.h>
3617 #include        <pc_err.h>
3618
3619 extern struct file      *_curfil;
3620 extern                  _trp();
3621
3622 _wf(f) struct file *f; {
3623
3624         _curfil = f;
3625         if ((f->flags&0377) != MAGIC)
3626                 _trp(EBADF);
3627         if ((f->flags & WRBIT) == 0)
3628                 _trp(EWRITEF);
3629 }
3630 nfa.c\0.c\0\0\0\0\0\0\0\0\0\0\ 2\ 2�\ 1\0\0I\ 1/* $Id: nfa.c,v 2.3 1994/06/24 12:32:31 ceriel Exp $ */
3631 /*
3632  * (c) copyright 1990 by the Vrije Universiteit, Amsterdam, The Netherlands.
3633  * See the copyright notice in the ACK home directory, in the file "Copyright".
3634  */
3635
3636 /* Author: Hans van Eck */
3637
3638 #include        <pc_err.h>
3639
3640 extern _trp();
3641
3642 _nfa(bool)
3643 {
3644         if (! bool) _trp(EFUNASS);
3645 }
3646 srcka.c\0c\0\0\0\0\0\0\0\0\0\0\ 2\ 2�\ 1\0\01\ 2/* $Id: rcka.c,v 2.4 1994/06/24 12:33:29 ceriel Exp $ */
3647 /*
3648  * (c) copyright 1990 by the Vrije Universiteit, Amsterdam, The Netherlands.
3649  * See the copyright notice in the ACK home directory, in the file "Copyright".
3650  */
3651
3652 /* Author: Hans van Eck */
3653
3654 #include        <em_abs.h>
3655
3656 extern _trp();
3657
3658 struct array_descr      {
3659                 int             lbound;
3660                 unsigned        n_elts_min_one;
3661                 unsigned        size;           /* doesn't really matter */
3662             };
3663
3664 _rcka(descr, index)
3665 struct array_descr *descr;
3666 {
3667         if( index < descr->lbound ||
3668             index > (int) descr->n_elts_min_one + descr->lbound )
3669                 _trp(EARRAY);
3670 }
3671 etrp.e\0\0c\0\0\0\0\0\0\0\0\0\0\ 2\ 2�\ 1\0\0\8e\ 3#
3672
3673 ; $Id: trp.e,v 2.3 1994/06/24 12:34:20 ceriel Exp $
3674 ;
3675 ; (c) copyright 1983 by the Vrije Universiteit, Amsterdam, The Netherlands.
3676 ;
3677 ;          This product is part of the Amsterdam Compiler Kit.
3678 ;
3679 ; Permission to use, sell, duplicate or disclose this software must be
3680 ; obtained in writing. Requests for such permissions may be sent to
3681 ;
3682 ;      Dr. Andrew S. Tanenbaum
3683 ;      Wiskundig Seminarium
3684 ;      Vrije Universiteit
3685 ;      Postbox 7161
3686 ;      1007 MC Amsterdam
3687 ;      The Netherlands
3688 ;
3689 ;
3690
3691  mes 2,EM_WSIZE,EM_PSIZE
3692
3693 #define TRAP    0
3694
3695 ; _trp() and trap() perform the same function,
3696 ; but have to be separate. trap exists to facilitate the user.
3697 ; _trp is there for the system, trap cannot be used for that purpose
3698 ; because a user might define its own Pascal routine called trap.
3699
3700 ; _trp is called with one parameter:
3701 ;       - trap number (TRAP)
3702
3703  exp $_trp
3704  pro $_trp,0
3705  lol TRAP
3706  trp
3707  ret 0
3708  end ?