--- /dev/null
+DEFINITION MODULE ASCII;
+
+CONST
+ nul = 00C; soh = 01C; stx = 02C; etx = 03C;
+ eot = 04C; enq = 05C; ack = 06C; bel = 07C;
+ bs = 10C; ht = 11C; lf = 12C; vt = 13C;
+ ff = 14C; cr = 15C; so = 16C; si = 17C;
+ dle = 20C; dc1 = 21C; dc2 = 22C; dc3 = 23C;
+ dc4 = 24C; nak = 25C; syn = 26C; etb = 27C;
+ can = 30C; em = 31C; sub = 32C; esc = 33C;
+ fs = 34C; gs = 35C; rs = 36C; us = 37C;
+ del = 177C;
+
+END ASCII.
--- /dev/null
+IMPLEMENTATION MODULE ASCII;
+BEGIN
+END ASCII.
--- /dev/null
+extern char **_argv, **_environ;
+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 = _environ;
+ register char *v = 0;
+
+ while (*p && !(v = findname(name, *p++))) {
+ /* nothing */
+ }
+ if (!v) return 0;
+ return scopy(v, value, u);
+}
--- /dev/null
+DEFINITION MODULE Arguments;
+(* Routines and variables to access the programs arguments and
+ environment
+*)
+
+VAR Argc: CARDINAL; (* Number of program arguments, including the program
+ name, so it is at least 1.
+ *)
+
+PROCEDURE Argv( argnum : CARDINAL;
+ VAR argument : ARRAY OF CHAR
+ ) : CARDINAL;
+(* Stores the "argnum'th" argument in "argument", and returns its length,
+ including a terminating null-byte. If it returns 0, the argument was not
+ present, and if it returns a number larger than the size of "argument",
+ "argument" was'nt large enough.
+ Argument 0 contains the program name.
+*)
+
+PROCEDURE GetEnv( name : ARRAY OF CHAR;
+ VAR value : ARRAY OF CHAR
+ ) : CARDINAL;
+(* Searches the environment list for a string of the form
+ name=value
+ and stores the value in "value", if such a string is present.
+ It returns the length of the "value" part, including a terminating
+ null-byte. If it returns 0, such a string is not present, and
+ if it returns a number larger than the size of the "value",
+ "value" was'nt large enough.
+ The string in "name" must be null_terminated.
+*)
+END Arguments.
--- /dev/null
+DEFINITION MODULE Conversions;
+
+ PROCEDURE ConvertOctal(num, len: CARDINAL; VAR str: ARRAY OF CHAR);
+ (* Convert number "num" to right-justified octal representation of
+ "len" positions, and put the result in "str".
+ If the result does not fit in "str", it is truncated on the right.
+ *)
+
+ PROCEDURE ConvertHex(num, len: CARDINAL; VAR str: ARRAY OF CHAR);
+ (* Convert a hexadecimal number to a string *)
+
+ PROCEDURE ConvertCardinal(num, len: CARDINAL; VAR str: ARRAY OF CHAR);
+ (* Convert a cardinal number to a string *)
+
+ PROCEDURE ConvertInteger(num: INTEGER;
+ len: CARDINAL;
+ VAR str: ARRAY OF CHAR);
+ (* Convert an integer number to a string *)
+
+END Conversions.
--- /dev/null
+IMPLEMENTATION MODULE Conversions;
+
+ 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;
+ IF neg THEN
+ tmp[0] := '-';
+ i := 1;
+ END;
+ 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 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;
+ IF r <= HIGH(str) THEN str[r] := 0C; 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 THEN
+ ConvertNum(-num, len, 10, TRUE, str);
+ ELSE
+ ConvertNum(num, len, 10, FALSE, str);
+ END;
+ END ConvertInteger;
+
+END Conversions.
--- /dev/null
+DEFINITION MODULE FIFFEF;
+
+ PROCEDURE FIF(arg1, arg2: REAL; VAR intres: REAL) : REAL;
+ (* multiplies arg1 and arg2, and returns the integer part of the
+ result in "intres" and the fraction part as the function result.
+ *)
+
+ PROCEDURE FEF(arg: REAL; VAR exp: INTEGER) : REAL;
+ (* splits "arg" in mantissa and a base-2 exponent.
+ The mantissa is returned, and the exponent is left in "exp".
+ *)
+END FIFFEF.
--- /dev/null
+#
+ mes 2,EM_WSIZE,EM_PSIZE
+
+#define ARG1 0
+#define ARG2 EM_FSIZE
+#define IRES 2*EM_FSIZE
+
+; FIFFEF_FIF is called with three parameters:
+; - address of integer part result (IRES)
+; - float two (ARG2)
+; - float one (ARG1)
+; and returns an EM_FSIZE-byte floating point number
+; Definition:
+; PROCEDURE FIF(ARG1, ARG2: REAL; VAR IRES: REAL) : REAL;
+
+ exp $FIFFEF_FIF
+ pro $FIFFEF_FIF,0
+ lal 0
+ loi 2*EM_FSIZE
+ fif EM_FSIZE
+ lal IRES
+ loi EM_PSIZE
+ sti EM_FSIZE
+ ret EM_FSIZE
+ end ?
+
+#define FARG 0
+#define ERES EM_FSIZE
+
+; FIFFEF_FEF is called with two parameters:
+; - address of base 2 exponent result (ERES)
+; - floating point number to be split (FARG)
+; and returns an EM_FSIZE-byte floating point number (the mantissa)
+; Definition:
+; PROCEDURE FEF(FARG: REAL; VAR ERES: integer): REAL;
+
+ exp $FIFFEF_FEF
+ pro $FIFFEF_FEF,0
+ lal FARG
+ loi EM_FSIZE
+ fef EM_FSIZE
+ lal ERES
+ loi EM_PSIZE
+ sti EM_WSIZE
+ ret EM_FSIZE
+ end ?
+
+ exp $FIFFEF
+ pro $FIFFEF,0
+ ret 0
+ end ?
--- /dev/null
+DEFINITION MODULE InOut;
+
+ CONST EOL = 12C;
+
+ VAR Done : BOOLEAN;
+ termCH : CHAR;
+
+ PROCEDURE OpenInput(defext: ARRAY OF CHAR);
+ (* Request a file name from the standard input stream and open
+ this file for reading.
+ If the filename ends with a '.', append the "defext" extension.
+ Done := "file was successfully opened".
+ If open, subsequent input is read from this file.
+ *)
+
+ PROCEDURE OpenOutput(defext : ARRAY OF CHAR);
+ (* Request a file name from the standard input stream and open
+ this file for writing.
+ If the filename ends with a '.', append the "defext" extension.
+ Done := "file was successfully opened".
+ If open, subsequent output is written to this file.
+ *)
+
+ PROCEDURE OpenInputFile(filename: ARRAY OF CHAR);
+ (* Like OpenInput, but filename given as parameter
+ *)
+
+ PROCEDURE OpenOutputFile(filename: ARRAY OF CHAR);
+ (* Like OpenOutput, but filename given as parameter
+ *)
+
+ PROCEDURE CloseInput;
+ (* Close input file. Subsequent input is read from the standard input
+ stream.
+ *)
+
+ PROCEDURE CloseOutput;
+ (* Close output file. Subsequent output is written to the standard
+ output stream.
+ *)
+
+ PROCEDURE Read(VAR ch : CHAR);
+ (* Read a character from the current input stream and leave it in "ch".
+ Done := NOT "end of file".
+ *)
+
+ PROCEDURE ReadString(VAR s : ARRAY OF CHAR);
+ (* Read a string from the current input stream and leave it in "s".
+ A string is any sequence of characters not containing blanks or
+ control characters; leading blanks are ignored.
+ Input is terminated by any character <= " ".
+ This character is assigned to termCH.
+ DEL or BACKSPACE is used for backspacing when input from terminal.
+ *)
+
+ PROCEDURE ReadInt(VAR x : INTEGER);
+ (* Read a string and convert it to INTEGER.
+ Syntax: integer = ['+'|'-'] digit {digit}.
+ Leading blanks are ignored.
+ Done := "integer was read".
+ *)
+
+ PROCEDURE ReadCard(VAR x : CARDINAL);
+ (* Read a string and convert it to CARDINAL.
+ Syntax: cardinal = digit {digit}.
+ Leading blanks are ignored.
+ Done := "cardinal was read".
+ *)
+
+ PROCEDURE Write(ch : CHAR);
+ (* Write character "ch" to the current output stream.
+ *)
+
+ PROCEDURE WriteLn;
+ (* Terminate line.
+ *)
+
+ PROCEDURE WriteString(s : ARRAY OF CHAR);
+ (* Write string "s" to the current output stream
+ *)
+
+ PROCEDURE WriteInt(x : INTEGER; n : CARDINAL);
+ (* Write integer x with (at least) n characters on the current output
+ stream. If n is greater that the number of digits needed,
+ blanks are added preceding the number.
+ *)
+
+ PROCEDURE WriteCard(x, n : CARDINAL);
+ (* Write cardinal x with (at least) n characters on the current output
+ stream. If n is greater that the number of digits needed,
+ blanks are added preceding the number.
+ *)
+
+ PROCEDURE WriteOct(x, n : CARDINAL);
+ (* Write cardinal x as an octal number with (at least) n characters
+ on the current output stream.
+ If n is greater that the number of digits needed,
+ blanks are added preceding the number.
+ *)
+
+ PROCEDURE WriteHex(x, n : CARDINAL);
+ (* Write cardinal x as a hexadecimal number with (at least)
+ n characters on the current output stream.
+ If n is greater that the number of digits needed,
+ blanks are added preceding the number.
+ *)
+
+END InOut.
--- /dev/null
+IMPLEMENTATION MODULE InOut ;
+
+ IMPORT Unix;
+ IMPORT Conversions;
+ FROM TTY IMPORT isatty;
+ FROM SYSTEM IMPORT ADR;
+
+ CONST BUFSIZ = 1024; (* Tunable *)
+ TAB = 11C;
+
+ TYPE IOBuf = RECORD
+ fildes: INTEGER;
+ cnt: INTEGER;
+ maxcnt: INTEGER;
+ bufferedcount: INTEGER;
+ buf: ARRAY [1..BUFSIZ] OF CHAR;
+ END;
+ numbuf = ARRAY[0..255] OF CHAR;
+
+ VAR ibuf, obuf: IOBuf;
+ unread: BOOLEAN;
+ unreadch: CHAR;
+
+ PROCEDURE Read(VAR c : CHAR);
+ BEGIN
+ IF unread THEN
+ unread := FALSE;
+ c := unreadch;
+ ELSE
+ WITH ibuf DO
+ IF cnt <= maxcnt THEN
+ c := buf[cnt];
+ INC(cnt);
+ Done := TRUE;
+ ELSE
+ c := FillBuf(ibuf);
+ END;
+ END;
+ END;
+ END Read;
+
+ PROCEDURE UnRead(ch: CHAR);
+ BEGIN
+ unread := TRUE;
+ unreadch := ch;
+ END UnRead;
+
+ PROCEDURE FillBuf(VAR ib: IOBuf) : CHAR;
+ VAR c : CHAR;
+ BEGIN
+ WITH ib DO
+ maxcnt := Unix.read(fildes, ADR(buf), bufferedcount);
+ cnt := 2;
+ Done := maxcnt > 0;
+ IF NOT Done THEN
+ c := 0C;
+ ELSE
+ c := buf[1];
+ END;
+ END;
+ RETURN c;
+ END FillBuf;
+
+ PROCEDURE Flush(VAR ob: IOBuf);
+ VAR dummy: INTEGER;
+ BEGIN
+ WITH ob DO
+ dummy := Unix.write(fildes, ADR(buf), cnt);
+ cnt := 0;
+ END;
+ END Flush;
+
+ PROCEDURE Write(c: CHAR);
+ BEGIN
+ WITH obuf DO
+ INC(cnt);
+ buf[cnt] := c;
+ IF cnt >= bufferedcount THEN
+ Flush(obuf);
+ END;
+ END;
+ END Write;
+
+ PROCEDURE OpenInput(defext: ARRAY OF CHAR);
+ VAR namebuf : ARRAY [1..256] OF CHAR;
+ BEGIN
+ IF ibuf.fildes # 0 THEN
+ CloseInput;
+ END;
+ MakeFileName("Name of input file: ", defext, namebuf);
+ IF (namebuf[1] = '-') AND (namebuf[2] = 0C) THEN
+ ELSE
+ WITH ibuf DO
+ fildes := Unix.open(ADR(namebuf), 0);
+ Done := fildes >= 0;
+ maxcnt := 0;
+ cnt := 1;
+ END;
+ END;
+ END OpenInput;
+
+ PROCEDURE OpenInputFile(filename: ARRAY OF CHAR);
+ BEGIN
+ IF ibuf.fildes # 0 THEN
+ CloseInput;
+ END;
+ IF (filename[0] = '-') AND (filename[1] = 0C) THEN
+ ELSE
+ WITH ibuf DO
+ fildes := Unix.open(ADR(filename), 0);
+ Done := fildes >= 0;
+ maxcnt := 0;
+ cnt := 1;
+ END;
+ END;
+ END OpenInputFile;
+
+ PROCEDURE CloseInput;
+ BEGIN
+ WITH ibuf DO
+ IF (fildes > 0) AND (Unix.close(fildes) < 0) THEN
+ ;
+ END;
+ fildes := 0;
+ maxcnt := 0;
+ cnt := 1;
+ END;
+ END CloseInput;
+
+ PROCEDURE OpenOutput(defext: ARRAY OF CHAR);
+ VAR namebuf : ARRAY [1..256] OF CHAR;
+ BEGIN
+ IF obuf.fildes # 1 THEN
+ CloseOutput;
+ END;
+ MakeFileName("Name of output file: ", defext, namebuf);
+ IF (namebuf[1] = '-') AND (namebuf[2] = 0C) THEN
+ ELSE
+ WITH obuf DO
+ fildes := Unix.creat(ADR(namebuf), 666B);
+ Done := fildes >= 0;
+ bufferedcount := BUFSIZ;
+ cnt := 0;
+ END;
+ END;
+ END OpenOutput;
+
+ PROCEDURE OpenOutputFile(filename: ARRAY OF CHAR);
+ BEGIN
+ IF obuf.fildes # 1 THEN
+ CloseOutput;
+ END;
+ IF (filename[0] = '-') AND (filename[1] = 0C) THEN
+ ELSE
+ WITH obuf DO
+ fildes := Unix.creat(ADR(filename), 666B);
+ Done := fildes >= 0;
+ bufferedcount := BUFSIZ;
+ cnt := 0;
+ END;
+ END;
+ END OpenOutputFile;
+
+ PROCEDURE CloseOutput;
+ BEGIN
+ Flush(obuf);
+ WITH obuf DO
+ IF (fildes # 1) AND (Unix.close(fildes) < 0) THEN
+ ;
+ END;
+ fildes := 1;
+ bufferedcount := 1;
+ cnt := 0;
+ END;
+ END CloseOutput;
+
+ PROCEDURE MakeFileName(prompt, defext : ARRAY OF CHAR;
+ VAR buf : ARRAY OF CHAR);
+ VAR i, k : INTEGER;
+ j : CARDINAL;
+ ch: CHAR;
+ BEGIN
+ FOR k := 1 TO 3 DO
+ IF isatty(0) 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;
+ END;
+ Error("no proper file name in three attempts. Giving up.");
+ END MakeFileName;
+
+ PROCEDURE Error(s: ARRAY OF CHAR);
+ VAR Xch: ARRAY[1..1] OF CHAR;
+ BEGIN
+ XWriteString("Error: ");
+ XWriteString(s);
+ Xch[1] := 12C;
+ XWriteString(Xch);
+ Unix.exit(1);
+ END Error;
+
+ PROCEDURE ReadInt(VAR integ : INTEGER);
+ CONST
+ SAFELIMITDIV10 = MAX(INTEGER) DIV 10;
+ SAFELIMITREM10 = MAX(INTEGER) MOD 10;
+ VAR
+ int : INTEGER;
+ ch : CHAR;
+ neg : BOOLEAN;
+ safedigit: [0 .. 9];
+ chvalue: CARDINAL;
+ BEGIN
+ Read(ch);
+ WHILE (ch = ' ') OR (ch = TAB) OR (ch = 12C) DO
+ Read(ch)
+ END;
+ IF ch = '-' THEN
+ neg := TRUE;
+ Read(ch)
+ ELSIF ch = '+' THEN
+ neg := FALSE;
+ Read(ch)
+ ELSE
+ neg := FALSE
+ END;
+
+ safedigit := SAFELIMITREM10;
+ IF neg THEN safedigit := safedigit + 1 END;
+ int := 0;
+ IF (ch >= '0') & (ch <= '9') THEN
+ WHILE (ch >= '0') & (ch <= '9') DO
+ chvalue := ORD(ch) - ORD('0');
+ IF (int > SAFELIMITDIV10) OR
+ ( (int = SAFELIMITDIV10) AND
+ (chvalue > safedigit)) THEN
+ Error("integer overflow");
+ ELSE
+ int := 10*int + VAL(INTEGER, chvalue);
+ Read(ch)
+ END;
+ END;
+ IF neg THEN
+ integ := -int
+ ELSE
+ integ := int
+ END;
+ Done := TRUE;
+ ELSE
+ Done := FALSE
+ END;
+ UnRead(ch)
+ END ReadInt;
+
+ PROCEDURE ReadCard(VAR card : CARDINAL);
+ CONST
+ SAFELIMITDIV10 = MAX(CARDINAL) DIV 10;
+ SAFELIMITREM10 = MAX(CARDINAL) MOD 10;
+
+ VAR
+ int : CARDINAL;
+ ch : CHAR;
+ safedigit: [0 .. 9];
+ chvalue: CARDINAL;
+ BEGIN
+ Read(ch);
+ WHILE (ch = ' ') OR (ch = TAB) OR (ch = 12C) DO
+ Read(ch)
+ END;
+
+ safedigit := SAFELIMITREM10;
+ int := 0;
+ IF (ch >= '0') & (ch <= '9') THEN
+ WHILE (ch >= '0') & (ch <= '9') DO
+ chvalue := ORD(ch) - ORD('0');
+ IF (int > SAFELIMITDIV10) OR
+ ( (int = SAFELIMITDIV10) AND
+ (chvalue > safedigit)) THEN
+ Error("cardinal overflow");
+ ELSE
+ int := 10*int + chvalue;
+ Read(ch)
+ END;
+ END;
+ card := int;
+ Done := TRUE;
+ ELSE
+ Done := FALSE
+ END;
+ UnRead(ch)
+ END ReadCard;
+
+ PROCEDURE ReadString(VAR s : ARRAY OF CHAR);
+ VAR i : CARDINAL;
+ ch : CHAR;
+
+ BEGIN
+ i := 0;
+ LOOP
+ Read(ch);
+ termCH := ch;
+ IF (NOT Done) OR (ch <= " ") THEN s[i] := 0C; RETURN END;
+ s[i] := ch;
+ INC(i);
+ IF i > HIGH(s) THEN DEC(i); END;
+ END;
+ END ReadString;
+
+ PROCEDURE XReadString(VAR s : ARRAY OF CHAR);
+ VAR i : INTEGER;
+ j : CARDINAL;
+ ch : CHAR;
+
+ BEGIN
+ j := 0;
+ LOOP
+ i := Unix.read(0, ADR(ch), 1);
+ IF i < 0 THEN
+ Error("failed read");
+ 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
+ INC(i);
+ ELSE
+ EXIT;
+ END;
+ END;
+ IF Unix.write(1, ADR(s), i) < 0 THEN
+ ;
+ END;
+ END XWriteString;
+
+ PROCEDURE WriteCard(card, width : CARDINAL);
+ VAR
+ buf : numbuf;
+ BEGIN
+ Conversions.ConvertCardinal(card, width, buf);
+ WriteString(buf);
+ END WriteCard;
+
+ PROCEDURE WriteInt(int : INTEGER; width : CARDINAL);
+ VAR
+ buf : numbuf;
+ BEGIN
+ Conversions.ConvertInteger(int, width, buf);
+ WriteString(buf);
+ END WriteInt;
+
+ PROCEDURE WriteHex(card, width : CARDINAL);
+ VAR
+ buf : numbuf;
+ BEGIN
+ Conversions.ConvertHex(card, width, buf);
+ WriteString(buf);
+ END WriteHex;
+
+ PROCEDURE WriteLn;
+ BEGIN
+ Write(EOL)
+ END WriteLn;
+
+ PROCEDURE WriteOct(card, width : CARDINAL);
+ VAR
+ buf : numbuf;
+ BEGIN
+ Conversions.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 *)
+ WITH ibuf DO
+ fildes := 0;
+ bufferedcount := BUFSIZ;
+ maxcnt := 0;
+ cnt := 1;
+ END;
+ WITH obuf DO
+ fildes := 1;
+ bufferedcount := 1;
+ cnt := 0;
+ END;
+END InOut.
--- /dev/null
+tail_m2.a
+InOut.mod
+Terminal.mod
+TTY.mod
+ASCII.mod
+FIFFEF.e
+MathLib0.mod
+Processes.mod
+RealInOut.mod
+Storage.mod
+Conversion.mod
+Semaphores.mod
+random.mod
+Strings.mod
+Arguments.c
+catch.c
+hol0.e
+LtoUset.e
+StrAss.c
+absd.c
+absf.e
+absi.c
+absl.c
+halt.c
+transfer.e
+store.c
+load.c
+stackprio.c
--- /dev/null
+#
+ mes 2,EM_WSIZE,EM_PSIZE
+
+ ; _LtoUset is called for set displays containing { expr1 .. expr2 }.
+ ; It has five parameters, of which the caller must pop four:
+ ; - The set in which bits must be set.
+ ; - 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 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
+1
+ lol LWB ; low bound
+ lol UPB ; high bound
+ bgt *2 ; while low <= high
+ lol LWB
+ lol SETSIZE
+ set ? ; create [low]
+ lol SETSIZE
+ ior ? ; merge with initial set
+ inl LWB ; increment low bound
+ bra *1 ; loop back
+2
+ lal SETBASE
+ lol SETSIZE
+ sts EM_WSIZE ; store result over initial set
+ ret 0
+ end 0
--- /dev/null
+HOME = ../../..
+DEFDIR = $(HOME)/lib/m2
+
+SOURCES = ASCII.def FIFFEF.def MathLib0.def Processes.def \
+ RealInOut.def Storage.def Arguments.def Conversion.def \
+ random.def Semaphores.def Unix.def \
+ Strings.def InOut.def Terminal.def TTY.def
+
+all:
+
+install:
+ -mkdir $(DEFDIR)
+ for i in $(SOURCES) ; do cp $$i $(DEFDIR)/$$i ; done
--- /dev/null
+DEFINITION MODULE MathLib0;
+
+ PROCEDURE sqrt(x : REAL) : REAL;
+
+ PROCEDURE exp(x : REAL) : REAL;
+
+ PROCEDURE ln(x : REAL) : REAL;
+
+ PROCEDURE sin(x : REAL) : REAL;
+
+ PROCEDURE cos(x : REAL) : REAL;
+
+ PROCEDURE arctan(x : REAL) : REAL;
+
+ PROCEDURE real(x : INTEGER) : REAL;
+
+ PROCEDURE entier(x : REAL) : INTEGER;
+
+END MathLib0.
--- /dev/null
+IMPLEMENTATION MODULE MathLib0;
+(* Rewritten in Modula-2.
+ The originals came from the Pascal runtime library.
+*)
+
+FROM FIFFEF IMPORT FIF, FEF;
+
+CONST
+ HUGE = 1.701411733192644270E38;
+
+PROCEDURE sinus(arg: REAL; quad: INTEGER): REAL;
+
+(* Coefficients for sin/cos are #3370 from Hart & Cheney (18.80D).
+*)
+CONST
+ twoopi = 0.63661977236758134308;
+ p0 = 0.1357884097877375669092680E8;
+ p1 = -0.4942908100902844161158627E7;
+ p2 = 0.4401030535375266501944918E6;
+ p3 = -0.1384727249982452873054457E5;
+ p4 = 0.1459688406665768722226959E3;
+ q0 = 0.8644558652922534429915149E7;
+ q1 = 0.4081792252343299749395779E6;
+ q2 = 0.9463096101538208180571257E4;
+ q3 = 0.1326534908786136358911494E3;
+VAR
+ e, f: REAL;
+ ysq: REAL;
+ x,y: REAL;
+ k: INTEGER;
+ temp1, temp2: REAL;
+BEGIN
+ x := arg;
+ IF x < 0.0 THEN
+ x := -x;
+ quad := quad + 2;
+ END;
+ x := x*twoopi; (*underflow?*)
+ IF x>32764.0 THEN
+ y := FIF(x, 10.0, e);
+ e := e + FLOAT(quad);
+ temp1 := FIF(0.25, e, f);
+ quad := TRUNC(e - 4.0*f);
+ ELSE
+ k := TRUNC(x);
+ y := x - FLOAT(k);
+ quad := (quad + k) MOD 4;
+ END;
+ IF ODD(quad) THEN
+ y := 1.0-y;
+ END;
+ IF quad > 1 THEN
+ y := -y;
+ END;
+
+ ysq := y*y;
+ temp1 := ((((p4*ysq+p3)*ysq+p2)*ysq+p1)*ysq+p0)*y;
+ temp2 := ((((ysq+q3)*ysq+q2)*ysq+q1)*ysq+q0);
+ RETURN temp1/temp2;
+END sinus;
+
+PROCEDURE cos(arg: REAL): REAL;
+BEGIN
+ IF arg < 0.0 THEN
+ arg := -arg;
+ END;
+ RETURN sinus(arg, 1);
+END cos;
+
+PROCEDURE sin(arg: REAL): REAL;
+BEGIN
+ RETURN sinus(arg, 0);
+END sin;
+
+(*
+ floating-point arctangent
+
+ arctan returns the value of the arctangent of its
+ argument in the range [-pi/2,pi/2].
+
+ coefficients are #5077 from Hart & Cheney. (19.56D)
+*)
+
+CONST
+ sq2p1 = 2.414213562373095048802E0;
+ sq2m1 = 0.414213562373095048802E0;
+ pio2 = 1.570796326794896619231E0;
+ pio4 = 0.785398163397448309615E0;
+ p4 = 0.161536412982230228262E2;
+ p3 = 0.26842548195503973794141E3;
+ p2 = 0.11530293515404850115428136E4;
+ p1 = 0.178040631643319697105464587E4;
+ p0 = 0.89678597403663861959987488E3;
+ q4 = 0.5895697050844462222791E2;
+ q3 = 0.536265374031215315104235E3;
+ q2 = 0.16667838148816337184521798E4;
+ q1 = 0.207933497444540981287275926E4;
+ q0 = 0.89678597403663861962481162E3;
+
+(*
+ xatan evaluates a series valid in the
+ range [-0.414...,+0.414...].
+*)
+
+PROCEDURE xatan(arg: REAL) : REAL;
+VAR
+ argsq, value: REAL;
+BEGIN
+ argsq := arg*arg;
+ value := ((((p4*argsq + p3)*argsq + p2)*argsq + p1)*argsq + p0);
+ value := value/(((((argsq + q4)*argsq + q3)*argsq + q2)*argsq + q1)*argsq + q0);
+ RETURN value*arg;
+END xatan;
+
+PROCEDURE satan(arg: REAL): REAL;
+BEGIN
+ IF arg < sq2m1 THEN
+ RETURN xatan(arg);
+ ELSIF arg > sq2p1 THEN
+ RETURN pio2 - xatan(1.0/arg);
+ ELSE
+ RETURN pio4 + xatan((arg-1.0)/(arg+1.0));
+ END;
+END satan;
+
+(*
+ atan makes its argument positive and
+ calls the inner routine satan.
+*)
+
+PROCEDURE arctan(arg: REAL): REAL;
+BEGIN
+ IF arg>0.0 THEN
+ RETURN satan(arg);
+ ELSE
+ RETURN -satan(-arg);
+ END;
+END arctan;
+
+(*
+ sqrt returns the square root of its floating
+ point argument. Newton's method.
+*)
+
+PROCEDURE sqrt(arg: REAL): REAL;
+VAR
+ x, temp: REAL;
+ exp, i: INTEGER;
+BEGIN
+ IF arg <= 0.0 THEN
+ IF arg < 0.0 THEN
+ (* ??? *)
+ ;
+ END;
+ RETURN 0.0;
+ END;
+ x := FEF(arg,exp);
+ (*
+ * NOTE
+ * this wont work on 1's comp
+ *)
+ IF ODD(exp) THEN
+ x := 2.0 * x;
+ DEC(exp);
+ END;
+ temp := 0.5*(1.0 + x);
+
+ WHILE exp > 28 DO
+ temp := temp * 16384.0;
+ exp := exp - 28;
+ END;
+ WHILE exp < -28 DO
+ temp := temp / 16384.0;
+ exp := exp + 28;
+ END;
+ WHILE exp >= 2 DO
+ temp := temp * 2.0;
+ exp := exp - 2;
+ END;
+ WHILE exp <= -2 DO
+ temp := temp / 2.0;
+ exp := exp + 2;
+ END;
+ FOR i := 0 TO 4 DO
+ temp := 0.5*(temp + arg/temp);
+ END;
+ RETURN temp;
+END sqrt;
+
+(*
+ ln returns the natural logarithm of its floating
+ point argument.
+
+ The coefficients are #2705 from Hart & Cheney. (19.38D)
+*)
+PROCEDURE ln(arg: REAL): REAL;
+CONST
+ log2 = 0.693147180559945309E0;
+ sqrto2 = 0.707106781186547524E0;
+ p0 = -0.240139179559210510E2;
+ p1 = 0.309572928215376501E2;
+ p2 = -0.963769093368686593E1;
+ p3 = 0.421087371217979714E0;
+ q0 = -0.120069589779605255E2;
+ q1 = 0.194809660700889731E2;
+ q2 = -0.891110902798312337E1;
+VAR
+ x,z, zsq, temp: REAL;
+ exp: INTEGER;
+BEGIN
+ IF arg <= 0.0 THEN
+ (* ??? *)
+ RETURN -HUGE;
+ END;
+ x := FEF(arg,exp);
+ IF x<sqrto2 THEN
+ x := x + x;
+ DEC(exp);
+ END;
+
+ z := (x-1.0)/(x+1.0);
+ zsq := z*z;
+
+ temp := ((p3*zsq + p2)*zsq + p1)*zsq + p0;
+ temp := temp/(((zsq + q2)*zsq + q1)*zsq + q0);
+ temp := temp*z + FLOAT(exp)*log2;
+ RETURN temp;
+END ln;
+
+(*
+ exp returns the exponential function of its
+ floating-point argument.
+
+ The coefficients are #1069 from Hart and Cheney. (22.35D)
+*)
+
+PROCEDURE floor(d: REAL): REAL;
+BEGIN
+ IF d < 0.0 THEN
+ d := -d;
+ IF FIF(d, 1.0, d) # 0.0 THEN
+ d := d + 1.0;
+ END;
+ d := -d;
+ ELSE
+ IF FIF(d, 1.0, d) # 0.0 THEN
+ (* just ignore result of FIF *)
+ ;
+ END;
+ END;
+ RETURN d;
+END floor;
+
+PROCEDURE ldexp(fr: REAL; exp: INTEGER): REAL;
+VAR
+ neg,i: INTEGER;
+BEGIN
+ neg := 1;
+ IF fr < 0.0 THEN
+ fr := -fr;
+ neg := -1;
+ END;
+ fr := FEF(fr, i);
+ exp := exp + i;
+ IF exp > 127 THEN
+ (* Too large. ??? *)
+ RETURN FLOAT(neg) * HUGE;
+ END;
+ IF exp < -127 THEN
+ RETURN 0.0;
+ END;
+ WHILE exp > 14 DO
+ fr := fr * 16384.0;
+ exp := exp - 14;
+ END;
+ WHILE exp < -14 DO
+ fr := fr / 16384.0;
+ exp := exp + 14;
+ END;
+ WHILE exp > 0 DO
+ fr := fr + fr;
+ DEC(exp);
+ END;
+ WHILE exp < 0 DO
+ fr := fr / 2.0;
+ INC(exp);
+ END;
+ RETURN FLOAT(neg) * fr;
+END ldexp;
+
+PROCEDURE exp(arg: REAL): REAL;
+CONST
+ p0 = 0.2080384346694663001443843411E7;
+ p1 = 0.3028697169744036299076048876E5;
+ p2 = 0.6061485330061080841615584556E2;
+ q0 = 0.6002720360238832528230907598E7;
+ q1 = 0.3277251518082914423057964422E6;
+ q2 = 0.1749287689093076403844945335E4;
+ log2e = 1.4426950408889634073599247;
+ sqrt2 = 1.4142135623730950488016887;
+ maxf = 10000.0;
+VAR
+ fract: REAL;
+ temp1, temp2, xsq: REAL;
+ ent: INTEGER;
+BEGIN
+ IF arg = 0.0 THEN
+ RETURN 1.0;
+ END;
+ IF arg < -maxf THEN
+ RETURN 0.0;
+ END;
+ IF arg > maxf THEN
+ (* result too large ??? *)
+ RETURN HUGE;
+ END;
+ arg := arg * log2e;
+ ent := TRUNC(floor(arg));
+ fract := (arg-FLOAT(ent)) - 0.5;
+ xsq := fract*fract;
+ temp1 := ((p2*xsq+p1)*xsq+p0)*fract;
+ temp2 := ((xsq+q2)*xsq+q1)*xsq + q0;
+ RETURN ldexp(sqrt2*(temp2+temp1)/(temp2-temp1), ent);
+END exp;
+
+PROCEDURE entier(x: REAL): INTEGER;
+BEGIN
+ RETURN TRUNC(x); (* ??? *)
+END entier;
+
+PROCEDURE real(x: INTEGER): REAL;
+BEGIN
+ RETURN FLOAT(x); (* ??? *)
+END real;
+
+BEGIN
+END MathLib0.
--- /dev/null
+DEFINITION MODULE Processes;
+
+ TYPE SIGNAL;
+
+ PROCEDURE StartProcess(P: PROC; n: CARDINAL);
+ (* Start a concurrent process with program "P" and workspace of
+ size "n"
+ *)
+
+ PROCEDURE SEND(VAR s: SIGNAL);
+ (* One process waiting for "s" is resumed
+ *)
+
+ PROCEDURE WAIT(VAR s: SIGNAL);
+ (* Wait for some other process to send "s"
+ *)
+
+ PROCEDURE Awaited(s: SIGNAL): BOOLEAN;
+ (* Return TRUE if at least one process is waiting for sinal "s".
+ *)
+
+ PROCEDURE Init(VAR s: SIGNAL);
+ (* Compulsory initialization
+ *)
+END Processes.
--- /dev/null
+IMPLEMENTATION MODULE Processes [1];
+(* This implementation module comes from
+ "Programming in Modula-2", by Niklaus Wirth,
+ 3rd edition, Springer-Verlag, New York, 1985
+*)
+
+ FROM SYSTEM IMPORT ADDRESS, TSIZE, NEWPROCESS, TRANSFER;
+
+ FROM Storage IMPORT ALLOCATE;
+
+ 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 *)
+ 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.
--- /dev/null
+DEFINITION MODULE RealInOut;
+
+ VAR Done: BOOLEAN;
+
+ PROCEDURE ReadReal(VAR x: REAL);
+ (* Read a real number "x" according to the syntax:
+
+ ['+'|'-'] digit {digit} ['.' digit {digit}]
+ ['E' ['+'|'-'] digit [digit]]
+
+ Done := "a number was read".
+ Input terminates with a blank or any control character.
+ When reading from a terminal, backspacing may be done by either
+ DEL or BACKSPACE, depending on the implementation of ReadString.
+ *)
+
+ PROCEDURE WriteReal(x: REAL; n: CARDINAL);
+ (* Write x using n characters.
+ If fewer than n characters are needed, leading blanks are inserted.
+ *)
+
+ PROCEDURE WriteRealOct(x: REAL);
+ (* Write x in octal form with exponent and mantissa.
+ *)
+END RealInOut.
--- /dev/null
+IMPLEMENTATION MODULE RealInOut;
+
+ FROM FIFFEF IMPORT FIF, FEF;
+ IMPORT InOut;
+
+ CONST NDIG = 80;
+
+ TYPE string = ARRAY[0..NDIG+6] OF CHAR;
+
+ PROCEDURE cvt(arg: REAL;
+ ndigits: INTEGER;
+ VAR decpt: INTEGER;
+ VAR sign: BOOLEAN;
+ eflag: BOOLEAN;
+ VAR buf: string);
+ VAR r2, i: INTEGER;
+ fi, fj: REAL;
+ ind1, ind2 : INTEGER;
+ BEGIN
+ IF ndigits < 0 THEN ndigits := 0 END;
+ IF ndigits >= NDIG-1 THEN ndigits := NDIG-2; END;
+ r2 := 0;
+ sign := arg < 0.0;
+ ind1 := 0;
+ IF sign THEN arg := -arg END;
+ arg := FIF(arg, 1.0, fi);
+ (*
+ Do integer part, which is now in "fi". "arg" now contains the
+ fraction part.
+ *)
+ IF fi # 0.0 THEN
+ ind2 := NDIG;
+ WHILE fi # 0.0 DO
+ DEC(ind2);
+ buf[ind2] := CHR(TRUNC((FIF(fi, 0.1, fi) +
+ 0.03
+ ) * 10.0
+ ) + ORD('0')
+ );
+ INC(r2);
+ END;
+ WHILE ind2 < NDIG DO
+ buf[ind1] := buf[ind2];
+ INC(ind1);
+ INC(ind2);
+ END;
+ ELSIF arg > 0.0 THEN
+ WHILE arg*10.0 < 1.0 DO
+ arg := arg * 10.0;
+ fj := arg;
+ DEC(r2);
+ END;
+ END;
+ ind2 := ndigits;
+ IF NOT eflag THEN ind2 := ind2 + r2 END;
+ decpt := r2;
+ IF ind2 < 0 THEN
+ buf[0] := 0C;
+ RETURN;
+ END;
+ WHILE (ind1 <= ind2) AND (ind1 < NDIG) DO
+ arg := FIF(arg, 10.0, fj);
+ buf[ind1] := CHR(TRUNC(fj)+ORD('0'));
+ INC(ind1);
+ END;
+ IF ind2 >= NDIG THEN
+ buf[NDIG-1] := 0C;
+ RETURN;
+ END;
+ ind1 := ind2;
+ buf[ind2] := CHR(ORD(buf[ind2])+5);
+ WHILE buf[ind2] > '9' DO
+ buf[ind2] := '0';
+ IF ind2 > 0 THEN
+ DEC(ind2);
+ buf[ind2] := CHR(ORD(buf[ind2])+1);
+ ELSE
+ buf[ind2] := '1';
+ INC(decpt);
+ IF NOT eflag THEN
+ IF ind1 > 0 THEN buf[ind1] := '0'; END;
+ INC(ind1);
+ END;
+ END;
+ END;
+ buf[ind1] := 0C;
+ END cvt;
+
+ PROCEDURE ecvt(arg: REAL;
+ ndigits: INTEGER;
+ VAR decpt: INTEGER;
+ VAR sign: BOOLEAN;
+ VAR buf: string);
+ BEGIN
+ cvt(arg, ndigits, decpt, sign, TRUE, buf);
+ END ecvt;
+
+ PROCEDURE fcvt(arg: REAL;
+ ndigits: INTEGER;
+ VAR decpt: INTEGER;
+ VAR sign: BOOLEAN;
+ VAR buf: string);
+ BEGIN
+ cvt(arg, ndigits, decpt, sign, FALSE, buf);
+ END fcvt;
+
+ PROCEDURE WriteReal(arg: REAL; ndigits: CARDINAL);
+ VAR buf, cvtbuf: string;
+ ind1, ind2: INTEGER;
+ d,i: INTEGER;
+ sign: BOOLEAN;
+
+ BEGIN
+ IF ndigits-6 < 2 THEN i := 2 ELSE i := ndigits-6; END;
+ ecvt(arg,i,d,sign,cvtbuf);
+ IF sign THEN buf[0] := '-' ELSE buf[0] := ' ' END;
+ ind1 := 1;
+ ind2 := 0;
+ IF cvtbuf[ind2] = '0' THEN INC(d); END;
+ buf[ind1] := cvtbuf[ind2]; INC(ind1); INC(ind2);
+ buf[ind1] := '.'; INC(ind1);
+ FOR i := i-1 TO 1 BY -1 DO
+ buf[ind1] := cvtbuf[ind2]; INC(ind1); INC(ind2);
+ END;
+ buf[ind1] := 'E'; INC(ind1);
+ DEC(d);
+ IF d < 0 THEN
+ d := -d;
+ buf[ind1] := '-';
+ ELSE
+ buf[ind1] := '+';
+ END;
+ INC(ind1);
+ buf[ind1] := CHR(ORD('0') + CARDINAL(d DIV 10));
+ buf[ind1+1] := CHR(ORD('0') + CARDINAL(d MOD 10));
+ buf[ind1+2] := 0C;
+ InOut.WriteString(buf);
+ END WriteReal;
+
+ PROCEDURE ReadReal(VAR x: REAL);
+ CONST BIG = 1.0E17;
+ VAR r : REAL;
+ pow10 : INTEGER;
+ i : INTEGER;
+ e : REAL;
+ ch : CHAR;
+ signed: BOOLEAN;
+ signedexp: BOOLEAN;
+ Buf: ARRAY[0..512] OF CHAR;
+ iB: INTEGER;
+
+ PROCEDURE dig(ch: CARDINAL);
+ BEGIN
+ IF r>BIG THEN INC(pow10) ELSE r:= 10.0*r + FLOAT(ch) END;
+ END dig;
+
+ PROCEDURE isdig(ch: CHAR) : BOOLEAN;
+ BEGIN
+ RETURN (ch >= '0') AND (ch <= '9');
+ END isdig;
+
+ BEGIN
+ r := 0.0;
+ pow10 := 0;
+ InOut.ReadString(Buf);
+ iB := 0;
+ signed := FALSE;
+ IF Buf[0] = '-' THEN signed := TRUE; INC(iB)
+ ELSIF Buf[0] = '+' THEN INC(iB)
+ END;
+ ch := Buf[iB]; INC(iB);
+ IF NOT isdig(ch) THEN Done := FALSE; RETURN END;
+ REPEAT
+ dig(ORD(ch));
+ ch := Buf[iB]; INC(iB);
+ UNTIL NOT isdig(ch);
+ IF ch = '.' THEN
+ ch := Buf[iB]; INC(iB);
+ IF NOT isdig(ch) THEN Done := FALSE; RETURN END;
+ REPEAT
+ dig(ORD(ch));
+ DEC(pow10);
+ ch := Buf[iB]; INC(iB);
+ UNTIL NOT isdig(ch);
+ END;
+ IF ch = 'E' THEN
+ ch := Buf[iB]; INC(iB);
+ i := 0;
+ signedexp := FALSE;
+ IF ch = '-' THEN signedexp := TRUE; ch:= Buf[iB]; INC(iB)
+ ELSIF Buf[iB] = '+' THEN ch := Buf[iB]; INC(iB)
+ END;
+ IF NOT isdig(ch) THEN Done := FALSE; RETURN END;
+ REPEAT
+ i := i*10 + INTEGER(ORD(ch) - ORD('0'));
+ ch := Buf[iB]; INC(iB);
+ UNTIL NOT isdig(ch);
+ IF signedexp THEN i := -i END;
+ pow10 := pow10 + i;
+ END;
+ IF pow10 < 0 THEN i := -pow10; ELSE i := pow10; END;
+ e := 1.0;
+ DEC(i);
+ WHILE i >= 0 DO
+ e := e * 10.0;
+ DEC(i)
+ END;
+ IF pow10<0 THEN
+ r := r / e;
+ ELSE
+ r := r * e;
+ END;
+ IF signed THEN x := -r; ELSE x := r END;
+ END ReadReal;
+
+ PROCEDURE WriteRealOct(x: REAL);
+ BEGIN
+ END WriteRealOct;
+
+BEGIN
+ Done := FALSE;
+END RealInOut.
--- /dev/null
+DEFINITION MODULE Semaphores;
+
+ TYPE Sema;
+
+ PROCEDURE Level(s: Sema) : CARDINAL;
+ (* Returns current value of semaphore s *)
+
+ PROCEDURE NewSema(n: CARDINAL) : Sema;
+ (* Creates a new semaphore with initial level "n" *)
+
+ PROCEDURE Down(VAR s: Sema);
+ (* If the value of "s" is > 0, then just decrement "s".
+ Else, suspend the current process until the semaphore becomes
+ positive again.
+ May result in a process switch.
+ *)
+
+ PROCEDURE Up(VAR s: Sema);
+ (* Increment the semaphore "s".
+ This call may result in a process switch
+ *)
+
+ PROCEDURE StartProcess(P: PROC; n: CARDINAL);
+ (* Create a new process with procedure P and workspace of size "n".
+ Also transfer control to it.
+ *)
+END Semaphores.
--- /dev/null
+IMPLEMENTATION MODULE Semaphores [1];
+
+ FROM SYSTEM IMPORT ADDRESS, NEWPROCESS, TRANSFER;
+ FROM Storage IMPORT ALLOCATE;
+ FROM random IMPORT Uniform;
+
+ 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 *) 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.
--- /dev/null
+DEFINITION MODULE Storage;
+
+ FROM SYSTEM IMPORT ADDRESS;
+
+ PROCEDURE ALLOCATE(VAR a : ADDRESS; size : CARDINAL);
+ (* Allocate an area of the given size and return the address
+ in "a". If no space is available, the calling program is
+ killed.
+ *)
+
+ PROCEDURE DEALLOCATE(VAR a : ADDRESS; size : CARDINAL);
+ (* Free the area at address "a" with the given size. The area
+ must have been allocated by "ALLOCATE", with the same size.
+ *)
+
+ PROCEDURE Available(size : CARDINAL) : BOOLEAN;
+ (* Return TRUE if an area with the given size could be allocated.
+ *)
+
+END Storage.
--- /dev/null
+IMPLEMENTATION MODULE Storage;
+(* 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, write, exit, ILLBREAK;
+ FROM SYSTEM IMPORT ADDRESS, ADR;
+
+ CONST
+ NLISTS = 20;
+
+ 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: BSIZE: INTEGER; (* size of user part in UNITs *)
+ BNEXT: BucketPtr; | (* next free Bucket *)
+ TRUE: BXX: ALIGNTYPE
+ END;
+ BSTORE: ALIGNTYPE;
+ END;
+
+ CONST
+ UNIT = SIZE(ALIGNTYPE);
+ USED = BucketPtr(1);
+
+ VAR
+ FreeLists: ARRAY[0..NLISTS] OF BucketPtr; (* small blocks *)
+ Llist: BucketPtr; (* others *)
+ Compacted: BOOLEAN; (* avoid recursive reorganization *)
+ FirstBlock: BucketPtr;
+
+ PROCEDURE Allocate(size: CARDINAL) : ADDRESS;
+ VAR nu : INTEGER;
+ b : INTEGER;
+ p, q: BucketPtr;
+ brk : ADDRESS;
+ BEGIN
+ nu := (size + (UNIT-1)) DIV UNIT;
+ IF nu = 0 THEN
+ RETURN NIL;
+ END;
+ IF nu <= NLISTS THEN
+ b := nu;
+ IF FreeLists[b] # NIL THEN
+ (* Exact fit *)
+ p := FreeLists[b];
+ FreeLists[b] := p^.BNEXT;
+ p^.BNEXT := USED;
+ 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) + CARDINAL((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;
+ 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) + CARDINAL((nu+1)*UNIT);
+ q^.BSIZE := p^.BSIZE -nu -1;
+ q^.BNEXT := FreeLists[q^.BSIZE];
+ FreeLists[q^.BSIZE] := q;
+ p^.BSIZE := nu;
+ END;
+ RETURN ADR(p^.BSTORE);
+ END;
+ (* Give part of tail of original block.
+ Block stays in this list.
+ *)
+ q := ADDRESS(p) + CARDINAL((p^.BSIZE-nu)*UNIT);
+ q^.BSIZE := nu;
+ p^.BSIZE := p^.BSIZE - nu - 1;
+ q^.BNEXT := USED;
+ 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 := Allocate(size);
+ Compacted := FALSE;
+ RETURN brk;
+ END;
+
+ p := brk;
+ p^.BSIZE := nu;
+ p^.BNEXT := USED;
+ RETURN ADR(p^.BSTORE);
+ END Allocate;
+
+ PROCEDURE ALLOCATE(VAR a: ADDRESS; size: CARDINAL);
+ VAR err: ARRAY[0..20] OF CHAR;
+ BEGIN
+ a := Allocate(size);
+ IF a = NIL THEN
+ err:= "Out of core";
+ err[11] := 12C;
+ IF write(2, ADR(err), 12) < 0 THEN
+ ;
+ END;
+ exit(1);
+ END;
+ END ALLOCATE;
+
+ PROCEDURE Available(size: CARDINAL): BOOLEAN;
+ VAR a: ADDRESS;
+ BEGIN
+ a:= Allocate(size);
+ IF a # NIL THEN
+ DEALLOCATE(a, size);
+ RETURN TRUE;
+ END;
+ RETURN FALSE;
+ END Available;
+
+ PROCEDURE DEALLOCATE(VAR a: ADDRESS; size: CARDINAL);
+ VAR p: BucketPtr;
+ BEGIN
+ IF (a = NIL) THEN RETURN; END;
+ p := a - UNIT;
+ IF (p^.BNEXT # USED) THEN RETURN; END;
+ WITH p^ DO
+ IF BSIZE <= NLISTS THEN
+ BNEXT := FreeLists[BSIZE];
+ FreeLists[BSIZE] := p;
+ ELSE
+ BNEXT := Llist;
+ Llist := p;
+ END;
+ END;
+ END DEALLOCATE;
+
+ PROCEDURE ReOrganize();
+ VAR lastblock: BucketPtr;
+ b, be: BucketPtr;
+ i: INTEGER;
+ BEGIN
+ 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)+CARDINAL((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
+ *)
+ b^.BSIZE := b^.BSIZE + be^.BSIZE + 1;
+ 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;
+ END;
+ END;
+ b := ADDRESS(b) + CARDINAL((b^.BSIZE+1) * UNIT);
+ END;
+ END ReOrganize;
+
+ PROCEDURE InitStorage();
+ VAR i: INTEGER;
+ brk: ADDRESS;
+ BEGIN
+ FOR i := 1 TO NLISTS DO
+ FreeLists[i] := NIL;
+ END;
+ Llist := NIL;
+ brk := sbrk(0);
+ brk := sbrk(UNIT - INTEGER(brk MOD UNIT));
+ FirstBlock := sbrk(0);
+ Compacted := FALSE;
+ END InitStorage;
+
+BEGIN
+ InitStorage();
+END Storage.
--- /dev/null
+_StringAssign(dstsiz, srcsiz, dstaddr, srcaddr)
+ register char *dstaddr, *srcaddr;
+{
+ while (srcsiz > 0) {
+ *dstaddr++ = *srcaddr++;
+ srcsiz--;
+ dstsiz--;
+ }
+ while (dstsiz > 0) {
+ *dstaddr++ = 0;
+ dstsiz--;
+ }
+}
--- /dev/null
+DEFINITION MODULE Strings;
+(* Note: truncation of strings may occur if the user does not provide
+ large enough variables to contain the result of the operation.
+*)
+
+(* Strings are of type ARRAY OF CHAR, and their length is the size
+ of the array, unless a 0-byte occurs in the string to indicate the
+ end of the string.
+*)
+
+PROCEDURE Assign(source: ARRAY OF CHAR; VAR dest: ARRAY OF CHAR);
+(* Assign string source to dest
+*)
+
+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.
+*)
+
+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.
+*)
+
+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.
+*)
+
+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].
+*)
+
+PROCEDURE Concat(s1, s2: ARRAY OF CHAR; VAR result: ARRAY OF CHAR);
+(* Concatenate two strings.
+*)
+
+PROCEDURE Length(str: ARRAY OF CHAR): CARDINAL;
+(* Return number of characters in str.
+*)
+
+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.
+*)
+
+END Strings.
--- /dev/null
+IMPLEMENTATION MODULE Strings;
+
+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;
+ i : 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.
--- /dev/null
+DEFINITION MODULE TTY;
+PROCEDURE isatty(fd: INTEGER): BOOLEAN;
+END TTY.
--- /dev/null
+#
+IMPLEMENTATION MODULE TTY;
+FROM Unix IMPORT ioctl;
+FROM SYSTEM IMPORT ADR;
+PROCEDURE isatty(fd: INTEGER): BOOLEAN;
+VAR buf: ARRAY[1..100] OF CHAR;
+BEGIN
+#ifdef __USG
+ RETURN ioctl(fd, INTEGER(ORD('T') * 256 + 1), ADR(buf)) >= 0;
+#else
+#ifdef __BSD4_2
+ RETURN ioctl(fd, INTEGER(ORD('t') * 256 + 8 + 6*65536 + 40000000H), ADR(buf)) >= 0;
+#else
+ RETURN ioctl(fd, INTEGER(ORD('t') * 256 + 8), ADR(buf)) >= 0;
+#endif
+#endif
+END isatty;
+END TTY.
--- /dev/null
+DEFINITION MODULE Terminal;
+
+ PROCEDURE Read(VAR ch : CHAR);
+ (* Read a character from the terminal and leave it in ch
+ *)
+
+ PROCEDURE BusyRead(VAR ch : CHAR);
+ (* Read a character from the terminal and leave it in ch.
+ This is a non-blocking call. It returns 0C in ch if no
+ character was typed.
+ *)
+
+ PROCEDURE ReadAgain;
+ (* Causes the last character read to be returned again upon the
+ next call of Read.
+ *)
+
+ PROCEDURE Write(ch : CHAR);
+ (* Write character ch to the terminal.
+ *)
+
+ PROCEDURE WriteLn;
+ (* Terminate line.
+ *)
+
+ PROCEDURE WriteString(s : ARRAY OF CHAR);
+ (* Write string s to the terminal.
+ *)
+
+END Terminal.
--- /dev/null
+#
+IMPLEMENTATION MODULE Terminal;
+(* This implementation is Unix-dependant
+*)
+ IMPORT Unix;
+ FROM SYSTEM IMPORT ADR;
+
+ 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 Unix.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 := Unix.fcntl(fildes, (*FGETFL*) 3, 0);
+ IF Unix.fcntl(fildes,
+ (* FSETFL *) 4,
+ l + (*ONDELAY*) 2) < 0 THEN
+ ;
+ END;
+ IF Unix.read(fildes, ADR(ch), 1) = 0 THEN
+ ch := 0C;
+ ELSE
+ unreadch := ch;
+ END;
+ IF Unix.fcntl(fildes, (*FSETFL*)4, l) < 0 THEN
+ ;
+ END;
+#else
+#ifdef __BSD4_2
+ IF Unix.ioctl(fildes, INTEGER(ORD('f')*256+127+4*65536+40000000H), ADR(l)) < 0 THEN
+#else
+ IF Unix.ioctl(fildes, INTEGER(ORD('f')*256+127), ADR(l)) < 0 THEN
+#endif
+ ;
+ END;
+
+ IF l = 0 THEN
+ ch := 0C;
+ ELSE
+ IF Unix.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 Unix.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 := Unix.open(ADR(tty), 2);
+ unread := FALSE;
+END Terminal.
--- /dev/null
+(*$Foreign language module *)
+DEFINITION MODULE Unix;
+(* An interface to some Unix system-calls *)
+ FROM SYSTEM IMPORT WORD, ADDRESS;
+
+(* Type needed for Signal *)
+ TYPE SignalPrc = PROCEDURE(INTEGER):INTEGER;
+ CONST
+ SIGDFL = SignalPrc(0);
+ SIGIGN = SignalPrc(1);
+ ILLBREAK = ADDRESS(-1);
+
+ VAR errno: INTEGER;
+(* Possible values of errno: *)
+ CONST
+ EPERM = 1; (* Not owner *)
+ ENOENT = 2; (* No such file or directory *)
+ ESRCH = 3; (* No such process *)
+ EINTR = 4; (* Interrupted system call *)
+ EIO = 5; (* I/O error *)
+ ENXIO = 6; (* No such device or address *)
+ E2BIG = 7; (* Arg list too long *)
+ ENOEXEC = 8; (* Exec format error *)
+ EBADF = 9; (* Bad file number *)
+ ECHILD = 10; (* No child processes *)
+ EAGAIN = 11; (* No more processes *)
+ ENOMEM = 12; (* Not enough space *)
+ EACCES = 13; (* Permission denied *)
+ EFAULT = 14; (* Bad address *)
+ ENOTBLK = 15; (* Block device required *)
+ EBUSY = 16; (* Mount device busy *)
+ EEXIST = 17; (* File exists *)
+ EXDEV = 18; (* Cross-device link *)
+ ENODEV = 19; (* No such device *)
+ ENOTDIR = 20; (* Not a directory *)
+ EISDIR = 21; (* Is a directory *)
+ EINVAL = 22; (* Invalid argument *)
+ ENFILE = 23; (* File table overflow *)
+ EMFILE = 24; (* Too many open files *)
+ ENOTTY = 25; (* Not a typewriter *)
+ ETXTBSY = 26; (* Text file busy *)
+ EFBIG = 27; (* File too large *)
+ ENOSPC = 28; (* No space left on device *)
+ ESPIPE = 29; (* Illegal seek *)
+ EROFS = 30; (* Read-only file system *)
+ EMLINK = 31; (* Too many links *)
+ EPIPE = 32; (* Broken pipe *)
+ EDOM = 33; (* Math argument *)
+ ERANGE = 34; (* Result too large *)
+
+ PROCEDURE access(path: ADDRESS; amode : INTEGER) : INTEGER;
+ PROCEDURE acct(path: ADDRESS) : INTEGER;
+ PROCEDURE alarm(sec: CARDINAL) : CARDINAL;
+ PROCEDURE brk(endds: ADDRESS) : INTEGER;
+ PROCEDURE sbrk(incr: INTEGER) : ADDRESS;
+ PROCEDURE chdir(path: ADDRESS) : INTEGER;
+ PROCEDURE chmod(path: ADDRESS; mode: INTEGER) : INTEGER;
+ PROCEDURE chown(path: ADDRESS; owner, group: INTEGER) : INTEGER;
+ PROCEDURE chroot(path: ADDRESS) : INTEGER;
+ PROCEDURE close(fildes: INTEGER) : INTEGER;
+ PROCEDURE creat(path: ADDRESS;
+ mode: INTEGER) : INTEGER;
+ PROCEDURE dup(fildes: INTEGER) : INTEGER;
+ PROCEDURE execve(path: ADDRESS;
+ argv: ADDRESS;
+ envp: ADDRESS) : INTEGER;
+ PROCEDURE exit(status: INTEGER);
+ (* Sys5 *) PROCEDURE fcntl(fildes, request, arg: INTEGER) : INTEGER;
+ PROCEDURE ftime(bufp:ADDRESS) : INTEGER;
+ PROCEDURE fork() : INTEGER;
+ PROCEDURE getpid() : INTEGER;
+ PROCEDURE getppid() : INTEGER;
+ PROCEDURE getuid() : INTEGER;
+ PROCEDURE geteuid() : INTEGER;
+ PROCEDURE getgid() : INTEGER;
+ PROCEDURE getegid() : INTEGER;
+ PROCEDURE ioctl(fildes, request: INTEGER; arg: ADDRESS) : INTEGER;
+ PROCEDURE kill(pid, sig: INTEGER) : INTEGER;
+ PROCEDURE link(path1, path2: ADDRESS) : INTEGER;
+ PROCEDURE lseek(fildes: INTEGER; offset: LONGINT; whence: INTEGER) : LONGINT;
+ PROCEDURE mknod(path: ADDRESS; mode, dev: INTEGER) : INTEGER;
+ PROCEDURE mount(spec, dir: ADDRESS; rwflag: INTEGER) : INTEGER;
+ PROCEDURE nice(incr: INTEGER) : INTEGER;
+ PROCEDURE open(path: ADDRESS; oflag: INTEGER) : INTEGER;
+ PROCEDURE pause();
+ PROCEDURE pipe(fildes: ADDRESS) : INTEGER;
+ PROCEDURE profil(buff: ADDRESS;
+ bufsiz, offset, scale: INTEGER);
+ PROCEDURE ptrace(request, pid, addr, data: WORD) : INTEGER;
+ PROCEDURE read(fildes: INTEGER;
+ buf: ADDRESS;
+ nbyte: INTEGER) : INTEGER;
+ PROCEDURE setuid(uid: INTEGER) : INTEGER;
+ PROCEDURE setgid(gid: INTEGER) : INTEGER;
+ PROCEDURE signal(sig: INTEGER;
+ func: SignalPrc;
+ VAR oldfunc: SignalPrc) : INTEGER;
+ PROCEDURE stat(path: ADDRESS; statbuf: ADDRESS) : INTEGER;
+ PROCEDURE fstat(fildes: INTEGER; statbuf: ADDRESS) : INTEGER;
+ PROCEDURE stime(t: LONGINT) : INTEGER;
+ PROCEDURE sync();
+ PROCEDURE time(tloc: ADDRESS) : LONGINT;
+ PROCEDURE times(buffer: ADDRESS) : LONGINT;
+ PROCEDURE umask(cmask: INTEGER) : INTEGER;
+ PROCEDURE umount(spec: ADDRESS) : INTEGER;
+ PROCEDURE unlink(path: ADDRESS) : INTEGER;
+ PROCEDURE utime(path: ADDRESS; times: ADDRESS) : INTEGER;
+ PROCEDURE wait(VAR statloc: INTEGER): INTEGER;
+ PROCEDURE write(fildes: INTEGER;
+ buf: ADDRESS;
+ nbyte: CARDINAL) : INTEGER;
+END Unix.
--- /dev/null
+#ifndef NOFLOAT
+double
+_absd(i)
+ double i;
+{
+ return i >= 0 ? i : -i;
+}
+#endif
--- /dev/null
+#
+ 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
--- /dev/null
+_absi(i)
+{
+ return i >= 0 ? i : -i;
+}
--- /dev/null
+long
+_absl(i)
+ long i;
+{
+ return i >= 0 ? i : -i;
+}
--- /dev/null
+#include <em_abs.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, "floating overflow"},
+ { EFUNFL, "floating underflow"},
+ { EIDIVZ, "divide by 0"},
+ { EFDIVZ, "divide by 0.0"},
+ { EIUND, "undefined integer"},
+ { EFUND, "undefined float"},
+ { 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"},
+ { 64, "stack size of process too large"},
+ { -1, 0}
+};
+
+extern char *_hol0();
+extern char *_argv[];
+extern exit();
+
+_catch(trapno)
+ int trapno;
+{
+ register struct errm *ep = &errors[0];
+ char *errmessage;
+ char *pp[8];
+ register char **qq = &pp[0];
+ register char *p;
+ char *q;
+ int i;
+
+ if (p = FILN)
+ *qq++ = p;
+ else
+ *qq++ = _argv[0];
+ p = &("xxxxxxxxxxx: "[11]);
+ if (i = LINO) {
+ if (i < 0) {
+ /* ??? */
+ *qq++ = ", -";
+ i = -i;
+ }
+ else
+ *qq++ = ", ";
+ do
+ *--p = i % 10 + '0';
+ while (i /= 10);
+ }
+ *qq++ = p;
+ while (ep->errno != trapno && ep->errmes != 0) ep++;
+ if (ep->errmes)
+ *qq++ = ep->errmes;
+ else {
+ *qq++ = "error number";
+ p = &("xxxxxxxxxxx: "[11]);
+ i = trapno;
+ if (i < 0) {
+ /* ??? */
+ *qq++ = "-";
+ i = -i;
+ }
+ do
+ *--p = i % 10 + '0';
+ while (i /= 10);
+ *qq++ = p;
+ }
+ *qq++ = "\n";
+ *qq = 0;
+ qq = pp;
+ while (q = *qq++) {
+ p = q;
+ while (*p)
+ p++;
+ if (write(2,q,p-q) < 0)
+ ;
+ }
+ exit(trapno);
+}
--- /dev/null
+_halt()
+{
+ exit(0);
+}
--- /dev/null
+#
+/*
+ * (c) copyright 1983 by the Vrije Universiteit, Amsterdam, The Netherlands.
+ *
+ * This product is part of the Amsterdam Compiler Kit.
+ *
+ * Permission to use, sell, duplicate or disclose this software must be
+ * obtained in writing. Requests for such permissions may be sent to
+ *
+ * Dr. Andrew S. Tanenbaum
+ * Wiskundig Seminarium
+ * Vrije Universiteit
+ * Postbox 7161
+ * 1007 MC Amsterdam
+ * The Netherlands
+ *
+ */
+
+/* Author: C.J.H. Jacobs */
+
+ mes 2,EM_WSIZE,EM_PSIZE
+
+#define STACKSIZE 1024 /* maximum stack size for a coroutine */
+
+ exa _environ
+ exa _argv
+ exa _argc
+ exa _CurrentProcess
+ exa _MainProcess
+ exa _StackBase
+ exa _MainLB
+ exa _StackSize
+ exp $_catch
+
+_environ
+ bss EM_PSIZE,0,0
+_argv
+ bss EM_PSIZE,0,0
+_argc
+ bss EM_WSIZE,0,0
+_CurrentProcess
+ bss EM_PSIZE,0,0
+_MainProcess
+ bss EM_PSIZE,0,0
+_StackBase
+ bss EM_PSIZE,0,0
+_MainLB
+ bss EM_PSIZE,0,0
+_StackSize
+ bss EM_WSIZE,0,0
+mainroutine
+ bss 2*EM_PSIZE,0,0
+
+ exp $m_a_i_n
+ pro $m_a_i_n, STACKSIZE
+
+ loc STACKSIZE
+ ste _StackSize
+
+ lor 0
+ lae _MainLB
+ sti EM_PSIZE
+
+ lal -EM_WSIZE
+ adp EM_WSIZE
+ lae _StackBase
+ sti EM_PSIZE
+
+ lae mainroutine
+ adp 2*EM_PSIZE
+ dup EM_PSIZE
+ lae _CurrentProcess
+ sti EM_PSIZE
+ lae _MainProcess
+ sti EM_PSIZE
+
+ lal EM_WSIZE+EM_PSIZE
+ loi EM_PSIZE
+ lae _environ ; save environment pointer
+ 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 $_catch
+ sig
+ asp EM_PSIZE
+ cal $_M2M
+ loc 0
+ ret EM_WSIZE
+ end
--- /dev/null
+#
+
+; $Header$
+;
+; (c) copyright 1983 by the Vrije Universiteit, Amsterdam, The Netherlands.
+;
+; This product is part of the Amsterdam Compiler Kit.
+;
+; Permission to use, sell, duplicate or disclose this software must be
+; obtained in writing. Requests for such permissions may be sent to
+;
+; Dr. Andrew S. Tanenbaum
+; Wiskundig Seminarium
+; Vrije Universiteit
+; Postbox 7161
+; 1007 MC Amsterdam
+; The Netherlands
+;
+;
+
+ mes 2,EM_WSIZE,EM_PSIZE
+
+; _hol0 return the address of the ABS block (hol0)
+
+ exp $_hol0
+ pro $_hol0,0
+ lae 0
+ ret EM_PSIZE
+ end ?
--- /dev/null
+_load(siz, addr, p)
+ register char *addr;
+ register int siz;
+{
+ register char *q = (char *) &p;
+
+ while (siz--) *q++ = *addr++;
+}
--- /dev/null
+DEFINITION MODULE random;
+
+PROCEDURE Random(): CARDINAL;
+(* Return a random CARDINAL
+*)
+
+PROCEDURE Uniform (lwb, upb: CARDINAL): CARDINAL;
+(* Return CARDINALs, uniformly distributed between "lwb" and "upb".
+ "lwb" must be smaller than "upb", or "lwb" is returned.
+*)
+
+END random.
--- /dev/null
+IMPLEMENTATION MODULE random;
+
+VAR seed: CARDINAL;
+
+PROCEDURE Random(): CARDINAL;
+BEGIN
+ seed := seed * 77 + 153;
+ RETURN seed;
+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;
+
+BEGIN
+ seed := 253B;
+END random.
--- /dev/null
+_stackprio(n)
+{
+}
+
+_unstackprio()
+{
+}
--- /dev/null
+_store(siz, addr, p)
+ register char *addr;
+ register int siz;
+{
+ register char *q = (char *) &p;
+
+ while (siz--) *addr++ = *q++;
+}
--- /dev/null
+#
+#include <em_mes.h>
+
+ mes 2, EM_WSIZE, EM_PSIZE
+
+ ; This file contains the implementation of the following routines from
+ ; the SYSTEM module:
+ ; TRANSFER, NEWPROCESS
+ ; The NEWPROCESS routine creates a new coroutine stack frame.
+ ; The TRANSFER routine implements transfers from one coroutine to another.
+ ; The memory organization for coroutines is rather complicated.
+ ; One problem is caused by the fact that the user must allocate the
+ ; stackspace. So, this stackspace can be located anywhere, including on
+ ; the heap. This means that we cannot use this space as a stack, because
+ ; in EM, the stack-pointer may never point below the heap-pointer.
+ ; So, this space is only used to save the stack when the coroutine isn't
+ ; running.
+ ; It also contains information about the size of the frame, the
+ ; address of the procedure that forms the coroutine body, the offset
+ ; of the LB from the start of the frame, and the offset of the SP from
+ ; the start of the frame.
+ ; So, is looks like this:
+ ; |-----------------------------|
+ ; | |
+ ; | |
+ ; | |
+ ; .
+ ; .
+ ; .
+ ; | |
+ ; | |
+ ; | | <--- coroutine ident
+ ; |-----------------------------|
+ ; | saved SP |
+ ; |-----------------------------|
+ ; | saved LB |
+ ; |-----------------------------|
+ ; | procedure address or 0 |
+ ; |-----------------------------|
+ ; | size |
+ ; |-----------------------------|
+ ;
+ ; Another problem is that the coroutines must always run at the same
+ ; place in the stack. Therefore, in the runtime startoff a piece of the
+ ; stack is allocated for coroutines.
+
+ exp $SYSTEM_NEWPROCESS
+ exp $SYSTEM_TRANSFER
+ inp $_ChkSize
+
+ pro $SYSTEM_NEWPROCESS, 0
+
+ ; This procedure only initializes the area used for saving the stack.
+ ; Its definition is:
+ ; PROCEDURE NEWPROCESS(P:PROC; A:ADDRESS; n:CARDINAL; VAR p1:ADDRESS);
+
+ lol 2*EM_PSIZE ; size of frame (n)
+ cal $_ChkSize
+ asp EM_WSIZE
+ lfr EM_WSIZE
+ sil EM_WSIZE ; store size in area (indicated by A)
+ lal EM_PSIZE
+ loi EM_PSIZE ; address of area (A)
+ lal 0
+ loi EM_PSIZE ; address of coroutine body (P)
+ lal EM_PSIZE
+ loi EM_PSIZE
+ adp EM_WSIZE
+ sti EM_PSIZE ; store it in area
+ lal EM_PSIZE
+ loi EM_PSIZE
+ adp 3*EM_PSIZE + EM_WSIZE ; this becomes the coroutine identifier
+ lal 2*EM_PSIZE+EM_WSIZE
+ loi EM_PSIZE
+ sti EM_PSIZE
+ ret 0
+ end 0
+
+_target
+ bss EM_PSIZE, 0, 0
+
+ pro $SYSTEM_TRANSFER, 0
+
+ ; This procedure does all the hard work.
+ ; It must save the current environment, and restore the one to which the
+ ; transfer is done. It must also make it look like the return is done
+ ; from ITS invocation of transfer.
+ ; Definition is:
+ ; PROCEDURE TRANSFER(VAR p1, p2 : ADDRESS);
+
+ mes ms_gto ; This is a dangerous procedure
+
+ lal EM_PSIZE
+ loi EM_PSIZE
+ loi EM_PSIZE ; address of target coroutine
+ dup EM_PSIZE
+ lae _CurrentProcess
+ loi EM_PSIZE
+ dup EM_PSIZE
+ lal 0
+ loi EM_PSIZE ; address of place where to store address of current coroutine
+ sti EM_PSIZE ; store
+ cmp ; compare with current process
+ zne *1
+ ; Here, no real transfer needs to be done
+ asp EM_PSIZE
+ ret 0 ; just return
+1
+ lae _target
+ sti EM_PSIZE ; store it in _target
+
+ ; Now, we save the current stack
+ ; Use local base from main program
+
+ lor 0 ; load LB
+ lae _CurrentProcess
+ loi EM_PSIZE
+ adp -2*EM_PSIZE
+ sti EM_PSIZE ; save it
+ lae _CurrentProcess
+ loi EM_PSIZE
+ lae _MainProcess
+ loi EM_PSIZE
+ cmp
+ zeq *2
+
+ lae _MainLB
+ loi EM_PSIZE
+ str 0
+
+ lae _StackBase
+ loi EM_PSIZE
+ lae _CurrentProcess
+ loi EM_PSIZE
+ adp -3*EM_PSIZE-EM_WSIZE
+ loi EM_WSIZE ; get size
+ ngi EM_WSIZE
+ ads EM_WSIZE ; gives source address
+ lae _CurrentProcess
+ loi EM_PSIZE ; destination address
+ lae _CurrentProcess
+ loi EM_PSIZE
+ adp -3*EM_PSIZE-EM_WSIZE
+ loi EM_WSIZE
+ bls EM_WSIZE ; copy
+2
+ lor 1 ; load SP
+ lae _CurrentProcess
+ loi EM_PSIZE
+ adp -EM_PSIZE
+ sti EM_PSIZE ; save it
+
+
+ ; Now, we must find a stack we can temporarily use.
+ ; Just take the one from the main program.
+ lae _MainProcess
+ loi EM_PSIZE
+ adp -EM_PSIZE
+ loi EM_PSIZE
+ str 1 ; temporary stackpointer
+ lae _target
+ loi EM_PSIZE
+ dup EM_PSIZE
+ lae _CurrentProcess
+ sti EM_PSIZE ; store target process descriptor in _CurrentProcess
+ lae _MainProcess
+ loi EM_PSIZE
+ cmp
+ zeq *4
+ ; Now check if the coroutine was called before
+ lae _target
+ loi EM_PSIZE
+ adp -3*EM_PSIZE
+ loi EM_PSIZE
+ zer EM_PSIZE
+ cmp
+ zeq *5
+ ; No, it was'nt
+ lae _StackBase
+ loi EM_PSIZE
+ str 1 ; new stack pointer
+ lae _target
+ loi EM_PSIZE
+ adp -3*EM_PSIZE
+ loi EM_PSIZE
+ zer EM_PSIZE
+ lae _target
+ loi EM_PSIZE
+ adp -3*EM_PSIZE
+ sti EM_PSIZE
+ cai
+ loc 0
+ cal $_exit
+ ret 0
+5
+ lae _target
+ loi EM_PSIZE ; push source address
+ lae _StackBase
+ loi EM_PSIZE ; subtract size from this and we have the destination address
+ lae _target
+ loi EM_PSIZE
+ adp -3*EM_PSIZE-EM_WSIZE
+ loi EM_WSIZE
+ ngi EM_WSIZE
+ ads EM_WSIZE ; got it
+ lae _target
+ loi EM_PSIZE
+ adp -3*EM_PSIZE-EM_WSIZE
+ loi EM_WSIZE
+ bls EM_WSIZE
+4
+ lae _target
+ loi EM_PSIZE
+ adp -EM_PSIZE
+ loi EM_PSIZE
+ str 1 ; restore SP
+ lae _target
+ loi EM_PSIZE
+ adp -2*EM_PSIZE
+ loi EM_PSIZE
+ str 0 ; restore LB
+ ret 0
+ end 0
+
+ pro $_ChkSize, 0
+ lol 0
+ loc 3*EM_PSIZE+EM_WSIZE
+ sbi EM_WSIZE
+ dup EM_WSIZE
+ stl 0
+ loe _StackSize
+ cmu EM_WSIZE
+ zle *1
+ loc 64 ; trap number for "stack size too large"
+ trp
+1
+ lol 0
+ loc EM_WSIZE-1
+ adi EM_WSIZE
+ loc EM_WSIZE
+ dvi EM_WSIZE
+ loc EM_WSIZE
+ mli EM_WSIZE
+ ret EM_WSIZE
+ end 0
--- /dev/null
+SUF=o
+EMHOME=../../..
+MAKEFILE=$(EMHOME)/mach/proto/libg/Makefile
+MACHDEF="MACH=mantra" "SUF=$(SUF)"
+M2LIB = lang/m2/libm2
+MOD="PREF=m2" "SUB=" "SRC=$(M2LIB)"
+
+install: cpmod
+
+cpmod:
+ make -f $(MAKEFILE) $(MOD) $(MACHDEF) cp
+
+cmp: cmpmod
+
+cmpmod:
+ make -f $(MAKEFILE) $(MOD) $(MACHDEF) tail
+ -$(EMHOME)/mach/compare tail_m2
+ make -f $(MAKEFILE) $(MOD) $(MACHDEF) head
+ -$(EMHOME)/mach/compare head_m2
+
+clean:
+ -rm -f *.old *.[ce$(SUF)] tail* head*
+
+opr:
+ make pr | opr
+
+pr:
+ @pr Makefile
--- /dev/null
+if ${MACH?} -I../../../h ${MACHFL?} $1 1>&2
+then echo `basename $1 $2`.o
+else exit 1
+fi
--- /dev/null
+SUF=o
+EMHOME=../../..
+MAKEFILE=$(EMHOME)/mach/proto/libg/Makefile
+MACHDEF="MACH=pdp" "SUF=$(SUF)" "ASAR=ar"
+M2LIB = lang/m2/libm2
+MOD="PREF=m2" "SUB=" "SRC=$(M2LIB)"
+
+install: cpmod
+
+cpmod:
+ make -f $(MAKEFILE) $(MOD) $(MACHDEF) cp
+
+cmp: cmpmod
+
+cmpmod:
+ make -f $(MAKEFILE) $(MOD) $(MACHDEF) tail
+ -$(EMHOME)/mach/compare tail_m2
+ make -f $(MAKEFILE) $(MOD) $(MACHDEF) head
+ -$(EMHOME)/mach/compare head_m2
+
+clean:
+ -rm -f *.old *.[ce$(SUF)] tail* head*
+
+opr:
+ make pr | opr
+
+pr:
+ @pr Makefile
--- /dev/null
+if ${MACH?} -I../../../h ${MACHFL?} $1 1>&2
+then echo `basename $1 $2`.o
+else exit 1
+fi
--- /dev/null
+SUF=o
+EMHOME=../../..
+MAKEFILE=$(EMHOME)/mach/proto/libg/Makefile
+MACHDEF="MACH=sun3" "SUF=$(SUF)" "ASAR=aal"
+M2LIB = lang/m2/libm2
+MOD="PREF=m2" "SUB=" "SRC=$(M2LIB)"
+
+install: cpmod
+
+cpmod:
+ make -f $(MAKEFILE) $(MOD) $(MACHDEF) cp
+
+cmp: cmpmod
+
+cmpmod:
+ make -f $(MAKEFILE) $(MOD) $(MACHDEF) tail
+ -$(EMHOME)/mach/compare tail_m2
+ make -f $(MAKEFILE) $(MOD) $(MACHDEF) head
+ -$(EMHOME)/mach/compare head_m2
+
+clean:
+ -rm -f *.old *.[ce$(SUF)] tail* head*
+
+opr:
+ make pr | opr
+
+pr:
+ @pr Makefile
--- /dev/null
+if ${MACH?} -I../../../h ${MACHFL?} $1 1>&2
+then echo `basename $1 $2`.o
+else exit 1
+fi
--- /dev/null
+SUF=o
+EMHOME=../../..
+MAKEFILE=$(EMHOME)/mach/proto/libg/Makefile
+MACHDEF="MACH=vax4" "SUF=$(SUF)" "ASAR=ar"
+M2LIB = lang/m2/libm2
+MOD="PREF=m2" "SUB=" "SRC=$(M2LIB)"
+
+install: cpmod
+
+cpmod:
+ RANLIB=ranlib ; export RANLIB ; \
+ make -f $(MAKEFILE) $(MOD) $(MACHDEF) cp
+
+cmp: cmpmod
+
+cmpmod:
+ RANLIB=ranlib ; export RANLIB ; \
+ make -f $(MAKEFILE) $(MOD) $(MACHDEF) tail
+ -$(EMHOME)/mach/compare tail_m2
+ make -f $(MAKEFILE) $(MOD) $(MACHDEF) head
+ -$(EMHOME)/mach/compare head_m2
+
+clean:
+ -rm -f *.old *.[ce$(SUF)] tail* head*
+
+opr:
+ make pr | opr
+
+pr:
+ @pr Makefile
--- /dev/null
+if ${MACH?} -I../../../h ${MACHFL?} $1 1>&2
+then echo `basename $1 $2`.o
+else exit 1
+fi
public / ack.git / commitdiff