lang/m2/libm2/tail_m2.a

   1 e�Termcap.mod\0\0\0\0\0\0\0\ 2\ 2�\ 1\0\0\r\b(*
   2   (c) copyright 1988 by the Vrije Universiteit, Amsterdam, The Netherlands.
   3   See the copyright notice in the ACK home directory, in the file "Copyright".
   4 *)
   5
   6 (*
   7   Module:       Interface to termcap database
   8   From:         Unix manual chapter 3
   9   Version:      $Id: Termcap.mod,v 1.5 1994/06/24 12:50:13 ceriel Exp $
  10 *)
  11
  12 (*$R-*)
  13 IMPLEMENTATION MODULE Termcap;
  14
  15   IMPORT XXTermcap;
  16   FROM  SYSTEM IMPORT   ADR, ADDRESS;
  17   FROM  Unix IMPORT     gtty;
  18   FROM  Arguments IMPORT
  19                         GetEnv;
  20
  21   TYPE  STR = ARRAY[1..32] OF CHAR;
  22         STRCAP = POINTER TO STR;
  23
  24   VAR   Buf, Buf1 : ARRAY [1..1024] OF CHAR;
  25         BufCnt : INTEGER;
  26
  27   PROCEDURE Tgetent(name: ARRAY OF CHAR) : INTEGER;
  28   VAR i: INTEGER;
  29       x: STRCAP;
  30       sp: STR;
  31   BEGIN
  32         i := XXTermcap.tgetent(ADR(Buf), ADR(name));
  33         BufCnt := 1;
  34         IF gtty(1, ADR(sp)) < 0 THEN
  35         ELSE
  36                 XXTermcap.ospeed := ORD(sp[2]);
  37         END;
  38         IF i > 0 THEN
  39                 IF Tgetstr("pc", x) THEN
  40                         XXTermcap.PC := x^[1];
  41                 ELSE    XXTermcap.PC := 0C;
  42                 END;
  43                 IF Tgetstr("up", x) THEN ; END; XXTermcap.UP := x;
  44                 IF Tgetstr("bc", x) THEN ; END; XXTermcap.BC := x;
  45         END;
  46         RETURN i;
  47   END Tgetent;
  48
  49   PROCEDURE Tgetnum(id: ARRAY OF CHAR): INTEGER;
  50   BEGIN
  51         RETURN XXTermcap.tgetnum(ADR(id));
  52   END Tgetnum;
  53
  54   PROCEDURE Tgetflag(id: ARRAY OF CHAR): BOOLEAN;
  55   BEGIN
  56         RETURN XXTermcap.tgetflag(ADR(id)) = 1;
  57   END Tgetflag;
  58
  59   PROCEDURE Tgoto(cm: STRCAP; col, line: INTEGER): STRCAP;
  60   BEGIN
  61         RETURN XXTermcap.tgoto(cm, col, line);
  62   END Tgoto;
  63
  64   PROCEDURE Tgetstr(id: ARRAY OF CHAR; VAR res: STRCAP) : BOOLEAN;
  65   VAR a, a2: ADDRESS;
  66       b: CARDINAL;
  67   BEGIN
  68         a := ADR(Buf1[BufCnt]);
  69         a2 := XXTermcap.tgetstr(ADR(id), ADR(a));
  70         res := a2;
  71         IF a2 = NIL THEN
  72                 RETURN FALSE;
  73         END;
  74         b := a - a2;
  75         INC(BufCnt, b);
  76         RETURN TRUE;
  77   END Tgetstr;
  78
  79   PROCEDURE Tputs(cp: STRCAP; affcnt: INTEGER; p: PUTPROC);
  80   BEGIN
  81         XXTermcap.tputs(cp, affcnt, XXTermcap.PUTPROC(p));
  82   END Tputs;
  83
  84   PROCEDURE InitTermcap;
  85   VAR Bf: STR;
  86   BEGIN
  87         IF GetEnv("TERM", Bf) = 0 THEN
  88                 Bf := "dumb";
  89         END;
  90         IF Tgetent(Bf) <= 0 THEN
  91         END;
  92   END InitTermcap;
  93
  94 BEGIN
  95         InitTermcap;
  96 END Termcap.
  97 \0CSP.mod\0mod\0\0\0\0\0\0\0\ 2\ 2�\ 1\0\0$\e(*$R-*)
  98 IMPLEMENTATION MODULE CSP;
  99 (*
 100   Module:       Communicating Sequential Processes
 101   From:         "A Modula-2 Implementation of CSP",
 102                 M. Collado, R. Morales, J.J. Moreno,
 103                 SIGPlan Notices, Volume 22, Number 6, June 1987.
 104                 Some modifications by Ceriel J.H. Jacobs
 105   Version:      $Id: CSP.mod,v 1.10 1994/06/24 12:48:25 ceriel Exp $
 106
 107    See this article for an explanation of the use of this module.
 108 *)
 109
 110   FROM random   IMPORT  Uniform;
 111   FROM SYSTEM   IMPORT  BYTE, ADDRESS, NEWPROCESS, TRANSFER;
 112   FROM Storage  IMPORT  Allocate, Deallocate;
 113   FROM Traps    IMPORT  Message;
 114
 115   CONST WorkSpaceSize = 2000;
 116
 117   TYPE  ByteAddress =   POINTER TO BYTE;
 118         Channel =       POINTER TO ChannelDescriptor;
 119         ProcessType =   POINTER TO ProcessDescriptor;
 120         ProcessDescriptor = RECORD
 121                                 next: ProcessType;
 122                                 father: ProcessType;
 123                                 cor: ADDRESS;
 124                                 wsp: ADDRESS;
 125                                 guardindex: INTEGER;
 126                                 guardno: CARDINAL;
 127                                 guardcount: CARDINAL;
 128                                 opened: Channel;
 129                                 sons: CARDINAL;
 130                                 msgadr: ADDRESS;
 131                                 msglen: CARDINAL;
 132                             END;
 133
 134         Queue = RECORD
 135                     head, tail: ProcessType;
 136                 END;
 137
 138         ChannelDescriptor = RECORD
 139                                 senders: Queue;
 140                                 owner: ProcessType;
 141                                 guardindex: INTEGER;
 142                                 next: Channel;
 143                             END;
 144
 145   VAR   cp: ProcessType;
 146         free, ready: Queue;
 147
 148 (* ------------ Private modules and procedures ------------- *)
 149
 150   MODULE ProcessQueue;
 151
 152     IMPORT      ProcessType, Queue;
 153     EXPORT      Push, Pop, InitQueue, IsEmpty;
 154
 155     PROCEDURE InitQueue(VAR q: Queue);
 156     BEGIN
 157         WITH q DO
 158                 head := NIL;
 159                 tail := NIL
 160         END
 161     END InitQueue;
 162
 163     PROCEDURE Push(p: ProcessType; VAR q: Queue);
 164     BEGIN
 165         p^.next := NIL;
 166         WITH q DO
 167                 IF head = NIL THEN
 168                         tail := p
 169                 ELSE
 170                         head^.next := p
 171                 END;
 172                 head := p
 173         END
 174     END Push;
 175
 176     PROCEDURE Pop(VAR q: Queue; VAR p: ProcessType);
 177     BEGIN
 178         WITH q DO
 179                 p := tail;
 180                 IF p # NIL THEN
 181                         tail := tail^.next;
 182                         IF head = p THEN
 183                                 head := NIL
 184                         END
 185                 END
 186         END
 187     END Pop;
 188
 189     PROCEDURE IsEmpty(q: Queue): BOOLEAN;
 190     BEGIN
 191         RETURN q.head = NIL
 192     END IsEmpty;
 193
 194   END ProcessQueue;
 195
 196
 197   PROCEDURE DoTransfer;
 198     VAR aux: ProcessType;
 199   BEGIN
 200         aux := cp;
 201         Pop(ready, cp);
 202         IF cp = NIL THEN
 203                 HALT
 204         ELSE
 205                 TRANSFER(aux^.cor, cp^.cor)
 206         END
 207   END DoTransfer;
 208
 209   PROCEDURE OpenChannel(ch: Channel; n: INTEGER);
 210   BEGIN
 211         WITH ch^ DO
 212                 IF guardindex = 0 THEN
 213                         guardindex := n;
 214                         next := cp^.opened;
 215                         cp^.opened := ch
 216                 END
 217         END
 218   END OpenChannel;
 219
 220   PROCEDURE CloseChannels(p: ProcessType);
 221   BEGIN
 222         WITH p^ DO
 223                 WHILE opened # NIL DO
 224                         opened^.guardindex := 0;
 225                         opened := opened^.next
 226                 END
 227         END
 228   END CloseChannels;
 229
 230   PROCEDURE ThereAreOpenChannels(): BOOLEAN;
 231   BEGIN
 232         RETURN cp^.opened # NIL;
 233   END ThereAreOpenChannels;
 234
 235   PROCEDURE Sending(ch: Channel): BOOLEAN;
 236   BEGIN
 237         RETURN NOT IsEmpty(ch^.senders)
 238   END Sending;
 239
 240 (* -------------- Public Procedures ----------------- *)
 241
 242   PROCEDURE COBEGIN;
 243   (* Beginning of a COBEGIN .. COEND structure *)
 244   BEGIN
 245   END COBEGIN;
 246
 247   PROCEDURE COEND;
 248   (* End of a COBEGIN .. COEND structure *)
 249     (* VAR      aux: ProcessType; *)
 250   BEGIN
 251         IF cp^.sons > 0 THEN
 252                 DoTransfer
 253         END
 254   END COEND;
 255
 256   PROCEDURE StartProcess(P: PROC);
 257   (* Start an anonimous process that executes the procedure P *)
 258     VAR newprocess: ProcessType;
 259   BEGIN
 260         Pop(free, newprocess);
 261         IF newprocess = NIL THEN
 262                 Allocate(newprocess,SIZE(ProcessDescriptor));
 263                 Allocate(newprocess^.wsp, WorkSpaceSize)
 264         END;
 265         WITH newprocess^ DO
 266                 father := cp;
 267                 sons := 0;
 268                 msglen := 0;
 269                 NEWPROCESS(P, wsp, WorkSpaceSize, cor)
 270         END;
 271         cp^.sons := cp^.sons + 1;
 272         Push(newprocess, ready)
 273   END StartProcess;
 274
 275   PROCEDURE StopProcess;
 276   (* Terminate a Process (itself) *)
 277     VAR aux: ProcessType;
 278   BEGIN
 279         aux := cp^.father;
 280         aux^.sons := aux^.sons - 1;
 281         IF aux^.sons = 0 THEN
 282                 Push(aux, ready)
 283         END;
 284         aux := cp;
 285         Push(aux, free);
 286         Pop(ready, cp);
 287         IF cp = NIL THEN
 288                 HALT
 289         ELSE
 290                 TRANSFER(aux^.cor, cp^.cor)
 291         END
 292   END StopProcess;
 293
 294   PROCEDURE InitChannel(VAR ch: Channel);
 295   (* Initialize the channel ch *)
 296   BEGIN
 297         Allocate(ch, SIZE(ChannelDescriptor));
 298         WITH ch^ DO
 299                 InitQueue(senders);
 300                 owner := NIL;
 301                 next := NIL;
 302                 guardindex := 0
 303         END
 304   END InitChannel;
 305
 306   PROCEDURE GetChannel(ch: Channel);
 307   (* Assign the channel ch to the process that gets it *)
 308   BEGIN
 309         WITH ch^ DO
 310                 IF owner # NIL THEN
 311                         Message("Channel already has an owner");
 312                         HALT
 313                 END;
 314                 owner := cp
 315         END
 316   END GetChannel;
 317
 318   PROCEDURE Send(data: ARRAY OF BYTE; VAR ch: Channel);
 319   (* Send a message with the data to the cvhannel ch *)
 320     VAR m: ByteAddress;
 321         (* aux: ProcessType; *)
 322         i: CARDINAL;
 323   BEGIN
 324         WITH ch^ DO
 325                 Push(cp, senders);
 326                 Allocate(cp^.msgadr, SIZE(data));
 327                 m := cp^.msgadr;
 328                 cp^.msglen := HIGH(data);
 329                 FOR i := 0 TO HIGH(data) DO
 330                         m^ := data[i];
 331                         m := ADDRESS(m) + 1
 332                 END;
 333                 IF guardindex # 0 THEN
 334                         owner^.guardindex := guardindex;
 335                         CloseChannels(owner);
 336                         Push(owner, ready)
 337                 END
 338         END;
 339         DoTransfer
 340   END Send;
 341
 342   PROCEDURE Receive(VAR ch: Channel; VAR dest: ARRAY OF BYTE);
 343   (* Receive a message from the channel ch into the dest variable *)
 344     VAR aux: ProcessType;
 345         m: ByteAddress;
 346         i: CARDINAL;
 347   BEGIN
 348         WITH ch^ DO
 349                 IF cp # owner THEN
 350                         Message("Only owner of channel can receive from it");
 351                         HALT
 352                 END;
 353                 IF Sending(ch) THEN
 354                         Pop(senders, aux);
 355                         m := aux^.msgadr;
 356                         FOR i := 0 TO aux^.msglen DO
 357                                 dest[i] := m^;
 358                                 m := ADDRESS(m) + 1
 359                         END;
 360                         Push(aux, ready);
 361                         Push(cp, ready);
 362                         CloseChannels(cp)
 363                 ELSE
 364                         OpenChannel(ch, -1);
 365                         DoTransfer;
 366                         Pop(senders, aux);
 367                         m := aux^.msgadr;
 368                         FOR i := 0 TO aux^.msglen DO
 369                                 dest[i] := m^;
 370                                 m := ADDRESS(m) + 1
 371                         END;
 372                         Push(cp, ready);
 373                         Push(aux, ready)
 374                 END;
 375                 Deallocate(aux^.msgadr, aux^.msglen+1);
 376                 DoTransfer
 377         END
 378   END Receive;
 379
 380   PROCEDURE SELECT(n: CARDINAL);
 381   (* Beginning of a SELECT structure with n guards *)
 382   BEGIN
 383         cp^.guardindex := Uniform(1,n);
 384         cp^.guardno := n;
 385         cp^.guardcount := n
 386   END SELECT;
 387
 388   PROCEDURE NEXTGUARD(): CARDINAL;
 389   (* Returns an index to the next guard to be evaluated in a SELECT *)
 390   BEGIN
 391         RETURN cp^.guardindex
 392   END NEXTGUARD;
 393
 394   PROCEDURE GUARD(cond: BOOLEAN; ch: Channel;
 395                   VAR dest: ARRAY OF BYTE): BOOLEAN;
 396   (* Evaluates a guard, including reception management *)
 397     (* VAR      aux: ProcessType; *)
 398   BEGIN
 399         IF NOT cond THEN
 400                 RETURN FALSE
 401         ELSIF ch = NIL THEN
 402                 CloseChannels(cp);
 403                 cp^.guardindex := 0;
 404                 RETURN TRUE
 405         ELSIF Sending(ch) THEN
 406                 Receive(ch, dest);
 407                 cp^.guardindex := 0;
 408                 RETURN TRUE
 409         ELSE
 410                 OpenChannel(ch, cp^.guardindex);
 411                 RETURN FALSE
 412         END
 413   END GUARD;
 414
 415   PROCEDURE ENDSELECT(): BOOLEAN;
 416   (* End of a SELECT structure *)
 417   BEGIN
 418         WITH cp^ DO
 419                 IF guardindex <= 0 THEN
 420                         RETURN TRUE
 421                 END;
 422                 guardcount := guardcount - 1;
 423                 IF guardcount # 0 THEN
 424                         guardindex := (guardindex MOD INTEGER(guardno)) + 1
 425                 ELSIF ThereAreOpenChannels() THEN
 426                         DoTransfer
 427                 ELSE
 428                         guardindex := 0
 429                 END
 430         END;
 431         RETURN FALSE
 432   END ENDSELECT;
 433
 434 BEGIN
 435         InitQueue(free);
 436         InitQueue(ready);
 437         Allocate(cp,SIZE(ProcessDescriptor));
 438         WITH cp^ DO
 439                 sons := 0;
 440                 father := NIL
 441         END
 442 END CSP.
 443
 444 PascalIO.mod\0\0\0\0\0\0\ 2\ 2�\ 1\0\0\13$(*
 445   (c) copyright 1988 by the Vrije Universiteit, Amsterdam, The Netherlands.
 446   See the copyright notice in the ACK home directory, in the file "Copyright".
 447 *)
 448
 449 (*$R-*)
 450 IMPLEMENTATION MODULE PascalIO;
 451 (*
 452   Module:       Pascal-like Input/Output
 453   Author:       Ceriel J.H. Jacobs
 454   Version:      $Id: PascalIO.mod,v 1.18 1994/06/24 12:49:12 ceriel Exp $
 455 *)
 456
 457   FROM  Conversions IMPORT
 458                         ConvertInteger, ConvertCardinal;
 459   FROM  RealConversions IMPORT
 460                         LongRealToString, StringToLongReal;
 461   FROM  Traps IMPORT    Message;
 462   FROM  Streams IMPORT  Stream, StreamKind, StreamMode, StreamResult,
 463                         InputStream, OutputStream, OpenStream, CloseStream,
 464                         EndOfStream, Read, Write, StreamBuffering;
 465   FROM  Storage IMPORT  Allocate;
 466   FROM  SYSTEM IMPORT   ADR;
 467
 468   TYPE  charset = SET OF CHAR;
 469         btype = (Preading, Pwriting, free);
 470
 471   CONST spaces = charset{11C, 12C, 13C, 14C, 15C, ' '};
 472
 473   TYPE  IOstream = RECORD
 474                         type: btype;
 475                         done, eof : BOOLEAN;
 476                         ch: CHAR;
 477                         next: Text;
 478                         stream: Stream;
 479                 END;
 480         Text =  POINTER TO IOstream;
 481         numbuf = ARRAY[0..255] OF CHAR;
 482
 483   VAR   ibuf, obuf: IOstream;
 484         head: Text;
 485         result: StreamResult;
 486
 487   PROCEDURE Reset(VAR InputText: Text; Filename: ARRAY OF CHAR);
 488   BEGIN
 489         doclose(InputText);
 490         getstruct(InputText);
 491         WITH InputText^ DO
 492                 OpenStream(stream, Filename, text, reading, result);
 493                 IF result # succeeded THEN
 494                         Message("could not open input file");
 495                         HALT;
 496                 END;
 497                 type := Preading;
 498                 done := FALSE;
 499                 eof := FALSE;
 500         END;
 501   END Reset;
 502
 503   PROCEDURE Rewrite(VAR OutputText: Text; Filename: ARRAY OF CHAR);
 504   BEGIN
 505         doclose(OutputText);
 506         getstruct(OutputText);
 507         WITH OutputText^ DO
 508                 OpenStream(stream, Filename, text, writing, result);
 509                 IF result # succeeded THEN
 510                         Message("could not open output file");
 511                         HALT;
 512                 END;
 513                 type := Pwriting;
 514         END;
 515   END Rewrite;
 516
 517   PROCEDURE CloseOutput();
 518   VAR p: Text;
 519   BEGIN
 520         p := head;
 521         WHILE p # NIL DO
 522                 doclose(p);
 523                 p := p^.next;
 524         END;
 525   END CloseOutput;
 526
 527   PROCEDURE doclose(Xtext: Text);
 528   BEGIN
 529         IF Xtext # Notext THEN
 530                 WITH Xtext^ DO
 531                         IF type # free THEN
 532                                 CloseStream(stream, result);
 533                                 type := free;
 534                         END;
 535                 END;
 536         END;
 537   END doclose;
 538
 539   PROCEDURE getstruct(VAR Xtext: Text);
 540   BEGIN
 541         Xtext := head;
 542         WHILE (Xtext # NIL) AND (Xtext^.type # free) DO
 543                 Xtext := Xtext^.next;
 544         END;
 545         IF Xtext = NIL THEN
 546                 Allocate(Xtext,SIZE(IOstream));
 547                 Xtext^.next := head;
 548                 head := Xtext;
 549         END;
 550   END getstruct;
 551
 552   PROCEDURE Error(tp: btype);
 553   BEGIN
 554         IF tp = Preading THEN
 555                 Message("input text expected");
 556         ELSE
 557                 Message("output text expected");
 558         END;
 559         HALT;
 560   END Error;
 561
 562   PROCEDURE ReadChar(InputText: Text; VAR ch : CHAR);
 563   BEGIN
 564         ch := NextChar(InputText);
 565         IF InputText^.eof THEN
 566                 Message("unexpected EOF");
 567                 HALT;
 568         END;
 569         InputText^.done := FALSE;
 570   END ReadChar;
 571
 572   PROCEDURE NextChar(InputText: Text): CHAR;
 573   BEGIN
 574         WITH InputText^ DO
 575                 IF type # Preading THEN Error(Preading); END;
 576                 IF NOT done THEN
 577                         IF EndOfStream(stream, result) THEN
 578                                 eof := TRUE;
 579                                 ch := 0C;
 580                         ELSE
 581                                 Read(stream, ch, result);
 582                                 done := TRUE;
 583                         END;
 584                 END;
 585                 RETURN ch;
 586         END;
 587   END NextChar;
 588
 589   PROCEDURE Get(InputText: Text);
 590   VAR dummy: CHAR;
 591   BEGIN
 592         ReadChar(InputText, dummy);
 593   END Get;
 594
 595   PROCEDURE Eoln(InputText: Text): BOOLEAN;
 596   BEGIN
 597         RETURN NextChar(InputText) = 12C;
 598   END Eoln;
 599
 600   PROCEDURE Eof(InputText: Text): BOOLEAN;
 601   BEGIN
 602         RETURN (NextChar(InputText) = 0C) AND InputText^.eof;
 603   END Eof;
 604
 605   PROCEDURE ReadLn(InputText: Text);
 606   VAR ch: CHAR;
 607   BEGIN
 608         REPEAT
 609                 ReadChar(InputText, ch)
 610         UNTIL ch = 12C;
 611   END ReadLn;
 612
 613   PROCEDURE WriteChar(OutputText: Text; char: CHAR);
 614   BEGIN
 615         WITH OutputText^ DO
 616                 IF type # Pwriting THEN Error(Pwriting); END;
 617                 Write(stream, char, result);
 618         END;
 619   END WriteChar;
 620
 621   PROCEDURE WriteLn(OutputText: Text);
 622   BEGIN
 623         WriteChar(OutputText, 12C);
 624   END WriteLn;
 625
 626   PROCEDURE Page(OutputText: Text);
 627   BEGIN
 628         WriteChar(OutputText, 14C);
 629   END Page;
 630
 631   PROCEDURE ReadInteger(InputText: Text; VAR int : INTEGER);
 632   CONST
 633         SAFELIMITDIV10 = MAX(INTEGER) DIV 10;
 634         SAFELIMITREM10 = MAX(INTEGER) MOD 10;
 635   VAR
 636         neg : BOOLEAN;
 637         safedigit: CARDINAL;
 638         ch: CHAR;
 639         chvalue: CARDINAL;
 640   BEGIN
 641         WHILE NextChar(InputText) IN spaces DO
 642                 Get(InputText);
 643         END;
 644         ch := NextChar(InputText);
 645         IF ch = '-' THEN
 646                 Get(InputText);
 647                 ch := NextChar(InputText);
 648                 neg := TRUE;
 649         ELSIF ch = '+' THEN
 650                 Get(InputText);
 651                 ch := NextChar(InputText);
 652                 neg := FALSE;
 653         ELSE
 654                 neg := FALSE
 655         END;
 656
 657         safedigit := SAFELIMITREM10;
 658         IF neg THEN safedigit := safedigit + 1 END;
 659         int := 0;
 660         IF (ch >= '0') AND (ch <= '9') THEN
 661                 WHILE (ch >= '0') & (ch <= '9') DO
 662                         chvalue := ORD(ch) - ORD('0');
 663                         IF (int < -SAFELIMITDIV10) OR
 664                            ( (int = -SAFELIMITDIV10) AND
 665                              (chvalue > safedigit)) THEN
 666                                 Message("integer too large");
 667                                 HALT;
 668                         ELSE
 669                                 int := 10*int - VAL(INTEGER, chvalue);
 670                                 Get(InputText);
 671                                 ch := NextChar(InputText);
 672                         END;
 673                 END;
 674                 IF NOT neg THEN
 675                         int := -int
 676                 END;
 677         ELSE
 678                 Message("integer expected");
 679                 HALT;
 680         END;
 681   END ReadInteger;
 682
 683   PROCEDURE ReadCardinal(InputText: Text; VAR card : CARDINAL);
 684   CONST
 685         SAFELIMITDIV10 = MAX(CARDINAL) DIV 10;
 686         SAFELIMITREM10 = MAX(CARDINAL) MOD 10;
 687
 688   VAR
 689         ch : CHAR;
 690         safedigit: CARDINAL;
 691         chvalue: CARDINAL;
 692   BEGIN
 693         WHILE NextChar(InputText) IN spaces DO
 694                 Get(InputText);
 695         END;
 696         ch := NextChar(InputText);
 697         safedigit := SAFELIMITREM10;
 698         card := 0;
 699         IF (ch >= '0') AND (ch <= '9') THEN
 700                 WHILE (ch >= '0') & (ch <= '9') DO
 701                         chvalue := ORD(ch) - ORD('0');
 702                         IF (card > SAFELIMITDIV10) OR
 703                            ( (card = SAFELIMITDIV10) AND
 704                              (chvalue > safedigit)) THEN
 705                                 Message("cardinal too large");
 706                                 HALT;
 707                         ELSE
 708                                 card := 10*card + chvalue;
 709                                 Get(InputText);
 710                                 ch := NextChar(InputText);
 711                         END;
 712                 END;
 713         ELSE
 714                 Message("cardinal expected");
 715                 HALT;
 716         END;
 717   END ReadCardinal;
 718
 719   PROCEDURE ReadReal(InputText: Text; VAR real: REAL);
 720   VAR x1: LONGREAL;
 721   BEGIN
 722         ReadLongReal(InputText, x1);
 723         real := x1
 724   END ReadReal;
 725
 726   PROCEDURE ReadLongReal(InputText: Text; VAR real: LONGREAL);
 727   VAR
 728         buf: numbuf;
 729         ch: CHAR;
 730         ok: BOOLEAN;
 731         index: INTEGER;
 732
 733     PROCEDURE inch(): CHAR;
 734     BEGIN
 735         buf[index] := ch;
 736         INC(index);
 737         Get(InputText);
 738         RETURN NextChar(InputText);
 739     END inch;
 740
 741   BEGIN
 742         index := 0;
 743         ok := TRUE;
 744         WHILE NextChar(InputText) IN spaces DO
 745                 Get(InputText);
 746         END;
 747         ch := NextChar(InputText);
 748         IF (ch ='+') OR (ch = '-') THEN
 749                 ch := inch();
 750         END;
 751         IF (ch >= '0') AND (ch <= '9') THEN
 752                 WHILE (ch >= '0') AND (ch <= '9') DO
 753                         ch := inch();
 754                 END;
 755                 IF (ch = '.') THEN
 756                         ch := inch();
 757                         IF (ch >= '0') AND (ch <= '9') THEN
 758                                 WHILE (ch >= '0') AND (ch <= '9') DO
 759                                         ch := inch();
 760                                 END;
 761                         ELSE
 762                                 ok := FALSE;
 763                         END;
 764                 END;
 765                 IF ok AND (ch = 'E') THEN
 766                         ch := inch();
 767                         IF (ch ='+') OR (ch = '-') THEN
 768                                 ch := inch();
 769                         END;
 770                         IF (ch >= '0') AND (ch <= '9') THEN
 771                                 WHILE (ch >= '0') AND (ch <= '9') DO
 772                                         ch := inch();
 773                                 END;
 774                         ELSE
 775                                 ok := FALSE;
 776                         END;
 777                 END;
 778         ELSE
 779                 ok := FALSE;
 780         END;
 781         IF ok THEN
 782                 buf[index] := 0C;
 783                 StringToLongReal(buf, real, ok);
 784         END;
 785         IF NOT ok THEN
 786                 Message("Illegal real");
 787                 HALT;
 788         END;
 789   END ReadLongReal;
 790
 791   PROCEDURE WriteCardinal(OutputText: Text; card: CARDINAL; width: CARDINAL);
 792   VAR
 793         buf : numbuf;
 794   BEGIN
 795         ConvertCardinal(card, 1, buf);
 796         WriteString(OutputText, buf, width);
 797   END WriteCardinal;
 798
 799   PROCEDURE WriteInteger(OutputText: Text; int: INTEGER; width: CARDINAL);
 800   VAR
 801         buf : numbuf;
 802   BEGIN
 803         ConvertInteger(int, 1, buf);
 804         WriteString(OutputText, buf, width);
 805   END WriteInteger;
 806
 807   PROCEDURE WriteBoolean(OutputText: Text; bool: BOOLEAN; width: CARDINAL);
 808   BEGIN
 809         IF bool THEN
 810                 WriteString(OutputText, " TRUE", width);
 811         ELSE
 812                 WriteString(OutputText, "FALSE", width);
 813         END;
 814   END WriteBoolean;
 815
 816   PROCEDURE WriteReal(OutputText: Text; real: REAL; width, nfrac: CARDINAL);
 817   BEGIN
 818         WriteLongReal(OutputText, LONG(real), width, nfrac)
 819   END WriteReal;
 820
 821   PROCEDURE WriteLongReal(OutputText: Text; real: LONGREAL; width, nfrac: CARDINAL);
 822   VAR
 823         buf: numbuf;
 824         ok: BOOLEAN;
 825         digits: INTEGER;
 826   BEGIN
 827         IF width > SIZE(buf) THEN
 828                 width := SIZE(buf);
 829         END;
 830         IF nfrac > 0 THEN
 831                 LongRealToString(real, width, nfrac, buf, ok);
 832         ELSE
 833                 IF width < 9 THEN width := 9; END;
 834                 IF real < 0.0D THEN
 835                         digits := 7 - INTEGER(width);
 836                 ELSE
 837                         digits := 6 - INTEGER(width);
 838                 END;
 839                 LongRealToString(real, width, digits, buf, ok);
 840         END;
 841         WriteString(OutputText, buf, 0);
 842   END WriteLongReal;
 843
 844   PROCEDURE WriteString(OutputText: Text; str: ARRAY OF CHAR; width: CARDINAL);
 845   VAR index: CARDINAL;
 846   BEGIN
 847         index := 0;
 848         WHILE (index <= HIGH(str)) AND (str[index] # Eos) DO
 849                 INC(index);
 850         END;
 851         WHILE index < width DO
 852                 WriteChar(OutputText, " ");
 853                 INC(index);
 854         END;
 855         index := 0;
 856         WHILE (index <= HIGH(str)) AND (str[index] # Eos) DO
 857                 WriteChar(OutputText, str[index]);
 858                 INC(index);
 859         END;
 860   END WriteString;
 861
 862 BEGIN   (* PascalIO initialization *)
 863         WITH ibuf DO
 864                 stream := InputStream;
 865                 eof := FALSE;
 866                 type := Preading;
 867                 done := FALSE;
 868         END;
 869         WITH obuf DO
 870                 stream := OutputStream;
 871                 eof := FALSE;
 872                 type := Pwriting;
 873         END;
 874         Notext := NIL;
 875         Input := ADR(ibuf);
 876         Output := ADR(obuf);
 877         Input^.next := Output;
 878         Output^.next := NIL;
 879         head := Input;
 880 END PascalIO.
 881 \0RealInOut.mod\0\0\0\0\0\ 2\ 2�\ 1\0\02\b(*
 882   (c) copyright 1988 by the Vrije Universiteit, Amsterdam, The Netherlands.
 883   See the copyright notice in the ACK home directory, in the file "Copyright".
 884 *)
 885
 886 (*$R-*)
 887 IMPLEMENTATION MODULE RealInOut;
 888 (*
 889   Module:       InOut for REAL numbers
 890   Author:       Ceriel J.H. Jacobs
 891   Version:      $Id: RealInOut.mod,v 1.11 1994/06/24 12:49:31 ceriel Exp $
 892 *)
 893
 894   FROM  InOut IMPORT    ReadString, WriteString, WriteOct;
 895   FROM  Traps IMPORT    Message;
 896   FROM  SYSTEM IMPORT   WORD;
 897   FROM  RealConversions IMPORT
 898                         LongRealToString, StringToLongReal;
 899
 900   CONST MAXNDIG = 32;
 901         MAXWIDTH = MAXNDIG+7;
 902   TYPE  RBUF = ARRAY [0..MAXWIDTH+1] OF CHAR;
 903
 904   PROCEDURE WriteReal(arg: REAL; ndigits: CARDINAL);
 905   BEGIN
 906         WriteLongReal(LONG(arg), ndigits)
 907   END WriteReal;
 908
 909   PROCEDURE WriteLongReal(arg: LONGREAL; ndigits: CARDINAL);
 910     VAR buf : RBUF;
 911         ok : BOOLEAN;
 912
 913   BEGIN
 914         IF ndigits > MAXWIDTH THEN ndigits := MAXWIDTH; END;
 915         IF ndigits < 10 THEN ndigits := 10; END;
 916         LongRealToString(arg, ndigits, -INTEGER(ndigits - 7), buf, ok);
 917         WriteString(buf);
 918   END WriteLongReal;
 919
 920   PROCEDURE WriteFixPt(arg: REAL; n, k: CARDINAL);
 921   BEGIN
 922         WriteLongFixPt(LONG(arg), n, k)
 923   END WriteFixPt;
 924
 925   PROCEDURE WriteLongFixPt(arg: LONGREAL; n, k: CARDINAL);
 926   VAR buf: RBUF;
 927       ok : BOOLEAN;
 928
 929   BEGIN
 930         IF n > MAXWIDTH THEN n := MAXWIDTH END;
 931         LongRealToString(arg, n, k, buf, ok);
 932         WriteString(buf);
 933   END WriteLongFixPt;
 934
 935   PROCEDURE ReadReal(VAR x: REAL);
 936   VAR x1: LONGREAL;
 937   BEGIN
 938         ReadLongReal(x1);
 939         x := x1
 940   END ReadReal;
 941
 942   PROCEDURE ReadLongReal(VAR x: LONGREAL);
 943     VAR Buf: ARRAY[0..512] OF CHAR;
 944         ok: BOOLEAN;
 945
 946   BEGIN
 947         ReadString(Buf);
 948         StringToLongReal(Buf, x, ok);
 949         IF NOT ok THEN
 950                 Message("real expected");
 951                 HALT;
 952         END;
 953         Done := TRUE;
 954   END ReadLongReal;
 955
 956   PROCEDURE wroct(x: ARRAY OF WORD);
 957   VAR   i: CARDINAL;
 958   BEGIN
 959         FOR i := 0 TO HIGH(x) DO
 960                 WriteOct(CARDINAL(x[i]), 0);
 961                 WriteString("  ");
 962         END;
 963   END wroct;
 964
 965   PROCEDURE WriteRealOct(x: REAL);
 966   BEGIN
 967         wroct(x);
 968   END WriteRealOct;
 969
 970   PROCEDURE WriteLongRealOct(x: LONGREAL);
 971   BEGIN
 972         wroct(x);
 973   END WriteLongRealOct;
 974
 975 BEGIN
 976         Done := FALSE;
 977 END RealInOut.
 978 InOut.mod\0mod\0\0\0\0\0\ 2\ 2�\ 1\0\0�\1d(*
 979   (c) copyright 1988 by the Vrije Universiteit, Amsterdam, The Netherlands.
 980   See the copyright notice in the ACK home directory, in the file "Copyright".
 981 *)
 982
 983 (*$R-*)
 984 IMPLEMENTATION MODULE InOut ;
 985 (*
 986   Module:       Wirth's Input/Output module
 987   Author:       Ceriel J.H. Jacobs
 988   Version:      $Id: InOut.mod,v 1.19 1994/06/24 12:48:49 ceriel Exp $
 989 *)
 990
 991   IMPORT        Streams;
 992   FROM  Conversions IMPORT
 993                         ConvertCardinal, ConvertInteger,
 994                         ConvertOctal, ConvertHex;
 995   FROM  Traps IMPORT    Message;
 996
 997   CONST TAB = 11C;
 998
 999   TYPE  numbuf = ARRAY[0..255] OF CHAR;
1000
1001   VAR   unread: BOOLEAN;
1002         unreadch: CHAR;
1003         CurrIn, CurrOut: Streams.Stream;
1004         result: Streams.StreamResult;
1005
1006   PROCEDURE Read(VAR c : CHAR);
1007
1008   BEGIN
1009         IF unread THEN
1010                 unread := FALSE;
1011                 c := unreadch;
1012                 Done := TRUE;
1013         ELSE
1014                 Streams.Read(CurrIn, c, result);
1015                 Done := result = Streams.succeeded;
1016         END;
1017   END Read;
1018
1019   PROCEDURE UnRead(ch: CHAR);
1020   BEGIN
1021         unread := TRUE;
1022         unreadch := ch;
1023   END UnRead;
1024
1025   PROCEDURE Write(c: CHAR);
1026   BEGIN
1027         Streams.Write(CurrOut, c, result);
1028   END Write;
1029
1030   PROCEDURE OpenInput(defext: ARRAY OF CHAR);
1031   VAR namebuf : ARRAY [1..128] OF CHAR;
1032   BEGIN
1033         IF CurrIn # Streams.InputStream THEN
1034                 Streams.CloseStream(CurrIn, result);
1035         END;
1036         MakeFileName("Name of input file: ", defext, namebuf);
1037         IF NOT Done THEN RETURN; END;
1038         openinput(namebuf);
1039   END OpenInput;
1040
1041   PROCEDURE OpenInputFile(filename: ARRAY OF CHAR);
1042   BEGIN
1043         IF CurrIn # Streams.InputStream THEN
1044                 Streams.CloseStream(CurrIn, result);
1045         END;
1046         openinput(filename);
1047   END OpenInputFile;
1048
1049   PROCEDURE openinput(namebuf: ARRAY OF CHAR);
1050   BEGIN
1051         IF (namebuf[0] = '-') AND (namebuf[1] = 0C) THEN
1052                 CurrIn := Streams.InputStream;
1053                 Done := TRUE;
1054         ELSE
1055                 Streams.OpenStream(CurrIn, namebuf, Streams.text,
1056                                    Streams.reading, result);
1057                 Done := result = Streams.succeeded;
1058         END;
1059   END openinput;
1060
1061   PROCEDURE CloseInput;
1062   BEGIN
1063         IF CurrIn # Streams.InputStream THEN
1064                 Streams.CloseStream(CurrIn, result);
1065         END;
1066         CurrIn := Streams.InputStream;
1067   END CloseInput;
1068
1069   PROCEDURE OpenOutput(defext: ARRAY OF CHAR);
1070   VAR namebuf : ARRAY [1..128] OF CHAR;
1071   BEGIN
1072         IF CurrOut # Streams.OutputStream THEN
1073                 Streams.CloseStream(CurrOut, result);
1074         END;
1075         MakeFileName("Name of output file: ", defext, namebuf);
1076         IF NOT Done THEN RETURN; END;
1077         openoutput(namebuf);
1078   END OpenOutput;
1079
1080   PROCEDURE OpenOutputFile(filename: ARRAY OF CHAR);
1081   BEGIN
1082         IF CurrOut # Streams.OutputStream THEN
1083                 Streams.CloseStream(CurrOut, result);
1084         END;
1085         openoutput(filename);
1086   END OpenOutputFile;
1087
1088   PROCEDURE openoutput(namebuf: ARRAY OF CHAR);
1089   BEGIN
1090         IF (namebuf[1] = '-') AND (namebuf[2] = 0C) THEN
1091                 CurrOut := Streams.OutputStream;
1092                 Done := TRUE;
1093         ELSE
1094                 Streams.OpenStream(CurrOut, namebuf, Streams.text,
1095                                    Streams.writing, result);
1096                 Done := result = Streams.succeeded;
1097         END;
1098   END openoutput;
1099
1100   PROCEDURE CloseOutput;
1101   BEGIN
1102         IF CurrOut # Streams.OutputStream THEN
1103                 Streams.CloseStream(CurrOut, result);
1104         END;
1105         CurrOut := Streams.OutputStream;
1106   END CloseOutput;
1107
1108   PROCEDURE MakeFileName(prompt, defext : ARRAY OF CHAR;
1109                        VAR buf : ARRAY OF CHAR);
1110   VAR   i : INTEGER;
1111         j : CARDINAL;
1112   BEGIN
1113         Done := TRUE;
1114         IF Streams.isatty(Streams.InputStream, result) THEN
1115                 XWriteString(prompt);
1116         END;
1117         XReadString(buf);
1118         i := 0;
1119         WHILE buf[i] # 0C DO i := i + 1 END;
1120         IF i # 0 THEN
1121                 i := i - 1;
1122                 IF buf[i] = '.' THEN
1123                         FOR j := 0 TO HIGH(defext) DO
1124                                 i := i + 1;
1125                                 buf[i] := defext[j];
1126                         END;
1127                         buf[i+1] := 0C;
1128                 END;
1129                 RETURN;
1130         END;
1131         Done := FALSE;
1132   END MakeFileName;
1133
1134   PROCEDURE ReadInt(VAR integ : INTEGER);
1135   CONST
1136         SAFELIMITDIV10 = MAX(INTEGER) DIV 10;
1137         SAFELIMITREM10 = MAX(INTEGER) MOD 10;
1138   TYPE
1139         itype = [0..31];
1140         ibuf =  ARRAY itype OF CHAR;
1141   VAR
1142         int : INTEGER;
1143         neg : BOOLEAN;
1144         safedigit: [0 .. 9];
1145         chvalue: CARDINAL;
1146         buf : ibuf;
1147         index : itype;
1148   BEGIN
1149         ReadString(buf);
1150         IF NOT Done THEN
1151                 RETURN
1152         END;
1153         index := 0;
1154         IF buf[index] = '-' THEN
1155                 neg := TRUE;
1156                 INC(index);
1157         ELSIF buf[index] = '+' THEN
1158                 neg := FALSE;
1159                 INC(index);
1160         ELSE
1161                 neg := FALSE
1162         END;
1163
1164         safedigit := SAFELIMITREM10;
1165         IF neg THEN safedigit := safedigit + 1 END;
1166         int := 0;
1167         WHILE (buf[index] >= '0') & (buf[index] <= '9') DO
1168                 chvalue := ORD(buf[index]) - ORD('0');
1169                 IF (int > SAFELIMITDIV10) OR
1170                    ( (int = SAFELIMITDIV10) AND
1171                      (chvalue > safedigit)) THEN
1172                         Message("integer too large");
1173                         HALT;
1174                 ELSE
1175                         int := 10*int + VAL(INTEGER, chvalue);
1176                         INC(index)
1177                 END;
1178         END;
1179         IF neg THEN
1180                 integ := -int
1181         ELSE
1182                 integ := int
1183         END;
1184         IF buf[index] > " " THEN
1185                 Message("illegal integer");
1186                 HALT;
1187         END;
1188         Done := TRUE;
1189   END ReadInt;
1190
1191   PROCEDURE ReadCard(VAR card : CARDINAL);
1192   CONST
1193         SAFELIMITDIV10 = MAX(CARDINAL) DIV 10;
1194         SAFELIMITREM10 = MAX(CARDINAL) MOD 10;
1195
1196   TYPE
1197         itype = [0..31];
1198         ibuf =  ARRAY itype OF CHAR;
1199
1200   VAR
1201         int : CARDINAL;
1202         index  : itype;
1203         buf : ibuf;
1204         safedigit: [0 .. 9];
1205         chvalue: CARDINAL;
1206   BEGIN
1207         ReadString(buf);
1208         IF NOT Done THEN RETURN; END;
1209         index := 0;
1210         safedigit := SAFELIMITREM10;
1211         int := 0;
1212         WHILE (buf[index] >= '0') & (buf[index] <= '9') DO
1213                 chvalue := ORD(buf[index]) - ORD('0');
1214                 IF (int > SAFELIMITDIV10) OR
1215                    ( (int = SAFELIMITDIV10) AND
1216                      (chvalue > safedigit)) THEN
1217                         Message("cardinal too large");
1218                         HALT;
1219                 ELSE
1220                         int := 10*int + chvalue;
1221                         INC(index);
1222                 END;
1223         END;
1224         IF buf[index] > " " THEN
1225                 Message("illegal cardinal");
1226                 HALT;
1227         END;
1228         card := int;
1229         Done := TRUE;
1230   END ReadCard;
1231
1232   PROCEDURE ReadString(VAR s : ARRAY OF CHAR);
1233   TYPE charset = SET OF CHAR;
1234   VAR   i : CARDINAL;
1235         ch : CHAR;
1236
1237   BEGIN
1238         i := 0;
1239         REPEAT
1240                 Read(ch);
1241         UNTIL NOT (ch IN charset{' ', TAB, 12C, 15C});
1242         IF NOT Done THEN
1243                 RETURN;
1244         END;
1245         UnRead(ch);
1246         REPEAT
1247                 Read(ch);
1248                 termCH := ch;
1249                 IF i <= HIGH(s) THEN
1250                         s[i] := ch;
1251                         IF (NOT Done) OR (ch <= " ") THEN
1252                                 s[i] := 0C;
1253                         END;
1254                 END;
1255                 INC(i);
1256         UNTIL (NOT Done) OR (ch <= " ");
1257         IF Done THEN UnRead(ch); END;
1258   END ReadString;
1259
1260   PROCEDURE XReadString(VAR s : ARRAY OF CHAR);
1261   VAR   j : CARDINAL;
1262         ch : CHAR;
1263
1264   BEGIN
1265         j := 0;
1266         LOOP
1267                 Streams.Read(Streams.InputStream, ch, result);
1268                 IF result # Streams.succeeded THEN
1269                         EXIT;
1270                 END;
1271                 IF ch <= " " THEN
1272                         s[j] := 0C;
1273                         EXIT;
1274                 END;
1275                 IF j < HIGH(s) THEN
1276                         s[j] := ch;
1277                         INC(j);
1278                 END;
1279         END;
1280   END XReadString;
1281
1282   PROCEDURE XWriteString(s: ARRAY OF CHAR);
1283   VAR i: CARDINAL;
1284   BEGIN
1285         i := 0;
1286         LOOP
1287                 IF (i <= HIGH(s)) AND (s[i] # 0C) THEN
1288                         Streams.Write(Streams.OutputStream, s[i], result);
1289                         INC(i);
1290                 ELSE
1291                         EXIT;
1292                 END;
1293         END;
1294   END XWriteString;
1295
1296   PROCEDURE WriteCard(card, width : CARDINAL);
1297   VAR
1298         buf : numbuf;
1299   BEGIN
1300         ConvertCardinal(card, width, buf);
1301         WriteString(buf);
1302   END WriteCard;
1303
1304   PROCEDURE WriteInt(int : INTEGER; width : CARDINAL);
1305   VAR
1306         buf : numbuf;
1307   BEGIN
1308         ConvertInteger(int, width, buf);
1309         WriteString(buf);
1310   END WriteInt;
1311
1312   PROCEDURE WriteHex(card, width : CARDINAL);
1313   VAR
1314         buf : numbuf;
1315   BEGIN
1316         ConvertHex(card, width, buf);
1317         WriteString(buf);
1318   END WriteHex;
1319
1320   PROCEDURE WriteLn;
1321   BEGIN
1322         Write(EOL)
1323   END WriteLn;
1324
1325   PROCEDURE WriteOct(card, width : CARDINAL);
1326   VAR
1327         buf : numbuf;
1328   BEGIN
1329         ConvertOctal(card, width, buf);
1330         WriteString(buf);
1331   END WriteOct;
1332
1333   PROCEDURE WriteString(str : ARRAY OF CHAR);
1334   VAR
1335         nbytes : CARDINAL;
1336   BEGIN
1337         nbytes := 0;
1338         WHILE (nbytes <= HIGH(str)) AND (str[nbytes] # 0C) DO
1339                 Write(str[nbytes]);
1340                 INC(nbytes)
1341         END;
1342   END WriteString;
1343
1344 BEGIN   (* InOut initialization *)
1345         CurrIn := Streams.InputStream;
1346         CurrOut := Streams.OutputStream;
1347         unread := FALSE;
1348 END InOut.
1349 Streams.mod\0d\0\0\0\0\0\ 2\ 2�\ 1\0\05&#
1350 (*
1351   (c) copyright 1988 by the Vrije Universiteit, Amsterdam, The Netherlands.
1352   See the copyright notice in the ACK home directory, in the file "Copyright".
1353 *)
1354
1355 (*$R-*)
1356 IMPLEMENTATION MODULE Streams;
1357 (*
1358   Module:       Stream Input/Output
1359   Author:       Ceriel J.H. Jacobs
1360   Version:      $Id: Streams.mod,v 1.12 1994/06/24 12:49:57 ceriel Exp $
1361
1362   Implementation for Unix
1363 *)
1364
1365   FROM  SYSTEM IMPORT   BYTE, ADR;
1366   FROM  Epilogue IMPORT CallAtEnd;
1367   FROM  Storage IMPORT  Allocate, Available;
1368   FROM  StripUnix IMPORT
1369                         open, close, lseek, read, write, creat, ioctl;
1370
1371   CONST BUFSIZ = 1024;  (* tunable *)
1372   TYPE  IOB = RECORD
1373                 kind: StreamKind;
1374                 mode: StreamMode;
1375                 eof: BOOLEAN;
1376                 buffering: StreamBuffering;
1377                 next : Stream;
1378                 fildes: INTEGER;
1379                 cnt, maxcnt: INTEGER;
1380                 bufferedcnt: INTEGER;
1381                 buf: ARRAY[1..BUFSIZ] OF BYTE;
1382               END;
1383         Stream = POINTER TO IOB;
1384   VAR
1385         ibuf, obuf, ebuf: IOB;
1386         head: Stream;
1387
1388   PROCEDURE getstruct(VAR stream: Stream);
1389   BEGIN
1390         stream := head;
1391         WHILE (stream # NIL) AND (stream^.kind # none) DO
1392                 stream := stream^.next;
1393         END;
1394         IF stream = NIL THEN
1395                 IF NOT Available(SIZE(IOB)) THEN
1396                         RETURN;
1397                 END;
1398                 Allocate(stream,SIZE(IOB));
1399                 stream^.next := head;
1400                 head := stream;
1401         END;
1402   END getstruct;
1403
1404   PROCEDURE freestruct(stream: Stream);
1405   BEGIN
1406         stream^.kind := none;
1407   END freestruct;
1408
1409   PROCEDURE OpenStream(VAR stream: Stream;
1410                        filename: ARRAY OF CHAR;
1411                        kind: StreamKind;
1412                        mode: StreamMode;
1413                        VAR result: StreamResult);
1414     VAR fd: INTEGER;
1415         i: CARDINAL;
1416   BEGIN
1417         IF kind = none THEN
1418                 result := illegaloperation;
1419                 RETURN;
1420         END;
1421         getstruct(stream);
1422         IF stream = NIL THEN
1423                 result := nomemory;
1424                 RETURN;
1425         END;
1426         WITH stream^ DO
1427                 FOR i := 0 TO HIGH(filename) DO
1428                         buf[i+1] := BYTE(filename[i]);
1429                 END;
1430                 buf[HIGH(filename)+2] := BYTE(0C);
1431         END;
1432         IF (mode = reading) THEN
1433                 fd := open(ADR(stream^.buf), 0);
1434         ELSE
1435                 fd := -1;
1436                 IF (mode = appending) THEN
1437                         fd := open(ADR(stream^.buf), 1);
1438                         IF fd >= 0 THEN
1439                                 IF (lseek(fd, 0D , 2) < 0D) THEN ; END;
1440                         END;
1441                 END;
1442                 IF fd < 0 THEN
1443                         fd := creat(ADR(stream^.buf), 666B);
1444                 END;
1445         END;
1446         IF fd < 0 THEN
1447                 result := openfailed;
1448                 freestruct(stream);
1449                 stream := NIL;
1450                 RETURN;
1451         END;
1452         result := succeeded;
1453         stream^.fildes := fd;
1454         stream^.kind := kind;
1455         stream^.mode := mode;
1456         stream^.buffering := blockbuffered;
1457         stream^.bufferedcnt := BUFSIZ;
1458         stream^.maxcnt := 0;
1459         stream^.eof := FALSE;
1460         IF mode = reading THEN
1461                 stream^.cnt := 1;
1462         ELSE
1463                 stream^.cnt := 0;
1464         END;
1465   END OpenStream;
1466
1467   PROCEDURE SetStreamBuffering( stream: Stream;
1468                                 b: StreamBuffering;
1469                                 VAR result: StreamResult);
1470   BEGIN
1471         result := succeeded;
1472         IF (stream = NIL) OR (stream^.kind = none) THEN
1473                 result := nostream;
1474                 RETURN;
1475         END;
1476         IF (stream^.mode = reading) OR
1477            ((b = linebuffered) AND (stream^.kind = binary)) THEN
1478                 result := illegaloperation;
1479                 RETURN;
1480         END;
1481         FlushStream(stream, result);
1482         IF b = unbuffered THEN
1483                 stream^.bufferedcnt := 1;
1484         END;
1485         stream^.buffering := b;
1486   END SetStreamBuffering;
1487
1488   PROCEDURE FlushStream(stream: Stream; VAR result: StreamResult);
1489   VAR cnt1: INTEGER;
1490   BEGIN
1491         result := succeeded;
1492         IF (stream = NIL) OR (stream^.kind = none) THEN
1493                 result := nostream;
1494                 RETURN;
1495         END;
1496         WITH stream^ DO
1497                 IF mode = reading THEN
1498                         result := illegaloperation;
1499                         RETURN;
1500                 END;
1501                 IF (cnt > 0) THEN
1502                         cnt1 := cnt;
1503                         cnt := 0;
1504                         IF write(fildes, ADR(buf), cnt1) < 0 THEN END;
1505                 END;
1506         END;
1507   END FlushStream;
1508
1509   PROCEDURE CloseStream(VAR stream: Stream; VAR result: StreamResult);
1510   BEGIN
1511         IF (stream # NIL) AND (stream^.kind # none) THEN
1512                 result := succeeded;
1513                 IF stream^.mode # reading THEN
1514                         FlushStream(stream, result);
1515                 END;
1516                 IF close(stream^.fildes) < 0 THEN ; END;
1517                 freestruct(stream);
1518         ELSE
1519                 result := nostream;
1520         END;
1521         stream := NIL;
1522   END CloseStream;
1523
1524   PROCEDURE EndOfStream(stream: Stream; VAR result: StreamResult): BOOLEAN;
1525   BEGIN
1526         result := succeeded;
1527         IF (stream = NIL) OR (stream^.kind = none) THEN
1528                 result := nostream;
1529                 RETURN FALSE;
1530         END;
1531         IF stream^.mode # reading THEN
1532                 result := illegaloperation;
1533                 RETURN FALSE;
1534         END;
1535         IF stream^.eof THEN RETURN TRUE; END;
1536         RETURN (CHAR(NextByte(stream)) = 0C) AND stream^.eof;
1537   END EndOfStream;
1538
1539   PROCEDURE FlushLineBuffers();
1540   VAR   s: Stream;
1541         result: StreamResult;
1542   BEGIN
1543         s := head;
1544         WHILE s # NIL DO
1545                 IF (s^.kind # none) AND (s^.buffering = linebuffered) THEN
1546                         FlushStream(s, result);
1547                 END;
1548                 s := s^.next;
1549         END;
1550   END FlushLineBuffers;
1551
1552   PROCEDURE NextByte(stream: Stream): BYTE;
1553   VAR c: BYTE;
1554   BEGIN
1555         WITH stream^ DO
1556                 IF cnt <= maxcnt THEN
1557                         c := buf[cnt];
1558                 ELSE
1559                         IF eof THEN RETURN BYTE(0C); END;
1560                         IF stream = InputStream THEN
1561                                 FlushLineBuffers();
1562                         END;
1563                         maxcnt := read(fildes, ADR(buf), bufferedcnt);
1564                         cnt := 1;
1565                         IF maxcnt <= 0 THEN
1566                                 eof := TRUE;
1567                                 c := BYTE(0C);
1568                         ELSE
1569                                 c := buf[1];
1570                         END;
1571                 END;
1572         END;
1573         RETURN c;
1574   END NextByte;
1575
1576   PROCEDURE Read(stream: Stream; VAR ch: CHAR; VAR result: StreamResult);
1577   VAR EoF: BOOLEAN;
1578   BEGIN
1579         ch := 0C;
1580         EoF := EndOfStream(stream, result);
1581         IF result # succeeded THEN RETURN; END;
1582         IF EoF THEN
1583                 result := endoffile;
1584                 RETURN;
1585         END;
1586         WITH stream^ DO
1587                 ch := CHAR(buf[cnt]);
1588                 INC(cnt);
1589         END;
1590   END Read;
1591
1592   PROCEDURE ReadByte(stream: Stream; VAR byte: BYTE; VAR result: StreamResult);
1593   VAR EoF: BOOLEAN;
1594   BEGIN
1595         byte := BYTE(0C);
1596         EoF := EndOfStream(stream, result);
1597         IF result # succeeded THEN RETURN; END;
1598         IF EoF THEN
1599                 result := endoffile;
1600                 RETURN;
1601         END;
1602         WITH stream^ DO
1603                 byte := buf[cnt];
1604                 INC(cnt);
1605         END;
1606   END ReadByte;
1607
1608   PROCEDURE ReadBytes(stream: Stream;
1609                       VAR bytes: ARRAY OF BYTE;
1610                       VAR result: StreamResult);
1611   VAR i: CARDINAL;
1612   BEGIN
1613         FOR i := 0 TO HIGH(bytes) DO
1614                 ReadByte(stream, bytes[i], result);
1615         END;
1616   END ReadBytes;
1617
1618   PROCEDURE Write(stream: Stream; ch: CHAR; VAR result: StreamResult);
1619   BEGIN
1620         IF (stream = NIL) OR (stream^.kind = none) THEN
1621                 result := nostream;
1622                 RETURN;
1623         END;
1624         IF (stream^.kind # text) OR (stream^.mode = reading) THEN
1625                 result := illegaloperation;
1626                 RETURN;
1627         END;
1628         WITH stream^ DO
1629                 INC(cnt);
1630                 buf[cnt] := BYTE(ch);
1631                 IF (cnt >= bufferedcnt) OR
1632                    ((ch = 12C) AND (buffering = linebuffered))
1633                 THEN
1634                         FlushStream(stream, result);
1635                 END;
1636         END;
1637   END Write;
1638
1639   PROCEDURE WriteByte(stream: Stream; byte: BYTE; VAR result: StreamResult);
1640   BEGIN
1641         IF (stream = NIL) OR (stream^.kind = none) THEN
1642                 result := nostream;
1643                 RETURN;
1644         END;
1645         IF (stream^.kind # binary) OR (stream^.mode = reading) THEN
1646                 result := illegaloperation;
1647                 RETURN;
1648         END;
1649         WITH stream^ DO
1650                 INC(cnt);
1651                 buf[cnt] := byte;
1652                 IF cnt >= bufferedcnt THEN
1653                         FlushStream(stream, result);
1654                 END;
1655         END;
1656   END WriteByte;
1657
1658   PROCEDURE WriteBytes(stream: Stream; bytes: ARRAY OF BYTE; VAR result: StreamResult);
1659   VAR i: CARDINAL;
1660   BEGIN
1661         FOR i := 0 TO HIGH(bytes) DO
1662                 WriteByte(stream, bytes[i], result);
1663         END;
1664   END WriteBytes;
1665
1666   PROCEDURE EndIt;
1667   VAR h, h1 : Stream;
1668       result: StreamResult;
1669   BEGIN
1670         h := head;
1671         WHILE h # NIL DO
1672                 h1 := h;
1673                 CloseStream(h1, result);
1674                 h := h^.next;
1675         END;
1676   END EndIt;
1677
1678   PROCEDURE GetPosition(s: Stream; VAR position: LONGINT;
1679                         VAR result: StreamResult);
1680   BEGIN
1681         IF (s = NIL) OR (s^.kind = none) THEN
1682                 result := illegaloperation;
1683                 RETURN;
1684         END;
1685         IF (s^.mode # reading) THEN FlushStream(s, result); END;
1686         position := lseek(s^.fildes, 0D, 1);
1687         IF position < 0D THEN
1688                 result := illegaloperation;
1689                 RETURN;
1690         END;
1691         IF s^.mode = reading THEN
1692                 position := position + LONG(s^.maxcnt - s^.cnt + 1);
1693         END;
1694   END GetPosition;
1695
1696   PROCEDURE SetPosition(s: Stream; position: LONGINT; VAR result: StreamResult);
1697   VAR currpos: LONGINT;
1698   BEGIN
1699         currpos := 0D;
1700         IF (s = NIL) OR (s^.kind = none) THEN
1701                 result := nostream;
1702                 RETURN;
1703         END;
1704         IF (s^.mode # reading) THEN
1705                 FlushStream(s, result);
1706         ELSE
1707                 s^.maxcnt := 0;
1708                 s^.eof := FALSE;
1709         END;
1710         IF s^.mode = appending THEN
1711                 currpos := lseek(s^.fildes, 0D, 1);
1712                 IF currpos < 0D THEN
1713                         result := illegaloperation;
1714                         RETURN;
1715                 END;
1716         END;
1717         IF position < currpos THEN
1718                 result := illegaloperation;
1719                 RETURN;
1720         END;
1721         currpos := lseek(s^.fildes, position, 0);
1722         IF currpos < 0D THEN
1723                 result := illegaloperation;
1724                 RETURN;
1725         END;
1726         result := succeeded;
1727   END SetPosition;
1728
1729   PROCEDURE isatty(stream: Stream; VAR result: StreamResult): BOOLEAN;
1730     VAR buf: ARRAY[1..100] OF CHAR;
1731   BEGIN
1732         IF (stream = NIL) OR (stream^.kind = none) THEN
1733                 result := nostream;
1734                 RETURN FALSE;
1735         END;
1736 #ifdef __USG
1737         RETURN ioctl(stream^.fildes, INTEGER(ORD('T') * 256 + 1), ADR(buf)) >= 0;
1738 #else
1739 #ifdef __BSD4_2
1740         RETURN ioctl(stream^.fildes, INTEGER(ORD('t') * 256 + 8 + 6*65536 + 40000000H), ADR(buf)) >= 0;
1741 #else
1742         RETURN ioctl(stream^.fildes, INTEGER(ORD('t') * 256 + 8), ADR(buf)) >= 0;
1743 #endif
1744 #endif
1745   END isatty;
1746
1747   PROCEDURE InitStreams;
1748   VAR result: StreamResult;
1749   BEGIN
1750         InputStream := ADR(ibuf);
1751         OutputStream := ADR(obuf);
1752         ErrorStream := ADR(ebuf);
1753         WITH ibuf DO
1754                 kind := text;
1755                 mode := reading;
1756                 eof := FALSE;
1757                 next := ADR(obuf);
1758                 fildes := 0;
1759                 maxcnt := 0;
1760                 cnt := 1;
1761                 bufferedcnt := BUFSIZ;
1762         END;
1763         WITH obuf DO
1764                 kind := text;
1765                 mode := writing;
1766                 eof := TRUE;
1767                 next := ADR(ebuf);
1768                 fildes := 1;
1769                 maxcnt := 0;
1770                 cnt := 0;
1771                 bufferedcnt := BUFSIZ;
1772                 IF isatty(OutputStream, result) THEN
1773                         buffering := linebuffered;
1774                 ELSE
1775                         buffering := blockbuffered;
1776                 END;
1777         END;
1778         WITH ebuf DO
1779                 kind := text;
1780                 mode := writing;
1781                 eof := TRUE;
1782                 next := NIL;
1783                 fildes := 2;
1784                 maxcnt := 0;
1785                 cnt := 0;
1786                 bufferedcnt := BUFSIZ;
1787                 IF isatty(ErrorStream, result) THEN
1788                         buffering := linebuffered;
1789                 ELSE
1790                         buffering := blockbuffered;
1791                 END;
1792         END;
1793         head := InputStream;
1794         IF CallAtEnd(EndIt) THEN ; END;
1795   END InitStreams;
1796
1797 BEGIN
1798         InitStreams
1799 END Streams.
1800 \0Terminal.mod\0\0\0\0\0\0\ 2\ 2�\ 1\0\0�\a#
1801 (*
1802   (c) copyright 1988 by the Vrije Universiteit, Amsterdam, The Netherlands.
1803   See the copyright notice in the ACK home directory, in the file "Copyright".
1804 *)
1805
1806 (*$R-*)
1807 IMPLEMENTATION MODULE Terminal;
1808 (*
1809   Module:       Input/Output to/from terminals
1810   Author:       Ceriel J.H. Jacobs
1811   Version:      $Id: Terminal.mod,v 1.5 1994/06/24 12:50:19 ceriel Exp $
1812
1813   Implementation for Unix.
1814 *)
1815   FROM  SYSTEM IMPORT   ADR;
1816 #ifdef __USG
1817   FROM  Unix IMPORT     read, write, open, fcntl;
1818 #else
1819   FROM  Unix IMPORT     read, write, open, ioctl;
1820 #endif
1821   VAR fildes: INTEGER;
1822       unreadch: CHAR;
1823       unread: BOOLEAN;
1824       tty: ARRAY[0..8] OF CHAR;
1825
1826   PROCEDURE Read(VAR ch: CHAR);
1827   BEGIN
1828         IF unread THEN
1829                 ch := unreadch;
1830                 unread := FALSE
1831         ELSE
1832                 IF read(fildes, ADR(ch), 1) < 0 THEN
1833                         ;
1834                 END;
1835         END;
1836         unreadch := ch;
1837   END Read;
1838
1839   PROCEDURE BusyRead(VAR ch: CHAR);
1840     VAR l: INTEGER;
1841   BEGIN
1842         IF unread THEN
1843                 ch := unreadch;
1844                 unread := FALSE
1845         ELSE
1846 #ifdef __USG
1847                 l := fcntl(fildes, (*FGETFL*) 3, 0);
1848                 IF fcntl(fildes,
1849                               (* FSETFL *) 4,
1850                               l + (*ONDELAY*) 2) < 0 THEN
1851                         ;
1852                 END;
1853                 IF read(fildes, ADR(ch), 1) = 0 THEN
1854                         ch := 0C;
1855                 ELSE
1856                         unreadch := ch;
1857                 END;
1858                 IF fcntl(fildes, (*FSETFL*)4, l) < 0 THEN
1859                         ;
1860                 END;
1861 #else
1862 #ifdef __BSD4_2
1863                 IF ioctl(fildes, INTEGER(ORD('f')*256+127+4*65536+40000000H), ADR(l)) < 0 THEN
1864 #else
1865                 IF ioctl(fildes, INTEGER(ORD('f')*256+127), ADR(l)) < 0 THEN
1866 #endif
1867                         ;
1868                 END;
1869
1870                 IF l = 0 THEN
1871                         ch := 0C;
1872                 ELSE
1873                         IF read(fildes, ADR(ch), 1) < 0 THEN
1874                                 ;
1875                         END;
1876                         unreadch := ch;
1877                 END;
1878 #endif
1879         END;
1880   END BusyRead;
1881
1882   PROCEDURE ReadAgain;
1883   BEGIN
1884         unread := TRUE;
1885   END ReadAgain;
1886
1887   PROCEDURE Write(ch: CHAR);
1888   BEGIN
1889         IF write(fildes, ADR(ch), 1) < 0 THEN
1890                 ;
1891         END;
1892   END Write;
1893
1894   PROCEDURE WriteLn;
1895   BEGIN
1896         Write(12C);
1897   END WriteLn;
1898
1899   PROCEDURE WriteString(s: ARRAY OF CHAR);
1900     VAR i: CARDINAL;
1901   BEGIN
1902         i := 0;
1903         WHILE (i <= HIGH(s)) & (s[i] # 0C) DO
1904                 Write(s[i]);
1905                 INC(i)
1906         END
1907   END WriteString;
1908
1909 BEGIN
1910         tty := "/dev/tty";
1911         fildes := open(ADR(tty), 2);
1912         unread := FALSE;
1913 END Terminal.
1914 fMathLib0.mod\0\0\0\0\0\0\ 2\ 2�\ 1\0\0�\ 4(*
1915   (c) copyright 1988 by the Vrije Universiteit, Amsterdam, The Netherlands.
1916   See the copyright notice in the ACK home directory, in the file "Copyright".
1917 *)
1918
1919 (*$R-*)
1920 IMPLEMENTATION MODULE MathLib0;
1921 (*
1922   Module:       Some mathematical functions
1923   Author:       Ceriel J.H. Jacobs
1924   Version:      $Id: MathLib0.mod,v 1.10 1994/06/24 12:48:58 ceriel Exp $
1925 *)
1926
1927   IMPORT        Mathlib;
1928
1929   PROCEDURE cos(arg: REAL): REAL;
1930   BEGIN
1931         RETURN Mathlib.cos(arg);
1932   END cos;
1933
1934   PROCEDURE sin(arg: REAL): REAL;
1935   BEGIN
1936         RETURN Mathlib.sin(arg);
1937   END sin;
1938
1939   PROCEDURE arctan(arg: REAL): REAL;
1940   BEGIN
1941         RETURN Mathlib.arctan(arg);
1942   END arctan;
1943
1944   PROCEDURE sqrt(arg: REAL): REAL;
1945   BEGIN
1946         RETURN Mathlib.sqrt(arg);
1947   END sqrt;
1948
1949   PROCEDURE ln(arg: REAL): REAL;
1950   BEGIN
1951         RETURN Mathlib.ln(arg);
1952   END ln;
1953
1954   PROCEDURE exp(arg: REAL): REAL;
1955   BEGIN
1956         RETURN Mathlib.exp(arg);
1957   END exp;
1958
1959   PROCEDURE entier(x: REAL): INTEGER;
1960   VAR i: INTEGER;
1961   BEGIN
1962         IF x < 0.0 THEN
1963                 i := TRUNC(-x);
1964                 IF FLOAT(i) = -x THEN
1965                         RETURN -i;
1966                 ELSE
1967                         RETURN -i -1;
1968                 END;
1969         END;
1970         RETURN TRUNC(x);
1971   END entier;
1972
1973   PROCEDURE real(x: INTEGER): REAL;
1974   BEGIN
1975         IF x < 0 THEN
1976                 RETURN - FLOAT(-x);
1977         END;
1978         RETURN FLOAT(x);
1979   END real;
1980
1981 BEGIN
1982 END MathLib0.
1983 Mathlib.mod\0\0\0\0\0\0\0\ 2\ 2�\ 1\0\0C1(*
1984   (c) copyright 1988 by the Vrije Universiteit, Amsterdam, The Netherlands.
1985   See the copyright notice in the ACK home directory, in the file "Copyright".
1986 *)
1987
1988 (*$R-*)
1989 IMPLEMENTATION MODULE Mathlib;
1990 (*
1991   Module:       Mathematical functions
1992   Author:       Ceriel J.H. Jacobs
1993   Version:      $Id: Mathlib.mod,v 1.10 1994/06/24 12:49:05 ceriel Exp $
1994 *)
1995
1996   FROM  EM IMPORT       FIF, FEF;
1997   FROM  Traps IMPORT    Message;
1998
1999   CONST
2000         OneRadianInDegrees      = 57.295779513082320876798155D;
2001         OneDegreeInRadians      =  0.017453292519943295769237D;
2002         OneOverSqrt2            = 0.70710678118654752440084436210484904D;
2003
2004   (* basic functions *)
2005
2006   PROCEDURE pow(x: REAL; i: INTEGER): REAL;
2007   BEGIN
2008         RETURN SHORT(longpow(LONG(x), i));
2009   END pow;
2010
2011   PROCEDURE longpow(x: LONGREAL; i: INTEGER): LONGREAL;
2012     VAR val: LONGREAL;
2013         ri: LONGREAL;
2014   BEGIN
2015         ri := FLOATD(i);
2016         IF x < 0.0D THEN
2017                 val := longexp(longln(-x) * ri);
2018                 IF ODD(i) THEN RETURN -val;
2019                 ELSE RETURN val;
2020                 END;
2021         ELSIF x = 0.0D THEN
2022                 RETURN 0.0D;
2023         ELSE
2024                 RETURN longexp(longln(x) * ri);
2025         END;
2026   END longpow;
2027
2028   PROCEDURE sqrt(x: REAL): REAL;
2029   BEGIN
2030         RETURN SHORT(longsqrt(LONG(x)));
2031   END sqrt;
2032
2033   PROCEDURE longsqrt(x: LONGREAL): LONGREAL;
2034     VAR
2035         temp: LONGREAL;
2036         exp, i: INTEGER;
2037   BEGIN
2038         IF x <= 0.0D THEN
2039                 IF x < 0.0D THEN
2040                         Message("sqrt: negative argument");
2041                         HALT
2042                 END;
2043                 RETURN 0.0D;
2044         END;
2045         temp := FEF(x,exp);
2046         (*
2047          * NOTE
2048          * this wont work on 1's comp
2049          *)
2050         IF ODD(exp) THEN
2051                 temp := 2.0D * temp;
2052                 DEC(exp);
2053         END;
2054         temp := 0.5D*(1.0D + temp);
2055
2056         WHILE exp > 28 DO
2057                 temp := temp * 16384.0D;
2058                 exp := exp - 28;
2059         END;
2060         WHILE exp < -28 DO
2061                 temp := temp / 16384.0D;
2062                 exp := exp + 28;
2063         END;
2064         WHILE exp >= 2 DO
2065                 temp := temp * 2.0D;
2066                 exp := exp - 2;
2067         END;
2068         WHILE exp <= -2 DO
2069                 temp := temp / 2.0D;
2070                 exp := exp + 2;
2071         END;
2072         FOR i := 0 TO 5 DO
2073                 temp := 0.5D*(temp + x/temp);
2074         END;
2075         RETURN temp;
2076   END longsqrt;
2077
2078   PROCEDURE ldexp(x:LONGREAL; n: INTEGER): LONGREAL;
2079   BEGIN
2080         WHILE n >= 16 DO
2081                 x := x * 65536.0D;
2082                 n := n - 16;
2083         END;
2084         WHILE n > 0 DO
2085                 x := x * 2.0D;
2086                 DEC(n);
2087         END;
2088         WHILE n <= -16 DO
2089                 x := x / 65536.0D;
2090                 n := n + 16;
2091         END;
2092         WHILE n < 0 DO
2093                 x := x / 2.0D;
2094                 INC(n);
2095         END;
2096         RETURN x;
2097   END ldexp;
2098
2099   PROCEDURE exp(x: REAL): REAL;
2100   BEGIN
2101         RETURN SHORT(longexp(LONG(x)));
2102   END exp;
2103
2104   PROCEDURE longexp(x: LONGREAL): LONGREAL;
2105   (*    Algorithm and coefficients from:
2106                 "Software manual for the elementary functions"
2107                 by W.J. Cody and W. Waite, Prentice-Hall, 1980
2108   *)
2109     CONST
2110         p0 = 0.25000000000000000000D+00;
2111         p1 = 0.75753180159422776666D-02;
2112         p2 = 0.31555192765684646356D-04;
2113         q0 = 0.50000000000000000000D+00;
2114         q1 = 0.56817302698551221787D-01;
2115         q2 = 0.63121894374398503557D-03;
2116         q3 = 0.75104028399870046114D-06;
2117
2118     VAR
2119         neg: BOOLEAN;
2120         n: INTEGER;
2121         xn, g, x1, x2: LONGREAL;
2122   BEGIN
2123         neg := x < 0.0D;
2124         IF neg THEN
2125                 x := -x;
2126         END;
2127         n := TRUNC(x/longln2 + 0.5D);
2128         xn := FLOATD(n);
2129         x1 := FLOATD(TRUNCD(x));
2130         x2 := x - x1;
2131         g := ((x1 - xn * 0.693359375D)+x2) - xn * (-2.1219444005469058277D-4);
2132         IF neg THEN
2133                 g := -g;
2134                 n := -n;
2135         END;
2136         xn := g*g;
2137         x := g*((p2*xn+p1)*xn+p0);
2138         INC(n);
2139         RETURN ldexp(0.5D + x/((((q3*xn+q2)*xn+q1)*xn+q0) - x), n);
2140   END longexp;
2141
2142   PROCEDURE ln(x: REAL): REAL;  (* natural log *)
2143   BEGIN
2144         RETURN SHORT(longln(LONG(x)));
2145   END ln;
2146
2147   PROCEDURE longln(x: LONGREAL): LONGREAL;      (* natural log *)
2148   (*    Algorithm and coefficients from:
2149                 "Software manual for the elementary functions"
2150                 by W.J. Cody and W. Waite, Prentice-Hall, 1980
2151    *)
2152     CONST
2153         p0 = -0.64124943423745581147D+02;
2154         p1 =  0.16383943563021534222D+02;
2155         p2 = -0.78956112887491257267D+00;
2156         q0 = -0.76949932108494879777D+03;
2157         q1 =  0.31203222091924532844D+03;
2158         q2 = -0.35667977739034646171D+02;
2159         q3 =  1.0D;
2160     VAR
2161         exp: INTEGER;
2162         z, znum, zden, w: LONGREAL;
2163
2164   BEGIN
2165         IF x <= 0.0D THEN
2166                 Message("ln: argument <= 0");
2167                 HALT
2168         END;
2169         x := FEF(x, exp);
2170         IF x > OneOverSqrt2 THEN
2171                 znum := (x - 0.5D) - 0.5D;
2172                 zden := x * 0.5D + 0.5D;
2173         ELSE
2174                 znum := x - 0.5D;
2175                 zden := znum * 0.5D + 0.5D;
2176                 DEC(exp);
2177         END;
2178         z := znum / zden;
2179         w := z * z;
2180         x := z + z * w * (((p2*w+p1)*w+p0)/(((q3*w+q2)*w+q1)*w+q0));
2181         z := FLOATD(exp);
2182         x := x + z * (-2.121944400546905827679D-4);
2183         RETURN x + z * 0.693359375D;
2184   END longln;
2185
2186   PROCEDURE log(x: REAL): REAL; (* log with base 10 *)
2187   BEGIN
2188         RETURN SHORT(longlog(LONG(x)));
2189   END log;
2190
2191   PROCEDURE longlog(x: LONGREAL): LONGREAL;     (* log with base 10 *)
2192   BEGIN
2193         RETURN longln(x)/longln10;
2194   END longlog;
2195
2196   (* trigonometric functions; arguments in radians *)
2197
2198   PROCEDURE sin(x: REAL): REAL;
2199   BEGIN
2200         RETURN SHORT(longsin(LONG(x)));
2201   END sin;
2202
2203   PROCEDURE sinus(x: LONGREAL; cosflag: BOOLEAN) : LONGREAL;
2204   (*    Algorithm and coefficients from:
2205                 "Software manual for the elementary functions"
2206                 by W.J. Cody and W. Waite, Prentice-Hall, 1980
2207   *)
2208     CONST
2209         r0 = -0.16666666666666665052D+00;
2210         r1 =  0.83333333333331650314D-02;
2211         r2 = -0.19841269841201840457D-03;
2212         r3 =  0.27557319210152756119D-05;
2213         r4 = -0.25052106798274584544D-07;
2214         r5 =  0.16058936490371589114D-09;
2215         r6 = -0.76429178068910467734D-12;
2216         r7 =  0.27204790957888846175D-14;
2217         A1 =  3.1416015625D;
2218         A2 = -8.908910206761537356617D-6;
2219     VAR
2220         x1, x2, y : LONGREAL;
2221         neg : BOOLEAN;
2222   BEGIN
2223         IF x < 0.0D THEN
2224                 neg := TRUE;
2225                 x := -x
2226         ELSE    neg := FALSE
2227         END;
2228         IF cosflag THEN
2229                 neg := FALSE;
2230                 y := longhalfpi + x
2231         ELSE
2232                 y := x
2233         END;
2234         y := y / longpi + 0.5D;
2235
2236         IF FIF(y, 1.0D, y) < 0.0D THEN ; END;
2237         IF FIF(y, 0.5D, x1) # 0.0D THEN neg := NOT neg END;
2238         IF cosflag THEN y := y - 0.5D END;
2239         x2 := FIF(x, 1.0, x1);
2240         x := x1 - y * A1;
2241         x := x + x2;
2242         x := x - y * A2;
2243
2244         IF x < 0.0D THEN
2245                 neg := NOT neg;
2246                 x := -x
2247         END;
2248         y := x * x;
2249         x := x + x * y * (((((((r7*y+r6)*y+r5)*y+r4)*y+r3)*y+r2)*y+r1)*y+r0);
2250         IF neg THEN RETURN -x END;
2251         RETURN x;
2252   END sinus;
2253
2254   PROCEDURE longsin(x: LONGREAL): LONGREAL;
2255   BEGIN
2256         RETURN sinus(x, FALSE);
2257   END longsin;
2258
2259   PROCEDURE cos(x: REAL): REAL;
2260   BEGIN
2261         RETURN SHORT(longcos(LONG(x)));
2262   END cos;
2263
2264   PROCEDURE longcos(x: LONGREAL): LONGREAL;
2265   BEGIN
2266         IF x < 0.0D THEN x := -x; END;
2267         RETURN sinus(x, TRUE);
2268   END longcos;
2269
2270   PROCEDURE tan(x: REAL): REAL;
2271   BEGIN
2272         RETURN SHORT(longtan(LONG(x)));
2273   END tan;
2274
2275   PROCEDURE longtan(x: LONGREAL): LONGREAL;
2276   (*    Algorithm and coefficients from:
2277                 "Software manual for the elementary functions"
2278                 by W.J. Cody and W. Waite, Prentice-Hall, 1980
2279   *)
2280
2281     CONST
2282         p1 = -0.13338350006421960681D+00;
2283         p2 =  0.34248878235890589960D-02;
2284         p3 = -0.17861707342254426711D-04;
2285
2286         q0 =  1.0D;
2287         q1 = -0.46671683339755294240D+00;
2288         q2 =  0.25663832289440112864D-01;
2289         q3 = -0.31181531907010027307D-03;
2290         q4 =  0.49819433993786512270D-06;
2291
2292         A1 =  1.57080078125D;
2293         A2 = -4.454455103380768678308D-06;
2294
2295     VAR y, x1, x2: LONGREAL;
2296         negative: BOOLEAN;
2297         invert: BOOLEAN;
2298   BEGIN
2299         negative := x < 0.0D;
2300         y := x / longhalfpi + 0.5D;
2301
2302         (*      Use extended precision to calculate reduced argument.
2303                 Here we used 12 bits of the mantissa for a1.
2304                 Also split x in integer part x1 and fraction part x2.
2305         *)
2306         IF FIF(y, 1.0D, y) < 0.0D THEN ; END;
2307         invert := FIF(y, 0.5D, x1) # 0.0D;
2308         x2 := FIF(x, 1.0D, x1);
2309         x := x1 - y * A1;
2310         x := x + x2;
2311         x := x - y * A2;
2312
2313         y := x * x;
2314         x := x + x * y * ((p3*y+p2)*y+p1);
2315         y := (((q4*y+q3)*y+q2)*y+q1)*y+q0;
2316         IF negative THEN x := -x END;
2317         IF invert THEN RETURN -y/x END;
2318         RETURN x/y;
2319   END longtan;
2320
2321   PROCEDURE arcsin(x: REAL): REAL;
2322   BEGIN
2323         RETURN SHORT(longarcsin(LONG(x)));
2324   END arcsin;
2325
2326   PROCEDURE arcsincos(x: LONGREAL; cosfl: BOOLEAN): LONGREAL;
2327     CONST
2328         p0 = -0.27368494524164255994D+02;
2329         p1 =  0.57208227877891731407D+02;
2330         p2 = -0.39688862997540877339D+02;
2331         p3 =  0.10152522233806463645D+02;
2332         p4 = -0.69674573447350646411D+00;
2333
2334         q0 = -0.16421096714498560795D+03;
2335         q1 =  0.41714430248260412556D+03;
2336         q2 = -0.38186303361750149284D+03;
2337         q3 =  0.15095270841030604719D+03;
2338         q4 = -0.23823859153670238830D+02;
2339         q5 =  1.0D;
2340     VAR
2341         negative : BOOLEAN;
2342         big: BOOLEAN;
2343         g: LONGREAL;
2344   BEGIN
2345         negative := x < 0.0D;
2346         IF negative THEN x := -x; END;
2347         IF x > 0.5D THEN
2348                 big := TRUE;
2349                 IF x > 1.0D THEN
2350                         Message("arcsin or arccos: argument > 1");
2351                         HALT
2352                 END;
2353                 g := 0.5D - 0.5D * x;
2354                 x := -longsqrt(g);
2355                 x := x + x;
2356         ELSE
2357                 big := FALSE;
2358                 g := x * x;
2359         END;
2360         x := x + x * g *
2361           ((((p4*g+p3)*g+p2)*g+p1)*g+p0)/(((((q5*g+q4)*g+q3)*g+q2)*g+q1)*g+q0);
2362         IF cosfl AND NOT negative THEN x := -x END;
2363         IF cosfl = NOT big THEN
2364                 x := (x + longquartpi) + longquartpi;
2365         ELSIF cosfl AND negative AND big THEN
2366                 x := (x + longhalfpi) + longhalfpi;
2367         END;
2368         IF negative AND NOT cosfl THEN x := -x END;
2369         RETURN x;
2370   END arcsincos;
2371
2372   PROCEDURE longarcsin(x: LONGREAL): LONGREAL;
2373   BEGIN
2374         RETURN arcsincos(x, FALSE);
2375   END longarcsin;
2376
2377   PROCEDURE arccos(x: REAL): REAL;
2378   BEGIN
2379         RETURN SHORT(longarccos(LONG(x)));
2380   END arccos;
2381
2382   PROCEDURE longarccos(x: LONGREAL): LONGREAL;
2383   BEGIN
2384         RETURN arcsincos(x, TRUE);
2385   END longarccos;
2386
2387   PROCEDURE arctan(x: REAL): REAL;
2388   BEGIN
2389         RETURN SHORT(longarctan(LONG(x)));
2390   END arctan;
2391
2392   VAR A: ARRAY[0..3] OF LONGREAL;
2393       arctaninit: BOOLEAN;
2394
2395   PROCEDURE longarctan(x: LONGREAL): LONGREAL;
2396   (*    Algorithm and coefficients from:
2397                 "Software manual for the elementary functions"
2398                 by W.J. Cody and W. Waite, Prentice-Hall, 1980
2399   *)
2400     CONST
2401         p0 = -0.13688768894191926929D+02;
2402         p1 = -0.20505855195861651981D+02;
2403         p2 = -0.84946240351320683534D+01;
2404         p3 = -0.83758299368150059274D+00;
2405         q0 =  0.41066306682575781263D+02;
2406         q1 =  0.86157349597130242515D+02;
2407         q2 =  0.59578436142597344465D+02;
2408         q3 =  0.15024001160028576121D+02;
2409         q4 =  1.0D;
2410     VAR
2411         g: LONGREAL;
2412         neg: BOOLEAN;
2413         n: INTEGER;
2414   BEGIN
2415         IF NOT arctaninit THEN
2416                 arctaninit := TRUE;
2417                 A[0] := 0.0D;
2418                 A[1] := 0.52359877559829887307710723554658381D; (* p1/6 *)
2419                 A[2] := longhalfpi;
2420                 A[3] := 1.04719755119659774615421446109316763D; (* pi/3 *)
2421         END;
2422         neg := FALSE;
2423         IF x < 0.0D THEN
2424                 neg := TRUE;
2425                 x := -x;
2426         END;
2427         IF x > 1.0D THEN
2428                 x := 1.0D/x;
2429                 n := 2
2430         ELSE
2431                 n := 0
2432         END;
2433         IF x > 0.26794919243112270647D (* 2-sqrt(3) *) THEN
2434                 INC(n);
2435                 x := (((0.73205080756887729353D*x-0.5D)-0.5D)+x)/
2436                         (1.73205080756887729353D + x);
2437         END;
2438         g := x*x;
2439         x := x + x * g * (((p3*g+p2)*g+p1)*g+p0) / ((((q4*g+q3)*g+q2)*g+q1)*g+q0);
2440         IF n > 1 THEN x := -x END;
2441         x := x + A[n];
2442         IF neg THEN RETURN -x; END;
2443         RETURN x;
2444   END longarctan;
2445
2446   (* hyperbolic functions *)
2447   (* The C math library has better implementations for some of these, but
2448      they depend on some properties of the floating point implementation,
2449      and, for now, we don't want that in the Modula-2 system.
2450   *)
2451
2452   PROCEDURE sinh(x: REAL): REAL;
2453   BEGIN
2454         RETURN SHORT(longsinh(LONG(x)));
2455   END sinh;
2456
2457   PROCEDURE longsinh(x: LONGREAL): LONGREAL;
2458     VAR expx: LONGREAL;
2459   BEGIN
2460         expx := longexp(x);
2461         RETURN (expx - 1.0D/expx)/2.0D;
2462   END longsinh;
2463
2464   PROCEDURE cosh(x: REAL): REAL;
2465   BEGIN
2466         RETURN SHORT(longcosh(LONG(x)));
2467   END cosh;
2468
2469   PROCEDURE longcosh(x: LONGREAL): LONGREAL;
2470     VAR expx: LONGREAL;
2471   BEGIN
2472         expx := longexp(x);
2473         RETURN (expx + 1.0D/expx)/2.0D;
2474   END longcosh;
2475
2476   PROCEDURE tanh(x: REAL): REAL;
2477   BEGIN
2478         RETURN SHORT(longtanh(LONG(x)));
2479   END tanh;
2480
2481   PROCEDURE longtanh(x: LONGREAL): LONGREAL;
2482     VAR expx: LONGREAL;
2483   BEGIN
2484         expx := longexp(x);
2485         RETURN (expx - 1.0D/expx) / (expx + 1.0D/expx);
2486   END longtanh;
2487
2488   PROCEDURE arcsinh(x: REAL): REAL;
2489   BEGIN
2490         RETURN SHORT(longarcsinh(LONG(x)));
2491   END arcsinh;
2492
2493   PROCEDURE longarcsinh(x: LONGREAL): LONGREAL;
2494     VAR neg: BOOLEAN;
2495   BEGIN
2496         neg := FALSE;
2497         IF x < 0.0D THEN
2498                 neg := TRUE;
2499                 x := -x;
2500         END;
2501         x := longln(x + longsqrt(x*x+1.0D));
2502         IF neg THEN RETURN -x; END;
2503         RETURN x;
2504   END longarcsinh;
2505
2506   PROCEDURE arccosh(x: REAL): REAL;
2507   BEGIN
2508         RETURN SHORT(longarccosh(LONG(x)));
2509   END arccosh;
2510
2511   PROCEDURE longarccosh(x: LONGREAL): LONGREAL;
2512   BEGIN
2513         IF x < 1.0D THEN
2514                 Message("arccosh: argument < 1");
2515                 HALT
2516         END;
2517         RETURN longln(x + longsqrt(x*x - 1.0D));
2518   END longarccosh;
2519
2520   PROCEDURE arctanh(x: REAL): REAL;
2521   BEGIN
2522         RETURN SHORT(longarctanh(LONG(x)));
2523   END arctanh;
2524
2525   PROCEDURE longarctanh(x: LONGREAL): LONGREAL;
2526   BEGIN
2527         IF (x <= -1.0D) OR (x >= 1.0D) THEN
2528                 Message("arctanh: ABS(argument) >= 1");
2529                 HALT
2530         END;
2531         RETURN longln((1.0D + x)/(1.0D - x)) / 2.0D;
2532   END longarctanh;
2533
2534   (* conversions *)
2535
2536   PROCEDURE RadianToDegree(x: REAL): REAL;
2537   BEGIN
2538         RETURN SHORT(longRadianToDegree(LONG(x)));
2539   END RadianToDegree;
2540
2541   PROCEDURE longRadianToDegree(x: LONGREAL): LONGREAL;
2542   BEGIN
2543         RETURN x * OneRadianInDegrees;
2544   END longRadianToDegree;
2545
2546   PROCEDURE DegreeToRadian(x: REAL): REAL;
2547   BEGIN
2548         RETURN SHORT(longDegreeToRadian(LONG(x)));
2549   END DegreeToRadian;
2550
2551   PROCEDURE longDegreeToRadian(x: LONGREAL): LONGREAL;
2552   BEGIN
2553         RETURN x * OneDegreeInRadians;
2554   END longDegreeToRadian;
2555
2556 BEGIN
2557         arctaninit := FALSE;
2558 END Mathlib.
2559 dProcesses.mod\0\0\0\0\0\ 2\ 2�\ 1\0\01\a(*$R-*)
2560 IMPLEMENTATION MODULE Processes [1];
2561 (*
2562   Module:       Processes
2563   From:         "Programming in Modula-2", 3rd, corrected edition, by N. Wirth
2564   Version:      $Id: Processes.mod,v 1.7 1994/06/24 12:49:18 ceriel Exp $
2565 *)
2566
2567   FROM  SYSTEM IMPORT   ADDRESS, TSIZE, NEWPROCESS, TRANSFER;
2568   FROM  Storage IMPORT  Allocate;
2569   FROM  Traps IMPORT    Message;
2570
2571   TYPE  SIGNAL = POINTER TO ProcessDescriptor;
2572
2573         ProcessDescriptor =
2574                 RECORD  next: SIGNAL;   (* ring *)
2575                         queue: SIGNAL;  (* queue of waiting processes *)
2576                         cor: ADDRESS;
2577                         ready: BOOLEAN;
2578                 END;
2579
2580   VAR   cp: SIGNAL;                     (* current process *)
2581
2582   PROCEDURE StartProcess(P: PROC; n: CARDINAL);
2583     VAR s0: SIGNAL;
2584         wsp: ADDRESS;
2585   BEGIN
2586         s0 := cp;
2587         Allocate(wsp, n);
2588         Allocate(cp, TSIZE(ProcessDescriptor));
2589         WITH cp^ DO
2590                 next := s0^.next;
2591                 s0^.next := cp;
2592                 ready := TRUE;
2593                 queue := NIL
2594         END;
2595         NEWPROCESS(P, wsp, n, cp^.cor);
2596         TRANSFER(s0^.cor, cp^.cor);
2597   END StartProcess;
2598
2599   PROCEDURE SEND(VAR s: SIGNAL);
2600     VAR s0: SIGNAL;
2601   BEGIN
2602         IF s # NIL THEN
2603                 s0 := cp;
2604                 cp := s;
2605                 WITH cp^ DO
2606                         s := queue;
2607                         ready := TRUE;
2608                         queue := NIL
2609                 END;
2610                 TRANSFER(s0^.cor, cp^.cor);
2611         END
2612   END SEND;
2613
2614   PROCEDURE WAIT(VAR s: SIGNAL);
2615     VAR s0, s1: SIGNAL;
2616   BEGIN
2617         (* insert cp in queue s *)
2618         IF s = NIL THEN
2619                 s := cp
2620         ELSE
2621                 s0 := s;
2622                 s1 := s0^.queue;
2623                 WHILE s1 # NIL DO
2624                         s0 := s1;
2625                         s1 := s0^.queue
2626                 END;
2627                 s0^.queue := cp
2628         END;
2629         s0 := cp;
2630         REPEAT
2631                 cp := cp^.next
2632         UNTIL cp^.ready;
2633         IF cp = s0 THEN
2634                 (* deadlock *)
2635                 Message("deadlock");
2636                 HALT
2637         END;
2638         s0^.ready := FALSE;
2639         TRANSFER(s0^.cor, cp^.cor)
2640   END WAIT;
2641
2642   PROCEDURE Awaited(s: SIGNAL): BOOLEAN;
2643   BEGIN
2644         RETURN s # NIL
2645   END Awaited;
2646
2647   PROCEDURE Init(VAR s: SIGNAL);
2648   BEGIN
2649         s := NIL
2650   END Init;
2651
2652 BEGIN
2653         Allocate(cp, TSIZE(ProcessDescriptor));
2654         WITH cp^ DO
2655                 next := cp;
2656                 ready := TRUE;
2657                 queue := NIL
2658         END
2659 END Processes.
2660 iRealConver.mod\0\0\0\0\ 2\ 2�\ 1\0\0�\1c(*
2661   (c) copyright 1988 by the Vrije Universiteit, Amsterdam, The Netherlands.
2662   See the copyright notice in the ACK home directory, in the file "Copyright".
2663 *)
2664
2665 (*$R-*)
2666 IMPLEMENTATION MODULE RealConversions;
2667 (*
2668   Module:       string-to-real and real-to-string conversions
2669   Author:       Ceriel J.H. Jacobs
2670   Version:      $Id: RealConver.mod,v 1.17 1997/01/27 14:06:51 ceriel Exp $
2671 *)
2672
2673
2674   PROCEDURE RealToString(arg: REAL;
2675                 width, digits: INTEGER;
2676                 VAR str: ARRAY OF CHAR;
2677                 VAR ok: BOOLEAN);
2678   BEGIN
2679         LongRealToString(LONG(arg), width, digits, str, ok);
2680   END RealToString;
2681
2682   TYPE
2683         Powers = RECORD
2684                 pval: LONGREAL;
2685                 rpval: LONGREAL;
2686                 exp: INTEGER
2687         END;
2688
2689   VAR Powers10: ARRAY[1..6] OF Powers;
2690
2691   PROCEDURE LongRealToString(arg: LONGREAL;
2692                 width, digits: INTEGER;
2693                 VAR str: ARRAY OF CHAR;
2694                 VAR ok: BOOLEAN);
2695     VAR pointpos: INTEGER;
2696         i: CARDINAL;
2697         ecvtflag: BOOLEAN;
2698         r: LONGREAL;
2699         ind1, ind2 : CARDINAL;
2700         sign: BOOLEAN;
2701         ndigits: CARDINAL;
2702
2703   BEGIN
2704         r := arg;
2705         IF digits < 0 THEN
2706                 ecvtflag := TRUE;
2707                 ndigits := -digits;
2708         ELSE
2709                 ecvtflag := FALSE;
2710                 ndigits := digits;
2711         END;
2712         IF (HIGH(str) < ndigits + 3) THEN
2713                 str[0] := 0C; ok := FALSE; RETURN
2714         END;
2715         pointpos := 0;
2716         sign := r < 0.0D;
2717         IF sign THEN r := -r END;
2718         ok := TRUE;
2719         IF (r <> 0.0D) AND NOT (r / 10.0D < r) THEN
2720                 (* assume Nan or Infinity *)
2721                 r := 0.0D;
2722                 ok := FALSE;
2723         END;
2724         IF r # 0.0D THEN
2725                 IF r >= 10.0D THEN
2726                         FOR i := 1 TO 6 DO
2727                                 WITH Powers10[i] DO
2728                                         WHILE r >= pval DO
2729                                                 r := r * rpval;
2730                                                 INC(pointpos, exp)
2731                                         END;
2732                                 END;
2733                         END;
2734                 END;
2735                 IF r < 1.0D THEN
2736                         FOR i := 1 TO 6 DO
2737                                 WITH Powers10[i] DO
2738                                         WHILE r*pval < 10.0D DO
2739                                                 r := r * pval;
2740                                                 DEC(pointpos, exp)
2741                                         END;
2742                                 END;
2743                         END;
2744                 END;
2745                 (* Now, we have r in [1.0, 10.0) *)
2746                 INC(pointpos);
2747         END;
2748         ind1 := 0;
2749         ind2 := ndigits+1;
2750
2751         IF NOT ecvtflag THEN
2752                 IF INTEGER(ind2) + pointpos <= 0 THEN
2753                         ind2 := 1;
2754                 ELSE
2755                         ind2 := INTEGER(ind2) + pointpos
2756                 END;
2757         END;
2758         IF ind2 > HIGH(str) THEN
2759                 ok := FALSE;
2760                 str[0] := 0C;
2761                 RETURN;
2762         END;
2763         WHILE ind1 < ind2 DO
2764                 str[ind1] := CHR(TRUNC(r)+ORD('0'));
2765                 r := 10.0D * (r - FLOATD(TRUNC(r)));
2766                 INC(ind1);
2767         END;
2768         IF ind2 > 0 THEN
2769                 DEC(ind2);
2770                 ind1 := ind2;
2771                 str[ind2] := CHR(ORD(str[ind2])+5);
2772                 WHILE str[ind2] > '9' DO
2773                         str[ind2] := '0';
2774                         IF ind2 > 0 THEN
2775                                 DEC(ind2);
2776                                 str[ind2] := CHR(ORD(str[ind2])+1);
2777                         ELSE
2778                                 str[ind2] := '1';
2779                                 INC(pointpos);
2780                                 IF NOT ecvtflag THEN
2781                                         IF ind1 > 0 THEN str[ind1] := '0'; END;
2782                                         INC(ind1);
2783                                 END;
2784                         END;
2785                 END;
2786                 IF (NOT ecvtflag) AND (ind1 = 0) THEN
2787                         str[0] := CHR(ORD(str[0])-5);
2788                         INC(ind1);
2789                 END;
2790         END;
2791         IF ecvtflag THEN
2792                 FOR i := ind1 TO 2 BY -1 DO
2793                         str[i] := str[i-1];
2794                 END;
2795                 str[1] := '.';
2796                 INC(ind1);
2797                 IF sign THEN
2798                         FOR i := ind1 TO 1 BY -1 DO
2799                                 str[i] := str[i-1];
2800                         END;
2801                         INC(ind1);
2802                         str[0] := '-';
2803                 END;
2804                 IF (ind1 + 4) > HIGH(str) THEN
2805                         str[0] := 0C;
2806                         ok := FALSE;
2807                         RETURN;
2808                 END;
2809                 str[ind1] := 'E'; INC(ind1);
2810                 IF arg # 0.0D THEN DEC(pointpos); END;
2811                 IF pointpos < 0 THEN
2812                         pointpos := -pointpos;
2813                         str[ind1] := '-';
2814                 ELSE
2815                         str[ind1] := '+';
2816                 END;
2817                 INC(ind1);
2818                 str[ind1] := CHR(ORD('0') + CARDINAL(pointpos DIV 100));
2819                 pointpos := pointpos MOD 100;
2820                 INC(ind1);
2821                 str[ind1] := CHR(ORD('0') + CARDINAL(pointpos DIV 10));
2822                 INC(ind1);
2823                 str[ind1] := CHR(ORD('0') + CARDINAL(pointpos MOD 10));
2824         ELSE
2825                 IF pointpos <= 0 THEN
2826                         FOR i := ind1 TO 1 BY -1 DO
2827                                 str[i+CARDINAL(-pointpos)] := str[i-1];
2828                         END;
2829                         FOR i := 0 TO CARDINAL(-pointpos) DO
2830                                 str[i] := '0';
2831                         END;
2832                         ind1 := ind1 + CARDINAL(1 - pointpos);
2833                         pointpos := 1;
2834                 END;
2835                 FOR i := ind1 TO CARDINAL(pointpos+1) BY -1 DO
2836                         str[i] := str[i-1];
2837                 END;
2838                 IF ndigits = 0 THEN
2839                         str[pointpos] := 0C;
2840                         ind1 := pointpos - 1;
2841                 ELSE
2842                         str[pointpos] := '.';
2843                         IF INTEGER(ind1) > pointpos+INTEGER(ndigits) THEN
2844                                 ind1 := pointpos+INTEGER(ndigits);
2845                         END;
2846                         str[pointpos+INTEGER(ndigits)+1] := 0C;
2847                 END;
2848                 IF sign THEN
2849                         FOR i := ind1 TO 0 BY -1 DO
2850                                 str[i+1] := str[i];
2851                         END;
2852                         str[0] := '-';
2853                         INC(ind1);
2854                 END;
2855         END;
2856         IF (ind1+1) <= HIGH(str) THEN str[ind1+1] := 0C; END;
2857         IF ind1 >= CARDINAL(width) THEN
2858                 ok := FALSE;
2859                 RETURN;
2860         END;
2861         IF width > 0 THEN
2862                 DEC(width);
2863         END;
2864         IF (width > 0) AND (ind1 < CARDINAL(width)) THEN
2865                 FOR i := ind1 TO 0 BY -1 DO
2866                         str[i + CARDINAL(width) - ind1] := str[i];
2867                 END;
2868                 FOR i := 0 TO CARDINAL(width)-(ind1+1) DO
2869                         str[i] := ' ';
2870                 END;
2871                 ind1 := CARDINAL(width);
2872                 IF (ind1+1) <= HIGH(str) THEN
2873                         FOR ind1 := ind1+1 TO HIGH(str) DO
2874                                 str[ind1] := 0C;
2875                         END;
2876                 END;
2877         END;
2878
2879   END LongRealToString;
2880
2881
2882   PROCEDURE StringToReal(str: ARRAY OF CHAR;
2883                          VAR r: REAL; VAR ok: BOOLEAN);
2884     VAR x: LONGREAL;
2885   BEGIN
2886         StringToLongReal(str, x, ok);
2887         IF ok THEN
2888                 r := x;
2889         END;
2890   END StringToReal;
2891
2892   PROCEDURE StringToLongReal(str: ARRAY OF CHAR;
2893                          VAR r: LONGREAL; VAR ok: BOOLEAN);
2894     CONST       BIG = 1.0D17;
2895     TYPE        SETOFCHAR = SET OF CHAR;
2896     VAR         pow10 : INTEGER;
2897                 i : INTEGER;
2898                 e : LONGREAL;
2899                 ch : CHAR;
2900                 signed: BOOLEAN;
2901                 signedexp: BOOLEAN;
2902                 iB: CARDINAL;
2903
2904   BEGIN
2905         r := 0.0D;
2906         pow10 := 0;
2907         iB := 0;
2908         ok := TRUE;
2909         signed := FALSE;
2910         WHILE (str[iB] = ' ') OR (str[iB] = CHR(9)) DO
2911                 INC(iB);
2912                 IF iB > HIGH(str) THEN
2913                         ok := FALSE;
2914                         RETURN;
2915                 END;
2916         END;
2917         IF str[iB] = '-' THEN signed := TRUE; INC(iB)
2918         ELSIF str[iB] = '+' THEN INC(iB)
2919         END;
2920         ch := str[iB]; INC(iB);
2921         IF NOT (ch IN SETOFCHAR{'0'..'9'}) THEN ok := FALSE; RETURN END;
2922         REPEAT
2923                 IF r>BIG THEN INC(pow10) ELSE r:= 10.0D*r+FLOATD(ORD(ch)-ORD('0')) END;
2924                 IF iB <= HIGH(str) THEN
2925                         ch := str[iB]; INC(iB);
2926                 END;
2927         UNTIL (iB > HIGH(str)) OR NOT (ch IN SETOFCHAR{'0'..'9'});
2928         IF (ch = '.') AND (iB <= HIGH(str)) THEN
2929                 ch := str[iB]; INC(iB);
2930                 IF NOT (ch IN SETOFCHAR{'0'..'9'}) THEN ok := FALSE; RETURN END;
2931                 REPEAT
2932                         IF r < BIG THEN
2933                                 r := 10.0D * r + FLOATD(ORD(ch)-ORD('0'));
2934                                 DEC(pow10);
2935                         END;
2936                         IF iB <= HIGH(str) THEN
2937                                 ch := str[iB]; INC(iB);
2938                         END;
2939                 UNTIL (iB > HIGH(str)) OR NOT (ch IN SETOFCHAR{'0'..'9'});
2940         END;
2941         IF (ch = 'E') THEN
2942                 IF iB > HIGH(str) THEN
2943                         ok := FALSE;
2944                         RETURN;
2945                 ELSE
2946                         ch := str[iB]; INC(iB);
2947                 END;
2948                 i := 0;
2949                 signedexp := FALSE;
2950                 IF (ch = '-') OR (ch = '+') THEN
2951                         signedexp := ch = '-';
2952                         IF iB > HIGH(str) THEN
2953                                 ok := FALSE;
2954                                 RETURN;
2955                         ELSE
2956                                 ch := str[iB]; INC(iB);
2957                         END;
2958                 END;
2959                 IF NOT (ch IN SETOFCHAR{'0'..'9'}) THEN ok := FALSE; RETURN END;
2960                 REPEAT
2961                         i := i*10 + INTEGER(ORD(ch) - ORD('0'));
2962                         IF iB <= HIGH(str) THEN
2963                                 ch := str[iB]; INC(iB);
2964                         END;
2965                 UNTIL (iB > HIGH(str)) OR NOT (ch IN SETOFCHAR{'0'..'9'});
2966                 IF signedexp THEN i := -i END;
2967                 pow10 := pow10 + i;
2968         END;
2969         IF pow10 < 0 THEN i := -pow10; ELSE i := pow10; END;
2970         e := 1.0D;
2971         DEC(i);
2972         WHILE i >= 10 DO
2973                 e := e * 10000000000.0D;
2974                 DEC(i,10);
2975         END;
2976         WHILE i >= 0 DO
2977                 e := e * 10.0D;
2978                 DEC(i)
2979         END;
2980         IF pow10<0 THEN
2981                 r := r / e;
2982         ELSE
2983                 r := r * e;
2984         END;
2985         IF signed THEN r := -r; END;
2986         IF (iB <= HIGH(str)) AND (ORD(ch) > ORD(' ')) THEN ok := FALSE; END
2987   END StringToLongReal;
2988
2989 BEGIN
2990         WITH Powers10[1] DO pval := 1.0D32; rpval := 1.0D-32; exp := 32 END;
2991         WITH Powers10[2] DO pval := 1.0D16; rpval := 1.0D-16; exp := 16 END;
2992         WITH Powers10[3] DO pval := 1.0D8; rpval := 1.0D-8; exp := 8 END;
2993         WITH Powers10[4] DO pval := 1.0D4; rpval := 1.0D-4; exp := 4 END;
2994         WITH Powers10[5] DO pval := 1.0D2; rpval := 1.0D-2; exp := 2 END;
2995         WITH Powers10[6] DO pval := 1.0D1; rpval := 1.0D-1; exp := 1 END;
2996 END RealConversions.
2997  Storage.mod\0od\0\0\0\0\ 2\ 2�\ 1\0\0v\1d(*
2998   (c) copyright 1988 by the Vrije Universiteit, Amsterdam, The Netherlands.
2999   See the copyright notice in the ACK home directory, in the file "Copyright".
3000 *)
3001
3002 (*$R-*)
3003 IMPLEMENTATION MODULE Storage;
3004 (*
3005   Module:       Dynamic Storage Allocation
3006   Author:       Ceriel J.H. Jacobs
3007                 Adapted from a version in C by Hans Tebra
3008   Version:      $Id: Storage.mod,v 1.17 1994/06/24 12:49:47 ceriel Exp $
3009 *)
3010 (* This storage manager maintains an array of lists of objects with the
3011    same size. Commonly used sizes have their own bucket. The larger ones
3012    are put in a single list.
3013 *)
3014   FROM  Unix IMPORT     sbrk, ILLBREAK;
3015   FROM  SYSTEM IMPORT   ADDRESS, ADR;
3016   FROM  Traps IMPORT    Message;
3017
3018   CONST
3019         NLISTS = 20;
3020         MAGICW = 0A5A5H;
3021         MAGICC = 175C;
3022
3023   TYPE
3024         ALIGNTYPE =
3025           RECORD
3026                 CASE : INTEGER OF
3027                   1: l: LONGINT |
3028                   2: p: ADDRESS |
3029                   3: d: LONGREAL
3030                 END
3031           END;                  (* A type with high alignment requirements *)
3032         BucketPtr = POINTER TO Bucket;
3033         Bucket =
3034           RECORD
3035                 CASE : BOOLEAN OF
3036                    FALSE:
3037                           BNEXT: BucketPtr;     (* next free Bucket *)
3038                           BSIZE: CARDINAL; |    (* size of user part in UNITs *)
3039                    TRUE: BXX: ALIGNTYPE
3040                 END;
3041                 BSTORE: ALIGNTYPE;
3042           END;
3043
3044   CONST
3045         UNIT = SIZE(ALIGNTYPE);
3046
3047   VAR
3048         FreeLists: ARRAY[0..NLISTS] OF BucketPtr;       (* small blocks *)
3049         Llist: BucketPtr;                               (* others *)
3050         Compacted: BOOLEAN;             (* avoid recursive reorganization *)
3051         FirstBlock: BucketPtr;
3052         USED: ADDRESS;
3053
3054   PROCEDURE MyAllocate(size: CARDINAL) : ADDRESS;
3055     VAR nu : CARDINAL;
3056         b : CARDINAL;
3057         p, q: BucketPtr;
3058         pc: POINTER TO CHAR;
3059         brk : ADDRESS;
3060   BEGIN
3061         IF size > CARDINAL(MAX(INTEGER)-2*UNIT + 1) THEN
3062                 RETURN NIL;
3063         END;
3064         nu := (size + (UNIT-1)) DIV UNIT;
3065         IF nu = 0 THEN
3066                 nu := 1;
3067         END;
3068         IF nu <= NLISTS THEN
3069                 b := nu;
3070                 IF FreeLists[b] # NIL THEN
3071                         (* Exact fit *)
3072                         p := FreeLists[b];
3073                         FreeLists[b] := p^.BNEXT;
3074                         p^.BNEXT := USED;
3075                         IF p^.BSIZE * UNIT # size THEN
3076                                 pc := ADR(p^.BSTORE) + size;
3077                                 pc^ := MAGICC;
3078                         END;
3079                         p^.BSIZE := size;
3080                         RETURN ADR(p^.BSTORE);
3081                 END;
3082
3083                 (* Search for a block with >= 2 units more than requested.
3084                    We pay for an additional header when the block is split.
3085                 *)
3086                 FOR b := b+2 TO NLISTS DO
3087                         IF FreeLists[b] # NIL THEN
3088                                 q := FreeLists[b];
3089                                 FreeLists[b] := q^.BNEXT;
3090                                 p := ADDRESS(q) + (nu+1)*UNIT;
3091                                 (* p indicates the block that must be given
3092                                    back
3093                                 *)
3094                                 p^.BSIZE := q^.BSIZE - nu - 1;
3095                                 p^.BNEXT := FreeLists[p^.BSIZE];
3096                                 FreeLists[p^.BSIZE] := p;
3097                                 q^.BSIZE := nu;
3098                                 q^.BNEXT := USED;
3099                                 IF q^.BSIZE * UNIT # size THEN
3100                                         pc := ADR(q^.BSTORE) + size;
3101                                         pc^ := MAGICC;
3102                                 END;
3103                                 q^.BSIZE := size;
3104                                 RETURN ADR(q^.BSTORE);
3105                         END;
3106                 END;
3107         END;
3108
3109         p := Llist;
3110         IF p # NIL THEN
3111                 q := NIL;
3112                 WHILE (p # NIL) AND (p^.BSIZE < nu) DO
3113                         q := p;
3114                         p := p^.BNEXT;
3115                 END;
3116
3117                 IF p # NIL THEN
3118                         (* p^.BSIZE >= nu *)
3119                         IF p^.BSIZE <= nu + NLISTS + 1 THEN
3120                                 (* Remove p from this list *)
3121                                 IF q # NIL THEN q^.BNEXT := p^.BNEXT
3122                                 ELSE Llist := p^.BNEXT;
3123                                 END;
3124                                 p^.BNEXT := USED;
3125                                 IF p^.BSIZE > nu + 1 THEN
3126                                         (* split block,
3127                                            tail goes to FreeLists area
3128                                         *)
3129                                         q := ADDRESS(p) + (nu+1)*UNIT;
3130                                         q^.BSIZE := p^.BSIZE -nu -1;
3131                                         q^.BNEXT := FreeLists[q^.BSIZE];
3132                                         FreeLists[q^.BSIZE] := q;
3133                                         p^.BSIZE := nu;
3134                                 END;
3135                                 IF p^.BSIZE * UNIT # size THEN
3136                                         pc := ADR(p^.BSTORE) + size;
3137                                         pc^ := MAGICC;
3138                                 END;
3139                                 p^.BSIZE := size;
3140                                 RETURN ADR(p^.BSTORE);
3141                         END;
3142                         (* Give part of tail of original block.
3143                            Block stays in this list.
3144                         *)
3145                         q := ADDRESS(p) + (p^.BSIZE-nu)*UNIT;
3146                         q^.BSIZE := nu;
3147                         p^.BSIZE := p^.BSIZE - nu - 1;
3148                         q^.BNEXT := USED;
3149                         IF q^.BSIZE * UNIT # size THEN
3150                                 pc := ADR(q^.BSTORE) + size;
3151                                 pc^ := MAGICC;
3152                         END;
3153                         q^.BSIZE := size;
3154                         RETURN ADR(q^.BSTORE);
3155                 END;
3156         END;
3157
3158         IF Compacted THEN
3159                 (* reorganization did not yield sufficient memory *)
3160                 RETURN NIL;
3161         END;
3162
3163         brk := sbrk(UNIT * (nu + 1));
3164         IF brk = ILLBREAK THEN
3165                 ReOrganize();
3166                 Compacted := TRUE;
3167                 brk := MyAllocate(size);
3168                 Compacted := FALSE;
3169                 RETURN brk;
3170         END;
3171
3172         p := brk;
3173         p^.BSIZE := nu;
3174         p^.BNEXT := USED;
3175         IF p^.BSIZE * UNIT # size THEN
3176                 pc := ADR(p^.BSTORE) + size;
3177                 pc^ := MAGICC;
3178         END;
3179         p^.BSIZE := size;
3180         RETURN ADR(p^.BSTORE);
3181   END MyAllocate;
3182
3183   PROCEDURE ALLOCATE(VAR a: ADDRESS; size: CARDINAL);
3184   BEGIN
3185         Allocate(a, size);
3186   END ALLOCATE;
3187
3188   PROCEDURE Allocate(VAR a: ADDRESS; size: CARDINAL);
3189   BEGIN
3190         a := MyAllocate(size);
3191         IF a = NIL THEN
3192                 Message("out of core");
3193                 HALT;
3194         END;
3195   END Allocate;
3196
3197   PROCEDURE Available(size: CARDINAL): BOOLEAN;
3198     VAR a: ADDRESS;
3199   BEGIN
3200         a:= MyAllocate(size);
3201         IF a # NIL THEN
3202                 Deallocate(a, size);
3203                 RETURN TRUE;
3204         END;
3205         RETURN FALSE;
3206   END Available;
3207
3208   PROCEDURE DEALLOCATE(VAR a: ADDRESS; size: CARDINAL);
3209   BEGIN
3210         Deallocate(a, size);
3211   END DEALLOCATE;
3212
3213   PROCEDURE Deallocate(VAR a: ADDRESS; size: CARDINAL);
3214     VAR p: BucketPtr;
3215         pc: POINTER TO CHAR;
3216   BEGIN
3217         IF (a = NIL) THEN
3218                 Message("(Warning) Deallocate: NIL pointer deallocated");
3219                 RETURN;
3220         END;
3221         p := a - UNIT;
3222         IF (p^.BNEXT # BucketPtr(USED)) THEN
3223                 Message("(Warning) Deallocate: area already deallocated or heap corrupted");
3224                 a := NIL;
3225                 RETURN;
3226         END;
3227         WITH p^ DO
3228                 IF BSIZE # size THEN
3229                         Message("(Warning) Deallocate: wrong size or heap corrupted");
3230                 END;
3231                 BSIZE := (size + (UNIT - 1)) DIV UNIT;
3232                 IF (BSIZE*UNIT # size) THEN
3233                         pc := a + size;
3234                         IF pc^ # MAGICC THEN
3235                                 Message("(Warning) Deallocate: heap corrupted");
3236                         END;
3237                 END;
3238                 IF BSIZE <= NLISTS THEN
3239                         BNEXT := FreeLists[BSIZE];
3240                         FreeLists[BSIZE] := p;
3241                 ELSE
3242                         BNEXT := Llist;
3243                         Llist := p;
3244                 END;
3245         END;
3246         a := NIL
3247   END Deallocate;
3248
3249   PROCEDURE ReOrganize();
3250     VAR lastblock: BucketPtr;
3251         b, be: BucketPtr;
3252         i: CARDINAL;
3253   BEGIN
3254         lastblock := NIL;
3255         FOR i := 1 TO NLISTS DO
3256                 b := FreeLists[i];
3257                 WHILE b # NIL DO
3258                         IF ADDRESS(b) > ADDRESS(lastblock) THEN
3259                                 lastblock := b;
3260                         END;
3261                         be := b^.BNEXT;
3262                         b^.BNEXT := NIL;        (* temporary free mark *)
3263                         b := be;
3264                 END;
3265         END;
3266
3267         b := Llist;
3268         WHILE b # NIL DO
3269                 IF ADDRESS(b) > ADDRESS(lastblock) THEN
3270                         lastblock := b;
3271                 END;
3272                 be := b^.BNEXT;
3273                 b^.BNEXT := NIL;
3274                 b := be;
3275         END;
3276
3277         (* Now, all free blocks have b^.BNEXT = NIL *)
3278
3279         b := FirstBlock;
3280         WHILE ADDRESS(b) < ADDRESS(lastblock) DO
3281                 LOOP
3282                         be := ADDRESS(b)+(b^.BSIZE+1)*UNIT;
3283                         IF b^.BNEXT # NIL THEN
3284                                 (* this block is not free *)
3285                                 EXIT;
3286                         END;
3287                         IF ADDRESS(be) > ADDRESS(lastblock) THEN
3288                                 (* no next block *)
3289                                 EXIT;
3290                         END;
3291                         IF be^.BNEXT # NIL THEN
3292                                 (* next block is not free *)
3293                                 EXIT;
3294                         END;
3295                         (* this block and the next one are free,
3296                            so merge them, but only if it is not too big
3297                         *)
3298                         IF MAX(CARDINAL) - b^.BSIZE > be^.BSIZE THEN
3299                                 b^.BSIZE := b^.BSIZE + be^.BSIZE + 1;
3300                         ELSE
3301                                 EXIT;
3302                         END;
3303                 END;
3304                 b := be;
3305         END;
3306
3307         (* clear all free lists *)
3308         FOR i := 1 TO NLISTS DO FreeLists[i] := NIL; END;
3309         Llist := NIL;
3310
3311         (* collect free blocks in them again *)
3312         b := FirstBlock;
3313         WHILE ADDRESS(b) <= ADDRESS(lastblock) DO
3314                 WITH b^ DO
3315                         IF BNEXT = NIL THEN
3316                                 IF BSIZE <= NLISTS THEN
3317                                         BNEXT := FreeLists[BSIZE];
3318                                         FreeLists[BSIZE] := b;
3319                                 ELSE
3320                                         BNEXT := Llist;
3321                                         Llist := b;
3322                                 END;
3323                                 b := ADDRESS(b) + (BSIZE+1) * UNIT;
3324                         ELSE
3325                                 b := ADDRESS(b) +
3326                                         ((BSIZE + (UNIT - 1)) DIV UNIT + 1) * UNIT;
3327                         END;
3328                 END;
3329         END;
3330   END ReOrganize;
3331
3332   PROCEDURE InitStorage();
3333     VAR i: CARDINAL;
3334         brk: ADDRESS;
3335   BEGIN
3336         FOR i := 1 TO NLISTS DO
3337                 FreeLists[i] := NIL;
3338         END;
3339         Llist := NIL;
3340         brk := sbrk(0);
3341         brk := sbrk(UNIT - brk MOD UNIT);
3342         FirstBlock := sbrk(0);
3343         Compacted := FALSE;
3344         USED := MAGICW;
3345   END InitStorage;
3346
3347 BEGIN
3348         InitStorage();
3349 END Storage.
3350 Conversion.mod\0\0\0\0\ 2\ 2�\ 1\0\0!\a(*
3351   (c) copyright 1988 by the Vrije Universiteit, Amsterdam, The Netherlands.
3352   See the copyright notice in the ACK home directory, in the file "Copyright".
3353 *)
3354
3355 (*$R-*)
3356 IMPLEMENTATION MODULE Conversions;
3357 (*
3358   Module:       numeric-to-string conversions
3359   Author:       Ceriel J.H. Jacobs
3360   Version:      $Id: Conversion.mod,v 1.8 1994/06/24 12:48:32 ceriel Exp $
3361 *)
3362
3363   PROCEDURE ConvertNum(num, len, base: CARDINAL;
3364                        neg: BOOLEAN;
3365                        VAR str: ARRAY OF CHAR);
3366     VAR i: CARDINAL;
3367         r: CARDINAL;
3368         tmp: ARRAY [0..20] OF CHAR;
3369     BEGIN
3370         i := 0;
3371         REPEAT
3372                 r := num MOD base;
3373                 num := num DIV base;
3374                 IF r <= 9 THEN
3375                         tmp[i] := CHR(r + ORD('0'));
3376                 ELSE
3377                         tmp[i] := CHR(r - 10 + ORD('A'));
3378                 END;
3379                 INC(i);
3380         UNTIL num = 0;
3381         IF neg THEN
3382                 tmp[i] := '-';
3383                 INC(i)
3384         END;
3385         IF len > HIGH(str) + 1 THEN len := HIGH(str) + 1; END;
3386         IF i > HIGH(str) + 1 THEN i := HIGH(str) + 1; END;
3387         r := 0;
3388         WHILE len > i DO str[r] := ' '; INC(r); DEC(len); END;
3389         WHILE i > 0 DO str[r] := tmp[i-1]; DEC(i); INC(r); END;
3390         WHILE r <= HIGH(str) DO
3391                 str[r] := 0C;
3392                 INC(r);
3393         END;
3394     END ConvertNum;
3395
3396   PROCEDURE ConvertOctal(num, len: CARDINAL; VAR str: ARRAY OF CHAR);
3397   BEGIN
3398         ConvertNum(num, len, 8, FALSE, str);
3399   END ConvertOctal;
3400
3401   PROCEDURE ConvertHex(num, len: CARDINAL; VAR str: ARRAY OF CHAR);
3402   BEGIN
3403         ConvertNum(num, len, 16, FALSE, str);
3404   END ConvertHex;
3405
3406   PROCEDURE ConvertCardinal(num, len: CARDINAL; VAR str: ARRAY OF CHAR);
3407   BEGIN
3408         ConvertNum(num, len, 10, FALSE, str);
3409   END ConvertCardinal;
3410
3411   PROCEDURE ConvertInteger(num: INTEGER;
3412                            len: CARDINAL;
3413                            VAR str: ARRAY OF CHAR);
3414   BEGIN
3415         IF (num < 0) AND (num >= -MAX(INTEGER)) THEN
3416                 ConvertNum(-num, len, 10, TRUE, str);
3417         ELSE
3418                 ConvertNum(CARDINAL(num), len, 10, num < 0, str);
3419         END;
3420   END ConvertInteger;
3421
3422 END Conversions.
3423 ISemaphores.mod\0\0\0\0\ 2\ 2�\ 1\0\0�\b(*
3424   (c) copyright 1988 by the Vrije Universiteit, Amsterdam, The Netherlands.
3425   See the copyright notice in the ACK home directory, in the file "Copyright".
3426 *)
3427
3428 (*$R-*)
3429 IMPLEMENTATION MODULE Semaphores [1];
3430 (*
3431   Module:       Processes with semaphores
3432   Author:       Ceriel J.H. Jacobs
3433   Version:      $Id: Semaphores.mod,v 1.7 1994/06/24 12:49:41 ceriel Exp $
3434
3435   Quasi-concurrency implementation
3436 *)
3437
3438   FROM  SYSTEM IMPORT   ADDRESS, NEWPROCESS, TRANSFER;
3439   FROM  Storage IMPORT  Allocate;
3440   FROM  random IMPORT   Uniform;
3441   FROM  Traps IMPORT    Message;
3442
3443   TYPE  Sema = POINTER TO Semaphore;
3444         Processes = POINTER TO Process;
3445         Semaphore =
3446                 RECORD
3447                         level: CARDINAL;
3448                 END;
3449         Process =
3450                 RECORD  next: Processes;
3451                         proc: ADDRESS;
3452                         waiting: Sema;
3453                 END;
3454
3455   VAR   cp: Processes;                  (* current process *)
3456
3457   PROCEDURE StartProcess(P: PROC; n: CARDINAL);
3458     VAR s0: Processes;
3459         wsp: ADDRESS;
3460   BEGIN
3461         s0 := cp;
3462         Allocate(wsp, n);
3463         Allocate(cp, SIZE(Process));
3464         WITH cp^ DO
3465                 next := s0^.next;
3466                 s0^.next := cp;
3467                 waiting := NIL;
3468         END;
3469         NEWPROCESS(P, wsp, n, cp^.proc);
3470         TRANSFER(s0^.proc, cp^.proc);
3471   END StartProcess;
3472
3473   PROCEDURE Up(VAR s: Sema);
3474   BEGIN
3475         s^.level := s^.level + 1;
3476         ReSchedule;
3477   END Up;
3478
3479   PROCEDURE Down(VAR s: Sema);
3480   BEGIN
3481         IF s^.level = 0 THEN
3482                 cp^.waiting := s;
3483         ELSE
3484                 s^.level := s^.level - 1;
3485         END;
3486         ReSchedule;
3487   END Down;
3488
3489   PROCEDURE NewSema(n: CARDINAL): Sema;
3490   VAR   s: Sema;
3491   BEGIN
3492         Allocate(s, SIZE(Semaphore));
3493         s^.level := n;
3494         RETURN s;
3495   END NewSema;
3496
3497   PROCEDURE Level(s: Sema): CARDINAL;
3498   BEGIN
3499         RETURN s^.level;
3500   END Level;
3501
3502   PROCEDURE ReSchedule;
3503   VAR s0: Processes;
3504       i, j: CARDINAL;
3505   BEGIN
3506         s0 := cp;
3507         i := Uniform(1, 5);
3508         j := i;
3509         LOOP
3510                 cp := cp^.next;
3511                 IF Runnable(cp) THEN
3512                         DEC(i);
3513                         IF i = 0 THEN EXIT END;
3514                 END;
3515                 IF (cp = s0) AND (j = i) THEN
3516                         (* deadlock *)
3517                         Message("deadlock");
3518                         HALT
3519                 END;
3520         END;
3521         IF cp # s0 THEN TRANSFER(s0^.proc, cp^.proc); END;
3522   END ReSchedule;
3523
3524   PROCEDURE Runnable(p: Processes): BOOLEAN;
3525   BEGIN
3526         IF p^.waiting = NIL THEN RETURN TRUE; END;
3527         IF p^.waiting^.level > 0 THEN
3528                 p^.waiting^.level := p^.waiting^.level - 1;
3529                 p^.waiting := NIL;
3530                 RETURN TRUE;
3531         END;
3532         RETURN FALSE;
3533   END Runnable;
3534 BEGIN
3535         Allocate(cp, SIZE(Process));
3536         WITH cp^ DO
3537                 next := cp;
3538                 waiting := NIL;
3539         END
3540 END Semaphores.
3541 random.mod\0mod\0\0\0\0\ 2\ 2�\ 1\0\0�\ 4(*
3542   (c) copyright 1988 by the Vrije Universiteit, Amsterdam, The Netherlands.
3543   See the copyright notice in the ACK home directory, in the file "Copyright".
3544 *)
3545
3546 (*$R-*)
3547 IMPLEMENTATION MODULE random;
3548 (*
3549   Module:       random numbers
3550   Author:       Ceriel J.H. Jacobs
3551   Version:      $Id: random.mod,v 1.8 1994/06/24 12:51:27 ceriel Exp $
3552 *)
3553
3554   FROM  Unix IMPORT     getpid, time;
3555   TYPE index = [1..55];
3556
3557   VAR   X: ARRAY index OF CARDINAL;
3558         j, k: index;
3559         tm: LONGINT;
3560
3561   PROCEDURE Random(): CARDINAL;
3562   BEGIN
3563         IF k-1 <= 0 THEN k := 55; ELSE DEC(k) END;
3564         IF j-1 <= 0 THEN j := 55; ELSE DEC(j) END;
3565         X[k] := X[k] + X[j];
3566         RETURN X[k]
3567   END Random;
3568
3569   PROCEDURE Uniform (lwb, upb: CARDINAL): CARDINAL;
3570   BEGIN
3571         IF upb <= lwb THEN RETURN lwb; END;
3572         RETURN lwb + (Random() MOD (upb - lwb + 1));
3573   END Uniform;
3574
3575   PROCEDURE StartSeed(seed: CARDINAL);
3576   VAR v: CARDINAL;
3577   BEGIN
3578         FOR k := 1 TO 55 DO
3579                 seed := 1297 * seed + 123;
3580                 X[k] := seed;
3581         END;
3582         FOR k := 1 TO 15 DO
3583                 j := tm MOD 55D + 1D;
3584                 v := X[j];
3585                 tm := tm DIV 7D;
3586                 j := tm MOD 55D + 1D;
3587                 X[j] := v;
3588                 tm := tm * 3D;
3589         END;
3590         k := 1;
3591         j := 25;
3592   END StartSeed;
3593
3594 BEGIN
3595         tm := time(NIL);
3596         X[1] := tm;
3597         StartSeed(CARDINAL(getpid()) * X[1]);
3598 END random.
3599 (Strings.mod\0od\0\0\0\0\ 2\ 2�\ 1\0\0�\10(*
3600   (c) copyright 1988 by the Vrije Universiteit, Amsterdam, The Netherlands.
3601   See the copyright notice in the ACK home directory, in the file "Copyright".
3602 *)
3603
3604 (*$R-*)
3605 IMPLEMENTATION MODULE Strings;
3606 (*
3607   Module:       String manipulations
3608   Author:       Ceriel J.H. Jacobs
3609   Version:      $Id: Strings.mod,v 1.6 1994/06/24 12:50:03 ceriel Exp $
3610 *)
3611
3612   PROCEDURE Assign(source: ARRAY OF CHAR; VAR dest: ARRAY OF CHAR);
3613   (* Assign string source to dest
3614   *)
3615   VAR   i: CARDINAL;
3616         max: CARDINAL;
3617   BEGIN
3618         max := HIGH(source);
3619         IF HIGH(dest) < max THEN max := HIGH(dest); END;
3620         i := 0;
3621         WHILE (i <= max) AND (source[i] # 0C) DO
3622                 dest[i] := source[i];
3623                 INC(i);
3624         END;
3625         IF i < HIGH(dest) THEN dest[i] := 0C; END;
3626   END Assign;
3627
3628   PROCEDURE Insert(substr: ARRAY OF CHAR; VAR str: ARRAY OF CHAR; inx: CARDINAL);
3629   (* Insert the string substr into str, starting at str[inx].
3630      If inx is equal to or greater than Length(str) then substr is appended
3631      to the end of str.
3632   *)
3633   VAR   sublen, length, i: CARDINAL;
3634   BEGIN
3635         sublen := Length(substr);
3636         IF sublen = 0 THEN RETURN; END;
3637         length := Length(str);
3638         IF inx > length THEN inx := length; END;
3639         i := length;
3640         IF i + sublen  - 1 > HIGH(str) THEN i := HIGH(str); END;
3641         WHILE i > inx DO
3642                 str[i+sublen-1] := str[i-1];
3643                 DEC(i);
3644         END;
3645         FOR i := 0 TO sublen - 1 DO
3646                 IF i + inx <= HIGH(str) THEN
3647                         str[i + inx] := substr[i];
3648                 ELSE
3649                         RETURN;
3650                 END;
3651         END;
3652         IF length + sublen <= HIGH(str) THEN
3653                 str[length + sublen] := 0C;
3654         END;
3655   END Insert;
3656
3657   PROCEDURE Delete(VAR str: ARRAY OF CHAR; inx, len: CARDINAL);
3658   (* Delete len characters from str, starting at str[inx].
3659      If inx >= Length(str) then nothing happens.
3660      If there are not len characters to delete, characters to the end of the
3661      string are deleted.
3662   *)
3663   VAR   length: CARDINAL;
3664   BEGIN
3665         IF len = 0 THEN RETURN; END;
3666         length := Length(str);
3667         IF inx >= length THEN RETURN; END;
3668         WHILE inx + len < length DO
3669                 str[inx] := str[inx + len];
3670                 INC(inx);
3671         END;
3672         str[inx] := 0C;
3673   END Delete;
3674
3675   PROCEDURE Pos(substr, str: ARRAY OF CHAR): CARDINAL;
3676   (* Return the index into str of the first occurrence of substr.
3677      Pos returns a value greater than HIGH(str) of no occurrence is found.
3678   *)
3679   VAR   i, j, max, subl: CARDINAL;
3680   BEGIN
3681         max := Length(str);
3682         subl := Length(substr);
3683         IF subl > max THEN RETURN HIGH(str) + 1; END;
3684         IF subl = 0 THEN RETURN 0; END;
3685         max := max - subl;
3686         FOR i := 0 TO max DO
3687                 j := 0;
3688                 WHILE (j <= subl-1) AND (str[i+j] = substr[j]) DO
3689                         INC(j);
3690                 END;
3691                 IF j = subl THEN RETURN i; END;
3692         END;
3693         RETURN HIGH(str) + 1;
3694   END Pos;
3695
3696   PROCEDURE Copy(str: ARRAY OF CHAR;
3697                  inx, len: CARDINAL;
3698                  VAR result: ARRAY OF CHAR);
3699   (* Copy at most len characters from str into result, starting at str[inx].
3700   *)
3701   VAR   i: CARDINAL;
3702   BEGIN
3703         IF Length(str) <= inx THEN RETURN END;
3704         i := 0;
3705         LOOP
3706                 IF i > HIGH(result) THEN RETURN; END;
3707                 IF len = 0 THEN EXIT; END;
3708                 IF inx > HIGH(str) THEN EXIT; END;
3709                 result[i] := str[inx];
3710                 INC(i); INC(inx); DEC(len);
3711         END;
3712         IF i <= HIGH(result) THEN result[i] := 0C; END;
3713   END Copy;
3714
3715   PROCEDURE Concat(s1, s2: ARRAY OF CHAR; VAR result: ARRAY OF CHAR);
3716   (* Concatenate two strings.
3717   *)
3718   VAR   i, j: CARDINAL;
3719   BEGIN
3720         i := 0;
3721         WHILE (i <= HIGH(s1)) AND (s1[i] # 0C) DO
3722                 IF i > HIGH(result) THEN RETURN END;
3723                 result[i] := s1[i];
3724                 INC(i);
3725         END;
3726         j := 0;
3727         WHILE (j <= HIGH(s2)) AND (s2[j] # 0C) DO
3728                 IF i > HIGH(result) THEN RETURN END;
3729                 result[i] := s2[j];
3730                 INC(i);
3731                 INC(j);
3732         END;
3733         IF i <= HIGH(result) THEN result[i] := 0C; END;
3734   END Concat;
3735
3736   PROCEDURE Length(str: ARRAY OF CHAR): CARDINAL;
3737   (* Return number of characters in str.
3738   *)
3739   VAR i: CARDINAL;
3740   BEGIN
3741         i := 0;
3742         WHILE (i <= HIGH(str)) DO
3743                 IF str[i] = 0C THEN RETURN i; END;
3744                 INC(i);
3745         END;
3746         RETURN i;
3747   END Length;
3748
3749   PROCEDURE CompareStr(s1, s2: ARRAY OF CHAR): INTEGER;
3750   (* Compare two strings, return -1 if s1 < s2, 0 if s1 = s2, and 1 if s1 > s2.
3751   *)
3752   VAR   i: CARDINAL;
3753         max: CARDINAL;
3754   BEGIN
3755         max := HIGH(s1);
3756         IF HIGH(s2) < max THEN max := HIGH(s2); END;
3757         i := 0;
3758         WHILE (i <= max) DO
3759                 IF s1[i] < s2[i] THEN RETURN -1; END;
3760                 IF s1[i] > s2[i] THEN RETURN 1; END;
3761                 IF s1[i] = 0C THEN RETURN 0; END;
3762                 INC(i);
3763         END;
3764         IF (i <= HIGH(s1)) AND (s1[i] # 0C) THEN RETURN 1; END;
3765         IF (i <= HIGH(s2)) AND (s2[i] # 0C) THEN RETURN -1; END;
3766         RETURN 0;
3767   END CompareStr;
3768
3769 END Strings.
3770 ArraySort.mod\0\0\0\0\0\ 2\ 2�\ 1\0\0�\10(*
3771   (c) copyright 1988 by the Vrije Universiteit, Amsterdam, The Netherlands.
3772   See the copyright notice in the ACK home directory, in the file "Copyright".
3773 *)
3774
3775 (*$R-*)
3776 IMPLEMENTATION MODULE ArraySort;
3777 (*
3778   Module:       Array sorting module.
3779   Author:       Ceriel J.H. Jacobs
3780   Version:      $Id: ArraySort.mod,v 1.4 1994/06/24 12:48:19 ceriel Exp $
3781 *)
3782   FROM  SYSTEM IMPORT   ADDRESS, BYTE;  (* no generics in Modula-2, sorry *)
3783
3784   TYPE BytePtr = POINTER TO BYTE;
3785
3786   VAR compareproc: CompareProc;
3787
3788   PROCEDURE Sort(base: ADDRESS;         (* address of array *)
3789                  nel: CARDINAL;         (* number of elements in array *)
3790                  size: CARDINAL;        (* size of each element *)
3791                  compar: CompareProc);  (* the comparison procedure *)
3792   BEGIN
3793         compareproc := compar;
3794         qsort(base, base+(nel-1)*size, size);
3795   END Sort;
3796
3797   PROCEDURE qsort(a1, a2: ADDRESS; size: CARDINAL);
3798   (* Implemented with quick-sort, with some extra's *)
3799     VAR left, right, lefteq, righteq: ADDRESS;
3800         cmp: CompareResult;
3801         mainloop: BOOLEAN;
3802   BEGIN
3803         WHILE a2 > a1 DO
3804                 left := a1;
3805                 right := a2;
3806                 lefteq := a1 + size * (((a2 - a1) + size) DIV (2 * size));
3807                 righteq := lefteq;
3808                 (*
3809                    Pick an element in the middle of the array.
3810                    We will collect the equals around it.
3811                    "lefteq" and "righteq" indicate the left and right
3812                    bounds of the equals respectively.
3813                    Smaller elements end up left of it, larger elements end
3814                    up right of it.
3815                 *)
3816                 LOOP
3817                         LOOP
3818                                 IF left >= lefteq THEN EXIT END;
3819                                 cmp := compareproc(left, lefteq);
3820                                 IF cmp = greater THEN EXIT END;
3821                                 IF cmp = less THEN
3822                                         left := left + size;
3823                                 ELSE
3824                                         (* equal, so exchange with the element
3825                                            to the left of the "equal"-interval.
3826                                         *)
3827                                         lefteq := lefteq - size;
3828                                         exchange(left, lefteq, size);
3829                                 END;
3830                         END;
3831                         mainloop := FALSE;
3832                         LOOP
3833                                 IF right <= righteq THEN EXIT END;
3834                                 cmp := compareproc(right, righteq);
3835                                 IF cmp = less THEN
3836                                         IF left < lefteq THEN
3837                                                 (* larger one at the left,
3838                                                    so exchange
3839                                                 *)
3840                                                 exchange(left,right,size);
3841                                                 left := left + size;
3842                                                 right := right - size;
3843                                                 mainloop := TRUE;
3844                                                 EXIT;
3845                                         END;
3846                                 (*
3847                                    no more room at the left part, so we
3848                                    move the "equal-interval" one place to the
3849                                    right, and the smaller element to the
3850                                    left of it.
3851                                    This is best expressed as a three-way
3852                                    exchange.
3853                                 *)
3854                                         righteq := righteq + size;
3855                                         threewayexchange(left, righteq, right,
3856                                                 size);
3857                                         lefteq := lefteq + size;
3858                                         left := lefteq;
3859                                 ELSIF cmp = equal THEN
3860                                         (* equal, zo exchange with the element
3861                                            to the right of the "equal"
3862                                            interval
3863                                         *)
3864                                         righteq := righteq + size;
3865                                         exchange(right, righteq, size);
3866                                 ELSE
3867                                         (* leave it where it is *)
3868                                         right := right - size;
3869                                 END;
3870                         END;
3871                         IF (NOT mainloop) THEN
3872                                 IF left >= lefteq THEN
3873                                         (* sort "smaller" part *)
3874                                         qsort(a1, lefteq - size, size);
3875                                         (* and now the "larger" part, saving a
3876                                            procedure call, because of this big
3877                                            WHILE loop
3878                                         *)
3879                                         a1 := righteq + size;
3880                                         EXIT;   (* from the LOOP *)
3881                                 END;
3882                                 (* larger element to the left, but no more room,
3883                                    so move the "equal-interval" one place to the
3884                                    left, and the larger element to the right
3885                                    of it.
3886                                 *)
3887                                 lefteq := lefteq - size;
3888                                 threewayexchange(right, lefteq, left, size);
3889                                 righteq := righteq - size;
3890                                 right := righteq;
3891                         END;
3892                 END;
3893         END;
3894   END qsort;
3895
3896   PROCEDURE exchange(a,b: BytePtr; size : CARDINAL);
3897     VAR c: BYTE;
3898   BEGIN
3899         WHILE size > 0 DO
3900                 DEC(size);
3901                 c := a^;
3902                 a^ := b^;
3903                 a := ADDRESS(a) + 1;
3904                 b^ := c;
3905                 b := ADDRESS(b) + 1;
3906         END;
3907   END exchange;
3908
3909   PROCEDURE threewayexchange(p,q,r: BytePtr; size: CARDINAL);
3910     VAR c: BYTE;
3911   BEGIN
3912         WHILE size > 0 DO
3913                 DEC(size);
3914                 c := p^;
3915                 p^ := r^;
3916                 p := ADDRESS(p) + 1;
3917                 r^ := q^;
3918                 r := ADDRESS(r) + 1;
3919                 q^ := c;
3920                 q := ADDRESS(q) + 1;
3921         END;
3922   END threewayexchange;
3923
3924 END ArraySort.
3925 pcatch.c\0t.mod\0\0\0\0\0\ 2\ 2�\ 1\0\0\9f      /*
3926   (c) copyright 1988 by the Vrije Universiteit, Amsterdam, The Netherlands.
3927   See the copyright notice in the ACK home directory, in the file "Copyright".
3928 */
3929
3930 /*
3931   Module:       default modula-2 trap handler
3932   Author:       Ceriel J.H. Jacobs
3933   Version:      $Id: catch.c,v 1.25 1994/11/14 11:51:24 ceriel Exp $
3934 */
3935 #include <em_abs.h>
3936 #include <m2_traps.h>
3937 #include <signal.h>
3938
3939 static struct errm {
3940         int errno;
3941         char *errmes;
3942 } errors[] = {
3943         { EARRAY,       "array bound error"},
3944         { ERANGE,       "range bound error"},
3945         { ESET,         "set bound error"},
3946         { EIOVFL,       "integer overflow"},
3947         { EFOVFL,       "real overflow"},
3948         { EFUNFL,       "real underflow"},
3949         { EIDIVZ,       "divide by 0"},
3950         { EFDIVZ,       "divide by 0.0"},
3951         { EIUND,        "undefined integer"},
3952         { EFUND,        "undefined real"},
3953         { ECONV,        "conversion error"},
3954
3955         { ESTACK,       "stack overflow"},
3956         { EHEAP,        "heap overflow"},
3957         { EILLINS,      "illegal instruction"},
3958         { EODDZ,        "illegal size argument"},
3959         { ECASE,        "case error"},
3960         { EMEMFLT,      "addressing non existent memory"},
3961         { EBADPTR,      "bad pointer used"},
3962         { EBADPC,       "program counter out of range"},
3963         { EBADLAE,      "bad argument of lae"},
3964         { EBADMON,      "bad monitor call"},
3965         { EBADLIN,      "argument if LIN too high"},
3966         { EBADGTO,      "GTO descriptor error"},
3967
3968         { M2_TOOLARGE,  "stack size of process too large"},
3969         { M2_TOOMANY,   "too many nested traps + handlers"},
3970         { M2_NORESULT,  "no RETURN from function procedure"},
3971         { M2_UOVFL,     "cardinal overflow"},
3972         { M2_FORCH,     "(warning) FOR-loop control variable was changed in the body"},
3973         { M2_UUVFL,     "cardinal underflow"},
3974         { M2_INTERNAL,  "internal error; ask an expert for help"},
3975         { M2_UNIXSIG,   "got a unix signal"},
3976         { -1,           0}
3977 };
3978
3979 catch(trapno)
3980         int trapno;
3981 {
3982         register struct errm *ep = &errors[0];
3983         char *errmessage;
3984         char buf[20];
3985         register char *p, *s;
3986
3987         while (ep->errno != trapno && ep->errmes != 0) ep++;
3988         if (p = ep->errmes) {
3989                 while (*p) p++;
3990                 _Traps__Message(ep->errmes, 0, (int) (p - ep->errmes), 1);
3991         }
3992         else {
3993                 int i = trapno;
3994                 static char q[] = "error number xxxxxxxxxxxxx";
3995
3996                 p = &q[13];
3997                 s = buf;
3998                 if (i < 0) {
3999                         i = -i;
4000                         *p++ = '-';
4001                 }
4002                 do
4003                         *s++ = i % 10 + '0';
4004                 while (i /= 10);
4005                 while (s > buf) *p++ = *--s;
4006                 *p = 0;
4007                 _Traps__Message(q, 0, (int) (p - q), 1);
4008         }
4009 #if !defined(__em24) && !defined(__em44) && !defined(__em22)
4010         if (trapno == M2_UNIXSIG) {
4011                 extern int __signo;
4012                 signal(__signo, SIG_DFL);
4013                 _cleanup();
4014                 kill(getpid(), __signo);
4015                 _exit(trapno+1);
4016         }
4017 #endif
4018         if (trapno != M2_FORCH) {
4019                 _cleanup();
4020                 _exit(trapno+1);
4021         }
4022         SIG(catch);
4023 }
4024  Traps.mod\0mod\0\0\0\0\0\ 2\ 2�\ 1\0\0\13\b(*
4025   (c) copyright 1988 by the Vrije Universiteit, Amsterdam, The Netherlands.
4026   See the copyright notice in the ACK home directory, in the file "Copyright".
4027 *)
4028
4029 (*$R-*)
4030 IMPLEMENTATION MODULE Traps;
4031 (*
4032   Module:       Facility for handling traps
4033   Author:       Ceriel J.H. Jacobs
4034   Version:      $Id: Traps.mod,v 1.8 1994/06/24 12:50:25 ceriel Exp $
4035 *)
4036
4037   FROM  EM IMPORT       SIG, LINO, FILN, TRP;
4038   FROM  Unix IMPORT     write;
4039   FROM  SYSTEM IMPORT   ADDRESS, ADR;
4040   FROM  Arguments IMPORT
4041                         Argv;
4042
4043   PROCEDURE InstallTrapHandler(t: TrapHandler): TrapHandler;
4044   (* Install a new trap handler, and return the previous one.
4045      Parameter of trap handler is the trap number.
4046   *)
4047   BEGIN
4048         RETURN SIG(t);
4049   END InstallTrapHandler;
4050
4051   PROCEDURE Message(str: ARRAY OF CHAR);
4052   (* Write message "str" on standard error, preceeded by filename and
4053      linenumber if possible
4054   *)
4055   VAR   p: POINTER TO CHAR;
4056         l: CARDINAL;
4057         lino: INTEGER;
4058         buf, buf2: ARRAY [0..255] OF CHAR;
4059         i, j: CARDINAL;
4060   BEGIN
4061         p := FILN();
4062         IF p # NIL THEN
4063                 i := 1;
4064                 buf[0] := '"';
4065                 WHILE p^ # 0C DO
4066                         buf[i] := p^;
4067                         INC(i);
4068                         p := ADDRESS(p) + 1;
4069                 END;
4070                 buf[i] := '"';
4071                 INC(i);
4072                 IF write(2, ADR(buf), i) < 0 THEN END;
4073         ELSE
4074                 l := Argv(0, buf);
4075                 IF write(2, ADR(buf), l-1) < 0 THEN END;
4076         END;
4077         lino := LINO();
4078         i := 0;
4079         IF lino # 0 THEN
4080                 i := 7;
4081                 buf[0] := ','; buf[1] := ' ';
4082                 buf[2] := 'l'; buf[3] := 'i'; buf[4] := 'n'; buf[5] := 'e';
4083                 buf[6] := ' ';
4084                 IF lino < 0 THEN
4085                         buf[7] := '-';
4086                         i := 8;
4087                         lino := - lino;
4088                 END;
4089                 j := 0;
4090                 REPEAT
4091                         buf2[j] := CHR(CARDINAL(lino) MOD 10 + ORD('0'));
4092                         lino := lino DIV 10;
4093                         INC(j);
4094                 UNTIL lino = 0;
4095                 WHILE j > 0 DO
4096                         DEC(j);
4097                         buf[i] := buf2[j];
4098                         INC(i);
4099                 END;
4100         END;
4101         buf[i] := ':';
4102         buf[i+1] := ' ';
4103         IF write(2, ADR(buf), i+2) < 0 THEN END;
4104         i := 0;
4105         WHILE (i <= HIGH(str)) AND (str[i] # 0C) DO
4106                 INC(i);
4107         END;
4108         IF write(2, ADR(str), i) < 0 THEN END;
4109         buf[0] := 12C;
4110         IF write(2, ADR(buf), 1) < 0 THEN END;
4111   END Message;
4112
4113   PROCEDURE Trap(n: INTEGER);
4114   (* cause trap number "n" to occur *)
4115   BEGIN
4116         TRP(n);
4117   END Trap;
4118
4119 END Traps.
4120 ;XXTermcap.c\0d\0\0\0\0\0\ 2\ 2�\ 1\0\0�(/*
4121  *      termcap.c       1.1     20/7/87         agc     Joypace Ltd
4122  *
4123  *      Copyright Joypace Ltd, London, UK, 1987. All rights reserved.
4124  *      This file may be freely distributed provided that this notice
4125  *      remains attached.
4126  *
4127  *      A public domain implementation of the termcap(3) routines.
4128  *
4129  *      Made fully functional by Ceriel J.H. Jacobs.
4130  *
4131  * BUGS:
4132  *      - does not check termcap entry sizes
4133  *      - not fully tested
4134  */
4135
4136 #define CAPABLEN        2
4137
4138 #define ISSPACE(c)      ((c) == ' ' || (c) == '\t' || (c) == '\r' || (c) == '\n')
4139 #define ISDIGIT(x)      ((x) >= '0' && (x) <= '9')
4140
4141 short   ospeed = 0;             /* output speed */
4142 char    PC = 0;                 /* padding character */
4143 char    *BC = 0;                /* back cursor movement */
4144 char    *UP = 0;                /* up cursor movement */
4145
4146 static char     *capab = 0;             /* the capability itself */
4147 static int      check_for_tc();
4148 static int      match_name();
4149
4150 #define NULL    0
4151
4152 /* Some things from C-library, needed here because the C-library is not
4153    loaded with Modula-2 programs
4154 */
4155
4156 static char *
4157 strcat(s1, s2)
4158 register char *s1, *s2;
4159 {
4160   /* Append s2 to the end of s1. */
4161
4162   char *original = s1;
4163
4164   /* Find the end of s1. */
4165   while (*s1 != 0) s1++;
4166
4167   /* Now copy s2 to the end of s1. */
4168   while (*s1++ = *s2++) /* nothing */ ;
4169   return(original);
4170 }
4171
4172 static char *
4173 strcpy(s1, s2)
4174 register char *s1, *s2;
4175 {
4176 /* Copy s2 to s1. */
4177   char *original = s1;
4178
4179   while (*s1++ = *s2++) /* nothing */;
4180   return(original);
4181 }
4182
4183 static int
4184 strlen(s)
4185 char *s;
4186 {
4187 /* Return length of s. */
4188
4189   char *original = s;
4190
4191   while (*s != 0) s++;
4192   return(s - original);
4193 }
4194
4195 static int
4196 strcmp(s1, s2)
4197 register char *s1, *s2;
4198 {
4199 /* Compare 2 strings. */
4200
4201   for(;;) {
4202         if (*s1 != *s2) {
4203                 if (!*s1) return -1;
4204                 if (!*s2) return 1;
4205                 return(*s1 - *s2);
4206         }
4207         if (*s1++ == 0) return(0);
4208         s2++;
4209   }
4210 }
4211
4212 static int
4213 strncmp(s1, s2, n)
4214         register char *s1, *s2;
4215         int n;
4216 {
4217 /* Compare two strings, but at most n characters. */
4218
4219   while (n-- > 0) {
4220         if (*s1 != *s2) {
4221                 if (!*s1) return -1;
4222                 if (!*s2) return 1;
4223                 return(*s1 - *s2);
4224         }
4225         if (*s1++ == 0) break;
4226         s2++;
4227   }
4228   return 0;
4229 }
4230
4231 static char *
4232 getenv(name)
4233 register char *name;
4234 {
4235   extern char **environ;
4236   register char **v = environ, *p, *q;
4237
4238   if (v == 0 || name == 0) return 0;
4239   while ((p = *v++) != 0) {
4240         q = name;
4241         while (*q && *q++ == *p++) /* nothing */ ;
4242         if (*q || *p != '=') continue;
4243         return(p+1);
4244   }
4245   return(0);
4246 }
4247
4248 static char *
4249 fgets(buf, count, fd)
4250         char *buf;
4251 {
4252         static char bf[1024];
4253         static int cnt = 0;
4254         static char *pbf = &bf[0];
4255         register char *c = buf;
4256
4257
4258         while (--count) {
4259                 if (pbf >= &bf[cnt]) {
4260                         if ((cnt = read(fd, bf, 1024)) <= 0) {
4261                                 if (c == buf) return (char *) NULL;
4262                                 *c = 0;
4263                                 return buf;
4264                         }
4265                         pbf = &bf[0];
4266                 }
4267                 *c = *pbf++;
4268                 if (*c++ == '\n') {
4269                         *c = 0;
4270                         return buf;
4271                 }
4272         }
4273         *c = 0;
4274         return buf;
4275 }
4276
4277 /*
4278  *      tgetent - get the termcap entry for terminal name, and put it
4279  *      in bp (which must be an array of 1024 chars). Returns 1 if
4280  *      termcap entry found, 0 if not found, and -1 if file not found.
4281  */
4282 int
4283 tgetent(bp, name)
4284 char    *bp;
4285 char    *name;
4286 {
4287         int     fp;
4288         char    *file;
4289         char    *cp;
4290         short   len = strlen(name);
4291         char    buf[1024];
4292
4293         capab = bp;
4294         if ((file = getenv("TERMCAP")) != (char *) NULL) {
4295                 if (*file != '/' &&
4296                     (cp = getenv("TERM")) != NULL && strcmp(name, cp) == 0) {
4297                         (void) strcpy(bp, file);
4298                         return(1);
4299                 }
4300                 else file = "/etc/termcap";
4301         } else
4302                 file = "/etc/termcap";
4303         if ((fp = open(file, 0)) < 0) {
4304                 capab = 0;
4305                 return(-1);
4306         }
4307         while (fgets(buf, 1024, fp) != NULL) {
4308                 if (buf[0] == '#') continue;
4309                 while (*(cp = &buf[strlen(buf) - 2]) == '\\')
4310                         if (fgets(cp, 1024, fp) == NULL)
4311                                 return (0);
4312                 if (match_name(buf, name)) {
4313                         strcpy(bp, buf);
4314                         close(fp);
4315                         if(check_for_tc() == 0) {
4316                                 capab = 0;
4317                                 return 0;
4318                         }
4319                         return 1;
4320                 }
4321         }
4322         capab = 0;
4323         close(fp);
4324         return(0);
4325 }
4326
4327 /*
4328  *      Compare the terminal name with each termcap entry name; Return 1 if a
4329  *      match is found.
4330  */
4331 static int
4332 match_name(buf, name)
4333         char    *buf;
4334         char    *name;
4335 {
4336         register char   *tp = buf;
4337         register char   *np;
4338
4339         for (;;) {
4340                 for (np = name; *np && *tp == *np; np++, tp++) { }
4341                 if (*np == 0 && (*tp == '|' || *tp == ':' || *tp == 0))
4342                         return(1);
4343                 while (*tp != 0 && *tp != '|' && *tp != ':') tp++;
4344                 if (*tp++ != '|') return (0);
4345         }
4346 }
4347
4348 /*
4349  *      Handle tc= definitions recursively.
4350  */
4351 static int
4352 check_for_tc()
4353 {
4354         static int      count = 0;
4355         char            *savcapab = capab;
4356         char            buf[1024];
4357         char            terminalname[128];
4358         register char   *p = capab + strlen(capab) - 2, *q;
4359
4360         while (*p != ':')
4361                 if (--p < capab)
4362                         return(0);      /* no : in termcap entry */
4363         if (p[1] != 't' || p[2] != 'c')
4364                 return(1);
4365         if (count > 16) {
4366                 return(0);      /* recursion in tc= definitions */
4367         }
4368         count++;
4369         strcpy(terminalname, &p[4]);
4370         q = terminalname;
4371         while (*q && *q != ':') q++;
4372         *q = 0;
4373         if (tgetent(buf, terminalname) != 1) {
4374                 --count;
4375                 return(0);
4376         }
4377         --count;
4378         for (q = buf; *q && *q != ':'; q++) { }
4379         strcpy(p, q);
4380         capab = savcapab;
4381         return(1);
4382 }
4383
4384 /*
4385  *      tgetnum - get the numeric terminal capability corresponding
4386  *      to id. Returns the value, -1 if invalid.
4387  */
4388 int
4389 tgetnum(id)
4390 char    *id;
4391 {
4392         char    *cp;
4393         int     ret;
4394
4395         if ((cp = capab) == NULL || id == NULL || *cp == 0)
4396                 return(-1);
4397         while (*++cp && *cp != ':')
4398                 ;
4399         while (*cp) {
4400                 cp++;
4401                 while (ISSPACE(*cp))
4402                         cp++;
4403                 if (strncmp(cp, id, CAPABLEN) == 0) {
4404                         while (*cp && *cp != ':' && *cp != '#')
4405                                 cp++;
4406                         if (*cp != '#')
4407                                 return(-1);
4408                         for (ret = 0, cp++ ; *cp && ISDIGIT(*cp) ; cp++)
4409                                 ret = ret * 10 + *cp - '0';
4410                         return(ret);
4411                 }
4412                 while (*cp && *cp != ':')
4413                         cp++;
4414         }
4415         return(-1);
4416 }
4417
4418 /*
4419  *      tgetflag - get the boolean flag corresponding to id. Returns -1
4420  *      if invalid, 0 if the flag is not in termcap entry, or 1 if it is
4421  *      present.
4422  */
4423 int
4424 tgetflag(id)
4425 char    *id;
4426 {
4427         char    *cp;
4428
4429         if ((cp = capab) == NULL || id == NULL || *cp == 0)
4430                 return(-1);
4431         while (*++cp && *cp != ':')
4432                 ;
4433         while (*cp) {
4434                 cp++;
4435                 while (ISSPACE(*cp))
4436                         cp++;
4437                 if (strncmp(cp, id, CAPABLEN) == 0)
4438                         return(1);
4439                 while (*cp && *cp != ':')
4440                         cp++;
4441         }
4442         return(0);
4443 }
4444
4445 /*
4446  *      tgetstr - get the string capability corresponding to id and place
4447  *      it in area (advancing area at same time). Expand escape sequences
4448  *      etc. Returns the string, or NULL if it can't do it.
4449  */
4450 char *
4451 tgetstr(id, area)
4452 char    *id;
4453 char    **area;
4454 {
4455         char    *cp;
4456         char    *ret;
4457         int     i;
4458
4459         if ((cp = capab) == NULL || id == NULL || *cp == 0)
4460                 return(NULL);
4461         while (*++cp != ':')
4462                 ;
4463         while (*cp) {
4464                 cp++;
4465                 while (ISSPACE(*cp))
4466                         cp++;
4467                 if (strncmp(cp, id, CAPABLEN) == 0) {
4468                         while (*cp && *cp != ':' && *cp != '=')
4469                                 cp++;
4470                         if (*cp != '=')
4471                                 return(NULL);
4472                         for (ret = *area, cp++; *cp && *cp != ':' ; (*area)++, cp++)
4473                                 switch(*cp) {
4474                                 case '^' :
4475                                         **area = *++cp - 'A' + 1;
4476                                         break;
4477                                 case '\\' :
4478                                         switch(*++cp) {
4479                                         case 'E' :
4480                                                 **area = '\033';
4481                                                 break;
4482                                         case 'n' :
4483                                                 **area = '\n';
4484                                                 break;
4485                                         case 'r' :
4486                                                 **area = '\r';
4487                                                 break;
4488                                         case 't' :
4489                                                 **area = '\t';
4490                                                 break;
4491                                         case 'b' :
4492                                                 **area = '\b';
4493                                                 break;
4494                                         case 'f' :
4495                                                 **area = '\f';
4496                                                 break;
4497                                         case '0' :
4498                                         case '1' :
4499                                         case '2' :
4500                                         case '3' :
4501                                                 for (i=0 ; *cp && ISDIGIT(*cp) ; cp++)
4502                                                         i = i * 8 + *cp - '0';
4503                                                 **area = i;
4504                                                 cp--;
4505                                                 break;
4506                                         case '^' :
4507                                         case '\\' :
4508                                                 **area = *cp;
4509                                                 break;
4510                                         }
4511                                         break;
4512                                 default :
4513                                         **area = *cp;
4514                                 }
4515                         *(*area)++ = '\0';
4516                         return(ret);
4517                 }
4518                 while (*cp && *cp != ':')
4519                         cp++;
4520         }
4521         return(NULL);
4522 }
4523
4524 /*
4525  *      tgoto - given the cursor motion string cm, make up the string
4526  *      for the cursor to go to (destcol, destline), and return the string.
4527  *      Returns "OOPS" if something's gone wrong, or the string otherwise.
4528  */
4529 char *
4530 tgoto(cm, destcol, destline)
4531 char    *cm;
4532 int     destcol;
4533 int     destline;
4534 {
4535         register char   *rp;
4536         static char     ret[32];
4537         char            added[16];
4538         int             *dp = &destline;
4539         int             numval;
4540         int             swapped = 0;
4541
4542         added[0] = 0;
4543         for (rp = ret ; *cm ; cm++) {
4544                 if (*cm == '%') {
4545                         switch(*++cm) {
4546                         case '>' :
4547                                 if (dp == NULL)
4548                                         return("OOPS");
4549                                 cm++;
4550                                 if (*dp > *cm++) {
4551                                         *dp += *cm;
4552                                 }
4553                                 break;
4554                         case '+' :
4555                         case '.' :
4556                                 if (dp == NULL)
4557                                         return("OOPS");
4558                                 if (*cm == '+') *dp = *dp + *++cm;
4559                                 for (;;) {
4560                                     switch(*dp) {
4561                                     case 0:
4562                                     case 04:
4563                                     case '\t':
4564                                     case '\n':
4565                                         /* filter these out */
4566                                         if (dp == &destcol || swapped || UP) {
4567                                                 strcat(added, dp == &destcol || swapped ?
4568                                                         (BC ? BC : "\b") :
4569                                                         UP);
4570                                                 (*dp)++;
4571                                                 continue;
4572                                         }
4573                                     }
4574                                     break;
4575                                 }
4576                                 *rp++ = *dp;
4577                                 dp = (dp == &destline) ? &destcol : NULL;
4578                                 break;
4579
4580                         case 'r' : {
4581                                 int tmp = destline;
4582
4583                                 destline = destcol;
4584                                 destcol = tmp;
4585                                 swapped = 1 - swapped;
4586                                 break;
4587                         }
4588                         case 'n' :
4589                                 destcol ^= 0140;
4590                                 destline ^= 0140;
4591                                 break;
4592
4593                         case '%' :
4594                                 *rp++ = '%';
4595                                 break;
4596
4597                         case 'i' :
4598                                 destcol++;
4599                                 destline++;
4600                                 break;
4601
4602                         case 'B' :
4603                                 if (dp == NULL)
4604                                         return("OOPS");
4605                                 *dp = 16 * (*dp / 10) + *dp % 10;
4606                                 break;
4607
4608                         case 'D' :
4609                                 if (dp == NULL)
4610                                         return("OOPS");
4611                                 *dp = *dp - 2 * (*dp % 16);
4612                                 break;
4613
4614                         case 'd' :
4615                         case '2' :
4616                         case '3' :
4617                                 if (dp == NULL)
4618                                         return("OOPS");
4619                                 numval = *dp;
4620                                 dp = (dp == &destline) ? &destcol : NULL;
4621                                 if (numval >= 100) {
4622                                         *rp++ = '0' + numval / 100;
4623                                 }
4624                                 else if (*cm == '3') {
4625                                         *rp++ = ' ';
4626                                 }
4627                                 if (numval >= 10) {
4628                                         *rp++ = '0' + ((numval%100)/10);
4629                                 }
4630                                 else if (*cm == '3' || *cm == '2') {
4631                                         *rp++ = ' ';
4632                                 }
4633                                 *rp++ = '0' + (numval%10);
4634                                 break;
4635                         default :
4636                                 return("OOPS");
4637                         }
4638                 }
4639                 else *rp++ = *cm;
4640         }
4641         *rp = '\0';
4642         strcpy(rp, added);
4643         return(ret);
4644 }
4645
4646 static int tens_of_ms_p_char[] = {      /* index as returned by gtty */
4647                                         /* assume 10 bits per char */
4648         0, 2000, 1333, 909, 743, 666, 500, 333, 166, 83, 55, 41, 20, 10, 5, 2
4649 };
4650 /*
4651  *      tputs - put the string cp out onto the terminal, using the function
4652  *      outc. Also handle padding.
4653  */
4654 int
4655 tputs(cp, affcnt, outc)
4656 register char   *cp;
4657 int             affcnt;
4658 int             (*outc)();
4659 {
4660         int delay = 0;
4661         if (cp == NULL)
4662                 return(1);
4663         while (ISDIGIT(*cp)) {
4664                 delay = delay * 10 + (*cp++ - '0');
4665         }
4666         delay *= 10;
4667         if (*cp == '.') {
4668                 cp++;
4669                 if (ISDIGIT(*cp)) {
4670                         delay += *cp++ - '0';
4671                 }
4672                 while (ISDIGIT(*cp)) cp++;
4673         }
4674         if (*cp == '*') {
4675                 delay *= affcnt;
4676                 cp++;
4677         }
4678         while (*cp)
4679                 (*outc)(*cp++);
4680         if (delay != 0 &&
4681             ospeed > 0 &&
4682             ospeed < (sizeof tens_of_ms_p_char / sizeof tens_of_ms_p_char[0])) {
4683                 delay = (delay + tens_of_ms_p_char[ospeed] - 1) /
4684                                   tens_of_ms_p_char[ospeed];
4685                 while (delay--) (*outc)(PC);
4686         }
4687         return(1);
4688 }
4689
4690 /*
4691  *      That's all, folks...
4692  */
4693 rdvi.c\0cap.c\0d\0\0\0\0\0\ 2\ 2�\ 1\0\0c\ 4/*
4694   (c) copyright 1988 by the Vrije Universiteit, Amsterdam, The Netherlands.
4695   See the copyright notice in the ACK home directory, in the file "Copyright".
4696 */
4697
4698 /*
4699   Module:       implementation of DIV and MOD
4700   Author:       Ceriel J.H. Jacobs
4701   Version:      $Id: dvi.c,v 1.2 1994/06/24 12:51:01 ceriel Exp $
4702   Reason:       We cannot use DVI and RMI, because DVI rounds towards 0
4703                 and Modula-2 requires truncation
4704 */
4705
4706 #include <em_abs.h>
4707
4708 int
4709 dvi(j,i)
4710         int j,i;
4711 {
4712         if (j == 0) TRP(EIDIVZ);
4713         if ((i < 0) != (j < 0)) {
4714                 if (i < 0) i = -i;
4715                 else j = -j;
4716                 return -((i+j-1)/j);
4717         }
4718         else return i/j;
4719 }
4720
4721 long
4722 dvil(j,i)
4723         long j,i;
4724 {
4725         if (j == 0) TRP(EIDIVZ);
4726         if ((i < 0) != (j < 0)) {
4727                 if (i < 0) i = -i;
4728                 else j = -j;
4729                 return -((i+j-1)/j);
4730         }
4731         else return i/j;
4732 }
4733
4734 int
4735 rmi(j,i)
4736         int j,i;
4737 {
4738         if (j == 0) TRP(EIDIVZ);
4739         if (i == 0) return 0;
4740         if ((i < 0) != (j < 0)) {
4741                 if (i < 0) i = -i;
4742                 else j = -j;
4743                 return j*((i+j-1)/j)-i;
4744         }
4745         else return i%j;
4746 }
4747
4748 long
4749 rmil(j,i)
4750         long j,i;
4751 {
4752         if (j == 0) TRP(EIDIVZ);
4753         if (i == 0) return 0L;
4754         if ((i < 0) != (j < 0)) {
4755                 if (i < 0) i = -i;
4756                 else j = -j;
4757                 return j*((i+j-1)/j)-i;
4758         }
4759         else return i%j;
4760 }
4761 eArguments.c\0d\0\0\0\0\0\ 2\ 2�\ 1\0\0\0\ 5/*
4762   (c) copyright 1988 by the Vrije Universiteit, Amsterdam, The Netherlands.
4763   See the copyright notice in the ACK home directory, in the file "Copyright".
4764 */
4765
4766 /*
4767   Module:       Access to program arguments and environment
4768   Author:       Ceriel J.H. Jacobs
4769   Version:      $Id: Arguments.c,v 1.6 1994/06/24 12:48:10 ceriel Exp $
4770 */
4771
4772 extern char **argv, **environ;
4773 extern int argc;
4774 unsigned int _Arguments__Argc;
4775
4776 static char *
4777 findname(s1, s2)
4778 register char *s1, *s2;
4779 {
4780
4781         while (*s1 == *s2++) s1++;
4782         if (*s1 == '\0' && *(s2-1) == '=') return s2;
4783         return 0;
4784 }
4785
4786 static unsigned int
4787 scopy(src, dst, max)
4788         register char *src, *dst;
4789         unsigned int max;
4790 {
4791         register unsigned int i = 0;
4792
4793         while (*src && i <= max) {
4794                 i++;
4795                 *dst++ = *src++;
4796         }
4797         if (i <= max) {
4798                 *dst = '\0';
4799                 return i+1;
4800         }
4801         while (*src++) i++;
4802         return i + 1;
4803 }
4804
4805 _Arguments_()
4806 {
4807         _Arguments__Argc = argc;
4808 }
4809
4810 unsigned
4811 _Arguments__Argv(n, argument, l, u, s)
4812         unsigned int u;
4813         char *argument;
4814 {
4815
4816         if (n >= argc) return 0;
4817         return scopy(argv[n], argument, u);
4818 }
4819
4820 unsigned
4821 _Arguments__GetEnv(name, nn, nu, ns, value, l, u, s)
4822         char *name, *value;
4823         unsigned int nu, u;
4824 {
4825         register char **p = environ;
4826         register char *v = 0;
4827
4828         while (*p && !(v = findname(name, *p++))) {
4829                 /* nothing */
4830         }
4831         if (!v) return 0;
4832         return scopy(v, value, u);
4833 }
4834 LtoUset.e\0c\0d\0\0\0\0\0\ 2\ 2�\ 1\0\0R\ 5#
4835 ;
4836 ; (c) copyright 1988 by the Vrije Universiteit, Amsterdam, The Netherlands.
4837 ; See the copyright notice in the ACK home directory, in the file "Copyright".
4838 ;
4839 ;
4840 ; Module:       Compute non-constant set displays
4841 ; Author:       Ceriel J.H. Jacobs
4842 ; Version:      $Id: LtoUset.e,v 1.5 1994/06/24 12:48:53 ceriel Exp $
4843 ;
4844  mes 2,EM_WSIZE,EM_PSIZE
4845
4846  ; LtoUset is called for set displays containing { expr1 .. expr2 }.
4847  ; It has six parameters, of which the caller must pop five:
4848  ; - The set in which bits must be set.
4849  ; - the lower bound of the set type.
4850  ; - The set size in bytes.
4851  ; - The upper bound of set elements, specified by the set-type.
4852  ; - "expr2", the upper bound
4853  ; - "expr1", the lower bound
4854
4855 #define SETBASE 5*EM_WSIZE
4856 #define SETLOW  4*EM_WSIZE
4857 #define SETSIZE 3*EM_WSIZE
4858 #define USETSIZ 2*EM_WSIZE
4859 #define LWB     EM_WSIZE
4860 #define UPB     0
4861  exp $LtoUset
4862  pro $LtoUset,0
4863  lal SETBASE    ; address of initial set
4864  lol SETSIZE
4865  los EM_WSIZE   ; load initial set
4866  lol LWB        ; low bound
4867  lol SETLOW
4868  sbu EM_WSIZE
4869  stl LWB
4870  lol UPB        ; high bound
4871  lol SETLOW
4872  sbu EM_WSIZE
4873  stl UPB
4874 1
4875  lol LWB
4876  lol UPB
4877  cmu EM_WSIZE
4878  zgt *2         ; while low <= high
4879  lol LWB
4880  lol SETSIZE
4881  set ?          ; create [low]
4882  lol SETSIZE
4883  ior ?          ; merge with initial set
4884  lol LWB
4885  loc 1
4886  adu EM_WSIZE
4887  stl LWB
4888  bra *1         ; loop back
4889 2
4890  lal SETBASE
4891  lol SETSIZE
4892  sts EM_WSIZE   ; store result over initial set
4893  ret 0
4894  end 0
4895 StrAss.c\0\0c\0d\0\0\0\0\0\ 2\ 2�\ 1\0\0\1a\ 2/*
4896   (c) copyright 1988 by the Vrije Universiteit, Amsterdam, The Netherlands.
4897   See the copyright notice in the ACK home directory, in the file "Copyright".
4898 */
4899
4900 /*
4901   Module:       assign string to character array, with possible 0-byte
4902                 extension
4903   Author:       Ceriel J.H. Jacobs
4904   Version:      $Id: StrAss.c,v 1.4 1994/06/24 12:49:51 ceriel Exp $
4905 */
4906 StringAssign(dstsiz, srcsiz, dstaddr, srcaddr)
4907         register char *dstaddr, *srcaddr;
4908 {
4909         while (srcsiz > 0) {
4910                 *dstaddr++ = *srcaddr++;
4911                 srcsiz--;
4912                 dstsiz--;
4913         }
4914         if (dstsiz > 0) {
4915                 *dstaddr = 0;
4916         }
4917 }
4918 cap.c\0.c\0\0c\0d\0\0\0\0\0\ 2\ 2�\ 1\0\0\89\ 1/*
4919   (c) copyright 1988 by the Vrije Universiteit, Amsterdam, The Netherlands.
4920   See the copyright notice in the ACK home directory, in the file "Copyright".
4921 */
4922
4923 /*
4924   Module:       cap; implementation of CAP
4925   Author:       Ceriel J.H. Jacobs
4926   Version:      $Id: cap.c,v 1.3 1994/06/24 12:50:52 ceriel Exp $
4927 */
4928
4929 cap(u)
4930         unsigned u;
4931 {
4932         register unsigned *p = &u;
4933
4934         if (*p >= 'a' && *p <= 'z') *p += 'A'-'a';
4935 }
4936 rabsd.c\0c\0\0c\0d\0\0\0\0\0\ 2\ 2�\ 1\0\0o\ 1/*
4937   (c) copyright 1988 by the Vrije Universiteit, Amsterdam, The Netherlands.
4938   See the copyright notice in the ACK home directory, in the file "Copyright".
4939 */
4940
4941 /*
4942   Module:       double abs function
4943   Author:       Ceriel J.H. Jacobs
4944   Version:      $Id: absd.c,v 1.4 1994/06/24 12:50:35 ceriel Exp $
4945 */
4946 #ifndef NOFLOAT
4947 double
4948 absd(i)
4949         double i;
4950 {
4951         return i >= 0 ? i : -i;
4952 }
4953 #endif
4954  absf.e\0c\0\0c\0d\0\0\0\0\0\ 2\ 2�\ 1\0\0�\ 1#
4955 ;
4956 ; (c) copyright 1988 by the Vrije Universiteit, Amsterdam, The Netherlands.
4957 ; See the copyright notice in the ACK home directory, in the file "Copyright".
4958 ;
4959 ;
4960 ; Module:       REAL abs function
4961 ; Author:       Ceriel J.H. Jacobs
4962 ; Version:      $Id: absf.e,v 1.4 1994/06/24 12:50:38 ceriel Exp $
4963 ;
4964  mes 2,EM_WSIZE,EM_PSIZE
4965  exp $absf
4966  pro $absf,0
4967  mes 5
4968  mes 9,8
4969  lal 0
4970  loi EM_FSIZE
4971  zrf EM_FSIZE
4972  cmf EM_FSIZE
4973  zlt *3
4974  lal 0
4975  loi EM_FSIZE
4976  bra *4
4977 3
4978  lal 0
4979  loi EM_FSIZE
4980  ngf EM_FSIZE
4981 4
4982  ret EM_FSIZE
4983  end 0
4984         absi.c\0c\0\0c\0d\0\0\0\0\0\ 2\ 2�\ 1\0\0H\ 1/*
4985   (c) copyright 1988 by the Vrije Universiteit, Amsterdam, The Netherlands.
4986   See the copyright notice in the ACK home directory, in the file "Copyright".
4987 */
4988
4989 /*
4990   Module:       integer abs function
4991   Author:       Ceriel J.H. Jacobs
4992   Version:      $Id: absi.c,v 1.4 1994/06/24 12:50:42 ceriel Exp $
4993 */
4994
4995 absi(i)
4996 {
4997         return i >= 0 ? i : -i;
4998 }
4999 absl.c\0c\0\0c\0d\0\0\0\0\0\ 2\ 2�\ 1\0\0U\ 1/*
5000   (c) copyright 1988 by the Vrije Universiteit, Amsterdam, The Netherlands.
5001   See the copyright notice in the ACK home directory, in the file "Copyright".
5002 */
5003
5004 /*
5005   Module:       longint abs function
5006   Author:       Ceriel J.H. Jacobs
5007   Version:      $Id: absl.c,v 1.4 1994/06/24 12:50:46 ceriel Exp $
5008 */
5009 long
5010 absl(i)
5011         long i;
5012 {
5013         return i >= 0 ? i : -i;
5014 }
5015 mhalt.c\0c\0\0c\0d\0\0\0\0\0\ 2\ 2�\ 1\0\0k\ 2/*
5016   (c) copyright 1988 by the Vrije Universiteit, Amsterdam, The Netherlands.
5017   See the copyright notice in the ACK home directory, in the file "Copyright".
5018 */
5019
5020 /*
5021   Module:       program termination routines
5022   Author:       Ceriel J.H. Jacobs
5023   Version:      $Id: halt.c,v 1.12 1994/06/24 12:51:04 ceriel Exp $
5024 */
5025 #define MAXPROCS 32
5026
5027 static int callindex = 0;
5028 static int (*proclist[MAXPROCS])();
5029
5030 _cleanup()
5031 {
5032         while (--callindex >= 0)
5033                 (*proclist[callindex])();
5034         callindex = 0;
5035 }
5036
5037 CallAtEnd(p)
5038         int (*p)();
5039 {
5040         if (callindex >= MAXPROCS) {
5041                 return 0;
5042         }
5043         proclist[callindex++] = p;
5044         return 1;
5045 }
5046
5047 halt()
5048 {
5049         _cleanup();
5050         _exit(0);
5051 }
5052  SYSTEM.c\0\0c\0d\0\0\0\0\0\ 2\ 2�\ 1\0\0u\f/*
5053   (c) copyright 1988 by the Vrije Universiteit, Amsterdam, The Netherlands.
5054   See the copyright notice in the ACK home directory, in the file "Copyright".
5055 */
5056
5057 /*
5058   Module:       SYSTEM
5059   Author:       Ceriel J.H. Jacobs
5060   Version:      $Id: SYSTEM.c,v 1.4 1994/06/24 12:49:34 ceriel Exp $
5061 */
5062
5063 /*
5064         An implementation of the Modula-2 NEWPROCESS and TRANSFER facilities
5065         using the topsize, topsave, and topload facilities.
5066         For each coroutine, a proc structure is built. For the main routine,
5067         a static space is declared to save its stack. For the other coroutines,
5068         the user specifies this space.
5069 */
5070
5071 #include <m2_traps.h>
5072
5073 #define MAXMAIN 2048
5074
5075 struct proc {
5076         unsigned size;          /* size of saved stackframe(s) */
5077         int (*proc)();          /* address of coroutine procedure */
5078         char *brk;              /* stack break of this coroutine */
5079 };
5080
5081 extern unsigned topsize();
5082
5083 static struct proc mainproc[MAXMAIN/sizeof(struct proc) + 1];
5084
5085 static struct proc *curproc = 0;/* current coroutine */
5086 extern char *MainLB;            /* stack break of main routine */
5087
5088 _SYSTEM__NEWPROCESS(p, a, n, p1)
5089         int (*p)();             /* coroutine procedure */
5090         struct proc *a;         /* pointer to area for saved stack-frame */
5091         unsigned n;             /* size of this area */
5092         struct proc **p1;       /* where to leave coroutine descriptor,
5093                                    in this implementation the address of
5094                                    the area for saved stack-frame(s) */
5095 {
5096         /*      This procedure creates a new coroutine, but does not
5097                 transfer control to it. The routine "topsize" will compute the
5098                 stack break, which will be the local base of this routine.
5099                 Notice that we can do this because we do not need the stack
5100                 above this point for this coroutine. In Modula-2, coroutines
5101                 must be level 0 procedures without parameters.
5102         */
5103         char *brk = 0;
5104         unsigned sz = topsize(&brk);
5105
5106         if (sz + sizeof(struct proc) > n) {
5107                 /* not enough space */
5108                 TRP(M2_TOOLARGE);
5109         }
5110         a->size = n;
5111         a->proc = p;
5112         a->brk = brk;
5113         *p1 = a;
5114         if (topsave(brk, a+1))
5115                 /* stack frame saved; now just return */
5116                 ;
5117         else {
5118                 /* We get here through the first transfer to the coroutine
5119                    created above.
5120                    This also means that curproc is now set to this coroutine.
5121                    We cannot trust the parameters anymore.
5122                    Just call the coroutine procedure.
5123                 */
5124                 (*(curproc->proc))();
5125                 _cleanup();
5126                 _exit(0);
5127         }
5128 }
5129
5130 _SYSTEM__TRANSFER(a, b)
5131         struct proc **a, **b;
5132 {
5133         /*      transfer from one coroutine to another, saving the current
5134                 descriptor in the space indicated by "a", and transfering to
5135                 the coroutine in descriptor "b".
5136         */
5137         unsigned size;
5138
5139         if (! curproc) {
5140                 /* the current coroutine is the main process;
5141                    initialize a coroutine descriptor for it ...
5142                 */
5143                 mainproc[0].brk = MainLB;
5144                 mainproc[0].size = sizeof(mainproc);
5145                 curproc = &mainproc[0];
5146         }
5147         *a = curproc;           /* save current descriptor in "a" */
5148         if (*b == curproc) {
5149                 /* transfer to itself is a no-op */
5150                 return;
5151         }
5152         size = topsize(&(curproc->brk));
5153         if (size + sizeof(struct proc) > curproc->size) {
5154                 TRP(M2_TOOLARGE);
5155         }
5156         if (topsave(curproc->brk, curproc+1)) {
5157                 /* stack top saved. Now restore context of target
5158                    coroutine
5159                 */
5160                 curproc = *b;
5161                 topload(curproc+1);
5162                 /* we never get here ... */
5163         }
5164         /* but we do get here, when a transfer is done to the coroutine in "a".
5165         */
5166 }
5167 {par_misc.e\0\0d\0\0\0\0\0\ 2\ 2�\ 1\0\0\11\r#
5168 ;
5169 ; (c) copyright 1988 by the Vrije Universiteit, Amsterdam, The Netherlands.
5170 ; See the copyright notice in the ACK home directory, in the file "Copyright".
5171 ;
5172
5173 ;
5174 ; Module:       coroutine primitives
5175 ; Author:       Kees Bot, Edwin Scheffer, Ceriel Jacobs
5176 ; Version:      $Id: par_misc.e,v 1.7 1994/06/24 12:51:18 ceriel Exp $
5177 ;
5178
5179  mes 2,EM_WSIZE,EM_PSIZE
5180
5181  ; topsize takes care of two things:
5182  ; - given a stack-break,
5183  ;   it computes the size of the chunk of memory needed to save the stack;
5184  ; - also, if this stack-break = 0, it creates one, assuming that caller is
5185  ;   the stack-break.
5186  ;
5187  ; This implementation assumes a continuous stack growing downwards
5188
5189  exp $topsize
5190 #ifdef __sparc
5191  inp $topsize2
5192  pro $topsize, 0
5193  mes 11
5194  zer EM_PSIZE
5195  lal 0
5196  loi EM_PSIZE
5197  cal $topsize2
5198  asp 2*EM_PSIZE
5199  lfr EM_WSIZE
5200  ret EM_WSIZE
5201  end 0
5202  pro $topsize2, 3*EM_WSIZE+3*EM_PSIZE
5203 #else
5204  pro $topsize, 3*EM_WSIZE+3*EM_PSIZE
5205 #endif
5206  ; local space for line-number, ignoremask, filename, stack-break, size,
5207  ; and stack-pointer (see the topsave routine)
5208  mes 11
5209  lal 0
5210  loi EM_PSIZE
5211  loi EM_PSIZE           ; stack-break or 0
5212  zer EM_PSIZE
5213  cmp
5214  zne *1
5215  lxl 0
5216  dch                    ; local base of caller
5217 #ifdef __sparc
5218  dch                    ; because of the extra layer
5219 #endif
5220  lal 0
5221  loi EM_PSIZE
5222  sti EM_PSIZE
5223 1
5224  lal 0
5225  loi EM_PSIZE
5226  loi EM_PSIZE
5227  lpb                    ; convert this local base to an argument base.
5228                         ; An implementation of a sort of "topsize" EM
5229                         ; instruction should take a local base, and save
5230                         ; the whole frame.
5231
5232  lor 1                  ; stack-break  SP
5233  sbs EM_WSIZE           ; stack-break-SP
5234  ret EM_WSIZE           ; return size of block to be saved
5235  end 3*EM_WSIZE+3*EM_PSIZE
5236
5237  exp $topsave
5238 #ifdef __sparc
5239  inp $topsave2
5240  pro $topsave,0
5241  mes 11
5242  lal 0
5243  loi 2*EM_PSIZE
5244  cal $topsave2
5245  asp 2*EM_PSIZE
5246  lfr EM_WSIZE
5247  ret EM_WSIZE
5248  end 0
5249  pro $topsave2,0
5250 #else
5251  pro $topsave, 0
5252 #endif
5253  mes 11
5254  loe 0
5255  lae 4                  ; load line number and file name
5256  loi EM_PSIZE
5257  lim                    ; ignore mask
5258  lor 0                  ; LB
5259  lal 0
5260  loi EM_PSIZE           ; stack-break
5261  lpb
5262  lor 1
5263  sbs EM_WSIZE
5264  loc EM_WSIZE
5265  adu EM_WSIZE           ; gives size
5266  dup EM_WSIZE
5267  stl 0                  ; save size
5268  lor 1                  ; SP (the SP BEFORE pushing)
5269  lor 1                  ; SP (address of stack top to save)
5270  lal EM_PSIZE           ; area
5271  loi EM_PSIZE
5272  lol 0                  ; size
5273  bls EM_WSIZE           ; move whole block
5274  asp 3*EM_PSIZE+3*EM_WSIZE      ; remove the lot from the stack
5275  loc 1
5276  ret EM_WSIZE                   ; return 1
5277  end 0
5278
5279 sv
5280  bss EM_PSIZE,0,0
5281
5282  exp $topload
5283 #ifdef __sparc
5284  inp $topload1
5285  pro $topload,0
5286  lal 0
5287  loi EM_PSIZE
5288  cal $topload1
5289  asp EM_PSIZE
5290  lfr EM_WSIZE
5291  ret EM_WSIZE
5292  end 0
5293  pro $topload1, 0
5294 #else
5295  pro $topload, 0
5296 #endif
5297  mes 11
5298
5299  lal 0
5300  loi EM_PSIZE
5301  lae sv
5302  sti EM_PSIZE           ; saved parameter
5303
5304  lxl 0
5305 2
5306  dup EM_PSIZE
5307  adp -3*EM_PSIZE
5308  lal 0
5309  loi EM_PSIZE           ; compare target SP with current LB to see if we must
5310  loi EM_PSIZE
5311  cmp                    ; find another LB first
5312  zgt *1
5313  dch                    ; just follow dynamic chain to make sure we find
5314                         ; a legal one
5315  bra *2
5316 1
5317  str 0
5318
5319  lae sv
5320  loi EM_PSIZE
5321  loi EM_PSIZE           ; load indirect to
5322  str 1                  ; restore SP
5323  asp -EM_PSIZE          ; to stop int from complaining about non-existent memory
5324  lae sv
5325  loi EM_PSIZE           ; source address
5326  lor 1
5327  adp EM_PSIZE           ; destination address
5328  lae sv
5329  loi EM_PSIZE
5330  adp EM_PSIZE
5331  loi EM_WSIZE           ; size of block
5332  bls EM_WSIZE
5333  asp EM_PSIZE+EM_WSIZE  ; drop size + SP
5334  str 0                  ; restore local base
5335  sim                    ; ignore mask
5336  lae 4
5337  sti EM_PSIZE
5338  ste 0                  ; line and file
5339  loc 0
5340  ret EM_WSIZE
5341  end 0
5342
5343 init.c\0c.e\0\0d\0\0\0\0\0\ 2\ 2�\ 1\0\0)\ 5/*
5344   (c) copyright 1988 by the Vrije Universiteit, Amsterdam, The Netherlands.
5345   See the copyright notice in the ACK home directory, in the file "Copyright".
5346 */
5347
5348 /*
5349   Module:       initialization and some global vars
5350   Author:       Ceriel J.H. Jacobs
5351   Version:      $Id: init.c,v 1.9 1994/06/24 12:51:11 ceriel Exp $
5352 */
5353
5354 #include <signal.h>
5355 #include <em_abs.h>
5356 #include <m2_traps.h>
5357
5358 /* map unix signals onto EM traps */
5359 init()
5360 {
5361         sigtrp(M2_UNIXSIG, SIGHUP);
5362         sigtrp(M2_UNIXSIG, SIGINT);
5363         sigtrp(M2_UNIXSIG, SIGQUIT);
5364         sigtrp(EILLINS, SIGILL);
5365         sigtrp(M2_UNIXSIG, SIGTRAP);
5366         sigtrp(M2_UNIXSIG, SIGIOT);
5367         sigtrp(M2_UNIXSIG, SIGEMT);
5368         sigtrp(M2_UNIXSIG, SIGFPE);
5369         sigtrp(M2_UNIXSIG, SIGBUS);
5370         sigtrp(M2_UNIXSIG, SIGSEGV);
5371         sigtrp(EBADMON, SIGSYS);
5372         sigtrp(M2_UNIXSIG, SIGPIPE);
5373         sigtrp(M2_UNIXSIG, SIGALRM);
5374         sigtrp(M2_UNIXSIG, SIGTERM);
5375 }
5376 #if defined(__em22) || defined(__em24) || defined(__em44)
5377 killbss()
5378 {
5379 }
5380 #else
5381
5382 static int blablabla;           /*      We cannot use end, because then also
5383                                         bss allocated for the systemcall lib
5384                                         would be overwritten. Lets hope that
5385                                         this helps ...
5386                                 */
5387
5388 killbss()
5389 {
5390         extern char *bkillbss;
5391         register char *p = (char *) &bkillbss;
5392
5393         while (p < (char *) &blablabla) *p++ = 0x66;
5394 }
5395 #endif
5396
5397 extern int catch();
5398
5399 int (*handler)() = catch;
5400 char **argv = 0, **environ = 0;
5401 int argc = 0;
5402 char *MainLB = 0;
5403  sigtrp.c\0e\0\0d\0\0\0\0\0\ 2\ 2�\ 1\0\0\1e\a/*
5404   (c) copyright 1988 by the Vrije Universiteit, Amsterdam, The Netherlands.
5405   See the copyright notice in the ACK home directory, in the file "Copyright".
5406 */
5407
5408 /*
5409   Module:       Mapping of Unix signals to EM traps
5410                 (only when not using the MON instruction)
5411   Author:       Ceriel J.H. Jacobs
5412   Version:      $Id: sigtrp.c,v 1.8 1994/06/24 12:51:47 ceriel Exp $
5413 */
5414
5415 #if !defined(__em22) && !defined(__em24) && !defined(__em44)
5416
5417 #define EM_trap(n) TRP(n)       /* define to whatever is needed to cause the trap */
5418
5419 #include <signal.h>
5420 #include <errno.h>
5421
5422 int __signo;
5423
5424 static int __traps[] = {
5425  -2, -2, -2, -2, -2, -2, -2, -2, -2, -2, -2, -2, -2, -2, -2, -2,
5426  -2, -2, -2, -2, -2, -2, -2, -2, -2, -2, -2, -2, -2, -2, -2, -2,
5427  -2, -2, -2, -2, -2, -2, -2, -2, -2, -2, -2, -2, -2, -2, -2, -2,
5428 };
5429
5430 static void
5431 __ctchsig(signo)
5432 {
5433         signal(signo,__ctchsig);
5434 #ifdef __BSD4_2
5435         sigsetmask(sigblock(0) & ~(1<<(signo - 1)));
5436 #endif
5437         __signo = signo;
5438         EM_trap(__traps[signo]);
5439 }
5440
5441 int
5442 sigtrp(trapno, signo)
5443 {
5444         /*      Let Unix signal signo cause EM trap trapno to occur.
5445                 If trapno = -2, restore default,
5446                 If trapno = -3, ignore.
5447                 Return old trapnumber.
5448                 Careful, this could be -2 or -3; But return value of -1
5449                 indicates failure, with error number in errno.
5450         */
5451         extern int errno;
5452         void (*ctch)() = __ctchsig;
5453         void (*oldctch)();
5454         int oldtrap;
5455
5456         if (signo <= 0 || signo >= sizeof(__traps)/sizeof(__traps[0])) {
5457                 errno = EINVAL;
5458                 return -1;
5459         }
5460
5461         if (trapno == -3)
5462                 ctch = SIG_IGN;
5463         else if (trapno == -2)
5464                 ctch = SIG_DFL;
5465         else if (trapno >= 0 && trapno <= 252)
5466                 ;
5467         else {
5468                 errno = EINVAL;
5469                 return -1;
5470         }
5471
5472         oldtrap = __traps[signo];
5473
5474         if ((oldctch = signal(signo, ctch)) == (void (*)())-1)  /* errno set by signal */
5475                 return -1;
5476
5477         else if (oldctch == SIG_IGN) {
5478                 signal(signo, SIG_IGN);
5479         }
5480         else __traps[signo] = trapno;
5481
5482         return oldtrap;
5483 }
5484 #endif
5485 store.c\0\0e\0\0d\0\0\0\0\0\ 2\ 2�\ 1\0\0�\ 3/*
5486   (c) copyright 1988 by the Vrije Universiteit, Amsterdam, The Netherlands.
5487   See the copyright notice in the ACK home directory, in the file "Copyright".
5488 */
5489
5490 /*
5491   Module:       store values from stack, byte by byte
5492   Author:       Ceriel J.H. Jacobs
5493   Version:      $Id: store.c,v 1.6 1994/06/24 12:51:53 ceriel Exp $
5494 */
5495
5496 #include <m2_traps.h>
5497
5498 #ifndef EM_WSIZE
5499 #define EM_WSIZE _EM_WSIZE
5500 #define EM_PSIZE _EM_PSIZE
5501 #endif
5502
5503 #if EM_WSIZE==EM_PSIZE
5504 typedef unsigned pcnt;
5505 #else
5506 typedef long pcnt;
5507 #endif
5508
5509 store(siz, addr, p)
5510         register char *addr;
5511         register pcnt siz;
5512 {
5513         /*      Make sure, that a value with a size that could have been
5514                 handled by the LOI instruction is handled as if it was
5515                 loaded with the LOI instruction.
5516         */
5517         register char *q = (char *) &p;
5518         char t[4];
5519
5520         if (siz < EM_WSIZE && EM_WSIZE % siz == 0) {
5521                 /* as long as EM_WSIZE <= 4 ... */
5522                 if (siz != 2) TRP(M2_INTERNAL); /* internal error */
5523                 *((unsigned short *) (&t[0])) = *((unsigned *) q);
5524                 q = &t[0];
5525         }
5526         while (siz--) *addr++ = *q++;
5527 }
5528 oconfarray.c\0d\0\0\0\0\0\ 2\ 2�\ 1\0\0�\ 5/*
5529   (c) copyright 1988 by the Vrije Universiteit, Amsterdam, The Netherlands.
5530   See the copyright notice in the ACK home directory, in the file "Copyright".
5531 */
5532
5533 /*
5534   Module:       runtime support for conformant arrays
5535   Author:       Ceriel J.H. Jacobs
5536   Version:      $Id: confarray.c,v 1.11 1994/06/24 12:50:58 ceriel Exp $
5537 */
5538 #include <m2_traps.h>
5539
5540 #ifndef EM_WSIZE
5541 #define EM_WSIZE _EM_WSIZE
5542 #define EM_PSIZE _EM_PSIZE
5543 #endif
5544
5545 #if EM_WSIZE==EM_PSIZE
5546 typedef unsigned pcnt;
5547 #else
5548 typedef unsigned long pcnt;
5549 #endif
5550
5551 struct descr {
5552         char *addr;
5553         int low;
5554         unsigned int highminlow;
5555         unsigned int size;
5556 };
5557
5558 static struct descr *descrs[10];
5559 static struct descr **ppdescr = descrs;
5560
5561 pcnt
5562 new_stackptr(pdscr, a)
5563         struct descr *pdscr;
5564 {
5565         register struct descr *pdescr = pdscr;
5566         pcnt size = (((pdescr->highminlow + 1) * pdescr->size +
5567                                 (EM_WSIZE - 1)) & ~(EM_WSIZE - 1));
5568
5569         if (ppdescr >= &descrs[10]) {
5570                 /* to many nested traps + handlers ! */
5571                 TRP(M2_TOOMANY);
5572         }
5573         *ppdescr++ = pdescr;
5574         if ((char *) &a - (char *) &pdscr > 0) {
5575                 /* stack grows downwards */
5576                 return - size;
5577         }
5578         return size;
5579 }
5580
5581 copy_array(pp, a)
5582         char *pp;
5583 {
5584         register char *p = pp;
5585         register char *q;
5586         register pcnt sz;
5587         char dummy;
5588
5589         ppdescr--;
5590         sz = ((*ppdescr)->highminlow + 1) * (*ppdescr)->size;
5591
5592         if ((char *) &a - (char *) &pp > 0) {
5593                 (*ppdescr)->addr = q = (char *) &a;
5594         }
5595         else    (*ppdescr)->addr = q = (char *) &a -
5596                         ((sz + (EM_WSIZE - 1)) & ~ (EM_WSIZE - 1));
5597
5598         while (sz--) *q++ = *p++;
5599 }
5600 load.c\0ay.c\0d\0\0\0\0\0\ 2\ 2�\ 1\0\0\a\ 4/*
5601   (c) copyright 1988 by the Vrije Universiteit, Amsterdam, The Netherlands.
5602   See the copyright notice in the ACK home directory, in the file "Copyright".
5603 */
5604
5605 /*
5606   Module:       get value on stack, byte by byte
5607   Author:       Ceriel J.H. Jacobs
5608   Version:      $Id: load.c,v 1.6 1994/06/24 12:51:14 ceriel Exp $
5609 */
5610
5611 #include <m2_traps.h>
5612
5613 #ifndef EM_WSIZE
5614 #define EM_WSIZE _EM_WSIZE
5615 #define EM_PSIZE _EM_PSIZE
5616 #endif
5617
5618 #if EM_WSIZE==EM_PSIZE
5619 typedef unsigned pcnt;
5620 #else
5621 typedef long pcnt;
5622 #endif
5623
5624 load(siz, addr, p)
5625         register char *addr;
5626         register pcnt siz;
5627 {
5628         /*      Make sure, that a value with a size that could have been
5629                 handled by the LOI instruction ends up at the same place,
5630                 where it would, were the LOI instruction used.
5631         */
5632         register char *q = (char *) &p;
5633         char t[4];
5634
5635         if (siz < EM_WSIZE && EM_WSIZE % siz == 0) {
5636                 /* as long as EM_WSIZE <= 4 ... */
5637                 if (siz != 2) TRP(M2_INTERNAL); /* internal error */
5638                 q = &t[0];
5639         }
5640         while (siz--) *q++ = *addr++;
5641         if (q - t == 2) {
5642                 *((unsigned *)(&p)) = *((unsigned short *) (&t[0]));
5643         }
5644 }
5645 dblockmove.c\0d\0\0\0\0\0\ 2\ 2�\ 1\0\0�\ 1/*
5646   (c) copyright 1988 by the Vrije Universiteit, Amsterdam, The Netherlands.
5647   See the copyright notice in the ACK home directory, in the file "Copyright".
5648 */
5649
5650 /*
5651   Module:       block moves
5652   Author:       Ceriel J.H. Jacobs
5653   Version:      $Id: blockmove.c,v 1.4 1994/06/24 12:50:49 ceriel Exp $
5654 */
5655
5656 #if _EM_WSIZE==_EM_PSIZE
5657 typedef unsigned pcnt;
5658 #else
5659 typedef unsigned long pcnt;
5660 #endif
5661
5662 blockmove(siz, dst, src)
5663         pcnt siz;
5664         register char *dst, *src;
5665 {
5666         while (siz--) *dst++ = *src++;
5667 }
5668 stackprio.c\0d\0\0\0\0\0\ 2\ 2�\ 1\0\0�\ 1/*
5669   (c) copyright 1988 by the Vrije Universiteit, Amsterdam, The Netherlands.
5670   See the copyright notice in the ACK home directory, in the file "Copyright".
5671 */
5672
5673 /*
5674   Module:       Dummy priority routines
5675   Author:       Ceriel J.H. Jacobs
5676   Version:      $Id: stackprio.c,v 1.5 1994/06/24 12:51:50 ceriel Exp $
5677 */
5678
5679 static unsigned prio = 0;
5680
5681 stackprio(n)
5682         unsigned n;
5683 {
5684         unsigned old = prio;
5685
5686         if (n > prio) prio = n;
5687         return old;
5688 }
5689
5690 unstackprio(n)
5691         unsigned n;
5692 {
5693         prio = n;
5694 }
5695 +ucheck.c\0.c\0d\0\0\0\0\0\ 2\ 2�\ 1\0\0H\ 4/*
5696  * (c) copyright 1988 by the Vrije Universiteit, Amsterdam, The Netherlands.
5697  * See the copyright notice in the ACK home directory, in the file "Copyright".
5698  *
5699  *
5700  * Module:      CARDINAL operations with overflow checking
5701  * Author:      Ceriel J.H. Jacobs
5702  * Version:     $Id: ucheck.c,v 1.4 1994/06/24 12:51:56 ceriel Exp $
5703 */
5704
5705 #ifndef EM_WSIZE
5706 #define EM_WSIZE _EM_WSIZE
5707 #endif
5708 #ifndef EM_LSIZE
5709 #define EM_LSIZE _EM_LSIZE
5710 #endif
5711
5712 #include <m2_traps.h>
5713
5714 #define MAXCARD ((unsigned)-1)
5715 #if EM_WSIZE < EM_LSIZE
5716 #define MAXLONGCARD     ((unsigned long) -1L)
5717 #endif
5718
5719 adduchk(a,b)
5720   unsigned      a,b;
5721 {
5722   if (MAXCARD - a < b) TRP(M2_UOVFL);
5723 }
5724
5725 #if EM_WSIZE < EM_LSIZE
5726 addulchk(a,b)
5727   unsigned long a,b;
5728 {
5729   if (MAXLONGCARD - a < b) TRP(M2_UOVFL);
5730 }
5731 #endif
5732
5733 muluchk(a,b)
5734   unsigned      a,b;
5735 {
5736   if (a != 0 && MAXCARD/a < b) TRP(M2_UOVFL);
5737 }
5738
5739 #if EM_WSIZE < EM_LSIZE
5740 mululchk(a,b)
5741   unsigned long a,b;
5742 {
5743   if (a != 0 && MAXLONGCARD/a < b) TRP(M2_UOVFL);
5744 }
5745 #endif
5746
5747 subuchk(a,b)
5748   unsigned      a,b;
5749 {
5750   if (b < a) TRP(M2_UUVFL);
5751 }
5752
5753 #if EM_WSIZE < EM_LSIZE
5754 subulchk(a,b)
5755   unsigned long a,b;
5756 {
5757   if (b < a) TRP(M2_UUVFL);
5758 }
5759 #endif
5760 rcka.c\0c\0.c\0d\0\0\0\0\0\ 2\ 2�\ 1\0\0%\ 2/*
5761  * (c) copyright 1988 by the Vrije Universiteit, Amsterdam, The Netherlands.
5762  * See the copyright notice in the ACK home directory, in the file "Copyright".
5763  *
5764  *
5765  * Module:      range checks for INTEGER, now for array indexing
5766  * Author:      Ceriel J.H. Jacobs
5767  * Version:     $Id: rcka.c,v 1.2 1994/06/24 12:51:30 ceriel Exp $
5768 */
5769
5770 #include <em_abs.h>
5771
5772 extern TRP();
5773
5774 struct array_descr {
5775   int   lbound;
5776   int   n_elts_min_one;
5777   unsigned size;
5778 };
5779
5780 rcka(descr, indx)
5781   struct array_descr *descr;
5782 {
5783   if (indx < 0 || indx > descr->n_elts_min_one) TRP(EARRAY);
5784 }
5785
5786 rcku.c\0c\0.c\0d\0\0\0\0\0\ 2\ 2�\ 1\0\0�\ 1/*
5787  * (c) copyright 1988 by the Vrije Universiteit, Amsterdam, The Netherlands.
5788  * See the copyright notice in the ACK home directory, in the file "Copyright".
5789  *
5790  *
5791  * Module:      range checks for CARDINAL
5792  * Author:      Ceriel J.H. Jacobs
5793  * Version:     $Id: rcku.c,v 1.3 1994/06/24 12:51:40 ceriel Exp $
5794 */
5795
5796 #include <em_abs.h>
5797
5798 extern TRP();
5799
5800 struct range_descr {
5801   unsigned      low, high;
5802 };
5803
5804 rcku(descr, val)
5805   struct range_descr *descr;
5806   unsigned val;
5807 {
5808   if (val < descr->low || val > descr->high) TRP(ERANGE);
5809 }
5810 xrcki.c\0c\0.c\0d\0\0\0\0\0\ 2\ 2�\ 1\0\0�\ 1/*
5811  * (c) copyright 1988 by the Vrije Universiteit, Amsterdam, The Netherlands.
5812  * See the copyright notice in the ACK home directory, in the file "Copyright".
5813  *
5814  *
5815  * Module:      range checks for INTEGER
5816  * Author:      Ceriel J.H. Jacobs
5817  * Version:     $Id: rcki.c,v 1.2 1994/06/24 12:51:33 ceriel Exp $
5818 */
5819
5820 #include <em_abs.h>
5821
5822 extern TRP();
5823
5824 struct range_descr {
5825   int   low, high;
5826 };
5827
5828 rcki(descr, val)
5829   struct range_descr *descr;
5830 {
5831   if (val < descr->low || val > descr->high) TRP(ERANGE);
5832 }
5833 >rckul.c\0\0.c\0d\0\0\0\0\0\ 2\ 2�\ 1\0\0\a\ 2/*
5834  * (c) copyright 1988 by the Vrije Universiteit, Amsterdam, The Netherlands.
5835  * See the copyright notice in the ACK home directory, in the file "Copyright".
5836  *
5837  *
5838  * Module:      range checks for LONGCARD
5839  * Author:      Ceriel J.H. Jacobs
5840  * Version:     $Id: rckul.c,v 1.3 1994/06/24 12:51:43 ceriel Exp $
5841 */
5842
5843 #include <em_abs.h>
5844
5845 extern TRP();
5846
5847 struct range_descr {
5848   unsigned long low, high;
5849 };
5850
5851 rckul(descr, val)
5852   struct range_descr *descr;
5853   unsigned long val;
5854 {
5855   if (val < descr->low || val > descr->high) TRP(ERANGE);
5856 }
5857 _rckil.c\0\0.c\0d\0\0\0\0\0\ 2\ 2�\ 1\0\0�\ 1/*
5858  * (c) copyright 1988 by the Vrije Universiteit, Amsterdam, The Netherlands.
5859  * See the copyright notice in the ACK home directory, in the file "Copyright".
5860  *
5861  *
5862  * Module:      range checks for LONGINT
5863  * Author:      Ceriel J.H. Jacobs
5864  * Version:     $Id: rckil.c,v 1.3 1994/06/24 12:51:37 ceriel Exp $
5865 */
5866
5867 #include <em_abs.h>
5868
5869 extern TRP();
5870
5871 struct range_descr {
5872   long  low, high;
5873 };
5874
5875 rckil(descr, val)
5876   struct range_descr *descr;
5877   long val;
5878 {
5879   if (val < descr->low || val > descr->high) TRP(ERANGE);
5880 }
5881 EM.e\0.c\0\0.c\0d\0\0\0\0\0\ 2\ 2�\ 1\0\0%\a#
5882 ;
5883 ; (c) copyright 1988 by the Vrije Universiteit, Amsterdam, The Netherlands.
5884 ; See the copyright notice in the ACK home directory, in the file "Copyright".
5885 ;
5886 ;
5887 ; Module:       Interface to some EM instructions and data
5888 ; Author:       Ceriel J.H. Jacobs
5889 ; Version:      $Id: EM.e,v 1.6 1994/06/24 12:48:39 ceriel Exp $
5890 ;
5891  mes 2,EM_WSIZE,EM_PSIZE
5892
5893 #define ARG1    0
5894 #define ARG2    EM_DSIZE
5895 #define IRES    2*EM_DSIZE
5896
5897 ; FIF is called with three parameters:
5898 ;       - address of integer part result (IRES)
5899 ;       - float two (ARG2)
5900 ;       - float one (ARG1)
5901 ; and returns an EM_DSIZE-byte floating point number
5902 ; Definition:
5903 ;       PROCEDURE FIF(ARG1, ARG2: LONGREAL; VAR IRES: LONGREAL) : LONGREAL;
5904
5905  exp $FIF
5906  pro $FIF,0
5907  lal 0
5908  loi 2*EM_DSIZE
5909  fif EM_DSIZE
5910  lal IRES
5911  loi EM_PSIZE
5912  sti EM_DSIZE
5913  ret EM_DSIZE
5914  end ?
5915
5916 #define FARG    0
5917 #define ERES    EM_DSIZE
5918
5919 ; FEF is called with two parameters:
5920 ;       - address of base 2 exponent result (ERES)
5921 ;       - floating point number to be split (FARG)
5922 ; and returns an EM_DSIZE-byte floating point number (the mantissa)
5923 ; Definition:
5924 ;       PROCEDURE FEF(FARG: LONGREAL; VAR ERES: integer): LONGREAL;
5925
5926  exp $FEF
5927  pro $FEF,0
5928  lal FARG
5929  loi EM_DSIZE
5930  fef EM_DSIZE
5931  lal ERES
5932  loi EM_PSIZE
5933  sti EM_WSIZE
5934  ret EM_DSIZE
5935  end ?
5936
5937 #define TRAP    0
5938
5939 ; TRP is called with one parameter:
5940 ;       - trap number (TRAP)
5941 ; Definition:
5942 ; PROCEDURE TRP(trapno: INTEGER);
5943
5944  exp $TRP
5945  pro $TRP, 0
5946  lol TRAP
5947  trp
5948  ret 0
5949  end ?
5950
5951 #define PROC    0
5952
5953 ; SIG is called with one parameter:
5954 ;       - procedure instance identifier (PROC)
5955 ; and returns the old traphandler.
5956
5957  exa handler
5958  exp $SIG
5959  pro $SIG, 0
5960  lae handler
5961  loi EM_PSIZE
5962  lal PROC
5963  loi EM_PSIZE
5964  lae handler
5965  sti EM_PSIZE
5966  ret EM_PSIZE
5967  end ?
5968
5969  exp $LINO
5970  pro $LINO,0
5971  loe 0
5972  ret EM_WSIZE
5973  end ?
5974
5975  exp $FILN
5976  pro $FILN,0
5977  lae 4
5978  loi EM_PSIZE
5979  ret EM_PSIZE
5980  end ?
5981 o