Initial revision

lang/m2/libm2/ASCII.def

@@ -0,0 +1,14 @@
+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.

lang/m2/libm2/ASCII.mod

@@ -0,0 +1,3 @@
+IMPLEMENTATION MODULE ASCII;
+BEGIN
+END ASCII.

lang/m2/libm2/Arguments.c

@@ -0,0 +1,62 @@
+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);
+}

lang/m2/libm2/Arguments.def

@@ -0,0 +1,32 @@
+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.

lang/m2/libm2/Conversion.def

@@ -0,0 +1,20 @@
+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.

lang/m2/libm2/Conversion.mod

@@ -0,0 +1,59 @@
+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.

lang/m2/libm2/FIFFEF.def

@@ -0,0 +1,12 @@
+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.

lang/m2/libm2/FIFFEF.e

@@ -0,0 +1,51 @@
+#
+ 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 ?

lang/m2/libm2/InOut.def

@@ -0,0 +1,108 @@
+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.

lang/m2/libm2/InOut.mod

@@ -0,0 +1,420 @@
+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.

lang/m2/libm2/LIST

@@ -0,0 +1,28 @@
+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

lang/m2/libm2/LtoUset.e

@@ -0,0 +1,38 @@
+#
+ 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

lang/m2/libm2/Makefile

@@ -0,0 +1,13 @@
+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

lang/m2/libm2/MathLib0.def

@@ -0,0 +1,19 @@
+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.

lang/m2/libm2/MathLib0.mod

@@ -0,0 +1,337 @@
+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.

lang/m2/libm2/Processes.def

@@ -0,0 +1,25 @@
+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.

lang/m2/libm2/Processes.mod

@@ -0,0 +1,98 @@
+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.

lang/m2/libm2/RealInOut.def

@@ -0,0 +1,25 @@
+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.

lang/m2/libm2/RealInOut.mod

@@ -0,0 +1,222 @@
+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.

lang/m2/libm2/Semaphores.def

@@ -0,0 +1,27 @@
+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.

lang/m2/libm2/Semaphores.mod

@@ -0,0 +1,100 @@
+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.

lang/m2/libm2/Storage.def

@@ -0,0 +1,20 @@
+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.

lang/m2/libm2/Storage.mod

@@ -0,0 +1,275 @@
+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.

lang/m2/libm2/StrAss.c

@@ -0,0 +1,13 @@
+_StringAssign(dstsiz, srcsiz, dstaddr, srcaddr)
+	register char *dstaddr, *srcaddr;
+{
+	while (srcsiz > 0) {
+		*dstaddr++ = *srcaddr++;
+		srcsiz--;
+		dstsiz--;
+	}
+	while (dstsiz > 0) {
+		*dstaddr++ = 0;
+		dstsiz--;
+	}
+}

lang/m2/libm2/Strings.def

@@ -0,0 +1,51 @@
+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.

lang/m2/libm2/Strings.mod

@@ -0,0 +1,161 @@
+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.

lang/m2/libm2/TTY.def

@@ -0,0 +1,3 @@
+DEFINITION MODULE TTY;
+PROCEDURE isatty(fd: INTEGER): BOOLEAN;
+END TTY.

lang/m2/libm2/TTY.mod

@@ -0,0 +1,18 @@
+#
+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.

lang/m2/libm2/Terminal.def

@@ -0,0 +1,30 @@
+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.

lang/m2/libm2/Terminal.mod

@@ -0,0 +1,100 @@
+#
+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.

lang/m2/libm2/Unix.def

@@ -0,0 +1,112 @@
+(*$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.

lang/m2/libm2/absd.c

@@ -0,0 +1,8 @@
+#ifndef NOFLOAT
+double
+_absd(i)
+	double i;
+{
+	return i >= 0 ? i : -i;
+}
+#endif

lang/m2/libm2/absf.e

@@ -0,0 +1,21 @@
+#
+ 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

lang/m2/libm2/absi.c

@@ -0,0 +1,4 @@
+_absi(i)
+{
+	return i >= 0 ? i : -i;
+}

lang/m2/libm2/absl.c

@@ -0,0 +1,6 @@
+long
+_absl(i)
+	long i;
+{
+	return i >= 0 ? i : -i;
+}

lang/m2/libm2/catch.c

@@ -0,0 +1,96 @@
+#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);
+}

lang/m2/libm2/halt.c

@@ -0,0 +1,4 @@
+_halt()
+{
+	exit(0);
+}

lang/m2/libm2/head_m2.e

@@ -0,0 +1,96 @@
+#
+/*
+ * (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

lang/m2/libm2/hol0.e

@@ -0,0 +1,29 @@
+#
+
+; $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 ?

lang/m2/libm2/load.c

@@ -0,0 +1,8 @@
+_load(siz, addr, p)
+	register char *addr;
+	register int siz;
+{
+	register char *q = (char *) &p;
+
+	while (siz--) *q++ = *addr++;
+}

lang/m2/libm2/random.def

@@ -0,0 +1,12 @@
+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.

lang/m2/libm2/random.mod

@@ -0,0 +1,19 @@
+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.

lang/m2/libm2/stackprio.c

@@ -0,0 +1,7 @@
+_stackprio(n)
+{
+}
+
+_unstackprio()
+{
+}

lang/m2/libm2/store.c

@@ -0,0 +1,8 @@
+_store(siz, addr, p)
+	register char *addr;
+	register int siz;
+{
+	register char *q = (char *) &p;
+
+	while (siz--) *addr++ = *q++;
+}

lang/m2/libm2/transfer.e

@@ -0,0 +1,245 @@
+#
+#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

mach/mantra/libm2/Makefile

@@ -0,0 +1,28 @@
+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

mach/mantra/libm2/compmodule

@@ -0,0 +1,4 @@
+if ${MACH?} -I../../../h ${MACHFL?} $1 1>&2
+then echo `basename $1 $2`.o
+else exit 1
+fi

mach/pdp/libm2/Makefile

@@ -0,0 +1,28 @@
+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

mach/pdp/libm2/compmodule

@@ -0,0 +1,4 @@
+if ${MACH?} -I../../../h ${MACHFL?} $1 1>&2
+then echo `basename $1 $2`.o
+else exit 1
+fi

mach/sun3/libm2/Makefile

@@ -0,0 +1,28 @@
+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

mach/sun3/libm2/compmodule

@@ -0,0 +1,4 @@
+if ${MACH?} -I../../../h ${MACHFL?} $1 1>&2
+then echo `basename $1 $2`.o
+else exit 1
+fi

mach/vax4/libm2/Makefile

@@ -0,0 +1,30 @@
+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

mach/vax4/libm2/compmodule

@@ -0,0 +1,4 @@
+if ${MACH?} -I../../../h ${MACHFL?} $1 1>&2
+then echo `basename $1 $2`.o
+else exit 1
+fi