From 0cc5442188f07a7e33a12326e491d996332ba880 Mon Sep 17 00:00:00 2001 From: ceriel Date: Wed, 13 May 1987 14:36:45 +0000 Subject: [PATCH] Initial revision --- lang/m2/libm2/ASCII.def | 14 ++ lang/m2/libm2/ASCII.mod | 3 + lang/m2/libm2/Arguments.c | 62 ++++++ lang/m2/libm2/Arguments.def | 32 +++ lang/m2/libm2/Conversion.def | 20 ++ lang/m2/libm2/Conversion.mod | 59 +++++ lang/m2/libm2/FIFFEF.def | 12 + lang/m2/libm2/FIFFEF.e | 51 +++++ lang/m2/libm2/InOut.def | 108 +++++++++ lang/m2/libm2/InOut.mod | 420 +++++++++++++++++++++++++++++++++++ lang/m2/libm2/LIST | 28 +++ lang/m2/libm2/LtoUset.e | 38 ++++ lang/m2/libm2/Makefile | 13 ++ lang/m2/libm2/MathLib0.def | 19 ++ lang/m2/libm2/MathLib0.mod | 337 ++++++++++++++++++++++++++++ lang/m2/libm2/Processes.def | 25 +++ lang/m2/libm2/Processes.mod | 98 ++++++++ lang/m2/libm2/RealInOut.def | 25 +++ lang/m2/libm2/RealInOut.mod | 222 ++++++++++++++++++ lang/m2/libm2/Semaphores.def | 27 +++ lang/m2/libm2/Semaphores.mod | 100 +++++++++ lang/m2/libm2/Storage.def | 20 ++ lang/m2/libm2/Storage.mod | 275 +++++++++++++++++++++++ lang/m2/libm2/StrAss.c | 13 ++ lang/m2/libm2/Strings.def | 51 +++++ lang/m2/libm2/Strings.mod | 161 ++++++++++++++ lang/m2/libm2/TTY.def | 3 + lang/m2/libm2/TTY.mod | 18 ++ lang/m2/libm2/Terminal.def | 30 +++ lang/m2/libm2/Terminal.mod | 100 +++++++++ lang/m2/libm2/Unix.def | 112 ++++++++++ lang/m2/libm2/absd.c | 8 + lang/m2/libm2/absf.e | 21 ++ lang/m2/libm2/absi.c | 4 + lang/m2/libm2/absl.c | 6 + lang/m2/libm2/catch.c | 96 ++++++++ lang/m2/libm2/halt.c | 4 + lang/m2/libm2/head_m2.e | 96 ++++++++ lang/m2/libm2/hol0.e | 29 +++ lang/m2/libm2/load.c | 8 + lang/m2/libm2/random.def | 12 + lang/m2/libm2/random.mod | 19 ++ lang/m2/libm2/stackprio.c | 7 + lang/m2/libm2/store.c | 8 + lang/m2/libm2/transfer.e | 245 ++++++++++++++++++++ mach/mantra/libm2/Makefile | 28 +++ mach/mantra/libm2/compmodule | 4 + mach/pdp/libm2/Makefile | 28 +++ mach/pdp/libm2/compmodule | 4 + mach/sun3/libm2/Makefile | 28 +++ mach/sun3/libm2/compmodule | 4 + mach/vax4/libm2/Makefile | 30 +++ mach/vax4/libm2/compmodule | 4 + 53 files changed, 3189 insertions(+) create mode 100644 lang/m2/libm2/ASCII.def create mode 100644 lang/m2/libm2/ASCII.mod create mode 100644 lang/m2/libm2/Arguments.c create mode 100644 lang/m2/libm2/Arguments.def create mode 100644 lang/m2/libm2/Conversion.def create mode 100644 lang/m2/libm2/Conversion.mod create mode 100644 lang/m2/libm2/FIFFEF.def create mode 100644 lang/m2/libm2/FIFFEF.e create mode 100644 lang/m2/libm2/InOut.def create mode 100644 lang/m2/libm2/InOut.mod create mode 100644 lang/m2/libm2/LIST create mode 100644 lang/m2/libm2/LtoUset.e create mode 100644 lang/m2/libm2/Makefile create mode 100644 lang/m2/libm2/MathLib0.def create mode 100644 lang/m2/libm2/MathLib0.mod create mode 100644 lang/m2/libm2/Processes.def create mode 100644 lang/m2/libm2/Processes.mod create mode 100644 lang/m2/libm2/RealInOut.def create mode 100644 lang/m2/libm2/RealInOut.mod create mode 100644 lang/m2/libm2/Semaphores.def create mode 100644 lang/m2/libm2/Semaphores.mod create mode 100644 lang/m2/libm2/Storage.def create mode 100644 lang/m2/libm2/Storage.mod create mode 100644 lang/m2/libm2/StrAss.c create mode 100644 lang/m2/libm2/Strings.def create mode 100644 lang/m2/libm2/Strings.mod create mode 100644 lang/m2/libm2/TTY.def create mode 100644 lang/m2/libm2/TTY.mod create mode 100644 lang/m2/libm2/Terminal.def create mode 100644 lang/m2/libm2/Terminal.mod create mode 100644 lang/m2/libm2/Unix.def create mode 100644 lang/m2/libm2/absd.c create mode 100644 lang/m2/libm2/absf.e create mode 100644 lang/m2/libm2/absi.c create mode 100644 lang/m2/libm2/absl.c create mode 100644 lang/m2/libm2/catch.c create mode 100644 lang/m2/libm2/halt.c create mode 100644 lang/m2/libm2/head_m2.e create mode 100644 lang/m2/libm2/hol0.e create mode 100644 lang/m2/libm2/load.c create mode 100644 lang/m2/libm2/random.def create mode 100644 lang/m2/libm2/random.mod create mode 100644 lang/m2/libm2/stackprio.c create mode 100644 lang/m2/libm2/store.c create mode 100644 lang/m2/libm2/transfer.e create mode 100644 mach/mantra/libm2/Makefile create mode 100755 mach/mantra/libm2/compmodule create mode 100644 mach/pdp/libm2/Makefile create mode 100755 mach/pdp/libm2/compmodule create mode 100644 mach/sun3/libm2/Makefile create mode 100755 mach/sun3/libm2/compmodule create mode 100644 mach/vax4/libm2/Makefile create mode 100755 mach/vax4/libm2/compmodule diff --git a/lang/m2/libm2/ASCII.def b/lang/m2/libm2/ASCII.def new file mode 100644 index 000000000..54c0cf474 --- /dev/null +++ b/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. diff --git a/lang/m2/libm2/ASCII.mod b/lang/m2/libm2/ASCII.mod new file mode 100644 index 000000000..77d932816 --- /dev/null +++ b/lang/m2/libm2/ASCII.mod @@ -0,0 +1,3 @@ +IMPLEMENTATION MODULE ASCII; +BEGIN +END ASCII. diff --git a/lang/m2/libm2/Arguments.c b/lang/m2/libm2/Arguments.c new file mode 100644 index 000000000..cbd2c6c24 --- /dev/null +++ b/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); +} diff --git a/lang/m2/libm2/Arguments.def b/lang/m2/libm2/Arguments.def new file mode 100644 index 000000000..a84950463 --- /dev/null +++ b/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. diff --git a/lang/m2/libm2/Conversion.def b/lang/m2/libm2/Conversion.def new file mode 100644 index 000000000..bfaa7e4ad --- /dev/null +++ b/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. diff --git a/lang/m2/libm2/Conversion.mod b/lang/m2/libm2/Conversion.mod new file mode 100644 index 000000000..ed400f9d0 --- /dev/null +++ b/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. diff --git a/lang/m2/libm2/FIFFEF.def b/lang/m2/libm2/FIFFEF.def new file mode 100644 index 000000000..922332d12 --- /dev/null +++ b/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. diff --git a/lang/m2/libm2/FIFFEF.e b/lang/m2/libm2/FIFFEF.e new file mode 100644 index 000000000..b7588e6a9 --- /dev/null +++ b/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 ? diff --git a/lang/m2/libm2/InOut.def b/lang/m2/libm2/InOut.def new file mode 100644 index 000000000..e1da2167f --- /dev/null +++ b/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. diff --git a/lang/m2/libm2/InOut.mod b/lang/m2/libm2/InOut.mod new file mode 100644 index 000000000..21d1a9f9d --- /dev/null +++ b/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. diff --git a/lang/m2/libm2/LIST b/lang/m2/libm2/LIST new file mode 100644 index 000000000..186416c44 --- /dev/null +++ b/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 diff --git a/lang/m2/libm2/LtoUset.e b/lang/m2/libm2/LtoUset.e new file mode 100644 index 000000000..bd7e823f0 --- /dev/null +++ b/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 diff --git a/lang/m2/libm2/Makefile b/lang/m2/libm2/Makefile new file mode 100644 index 000000000..6e109b5f5 --- /dev/null +++ b/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 diff --git a/lang/m2/libm2/MathLib0.def b/lang/m2/libm2/MathLib0.def new file mode 100644 index 000000000..cbae3a382 --- /dev/null +++ b/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. diff --git a/lang/m2/libm2/MathLib0.mod b/lang/m2/libm2/MathLib0.mod new file mode 100644 index 000000000..93c8a7864 --- /dev/null +++ b/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 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. diff --git a/lang/m2/libm2/Processes.def b/lang/m2/libm2/Processes.def new file mode 100644 index 000000000..8437deba3 --- /dev/null +++ b/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. diff --git a/lang/m2/libm2/Processes.mod b/lang/m2/libm2/Processes.mod new file mode 100644 index 000000000..8d144a36e --- /dev/null +++ b/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. diff --git a/lang/m2/libm2/RealInOut.def b/lang/m2/libm2/RealInOut.def new file mode 100644 index 000000000..0cc67da1b --- /dev/null +++ b/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. diff --git a/lang/m2/libm2/RealInOut.mod b/lang/m2/libm2/RealInOut.mod new file mode 100644 index 000000000..a106a6971 --- /dev/null +++ b/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. diff --git a/lang/m2/libm2/Semaphores.def b/lang/m2/libm2/Semaphores.def new file mode 100644 index 000000000..9883fb971 --- /dev/null +++ b/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. diff --git a/lang/m2/libm2/Semaphores.mod b/lang/m2/libm2/Semaphores.mod new file mode 100644 index 000000000..c04362027 --- /dev/null +++ b/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. diff --git a/lang/m2/libm2/Storage.def b/lang/m2/libm2/Storage.def new file mode 100644 index 000000000..fda4c9c48 --- /dev/null +++ b/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. diff --git a/lang/m2/libm2/Storage.mod b/lang/m2/libm2/Storage.mod new file mode 100644 index 000000000..42e45b0a2 --- /dev/null +++ b/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. diff --git a/lang/m2/libm2/StrAss.c b/lang/m2/libm2/StrAss.c new file mode 100644 index 000000000..371042d0a --- /dev/null +++ b/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--; + } +} diff --git a/lang/m2/libm2/Strings.def b/lang/m2/libm2/Strings.def new file mode 100644 index 000000000..a5ce67eae --- /dev/null +++ b/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. diff --git a/lang/m2/libm2/Strings.mod b/lang/m2/libm2/Strings.mod new file mode 100644 index 000000000..54179afff --- /dev/null +++ b/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. diff --git a/lang/m2/libm2/TTY.def b/lang/m2/libm2/TTY.def new file mode 100644 index 000000000..db60c635c --- /dev/null +++ b/lang/m2/libm2/TTY.def @@ -0,0 +1,3 @@ +DEFINITION MODULE TTY; +PROCEDURE isatty(fd: INTEGER): BOOLEAN; +END TTY. diff --git a/lang/m2/libm2/TTY.mod b/lang/m2/libm2/TTY.mod new file mode 100644 index 000000000..c330183d6 --- /dev/null +++ b/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. diff --git a/lang/m2/libm2/Terminal.def b/lang/m2/libm2/Terminal.def new file mode 100644 index 000000000..1a5a71a52 --- /dev/null +++ b/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. diff --git a/lang/m2/libm2/Terminal.mod b/lang/m2/libm2/Terminal.mod new file mode 100644 index 000000000..d53b792b4 --- /dev/null +++ b/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. diff --git a/lang/m2/libm2/Unix.def b/lang/m2/libm2/Unix.def new file mode 100644 index 000000000..afa212328 --- /dev/null +++ b/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. diff --git a/lang/m2/libm2/absd.c b/lang/m2/libm2/absd.c new file mode 100644 index 000000000..f0d5c5334 --- /dev/null +++ b/lang/m2/libm2/absd.c @@ -0,0 +1,8 @@ +#ifndef NOFLOAT +double +_absd(i) + double i; +{ + return i >= 0 ? i : -i; +} +#endif diff --git a/lang/m2/libm2/absf.e b/lang/m2/libm2/absf.e new file mode 100644 index 000000000..f52bcbe59 --- /dev/null +++ b/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 diff --git a/lang/m2/libm2/absi.c b/lang/m2/libm2/absi.c new file mode 100644 index 000000000..16c883849 --- /dev/null +++ b/lang/m2/libm2/absi.c @@ -0,0 +1,4 @@ +_absi(i) +{ + return i >= 0 ? i : -i; +} diff --git a/lang/m2/libm2/absl.c b/lang/m2/libm2/absl.c new file mode 100644 index 000000000..20feb980d --- /dev/null +++ b/lang/m2/libm2/absl.c @@ -0,0 +1,6 @@ +long +_absl(i) + long i; +{ + return i >= 0 ? i : -i; +} diff --git a/lang/m2/libm2/catch.c b/lang/m2/libm2/catch.c new file mode 100644 index 000000000..003d0f058 --- /dev/null +++ b/lang/m2/libm2/catch.c @@ -0,0 +1,96 @@ +#include + +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); +} diff --git a/lang/m2/libm2/halt.c b/lang/m2/libm2/halt.c new file mode 100644 index 000000000..5a93c56e4 --- /dev/null +++ b/lang/m2/libm2/halt.c @@ -0,0 +1,4 @@ +_halt() +{ + exit(0); +} diff --git a/lang/m2/libm2/head_m2.e b/lang/m2/libm2/head_m2.e new file mode 100644 index 000000000..e5f4f6ccf --- /dev/null +++ b/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 diff --git a/lang/m2/libm2/hol0.e b/lang/m2/libm2/hol0.e new file mode 100644 index 000000000..8db66cf7e --- /dev/null +++ b/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 ? diff --git a/lang/m2/libm2/load.c b/lang/m2/libm2/load.c new file mode 100644 index 000000000..f88e9a6db --- /dev/null +++ b/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++; +} diff --git a/lang/m2/libm2/random.def b/lang/m2/libm2/random.def new file mode 100644 index 000000000..44d31f77c --- /dev/null +++ b/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. diff --git a/lang/m2/libm2/random.mod b/lang/m2/libm2/random.mod new file mode 100644 index 000000000..69aa9fa91 --- /dev/null +++ b/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. diff --git a/lang/m2/libm2/stackprio.c b/lang/m2/libm2/stackprio.c new file mode 100644 index 000000000..a1fcd7ca6 --- /dev/null +++ b/lang/m2/libm2/stackprio.c @@ -0,0 +1,7 @@ +_stackprio(n) +{ +} + +_unstackprio() +{ +} diff --git a/lang/m2/libm2/store.c b/lang/m2/libm2/store.c new file mode 100644 index 000000000..6a728785d --- /dev/null +++ b/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++; +} diff --git a/lang/m2/libm2/transfer.e b/lang/m2/libm2/transfer.e new file mode 100644 index 000000000..2ac9ee3e6 --- /dev/null +++ b/lang/m2/libm2/transfer.e @@ -0,0 +1,245 @@ +# +#include + + 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 diff --git a/mach/mantra/libm2/Makefile b/mach/mantra/libm2/Makefile new file mode 100644 index 000000000..eca849e51 --- /dev/null +++ b/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 diff --git a/mach/mantra/libm2/compmodule b/mach/mantra/libm2/compmodule new file mode 100755 index 000000000..a794a2257 --- /dev/null +++ b/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 diff --git a/mach/pdp/libm2/Makefile b/mach/pdp/libm2/Makefile new file mode 100644 index 000000000..f4d4a6666 --- /dev/null +++ b/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 diff --git a/mach/pdp/libm2/compmodule b/mach/pdp/libm2/compmodule new file mode 100755 index 000000000..a794a2257 --- /dev/null +++ b/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 diff --git a/mach/sun3/libm2/Makefile b/mach/sun3/libm2/Makefile new file mode 100644 index 000000000..0ec739d83 --- /dev/null +++ b/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 diff --git a/mach/sun3/libm2/compmodule b/mach/sun3/libm2/compmodule new file mode 100755 index 000000000..a794a2257 --- /dev/null +++ b/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 diff --git a/mach/vax4/libm2/Makefile b/mach/vax4/libm2/Makefile new file mode 100644 index 000000000..d7c0260f0 --- /dev/null +++ b/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 diff --git a/mach/vax4/libm2/compmodule b/mach/vax4/libm2/compmodule new file mode 100755 index 000000000..a794a2257 --- /dev/null +++ b/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 -- 2.34.1