Minix/minix
1
0
Fork 0
Code Issues Pull Requests Projects Releases Wiki Activity

Initial revision

Browse Source
This commit is contained in:
Ben Gras
2005-04-21 14:53:53 +00:00
commit 9865aeaa79
2264 changed files with 411685 additions and 0 deletions
Download Patch File Download Diff File Expand all files Collapse all files

73
lib/libm2/Arguments.c Executable file
View File

@@ -0,0 +1,73 @@
/*
(c) copyright 1988 by the Vrije Universiteit, Amsterdam, The Netherlands.
See the copyright notice in the ACK home directory, in the file "Copyright".
*/
/*
Module: Access to program arguments and environment
Author: Ceriel J.H. Jacobs
Version: $Header$
*/
extern char **argv, ***_penviron;
extern int argc;
unsigned int _Arguments__Argc;
static char *
findname(s1, s2)
register char *s1, *s2;
{
while (*s1 == *s2++) s1++;
if (*s1 == '\0' && *(s2-1) == '=') return s2;
return 0;
}
static unsigned int
scopy(src, dst, max)
register char *src, *dst;
unsigned int max;
{
register unsigned int i = 0;
while (*src && i <= max) {
i++;
*dst++ = *src++;
}
if (i <= max) {
*dst = '\0';
return i+1;
}
while (*src++) i++;
return i + 1;
}
_Arguments_()
{
_Arguments__Argc = argc;
}
unsigned
_Arguments__Argv(n, argument, l, u, s)
unsigned int u;
char *argument;
{
if (n >= argc) return 0;
return scopy(argv[n], argument, u);
}
unsigned
_Arguments__GetEnv(name, nn, nu, ns, value, l, u, s)
char *name, *value;
unsigned int nu, u;
{
register char **p = *_penviron;
register char *v = 0;
while (*p && !(v = findname(name, *p++))) {
/* nothing */
}
if (!v) return 0;
return scopy(v, value, u);
}

155
lib/libm2/ArraySort.mod Executable file
View File

@@ -0,0 +1,155 @@
(*
(c) copyright 1988 by the Vrije Universiteit, Amsterdam, The Netherlands.
See the copyright notice in the ACK home directory, in the file "Copyright".
*)
(*$R-*)
IMPLEMENTATION MODULE ArraySort;
(*
Module: Array sorting module.
Author: Ceriel J.H. Jacobs
Version: $Header$
*)
FROM SYSTEM IMPORT ADDRESS, BYTE; (* no generics in Modula-2, sorry *)
TYPE BytePtr = POINTER TO BYTE;
VAR compareproc: CompareProc;
PROCEDURE Sort(base: ADDRESS; (* address of array *)
nel: CARDINAL; (* number of elements in array *)
size: CARDINAL; (* size of each element *)
compar: CompareProc); (* the comparison procedure *)
BEGIN
compareproc := compar;
qsort(base, base+(nel-1)*size, size);
END Sort;
PROCEDURE qsort(a1, a2: ADDRESS; size: CARDINAL);
(* Implemented with quick-sort, with some extra's *)
VAR left, right, lefteq, righteq: ADDRESS;
cmp: CompareResult;
mainloop: BOOLEAN;
BEGIN
WHILE a2 > a1 DO
left := a1;
right := a2;
lefteq := a1 + size * (((a2 - a1) + size) DIV (2 * size));
righteq := lefteq;
(*
Pick an element in the middle of the array.
We will collect the equals around it.
"lefteq" and "righteq" indicate the left and right
bounds of the equals respectively.
Smaller elements end up left of it, larger elements end
up right of it.
*)
LOOP
LOOP
IF left >= lefteq THEN EXIT END;
cmp := compareproc(left, lefteq);
IF cmp = greater THEN EXIT END;
IF cmp = less THEN
left := left + size;
ELSE
(* equal, so exchange with the element
to the left of the "equal"-interval.
*)
lefteq := lefteq - size;
exchange(left, lefteq, size);
END;
END;
mainloop := FALSE;
LOOP
IF right <= righteq THEN EXIT END;
cmp := compareproc(right, righteq);
IF cmp = less THEN
IF left < lefteq THEN
(* larger one at the left,
so exchange
*)
exchange(left,right,size);
left := left + size;
right := right - size;
mainloop := TRUE;
EXIT;
END;
(*
no more room at the left part, so we
move the "equal-interval" one place to the
right, and the smaller element to the
left of it.
This is best expressed as a three-way
exchange.
*)
righteq := righteq + size;
threewayexchange(left, righteq, right,
size);
lefteq := lefteq + size;
left := lefteq;
ELSIF cmp = equal THEN
(* equal, zo exchange with the element
to the right of the "equal"
interval
*)
righteq := righteq + size;
exchange(right, righteq, size);
ELSE
(* leave it where it is *)
right := right - size;
END;
END;
IF (NOT mainloop) THEN
IF left >= lefteq THEN
(* sort "smaller" part *)
qsort(a1, lefteq - size, size);
(* and now the "larger" part, saving a
procedure call, because of this big
WHILE loop
*)
a1 := righteq + size;
EXIT; (* from the LOOP *)
END;
(* larger element to the left, but no more room,
so move the "equal-interval" one place to the
left, and the larger element to the right
of it.
*)
lefteq := lefteq - size;
threewayexchange(right, lefteq, left, size);
righteq := righteq - size;
right := righteq;
END;
END;
END;
END qsort;
PROCEDURE exchange(a,b: BytePtr; size : CARDINAL);
VAR c: BYTE;
BEGIN
WHILE size > 0 DO
DEC(size);
c := a^;
a^ := b^;
a := ADDRESS(a) + 1;
b^ := c;
b := ADDRESS(b) + 1;
END;
END exchange;
PROCEDURE threewayexchange(p,q,r: BytePtr; size: CARDINAL);
VAR c: BYTE;
BEGIN
WHILE size > 0 DO
DEC(size);
c := p^;
p^ := r^;
p := ADDRESS(p) + 1;
r^ := q^;
r := ADDRESS(r) + 1;
q^ := c;
q := ADDRESS(q) + 1;
END;
END threewayexchange;
END ArraySort.

347
lib/libm2/CSP.mod Executable file
View File

@@ -0,0 +1,347 @@
(*$R-*)
IMPLEMENTATION MODULE CSP;
(*
Module: Communicating Sequential Processes
From: "A Modula-2 Implementation of CSP",
M. Collado, R. Morales, J.J. Moreno,
SIGPlan Notices, Volume 22, Number 6, June 1987.
Some modifications by Ceriel J.H. Jacobs
Version: $Header$
See this article for an explanation of the use of this module.
*)
FROM random IMPORT Uniform;
FROM SYSTEM IMPORT BYTE, ADDRESS, NEWPROCESS, TRANSFER;
FROM Storage IMPORT Allocate, Deallocate;
FROM Traps IMPORT Message;
CONST WorkSpaceSize = 2000;
TYPE ByteAddress = POINTER TO BYTE;
Channel = POINTER TO ChannelDescriptor;
ProcessType = POINTER TO ProcessDescriptor;
ProcessDescriptor = RECORD
next: ProcessType;
father: ProcessType;
cor: ADDRESS;
wsp: ADDRESS;
guardindex: INTEGER;
guardno: CARDINAL;
guardcount: CARDINAL;
opened: Channel;
sons: CARDINAL;
msgadr: ADDRESS;
msglen: CARDINAL;
END;
Queue = RECORD
head, tail: ProcessType;
END;
ChannelDescriptor = RECORD
senders: Queue;
owner: ProcessType;
guardindex: INTEGER;
next: Channel;
END;
VAR cp: ProcessType;
free, ready: Queue;
(* ------------ Private modules and procedures ------------- *)
MODULE ProcessQueue;
IMPORT ProcessType, Queue;
EXPORT Push, Pop, InitQueue, IsEmpty;
PROCEDURE InitQueue(VAR q: Queue);
BEGIN
WITH q DO
head := NIL;
tail := NIL
END
END InitQueue;
PROCEDURE Push(p: ProcessType; VAR q: Queue);
BEGIN
p^.next := NIL;
WITH q DO
IF head = NIL THEN
tail := p
ELSE
head^.next := p
END;
head := p
END
END Push;
PROCEDURE Pop(VAR q: Queue; VAR p: ProcessType);
BEGIN
WITH q DO
p := tail;
IF p # NIL THEN
tail := tail^.next;
IF head = p THEN
head := NIL
END
END
END
END Pop;
PROCEDURE IsEmpty(q: Queue): BOOLEAN;
BEGIN
RETURN q.head = NIL
END IsEmpty;
END ProcessQueue;
PROCEDURE DoTransfer;
VAR aux: ProcessType;
BEGIN
aux := cp;
Pop(ready, cp);
IF cp = NIL THEN
HALT
ELSE
TRANSFER(aux^.cor, cp^.cor)
END
END DoTransfer;
PROCEDURE OpenChannel(ch: Channel; n: INTEGER);
BEGIN
WITH ch^ DO
IF guardindex = 0 THEN
guardindex := n;
next := cp^.opened;
cp^.opened := ch
END
END
END OpenChannel;
PROCEDURE CloseChannels(p: ProcessType);
BEGIN
WITH p^ DO
WHILE opened # NIL DO
opened^.guardindex := 0;
opened := opened^.next
END
END
END CloseChannels;
PROCEDURE ThereAreOpenChannels(): BOOLEAN;
BEGIN
RETURN cp^.opened # NIL;
END ThereAreOpenChannels;
PROCEDURE Sending(ch: Channel): BOOLEAN;
BEGIN
RETURN NOT IsEmpty(ch^.senders)
END Sending;
(* -------------- Public Procedures ----------------- *)
PROCEDURE COBEGIN;
(* Beginning of a COBEGIN .. COEND structure *)
BEGIN
END COBEGIN;
PROCEDURE COEND;
(* End of a COBEGIN .. COEND structure *)
(* VAR aux: ProcessType; *)
BEGIN
IF cp^.sons > 0 THEN
DoTransfer
END
END COEND;
PROCEDURE StartProcess(P: PROC);
(* Start an anonimous process that executes the procedure P *)
VAR newprocess: ProcessType;
BEGIN
Pop(free, newprocess);
IF newprocess = NIL THEN
Allocate(newprocess,SIZE(ProcessDescriptor));
Allocate(newprocess^.wsp, WorkSpaceSize)
END;
WITH newprocess^ DO
father := cp;
sons := 0;
msglen := 0;
NEWPROCESS(P, wsp, WorkSpaceSize, cor)
END;
cp^.sons := cp^.sons + 1;
Push(newprocess, ready)
END StartProcess;
PROCEDURE StopProcess;
(* Terminate a Process (itself) *)
VAR aux: ProcessType;
BEGIN
aux := cp^.father;
aux^.sons := aux^.sons - 1;
IF aux^.sons = 0 THEN
Push(aux, ready)
END;
aux := cp;
Push(aux, free);
Pop(ready, cp);
IF cp = NIL THEN
HALT
ELSE
TRANSFER(aux^.cor, cp^.cor)
END
END StopProcess;
PROCEDURE InitChannel(VAR ch: Channel);
(* Initialize the channel ch *)
BEGIN
Allocate(ch, SIZE(ChannelDescriptor));
WITH ch^ DO
InitQueue(senders);
owner := NIL;
next := NIL;
guardindex := 0
END
END InitChannel;
PROCEDURE GetChannel(ch: Channel);
(* Assign the channel ch to the process that gets it *)
BEGIN
WITH ch^ DO
IF owner # NIL THEN
Message("Channel already has an owner");
HALT
END;
owner := cp
END
END GetChannel;
PROCEDURE Send(data: ARRAY OF BYTE; VAR ch: Channel);
(* Send a message with the data to the cvhannel ch *)
VAR m: ByteAddress;
(* aux: ProcessType; *)
i: CARDINAL;
BEGIN
WITH ch^ DO
Push(cp, senders);
Allocate(cp^.msgadr, SIZE(data));
m := cp^.msgadr;
cp^.msglen := HIGH(data);
FOR i := 0 TO HIGH(data) DO
m^ := data[i];
m := ADDRESS(m) + 1
END;
IF guardindex # 0 THEN
owner^.guardindex := guardindex;
CloseChannels(owner);
Push(owner, ready)
END
END;
DoTransfer
END Send;
PROCEDURE Receive(VAR ch: Channel; VAR dest: ARRAY OF BYTE);
(* Receive a message from the channel ch into the dest variable *)
VAR aux: ProcessType;
m: ByteAddress;
i: CARDINAL;
BEGIN
WITH ch^ DO
IF cp # owner THEN
Message("Only owner of channel can receive from it");
HALT
END;
IF Sending(ch) THEN
Pop(senders, aux);
m := aux^.msgadr;
FOR i := 0 TO aux^.msglen DO
dest[i] := m^;
m := ADDRESS(m) + 1
END;
Push(aux, ready);
Push(cp, ready);
CloseChannels(cp)
ELSE
OpenChannel(ch, -1);
DoTransfer;
Pop(senders, aux);
m := aux^.msgadr;
FOR i := 0 TO aux^.msglen DO
dest[i] := m^;
m := ADDRESS(m) + 1
END;
Push(cp, ready);
Push(aux, ready)
END;
Deallocate(aux^.msgadr, aux^.msglen+1);
DoTransfer
END
END Receive;
PROCEDURE SELECT(n: CARDINAL);
(* Beginning of a SELECT structure with n guards *)
BEGIN
cp^.guardindex := Uniform(1,n);
cp^.guardno := n;
cp^.guardcount := n
END SELECT;
PROCEDURE NEXTGUARD(): CARDINAL;
(* Returns an index to the next guard to be evaluated in a SELECT *)
BEGIN
RETURN cp^.guardindex
END NEXTGUARD;
PROCEDURE GUARD(cond: BOOLEAN; ch: Channel;
VAR dest: ARRAY OF BYTE): BOOLEAN;
(* Evaluates a guard, including reception management *)
(* VAR aux: ProcessType; *)
BEGIN
IF NOT cond THEN
RETURN FALSE
ELSIF ch = NIL THEN
CloseChannels(cp);
cp^.guardindex := 0;
RETURN TRUE
ELSIF Sending(ch) THEN
Receive(ch, dest);
cp^.guardindex := 0;
RETURN TRUE
ELSE
OpenChannel(ch, cp^.guardindex);
RETURN FALSE
END
END GUARD;
PROCEDURE ENDSELECT(): BOOLEAN;
(* End of a SELECT structure *)
BEGIN
WITH cp^ DO
IF guardindex <= 0 THEN
RETURN TRUE
END;
guardcount := guardcount - 1;
IF guardcount # 0 THEN
guardindex := (guardindex MOD INTEGER(guardno)) + 1
ELSIF ThereAreOpenChannels() THEN
DoTransfer
ELSE
guardindex := 0
END
END;
RETURN FALSE
END ENDSELECT;
BEGIN
InitQueue(free);
InitQueue(ready);
Allocate(cp,SIZE(ProcessDescriptor));
WITH cp^ DO
sons := 0;
father := NIL
END
END CSP.

73
lib/libm2/Conversion.mod Executable file
View File

@@ -0,0 +1,73 @@
(*
(c) copyright 1988 by the Vrije Universiteit, Amsterdam, The Netherlands.
See the copyright notice in the ACK home directory, in the file "Copyright".
*)
(*$R-*)
IMPLEMENTATION MODULE Conversions;
(*
Module: numeric-to-string conversions
Author: Ceriel J.H. Jacobs
Version: $Header$
*)
PROCEDURE ConvertNum(num, len, base: CARDINAL;
neg: BOOLEAN;
VAR str: ARRAY OF CHAR);
VAR i: CARDINAL;
r: CARDINAL;
tmp: ARRAY [0..20] OF CHAR;
BEGIN
i := 0;
REPEAT
r := num MOD base;
num := num DIV base;
IF r <= 9 THEN
tmp[i] := CHR(r + ORD('0'));
ELSE
tmp[i] := CHR(r - 10 + ORD('A'));
END;
INC(i);
UNTIL num = 0;
IF neg THEN
tmp[i] := '-';
INC(i)
END;
IF len > HIGH(str) + 1 THEN len := HIGH(str) + 1; END;
IF i > HIGH(str) + 1 THEN i := HIGH(str) + 1; END;
r := 0;
WHILE len > i DO str[r] := ' '; INC(r); DEC(len); END;
WHILE i > 0 DO str[r] := tmp[i-1]; DEC(i); INC(r); END;
WHILE r <= HIGH(str) DO
str[r] := 0C;
INC(r);
END;
END ConvertNum;
PROCEDURE ConvertOctal(num, len: CARDINAL; VAR str: ARRAY OF CHAR);
BEGIN
ConvertNum(num, len, 8, FALSE, str);
END ConvertOctal;
PROCEDURE ConvertHex(num, len: CARDINAL; VAR str: ARRAY OF CHAR);
BEGIN
ConvertNum(num, len, 16, FALSE, str);
END ConvertHex;
PROCEDURE ConvertCardinal(num, len: CARDINAL; VAR str: ARRAY OF CHAR);
BEGIN
ConvertNum(num, len, 10, FALSE, str);
END ConvertCardinal;
PROCEDURE ConvertInteger(num: INTEGER;
len: CARDINAL;
VAR str: ARRAY OF CHAR);
BEGIN
IF (num < 0) AND (num >= -MAX(INTEGER)) THEN
ConvertNum(-num, len, 10, TRUE, str);
ELSE
ConvertNum(CARDINAL(num), len, 10, num < 0, str);
END;
END ConvertInteger;
END Conversions.

100
lib/libm2/EM.e Executable file
View File

@@ -0,0 +1,100 @@
#
;
; (c) copyright 1988 by the Vrije Universiteit, Amsterdam, The Netherlands.
; See the copyright notice in the ACK home directory, in the file "Copyright".
;
;
; Module: Interface to some EM instructions and data
; Author: Ceriel J.H. Jacobs
; Version: $Header$
;
mes 2,_EM_WSIZE,_EM_PSIZE
#define ARG1 0
#define ARG2 _EM_DSIZE
#define IRES 2*_EM_DSIZE
; FIF is called with three parameters:
; - address of integer part result (IRES)
; - float two (ARG2)
; - float one (ARG1)
; and returns an _EM_DSIZE-byte floating point number
; Definition:
; PROCEDURE FIF(ARG1, ARG2: LONGREAL; VAR IRES: LONGREAL) : LONGREAL;
exp $FIF
pro $FIF,0
lal 0
loi 2*_EM_DSIZE
fif _EM_DSIZE
lal IRES
loi _EM_PSIZE
sti _EM_DSIZE
ret _EM_DSIZE
end ?
#define FARG 0
#define ERES _EM_DSIZE
; FEF is called with two parameters:
; - address of base 2 exponent result (ERES)
; - floating point number to be split (FARG)
; and returns an _EM_DSIZE-byte floating point number (the mantissa)
; Definition:
; PROCEDURE FEF(FARG: LONGREAL; VAR ERES: integer): LONGREAL;
exp $FEF
pro $FEF,0
lal FARG
loi _EM_DSIZE
fef _EM_DSIZE
lal ERES
loi _EM_PSIZE
sti _EM_WSIZE
ret _EM_DSIZE
end ?
#define TRAP 0
; TRP is called with one parameter:
; - trap number (TRAP)
; Definition:
; PROCEDURE TRP(trapno: INTEGER);
exp $TRP
pro $TRP, 0
lol TRAP
trp
ret 0
end ?
#define PROC 0
; SIG is called with one parameter:
; - procedure instance identifier (PROC)
; and returns the old traphandler.
exa handler
exp $SIG
pro $SIG, 0
lae handler
loi _EM_PSIZE
lal PROC
loi _EM_PSIZE
lae handler
sti _EM_PSIZE
ret _EM_PSIZE
end ?
exp $LINO
pro $LINO,0
loe 0
ret _EM_WSIZE
end ?
exp $FILN
pro $FILN,0
lae 4
loi _EM_PSIZE
ret _EM_PSIZE
end ?

371
lib/libm2/InOut.mod Executable file
View File

@@ -0,0 +1,371 @@
(*
(c) copyright 1988 by the Vrije Universiteit, Amsterdam, The Netherlands.
See the copyright notice in the ACK home directory, in the file "Copyright".
*)
(*$R-*)
IMPLEMENTATION MODULE InOut ;
(*
Module: Wirth's Input/Output module
Author: Ceriel J.H. Jacobs
Version: $Header$
*)
IMPORT Streams;
FROM Conversions IMPORT
ConvertCardinal, ConvertInteger,
ConvertOctal, ConvertHex;
FROM Traps IMPORT Message;
CONST TAB = 11C;
TYPE numbuf = ARRAY[0..255] OF CHAR;
VAR unread: BOOLEAN;
unreadch: CHAR;
CurrIn, CurrOut: Streams.Stream;
result: Streams.StreamResult;
PROCEDURE Read(VAR c : CHAR);
BEGIN
IF unread THEN
unread := FALSE;
c := unreadch;
Done := TRUE;
ELSE
Streams.Read(CurrIn, c, result);
Done := result = Streams.succeeded;
END;
END Read;
PROCEDURE UnRead(ch: CHAR);
BEGIN
unread := TRUE;
unreadch := ch;
END UnRead;
PROCEDURE Write(c: CHAR);
BEGIN
Streams.Write(CurrOut, c, result);
END Write;
PROCEDURE OpenInput(defext: ARRAY OF CHAR);
VAR namebuf : ARRAY [1..128] OF CHAR;
BEGIN
IF CurrIn # Streams.InputStream THEN
Streams.CloseStream(CurrIn, result);
END;
MakeFileName("Name of input file: ", defext, namebuf);
IF NOT Done THEN RETURN; END;
openinput(namebuf);
END OpenInput;
PROCEDURE OpenInputFile(filename: ARRAY OF CHAR);
BEGIN
IF CurrIn # Streams.InputStream THEN
Streams.CloseStream(CurrIn, result);
END;
openinput(filename);
END OpenInputFile;
PROCEDURE openinput(namebuf: ARRAY OF CHAR);
BEGIN
IF (namebuf[0] = '-') AND (namebuf[1] = 0C) THEN
CurrIn := Streams.InputStream;
Done := TRUE;
ELSE
Streams.OpenStream(CurrIn, namebuf, Streams.text,
Streams.reading, result);
Done := result = Streams.succeeded;
END;
END openinput;
PROCEDURE CloseInput;
BEGIN
IF CurrIn # Streams.InputStream THEN
Streams.CloseStream(CurrIn, result);
END;
CurrIn := Streams.InputStream;
END CloseInput;
PROCEDURE OpenOutput(defext: ARRAY OF CHAR);
VAR namebuf : ARRAY [1..128] OF CHAR;
BEGIN
IF CurrOut # Streams.OutputStream THEN
Streams.CloseStream(CurrOut, result);
END;
MakeFileName("Name of output file: ", defext, namebuf);
IF NOT Done THEN RETURN; END;
openoutput(namebuf);
END OpenOutput;
PROCEDURE OpenOutputFile(filename: ARRAY OF CHAR);
BEGIN
IF CurrOut # Streams.OutputStream THEN
Streams.CloseStream(CurrOut, result);
END;
openoutput(filename);
END OpenOutputFile;
PROCEDURE openoutput(namebuf: ARRAY OF CHAR);
BEGIN
IF (namebuf[1] = '-') AND (namebuf[2] = 0C) THEN
CurrOut := Streams.OutputStream;
Done := TRUE;
ELSE
Streams.OpenStream(CurrOut, namebuf, Streams.text,
Streams.writing, result);
Done := result = Streams.succeeded;
END;
END openoutput;
PROCEDURE CloseOutput;
BEGIN
IF CurrOut # Streams.OutputStream THEN
Streams.CloseStream(CurrOut, result);
END;
CurrOut := Streams.OutputStream;
END CloseOutput;
PROCEDURE MakeFileName(prompt, defext : ARRAY OF CHAR;
VAR buf : ARRAY OF CHAR);
VAR i : INTEGER;
j : CARDINAL;
BEGIN
Done := TRUE;
IF Streams.isatty(Streams.InputStream, result) THEN
XWriteString(prompt);
END;
XReadString(buf);
i := 0;
WHILE buf[i] # 0C DO i := i + 1 END;
IF i # 0 THEN
i := i - 1;
IF buf[i] = '.' THEN
FOR j := 0 TO HIGH(defext) DO
i := i + 1;
buf[i] := defext[j];
END;
buf[i+1] := 0C;
END;
RETURN;
END;
Done := FALSE;
END MakeFileName;
PROCEDURE ReadInt(VAR integ : INTEGER);
CONST
SAFELIMITDIV10 = MAX(INTEGER) DIV 10;
SAFELIMITREM10 = MAX(INTEGER) MOD 10;
TYPE
itype = [0..31];
ibuf = ARRAY itype OF CHAR;
VAR
int : INTEGER;
neg : BOOLEAN;
safedigit: [0 .. 9];
chvalue: CARDINAL;
buf : ibuf;
index : itype;
BEGIN
ReadString(buf);
IF NOT Done THEN
RETURN
END;
index := 0;
IF buf[index] = '-' THEN
neg := TRUE;
INC(index);
ELSIF buf[index] = '+' THEN
neg := FALSE;
INC(index);
ELSE
neg := FALSE
END;
safedigit := SAFELIMITREM10;
IF neg THEN safedigit := safedigit + 1 END;
int := 0;
WHILE (buf[index] >= '0') & (buf[index] <= '9') DO
chvalue := ORD(buf[index]) - ORD('0');
IF (int > SAFELIMITDIV10) OR
( (int = SAFELIMITDIV10) AND
(chvalue > safedigit)) THEN
Message("integer too large");
HALT;
ELSE
int := 10*int + VAL(INTEGER, chvalue);
INC(index)
END;
END;
IF neg THEN
integ := -int
ELSE
integ := int
END;
IF buf[index] > " " THEN
Message("illegal integer");
HALT;
END;
Done := TRUE;
END ReadInt;
PROCEDURE ReadCard(VAR card : CARDINAL);
CONST
SAFELIMITDIV10 = MAX(CARDINAL) DIV 10;
SAFELIMITREM10 = MAX(CARDINAL) MOD 10;
TYPE
itype = [0..31];
ibuf = ARRAY itype OF CHAR;
VAR
int : CARDINAL;
index : itype;
buf : ibuf;
safedigit: [0 .. 9];
chvalue: CARDINAL;
BEGIN
ReadString(buf);
IF NOT Done THEN RETURN; END;
index := 0;
safedigit := SAFELIMITREM10;
int := 0;
WHILE (buf[index] >= '0') & (buf[index] <= '9') DO
chvalue := ORD(buf[index]) - ORD('0');
IF (int > SAFELIMITDIV10) OR
( (int = SAFELIMITDIV10) AND
(chvalue > safedigit)) THEN
Message("cardinal too large");
HALT;
ELSE
int := 10*int + chvalue;
INC(index);
END;
END;
IF buf[index] > " " THEN
Message("illegal cardinal");
HALT;
END;
card := int;
Done := TRUE;
END ReadCard;
PROCEDURE ReadString(VAR s : ARRAY OF CHAR);
TYPE charset = SET OF CHAR;
VAR i : CARDINAL;
ch : CHAR;
BEGIN
i := 0;
REPEAT
Read(ch);
UNTIL NOT (ch IN charset{' ', TAB, 12C, 15C});
IF NOT Done THEN
RETURN;
END;
UnRead(ch);
REPEAT
Read(ch);
termCH := ch;
IF i <= HIGH(s) THEN
s[i] := ch;
IF (NOT Done) OR (ch <= " ") THEN
s[i] := 0C;
END;
END;
INC(i);
UNTIL (NOT Done) OR (ch <= " ");
IF Done THEN UnRead(ch); END;
END ReadString;
PROCEDURE XReadString(VAR s : ARRAY OF CHAR);
VAR j : CARDINAL;
ch : CHAR;
BEGIN
j := 0;
LOOP
Streams.Read(Streams.InputStream, ch, result);
IF result # Streams.succeeded THEN
EXIT;
END;
IF ch <= " " THEN
s[j] := 0C;
EXIT;
END;
IF j < HIGH(s) THEN
s[j] := ch;
INC(j);
END;
END;
END XReadString;
PROCEDURE XWriteString(s: ARRAY OF CHAR);
VAR i: CARDINAL;
BEGIN
i := 0;
LOOP
IF (i <= HIGH(s)) AND (s[i] # 0C) THEN
Streams.Write(Streams.OutputStream, s[i], result);
INC(i);
ELSE
EXIT;
END;
END;
END XWriteString;
PROCEDURE WriteCard(card, width : CARDINAL);
VAR
buf : numbuf;
BEGIN
ConvertCardinal(card, width, buf);
WriteString(buf);
END WriteCard;
PROCEDURE WriteInt(int : INTEGER; width : CARDINAL);
VAR
buf : numbuf;
BEGIN
ConvertInteger(int, width, buf);
WriteString(buf);
END WriteInt;
PROCEDURE WriteHex(card, width : CARDINAL);
VAR
buf : numbuf;
BEGIN
ConvertHex(card, width, buf);
WriteString(buf);
END WriteHex;
PROCEDURE WriteLn;
BEGIN
Write(EOL)
END WriteLn;
PROCEDURE WriteOct(card, width : CARDINAL);
VAR
buf : numbuf;
BEGIN
ConvertOctal(card, width, buf);
WriteString(buf);
END WriteOct;
PROCEDURE WriteString(str : ARRAY OF CHAR);
VAR
nbytes : CARDINAL;
BEGIN
nbytes := 0;
WHILE (nbytes <= HIGH(str)) AND (str[nbytes] # 0C) DO
Write(str[nbytes]);
INC(nbytes)
END;
END WriteString;
BEGIN (* InOut initialization *)
CurrIn := Streams.InputStream;
CurrOut := Streams.OutputStream;
unread := FALSE;
END InOut.

61
lib/libm2/LtoUset.e Executable file
View File

@@ -0,0 +1,61 @@
#
;
; (c) copyright 1988 by the Vrije Universiteit, Amsterdam, The Netherlands.
; See the copyright notice in the ACK home directory, in the file "Copyright".
;
;
; Module: Compute non-constant set displays
; Author: Ceriel J.H. Jacobs
; Version: $Header$
;
mes 2,_EM_WSIZE,_EM_PSIZE
; LtoUset is called for set displays containing { expr1 .. expr2 }.
; It has six parameters, of which the caller must pop five:
; - The set in which bits must be set.
; - the lower bound of the set type.
; - The set size in bytes.
; - The upper bound of set elements, specified by the set-type.
; - "expr2", the upper bound
; - "expr1", the lower bound
#define SETBASE 5*_EM_WSIZE
#define SETLOW 4*_EM_WSIZE
#define SETSIZE 3*_EM_WSIZE
#define USETSIZ 2*_EM_WSIZE
#define LWB _EM_WSIZE
#define UPB 0
exp $LtoUset
pro $LtoUset,0
lal SETBASE ; address of initial set
lol SETSIZE
los _EM_WSIZE ; load initial set
lol LWB ; low bound
lol SETLOW
sbu _EM_WSIZE
stl LWB
lol UPB ; high bound
lol SETLOW
sbu _EM_WSIZE
stl UPB
1
lol LWB
lol UPB
cmu _EM_WSIZE
zgt *2 ; while low <= high
lol LWB
lol SETSIZE
set ? ; create [low]
lol SETSIZE
ior ? ; merge with initial set
lol LWB
loc 1
adu _EM_WSIZE
stl LWB
bra *1 ; loop back
2
lal SETBASE
lol SETSIZE
sts _EM_WSIZE ; store result over initial set
ret 0
end 0

204
lib/libm2/Makefile Executable file
View File

@@ -0,0 +1,204 @@
# Makefile for lib/ack/libm2.
M2 = m2
CFLAGS = -O -I../h -wo
CC1 = $(CC) $(CFLAGS) -c
M2FLAGS = -O -ws -n
M21 = $(M2) $(M2FLAGS) -c
LIBRARY = ../libm2.a
all: $(LIBRARY)
OBJECTS = \
$(LIBRARY)(Arguments.o) \
$(LIBRARY)(ArraySort.o) \
$(LIBRARY)(CSP.o) \
$(LIBRARY)(Conversion.o) \
$(LIBRARY)(EM.o) \
$(LIBRARY)(InOut.o) \
$(LIBRARY)(LtoUset.o) \
$(LIBRARY)(MathLib0.o) \
$(LIBRARY)(Mathlib.o) \
$(LIBRARY)(PascalIO.o) \
$(LIBRARY)(Processes.o) \
$(LIBRARY)(RealConver.o) \
$(LIBRARY)(RealInOut.o) \
$(LIBRARY)(SYSTEM.o) \
$(LIBRARY)(Semaphores.o) \
$(LIBRARY)(Storage.o) \
$(LIBRARY)(StrAss.o) \
$(LIBRARY)(Streams.o) \
$(LIBRARY)(Strings.o) \
$(LIBRARY)(Termcap.o) \
$(LIBRARY)(Terminal.o) \
$(LIBRARY)(Traps.o) \
$(LIBRARY)(XXTermcap.o) \
$(LIBRARY)(absd.o) \
$(LIBRARY)(absf.o) \
$(LIBRARY)(absi.o) \
$(LIBRARY)(absl.o) \
$(LIBRARY)(blockmove.o) \
$(LIBRARY)(cap.o) \
$(LIBRARY)(catch.o) \
$(LIBRARY)(confarray.o) \
$(LIBRARY)(dvi.o) \
$(LIBRARY)(halt.o) \
$(LIBRARY)(head_m2.o) \
$(LIBRARY)(init.o) \
$(LIBRARY)(load.o) \
$(LIBRARY)(par_misc.o) \
$(LIBRARY)(random.o) \
$(LIBRARY)(rcka.o) \
$(LIBRARY)(rcki.o) \
$(LIBRARY)(rckil.o) \
$(LIBRARY)(rcku.o) \
$(LIBRARY)(rckul.o) \
$(LIBRARY)(sigtrp.o) \
$(LIBRARY)(stackprio.o) \
$(LIBRARY)(store.o) \
$(LIBRARY)(ucheck.o) \
$(LIBRARY): $(OBJECTS)
aal cr $@ *.o
rm *.o
$(LIBRARY)(Arguments.o): Arguments.c
$(CC1) Arguments.c
$(LIBRARY)(ArraySort.o): ArraySort.mod
$(M21) ArraySort.mod
$(LIBRARY)(CSP.o): CSP.mod
$(M21) CSP.mod
$(LIBRARY)(Conversion.o): Conversion.mod
$(M21) Conversion.mod
$(LIBRARY)(EM.o): EM.e
$(CC1) EM.e
$(LIBRARY)(InOut.o): InOut.mod
$(M21) InOut.mod
$(LIBRARY)(LtoUset.o): LtoUset.e
$(CC1) LtoUset.e
$(LIBRARY)(MathLib0.o): MathLib0.mod
$(M21) MathLib0.mod
$(LIBRARY)(Mathlib.o): Mathlib.mod
$(M21) Mathlib.mod
$(LIBRARY)(PascalIO.o): PascalIO.mod
$(M21) PascalIO.mod
$(LIBRARY)(Processes.o): Processes.mod
$(M21) Processes.mod
$(LIBRARY)(RealConver.o): RealConver.mod
$(M21) RealConver.mod
$(LIBRARY)(RealInOut.o): RealInOut.mod
$(M21) RealInOut.mod
$(LIBRARY)(SYSTEM.o): SYSTEM.c
$(CC1) SYSTEM.c
$(LIBRARY)(Semaphores.o): Semaphores.mod
$(M21) Semaphores.mod
$(LIBRARY)(Storage.o): Storage.mod
$(M21) Storage.mod
$(LIBRARY)(StrAss.o): StrAss.c
$(CC1) StrAss.c
$(LIBRARY)(Streams.o): Streams.mod
$(M21) Streams.mod
$(LIBRARY)(Strings.o): Strings.mod
$(M21) Strings.mod
$(LIBRARY)(Termcap.o): Termcap.mod
$(M21) Termcap.mod
$(LIBRARY)(Terminal.o): Terminal.mod
$(M21) -D__USG Terminal.mod
$(LIBRARY)(Traps.o): Traps.mod
$(M21) Traps.mod
$(LIBRARY)(XXTermcap.o): XXTermcap.c
$(CC1) XXTermcap.c
$(LIBRARY)(absd.o): absd.c
$(CC1) absd.c
$(LIBRARY)(absf.o): absf.e
$(CC1) absf.e
$(LIBRARY)(absi.o): absi.c
$(CC1) absi.c
$(LIBRARY)(absl.o): absl.c
$(CC1) absl.c
$(LIBRARY)(blockmove.o): blockmove.c
$(CC1) blockmove.c
$(LIBRARY)(cap.o): cap.c
$(CC1) cap.c
$(LIBRARY)(catch.o): catch.c
$(CC1) catch.c
$(LIBRARY)(confarray.o): confarray.c
$(CC1) confarray.c
$(LIBRARY)(dvi.o): dvi.c
$(CC1) dvi.c
$(LIBRARY)(halt.o): halt.c
$(CC1) halt.c
$(LIBRARY)(head_m2.o): head_m2.e
$(CC1) head_m2.e
$(LIBRARY)(init.o): init.c
$(CC1) init.c
$(LIBRARY)(load.o): load.c
$(CC1) load.c
$(LIBRARY)(par_misc.o): par_misc.e
$(CC1) par_misc.e
$(LIBRARY)(random.o): random.mod
$(M21) random.mod
$(LIBRARY)(rcka.o): rcka.c
$(CC1) rcka.c
$(LIBRARY)(rcki.o): rcki.c
$(CC1) rcki.c
$(LIBRARY)(rckil.o): rckil.c
$(CC1) rckil.c
$(LIBRARY)(rcku.o): rcku.c
$(CC1) rcku.c
$(LIBRARY)(rckul.o): rckul.c
$(CC1) rckul.c
$(LIBRARY)(sigtrp.o): sigtrp.c
$(CC1) sigtrp.c
$(LIBRARY)(stackprio.o): stackprio.c
$(CC1) stackprio.c
$(LIBRARY)(store.o): store.c
$(CC1) store.c
$(LIBRARY)(ucheck.o): ucheck.c
$(CC1) ucheck.c

69
lib/libm2/MathLib0.mod Executable file
View File

@@ -0,0 +1,69 @@
(*
(c) copyright 1988 by the Vrije Universiteit, Amsterdam, The Netherlands.
See the copyright notice in the ACK home directory, in the file "Copyright".
*)
(*$R-*)
IMPLEMENTATION MODULE MathLib0;
(*
Module: Some mathematical functions
Author: Ceriel J.H. Jacobs
Version: $Header$
*)
IMPORT Mathlib;
PROCEDURE cos(arg: REAL): REAL;
BEGIN
RETURN Mathlib.cos(arg);
END cos;
PROCEDURE sin(arg: REAL): REAL;
BEGIN
RETURN Mathlib.sin(arg);
END sin;
PROCEDURE arctan(arg: REAL): REAL;
BEGIN
RETURN Mathlib.arctan(arg);
END arctan;
PROCEDURE sqrt(arg: REAL): REAL;
BEGIN
RETURN Mathlib.sqrt(arg);
END sqrt;
PROCEDURE ln(arg: REAL): REAL;
BEGIN
RETURN Mathlib.ln(arg);
END ln;
PROCEDURE exp(arg: REAL): REAL;
BEGIN
RETURN Mathlib.exp(arg);
END exp;
PROCEDURE entier(x: REAL): INTEGER;
VAR i: INTEGER;
BEGIN
IF x < 0.0 THEN
i := TRUNC(-x);
IF FLOAT(i) = -x THEN
RETURN -i;
ELSE
RETURN -i -1;
END;
END;
RETURN TRUNC(x);
END entier;
PROCEDURE real(x: INTEGER): REAL;
BEGIN
IF x < 0 THEN
RETURN - FLOAT(-x);
END;
RETURN FLOAT(x);
END real;
BEGIN
END MathLib0.

576
lib/libm2/Mathlib.mod Executable file
View File

@@ -0,0 +1,576 @@
(*
(c) copyright 1988 by the Vrije Universiteit, Amsterdam, The Netherlands.
See the copyright notice in the ACK home directory, in the file "Copyright".
*)
(*$R-*)
IMPLEMENTATION MODULE Mathlib;
(*
Module: Mathematical functions
Author: Ceriel J.H. Jacobs
Version: $Header$
*)
FROM EM IMPORT FIF, FEF;
FROM Traps IMPORT Message;
CONST
OneRadianInDegrees = 57.295779513082320876798155D;
OneDegreeInRadians = 0.017453292519943295769237D;
OneOverSqrt2 = 0.70710678118654752440084436210484904D;
(* basic functions *)
PROCEDURE pow(x: REAL; i: INTEGER): REAL;
BEGIN
RETURN SHORT(longpow(LONG(x), i));
END pow;
PROCEDURE longpow(x: LONGREAL; i: INTEGER): LONGREAL;
VAR val: LONGREAL;
ri: LONGREAL;
BEGIN
ri := FLOATD(i);
IF x < 0.0D THEN
val := longexp(longln(-x) * ri);
IF ODD(i) THEN RETURN -val;
ELSE RETURN val;
END;
ELSIF x = 0.0D THEN
RETURN 0.0D;
ELSE
RETURN longexp(longln(x) * ri);
END;
END longpow;
PROCEDURE sqrt(x: REAL): REAL;
BEGIN
RETURN SHORT(longsqrt(LONG(x)));
END sqrt;
PROCEDURE longsqrt(x: LONGREAL): LONGREAL;
VAR
temp: LONGREAL;
exp, i: INTEGER;
BEGIN
IF x <= 0.0D THEN
IF x < 0.0D THEN
Message("sqrt: negative argument");
HALT
END;
RETURN 0.0D;
END;
temp := FEF(x,exp);
(*
* NOTE
* this wont work on 1's comp
*)
IF ODD(exp) THEN
temp := 2.0D * temp;
DEC(exp);
END;
temp := 0.5D*(1.0D + temp);
WHILE exp > 28 DO
temp := temp * 16384.0D;
exp := exp - 28;
END;
WHILE exp < -28 DO
temp := temp / 16384.0D;
exp := exp + 28;
END;
WHILE exp >= 2 DO
temp := temp * 2.0D;
exp := exp - 2;
END;
WHILE exp <= -2 DO
temp := temp / 2.0D;
exp := exp + 2;
END;
FOR i := 0 TO 5 DO
temp := 0.5D*(temp + x/temp);
END;
RETURN temp;
END longsqrt;
PROCEDURE ldexp(x:LONGREAL; n: INTEGER): LONGREAL;
BEGIN
WHILE n >= 16 DO
x := x * 65536.0D;
n := n - 16;
END;
WHILE n > 0 DO
x := x * 2.0D;
DEC(n);
END;
WHILE n <= -16 DO
x := x / 65536.0D;
n := n + 16;
END;
WHILE n < 0 DO
x := x / 2.0D;
INC(n);
END;
RETURN x;
END ldexp;
PROCEDURE exp(x: REAL): REAL;
BEGIN
RETURN SHORT(longexp(LONG(x)));
END exp;
PROCEDURE longexp(x: LONGREAL): LONGREAL;
(* Algorithm and coefficients from:
"Software manual for the elementary functions"
by W.J. Cody and W. Waite, Prentice-Hall, 1980
*)
CONST
p0 = 0.25000000000000000000D+00;
p1 = 0.75753180159422776666D-02;
p2 = 0.31555192765684646356D-04;
q0 = 0.50000000000000000000D+00;
q1 = 0.56817302698551221787D-01;
q2 = 0.63121894374398503557D-03;
q3 = 0.75104028399870046114D-06;
VAR
neg: BOOLEAN;
n: INTEGER;
xn, g, x1, x2: LONGREAL;
BEGIN
neg := x < 0.0D;
IF neg THEN
x := -x;
END;
n := TRUNC(x/longln2 + 0.5D);
xn := FLOATD(n);
x1 := FLOATD(TRUNCD(x));
x2 := x - x1;
g := ((x1 - xn * 0.693359375D)+x2) - xn * (-2.1219444005469058277D-4);
IF neg THEN
g := -g;
n := -n;
END;
xn := g*g;
x := g*((p2*xn+p1)*xn+p0);
INC(n);
RETURN ldexp(0.5D + x/((((q3*xn+q2)*xn+q1)*xn+q0) - x), n);
END longexp;
PROCEDURE ln(x: REAL): REAL; (* natural log *)
BEGIN
RETURN SHORT(longln(LONG(x)));
END ln;
PROCEDURE longln(x: LONGREAL): LONGREAL; (* natural log *)
(* Algorithm and coefficients from:
"Software manual for the elementary functions"
by W.J. Cody and W. Waite, Prentice-Hall, 1980
*)
CONST
p0 = -0.64124943423745581147D+02;
p1 = 0.16383943563021534222D+02;
p2 = -0.78956112887491257267D+00;
q0 = -0.76949932108494879777D+03;
q1 = 0.31203222091924532844D+03;
q2 = -0.35667977739034646171D+02;
q3 = 1.0D;
VAR
exp: INTEGER;
z, znum, zden, w: LONGREAL;
BEGIN
IF x <= 0.0D THEN
Message("ln: argument <= 0");
HALT
END;
x := FEF(x, exp);
IF x > OneOverSqrt2 THEN
znum := (x - 0.5D) - 0.5D;
zden := x * 0.5D + 0.5D;
ELSE
znum := x - 0.5D;
zden := znum * 0.5D + 0.5D;
DEC(exp);
END;
z := znum / zden;
w := z * z;
x := z + z * w * (((p2*w+p1)*w+p0)/(((q3*w+q2)*w+q1)*w+q0));
z := FLOATD(exp);
x := x + z * (-2.121944400546905827679D-4);
RETURN x + z * 0.693359375D;
END longln;
PROCEDURE log(x: REAL): REAL; (* log with base 10 *)
BEGIN
RETURN SHORT(longlog(LONG(x)));
END log;
PROCEDURE longlog(x: LONGREAL): LONGREAL; (* log with base 10 *)
BEGIN
RETURN longln(x)/longln10;
END longlog;
(* trigonometric functions; arguments in radians *)
PROCEDURE sin(x: REAL): REAL;
BEGIN
RETURN SHORT(longsin(LONG(x)));
END sin;
PROCEDURE sinus(x: LONGREAL; cosflag: BOOLEAN) : LONGREAL;
(* Algorithm and coefficients from:
"Software manual for the elementary functions"
by W.J. Cody and W. Waite, Prentice-Hall, 1980
*)
CONST
r0 = -0.16666666666666665052D+00;
r1 = 0.83333333333331650314D-02;
r2 = -0.19841269841201840457D-03;
r3 = 0.27557319210152756119D-05;
r4 = -0.25052106798274584544D-07;
r5 = 0.16058936490371589114D-09;
r6 = -0.76429178068910467734D-12;
r7 = 0.27204790957888846175D-14;
A1 = 3.1416015625D;
A2 = -8.908910206761537356617D-6;
VAR
x1, x2, y : LONGREAL;
neg : BOOLEAN;
BEGIN
IF x < 0.0D THEN
neg := TRUE;
x := -x
ELSE neg := FALSE
END;
IF cosflag THEN
neg := FALSE;
y := longhalfpi + x
ELSE
y := x
END;
y := y / longpi + 0.5D;
IF FIF(y, 1.0D, y) < 0.0D THEN ; END;
IF FIF(y, 0.5D, x1) # 0.0D THEN neg := NOT neg END;
IF cosflag THEN y := y - 0.5D END;
x2 := FIF(x, 1.0, x1);
x := x1 - y * A1;
x := x + x2;
x := x - y * A2;
IF x < 0.0D THEN
neg := NOT neg;
x := -x
END;
y := x * x;
x := x + x * y * (((((((r7*y+r6)*y+r5)*y+r4)*y+r3)*y+r2)*y+r1)*y+r0);
IF neg THEN RETURN -x END;
RETURN x;
END sinus;
PROCEDURE longsin(x: LONGREAL): LONGREAL;
BEGIN
RETURN sinus(x, FALSE);
END longsin;
PROCEDURE cos(x: REAL): REAL;
BEGIN
RETURN SHORT(longcos(LONG(x)));
END cos;
PROCEDURE longcos(x: LONGREAL): LONGREAL;
BEGIN
IF x < 0.0D THEN x := -x; END;
RETURN sinus(x, TRUE);
END longcos;
PROCEDURE tan(x: REAL): REAL;
BEGIN
RETURN SHORT(longtan(LONG(x)));
END tan;
PROCEDURE longtan(x: LONGREAL): LONGREAL;
(* Algorithm and coefficients from:
"Software manual for the elementary functions"
by W.J. Cody and W. Waite, Prentice-Hall, 1980
*)
CONST
p1 = -0.13338350006421960681D+00;
p2 = 0.34248878235890589960D-02;
p3 = -0.17861707342254426711D-04;
q0 = 1.0D;
q1 = -0.46671683339755294240D+00;
q2 = 0.25663832289440112864D-01;
q3 = -0.31181531907010027307D-03;
q4 = 0.49819433993786512270D-06;
A1 = 1.57080078125D;
A2 = -4.454455103380768678308D-06;
VAR y, x1, x2: LONGREAL;
negative: BOOLEAN;
invert: BOOLEAN;
BEGIN
negative := x < 0.0D;
y := x / longhalfpi + 0.5D;
(* Use extended precision to calculate reduced argument.
Here we used 12 bits of the mantissa for a1.
Also split x in integer part x1 and fraction part x2.
*)
IF FIF(y, 1.0D, y) < 0.0D THEN ; END;
invert := FIF(y, 0.5D, x1) # 0.0D;
x2 := FIF(x, 1.0D, x1);
x := x1 - y * A1;
x := x + x2;
x := x - y * A2;
y := x * x;
x := x + x * y * ((p3*y+p2)*y+p1);
y := (((q4*y+q3)*y+q2)*y+q1)*y+q0;
IF negative THEN x := -x END;
IF invert THEN RETURN -y/x END;
RETURN x/y;
END longtan;
PROCEDURE arcsin(x: REAL): REAL;
BEGIN
RETURN SHORT(longarcsin(LONG(x)));
END arcsin;
PROCEDURE arcsincos(x: LONGREAL; cosfl: BOOLEAN): LONGREAL;
CONST
p0 = -0.27368494524164255994D+02;
p1 = 0.57208227877891731407D+02;
p2 = -0.39688862997540877339D+02;
p3 = 0.10152522233806463645D+02;
p4 = -0.69674573447350646411D+00;
q0 = -0.16421096714498560795D+03;
q1 = 0.41714430248260412556D+03;
q2 = -0.38186303361750149284D+03;
q3 = 0.15095270841030604719D+03;
q4 = -0.23823859153670238830D+02;
q5 = 1.0D;
VAR
negative : BOOLEAN;
big: BOOLEAN;
g: LONGREAL;
BEGIN
negative := x < 0.0D;
IF negative THEN x := -x; END;
IF x > 0.5D THEN
big := TRUE;
IF x > 1.0D THEN
Message("arcsin or arccos: argument > 1");
HALT
END;
g := 0.5D - 0.5D * x;
x := -longsqrt(g);
x := x + x;
ELSE
big := FALSE;
g := x * x;
END;
x := x + x * g *
((((p4*g+p3)*g+p2)*g+p1)*g+p0)/(((((q5*g+q4)*g+q3)*g+q2)*g+q1)*g+q0);
IF cosfl AND NOT negative THEN x := -x END;
IF cosfl = NOT big THEN
x := (x + longquartpi) + longquartpi;
ELSIF cosfl AND negative AND big THEN
x := (x + longhalfpi) + longhalfpi;
END;
IF negative AND NOT cosfl THEN x := -x END;
RETURN x;
END arcsincos;
PROCEDURE longarcsin(x: LONGREAL): LONGREAL;
BEGIN
RETURN arcsincos(x, FALSE);
END longarcsin;
PROCEDURE arccos(x: REAL): REAL;
BEGIN
RETURN SHORT(longarccos(LONG(x)));
END arccos;
PROCEDURE longarccos(x: LONGREAL): LONGREAL;
BEGIN
RETURN arcsincos(x, TRUE);
END longarccos;
PROCEDURE arctan(x: REAL): REAL;
BEGIN
RETURN SHORT(longarctan(LONG(x)));
END arctan;
VAR A: ARRAY[0..3] OF LONGREAL;
arctaninit: BOOLEAN;
PROCEDURE longarctan(x: LONGREAL): LONGREAL;
(* Algorithm and coefficients from:
"Software manual for the elementary functions"
by W.J. Cody and W. Waite, Prentice-Hall, 1980
*)
CONST
p0 = -0.13688768894191926929D+02;
p1 = -0.20505855195861651981D+02;
p2 = -0.84946240351320683534D+01;
p3 = -0.83758299368150059274D+00;
q0 = 0.41066306682575781263D+02;
q1 = 0.86157349597130242515D+02;
q2 = 0.59578436142597344465D+02;
q3 = 0.15024001160028576121D+02;
q4 = 1.0D;
VAR
g: LONGREAL;
neg: BOOLEAN;
n: INTEGER;
BEGIN
IF NOT arctaninit THEN
arctaninit := TRUE;
A[0] := 0.0D;
A[1] := 0.52359877559829887307710723554658381D; (* p1/6 *)
A[2] := longhalfpi;
A[3] := 1.04719755119659774615421446109316763D; (* pi/3 *)
END;
neg := FALSE;
IF x < 0.0D THEN
neg := TRUE;
x := -x;
END;
IF x > 1.0D THEN
x := 1.0D/x;
n := 2
ELSE
n := 0
END;
IF x > 0.26794919243112270647D (* 2-sqrt(3) *) THEN
INC(n);
x := (((0.73205080756887729353D*x-0.5D)-0.5D)+x)/
(1.73205080756887729353D + x);
END;
g := x*x;
x := x + x * g * (((p3*g+p2)*g+p1)*g+p0) / ((((q4*g+q3)*g+q2)*g+q1)*g+q0);
IF n > 1 THEN x := -x END;
x := x + A[n];
IF neg THEN RETURN -x; END;
RETURN x;
END longarctan;
(* hyperbolic functions *)
(* The C math library has better implementations for some of these, but
they depend on some properties of the floating point implementation,
and, for now, we don't want that in the Modula-2 system.
*)
PROCEDURE sinh(x: REAL): REAL;
BEGIN
RETURN SHORT(longsinh(LONG(x)));
END sinh;
PROCEDURE longsinh(x: LONGREAL): LONGREAL;
VAR expx: LONGREAL;
BEGIN
expx := longexp(x);
RETURN (expx - 1.0D/expx)/2.0D;
END longsinh;
PROCEDURE cosh(x: REAL): REAL;
BEGIN
RETURN SHORT(longcosh(LONG(x)));
END cosh;
PROCEDURE longcosh(x: LONGREAL): LONGREAL;
VAR expx: LONGREAL;
BEGIN
expx := longexp(x);
RETURN (expx + 1.0D/expx)/2.0D;
END longcosh;
PROCEDURE tanh(x: REAL): REAL;
BEGIN
RETURN SHORT(longtanh(LONG(x)));
END tanh;
PROCEDURE longtanh(x: LONGREAL): LONGREAL;
VAR expx: LONGREAL;
BEGIN
expx := longexp(x);
RETURN (expx - 1.0D/expx) / (expx + 1.0D/expx);
END longtanh;
PROCEDURE arcsinh(x: REAL): REAL;
BEGIN
RETURN SHORT(longarcsinh(LONG(x)));
END arcsinh;
PROCEDURE longarcsinh(x: LONGREAL): LONGREAL;
VAR neg: BOOLEAN;
BEGIN
neg := FALSE;
IF x < 0.0D THEN
neg := TRUE;
x := -x;
END;
x := longln(x + longsqrt(x*x+1.0D));
IF neg THEN RETURN -x; END;
RETURN x;
END longarcsinh;
PROCEDURE arccosh(x: REAL): REAL;
BEGIN
RETURN SHORT(longarccosh(LONG(x)));
END arccosh;
PROCEDURE longarccosh(x: LONGREAL): LONGREAL;
BEGIN
IF x < 1.0D THEN
Message("arccosh: argument < 1");
HALT
END;
RETURN longln(x + longsqrt(x*x - 1.0D));
END longarccosh;
PROCEDURE arctanh(x: REAL): REAL;
BEGIN
RETURN SHORT(longarctanh(LONG(x)));
END arctanh;
PROCEDURE longarctanh(x: LONGREAL): LONGREAL;
BEGIN
IF (x <= -1.0D) OR (x >= 1.0D) THEN
Message("arctanh: ABS(argument) >= 1");
HALT
END;
RETURN longln((1.0D + x)/(1.0D - x)) / 2.0D;
END longarctanh;
(* conversions *)
PROCEDURE RadianToDegree(x: REAL): REAL;
BEGIN
RETURN SHORT(longRadianToDegree(LONG(x)));
END RadianToDegree;
PROCEDURE longRadianToDegree(x: LONGREAL): LONGREAL;
BEGIN
RETURN x * OneRadianInDegrees;
END longRadianToDegree;
PROCEDURE DegreeToRadian(x: REAL): REAL;
BEGIN
RETURN SHORT(longDegreeToRadian(LONG(x)));
END DegreeToRadian;
PROCEDURE longDegreeToRadian(x: LONGREAL): LONGREAL;
BEGIN
RETURN x * OneDegreeInRadians;
END longDegreeToRadian;
BEGIN
arctaninit := FALSE;
END Mathlib.

437
lib/libm2/PascalIO.mod Executable file
View File

@@ -0,0 +1,437 @@
(*
(c) copyright 1988 by the Vrije Universiteit, Amsterdam, The Netherlands.
See the copyright notice in the ACK home directory, in the file "Copyright".
*)
(*$R-*)
IMPLEMENTATION MODULE PascalIO;
(*
Module: Pascal-like Input/Output
Author: Ceriel J.H. Jacobs
Version: $Header$
*)
FROM Conversions IMPORT
ConvertInteger, ConvertCardinal;
FROM RealConversions IMPORT
LongRealToString, StringToLongReal;
FROM Traps IMPORT Message;
FROM Streams IMPORT Stream, StreamKind, StreamMode, StreamResult,
InputStream, OutputStream, OpenStream, CloseStream,
EndOfStream, Read, Write, StreamBuffering;
FROM Storage IMPORT Allocate;
FROM SYSTEM IMPORT ADR;
TYPE charset = SET OF CHAR;
btype = (Preading, Pwriting, free);
CONST spaces = charset{11C, 12C, 13C, 14C, 15C, ' '};
TYPE IOstream = RECORD
type: btype;
done, eof : BOOLEAN;
ch: CHAR;
next: Text;
stream: Stream;
END;
Text = POINTER TO IOstream;
numbuf = ARRAY[0..255] OF CHAR;
VAR ibuf, obuf: IOstream;
head: Text;
result: StreamResult;
PROCEDURE Reset(VAR InputText: Text; Filename: ARRAY OF CHAR);
BEGIN
doclose(InputText);
getstruct(InputText);
WITH InputText^ DO
OpenStream(stream, Filename, text, reading, result);
IF result # succeeded THEN
Message("could not open input file");
HALT;
END;
type := Preading;
done := FALSE;
eof := FALSE;
END;
END Reset;
PROCEDURE Rewrite(VAR OutputText: Text; Filename: ARRAY OF CHAR);
BEGIN
doclose(OutputText);
getstruct(OutputText);
WITH OutputText^ DO
OpenStream(stream, Filename, text, writing, result);
IF result # succeeded THEN
Message("could not open output file");
HALT;
END;
type := Pwriting;
END;
END Rewrite;
PROCEDURE CloseOutput();
VAR p: Text;
BEGIN
p := head;
WHILE p # NIL DO
doclose(p);
p := p^.next;
END;
END CloseOutput;
PROCEDURE doclose(Xtext: Text);
BEGIN
IF Xtext # Notext THEN
WITH Xtext^ DO
IF type # free THEN
CloseStream(stream, result);
type := free;
END;
END;
END;
END doclose;
PROCEDURE getstruct(VAR Xtext: Text);
BEGIN
Xtext := head;
WHILE (Xtext # NIL) AND (Xtext^.type # free) DO
Xtext := Xtext^.next;
END;
IF Xtext = NIL THEN
Allocate(Xtext,SIZE(IOstream));
Xtext^.next := head;
head := Xtext;
END;
END getstruct;
PROCEDURE Error(tp: btype);
BEGIN
IF tp = Preading THEN
Message("input text expected");
ELSE
Message("output text expected");
END;
HALT;
END Error;
PROCEDURE ReadChar(InputText: Text; VAR ch : CHAR);
BEGIN
ch := NextChar(InputText);
IF InputText^.eof THEN
Message("unexpected EOF");
HALT;
END;
InputText^.done := FALSE;
END ReadChar;
PROCEDURE NextChar(InputText: Text): CHAR;
BEGIN
WITH InputText^ DO
IF type # Preading THEN Error(Preading); END;
IF NOT done THEN
IF EndOfStream(stream, result) THEN
eof := TRUE;
ch := 0C;
ELSE
Read(stream, ch, result);
done := TRUE;
END;
END;
RETURN ch;
END;
END NextChar;
PROCEDURE Get(InputText: Text);
VAR dummy: CHAR;
BEGIN
ReadChar(InputText, dummy);
END Get;
PROCEDURE Eoln(InputText: Text): BOOLEAN;
BEGIN
RETURN NextChar(InputText) = 12C;
END Eoln;
PROCEDURE Eof(InputText: Text): BOOLEAN;
BEGIN
RETURN (NextChar(InputText) = 0C) AND InputText^.eof;
END Eof;
PROCEDURE ReadLn(InputText: Text);
VAR ch: CHAR;
BEGIN
REPEAT
ReadChar(InputText, ch)
UNTIL ch = 12C;
END ReadLn;
PROCEDURE WriteChar(OutputText: Text; char: CHAR);
BEGIN
WITH OutputText^ DO
IF type # Pwriting THEN Error(Pwriting); END;
Write(stream, char, result);
END;
END WriteChar;
PROCEDURE WriteLn(OutputText: Text);
BEGIN
WriteChar(OutputText, 12C);
END WriteLn;
PROCEDURE Page(OutputText: Text);
BEGIN
WriteChar(OutputText, 14C);
END Page;
PROCEDURE ReadInteger(InputText: Text; VAR int : INTEGER);
CONST
SAFELIMITDIV10 = MAX(INTEGER) DIV 10;
SAFELIMITREM10 = MAX(INTEGER) MOD 10;
VAR
neg : BOOLEAN;
safedigit: CARDINAL;
ch: CHAR;
chvalue: CARDINAL;
BEGIN
WHILE NextChar(InputText) IN spaces DO
Get(InputText);
END;
ch := NextChar(InputText);
IF ch = '-' THEN
Get(InputText);
ch := NextChar(InputText);
neg := TRUE;
ELSIF ch = '+' THEN
Get(InputText);
ch := NextChar(InputText);
neg := FALSE;
ELSE
neg := FALSE
END;
safedigit := SAFELIMITREM10;
IF neg THEN safedigit := safedigit + 1 END;
int := 0;
IF (ch >= '0') AND (ch <= '9') THEN
WHILE (ch >= '0') & (ch <= '9') DO
chvalue := ORD(ch) - ORD('0');
IF (int < -SAFELIMITDIV10) OR
( (int = -SAFELIMITDIV10) AND
(chvalue > safedigit)) THEN
Message("integer too large");
HALT;
ELSE
int := 10*int - VAL(INTEGER, chvalue);
Get(InputText);
ch := NextChar(InputText);
END;
END;
IF NOT neg THEN
int := -int
END;
ELSE
Message("integer expected");
HALT;
END;
END ReadInteger;
PROCEDURE ReadCardinal(InputText: Text; VAR card : CARDINAL);
CONST
SAFELIMITDIV10 = MAX(CARDINAL) DIV 10;
SAFELIMITREM10 = MAX(CARDINAL) MOD 10;
VAR
ch : CHAR;
safedigit: CARDINAL;
chvalue: CARDINAL;
BEGIN
WHILE NextChar(InputText) IN spaces DO
Get(InputText);
END;
ch := NextChar(InputText);
safedigit := SAFELIMITREM10;
card := 0;
IF (ch >= '0') AND (ch <= '9') THEN
WHILE (ch >= '0') & (ch <= '9') DO
chvalue := ORD(ch) - ORD('0');
IF (card > SAFELIMITDIV10) OR
( (card = SAFELIMITDIV10) AND
(chvalue > safedigit)) THEN
Message("cardinal too large");
HALT;
ELSE
card := 10*card + chvalue;
Get(InputText);
ch := NextChar(InputText);
END;
END;
ELSE
Message("cardinal expected");
HALT;
END;
END ReadCardinal;
PROCEDURE ReadReal(InputText: Text; VAR real: REAL);
VAR x1: LONGREAL;
BEGIN
ReadLongReal(InputText, x1);
real := x1
END ReadReal;
PROCEDURE ReadLongReal(InputText: Text; VAR real: LONGREAL);
VAR
buf: numbuf;
ch: CHAR;
ok: BOOLEAN;
index: INTEGER;
PROCEDURE inch(): CHAR;
BEGIN
buf[index] := ch;
INC(index);
Get(InputText);
RETURN NextChar(InputText);
END inch;
BEGIN
index := 0;
ok := TRUE;
WHILE NextChar(InputText) IN spaces DO
Get(InputText);
END;
ch := NextChar(InputText);
IF (ch ='+') OR (ch = '-') THEN
ch := inch();
END;
IF (ch >= '0') AND (ch <= '9') THEN
WHILE (ch >= '0') AND (ch <= '9') DO
ch := inch();
END;
IF (ch = '.') THEN
ch := inch();
IF (ch >= '0') AND (ch <= '9') THEN
WHILE (ch >= '0') AND (ch <= '9') DO
ch := inch();
END;
ELSE
ok := FALSE;
END;
END;
IF ok AND (ch = 'E') THEN
ch := inch();
IF (ch ='+') OR (ch = '-') THEN
ch := inch();
END;
IF (ch >= '0') AND (ch <= '9') THEN
WHILE (ch >= '0') AND (ch <= '9') DO
ch := inch();
END;
ELSE
ok := FALSE;
END;
END;
ELSE
ok := FALSE;
END;
IF ok THEN
buf[index] := 0C;
StringToLongReal(buf, real, ok);
END;
IF NOT ok THEN
Message("Illegal real");
HALT;
END;
END ReadLongReal;
PROCEDURE WriteCardinal(OutputText: Text; card: CARDINAL; width: CARDINAL);
VAR
buf : numbuf;
BEGIN
ConvertCardinal(card, 1, buf);
WriteString(OutputText, buf, width);
END WriteCardinal;
PROCEDURE WriteInteger(OutputText: Text; int: INTEGER; width: CARDINAL);
VAR
buf : numbuf;
BEGIN
ConvertInteger(int, 1, buf);
WriteString(OutputText, buf, width);
END WriteInteger;
PROCEDURE WriteBoolean(OutputText: Text; bool: BOOLEAN; width: CARDINAL);
BEGIN
IF bool THEN
WriteString(OutputText, " TRUE", width);
ELSE
WriteString(OutputText, "FALSE", width);
END;
END WriteBoolean;
PROCEDURE WriteReal(OutputText: Text; real: REAL; width, nfrac: CARDINAL);
BEGIN
WriteLongReal(OutputText, LONG(real), width, nfrac)
END WriteReal;
PROCEDURE WriteLongReal(OutputText: Text; real: LONGREAL; width, nfrac: CARDINAL);
VAR
buf: numbuf;
ok: BOOLEAN;
digits: INTEGER;
BEGIN
IF width > SIZE(buf) THEN
width := SIZE(buf);
END;
IF nfrac > 0 THEN
LongRealToString(real, width, nfrac, buf, ok);
ELSE
IF width < 9 THEN width := 9; END;
IF real < 0.0D THEN
digits := 7 - INTEGER(width);
ELSE
digits := 6 - INTEGER(width);
END;
LongRealToString(real, width, digits, buf, ok);
END;
WriteString(OutputText, buf, 0);
END WriteLongReal;
PROCEDURE WriteString(OutputText: Text; str: ARRAY OF CHAR; width: CARDINAL);
VAR index: CARDINAL;
BEGIN
index := 0;
WHILE (index <= HIGH(str)) AND (str[index] # Eos) DO
INC(index);
END;
WHILE index < width DO
WriteChar(OutputText, " ");
INC(index);
END;
index := 0;
WHILE (index <= HIGH(str)) AND (str[index] # Eos) DO
WriteChar(OutputText, str[index]);
INC(index);
END;
END WriteString;
BEGIN (* PascalIO initialization *)
WITH ibuf DO
stream := InputStream;
eof := FALSE;
type := Preading;
done := FALSE;
END;
WITH obuf DO
stream := OutputStream;
eof := FALSE;
type := Pwriting;
END;
Notext := NIL;
Input := ADR(ibuf);
Output := ADR(obuf);
Input^.next := Output;
Output^.next := NIL;
head := Input;
END PascalIO.

101
lib/libm2/Processes.mod Executable file
View File

@@ -0,0 +1,101 @@
(*$R-*)
IMPLEMENTATION MODULE Processes [1];
(*
Module: Processes
From: "Programming in Modula-2", 3rd, corrected edition, by N. Wirth
Version: $Header$
*)
FROM SYSTEM IMPORT ADDRESS, TSIZE, NEWPROCESS, TRANSFER;
FROM Storage IMPORT Allocate;
FROM Traps IMPORT Message;
TYPE SIGNAL = POINTER TO ProcessDescriptor;
ProcessDescriptor =
RECORD next: SIGNAL; (* ring *)
queue: SIGNAL; (* queue of waiting processes *)
cor: ADDRESS;
ready: BOOLEAN;
END;
VAR cp: SIGNAL; (* current process *)
PROCEDURE StartProcess(P: PROC; n: CARDINAL);
VAR s0: SIGNAL;
wsp: ADDRESS;
BEGIN
s0 := cp;
Allocate(wsp, n);
Allocate(cp, TSIZE(ProcessDescriptor));
WITH cp^ DO
next := s0^.next;
s0^.next := cp;
ready := TRUE;
queue := NIL
END;
NEWPROCESS(P, wsp, n, cp^.cor);
TRANSFER(s0^.cor, cp^.cor);
END StartProcess;
PROCEDURE SEND(VAR s: SIGNAL);
VAR s0: SIGNAL;
BEGIN
IF s # NIL THEN
s0 := cp;
cp := s;
WITH cp^ DO
s := queue;
ready := TRUE;
queue := NIL
END;
TRANSFER(s0^.cor, cp^.cor);
END
END SEND;
PROCEDURE WAIT(VAR s: SIGNAL);
VAR s0, s1: SIGNAL;
BEGIN
(* insert cp in queue s *)
IF s = NIL THEN
s := cp
ELSE
s0 := s;
s1 := s0^.queue;
WHILE s1 # NIL DO
s0 := s1;
s1 := s0^.queue
END;
s0^.queue := cp
END;
s0 := cp;
REPEAT
cp := cp^.next
UNTIL cp^.ready;
IF cp = s0 THEN
(* deadlock *)
Message("deadlock");
HALT
END;
s0^.ready := FALSE;
TRANSFER(s0^.cor, cp^.cor)
END WAIT;
PROCEDURE Awaited(s: SIGNAL): BOOLEAN;
BEGIN
RETURN s # NIL
END Awaited;
PROCEDURE Init(VAR s: SIGNAL);
BEGIN
s := NIL
END Init;
BEGIN
Allocate(cp, TSIZE(ProcessDescriptor));
WITH cp^ DO
next := cp;
ready := TRUE;
queue := NIL
END
END Processes.

337
lib/libm2/RealConver.mod Executable file
View File

@@ -0,0 +1,337 @@
(*
(c) copyright 1988 by the Vrije Universiteit, Amsterdam, The Netherlands.
See the copyright notice in the ACK home directory, in the file "Copyright".
*)
(*$R-*)
IMPLEMENTATION MODULE RealConversions;
(*
Module: string-to-real and real-to-string conversions
Author: Ceriel J.H. Jacobs
Version: $Header$
*)
PROCEDURE RealToString(arg: REAL;
width, digits: INTEGER;
VAR str: ARRAY OF CHAR;
VAR ok: BOOLEAN);
BEGIN
LongRealToString(LONG(arg), width, digits, str, ok);
END RealToString;
TYPE
Powers = RECORD
pval: LONGREAL;
rpval: LONGREAL;
exp: INTEGER
END;
VAR Powers10: ARRAY[1..6] OF Powers;
PROCEDURE LongRealToString(arg: LONGREAL;
width, digits: INTEGER;
VAR str: ARRAY OF CHAR;
VAR ok: BOOLEAN);
VAR pointpos: INTEGER;
i: CARDINAL;
ecvtflag: BOOLEAN;
r: LONGREAL;
ind1, ind2 : CARDINAL;
sign: BOOLEAN;
ndigits: CARDINAL;
BEGIN
r := arg;
IF digits < 0 THEN
ecvtflag := TRUE;
ndigits := -digits;
ELSE
ecvtflag := FALSE;
ndigits := digits;
END;
IF (HIGH(str) < ndigits + 3) THEN
str[0] := 0C; ok := FALSE; RETURN
END;
pointpos := 0;
sign := r < 0.0D;
IF sign THEN r := -r END;
ok := TRUE;
IF NOT (r / 10.0D < r) THEN
(* assume Nan or Infinity *)
r := 0.0D;
ok := FALSE;
END;
IF r # 0.0D THEN
IF r >= 10.0D THEN
FOR i := 1 TO 6 DO
WITH Powers10[i] DO
WHILE r >= pval DO
r := r * rpval;
INC(pointpos, exp)
END;
END;
END;
END;
IF r < 1.0D THEN
FOR i := 1 TO 6 DO
WITH Powers10[i] DO
WHILE r*pval < 10.0D DO
r := r * pval;
DEC(pointpos, exp)
END;
END;
END;
END;
(* Now, we have r in [1.0, 10.0) *)
INC(pointpos);
END;
ind1 := 0;
ind2 := ndigits+1;
IF NOT ecvtflag THEN
IF INTEGER(ind2) + pointpos <= 0 THEN
ind2 := 1;
ELSE
ind2 := INTEGER(ind2) + pointpos
END;
END;
IF ind2 > HIGH(str) THEN
ok := FALSE;
str[0] := 0C;
RETURN;
END;
WHILE ind1 < ind2 DO
str[ind1] := CHR(TRUNC(r)+ORD('0'));
r := 10.0D * (r - FLOATD(TRUNC(r)));
INC(ind1);
END;
IF ind2 > 0 THEN
DEC(ind2);
ind1 := ind2;
str[ind2] := CHR(ORD(str[ind2])+5);
WHILE str[ind2] > '9' DO
str[ind2] := '0';
IF ind2 > 0 THEN
DEC(ind2);
str[ind2] := CHR(ORD(str[ind2])+1);
ELSE
str[ind2] := '1';
INC(pointpos);
IF NOT ecvtflag THEN
IF ind1 > 0 THEN str[ind1] := '0'; END;
INC(ind1);
END;
END;
END;
IF (NOT ecvtflag) AND (ind1 = 0) THEN
str[0] := CHR(ORD(str[0])-5);
INC(ind1);
END;
END;
IF ecvtflag THEN
FOR i := ind1 TO 2 BY -1 DO
str[i] := str[i-1];
END;
str[1] := '.';
INC(ind1);
IF sign THEN
FOR i := ind1 TO 1 BY -1 DO
str[i] := str[i-1];
END;
INC(ind1);
str[0] := '-';
END;
IF (ind1 + 4) > HIGH(str) THEN
str[0] := 0C;
ok := FALSE;
RETURN;
END;
str[ind1] := 'E'; INC(ind1);
IF arg # 0.0D THEN DEC(pointpos); END;
IF pointpos < 0 THEN
pointpos := -pointpos;
str[ind1] := '-';
ELSE
str[ind1] := '+';
END;
INC(ind1);
str[ind1] := CHR(ORD('0') + CARDINAL(pointpos DIV 100));
pointpos := pointpos MOD 100;
INC(ind1);
str[ind1] := CHR(ORD('0') + CARDINAL(pointpos DIV 10));
INC(ind1);
str[ind1] := CHR(ORD('0') + CARDINAL(pointpos MOD 10));
ELSE
IF pointpos <= 0 THEN
FOR i := ind1 TO 1 BY -1 DO
str[i+CARDINAL(-pointpos)] := str[i-1];
END;
FOR i := 0 TO CARDINAL(-pointpos) DO
str[i] := '0';
END;
ind1 := ind1 + CARDINAL(1 - pointpos);
pointpos := 1;
END;
FOR i := ind1 TO CARDINAL(pointpos+1) BY -1 DO
str[i] := str[i-1];
END;
IF ndigits = 0 THEN
str[pointpos] := 0C;
ind1 := pointpos - 1;
ELSE
str[pointpos] := '.';
IF INTEGER(ind1) > pointpos+INTEGER(ndigits) THEN
ind1 := pointpos+INTEGER(ndigits);
END;
str[pointpos+INTEGER(ndigits)+1] := 0C;
END;
IF sign THEN
FOR i := ind1 TO 0 BY -1 DO
str[i+1] := str[i];
END;
str[0] := '-';
INC(ind1);
END;
END;
IF (ind1+1) <= HIGH(str) THEN str[ind1+1] := 0C; END;
IF ind1 >= CARDINAL(width) THEN
ok := FALSE;
RETURN;
END;
IF width > 0 THEN
DEC(width);
END;
IF (width > 0) AND (ind1 < CARDINAL(width)) THEN
FOR i := ind1 TO 0 BY -1 DO
str[i + CARDINAL(width) - ind1] := str[i];
END;
FOR i := 0 TO CARDINAL(width)-(ind1+1) DO
str[i] := ' ';
END;
ind1 := CARDINAL(width);
IF (ind1+1) <= HIGH(str) THEN
FOR ind1 := ind1+1 TO HIGH(str) DO
str[ind1] := 0C;
END;
END;
END;
END LongRealToString;
PROCEDURE StringToReal(str: ARRAY OF CHAR;
VAR r: REAL; VAR ok: BOOLEAN);
VAR x: LONGREAL;
BEGIN
StringToLongReal(str, x, ok);
IF ok THEN
r := x;
END;
END StringToReal;
PROCEDURE StringToLongReal(str: ARRAY OF CHAR;
VAR r: LONGREAL; VAR ok: BOOLEAN);
CONST BIG = 1.0D17;
TYPE SETOFCHAR = SET OF CHAR;
VAR pow10 : INTEGER;
i : INTEGER;
e : LONGREAL;
ch : CHAR;
signed: BOOLEAN;
signedexp: BOOLEAN;
iB: CARDINAL;
BEGIN
r := 0.0D;
pow10 := 0;
iB := 0;
ok := TRUE;
signed := FALSE;
WHILE (str[iB] = ' ') OR (str[iB] = CHR(9)) DO
INC(iB);
IF iB > HIGH(str) THEN
ok := FALSE;
RETURN;
END;
END;
IF str[iB] = '-' THEN signed := TRUE; INC(iB)
ELSIF str[iB] = '+' THEN INC(iB)
END;
ch := str[iB]; INC(iB);
IF NOT (ch IN SETOFCHAR{'0'..'9'}) THEN ok := FALSE; RETURN END;
REPEAT
IF r>BIG THEN INC(pow10) ELSE r:= 10.0D*r+FLOATD(ORD(ch)-ORD('0')) END;
IF iB <= HIGH(str) THEN
ch := str[iB]; INC(iB);
END;
UNTIL (iB > HIGH(str)) OR NOT (ch IN SETOFCHAR{'0'..'9'});
IF (ch = '.') AND (iB <= HIGH(str)) THEN
ch := str[iB]; INC(iB);
IF NOT (ch IN SETOFCHAR{'0'..'9'}) THEN ok := FALSE; RETURN END;
REPEAT
IF r < BIG THEN
r := 10.0D * r + FLOATD(ORD(ch)-ORD('0'));
DEC(pow10);
END;
IF iB <= HIGH(str) THEN
ch := str[iB]; INC(iB);
END;
UNTIL (iB > HIGH(str)) OR NOT (ch IN SETOFCHAR{'0'..'9'});
END;
IF (ch = 'E') THEN
IF iB > HIGH(str) THEN
ok := FALSE;
RETURN;
ELSE
ch := str[iB]; INC(iB);
END;
i := 0;
signedexp := FALSE;
IF (ch = '-') OR (ch = '+') THEN
signedexp := ch = '-';
IF iB > HIGH(str) THEN
ok := FALSE;
RETURN;
ELSE
ch := str[iB]; INC(iB);
END;
END;
IF NOT (ch IN SETOFCHAR{'0'..'9'}) THEN ok := FALSE; RETURN END;
REPEAT
i := i*10 + INTEGER(ORD(ch) - ORD('0'));
IF iB <= HIGH(str) THEN
ch := str[iB]; INC(iB);
END;
UNTIL (iB > HIGH(str)) OR NOT (ch IN SETOFCHAR{'0'..'9'});
IF signedexp THEN i := -i END;
pow10 := pow10 + i;
END;
IF pow10 < 0 THEN i := -pow10; ELSE i := pow10; END;
e := 1.0D;
DEC(i);
WHILE i >= 10 DO
e := e * 10000000000.0D;
DEC(i,10);
END;
WHILE i >= 0 DO
e := e * 10.0D;
DEC(i)
END;
IF pow10<0 THEN
r := r / e;
ELSE
r := r * e;
END;
IF signed THEN r := -r; END;
IF (iB <= HIGH(str)) AND (ORD(ch) > ORD(' ')) THEN ok := FALSE; END
END StringToLongReal;
BEGIN
WITH Powers10[1] DO pval := 1.0D32; rpval := 1.0D-32; exp := 32 END;
WITH Powers10[2] DO pval := 1.0D16; rpval := 1.0D-16; exp := 16 END;
WITH Powers10[3] DO pval := 1.0D8; rpval := 1.0D-8; exp := 8 END;
WITH Powers10[4] DO pval := 1.0D4; rpval := 1.0D-4; exp := 4 END;
WITH Powers10[5] DO pval := 1.0D2; rpval := 1.0D-2; exp := 2 END;
WITH Powers10[6] DO pval := 1.0D1; rpval := 1.0D-1; exp := 1 END;
END RealConversions.

97
lib/libm2/RealInOut.mod Executable file
View File

@@ -0,0 +1,97 @@
(*
(c) copyright 1988 by the Vrije Universiteit, Amsterdam, The Netherlands.
See the copyright notice in the ACK home directory, in the file "Copyright".
*)
(*$R-*)
IMPLEMENTATION MODULE RealInOut;
(*
Module: InOut for REAL numbers
Author: Ceriel J.H. Jacobs
Version: $Header$
*)
FROM InOut IMPORT ReadString, WriteString, WriteOct;
FROM Traps IMPORT Message;
FROM SYSTEM IMPORT WORD;
FROM RealConversions IMPORT
LongRealToString, StringToLongReal;
CONST MAXNDIG = 32;
MAXWIDTH = MAXNDIG+7;
TYPE RBUF = ARRAY [0..MAXWIDTH+1] OF CHAR;
PROCEDURE WriteReal(arg: REAL; ndigits: CARDINAL);
BEGIN
WriteLongReal(LONG(arg), ndigits)
END WriteReal;
PROCEDURE WriteLongReal(arg: LONGREAL; ndigits: CARDINAL);
VAR buf : RBUF;
ok : BOOLEAN;
BEGIN
IF ndigits > MAXWIDTH THEN ndigits := MAXWIDTH; END;
IF ndigits < 10 THEN ndigits := 10; END;
LongRealToString(arg, ndigits, -INTEGER(ndigits - 7), buf, ok);
WriteString(buf);
END WriteLongReal;
PROCEDURE WriteFixPt(arg: REAL; n, k: CARDINAL);
BEGIN
WriteLongFixPt(LONG(arg), n, k)
END WriteFixPt;
PROCEDURE WriteLongFixPt(arg: LONGREAL; n, k: CARDINAL);
VAR buf: RBUF;
ok : BOOLEAN;
BEGIN
IF n > MAXWIDTH THEN n := MAXWIDTH END;
LongRealToString(arg, n, k, buf, ok);
WriteString(buf);
END WriteLongFixPt;
PROCEDURE ReadReal(VAR x: REAL);
VAR x1: LONGREAL;
BEGIN
ReadLongReal(x1);
x := x1
END ReadReal;
PROCEDURE ReadLongReal(VAR x: LONGREAL);
VAR Buf: ARRAY[0..512] OF CHAR;
ok: BOOLEAN;
BEGIN
ReadString(Buf);
StringToLongReal(Buf, x, ok);
IF NOT ok THEN
Message("real expected");
HALT;
END;
Done := TRUE;
END ReadLongReal;
PROCEDURE wroct(x: ARRAY OF WORD);
VAR i: CARDINAL;
BEGIN
FOR i := 0 TO HIGH(x) DO
WriteOct(CARDINAL(x[i]), 0);
WriteString(" ");
END;
END wroct;
PROCEDURE WriteRealOct(x: REAL);
BEGIN
wroct(x);
END WriteRealOct;
PROCEDURE WriteLongRealOct(x: LONGREAL);
BEGIN
wroct(x);
END WriteLongRealOct;
BEGIN
Done := FALSE;
END RealInOut.

115
lib/libm2/SYSTEM.c Executable file
View File

@@ -0,0 +1,115 @@
/*
(c) copyright 1988 by the Vrije Universiteit, Amsterdam, The Netherlands.
See the copyright notice in the ACK home directory, in the file "Copyright".
*/
/*
Module: SYSTEM
Author: Ceriel J.H. Jacobs
Version: $Header$
*/
/*
An implementation of the Modula-2 NEWPROCESS and TRANSFER facilities
using the topsize, topsave, and topload facilities.
For each coroutine, a proc structure is built. For the main routine,
a static space is declared to save its stack. For the other coroutines,
the user specifies this space.
*/
#include <m2_traps.h>
#define MAXMAIN 2048
struct proc {
unsigned size; /* size of saved stackframe(s) */
int (*proc)(); /* address of coroutine procedure */
char *brk; /* stack break of this coroutine */
};
extern unsigned topsize();
static struct proc mainproc[MAXMAIN/sizeof(struct proc) + 1];
static struct proc *curproc = 0;/* current coroutine */
extern char *MainLB; /* stack break of main routine */
_SYSTEM__NEWPROCESS(p, a, n, p1)
int (*p)(); /* coroutine procedure */
struct proc *a; /* pointer to area for saved stack-frame */
unsigned n; /* size of this area */
struct proc **p1; /* where to leave coroutine descriptor,
in this implementation the address of
the area for saved stack-frame(s) */
{
/* This procedure creates a new coroutine, but does not
transfer control to it. The routine "topsize" will compute the
stack break, which will be the local base of this routine.
Notice that we can do this because we do not need the stack
above this point for this coroutine. In Modula-2, coroutines
must be level 0 procedures without parameters.
*/
char *brk = 0;
unsigned sz = topsize(&brk);
if (sz + sizeof(struct proc) > n) {
/* not enough space */
TRP(M2_TOOLARGE);
}
a->size = n;
a->proc = p;
a->brk = brk;
*p1 = a;
if (topsave(brk, a+1))
/* stack frame saved; now just return */
;
else {
/* We get here through the first transfer to the coroutine
created above.
This also means that curproc is now set to this coroutine.
We cannot trust the parameters anymore.
Just call the coroutine procedure.
*/
(*(curproc->proc))();
_cleanup();
_exit(0);
}
}
_SYSTEM__TRANSFER(a, b)
struct proc **a, **b;
{
/* transfer from one coroutine to another, saving the current
descriptor in the space indicated by "a", and transfering to
the coroutine in descriptor "b".
*/
unsigned size;
if (! curproc) {
/* the current coroutine is the main process;
initialize a coroutine descriptor for it ...
*/
mainproc[0].brk = MainLB;
mainproc[0].size = sizeof(mainproc);
curproc = &mainproc[0];
}
*a = curproc; /* save current descriptor in "a" */
if (*b == curproc) {
/* transfer to itself is a no-op */
return;
}
size = topsize(&(curproc->brk));
if (size + sizeof(struct proc) > curproc->size) {
TRP(M2_TOOLARGE);
}
if (topsave(curproc->brk, curproc+1)) {
/* stack top saved. Now restore context of target
coroutine
*/
curproc = *b;
topload(curproc+1);
/* we never get here ... */
}
/* but we do get here, when a transfer is done to the coroutine in "a".
*/
}

118
lib/libm2/Semaphores.mod Executable file
View File

@@ -0,0 +1,118 @@
(*
(c) copyright 1988 by the Vrije Universiteit, Amsterdam, The Netherlands.
See the copyright notice in the ACK home directory, in the file "Copyright".
*)
(*$R-*)
IMPLEMENTATION MODULE Semaphores [1];
(*
Module: Processes with semaphores
Author: Ceriel J.H. Jacobs
Version: $Header$
Quasi-concurrency implementation
*)
FROM SYSTEM IMPORT ADDRESS, NEWPROCESS, TRANSFER;
FROM Storage IMPORT Allocate;
FROM random IMPORT Uniform;
FROM Traps IMPORT Message;
TYPE Sema = POINTER TO Semaphore;
Processes = POINTER TO Process;
Semaphore =
RECORD
level: CARDINAL;
END;
Process =
RECORD next: Processes;
proc: ADDRESS;
waiting: Sema;
END;
VAR cp: Processes; (* current process *)
PROCEDURE StartProcess(P: PROC; n: CARDINAL);
VAR s0: Processes;
wsp: ADDRESS;
BEGIN
s0 := cp;
Allocate(wsp, n);
Allocate(cp, SIZE(Process));
WITH cp^ DO
next := s0^.next;
s0^.next := cp;
waiting := NIL;
END;
NEWPROCESS(P, wsp, n, cp^.proc);
TRANSFER(s0^.proc, cp^.proc);
END StartProcess;
PROCEDURE Up(VAR s: Sema);
BEGIN
s^.level := s^.level + 1;
ReSchedule;
END Up;
PROCEDURE Down(VAR s: Sema);
BEGIN
IF s^.level = 0 THEN
cp^.waiting := s;
ELSE
s^.level := s^.level - 1;
END;
ReSchedule;
END Down;
PROCEDURE NewSema(n: CARDINAL): Sema;
VAR s: Sema;
BEGIN
Allocate(s, SIZE(Semaphore));
s^.level := n;
RETURN s;
END NewSema;
PROCEDURE Level(s: Sema): CARDINAL;
BEGIN
RETURN s^.level;
END Level;
PROCEDURE ReSchedule;
VAR s0: Processes;
i, j: CARDINAL;
BEGIN
s0 := cp;
i := Uniform(1, 5);
j := i;
LOOP
cp := cp^.next;
IF Runnable(cp) THEN
DEC(i);
IF i = 0 THEN EXIT END;
END;
IF (cp = s0) AND (j = i) THEN
(* deadlock *)
Message("deadlock");
HALT
END;
END;
IF cp # s0 THEN TRANSFER(s0^.proc, cp^.proc); END;
END ReSchedule;
PROCEDURE Runnable(p: Processes): BOOLEAN;
BEGIN
IF p^.waiting = NIL THEN RETURN TRUE; END;
IF p^.waiting^.level > 0 THEN
p^.waiting^.level := p^.waiting^.level - 1;
p^.waiting := NIL;
RETURN TRUE;
END;
RETURN FALSE;
END Runnable;
BEGIN
Allocate(cp, SIZE(Process));
WITH cp^ DO
next := cp;
waiting := NIL;
END
END Semaphores.

353
lib/libm2/Storage.mod Executable file
View File

@@ -0,0 +1,353 @@
(*
(c) copyright 1988 by the Vrije Universiteit, Amsterdam, The Netherlands.
See the copyright notice in the ACK home directory, in the file "Copyright".
*)
(*$R-*)
IMPLEMENTATION MODULE Storage;
(*
Module: Dynamic Storage Allocation
Author: Ceriel J.H. Jacobs
Adapted from a version in C by Hans Tebra
Version: $Header$
*)
(* This storage manager maintains an array of lists of objects with the
same size. Commonly used sizes have their own bucket. The larger ones
are put in a single list.
*)
FROM Unix IMPORT sbrk, ILLBREAK;
FROM SYSTEM IMPORT ADDRESS, ADR;
FROM Traps IMPORT Message;
CONST
NLISTS = 20;
MAGICW = 0A5A5H;
MAGICC = 175C;
TYPE
ALIGNTYPE =
RECORD
CASE : INTEGER OF
1: l: LONGINT |
2: p: ADDRESS |
3: d: LONGREAL
END
END; (* A type with high alignment requirements *)
BucketPtr = POINTER TO Bucket;
Bucket =
RECORD
CASE : BOOLEAN OF
FALSE:
BNEXT: BucketPtr; (* next free Bucket *)
BSIZE: CARDINAL; | (* size of user part in UNITs *)
TRUE: BXX: ALIGNTYPE
END;
BSTORE: ALIGNTYPE;
END;
CONST
UNIT = SIZE(ALIGNTYPE);
VAR
FreeLists: ARRAY[0..NLISTS] OF BucketPtr; (* small blocks *)
Llist: BucketPtr; (* others *)
Compacted: BOOLEAN; (* avoid recursive reorganization *)
FirstBlock: BucketPtr;
USED: ADDRESS;
PROCEDURE MyAllocate(size: CARDINAL) : ADDRESS;
VAR nu : CARDINAL;
b : CARDINAL;
p, q: BucketPtr;
pc: POINTER TO CHAR;
brk : ADDRESS;
BEGIN
IF size > CARDINAL(MAX(INTEGER)-2*UNIT + 1) THEN
RETURN NIL;
END;
nu := (size + (UNIT-1)) DIV UNIT;
IF nu = 0 THEN
nu := 1;
END;
IF nu <= NLISTS THEN
b := nu;
IF FreeLists[b] # NIL THEN
(* Exact fit *)
p := FreeLists[b];
FreeLists[b] := p^.BNEXT;
p^.BNEXT := USED;
IF p^.BSIZE * UNIT # size THEN
pc := ADR(p^.BSTORE) + size;
pc^ := MAGICC;
END;
p^.BSIZE := size;
RETURN ADR(p^.BSTORE);
END;
(* Search for a block with >= 2 units more than requested.
We pay for an additional header when the block is split.
*)
FOR b := b+2 TO NLISTS DO
IF FreeLists[b] # NIL THEN
q := FreeLists[b];
FreeLists[b] := q^.BNEXT;
p := ADDRESS(q) + (nu+1)*UNIT;
(* p indicates the block that must be given
back
*)
p^.BSIZE := q^.BSIZE - nu - 1;
p^.BNEXT := FreeLists[p^.BSIZE];
FreeLists[p^.BSIZE] := p;
q^.BSIZE := nu;
q^.BNEXT := USED;
IF q^.BSIZE * UNIT # size THEN
pc := ADR(q^.BSTORE) + size;
pc^ := MAGICC;
END;
q^.BSIZE := size;
RETURN ADR(q^.BSTORE);
END;
END;
END;
p := Llist;
IF p # NIL THEN
q := NIL;
WHILE (p # NIL) AND (p^.BSIZE < nu) DO
q := p;
p := p^.BNEXT;
END;
IF p # NIL THEN
(* p^.BSIZE >= nu *)
IF p^.BSIZE <= nu + NLISTS + 1 THEN
(* Remove p from this list *)
IF q # NIL THEN q^.BNEXT := p^.BNEXT
ELSE Llist := p^.BNEXT;
END;
p^.BNEXT := USED;
IF p^.BSIZE > nu + 1 THEN
(* split block,
tail goes to FreeLists area
*)
q := ADDRESS(p) + (nu+1)*UNIT;
q^.BSIZE := p^.BSIZE -nu -1;
q^.BNEXT := FreeLists[q^.BSIZE];
FreeLists[q^.BSIZE] := q;
p^.BSIZE := nu;
END;
IF p^.BSIZE * UNIT # size THEN
pc := ADR(p^.BSTORE) + size;
pc^ := MAGICC;
END;
p^.BSIZE := size;
RETURN ADR(p^.BSTORE);
END;
(* Give part of tail of original block.
Block stays in this list.
*)
q := ADDRESS(p) + (p^.BSIZE-nu)*UNIT;
q^.BSIZE := nu;
p^.BSIZE := p^.BSIZE - nu - 1;
q^.BNEXT := USED;
IF q^.BSIZE * UNIT # size THEN
pc := ADR(q^.BSTORE) + size;
pc^ := MAGICC;
END;
q^.BSIZE := size;
RETURN ADR(q^.BSTORE);
END;
END;
IF Compacted THEN
(* reorganization did not yield sufficient memory *)
RETURN NIL;
END;
brk := sbrk(UNIT * (nu + 1));
IF brk = ILLBREAK THEN
ReOrganize();
Compacted := TRUE;
brk := MyAllocate(size);
Compacted := FALSE;
RETURN brk;
END;
p := brk;
p^.BSIZE := nu;
p^.BNEXT := USED;
IF p^.BSIZE * UNIT # size THEN
pc := ADR(p^.BSTORE) + size;
pc^ := MAGICC;
END;
p^.BSIZE := size;
RETURN ADR(p^.BSTORE);
END MyAllocate;
PROCEDURE ALLOCATE(VAR a: ADDRESS; size: CARDINAL);
BEGIN
Allocate(a, size);
END ALLOCATE;
PROCEDURE Allocate(VAR a: ADDRESS; size: CARDINAL);
BEGIN
a := MyAllocate(size);
IF a = NIL THEN
Message("out of core");
HALT;
END;
END Allocate;
PROCEDURE Available(size: CARDINAL): BOOLEAN;
VAR a: ADDRESS;
BEGIN
a:= MyAllocate(size);
IF a # NIL THEN
Deallocate(a, size);
RETURN TRUE;
END;
RETURN FALSE;
END Available;
PROCEDURE DEALLOCATE(VAR a: ADDRESS; size: CARDINAL);
BEGIN
Deallocate(a, size);
END DEALLOCATE;
PROCEDURE Deallocate(VAR a: ADDRESS; size: CARDINAL);
VAR p: BucketPtr;
pc: POINTER TO CHAR;
BEGIN
IF (a = NIL) THEN
Message("(Warning) Deallocate: NIL pointer deallocated");
RETURN;
END;
p := a - UNIT;
IF (p^.BNEXT # BucketPtr(USED)) THEN
Message("(Warning) Deallocate: area already deallocated or heap corrupted");
a := NIL;
RETURN;
END;
WITH p^ DO
IF BSIZE # size THEN
Message("(Warning) Deallocate: wrong size or heap corrupted");
END;
BSIZE := (size + (UNIT - 1)) DIV UNIT;
IF (BSIZE*UNIT # size) THEN
pc := a + size;
IF pc^ # MAGICC THEN
Message("(Warning) Deallocate: heap corrupted");
END;
END;
IF BSIZE <= NLISTS THEN
BNEXT := FreeLists[BSIZE];
FreeLists[BSIZE] := p;
ELSE
BNEXT := Llist;
Llist := p;
END;
END;
a := NIL
END Deallocate;
PROCEDURE ReOrganize();
VAR lastblock: BucketPtr;
b, be: BucketPtr;
i: CARDINAL;
BEGIN
lastblock := NIL;
FOR i := 1 TO NLISTS DO
b := FreeLists[i];
WHILE b # NIL DO
IF ADDRESS(b) > ADDRESS(lastblock) THEN
lastblock := b;
END;
be := b^.BNEXT;
b^.BNEXT := NIL; (* temporary free mark *)
b := be;
END;
END;
b := Llist;
WHILE b # NIL DO
IF ADDRESS(b) > ADDRESS(lastblock) THEN
lastblock := b;
END;
be := b^.BNEXT;
b^.BNEXT := NIL;
b := be;
END;
(* Now, all free blocks have b^.BNEXT = NIL *)
b := FirstBlock;
WHILE ADDRESS(b) < ADDRESS(lastblock) DO
LOOP
be := ADDRESS(b)+(b^.BSIZE+1)*UNIT;
IF b^.BNEXT # NIL THEN
(* this block is not free *)
EXIT;
END;
IF ADDRESS(be) > ADDRESS(lastblock) THEN
(* no next block *)
EXIT;
END;
IF be^.BNEXT # NIL THEN
(* next block is not free *)
EXIT;
END;
(* this block and the next one are free,
so merge them, but only if it is not too big
*)
IF MAX(CARDINAL) - b^.BSIZE > be^.BSIZE THEN
b^.BSIZE := b^.BSIZE + be^.BSIZE + 1;
ELSE
EXIT;
END;
END;
b := be;
END;
(* clear all free lists *)
FOR i := 1 TO NLISTS DO FreeLists[i] := NIL; END;
Llist := NIL;
(* collect free blocks in them again *)
b := FirstBlock;
WHILE ADDRESS(b) <= ADDRESS(lastblock) DO
WITH b^ DO
IF BNEXT = NIL THEN
IF BSIZE <= NLISTS THEN
BNEXT := FreeLists[BSIZE];
FreeLists[BSIZE] := b;
ELSE
BNEXT := Llist;
Llist := b;
END;
b := ADDRESS(b) + (BSIZE+1) * UNIT;
ELSE
b := ADDRESS(b) +
((BSIZE + (UNIT - 1)) DIV UNIT + 1) * UNIT;
END;
END;
END;
END ReOrganize;
PROCEDURE InitStorage();
VAR i: CARDINAL;
brk: ADDRESS;
BEGIN
FOR i := 1 TO NLISTS DO
FreeLists[i] := NIL;
END;
Llist := NIL;
brk := sbrk(0);
brk := sbrk(UNIT - brk MOD UNIT);
FirstBlock := sbrk(0);
Compacted := FALSE;
USED := MAGICW;
END InitStorage;
BEGIN
InitStorage();
END Storage.

23
lib/libm2/StrAss.c Executable file
View File

@@ -0,0 +1,23 @@
/*
(c) copyright 1988 by the Vrije Universiteit, Amsterdam, The Netherlands.
See the copyright notice in the ACK home directory, in the file "Copyright".
*/
/*
Module: assign string to character array, with possible 0-byte
extension
Author: Ceriel J.H. Jacobs
Version: $Header$
*/
StringAssign(dstsiz, srcsiz, dstaddr, srcaddr)
register char *dstaddr, *srcaddr;
{
while (srcsiz > 0) {
*dstaddr++ = *srcaddr++;
srcsiz--;
dstsiz--;
}
if (dstsiz > 0) {
*dstaddr = 0;
}
}

443
lib/libm2/Streams.mod Executable file
View File

@@ -0,0 +1,443 @@
#
(*
(c) copyright 1988 by the Vrije Universiteit, Amsterdam, The Netherlands.
See the copyright notice in the ACK home directory, in the file "Copyright".
*)
(*$R-*)
IMPLEMENTATION MODULE Streams;
(*
Module: Stream Input/Output
Author: Ceriel J.H. Jacobs
Version: $Header$
Implementation for Unix
*)
FROM SYSTEM IMPORT BYTE, ADR;
FROM Epilogue IMPORT CallAtEnd;
FROM Storage IMPORT Allocate, Available;
FROM StripUnix IMPORT
open, close, lseek, read, write, creat;
IMPORT StripUnix;
CONST BUFSIZ = 1024; (* tunable *)
TYPE IOB = RECORD
kind: StreamKind;
mode: StreamMode;
eof: BOOLEAN;
buffering: StreamBuffering;
next : Stream;
fildes: INTEGER;
cnt, maxcnt: INTEGER;
bufferedcnt: INTEGER;
buf: ARRAY[1..BUFSIZ] OF BYTE;
END;
Stream = POINTER TO IOB;
VAR
ibuf, obuf, ebuf: IOB;
head: Stream;
PROCEDURE getstruct(VAR stream: Stream);
BEGIN
stream := head;
WHILE (stream # NIL) AND (stream^.kind # none) DO
stream := stream^.next;
END;
IF stream = NIL THEN
IF NOT Available(SIZE(IOB)) THEN
RETURN;
END;
Allocate(stream,SIZE(IOB));
stream^.next := head;
head := stream;
END;
END getstruct;
PROCEDURE freestruct(stream: Stream);
BEGIN
stream^.kind := none;
END freestruct;
PROCEDURE OpenStream(VAR stream: Stream;
filename: ARRAY OF CHAR;
kind: StreamKind;
mode: StreamMode;
VAR result: StreamResult);
VAR fd: INTEGER;
i: CARDINAL;
BEGIN
IF kind = none THEN
result := illegaloperation;
RETURN;
END;
getstruct(stream);
IF stream = NIL THEN
result := nomemory;
RETURN;
END;
WITH stream^ DO
FOR i := 0 TO HIGH(filename) DO
buf[i+1] := BYTE(filename[i]);
END;
buf[HIGH(filename)+2] := BYTE(0C);
END;
IF (mode = reading) THEN
fd := open(ADR(stream^.buf), 0);
ELSE
fd := -1;
IF (mode = appending) THEN
fd := open(ADR(stream^.buf), 1);
IF fd >= 0 THEN
IF (lseek(fd, 0D , 2) < 0D) THEN ; END;
END;
END;
IF fd < 0 THEN
fd := creat(ADR(stream^.buf), 666B);
END;
END;
IF fd < 0 THEN
result := openfailed;
freestruct(stream);
stream := NIL;
RETURN;
END;
result := succeeded;
stream^.fildes := fd;
stream^.kind := kind;
stream^.mode := mode;
stream^.buffering := blockbuffered;
stream^.bufferedcnt := BUFSIZ;
stream^.maxcnt := 0;
stream^.eof := FALSE;
IF mode = reading THEN
stream^.cnt := 1;
ELSE
stream^.cnt := 0;
END;
END OpenStream;
PROCEDURE SetStreamBuffering( stream: Stream;
b: StreamBuffering;
VAR result: StreamResult);
BEGIN
result := succeeded;
IF (stream = NIL) OR (stream^.kind = none) THEN
result := nostream;
RETURN;
END;
IF (stream^.mode = reading) OR
((b = linebuffered) AND (stream^.kind = binary)) THEN
result := illegaloperation;
RETURN;
END;
FlushStream(stream, result);
IF b = unbuffered THEN
stream^.bufferedcnt := 1;
END;
stream^.buffering := b;
END SetStreamBuffering;
PROCEDURE FlushStream(stream: Stream; VAR result: StreamResult);
VAR cnt1: INTEGER;
BEGIN
result := succeeded;
IF (stream = NIL) OR (stream^.kind = none) THEN
result := nostream;
RETURN;
END;
WITH stream^ DO
IF mode = reading THEN
result := illegaloperation;
RETURN;
END;
IF (cnt > 0) THEN
cnt1 := cnt;
cnt := 0;
IF write(fildes, ADR(buf), cnt1) < 0 THEN END;
END;
END;
END FlushStream;
PROCEDURE CloseStream(VAR stream: Stream; VAR result: StreamResult);
BEGIN
IF (stream # NIL) AND (stream^.kind # none) THEN
result := succeeded;
IF stream^.mode # reading THEN
FlushStream(stream, result);
END;
IF close(stream^.fildes) < 0 THEN ; END;
freestruct(stream);
ELSE
result := nostream;
END;
stream := NIL;
END CloseStream;
PROCEDURE EndOfStream(stream: Stream; VAR result: StreamResult): BOOLEAN;
BEGIN
result := succeeded;
IF (stream = NIL) OR (stream^.kind = none) THEN
result := nostream;
RETURN FALSE;
END;
IF stream^.mode # reading THEN
result := illegaloperation;
RETURN FALSE;
END;
IF stream^.eof THEN RETURN TRUE; END;
RETURN (CHAR(NextByte(stream)) = 0C) AND stream^.eof;
END EndOfStream;
PROCEDURE FlushLineBuffers();
VAR s: Stream;
result: StreamResult;
BEGIN
s := head;
WHILE s # NIL DO
IF (s^.kind # none) AND (s^.buffering = linebuffered) THEN
FlushStream(s, result);
END;
s := s^.next;
END;
END FlushLineBuffers;
PROCEDURE NextByte(stream: Stream): BYTE;
VAR c: BYTE;
BEGIN
WITH stream^ DO
IF cnt <= maxcnt THEN
c := buf[cnt];
ELSE
IF eof THEN RETURN BYTE(0C); END;
IF stream = InputStream THEN
FlushLineBuffers();
END;
maxcnt := read(fildes, ADR(buf), bufferedcnt);
cnt := 1;
IF maxcnt <= 0 THEN
eof := TRUE;
c := BYTE(0C);
ELSE
c := buf[1];
END;
END;
END;
RETURN c;
END NextByte;
PROCEDURE Read(stream: Stream; VAR ch: CHAR; VAR result: StreamResult);
VAR EoF: BOOLEAN;
BEGIN
ch := 0C;
EoF := EndOfStream(stream, result);
IF result # succeeded THEN RETURN; END;
IF EoF THEN
result := endoffile;
RETURN;
END;
WITH stream^ DO
ch := CHAR(buf[cnt]);
INC(cnt);
END;
END Read;
PROCEDURE ReadByte(stream: Stream; VAR byte: BYTE; VAR result: StreamResult);
VAR EoF: BOOLEAN;
BEGIN
byte := BYTE(0C);
EoF := EndOfStream(stream, result);
IF result # succeeded THEN RETURN; END;
IF EoF THEN
result := endoffile;
RETURN;
END;
WITH stream^ DO
byte := buf[cnt];
INC(cnt);
END;
END ReadByte;
PROCEDURE ReadBytes(stream: Stream;
VAR bytes: ARRAY OF BYTE;
VAR result: StreamResult);
VAR i: CARDINAL;
BEGIN
FOR i := 0 TO HIGH(bytes) DO
ReadByte(stream, bytes[i], result);
END;
END ReadBytes;
PROCEDURE Write(stream: Stream; ch: CHAR; VAR result: StreamResult);
BEGIN
IF (stream = NIL) OR (stream^.kind = none) THEN
result := nostream;
RETURN;
END;
IF (stream^.kind # text) OR (stream^.mode = reading) THEN
result := illegaloperation;
RETURN;
END;
WITH stream^ DO
INC(cnt);
buf[cnt] := BYTE(ch);
IF (cnt >= bufferedcnt) OR
((ch = 12C) AND (buffering = linebuffered))
THEN
FlushStream(stream, result);
END;
END;
END Write;
PROCEDURE WriteByte(stream: Stream; byte: BYTE; VAR result: StreamResult);
BEGIN
IF (stream = NIL) OR (stream^.kind = none) THEN
result := nostream;
RETURN;
END;
IF (stream^.kind # binary) OR (stream^.mode = reading) THEN
result := illegaloperation;
RETURN;
END;
WITH stream^ DO
INC(cnt);
buf[cnt] := byte;
IF cnt >= bufferedcnt THEN
FlushStream(stream, result);
END;
END;
END WriteByte;
PROCEDURE WriteBytes(stream: Stream; bytes: ARRAY OF BYTE; VAR result: StreamResult);
VAR i: CARDINAL;
BEGIN
FOR i := 0 TO HIGH(bytes) DO
WriteByte(stream, bytes[i], result);
END;
END WriteBytes;
PROCEDURE EndIt;
VAR h, h1 : Stream;
result: StreamResult;
BEGIN
h := head;
WHILE h # NIL DO
h1 := h;
CloseStream(h1, result);
h := h^.next;
END;
END EndIt;
PROCEDURE GetPosition(s: Stream; VAR position: LONGINT;
VAR result: StreamResult);
BEGIN
IF (s = NIL) OR (s^.kind = none) THEN
result := illegaloperation;
RETURN;
END;
IF (s^.mode # reading) THEN FlushStream(s, result); END;
position := lseek(s^.fildes, 0D, 1);
IF position < 0D THEN
result := illegaloperation;
RETURN;
END;
IF s^.mode = reading THEN
position := position + LONG(s^.maxcnt - s^.cnt + 1);
END;
END GetPosition;
PROCEDURE SetPosition(s: Stream; position: LONGINT; VAR result: StreamResult);
VAR currpos: LONGINT;
BEGIN
currpos := 0D;
IF (s = NIL) OR (s^.kind = none) THEN
result := nostream;
RETURN;
END;
IF (s^.mode # reading) THEN
FlushStream(s, result);
ELSE
s^.maxcnt := 0;
s^.eof := FALSE;
END;
IF s^.mode = appending THEN
currpos := lseek(s^.fildes, 0D, 1);
IF currpos < 0D THEN
result := illegaloperation;
RETURN;
END;
END;
IF position < currpos THEN
result := illegaloperation;
RETURN;
END;
currpos := lseek(s^.fildes, position, 0);
IF currpos < 0D THEN
result := illegaloperation;
RETURN;
END;
result := succeeded;
END SetPosition;
PROCEDURE isatty(stream: Stream; VAR result: StreamResult): BOOLEAN;
BEGIN
IF (stream = NIL) OR (stream^.kind = none) THEN
result := nostream;
RETURN FALSE;
END;
RETURN StripUnix.isatty(stream^.fildes);
END isatty;
PROCEDURE InitStreams;
VAR result: StreamResult;
BEGIN
InputStream := ADR(ibuf);
OutputStream := ADR(obuf);
ErrorStream := ADR(ebuf);
WITH ibuf DO
kind := text;
mode := reading;
eof := FALSE;
next := ADR(obuf);
fildes := 0;
maxcnt := 0;
cnt := 1;
bufferedcnt := BUFSIZ;
END;
WITH obuf DO
kind := text;
mode := writing;
eof := TRUE;
next := ADR(ebuf);
fildes := 1;
maxcnt := 0;
cnt := 0;
bufferedcnt := BUFSIZ;
IF isatty(OutputStream, result) THEN
buffering := linebuffered;
ELSE
buffering := blockbuffered;
END;
END;
WITH ebuf DO
kind := text;
mode := writing;
eof := TRUE;
next := NIL;
fildes := 2;
maxcnt := 0;
cnt := 0;
bufferedcnt := BUFSIZ;
IF isatty(ErrorStream, result) THEN
buffering := linebuffered;
ELSE
buffering := blockbuffered;
END;
END;
head := InputStream;
IF CallAtEnd(EndIt) THEN ; END;
END InitStreams;
BEGIN
InitStreams
END Streams.

171
lib/libm2/Strings.mod Executable file
View File

@@ -0,0 +1,171 @@
(*
(c) copyright 1988 by the Vrije Universiteit, Amsterdam, The Netherlands.
See the copyright notice in the ACK home directory, in the file "Copyright".
*)
(*$R-*)
IMPLEMENTATION MODULE Strings;
(*
Module: String manipulations
Author: Ceriel J.H. Jacobs
Version: $Header$
*)
PROCEDURE Assign(source: ARRAY OF CHAR; VAR dest: ARRAY OF CHAR);
(* Assign string source to dest
*)
VAR i: CARDINAL;
max: CARDINAL;
BEGIN
max := HIGH(source);
IF HIGH(dest) < max THEN max := HIGH(dest); END;
i := 0;
WHILE (i <= max) AND (source[i] # 0C) DO
dest[i] := source[i];
INC(i);
END;
IF i < HIGH(dest) THEN dest[i] := 0C; END;
END Assign;
PROCEDURE Insert(substr: ARRAY OF CHAR; VAR str: ARRAY OF CHAR; inx: CARDINAL);
(* Insert the string substr into str, starting at str[inx].
If inx is equal to or greater than Length(str) then substr is appended
to the end of str.
*)
VAR sublen, length, i: CARDINAL;
BEGIN
sublen := Length(substr);
IF sublen = 0 THEN RETURN; END;
length := Length(str);
IF inx > length THEN inx := length; END;
i := length;
IF i + sublen - 1 > HIGH(str) THEN i := HIGH(str); END;
WHILE i > inx DO
str[i+sublen-1] := str[i-1];
DEC(i);
END;
FOR i := 0 TO sublen - 1 DO
IF i + inx <= HIGH(str) THEN
str[i + inx] := substr[i];
ELSE
RETURN;
END;
END;
IF length + sublen <= HIGH(str) THEN
str[length + sublen] := 0C;
END;
END Insert;
PROCEDURE Delete(VAR str: ARRAY OF CHAR; inx, len: CARDINAL);
(* Delete len characters from str, starting at str[inx].
If inx >= Length(str) then nothing happens.
If there are not len characters to delete, characters to the end of the
string are deleted.
*)
VAR length: CARDINAL;
BEGIN
IF len = 0 THEN RETURN; END;
length := Length(str);
IF inx >= length THEN RETURN; END;
WHILE inx + len < length DO
str[inx] := str[inx + len];
INC(inx);
END;
str[inx] := 0C;
END Delete;
PROCEDURE Pos(substr, str: ARRAY OF CHAR): CARDINAL;
(* Return the index into str of the first occurrence of substr.
Pos returns a value greater than HIGH(str) of no occurrence is found.
*)
VAR i, j, max, subl: CARDINAL;
BEGIN
max := Length(str);
subl := Length(substr);
IF subl > max THEN RETURN HIGH(str) + 1; END;
IF subl = 0 THEN RETURN 0; END;
max := max - subl;
FOR i := 0 TO max DO
j := 0;
WHILE (j <= subl-1) AND (str[i+j] = substr[j]) DO
INC(j);
END;
IF j = subl THEN RETURN i; END;
END;
RETURN HIGH(str) + 1;
END Pos;
PROCEDURE Copy(str: ARRAY OF CHAR;
inx, len: CARDINAL;
VAR result: ARRAY OF CHAR);
(* Copy at most len characters from str into result, starting at str[inx].
*)
VAR i: CARDINAL;
BEGIN
IF Length(str) <= inx THEN RETURN END;
i := 0;
LOOP
IF i > HIGH(result) THEN RETURN; END;
IF len = 0 THEN EXIT; END;
IF inx > HIGH(str) THEN EXIT; END;
result[i] := str[inx];
INC(i); INC(inx); DEC(len);
END;
IF i <= HIGH(result) THEN result[i] := 0C; END;
END Copy;
PROCEDURE Concat(s1, s2: ARRAY OF CHAR; VAR result: ARRAY OF CHAR);
(* Concatenate two strings.
*)
VAR i, j: CARDINAL;
BEGIN
i := 0;
WHILE (i <= HIGH(s1)) AND (s1[i] # 0C) DO
IF i > HIGH(result) THEN RETURN END;
result[i] := s1[i];
INC(i);
END;
j := 0;
WHILE (j <= HIGH(s2)) AND (s2[j] # 0C) DO
IF i > HIGH(result) THEN RETURN END;
result[i] := s2[j];
INC(i);
INC(j);
END;
IF i <= HIGH(result) THEN result[i] := 0C; END;
END Concat;
PROCEDURE Length(str: ARRAY OF CHAR): CARDINAL;
(* Return number of characters in str.
*)
VAR i: CARDINAL;
BEGIN
i := 0;
WHILE (i <= HIGH(str)) DO
IF str[i] = 0C THEN RETURN i; END;
INC(i);
END;
RETURN i;
END Length;
PROCEDURE CompareStr(s1, s2: ARRAY OF CHAR): INTEGER;
(* Compare two strings, return -1 if s1 < s2, 0 if s1 = s2, and 1 if s1 > s2.
*)
VAR i: CARDINAL;
max: CARDINAL;
BEGIN
max := HIGH(s1);
IF HIGH(s2) < max THEN max := HIGH(s2); END;
i := 0;
WHILE (i <= max) DO
IF s1[i] < s2[i] THEN RETURN -1; END;
IF s1[i] > s2[i] THEN RETURN 1; END;
IF s1[i] = 0C THEN RETURN 0; END;
INC(i);
END;
IF (i <= HIGH(s1)) AND (s1[i] # 0C) THEN RETURN 1; END;
IF (i <= HIGH(s2)) AND (s2[i] # 0C) THEN RETURN -1; END;
RETURN 0;
END CompareStr;
END Strings.

99
lib/libm2/Termcap.mod Executable file
View File

@@ -0,0 +1,99 @@
(*
(c) copyright 1988 by the Vrije Universiteit, Amsterdam, The Netherlands.
See the copyright notice in the ACK home directory, in the file "Copyright".
*)
(*
Module: Interface to termcap database
From: Unix manual chapter 3
Version: $Header$
*)
(*$R-*)
IMPLEMENTATION MODULE Termcap;
IMPORT XXTermcap;
FROM SYSTEM IMPORT ADR, ADDRESS;
FROM Unix IMPORT isatty;
FROM Arguments IMPORT
GetEnv;
TYPE STR = ARRAY[1..32] OF CHAR;
STRCAP = POINTER TO STR;
VAR Buf, Buf1 : ARRAY [1..1024] OF CHAR;
BufCnt : INTEGER;
PROCEDURE Tgetent(name: ARRAY OF CHAR) : INTEGER;
VAR i: INTEGER;
x: STRCAP;
BEGIN
i := XXTermcap.tgetent(ADR(Buf), ADR(name));
BufCnt := 1;
IF isatty(1) THEN
ELSE
(* This used to be something returned by gtty(). To increase
* portability we forget about old terminals needing delays.
* (kjb)
*)
XXTermcap.ospeed := 0;
END;
IF i > 0 THEN
IF Tgetstr("pc", x) THEN
XXTermcap.PC := x^[1];
ELSE XXTermcap.PC := 0C;
END;
IF Tgetstr("up", x) THEN ; END; XXTermcap.UP := x;
IF Tgetstr("bc", x) THEN ; END; XXTermcap.BC := x;
END;
RETURN i;
END Tgetent;
PROCEDURE Tgetnum(id: ARRAY OF CHAR): INTEGER;
BEGIN
RETURN XXTermcap.tgetnum(ADR(id));
END Tgetnum;
PROCEDURE Tgetflag(id: ARRAY OF CHAR): BOOLEAN;
BEGIN
RETURN XXTermcap.tgetflag(ADR(id)) = 1;
END Tgetflag;
PROCEDURE Tgoto(cm: STRCAP; col, line: INTEGER): STRCAP;
BEGIN
RETURN XXTermcap.tgoto(cm, col, line);
END Tgoto;
PROCEDURE Tgetstr(id: ARRAY OF CHAR; VAR res: STRCAP) : BOOLEAN;
VAR a, a2: ADDRESS;
b: CARDINAL;
BEGIN
a := ADR(Buf1[BufCnt]);
a2 := XXTermcap.tgetstr(ADR(id), ADR(a));
res := a2;
IF a2 = NIL THEN
RETURN FALSE;
END;
b := a - a2;
INC(BufCnt, b);
RETURN TRUE;
END Tgetstr;
PROCEDURE Tputs(cp: STRCAP; affcnt: INTEGER; p: PUTPROC);
BEGIN
XXTermcap.tputs(cp, affcnt, XXTermcap.PUTPROC(p));
END Tputs;
PROCEDURE InitTermcap;
VAR Bf: STR;
BEGIN
IF GetEnv("TERM", Bf) = 0 THEN
Bf := "dumb";
END;
IF Tgetent(Bf) <= 0 THEN
END;
END InitTermcap;
BEGIN
InitTermcap;
END Termcap.

114
lib/libm2/Terminal.mod Executable file
View File

@@ -0,0 +1,114 @@
#
(*
(c) copyright 1988 by the Vrije Universiteit, Amsterdam, The Netherlands.
See the copyright notice in the ACK home directory, in the file "Copyright".
*)
(*$R-*)
IMPLEMENTATION MODULE Terminal;
(*
Module: Input/Output to/from terminals
Author: Ceriel J.H. Jacobs
Version: $Header$
Implementation for Unix.
*)
FROM SYSTEM IMPORT ADR;
#ifdef __USG
FROM Unix IMPORT read, write, open, fcntl;
#else
FROM Unix IMPORT read, write, open, ioctl;
#endif
VAR fildes: INTEGER;
unreadch: CHAR;
unread: BOOLEAN;
tty: ARRAY[0..8] OF CHAR;
PROCEDURE Read(VAR ch: CHAR);
BEGIN
IF unread THEN
ch := unreadch;
unread := FALSE
ELSE
IF read(fildes, ADR(ch), 1) < 0 THEN
;
END;
END;
unreadch := ch;
END Read;
PROCEDURE BusyRead(VAR ch: CHAR);
VAR l: INTEGER;
BEGIN
IF unread THEN
ch := unreadch;
unread := FALSE
ELSE
#ifdef __USG
l := fcntl(fildes, (*FGETFL*) 3, 0);
IF fcntl(fildes,
(* FSETFL *) 4,
l + (*ONDELAY*) 2) < 0 THEN
;
END;
IF read(fildes, ADR(ch), 1) = 0 THEN
ch := 0C;
ELSE
unreadch := ch;
END;
IF fcntl(fildes, (*FSETFL*)4, l) < 0 THEN
;
END;
#else
#ifdef __BSD4_2
IF ioctl(fildes, INTEGER(ORD('f')*256+127+4*65536+40000000H), ADR(l)) < 0 THEN
#else
IF ioctl(fildes, INTEGER(ORD('f')*256+127), ADR(l)) < 0 THEN
#endif
;
END;
IF l = 0 THEN
ch := 0C;
ELSE
IF read(fildes, ADR(ch), 1) < 0 THEN
;
END;
unreadch := ch;
END;
#endif
END;
END BusyRead;
PROCEDURE ReadAgain;
BEGIN
unread := TRUE;
END ReadAgain;
PROCEDURE Write(ch: CHAR);
BEGIN
IF write(fildes, ADR(ch), 1) < 0 THEN
;
END;
END Write;
PROCEDURE WriteLn;
BEGIN
Write(12C);
END WriteLn;
PROCEDURE WriteString(s: ARRAY OF CHAR);
VAR i: CARDINAL;
BEGIN
i := 0;
WHILE (i <= HIGH(s)) & (s[i] # 0C) DO
Write(s[i]);
INC(i)
END
END WriteString;
BEGIN
tty := "/dev/tty";
fildes := open(ADR(tty), 2);
unread := FALSE;
END Terminal.

96
lib/libm2/Traps.mod Executable file
View File

@@ -0,0 +1,96 @@
(*
(c) copyright 1988 by the Vrije Universiteit, Amsterdam, The Netherlands.
See the copyright notice in the ACK home directory, in the file "Copyright".
*)
(*$R-*)
IMPLEMENTATION MODULE Traps;
(*
Module: Facility for handling traps
Author: Ceriel J.H. Jacobs
Version: $Header$
*)
FROM EM IMPORT SIG, LINO, FILN, TRP;
FROM Unix IMPORT write;
FROM SYSTEM IMPORT ADDRESS, ADR;
FROM Arguments IMPORT
Argv;
PROCEDURE InstallTrapHandler(t: TrapHandler): TrapHandler;
(* Install a new trap handler, and return the previous one.
Parameter of trap handler is the trap number.
*)
BEGIN
RETURN SIG(t);
END InstallTrapHandler;
PROCEDURE Message(str: ARRAY OF CHAR);
(* Write message "str" on standard error, preceeded by filename and
linenumber if possible
*)
VAR p: POINTER TO CHAR;
l: CARDINAL;
lino: INTEGER;
buf, buf2: ARRAY [0..255] OF CHAR;
i, j: CARDINAL;
BEGIN
p := FILN();
IF p # NIL THEN
i := 1;
buf[0] := '"';
WHILE p^ # 0C DO
buf[i] := p^;
INC(i);
p := ADDRESS(p) + 1;
END;
buf[i] := '"';
INC(i);
IF write(2, ADR(buf), i) < 0 THEN END;
ELSE
l := Argv(0, buf);
IF write(2, ADR(buf), l-1) < 0 THEN END;
END;
lino := LINO();
i := 0;
IF lino # 0 THEN
i := 7;
buf[0] := ','; buf[1] := ' ';
buf[2] := 'l'; buf[3] := 'i'; buf[4] := 'n'; buf[5] := 'e';
buf[6] := ' ';
IF lino < 0 THEN
buf[7] := '-';
i := 8;
lino := - lino;
END;
j := 0;
REPEAT
buf2[j] := CHR(CARDINAL(lino) MOD 10 + ORD('0'));
lino := lino DIV 10;
INC(j);
UNTIL lino = 0;
WHILE j > 0 DO
DEC(j);
buf[i] := buf2[j];
INC(i);
END;
END;
buf[i] := ':';
buf[i+1] := ' ';
IF write(2, ADR(buf), i+2) < 0 THEN END;
i := 0;
WHILE (i <= HIGH(str)) AND (str[i] # 0C) DO
INC(i);
END;
IF write(2, ADR(str), i) < 0 THEN END;
buf[0] := 12C;
IF write(2, ADR(buf), 1) < 0 THEN END;
END Message;
PROCEDURE Trap(n: INTEGER);
(* cause trap number "n" to occur *)
BEGIN
TRP(n);
END Trap;
END Traps.

573
lib/libm2/XXTermcap.c Executable file
View File

@@ -0,0 +1,573 @@
/*
* termcap.c 1.1 20/7/87 agc Joypace Ltd
*
* Copyright Joypace Ltd, London, UK, 1987. All rights reserved.
* This file may be freely distributed provided that this notice
* remains attached.
*
* A public domain implementation of the termcap(3) routines.
*
* Made fully functional by Ceriel J.H. Jacobs.
*
* BUGS:
* - does not check termcap entry sizes
* - not fully tested
*/
#define CAPABLEN 2
#define ISSPACE(c) ((c) == ' ' || (c) == '\t' || (c) == '\r' || (c) == '\n')
#define ISDIGIT(x) ((x) >= '0' && (x) <= '9')
short ospeed = 0; /* output speed */
char PC = 0; /* padding character */
char *BC = 0; /* back cursor movement */
char *UP = 0; /* up cursor movement */
static char *capab = 0; /* the capability itself */
static int check_for_tc();
static int match_name();
#define NULL 0
/* Some things from C-library, needed here because the C-library is not
loaded with Modula-2 programs
*/
static char *
strcat(s1, s2)
register char *s1, *s2;
{
/* Append s2 to the end of s1. */
char *original = s1;
/* Find the end of s1. */
while (*s1 != 0) s1++;
/* Now copy s2 to the end of s1. */
while (*s1++ = *s2++) /* nothing */ ;
return(original);
}
static char *
strcpy(s1, s2)
register char *s1, *s2;
{
/* Copy s2 to s1. */
char *original = s1;
while (*s1++ = *s2++) /* nothing */;
return(original);
}
static int
strlen(s)
char *s;
{
/* Return length of s. */
char *original = s;
while (*s != 0) s++;
return(s - original);
}
static int
strcmp(s1, s2)
register char *s1, *s2;
{
/* Compare 2 strings. */
for(;;) {
if (*s1 != *s2) {
if (!*s1) return -1;
if (!*s2) return 1;
return(*s1 - *s2);
}
if (*s1++ == 0) return(0);
s2++;
}
}
static int
strncmp(s1, s2, n)
register char *s1, *s2;
int n;
{
/* Compare two strings, but at most n characters. */
while (n-- > 0) {
if (*s1 != *s2) {
if (!*s1) return -1;
if (!*s2) return 1;
return(*s1 - *s2);
}
if (*s1++ == 0) break;
s2++;
}
return 0;
}
static char *
getenv(name)
register char *name;
{
extern char ***_penviron;
register char **v = *_penviron, *p, *q;
if (v == 0 || name == 0) return 0;
while ((p = *v++) != 0) {
q = name;
while (*q && *q++ == *p++) /* nothing */ ;
if (*q || *p != '=') continue;
return(p+1);
}
return(0);
}
static char *
fgets(buf, count, fd)
char *buf;
{
static char bf[1024];
static int cnt = 0;
static char *pbf = &bf[0];
register char *c = buf;
while (--count) {
if (pbf >= &bf[cnt]) {
if ((cnt = read(fd, bf, 1024)) <= 0) {
if (c == buf) return (char *) NULL;
*c = 0;
return buf;
}
pbf = &bf[0];
}
*c = *pbf++;
if (*c++ == '\n') {
*c = 0;
return buf;
}
}
*c = 0;
return buf;
}
/*
* tgetent - get the termcap entry for terminal name, and put it
* in bp (which must be an array of 1024 chars). Returns 1 if
* termcap entry found, 0 if not found, and -1 if file not found.
*/
int
tgetent(bp, name)
char *bp;
char *name;
{
int fp;
char *file;
char *cp;
short len = strlen(name);
char buf[1024];
capab = bp;
if ((file = getenv("TERMCAP")) != (char *) NULL) {
if (*file != '/' &&
(cp = getenv("TERM")) != NULL && strcmp(name, cp) == 0) {
(void) strcpy(bp, file);
return(1);
}
else file = "/etc/termcap";
} else
file = "/etc/termcap";
if ((fp = open(file, 0)) < 0) {
capab = 0;
return(-1);
}
while (fgets(buf, 1024, fp) != NULL) {
if (buf[0] == '#') continue;
while (*(cp = &buf[strlen(buf) - 2]) == '\\')
if (fgets(cp, 1024, fp) == NULL)
return (0);
if (match_name(buf, name)) {
strcpy(bp, buf);
close(fp);
if(check_for_tc() == 0) {
capab = 0;
return 0;
}
return 1;
}
}
capab = 0;
close(fp);
return(0);
}
/*
* Compare the terminal name with each termcap entry name; Return 1 if a
* match is found.
*/
static int
match_name(buf, name)
char *buf;
char *name;
{
register char *tp = buf;
register char *np;
for (;;) {
for (np = name; *np && *tp == *np; np++, tp++) { }
if (*np == 0 && (*tp == '|' || *tp == ':' || *tp == 0))
return(1);
while (*tp != 0 && *tp != '|' && *tp != ':') tp++;
if (*tp++ != '|') return (0);
}
}
/*
* Handle tc= definitions recursively.
*/
static int
check_for_tc()
{
static int count = 0;
char *savcapab = capab;
char buf[1024];
char terminalname[128];
register char *p = capab + strlen(capab) - 2, *q;
while (*p != ':')
if (--p < capab)
return(0); /* no : in termcap entry */
if (p[1] != 't' || p[2] != 'c')
return(1);
if (count > 16) {
return(0); /* recursion in tc= definitions */
}
count++;
strcpy(terminalname, &p[4]);
q = terminalname;
while (*q && *q != ':') q++;
*q = 0;
if (tgetent(buf, terminalname) != 1) {
--count;
return(0);
}
--count;
for (q = buf; *q && *q != ':'; q++) { }
strcpy(p, q);
capab = savcapab;
return(1);
}
/*
* tgetnum - get the numeric terminal capability corresponding
* to id. Returns the value, -1 if invalid.
*/
int
tgetnum(id)
char *id;
{
char *cp;
int ret;
if ((cp = capab) == NULL || id == NULL || *cp == 0)
return(-1);
while (*++cp && *cp != ':')
;
while (*cp) {
cp++;
while (ISSPACE(*cp))
cp++;
if (strncmp(cp, id, CAPABLEN) == 0) {
while (*cp && *cp != ':' && *cp != '#')
cp++;
if (*cp != '#')
return(-1);
for (ret = 0, cp++ ; *cp && ISDIGIT(*cp) ; cp++)
ret = ret * 10 + *cp - '0';
return(ret);
}
while (*cp && *cp != ':')
cp++;
}
return(-1);
}
/*
* tgetflag - get the boolean flag corresponding to id. Returns -1
* if invalid, 0 if the flag is not in termcap entry, or 1 if it is
* present.
*/
int
tgetflag(id)
char *id;
{
char *cp;
if ((cp = capab) == NULL || id == NULL || *cp == 0)
return(-1);
while (*++cp && *cp != ':')
;
while (*cp) {
cp++;
while (ISSPACE(*cp))
cp++;
if (strncmp(cp, id, CAPABLEN) == 0)
return(1);
while (*cp && *cp != ':')
cp++;
}
return(0);
}
/*
* tgetstr - get the string capability corresponding to id and place
* it in area (advancing area at same time). Expand escape sequences
* etc. Returns the string, or NULL if it can't do it.
*/
char *
tgetstr(id, area)
char *id;
char **area;
{
char *cp;
char *ret;
int i;
if ((cp = capab) == NULL || id == NULL || *cp == 0)
return(NULL);
while (*++cp != ':')
;
while (*cp) {
cp++;
while (ISSPACE(*cp))
cp++;
if (strncmp(cp, id, CAPABLEN) == 0) {
while (*cp && *cp != ':' && *cp != '=')
cp++;
if (*cp != '=')
return(NULL);
for (ret = *area, cp++; *cp && *cp != ':' ; (*area)++, cp++)
switch(*cp) {
case '^' :
**area = *++cp - 'A' + 1;
break;
case '\\' :
switch(*++cp) {
case 'E' :
**area = '\033';
break;
case 'n' :
**area = '\n';
break;
case 'r' :
**area = '\r';
break;
case 't' :
**area = '\t';
break;
case 'b' :
**area = '\b';
break;
case 'f' :
**area = '\f';
break;
case '0' :
case '1' :
case '2' :
case '3' :
for (i=0 ; *cp && ISDIGIT(*cp) ; cp++)
i = i * 8 + *cp - '0';
**area = i;
cp--;
break;
case '^' :
case '\\' :
**area = *cp;
break;
}
break;
default :
**area = *cp;
}
*(*area)++ = '\0';
return(ret);
}
while (*cp && *cp != ':')
cp++;
}
return(NULL);
}
/*
* tgoto - given the cursor motion string cm, make up the string
* for the cursor to go to (destcol, destline), and return the string.
* Returns "OOPS" if something's gone wrong, or the string otherwise.
*/
char *
tgoto(cm, destcol, destline)
char *cm;
int destcol;
int destline;
{
register char *rp;
static char ret[32];
char added[16];
int *dp = &destline;
int numval;
int swapped = 0;
added[0] = 0;
for (rp = ret ; *cm ; cm++) {
if (*cm == '%') {
switch(*++cm) {
case '>' :
if (dp == NULL)
return("OOPS");
cm++;
if (*dp > *cm++) {
*dp += *cm;
}
break;
case '+' :
case '.' :
if (dp == NULL)
return("OOPS");
if (*cm == '+') *dp = *dp + *++cm;
for (;;) {
switch(*dp) {
case 0:
case 04:
case '\t':
case '\n':
/* filter these out */
if (dp == &destcol || swapped || UP) {
strcat(added, dp == &destcol || swapped ?
(BC ? BC : "\b") :
UP);
(*dp)++;
continue;
}
}
break;
}
*rp++ = *dp;
dp = (dp == &destline) ? &destcol : NULL;
break;
case 'r' : {
int tmp = destline;
destline = destcol;
destcol = tmp;
swapped = 1 - swapped;
break;
}
case 'n' :
destcol ^= 0140;
destline ^= 0140;
break;
case '%' :
*rp++ = '%';
break;
case 'i' :
destcol++;
destline++;
break;
case 'B' :
if (dp == NULL)
return("OOPS");
*dp = 16 * (*dp / 10) + *dp % 10;
break;
case 'D' :
if (dp == NULL)
return("OOPS");
*dp = *dp - 2 * (*dp % 16);
break;
case 'd' :
case '2' :
case '3' :
if (dp == NULL)
return("OOPS");
numval = *dp;
dp = (dp == &destline) ? &destcol : NULL;
if (numval >= 100) {
*rp++ = '0' + numval / 100;
}
else if (*cm == '3') {
*rp++ = ' ';
}
if (numval >= 10) {
*rp++ = '0' + ((numval%100)/10);
}
else if (*cm == '3' || *cm == '2') {
*rp++ = ' ';
}
*rp++ = '0' + (numval%10);
break;
default :
return("OOPS");
}
}
else *rp++ = *cm;
}
*rp = '\0';
strcpy(rp, added);
return(ret);
}
static int tens_of_ms_p_char[] = { /* index as returned by gtty */
/* assume 10 bits per char */
0, 2000, 1333, 909, 743, 666, 500, 333, 166, 83, 55, 41, 20, 10, 5, 2
};
/*
* tputs - put the string cp out onto the terminal, using the function
* outc. Also handle padding.
*/
int
tputs(cp, affcnt, outc)
register char *cp;
int affcnt;
int (*outc)();
{
int delay = 0;
if (cp == NULL)
return(1);
while (ISDIGIT(*cp)) {
delay = delay * 10 + (*cp++ - '0');
}
delay *= 10;
if (*cp == '.') {
cp++;
if (ISDIGIT(*cp)) {
delay += *cp++ - '0';
}
while (ISDIGIT(*cp)) cp++;
}
if (*cp == '*') {
delay *= affcnt;
cp++;
}
while (*cp)
(*outc)(*cp++);
if (delay != 0 &&
ospeed > 0 &&
ospeed < (sizeof tens_of_ms_p_char / sizeof tens_of_ms_p_char[0])) {
delay = (delay + tens_of_ms_p_char[ospeed] - 1) /
tens_of_ms_p_char[ospeed];
while (delay--) (*outc)(PC);
}
return(1);
}
/*
* That's all, folks...
*/

18
lib/libm2/absd.c Executable file
View File

@@ -0,0 +1,18 @@
/*
(c) copyright 1988 by the Vrije Universiteit, Amsterdam, The Netherlands.
See the copyright notice in the ACK home directory, in the file "Copyright".
*/
/*
Module: double abs function
Author: Ceriel J.H. Jacobs
Version: $Header$
*/
#ifndef NOFLOAT
double
absd(i)
double i;
{
return i >= 0 ? i : -i;
}
#endif

30
lib/libm2/absf.e Executable file
View File

@@ -0,0 +1,30 @@
#
;
; (c) copyright 1988 by the Vrije Universiteit, Amsterdam, The Netherlands.
; See the copyright notice in the ACK home directory, in the file "Copyright".
;
;
; Module: REAL abs function
; Author: Ceriel J.H. Jacobs
; Version: $Header$
;
mes 2,_EM_WSIZE,_EM_PSIZE
exp $absf
pro $absf,0
mes 5
mes 9,8
lal 0
loi _EM_FSIZE
zrf _EM_FSIZE
cmf _EM_FSIZE
zlt *3
lal 0
loi _EM_FSIZE
bra *4
3
lal 0
loi _EM_FSIZE
ngf _EM_FSIZE
4
ret _EM_FSIZE
end 0

15
lib/libm2/absi.c Executable file
View File

@@ -0,0 +1,15 @@
/*
(c) copyright 1988 by the Vrije Universiteit, Amsterdam, The Netherlands.
See the copyright notice in the ACK home directory, in the file "Copyright".
*/
/*
Module: integer abs function
Author: Ceriel J.H. Jacobs
Version: $Header$
*/
absi(i)
{
return i >= 0 ? i : -i;
}

16
lib/libm2/absl.c Executable file
View File

@@ -0,0 +1,16 @@
/*
(c) copyright 1988 by the Vrije Universiteit, Amsterdam, The Netherlands.
See the copyright notice in the ACK home directory, in the file "Copyright".
*/
/*
Module: longint abs function
Author: Ceriel J.H. Jacobs
Version: $Header$
*/
long
absl(i)
long i;
{
return i >= 0 ? i : -i;
}

23
lib/libm2/blockmove.c Executable file
View File

@@ -0,0 +1,23 @@
/*
(c) copyright 1988 by the Vrije Universiteit, Amsterdam, The Netherlands.
See the copyright notice in the ACK home directory, in the file "Copyright".
*/
/*
Module: block moves
Author: Ceriel J.H. Jacobs
Version: $Header$
*/
#if _EM_WSIZE==_EM_PSIZE
typedef unsigned pcnt;
#else
typedef unsigned long pcnt;
#endif
blockmove(siz, dst, src)
pcnt siz;
register char *dst, *src;
{
while (siz--) *dst++ = *src++;
}

18
lib/libm2/cap.c Executable file
View File

@@ -0,0 +1,18 @@
/*
(c) copyright 1988 by the Vrije Universiteit, Amsterdam, The Netherlands.
See the copyright notice in the ACK home directory, in the file "Copyright".
*/
/*
Module: cap; implementation of CAP
Author: Ceriel J.H. Jacobs
Version: $Header$
*/
cap(u)
unsigned u;
{
register unsigned *p = &u;
if (*p >= 'a' && *p <= 'z') *p += 'A'-'a';
}

99
lib/libm2/catch.c Executable file
View File

@@ -0,0 +1,99 @@
/*
(c) copyright 1988 by the Vrije Universiteit, Amsterdam, The Netherlands.
See the copyright notice in the ACK home directory, in the file "Copyright".
*/
/*
Module: default modula-2 trap handler
Author: Ceriel J.H. Jacobs
Version: $Header$
*/
#include <em_abs.h>
#include <m2_traps.h>
#include <signal.h>
static struct errm {
int errno;
char *errmes;
} errors[] = {
{ EARRAY, "array bound error"},
{ ERANGE, "range bound error"},
{ ESET, "set bound error"},
{ EIOVFL, "integer overflow"},
{ EFOVFL, "real overflow"},
{ EFUNFL, "real underflow"},
{ EIDIVZ, "divide by 0"},
{ EFDIVZ, "divide by 0.0"},
{ EIUND, "undefined integer"},
{ EFUND, "undefined real"},
{ ECONV, "conversion error"},
{ ESTACK, "stack overflow"},
{ EHEAP, "heap overflow"},
{ EILLINS, "illegal instruction"},
{ EODDZ, "illegal size argument"},
{ ECASE, "case error"},
{ EMEMFLT, "addressing non existent memory"},
{ EBADPTR, "bad pointer used"},
{ EBADPC, "program counter out of range"},
{ EBADLAE, "bad argument of lae"},
{ EBADMON, "bad monitor call"},
{ EBADLIN, "argument if LIN too high"},
{ EBADGTO, "GTO descriptor error"},
{ M2_TOOLARGE, "stack size of process too large"},
{ M2_TOOMANY, "too many nested traps + handlers"},
{ M2_NORESULT, "no RETURN from function procedure"},
{ M2_UOVFL, "cardinal overflow"},
{ M2_FORCH, "(warning) FOR-loop control variable was changed in the body"},
{ M2_UUVFL, "cardinal underflow"},
{ M2_INTERNAL, "internal error; ask an expert for help"},
{ M2_UNIXSIG, "got a unix signal"},
{ -1, 0}
};
catch(trapno)
int trapno;
{
register struct errm *ep = &errors[0];
char *errmessage;
char buf[20];
register char *p, *s;
while (ep->errno != trapno && ep->errmes != 0) ep++;
if (p = ep->errmes) {
while (*p) p++;
_Traps__Message(ep->errmes, 0, (int) (p - ep->errmes), 1);
}
else {
int i = trapno;
static char q[] = "error number xxxxxxxxxxxxx";
p = &q[13];
s = buf;
if (i < 0) {
i = -i;
*p++ = '-';
}
do
*s++ = i % 10 + '0';
while (i /= 10);
while (s > buf) *p++ = *--s;
*p = 0;
_Traps__Message(q, 0, (int) (p - q), 1);
}
#if !defined(__em24) && !defined(__em44) && !defined(__em22)
if (trapno == M2_UNIXSIG) {
extern int __signo;
signal(__signo, SIG_DFL);
_cleanup();
kill(getpid(), __signo);
_exit(trapno);
}
#endif
if (trapno != M2_FORCH) {
_cleanup();
_exit(trapno);
}
SIG(catch);
}

72
lib/libm2/confarray.c Executable file
View File

@@ -0,0 +1,72 @@
/*
(c) copyright 1988 by the Vrije Universiteit, Amsterdam, The Netherlands.
See the copyright notice in the ACK home directory, in the file "Copyright".
*/
/*
Module: runtime support for conformant arrays
Author: Ceriel J.H. Jacobs
Version: $Header$
*/
#include <m2_traps.h>
#ifndef EM_WSIZE
#define EM_WSIZE _EM_WSIZE
#define EM_PSIZE _EM_PSIZE
#endif
#if EM_WSIZE==EM_PSIZE
typedef unsigned pcnt;
#else
typedef unsigned long pcnt;
#endif
struct descr {
char *addr;
int low;
unsigned int highminlow;
unsigned int size;
};
static struct descr *descrs[10];
static struct descr **ppdescr = descrs;
pcnt
new_stackptr(pdscr, a)
struct descr *pdscr;
{
register struct descr *pdescr = pdscr;
pcnt size = (((pdescr->highminlow + 1) * pdescr->size +
(EM_WSIZE - 1)) & ~(EM_WSIZE - 1));
if (ppdescr >= &descrs[10]) {
/* to many nested traps + handlers ! */
TRP(M2_TOOMANY);
}
*ppdescr++ = pdescr;
if ((char *) &a - (char *) &pdscr > 0) {
/* stack grows downwards */
return - size;
}
return size;
}
copy_array(pp, a)
char *pp;
{
register char *p = pp;
register char *q;
register pcnt sz;
char dummy;
ppdescr--;
sz = ((*ppdescr)->highminlow + 1) * (*ppdescr)->size;
if ((char *) &a - (char *) &pp > 0) {
(*ppdescr)->addr = q = (char *) &a;
}
else (*ppdescr)->addr = q = (char *) &a -
((sz + (EM_WSIZE - 1)) & ~ (EM_WSIZE - 1));
while (sz--) *q++ = *p++;
}

68
lib/libm2/dvi.c Executable file
View File

@@ -0,0 +1,68 @@
/*
(c) copyright 1988 by the Vrije Universiteit, Amsterdam, The Netherlands.
See the copyright notice in the ACK home directory, in the file "Copyright".
*/
/*
Module: implementation of DIV and MOD
Author: Ceriel J.H. Jacobs
Version: $Header$
Reason: We cannot use DVI and RMI, because DVI rounds towards 0
and Modula-2 requires truncation
*/
#include <em_abs.h>
int
dvi(j,i)
int j,i;
{
if (j == 0) TRP(EIDIVZ);
if ((i < 0) != (j < 0)) {
if (i < 0) i = -i;
else j = -j;
return -((i+j-1)/j);
}
else return i/j;
}
long
dvil(j,i)
long j,i;
{
if (j == 0) TRP(EIDIVZ);
if ((i < 0) != (j < 0)) {
if (i < 0) i = -i;
else j = -j;
return -((i+j-1)/j);
}
else return i/j;
}
int
rmi(j,i)
int j,i;
{
if (j == 0) TRP(EIDIVZ);
if (i == 0) return 0;
if ((i < 0) != (j < 0)) {
if (i < 0) i = -i;
else j = -j;
return j*((i+j-1)/j)-i;
}
else return i%j;
}
long
rmil(j,i)
long j,i;
{
if (j == 0) TRP(EIDIVZ);
if (i == 0) return 0L;
if ((i < 0) != (j < 0)) {
if (i < 0) i = -i;
else j = -j;
return j*((i+j-1)/j)-i;
}
else return i%j;
}

37
lib/libm2/halt.c Executable file
View File

@@ -0,0 +1,37 @@
/*
(c) copyright 1988 by the Vrije Universiteit, Amsterdam, The Netherlands.
See the copyright notice in the ACK home directory, in the file "Copyright".
*/
/*
Module: program termination routines
Author: Ceriel J.H. Jacobs
Version: $Header$
*/
#define MAXPROCS 32
static int callindex = 0;
static int (*proclist[MAXPROCS])();
_cleanup()
{
while (--callindex >= 0)
(*proclist[callindex])();
callindex = 0;
}
CallAtEnd(p)
int (*p)();
{
if (callindex >= MAXPROCS) {
return 0;
}
proclist[callindex++] = p;
return 1;
}
halt()
{
_cleanup();
_exit(0);
}

63
lib/libm2/head_m2.e Executable file
View File

@@ -0,0 +1,63 @@
#
;
; (c) copyright 1988 by the Vrije Universiteit, Amsterdam, The Netherlands.
; See the copyright notice in the ACK home directory, in the file "Copyright".
;
;
; Module: Modula-2 runtime startoff
; Author: Ceriel J.H. Jacobs
; Version: $Header$
;
mes 2,_EM_WSIZE,_EM_PSIZE
exa handler
exa argv
exa argc
exa MainLB
exa bkillbss
exp $catch
exp $init
inp $trap_handler
bkillbss
bss _EM_PSIZE,0,0
exp $_m_a_i_n
pro $_m_a_i_n, 0
lor 0
lae MainLB
sti _EM_PSIZE
lal _EM_WSIZE
loi _EM_PSIZE
lae argv ; save argument pointer
sti _EM_PSIZE
lol 0
ste argc ; save argument count
lpi $trap_handler
sig
asp _EM_PSIZE
cal $init
cal $__M2M_
cal $halt
loc 0 ; should not get here
ret _EM_WSIZE
end
pro $trap_handler,0
lpi $trap_handler
sig
lol 0 ; trap number
lae handler
loi _EM_PSIZE
lpi $catch
lae handler
sti _EM_PSIZE
cai
asp _EM_PSIZE+_EM_WSIZE
rtt
end 0

47
lib/libm2/init.c Executable file
View File

@@ -0,0 +1,47 @@
/*
(c) copyright 1988 by the Vrije Universiteit, Amsterdam, The Netherlands.
See the copyright notice in the ACK home directory, in the file "Copyright".
*/
/*
Module: initialization and some global vars
Author: Ceriel J.H. Jacobs
Version: $Header$
*/
#include <signal.h>
#include <em_abs.h>
#include <m2_traps.h>
/* map unix signals onto EM traps */
init()
{
sigtrp(M2_UNIXSIG, SIGHUP);
sigtrp(M2_UNIXSIG, SIGINT);
sigtrp(M2_UNIXSIG, SIGQUIT);
sigtrp(EILLINS, SIGILL);
sigtrp(M2_UNIXSIG, SIGTRAP);
sigtrp(M2_UNIXSIG, SIGIOT);
sigtrp(M2_UNIXSIG, SIGEMT);
sigtrp(M2_UNIXSIG, SIGFPE);
sigtrp(M2_UNIXSIG, SIGBUS);
sigtrp(M2_UNIXSIG, SIGSEGV);
#ifdef SIGSYS
sigtrp(EBADMON, SIGSYS);
#endif
sigtrp(M2_UNIXSIG, SIGPIPE);
sigtrp(M2_UNIXSIG, SIGALRM);
sigtrp(M2_UNIXSIG, SIGTERM);
}
killbss()
{
/* Fill bss with junk? Make lots of VM pages dirty? No way! */
}
extern int catch();
int (*handler)() = catch;
char **argv;
int argc;
char *MainLB;

45
lib/libm2/load.c Executable file
View File

@@ -0,0 +1,45 @@
/*
(c) copyright 1988 by the Vrije Universiteit, Amsterdam, The Netherlands.
See the copyright notice in the ACK home directory, in the file "Copyright".
*/
/*
Module: get value on stack, byte by byte
Author: Ceriel J.H. Jacobs
Version: $Header$
*/
#include <m2_traps.h>
#ifndef EM_WSIZE
#define EM_WSIZE _EM_WSIZE
#define EM_PSIZE _EM_PSIZE
#endif
#if EM_WSIZE==EM_PSIZE
typedef unsigned pcnt;
#else
typedef long pcnt;
#endif
load(siz, addr, p)
register char *addr;
register pcnt siz;
{
/* Make sure, that a value with a size that could have been
handled by the LOI instruction ends up at the same place,
where it would, were the LOI instruction used.
*/
register char *q = (char *) &p;
char t[4];
if (siz < EM_WSIZE && EM_WSIZE % siz == 0) {
/* as long as EM_WSIZE <= 4 ... */
if (siz != 2) TRP(M2_INTERNAL); /* internal error */
q = &t[0];
}
while (siz--) *q++ = *addr++;
if (q - t == 2) {
*((unsigned *)(&p)) = *((unsigned short *) (&t[0]));
}
}

175
lib/libm2/par_misc.e Executable file
View File

@@ -0,0 +1,175 @@
#
;
; (c) copyright 1988 by the Vrije Universiteit, Amsterdam, The Netherlands.
; See the copyright notice in the ACK home directory, in the file "Copyright".
;
;
; Module: coroutine primitives
; Author: Kees Bot, Edwin Scheffer, Ceriel Jacobs
; Version: $Header$
;
mes 2,_EM_WSIZE,_EM_PSIZE
; topsize takes care of two things:
; - given a stack-break,
; it computes the size of the chunk of memory needed to save the stack;
; - also, if this stack-break = 0, it creates one, assuming that caller is
; the stack-break.
;
; This implementation assumes a continuous stack growing downwards
exp $topsize
#ifdef __sparc
inp $topsize2
pro $topsize, 0
mes 11
zer _EM_PSIZE
lal 0
loi _EM_PSIZE
cal $topsize2
asp 2*_EM_PSIZE
lfr _EM_WSIZE
ret _EM_WSIZE
end 0
pro $topsize2, (3*_EM_WSIZE+3*_EM_PSIZE)
#else
pro $topsize, (3*_EM_WSIZE+3*_EM_PSIZE)
#endif
; local space for line-number, ignoremask, filename, stack-break, size,
; and stack-pointer (see the topsave routine)
mes 11
lal 0
loi _EM_PSIZE
loi _EM_PSIZE ; stack-break or 0
zer _EM_PSIZE
cmp
zne *1
lxl 0
dch ; local base of caller
#ifdef __sparc
dch ; because of the extra layer
#endif
lal 0
loi _EM_PSIZE
sti _EM_PSIZE
1
lal 0
loi _EM_PSIZE
loi _EM_PSIZE
lpb ; convert this local base to an argument base.
; An implementation of a sort of "topsize" EM
; instruction should take a local base, and save
; the whole frame.
lor 1 ; stack-break SP
sbs _EM_WSIZE ; stack-break-SP
ret _EM_WSIZE ; return size of block to be saved
end 3*_EM_WSIZE+3*_EM_PSIZE
exp $topsave
#ifdef __sparc
inp $topsave2
pro $topsave,0
mes 11
lal 0
loi 2*_EM_PSIZE
cal $topsave2
asp 2*_EM_PSIZE
lfr _EM_WSIZE
ret _EM_WSIZE
end 0
pro $topsave2,0
#else
pro $topsave, 0
#endif
mes 11
loe 0
lae 4 ; load line number and file name
loi _EM_PSIZE
lim ; ignore mask
lor 0 ; LB
lal 0
loi _EM_PSIZE ; stack-break
lpb
lor 1
sbs _EM_WSIZE
loc _EM_WSIZE
adu _EM_WSIZE ; gives size
dup _EM_WSIZE
stl 0 ; save size
lor 1 ; SP (the SP BEFORE pushing)
lor 1 ; SP (address of stack top to save)
lal _EM_PSIZE ; area
loi _EM_PSIZE
lol 0 ; size
bls _EM_WSIZE ; move whole block
asp 3*_EM_PSIZE+3*_EM_WSIZE ; remove the lot from the stack
loc 1
ret _EM_WSIZE ; return 1
end 0
sv
bss _EM_PSIZE,0,0
exp $topload
#ifdef __sparc
inp $topload1
pro $topload,0
lal 0
loi _EM_PSIZE
cal $topload1
asp _EM_PSIZE
lfr _EM_WSIZE
ret _EM_WSIZE
end 0
pro $topload1, 0
#else
pro $topload, 0
#endif
mes 11
lal 0
loi _EM_PSIZE
lae sv
sti _EM_PSIZE ; saved parameter
lxl 0
2
dup _EM_PSIZE
adp -3*_EM_PSIZE
lal 0
loi _EM_PSIZE ; compare target SP with current LB to see if we must
loi _EM_PSIZE
cmp ; find another LB first
zgt *1
dch ; just follow dynamic chain to make sure we find
; a legal one
bra *2
1
str 0
lae sv
loi _EM_PSIZE
loi _EM_PSIZE ; load indirect to
str 1 ; restore SP
asp 0-_EM_PSIZE ; to stop int from complaining about non-existent memory
lae sv
loi _EM_PSIZE ; source address
lor 1
adp _EM_PSIZE ; destination address
lae sv
loi _EM_PSIZE
adp _EM_PSIZE
loi _EM_WSIZE ; size of block
bls _EM_WSIZE
asp _EM_PSIZE+_EM_WSIZE ; drop size + SP
str 0 ; restore local base
sim ; ignore mask
lae 4
sti _EM_PSIZE
ste 0 ; line and file
loc 0
ret _EM_WSIZE
end 0

58
lib/libm2/random.mod Executable file
View File

@@ -0,0 +1,58 @@
(*
(c) copyright 1988 by the Vrije Universiteit, Amsterdam, The Netherlands.
See the copyright notice in the ACK home directory, in the file "Copyright".
*)
(*$R-*)
IMPLEMENTATION MODULE random;
(*
Module: random numbers
Author: Ceriel J.H. Jacobs
Version: $Header$
*)
FROM Unix IMPORT getpid, time;
TYPE index = [1..55];
VAR X: ARRAY index OF CARDINAL;
j, k: index;
tm: LONGINT;
PROCEDURE Random(): CARDINAL;
BEGIN
IF k-1 <= 0 THEN k := 55; ELSE DEC(k) END;
IF j-1 <= 0 THEN j := 55; ELSE DEC(j) END;
X[k] := X[k] + X[j];
RETURN X[k]
END Random;
PROCEDURE Uniform (lwb, upb: CARDINAL): CARDINAL;
BEGIN
IF upb <= lwb THEN RETURN lwb; END;
RETURN lwb + (Random() MOD (upb - lwb + 1));
END Uniform;
PROCEDURE StartSeed(seed: CARDINAL);
VAR v: CARDINAL;
BEGIN
FOR k := 1 TO 55 DO
seed := 1297 * seed + 123;
X[k] := seed;
END;
FOR k := 1 TO 15 DO
j := tm MOD 55D + 1D;
v := X[j];
tm := tm DIV 7D;
j := tm MOD 55D + 1D;
X[j] := v;
tm := tm * 3D;
END;
k := 1;
j := 25;
END StartSeed;
BEGIN
tm := time(NIL);
X[1] := tm;
StartSeed(CARDINAL(getpid()) * X[1]);
END random.

25
lib/libm2/rcka.c Executable file
View File

@@ -0,0 +1,25 @@
/*
* (c) copyright 1988 by the Vrije Universiteit, Amsterdam, The Netherlands.
* See the copyright notice in the ACK home directory, in the file "Copyright".
*
*
* Module: range checks for INTEGER, now for array indexing
* Author: Ceriel J.H. Jacobs
* Version: $Header$
*/
#include <em_abs.h>
extern TRP();
struct array_descr {
int lbound;
int n_elts_min_one;
unsigned size;
};
rcka(descr, indx)
struct array_descr *descr;
{
if (indx < 0 || indx > descr->n_elts_min_one) TRP(EARRAY);
}

23
lib/libm2/rcki.c Executable file
View File

@@ -0,0 +1,23 @@
/*
* (c) copyright 1988 by the Vrije Universiteit, Amsterdam, The Netherlands.
* See the copyright notice in the ACK home directory, in the file "Copyright".
*
*
* Module: range checks for INTEGER
* Author: Ceriel J.H. Jacobs
* Version: $Header$
*/
#include <em_abs.h>
extern TRP();
struct range_descr {
int low, high;
};
rcki(descr, val)
struct range_descr *descr;
{
if (val < descr->low || val > descr->high) TRP(ERANGE);
}

24
lib/libm2/rckil.c Executable file
View File

@@ -0,0 +1,24 @@
/*
* (c) copyright 1988 by the Vrije Universiteit, Amsterdam, The Netherlands.
* See the copyright notice in the ACK home directory, in the file "Copyright".
*
*
* Module: range checks for LONGINT
* Author: Ceriel J.H. Jacobs
* Version: $Header$
*/
#include <em_abs.h>
extern TRP();
struct range_descr {
long low, high;
};
rckil(descr, val)
struct range_descr *descr;
long val;
{
if (val < descr->low || val > descr->high) TRP(ERANGE);
}

24
lib/libm2/rcku.c Executable file
View File

@@ -0,0 +1,24 @@
/*
* (c) copyright 1988 by the Vrije Universiteit, Amsterdam, The Netherlands.
* See the copyright notice in the ACK home directory, in the file "Copyright".
*
*
* Module: range checks for CARDINAL
* Author: Ceriel J.H. Jacobs
* Version: $Header$
*/
#include <em_abs.h>
extern TRP();
struct range_descr {
unsigned low, high;
};
rcku(descr, val)
struct range_descr *descr;
unsigned val;
{
if (val < descr->low || val > descr->high) TRP(ERANGE);
}

24
lib/libm2/rckul.c Executable file
View File

@@ -0,0 +1,24 @@
/*
* (c) copyright 1988 by the Vrije Universiteit, Amsterdam, The Netherlands.
* See the copyright notice in the ACK home directory, in the file "Copyright".
*
*
* Module: range checks for LONGCARD
* Author: Ceriel J.H. Jacobs
* Version: $Header$
*/
#include <em_abs.h>
extern TRP();
struct range_descr {
unsigned long low, high;
};
rckul(descr, val)
struct range_descr *descr;
unsigned long val;
{
if (val < descr->low || val > descr->high) TRP(ERANGE);
}

82
lib/libm2/sigtrp.c Executable file
View File

@@ -0,0 +1,82 @@
/*
(c) copyright 1988 by the Vrije Universiteit, Amsterdam, The Netherlands.
See the copyright notice in the ACK home directory, in the file "Copyright".
*/
/*
Module: Mapping of Unix signals to EM traps
(only when not using the MON instruction)
Author: Ceriel J.H. Jacobs
Version: $Header$
*/
#if !defined(__em22) && !defined(__em24) && !defined(__em44)
#define EM_trap(n) TRP(n) /* define to whatever is needed to cause the trap */
#include <signal.h>
#include <errno.h>
int __signo;
static int __traps[] = {
-2, -2, -2, -2, -2, -2, -2, -2, -2, -2, -2, -2, -2, -2, -2, -2,
-2, -2, -2, -2, -2, -2, -2, -2, -2, -2, -2, -2, -2, -2, -2, -2,
-2, -2, -2, -2, -2, -2, -2, -2, -2, -2, -2, -2, -2, -2, -2, -2,
};
static void
__ctchsig(signo)
{
signal(signo,__ctchsig);
#ifdef __BSD4_2
sigsetmask(sigblock(0) & ~(1<<(signo - 1)));
#endif
__signo = signo;
EM_trap(__traps[signo]);
}
int
sigtrp(trapno, signo)
{
/* Let Unix signal signo cause EM trap trapno to occur.
If trapno = -2, restore default,
If trapno = -3, ignore.
Return old trapnumber.
Careful, this could be -2 or -3; But return value of -1
indicates failure, with error number in errno.
*/
extern int errno;
void (*ctch)() = __ctchsig;
void (*oldctch)();
int oldtrap;
if (signo <= 0 || signo >= sizeof(__traps)/sizeof(__traps[0])) {
errno = EINVAL;
return -1;
}
if (trapno == -3)
ctch = SIG_IGN;
else if (trapno == -2)
ctch = SIG_DFL;
else if (trapno >= 0 && trapno <= 252)
;
else {
errno = EINVAL;
return -1;
}
oldtrap = __traps[signo];
if ((oldctch = signal(signo, ctch)) == (void (*)())-1) /* errno set by signal */
return -1;
else if (oldctch == SIG_IGN) {
signal(signo, SIG_IGN);
}
else __traps[signo] = trapno;
return oldtrap;
}
#endif

27
lib/libm2/stackprio.c Executable file
View File

@@ -0,0 +1,27 @@
/*
(c) copyright 1988 by the Vrije Universiteit, Amsterdam, The Netherlands.
See the copyright notice in the ACK home directory, in the file "Copyright".
*/
/*
Module: Dummy priority routines
Author: Ceriel J.H. Jacobs
Version: $Header$
*/
static unsigned prio = 0;
stackprio(n)
unsigned n;
{
unsigned old = prio;
if (n > prio) prio = n;
return old;
}
unstackprio(n)
unsigned n;
{
prio = n;
}

43
lib/libm2/store.c Executable file
View File

@@ -0,0 +1,43 @@
/*
(c) copyright 1988 by the Vrije Universiteit, Amsterdam, The Netherlands.
See the copyright notice in the ACK home directory, in the file "Copyright".
*/
/*
Module: store values from stack, byte by byte
Author: Ceriel J.H. Jacobs
Version: $Header$
*/
#include <m2_traps.h>
#ifndef EM_WSIZE
#define EM_WSIZE _EM_WSIZE
#define EM_PSIZE _EM_PSIZE
#endif
#if EM_WSIZE==EM_PSIZE
typedef unsigned pcnt;
#else
typedef long pcnt;
#endif
store(siz, addr, p)
register char *addr;
register pcnt siz;
{
/* Make sure, that a value with a size that could have been
handled by the LOI instruction is handled as if it was
loaded with the LOI instruction.
*/
register char *q = (char *) &p;
char t[4];
if (siz < EM_WSIZE && EM_WSIZE % siz == 0) {
/* as long as EM_WSIZE <= 4 ... */
if (siz != 2) TRP(M2_INTERNAL); /* internal error */
*((unsigned short *) (&t[0])) = *((unsigned *) q);
q = &t[0];
}
while (siz--) *addr++ = *q++;
}

65
lib/libm2/ucheck.c Executable file
View File

@@ -0,0 +1,65 @@
/*
* (c) copyright 1988 by the Vrije Universiteit, Amsterdam, The Netherlands.
* See the copyright notice in the ACK home directory, in the file "Copyright".
*
*
* Module: CARDINAL operations with overflow checking
* Author: Ceriel J.H. Jacobs
* Version: $Header$
*/
#ifndef EM_WSIZE
#define EM_WSIZE _EM_WSIZE
#endif
#ifndef EM_LSIZE
#define EM_LSIZE _EM_LSIZE
#endif
#include <m2_traps.h>
#define MAXCARD ((unsigned)-1)
#if EM_WSIZE < EM_LSIZE
#define MAXLONGCARD ((unsigned long) -1L)
#endif
adduchk(a,b)
unsigned a,b;
{
if (MAXCARD - a < b) TRP(M2_UOVFL);
}
#if EM_WSIZE < EM_LSIZE
addulchk(a,b)
unsigned long a,b;
{
if (MAXLONGCARD - a < b) TRP(M2_UOVFL);
}
#endif
muluchk(a,b)
unsigned a,b;
{
if (a != 0 && MAXCARD/a < b) TRP(M2_UOVFL);
}
#if EM_WSIZE < EM_LSIZE
mululchk(a,b)
unsigned long a,b;
{
if (a != 0 && MAXLONGCARD/a < b) TRP(M2_UOVFL);
}
#endif
subuchk(a,b)
unsigned a,b;
{
if (b < a) TRP(M2_UUVFL);
}
#if EM_WSIZE < EM_LSIZE
subulchk(a,b)
unsigned long a,b;
{
if (b < a) TRP(M2_UUVFL);
}
#endif