vishapoberon/compiler
1
0
Fork 0
mirror of https://github.com/vishapoberon/compiler.git synced 2026-04-06 09:52:24 +00:00
Code Issues Projects Releases Packages Wiki Activity Actions

voc compiler first commit

Browse source 
Former-commit-id: 760d826948
This commit is contained in:
Norayr Chilingarian 2013-09-27 22:34:17 +04:00
parent 4a7dc4b549
commit 6a1eccd316
119 changed files with 30400 additions and 0 deletions
Download patch file Download diff file Expand all files Collapse all files

130
src/lib/ooc/lowlevel/oocSysClock.Mod Normal file
View file

@ -0,0 +1,130 @@
(* $Id: SysClock.Mod,v 1.7 1999/09/02 13:42:24 acken Exp $ *)
MODULE oocSysClock(* [FOREIGN "C"; LINK FILE "SysClock.c" END]*);
IMPORT SYSTEM;
(* SysClock - facilities for accessing a system clock that records the
date and time of day.
Copyright (C) 1996-1998 Michael Griebling
This module is free software; you can redistribute it and/or modify
it under the terms of the GNU Lesser General Public License as
published by the Free Software Foundation; either version 2 of the
License, or (at your option) any later version.
This module is distributed in the hope that it will be useful,
but WITHOUT ANY WARRANTY; without even the implied warranty of
MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
GNU Lesser General Public License for more details.
You should have received a copy of the GNU Lesser General Public
License along with this program; if not, write to the Free Software
Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA 02111-1307 USA
*)
(*<* Warnings := FALSE *>*)
CONST
maxSecondParts* = 999; (* Most systems have just millisecond accuracy *)
zoneMin* = -780; (* time zone minimum minutes *)
zoneMax* = 720; (* time zone maximum minutes *)
localTime* = MIN(INTEGER); (* time zone is inactive & time is local *)
unknownZone* = localTime+1; (* time zone is unknown *)
(* daylight savings mode values *)
unknown* = -1; (* current daylight savings status is unknown *)
inactive* = 0; (* daylight savings adjustments are not in effect *)
active* = 1; (* daylight savings adjustments are being used *)
TYPE
(* The DateTime type is a system-independent time format whose fields
are defined as follows:
year > 0
month = 1 .. 12
day = 1 .. 31
hour = 0 .. 23
minute = 0 .. 59
second = 0 .. 59
fractions = 0 .. maxSecondParts
zone = -780 .. 720
*)
DateTime* =
RECORD
year*: INTEGER;
month*: SHORTINT;
day*: SHORTINT;
hour*: SHORTINT;
minute*: SHORTINT;
second*: SHORTINT;
summerTimeFlag*: SHORTINT; (* daylight savings mode (see above) *)
fractions*: INTEGER; (* parts of a second in milliseconds *)
zone*: INTEGER; (* Time zone differential factor which
is the number of minutes to add to
local time to obtain UTC or is set
to localTime when time zones are
inactive. *)
END;
PROCEDURE -includeTime()
"#include <time.h>";
PROCEDURE -includeiSysTime()
"#include <sys/time.h>";
PROCEDURE -cangetclock() : BOOLEAN
"struct timeval t; return (BOOLEAN)(gettimeofday(&t, NULL) == 0);";
(*
PROCEDURE CanGetClock*(): BOOLEAN;
(* Returns TRUE if a system clock can be read; FALSE otherwise. *)
*)
(*
PROCEDURE CanSetClock*(): BOOLEAN;
(* Returns TRUE if a system clock can be set; FALSE otherwise. *)
*)
(*
PROCEDURE IsValidDateTime* (d: DateTime): BOOLEAN;
(* Returns TRUE if the value of `d' represents a valid date and time;
FALSE otherwise. *)
*)
(*
PROCEDURE GetClock* (VAR userData: DateTime);
(* If possible, assigns system date and time of day to `userData' (i.e.,
the local time is returned). Error returns 1 Jan 1970. *)
*)
(*
PROCEDURE SetClock* (userData: DateTime);
(* If possible, sets the system clock to the values of `userData'. *)
*)
(*
PROCEDURE MakeLocalTime * (VAR c: DateTime);
(* Fill in the daylight savings mode and time zone for calendar date `c'.
The fields `zone' and `summerTimeFlag' given in `c' are ignored, assuming
that the rest of the record describes a local time.
Note 1: On most Unix systems the time zone information is only available for
dates falling within approx. 1 Jan 1902 to 31 Dec 2037. Outside this range
the field `zone' will be set to the unspecified `localTime' value (see
above), and `summerTimeFlag' will be set to `unknown'.
Note 2: The time zone information might not be fully accurate for past (and
future) years that apply different DST rules than the current year.
Usually the current set of rules is used for _all_ years between 1902 and
2037.
Note 3: With DST there is one hour in the year that happens twice: the
hour after which the clock is turned back for a full hour. It is undefined
which time zone will be selected for dates refering to this hour, i.e.
whether DST or normal time zone will be chosen. *)
*)
PROCEDURE -gtod(VAR sec, usec : LONGINT)
" struct timeval tval; int res; res = gettimeofday(&tval, NULL); if (!res) { *sec = tval.tv_sec; *usec = tval.tv_usec; return 0; } else {*sec = 0; *usec = 0; return -1; }";
PROCEDURE GetTimeOfDay* (VAR sec, usec: LONGINT): LONGINT;
(* PRIVAT. Don't use this. Take Time.GetTime instead.
Equivalent to the C function `gettimeofday'. The return value is `0' on
success and `-1' on failure; in the latter case `sec' and `usec' are set to
zero. *)
BEGIN
gtod (sec, usec);
END GetTimeOfDay;
END oocSysClock.

20
src/lib/ooc/oocAscii.Mod Normal file
View file

@ -0,0 +1,20 @@
(* $Id: Ascii.Mod,v 1.1 1997/02/07 07:45:32 oberon1 Exp $ *)
MODULE oocAscii; (* Standard short character names for control chars. *)
CONST
nul* = 00X; soh* = 01X; stx* = 02X; etx* = 03X;
eot* = 04X; enq* = 05X; ack* = 06X; bel* = 07X;
bs * = 08X; ht * = 09X; lf * = 0AX; vt * = 0BX;
ff * = 0CX; cr * = 0DX; so * = 0EX; si * = 0FX;
dle* = 01X; dc1* = 11X; dc2* = 12X; dc3* = 13X;
dc4* = 14X; nak* = 15X; syn* = 16X; etb* = 17X;
can* = 18X; em * = 19X; sub* = 1AX; esc* = 1BX;
fs * = 1CX; gs * = 1DX; rs * = 1EX; us * = 1FX;
del* = 7FX;
CONST (* often used synonyms *)
sp * = " ";
xon* = dc1;
xoff* = dc3;
END oocAscii.

95
src/lib/ooc/oocCharClass.Mod Normal file
View file

@ -0,0 +1,95 @@
(* $Id: CharClass.Mod,v 1.6 1999/10/03 11:43:57 ooc-devel Exp $ *)
MODULE oocCharClass;
(* Classification of values of the type CHAR.
Copyright (C) 1997-1998 Michael van Acken
This module is free software; you can redistribute it and/or
modify it under the terms of the GNU Lesser General Public License
as published by the Free Software Foundation; either version 2 of
the License, or (at your option) any later version.
This module is distributed in the hope that it will be useful, but
WITHOUT ANY WARRANTY; without even the implied warranty of
MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU
Lesser General Public License for more details.
You should have received a copy of the GNU Lesser General Public
License along with OOC. If not, write to the Free Software Foundation,
59 Temple Place - Suite 330, Boston, MA 02111-1307, USA.
*)
(*
Notes:
- This module boldly assumes ASCII character encoding. ;-)
- The value `eol' and the procedure `IsEOL' are not part of the Modula-2
DIS. OOC defines them to fixed values for all its implementations,
independent of the target system. The string `systemEol' holds the target
system's end of line marker, which can be longer than one byte (but cannot
contain 0X).
*)
IMPORT
Ascii := oocAscii;
CONST
eol* = Ascii.lf;
(* the implementation-defined character used to represent end of line
internally for OOC *)
VAR
systemEol-: ARRAY 3 OF CHAR;
(* End of line marker used by the target system for text files. The string
defined here can contain more than one character. For one character eol
markers, `systemEol' must not necessarily equal `eol'. Note that the
string cannot contain the termination character 0X. *)
PROCEDURE IsNumeric* (ch: CHAR): BOOLEAN;
(* Returns TRUE if and only if ch is classified as a numeric character *)
BEGIN
RETURN ("0" <= ch) & (ch <= "9")
END IsNumeric;
PROCEDURE IsLetter* (ch: CHAR): BOOLEAN;
(* Returns TRUE if and only if ch is classified as a letter *)
BEGIN
RETURN ("a" <= ch) & (ch <= "z") OR ("A" <= ch) & (ch <= "Z")
END IsLetter;
PROCEDURE IsUpper* (ch: CHAR): BOOLEAN;
(* Returns TRUE if and only if ch is classified as an upper case letter *)
BEGIN
RETURN ("A" <= ch) & (ch <= "Z")
END IsUpper;
PROCEDURE IsLower* (ch: CHAR): BOOLEAN;
(* Returns TRUE if and only if ch is classified as a lower case letter *)
BEGIN
RETURN ("a" <= ch) & (ch <= "z")
END IsLower;
PROCEDURE IsControl* (ch: CHAR): BOOLEAN;
(* Returns TRUE if and only if ch represents a control function *)
BEGIN
RETURN (ch < Ascii.sp)
END IsControl;
PROCEDURE IsWhiteSpace* (ch: CHAR): BOOLEAN;
(* Returns TRUE if and only if ch represents a space character or a format
effector *)
BEGIN
RETURN (ch = Ascii.sp) OR (ch = Ascii.ff) OR (ch = Ascii.lf) OR
(ch = Ascii.cr) OR (ch = Ascii.ht) OR (ch = Ascii.vt)
END IsWhiteSpace;
PROCEDURE IsEol* (ch: CHAR): BOOLEAN;
(* Returns TRUE if and only if ch is the implementation-defined character used
to represent end of line internally for OOC. *)
BEGIN
RETURN (ch = eol)
END IsEol;
BEGIN
systemEol[0] := Ascii.lf; systemEol[1] := 0X
END oocCharClass.

33
src/lib/ooc/oocConvTypes.Mod Normal file
View file

@ -0,0 +1,33 @@
(* $Id: ConvTypes.Mod,v 1.1 1997/02/07 07:45:32 oberon1 Exp $ *)
MODULE oocConvTypes;
(* Common types used in the string conversion modules *)
TYPE
ConvResults*= SHORTINT; (* Values of this type are used to express the format of a string *)
CONST
strAllRight*=0; (* the string format is correct for the corresponding conversion *)
strOutOfRange*=1; (* the string is well-formed but the value cannot be represented *)
strWrongFormat*=2; (* the string is in the wrong format for the conversion *)
strEmpty*=3; (* the given string is empty *)
TYPE
ScanClass*= SHORTINT; (* Values of this type are used to classify input to finite state scanners *)
CONST
padding*=0; (* a leading or padding character at this point in the scan - ignore it *)
valid*=1; (* a valid character at this point in the scan - accept it *)
invalid*=2; (* an invalid character at this point in the scan - reject it *)
terminator*=3; (* a terminating character at this point in the scan (not part of token) *)
TYPE
ScanState*=POINTER TO ScanDesc;
ScanDesc*= (* The type of lexical scanning control procedures *)
RECORD
p*: PROCEDURE (ch: CHAR; VAR cl: ScanClass; VAR st: ScanState);
END;
END oocConvTypes.

240
src/lib/ooc/oocIntConv.Mod Normal file
View file

@ -0,0 +1,240 @@
(* $Id: IntConv.Mod,v 1.5 2002/05/10 23:06:58 ooc-devel Exp $ *)
MODULE oocIntConv;
(*
IntConv - Low-level integer/string conversions.
Copyright (C) 1995 Michael Griebling
Copyright (C) 2000, 2002 Michael van Acken
This module is free software; you can redistribute it and/or modify
it under the terms of the GNU Lesser General Public License as
published by the Free Software Foundation; either version 2 of the
License, or (at your option) any later version.
This module is distributed in the hope that it will be useful,
but WITHOUT ANY WARRANTY; without even the implied warranty of
MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
GNU Lesser General Public License for more details.
You should have received a copy of the GNU Lesser General Public
License along with this program; if not, write to the Free Software
Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA 02111-1307 USA
*)
IMPORT
Char := oocCharClass, Str := oocStrings, Conv := oocConvTypes;
TYPE
ConvResults = Conv.ConvResults; (* strAllRight, strOutOfRange, strWrongFormat, strEmpty *)
CONST
strAllRight*=Conv.strAllRight; (* the string format is correct for the corresponding conversion *)
strOutOfRange*=Conv.strOutOfRange; (* the string is well-formed but the value cannot be represented *)
strWrongFormat*=Conv.strWrongFormat; (* the string is in the wrong format for the conversion *)
strEmpty*=Conv.strEmpty; (* the given string is empty *)
VAR
W, S, SI: Conv.ScanState;
(* internal state machine procedures *)
PROCEDURE WState(inputCh: CHAR; VAR chClass: Conv.ScanClass; VAR nextState: Conv.ScanState);
BEGIN
IF Char.IsNumeric(inputCh) THEN chClass:=Conv.valid; nextState:=W
ELSE chClass:=Conv.terminator; nextState:=NIL
END
END WState;
PROCEDURE SState(inputCh: CHAR; VAR chClass: Conv.ScanClass; VAR nextState: Conv.ScanState);
BEGIN
IF Char.IsNumeric(inputCh) THEN chClass:=Conv.valid; nextState:=W
ELSE chClass:=Conv.invalid; nextState:=S
END
END SState;
PROCEDURE ScanInt*(inputCh: CHAR; VAR chClass: Conv.ScanClass; VAR nextState: Conv.ScanState);
(*
Represents the start state of a finite state scanner for signed whole
numbers - assigns class of inputCh to chClass and a procedure
representing the next state to nextState.
The call of ScanInt(inputCh,chClass,nextState) shall assign values to
`chClass' and `nextState' depending upon the value of `inputCh' as
shown in the following table.
Procedure inputCh chClass nextState (a procedure
with behaviour of)
--------- --------- -------- ---------
ScanInt space padding ScanInt
sign valid SState
decimal digit valid WState
other invalid ScanInt
SState decimal digit valid WState
other invalid SState
WState decimal digit valid WState
other terminator --
NOTE 1 -- The procedure `ScanInt' corresponds to the start state of a
finite state machine to scan for a character sequence that forms a
signed whole number. Like `ScanCard' and the corresponding procedures
in the other low-level string conversion modules, it may be used to
control the actions of a finite state interpreter. As long as the
value of `chClass' is other than `terminator' or `invalid', the
interpreter should call the procedure whose value is assigned to
`nextState' by the previous call, supplying the next character from
the sequence to be scanned. It may be appropriate for the interpreter
to ignore characters classified as `invalid', and proceed with the
scan. This would be the case, for example, with interactive input, if
only valid characters are being echoed in order to give interactive
users an immediate indication of badly-formed data.
If the character sequence end before one is classified as a
terminator, the string-terminator character should be supplied as
input to the finite state scanner. If the preceeding character
sequence formed a complete number, the string-terminator will be
classified as `terminator', otherwise it will be classified as
`invalid'.
For examples of how ScanInt is used, refer to the FormatInt and
ValueInt procedures below.
*)
BEGIN
IF Char.IsWhiteSpace(inputCh) THEN chClass:=Conv.padding; nextState:=SI
ELSIF (inputCh="+") OR (inputCh="-") THEN chClass:=Conv.valid; nextState:=S
ELSIF Char.IsNumeric(inputCh) THEN chClass:=Conv.valid; nextState:=W
ELSE chClass:=Conv.invalid; nextState:=SI
END
END ScanInt;
PROCEDURE FormatInt*(str: ARRAY OF CHAR): ConvResults;
(* Returns the format of the string value for conversion to LONGINT. *)
VAR
ch: CHAR;
int: LONGINT;
len, index, digit: INTEGER;
state: Conv.ScanState;
positive: BOOLEAN;
prev, class: Conv.ScanClass;
BEGIN
len:=Str.Length(str); index:=0;
class:=Conv.padding; prev:=class;
state:=SI; int:=0; positive:=TRUE;
LOOP
ch:=str[index];
state.p(ch, class, state);
CASE class OF
| Conv.padding: (* nothing to do *)
| Conv.valid:
IF ch="-" THEN positive:=FALSE
ELSIF ch="+" THEN positive:=TRUE
ELSE (* must be a digit *)
digit:=ORD(ch)-ORD("0");
IF positive THEN
IF int>(MAX(LONGINT)-digit) DIV 10 THEN RETURN strOutOfRange END;
int:=int*10+digit
ELSE
IF int>(MIN(LONGINT)+digit) DIV 10 THEN
int:=int*10-digit
ELSIF (int < (MIN(LONGINT)+digit) DIV 10) OR
((int = (MIN(LONGINT)+digit) DIV 10) &
((MIN(LONGINT)+digit) MOD 10 # 0)) THEN
RETURN strOutOfRange
ELSE
int:=int*10-digit
END
END
END
| Conv.invalid:
IF (prev = Conv.padding) THEN
RETURN strEmpty;
ELSE
RETURN strWrongFormat;
END;
| Conv.terminator:
IF (ch = 0X) THEN
RETURN strAllRight;
ELSE
RETURN strWrongFormat;
END;
END;
prev:=class; INC(index)
END;
END FormatInt;
PROCEDURE ValueInt*(str: ARRAY OF CHAR): LONGINT;
(*
Returns the value corresponding to the signed whole number string value
str if str is well-formed; otherwise raises the WholeConv exception.
*)
VAR
ch: CHAR;
len, index, digit: INTEGER;
int: LONGINT;
state: Conv.ScanState;
positive: BOOLEAN;
class: Conv.ScanClass;
BEGIN
IF FormatInt(str)=strAllRight THEN
len:=Str.Length(str); index:=0;
state:=SI; int:=0; positive:=TRUE;
FOR index:=0 TO len-1 DO
ch:=str[index];
state.p(ch, class, state);
IF class=Conv.valid THEN
IF ch="-" THEN positive:=FALSE
ELSIF ch="+" THEN positive:=TRUE
ELSE (* must be a digit *)
digit:=ORD(ch)-ORD("0");
IF positive THEN int:=int*10+digit
ELSE int:=int*10-digit
END
END
END
END;
RETURN int
ELSE RETURN 0 (* raise exception here *)
END
END ValueInt;
PROCEDURE LengthInt*(int: LONGINT): INTEGER;
(*
Returns the number of characters in the string representation of int.
This value corresponds to the capacity of an array `str' which is
of the minimum capacity needed to avoid truncation of the result in
the call IntStr.IntToStr(int,str).
*)
VAR
cnt: INTEGER;
BEGIN
IF int=MIN(LONGINT) THEN int:=-(int+1); cnt:=1 (* argh!! *)
ELSIF int<=0 THEN int:=-int; cnt:=1
ELSE cnt:=0
END;
WHILE int>0 DO INC(cnt); int:=int DIV 10 END;
RETURN cnt
END LengthInt;
PROCEDURE IsIntConvException*(): BOOLEAN;
(* Returns TRUE if the current coroutine is in the exceptional execution
state because of the raising of the IntConv exception; otherwise
returns FALSE.
*)
BEGIN
RETURN FALSE
END IsIntConvException;
BEGIN
(* kludge necessary because of recursive procedure declaration *)
NEW(S); NEW(W); NEW(SI);
S.p:=SState; W.p:=WState; SI.p:=ScanInt
END oocIntConv.

100
src/lib/ooc/oocIntStr.Mod Normal file
View file

@ -0,0 +1,100 @@
(* $Id: IntStr.Mod,v 1.4 1999/09/02 13:07:47 acken Exp $ *)
MODULE oocIntStr;
(* IntStr - Integer-number/string conversions.
Copyright (C) 1995 Michael Griebling
This module is free software; you can redistribute it and/or modify
it under the terms of the GNU Lesser General Public License as
published by the Free Software Foundation; either version 2 of the
License, or (at your option) any later version.
This module is distributed in the hope that it will be useful,
but WITHOUT ANY WARRANTY; without even the implied warranty of
MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
GNU Lesser General Public License for more details.
You should have received a copy of the GNU Lesser General Public
License along with this program; if not, write to the Free Software
Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA 02111-1307 USA
*)
IMPORT
Conv := oocConvTypes, IntConv := oocIntConv;
TYPE
ConvResults*= Conv.ConvResults;
(* possible values: strAllRight, strOutOfRange, strWrongFormat, strEmpty *)
CONST
strAllRight*=Conv.strAllRight;
(* the string format is correct for the corresponding conversion *)
strOutOfRange*=Conv.strOutOfRange;
(* the string is well-formed but the value cannot be represented *)
strWrongFormat*=Conv.strWrongFormat;
(* the string is in the wrong format for the conversion *)
strEmpty*=Conv.strEmpty;
(* the given string is empty *)
(* the string form of a signed whole number is
["+" | "-"] decimal_digit {decimal_digit}
*)
PROCEDURE StrToInt*(str: ARRAY OF CHAR; VAR int: LONGINT; VAR res: ConvResults);
(* Ignores any leading spaces in `str'. If the subsequent characters in `str'
are in the format of a signed whole number, assigns a corresponding value to
`int'. Assigns a value indicating the format of `str' to `res'. *)
BEGIN
res:=IntConv.FormatInt(str);
IF (res = strAllRight) THEN
int:=IntConv.ValueInt(str)
END
END StrToInt;
PROCEDURE Reverse (VAR str : ARRAY OF CHAR; start, end : INTEGER);
(* Reverses order of characters in the interval [start..end]. *)
VAR
h : CHAR;
BEGIN
WHILE start < end DO
h := str[start]; str[start] := str[end]; str[end] := h;
INC(start); DEC(end)
END
END Reverse;
PROCEDURE IntToStr*(int: LONGINT; VAR str: ARRAY OF CHAR);
(* Converts the value of `int' to string form and copies the possibly truncated
result to `str'. *)
CONST
maxLength = 11; (* maximum number of digits representing a LONGINT value *)
VAR
b : ARRAY maxLength+1 OF CHAR;
s, e: INTEGER;
BEGIN
(* build representation in string 'b' *)
IF int = MIN(LONGINT) THEN (* smallest LONGINT, -int is an overflow *)
b := "-2147483648";
e := 11
ELSE
IF int < 0 THEN (* negative sign *)
b[0] := "-"; int := -int; s := 1
ELSE (* no sign *)
s := 0
END;
e := s; (* 's' holds starting position of string *)
REPEAT
b[e] := CHR(int MOD 10+ORD("0"));
int := int DIV 10;
INC(e)
UNTIL int = 0;
b[e] := 0X;
Reverse(b, s, e-1)
END;
COPY(b, str) (* truncate output if necessary *)
END IntToStr;
END oocIntStr.

181
src/lib/ooc/oocOakStrings.Mod Normal file
View file

@ -0,0 +1,181 @@
(* $Id: OakStrings.Mod,v 1.3 1999/10/03 11:44:53 ooc-devel Exp $ *)
MODULE oocOakStrings;
(* Oakwood compliant string manipulation facilities.
Copyright (C) 1998, 1999 Michael van Acken
This module is free software; you can redistribute it and/or
modify it under the terms of the GNU Lesser General Public License
as published by the Free Software Foundation; either version 2 of
the License, or (at your option) any later version.
This module is distributed in the hope that it will be useful, but
WITHOUT ANY WARRANTY; without even the implied warranty of
MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU
Lesser General Public License for more details.
You should have received a copy of the GNU Lesser General Public
License along with OOC. If not, write to the Free Software Foundation,
59 Temple Place - Suite 330, Boston, MA 02111-1307, USA.
*)
(* see also [Oakwood Guidelines, revision 1A]
Module Strings provides a set of operations on strings (i.e., on string
constants and character arrays, both of wich contain the character 0X as a
terminator). All positions in strings start at 0.
Remarks
String assignments and string comparisons are already supported by the language
Oberon-2.
*)
PROCEDURE Length* (s: ARRAY OF CHAR): INTEGER;
(* Returns the number of characters in s up to and excluding the first 0X. *)
VAR
i: INTEGER;
BEGIN
i := 0;
WHILE (s[i] # 0X) DO
INC (i)
END;
RETURN i
END Length;
PROCEDURE Insert* (src: ARRAY OF CHAR; pos: INTEGER; VAR dst: ARRAY OF CHAR);
(* Inserts the string src into the string dst at position pos (0<=pos<=
Length(dst)). If pos=Length(dst), src is appended to dst. If the size of
dst is not large enough to hold the result of the operation, the result is
truncated so that dst is always terminated with a 0X. *)
VAR
lenSrc, lenDst, maxDst, i: INTEGER;
BEGIN
lenDst := Length (dst);
lenSrc := Length (src);
maxDst := SHORT (LEN (dst))-1;
IF (pos+lenSrc < maxDst) THEN
IF (lenDst+lenSrc > maxDst) THEN
(* 'dst' too long, truncate it *)
lenDst := maxDst-lenSrc;
dst[lenDst] := 0X
END;
(* 'src' is inserted inside of 'dst', move tail section *)
FOR i := lenDst TO pos BY -1 DO
dst[i+lenSrc] := dst[i]
END
ELSE
dst[maxDst] := 0X;
lenSrc := maxDst-pos
END;
(* copy characters from 'src' to 'dst' *)
FOR i := 0 TO lenSrc-1 DO
dst[pos+i] := src[i]
END
END Insert;
PROCEDURE Append* (s: ARRAY OF CHAR; VAR dst: ARRAY OF CHAR);
(* Has the same effect as Insert(s, Length(dst), dst). *)
VAR
sp, dp, m: INTEGER;
BEGIN
m := SHORT (LEN(dst))-1; (* max length of dst *)
dp := Length (dst); (* append s at position dp *)
sp := 0;
WHILE (dp < m) & (s[sp] # 0X) DO (* copy chars from s to dst *)
dst[dp] := s[sp];
INC (dp);
INC (sp)
END;
dst[dp] := 0X (* terminate dst *)
END Append;
PROCEDURE Delete* (VAR s: ARRAY OF CHAR; pos, n: INTEGER);
(* Deletes n characters from s starting at position pos (0<=pos<=Length(s)).
If n>Length(s)-pos, the new length of s is pos. *)
VAR
lenStr, i: INTEGER;
BEGIN
lenStr := Length (s);
IF (pos+n < lenStr) THEN
FOR i := pos TO lenStr-n DO
s[i] := s[i+n]
END
ELSE
s[pos] := 0X
END
END Delete;
PROCEDURE Replace* (src: ARRAY OF CHAR; pos: INTEGER; VAR dst: ARRAY OF CHAR);
(* Has the same effect as Delete(dst, pos, Length(src)) followed by an
Insert(src, pos, dst). *)
VAR
sp, maxDst: INTEGER;
addNull: BOOLEAN;
BEGIN
maxDst := SHORT (LEN (dst))-1; (* max length of dst *)
addNull := FALSE;
sp := 0;
WHILE (src[sp] # 0X) & (pos < maxDst) DO (* copy chars from src to dst *)
(* set addNull=TRUE if we write over the end of dst *)
addNull := addNull OR (dst[pos] = 0X);
dst[pos] := src[sp];
INC (pos);
INC (sp)
END;
IF addNull THEN
dst[pos] := 0X (* terminate dst *)
END
END Replace;
PROCEDURE Extract* (src: ARRAY OF CHAR; pos, n: INTEGER; VAR dst: ARRAY OF CHAR);
(* Extracts a substring dst with n characters from position pos (0<=pos<=
Length(src)) in src. If n>Length(src)-pos, dst is only the part of src from
pos to the end of src, i.e. Length(src)-1. If the size of dst is not large
enough to hold the result of the operation, the result is truncated so that
dst is always terminated with a 0X. *)
VAR
i: INTEGER;
BEGIN
(* set n to Max(n, LEN(dst)-1) *)
IF (n > LEN(dst)) THEN
n := SHORT (LEN(dst))-1
END;
(* copy upto n characters into dst *)
i := 0;
WHILE (i < n) & (src[pos+i] # 0X) DO
dst[i] := src[pos+i];
INC (i)
END;
dst[i] := 0X
END Extract;
PROCEDURE Pos* (pat, s: ARRAY OF CHAR; pos: INTEGER): INTEGER;
(* Returns the position of the first occurrence of pat in s. Searching starts
at position pos. If pat is not found, -1 is returned. *)
VAR
posPat: INTEGER;
BEGIN
posPat := 0;
LOOP
IF (pat[posPat] = 0X) THEN (* reached end of pattern *)
RETURN pos-posPat
ELSIF (s[pos] = 0X) THEN (* end of string (but not of pattern) *)
RETURN -1
ELSIF (s[pos] = pat[posPat]) THEN (* characters identic, compare next one *)
INC (pos); INC (posPat)
ELSE (* difference found: reset indices and restart *)
pos := pos-posPat+1; posPat := 0
END
END
END Pos;
PROCEDURE Cap* (VAR s: ARRAY OF CHAR);
(* Replaces each lower case letter with s by its upper case equivalent. *)
VAR
i: INTEGER;
BEGIN
i := 0;
WHILE (s[i] # 0X) DO
s[i] := CAP (s[i]);
INC (i)
END
END Cap;
END oocOakStrings.

497
src/lib/ooc/oocStrings.Mod Normal file
View file

@ -0,0 +1,497 @@
(* $Id: Strings.Mod,v 1.4 1999/10/03 11:45:07 ooc-devel Exp $ *)
MODULE oocStrings;
(* Facilities for manipulating strings.
Copyright (C) 1996, 1997 Michael van Acken
This module is free software; you can redistribute it and/or
modify it under the terms of the GNU Lesser General Public License
as published by the Free Software Foundation; either version 2 of
the License, or (at your option) any later version.
This module is distributed in the hope that it will be useful, but
WITHOUT ANY WARRANTY; without even the implied warranty of
MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU
Lesser General Public License for more details.
You should have received a copy of the GNU Lesser General Public
License along with OOC. If not, write to the Free Software Foundation,
59 Temple Place - Suite 330, Boston, MA 02111-1307, USA.
*)
(*
Notes:
Unlike Modula-2, the behaviour of a procedure is undefined, if one of its input
parameters is an unterminated character array. All of the following procedures
expect to get 0X terminated strings, and will return likewise terminated
strings.
All input parameters that represent an array index or a length are expected to
be non-negative. In the descriptions below these restrictions are stated as
pre-conditions of the procedures, but they aren't checked explicitly. If this
module is compiled with enable run-time index checks some illegal input values
may be caught. By default it is installed _without_ index checks.
Differences from the Strings module of the Oakwood Guidelines:
- `Delete' is defined for `startPos' greater than `Length(stringVar)'
- `Insert' is defined for `startPos' greater than `Length(destination)'
- `Replace' is defined for `startPos' greater than `Length(destination)'
- `Replace' will never return a string in `destination' that is longer
than the initial value of `destination' before the call.
- `Capitalize' replaces `Cap'
- `FindNext' replaces `Pos' with slightly changed call pattern
- the `CanSomethingAll' predicates are new
- also new: `Compare', `Equal', `FindPrev', and `FindDiff'
*)
TYPE
CompareResults* = SHORTINT;
CONST
(* values returned by `Compare' *)
less* = -1;
equal* = 0;
greater* = 1;
PROCEDURE Length* (stringVal: ARRAY OF CHAR): INTEGER;
(* Returns the length of `stringVal'. This is equal to the number of
characters in `stringVal' up to and excluding the first 0X. *)
VAR
i: INTEGER;
BEGIN
i := 0;
WHILE (stringVal[i] # 0X) DO
INC (i)
END;
RETURN i
END Length;
(*
The following seven procedures construct a string value, and attempt to assign
it to a variable parameter. They all have the property that if the length of
the constructed string value exceeds the capacity of the variable parameter, a
truncated value is assigned. The constructed string always ends with the
string terminator 0X.
*)
PROCEDURE Assign* (source: ARRAY OF CHAR; VAR destination: ARRAY OF CHAR);
(* Copies `source' to `destination'. Equivalent to the predefined procedure
COPY. Unlike COPY, this procedure can be assigned to a procedure
variable. *)
VAR
i: INTEGER;
BEGIN
i := -1;
REPEAT
INC (i);
destination[i] := source[i]
UNTIL (destination[i] = 0X) OR (i = LEN (destination)-1);
destination[i] := 0X
END Assign;
PROCEDURE Extract* (source: ARRAY OF CHAR; startPos, numberToExtract: INTEGER;
VAR destination: ARRAY OF CHAR);
(* Copies at most `numberToExtract' characters from `source' to `destination',
starting at position `startPos' in `source'. An empty string value will be
extracted if `startPos' is greater than or equal to `Length(source)'.
pre: `startPos' and `numberToExtract' are not negative. *)
VAR
sourceLength, i: INTEGER;
BEGIN
(* make sure that we get an empty string if `startPos' refers to an array
index beyond `Length (source)' *)
sourceLength := Length (source);
IF (startPos > sourceLength) THEN
startPos := sourceLength
END;
(* make sure that `numberToExtract' doesn't exceed the capacity
of `destination' *)
IF (numberToExtract >= LEN (destination)) THEN
numberToExtract := SHORT (LEN (destination))-1
END;
(* copy up to `numberToExtract' characters to `destination' *)
i := 0;
WHILE (i < numberToExtract) & (source[startPos+i] # 0X) DO
destination[i] := source[startPos+i];
INC (i)
END;
destination[i] := 0X
END Extract;
PROCEDURE Delete* (VAR stringVar: ARRAY OF CHAR;
startPos, numberToDelete: INTEGER);
(* Deletes at most `numberToDelete' characters from `stringVar', starting at
position `startPos'. The string value in `stringVar' is not altered if
`startPos' is greater than or equal to `Length(stringVar)'.
pre: `startPos' and `numberToDelete' are not negative. *)
VAR
stringLength, i: INTEGER;
BEGIN
stringLength := Length (stringVar);
IF (startPos+numberToDelete < stringLength) THEN
(* `stringVar' has remaining characters beyond the deleted section;
these have to be moved forward by `numberToDelete' characters *)
FOR i := startPos TO stringLength-numberToDelete DO
stringVar[i] := stringVar[i+numberToDelete]
END
ELSIF (startPos < stringLength) THEN
stringVar[startPos] := 0X
END
END Delete;
PROCEDURE Insert* (source: ARRAY OF CHAR; startPos: INTEGER;
VAR destination: ARRAY OF CHAR);
(* Inserts `source' into `destination' at position `startPos'. After the call
`destination' contains the string that is contructed by first splitting
`destination' at the position `startPos' and then concatenating the first
half, `source', and the second half. The string value in `destination' is
not altered if `startPos' is greater than `Length(source)'. If `startPos =
Length(source)', then `source' is appended to `destination'.
pre: `startPos' is not negative. *)
VAR
sourceLength, destLength, destMax, i: INTEGER;
BEGIN
destLength := Length (destination);
sourceLength := Length (source);
destMax := SHORT (LEN (destination))-1;
IF (startPos+sourceLength < destMax) THEN
(* `source' is inserted inside of `destination' *)
IF (destLength+sourceLength > destMax) THEN
(* `destination' too long, truncate it *)
destLength := destMax-sourceLength;
destination[destLength] := 0X
END;
(* move tail section of `destination' *)
FOR i := destLength TO startPos BY -1 DO
destination[i+sourceLength] := destination[i]
END
ELSIF (startPos <= destLength) THEN
(* `source' replaces `destination' from `startPos' on *)
destination[destMax] := 0X; (* set string terminator *)
sourceLength := destMax-startPos (* truncate `source' *)
ELSE (* startPos > destLength: no change in `destination' *)
sourceLength := 0
END;
(* copy characters from `source' to `destination' *)
FOR i := 0 TO sourceLength-1 DO
destination[startPos+i] := source[i]
END
END Insert;
PROCEDURE Replace* (source: ARRAY OF CHAR; startPos: INTEGER;
VAR destination: ARRAY OF CHAR);
(* Copies `source' into `destination', starting at position `startPos'. Copying
stops when all of `source' has been copied, or when the last character of
the string value in `destination' has been replaced. The string value in
`destination' is not altered if `startPos' is greater than or equal to
`Length(source)'.
pre: `startPos' is not negative. *)
VAR
destLength, i: INTEGER;
BEGIN
destLength := Length (destination);
IF (startPos < destLength) THEN
(* if `startPos' is inside `destination', then replace characters until
the end of `source' or `destination' is reached *)
i := 0;
WHILE (startPos # destLength) & (source[i] # 0X) DO
destination[startPos] := source[i];
INC (startPos);
INC (i)
END
END
END Replace;
PROCEDURE Append* (source: ARRAY OF CHAR; VAR destination: ARRAY OF CHAR);
(* Appends source to destination. *)
VAR
destLength, i: INTEGER;
BEGIN
destLength := Length (destination);
i := 0;
WHILE (destLength < LEN (destination)-1) & (source[i] # 0X) DO
destination[destLength] := source[i];
INC (destLength);
INC (i)
END;
destination[destLength] := 0X
END Append;
PROCEDURE Concat* (source1, source2: ARRAY OF CHAR;
VAR destination: ARRAY OF CHAR);
(* Concatenates `source2' onto `source1' and copies the result into
`destination'. *)
VAR
i, j: INTEGER;
BEGIN
(* copy `source1' into `destination' *)
i := 0;
WHILE (source1[i] # 0X) & (i < LEN(destination)-1) DO
destination[i] := source1[i];
INC (i)
END;
(* append `source2' to `destination' *)
j := 0;
WHILE (source2[j] # 0X) & (i < LEN (destination)-1) DO
destination[i] := source2[j];
INC (j); INC (i)
END;
destination[i] := 0X
END Concat;
(*
The following predicates provide for pre-testing of the operation-completion
conditions for the procedures above.
*)
PROCEDURE CanAssignAll* (sourceLength: INTEGER; VAR destination: ARRAY OF CHAR): BOOLEAN;
(* Returns TRUE if a number of characters, indicated by `sourceLength', will
fit into `destination'; otherwise returns FALSE.
pre: `sourceLength' is not negative. *)
BEGIN
RETURN (sourceLength < LEN (destination))
END CanAssignAll;
PROCEDURE CanExtractAll* (sourceLength, startPos, numberToExtract: INTEGER;
VAR destination: ARRAY OF CHAR): BOOLEAN;
(* Returns TRUE if there are `numberToExtract' characters starting at
`startPos' and within the `sourceLength' of some string, and if the capacity
of `destination' is sufficient to hold `numberToExtract' characters;
otherwise returns FALSE.
pre: `sourceLength', `startPos', and `numberToExtract' are not negative. *)
BEGIN
RETURN (startPos+numberToExtract <= sourceLength) &
(numberToExtract < LEN (destination))
END CanExtractAll;
PROCEDURE CanDeleteAll* (stringLength, startPos,
numberToDelete: INTEGER): BOOLEAN;
(* Returns TRUE if there are `numberToDelete' characters starting at `startPos'
and within the `stringLength' of some string; otherwise returns FALSE.
pre: `stringLength', `startPos' and `numberToDelete' are not negative. *)
BEGIN
RETURN (startPos+numberToDelete <= stringLength)
END CanDeleteAll;
PROCEDURE CanInsertAll* (sourceLength, startPos: INTEGER;
VAR destination: ARRAY OF CHAR): BOOLEAN;
(* Returns TRUE if there is room for the insertion of `sourceLength'
characters from some string into `destination' starting at `startPos';
otherwise returns FALSE.
pre: `sourceLength' and `startPos' are not negative. *)
VAR
lenDestination: INTEGER;
BEGIN
lenDestination := Length (destination);
RETURN (startPos <= lenDestination) &
(sourceLength+lenDestination < LEN (destination))
END CanInsertAll;
PROCEDURE CanReplaceAll* (sourceLength, startPos: INTEGER;
VAR destination: ARRAY OF CHAR): BOOLEAN;
(* Returns TRUE if there is room for the replacement of `sourceLength'
characters in `destination' starting at `startPos'; otherwise returns FALSE.
pre: `sourceLength' and `startPos' are not negative. *)
BEGIN
RETURN (sourceLength+startPos <= Length(destination))
END CanReplaceAll;
PROCEDURE CanAppendAll* (sourceLength: INTEGER;
VAR destination: ARRAY OF CHAR): BOOLEAN;
(* Returns TRUE if there is sufficient room in `destination' to append a string
of length `sourceLength' to the string in `destination'; otherwise returns
FALSE.
pre: `sourceLength' is not negative. *)
BEGIN
RETURN (Length (destination)+sourceLength < LEN (destination))
END CanAppendAll;
PROCEDURE CanConcatAll* (source1Length, source2Length: INTEGER;
VAR destination: ARRAY OF CHAR): BOOLEAN;
(* Returns TRUE if there is sufficient room in `destination' for a two strings
of lengths `source1Length' and `source2Length'; otherwise returns FALSE.
pre: `source1Length' and `source2Length' are not negative. *)
BEGIN
RETURN (source1Length+source2Length < LEN (destination))
END CanConcatAll;
(*
The following type and procedures provide for the comparison of string values,
and for the location of substrings within strings.
*)
PROCEDURE Compare* (stringVal1, stringVal2: ARRAY OF CHAR): CompareResults;
(* Returns `less', `equal', or `greater', according as `stringVal1' is
lexically less than, equal to, or greater than `stringVal2'.
Note that Oberon-2 already contains predefined comparison operators on
strings. *)
VAR
i: INTEGER;
BEGIN
i := 0;
WHILE (stringVal1[i] # 0X) & (stringVal1[i] = stringVal2[i]) DO
INC (i)
END;
IF (stringVal1[i] < stringVal2[i]) THEN
RETURN less
ELSIF (stringVal1[i] > stringVal2[i]) THEN
RETURN greater
ELSE
RETURN equal
END
END Compare;
PROCEDURE Equal* (stringVal1, stringVal2: ARRAY OF CHAR): BOOLEAN;
(* Returns `stringVal1 = stringVal2'. Unlike the predefined operator `=', this
procedure can be assigned to a procedure variable. *)
VAR
i: INTEGER;
BEGIN
i := 0;
WHILE (stringVal1[i] # 0X) & (stringVal1[i] = stringVal2[i]) DO
INC (i)
END;
RETURN (stringVal1[i] = 0X) & (stringVal2[i] = 0X)
END Equal;
PROCEDURE FindNext* (pattern, stringToSearch: ARRAY OF CHAR; startPos: INTEGER;
VAR patternFound: BOOLEAN; VAR posOfPattern: INTEGER);
(* Looks forward for next occurrence of `pattern' in `stringToSearch', starting
the search at position `startPos'. If `startPos < Length(stringToSearch)'
and `pattern' is found, `patternFound' is returned as TRUE, and
`posOfPattern' contains the start position in `stringToSearch' of `pattern',
a value in the range [startPos..Length(stringToSearch)-1]. Otherwise
`patternFound' is returned as FALSE, and `posOfPattern' is unchanged.
If `startPos > Length(stringToSearch)-Length(Pattern)' then `patternFound'
is returned as FALSE.
pre: `startPos' is not negative. *)
VAR
patternPos: INTEGER;
BEGIN
IF (startPos < Length (stringToSearch)) THEN
patternPos := 0;
LOOP
IF (pattern[patternPos] = 0X) THEN
(* reached end of pattern *)
patternFound := TRUE;
posOfPattern := startPos-patternPos;
EXIT
ELSIF (stringToSearch[startPos] = 0X) THEN
(* end of string (but not of pattern) *)
patternFound := FALSE;
EXIT
ELSIF (stringToSearch[startPos] = pattern[patternPos]) THEN
(* characters identic, compare next one *)
INC (startPos);
INC (patternPos)
ELSE
(* difference found: reset indices and restart *)
startPos := startPos-patternPos+1;
patternPos := 0
END
END
ELSE
patternFound := FALSE
END
END FindNext;
PROCEDURE FindPrev* (pattern, stringToSearch: ARRAY OF CHAR; startPos: INTEGER;
VAR patternFound: BOOLEAN; VAR posOfPattern: INTEGER);
(* Looks backward for the previous occurrence of `pattern' in `stringToSearch'
and returns the position of the first character of the `pattern' if found.
The search for the pattern begins at `startPos'. If `pattern' is found,
`patternFound' is returned as TRUE, and `posOfPattern' contains the start
position in `stringToSearch' of pattern in the range [0..startPos].
Otherwise `patternFound' is returned as FALSE, and `posOfPattern' is
unchanged.
The pattern might be found at the given value of `startPos'. The search
will fail if `startPos' is negative.
If `startPos > Length(stringToSearch)-Length(pattern)' the whole string
value is searched. *)
VAR
patternPos, stringLength, patternLength: INTEGER;
BEGIN
(* correct `startPos' if it is larger than the possible searching range *)
stringLength := Length (stringToSearch);
patternLength := Length (pattern);
IF (startPos > stringLength-patternLength) THEN
startPos := stringLength-patternLength
END;
IF (startPos >= 0) THEN
patternPos := 0;
LOOP
IF (pattern[patternPos] = 0X) THEN
(* reached end of pattern *)
patternFound := TRUE;
posOfPattern := startPos-patternPos;
EXIT
ELSIF (stringToSearch[startPos] # pattern[patternPos]) THEN
(* characters differ: reset indices and restart *)
IF (startPos > patternPos) THEN
startPos := startPos-patternPos-1;
patternPos := 0
ELSE
(* reached beginning of `stringToSearch' without finding a match *)
patternFound := FALSE;
EXIT
END
ELSE (* characters identic, compare next one *)
INC (startPos);
INC (patternPos)
END
END
ELSE
patternFound := FALSE
END
END FindPrev;
PROCEDURE FindDiff* (stringVal1, stringVal2: ARRAY OF CHAR;
VAR differenceFound: BOOLEAN;
VAR posOfDifference: INTEGER);
(* Compares the string values in `stringVal1' and `stringVal2' for differences.
If they are equal, `differenceFound' is returned as FALSE, and TRUE
otherwise. If `differenceFound' is TRUE, `posOfDifference' is set to the
position of the first difference; otherwise `posOfDifference' is unchanged.
*)
VAR
i: INTEGER;
BEGIN
i := 0;
WHILE (stringVal1[i] # 0X) & (stringVal1[i] = stringVal2[i]) DO
INC (i)
END;
differenceFound := (stringVal1[i] # 0X) OR (stringVal2[i] # 0X);
IF differenceFound THEN
posOfDifference := i
END
END FindDiff;
PROCEDURE Capitalize* (VAR stringVar: ARRAY OF CHAR);
(* Applies the function CAP to each character of the string value in
`stringVar'. *)
VAR
i: INTEGER;
BEGIN
i := 0;
WHILE (stringVar[i] # 0X) DO
stringVar[i] := CAP (stringVar[i]);
INC (i)
END
END Capitalize;
END oocStrings.

100
src/lib/ooc/oocStrings2.Mod Normal file
View file

@ -0,0 +1,100 @@
(* This module is obsolete. Don't use it. *)
MODULE oocStrings2;
IMPORT
Strings := oocStrings;
PROCEDURE AppendChar* (ch: CHAR; VAR dst: ARRAY OF CHAR);
(* Appends 'ch' to string 'dst' (if Length(dst)<LEN(dst)-1). *)
VAR
len: INTEGER;
BEGIN
len := Strings.Length (dst);
IF (len < SHORT (LEN (dst))-1) THEN
dst[len] := ch;
dst[len+1] := 0X
END
END AppendChar;
PROCEDURE InsertChar* (ch: CHAR; pos: INTEGER; VAR dst: ARRAY OF CHAR);
(* Inserts the character ch into the string dst at position pos (0<=pos<=
Length(dst)). If pos=Length(dst), src is appended to dst. If the size of
dst is not large enough to hold the result of the operation, the result is
truncated so that dst is always terminated with a 0X. *)
VAR
src: ARRAY 2 OF CHAR;
BEGIN
src[0] := ch; src[1] := 0X;
Strings.Insert (src, pos, dst)
END InsertChar;
PROCEDURE PosChar* (ch: CHAR; str: ARRAY OF CHAR): INTEGER;
(* Returns the first position of character 'ch' in 'str' or
-1 if 'str' doesn't contain the character.
Ex.: PosChar ("abcd", "c") = 2
PosChar ("abcd", "D") = -1 *)
VAR
i: INTEGER;
BEGIN
i := 0;
LOOP
IF (str[i] = ch) THEN
RETURN i
ELSIF (str[i] = 0X) THEN
RETURN -1
ELSE
INC (i)
END
END
END PosChar;
PROCEDURE Match* (pat, s: ARRAY OF CHAR): BOOLEAN;
(* Returns TRUE if the string in s matches the string in pat.
The pattern may contain any number of the wild characters '*' and '?'
'?' matches any single character
'*' matches any sequence of characters (including a zero length sequence)
E.g. '*.?' will match any string with two or more characters if it's second
last character is '.'. *)
VAR
lenSource,
lenPattern: INTEGER;
PROCEDURE RecMatch(VAR src: ARRAY OF CHAR; posSrc: INTEGER;
VAR pat: ARRAY OF CHAR; posPat: INTEGER): BOOLEAN;
(* src = to be tested , posSrc = position in src *)
(* pat = pattern to match, posPat = position in pat *)
VAR
i: INTEGER;
BEGIN
LOOP
IF (posSrc = lenSource) & (posPat = lenPattern) THEN
RETURN TRUE
ELSIF (posPat = lenPattern) THEN
RETURN FALSE
ELSIF (pat[posPat] = "*") THEN
IF (posPat = lenPattern-1) THEN
RETURN TRUE
ELSE
FOR i := posSrc TO lenSource DO
IF RecMatch (src, i, pat, posPat+1) THEN
RETURN TRUE
END
END;
RETURN FALSE
END
ELSIF (pat[posPat] # "?") & (pat[posPat] # src[posSrc]) THEN
RETURN FALSE
ELSE
INC(posSrc); INC(posPat)
END
END
END RecMatch;
BEGIN
lenPattern := Strings.Length (pat);
lenSource := Strings.Length (s);
RETURN RecMatch (s, 0, pat, 0)
END Match;
END oocStrings2.

205
src/lib/ooc/oocTime.Mod Normal file
View file

@ -0,0 +1,205 @@
(* $Id: Time.Mod,v 1.6 2000/08/05 18:39:09 ooc-devel Exp $ *)
MODULE oocTime;
(*
Time - time and time interval manipulation.
Copyright (C) 1996 Michael Griebling
This module is free software; you can redistribute it and/or modify
it under the terms of the GNU Lesser General Public License as
published by the Free Software Foundation; either version 2 of the
License, or (at your option) any later version.
This module is distributed in the hope that it will be useful,
but WITHOUT ANY WARRANTY; without even the implied warranty of
MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
GNU Lesser General Public License for more details.
You should have received a copy of the GNU Lesser General Public
License along with this program; if not, write to the Free Software
Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA 02111-1307 USA
*)
IMPORT SysClock := oocSysClock;
CONST
msecPerSec* = 1000;
msecPerMin* = msecPerSec*60;
msecPerHour* = msecPerMin*60;
msecPerDay * = msecPerHour*24;
TYPE
(* The TimeStamp is a compressed date/time format with the
advantage over the Unix time stamp of being able to
represent any date/time in the DateTime type. The
fields are defined as follows:
days = Modified Julian days since 17 Nov 1858.
This quantity can be negative to represent
dates occuring before day zero.
msecs = Milliseconds since 00:00.
NOTE: TimeStamp is in UTC or local time when time zones
are not supported by the local operating system.
*)
TimeStamp * =
RECORD
days-: LONGINT;
msecs-: LONGINT
END;
(* The Interval is a delta time measure which can be used
to increment a Time or find the time difference between
two Times. The fields are defined as follows:
dayInt = numbers of days in this interval
msecInt = the number of milliseconds in this interval
The maximum number of milliseconds in an interval will
be the value `msecPerDay' *)
Interval * =
RECORD
dayInt-: LONGINT;
msecInt-: LONGINT
END;
(* ------------------------------------------------------------- *)
(* TimeStamp functions *)
PROCEDURE InitTimeStamp* (VAR t: TimeStamp; days, msecs: LONGINT);
(* Initialize the TimeStamp `t' with `days' days and `msecs' mS.
Pre: msecs>=0 *)
BEGIN
t.msecs:=msecs MOD msecPerDay;
t.days:=days + msecs DIV msecPerDay
END InitTimeStamp;
PROCEDURE GetTime* (VAR t: TimeStamp);
(* Set `t' to the current time of day. In case of failure (i.e. if
SysClock.CanGetClock() is FALSE) the time 00:00 UTC on Jan 1 1970 is
returned. This procedure is typically much faster than doing
SysClock.GetClock followed by Calendar.SetTimeStamp. *)
VAR
res, sec, usec: LONGINT;
BEGIN
res := SysClock.GetTimeOfDay (sec, usec);
t. days := 40587+sec DIV 86400;
t. msecs := (sec MOD 86400)*msecPerSec + usec DIV 1000
END GetTime;
PROCEDURE (VAR a: TimeStamp) Add* (b: Interval);
(* Adds the interval `b' to the time stamp `a'. *)
BEGIN
INC(a.msecs, b.msecInt);
INC(a.days, b.dayInt);
IF a.msecs>=msecPerDay THEN
DEC(a.msecs, msecPerDay); INC(a.days)
END
END Add;
PROCEDURE (VAR a: TimeStamp) Sub* (b: Interval);
(* Subtracts the interval `b' from the time stamp `a'. *)
BEGIN
DEC(a.msecs, b.msecInt);
DEC(a.days, b.dayInt);
IF a.msecs<0 THEN INC(a.msecs, msecPerDay); DEC(a.days) END
END Sub;
PROCEDURE (VAR a: TimeStamp) Delta* (b: TimeStamp; VAR c: Interval);
(* Post: c = a - b *)
BEGIN
c.msecInt:=a.msecs-b.msecs;
c.dayInt:=a.days-b.days;
IF c.msecInt<0 THEN
INC(c.msecInt, msecPerDay); DEC(c.dayInt)
END
END Delta;
PROCEDURE (VAR a: TimeStamp) Cmp* (b: TimeStamp) : SHORTINT;
(* Compares 'a' to 'b'. Result: -1: a<b; 0: a=b; 1: a>b
This means the comparison
can be directly extrapolated to a comparison between the
two numbers e.g.,
Cmp(a,b)<0 then a<b
Cmp(a,b)=0 then a=b
Cmp(a,b)>0 then a>b
Cmp(a,b)>=0 then a>=b
*)
BEGIN
IF (a.days>b.days) OR (a.days=b.days) & (a.msecs>b.msecs) THEN RETURN 1
ELSIF (a.days=b.days) & (a.msecs=b.msecs) THEN RETURN 0
ELSE RETURN -1
END
END Cmp;
(* ------------------------------------------------------------- *)
(* Interval functions *)
PROCEDURE InitInterval* (VAR int: Interval; days, msecs: LONGINT);
(* Initialize the Interval `int' with `days' days and `msecs' mS.
Pre: msecs>=0 *)
BEGIN
int.dayInt:=days + msecs DIV msecPerDay;
int.msecInt:=msecs MOD msecPerDay
END InitInterval;
PROCEDURE (VAR a: Interval) Add* (b: Interval);
(* Post: a = a + b *)
BEGIN
INC(a.msecInt, b.msecInt);
INC(a.dayInt, b.dayInt);
IF a.msecInt>=msecPerDay THEN
DEC(a.msecInt, msecPerDay); INC(a.dayInt)
END
END Add;
PROCEDURE (VAR a: Interval) Sub* (b: Interval);
(* Post: a = a - b *)
BEGIN
DEC(a.msecInt, b.msecInt);
DEC(a.dayInt, b.dayInt);
IF a.msecInt<0 THEN
INC(a.msecInt, msecPerDay); DEC(a.dayInt)
END
END Sub;
PROCEDURE (VAR a: Interval) Cmp* (b: Interval) : SHORTINT;
(* Compares 'a' to 'b'. Result: -1: a<b; 0: a=b; 1: a>b
Above convention makes more sense since the comparison
can be directly extrapolated to a comparison between the
two numbers e.g.,
Cmp(a,b)<0 then a<b
Cmp(a,b)=0 then a=b
Cmp(a,b)>0 then a>b
Cmp(a,b)>=0 then a>=b
*)
BEGIN
IF (a.dayInt>b.dayInt) OR (a.dayInt=b.dayInt)&(a.msecInt>b.msecInt) THEN RETURN 1
ELSIF (a.dayInt=b.dayInt) & (a.msecInt=b.msecInt) THEN RETURN 0
ELSE RETURN -1
END
END Cmp;
PROCEDURE (VAR a: Interval) Scale* (b: LONGREAL);
(* Pre: b>=0; Post: a := a*b *)
VAR
si: LONGREAL;
BEGIN
si:=(a.dayInt+a.msecInt/msecPerDay)*b;
a.dayInt:=ENTIER(si);
a.msecInt:=ENTIER((si-a.dayInt)*msecPerDay+0.5D0)
END Scale;
PROCEDURE (VAR a: Interval) Fraction* (b: Interval) : LONGREAL;
(* Pre: b<>0; Post: RETURN a/b *)
BEGIN
RETURN (a.dayInt+a.msecInt/msecPerDay)/(b.dayInt+b.msecInt/msecPerDay)
END Fraction;
END oocTime.

34
src/lib/ooc2/gnuc/oocwrapperlibc.Mod Normal file
View file

@ -0,0 +1,34 @@
MODULE oocwrapperlibc;
IMPORT SYSTEM;
PROCEDURE -includeStdio()
"#include <stdio.h>";
PROCEDURE -sys(str: ARRAY OF CHAR): INTEGER
"system(str)";
PROCEDURE system*(cmd : ARRAY OF CHAR);
VAR r : INTEGER;
BEGIN
r := sys(cmd);
END system;
(*
PROCEDURE strtod* (string: C.address;
VAR tailptr: C.charPtr1d): C.double;
PROCEDURE strtof* (string: C.address;
VAR tailptr: C.charPtr1d): C.float;
PROCEDURE sscanf* (s: C.address; template: ARRAY OF CHAR; ...) : C.int;
*)
PROCEDURE -sprntf(s, t0, t1, t2: ARRAY OF CHAR): INTEGER
"sprintf(s, t0, t1, t2)";
PROCEDURE sprintf* (VAR s: ARRAY OF CHAR; template0: ARRAY OF CHAR; template1: ARRAY OF CHAR; template2: ARRAY OF CHAR);
VAR r : INTEGER;
BEGIN
r := sprntf (s, template0, template1, template2);
END sprintf;
BEGIN
END oocwrapperlibc.

37
src/lib/ooc2/ooc2Ascii.Mod Normal file
View file

@ -0,0 +1,37 @@
(* $Id: Ascii.Mod,v 1.2 2003/01/04 10:19:19 mva Exp $ *)
MODULE ooc2Ascii;
(* Standard short character names for control chars.
Copyright (C) 2002 Michael van Acken
This module is free software; you can redistribute it and/or
modify it under the terms of the GNU Lesser General Public License
as published by the Free Software Foundation; either version 2 of
the License, or (at your option) any later version.
This module is distributed in the hope that it will be useful, but
WITHOUT ANY WARRANTY; without even the implied warranty of
MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU
Lesser General Public License for more details.
You should have received a copy of the GNU Lesser General Public
License along with OOC. If not, write to the Free Software Foundation,
59 Temple Place - Suite 330, Boston, MA 02111-1307, USA.
*)
CONST
nul* = 00X; soh* = 01X; stx* = 02X; etx* = 03X;
eot* = 04X; enq* = 05X; ack* = 06X; bel* = 07X;
bs * = 08X; ht * = 09X; lf * = 0AX; vt * = 0BX;
ff * = 0CX; cr * = 0DX; so * = 0EX; si * = 0FX;
dle* = 10X; dc1* = 11X; dc2* = 12X; dc3* = 13X;
dc4* = 14X; nak* = 15X; syn* = 16X; etb* = 17X;
can* = 18X; em * = 19X; sub* = 1AX; esc* = 1BX;
fs * = 1CX; gs * = 1DX; rs * = 1EX; us * = 1FX;
del* = 7FX;
CONST (* often used synonyms *)
sp * = " ";
xon* = dc1;
xoff* = dc3;
END ooc2Ascii.

89
src/lib/ooc2/ooc2CharClass.Mod Normal file
View file

@ -0,0 +1,89 @@
(* $Id: CharClass.Mod,v 1.1 2002/04/15 22:42:48 mva Exp $ *)
MODULE ooc2CharClass;
(* Classification of values of the type CHAR.
Copyright (C) 1997-1998, 2002 Michael van Acken
This module is free software; you can redistribute it and/or
modify it under the terms of the GNU Lesser General Public License
as published by the Free Software Foundation; either version 2 of
the License, or (at your option) any later version.
This module is distributed in the hope that it will be useful, but
WITHOUT ANY WARRANTY; without even the implied warranty of
MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU
Lesser General Public License for more details.
You should have received a copy of the GNU Lesser General Public
License along with OOC. If not, write to the Free Software Foundation,
59 Temple Place - Suite 330, Boston, MA 02111-1307, USA.
*)
IMPORT
Ascii := ooc2Ascii;
CONST
eol* = Ascii.lf;
(**The implementation-defined character used to represent end of line
internally for OOC. *)
VAR
systemEol-: ARRAY 3 OF CHAR;
(**End of line marker used by the target system for text files. The string
defined here can contain more than one character. For one character eol
markers, @ovar{systemEol} must not necessarily equal @oconst{eol}. Note
that the string cannot contain the termination character @code{0X}. *)
PROCEDURE IsNumeric* (ch: CHAR): BOOLEAN;
(**Returns @code{TRUE} if and only if @oparam{ch} is classified as a numeric
character. *)
BEGIN
RETURN ("0" <= ch) & (ch <= "9")
END IsNumeric;
PROCEDURE IsLetter* (ch: CHAR): BOOLEAN;
(**Returns @code{TRUE} if and only if @oparam{ch} is classified as a letter. *)
BEGIN
RETURN ("a" <= ch) & (ch <= "z") OR ("A" <= ch) & (ch <= "Z")
END IsLetter;
PROCEDURE IsUpper* (ch: CHAR): BOOLEAN;
(**Returns @code{TRUE} if and only if @oparam{ch} is classified as an upper
case letter. *)
BEGIN
RETURN ("A" <= ch) & (ch <= "Z")
END IsUpper;
PROCEDURE IsLower* (ch: CHAR): BOOLEAN;
(**Returns @code{TRUE} if and only if @oparam{ch} is classified as a lower case
letter. *)
BEGIN
RETURN ("a" <= ch) & (ch <= "z")
END IsLower;
PROCEDURE IsControl* (ch: CHAR): BOOLEAN;
(**Returns @code{TRUE} if and only if @oparam{ch} represents a control
function. *)
BEGIN
RETURN (ch < Ascii.sp)
END IsControl;
PROCEDURE IsWhiteSpace* (ch: CHAR): BOOLEAN;
(**Returns @code{TRUE} if and only if @oparam{ch} represents a space character
or a format effector. *)
BEGIN
RETURN (ch = Ascii.sp) OR (ch = Ascii.ff) OR (ch = Ascii.lf) OR
(ch = Ascii.cr) OR (ch = Ascii.ht) OR (ch = Ascii.vt)
END IsWhiteSpace;
PROCEDURE IsEol* (ch: CHAR): BOOLEAN;
(**Returns @code{TRUE} if and only if @oparam{ch} is the implementation-defined
character used to represent end of line internally for OOC. *)
BEGIN
RETURN (ch = eol)
END IsEol;
BEGIN
systemEol[0] := Ascii.lf; systemEol[1] := 0X
END ooc2CharClass.

45
src/lib/ooc2/ooc2ConvTypes.Mod Normal file
View file

@ -0,0 +1,45 @@
(* $Id: ConvTypes.Mod,v 1.1 2002/05/10 22:25:18 mva Exp $ *)
MODULE ooc2ConvTypes;
(**Common types used in the string conversion modules. *)
TYPE
ConvResults*= SHORTINT;
(**Values of this type are used to express the format of a string. *)
CONST
strAllRight*=0;
(**The string format is correct for the corresponding conversion. *)
strOutOfRange*=1;
(**The string is well-formed but the value cannot be represented. *)
strWrongFormat*=2;
(**The string is in the wrong format for the conversion. *)
strEmpty*=3;
(**The given string is empty. *)
TYPE
ScanClass*= SHORTINT;
(**Values of this type are used to classify input to finite state scanners. *)
CONST
padding*=0;
(**A leading or padding character at this point in the scan---ignore it. *)
valid*=1;
(**A valid character at this point in the scan---accept it. *)
invalid*=2;
(*An invalid character at this point in the scan---reject it *)
terminator*=3;
(**A terminating character at this point in the scan (not part of token). *)
TYPE
ScanState*=POINTER TO ScanDesc;
ScanDesc*=RECORD
(**The type of lexical scanning control procedures. *)
p*: PROCEDURE (ch: CHAR; VAR cl: ScanClass; VAR st: ScanState);
(**A procedure that produces the next state corresponding to the
character @var{ch}. The class of the character is returned
in @var{cl}, the next state in @var{st}. *)
END;
END ooc2ConvTypes.

249
src/lib/ooc2/ooc2IntConv.Mod Normal file
View file

@ -0,0 +1,249 @@
(* $Id: IntConv.Mod,v 1.6 2002/05/26 12:15:17 mva Exp $ *)
MODULE ooc2IntConv;
(*
IntConv - Low-level integer/string conversions.
Copyright (C) 2000, 2002 Michael van Acken
Copyright (C) 1995 Michael Griebling
This module is free software; you can redistribute it and/or modify
it under the terms of the GNU Lesser General Public License as
published by the Free Software Foundation; either version 2 of the
License, or (at your option) any later version.
This module is distributed in the hope that it will be useful,
but WITHOUT ANY WARRANTY; without even the implied warranty of
MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
GNU Lesser General Public License for more details.
You should have received a copy of the GNU Lesser General Public
License along with this program; if not, write to the Free Software
Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA 02111-1307 USA
*)
IMPORT
Char := ooc2CharClass, Conv := ooc2ConvTypes;
TYPE
ConvResults* = Conv.ConvResults;
(**One of @oconst{strAllRight}, @oconst{strOutOfRange},
@oconst{strWrongFormat}, or @oconst{strEmpty}. *)
CONST
strAllRight*=Conv.strAllRight;
(**The string format is correct for the corresponding conversion. *)
strOutOfRange*=Conv.strOutOfRange;
(**The string is well-formed but the value cannot be represented. *)
strWrongFormat*=Conv.strWrongFormat;
(**The string is in the wrong format for the conversion. *)
strEmpty*=Conv.strEmpty;
(**The given string is empty. *)
VAR
W, S, SI: Conv.ScanState;
minInt, maxInt: ARRAY 11 OF CHAR;
CONST
maxDigits = 10; (* length of minInt, maxInt *)
(* internal state machine procedures *)
PROCEDURE WState(inputCh: CHAR; VAR chClass: Conv.ScanClass; VAR nextState: Conv.ScanState);
BEGIN
IF Char.IsNumeric(inputCh) THEN chClass:=Conv.valid; nextState:=W
ELSE chClass:=Conv.terminator; nextState:=NIL
END
END WState;
PROCEDURE SState(inputCh: CHAR; VAR chClass: Conv.ScanClass; VAR nextState: Conv.ScanState);
BEGIN
IF Char.IsNumeric(inputCh) THEN chClass:=Conv.valid; nextState:=W
ELSE chClass:=Conv.invalid; nextState:=S
END
END SState;
PROCEDURE ScanInt*(inputCh: CHAR; VAR chClass: Conv.ScanClass; VAR nextState: Conv.ScanState);
(**Represents the start state of a finite state scanner for signed whole
numbers---assigns class of @oparam{inputCh} to @oparam{chClass} and a
procedure representing the next state to @oparam{nextState}.
The call of @samp{ScanInt(inputCh,chClass,nextState)} shall assign values
to @oparam{chClass} and @oparam{nextState} depending upon the value of
@oparam{inputCh} as shown in the following table.
@example
Procedure inputCh chClass nextState (a procedure
with behaviour of)
--------- --------- -------- ---------
ScanInt space padding ScanInt
sign valid SState
decimal digit valid WState
other invalid ScanInt
SState decimal digit valid WState
other invalid SState
WState decimal digit valid WState
other terminator --
@end example
NOTE 1 -- The procedure @oproc{ScanInt} corresponds to the start state of a
finite state machine to scan for a character sequence that forms a signed
whole number. It may be used to control the actions of a finite state
interpreter. As long as the value of @oparam{chClass} is other than
@oconst{Conv.terminator} or @oconst{Conv.invalid}, the
interpreter should call the procedure whose value is assigned to
@oparam{nextState} by the previous call, supplying the next character from
the sequence to be scanned. It may be appropriate for the interpreter to
ignore characters classified as @oconst{Conv.invalid}, and proceed
with the scan. This would be the case, for example, with interactive
input, if only valid characters are being echoed in order to give
interactive users an immediate indication of badly-formed data. If the
character sequence end before one is classified as a terminator, the
string-terminator character should be supplied as input to the finite state
scanner. If the preceeding character sequence formed a complete number,
the string-terminator will be classified as @oconst{Conv.terminator},
otherwise it will be classified as @oconst{Conv.invalid}. *)
BEGIN
IF Char.IsWhiteSpace(inputCh) THEN chClass:=Conv.padding; nextState:=SI
ELSIF (inputCh="+") OR (inputCh="-") THEN chClass:=Conv.valid; nextState:=S
ELSIF Char.IsNumeric(inputCh) THEN chClass:=Conv.valid; nextState:=W
ELSE chClass:=Conv.invalid; nextState:=SI
END
END ScanInt;
PROCEDURE FormatInt*(str: ARRAY OF CHAR): ConvResults;
(**Returns the format of the string value for conversion to LONGINT. *)
VAR
ch: CHAR;
index, start: INTEGER;
state: Conv.ScanState;
positive: BOOLEAN;
prev, class: Conv.ScanClass;
PROCEDURE LessOrEqual (VAR high: ARRAY OF CHAR; start, end: INTEGER): BOOLEAN;
VAR
i: INTEGER;
BEGIN (* pre: index-start = maxDigits *)
i := 0;
WHILE (start # end) DO
IF (str[start] < high[i]) THEN
RETURN TRUE;
ELSIF (str[start] > high[i]) THEN
RETURN FALSE;
ELSE (* str[start] = high[i] *)
INC (start); INC (i);
END;
END;
RETURN TRUE; (* full match *)
END LessOrEqual;
BEGIN
index:=0; prev:=Conv.padding; state:=SI; positive:=TRUE; start := -1;
LOOP
ch:=str[index];
state.p(ch, class, state);
CASE class OF
| Conv.padding: (* nothing to do *)
| Conv.valid:
IF ch="-" THEN positive:=FALSE
ELSIF ch="+" THEN positive:=TRUE
ELSIF (start < 0) & (ch # "0") THEN
start := index;
END
| Conv.invalid:
IF (prev = Conv.padding) & (ch = 0X) THEN
RETURN strEmpty;
ELSE
RETURN strWrongFormat;
END;
| Conv.terminator:
IF (ch = 0X) THEN
IF (index-start < maxDigits) OR
(index-start = maxDigits) &
(positive & LessOrEqual (maxInt, start, index) OR
~positive & LessOrEqual (minInt, start, index)) THEN
RETURN strAllRight;
ELSE
RETURN strOutOfRange;
END;
ELSE
RETURN strWrongFormat;
END;
END;
prev:=class; INC(index)
END;
END FormatInt;
PROCEDURE ValueInt*(str: ARRAY OF CHAR): LONGINT;
(**Returns the value corresponding to the signed whole number string value
@oparam{str} if @oparam{str} is well-formed. Otherwise, result is
undefined. *)
VAR
i: INTEGER;
int: LONGINT;
positive: BOOLEAN;
BEGIN
IF FormatInt(str)=strAllRight THEN
(* here holds: `str' is a well formed string and its value is in range *)
i:=0; positive:=TRUE;
WHILE (str[i] < "0") OR (str[i] > "9") DO (* skip whitespace and sign *)
IF (str[i] = "-") THEN
positive := FALSE;
END;
INC (i);
END;
int := 0;
IF positive THEN
WHILE (str[i] # 0X) DO
int:=int*10 + (ORD(str[i]) - ORD("0"));
INC (i);
END;
ELSE
WHILE (str[i] # 0X) DO
int:=int*10 - (ORD(str[i]) - ORD("0"));
INC (i);
END;
END;
RETURN int;
ELSE (* result is undefined *)
RETURN 0;
END
END ValueInt;
PROCEDURE LengthInt*(int: LONGINT): INTEGER;
(**Returns the number of characters in the string representation of
@oparam{int}. This value corresponds to the capacity of an array @samp{str}
which is of the minimum capacity needed to avoid truncation of the result in
the call @samp{IntStr.IntToStr(int,str)}. *)
VAR
cnt: INTEGER;
BEGIN
IF int=MIN(LONGINT) THEN
RETURN maxDigits+1;
ELSE
IF int<=0 THEN int:=-int; cnt:=1
ELSE cnt:=0
END;
WHILE int>0 DO INC(cnt); int:=int DIV 10 END;
RETURN cnt;
END;
END LengthInt;
BEGIN
(* kludge necessary because of recursive procedure declaration *)
NEW(S); NEW(W); NEW(SI);
S.p:=SState; W.p:=WState; SI.p:=ScanInt;
minInt := "2147483648";
maxInt := "2147483647";
END ooc2IntConv.

103
src/lib/ooc2/ooc2IntStr.Mod Normal file
View file

@ -0,0 +1,103 @@
(* $Id: IntStr.Mod,v 1.1 2002/05/12 21:58:14 mva Exp $ *)
MODULE ooc2IntStr;
(* IntStr - Integer-number/string conversions.
Copyright (C) 1995 Michael Griebling
This module is free software; you can redistribute it and/or modify
it under the terms of the GNU Lesser General Public License as
published by the Free Software Foundation; either version 2 of the
License, or (at your option) any later version.
This module is distributed in the hope that it will be useful,
but WITHOUT ANY WARRANTY; without even the implied warranty of
MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
GNU Lesser General Public License for more details.
You should have received a copy of the GNU Lesser General Public
License along with this program; if not, write to the Free Software
Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA 02111-1307 USA
*)
IMPORT
Conv := ooc2ConvTypes, IntConv := ooc2IntConv;
TYPE
ConvResults*= Conv.ConvResults;
(**One of @oconst{strAllRight}, @oconst{strOutOfRange},
@oconst{strWrongFormat}, or @oconst{strEmpty}. *)
CONST
strAllRight*=Conv.strAllRight;
(**The string format is correct for the corresponding conversion. *)
strOutOfRange*=Conv.strOutOfRange;
(**The string is well-formed but the value cannot be represented. *)
strWrongFormat*=Conv.strWrongFormat;
(**The string is in the wrong format for the conversion. *)
strEmpty*=Conv.strEmpty;
(**The given string is empty. *)
(* the string form of a signed whole number is
["+" | "-"] decimal_digit {decimal_digit}
*)
PROCEDURE StrToInt*(str: ARRAY OF CHAR; VAR int: LONGINT; VAR res: ConvResults);
(**Converts string to integer value. Ignores any leading spaces in
@oparam{str}. If the subsequent characters in @oparam{str} are in the
format of a signed whole number, assigns a corresponding value to
@oparam{int}. Assigns a value indicating the format of @oparam{str} to
@oparam{res}. *)
BEGIN
res:=IntConv.FormatInt(str);
IF (res = strAllRight) THEN
int:=IntConv.ValueInt(str)
END
END StrToInt;
PROCEDURE Reverse (VAR str : ARRAY OF CHAR; start, end : INTEGER);
(* Reverses order of characters in the interval [start..end]. *)
VAR
h : CHAR;
BEGIN
WHILE start < end DO
h := str[start]; str[start] := str[end]; str[end] := h;
INC(start); DEC(end)
END
END Reverse;
PROCEDURE IntToStr*(int: LONGINT; VAR str: ARRAY OF CHAR);
(**Converts the value of @oparam{int} to string form and copies the possibly
truncated result to @oparam{str}. *)
CONST
maxLength = 11; (* maximum number of digits representing a LONGINT value *)
VAR
b : ARRAY maxLength+1 OF CHAR;
s, e: INTEGER;
BEGIN
(* build representation in string 'b' *)
IF int = MIN(LONGINT) THEN (* smallest LONGINT, -int is an overflow *)
b := "-2147483648";
e := 11
ELSE
IF int < 0 THEN (* negative sign *)
b[0] := "-"; int := -int; s := 1
ELSE (* no sign *)
s := 0
END;
e := s; (* 's' holds starting position of string *)
REPEAT
b[e] := CHR(int MOD 10+ORD("0"));
int := int DIV 10;
INC(e)
UNTIL int = 0;
b[e] := 0X;
Reverse(b, s, e-1)
END;
COPY(b, str) (* truncate output if necessary *)
END IntToStr;
END ooc2IntStr.

106
src/lib/ooc2/ooc2LRealConv.Mod Normal file
View file

@ -0,0 +1,106 @@
(* $Id: LRealConv.Mod,v 1.13 2003/04/06 12:11:15 mva Exp $ *)
MODULE ooc2LRealConv;
(* String to LONGREAL conversion functions.
Copyright (C) 2002 Michael van Acken
This module is free software; you can redistribute it and/or
modify it under the terms of the GNU Lesser General Public License
as published by the Free Software Foundation; either version 2 of
the License, or (at your option) any later version.
This module is distributed in the hope that it will be useful, but
WITHOUT ANY WARRANTY; without even the implied warranty of
MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU
Lesser General Public License for more details.
You should have received a copy of the GNU Lesser General Public
License along with OOC. If not, write to the Free Software Foundation,
59 Temple Place - Suite 330, Boston, MA 02111-1307, USA.
*)
IMPORT
SYSTEM, libc := oocwrapperlibc, CharClass := ooc2CharClass, ConvTypes := ooc2ConvTypes, Real0 := ooc2Real0;
(**
The regular expression for a signed fixed-point real number is
@samp{[+-]?\d+(\.\d* )?}. For the optional exponent part, it is
@samp{E[+-]?\d+}.
*)
TYPE
ConvResults* = ConvTypes.ConvResults;
(**One of @oconst{strAllRight}, @oconst{strOutOfRange},
@oconst{strWrongFormat}, or @oconst{strEmpty}. *)
CONST
strAllRight*=ConvTypes.strAllRight;
(**The string format is correct for the corresponding conversion. *)
strOutOfRange*=ConvTypes.strOutOfRange;
(**The string is well-formed but the value cannot be represented. *)
strWrongFormat*=ConvTypes.strWrongFormat;
(**The string is in the wrong format for the conversion. *)
strEmpty*=ConvTypes.strEmpty;
(**The given string is empty. *)
CONST
maxValue = "17976931348623157";
(* signifcant digits of the maximum value 1.7976931348623157D+308 *)
maxExp = 308;
(* maxium positive exponent of a normalized number *)
PROCEDURE ScanReal*(inputCh: CHAR;
VAR chClass: ConvTypes.ScanClass;
VAR nextState: ConvTypes.ScanState);
BEGIN
Real0.ScanReal (inputCh, chClass, nextState);
END ScanReal;
PROCEDURE FormatReal* (str: ARRAY OF CHAR): ConvResults;
BEGIN
RETURN Real0.FormatReal (str, maxExp, maxValue);
END FormatReal;
PROCEDURE ValueReal*(str: ARRAY OF CHAR): LONGREAL;
(* result is undefined if FormatReal(str) # strAllRight *)
VAR
i: LONGINT;
value: LONGREAL;
BEGIN
i := 0;
WHILE CharClass.IsWhiteSpace(str[i]) DO
(* skip our definition of whitespace *)
INC (i);
END;
IF libc.sscanf(SYSTEM.ADR(str[i]), "%lf", SYSTEM.ADR(value)) = 1 THEN
(* <*PUSH; Warnings:=FALSE*> *)
RETURN value (* syntax is ok *)
(* <*POP*> *)
ELSE
RETURN 0; (* error *)
END;
END ValueReal;
PROCEDURE LengthFloatReal*(real: LONGREAL; sigFigs: INTEGER): INTEGER;
BEGIN
(*<*PUSH; Assertions:=TRUE*>*)
ASSERT (FALSE)
(*<*POP*>*)
END LengthFloatReal;
PROCEDURE LengthEngReal*(real: LONGREAL; sigFigs: INTEGER): INTEGER;
BEGIN
(*<*PUSH; Assertions:=TRUE*>*)
ASSERT (FALSE)
(*<*POP*>*)
END LengthEngReal;
PROCEDURE LengthFixedReal*(real: LONGREAL; place: INTEGER): INTEGER;
BEGIN
(*<*PUSH; Assertions:=TRUE*>*)
ASSERT (FALSE)
(*<*POP*>*)
END LengthFixedReal;
END ooc2LRealConv.

447
src/lib/ooc2/ooc2Real0.Mod Normal file
View file

@ -0,0 +1,447 @@
(* $Id: Real0.Mod,v 1.3 2002/08/12 18:11:30 mva Exp $ *)
MODULE ooc2Real0;
(* Helper functions used by the real conversion modules.
Copyright (C) 2002 Michael van Acken
This module is free software; you can redistribute it and/or
modify it under the terms of the GNU Lesser General Public License
as published by the Free Software Foundation; either version 2 of
the License, or (at your option) any later version.
This module is distributed in the hope that it will be useful, but
WITHOUT ANY WARRANTY; without even the implied warranty of
MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU
Lesser General Public License for more details.
You should have received a copy of the GNU Lesser General Public
License along with OOC. If not, write to the Free Software Foundation,
59 Temple Place - Suite 330, Boston, MA 02111-1307, USA.
*)
IMPORT
CharClass := ooc2CharClass, ConvTypes := ooc2ConvTypes, Strings := ooc2Strings;
TYPE
ConvResults = ConvTypes.ConvResults;
CONST
strAllRight=ConvTypes.strAllRight;
strOutOfRange=ConvTypes.strOutOfRange;
strWrongFormat=ConvTypes.strWrongFormat;
strEmpty=ConvTypes.strEmpty;
CONST
padding=ConvTypes.padding;
valid=ConvTypes.valid;
invalid=ConvTypes.invalid;
terminator=ConvTypes.terminator;
TYPE
ScanClass = ConvTypes.ScanClass;
ScanState = ConvTypes.ScanState;
CONST
expChar* = "E";
VAR
RS-, P-, F-, E-, SE-, WE-, SR-: ScanState;
(* internal state machine procedures *)
PROCEDURE IsSign (ch: CHAR): BOOLEAN;
(* Return TRUE for '+' or '-' *)
BEGIN
RETURN (ch='+') OR (ch='-')
END IsSign;
PROCEDURE RSState(inputCh: CHAR;
VAR chClass: ScanClass; VAR nextState: ScanState);
BEGIN
IF CharClass.IsNumeric(inputCh) THEN
chClass:=valid; nextState:=P
ELSE
chClass:=invalid; nextState:=RS
END
END RSState;
PROCEDURE PState(inputCh: CHAR;
VAR chClass: ScanClass; VAR nextState: ScanState);
BEGIN
IF CharClass.IsNumeric(inputCh) THEN
chClass:=valid; nextState:=P
ELSIF inputCh="." THEN
chClass:=valid; nextState:=F
ELSIF inputCh=expChar THEN
chClass:=valid; nextState:=E
ELSE
chClass:=terminator; nextState:=NIL
END
END PState;
PROCEDURE FState(inputCh: CHAR;
VAR chClass: ScanClass; VAR nextState: ScanState);
BEGIN
IF CharClass.IsNumeric(inputCh) THEN
chClass:=valid; nextState:=F
ELSIF inputCh=expChar THEN
chClass:=valid; nextState:=E
ELSE
chClass:=terminator; nextState:=NIL
END
END FState;
PROCEDURE EState(inputCh: CHAR;
VAR chClass: ScanClass; VAR nextState: ScanState);
BEGIN
IF IsSign(inputCh) THEN
chClass:=valid; nextState:=SE
ELSIF CharClass.IsNumeric(inputCh) THEN
chClass:=valid; nextState:=WE
ELSE
chClass:=invalid; nextState:=E
END
END EState;
PROCEDURE SEState(inputCh: CHAR;
VAR chClass: ScanClass; VAR nextState: ScanState);
BEGIN
IF CharClass.IsNumeric(inputCh) THEN
chClass:=valid; nextState:=WE
ELSE
chClass:=invalid; nextState:=SE
END
END SEState;
PROCEDURE WEState(inputCh: CHAR;
VAR chClass: ScanClass; VAR nextState: ScanState);
BEGIN
IF CharClass.IsNumeric(inputCh) THEN
chClass:=valid; nextState:=WE
ELSE
chClass:=terminator; nextState:=NIL
END
END WEState;
PROCEDURE ScanReal*(inputCh: CHAR;
VAR chClass: ScanClass; VAR nextState: ScanState);
BEGIN
IF CharClass.IsWhiteSpace(inputCh) THEN
chClass:=padding; nextState:=SR
ELSIF IsSign(inputCh) THEN
chClass:=valid; nextState:=RS
ELSIF CharClass.IsNumeric(inputCh) THEN
chClass:=valid; nextState:=P
ELSE
chClass:=invalid; nextState:=SR
END
END ScanReal;
PROCEDURE FormatReal* (str: ARRAY OF CHAR; maxExp: LONGINT;
maxValue: ARRAY OF CHAR): ConvResults;
VAR
i: LONGINT;
ch: CHAR;
state: ConvTypes.ScanState;
class: ConvTypes.ScanClass;
wSigFigs, fLeadingZeros, exp, startOfExp: LONGINT;
expNegative, allZeroDigit: BOOLEAN;
CONST
expCutoff = 100000000;
(* assume overflow if the value of the exponent is larger than this *)
PROCEDURE NonZeroDigit (): LONGINT;
(* locate first non-zero digit in str *)
BEGIN
i := 0;
WHILE (i # startOfExp) & ((str[i] < "1") OR (str[i] > "9")) DO
INC (i);
END;
RETURN i;
END NonZeroDigit;
PROCEDURE LessOrEqual (upperBound: ARRAY OF CHAR): BOOLEAN;
VAR
i, j: LONGINT;
BEGIN
i := NonZeroDigit();
IF (i # startOfExp) THEN (* str[i] is non-zero digit *)
j := 0;
WHILE (i # startOfExp) & (upperBound[j] # 0X) DO
IF (str[i] < upperBound[j]) THEN
RETURN TRUE;
ELSIF (str[i] > upperBound[j]) THEN
RETURN FALSE;
ELSE
INC (j); INC (i);
IF (str[i] = ".") THEN (* skip decimal point *)
INC (i);
END;
END;
END;
IF (upperBound[j] = 0X) THEN
(* any trailing zeros don't change the outcome: skip them *)
WHILE (str[i] = "0") OR (str[i] = ".") DO
INC (i);
END;
END;
END;
RETURN (i = startOfExp);
END LessOrEqual;
BEGIN
(* normalize exponent character *)
i := 0;
WHILE (str[i] # 0X) & (str[i] # "e") DO
INC (i);
END;
IF (str[i] = "e") THEN
str[i] := expChar;
END;
(* move index `i' over padding characters *)
i := 0;
state := SR;
REPEAT
ch := str[i];
state.p(ch, class, state);
INC (i);
UNTIL (class # ConvTypes.padding);
IF (ch = 0X) THEN
RETURN strEmpty;
ELSE
(* scan part before decimal point or exponent *)
WHILE (class = ConvTypes.valid) & (state # F) & (state # E) &
((ch < "1") OR (ch > "9")) DO
ch := str[i];
state.p(ch, class, state);
INC (i);
END;
wSigFigs := 0;
WHILE (class = ConvTypes.valid) & (state # F) & (state # E) DO
INC (wSigFigs);
ch := str[i];
state.p(ch, class, state);
INC (i);
END;
(* here holds: wSigFigs is the number of significant digits in
the whole number part of the number; 0 means there are only
zeros before the decimal point *)
(* scan fractional part exponent *)
fLeadingZeros := 0; allZeroDigit := TRUE;
WHILE (class = ConvTypes.valid) & (state # E) DO
ch := str[i];
IF allZeroDigit THEN
IF (ch = "0") THEN
INC (fLeadingZeros);
ELSIF (ch # ".") THEN
allZeroDigit := FALSE;
END;
END;
state.p(ch, class, state);
INC (i);
END;
(* here holds: fLeadingZeros holds the number of zeros after
the decimal point *)
(* scan exponent *)
startOfExp := i-1; exp := 0; expNegative := FALSE;
WHILE (class = ConvTypes.valid) DO
ch := str[i];
IF (ch = "-") THEN
expNegative := TRUE;
ELSIF ("0" <= ch) & (ch <= "9") & (exp < expCutoff) THEN
exp := exp*10 + (ORD(ch)-ORD("0"));
END;
state.p(ch, class, state);
INC (i);
END;
IF expNegative THEN
exp := -exp;
END;
(* here holds: exp holds the value of the exponent; if it's absolute
value is larger than expCutoff, then there has been an overflow *)
IF (class = ConvTypes.invalid) OR (ch # 0X) THEN
RETURN strWrongFormat;
ELSE (* (class = ConvTypes.terminator) & (ch = 0X) *)
(* normalize the number: calculate the exponent if the number would
start with a non-zero digit, immediately followed by the
decimal point *)
IF (wSigFigs > 0) THEN
exp := exp+wSigFigs-1;
ELSE
exp := exp-fLeadingZeros-1;
END;
IF (exp > maxExp) & (NonZeroDigit() # startOfExp) OR
(exp = maxExp) & ~LessOrEqual (maxValue) THEN
RETURN strOutOfRange;
ELSE
RETURN strAllRight;
END;
END;
END;
END FormatReal;
PROCEDURE NormalizeFloat* (VAR s: ARRAY OF CHAR);
VAR
i, d: INTEGER;
BEGIN
(* massage the output of sprintf to match our requirements; note: this
code should also handle "Inf", "Infinity", "NaN", etc., gracefully
but this is untested *)
IF (s[0] = "+") THEN d := 1; ELSE d := 0; END; (* erase "+" sign *)
i := 1;
WHILE (s[i] # 0X) DO
IF (s[i] = ".") & (s[i+1] = expChar) THEN
INC (d); (* eliminate "." if no digits follow *)
ELSIF (s[i] = "0") & (i-d-1 >= 0) & IsSign (s[i-d-1]) THEN
INC (d); (* eliminate zeros after exponent sign *)
ELSE
s[i-d] := s[i];
END;
INC (i);
END;
IF (s[i-d-2] = "E") THEN
s[i-d-2] := 0X; (* remove "E+" or "E-" *)
ELSE
s[i-d] := 0X;
END;
END NormalizeFloat;
PROCEDURE FormatForEng* (VAR s: ARRAY OF CHAR);
VAR
i, d, fract, exp, posExp, offset: INTEGER;
BEGIN
(* find out how large the exponent is, and how many digits are in the
fractional part *)
fract := 0; exp := 0; posExp := 0;
IF CharClass.IsNumeric (s[1]) THEN (* skip for NaN, Inf *)
i := 0; d := 0;
WHILE (s[i] # "E") DO
fract := fract + d;
IF (s[i] = ".") THEN d := 1; END;
INC (i);
END;
INC (i);
IF (s[i] = "-") THEN d := -1; ELSE d := 1; END;
posExp := i;
INC (i);
WHILE (s[i] # 0X) DO
exp := exp*10 + d*(ORD (s[i]) - ORD ("0"));
INC (i);
END;
END;
offset := exp MOD 3;
IF (offset # 0) THEN
WHILE (fract < offset) DO (* need more zeros before "E" *)
Strings.Insert ("0", posExp-1, s); INC (fract); INC (posExp);
END;
i := 2;
WHILE (i < offset+2) DO (* move "." offset places to right *)
s[i] := s[i+1]; INC (i);
END;
s[i] := ".";
(* write new exponent *)
exp := exp-offset;
IF (exp < 0) THEN
exp := -exp; s[posExp] := "-";
ELSE
s[posExp] := "+";
END;
s[posExp+1] := CHR (exp DIV 100 + ORD("0"));
s[posExp+2] := CHR (exp DIV 10 MOD 10 + ORD("0"));
s[posExp+3] := CHR (exp MOD 10 + ORD("0"));
s[posExp+4] := 0X;
END;
NormalizeFloat (s);
END FormatForEng;
PROCEDURE FormatForFixed* (VAR s: ARRAY OF CHAR; place: INTEGER);
VAR
i, d, c, fract, point, suffix: INTEGER;
PROCEDURE NotZero (VAR s: ARRAY OF CHAR; pos: INTEGER): BOOLEAN;
BEGIN
WHILE (s[pos] # 0X) DO
IF (s[pos] # "0") & (s[pos] # ".") THEN
RETURN TRUE;
END;
INC (pos);
END;
RETURN FALSE;
END NotZero;
BEGIN
IF (place < 0) THEN
(* locate position of decimal point in string *)
point := 1;
WHILE (s[point] # ".") DO INC (point); END;
(* number of digits before point is `point-1'; position in string
of the first digit that will be converted to zero due to rounding:
`point+place+1'; rightmost digit that may be incremented because
of rounding: `point+place' *)
IF (point+place >= 0) THEN
suffix := point+place+1; IF (s[suffix] = ".") THEN INC (suffix); END;
IF (s[suffix] > "5") OR
(s[suffix] = "5") &
(NotZero (s, suffix+1) OR
(point+place # 0) & ODD (ORD (s[point+place]))) THEN
(* we are rounding up *)
i := point+place;
WHILE (s[i] = "9") DO s[i] := "0"; DEC (i); END;
IF (i = 0) THEN (* looking at sign *)
Strings.Insert ("1", 1, s); INC (point);
ELSE
s[i] := CHR (ORD (s[i])+1); (* increment non-"9" digit by one *)
END;
END;
(* zero everything after the digit at `place' *)
i := point+place+1;
IF (i = 1) THEN (* all zero *)
s[1] := "0"; s[2] := 0X;
ELSE
WHILE (s[i] # ".") DO s[i] := "0"; INC (i); END;
END;
ELSE (* round to zero *)
s[1] := "0"; s[2] := 0X;
END;
s[point] := 0X;
END;
(* correct sign, and add trailing zeros if necessary *)
IF (s[0] = "+") THEN d := 1; ELSE d := 0; END; (* erase "+" sign *)
i := 1; fract := 0; c := 0;
WHILE (s[i] # 0X) DO
s[i-d] := s[i];
fract := fract+c;
IF (s[i] = ".") THEN
c := 1;
END;
INC (i);
END;
WHILE (fract < place) DO
s[i-d] := "0"; INC (fract); INC (i);
END;
s[i-d] := 0X;
END FormatForFixed;
BEGIN
NEW(RS); RS.p:=RSState;
NEW(P); P.p:=PState;
NEW(F); F.p:=FState;
NEW(E); E.p:=EState;
NEW(SE); SE.p:=SEState;
NEW(WE); WE.p:=WEState;
NEW(SR); SR.p:=ScanReal;
END ooc2Real0.

524
src/lib/ooc2/ooc2Strings.Mod Normal file
View file

@ -0,0 +1,524 @@
(* $Id: Strings.Mod,v 1.2 2002/03/11 21:33:22 mva Exp $ *)
MODULE ooc2Strings;
(* Facilities for manipulating strings in character arrays.
Copyright (C) 1996, 1997 Michael van Acken
This module is free software; you can redistribute it and/or
modify it under the terms of the GNU Lesser General Public License
as published by the Free Software Foundation; either version 2 of
the License, or (at your option) any later version.
This module is distributed in the hope that it will be useful, but
WITHOUT ANY WARRANTY; without even the implied warranty of
MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU
Lesser General Public License for more details.
You should have received a copy of the GNU Lesser General Public
License along with OOC. If not, write to the Free Software Foundation,
59 Temple Place - Suite 330, Boston, MA 02111-1307, USA.
*)
(**
Unlike Modula-2, the behaviour of a procedure is undefined, if one of its input
parameters is an unterminated character array. All of the following procedures
expect to get 0X terminated strings, and will return likewise terminated
strings.
All input parameters that represent an array index or a length are
expected to be non-negative. In the descriptions below these
restrictions are stated as pre-conditions of the procedures, but they
aren't checked explicitly. If this module is compiled with run-time
index enabled, checks some illegal input values may be caught. By
default it is installed @emph{without} index checks.
*)
TYPE
CompareResults* = SHORTINT;
(**Result type of @oproc{Compare}. *)
CONST
less* = -1;
(**Result of @oproc{Compare} if the first argument is lexically less
than the second one. *)
equal* = 0;
(**Result of @oproc{Compare} if the first argument is equal to the second
one. *)
greater* = 1;
(**Result of @oproc{Compare} if the first argument is lexically greater
than the second one. *)
PROCEDURE Length* (stringVal: ARRAY OF CHAR): INTEGER;
(**Returns the length of @oparam{stringVal}. This is equal to the number of
characters in @oparam{stringVal} up to and excluding the first @code{0X}. *)
VAR
i: INTEGER;
BEGIN
i := 0;
WHILE (stringVal[i] # 0X) DO
INC (i)
END;
RETURN i
END Length;
PROCEDURE Assign* (source: ARRAY OF CHAR; VAR destination: ARRAY OF CHAR);
(**Copies @oparam{source} to @oparam{destination}. Equivalent to the
predefined procedure @code{COPY}. Unlike @code{COPY}, this procedure can be
assigned to a procedure variable. *)
VAR
i: INTEGER;
BEGIN
i := -1;
REPEAT
INC (i);
destination[i] := source[i]
UNTIL (destination[i] = 0X) OR (i = LEN (destination)-1);
destination[i] := 0X
END Assign;
PROCEDURE Extract* (source: ARRAY OF CHAR; startPos, numberToExtract: INTEGER;
VAR destination: ARRAY OF CHAR);
(**Copies at most @oparam{numberToExtract} characters from @oparam{source} to
@oparam{destination}, starting at position @oparam{startPos} in
@oparam{source}. An empty string value will be extracted if
@oparam{startPos} is greater than or equal to @samp{Length(source)}.
@precond
@oparam{startPos} and @oparam{numberToExtract} are not negative.
@end precond *)
VAR
sourceLength, i: INTEGER;
BEGIN
(* make sure that we get an empty string if `startPos' refers to an array
index beyond `Length (source)' *)
sourceLength := Length (source);
IF (startPos > sourceLength) THEN
startPos := sourceLength
END;
(* make sure that `numberToExtract' doesn't exceed the capacity
of `destination' *)
IF (numberToExtract >= LEN (destination)) THEN
numberToExtract := SHORT (LEN (destination))-1
END;
(* copy up to `numberToExtract' characters to `destination' *)
i := 0;
WHILE (i < numberToExtract) & (source[startPos+i] # 0X) DO
destination[i] := source[startPos+i];
INC (i)
END;
destination[i] := 0X
END Extract;
PROCEDURE Delete* (VAR stringVar: ARRAY OF CHAR;
startPos, numberToDelete: INTEGER);
(**Deletes at most @oparam{numberToDelete} characters from @oparam{stringVar},
starting at position @oparam{startPos}. The string value in
@oparam{stringVar} is not altered if @oparam{startPos} is greater than or
equal to @samp{Length(stringVar)}.
@precond
@oparam{startPos} and @oparam{numberToDelete} are not negative.
@end precond *)
VAR
stringLength, i: INTEGER;
BEGIN
stringLength := Length (stringVar);
IF (startPos+numberToDelete < stringLength) THEN
(* `stringVar' has remaining characters beyond the deleted section;
these have to be moved forward by `numberToDelete' characters *)
FOR i := startPos TO stringLength-numberToDelete DO
stringVar[i] := stringVar[i+numberToDelete]
END
ELSIF (startPos < stringLength) THEN
stringVar[startPos] := 0X
END
END Delete;
PROCEDURE Insert* (source: ARRAY OF CHAR; startPos: INTEGER;
VAR destination: ARRAY OF CHAR);
(**Inserts @oparam{source} into @oparam{destination} at position
@oparam{startPos}. After the call @oparam{destination} contains the string
that is contructed by first splitting @oparam{destination} at the position
@oparam{startPos} and then concatenating the first half, @oparam{source},
and the second half. The string value in @oparam{destination} is not
altered if @oparam{startPos} is greater than @samp{Length(source)}. If
@samp{startPos = Length(source)}, then @oparam{source} is appended to
@oparam{destination}.
@precond
@oparam{startPos} is not negative.
@end precond *)
VAR
sourceLength, destLength, destMax, i: INTEGER;
BEGIN
destLength := Length (destination);
sourceLength := Length (source);
destMax := SHORT (LEN (destination))-1;
IF (startPos+sourceLength < destMax) THEN
(* `source' is inserted inside of `destination' *)
IF (destLength+sourceLength > destMax) THEN
(* `destination' too long, truncate it *)
destLength := destMax-sourceLength;
destination[destLength] := 0X
END;
(* move tail section of `destination' *)
FOR i := destLength TO startPos BY -1 DO
destination[i+sourceLength] := destination[i]
END
ELSIF (startPos <= destLength) THEN
(* `source' replaces `destination' from `startPos' on *)
destination[destMax] := 0X; (* set string terminator *)
sourceLength := destMax-startPos (* truncate `source' *)
ELSE (* startPos > destLength: no change in `destination' *)
sourceLength := 0
END;
(* copy characters from `source' to `destination' *)
FOR i := 0 TO sourceLength-1 DO
destination[startPos+i] := source[i]
END
END Insert;
PROCEDURE Replace* (source: ARRAY OF CHAR; startPos: INTEGER;
VAR destination: ARRAY OF CHAR);
(**Copies @oparam{source} into @oparam{destination}, starting at position
@oparam{startPos}. Copying stops when all of @oparam{source} has been
copied, or when the last character of the string value in
@oparam{destination} has been replaced. The string value in
@oparam{destination} is not altered if @oparam{startPos} is greater than or
equal to @samp{Length(source)}.
@precond
@oparam{startPos} is not negative.
@end precond *)
VAR
destLength, i: INTEGER;
BEGIN
destLength := Length (destination);
IF (startPos < destLength) THEN
(* if `startPos' is inside `destination', then replace characters until
the end of `source' or `destination' is reached *)
i := 0;
WHILE (startPos # destLength) & (source[i] # 0X) DO
destination[startPos] := source[i];
INC (startPos);
INC (i)
END
END
END Replace;
PROCEDURE Append* (source: ARRAY OF CHAR; VAR destination: ARRAY OF CHAR);
(**Appends @oparam{source} to @oparam{destination}. *)
VAR
destLength, i: INTEGER;
BEGIN
destLength := Length (destination);
i := 0;
WHILE (destLength < LEN (destination)-1) & (source[i] # 0X) DO
destination[destLength] := source[i];
INC (destLength);
INC (i)
END;
destination[destLength] := 0X
END Append;
PROCEDURE Concat* (source1, source2: ARRAY OF CHAR;
VAR destination: ARRAY OF CHAR);
(**Concatenates @oparam{source2} onto @oparam{source1} and copies the result
into @oparam{destination}. *)
VAR
i, j: INTEGER;
BEGIN
(* copy `source1' into `destination' *)
i := 0;
WHILE (source1[i] # 0X) & (i < LEN(destination)-1) DO
destination[i] := source1[i];
INC (i)
END;
(* append `source2' to `destination' *)
j := 0;
WHILE (source2[j] # 0X) & (i < LEN (destination)-1) DO
destination[i] := source2[j];
INC (j); INC (i)
END;
destination[i] := 0X
END Concat;
PROCEDURE CanAssignAll* (sourceLength: INTEGER; VAR destination: ARRAY OF CHAR): BOOLEAN;
(**Returns @code{TRUE} if a number of characters, indicated by
@oparam{sourceLength}, will fit into @oparam{destination}; otherwise returns
@code{FALSE}.
@precond
@oparam{sourceLength} is not negative.
@end precond *)
BEGIN
RETURN (sourceLength < LEN (destination))
END CanAssignAll;
PROCEDURE CanExtractAll* (sourceLength, startPos, numberToExtract: INTEGER;
VAR destination: ARRAY OF CHAR): BOOLEAN;
(**Returns @code{TRUE} if there are @oparam{numberToExtract} characters
starting at @oparam{startPos} and within the @oparam{sourceLength} of some
string, and if the capacity of @oparam{destination} is sufficient to hold
@oparam{numberToExtract} characters; otherwise returns @code{FALSE}.
@precond
@oparam{sourceLength}, @oparam{startPos}, and @oparam{numberToExtract} are
not negative.
@end precond *)
BEGIN
RETURN (startPos+numberToExtract <= sourceLength) &
(numberToExtract < LEN (destination))
END CanExtractAll;
PROCEDURE CanDeleteAll* (stringLength, startPos,
numberToDelete: INTEGER): BOOLEAN;
(**Returns @code{TRUE} if there are @oparam{numberToDelete} characters starting
at @oparam{startPos} and within the @oparam{stringLength} of some string;
otherwise returns @code{FALSE}.
@precond
@oparam{stringLength}, @oparam{startPos} and @oparam{numberToDelete} are not
negative.
@end precond *)
BEGIN
RETURN (startPos+numberToDelete <= stringLength)
END CanDeleteAll;
PROCEDURE CanInsertAll* (sourceLength, startPos: INTEGER;
VAR destination: ARRAY OF CHAR): BOOLEAN;
(**Returns @code{TRUE} if there is room for the insertion of
@oparam{sourceLength} characters from some string into @oparam{destination}
starting at @oparam{startPos}; otherwise returns @code{FALSE}.
@precond
@oparam{sourceLength} and @oparam{startPos} are not negative.
@end precond *)
VAR
lenDestination: INTEGER;
BEGIN
lenDestination := Length (destination);
RETURN (startPos <= lenDestination) &
(sourceLength+lenDestination < LEN (destination))
END CanInsertAll;
PROCEDURE CanReplaceAll* (sourceLength, startPos: INTEGER;
VAR destination: ARRAY OF CHAR): BOOLEAN;
(**Returns @code{TRUE} if there is room for the replacement of
@oparam{sourceLength} characters in @oparam{destination} starting at
@oparam{startPos}; otherwise returns @code{FALSE}.
@precond
@oparam{sourceLength} and @oparam{startPos} are not negative.
@end precond *)
BEGIN
RETURN (sourceLength+startPos <= Length(destination))
END CanReplaceAll;
PROCEDURE CanAppendAll* (sourceLength: INTEGER;
VAR destination: ARRAY OF CHAR): BOOLEAN;
(**Returns @code{TRUE} if there is sufficient room in @oparam{destination} to
append a string of length @oparam{sourceLength} to the string in
@oparam{destination}; otherwise returns @code{FALSE}.
@precond
@oparam{sourceLength} is not negative.
@end precond *)
BEGIN
RETURN (Length (destination)+sourceLength < LEN (destination))
END CanAppendAll;
PROCEDURE CanConcatAll* (source1Length, source2Length: INTEGER;
VAR destination: ARRAY OF CHAR): BOOLEAN;
(**Returns @code{TRUE} if there is sufficient room in @oparam{destination} for
a two strings of lengths @oparam{source1Length} and @oparam{source2Length};
otherwise returns @code{FALSE}.
@precond
@oparam{source1Length} and @oparam{source2Length} are not negative.
@end precond *)
BEGIN
RETURN (source1Length+source2Length < LEN (destination))
END CanConcatAll;
PROCEDURE Compare* (stringVal1, stringVal2: ARRAY OF CHAR): CompareResults;
(**Returns @oconst{less}, @oconst{equal}, or @oconst{greater}, according as
@oparam{stringVal1} is lexically less than, equal to, or greater than
@oparam{stringVal2}. Note that Oberon-2 already contains predefined
comparison operators on strings. *)
VAR
i: INTEGER;
BEGIN
i := 0;
WHILE (stringVal1[i] # 0X) & (stringVal1[i] = stringVal2[i]) DO
INC (i)
END;
IF (stringVal1[i] < stringVal2[i]) THEN
RETURN less
ELSIF (stringVal1[i] > stringVal2[i]) THEN
RETURN greater
ELSE
RETURN equal
END
END Compare;
PROCEDURE Equal* (stringVal1, stringVal2: ARRAY OF CHAR): BOOLEAN;
(**Returns @samp{stringVal1 = stringVal2}. Unlike the predefined operator
@samp{=}, this procedure can be assigned to a procedure variable. *)
VAR
i: INTEGER;
BEGIN
i := 0;
WHILE (stringVal1[i] # 0X) & (stringVal1[i] = stringVal2[i]) DO
INC (i)
END;
RETURN (stringVal1[i] = 0X) & (stringVal2[i] = 0X)
END Equal;
PROCEDURE FindNext* (pattern, stringToSearch: ARRAY OF CHAR; startPos: INTEGER;
VAR patternFound: BOOLEAN; VAR posOfPattern: INTEGER);
(**Looks forward for next occurrence of @oparam{pattern} in
@oparam{stringToSearch}, starting the search at position @oparam{startPos}.
If @samp{startPos < Length(stringToSearch)} and @oparam{pattern} is found,
@oparam{patternFound} is returned as @code{TRUE}, and @oparam{posOfPattern}
contains the start position in @oparam{stringToSearch} of @oparam{pattern}.
The position is a value in the range [startPos..Length(stringToSearch)-1].
Otherwise @oparam{patternFound} is returned as @code{FALSE}, and
@oparam{posOfPattern} is unchanged. If @samp{startPos >
Length(stringToSearch)-Length(Pattern)} then @oparam{patternFound} is
returned as @code{FALSE}.
@precond
@oparam{startPos} is not negative.
@end precond *)
VAR
patternPos: INTEGER;
BEGIN
IF (startPos < Length (stringToSearch)) THEN
patternPos := 0;
LOOP
IF (pattern[patternPos] = 0X) THEN
(* reached end of pattern *)
patternFound := TRUE;
posOfPattern := startPos-patternPos;
EXIT
ELSIF (stringToSearch[startPos] = 0X) THEN
(* end of string (but not of pattern) *)
patternFound := FALSE;
EXIT
ELSIF (stringToSearch[startPos] = pattern[patternPos]) THEN
(* characters identic, compare next one *)
INC (startPos);
INC (patternPos)
ELSE
(* difference found: reset indices and restart *)
startPos := startPos-patternPos+1;
patternPos := 0
END
END
ELSE
patternFound := FALSE
END
END FindNext;
PROCEDURE FindPrev* (pattern, stringToSearch: ARRAY OF CHAR; startPos: INTEGER;
VAR patternFound: BOOLEAN; VAR posOfPattern: INTEGER);
(**Looks backward for the previous occurrence of @oparam{pattern} in
@oparam{stringToSearch} and returns the position of the first character of
the @oparam{pattern} if found. The search for the pattern begins at
@oparam{startPos}. If @oparam{pattern} is found, @oparam{patternFound} is
returned as @code{TRUE}, and @oparam{posOfPattern} contains the start
position in @oparam{stringToSearch} of pattern in the range [0..startPos].
Otherwise @oparam{patternFound} is returned as @code{FALSE}, and
@oparam{posOfPattern} is unchanged. The pattern might be found at the given
value of @oparam{startPos}. The search will fail if @oparam{startPos} is
negative. If @samp{startPos > Length(stringToSearch)-Length(pattern)} the
whole string value is searched. *)
VAR
patternPos, stringLength, patternLength: INTEGER;
BEGIN
(* correct `startPos' if it is larger than the possible searching range *)
stringLength := Length (stringToSearch);
patternLength := Length (pattern);
IF (startPos > stringLength-patternLength) THEN
startPos := stringLength-patternLength
END;
IF (startPos >= 0) THEN
patternPos := 0;
LOOP
IF (pattern[patternPos] = 0X) THEN
(* reached end of pattern *)
patternFound := TRUE;
posOfPattern := startPos-patternPos;
EXIT
ELSIF (stringToSearch[startPos] # pattern[patternPos]) THEN
(* characters differ: reset indices and restart *)
IF (startPos > patternPos) THEN
startPos := startPos-patternPos-1;
patternPos := 0
ELSE
(* reached beginning of `stringToSearch' without finding a match *)
patternFound := FALSE;
EXIT
END
ELSE (* characters identic, compare next one *)
INC (startPos);
INC (patternPos)
END
END
ELSE
patternFound := FALSE
END
END FindPrev;
PROCEDURE FindDiff* (stringVal1, stringVal2: ARRAY OF CHAR;
VAR differenceFound: BOOLEAN;
VAR posOfDifference: INTEGER);
(**Compares the string values in @oparam{stringVal1} and @oparam{stringVal2}
for differences. If they are equal, @oparam{differenceFound} is returned as
@code{FALSE}, and @code{TRUE} otherwise. If @oparam{differenceFound} is
@code{TRUE}, @oparam{posOfDifference} is set to the position of the first
difference; otherwise @oparam{posOfDifference} is unchanged. *)
VAR
i: INTEGER;
BEGIN
i := 0;
WHILE (stringVal1[i] # 0X) & (stringVal1[i] = stringVal2[i]) DO
INC (i)
END;
differenceFound := (stringVal1[i] # 0X) OR (stringVal2[i] # 0X);
IF differenceFound THEN
posOfDifference := i
END
END FindDiff;
PROCEDURE Capitalize* (VAR stringVar: ARRAY OF CHAR);
(**Applies the function @code{CAP} to each character of the string value in
@oparam{stringVar}. *)
VAR
i: INTEGER;
BEGIN
i := 0;
WHILE (stringVar[i] # 0X) DO
stringVar[i] := CAP (stringVar[i]);
INC (i)
END
END Capitalize;
END ooc2Strings.

86
src/lib/system/gnuc/Console.Mod Normal file
View file

@ -0,0 +1,86 @@
MODULE Console; (* J. Templ, 29-June-96 *)
(* output to Unix standard output device based Write system call *)
IMPORT SYSTEM;
VAR line: ARRAY 128 OF CHAR;
pos: INTEGER;
PROCEDURE -Write(adr, n: LONGINT)
"write(1/*stdout*/, adr, n)";
PROCEDURE -read(VAR ch: CHAR): LONGINT
"read(0/*stdin*/, ch, 1)";
PROCEDURE Flush*();
BEGIN
Write(SYSTEM.ADR(line), pos); pos := 0;
END Flush;
PROCEDURE Char*(ch: CHAR);
BEGIN
IF pos = LEN(line) THEN Flush() END ;
line[pos] := ch; INC(pos);
IF ch = 0AX THEN Flush() END
END Char;
PROCEDURE String*(s: ARRAY OF CHAR);
VAR i: INTEGER;
BEGIN i := 0;
WHILE s[i] # 0X DO Char(s[i]); INC(i) END
END String;
PROCEDURE Int*(i, n: LONGINT);
VAR s: ARRAY 32 OF CHAR; i1, k: LONGINT;
BEGIN
IF i = SYSTEM.LSH(LONG(LONG(1)), SIZE(LONGINT)*8 - 1) THEN
IF SIZE(LONGINT) = 8 THEN s := "8085774586302733229"; k := 19
ELSE s := "8463847412"; k := 10
END
ELSE
i1 := ABS(i);
s[0] := CHR(i1 MOD 10 + ORD("0")); i1 := i1 DIV 10; k := 1;
WHILE i1 > 0 DO s[k] := CHR(i1 MOD 10 + ORD("0")); i1 := i1 DIV 10; INC(k) END
END ;
IF i < 0 THEN s[k] := "-"; INC(k) END ;
WHILE n > k DO Char(" "); DEC(n) END ;
WHILE k > 0 DO DEC(k); Char(s[k]) END
END Int;
PROCEDURE Ln*;
BEGIN Char(0AX); (* Unix end-of-line *)
END Ln;
PROCEDURE Bool*(b: BOOLEAN);
BEGIN IF b THEN String("TRUE") ELSE String("FALSE") END
END Bool;
PROCEDURE Hex*(i: LONGINT);
VAR k, n: LONGINT;
BEGIN
k := -28;
WHILE k <= 0 DO
n := ASH(i, k) MOD 16;
IF n <= 9 THEN Char(CHR(ORD("0") + n)) ELSE Char(CHR(ORD("A") - 10 + n)) END ;
INC(k, 4)
END
END Hex;
PROCEDURE Read*(VAR ch: CHAR);
VAR n: LONGINT;
BEGIN Flush();
n := read(ch);
IF n # 1 THEN ch := 0X END
END Read;
PROCEDURE ReadLine*(VAR line: ARRAY OF CHAR);
VAR i: LONGINT; ch: CHAR;
BEGIN Flush();
i := 0; Read(ch);
WHILE (i < LEN(line) - 1) & (ch # 0AX) & (ch # 0X) DO line[i] := ch; INC(i); Read(ch) END ;
line[i] := 0X
END ReadLine;
BEGIN pos := 0;
END Console.

520
src/lib/system/gnuc/SYSTEM.Mod Normal file
View file

@ -0,0 +1,520 @@
(*
* voc (jet backend) runtime system, Version 1.1
*
* Copyright (c) Software Templ, 1994, 1995, 1996
*
* Module SYSTEM is subject to change any time without prior notification.
* Software Templ disclaims all warranties with regard to module SYSTEM,
* in particular shall Software Templ not be liable for any damage resulting
* from inappropriate use or modification of module SYSTEM.
*)
MODULE SYSTEM; (* J. Templ, 31.5.95 *)
IMPORT SYSTEM; (*must not import other modules*)
CONST
ModNameLen = 20;
CmdNameLen = 24;
SZL = SIZE(LONGINT);
Unit = 4*SZL; (* smallest possible heap block *)
nofLists = 9; (* number of free_lists *)
heapSize0 = 8000*Unit; (* startup heap size *)
(* all blocks look the same:
free blocks describe themselves: size = Unit
tag = &tag++
->blksize
sentinel = -SZL
next
*)
(* heap chunks *)
nextChnkOff = 0; (* next heap chunk, sorted ascendingly! *)
endOff = SZL; (* end of heap chunk *)
blkOff = 3*SZL; (* first block in a chunk *)
(* heap blocks *)
tagOff = 0; (* block starts with tag *)
sizeOff = SZL; (* block size in free block relative to block start *)
sntlOff = 2*SZL; (* pointer offset table sentinel in free block relative to block start *)
nextOff = 3*SZL; (* next pointer in free block relative to block start *)
NoPtrSntl = LONG(LONG(-SZL));
TYPE
ModuleName = ARRAY ModNameLen OF CHAR;
CmdName = ARRAY CmdNameLen OF CHAR;
Module = POINTER TO ModuleDesc;
Cmd = POINTER TO CmdDesc;
EnumProc = PROCEDURE(P: PROCEDURE(p: SYSTEM.PTR));
ModuleDesc = RECORD
next: Module;
name: ModuleName;
refcnt: LONGINT;
cmds: Cmd;
types: LONGINT;
enumPtrs: EnumProc;
reserved1, reserved2: LONGINT
END ;
Command = PROCEDURE;
CmdDesc = RECORD
next: Cmd;
name: CmdName;
cmd: Command
END ;
Finalizer = PROCEDURE(obj: SYSTEM.PTR);
FinNode = POINTER TO FinDesc;
FinDesc = RECORD
next: FinNode;
obj: LONGINT; (* weak pointer *)
marked: BOOLEAN;
finalize: Finalizer;
END ;
VAR
(* the list of loaded (=initialization started) modules *)
modules*: SYSTEM.PTR;
freeList: ARRAY nofLists + 1 OF LONGINT; (* dummy, 16, 32, 48, 64, 80, 96, 112, 128, sentinel *)
bigBlocks, allocated*: LONGINT;
firstTry: BOOLEAN;
(* extensible heap *)
heap, (* the sorted list of heap chunks *)
heapend, (* max possible pointer value (used for stack collection) *)
heapsize*: LONGINT; (* the sum of all heap chunk sizes *)
(* finalization candidates *)
fin: FinNode;
(* garbage collector locking *)
gclock*: SHORTINT;
PROCEDURE -malloc(size: LONGINT): LONGINT "(LONGINT)malloc(size)";
PROCEDURE -Lock() "Lock";
PROCEDURE -Unlock() "Unlock";
PROCEDURE -Mainfrm(): LONGINT "SYSTEM_mainfrm";
(*
PROCEDURE TAS*(VAR flag:BOOLEAN): BOOLEAN; (* added for compatibility with ulmSYSTEM module; noch *)
VAR oldflag : BOOLEAN;
BEGIN
oldflag := flag;
flag := TRUE;
RETURN oldflag;
END TAS;
*)
PROCEDURE REGMOD*(VAR name: ModuleName; enumPtrs: EnumProc): SYSTEM.PTR;
VAR m: Module;
BEGIN
IF name = "SYSTEM" THEN (* cannot use NEW *)
SYSTEM.NEW(m, SIZE(ModuleDesc)); m.cmds := NIL
ELSE NEW(m)
END ;
COPY(name, m.name); m.refcnt := 0; m.enumPtrs := enumPtrs; m.next := SYSTEM.VAL(Module, modules);
modules := m;
RETURN m
END REGMOD;
PROCEDURE REGCMD*(m: Module; VAR name: CmdName; cmd: Command);
VAR c: Cmd;
BEGIN NEW(c);
COPY(name, c.name); c.cmd := cmd; c.next := m.cmds; m.cmds := c
END REGCMD;
PROCEDURE REGTYP*(m: Module; typ: LONGINT);
BEGIN SYSTEM.PUT(typ, m.types); m.types := typ
END REGTYP;
PROCEDURE INCREF*(m: Module);
BEGIN INC(m.refcnt)
END INCREF;
PROCEDURE NewChunk(blksz: LONGINT): LONGINT;
VAR chnk: LONGINT;
BEGIN
chnk := malloc(blksz + blkOff);
IF chnk # 0 THEN
SYSTEM.PUT(chnk + endOff, chnk + (blkOff + blksz));
SYSTEM.PUT(chnk + blkOff, chnk + (blkOff + sizeOff));
SYSTEM.PUT(chnk + (blkOff + sizeOff), blksz);
SYSTEM.PUT(chnk + (blkOff + sntlOff), NoPtrSntl);
SYSTEM.PUT(chnk + (blkOff + nextOff), bigBlocks);
bigBlocks := chnk + blkOff;
INC(heapsize, blksz)
END ;
RETURN chnk
END NewChunk;
PROCEDURE ExtendHeap(blksz: LONGINT);
VAR size, chnk, j, next: LONGINT;
BEGIN
IF blksz > 10000*Unit THEN size := blksz
ELSE size := 10000*Unit (* additional heuristics *)
END ;
chnk := NewChunk(size);
IF chnk # 0 THEN
(*sorted insertion*)
IF chnk < heap THEN
SYSTEM.PUT(chnk, heap); heap := chnk
ELSE
j := heap; SYSTEM.GET(j, next);
WHILE (next # 0) & (chnk > next) DO j := next; SYSTEM.GET(j, next) END ;
SYSTEM.PUT(chnk, next); SYSTEM.PUT(j, chnk)
END ;
IF next = 0 THEN SYSTEM.GET(chnk + endOff, heapend) END
END
END ExtendHeap;
PROCEDURE ^GC*(markStack: BOOLEAN);
PROCEDURE NEWREC*(tag: LONGINT): SYSTEM.PTR;
VAR i, i0, di, blksz, restsize, t, adr, end, next, prev: LONGINT; new: SYSTEM.PTR;
BEGIN
Lock();
SYSTEM.GET(tag, blksz);
ASSERT(blksz MOD Unit = 0);
i0 := blksz DIV Unit; i := i0;
IF i < nofLists THEN adr := freeList[i];
WHILE adr = 0 DO INC(i); adr := freeList[i] END
END ;
IF i < nofLists THEN (* unlink *)
SYSTEM.GET(adr + nextOff, next);
freeList[i] := next;
IF i # i0 THEN (* split *)
di := i - i0; restsize := di * Unit; end := adr + restsize;
SYSTEM.PUT(end + sizeOff, blksz);
SYSTEM.PUT(end + sntlOff, NoPtrSntl);
SYSTEM.PUT(end, end + sizeOff);
SYSTEM.PUT(adr + sizeOff, restsize);
SYSTEM.PUT(adr + nextOff, freeList[di]);
freeList[di] := adr;
INC(adr, restsize)
END
ELSE
adr := bigBlocks; prev := 0;
LOOP
IF adr = 0 THEN
IF firstTry THEN
GC(TRUE); INC(blksz, Unit);
IF (heapsize - allocated - blksz) * 4 < heapsize THEN
(* heap is still almost full; expand to avoid thrashing *)
ExtendHeap((allocated + blksz) DIV (3*Unit) * (4*Unit) - heapsize)
END ;
firstTry := FALSE; new := NEWREC(tag); firstTry := TRUE;
IF new = NIL THEN
(* depending on the fragmentation, the heap may not have been extended by
the anti-thrashing heuristics above *)
ExtendHeap((allocated + blksz) DIV (3*Unit) * (4*Unit) - heapsize);
new := NEWREC(tag); (* will find a free block if heap has been expanded properly *)
END ;
Unlock(); RETURN new
ELSE
Unlock(); RETURN NIL
END
END ;
SYSTEM.GET(adr+sizeOff, t);
IF t >= blksz THEN EXIT END ;
prev := adr; SYSTEM.GET(adr + nextOff, adr)
END ;
restsize := t - blksz; end := adr + restsize;
SYSTEM.PUT(end + sizeOff, blksz);
SYSTEM.PUT(end + sntlOff, NoPtrSntl);
SYSTEM.PUT(end, end + sizeOff);
IF restsize > nofLists * Unit THEN (*resize*)
SYSTEM.PUT(adr + sizeOff, restsize)
ELSE (*unlink*)
SYSTEM.GET(adr + nextOff, next);
IF prev = 0 THEN bigBlocks := next
ELSE SYSTEM.PUT(prev + nextOff, next);
END ;
IF restsize > 0 THEN (*move*)
di := restsize DIV Unit;
SYSTEM.PUT(adr + sizeOff, restsize);
SYSTEM.PUT(adr + nextOff, freeList[di]);
freeList[di] := adr
END
END ;
INC(adr, restsize)
END ;
i := adr + 4*SZL; end := adr + blksz;
WHILE i < end DO (*deliberately unrolled*)
SYSTEM.PUT(i, LONG(LONG(0)));
SYSTEM.PUT(i + SZL, LONG(LONG(0)));
SYSTEM.PUT(i + 2*SZL, LONG(LONG(0)));
SYSTEM.PUT(i + 3*SZL, LONG(LONG(0)));
INC(i, 4*SZL)
END ;
SYSTEM.PUT(adr + nextOff, LONG(LONG(0)));
SYSTEM.PUT(adr, tag);
SYSTEM.PUT(adr + sizeOff, LONG(LONG(0)));
SYSTEM.PUT(adr + sntlOff, LONG(LONG(0)));
INC(allocated, blksz);
Unlock();
RETURN SYSTEM.VAL(SYSTEM.PTR, adr + SZL)
END NEWREC;
PROCEDURE NEWBLK*(size: LONGINT): SYSTEM.PTR;
VAR blksz, tag: LONGINT; new: SYSTEM.PTR;
BEGIN
Lock();
blksz := (size + (4*SZL + Unit - 1)) DIV Unit * Unit; (*size + tag + meta + blksz + sntnl + UnitAlignment*)
new := NEWREC(SYSTEM.ADR(blksz));
tag := SYSTEM.VAL(LONGINT, new) + blksz - 3*SZL;
SYSTEM.PUT(tag - SZL, LONG(LONG(0))); (*reserved for meta info*)
SYSTEM.PUT(tag, blksz);
SYSTEM.PUT(tag + SZL, NoPtrSntl);
SYSTEM.PUT(SYSTEM.VAL(LONGINT, new) - SZL, tag);
Unlock();
RETURN new
END NEWBLK;
PROCEDURE Mark(q: LONGINT);
VAR p, tag, fld, n, offset, tagbits: LONGINT;
BEGIN
IF q # 0 THEN SYSTEM.GET(q - SZL, tagbits);
IF ~ODD(tagbits) THEN
SYSTEM.PUT(q - SZL, tagbits + 1);
p := 0; tag := tagbits + SZL;
LOOP
SYSTEM.GET(tag, offset);
IF offset < 0 THEN
SYSTEM.PUT(q - SZL, tag + offset + 1);
IF p = 0 THEN EXIT END ;
n := q; q := p;
SYSTEM.GET(q - SZL, tag); DEC(tag, 1);
SYSTEM.GET(tag, offset); fld := q + offset;
SYSTEM.GET(fld, p); SYSTEM.PUT(fld, n)
ELSE
fld := q + offset;
SYSTEM.GET(fld, n);
IF n # 0 THEN
SYSTEM.GET(n - SZL, tagbits);
IF ~ODD(tagbits) THEN
SYSTEM.PUT(n - SZL, tagbits + 1);
SYSTEM.PUT(q - SZL, tag + 1);
SYSTEM.PUT(fld, p); p := q; q := n;
tag := tagbits
END
END
END ;
INC(tag, SZL)
END
END
END
END Mark;
PROCEDURE MarkP(p: SYSTEM.PTR); (* for compatibility with EnumPtrs in ANSI mode *)
BEGIN
Mark(SYSTEM.VAL(LONGINT, p))
END MarkP;
PROCEDURE Scan;
VAR chnk, adr, end, start, tag, i, size, freesize: LONGINT;
BEGIN bigBlocks := 0; i := 1;
WHILE i < nofLists DO freeList[i] := 0; INC(i) END ;
freesize := 0; allocated := 0; chnk := heap;
WHILE chnk # 0 DO
adr := chnk + blkOff; SYSTEM.GET(chnk + endOff, end);
WHILE adr < end DO
SYSTEM.GET(adr, tag);
IF ODD(tag) THEN (*marked*)
IF freesize > 0 THEN
start := adr - freesize;
SYSTEM.PUT(start, start+SZL);
SYSTEM.PUT(start+sizeOff, freesize);
SYSTEM.PUT(start+sntlOff, NoPtrSntl);
i := freesize DIV Unit; freesize := 0;
IF i < nofLists THEN SYSTEM.PUT(start + nextOff, freeList[i]); freeList[i] := start
ELSE SYSTEM.PUT(start + nextOff, bigBlocks); bigBlocks := start
END
END ;
DEC(tag, 1);
SYSTEM.PUT(adr, tag);
SYSTEM.GET(tag, size);
INC(allocated, size);
INC(adr, size)
ELSE (*unmarked*)
SYSTEM.GET(tag, size);
INC(freesize, size);
INC(adr, size)
END
END ;
IF freesize > 0 THEN (*collect last block*)
start := adr - freesize;
SYSTEM.PUT(start, start+SZL);
SYSTEM.PUT(start+sizeOff, freesize);
SYSTEM.PUT(start+sntlOff, NoPtrSntl);
i := freesize DIV Unit; freesize := 0;
IF i < nofLists THEN SYSTEM.PUT(start + nextOff, freeList[i]); freeList[i] := start
ELSE SYSTEM.PUT(start + nextOff, bigBlocks); bigBlocks := start
END
END ;
SYSTEM.GET(chnk, chnk)
END
END Scan;
PROCEDURE Sift (l, r: LONGINT; VAR a: ARRAY OF LONGINT);
VAR i, j, x: LONGINT;
BEGIN j := l; x := a[j];
LOOP i := j; j := 2*j + 1;
IF (j < r) & (a[j] < a[j+1]) THEN INC(j) END;
IF (j > r) OR (a[j] <= x) THEN EXIT END;
a[i] := a[j]
END;
a[i] := x
END Sift;
PROCEDURE HeapSort (n: LONGINT; VAR a: ARRAY OF LONGINT);
VAR l, r, x: LONGINT;
BEGIN l := n DIV 2; r := n - 1;
WHILE l > 0 DO DEC(l); Sift(l, r, a) END;
WHILE r > 0 DO x := a[0]; a[0] := a[r]; a[r] := x; DEC(r); Sift(l, r, a) END
END HeapSort;
PROCEDURE MarkCandidates(n: LONGINT; VAR cand: ARRAY OF LONGINT);
VAR chnk, adr, tag, next, lim, lim1, i, ptr, size: LONGINT;
BEGIN
chnk := heap; i := 0; lim := cand[n-1];
WHILE (chnk # 0 ) & (chnk < lim) DO
adr := chnk + blkOff;
SYSTEM.GET(chnk + endOff, lim1);
IF lim < lim1 THEN lim1 := lim END ;
WHILE adr < lim1 DO
SYSTEM.GET(adr, tag);
IF ODD(tag) THEN (*already marked*)
SYSTEM.GET(tag-1, size); INC(adr, size)
ELSE
SYSTEM.GET(tag, size);
ptr := adr + SZL;
WHILE cand[i] < ptr DO INC(i) END ;
IF i = n THEN RETURN END ;
next := adr + size;
IF cand[i] < next THEN Mark(ptr) END ;
adr := next
END
END ;
SYSTEM.GET(chnk, chnk)
END
END MarkCandidates;
PROCEDURE CheckFin;
VAR n: FinNode; tag: LONGINT;
BEGIN n := fin;
WHILE n # NIL DO
SYSTEM.GET(n.obj - SZL, tag);
IF ~ODD(tag) THEN n.marked := FALSE; Mark(n.obj)
ELSE n.marked := TRUE
END ;
n := n.next
END
END CheckFin;
PROCEDURE Finalize;
VAR n, prev: FinNode;
BEGIN n := fin; prev := NIL;
WHILE n # NIL DO
IF ~n.marked THEN
IF n = fin THEN fin := fin.next ELSE prev.next := n.next END ;
n.finalize(SYSTEM.VAL(SYSTEM.PTR, n.obj));
(* new nodes may have been pushed in n.finalize, therefore: *)
IF prev = NIL THEN n := fin ELSE n := n.next END
ELSE prev := n; n := n.next
END
END
END Finalize;
PROCEDURE FINALL*;
VAR n: FinNode;
BEGIN
WHILE fin # NIL DO
n := fin; fin := fin.next;
n.finalize(SYSTEM.VAL(SYSTEM.PTR, n.obj))
END
END FINALL;
PROCEDURE MarkStack(n: LONGINT; VAR cand: ARRAY OF LONGINT);
VAR
frame: SYSTEM.PTR;
inc, nofcand: LONGINT;
sp, p, stack0, ptr: LONGINT;
align: RECORD ch: CHAR; p: SYSTEM.PTR END ;
BEGIN
IF n > 0 THEN MarkStack(n-1, cand); (* flush register windows by means of recursive calls *)
IF n > 100 THEN RETURN END (* prevent tail recursion optimization *)
END ;
IF n = 0 THEN
nofcand := 0; sp := SYSTEM.ADR(frame);
stack0 := Mainfrm();
(* check for minimum alignment of pointers *)
inc := SYSTEM.ADR(align.p) - SYSTEM.ADR(align);
IF sp > stack0 THEN inc := -inc END ;
WHILE sp # stack0 DO
SYSTEM.GET(sp, p);
IF (p > heap) & (p < heapend) THEN
IF nofcand = LEN(cand) THEN HeapSort(nofcand, cand); MarkCandidates(nofcand, cand); nofcand := 0 END ;
cand[nofcand] := p; INC(nofcand)
END ;
INC(sp, inc)
END ;
IF nofcand > 0 THEN HeapSort(nofcand, cand); MarkCandidates(nofcand, cand) END
END
END MarkStack;
PROCEDURE GC*(markStack: BOOLEAN);
VAR
m: Module;
i0, i1, i2, i3, i4, i5, i6, i7, i8, i9, i10, i11, i12, i13, i14, i15, i16, i17, i18, i19, i20, i21, i22, i23: LONGINT;
cand: ARRAY 10000 OF LONGINT;
BEGIN
IF (gclock = 0) OR (gclock = 1) & ~markStack THEN
Lock();
m := SYSTEM.VAL(Module, modules);
WHILE m # NIL DO
IF m.enumPtrs # NIL THEN m.enumPtrs(MarkP) END ;
m := m^.next
END ;
IF markStack THEN
(* generate register pressure to force callee saved registers to memory;
may be simplified by inlining OS calls or processor specific instructions
*)
i0 := -100; i1 := -101; i2 := -102; i3 := -103; i4 := -104; i5 := -105; i6 := -106; i7 := -107;
i8 := 1; i9 := 2; i10 := 3; i11 := 4; i12 := 5; i13 := 6; i14 := 7; i15 := 8;
i16 := 9; i17 := 10; i18 := 11; i19 := 12; i20 := 13; i21 := 14; i22 := 15; i23 := 16;
LOOP INC(i0, 1); INC(i1, 2); INC(i2, 3); INC(i3, 4); INC(i4, 5); INC(i5, 6); INC(i6, 7); INC(i7, 8);
INC(i8, 9); INC(i9, 10); INC(i10, 11); INC(i11, 12); INC(i12, 13); INC(i13, 14); INC(i14, 15); INC(i15, 16);
INC(i16, 17); INC(i17, 18); INC(i18, 19); INC(i19, 20); INC(i20, 21); INC(i21, 22); INC(i22, 23); INC(i23, 24);
IF (i0 = -99) & (i15 = 24) THEN MarkStack(32, cand); EXIT END
END ;
IF i0 + i1 + i2 + i3 + i4 + i5 + i6 + i7 + i8 + i9 + i10 + i11 + i12 + i13 + i14 + i15
+ i16 + i17 + i18 + i19 + i20 + i21 + i22 + i23 > 10000 THEN RETURN (* use all variables *)
END ;
END;
CheckFin;
Scan;
Finalize;
Unlock()
END
END GC;
PROCEDURE REGFIN*(obj: SYSTEM.PTR; finalize: Finalizer);
VAR f: FinNode;
BEGIN NEW(f);
f.obj := SYSTEM.VAL(LONGINT, obj); f.finalize := finalize; f.marked := TRUE; f.next := fin; fin := f
END REGFIN;
PROCEDURE InitHeap; (* initialized before body to enable NEW, SYSTEM.NEW *)
BEGIN
heap := NewChunk(heapSize0);
SYSTEM.GET(heap + endOff, heapend);
SYSTEM.PUT(heap, LONG(LONG(0)));
allocated := 0; firstTry := TRUE; freeList[nofLists] := 1; gclock := 0
END InitHeap;
END SYSTEM.

52
src/lib/system/gnuc/armv6j/Args.Mod Normal file
View file

@ -0,0 +1,52 @@
MODULE Args; (* jt, 8.12.94 *)
(* command line argument handling for ofront *)
IMPORT SYSTEM;
TYPE
ArgPtr = POINTER TO ARRAY 1024 OF CHAR;
ArgVec = POINTER TO ARRAY 1024 OF ArgPtr;
VAR argc-, argv-: LONGINT;
PROCEDURE -Argc(): INTEGER "SYSTEM_argc";
PROCEDURE -Argv(): LONGINT "(long)SYSTEM_argv";
PROCEDURE -getenv(var: ARRAY OF CHAR): ArgPtr
"(Args_ArgPtr)getenv(var)";
PROCEDURE Get*(n: INTEGER; VAR val: ARRAY OF CHAR);
VAR av: ArgVec;
BEGIN
IF n < argc THEN av := SYSTEM.VAL(ArgVec, argv); COPY(av[n]^, val) END
END Get;
PROCEDURE GetInt*(n: INTEGER; VAR val: LONGINT);
VAR s: ARRAY 64 OF CHAR; k, d, i: LONGINT;
BEGIN
s := ""; Get(n, s); i := 0;
IF s[0] = "-" THEN i := 1 END ;
k := 0; d := ORD(s[i]) - ORD("0");
WHILE (d >= 0 ) & (d <= 9) DO k := k*10 + d; INC(i); d := ORD(s[i]) - ORD("0") END ;
IF s[0] = "-" THEN d := -d; DEC(i) END ;
IF i > 0 THEN val := k END
END GetInt;
PROCEDURE Pos*(s: ARRAY OF CHAR): INTEGER;
VAR i: INTEGER; arg: ARRAY 256 OF CHAR;
BEGIN
i := 0; Get(i, arg);
WHILE (i < argc) & (s # arg) DO INC(i); Get(i, arg) END ;
RETURN i
END Pos;
PROCEDURE GetEnv*(var: ARRAY OF CHAR; VAR val: ARRAY OF CHAR);
VAR p: ArgPtr;
BEGIN
p := getenv(var);
IF p # NIL THEN COPY(p^, val) END
END GetEnv;
BEGIN argc := Argc(); argv := Argv()
END Args.

205
src/lib/system/gnuc/armv6j/SYSTEM.c0 Normal file
View file

@ -0,0 +1,205 @@
/*
* The body prefix file of the Ofront runtime system, Version 1.0
*
* Copyright (c) Software Templ, 1994, 1995
*
* Module SYSTEM is subject to change any time without prior notification.
* Software Templ disclaims all warranties with regard to module SYSTEM,
* in particular shall Software Templ not be liable for any damage resulting
* from inappropriate use or modification of module SYSTEM.
*
* Version 1.1 jt, 24.11.95 fixes for correct pointer arithmetic on Cray computers
* jt 31.1.2007 ANSI prototypes for malloc and exit in order to avoid cc warnings
*
*/
#include "SYSTEM.h"
#ifdef __STDC__
#include "stdarg.h"
#else
#include "varargs.h"
#endif
extern void *malloc(long size);
extern void exit(int status);
void (*SYSTEM_Halt)();
LONGINT SYSTEM_halt; /* x in HALT(x) */
LONGINT SYSTEM_assert; /* x in ASSERT(cond, x) */
LONGINT SYSTEM_argc;
LONGINT SYSTEM_argv;
LONGINT SYSTEM_lock;
BOOLEAN SYSTEM_interrupted;
static LONGINT SYSTEM_mainfrm; /* adr of main proc stack frame, used for stack collection */
#define Lock SYSTEM_lock++
#define Unlock SYSTEM_lock--; if (SYSTEM_interrupted && (SYSTEM_lock == 0)) __HALT(-9)
static void SYSTEM_InitHeap();
void *SYSTEM__init();
void SYSTEM_INIT(argc, argvadr)
int argc; long argvadr;
{
SYSTEM_mainfrm = argvadr;
SYSTEM_argc = argc;
SYSTEM_argv = *(long*)argvadr;
SYSTEM_InitHeap();
SYSTEM_halt = -128;
SYSTEM__init();
}
void SYSTEM_FINI()
{
SYSTEM_FINALL();
}
long SYSTEM_XCHK(i, ub) long i, ub; {return __X(i, ub);}
long SYSTEM_RCHK(i, ub) long i, ub; {return __R(i, ub);}
long SYSTEM_ASH(i, n) long i, n; {return __ASH(i, n);}
long SYSTEM_ABS(i) long i; {return __ABS(i);}
double SYSTEM_ABSD(i) double i; {return __ABS(i);}
void SYSTEM_INHERIT(t, t0)
long *t, *t0;
{
t -= __TPROC0OFF;
t0 -= __TPROC0OFF;
while (*t0 != __EOM) {*t = *t0; t--; t0--;}
}
void SYSTEM_ENUMP(adr, n, P)
long *adr;
long n;
void (*P)();
{
while (n > 0) {P(*adr); adr++; n--;}
}
void SYSTEM_ENUMR(adr, typ, size, n, P)
char *adr;
long *typ, size, n;
void (*P)();
{
long *t, off;
typ++;
while (n > 0) {
t = typ;
off = *t;
while (off >= 0) {P(*(long*)(adr+off)); t++; off = *t;}
adr += size; n--;
}
}
long SYSTEM_DIV(x, y)
unsigned long x, y;
{ if ((long) x >= 0) return (x / y);
else return -((y - 1 - x) / y);
}
long SYSTEM_MOD(x, y)
unsigned long x, y;
{ unsigned long m;
if ((long) x >= 0) return (x % y);
else { m = (-x) % y;
if (m != 0) return (y - m); else return 0;
}
}
long SYSTEM_ENTIER(x)
double x;
{
long y;
if (x >= 0)
return (long)x;
else {
y = (long)x;
if (y <= x) return y; else return y - 1;
}
}
void SYSTEM_HALT(n)
int n;
{
SYSTEM_halt = n;
if (SYSTEM_Halt!=0) SYSTEM_Halt(n);
exit(n);
}
#ifdef __STDC__
SYSTEM_PTR SYSTEM_NEWARR(long *typ, long elemsz, int elemalgn, int nofdim, int nofdyn, ...)
#else
SYSTEM_PTR SYSTEM_NEWARR(typ, elemsz, elemalgn, nofdim, nofdyn, va_alist)
long *typ, elemsz;
int elemalgn, nofdim, nofdyn;
va_dcl
#endif
{
long nofelems, size, dataoff, n, nptr, *x, *p, nofptrs, i, *ptab, off;
va_list ap;
#ifdef __STDC__
va_start(ap, nofdyn);
#else
va_start(ap);
#endif
nofelems = 1;
while (nofdim > 0) {
nofelems = nofelems * va_arg(ap, long); nofdim--;
if (nofelems <= 0) __HALT(-20);
}
va_end(ap);
dataoff = nofdyn * sizeof(long);
if (elemalgn > sizeof(long)) {
n = dataoff % elemalgn;
if (n != 0) dataoff += elemalgn - n;
}
size = dataoff + nofelems * elemsz;
Lock;
if (typ == NIL) {
/* element typ does not contain pointers */
x = SYSTEM_NEWBLK(size);
}
else if (typ == POINTER__typ) {
/* element type is a pointer */
x = SYSTEM_NEWBLK(size + nofelems * sizeof(long));
p = (long*)x[-1];
p[-nofelems] = *p; /* build new type desc in situ: 1. copy block size; 2. setup ptr tab; 3. set sentinel; 4. patch tag */
p -= nofelems - 1; n = 1; /* n =1 for skipping the size field */
while (n <= nofelems) {*p = n*sizeof(long); p++; n++;}
*p = - (nofelems + 1) * sizeof(long); /* sentinel */
x[-1] -= nofelems * sizeof(long);
}
else {
/* element type is a record that contains pointers */
ptab = typ + 1; nofptrs = 0;
while (ptab[nofptrs] >= 0) {nofptrs++;} /* number of pointers per element */
nptr = nofelems * nofptrs; /* total number of pointers */
x = SYSTEM_NEWBLK(size + nptr * sizeof(long));
p = (long*)x[- 1];
p[-nptr] = *p; /* build new type desc in situ; 1. copy block size; 2. setup ptr tab; 3. set sentinel; 4. patch tag */
p -= nptr - 1; n = 0; off = dataoff;
while (n < nofelems) {i = 0;
while (i < nofptrs) {*p = off + ptab[i]; p++; i++;}
off += elemsz; n++;
}
*p = - (nptr + 1) * sizeof(long); /* sentinel */
x[-1] -= nptr * sizeof(long);
}
if (nofdyn != 0) {
/* setup len vector for index checks */
#ifdef __STDC__
va_start(ap, nofdyn);
#else
va_start(ap);
#endif
p = x;
while (nofdyn > 0) {*p = va_arg(ap, long); p++, nofdyn--;}
va_end(ap);
}
Unlock;
return x;
}
/* ----------- end of SYSTEM.co ------------- */

215
src/lib/system/gnuc/armv6j/SYSTEM.h Normal file
View file

@ -0,0 +1,215 @@
#ifndef SYSTEM__h
#define SYSTEM__h
/*
the Ofront runtime system interface and macros library
copyright (c) Josef Templ, 1995, 1996
gcc for Linux version (same as SPARC/Solaris2)
uses double # as concatenation operator
*/
#include <alloca.h>
//extern void *memcpy(void *dest, const void *src, long n);
extern void *memcpy(void *dest, const void *src, size_t n);
extern void *malloc(long size);
extern void exit(int status);
#define export
#define import extern
/* constants */
#define __MAXEXT 16
#define NIL 0L
#define POINTER__typ (long*)1L /* not NIL and not a valid type */
/* basic types */
typedef char BOOLEAN;
typedef unsigned char CHAR;
typedef signed char SHORTINT;
typedef short int INTEGER;
typedef long LONGINT;
typedef float REAL;
typedef double LONGREAL;
typedef unsigned long SET;
typedef void *SYSTEM_PTR;
typedef unsigned char SYSTEM_BYTE;
/* runtime system routines */
extern long SYSTEM_DIV();
extern long SYSTEM_MOD();
extern long SYSTEM_ENTIER();
extern long SYSTEM_ASH();
extern long SYSTEM_ABS();
extern long SYSTEM_XCHK();
extern long SYSTEM_RCHK();
extern double SYSTEM_ABSD();
extern SYSTEM_PTR SYSTEM_NEWREC();
extern SYSTEM_PTR SYSTEM_NEWBLK();
#ifdef __STDC__
extern SYSTEM_PTR SYSTEM_NEWARR(long*, long, int, int, int, ...);
#else
extern SYSTEM_PTR SYSTEM_NEWARR();
#endif
extern SYSTEM_PTR SYSTEM_REGMOD();
extern void SYSTEM_INCREF();
extern void SYSTEM_REGCMD();
extern void SYSTEM_REGTYP();
extern void SYSTEM_REGFIN();
extern void SYSTEM_FINALL();
extern void SYSTEM_INIT();
extern void SYSTEM_FINI();
extern void SYSTEM_HALT();
extern void SYSTEM_INHERIT();
extern void SYSTEM_ENUMP();
extern void SYSTEM_ENUMR();
/* module registry */
#define __DEFMOD static void *m; if(m!=0)return m
#define __REGMOD(name, enum) if(m==0)m=SYSTEM_REGMOD((CHAR*)name,enum); else return m
#define __ENDMOD return m
#define __INIT(argc, argv) static void *m; SYSTEM_INIT(argc, (long)&argv);
#define __REGMAIN(name, enum) m=SYSTEM_REGMOD(name,enum)
#define __FINI SYSTEM_FINI(); return 0
#define __IMPORT(name) SYSTEM_INCREF(name##__init())
#define __REGCMD(name, cmd) SYSTEM_REGCMD(m, name, cmd)
/* SYSTEM ops */
#define __SYSNEW(p, len) p=SYSTEM_NEWBLK((long)(len))
#define __VAL(t, x) (*(t*)&(x))
#define __GET(a, x, t) x= *(t*)(a)
#define __PUT(a, x, t) *(t*)(a)=x
#define __LSHL(x, n, t) ((t)((unsigned)(x)<<(n)))
#define __LSHR(x, n, t) ((t)((unsigned)(x)>>(n)))
#define __LSH(x, n, t) ((n)>=0? __LSHL(x, n, t): __LSHR(x, -(n), t))
#define __ROTL(x, n, t) ((t)((unsigned)(x)<<(n)|(unsigned)(x)>>(8*sizeof(t)-(n))))
#define __ROTR(x, n, t) ((t)((unsigned)(x)>>(n)|(unsigned)(x)<<(8*sizeof(t)-(n))))
#define __ROT(x, n, t) ((n)>=0? __ROTL(x, n, t): __ROTR(x, -(n), t))
#define __BIT(x, n) (*(unsigned long*)(x)>>(n)&1)
#define __MOVE(s, d, n) memcpy((char*)(d),(char*)(s),n)
/* std procs and operator mappings */
#define __SHORT(x, y) ((int)((unsigned long)(x)+(y)<(y)+(y)?(x):(__HALT(-8),0)))
#define __SHORTF(x, y) ((int)(__RF((x)+(y),(y)+(y))-(y)))
#define __CHR(x) ((CHAR)__R(x, 256))
#define __CHRF(x) ((CHAR)__RF(x, 256))
#define __DIV(x, y) ((x)>=0?(x)/(y):-(((y)-1-(x))/(y)))
#define __DIVF(x, y) SYSTEM_DIV((long)(x),(long)(y))
#define __MOD(x, y) ((x)>=0?(x)%(y):__MODF(x,y))
#define __MODF(x, y) SYSTEM_MOD((long)(x),(long)(y))
#define __NEW(p, t) p=SYSTEM_NEWREC((long)t##__typ)
#define __NEWARR SYSTEM_NEWARR
#define __HALT(x) SYSTEM_HALT(x)
#define __ASSERT(cond, x) if (!(cond)) {SYSTEM_assert = x; SYSTEM_HALT(-1);}
#define __ENTIER(x) SYSTEM_ENTIER(x)
#define __ABS(x) (((x)<0)?-(x):(x))
#define __ABSF(x) SYSTEM_ABS((long)(x))
#define __ABSFD(x) SYSTEM_ABSD((double)(x))
#define __CAP(ch) ((CHAR)((ch)&0x5f))
#define __ODD(x) ((x)&1)
#define __IN(x, s) (((s)>>(x))&1)
#define __SETOF(x) ((SET)1<<(x))
#define __SETRNG(l, h) ((~(SET)0<<(l))&~(SET)0>>(8*sizeof(SET)-1-(h)))
#define __MASK(x, m) ((x)&~(m))
#define __COPY(s, d, n) {char*_a=(void*)s,*_b=(void*)d;long _i=0,_t=n-1;while(_i<_t&&((_b[_i]=_a[_i])!=0)){_i++;};_b[_i]=0;}
static int __STRCMP(x, y)
CHAR *x, *y;
{long i = 0; CHAR ch1, ch2;
do {ch1 = x[i]; ch2 = y[i]; i++;
if (!ch1) return -(int)ch2;
} while (ch1==ch2);
return (int)ch1 - (int)ch2;
}
#define __ASH(x, n) ((n)>=0?__ASHL(x,n):__ASHR(x,-(n)))
#define __ASHL(x, n) ((long)(x)<<(n))
#define __ASHR(x, n) ((long)(x)>>(n))
#define __ASHF(x, n) SYSTEM_ASH((long)(x), (long)(n))
#define __DUP(x, l, t) x=(void*)memcpy(alloca(l*sizeof(t)),x,l*sizeof(t))
#define __DUPARR(v, t) v=(void*)memcpy(v##__copy,v,sizeof(t))
#define __DEL(x) /* DUP with alloca frees storage automatically */
#define __IS(tag, typ, level) (*(tag-(__BASEOFF-level))==(long)typ##__typ)
#define __TYPEOF(p) (*(((long**)(p))-1))
#define __ISP(p, typ, level) __IS(__TYPEOF(p),typ,level)
/* runtime checks */
#define __X(i, ub) (((unsigned)(long)(i)<(unsigned long)(ub))?i:(__HALT(-2),0))
#define __XF(i, ub) SYSTEM_XCHK((long)(i), (long)(ub))
#define __RETCHK __retchk: __HALT(-3)
#define __CASECHK __HALT(-4)
#define __GUARDP(p, typ, level) ((typ*)(__ISP(p,typ,level)?p:(__HALT(-5),p)))
#define __GUARDR(r, typ, level) (*((typ*)(__IS(r##__typ,typ,level)?r:(__HALT(-5),r))))
#define __GUARDA(p, typ, level) ((struct typ*)(__IS(__TYPEOF(p),typ,level)?p:(__HALT(-5),p)))
#define __GUARDEQR(p, dyntyp, typ) if(dyntyp!=typ##__typ) __HALT(-6);*(p)
#define __GUARDEQP(p, typ) if(__TYPEOF(p)!=typ##__typ)__HALT(-6);*(p)
#define __WITHCHK __HALT(-7)
#define __R(i, ub) (((unsigned)(long)(i)<(unsigned long)(ub))?i:(__HALT(-8),0))
#define __RF(i, ub) SYSTEM_RCHK((long)(i),(long)(ub))
/* record type descriptors */
#define __TDESC(t, m, n) \
static struct t##__desc {\
long tproc[m]; \
long tag, next, level, module; \
char name[24]; \
long *base[__MAXEXT]; \
char *rsrvd; \
long blksz, ptr[n+1]; \
} t##__desc
#define __BASEOFF (__MAXEXT+1)
#define __TPROC0OFF (__BASEOFF+24/sizeof(long)+5)
#define __EOM 1
#define __TDFLDS(name, size) {__EOM}, 1, 0, 0, 0, name, {0}, 0, size
#define __ENUMP(adr, n, P) SYSTEM_ENUMP(adr, (long)(n), P)
#define __ENUMR(adr, typ, size, n, P) SYSTEM_ENUMR(adr, typ, (long)(size), (long)(n), P)
#define __INITYP(t, t0, level) \
t##__typ= &t##__desc.blksz; \
memcpy(t##__desc.base, t0##__typ - __BASEOFF, level*sizeof(long)); \
t##__desc.base[level]=t##__typ; \
t##__desc.module=(long)m; \
if(t##__desc.blksz!=sizeof(struct t)) __HALT(-15); \
t##__desc.blksz=(t##__desc.blksz+5*sizeof(long)-1)/(4*sizeof(long))*(4*sizeof(long)); \
SYSTEM_REGTYP(m, (long)&t##__desc.next); \
SYSTEM_INHERIT(t##__typ, t0##__typ)
/* Oberon-2 type bound procedures support */
#define __INITBP(t, proc, num) *(t##__typ-(__TPROC0OFF+num))=(long)proc
#define __SEND(typ, num, funtyp, parlist) ((funtyp)(*(typ-(__TPROC0OFF+num))))parlist
/* runtime system variables */
extern LONGINT SYSTEM_argc;
extern LONGINT SYSTEM_argv;
extern void (*SYSTEM_Halt)();
extern LONGINT SYSTEM_halt;
extern LONGINT SYSTEM_assert;
extern SYSTEM_PTR SYSTEM_modules;
extern LONGINT SYSTEM_heapsize;
extern LONGINT SYSTEM_allocated;
extern LONGINT SYSTEM_lock;
extern SHORTINT SYSTEM_gclock;
extern BOOLEAN SYSTEM_interrupted;
/* ANSI prototypes; not used so far
static int __STRCMP(CHAR *x, CHAR *y);
void SYSTEM_INIT(int argc, long argvadr);
void SYSTEM_FINI(void);
long SYSTEM_XCHK(long i, long ub);
long SYSTEM_RCHK(long i, long ub);
long SYSTEM_ASH(long i, long n);
long SYSTEM_ABS(long i);
double SYSTEM_ABSD(double i);
void SYSTEM_INHERIT(long *t, long *t0);
void SYSTEM_ENUMP(long *adr, long n, void (*P)(void*));
void SYSTEM_ENUMR(char *adr, long *typ, long size, long n, void (*P)(void*));
long SYSTEM_DIV(unsigned long x, unsigned long y);
long SYSTEM_MOD(unsigned long x, unsigned long y);
long SYSTEM_ENTIER(double x);
void SYSTEM_HALT(int n);
*/
#endif

411
src/lib/system/gnuc/armv6j/Unix.Mod Normal file
View file

@ -0,0 +1,411 @@
MODULE Unix; (* Josef Templ, 5.3.90 Linux system calls *)
(* system procedure added by noch *)
(* Module Unix provides a system call interface to Linux.
Naming conventions:
Procedure and Type-names always start with a capital letter.
error numbers as defined in Unix
other constants start with lower case letters *)
IMPORT SYSTEM;
CONST
(* various important constants *)
stdin* = 0; stdout* =1; stderr* = 2;
LOCKEX* = 2; LOCKUN* = 8; (* /usr/include/file.h *)
AFINET* = 2; (* /usr/include/sys/socket.h *)
PFINET* = AFINET; (* /usr/include/linux/socket.h *)
SOCKSTREAM* = 1; (* /usr/include/linux/socket.h *)
FIONREAD* = 541BH; (* in /usr/include/asm/termios.h *)
SETFL* = 4; (* set file descriptor flags; in asm/fcntl.h *)
TCP* = 0;
(* flag sets, cf. /usr/include/asm/fcntl.h *)
rdonly* = {}; wronly* = {0}; rdwr* = {1}; creat* = {6}; excl* = {7}; trunc* = {9}; append* = {10}; ndelay = {11};
(* error numbers *)
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 children *)
EAGAIN* = 11; (* No more processes *)
ENOMEM* = 12; (* Not enough core *)
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; (* Argument too large *)
ERANGE* = 34; (* Result too large *)
EDEADLK* = 35; (* Resource deadlock would occur *)
ENAMETOOLONG* = 36; (* File name too long *)
ENOLCK* = 37; (* No record locks available *)
ENOSYS* = 38; (* Function not implemented *)
ENOTEMPTY* = 39; (* Directory not empty *)
ELOOP* = 40; (* Too many symbolic links encountered *)
EWOULDBLOCK* = EAGAIN; (* Operation would block *)
ENOMSG* = 42; (* No message of desired type *)
EIDRM* = 43; (* Identifier removed *)
ECHRNG* = 44; (* Channel number out of range *)
EL2NSYNC* = 45; (* Level 2 not synchronized *)
EL3HLT* = 46; (* Level 3 halted *)
EL3RST* = 47; (* Level 3 reset *)
ELNRNG* = 48; (* Link number out of range *)
EUNATCH* = 49; (* Protocol driver not attached *)
ENOCSI* = 50; (* No CSI structure available *)
EL2HLT* = 51; (* Level 2 halted *)
EBADE* = 52; (* Invalid exchange *)
EBADR* = 53; (* Invalid request descriptor *)
EXFULL* = 54; (* Exchange full *)
ENOANO* = 55; (* No anode *)
EBADRQC* = 56; (* Invalid request code *)
EBADSLT* = 57; (* Invalid slot *)
EDEADLOCK* = 58; (* File locking deadlock error *)
EBFONT* = 59; (* Bad font file format *)
ENOSTR* = 60; (* Device not a stream *)
ENODATA* = 61; (* No data available *)
ETIME* = 62; (* Timer expired *)
ENOSR* = 63; (* Out of streams resources *)
ENONET* = 64; (* Machine is not on the network *)
ENOPKG* = 65; (* Package not installed *)
EREMOTE* = 66; (* Object is remote *)
ENOLINK* = 67; (* Link has been severed *)
EADV* = 68; (* Advertise error *)
ESRMNT* = 69; (* Srmount error *)
ECOMM* = 70; (* Communication error on send *)
EPROTO* = 71; (* Protocol error *)
EMULTIHOP* = 72; (* Multihop attempted *)
EDOTDOT* = 73; (* RFS specific error *)
EBADMSG* = 74; (* Not a data message *)
EOVERFLOW* = 75; (* Value too large for defined data type *)
ENOTUNIQ* = 76; (* Name not unique on network *)
EBADFD* = 77; (* File descriptor in bad state *)
EREMCHG* = 78; (* Remote address changed *)
ELIBACC* = 79; (* Can not access a needed shared library *)
ELIBBAD* = 80; (* Accessing a corrupted shared library *)
ELIBSCN* = 81; (* .lib section in a.out corrupted *)
ELIBMAX* = 82; (* Attempting to link in too many shared libraries *)
ELIBEXEC* = 83; (* Cannot exec a shared library directly *)
EILSEQ* = 84; (* Illegal byte sequence *)
ERESTART* = 85; (* Interrupted system call should be restarted *)
ESTRPIPE* = 86; (* Streams pipe error *)
EUSERS* = 87; (* Too many users *)
ENOTSOCK* = 88; (* Socket operation on non-socket *)
EDESTADDRREQ* = 89; (* Destination address required *)
EMSGSIZE* = 90; (* Message too long *)
EPROTOTYPE* = 91; (* Protocol wrong type for socket *)
ENOPROTOOPT* = 92; (* Protocol not available *)
EPROTONOSUPPORT* = 93; (* Protocol not supported *)
ESOCKTNOSUPPORT* = 94; (* Socket type not supported *)
EOPNOTSUPP* = 95; (* Operation not supported on transport endpoint *)
EPFNOSUPPORT* = 96; (* Protocol family not supported *)
EAFNOSUPPORT* = 97; (* Address family not supported by protocol *)
EADDRINUSE* = 98; (* Address already in use *)
EADDRNOTAVAIL* = 99; (* Cannot assign requested address *)
ENETDOWN* = 100; (* Network is down *)
ENETUNREACH* = 101; (* Network is unreachable *)
ENETRESET* = 102; (* Network dropped connection because of reset *)
ECONNABORTED* = 103; (* Software caused connection abort *)
ECONNRESET* = 104; (* Connection reset by peer *)
ENOBUFS* = 105; (* No buffer space available *)
EISCONN* = 106; (* Transport endpoint is already connected *)
ENOTCONN* = 107; (* Transport endpoint is not connected *)
ESHUTDOWN* = 108; (* Cannot send after transport endpoint shutdown *)
ETOOMANYREFS* = 109; (* Too many references: cannot splice *)
ETIMEDOUT* = 110; (* Connection timed out *)
ECONNREFUSED* = 111; (* Connection refused *)
EHOSTDOWN* = 112; (* Host is down *)
EHOSTUNREACH* = 113; (* No route to host *)
EALREADY* = 114; (* Operation already in progress *)
EINPROGRESS* = 115; (* Operation now in progress *)
ESTALE* = 116; (* Stale NFS file handle *)
EUCLEAN* = 117; (* Structure needs cleaning *)
ENOTNAM* = 118; (* Not a XENIX named type file *)
ENAVAIL* = 119; (* No XENIX semaphores available *)
EISNAM* = 120; (* Is a named type file *)
EREMOTEIO* = 121; (* Remote I/O error *)
EDQUOT* = 122; (* Quota exceeded *)
TYPE
JmpBuf* = RECORD
bx*, si*, di*, bp*, sp*, pc*: LONGINT;
maskWasSaved*, savedMask*: LONGINT;
END ;
Status* = RECORD (* struct stat *)
dev*, devX*: LONGINT; (* 64 bit in Linux 2.2 *)
pad1: INTEGER;
ino*, mode*, nlink*, uid*, gid*: LONGINT;
rdev*, rdevX*: LONGINT; (* 64 bit in Linux 2.2 *)
pad2: INTEGER;
size*, blksize*, blocks*, atime*, unused1*, mtime*, unused2*, ctime*,
unused3*, unused4*, unused5*: LONGINT;
END ;
Timeval* = RECORD
sec*, usec*: LONGINT
END ;
Timezone* = RECORD
minuteswest*, dsttime*: LONGINT
END ;
Itimerval* = RECORD
interval*, value*: Timeval
END ;
FdSet* = ARRAY 8 OF SET;
SigCtxPtr* = POINTER TO SigContext;
SigContext* = RECORD
END ;
SignalHandler* = PROCEDURE (sig, code: LONGINT; scp: SigCtxPtr);
Dirent* = RECORD
ino, off: LONGINT;
reclen: INTEGER;
name: ARRAY 256 OF CHAR;
END ;
Rusage* = RECORD
utime*, stime*: Timeval;
maxrss*, ixrss*, idrss*, isrss*,
minflt*, majflt*, nswap*, inblock*,
oublock*, msgsnd*, msgrcv*, nsignals*,
nvcsw*, nivcsw*: LONGINT
END ;
Iovec* = RECORD
base*, len*: LONGINT
END ;
SocketPair* = ARRAY 2 OF LONGINT;
Pollfd* = RECORD
fd*: LONGINT;
events*, revents*: INTEGER
END ;
Sockaddr* = RECORD
family*: INTEGER;
port*: INTEGER;
internetAddr*: LONGINT;
pad*: ARRAY 8 OF CHAR;
END ;
HostEntry* = POINTER [1] TO Hostent;
Hostent* = RECORD
name*, aliases*: LONGINT;
addrtype*, length*: LONGINT;
addrlist*: LONGINT; (*POINTER TO POINTER TO LONGINT, network byte order*)
END;
Name* = ARRAY OF CHAR;
PROCEDURE -includeStat()
"#include <sys/stat.h>";
PROCEDURE -includeErrno()
"#include <errno.h>";
PROCEDURE -err(): LONGINT
"errno";
PROCEDURE errno*(): LONGINT;
BEGIN
RETURN err()
END errno;
PROCEDURE -Exit*(n: LONGINT)
"exit(n)";
PROCEDURE -Fork*(): LONGINT
"fork()";
PROCEDURE -Wait*(VAR status: LONGINT): LONGINT
"wait(status)";
PROCEDURE -Select*(width: LONGINT; VAR readfds, writefds, exceptfds: FdSet; VAR timeout: Timeval): LONGINT
"select(width, readfds, writefds, exceptfds, timeout)";
PROCEDURE -Gettimeofday* (VAR tv: Timeval; VAR tz: Timezone)
"gettimeofday(tv, tz)";
PROCEDURE -Read* (fd, buf, nbyte: LONGINT): LONGINT
"read(fd, buf, nbyte)";
PROCEDURE -ReadBlk* (fd: LONGINT; VAR buf: ARRAY OF SYSTEM.BYTE): LONGINT
"read(fd, buf, buf__len)";
PROCEDURE -Write* (fd, buf, nbyte: LONGINT): LONGINT
"write(fd, buf, nbyte)";
PROCEDURE -WriteBlk* (fd: LONGINT; VAR buf: ARRAY OF SYSTEM.BYTE): LONGINT
"write(fd, buf, buf__len)";
PROCEDURE -Dup*(fd: LONGINT): LONGINT
"dup(fd)";
PROCEDURE -Dup2*(fd1, fd2: LONGINT): LONGINT
"dup(fd1, fd2)";
PROCEDURE -Getpid*(): LONGINT
"getpid()";
PROCEDURE -Getuid*(): LONGINT
"getuid()";
PROCEDURE -Geteuid*(): LONGINT
"geteuid()";
PROCEDURE -Getgid*(): LONGINT
"getgid()";
PROCEDURE -Getegid*(): LONGINT
"getegid()";
PROCEDURE -Unlink*(name: Name): LONGINT
"unlink(name)";
PROCEDURE -Open*(name: Name; flag, mode: SET): LONGINT
"open(name, flag, mode)";
PROCEDURE -Close*(fd: LONGINT): LONGINT
"close(fd)";
PROCEDURE -stat(name: Name; VAR statbuf: Status): LONGINT
"stat((const char*)name, (struct stat*)statbuf)";
PROCEDURE Stat*(name: Name; VAR statbuf: Status): LONGINT;
VAR res: LONGINT;
BEGIN
res := stat(name, statbuf);
(* make the first 4 bytes as unique as possible (used in module Files for caching!) *)
INC(statbuf.dev, statbuf.devX);
INC(statbuf.rdev, statbuf.rdevX);
RETURN res;
END Stat;
PROCEDURE -fstat(fd: LONGINT; VAR statbuf: Status): LONGINT
"fstat(fd, (struct stat*)statbuf)";
PROCEDURE Fstat*(fd: LONGINT; VAR statbuf: Status): LONGINT;
VAR res: LONGINT;
BEGIN
res := fstat(fd, statbuf);
(* make the first 4 bytes as unique as possible (used in module Files for caching!) *)
INC(statbuf.dev, statbuf.devX);
INC(statbuf.rdev, statbuf.rdevX);
RETURN res;
END Fstat;
PROCEDURE -Fchmod*(fd, mode: LONGINT): LONGINT
"fchmod(fd, mode)";
PROCEDURE -Chmod*(path: Name; mode: LONGINT): LONGINT
"chmod(path, mode)";
PROCEDURE -Lseek*(fd, offset, origin: LONGINT): LONGINT
"lseek(fd, offset, origin)";
PROCEDURE -Fsync*(fd: LONGINT): LONGINT
"fsync(fd)";
PROCEDURE -Fcntl*(fd, cmd, arg: LONGINT ): LONGINT
"fcntl(fd, cmd, arg)";
PROCEDURE -Flock*(fd, operation: LONGINT): LONGINT
"flock(fd, operation)";
PROCEDURE -Ftruncate*(fd, length: LONGINT): LONGINT
"ftruncate(fd, length)";
PROCEDURE -Readblk*(fd: LONGINT; VAR buf: ARRAY OF SYSTEM.BYTE; len: LONGINT): LONGINT
"read(fd, buf, len)";
PROCEDURE -Rename*(old, new: Name): LONGINT
"rename(old, new)";
PROCEDURE -Chdir*(path: Name): LONGINT
"chdir(path)";
PROCEDURE -Ioctl*(fd, request, arg: LONGINT): LONGINT
"ioctl(fd, request, arg)";
PROCEDURE -Kill*(pid, sig: LONGINT): LONGINT
"kill(pid, sig)";
PROCEDURE -Sigsetmask*(mask: LONGINT): LONGINT
"sigsetmask(mask)";
(* TCP/IP networking *)
PROCEDURE -Gethostbyname*(name: Name): HostEntry
"(Unix_HostEntry)gethostbyname(name)";
PROCEDURE -Gethostname*(VAR name: Name): LONGINT
"gethostname(name, name__len)";
PROCEDURE -Socket*(af, type, protocol: LONGINT): LONGINT
"socket(af, type, protocol)";
PROCEDURE -Connect*(socket: LONGINT; name: Sockaddr; namelen: LONGINT): LONGINT
"connect(socket, &(name), namelen)";
PROCEDURE -Getsockname*(socket: LONGINT; VAR name: Sockaddr; VAR namelen: LONGINT): LONGINT
"getsockname(socket, name, namelen)";
PROCEDURE -Bind*(socket: LONGINT; name: Sockaddr; namelen: LONGINT): LONGINT
"bind(socket, &(name), namelen)";
PROCEDURE -Listen*(socket, backlog: LONGINT): LONGINT
"listen(socket, backlog)";
PROCEDURE -Accept*(socket: LONGINT; VAR addr: Sockaddr; VAR addrlen: LONGINT): LONGINT
"accept(socket, addr, addrlen)";
PROCEDURE -Recv*(socket, bufadr, buflen, flags: LONGINT): LONGINT
"recv(socket, bufadr, buflen, flags)";
PROCEDURE -Send*(socket, bufadr, buflen, flags: LONGINT): LONGINT
"send(socket, bufadr, buflen, flags)";
PROCEDURE -sys(str: ARRAY OF CHAR): INTEGER (* need this to call external tools like gcc or gas; noch *)
"system(str)";
PROCEDURE system*(cmd : ARRAY OF CHAR);
VAR r : INTEGER;
BEGIN
r := sys(cmd);
END system;
END Unix.

52
src/lib/system/gnuc/armv6j_hardfp/Args.Mod Normal file
View file

@ -0,0 +1,52 @@
MODULE Args; (* jt, 8.12.94 *)
(* command line argument handling for ofront *)
IMPORT SYSTEM;
TYPE
ArgPtr = POINTER TO ARRAY 1024 OF CHAR;
ArgVec = POINTER TO ARRAY 1024 OF ArgPtr;
VAR argc-, argv-: LONGINT;
PROCEDURE -Argc(): INTEGER "SYSTEM_argc";
PROCEDURE -Argv(): LONGINT "(long)SYSTEM_argv";
PROCEDURE -getenv(var: ARRAY OF CHAR): ArgPtr
"(Args_ArgPtr)getenv(var)";
PROCEDURE Get*(n: INTEGER; VAR val: ARRAY OF CHAR);
VAR av: ArgVec;
BEGIN
IF n < argc THEN av := SYSTEM.VAL(ArgVec, argv); COPY(av[n]^, val) END
END Get;
PROCEDURE GetInt*(n: INTEGER; VAR val: LONGINT);
VAR s: ARRAY 64 OF CHAR; k, d, i: LONGINT;
BEGIN
s := ""; Get(n, s); i := 0;
IF s[0] = "-" THEN i := 1 END ;
k := 0; d := ORD(s[i]) - ORD("0");
WHILE (d >= 0 ) & (d <= 9) DO k := k*10 + d; INC(i); d := ORD(s[i]) - ORD("0") END ;
IF s[0] = "-" THEN d := -d; DEC(i) END ;
IF i > 0 THEN val := k END
END GetInt;
PROCEDURE Pos*(s: ARRAY OF CHAR): INTEGER;
VAR i: INTEGER; arg: ARRAY 256 OF CHAR;
BEGIN
i := 0; Get(i, arg);
WHILE (i < argc) & (s # arg) DO INC(i); Get(i, arg) END ;
RETURN i
END Pos;
PROCEDURE GetEnv*(var: ARRAY OF CHAR; VAR val: ARRAY OF CHAR);
VAR p: ArgPtr;
BEGIN
p := getenv(var);
IF p # NIL THEN COPY(p^, val) END
END GetEnv;
BEGIN argc := Argc(); argv := Argv()
END Args.

205
src/lib/system/gnuc/armv6j_hardfp/SYSTEM.c0 Normal file
View file

@ -0,0 +1,205 @@
/*
* The body prefix file of the Ofront runtime system, Version 1.0
*
* Copyright (c) Software Templ, 1994, 1995
*
* Module SYSTEM is subject to change any time without prior notification.
* Software Templ disclaims all warranties with regard to module SYSTEM,
* in particular shall Software Templ not be liable for any damage resulting
* from inappropriate use or modification of module SYSTEM.
*
* Version 1.1 jt, 24.11.95 fixes for correct pointer arithmetic on Cray computers
* jt 31.1.2007 ANSI prototypes for malloc and exit in order to avoid cc warnings
*
*/
#include "SYSTEM.h"
#ifdef __STDC__
#include "stdarg.h"
#else
#include "varargs.h"
#endif
extern void *malloc(long size);
extern void exit(int status);
void (*SYSTEM_Halt)();
LONGINT SYSTEM_halt; /* x in HALT(x) */
LONGINT SYSTEM_assert; /* x in ASSERT(cond, x) */
LONGINT SYSTEM_argc;
LONGINT SYSTEM_argv;
LONGINT SYSTEM_lock;
BOOLEAN SYSTEM_interrupted;
static LONGINT SYSTEM_mainfrm; /* adr of main proc stack frame, used for stack collection */
#define Lock SYSTEM_lock++
#define Unlock SYSTEM_lock--; if (SYSTEM_interrupted && (SYSTEM_lock == 0)) __HALT(-9)
static void SYSTEM_InitHeap();
void *SYSTEM__init();
void SYSTEM_INIT(argc, argvadr)
int argc; long argvadr;
{
SYSTEM_mainfrm = argvadr;
SYSTEM_argc = argc;
SYSTEM_argv = *(long*)argvadr;
SYSTEM_InitHeap();
SYSTEM_halt = -128;
SYSTEM__init();
}
void SYSTEM_FINI()
{
SYSTEM_FINALL();
}
long SYSTEM_XCHK(i, ub) long i, ub; {return __X(i, ub);}
long SYSTEM_RCHK(i, ub) long i, ub; {return __R(i, ub);}
long SYSTEM_ASH(i, n) long i, n; {return __ASH(i, n);}
long SYSTEM_ABS(i) long i; {return __ABS(i);}
double SYSTEM_ABSD(i) double i; {return __ABS(i);}
void SYSTEM_INHERIT(t, t0)
long *t, *t0;
{
t -= __TPROC0OFF;
t0 -= __TPROC0OFF;
while (*t0 != __EOM) {*t = *t0; t--; t0--;}
}
void SYSTEM_ENUMP(adr, n, P)
long *adr;
long n;
void (*P)();
{
while (n > 0) {P(*adr); adr++; n--;}
}
void SYSTEM_ENUMR(adr, typ, size, n, P)
char *adr;
long *typ, size, n;
void (*P)();
{
long *t, off;
typ++;
while (n > 0) {
t = typ;
off = *t;
while (off >= 0) {P(*(long*)(adr+off)); t++; off = *t;}
adr += size; n--;
}
}
long SYSTEM_DIV(x, y)
unsigned long x, y;
{ if ((long) x >= 0) return (x / y);
else return -((y - 1 - x) / y);
}
long SYSTEM_MOD(x, y)
unsigned long x, y;
{ unsigned long m;
if ((long) x >= 0) return (x % y);
else { m = (-x) % y;
if (m != 0) return (y - m); else return 0;
}
}
long SYSTEM_ENTIER(x)
double x;
{
long y;
if (x >= 0)
return (long)x;
else {
y = (long)x;
if (y <= x) return y; else return y - 1;
}
}
void SYSTEM_HALT(n)
int n;
{
SYSTEM_halt = n;
if (SYSTEM_Halt!=0) SYSTEM_Halt(n);
exit(n);
}
#ifdef __STDC__
SYSTEM_PTR SYSTEM_NEWARR(long *typ, long elemsz, int elemalgn, int nofdim, int nofdyn, ...)
#else
SYSTEM_PTR SYSTEM_NEWARR(typ, elemsz, elemalgn, nofdim, nofdyn, va_alist)
long *typ, elemsz;
int elemalgn, nofdim, nofdyn;
va_dcl
#endif
{
long nofelems, size, dataoff, n, nptr, *x, *p, nofptrs, i, *ptab, off;
va_list ap;
#ifdef __STDC__
va_start(ap, nofdyn);
#else
va_start(ap);
#endif
nofelems = 1;
while (nofdim > 0) {
nofelems = nofelems * va_arg(ap, long); nofdim--;
if (nofelems <= 0) __HALT(-20);
}
va_end(ap);
dataoff = nofdyn * sizeof(long);
if (elemalgn > sizeof(long)) {
n = dataoff % elemalgn;
if (n != 0) dataoff += elemalgn - n;
}
size = dataoff + nofelems * elemsz;
Lock;
if (typ == NIL) {
/* element typ does not contain pointers */
x = SYSTEM_NEWBLK(size);
}
else if (typ == POINTER__typ) {
/* element type is a pointer */
x = SYSTEM_NEWBLK(size + nofelems * sizeof(long));
p = (long*)x[-1];
p[-nofelems] = *p; /* build new type desc in situ: 1. copy block size; 2. setup ptr tab; 3. set sentinel; 4. patch tag */
p -= nofelems - 1; n = 1; /* n =1 for skipping the size field */
while (n <= nofelems) {*p = n*sizeof(long); p++; n++;}
*p = - (nofelems + 1) * sizeof(long); /* sentinel */
x[-1] -= nofelems * sizeof(long);
}
else {
/* element type is a record that contains pointers */
ptab = typ + 1; nofptrs = 0;
while (ptab[nofptrs] >= 0) {nofptrs++;} /* number of pointers per element */
nptr = nofelems * nofptrs; /* total number of pointers */
x = SYSTEM_NEWBLK(size + nptr * sizeof(long));
p = (long*)x[- 1];
p[-nptr] = *p; /* build new type desc in situ; 1. copy block size; 2. setup ptr tab; 3. set sentinel; 4. patch tag */
p -= nptr - 1; n = 0; off = dataoff;
while (n < nofelems) {i = 0;
while (i < nofptrs) {*p = off + ptab[i]; p++; i++;}
off += elemsz; n++;
}
*p = - (nptr + 1) * sizeof(long); /* sentinel */
x[-1] -= nptr * sizeof(long);
}
if (nofdyn != 0) {
/* setup len vector for index checks */
#ifdef __STDC__
va_start(ap, nofdyn);
#else
va_start(ap);
#endif
p = x;
while (nofdyn > 0) {*p = va_arg(ap, long); p++, nofdyn--;}
va_end(ap);
}
Unlock;
return x;
}
/* ----------- end of SYSTEM.co ------------- */

215
src/lib/system/gnuc/armv6j_hardfp/SYSTEM.h Normal file
View file

@ -0,0 +1,215 @@
#ifndef SYSTEM__h
#define SYSTEM__h
/*
the Ofront runtime system interface and macros library
copyright (c) Josef Templ, 1995, 1996
gcc for Linux version (same as SPARC/Solaris2)
uses double # as concatenation operator
*/
#include <alloca.h>
//extern void *memcpy(void *dest, const void *src, long n);
extern void *memcpy(void *dest, const void *src, size_t n);
extern void *malloc(long size);
extern void exit(int status);
#define export
#define import extern
/* constants */
#define __MAXEXT 16
#define NIL 0L
#define POINTER__typ (long*)1L /* not NIL and not a valid type */
/* basic types */
typedef char BOOLEAN;
typedef unsigned char CHAR;
typedef signed char SHORTINT;
typedef short int INTEGER;
typedef long LONGINT;
typedef float REAL;
typedef double LONGREAL;
typedef unsigned long SET;
typedef void *SYSTEM_PTR;
typedef unsigned char SYSTEM_BYTE;
/* runtime system routines */
extern long SYSTEM_DIV();
extern long SYSTEM_MOD();
extern long SYSTEM_ENTIER();
extern long SYSTEM_ASH();
extern long SYSTEM_ABS();
extern long SYSTEM_XCHK();
extern long SYSTEM_RCHK();
extern double SYSTEM_ABSD();
extern SYSTEM_PTR SYSTEM_NEWREC();
extern SYSTEM_PTR SYSTEM_NEWBLK();
#ifdef __STDC__
extern SYSTEM_PTR SYSTEM_NEWARR(long*, long, int, int, int, ...);
#else
extern SYSTEM_PTR SYSTEM_NEWARR();
#endif
extern SYSTEM_PTR SYSTEM_REGMOD();
extern void SYSTEM_INCREF();
extern void SYSTEM_REGCMD();
extern void SYSTEM_REGTYP();
extern void SYSTEM_REGFIN();
extern void SYSTEM_FINALL();
extern void SYSTEM_INIT();
extern void SYSTEM_FINI();
extern void SYSTEM_HALT();
extern void SYSTEM_INHERIT();
extern void SYSTEM_ENUMP();
extern void SYSTEM_ENUMR();
/* module registry */
#define __DEFMOD static void *m; if(m!=0)return m
#define __REGMOD(name, enum) if(m==0)m=SYSTEM_REGMOD((CHAR*)name,enum); else return m
#define __ENDMOD return m
#define __INIT(argc, argv) static void *m; SYSTEM_INIT(argc, (long)&argv);
#define __REGMAIN(name, enum) m=SYSTEM_REGMOD(name,enum)
#define __FINI SYSTEM_FINI(); return 0
#define __IMPORT(name) SYSTEM_INCREF(name##__init())
#define __REGCMD(name, cmd) SYSTEM_REGCMD(m, name, cmd)
/* SYSTEM ops */
#define __SYSNEW(p, len) p=SYSTEM_NEWBLK((long)(len))
#define __VAL(t, x) (*(t*)&(x))
#define __GET(a, x, t) x= *(t*)(a)
#define __PUT(a, x, t) *(t*)(a)=x
#define __LSHL(x, n, t) ((t)((unsigned)(x)<<(n)))
#define __LSHR(x, n, t) ((t)((unsigned)(x)>>(n)))
#define __LSH(x, n, t) ((n)>=0? __LSHL(x, n, t): __LSHR(x, -(n), t))
#define __ROTL(x, n, t) ((t)((unsigned)(x)<<(n)|(unsigned)(x)>>(8*sizeof(t)-(n))))
#define __ROTR(x, n, t) ((t)((unsigned)(x)>>(n)|(unsigned)(x)<<(8*sizeof(t)-(n))))
#define __ROT(x, n, t) ((n)>=0? __ROTL(x, n, t): __ROTR(x, -(n), t))
#define __BIT(x, n) (*(unsigned long*)(x)>>(n)&1)
#define __MOVE(s, d, n) memcpy((char*)(d),(char*)(s),n)
/* std procs and operator mappings */
#define __SHORT(x, y) ((int)((unsigned long)(x)+(y)<(y)+(y)?(x):(__HALT(-8),0)))
#define __SHORTF(x, y) ((int)(__RF((x)+(y),(y)+(y))-(y)))
#define __CHR(x) ((CHAR)__R(x, 256))
#define __CHRF(x) ((CHAR)__RF(x, 256))
#define __DIV(x, y) ((x)>=0?(x)/(y):-(((y)-1-(x))/(y)))
#define __DIVF(x, y) SYSTEM_DIV((long)(x),(long)(y))
#define __MOD(x, y) ((x)>=0?(x)%(y):__MODF(x,y))
#define __MODF(x, y) SYSTEM_MOD((long)(x),(long)(y))
#define __NEW(p, t) p=SYSTEM_NEWREC((long)t##__typ)
#define __NEWARR SYSTEM_NEWARR
#define __HALT(x) SYSTEM_HALT(x)
#define __ASSERT(cond, x) if (!(cond)) {SYSTEM_assert = x; SYSTEM_HALT(-1);}
#define __ENTIER(x) SYSTEM_ENTIER(x)
#define __ABS(x) (((x)<0)?-(x):(x))
#define __ABSF(x) SYSTEM_ABS((long)(x))
#define __ABSFD(x) SYSTEM_ABSD((double)(x))
#define __CAP(ch) ((CHAR)((ch)&0x5f))
#define __ODD(x) ((x)&1)
#define __IN(x, s) (((s)>>(x))&1)
#define __SETOF(x) ((SET)1<<(x))
#define __SETRNG(l, h) ((~(SET)0<<(l))&~(SET)0>>(8*sizeof(SET)-1-(h)))
#define __MASK(x, m) ((x)&~(m))
#define __COPY(s, d, n) {char*_a=(void*)s,*_b=(void*)d;long _i=0,_t=n-1;while(_i<_t&&((_b[_i]=_a[_i])!=0)){_i++;};_b[_i]=0;}
static int __STRCMP(x, y)
CHAR *x, *y;
{long i = 0; CHAR ch1, ch2;
do {ch1 = x[i]; ch2 = y[i]; i++;
if (!ch1) return -(int)ch2;
} while (ch1==ch2);
return (int)ch1 - (int)ch2;
}
#define __ASH(x, n) ((n)>=0?__ASHL(x,n):__ASHR(x,-(n)))
#define __ASHL(x, n) ((long)(x)<<(n))
#define __ASHR(x, n) ((long)(x)>>(n))
#define __ASHF(x, n) SYSTEM_ASH((long)(x), (long)(n))
#define __DUP(x, l, t) x=(void*)memcpy(alloca(l*sizeof(t)),x,l*sizeof(t))
#define __DUPARR(v, t) v=(void*)memcpy(v##__copy,v,sizeof(t))
#define __DEL(x) /* DUP with alloca frees storage automatically */
#define __IS(tag, typ, level) (*(tag-(__BASEOFF-level))==(long)typ##__typ)
#define __TYPEOF(p) (*(((long**)(p))-1))
#define __ISP(p, typ, level) __IS(__TYPEOF(p),typ,level)
/* runtime checks */
#define __X(i, ub) (((unsigned)(long)(i)<(unsigned long)(ub))?i:(__HALT(-2),0))
#define __XF(i, ub) SYSTEM_XCHK((long)(i), (long)(ub))
#define __RETCHK __retchk: __HALT(-3)
#define __CASECHK __HALT(-4)
#define __GUARDP(p, typ, level) ((typ*)(__ISP(p,typ,level)?p:(__HALT(-5),p)))
#define __GUARDR(r, typ, level) (*((typ*)(__IS(r##__typ,typ,level)?r:(__HALT(-5),r))))
#define __GUARDA(p, typ, level) ((struct typ*)(__IS(__TYPEOF(p),typ,level)?p:(__HALT(-5),p)))
#define __GUARDEQR(p, dyntyp, typ) if(dyntyp!=typ##__typ) __HALT(-6);*(p)
#define __GUARDEQP(p, typ) if(__TYPEOF(p)!=typ##__typ)__HALT(-6);*(p)
#define __WITHCHK __HALT(-7)
#define __R(i, ub) (((unsigned)(long)(i)<(unsigned long)(ub))?i:(__HALT(-8),0))
#define __RF(i, ub) SYSTEM_RCHK((long)(i),(long)(ub))
/* record type descriptors */
#define __TDESC(t, m, n) \
static struct t##__desc {\
long tproc[m]; \
long tag, next, level, module; \
char name[24]; \
long *base[__MAXEXT]; \
char *rsrvd; \
long blksz, ptr[n+1]; \
} t##__desc
#define __BASEOFF (__MAXEXT+1)
#define __TPROC0OFF (__BASEOFF+24/sizeof(long)+5)
#define __EOM 1
#define __TDFLDS(name, size) {__EOM}, 1, 0, 0, 0, name, {0}, 0, size
#define __ENUMP(adr, n, P) SYSTEM_ENUMP(adr, (long)(n), P)
#define __ENUMR(adr, typ, size, n, P) SYSTEM_ENUMR(adr, typ, (long)(size), (long)(n), P)
#define __INITYP(t, t0, level) \
t##__typ= &t##__desc.blksz; \
memcpy(t##__desc.base, t0##__typ - __BASEOFF, level*sizeof(long)); \
t##__desc.base[level]=t##__typ; \
t##__desc.module=(long)m; \
if(t##__desc.blksz!=sizeof(struct t)) __HALT(-15); \
t##__desc.blksz=(t##__desc.blksz+5*sizeof(long)-1)/(4*sizeof(long))*(4*sizeof(long)); \
SYSTEM_REGTYP(m, (long)&t##__desc.next); \
SYSTEM_INHERIT(t##__typ, t0##__typ)
/* Oberon-2 type bound procedures support */
#define __INITBP(t, proc, num) *(t##__typ-(__TPROC0OFF+num))=(long)proc
#define __SEND(typ, num, funtyp, parlist) ((funtyp)(*(typ-(__TPROC0OFF+num))))parlist
/* runtime system variables */
extern LONGINT SYSTEM_argc;
extern LONGINT SYSTEM_argv;
extern void (*SYSTEM_Halt)();
extern LONGINT SYSTEM_halt;
extern LONGINT SYSTEM_assert;
extern SYSTEM_PTR SYSTEM_modules;
extern LONGINT SYSTEM_heapsize;
extern LONGINT SYSTEM_allocated;
extern LONGINT SYSTEM_lock;
extern SHORTINT SYSTEM_gclock;
extern BOOLEAN SYSTEM_interrupted;
/* ANSI prototypes; not used so far
static int __STRCMP(CHAR *x, CHAR *y);
void SYSTEM_INIT(int argc, long argvadr);
void SYSTEM_FINI(void);
long SYSTEM_XCHK(long i, long ub);
long SYSTEM_RCHK(long i, long ub);
long SYSTEM_ASH(long i, long n);
long SYSTEM_ABS(long i);
double SYSTEM_ABSD(double i);
void SYSTEM_INHERIT(long *t, long *t0);
void SYSTEM_ENUMP(long *adr, long n, void (*P)(void*));
void SYSTEM_ENUMR(char *adr, long *typ, long size, long n, void (*P)(void*));
long SYSTEM_DIV(unsigned long x, unsigned long y);
long SYSTEM_MOD(unsigned long x, unsigned long y);
long SYSTEM_ENTIER(double x);
void SYSTEM_HALT(int n);
*/
#endif

411
src/lib/system/gnuc/armv6j_hardfp/Unix.Mod Normal file
View file

@ -0,0 +1,411 @@
MODULE Unix; (* Josef Templ, 5.3.90 Linux system calls *)
(* system procedure added by noch *)
(* Module Unix provides a system call interface to Linux.
Naming conventions:
Procedure and Type-names always start with a capital letter.
error numbers as defined in Unix
other constants start with lower case letters *)
IMPORT SYSTEM;
CONST
(* various important constants *)
stdin* = 0; stdout* =1; stderr* = 2;
LOCKEX* = 2; LOCKUN* = 8; (* /usr/include/file.h *)
AFINET* = 2; (* /usr/include/sys/socket.h *)
PFINET* = AFINET; (* /usr/include/linux/socket.h *)
SOCKSTREAM* = 1; (* /usr/include/linux/socket.h *)
FIONREAD* = 541BH; (* in /usr/include/asm/termios.h *)
SETFL* = 4; (* set file descriptor flags; in asm/fcntl.h *)
TCP* = 0;
(* flag sets, cf. /usr/include/asm/fcntl.h *)
rdonly* = {}; wronly* = {0}; rdwr* = {1}; creat* = {6}; excl* = {7}; trunc* = {9}; append* = {10}; ndelay = {11};
(* error numbers *)
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 children *)
EAGAIN* = 11; (* No more processes *)
ENOMEM* = 12; (* Not enough core *)
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; (* Argument too large *)
ERANGE* = 34; (* Result too large *)
EDEADLK* = 35; (* Resource deadlock would occur *)
ENAMETOOLONG* = 36; (* File name too long *)
ENOLCK* = 37; (* No record locks available *)
ENOSYS* = 38; (* Function not implemented *)
ENOTEMPTY* = 39; (* Directory not empty *)
ELOOP* = 40; (* Too many symbolic links encountered *)
EWOULDBLOCK* = EAGAIN; (* Operation would block *)
ENOMSG* = 42; (* No message of desired type *)
EIDRM* = 43; (* Identifier removed *)
ECHRNG* = 44; (* Channel number out of range *)
EL2NSYNC* = 45; (* Level 2 not synchronized *)
EL3HLT* = 46; (* Level 3 halted *)
EL3RST* = 47; (* Level 3 reset *)
ELNRNG* = 48; (* Link number out of range *)
EUNATCH* = 49; (* Protocol driver not attached *)
ENOCSI* = 50; (* No CSI structure available *)
EL2HLT* = 51; (* Level 2 halted *)
EBADE* = 52; (* Invalid exchange *)
EBADR* = 53; (* Invalid request descriptor *)
EXFULL* = 54; (* Exchange full *)
ENOANO* = 55; (* No anode *)
EBADRQC* = 56; (* Invalid request code *)
EBADSLT* = 57; (* Invalid slot *)
EDEADLOCK* = 58; (* File locking deadlock error *)
EBFONT* = 59; (* Bad font file format *)
ENOSTR* = 60; (* Device not a stream *)
ENODATA* = 61; (* No data available *)
ETIME* = 62; (* Timer expired *)
ENOSR* = 63; (* Out of streams resources *)
ENONET* = 64; (* Machine is not on the network *)
ENOPKG* = 65; (* Package not installed *)
EREMOTE* = 66; (* Object is remote *)
ENOLINK* = 67; (* Link has been severed *)
EADV* = 68; (* Advertise error *)
ESRMNT* = 69; (* Srmount error *)
ECOMM* = 70; (* Communication error on send *)
EPROTO* = 71; (* Protocol error *)
EMULTIHOP* = 72; (* Multihop attempted *)
EDOTDOT* = 73; (* RFS specific error *)
EBADMSG* = 74; (* Not a data message *)
EOVERFLOW* = 75; (* Value too large for defined data type *)
ENOTUNIQ* = 76; (* Name not unique on network *)
EBADFD* = 77; (* File descriptor in bad state *)
EREMCHG* = 78; (* Remote address changed *)
ELIBACC* = 79; (* Can not access a needed shared library *)
ELIBBAD* = 80; (* Accessing a corrupted shared library *)
ELIBSCN* = 81; (* .lib section in a.out corrupted *)
ELIBMAX* = 82; (* Attempting to link in too many shared libraries *)
ELIBEXEC* = 83; (* Cannot exec a shared library directly *)
EILSEQ* = 84; (* Illegal byte sequence *)
ERESTART* = 85; (* Interrupted system call should be restarted *)
ESTRPIPE* = 86; (* Streams pipe error *)
EUSERS* = 87; (* Too many users *)
ENOTSOCK* = 88; (* Socket operation on non-socket *)
EDESTADDRREQ* = 89; (* Destination address required *)
EMSGSIZE* = 90; (* Message too long *)
EPROTOTYPE* = 91; (* Protocol wrong type for socket *)
ENOPROTOOPT* = 92; (* Protocol not available *)
EPROTONOSUPPORT* = 93; (* Protocol not supported *)
ESOCKTNOSUPPORT* = 94; (* Socket type not supported *)
EOPNOTSUPP* = 95; (* Operation not supported on transport endpoint *)
EPFNOSUPPORT* = 96; (* Protocol family not supported *)
EAFNOSUPPORT* = 97; (* Address family not supported by protocol *)
EADDRINUSE* = 98; (* Address already in use *)
EADDRNOTAVAIL* = 99; (* Cannot assign requested address *)
ENETDOWN* = 100; (* Network is down *)
ENETUNREACH* = 101; (* Network is unreachable *)
ENETRESET* = 102; (* Network dropped connection because of reset *)
ECONNABORTED* = 103; (* Software caused connection abort *)
ECONNRESET* = 104; (* Connection reset by peer *)
ENOBUFS* = 105; (* No buffer space available *)
EISCONN* = 106; (* Transport endpoint is already connected *)
ENOTCONN* = 107; (* Transport endpoint is not connected *)
ESHUTDOWN* = 108; (* Cannot send after transport endpoint shutdown *)
ETOOMANYREFS* = 109; (* Too many references: cannot splice *)
ETIMEDOUT* = 110; (* Connection timed out *)
ECONNREFUSED* = 111; (* Connection refused *)
EHOSTDOWN* = 112; (* Host is down *)
EHOSTUNREACH* = 113; (* No route to host *)
EALREADY* = 114; (* Operation already in progress *)
EINPROGRESS* = 115; (* Operation now in progress *)
ESTALE* = 116; (* Stale NFS file handle *)
EUCLEAN* = 117; (* Structure needs cleaning *)
ENOTNAM* = 118; (* Not a XENIX named type file *)
ENAVAIL* = 119; (* No XENIX semaphores available *)
EISNAM* = 120; (* Is a named type file *)
EREMOTEIO* = 121; (* Remote I/O error *)
EDQUOT* = 122; (* Quota exceeded *)
TYPE
JmpBuf* = RECORD
bx*, si*, di*, bp*, sp*, pc*: LONGINT;
maskWasSaved*, savedMask*: LONGINT;
END ;
Status* = RECORD (* struct stat *)
dev*, devX*: LONGINT; (* 64 bit in Linux 2.2 *)
pad1: INTEGER;
ino*, mode*, nlink*, uid*, gid*: LONGINT;
rdev*, rdevX*: LONGINT; (* 64 bit in Linux 2.2 *)
pad2: INTEGER;
size*, blksize*, blocks*, atime*, unused1*, mtime*, unused2*, ctime*,
unused3*, unused4*, unused5*: LONGINT;
END ;
Timeval* = RECORD
sec*, usec*: LONGINT
END ;
Timezone* = RECORD
minuteswest*, dsttime*: LONGINT
END ;
Itimerval* = RECORD
interval*, value*: Timeval
END ;
FdSet* = ARRAY 8 OF SET;
SigCtxPtr* = POINTER TO SigContext;
SigContext* = RECORD
END ;
SignalHandler* = PROCEDURE (sig, code: LONGINT; scp: SigCtxPtr);
Dirent* = RECORD
ino, off: LONGINT;
reclen: INTEGER;
name: ARRAY 256 OF CHAR;
END ;
Rusage* = RECORD
utime*, stime*: Timeval;
maxrss*, ixrss*, idrss*, isrss*,
minflt*, majflt*, nswap*, inblock*,
oublock*, msgsnd*, msgrcv*, nsignals*,
nvcsw*, nivcsw*: LONGINT
END ;
Iovec* = RECORD
base*, len*: LONGINT
END ;
SocketPair* = ARRAY 2 OF LONGINT;
Pollfd* = RECORD
fd*: LONGINT;
events*, revents*: INTEGER
END ;
Sockaddr* = RECORD
family*: INTEGER;
port*: INTEGER;
internetAddr*: LONGINT;
pad*: ARRAY 8 OF CHAR;
END ;
HostEntry* = POINTER [1] TO Hostent;
Hostent* = RECORD
name*, aliases*: LONGINT;
addrtype*, length*: LONGINT;
addrlist*: LONGINT; (*POINTER TO POINTER TO LONGINT, network byte order*)
END;
Name* = ARRAY OF CHAR;
PROCEDURE -includeStat()
"#include <sys/stat.h>";
PROCEDURE -includeErrno()
"#include <errno.h>";
PROCEDURE -err(): LONGINT
"errno";
PROCEDURE errno*(): LONGINT;
BEGIN
RETURN err()
END errno;
PROCEDURE -Exit*(n: LONGINT)
"exit(n)";
PROCEDURE -Fork*(): LONGINT
"fork()";
PROCEDURE -Wait*(VAR status: LONGINT): LONGINT
"wait(status)";
PROCEDURE -Select*(width: LONGINT; VAR readfds, writefds, exceptfds: FdSet; VAR timeout: Timeval): LONGINT
"select(width, readfds, writefds, exceptfds, timeout)";
PROCEDURE -Gettimeofday* (VAR tv: Timeval; VAR tz: Timezone)
"gettimeofday(tv, tz)";
PROCEDURE -Read* (fd, buf, nbyte: LONGINT): LONGINT
"read(fd, buf, nbyte)";
PROCEDURE -ReadBlk* (fd: LONGINT; VAR buf: ARRAY OF SYSTEM.BYTE): LONGINT
"read(fd, buf, buf__len)";
PROCEDURE -Write* (fd, buf, nbyte: LONGINT): LONGINT
"write(fd, buf, nbyte)";
PROCEDURE -WriteBlk* (fd: LONGINT; VAR buf: ARRAY OF SYSTEM.BYTE): LONGINT
"write(fd, buf, buf__len)";
PROCEDURE -Dup*(fd: LONGINT): LONGINT
"dup(fd)";
PROCEDURE -Dup2*(fd1, fd2: LONGINT): LONGINT
"dup(fd1, fd2)";
PROCEDURE -Getpid*(): LONGINT
"getpid()";
PROCEDURE -Getuid*(): LONGINT
"getuid()";
PROCEDURE -Geteuid*(): LONGINT
"geteuid()";
PROCEDURE -Getgid*(): LONGINT
"getgid()";
PROCEDURE -Getegid*(): LONGINT
"getegid()";
PROCEDURE -Unlink*(name: Name): LONGINT
"unlink(name)";
PROCEDURE -Open*(name: Name; flag, mode: SET): LONGINT
"open(name, flag, mode)";
PROCEDURE -Close*(fd: LONGINT): LONGINT
"close(fd)";
PROCEDURE -stat(name: Name; VAR statbuf: Status): LONGINT
"stat((const char*)name, (struct stat*)statbuf)";
PROCEDURE Stat*(name: Name; VAR statbuf: Status): LONGINT;
VAR res: LONGINT;
BEGIN
res := stat(name, statbuf);
(* make the first 4 bytes as unique as possible (used in module Files for caching!) *)
INC(statbuf.dev, statbuf.devX);
INC(statbuf.rdev, statbuf.rdevX);
RETURN res;
END Stat;
PROCEDURE -fstat(fd: LONGINT; VAR statbuf: Status): LONGINT
"fstat(fd, (struct stat*)statbuf)";
PROCEDURE Fstat*(fd: LONGINT; VAR statbuf: Status): LONGINT;
VAR res: LONGINT;
BEGIN
res := fstat(fd, statbuf);
(* make the first 4 bytes as unique as possible (used in module Files for caching!) *)
INC(statbuf.dev, statbuf.devX);
INC(statbuf.rdev, statbuf.rdevX);
RETURN res;
END Fstat;
PROCEDURE -Fchmod*(fd, mode: LONGINT): LONGINT
"fchmod(fd, mode)";
PROCEDURE -Chmod*(path: Name; mode: LONGINT): LONGINT
"chmod(path, mode)";
PROCEDURE -Lseek*(fd, offset, origin: LONGINT): LONGINT
"lseek(fd, offset, origin)";
PROCEDURE -Fsync*(fd: LONGINT): LONGINT
"fsync(fd)";
PROCEDURE -Fcntl*(fd, cmd, arg: LONGINT ): LONGINT
"fcntl(fd, cmd, arg)";
PROCEDURE -Flock*(fd, operation: LONGINT): LONGINT
"flock(fd, operation)";
PROCEDURE -Ftruncate*(fd, length: LONGINT): LONGINT
"ftruncate(fd, length)";
PROCEDURE -Readblk*(fd: LONGINT; VAR buf: ARRAY OF SYSTEM.BYTE; len: LONGINT): LONGINT
"read(fd, buf, len)";
PROCEDURE -Rename*(old, new: Name): LONGINT
"rename(old, new)";
PROCEDURE -Chdir*(path: Name): LONGINT
"chdir(path)";
PROCEDURE -Ioctl*(fd, request, arg: LONGINT): LONGINT
"ioctl(fd, request, arg)";
PROCEDURE -Kill*(pid, sig: LONGINT): LONGINT
"kill(pid, sig)";
PROCEDURE -Sigsetmask*(mask: LONGINT): LONGINT
"sigsetmask(mask)";
(* TCP/IP networking *)
PROCEDURE -Gethostbyname*(name: Name): HostEntry
"(Unix_HostEntry)gethostbyname(name)";
PROCEDURE -Gethostname*(VAR name: Name): LONGINT
"gethostname(name, name__len)";
PROCEDURE -Socket*(af, type, protocol: LONGINT): LONGINT
"socket(af, type, protocol)";
PROCEDURE -Connect*(socket: LONGINT; name: Sockaddr; namelen: LONGINT): LONGINT
"connect(socket, &(name), namelen)";
PROCEDURE -Getsockname*(socket: LONGINT; VAR name: Sockaddr; VAR namelen: LONGINT): LONGINT
"getsockname(socket, name, namelen)";
PROCEDURE -Bind*(socket: LONGINT; name: Sockaddr; namelen: LONGINT): LONGINT
"bind(socket, &(name), namelen)";
PROCEDURE -Listen*(socket, backlog: LONGINT): LONGINT
"listen(socket, backlog)";
PROCEDURE -Accept*(socket: LONGINT; VAR addr: Sockaddr; VAR addrlen: LONGINT): LONGINT
"accept(socket, addr, addrlen)";
PROCEDURE -Recv*(socket, bufadr, buflen, flags: LONGINT): LONGINT
"recv(socket, bufadr, buflen, flags)";
PROCEDURE -Send*(socket, bufadr, buflen, flags: LONGINT): LONGINT
"send(socket, bufadr, buflen, flags)";
PROCEDURE -sys(str: ARRAY OF CHAR): INTEGER (* need this to call external tools like gcc or gas; noch *)
"system(str)";
PROCEDURE system*(cmd : ARRAY OF CHAR);
VAR r : INTEGER;
BEGIN
r := sys(cmd);
END system;
END Unix.

52
src/lib/system/gnuc/armv7a_hardfp/Args.Mod Normal file
View file

@ -0,0 +1,52 @@
MODULE Args; (* jt, 8.12.94 *)
(* command line argument handling for ofront *)
IMPORT SYSTEM;
TYPE
ArgPtr = POINTER TO ARRAY 1024 OF CHAR;
ArgVec = POINTER TO ARRAY 1024 OF ArgPtr;
VAR argc-, argv-: LONGINT;
PROCEDURE -Argc(): INTEGER "SYSTEM_argc";
PROCEDURE -Argv(): LONGINT "(long)SYSTEM_argv";
PROCEDURE -getenv(var: ARRAY OF CHAR): ArgPtr
"(Args_ArgPtr)getenv(var)";
PROCEDURE Get*(n: INTEGER; VAR val: ARRAY OF CHAR);
VAR av: ArgVec;
BEGIN
IF n < argc THEN av := SYSTEM.VAL(ArgVec, argv); COPY(av[n]^, val) END
END Get;
PROCEDURE GetInt*(n: INTEGER; VAR val: LONGINT);
VAR s: ARRAY 64 OF CHAR; k, d, i: LONGINT;
BEGIN
s := ""; Get(n, s); i := 0;
IF s[0] = "-" THEN i := 1 END ;
k := 0; d := ORD(s[i]) - ORD("0");
WHILE (d >= 0 ) & (d <= 9) DO k := k*10 + d; INC(i); d := ORD(s[i]) - ORD("0") END ;
IF s[0] = "-" THEN d := -d; DEC(i) END ;
IF i > 0 THEN val := k END
END GetInt;
PROCEDURE Pos*(s: ARRAY OF CHAR): INTEGER;
VAR i: INTEGER; arg: ARRAY 256 OF CHAR;
BEGIN
i := 0; Get(i, arg);
WHILE (i < argc) & (s # arg) DO INC(i); Get(i, arg) END ;
RETURN i
END Pos;
PROCEDURE GetEnv*(var: ARRAY OF CHAR; VAR val: ARRAY OF CHAR);
VAR p: ArgPtr;
BEGIN
p := getenv(var);
IF p # NIL THEN COPY(p^, val) END
END GetEnv;
BEGIN argc := Argc(); argv := Argv()
END Args.

205
src/lib/system/gnuc/armv7a_hardfp/SYSTEM.c0 Normal file
View file

@ -0,0 +1,205 @@
/*
* The body prefix file of the Ofront runtime system, Version 1.0
*
* Copyright (c) Software Templ, 1994, 1995
*
* Module SYSTEM is subject to change any time without prior notification.
* Software Templ disclaims all warranties with regard to module SYSTEM,
* in particular shall Software Templ not be liable for any damage resulting
* from inappropriate use or modification of module SYSTEM.
*
* Version 1.1 jt, 24.11.95 fixes for correct pointer arithmetic on Cray computers
* jt 31.1.2007 ANSI prototypes for malloc and exit in order to avoid cc warnings
*
*/
#include "SYSTEM.h"
#ifdef __STDC__
#include "stdarg.h"
#else
#include "varargs.h"
#endif
extern void *malloc(long size);
extern void exit(int status);
void (*SYSTEM_Halt)();
LONGINT SYSTEM_halt; /* x in HALT(x) */
LONGINT SYSTEM_assert; /* x in ASSERT(cond, x) */
LONGINT SYSTEM_argc;
LONGINT SYSTEM_argv;
LONGINT SYSTEM_lock;
BOOLEAN SYSTEM_interrupted;
static LONGINT SYSTEM_mainfrm; /* adr of main proc stack frame, used for stack collection */
#define Lock SYSTEM_lock++
#define Unlock SYSTEM_lock--; if (SYSTEM_interrupted && (SYSTEM_lock == 0)) __HALT(-9)
static void SYSTEM_InitHeap();
void *SYSTEM__init();
void SYSTEM_INIT(argc, argvadr)
int argc; long argvadr;
{
SYSTEM_mainfrm = argvadr;
SYSTEM_argc = argc;
SYSTEM_argv = *(long*)argvadr;
SYSTEM_InitHeap();
SYSTEM_halt = -128;
SYSTEM__init();
}
void SYSTEM_FINI()
{
SYSTEM_FINALL();
}
long SYSTEM_XCHK(i, ub) long i, ub; {return __X(i, ub);}
long SYSTEM_RCHK(i, ub) long i, ub; {return __R(i, ub);}
long SYSTEM_ASH(i, n) long i, n; {return __ASH(i, n);}
long SYSTEM_ABS(i) long i; {return __ABS(i);}
double SYSTEM_ABSD(i) double i; {return __ABS(i);}
void SYSTEM_INHERIT(t, t0)
long *t, *t0;
{
t -= __TPROC0OFF;
t0 -= __TPROC0OFF;
while (*t0 != __EOM) {*t = *t0; t--; t0--;}
}
void SYSTEM_ENUMP(adr, n, P)
long *adr;
long n;
void (*P)();
{
while (n > 0) {P(*adr); adr++; n--;}
}
void SYSTEM_ENUMR(adr, typ, size, n, P)
char *adr;
long *typ, size, n;
void (*P)();
{
long *t, off;
typ++;
while (n > 0) {
t = typ;
off = *t;
while (off >= 0) {P(*(long*)(adr+off)); t++; off = *t;}
adr += size; n--;
}
}
long SYSTEM_DIV(x, y)
unsigned long x, y;
{ if ((long) x >= 0) return (x / y);
else return -((y - 1 - x) / y);
}
long SYSTEM_MOD(x, y)
unsigned long x, y;
{ unsigned long m;
if ((long) x >= 0) return (x % y);
else { m = (-x) % y;
if (m != 0) return (y - m); else return 0;
}
}
long SYSTEM_ENTIER(x)
double x;
{
long y;
if (x >= 0)
return (long)x;
else {
y = (long)x;
if (y <= x) return y; else return y - 1;
}
}
void SYSTEM_HALT(n)
int n;
{
SYSTEM_halt = n;
if (SYSTEM_Halt!=0) SYSTEM_Halt(n);
exit(n);
}
#ifdef __STDC__
SYSTEM_PTR SYSTEM_NEWARR(long *typ, long elemsz, int elemalgn, int nofdim, int nofdyn, ...)
#else
SYSTEM_PTR SYSTEM_NEWARR(typ, elemsz, elemalgn, nofdim, nofdyn, va_alist)
long *typ, elemsz;
int elemalgn, nofdim, nofdyn;
va_dcl
#endif
{
long nofelems, size, dataoff, n, nptr, *x, *p, nofptrs, i, *ptab, off;
va_list ap;
#ifdef __STDC__
va_start(ap, nofdyn);
#else
va_start(ap);
#endif
nofelems = 1;
while (nofdim > 0) {
nofelems = nofelems * va_arg(ap, long); nofdim--;
if (nofelems <= 0) __HALT(-20);
}
va_end(ap);
dataoff = nofdyn * sizeof(long);
if (elemalgn > sizeof(long)) {
n = dataoff % elemalgn;
if (n != 0) dataoff += elemalgn - n;
}
size = dataoff + nofelems * elemsz;
Lock;
if (typ == NIL) {
/* element typ does not contain pointers */
x = SYSTEM_NEWBLK(size);
}
else if (typ == POINTER__typ) {
/* element type is a pointer */
x = SYSTEM_NEWBLK(size + nofelems * sizeof(long));
p = (long*)x[-1];
p[-nofelems] = *p; /* build new type desc in situ: 1. copy block size; 2. setup ptr tab; 3. set sentinel; 4. patch tag */
p -= nofelems - 1; n = 1; /* n =1 for skipping the size field */
while (n <= nofelems) {*p = n*sizeof(long); p++; n++;}
*p = - (nofelems + 1) * sizeof(long); /* sentinel */
x[-1] -= nofelems * sizeof(long);
}
else {
/* element type is a record that contains pointers */
ptab = typ + 1; nofptrs = 0;
while (ptab[nofptrs] >= 0) {nofptrs++;} /* number of pointers per element */
nptr = nofelems * nofptrs; /* total number of pointers */
x = SYSTEM_NEWBLK(size + nptr * sizeof(long));
p = (long*)x[- 1];
p[-nptr] = *p; /* build new type desc in situ; 1. copy block size; 2. setup ptr tab; 3. set sentinel; 4. patch tag */
p -= nptr - 1; n = 0; off = dataoff;
while (n < nofelems) {i = 0;
while (i < nofptrs) {*p = off + ptab[i]; p++; i++;}
off += elemsz; n++;
}
*p = - (nptr + 1) * sizeof(long); /* sentinel */
x[-1] -= nptr * sizeof(long);
}
if (nofdyn != 0) {
/* setup len vector for index checks */
#ifdef __STDC__
va_start(ap, nofdyn);
#else
va_start(ap);
#endif
p = x;
while (nofdyn > 0) {*p = va_arg(ap, long); p++, nofdyn--;}
va_end(ap);
}
Unlock;
return x;
}
/* ----------- end of SYSTEM.co ------------- */

215
src/lib/system/gnuc/armv7a_hardfp/SYSTEM.h Normal file
View file

@ -0,0 +1,215 @@
#ifndef SYSTEM__h
#define SYSTEM__h
/*
the Ofront runtime system interface and macros library
copyright (c) Josef Templ, 1995, 1996
gcc for Linux version (same as SPARC/Solaris2)
uses double # as concatenation operator
*/
#include <alloca.h>
//extern void *memcpy(void *dest, const void *src, long n);
extern void *memcpy(void *dest, const void *src, size_t n);
extern void *malloc(long size);
extern void exit(int status);
#define export
#define import extern
/* constants */
#define __MAXEXT 16
#define NIL 0L
#define POINTER__typ (long*)1L /* not NIL and not a valid type */
/* basic types */
typedef char BOOLEAN;
typedef unsigned char CHAR;
typedef signed char SHORTINT;
typedef short int INTEGER;
typedef long LONGINT;
typedef float REAL;
typedef double LONGREAL;
typedef unsigned long SET;
typedef void *SYSTEM_PTR;
typedef unsigned char SYSTEM_BYTE;
/* runtime system routines */
extern long SYSTEM_DIV();
extern long SYSTEM_MOD();
extern long SYSTEM_ENTIER();
extern long SYSTEM_ASH();
extern long SYSTEM_ABS();
extern long SYSTEM_XCHK();
extern long SYSTEM_RCHK();
extern double SYSTEM_ABSD();
extern SYSTEM_PTR SYSTEM_NEWREC();
extern SYSTEM_PTR SYSTEM_NEWBLK();
#ifdef __STDC__
extern SYSTEM_PTR SYSTEM_NEWARR(long*, long, int, int, int, ...);
#else
extern SYSTEM_PTR SYSTEM_NEWARR();
#endif
extern SYSTEM_PTR SYSTEM_REGMOD();
extern void SYSTEM_INCREF();
extern void SYSTEM_REGCMD();
extern void SYSTEM_REGTYP();
extern void SYSTEM_REGFIN();
extern void SYSTEM_FINALL();
extern void SYSTEM_INIT();
extern void SYSTEM_FINI();
extern void SYSTEM_HALT();
extern void SYSTEM_INHERIT();
extern void SYSTEM_ENUMP();
extern void SYSTEM_ENUMR();
/* module registry */
#define __DEFMOD static void *m; if(m!=0)return m
#define __REGMOD(name, enum) if(m==0)m=SYSTEM_REGMOD((CHAR*)name,enum); else return m
#define __ENDMOD return m
#define __INIT(argc, argv) static void *m; SYSTEM_INIT(argc, (long)&argv);
#define __REGMAIN(name, enum) m=SYSTEM_REGMOD(name,enum)
#define __FINI SYSTEM_FINI(); return 0
#define __IMPORT(name) SYSTEM_INCREF(name##__init())
#define __REGCMD(name, cmd) SYSTEM_REGCMD(m, name, cmd)
/* SYSTEM ops */
#define __SYSNEW(p, len) p=SYSTEM_NEWBLK((long)(len))
#define __VAL(t, x) (*(t*)&(x))
#define __GET(a, x, t) x= *(t*)(a)
#define __PUT(a, x, t) *(t*)(a)=x
#define __LSHL(x, n, t) ((t)((unsigned)(x)<<(n)))
#define __LSHR(x, n, t) ((t)((unsigned)(x)>>(n)))
#define __LSH(x, n, t) ((n)>=0? __LSHL(x, n, t): __LSHR(x, -(n), t))
#define __ROTL(x, n, t) ((t)((unsigned)(x)<<(n)|(unsigned)(x)>>(8*sizeof(t)-(n))))
#define __ROTR(x, n, t) ((t)((unsigned)(x)>>(n)|(unsigned)(x)<<(8*sizeof(t)-(n))))
#define __ROT(x, n, t) ((n)>=0? __ROTL(x, n, t): __ROTR(x, -(n), t))
#define __BIT(x, n) (*(unsigned long*)(x)>>(n)&1)
#define __MOVE(s, d, n) memcpy((char*)(d),(char*)(s),n)
/* std procs and operator mappings */
#define __SHORT(x, y) ((int)((unsigned long)(x)+(y)<(y)+(y)?(x):(__HALT(-8),0)))
#define __SHORTF(x, y) ((int)(__RF((x)+(y),(y)+(y))-(y)))
#define __CHR(x) ((CHAR)__R(x, 256))
#define __CHRF(x) ((CHAR)__RF(x, 256))
#define __DIV(x, y) ((x)>=0?(x)/(y):-(((y)-1-(x))/(y)))
#define __DIVF(x, y) SYSTEM_DIV((long)(x),(long)(y))
#define __MOD(x, y) ((x)>=0?(x)%(y):__MODF(x,y))
#define __MODF(x, y) SYSTEM_MOD((long)(x),(long)(y))
#define __NEW(p, t) p=SYSTEM_NEWREC((long)t##__typ)
#define __NEWARR SYSTEM_NEWARR
#define __HALT(x) SYSTEM_HALT(x)
#define __ASSERT(cond, x) if (!(cond)) {SYSTEM_assert = x; SYSTEM_HALT(-1);}
#define __ENTIER(x) SYSTEM_ENTIER(x)
#define __ABS(x) (((x)<0)?-(x):(x))
#define __ABSF(x) SYSTEM_ABS((long)(x))
#define __ABSFD(x) SYSTEM_ABSD((double)(x))
#define __CAP(ch) ((CHAR)((ch)&0x5f))
#define __ODD(x) ((x)&1)
#define __IN(x, s) (((s)>>(x))&1)
#define __SETOF(x) ((SET)1<<(x))
#define __SETRNG(l, h) ((~(SET)0<<(l))&~(SET)0>>(8*sizeof(SET)-1-(h)))
#define __MASK(x, m) ((x)&~(m))
#define __COPY(s, d, n) {char*_a=(void*)s,*_b=(void*)d;long _i=0,_t=n-1;while(_i<_t&&((_b[_i]=_a[_i])!=0)){_i++;};_b[_i]=0;}
static int __STRCMP(x, y)
CHAR *x, *y;
{long i = 0; CHAR ch1, ch2;
do {ch1 = x[i]; ch2 = y[i]; i++;
if (!ch1) return -(int)ch2;
} while (ch1==ch2);
return (int)ch1 - (int)ch2;
}
#define __ASH(x, n) ((n)>=0?__ASHL(x,n):__ASHR(x,-(n)))
#define __ASHL(x, n) ((long)(x)<<(n))
#define __ASHR(x, n) ((long)(x)>>(n))
#define __ASHF(x, n) SYSTEM_ASH((long)(x), (long)(n))
#define __DUP(x, l, t) x=(void*)memcpy(alloca(l*sizeof(t)),x,l*sizeof(t))
#define __DUPARR(v, t) v=(void*)memcpy(v##__copy,v,sizeof(t))
#define __DEL(x) /* DUP with alloca frees storage automatically */
#define __IS(tag, typ, level) (*(tag-(__BASEOFF-level))==(long)typ##__typ)
#define __TYPEOF(p) (*(((long**)(p))-1))
#define __ISP(p, typ, level) __IS(__TYPEOF(p),typ,level)
/* runtime checks */
#define __X(i, ub) (((unsigned)(long)(i)<(unsigned long)(ub))?i:(__HALT(-2),0))
#define __XF(i, ub) SYSTEM_XCHK((long)(i), (long)(ub))
#define __RETCHK __retchk: __HALT(-3)
#define __CASECHK __HALT(-4)
#define __GUARDP(p, typ, level) ((typ*)(__ISP(p,typ,level)?p:(__HALT(-5),p)))
#define __GUARDR(r, typ, level) (*((typ*)(__IS(r##__typ,typ,level)?r:(__HALT(-5),r))))
#define __GUARDA(p, typ, level) ((struct typ*)(__IS(__TYPEOF(p),typ,level)?p:(__HALT(-5),p)))
#define __GUARDEQR(p, dyntyp, typ) if(dyntyp!=typ##__typ) __HALT(-6);*(p)
#define __GUARDEQP(p, typ) if(__TYPEOF(p)!=typ##__typ)__HALT(-6);*(p)
#define __WITHCHK __HALT(-7)
#define __R(i, ub) (((unsigned)(long)(i)<(unsigned long)(ub))?i:(__HALT(-8),0))
#define __RF(i, ub) SYSTEM_RCHK((long)(i),(long)(ub))
/* record type descriptors */
#define __TDESC(t, m, n) \
static struct t##__desc {\
long tproc[m]; \
long tag, next, level, module; \
char name[24]; \
long *base[__MAXEXT]; \
char *rsrvd; \
long blksz, ptr[n+1]; \
} t##__desc
#define __BASEOFF (__MAXEXT+1)
#define __TPROC0OFF (__BASEOFF+24/sizeof(long)+5)
#define __EOM 1
#define __TDFLDS(name, size) {__EOM}, 1, 0, 0, 0, name, {0}, 0, size
#define __ENUMP(adr, n, P) SYSTEM_ENUMP(adr, (long)(n), P)
#define __ENUMR(adr, typ, size, n, P) SYSTEM_ENUMR(adr, typ, (long)(size), (long)(n), P)
#define __INITYP(t, t0, level) \
t##__typ= &t##__desc.blksz; \
memcpy(t##__desc.base, t0##__typ - __BASEOFF, level*sizeof(long)); \
t##__desc.base[level]=t##__typ; \
t##__desc.module=(long)m; \
if(t##__desc.blksz!=sizeof(struct t)) __HALT(-15); \
t##__desc.blksz=(t##__desc.blksz+5*sizeof(long)-1)/(4*sizeof(long))*(4*sizeof(long)); \
SYSTEM_REGTYP(m, (long)&t##__desc.next); \
SYSTEM_INHERIT(t##__typ, t0##__typ)
/* Oberon-2 type bound procedures support */
#define __INITBP(t, proc, num) *(t##__typ-(__TPROC0OFF+num))=(long)proc
#define __SEND(typ, num, funtyp, parlist) ((funtyp)(*(typ-(__TPROC0OFF+num))))parlist
/* runtime system variables */
extern LONGINT SYSTEM_argc;
extern LONGINT SYSTEM_argv;
extern void (*SYSTEM_Halt)();
extern LONGINT SYSTEM_halt;
extern LONGINT SYSTEM_assert;
extern SYSTEM_PTR SYSTEM_modules;
extern LONGINT SYSTEM_heapsize;
extern LONGINT SYSTEM_allocated;
extern LONGINT SYSTEM_lock;
extern SHORTINT SYSTEM_gclock;
extern BOOLEAN SYSTEM_interrupted;
/* ANSI prototypes; not used so far
static int __STRCMP(CHAR *x, CHAR *y);
void SYSTEM_INIT(int argc, long argvadr);
void SYSTEM_FINI(void);
long SYSTEM_XCHK(long i, long ub);
long SYSTEM_RCHK(long i, long ub);
long SYSTEM_ASH(long i, long n);
long SYSTEM_ABS(long i);
double SYSTEM_ABSD(double i);
void SYSTEM_INHERIT(long *t, long *t0);
void SYSTEM_ENUMP(long *adr, long n, void (*P)(void*));
void SYSTEM_ENUMR(char *adr, long *typ, long size, long n, void (*P)(void*));
long SYSTEM_DIV(unsigned long x, unsigned long y);
long SYSTEM_MOD(unsigned long x, unsigned long y);
long SYSTEM_ENTIER(double x);
void SYSTEM_HALT(int n);
*/
#endif

411
src/lib/system/gnuc/armv7a_hardfp/Unix.Mod Normal file
View file

@ -0,0 +1,411 @@
MODULE Unix; (* Josef Templ, 5.3.90 Linux system calls *)
(* system procedure added by noch *)
(* Module Unix provides a system call interface to Linux.
Naming conventions:
Procedure and Type-names always start with a capital letter.
error numbers as defined in Unix
other constants start with lower case letters *)
IMPORT SYSTEM;
CONST
(* various important constants *)
stdin* = 0; stdout* =1; stderr* = 2;
LOCKEX* = 2; LOCKUN* = 8; (* /usr/include/file.h *)
AFINET* = 2; (* /usr/include/sys/socket.h *)
PFINET* = AFINET; (* /usr/include/linux/socket.h *)
SOCKSTREAM* = 1; (* /usr/include/linux/socket.h *)
FIONREAD* = 541BH; (* in /usr/include/asm/termios.h *)
SETFL* = 4; (* set file descriptor flags; in asm/fcntl.h *)
TCP* = 0;
(* flag sets, cf. /usr/include/asm/fcntl.h *)
rdonly* = {}; wronly* = {0}; rdwr* = {1}; creat* = {6}; excl* = {7}; trunc* = {9}; append* = {10}; ndelay = {11};
(* error numbers *)
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 children *)
EAGAIN* = 11; (* No more processes *)
ENOMEM* = 12; (* Not enough core *)
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; (* Argument too large *)
ERANGE* = 34; (* Result too large *)
EDEADLK* = 35; (* Resource deadlock would occur *)
ENAMETOOLONG* = 36; (* File name too long *)
ENOLCK* = 37; (* No record locks available *)
ENOSYS* = 38; (* Function not implemented *)
ENOTEMPTY* = 39; (* Directory not empty *)
ELOOP* = 40; (* Too many symbolic links encountered *)
EWOULDBLOCK* = EAGAIN; (* Operation would block *)
ENOMSG* = 42; (* No message of desired type *)
EIDRM* = 43; (* Identifier removed *)
ECHRNG* = 44; (* Channel number out of range *)
EL2NSYNC* = 45; (* Level 2 not synchronized *)
EL3HLT* = 46; (* Level 3 halted *)
EL3RST* = 47; (* Level 3 reset *)
ELNRNG* = 48; (* Link number out of range *)
EUNATCH* = 49; (* Protocol driver not attached *)
ENOCSI* = 50; (* No CSI structure available *)
EL2HLT* = 51; (* Level 2 halted *)
EBADE* = 52; (* Invalid exchange *)
EBADR* = 53; (* Invalid request descriptor *)
EXFULL* = 54; (* Exchange full *)
ENOANO* = 55; (* No anode *)
EBADRQC* = 56; (* Invalid request code *)
EBADSLT* = 57; (* Invalid slot *)
EDEADLOCK* = 58; (* File locking deadlock error *)
EBFONT* = 59; (* Bad font file format *)
ENOSTR* = 60; (* Device not a stream *)
ENODATA* = 61; (* No data available *)
ETIME* = 62; (* Timer expired *)
ENOSR* = 63; (* Out of streams resources *)
ENONET* = 64; (* Machine is not on the network *)
ENOPKG* = 65; (* Package not installed *)
EREMOTE* = 66; (* Object is remote *)
ENOLINK* = 67; (* Link has been severed *)
EADV* = 68; (* Advertise error *)
ESRMNT* = 69; (* Srmount error *)
ECOMM* = 70; (* Communication error on send *)
EPROTO* = 71; (* Protocol error *)
EMULTIHOP* = 72; (* Multihop attempted *)
EDOTDOT* = 73; (* RFS specific error *)
EBADMSG* = 74; (* Not a data message *)
EOVERFLOW* = 75; (* Value too large for defined data type *)
ENOTUNIQ* = 76; (* Name not unique on network *)
EBADFD* = 77; (* File descriptor in bad state *)
EREMCHG* = 78; (* Remote address changed *)
ELIBACC* = 79; (* Can not access a needed shared library *)
ELIBBAD* = 80; (* Accessing a corrupted shared library *)
ELIBSCN* = 81; (* .lib section in a.out corrupted *)
ELIBMAX* = 82; (* Attempting to link in too many shared libraries *)
ELIBEXEC* = 83; (* Cannot exec a shared library directly *)
EILSEQ* = 84; (* Illegal byte sequence *)
ERESTART* = 85; (* Interrupted system call should be restarted *)
ESTRPIPE* = 86; (* Streams pipe error *)
EUSERS* = 87; (* Too many users *)
ENOTSOCK* = 88; (* Socket operation on non-socket *)
EDESTADDRREQ* = 89; (* Destination address required *)
EMSGSIZE* = 90; (* Message too long *)
EPROTOTYPE* = 91; (* Protocol wrong type for socket *)
ENOPROTOOPT* = 92; (* Protocol not available *)
EPROTONOSUPPORT* = 93; (* Protocol not supported *)
ESOCKTNOSUPPORT* = 94; (* Socket type not supported *)
EOPNOTSUPP* = 95; (* Operation not supported on transport endpoint *)
EPFNOSUPPORT* = 96; (* Protocol family not supported *)
EAFNOSUPPORT* = 97; (* Address family not supported by protocol *)
EADDRINUSE* = 98; (* Address already in use *)
EADDRNOTAVAIL* = 99; (* Cannot assign requested address *)
ENETDOWN* = 100; (* Network is down *)
ENETUNREACH* = 101; (* Network is unreachable *)
ENETRESET* = 102; (* Network dropped connection because of reset *)
ECONNABORTED* = 103; (* Software caused connection abort *)
ECONNRESET* = 104; (* Connection reset by peer *)
ENOBUFS* = 105; (* No buffer space available *)
EISCONN* = 106; (* Transport endpoint is already connected *)
ENOTCONN* = 107; (* Transport endpoint is not connected *)
ESHUTDOWN* = 108; (* Cannot send after transport endpoint shutdown *)
ETOOMANYREFS* = 109; (* Too many references: cannot splice *)
ETIMEDOUT* = 110; (* Connection timed out *)
ECONNREFUSED* = 111; (* Connection refused *)
EHOSTDOWN* = 112; (* Host is down *)
EHOSTUNREACH* = 113; (* No route to host *)
EALREADY* = 114; (* Operation already in progress *)
EINPROGRESS* = 115; (* Operation now in progress *)
ESTALE* = 116; (* Stale NFS file handle *)
EUCLEAN* = 117; (* Structure needs cleaning *)
ENOTNAM* = 118; (* Not a XENIX named type file *)
ENAVAIL* = 119; (* No XENIX semaphores available *)
EISNAM* = 120; (* Is a named type file *)
EREMOTEIO* = 121; (* Remote I/O error *)
EDQUOT* = 122; (* Quota exceeded *)
TYPE
JmpBuf* = RECORD
bx*, si*, di*, bp*, sp*, pc*: LONGINT;
maskWasSaved*, savedMask*: LONGINT;
END ;
Status* = RECORD (* struct stat *)
dev*, devX*: LONGINT; (* 64 bit in Linux 2.2 *)
pad1: INTEGER;
ino*, mode*, nlink*, uid*, gid*: LONGINT;
rdev*, rdevX*: LONGINT; (* 64 bit in Linux 2.2 *)
pad2: INTEGER;
size*, blksize*, blocks*, atime*, unused1*, mtime*, unused2*, ctime*,
unused3*, unused4*, unused5*: LONGINT;
END ;
Timeval* = RECORD
sec*, usec*: LONGINT
END ;
Timezone* = RECORD
minuteswest*, dsttime*: LONGINT
END ;
Itimerval* = RECORD
interval*, value*: Timeval
END ;
FdSet* = ARRAY 8 OF SET;
SigCtxPtr* = POINTER TO SigContext;
SigContext* = RECORD
END ;
SignalHandler* = PROCEDURE (sig, code: LONGINT; scp: SigCtxPtr);
Dirent* = RECORD
ino, off: LONGINT;
reclen: INTEGER;
name: ARRAY 256 OF CHAR;
END ;
Rusage* = RECORD
utime*, stime*: Timeval;
maxrss*, ixrss*, idrss*, isrss*,
minflt*, majflt*, nswap*, inblock*,
oublock*, msgsnd*, msgrcv*, nsignals*,
nvcsw*, nivcsw*: LONGINT
END ;
Iovec* = RECORD
base*, len*: LONGINT
END ;
SocketPair* = ARRAY 2 OF LONGINT;
Pollfd* = RECORD
fd*: LONGINT;
events*, revents*: INTEGER
END ;
Sockaddr* = RECORD
family*: INTEGER;
port*: INTEGER;
internetAddr*: LONGINT;
pad*: ARRAY 8 OF CHAR;
END ;
HostEntry* = POINTER [1] TO Hostent;
Hostent* = RECORD
name*, aliases*: LONGINT;
addrtype*, length*: LONGINT;
addrlist*: LONGINT; (*POINTER TO POINTER TO LONGINT, network byte order*)
END;
Name* = ARRAY OF CHAR;
PROCEDURE -includeStat()
"#include <sys/stat.h>";
PROCEDURE -includeErrno()
"#include <errno.h>";
PROCEDURE -err(): LONGINT
"errno";
PROCEDURE errno*(): LONGINT;
BEGIN
RETURN err()
END errno;
PROCEDURE -Exit*(n: LONGINT)
"exit(n)";
PROCEDURE -Fork*(): LONGINT
"fork()";
PROCEDURE -Wait*(VAR status: LONGINT): LONGINT
"wait(status)";
PROCEDURE -Select*(width: LONGINT; VAR readfds, writefds, exceptfds: FdSet; VAR timeout: Timeval): LONGINT
"select(width, readfds, writefds, exceptfds, timeout)";
PROCEDURE -Gettimeofday* (VAR tv: Timeval; VAR tz: Timezone)
"gettimeofday(tv, tz)";
PROCEDURE -Read* (fd, buf, nbyte: LONGINT): LONGINT
"read(fd, buf, nbyte)";
PROCEDURE -ReadBlk* (fd: LONGINT; VAR buf: ARRAY OF SYSTEM.BYTE): LONGINT
"read(fd, buf, buf__len)";
PROCEDURE -Write* (fd, buf, nbyte: LONGINT): LONGINT
"write(fd, buf, nbyte)";
PROCEDURE -WriteBlk* (fd: LONGINT; VAR buf: ARRAY OF SYSTEM.BYTE): LONGINT
"write(fd, buf, buf__len)";
PROCEDURE -Dup*(fd: LONGINT): LONGINT
"dup(fd)";
PROCEDURE -Dup2*(fd1, fd2: LONGINT): LONGINT
"dup(fd1, fd2)";
PROCEDURE -Getpid*(): LONGINT
"getpid()";
PROCEDURE -Getuid*(): LONGINT
"getuid()";
PROCEDURE -Geteuid*(): LONGINT
"geteuid()";
PROCEDURE -Getgid*(): LONGINT
"getgid()";
PROCEDURE -Getegid*(): LONGINT
"getegid()";
PROCEDURE -Unlink*(name: Name): LONGINT
"unlink(name)";
PROCEDURE -Open*(name: Name; flag, mode: SET): LONGINT
"open(name, flag, mode)";
PROCEDURE -Close*(fd: LONGINT): LONGINT
"close(fd)";
PROCEDURE -stat(name: Name; VAR statbuf: Status): LONGINT
"stat((const char*)name, (struct stat*)statbuf)";
PROCEDURE Stat*(name: Name; VAR statbuf: Status): LONGINT;
VAR res: LONGINT;
BEGIN
res := stat(name, statbuf);
(* make the first 4 bytes as unique as possible (used in module Files for caching!) *)
INC(statbuf.dev, statbuf.devX);
INC(statbuf.rdev, statbuf.rdevX);
RETURN res;
END Stat;
PROCEDURE -fstat(fd: LONGINT; VAR statbuf: Status): LONGINT
"fstat(fd, (struct stat*)statbuf)";
PROCEDURE Fstat*(fd: LONGINT; VAR statbuf: Status): LONGINT;
VAR res: LONGINT;
BEGIN
res := fstat(fd, statbuf);
(* make the first 4 bytes as unique as possible (used in module Files for caching!) *)
INC(statbuf.dev, statbuf.devX);
INC(statbuf.rdev, statbuf.rdevX);
RETURN res;
END Fstat;
PROCEDURE -Fchmod*(fd, mode: LONGINT): LONGINT
"fchmod(fd, mode)";
PROCEDURE -Chmod*(path: Name; mode: LONGINT): LONGINT
"chmod(path, mode)";
PROCEDURE -Lseek*(fd, offset, origin: LONGINT): LONGINT
"lseek(fd, offset, origin)";
PROCEDURE -Fsync*(fd: LONGINT): LONGINT
"fsync(fd)";
PROCEDURE -Fcntl*(fd, cmd, arg: LONGINT ): LONGINT
"fcntl(fd, cmd, arg)";
PROCEDURE -Flock*(fd, operation: LONGINT): LONGINT
"flock(fd, operation)";
PROCEDURE -Ftruncate*(fd, length: LONGINT): LONGINT
"ftruncate(fd, length)";
PROCEDURE -Readblk*(fd: LONGINT; VAR buf: ARRAY OF SYSTEM.BYTE; len: LONGINT): LONGINT
"read(fd, buf, len)";
PROCEDURE -Rename*(old, new: Name): LONGINT
"rename(old, new)";
PROCEDURE -Chdir*(path: Name): LONGINT
"chdir(path)";
PROCEDURE -Ioctl*(fd, request, arg: LONGINT): LONGINT
"ioctl(fd, request, arg)";
PROCEDURE -Kill*(pid, sig: LONGINT): LONGINT
"kill(pid, sig)";
PROCEDURE -Sigsetmask*(mask: LONGINT): LONGINT
"sigsetmask(mask)";
(* TCP/IP networking *)
PROCEDURE -Gethostbyname*(name: Name): HostEntry
"(Unix_HostEntry)gethostbyname(name)";
PROCEDURE -Gethostname*(VAR name: Name): LONGINT
"gethostname(name, name__len)";
PROCEDURE -Socket*(af, type, protocol: LONGINT): LONGINT
"socket(af, type, protocol)";
PROCEDURE -Connect*(socket: LONGINT; name: Sockaddr; namelen: LONGINT): LONGINT
"connect(socket, &(name), namelen)";
PROCEDURE -Getsockname*(socket: LONGINT; VAR name: Sockaddr; VAR namelen: LONGINT): LONGINT
"getsockname(socket, name, namelen)";
PROCEDURE -Bind*(socket: LONGINT; name: Sockaddr; namelen: LONGINT): LONGINT
"bind(socket, &(name), namelen)";
PROCEDURE -Listen*(socket, backlog: LONGINT): LONGINT
"listen(socket, backlog)";
PROCEDURE -Accept*(socket: LONGINT; VAR addr: Sockaddr; VAR addrlen: LONGINT): LONGINT
"accept(socket, addr, addrlen)";
PROCEDURE -Recv*(socket, bufadr, buflen, flags: LONGINT): LONGINT
"recv(socket, bufadr, buflen, flags)";
PROCEDURE -Send*(socket, bufadr, buflen, flags: LONGINT): LONGINT
"send(socket, bufadr, buflen, flags)";
PROCEDURE -sys(str: ARRAY OF CHAR): INTEGER (* need this to call external tools like gcc or gas; noch *)
"system(str)";
PROCEDURE system*(cmd : ARRAY OF CHAR);
VAR r : INTEGER;
BEGIN
r := sys(cmd);
END system;
END Unix.

52
src/lib/system/gnuc/x86/Args.Mod Normal file
View file

@ -0,0 +1,52 @@
MODULE Args; (* jt, 8.12.94 *)
(* command line argument handling for ofront *)
IMPORT SYSTEM;
TYPE
ArgPtr = POINTER TO ARRAY 1024 OF CHAR;
ArgVec = POINTER TO ARRAY 1024 OF ArgPtr;
VAR argc-, argv-: LONGINT;
PROCEDURE -Argc(): INTEGER "SYSTEM_argc";
PROCEDURE -Argv(): LONGINT "(long)SYSTEM_argv";
PROCEDURE -getenv(var: ARRAY OF CHAR): ArgPtr
"(Args_ArgPtr)getenv(var)";
PROCEDURE Get*(n: INTEGER; VAR val: ARRAY OF CHAR);
VAR av: ArgVec;
BEGIN
IF n < argc THEN av := SYSTEM.VAL(ArgVec, argv); COPY(av[n]^, val) END
END Get;
PROCEDURE GetInt*(n: INTEGER; VAR val: LONGINT);
VAR s: ARRAY 64 OF CHAR; k, d, i: LONGINT;
BEGIN
s := ""; Get(n, s); i := 0;
IF s[0] = "-" THEN i := 1 END ;
k := 0; d := ORD(s[i]) - ORD("0");
WHILE (d >= 0 ) & (d <= 9) DO k := k*10 + d; INC(i); d := ORD(s[i]) - ORD("0") END ;
IF s[0] = "-" THEN d := -d; DEC(i) END ;
IF i > 0 THEN val := k END
END GetInt;
PROCEDURE Pos*(s: ARRAY OF CHAR): INTEGER;
VAR i: INTEGER; arg: ARRAY 256 OF CHAR;
BEGIN
i := 0; Get(i, arg);
WHILE (i < argc) & (s # arg) DO INC(i); Get(i, arg) END ;
RETURN i
END Pos;
PROCEDURE GetEnv*(var: ARRAY OF CHAR; VAR val: ARRAY OF CHAR);
VAR p: ArgPtr;
BEGIN
p := getenv(var);
IF p # NIL THEN COPY(p^, val) END
END GetEnv;
BEGIN argc := Argc(); argv := Argv()
END Args.

205
src/lib/system/gnuc/x86/SYSTEM.c0 Normal file
View file

@ -0,0 +1,205 @@
/*
* The body prefix file of the Ofront runtime system, Version 1.0
*
* Copyright (c) Software Templ, 1994, 1995
*
* Module SYSTEM is subject to change any time without prior notification.
* Software Templ disclaims all warranties with regard to module SYSTEM,
* in particular shall Software Templ not be liable for any damage resulting
* from inappropriate use or modification of module SYSTEM.
*
* Version 1.1 jt, 24.11.95 fixes for correct pointer arithmetic on Cray computers
* jt 31.1.2007 ANSI prototypes for malloc and exit in order to avoid cc warnings
*
*/
#include "SYSTEM.h"
#ifdef __STDC__
#include "stdarg.h"
#else
#include "varargs.h"
#endif
extern void *malloc(long size);
extern void exit(int status);
void (*SYSTEM_Halt)();
LONGINT SYSTEM_halt; /* x in HALT(x) */
LONGINT SYSTEM_assert; /* x in ASSERT(cond, x) */
LONGINT SYSTEM_argc;
LONGINT SYSTEM_argv;
LONGINT SYSTEM_lock;
BOOLEAN SYSTEM_interrupted;
static LONGINT SYSTEM_mainfrm; /* adr of main proc stack frame, used for stack collection */
#define Lock SYSTEM_lock++
#define Unlock SYSTEM_lock--; if (SYSTEM_interrupted && (SYSTEM_lock == 0)) __HALT(-9)
static void SYSTEM_InitHeap();
void *SYSTEM__init();
void SYSTEM_INIT(argc, argvadr)
int argc; long argvadr;
{
SYSTEM_mainfrm = argvadr;
SYSTEM_argc = argc;
SYSTEM_argv = *(long*)argvadr;
SYSTEM_InitHeap();
SYSTEM_halt = -128;
SYSTEM__init();
}
void SYSTEM_FINI()
{
SYSTEM_FINALL();
}
long SYSTEM_XCHK(i, ub) long i, ub; {return __X(i, ub);}
long SYSTEM_RCHK(i, ub) long i, ub; {return __R(i, ub);}
long SYSTEM_ASH(i, n) long i, n; {return __ASH(i, n);}
long SYSTEM_ABS(i) long i; {return __ABS(i);}
double SYSTEM_ABSD(i) double i; {return __ABS(i);}
void SYSTEM_INHERIT(t, t0)
long *t, *t0;
{
t -= __TPROC0OFF;
t0 -= __TPROC0OFF;
while (*t0 != __EOM) {*t = *t0; t--; t0--;}
}
void SYSTEM_ENUMP(adr, n, P)
long *adr;
long n;
void (*P)();
{
while (n > 0) {P(*adr); adr++; n--;}
}
void SYSTEM_ENUMR(adr, typ, size, n, P)
char *adr;
long *typ, size, n;
void (*P)();
{
long *t, off;
typ++;
while (n > 0) {
t = typ;
off = *t;
while (off >= 0) {P(*(long*)(adr+off)); t++; off = *t;}
adr += size; n--;
}
}
long SYSTEM_DIV(x, y)
unsigned long x, y;
{ if ((long) x >= 0) return (x / y);
else return -((y - 1 - x) / y);
}
long SYSTEM_MOD(x, y)
unsigned long x, y;
{ unsigned long m;
if ((long) x >= 0) return (x % y);
else { m = (-x) % y;
if (m != 0) return (y - m); else return 0;
}
}
long SYSTEM_ENTIER(x)
double x;
{
long y;
if (x >= 0)
return (long)x;
else {
y = (long)x;
if (y <= x) return y; else return y - 1;
}
}
void SYSTEM_HALT(n)
int n;
{
SYSTEM_halt = n;
if (SYSTEM_Halt!=0) SYSTEM_Halt(n);
exit(n);
}
#ifdef __STDC__
SYSTEM_PTR SYSTEM_NEWARR(long *typ, long elemsz, int elemalgn, int nofdim, int nofdyn, ...)
#else
SYSTEM_PTR SYSTEM_NEWARR(typ, elemsz, elemalgn, nofdim, nofdyn, va_alist)
long *typ, elemsz;
int elemalgn, nofdim, nofdyn;
va_dcl
#endif
{
long nofelems, size, dataoff, n, nptr, *x, *p, nofptrs, i, *ptab, off;
va_list ap;
#ifdef __STDC__
va_start(ap, nofdyn);
#else
va_start(ap);
#endif
nofelems = 1;
while (nofdim > 0) {
nofelems = nofelems * va_arg(ap, long); nofdim--;
if (nofelems <= 0) __HALT(-20);
}
va_end(ap);
dataoff = nofdyn * sizeof(long);
if (elemalgn > sizeof(long)) {
n = dataoff % elemalgn;
if (n != 0) dataoff += elemalgn - n;
}
size = dataoff + nofelems * elemsz;
Lock;
if (typ == NIL) {
/* element typ does not contain pointers */
x = SYSTEM_NEWBLK(size);
}
else if (typ == POINTER__typ) {
/* element type is a pointer */
x = SYSTEM_NEWBLK(size + nofelems * sizeof(long));
p = (long*)x[-1];
p[-nofelems] = *p; /* build new type desc in situ: 1. copy block size; 2. setup ptr tab; 3. set sentinel; 4. patch tag */
p -= nofelems - 1; n = 1; /* n =1 for skipping the size field */
while (n <= nofelems) {*p = n*sizeof(long); p++; n++;}
*p = - (nofelems + 1) * sizeof(long); /* sentinel */
x[-1] -= nofelems * sizeof(long);
}
else {
/* element type is a record that contains pointers */
ptab = typ + 1; nofptrs = 0;
while (ptab[nofptrs] >= 0) {nofptrs++;} /* number of pointers per element */
nptr = nofelems * nofptrs; /* total number of pointers */
x = SYSTEM_NEWBLK(size + nptr * sizeof(long));
p = (long*)x[- 1];
p[-nptr] = *p; /* build new type desc in situ; 1. copy block size; 2. setup ptr tab; 3. set sentinel; 4. patch tag */
p -= nptr - 1; n = 0; off = dataoff;
while (n < nofelems) {i = 0;
while (i < nofptrs) {*p = off + ptab[i]; p++; i++;}
off += elemsz; n++;
}
*p = - (nptr + 1) * sizeof(long); /* sentinel */
x[-1] -= nptr * sizeof(long);
}
if (nofdyn != 0) {
/* setup len vector for index checks */
#ifdef __STDC__
va_start(ap, nofdyn);
#else
va_start(ap);
#endif
p = x;
while (nofdyn > 0) {*p = va_arg(ap, long); p++, nofdyn--;}
va_end(ap);
}
Unlock;
return x;
}
/* ----------- end of SYSTEM.co ------------- */

215
src/lib/system/gnuc/x86/SYSTEM.h Normal file
View file

@ -0,0 +1,215 @@
#ifndef SYSTEM__h
#define SYSTEM__h
/*
the Ofront runtime system interface and macros library
copyright (c) Josef Templ, 1995, 1996
gcc for Linux version (same as SPARC/Solaris2)
uses double # as concatenation operator
*/
#include <alloca.h>
//extern void *memcpy(void *dest, const void *src, long n);
extern void *memcpy(void *dest, const void *src, size_t n);
extern void *malloc(long size);
extern void exit(int status);
#define export
#define import extern
/* constants */
#define __MAXEXT 16
#define NIL 0L
#define POINTER__typ (long*)1L /* not NIL and not a valid type */
/* basic types */
typedef char BOOLEAN;
typedef unsigned char CHAR;
typedef signed char SHORTINT;
typedef short int INTEGER;
typedef long LONGINT;
typedef float REAL;
typedef double LONGREAL;
typedef unsigned long SET;
typedef void *SYSTEM_PTR;
typedef unsigned char SYSTEM_BYTE;
/* runtime system routines */
extern long SYSTEM_DIV();
extern long SYSTEM_MOD();
extern long SYSTEM_ENTIER();
extern long SYSTEM_ASH();
extern long SYSTEM_ABS();
extern long SYSTEM_XCHK();
extern long SYSTEM_RCHK();
extern double SYSTEM_ABSD();
extern SYSTEM_PTR SYSTEM_NEWREC();
extern SYSTEM_PTR SYSTEM_NEWBLK();
#ifdef __STDC__
extern SYSTEM_PTR SYSTEM_NEWARR(long*, long, int, int, int, ...);
#else
extern SYSTEM_PTR SYSTEM_NEWARR();
#endif
extern SYSTEM_PTR SYSTEM_REGMOD();
extern void SYSTEM_INCREF();
extern void SYSTEM_REGCMD();
extern void SYSTEM_REGTYP();
extern void SYSTEM_REGFIN();
extern void SYSTEM_FINALL();
extern void SYSTEM_INIT();
extern void SYSTEM_FINI();
extern void SYSTEM_HALT();
extern void SYSTEM_INHERIT();
extern void SYSTEM_ENUMP();
extern void SYSTEM_ENUMR();
/* module registry */
#define __DEFMOD static void *m; if(m!=0)return m
#define __REGMOD(name, enum) if(m==0)m=SYSTEM_REGMOD((CHAR*)name,enum); else return m
#define __ENDMOD return m
#define __INIT(argc, argv) static void *m; SYSTEM_INIT(argc, (long)&argv);
#define __REGMAIN(name, enum) m=SYSTEM_REGMOD(name,enum)
#define __FINI SYSTEM_FINI(); return 0
#define __IMPORT(name) SYSTEM_INCREF(name##__init())
#define __REGCMD(name, cmd) SYSTEM_REGCMD(m, name, cmd)
/* SYSTEM ops */
#define __SYSNEW(p, len) p=SYSTEM_NEWBLK((long)(len))
#define __VAL(t, x) (*(t*)&(x))
#define __GET(a, x, t) x= *(t*)(a)
#define __PUT(a, x, t) *(t*)(a)=x
#define __LSHL(x, n, t) ((t)((unsigned)(x)<<(n)))
#define __LSHR(x, n, t) ((t)((unsigned)(x)>>(n)))
#define __LSH(x, n, t) ((n)>=0? __LSHL(x, n, t): __LSHR(x, -(n), t))
#define __ROTL(x, n, t) ((t)((unsigned)(x)<<(n)|(unsigned)(x)>>(8*sizeof(t)-(n))))
#define __ROTR(x, n, t) ((t)((unsigned)(x)>>(n)|(unsigned)(x)<<(8*sizeof(t)-(n))))
#define __ROT(x, n, t) ((n)>=0? __ROTL(x, n, t): __ROTR(x, -(n), t))
#define __BIT(x, n) (*(unsigned long*)(x)>>(n)&1)
#define __MOVE(s, d, n) memcpy((char*)(d),(char*)(s),n)
/* std procs and operator mappings */
#define __SHORT(x, y) ((int)((unsigned long)(x)+(y)<(y)+(y)?(x):(__HALT(-8),0)))
#define __SHORTF(x, y) ((int)(__RF((x)+(y),(y)+(y))-(y)))
#define __CHR(x) ((CHAR)__R(x, 256))
#define __CHRF(x) ((CHAR)__RF(x, 256))
#define __DIV(x, y) ((x)>=0?(x)/(y):-(((y)-1-(x))/(y)))
#define __DIVF(x, y) SYSTEM_DIV((long)(x),(long)(y))
#define __MOD(x, y) ((x)>=0?(x)%(y):__MODF(x,y))
#define __MODF(x, y) SYSTEM_MOD((long)(x),(long)(y))
#define __NEW(p, t) p=SYSTEM_NEWREC((long)t##__typ)
#define __NEWARR SYSTEM_NEWARR
#define __HALT(x) SYSTEM_HALT(x)
#define __ASSERT(cond, x) if (!(cond)) {SYSTEM_assert = x; SYSTEM_HALT(-1);}
#define __ENTIER(x) SYSTEM_ENTIER(x)
#define __ABS(x) (((x)<0)?-(x):(x))
#define __ABSF(x) SYSTEM_ABS((long)(x))
#define __ABSFD(x) SYSTEM_ABSD((double)(x))
#define __CAP(ch) ((CHAR)((ch)&0x5f))
#define __ODD(x) ((x)&1)
#define __IN(x, s) (((s)>>(x))&1)
#define __SETOF(x) ((SET)1<<(x))
#define __SETRNG(l, h) ((~(SET)0<<(l))&~(SET)0>>(8*sizeof(SET)-1-(h)))
#define __MASK(x, m) ((x)&~(m))
#define __COPY(s, d, n) {char*_a=(void*)s,*_b=(void*)d;long _i=0,_t=n-1;while(_i<_t&&((_b[_i]=_a[_i])!=0)){_i++;};_b[_i]=0;}
static int __STRCMP(x, y)
CHAR *x, *y;
{long i = 0; CHAR ch1, ch2;
do {ch1 = x[i]; ch2 = y[i]; i++;
if (!ch1) return -(int)ch2;
} while (ch1==ch2);
return (int)ch1 - (int)ch2;
}
#define __ASH(x, n) ((n)>=0?__ASHL(x,n):__ASHR(x,-(n)))
#define __ASHL(x, n) ((long)(x)<<(n))
#define __ASHR(x, n) ((long)(x)>>(n))
#define __ASHF(x, n) SYSTEM_ASH((long)(x), (long)(n))
#define __DUP(x, l, t) x=(void*)memcpy(alloca(l*sizeof(t)),x,l*sizeof(t))
#define __DUPARR(v, t) v=(void*)memcpy(v##__copy,v,sizeof(t))
#define __DEL(x) /* DUP with alloca frees storage automatically */
#define __IS(tag, typ, level) (*(tag-(__BASEOFF-level))==(long)typ##__typ)
#define __TYPEOF(p) (*(((long**)(p))-1))
#define __ISP(p, typ, level) __IS(__TYPEOF(p),typ,level)
/* runtime checks */
#define __X(i, ub) (((unsigned)(long)(i)<(unsigned long)(ub))?i:(__HALT(-2),0))
#define __XF(i, ub) SYSTEM_XCHK((long)(i), (long)(ub))
#define __RETCHK __retchk: __HALT(-3)
#define __CASECHK __HALT(-4)
#define __GUARDP(p, typ, level) ((typ*)(__ISP(p,typ,level)?p:(__HALT(-5),p)))
#define __GUARDR(r, typ, level) (*((typ*)(__IS(r##__typ,typ,level)?r:(__HALT(-5),r))))
#define __GUARDA(p, typ, level) ((struct typ*)(__IS(__TYPEOF(p),typ,level)?p:(__HALT(-5),p)))
#define __GUARDEQR(p, dyntyp, typ) if(dyntyp!=typ##__typ) __HALT(-6);*(p)
#define __GUARDEQP(p, typ) if(__TYPEOF(p)!=typ##__typ)__HALT(-6);*(p)
#define __WITHCHK __HALT(-7)
#define __R(i, ub) (((unsigned)(long)(i)<(unsigned long)(ub))?i:(__HALT(-8),0))
#define __RF(i, ub) SYSTEM_RCHK((long)(i),(long)(ub))
/* record type descriptors */
#define __TDESC(t, m, n) \
static struct t##__desc {\
long tproc[m]; \
long tag, next, level, module; \
char name[24]; \
long *base[__MAXEXT]; \
char *rsrvd; \
long blksz, ptr[n+1]; \
} t##__desc
#define __BASEOFF (__MAXEXT+1)
#define __TPROC0OFF (__BASEOFF+24/sizeof(long)+5)
#define __EOM 1
#define __TDFLDS(name, size) {__EOM}, 1, 0, 0, 0, name, {0}, 0, size
#define __ENUMP(adr, n, P) SYSTEM_ENUMP(adr, (long)(n), P)
#define __ENUMR(adr, typ, size, n, P) SYSTEM_ENUMR(adr, typ, (long)(size), (long)(n), P)
#define __INITYP(t, t0, level) \
t##__typ= &t##__desc.blksz; \
memcpy(t##__desc.base, t0##__typ - __BASEOFF, level*sizeof(long)); \
t##__desc.base[level]=t##__typ; \
t##__desc.module=(long)m; \
if(t##__desc.blksz!=sizeof(struct t)) __HALT(-15); \
t##__desc.blksz=(t##__desc.blksz+5*sizeof(long)-1)/(4*sizeof(long))*(4*sizeof(long)); \
SYSTEM_REGTYP(m, (long)&t##__desc.next); \
SYSTEM_INHERIT(t##__typ, t0##__typ)
/* Oberon-2 type bound procedures support */
#define __INITBP(t, proc, num) *(t##__typ-(__TPROC0OFF+num))=(long)proc
#define __SEND(typ, num, funtyp, parlist) ((funtyp)(*(typ-(__TPROC0OFF+num))))parlist
/* runtime system variables */
extern LONGINT SYSTEM_argc;
extern LONGINT SYSTEM_argv;
extern void (*SYSTEM_Halt)();
extern LONGINT SYSTEM_halt;
extern LONGINT SYSTEM_assert;
extern SYSTEM_PTR SYSTEM_modules;
extern LONGINT SYSTEM_heapsize;
extern LONGINT SYSTEM_allocated;
extern LONGINT SYSTEM_lock;
extern SHORTINT SYSTEM_gclock;
extern BOOLEAN SYSTEM_interrupted;
/* ANSI prototypes; not used so far
static int __STRCMP(CHAR *x, CHAR *y);
void SYSTEM_INIT(int argc, long argvadr);
void SYSTEM_FINI(void);
long SYSTEM_XCHK(long i, long ub);
long SYSTEM_RCHK(long i, long ub);
long SYSTEM_ASH(long i, long n);
long SYSTEM_ABS(long i);
double SYSTEM_ABSD(double i);
void SYSTEM_INHERIT(long *t, long *t0);
void SYSTEM_ENUMP(long *adr, long n, void (*P)(void*));
void SYSTEM_ENUMR(char *adr, long *typ, long size, long n, void (*P)(void*));
long SYSTEM_DIV(unsigned long x, unsigned long y);
long SYSTEM_MOD(unsigned long x, unsigned long y);
long SYSTEM_ENTIER(double x);
void SYSTEM_HALT(int n);
*/
#endif

411
src/lib/system/gnuc/x86/Unix.Mod Normal file
View file

@ -0,0 +1,411 @@
MODULE Unix; (* Josef Templ, 5.3.90 Linux system calls *)
(* system procedure added by noch *)
(* Module Unix provides a system call interface to Linux.
Naming conventions:
Procedure and Type-names always start with a capital letter.
error numbers as defined in Unix
other constants start with lower case letters *)
IMPORT SYSTEM;
CONST
(* various important constants *)
stdin* = 0; stdout* =1; stderr* = 2;
LOCKEX* = 2; LOCKUN* = 8; (* /usr/include/file.h *)
AFINET* = 2; (* /usr/include/sys/socket.h *)
PFINET* = AFINET; (* /usr/include/linux/socket.h *)
SOCKSTREAM* = 1; (* /usr/include/linux/socket.h *)
FIONREAD* = 541BH; (* in /usr/include/asm/termios.h *)
SETFL* = 4; (* set file descriptor flags; in asm/fcntl.h *)
TCP* = 0;
(* flag sets, cf. /usr/include/asm/fcntl.h *)
rdonly* = {}; wronly* = {0}; rdwr* = {1}; creat* = {6}; excl* = {7}; trunc* = {9}; append* = {10}; ndelay = {11};
(* error numbers *)
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 children *)
EAGAIN* = 11; (* No more processes *)
ENOMEM* = 12; (* Not enough core *)
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; (* Argument too large *)
ERANGE* = 34; (* Result too large *)
EDEADLK* = 35; (* Resource deadlock would occur *)
ENAMETOOLONG* = 36; (* File name too long *)
ENOLCK* = 37; (* No record locks available *)
ENOSYS* = 38; (* Function not implemented *)
ENOTEMPTY* = 39; (* Directory not empty *)
ELOOP* = 40; (* Too many symbolic links encountered *)
EWOULDBLOCK* = EAGAIN; (* Operation would block *)
ENOMSG* = 42; (* No message of desired type *)
EIDRM* = 43; (* Identifier removed *)
ECHRNG* = 44; (* Channel number out of range *)
EL2NSYNC* = 45; (* Level 2 not synchronized *)
EL3HLT* = 46; (* Level 3 halted *)
EL3RST* = 47; (* Level 3 reset *)
ELNRNG* = 48; (* Link number out of range *)
EUNATCH* = 49; (* Protocol driver not attached *)
ENOCSI* = 50; (* No CSI structure available *)
EL2HLT* = 51; (* Level 2 halted *)
EBADE* = 52; (* Invalid exchange *)
EBADR* = 53; (* Invalid request descriptor *)
EXFULL* = 54; (* Exchange full *)
ENOANO* = 55; (* No anode *)
EBADRQC* = 56; (* Invalid request code *)
EBADSLT* = 57; (* Invalid slot *)
EDEADLOCK* = 58; (* File locking deadlock error *)
EBFONT* = 59; (* Bad font file format *)
ENOSTR* = 60; (* Device not a stream *)
ENODATA* = 61; (* No data available *)
ETIME* = 62; (* Timer expired *)
ENOSR* = 63; (* Out of streams resources *)
ENONET* = 64; (* Machine is not on the network *)
ENOPKG* = 65; (* Package not installed *)
EREMOTE* = 66; (* Object is remote *)
ENOLINK* = 67; (* Link has been severed *)
EADV* = 68; (* Advertise error *)
ESRMNT* = 69; (* Srmount error *)
ECOMM* = 70; (* Communication error on send *)
EPROTO* = 71; (* Protocol error *)
EMULTIHOP* = 72; (* Multihop attempted *)
EDOTDOT* = 73; (* RFS specific error *)
EBADMSG* = 74; (* Not a data message *)
EOVERFLOW* = 75; (* Value too large for defined data type *)
ENOTUNIQ* = 76; (* Name not unique on network *)
EBADFD* = 77; (* File descriptor in bad state *)
EREMCHG* = 78; (* Remote address changed *)
ELIBACC* = 79; (* Can not access a needed shared library *)
ELIBBAD* = 80; (* Accessing a corrupted shared library *)
ELIBSCN* = 81; (* .lib section in a.out corrupted *)
ELIBMAX* = 82; (* Attempting to link in too many shared libraries *)
ELIBEXEC* = 83; (* Cannot exec a shared library directly *)
EILSEQ* = 84; (* Illegal byte sequence *)
ERESTART* = 85; (* Interrupted system call should be restarted *)
ESTRPIPE* = 86; (* Streams pipe error *)
EUSERS* = 87; (* Too many users *)
ENOTSOCK* = 88; (* Socket operation on non-socket *)
EDESTADDRREQ* = 89; (* Destination address required *)
EMSGSIZE* = 90; (* Message too long *)
EPROTOTYPE* = 91; (* Protocol wrong type for socket *)
ENOPROTOOPT* = 92; (* Protocol not available *)
EPROTONOSUPPORT* = 93; (* Protocol not supported *)
ESOCKTNOSUPPORT* = 94; (* Socket type not supported *)
EOPNOTSUPP* = 95; (* Operation not supported on transport endpoint *)
EPFNOSUPPORT* = 96; (* Protocol family not supported *)
EAFNOSUPPORT* = 97; (* Address family not supported by protocol *)
EADDRINUSE* = 98; (* Address already in use *)
EADDRNOTAVAIL* = 99; (* Cannot assign requested address *)
ENETDOWN* = 100; (* Network is down *)
ENETUNREACH* = 101; (* Network is unreachable *)
ENETRESET* = 102; (* Network dropped connection because of reset *)
ECONNABORTED* = 103; (* Software caused connection abort *)
ECONNRESET* = 104; (* Connection reset by peer *)
ENOBUFS* = 105; (* No buffer space available *)
EISCONN* = 106; (* Transport endpoint is already connected *)
ENOTCONN* = 107; (* Transport endpoint is not connected *)
ESHUTDOWN* = 108; (* Cannot send after transport endpoint shutdown *)
ETOOMANYREFS* = 109; (* Too many references: cannot splice *)
ETIMEDOUT* = 110; (* Connection timed out *)
ECONNREFUSED* = 111; (* Connection refused *)
EHOSTDOWN* = 112; (* Host is down *)
EHOSTUNREACH* = 113; (* No route to host *)
EALREADY* = 114; (* Operation already in progress *)
EINPROGRESS* = 115; (* Operation now in progress *)
ESTALE* = 116; (* Stale NFS file handle *)
EUCLEAN* = 117; (* Structure needs cleaning *)
ENOTNAM* = 118; (* Not a XENIX named type file *)
ENAVAIL* = 119; (* No XENIX semaphores available *)
EISNAM* = 120; (* Is a named type file *)
EREMOTEIO* = 121; (* Remote I/O error *)
EDQUOT* = 122; (* Quota exceeded *)
TYPE
JmpBuf* = RECORD
bx*, si*, di*, bp*, sp*, pc*: LONGINT;
maskWasSaved*, savedMask*: LONGINT;
END ;
Status* = RECORD (* struct stat *)
dev*, devX*: LONGINT; (* 64 bit in Linux 2.2 *)
pad1: INTEGER;
ino*, mode*, nlink*, uid*, gid*: LONGINT;
rdev*, rdevX*: LONGINT; (* 64 bit in Linux 2.2 *)
pad2: INTEGER;
size*, blksize*, blocks*, atime*, unused1*, mtime*, unused2*, ctime*,
unused3*, unused4*, unused5*: LONGINT;
END ;
Timeval* = RECORD
sec*, usec*: LONGINT
END ;
Timezone* = RECORD
minuteswest*, dsttime*: LONGINT
END ;
Itimerval* = RECORD
interval*, value*: Timeval
END ;
FdSet* = ARRAY 8 OF SET;
SigCtxPtr* = POINTER TO SigContext;
SigContext* = RECORD
END ;
SignalHandler* = PROCEDURE (sig, code: LONGINT; scp: SigCtxPtr);
Dirent* = RECORD
ino, off: LONGINT;
reclen: INTEGER;
name: ARRAY 256 OF CHAR;
END ;
Rusage* = RECORD
utime*, stime*: Timeval;
maxrss*, ixrss*, idrss*, isrss*,
minflt*, majflt*, nswap*, inblock*,
oublock*, msgsnd*, msgrcv*, nsignals*,
nvcsw*, nivcsw*: LONGINT
END ;
Iovec* = RECORD
base*, len*: LONGINT
END ;
SocketPair* = ARRAY 2 OF LONGINT;
Pollfd* = RECORD
fd*: LONGINT;
events*, revents*: INTEGER
END ;
Sockaddr* = RECORD
family*: INTEGER;
port*: INTEGER;
internetAddr*: LONGINT;
pad*: ARRAY 8 OF CHAR;
END ;
HostEntry* = POINTER [1] TO Hostent;
Hostent* = RECORD
name*, aliases*: LONGINT;
addrtype*, length*: LONGINT;
addrlist*: LONGINT; (*POINTER TO POINTER TO LONGINT, network byte order*)
END;
Name* = ARRAY OF CHAR;
PROCEDURE -includeStat()
"#include <sys/stat.h>";
PROCEDURE -includeErrno()
"#include <errno.h>";
PROCEDURE -err(): LONGINT
"errno";
PROCEDURE errno*(): LONGINT;
BEGIN
RETURN err()
END errno;
PROCEDURE -Exit*(n: LONGINT)
"exit(n)";
PROCEDURE -Fork*(): LONGINT
"fork()";
PROCEDURE -Wait*(VAR status: LONGINT): LONGINT
"wait(status)";
PROCEDURE -Select*(width: LONGINT; VAR readfds, writefds, exceptfds: FdSet; VAR timeout: Timeval): LONGINT
"select(width, readfds, writefds, exceptfds, timeout)";
PROCEDURE -Gettimeofday* (VAR tv: Timeval; VAR tz: Timezone)
"gettimeofday(tv, tz)";
PROCEDURE -Read* (fd, buf, nbyte: LONGINT): LONGINT
"read(fd, buf, nbyte)";
PROCEDURE -ReadBlk* (fd: LONGINT; VAR buf: ARRAY OF SYSTEM.BYTE): LONGINT
"read(fd, buf, buf__len)";
PROCEDURE -Write* (fd, buf, nbyte: LONGINT): LONGINT
"write(fd, buf, nbyte)";
PROCEDURE -WriteBlk* (fd: LONGINT; VAR buf: ARRAY OF SYSTEM.BYTE): LONGINT
"write(fd, buf, buf__len)";
PROCEDURE -Dup*(fd: LONGINT): LONGINT
"dup(fd)";
PROCEDURE -Dup2*(fd1, fd2: LONGINT): LONGINT
"dup(fd1, fd2)";
PROCEDURE -Getpid*(): LONGINT
"getpid()";
PROCEDURE -Getuid*(): LONGINT
"getuid()";
PROCEDURE -Geteuid*(): LONGINT
"geteuid()";
PROCEDURE -Getgid*(): LONGINT
"getgid()";
PROCEDURE -Getegid*(): LONGINT
"getegid()";
PROCEDURE -Unlink*(name: Name): LONGINT
"unlink(name)";
PROCEDURE -Open*(name: Name; flag, mode: SET): LONGINT
"open(name, flag, mode)";
PROCEDURE -Close*(fd: LONGINT): LONGINT
"close(fd)";
PROCEDURE -stat(name: Name; VAR statbuf: Status): LONGINT
"stat((const char*)name, (struct stat*)statbuf)";
PROCEDURE Stat*(name: Name; VAR statbuf: Status): LONGINT;
VAR res: LONGINT;
BEGIN
res := stat(name, statbuf);
(* make the first 4 bytes as unique as possible (used in module Files for caching!) *)
INC(statbuf.dev, statbuf.devX);
INC(statbuf.rdev, statbuf.rdevX);
RETURN res;
END Stat;
PROCEDURE -fstat(fd: LONGINT; VAR statbuf: Status): LONGINT
"fstat(fd, (struct stat*)statbuf)";
PROCEDURE Fstat*(fd: LONGINT; VAR statbuf: Status): LONGINT;
VAR res: LONGINT;
BEGIN
res := fstat(fd, statbuf);
(* make the first 4 bytes as unique as possible (used in module Files for caching!) *)
INC(statbuf.dev, statbuf.devX);
INC(statbuf.rdev, statbuf.rdevX);
RETURN res;
END Fstat;
PROCEDURE -Fchmod*(fd, mode: LONGINT): LONGINT
"fchmod(fd, mode)";
PROCEDURE -Chmod*(path: Name; mode: LONGINT): LONGINT
"chmod(path, mode)";
PROCEDURE -Lseek*(fd, offset, origin: LONGINT): LONGINT
"lseek(fd, offset, origin)";
PROCEDURE -Fsync*(fd: LONGINT): LONGINT
"fsync(fd)";
PROCEDURE -Fcntl*(fd, cmd, arg: LONGINT ): LONGINT
"fcntl(fd, cmd, arg)";
PROCEDURE -Flock*(fd, operation: LONGINT): LONGINT
"flock(fd, operation)";
PROCEDURE -Ftruncate*(fd, length: LONGINT): LONGINT
"ftruncate(fd, length)";
PROCEDURE -Readblk*(fd: LONGINT; VAR buf: ARRAY OF SYSTEM.BYTE; len: LONGINT): LONGINT
"read(fd, buf, len)";
PROCEDURE -Rename*(old, new: Name): LONGINT
"rename(old, new)";
PROCEDURE -Chdir*(path: Name): LONGINT
"chdir(path)";
PROCEDURE -Ioctl*(fd, request, arg: LONGINT): LONGINT
"ioctl(fd, request, arg)";
PROCEDURE -Kill*(pid, sig: LONGINT): LONGINT
"kill(pid, sig)";
PROCEDURE -Sigsetmask*(mask: LONGINT): LONGINT
"sigsetmask(mask)";
(* TCP/IP networking *)
PROCEDURE -Gethostbyname*(name: Name): HostEntry
"(Unix_HostEntry)gethostbyname(name)";
PROCEDURE -Gethostname*(VAR name: Name): LONGINT
"gethostname(name, name__len)";
PROCEDURE -Socket*(af, type, protocol: LONGINT): LONGINT
"socket(af, type, protocol)";
PROCEDURE -Connect*(socket: LONGINT; name: Sockaddr; namelen: LONGINT): LONGINT
"connect(socket, &(name), namelen)";
PROCEDURE -Getsockname*(socket: LONGINT; VAR name: Sockaddr; VAR namelen: LONGINT): LONGINT
"getsockname(socket, name, namelen)";
PROCEDURE -Bind*(socket: LONGINT; name: Sockaddr; namelen: LONGINT): LONGINT
"bind(socket, &(name), namelen)";
PROCEDURE -Listen*(socket, backlog: LONGINT): LONGINT
"listen(socket, backlog)";
PROCEDURE -Accept*(socket: LONGINT; VAR addr: Sockaddr; VAR addrlen: LONGINT): LONGINT
"accept(socket, addr, addrlen)";
PROCEDURE -Recv*(socket, bufadr, buflen, flags: LONGINT): LONGINT
"recv(socket, bufadr, buflen, flags)";
PROCEDURE -Send*(socket, bufadr, buflen, flags: LONGINT): LONGINT
"send(socket, bufadr, buflen, flags)";
PROCEDURE -sys(str: ARRAY OF CHAR): INTEGER (* need this to call external tools like gcc or gas; noch *)
"system(str)";
PROCEDURE system*(cmd : ARRAY OF CHAR);
VAR r : INTEGER;
BEGIN
r := sys(cmd);
END system;
END Unix.

53
src/lib/system/gnuc/x86_64/Args.Mod Normal file
View file

@ -0,0 +1,53 @@
MODULE Args; (* jt, 8.12.94 *)
(* command line argument handling for voc (jet backend) *)
IMPORT SYSTEM;
TYPE
ArgPtr = POINTER TO ARRAY 1024 OF CHAR;
ArgVec = POINTER TO ARRAY 1024 OF ArgPtr;
VAR argc-, argv-: LONGINT;
(*PROCEDURE -includestdlib() "#include <stdlib.h>";*)
PROCEDURE -externgetenv() "extern char *getenv(const char *name);"; (* took this from stdlib.h*)
PROCEDURE -Argc(): INTEGER "SYSTEM_argc";
PROCEDURE -Argv(): LONGINT "(long)SYSTEM_argv";
PROCEDURE -getenv(var: ARRAY OF CHAR): ArgPtr
"(Args_ArgPtr)getenv(var)";
PROCEDURE Get*(n: INTEGER; VAR val: ARRAY OF CHAR);
VAR av: ArgVec;
BEGIN
IF n < argc THEN av := SYSTEM.VAL(ArgVec, argv); COPY(av[n]^, val) END
END Get;
PROCEDURE GetInt*(n: INTEGER; VAR val: LONGINT);
VAR s: ARRAY 64 OF CHAR; k, d, i: LONGINT;
BEGIN
s := ""; Get(n, s); i := 0;
IF s[0] = "-" THEN i := 1 END ;
k := 0; d := ORD(s[i]) - ORD("0");
WHILE (d >= 0 ) & (d <= 9) DO k := k*10 + d; INC(i); d := ORD(s[i]) - ORD("0") END ;
IF s[0] = "-" THEN d := -d; DEC(i) END ;
IF i > 0 THEN val := k END
END GetInt;
PROCEDURE Pos*(s: ARRAY OF CHAR): INTEGER;
VAR i: INTEGER; arg: ARRAY 256 OF CHAR;
BEGIN
i := 0; Get(i, arg);
WHILE (i < argc) & (s # arg) DO INC(i); Get(i, arg) END ;
RETURN i
END Pos;
PROCEDURE GetEnv*(var: ARRAY OF CHAR; VAR val: ARRAY OF CHAR);
VAR p: ArgPtr;
BEGIN
p := getenv(var);
IF p # NIL THEN COPY(p^, val) END
END GetEnv;
BEGIN argc := Argc(); argv := Argv()
END Args.

205
src/lib/system/gnuc/x86_64/SYSTEM.c0 Normal file
View file

@ -0,0 +1,205 @@
/*
* The body prefix file of the voc(jet backend) runtime system, Version 1.0
*
* Copyright (c) Software Templ, 1994, 1995
*
* Module SYSTEM is subject to change any time without prior notification.
* Software Templ disclaims all warranties with regard to module SYSTEM,
* in particular shall Software Templ not be liable for any damage resulting
* from inappropriate use or modification of module SYSTEM.
*
* Version 1.1 jt, 24.11.95 fixes for correct pointer arithmetic on Cray computers
* jt 31.1.2007 ANSI prototypes for malloc and exit in order to avoid cc warnings
*
*/
#include "SYSTEM.h"
#ifdef __STDC__
#include "stdarg.h"
#else
#include "varargs.h"
#endif
extern void *malloc(long size);
extern void exit(int status);
void (*SYSTEM_Halt)();
LONGINT SYSTEM_halt; /* x in HALT(x) */
LONGINT SYSTEM_assert; /* x in ASSERT(cond, x) */
LONGINT SYSTEM_argc;
LONGINT SYSTEM_argv;
LONGINT SYSTEM_lock;
BOOLEAN SYSTEM_interrupted;
static LONGINT SYSTEM_mainfrm; /* adr of main proc stack frame, used for stack collection */
#define Lock SYSTEM_lock++
#define Unlock SYSTEM_lock--; if (SYSTEM_interrupted && (SYSTEM_lock == 0)) __HALT(-9)
static void SYSTEM_InitHeap();
void *SYSTEM__init();
void SYSTEM_INIT(argc, argvadr)
int argc; long argvadr;
{
SYSTEM_mainfrm = argvadr;
SYSTEM_argc = argc;
SYSTEM_argv = *(long*)argvadr;
SYSTEM_InitHeap();
SYSTEM_halt = -128;
SYSTEM__init();
}
void SYSTEM_FINI()
{
SYSTEM_FINALL();
}
long SYSTEM_XCHK(i, ub) long i, ub; {return __X(i, ub);}
long SYSTEM_RCHK(i, ub) long i, ub; {return __R(i, ub);}
long SYSTEM_ASH(i, n) long i, n; {return __ASH(i, n);}
long SYSTEM_ABS(i) long i; {return __ABS(i);}
double SYSTEM_ABSD(i) double i; {return __ABS(i);}
void SYSTEM_INHERIT(t, t0)
long *t, *t0;
{
t -= __TPROC0OFF;
t0 -= __TPROC0OFF;
while (*t0 != __EOM) {*t = *t0; t--; t0--;}
}
void SYSTEM_ENUMP(adr, n, P)
long *adr;
long n;
void (*P)();
{
while (n > 0) {P(*adr); adr++; n--;}
}
void SYSTEM_ENUMR(adr, typ, size, n, P)
char *adr;
long *typ, size, n;
void (*P)();
{
long *t, off;
typ++;
while (n > 0) {
t = typ;
off = *t;
while (off >= 0) {P(*(long*)(adr+off)); t++; off = *t;}
adr += size; n--;
}
}
long SYSTEM_DIV(x, y)
unsigned long x, y;
{ if ((long) x >= 0) return (x / y);
else return -((y - 1 - x) / y);
}
long SYSTEM_MOD(x, y)
unsigned long x, y;
{ unsigned long m;
if ((long) x >= 0) return (x % y);
else { m = (-x) % y;
if (m != 0) return (y - m); else return 0;
}
}
long SYSTEM_ENTIER(x)
double x;
{
long y;
if (x >= 0)
return (long)x;
else {
y = (long)x;
if (y <= x) return y; else return y - 1;
}
}
void SYSTEM_HALT(n)
int n;
{
SYSTEM_halt = n;
if (SYSTEM_Halt!=0) SYSTEM_Halt(n);
exit(n);
}
#ifdef __STDC__
SYSTEM_PTR SYSTEM_NEWARR(long *typ, long elemsz, int elemalgn, int nofdim, int nofdyn, ...)
#else
SYSTEM_PTR SYSTEM_NEWARR(typ, elemsz, elemalgn, nofdim, nofdyn, va_alist)
long *typ, elemsz;
int elemalgn, nofdim, nofdyn;
va_dcl
#endif
{
long nofelems, size, dataoff, n, nptr, *x, *p, nofptrs, i, *ptab, off;
va_list ap;
#ifdef __STDC__
va_start(ap, nofdyn);
#else
va_start(ap);
#endif
nofelems = 1;
while (nofdim > 0) {
nofelems = nofelems * va_arg(ap, long); nofdim--;
if (nofelems <= 0) __HALT(-20);
}
va_end(ap);
dataoff = nofdyn * sizeof(long);
if (elemalgn > sizeof(long)) {
n = dataoff % elemalgn;
if (n != 0) dataoff += elemalgn - n;
}
size = dataoff + nofelems * elemsz;
Lock;
if (typ == NIL) {
/* element typ does not contain pointers */
x = SYSTEM_NEWBLK(size);
}
else if (typ == POINTER__typ) {
/* element type is a pointer */
x = SYSTEM_NEWBLK(size + nofelems * sizeof(long));
p = (long*)x[-1];
p[-nofelems] = *p; /* build new type desc in situ: 1. copy block size; 2. setup ptr tab; 3. set sentinel; 4. patch tag */
p -= nofelems - 1; n = 1; /* n =1 for skipping the size field */
while (n <= nofelems) {*p = n*sizeof(long); p++; n++;}
*p = - (nofelems + 1) * sizeof(long); /* sentinel */
x[-1] -= nofelems * sizeof(long);
}
else {
/* element type is a record that contains pointers */
ptab = typ + 1; nofptrs = 0;
while (ptab[nofptrs] >= 0) {nofptrs++;} /* number of pointers per element */
nptr = nofelems * nofptrs; /* total number of pointers */
x = SYSTEM_NEWBLK(size + nptr * sizeof(long));
p = (long*)x[- 1];
p[-nptr] = *p; /* build new type desc in situ; 1. copy block size; 2. setup ptr tab; 3. set sentinel; 4. patch tag */
p -= nptr - 1; n = 0; off = dataoff;
while (n < nofelems) {i = 0;
while (i < nofptrs) {*p = off + ptab[i]; p++; i++;}
off += elemsz; n++;
}
*p = - (nptr + 1) * sizeof(long); /* sentinel */
x[-1] -= nptr * sizeof(long);
}
if (nofdyn != 0) {
/* setup len vector for index checks */
#ifdef __STDC__
va_start(ap, nofdyn);
#else
va_start(ap);
#endif
p = x;
while (nofdyn > 0) {*p = va_arg(ap, long); p++, nofdyn--;}
va_end(ap);
}
Unlock;
return x;
}
/* ----------- end of SYSTEM.co ------------- */

233
src/lib/system/gnuc/x86_64/SYSTEM.h Normal file
View file

@ -0,0 +1,233 @@
#ifndef SYSTEM__h
#define SYSTEM__h
/*
voc (jet backend) runtime system interface and macros library
copyright (c) Josef Templ, 1995, 1996
gcc for Linux version (same as SPARC/Solaris2)
uses double # as concatenation operator
*/
#include <alloca.h>
extern void *memcpy(void *dest, const void *src, long n);
extern void *malloc(long size);
extern void exit(int status);
#define export
#define import extern
/* constants */
#define __MAXEXT 16
#define NIL 0L
#define POINTER__typ (long*)1L /* not NIL and not a valid type */
/* basic types */
//typedef char BOOLEAN;
#define BOOLEAN char
//typedef unsigned char CHAR;
#define CHAR unsigned char
//exactly two bytes
#define LONGCHAR unsigned short int
//typedef signed char SHORTINT;
#define SHORTINT signed char
//for x86 GNU/Linux
//typedef short int INTEGER;
//for x86_64 GNU/Linux
//typedef int INTEGER;
#define INTEGER int
//typedef long LONGINT;
#define LONGINT long
//typedef float REAL;
#define REAL float
//typedef double LONGREAL;
#define LONGREAL double
//typedef unsigned long SET;
#define SET unsigned long
typedef void *SYSTEM_PTR;
//#define *SYSTEM_PTR void
//typedef unsigned char SYSTEM_BYTE;
#define SYSTEM_BYTE unsigned char
/* runtime system routines */
extern long SYSTEM_DIV();
extern long SYSTEM_MOD();
extern long SYSTEM_ENTIER();
extern long SYSTEM_ASH();
extern long SYSTEM_ABS();
extern long SYSTEM_XCHK();
extern long SYSTEM_RCHK();
extern double SYSTEM_ABSD();
extern SYSTEM_PTR SYSTEM_NEWREC();
extern SYSTEM_PTR SYSTEM_NEWBLK();
#ifdef __STDC__
extern SYSTEM_PTR SYSTEM_NEWARR(long*, long, int, int, int, ...);
#else
extern SYSTEM_PTR SYSTEM_NEWARR();
#endif
extern SYSTEM_PTR SYSTEM_REGMOD();
extern void SYSTEM_INCREF();
extern void SYSTEM_REGCMD();
extern void SYSTEM_REGTYP();
extern void SYSTEM_REGFIN();
extern void SYSTEM_FINALL();
extern void SYSTEM_INIT();
extern void SYSTEM_FINI();
extern void SYSTEM_HALT();
extern void SYSTEM_INHERIT();
extern void SYSTEM_ENUMP();
extern void SYSTEM_ENUMR();
/* module registry */
#define __DEFMOD static void *m; if(m!=0)return m
#define __REGMOD(name, enum) if(m==0)m=SYSTEM_REGMOD((CHAR*)name,enum); else return m
#define __ENDMOD return m
#define __INIT(argc, argv) static void *m; SYSTEM_INIT(argc, (long)&argv);
#define __REGMAIN(name, enum) m=SYSTEM_REGMOD(name,enum)
#define __FINI SYSTEM_FINI(); return 0
#define __IMPORT(name) SYSTEM_INCREF(name##__init())
#define __REGCMD(name, cmd) SYSTEM_REGCMD(m, name, cmd)
/* SYSTEM ops */
#define __SYSNEW(p, len) p=SYSTEM_NEWBLK((long)(len))
#define __VAL(t, x) (*(t*)&(x))
#define __GET(a, x, t) x= *(t*)(a)
#define __PUT(a, x, t) *(t*)(a)=x
#define __LSHL(x, n, t) ((t)((unsigned t)(x)<<(n)))
#define __LSHR(x, n, t) ((t)((unsigned t)(x)>>(n)))
#define __LSH(x, n, t) ((n)>=0? __LSHL(x, n, t): __LSHR(x, -(n), t))
#define __ROTL(x, n, t) ((t)((unsigned t)(x)<<(n)|(unsigned t)(x)>>(8*sizeof(t)-(n))))
#define __ROTR(x, n, t) ((t)((unsigned t)(x)>>(n)|(unsigned t)(x)<<(8*sizeof(t)-(n))))
#define __LSHR(x, n, t) ((t)((unsigned t)(x)>>(n)))
#define __LSH(x, n, t) ((n)>=0? __LSHL(x, n, t): __LSHR(x, -(n), t))
#define __ROTL(x, n, t) ((t)((unsigned t)(x)<<(n)|(unsigned t)(x)>>(8*sizeof(t)-(n))))
#define __ROTR(x, n, t) ((t)((unsigned t)(x)>>(n)|(unsigned t)(x)<<(8*sizeof(t)-(n))))
#define __ROT(x, n, t) ((n)>=0? __ROTL(x, n, t): __ROTR(x, -(n), t))
#define __BIT(x, n) (*(unsigned long*)(x)>>(n)&1)
#define __MOVE(s, d, n) memcpy((char*)(d),(char*)(s),n)
/* std procs and operator mappings */
#define __SHORT(x, y) ((int)((unsigned long)(x)+(y)<(y)+(y)?(x):(__HALT(-8),0)))
#define __SHORTF(x, y) ((int)(__RF((x)+(y),(y)+(y))-(y)))
#define __CHR(x) ((CHAR)__R(x, 256))
#define __CHRF(x) ((CHAR)__RF(x, 256))
#define __DIV(x, y) ((x)>=0?(x)/(y):-(((y)-1-(x))/(y)))
#define __DIVF(x, y) SYSTEM_DIV((long)(x),(long)(y))
#define __MOD(x, y) ((x)>=0?(x)%(y):__MODF(x,y))
#define __MODF(x, y) SYSTEM_MOD((long)(x),(long)(y))
#define __NEW(p, t) p=SYSTEM_NEWREC((long)t##__typ)
#define __NEWARR SYSTEM_NEWARR
#define __HALT(x) SYSTEM_HALT(x)
#define __ASSERT(cond, x) if (!(cond)) {SYSTEM_assert = x; SYSTEM_HALT(-1);}
#define __ENTIER(x) SYSTEM_ENTIER(x)
#define __ABS(x) (((x)<0)?-(x):(x))
#define __ABSF(x) SYSTEM_ABS((long)(x))
#define __ABSFD(x) SYSTEM_ABSD((double)(x))
#define __CAP(ch) ((CHAR)((ch)&0x5f))
#define __ODD(x) ((x)&1)
#define __IN(x, s) (((s)>>(x))&1)
#define __SETOF(x) ((SET)1<<(x))
#define __SETRNG(l, h) ((~(SET)0<<(l))&~(SET)0>>(8*sizeof(SET)-1-(h)))
#define __MASK(x, m) ((x)&~(m))
#define __COPY(s, d, n) {char*_a=(void*)s,*_b=(void*)d;long _i=0,_t=n-1;while(_i<_t&&((_b[_i]=_a[_i])!=0)){_i++;};_b[_i]=0;}
static int __STRCMP(x, y)
CHAR *x, *y;
{long i = 0; CHAR ch1, ch2;
do {ch1 = x[i]; ch2 = y[i]; i++;
if (!ch1) return -(int)ch2;
} while (ch1==ch2);
return (int)ch1 - (int)ch2;
}
#define __ASH(x, n) ((n)>=0?__ASHL(x,n):__ASHR(x,-(n)))
#define __ASHL(x, n) ((long)(x)<<(n))
#define __ASHR(x, n) ((long)(x)>>(n))
#define __ASHF(x, n) SYSTEM_ASH((long)(x), (long)(n))
#define __DUP(x, l, t) x=(void*)memcpy(alloca(l*sizeof(t)),x,l*sizeof(t))
#define __DUPARR(v, t) v=(void*)memcpy(v##__copy,v,sizeof(t))
#define __DEL(x) /* DUP with alloca frees storage automatically */
#define __IS(tag, typ, level) (*(tag-(__BASEOFF-level))==(long)typ##__typ)
#define __TYPEOF(p) (*(((long**)(p))-1))
#define __ISP(p, typ, level) __IS(__TYPEOF(p),typ,level)
/* runtime checks */
#define __X(i, ub) (((unsigned)(long)(i)<(unsigned long)(ub))?i:(__HALT(-2),0))
#define __XF(i, ub) SYSTEM_XCHK((long)(i), (long)(ub))
#define __RETCHK __retchk: __HALT(-3)
#define __CASECHK __HALT(-4)
#define __GUARDP(p, typ, level) ((typ*)(__ISP(p,typ,level)?p:(__HALT(-5),p)))
#define __GUARDR(r, typ, level) (*((typ*)(__IS(r##__typ,typ,level)?r:(__HALT(-5),r))))
#define __GUARDA(p, typ, level) ((struct typ*)(__IS(__TYPEOF(p),typ,level)?p:(__HALT(-5),p)))
#define __GUARDEQR(p, dyntyp, typ) if(dyntyp!=typ##__typ) __HALT(-6);*(p)
#define __GUARDEQP(p, typ) if(__TYPEOF(p)!=typ##__typ)__HALT(-6);*(p)
#define __WITHCHK __HALT(-7)
#define __R(i, ub) (((unsigned)(long)(i)<(unsigned long)(ub))?i:(__HALT(-8),0))
#define __RF(i, ub) SYSTEM_RCHK((long)(i),(long)(ub))
/* record type descriptors */
#define __TDESC(t, m, n) \
static struct t##__desc {\
long tproc[m]; \
long tag, next, level, module; \
char name[24]; \
long *base[__MAXEXT]; \
char *rsrvd; \
long blksz, ptr[n+1]; \
} t##__desc
#define __BASEOFF (__MAXEXT+1)
#define __TPROC0OFF (__BASEOFF+24/sizeof(long)+5)
#define __EOM 1
#define __TDFLDS(name, size) {__EOM}, 1, 0, 0, 0, name, {0}, 0, size
#define __ENUMP(adr, n, P) SYSTEM_ENUMP(adr, (long)(n), P)
#define __ENUMR(adr, typ, size, n, P) SYSTEM_ENUMR(adr, typ, (long)(size), (long)(n), P)
#define __INITYP(t, t0, level) \
t##__typ= &t##__desc.blksz; \
memcpy(t##__desc.base, t0##__typ - __BASEOFF, level*sizeof(long)); \
t##__desc.base[level]=t##__typ; \
t##__desc.module=(long)m; \
if(t##__desc.blksz!=sizeof(struct t)) __HALT(-15); \
t##__desc.blksz=(t##__desc.blksz+5*sizeof(long)-1)/(4*sizeof(long))*(4*sizeof(long)); \
SYSTEM_REGTYP(m, (long)&t##__desc.next); \
SYSTEM_INHERIT(t##__typ, t0##__typ)
/* Oberon-2 type bound procedures support */
#define __INITBP(t, proc, num) *(t##__typ-(__TPROC0OFF+num))=(long)proc
#define __SEND(typ, num, funtyp, parlist) ((funtyp)(*(typ-(__TPROC0OFF+num))))parlist
/* runtime system variables */
extern LONGINT SYSTEM_argc;
extern LONGINT SYSTEM_argv;
extern void (*SYSTEM_Halt)();
extern LONGINT SYSTEM_halt;
extern LONGINT SYSTEM_assert;
extern SYSTEM_PTR SYSTEM_modules;
extern LONGINT SYSTEM_heapsize;
extern LONGINT SYSTEM_allocated;
extern LONGINT SYSTEM_lock;
extern SHORTINT SYSTEM_gclock;
extern BOOLEAN SYSTEM_interrupted;
/* ANSI prototypes; not used so far
static int __STRCMP(CHAR *x, CHAR *y);
void SYSTEM_INIT(int argc, long argvadr);
void SYSTEM_FINI(void);
long SYSTEM_XCHK(long i, long ub);
long SYSTEM_RCHK(long i, long ub);
long SYSTEM_ASH(long i, long n);
long SYSTEM_ABS(long i);
double SYSTEM_ABSD(double i);
void SYSTEM_INHERIT(long *t, long *t0);
void SYSTEM_ENUMP(long *adr, long n, void (*P)(void*));
void SYSTEM_ENUMR(char *adr, long *typ, long size, long n, void (*P)(void*));
long SYSTEM_DIV(unsigned long x, unsigned long y);
long SYSTEM_MOD(unsigned long x, unsigned long y);
long SYSTEM_ENTIER(double x);
void SYSTEM_HALT(int n);
*/
#endif

488
src/lib/system/gnuc/x86_64/Unix.Mod Normal file
View file

@ -0,0 +1,488 @@
MODULE Unix; (* Josef Templ, 5.3.90 Linux system calls *)
(* ported to gnu x86_64 and added system function, noch *)
(* Module Unix provides a system call interface to Linux.
Naming conventions:
Procedure and Type-names always start with a capital letter.
error numbers as defined in Unix
other constants start with lower case letters *)
IMPORT SYSTEM;
CONST
(* various important constants *)
stdin* = 0; stdout* =1; stderr* = 2;
LOCKEX* = 2; LOCKUN* = 8; (* /usr/include/file.h *)
AFINET* = 2; (* /usr/include/sys/socket.h *)
PFINET* = AFINET; (* /usr/include/linux/socket.h *)
SOCKSTREAM* = 1; (* /usr/include/linux/socket.h *)
FIONREAD* = 541BH; (* in /usr/include/asm/termios.h *)
SETFL* = 4; (* set file descriptor flags; in asm/fcntl.h *)
TCP* = 0;
(* flag sets, cf. /usr/include/asm/fcntl.h *)
rdonly* = {}; wronly* = {0}; rdwr* = {1}; creat* = {6}; excl* = {7}; trunc* = {9}; append* = {10}; ndelay = {11};
(* error numbers *)
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 children *)
EAGAIN* = 11; (* No more processes *)
ENOMEM* = 12; (* Not enough core *)
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; (* Argument too large *)
ERANGE* = 34; (* Result too large *)
EDEADLK* = 35; (* Resource deadlock would occur *)
ENAMETOOLONG* = 36; (* File name too long *)
ENOLCK* = 37; (* No record locks available *)
ENOSYS* = 38; (* Function not implemented *)
ENOTEMPTY* = 39; (* Directory not empty *)
ELOOP* = 40; (* Too many symbolic links encountered *)
EWOULDBLOCK* = EAGAIN; (* Operation would block *)
ENOMSG* = 42; (* No message of desired type *)
EIDRM* = 43; (* Identifier removed *)
ECHRNG* = 44; (* Channel number out of range *)
EL2NSYNC* = 45; (* Level 2 not synchronized *)
EL3HLT* = 46; (* Level 3 halted *)
EL3RST* = 47; (* Level 3 reset *)
ELNRNG* = 48; (* Link number out of range *)
EUNATCH* = 49; (* Protocol driver not attached *)
ENOCSI* = 50; (* No CSI structure available *)
EL2HLT* = 51; (* Level 2 halted *)
EBADE* = 52; (* Invalid exchange *)
EBADR* = 53; (* Invalid request descriptor *)
EXFULL* = 54; (* Exchange full *)
ENOANO* = 55; (* No anode *)
EBADRQC* = 56; (* Invalid request code *)
EBADSLT* = 57; (* Invalid slot *)
EDEADLOCK* = 58; (* File locking deadlock error *)
EBFONT* = 59; (* Bad font file format *)
ENOSTR* = 60; (* Device not a stream *)
ENODATA* = 61; (* No data available *)
ETIME* = 62; (* Timer expired *)
ENOSR* = 63; (* Out of streams resources *)
ENONET* = 64; (* Machine is not on the network *)
ENOPKG* = 65; (* Package not installed *)
EREMOTE* = 66; (* Object is remote *)
ENOLINK* = 67; (* Link has been severed *)
EADV* = 68; (* Advertise error *)
ESRMNT* = 69; (* Srmount error *)
ECOMM* = 70; (* Communication error on send *)
EPROTO* = 71; (* Protocol error *)
EMULTIHOP* = 72; (* Multihop attempted *)
EDOTDOT* = 73; (* RFS specific error *)
EBADMSG* = 74; (* Not a data message *)
EOVERFLOW* = 75; (* Value too large for defined data type *)
ENOTUNIQ* = 76; (* Name not unique on network *)
EBADFD* = 77; (* File descriptor in bad state *)
EREMCHG* = 78; (* Remote address changed *)
ELIBACC* = 79; (* Can not access a needed shared library *)
ELIBBAD* = 80; (* Accessing a corrupted shared library *)
ELIBSCN* = 81; (* .lib section in a.out corrupted *)
ELIBMAX* = 82; (* Attempting to link in too many shared libraries *)
ELIBEXEC* = 83; (* Cannot exec a shared library directly *)
EILSEQ* = 84; (* Illegal byte sequence *)
ERESTART* = 85; (* Interrupted system call should be restarted *)
ESTRPIPE* = 86; (* Streams pipe error *)
EUSERS* = 87; (* Too many users *)
ENOTSOCK* = 88; (* Socket operation on non-socket *)
EDESTADDRREQ* = 89; (* Destination address required *)
EMSGSIZE* = 90; (* Message too long *)
EPROTOTYPE* = 91; (* Protocol wrong type for socket *)
ENOPROTOOPT* = 92; (* Protocol not available *)
EPROTONOSUPPORT* = 93; (* Protocol not supported *)
ESOCKTNOSUPPORT* = 94; (* Socket type not supported *)
EOPNOTSUPP* = 95; (* Operation not supported on transport endpoint *)
EPFNOSUPPORT* = 96; (* Protocol family not supported *)
EAFNOSUPPORT* = 97; (* Address family not supported by protocol *)
EADDRINUSE* = 98; (* Address already in use *)
EADDRNOTAVAIL* = 99; (* Cannot assign requested address *)
ENETDOWN* = 100; (* Network is down *)
ENETUNREACH* = 101; (* Network is unreachable *)
ENETRESET* = 102; (* Network dropped connection because of reset *)
ECONNABORTED* = 103; (* Software caused connection abort *)
ECONNRESET* = 104; (* Connection reset by peer *)
ENOBUFS* = 105; (* No buffer space available *)
EISCONN* = 106; (* Transport endpoint is already connected *)
ENOTCONN* = 107; (* Transport endpoint is not connected *)
ESHUTDOWN* = 108; (* Cannot send after transport endpoint shutdown *)
ETOOMANYREFS* = 109; (* Too many references: cannot splice *)
ETIMEDOUT* = 110; (* Connection timed out *)
ECONNREFUSED* = 111; (* Connection refused *)
EHOSTDOWN* = 112; (* Host is down *)
EHOSTUNREACH* = 113; (* No route to host *)
EALREADY* = 114; (* Operation already in progress *)
EINPROGRESS* = 115; (* Operation now in progress *)
ESTALE* = 116; (* Stale NFS file handle *)
EUCLEAN* = 117; (* Structure needs cleaning *)
ENOTNAM* = 118; (* Not a XENIX named type file *)
ENAVAIL* = 119; (* No XENIX semaphores available *)
EISNAM* = 120; (* Is a named type file *)
EREMOTEIO* = 121; (* Remote I/O error *)
EDQUOT* = 122; (* Quota exceeded *)
CONST sigsetarrlength = 1024 / 8 * SIZE(LONGINT);
TYPE
(* bits/sigset.h
_SIGSET_NWORDS (1024 / (8 * sizeof (unsigned long int)))
1024 / 8*8 = 16
1024 / 8*4 = 32
*)
sigsett* = RECORD
val : ARRAY 16 OF LONGINT (* 32 for 32 bit *)
(*val : ARRAY sigsetarrlength OF LONGINT *)
END;
JmpBuf* = RECORD
(*bx*, si*, di*, bp*, sp*, pc*: LONGINT;*)
(* bits/setjmp.h sets up longer array in GNU libc *)
(*
# if __WORDSIZE == 64
typedef long int __jmp_buf[8];
# else
typedef int __jmp_buf[6];
# endif
*)
bx*, si*, di*, bp*, sp*, pc*, ki*, ku*: LONGINT;
(* setjmp.h
/* Calling environment, plus possibly a saved signal mask. */
struct __jmp_buf_tag
{
/* NOTE: The machine-dependent definitions of `__sigsetjmp'
assume that a `jmp_buf' begins with a `__jmp_buf' and that
`__mask_was_saved' follows it. Do not move these members
or add others before it. */
__jmp_buf __jmpbuf; /* Calling environment. */
int __mask_was_saved; /* Saved the signal mask? */
__sigset_t __saved_mask; /* Saved signal mask. */
};
*)
(*maskWasSaved*, savedMask*: LONGINT;*)
maskWasSaved*: INTEGER;
(*
# define _SIGSET_NWORDS (1024 / (8 * sizeof (unsigned long int)))
typedef struct
{
unsigned long int __val[_SIGSET_NWORDS];
} __sigset_t;
*)
savedMask*: sigsett;
END ;
Status* = RECORD (* struct stat *)
dev* : LONGINT; (* dev_t 8 *)
ino* : LONGINT; (* ino 8 *)
nlink* : LONGINT;
mode* : INTEGER;
uid*, gid*: INTEGER;
rdev* : LONGINT;
size* : LONGINT;
blksize* : LONGINT;
blocks* : LONGINT;
atime* : LONGINT;
atimences* : LONGINT;
mtime* : LONGINT;
mtimensec* : LONGINT;
ctime* : LONGINT;
ctimensec* : LONGINT;
unused4*, unused5*: LONGINT;
END ;
(* from /usr/include/bits/time.h
struct timeval
{
__time_t tv_sec; /* Seconds. */ //__time_t 8
__suseconds_t tv_usec; /* Microseconds. */ __suseconds_t 8
};
*)
Timeval* = RECORD
sec*, usec*: LONGINT
END ;
(*
from man gettimeofday
struct timezone {
int tz_minuteswest; /* minutes west of Greenwich */ int 4
int tz_dsttime; /* type of DST correction */ int 4
};
*)
Timezone* = RECORD
(*minuteswest*, dsttime*: LONGINT*)
minuteswest*, dsttime*: INTEGER
END ;
Itimerval* = RECORD
interval*, value*: Timeval
END ;
FdSet* = ARRAY 8 OF SET;
SigCtxPtr* = POINTER TO SigContext;
SigContext* = RECORD
END ;
SignalHandler* = PROCEDURE (sig, code: LONGINT; scp: SigCtxPtr);
Dirent* = RECORD
ino, off: LONGINT;
reclen: INTEGER;
name: ARRAY 256 OF CHAR;
END ;
Rusage* = RECORD
utime*, stime*: Timeval;
maxrss*, ixrss*, idrss*, isrss*,
minflt*, majflt*, nswap*, inblock*,
oublock*, msgsnd*, msgrcv*, nsignals*,
nvcsw*, nivcsw*: LONGINT
END ;
Iovec* = RECORD
base*, len*: LONGINT
END ;
SocketPair* = ARRAY 2 OF LONGINT;
Pollfd* = RECORD
fd*: LONGINT;
events*, revents*: INTEGER
END ;
Sockaddr* = RECORD
family*: INTEGER;
port*: INTEGER;
internetAddr*: LONGINT;
pad*: ARRAY 8 OF CHAR;
END ;
HostEntry* = POINTER [1] TO Hostent;
Hostent* = RECORD
name*, aliases*: LONGINT;
addrtype*, length*: LONGINT;
addrlist*: LONGINT; (*POINTER TO POINTER TO LONGINT, network byte order*)
END;
Name* = ARRAY OF CHAR;
PROCEDURE -includeStat()
"#include <sys/stat.h>";
PROCEDURE -includeErrno()
"#include <errno.h>";
PROCEDURE -err(): LONGINT
"errno";
PROCEDURE errno*(): LONGINT;
BEGIN
RETURN err()
END errno;
PROCEDURE -Exit*(n: LONGINT)
"exit(n)";
PROCEDURE -Fork*(): LONGINT
"fork()";
PROCEDURE -Wait*(VAR status: LONGINT): LONGINT
"wait(status)";
PROCEDURE -Select*(width: LONGINT; VAR readfds, writefds, exceptfds: FdSet; VAR timeout: Timeval): LONGINT
"select(width, readfds, writefds, exceptfds, timeout)";
PROCEDURE -Gettimeofday* (VAR tv: Timeval; VAR tz: Timezone)
"gettimeofday(tv, tz)";
PROCEDURE -Read* (fd, buf, nbyte: LONGINT): LONGINT
"read(fd, buf, nbyte)";
PROCEDURE -ReadBlk* (fd: LONGINT; VAR buf: ARRAY OF SYSTEM.BYTE): LONGINT
"read(fd, buf, buf__len)";
PROCEDURE -Write* (fd, buf, nbyte: LONGINT): LONGINT
"write(fd, buf, nbyte)";
PROCEDURE -WriteBlk* (fd: LONGINT; VAR buf: ARRAY OF SYSTEM.BYTE): LONGINT
"write(fd, buf, buf__len)";
PROCEDURE -Dup*(fd: LONGINT): LONGINT
"dup(fd)";
PROCEDURE -Dup2*(fd1, fd2: LONGINT): LONGINT
"dup(fd1, fd2)";
PROCEDURE -Getpid*(): LONGINT
"getpid()";
PROCEDURE -Getuid*(): LONGINT
"getuid()";
PROCEDURE -Geteuid*(): LONGINT
"geteuid()";
PROCEDURE -Getgid*(): LONGINT
"getgid()";
PROCEDURE -Getegid*(): LONGINT
"getegid()";
PROCEDURE -Unlink*(name: Name): LONGINT
"unlink(name)";
PROCEDURE -Open*(name: Name; flag, mode: SET): LONGINT
"open(name, flag, mode)";
PROCEDURE -Close*(fd: LONGINT): LONGINT
"close(fd)";
PROCEDURE -stat(name: Name; VAR statbuf: Status): LONGINT
"stat((const char*)name, (struct stat*)statbuf)";
PROCEDURE Stat*(name: Name; VAR statbuf: Status): LONGINT;
VAR res: LONGINT;
BEGIN
res := stat(name, statbuf);
(* make the first 4 bytes as unique as possible (used in module Files for caching!) *)
(* don't understand this
INC(statbuf.dev, statbuf.devX);
INC(statbuf.rdev, statbuf.rdevX); *)
RETURN res;
END Stat;
PROCEDURE -fstat(fd: LONGINT; VAR statbuf: Status): LONGINT
"fstat(fd, (struct stat*)statbuf)";
PROCEDURE Fstat*(fd: LONGINT; VAR statbuf: Status): LONGINT;
VAR res: LONGINT;
BEGIN
res := fstat(fd, statbuf);
(* make the first 4 bytes as unique as possible (used in module Files for caching!) *)
(*INC(statbuf.dev, statbuf.devX);
INC(statbuf.rdev, statbuf.rdevX); *)
RETURN res;
END Fstat;
PROCEDURE -Fchmod*(fd, mode: LONGINT): LONGINT
"fchmod(fd, mode)";
PROCEDURE -Chmod*(path: Name; mode: LONGINT): LONGINT
"chmod(path, mode)";
PROCEDURE -Lseek*(fd, offset, origin: LONGINT): LONGINT
"lseek(fd, offset, origin)";
PROCEDURE -Fsync*(fd: LONGINT): LONGINT
"fsync(fd)";
PROCEDURE -Fcntl*(fd, cmd, arg: LONGINT ): LONGINT
"fcntl(fd, cmd, arg)";
PROCEDURE -Flock*(fd, operation: LONGINT): LONGINT
"flock(fd, operation)";
PROCEDURE -Ftruncate*(fd, length: LONGINT): LONGINT
"ftruncate(fd, length)";
PROCEDURE -Readblk*(fd: LONGINT; VAR buf: ARRAY OF SYSTEM.BYTE; len: LONGINT): LONGINT
"read(fd, buf, len)";
PROCEDURE -Rename*(old, new: Name): LONGINT
"rename(old, new)";
PROCEDURE -Chdir*(path: Name): LONGINT
"chdir(path)";
PROCEDURE -Ioctl*(fd, request, arg: LONGINT): LONGINT
"ioctl(fd, request, arg)";
PROCEDURE -Kill*(pid, sig: LONGINT): LONGINT
"kill(pid, sig)";
PROCEDURE -Sigsetmask*(mask: LONGINT): LONGINT
"sigsetmask(mask)";
(* TCP/IP networking *)
PROCEDURE -Gethostbyname*(name: Name): HostEntry
"(Unix_HostEntry)gethostbyname(name)";
PROCEDURE -Gethostname*(VAR name: Name): LONGINT
"gethostname(name, name__len)";
PROCEDURE -Socket*(af, type, protocol: LONGINT): LONGINT
"socket(af, type, protocol)";
PROCEDURE -Connect*(socket: LONGINT; name: Sockaddr; namelen: LONGINT): LONGINT
"connect(socket, &(name), namelen)";
PROCEDURE -Getsockname*(socket: LONGINT; VAR name: Sockaddr; VAR namelen: LONGINT): LONGINT
"getsockname(socket, name, namelen)";
PROCEDURE -Bind*(socket: LONGINT; name: Sockaddr; namelen: LONGINT): LONGINT
"bind(socket, &(name), namelen)";
PROCEDURE -Listen*(socket, backlog: LONGINT): LONGINT
"listen(socket, backlog)";
PROCEDURE -Accept*(socket: LONGINT; VAR addr: Sockaddr; VAR addrlen: LONGINT): LONGINT
"accept(socket, addr, addrlen)";
PROCEDURE -Recv*(socket, bufadr, buflen, flags: LONGINT): LONGINT
"recv(socket, bufadr, buflen, flags)";
PROCEDURE -Send*(socket, bufadr, buflen, flags: LONGINT): LONGINT
"send(socket, bufadr, buflen, flags)";
PROCEDURE -sys(str: ARRAY OF CHAR): INTEGER (* need this to call external tools like gcc or gas; noch *)
"system(str)";
PROCEDURE system*(cmd : ARRAY OF CHAR);
VAR r : INTEGER;
BEGIN
r := sys(cmd);
END system;
END Unix.

565
src/lib/ulm/gnuc/ulmEvents.Mod Normal file
View file

@ -0,0 +1,565 @@
(* Ulm's Oberon Library
Copyright (C) 1989-1994 by University of Ulm, SAI, D-89069 Ulm, Germany
----------------------------------------------------------------------------
Ulm's Oberon Library is free software; you can redistribute it
and/or modify it under the terms of the GNU Library General Public
License as published by the Free Software Foundation; either version
2 of the License, or (at your option) any later version.
Ulm's Oberon Library is distributed in the hope that it will be
useful, but WITHOUT ANY WARRANTY; without even the implied warranty
of MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU
Library General Public License for more details.
You should have received a copy of the GNU Library General Public
License along with this library; if not, write to the Free Software
Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA.
----------------------------------------------------------------------------
E-mail contact: oberon@mathematik.uni-ulm.de
----------------------------------------------------------------------------
$Id: Events.om,v 1.4 2004/03/30 17:48:14 borchert Exp $
----------------------------------------------------------------------------
$Log: Events.om,v $
Revision 1.4 2004/03/30 17:48:14 borchert
support of external queue handling added
Revision 1.3 1996/01/04 17:07:20 borchert
event types are now an extension of Services.Object
Revision 1.2 1994/07/18 14:17:17 borchert
unused variables of Raise (oldevent + newevent) removed
Revision 1.1 1994/02/22 20:07:41 borchert
Initial revision
----------------------------------------------------------------------------
AFB 8/89
----------------------------------------------------------------------------
*)
MODULE ulmEvents;
IMPORT Objects := ulmObjects, Priorities := ulmPriorities, Services := ulmServices, SYS := ulmSYSTEM, SYSTEM;
TYPE
EventType* = POINTER TO EventTypeRec;
CONST
(* possibilities on receipt of an event: *)
default* = 0; (* causes abortion *)
ignore* = 1; (* ignore event *)
funcs* = 2; (* call associated event handlers *)
TYPE
Reaction* = INTEGER; (* one of default, ignore, or funcs *)
Message* = ARRAY 80 OF CHAR;
Event* = POINTER TO EventRec;
EventRec* =
RECORD
(Objects.ObjectRec)
type*: EventType;
message*: Message;
(* private part *)
next: Event; (* queue *)
END;
EventHandler = PROCEDURE (event: Event);
(* event managers are needed if there is any action necessary
on changing the kind of reaction
*)
EventManager = PROCEDURE (type: EventType; reaction: Reaction);
Priority = INTEGER; (* must be non-negative *)
(* every event with reaction `funcs' has a handler list;
the list is in calling order which is reverse to
the order of `Handler'-calls
*)
HandlerList = POINTER TO HandlerRec;
HandlerRec* =
RECORD
(Objects.ObjectRec)
handler*: EventHandler;
next*: HandlerList;
END;
SaveList = POINTER TO SaveRec;
SaveRec =
RECORD
reaction: Reaction;
handlers: HandlerList;
next: SaveList;
END;
EventTypeRec* =
RECORD
(Services.ObjectRec)
(* private components *)
handlers: HandlerList;
priority: Priority;
reaction: Reaction;
manager: EventManager;
savelist: SaveList;
END;
Queue = POINTER TO QueueRec;
QueueRec =
RECORD
priority: INTEGER; (* queue for this priority *)
head, tail: Event;
next: Queue; (* queue with lower priority *)
END;
VAR
eventTypeType: Services.Type;
CONST
priotabsize = 256; (* size of a priority table *)
maxnestlevel = 1024; (* of Raise-calls (avoids endless recursion) *)
TYPE
(* in some cases coroutines uses local priority systems *)
PrioritySystem* = POINTER TO PrioritySystemRec;
PrioritySystemRec* =
RECORD
(Objects.ObjectRec)
(* private part *)
currentPriority: Priority;
priotab: ARRAY priotabsize OF Priority;
priotop: INTEGER;
overflow: INTEGER; (* of priority table *)
END;
CONST
priorityViolation* = 0; (* priority violation (EnterPriority *)
unbalancedExitPriority* = 1; (* unbalanced call of ExitPriority *)
unbalancedRestoreReaction* = 2; (* unbalanced call of RestoreReaction *)
negPriority* = 3; (* negative priority given to SetPriority *)
errorcodes* = 4;
TYPE
ErrorEvent* = POINTER TO ErrorEventRec;
ErrorEventRec* =
RECORD
(EventRec)
errorcode*: SHORTINT;
END;
VAR
errormsg*: ARRAY errorcodes OF Message;
error*: EventType;
VAR
(* private part *)
abort, log, queueHandler: EventHandler;
nestlevel: INTEGER; (* of Raise calls *)
queue: Queue;
lock: BOOLEAN; (* lock critical operations *)
psys: PrioritySystem; (* current priority system *)
PROCEDURE ^ Define*(VAR type: EventType);
PROCEDURE ^ SetPriority*(type: EventType; priority: Priority);
PROCEDURE ^ Raise*(event: Event);
PROCEDURE InitErrorHandling;
BEGIN
Define(error); SetPriority(error, Priorities.liberrors);
errormsg[priorityViolation] :=
"priority violation (Events.EnterPriority)";
errormsg[unbalancedExitPriority] :=
"unbalanced call of Events.ExitPriority";
errormsg[unbalancedRestoreReaction] :=
"unbalanced call of Events.RestoreReaction";
errormsg[negPriority] :=
"negative priority given to Events.SetPriority";
END InitErrorHandling;
PROCEDURE Error(code: SHORTINT);
VAR event: ErrorEvent;
BEGIN
NEW(event); event.type := error;
event.message := errormsg[code];
event.errorcode := code;
Raise(event);
END Error;
PROCEDURE NilEventManager(type: EventType; reaction: Reaction);
END NilEventManager;
PROCEDURE Init*(type: EventType);
VAR
stype: Services.Type;
BEGIN
Services.GetType(type, stype); ASSERT(stype # NIL);
type.handlers := NIL;
type.priority := Priorities.default;
type.reaction := default;
type.manager := NilEventManager;
type.savelist := NIL;
END Init;
PROCEDURE Define*(VAR type: EventType);
(* definition of a new event;
an unique event number is returned;
the reaction on receipt of `type' is defined to be `default'
*)
BEGIN
NEW(type);
Services.Init(type, eventTypeType);
Init(type);
END Define;
PROCEDURE GetReaction*(type: EventType) : Reaction;
(* returns either `default', `ignore', or `funcs' *)
BEGIN
RETURN type.reaction
END GetReaction;
PROCEDURE SetPriority*(type: EventType; priority: Priority);
(* (re-)defines the priority of an event *)
BEGIN
IF priority <= 0 THEN
Error(negPriority);
ELSE
type.priority := priority;
END;
END SetPriority;
PROCEDURE GetEventPriority*(type: EventType) : Priority;
(* return the priority of the given event *)
BEGIN
RETURN type.priority
END GetEventPriority;
PROCEDURE Manager*(type: EventType; manager: EventManager);
BEGIN
type.manager := manager;
END Manager;
PROCEDURE Handler*(type: EventType; handler: EventHandler);
(* add `handler' to the list of handlers for event `type' *)
VAR
newhandler: HandlerList;
BEGIN
NEW(newhandler);
newhandler.handler := handler; newhandler.next := type.handlers;
type.handlers := newhandler;
IF type.reaction # funcs THEN
type.reaction := funcs; type.manager(type, funcs);
END;
END Handler;
PROCEDURE RemoveHandlers*(type: EventType);
(* remove list of handlers for event `type';
implies default reaction (abortion) on
receipt of `type'
*)
BEGIN
type.handlers := NIL;
IF type.reaction # default THEN
type.reaction := default; type.manager(type, default);
END;
END RemoveHandlers;
PROCEDURE Ignore*(type: EventType);
(* implies RemoveHandlers(type) and causes receipt
of `type' to be ignored
*)
BEGIN
type.handlers := NIL;
IF type.reaction # ignore THEN
type.reaction := ignore; type.manager(type, ignore);
END;
END Ignore;
PROCEDURE GetHandlers*(type: EventType; handlers: HandlerList);
(* returns the list of handlers in `handlers';
the reaction of `type' must be `funcs'
*)
BEGIN
handlers := type.handlers;
END GetHandlers;
PROCEDURE Log*(loghandler: EventHandler);
(* call `loghandler' for every event;
subsequent calls of `Log' replace the loghandler;
the loghandler is not called on default and ignore
*)
BEGIN
log := loghandler;
END Log;
PROCEDURE GetLog*(VAR loghandler: EventHandler);
(* returns the loghandler set by `Log' *)
BEGIN
loghandler := log;
END GetLog;
(* noch *)
PROCEDURE -getaddr(handler: EventHandler): LONGINT
"(LONGINT)&handler";
PROCEDURE NilHandler*(event: Event);
(* an empty event handler *)
END NilHandler;
(* now QueueHandler will translate partly like
i = (long)&handler;
j = (long)&ulmEvents_NilHandler;
b = i != j;
if (!(b)) {SYSTEM_assert = 0; SYSTEM_HALT(-1);};
; noch
*)
PROCEDURE QueueHandler*(handler: EventHandler);
(* setup an alternative handler of events
that cannot be processed now because
of their unsufficient priority
*)
VAR b : BOOLEAN; (* noch *)
i,j : LONGINT;
BEGIN
i := getaddr(handler);
j := getaddr(NilHandler);
b := i # j;
(*ASSERT (handler # NilHandler);*)
ASSERT(b);
queueHandler := handler;
END QueueHandler;
PROCEDURE AbortHandler*(handler: EventHandler);
(* defines the handler to be called on abortion *)
BEGIN
abort := handler;
END AbortHandler;
PROCEDURE GetAbortHandler*(VAR handler: EventHandler);
(* returns the handler set by `AbortHandler' *)
BEGIN
handler := abort;
END GetAbortHandler;
PROCEDURE ^ CallHandlers(event: Event);
PROCEDURE WorkupQueue;
VAR
ptr: Event;
BEGIN
WHILE (queue # NIL) & (queue.priority > psys.currentPriority) DO
IF SYS.TAS(lock) THEN RETURN END;
ptr := queue.head; queue := queue.next;
lock := FALSE;
WHILE ptr # NIL DO
CallHandlers(ptr);
ptr := ptr.next;
END;
END;
END WorkupQueue;
PROCEDURE CallHandlers(event: Event);
VAR
ptr: HandlerList;
oldPriority: Priority;
BEGIN
CASE event.type.reaction OF
| default: abort(event);
| ignore:
| funcs: oldPriority := psys.currentPriority;
psys.currentPriority := event.type.priority;
log(event);
ptr := event.type.handlers;
WHILE ptr # NIL DO
ptr.handler(event);
ptr := ptr.next;
END;
psys.currentPriority := oldPriority;
END;
END CallHandlers;
PROCEDURE Raise*(event: Event);
(* call all event handlers (in reverse order)
associated with event.type;
abort if there are none;
some system events may abort in another way
(i.e. they do not cause the abortion handler to be called)
*)
VAR
priority: Priority;
PROCEDURE AddToQueue(event: Event);
VAR
prev, ptr: Queue;
BEGIN
event.next := NIL;
ptr := queue; prev := NIL;
WHILE (ptr # NIL) & (ptr.priority > priority) DO
prev := ptr;
ptr := ptr.next;
END;
IF (ptr # NIL) & (ptr.priority = priority) THEN
ptr.tail.next := event;
ptr.tail := event;
ELSE
NEW(ptr);
ptr.priority := priority;
ptr.head := event; ptr.tail := event;
IF prev = NIL THEN
ptr.next := queue;
queue := ptr;
ELSE
ptr.next := prev.next;
prev.next := ptr;
END;
END;
END AddToQueue;
BEGIN (* Raise *)
INC(nestlevel);
IF nestlevel >= maxnestlevel THEN
abort(event);
ELSE
IF event.type.reaction # ignore THEN
priority := event.type.priority;
IF psys.currentPriority < priority THEN
CallHandlers(event); WorkupQueue;
ELSIF queueHandler # NIL THEN
queueHandler(event);
ELSIF ~SYS.TAS(lock) THEN
AddToQueue(event);
lock := FALSE;
END;
END;
END;
DEC(nestlevel);
END Raise;
PROCEDURE CreatePrioritySystem*(VAR prioritySystem: PrioritySystem);
(* create and initialize a new priority system *)
BEGIN
NEW(prioritySystem);
prioritySystem.currentPriority := Priorities.base;
prioritySystem.priotop := 0;
END CreatePrioritySystem;
PROCEDURE CurrentPrioritySystem*() : PrioritySystem;
(* return the priority system currently active *)
BEGIN
RETURN psys
END CurrentPrioritySystem;
PROCEDURE SwitchPrioritySystem*(prioritySystem: PrioritySystem);
(* switch to another priority system; this is typically
done in case of task switches
*)
BEGIN
psys := prioritySystem;
END SwitchPrioritySystem;
PROCEDURE EnterPriority*(priority: Priority);
(* sets the current priority to `priority';
it is an error to give a priority less than
the current priority (event `badpriority')
*)
BEGIN
IF psys.currentPriority <= priority THEN
IF (psys.overflow = 0) & (psys.priotop < priotabsize) THEN
psys.priotab[psys.priotop] := psys.currentPriority;
INC(psys.priotop);
psys.currentPriority := priority;
ELSE
INC(psys.overflow);
END;
ELSE
Error(priorityViolation);
INC(psys.overflow);
END;
END EnterPriority;
PROCEDURE AssertPriority*(priority: Priority);
(* current priority
< priority: set the current priority to `priority'
>= priority: the current priority remains unchanged
*)
BEGIN
IF (psys.overflow = 0) & (psys.priotop < priotabsize) THEN
psys.priotab[psys.priotop] := psys.currentPriority; INC(psys.priotop);
IF psys.currentPriority < priority THEN
psys.currentPriority := priority;
END;
ELSE
INC(psys.overflow);
END;
END AssertPriority;
PROCEDURE ExitPriority*;
(* causes the priority before the last effective call
of SetPriority or AssertPriority to be restored
*)
BEGIN
IF psys.overflow > 0 THEN
DEC(psys.overflow);
ELSIF psys.priotop = 0 THEN
Error(unbalancedExitPriority);
ELSE
DEC(psys.priotop); psys.currentPriority := psys.priotab[psys.priotop];
WorkupQueue;
END;
END ExitPriority;
PROCEDURE GetPriority*() : Priority;
(* returns the current priority *)
BEGIN
RETURN psys.currentPriority
END GetPriority;
PROCEDURE SaveReaction*(type: EventType);
(* saves current reaction until call of RestoreReaction;
the new reaction of `type' is defined to be `ignore'
but can be changed by Events.Handler or Events.RemoveHandlers
*)
VAR
savelist: SaveList;
BEGIN
NEW(savelist);
savelist.reaction := type.reaction;
savelist.handlers := type.handlers;
savelist.next := type.savelist;
type.savelist := savelist;
type.handlers := NIL;
IF type.reaction # ignore THEN
type.reaction := ignore; type.manager(type, ignore);
END;
END SaveReaction;
PROCEDURE RestoreReaction*(type: EventType);
(* restores old reaction;
must be properly nested
*)
VAR
savelist: SaveList;
BEGIN
IF type.savelist = NIL THEN
Error(unbalancedRestoreReaction);
ELSE
savelist := type.savelist;
type.savelist := savelist.next;
type.handlers := savelist.handlers;
IF type.reaction # savelist.reaction THEN
type.reaction := savelist.reaction;
type.manager(type, savelist.reaction);
END;
END;
END RestoreReaction;
BEGIN
CreatePrioritySystem(psys);
Services.CreateType(eventTypeType, "Events.EventType", "");
abort := NilHandler; log := NilHandler; queueHandler := NIL;
nestlevel := 0;
queue := NIL;
lock := FALSE;
InitErrorHandling;
END ulmEvents.

60
src/lib/ulm/ulmASCII.Mod Normal file
View file

@ -0,0 +1,60 @@
(* Ulm's Oberon Library
Copyright (C) 1989-1994 by University of Ulm, SAI, D-89069 Ulm, Germany
----------------------------------------------------------------------------
Ulm's Oberon Library is free software; you can redistribute it
and/or modify it under the terms of the GNU Library General Public
License as published by the Free Software Foundation; either version
2 of the License, or (at your option) any later version.
Ulm's Oberon Library is distributed in the hope that it will be
useful, but WITHOUT ANY WARRANTY; without even the implied warranty
of MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU
Library General Public License for more details.
You should have received a copy of the GNU Library General Public
License along with this library; if not, write to the Free Software
Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA.
----------------------------------------------------------------------------
E-mail contact: oberon@mathematik.uni-ulm.de
----------------------------------------------------------------------------
$Id: ASCII.om,v 1.1 1994/02/22 20:01:03 borchert Exp $
----------------------------------------------------------------------------
$Log: ASCII.om,v $
Revision 1.1 1994/02/22 20:01:03 borchert
Initial revision
----------------------------------------------------------------------------
AFB 12/90
----------------------------------------------------------------------------
*)
MODULE ulmASCII;
CONST
(* control characters *)
nul* = 000X; soh* = 001X; stx* = 002X; etx* = 003X; eot* = 004X;
enq* = 005X; ack* = 006X; bel* = 007X; bs* = 008X; ht* = 009X;
nl* = 00AX; vt* = 00BX; np* = 00CX; cr* = 00DX; so* = 00EX;
si* = 00FX; dle* = 010X; dc1* = 011X; dc2* = 012X; dc3* = 013X;
dc4* = 014X; nak* = 015X; syn* = 016X; etb* = 017X; can* = 018X;
em* = 019X; sub* = 01AX; esc* = 01BX; fs* = 01CX; gs* = 01DX;
rs* = 01EX; us* = 01FX; sp* = 020X; del* = 07FX;
CtrlA* = 01X; CtrlB* = 02X; CtrlC* = 03X; CtrlD* = 04X; CtrlE* = 05X;
CtrlF* = 06X; CtrlG* = 07X; CtrlH* = 08X; CtrlI* = 09X; CtrlJ* = 0AX;
CtrlK* = 0BX; CtrlL* = 0CX; CtrlM* = 0DX; CtrlN* = 0EX; CtrlO* = 0FX;
CtrlP* = 10X; CtrlQ* = 11X; CtrlR* = 12X; CtrlS* = 13X; CtrlT* = 14X;
CtrlU* = 15X; CtrlV* = 16X; CtrlW* = 17X; CtrlX* = 18X; CtrlY* = 19X;
CtrlZ* = 1AX;
(* other usual names *)
EOL* = nl;
null* = nul;
bell* = bel;
tab* = ht;
lf* = nl;
ff* = np;
quote* = 22X;
END ulmASCII.

140
src/lib/ulm/ulmDisciplines.Mod Normal file
View file

@ -0,0 +1,140 @@
(* Ulm's Oberon Library
Copyright (C) 1989-1994 by University of Ulm, SAI, D-89069 Ulm, Germany
----------------------------------------------------------------------------
Ulm's Oberon Library is free software; you can redistribute it
and/or modify it under the terms of the GNU Library General Public
License as published by the Free Software Foundation; either version
2 of the License, or (at your option) any later version.
Ulm's Oberon Library is distributed in the hope that it will be
useful, but WITHOUT ANY WARRANTY; without even the implied warranty
of MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU
Library General Public License for more details.
You should have received a copy of the GNU Library General Public
License along with this library; if not, write to the Free Software
Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA.
----------------------------------------------------------------------------
E-mail contact: oberon@mathematik.uni-ulm.de
----------------------------------------------------------------------------
$Id: Disciplines.om,v 1.1 1994/02/22 20:07:03 borchert Exp $
----------------------------------------------------------------------------
$Log: Disciplines.om,v $
Revision 1.1 1994/02/22 20:07:03 borchert
Initial revision
----------------------------------------------------------------------------
AFB 5/91
----------------------------------------------------------------------------
*)
MODULE ulmDisciplines;
(* Disciplines allows to attach additional data structures to
abstract datatypes like Streams;
these added data structures permit to parametrize operations
which are provided by other modules (e.g. Read or Write for Streams)
*)
IMPORT Objects := ulmObjects;
TYPE
Identifier* = LONGINT;
Discipline* = POINTER TO DisciplineRec;
DisciplineRec* =
RECORD
(Objects.ObjectRec)
id*: Identifier; (* should be unique for all types of disciplines *)
END;
DisciplineList = POINTER TO DisciplineListRec;
DisciplineListRec =
RECORD
discipline: Discipline;
id: Identifier; (* copied from discipline.id *)
next: DisciplineList;
END;
Object* = POINTER TO ObjectRec;
ObjectRec* =
RECORD
(Objects.ObjectRec)
(* private part *)
list: DisciplineList; (* set of disciplines *)
END;
VAR
unique: Identifier;
PROCEDURE Unique*() : Identifier;
(* returns a unique identifier;
this procedure should be called during initialization by
all modules defining a discipline type
*)
BEGIN
INC(unique);
RETURN unique
END Unique;
PROCEDURE Remove*(object: Object; id: Identifier);
(* remove the discipline with the given id from object, if it exists *)
VAR
prev, dl: DisciplineList;
BEGIN
prev := NIL;
dl := object.list;
WHILE (dl # NIL) & (dl.id # id) DO
prev := dl; dl := dl.next;
END;
IF dl # NIL THEN
IF prev = NIL THEN
object.list := dl.next;
ELSE
prev.next := dl.next;
END;
END;
END Remove;
PROCEDURE Add*(object: Object; discipline: Discipline);
(* adds a new discipline to the given object;
if already a discipline with the same identifier exist
it is deleted first
*)
VAR
dl: DisciplineList;
BEGIN
dl := object.list;
WHILE (dl # NIL) & (dl.id # discipline.id) DO
dl := dl.next;
END;
IF dl = NIL THEN
NEW(dl);
dl.id := discipline.id;
dl.next := object.list;
object.list := dl;
END;
dl.discipline := discipline;
END Add;
PROCEDURE Seek*(object: Object; id: Identifier;
VAR discipline: Discipline) : BOOLEAN;
(* returns TRUE if a discipline with the given id is found *)
VAR
dl: DisciplineList;
BEGIN
dl := object.list;
WHILE (dl # NIL) & (dl.id # id) DO
dl := dl.next;
END;
IF dl # NIL THEN
discipline := dl.discipline;
ELSE
discipline := NIL;
END;
RETURN discipline # NIL
END Seek;
BEGIN
unique := 0;
END ulmDisciplines.

244
src/lib/ulm/ulmForwarders.Mod Normal file
View file

@ -0,0 +1,244 @@
(* Ulm's Oberon Library
Copyright (C) 1989-1995 by University of Ulm, SAI, D-89069 Ulm, Germany
----------------------------------------------------------------------------
Ulm's Oberon Library is free software; you can redistribute it
and/or modify it under the terms of the GNU Library General Public
License as published by the Free Software Foundation; either version
2 of the License, or (at your option) any later version.
Ulm's Oberon Library is distributed in the hope that it will be
useful, but WITHOUT ANY WARRANTY; without even the implied warranty
of MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU
Library General Public License for more details.
You should have received a copy of the GNU Library General Public
License along with this library; if not, write to the Free Software
Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA.
----------------------------------------------------------------------------
E-mail contact: oberon@mathematik.uni-ulm.de
----------------------------------------------------------------------------
$Id: Forwarders.om,v 1.1 1996/01/04 16:40:57 borchert Exp $
----------------------------------------------------------------------------
$Log: Forwarders.om,v $
Revision 1.1 1996/01/04 16:40:57 borchert
Initial revision
----------------------------------------------------------------------------
*)
MODULE ulmForwarders; (* AFB 3/95 *)
IMPORT Disciplines := ulmDisciplines, Events := ulmEvents, Resources := ulmResources, Services := ulmServices, SYSTEM;
(* SYSTEM is necessary to cast to Disciplines.Discipline; noch *)
TYPE
Object* = Services.Object;
ForwardProc* = PROCEDURE (from, to: Object);
TYPE
ListOfForwarders = POINTER TO ListOfForwardersRec;
ListOfForwardersRec =
RECORD
forward: ForwardProc;
next: ListOfForwarders;
END;
ListOfDependants = POINTER TO ListOfDependantsRec;
ListOfDependantsRec =
RECORD
dependant: Object;
next: ListOfDependants;
END;
TypeDiscipline = POINTER TO TypeDisciplineRec;
TypeDisciplineRec =
RECORD
(Disciplines.DisciplineRec)
list: ListOfForwarders;
END;
ObjectDiscipline = POINTER TO ObjectDisciplineRec;
ObjectDisciplineRec =
RECORD
(Disciplines.DisciplineRec)
dependants: ListOfDependants;
forwarders: ListOfForwarders;
dependsOn: Object;
END;
VAR
genlist: ListOfForwarders; (* list which applies to all types *)
typeDiscID: Disciplines.Identifier;
objectDiscID: Disciplines.Identifier;
(* === private procedures ============================================ *)
PROCEDURE RemoveDependant(VAR list: ListOfDependants; dependant: Object);
VAR
prev, p: ListOfDependants;
BEGIN
prev := NIL; p := list;
WHILE (p # NIL) & (p.dependant # dependant) DO
prev := p; p := p.next;
END;
IF p # NIL THEN
IF prev = NIL THEN
list := p.next;
ELSE
prev.next := p.next;
END;
END;
END RemoveDependant;
PROCEDURE TerminationHandler(event: Events.Event);
(* remove list of dependants in case of termination and
remove event.resource from the list of dependants of that
object it depends on
*)
VAR
odisc: ObjectDiscipline;
dependsOn: Object;
BEGIN
WITH event: Resources.Event DO
IF event.change = Resources.terminated THEN
IF Disciplines.Seek(event.resource, objectDiscID, SYSTEM.VAL(Disciplines.Discipline, odisc)) THEN (* noch *)
Disciplines.Remove(event.resource, objectDiscID);
dependsOn := odisc.dependsOn;
IF (dependsOn # NIL) & ~Resources.Terminated(dependsOn) &
Disciplines.Seek(dependsOn, objectDiscID, SYSTEM.VAL(Disciplines.Discipline, odisc)) THEN (* noch *)
RemoveDependant(odisc.dependants, event.resource(Object));
END;
END;
END;
END;
END TerminationHandler;
PROCEDURE Insert(VAR list: ListOfForwarders; forward: ForwardProc);
VAR
member: ListOfForwarders;
BEGIN
NEW(member); member.forward := forward;
member.next := list; list := member;
END Insert;
PROCEDURE GetObjectDiscipline(object: Object; VAR odisc: ObjectDiscipline);
VAR
resourceNotification: Events.EventType;
BEGIN
IF ~Disciplines.Seek(object, objectDiscID, SYSTEM.VAL(Disciplines.Discipline, odisc)) THEN (* noch *)
NEW(odisc); odisc.id := objectDiscID; odisc.dependants := NIL;
odisc.forwarders := NIL; odisc.dependsOn := NIL;
(* let's state our interest in termination of `object' if
we see this object the first time
*)
Resources.TakeInterest(object, resourceNotification);
Events.Handler(resourceNotification, TerminationHandler);
Disciplines.Add(object, odisc);
END;
END GetObjectDiscipline;
(* === exported procedures =========================================== *)
PROCEDURE Register*(for: ARRAY OF CHAR; forward: ForwardProc);
(* register a forwarder which is to be called for all
forward operations which affects extensions of `for';
"" may be given for Services.Object
*)
VAR
type: Services.Type;
tdisc: TypeDiscipline;
BEGIN (* Register *)
IF for = "" THEN
Insert(genlist, forward);
ELSE
Services.SeekType(for, type);
ASSERT(type # NIL);
IF ~Disciplines.Seek(type, typeDiscID, SYSTEM.VAL(Disciplines.Discipline, tdisc)) THEN
NEW(tdisc); tdisc.id := typeDiscID; tdisc.list := NIL;
END;
Insert(tdisc.list, forward);
Disciplines.Add(type, tdisc);
END;
END Register;
PROCEDURE RegisterObject*(object: Object; forward: ForwardProc);
(* to be called instead of Register if specific objects
are supported only and not all extensions of a type
*)
VAR
odisc: ObjectDiscipline;
BEGIN
GetObjectDiscipline(object, odisc);
Insert(odisc.forwarders, forward);
END RegisterObject;
PROCEDURE Update*(object: Object; forward: ForwardProc);
(* is to be called by one of the registered forwarders if
an interface for object has been newly installed or changed
in a way which needs forward to be called for each of
the filter objects which delegate to `object'
*)
VAR
odisc: ObjectDiscipline;
client: ListOfDependants;
BEGIN
IF Disciplines.Seek(object, objectDiscID, SYSTEM.VAL(Disciplines.Discipline, odisc)) THEN (* noch *)
client := odisc.dependants;
WHILE client # NIL DO
forward(client.dependant, object);
client := client.next;
END;
END;
END Update;
PROCEDURE Forward*(from, to: Object);
(* forward (as far as supported) all operations from `from' to `to' *)
VAR
type, otherType, baseType: Services.Type;
tdisc: TypeDiscipline;
odisc: ObjectDiscipline;
client: ListOfDependants;
forwarder: ListOfForwarders;
PROCEDURE CallForwarders(list: ListOfForwarders);
BEGIN
WHILE list # NIL DO
list.forward(from, to);
list := list.next;
END;
END CallForwarders;
BEGIN (* Forward *)
Services.GetType(from, type);
Services.GetType(to, otherType);
ASSERT((type # NIL) & (otherType # NIL));
IF Resources.Terminated(to) OR Resources.Terminated(from) THEN
(* forwarding operations is no longer useful *)
RETURN
END;
Resources.DependsOn(from, to);
(* update the list of dependants for `to' *)
GetObjectDiscipline(to, odisc);
NEW(client); client.dependant := from;
client.next := odisc.dependants; odisc.dependants := client;
(* call object-specific forwarders *)
CallForwarders(odisc.forwarders);
LOOP (* go through the list of base types in descending order *)
IF Disciplines.Seek(type, typeDiscID, SYSTEM.VAL(Disciplines.Discipline, tdisc)) & (* noch *)
Services.IsExtensionOf(otherType, type) THEN
CallForwarders(tdisc.list);
END;
Services.GetBaseType(type, baseType);
IF baseType = NIL THEN EXIT END;
type := baseType;
END;
CallForwarders(genlist);
END Forward;
BEGIN
genlist := NIL;
typeDiscID := Disciplines.Unique();
objectDiscID := Disciplines.Unique();
END ulmForwarders.

138
src/lib/ulm/ulmIEEE.Mod Normal file
View file

@ -0,0 +1,138 @@
(* Ulm's Oberon Library
Copyright (C) 1989-2005 by University of Ulm, SAI, D-89069 Ulm, Germany
----------------------------------------------------------------------------
Ulm's Oberon Library is free software; you can redistribute it
and/or modify it under the terms of the GNU Library General Public
License as published by the Free Software Foundation; either version
2 of the License, or (at your option) any later version.
Ulm's Oberon Library is distributed in the hope that it will be
useful, but WITHOUT ANY WARRANTY; without even the implied warranty
of MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU
Library General Public License for more details.
You should have received a copy of the GNU Library General Public
License along with this library; if not, write to the Free Software
Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA.
----------------------------------------------------------------------------
E-mail contact: oberon@mathematik.uni-ulm.de
----------------------------------------------------------------------------
$Id: IEEE.om,v 1.1 1994/02/23 07:45:22 borchert Exp $
----------------------------------------------------------------------------
$Log: IEEE.om,v $
Revision 1.1 1994/02/23 07:45:22 borchert
Initial revision
----------------------------------------------------------------------------
AFB 7/89
----------------------------------------------------------------------------
*)
MODULE ulmIEEE;
(* this module is portable as far as a IEEE floating point processor
is present
implementation for the I386 architecture
assumptions:
{0} is the most significant bit
MAX(SET) = 31
double precision binary real format (REAL):
0 1..11 12 .. 63
+-+-----+---------------+
|S| exp | fraction |
+-+-----+---------------+
normalized numbers: min < exp < max
denormalized numbers: exp = 0 and nonzero mantissa
zero: exp = 0 and mantissa = 0
infinity: exp = max and mantissa = 0
not-a-number: exp = max and mantissa # 0
*)
IMPORT SYS := SYSTEM;
CONST
(*patternlen = SYS.SIZE(LONGREAL) DIV SYS.SIZE(SET);*)
patternlen = SIZE(LONGREAL) DIV SIZE(SET);
VAR
plusInfinity*: REAL;
minusInfinity*: REAL;
nan*: REAL; (* Not-A-Number *)
snan*: REAL; (* Signaling Not-A-Number *)
(*PROCEDURE Convert(VAR from, to: ARRAY OF BYTE);*)
PROCEDURE Convert(VAR from, to: ARRAY OF SYS.BYTE);
VAR i: INTEGER;
BEGIN
i := 0;
WHILE i < LEN(to) DO
to[i] := from[i]; INC(i);
END;
END Convert;
PROCEDURE Normalized*(real: LONGREAL) : BOOLEAN;
VAR pattern: ARRAY patternlen OF SET;
BEGIN
Convert(real, pattern);
pattern[1] := pattern[1] * {20..30};
RETURN (pattern[1] # {}) & (pattern[1] # {20..30})
END Normalized;
PROCEDURE Valid*(real: LONGREAL) : BOOLEAN;
(* returns TRUE if real is normalized or denormalized
but FALSE for infinity and Not-A-Numbers
*)
VAR pattern: ARRAY patternlen OF SET;
BEGIN
Convert(real, pattern);
pattern[1] := pattern[1] * {20..30};
RETURN pattern[1] # {20..30}
END Valid;
PROCEDURE NotANumber*(real: LONGREAL) : BOOLEAN;
(* returns TRUE if real is a (signaling) Not-A-Number *)
VAR pattern: ARRAY patternlen OF SET;
BEGIN
Convert(real, pattern);
RETURN (pattern[1] * {20..30} = {20..30}) &
((pattern[0] * {0..MAX(SET)} # {}) OR
(pattern[1] * {0..19} # {}))
END NotANumber;
PROCEDURE SetReal(VAR real: REAL;
sign: BOOLEAN; expbits: BOOLEAN;
msb: BOOLEAN; otherbits: BOOLEAN);
VAR
pattern: ARRAY 2 OF SET;
BEGIN
pattern[0] := {}; pattern[1] := {};
IF sign THEN
INCL(pattern[1], 31);
END;
IF expbits THEN
pattern[1] := pattern[1] + {20..30};
END;
IF msb THEN
INCL(pattern[1], 19);
END;
IF otherbits THEN
pattern[1] := pattern[1] + {0..18};
pattern[0] := {0..MAX(SET)};
END;
Convert(pattern, real);
END SetReal;
BEGIN
(* sign exp msb mantissa *)
SetReal(plusInfinity, FALSE, TRUE, FALSE, FALSE);
SetReal(minusInfinity, TRUE, TRUE, FALSE, FALSE);
SetReal(nan, FALSE, TRUE, TRUE, TRUE);
SetReal(snan, FALSE, TRUE, FALSE, TRUE);
END ulmIEEE.

39
src/lib/ulm/ulmObjects.Mod Normal file
View file

@ -0,0 +1,39 @@
(* Ulm's Oberon Library
Copyright (C) 1989-1994 by University of Ulm, SAI, D-89069 Ulm, Germany
----------------------------------------------------------------------------
Ulm's Oberon Library is free software; you can redistribute it
and/or modify it under the terms of the GNU Library General Public
License as published by the Free Software Foundation; either version
2 of the License, or (at your option) any later version.
Ulm's Oberon Library is distributed in the hope that it will be
useful, but WITHOUT ANY WARRANTY; without even the implied warranty
of MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU
Library General Public License for more details.
You should have received a copy of the GNU Library General Public
License along with this library; if not, write to the Free Software
Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA.
----------------------------------------------------------------------------
E-mail contact: oberon@mathematik.uni-ulm.de
----------------------------------------------------------------------------
$Id: Objects.om,v 1.1 1994/02/22 20:08:53 borchert Exp $
----------------------------------------------------------------------------
$Log: Objects.om,v $
Revision 1.1 1994/02/22 20:08:53 borchert
Initial revision
----------------------------------------------------------------------------
AFB 6/89
----------------------------------------------------------------------------
*)
MODULE ulmObjects;
(* common base of all record definitions of the library *)
TYPE
Object* = POINTER TO ObjectRec;
ObjectRec* = RECORD END;
END ulmObjects.

155
src/lib/ulm/ulmPriorities.Mod Normal file
View file

@ -0,0 +1,155 @@
(* Ulm's Oberon Library
Copyright (C) 1989-1994 by University of Ulm, SAI, D-89069 Ulm, Germany
----------------------------------------------------------------------------
Ulm's Oberon Library is free software; you can redistribute it
and/or modify it under the terms of the GNU Library General Public
License as published by the Free Software Foundation; either version
2 of the License, or (at your option) any later version.
Ulm's Oberon Library is distributed in the hope that it will be
useful, but WITHOUT ANY WARRANTY; without even the implied warranty
of MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU
Library General Public License for more details.
You should have received a copy of the GNU Library General Public
License along with this library; if not, write to the Free Software
Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA.
----------------------------------------------------------------------------
E-mail contact: oberon@mathematik.uni-ulm.de
----------------------------------------------------------------------------
$Id: Priorities.om,v 1.1 1994/02/22 20:09:33 borchert Exp $
----------------------------------------------------------------------------
$Log: Priorities.om,v $
Revision 1.1 1994/02/22 20:09:33 borchert
Initial revision
----------------------------------------------------------------------------
AFB 9/89
----------------------------------------------------------------------------
*)
MODULE ulmPriorities;
(* defines priority system per initialized variables;
all priorities needed by the Oberon-library (base, sys, and std) are
defined in this module;
the original module of this definition can be copied
and modified to match the needs of a specific application;
the default priority should range in [null..error);
setting the default priority to null allows to take advantage
of default error handling routines in small applications;
the priority system must be open for extensions:
- each priority below defines a base value of a priority region;
the region size is defined by `region';
e.g. legal library error priorities range from
liberrors to liberrors+region-1
- gap defines the minimum distance between two priority regions
defined in this module
*)
CONST
region* = 10;
gap* = 10;
null* = 0; (* lowest priority possible;
this is not a legal priority for events
*)
TYPE
Priority* = INTEGER;
VAR
(* current priority at begin of execution (after init of Events);
this is the lowest priority possible during execution (>= null);
every event with priority less than `base' is ignored
automatically
*)
base*: Priority;
(* default priority of events (if not changed by Events.SetPriority)*)
default*: Priority;
(* priority of messages which do not indicate an error *)
message*: Priority;
(* priority of system call errors *)
syserrors*: Priority;
(* priority of library errors;
e.g. usage errors or failed system calls;
library errors should have higher priority than syserrors
*)
liberrors*: Priority;
(* priority of assertions of library modules *)
assertions*: Priority;
(* priority of (application) error messages or warnings *)
error*: Priority;
(* priority of asynchronous interrupts like
break key, alarm clock, etc.
*)
interrupts*: Priority;
(* priority of ``out of space'' events (SysStorage) *)
storage*: Priority;
(* priority of run time errors *)
rtserrors*: Priority;
(* priority of fatal errors (error message & exit) *)
fatal*: Priority;
(* priority of fatal signals;
e.g. segmentation violation, alignment faults, illegal instructions;
these signals must not be ignored, and
event handlers must not return on such events
(this would cause an infinite loop)
*)
fatalsignals*: Priority;
(* priority of bugs and (failed) assertions;
bugs are error messages followed by exit (with core dump if possible)
*)
bug*: Priority;
(* priority of task switches are at very high priority to
allow the necessary bookkeeping
*)
taskswitch*: Priority;
(* priority of exit and abort;
actions on this priority level should be minimized
and (if possible) error-free
*)
exit*: Priority;
next: Priority; (* next legal priority value *)
PROCEDURE Set(VAR base: Priority);
BEGIN
base := next; INC(next, region+gap);
END Set;
BEGIN
next := null;
Set(base);
Set(default);
Set(message);
Set(syserrors);
Set(liberrors);
Set(assertions);
Set(error);
Set(interrupts);
Set(storage);
Set(rtserrors);
Set(fatal);
Set(fatalsignals);
Set(bug);
Set(taskswitch);
Set(exit);
END ulmPriorities.

422
src/lib/ulm/ulmRelatedEvents.Mod Normal file
View file

@ -0,0 +1,422 @@
(* Ulm's Oberon Library
Copyright (C) 1989-1994 by University of Ulm, SAI, D-89069 Ulm, Germany
----------------------------------------------------------------------------
Ulm's Oberon Library is free software; you can redistribute it
and/or modify it under the terms of the GNU Library General Public
License as published by the Free Software Foundation; either version
2 of the License, or (at your option) any later version.
Ulm's Oberon Library is distributed in the hope that it will be
useful, but WITHOUT ANY WARRANTY; without even the implied warranty
of MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU
Library General Public License for more details.
You should have received a copy of the GNU Library General Public
License along with this library; if not, write to the Free Software
Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA.
----------------------------------------------------------------------------
E-mail contact: oberon@mathematik.uni-ulm.de
----------------------------------------------------------------------------
$Id: RelatedEven.om,v 1.8 2005/04/28 08:30:09 borchert Exp $
----------------------------------------------------------------------------
$Log: RelatedEven.om,v $
Revision 1.8 2005/04/28 08:30:09 borchert
added assertion to Forward that takes care that from # to
(otherwise we get a nasty infinite loop)
Revision 1.7 2004/09/09 21:04:24 borchert
undoing change of Revision 1.5:
fields dependants and dependson must not be subject of
Save/Restore as this makes it impossible to undo the
dependencies within the TerminationHandler
we no longer remove the discipline in case of terminated
objects as this causes a list of error events to be lost
Revision 1.6 2004/02/18 17:01:59 borchert
Raise asserts now that event.type # NIL
Revision 1.5 2004/02/18 16:53:48 borchert
fields dependants and dependson moved from discipline to state
object to support them for Save/Restore
Revision 1.4 1998/01/12 14:39:18 borchert
some bug fixes around RelatedEvents.null
Revision 1.3 1995/03/20 17:05:13 borchert
- Save & Restore added
- support for Forwarders & Resources added
Revision 1.2 1994/08/27 14:49:44 borchert
null object added
Revision 1.1 1994/02/22 20:09:53 borchert
Initial revision
----------------------------------------------------------------------------
AFB 11/91
----------------------------------------------------------------------------
*)
MODULE ulmRelatedEvents;
(* relate events to objects *)
IMPORT Disciplines := ulmDisciplines, Events := ulmEvents, Forwarders := ulmForwarders, Objects := ulmObjects, Priorities := ulmPriorities, Resources := ulmResources, SYSTEM;
CONST
(* possible directions of propagated events *)
forward = 0; (* forward along the forwardTo chain, if given *)
backward = 1; (* forward event to all dependants, if present *)
both = 2; (* forward event to both directions *)
TYPE
Direction = SHORTINT; (* forward, backward, both *)
TYPE
Object* = Disciplines.Object;
Event* = POINTER TO EventRec;
EventRec* =
RECORD
(Events.EventRec)
object*: Object;
event*: Events.Event;
END;
Queue = POINTER TO QueueRec;
QueueRec* =
RECORD
(Objects.ObjectRec)
event*: Events.Event;
next*: Queue;
END;
ObjectList = POINTER TO ObjectListRec;
ObjectListRec =
RECORD
object: Object;
next: ObjectList;
END;
TYPE
State = POINTER TO StateRec;
StateRec =
RECORD
default: BOOLEAN; (* default reaction? *)
eventType: Events.EventType; (* may be NIL *)
queue: BOOLEAN; (* are events to be queued? *)
forwardto: Object;
head, tail: Queue;
saved: State;
END;
Discipline = POINTER TO DisciplineRec;
DisciplineRec =
RECORD
(Disciplines.DisciplineRec)
state: State;
dependants: ObjectList;
dependsOn: Object;
END;
VAR
id: Disciplines.Identifier;
VAR
null*: Object; (* object which ignores all related events *)
nullevent: Events.EventType;
PROCEDURE RemoveDependant(VAR list: ObjectList; dependant: Object);
VAR
prev, p: ObjectList;
BEGIN
prev := NIL; p := list;
WHILE (p # NIL) & (p.object # dependant) DO
prev := p; p := p.next;
END;
IF p # NIL THEN
IF prev = NIL THEN
list := p.next;
ELSE
prev.next := p.next;
END;
END;
END RemoveDependant;
PROCEDURE TerminationHandler(event: Events.Event);
VAR
disc: Discipline;
BEGIN
WITH event: Resources.Event DO
IF (event.change = Resources.terminated) &
Disciplines.Seek(event.resource, id, SYSTEM.VAL(Disciplines.Discipline, disc)) THEN (* noch *)
IF (disc.dependsOn # NIL) &
Disciplines.Seek(disc.dependsOn, id, SYSTEM.VAL(Disciplines.Discipline, disc)) THEN (* noch *)
RemoveDependant(disc.dependants, event.resource);
disc.dependsOn := NIL;
END;
(*
afb 9/2004:
do not remove this discipline for dead objects
as this makes it impossible to retrieve the final
list of error events
Disciplines.Remove(event.resource, id);
*)
END;
END;
END TerminationHandler;
PROCEDURE CreateState(VAR state: State);
BEGIN
NEW(state);
state.eventType := NIL;
state.queue := FALSE; state.head := NIL; state.tail := NIL;
state.forwardto := NIL;
state.default := TRUE;
state.saved := NIL;
END CreateState;
PROCEDURE CreateDiscipline(VAR disc: Discipline);
BEGIN
NEW(disc); disc.id := id; CreateState(disc.state);
END CreateDiscipline;
PROCEDURE GetEventType*(object: Object; VAR eventType: Events.EventType);
(* returns an event type for the given object;
all events related to the object are also handled by this event type
*)
VAR
disc: Discipline;
state: State;
BEGIN
IF object = null THEN
eventType := nullevent;
ELSE
IF ~Disciplines.Seek(object, id, SYSTEM.VAL(Disciplines.Discipline, disc)) THEN (* noch *)
CreateDiscipline(disc);
Disciplines.Add(object, disc);
END;
state := disc.state;
state.default := FALSE;
IF state.eventType = NIL THEN
Events.Define(state.eventType);
Events.SetPriority(state.eventType, Priorities.liberrors + 1);
Events.Ignore(state.eventType);
END;
eventType := state.eventType;
END;
END GetEventType;
PROCEDURE Forward*(from, to: Object);
(* causes all events related to `from' to be forwarded to `to' *)
VAR
disc: Discipline;
BEGIN
IF (from # NIL) & (from # null) THEN
ASSERT(from # to);
IF ~Disciplines.Seek(from, id, SYSTEM.VAL(Disciplines.Discipline, disc)) THEN (* noch *)
CreateDiscipline(disc);
Disciplines.Add(from, disc);
END;
IF to = null THEN
to := NIL;
END;
disc.state.forwardto := to;
disc.state.default := FALSE;
END;
END Forward;
PROCEDURE ForwardToDependants(from, to: Forwarders.Object);
(* is called by Forwarders.Forward:
build a backward chain from `to' to `from'
*)
VAR
fromDisc, toDisc: Discipline;
member: ObjectList;
eventType: Events.EventType;
BEGIN
IF (from = null) OR (to = null) THEN RETURN END;
IF ~Disciplines.Seek(from, id, SYSTEM.VAL(Disciplines.Discipline, fromDisc)) THEN (* noch *)
CreateDiscipline(fromDisc); Disciplines.Add(from, fromDisc);
END;
IF fromDisc.dependsOn # NIL THEN RETURN END;
fromDisc.dependsOn := to;
Resources.TakeInterest(from, eventType);
Events.Handler(eventType, TerminationHandler);
IF ~Disciplines.Seek(to, id, SYSTEM.VAL(Disciplines.Discipline, toDisc)) THEN (* noch *)
CreateDiscipline(toDisc); Disciplines.Add(to, toDisc);
END;
NEW(member); member.object := from;
member.next := toDisc.dependants; toDisc.dependants := member;
END ForwardToDependants;
PROCEDURE QueueEvents*(object: Object);
(* put all incoming events into a queue *)
VAR
disc: Discipline;
state: State;
BEGIN
IF (object # NIL) & (object # null) THEN
IF ~Disciplines.Seek(object, id, SYSTEM.VAL(Disciplines.Discipline, disc)) THEN
CreateDiscipline(disc);
Disciplines.Add(object, disc);
END;
state := disc.state;
state.default := FALSE;
IF ~state.queue THEN
state.queue := TRUE; state.head := NIL; state.tail := NIL;
END;
END;
END QueueEvents;
PROCEDURE GetQueue*(object: Object; VAR queue: Queue);
(* return queue of related events which is removed
from the object;
object must have been prepared by QueueEvents
*)
VAR
disc: Discipline;
state: State;
BEGIN
IF (object # NIL) & (object # null) &
Disciplines.Seek(object, id, SYSTEM.VAL(Disciplines.Discipline, disc)) & disc.state.queue THEN (* noch *)
state := disc.state;
queue := state.head; state.head := NIL; state.tail := NIL;
ELSE
queue := NIL;
END;
END GetQueue;
PROCEDURE EventsPending*(object: Object) : BOOLEAN;
(* return TRUE if GetQueue will return a queue # NIL *)
VAR
disc: Discipline;
BEGIN
IF (object # NIL) & (object # null) &
Disciplines.Seek(object, id, SYSTEM.VAL(Disciplines.Discipline, disc)) & disc.state.queue THEN (* noch *)
RETURN disc.state.head # NIL
ELSE
RETURN FALSE
END;
END EventsPending;
PROCEDURE Reset*(object: Object);
(* return to default behaviour *)
VAR
disc: Discipline;
state: State;
BEGIN
IF object # null THEN
IF Disciplines.Seek(object, id, SYSTEM.VAL(Disciplines.Discipline, disc)) THEN (* noch *)
IF (disc.state.saved = NIL) &
(disc.dependsOn = NIL) &
(disc.dependants = NIL) THEN
Disciplines.Remove(object, id);
ELSE
state := disc.state;
state.queue := FALSE; state.head := NIL; state.tail := NIL;
state.eventType := NIL; state.forwardto := NIL;
state.default := TRUE;
END;
END;
END;
END Reset;
PROCEDURE Save*(object: Object);
(* save current status of the given object and reset to
default behaviour;
the status includes the reaction types and event queues;
Save operations may be nested
*)
VAR
disc: Discipline;
state: State;
BEGIN
IF object # null THEN
IF ~Disciplines.Seek(object, id, SYSTEM.VAL(Disciplines.Discipline, disc)) THEN (* noch *)
CreateDiscipline(disc);
Disciplines.Add(object, disc);
END;
CreateState(state);
state.saved := disc.state; disc.state := state;
END;
END Save;
PROCEDURE Restore*(object: Object);
(* restore status saved earlier by Save *)
VAR
disc: Discipline;
BEGIN
IF Disciplines.Seek(object, id, SYSTEM.VAL(Disciplines.Discipline, disc)) & (disc.state.saved # NIL) THEN (* noch *)
disc.state := disc.state.saved;
END;
END Restore;
PROCEDURE InternalRaise(object: Object; dir: Direction; event: Events.Event);
VAR
disc: Discipline;
state: State;
relEvent: Event;
element: Queue; (* new element of queue *)
dependant: ObjectList;
BEGIN
IF (object = null) OR ~Disciplines.Seek(object, id, SYSTEM.VAL(Disciplines.Discipline, disc)) THEN RETURN END;
(* backward chaining *)
IF (disc.dependants # NIL) & (dir IN {backward, both}) THEN
dependant := disc.dependants;
WHILE dependant # NIL DO
InternalRaise(dependant.object, backward, event);
dependant := dependant.next;
END;
END;
(* local handling & forward chaining *)
IF ~disc.state.default THEN
state := disc.state;
IF state.queue THEN
NEW(element); element.next := NIL; element.event := event;
IF state.tail # NIL THEN
state.tail.next := element;
ELSE
state.head := element;
END;
state.tail := element;
END;
IF state.eventType # NIL THEN
NEW(relEvent);
relEvent.message := event.message;
relEvent.type := state.eventType;
relEvent.object := object;
relEvent.event := event;
Events.Raise(relEvent);
END;
IF (state.forwardto # NIL) & (dir IN {both, forward}) THEN
InternalRaise(state.forwardto, forward, event);
END;
END;
END InternalRaise;
PROCEDURE Raise*(object: Object; event: Events.Event);
VAR
disc: Discipline;
BEGIN
ASSERT(event.type # NIL);
IF object # null THEN
IF (object = NIL) OR ~Disciplines.Seek(object, id, SYSTEM.VAL(Disciplines.Discipline, disc)) THEN (* noch *)
Events.Raise(event);
ELSE
InternalRaise(object, both, event);
END;
END;
END Raise;
PROCEDURE AppendQueue*(object: Object; queue: Queue);
(* Raise(object, event) for all events of the queue *)
BEGIN
WHILE queue # NIL DO
Raise(object, queue.event);
queue := queue.next;
END;
END AppendQueue;
BEGIN
id := Disciplines.Unique();
NEW(null);
Events.Define(nullevent);
Forwarders.Register("", ForwardToDependants);
END ulmRelatedEvents.

354
src/lib/ulm/ulmResources.Mod Normal file
View file

@ -0,0 +1,354 @@
(* Ulm's Oberon Library
Copyright (C) 1989-1994 by University of Ulm, SAI, D-89069 Ulm, Germany
----------------------------------------------------------------------------
Ulm's Oberon Library is free software; you can redistribute it
and/or modify it under the terms of the GNU Library General Public
License as published by the Free Software Foundation; either version
2 of the License, or (at your option) any later version.
Ulm's Oberon Library is distributed in the hope that it will be
useful, but WITHOUT ANY WARRANTY; without even the implied warranty
of MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU
Library General Public License for more details.
You should have received a copy of the GNU Library General Public
License along with this library; if not, write to the Free Software
Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA.
----------------------------------------------------------------------------
E-mail contact: oberon@mathematik.uni-ulm.de
----------------------------------------------------------------------------
$Id: Resources.om,v 1.2 1998/03/24 22:51:29 borchert Exp $
----------------------------------------------------------------------------
$Log: Resources.om,v $
Revision 1.2 1998/03/24 22:51:29 borchert
bug fix: do not create a relationship to dead or unreferenced objects
but propagate terminations immediately to dependants
Revision 1.1 1996/01/04 16:44:44 borchert
Initial revision
----------------------------------------------------------------------------
*)
MODULE ulmResources;
(* general interface for objects which are shared and need
some cooperative termination/cleanup handling
*)
IMPORT Disciplines := ulmDisciplines, Events := ulmEvents, Objects := ulmObjects, SYSTEM;
TYPE
Resource* = Disciplines.Object;
(* notification of state changes:
initially, resources are alive;
later the communication to an object may be temporarily
stopped (communicationStopped) and resumed (communicationResumed) --
the effect of calling operations during the communicationStopped
state is undefined: possible variants are (1) immediate failure
and (2) being blocked until the state changes to communicationResumed;
unreferenced objects are still alive but no longer in use by
our side -- some cleanup actions may be associated with this state change;
terminated objects are no longer alive and all operations for
them will fail
*)
CONST
(* state changes *)
terminated* = 0;
unreferenced* = 1;
communicationStopped* = 2;
communicationResumed* = 3;
(* states *)
alive = 4; (* private extension *)
TYPE
StateChange* = SHORTINT; (* terminated..communicationResumed *)
State = SHORTINT; (* alive, unreferenced, or alive *)
(* whether objects are stopped or not is maintained separately *)
Event* = POINTER TO EventRec; (* notification of state changes *)
EventRec* =
RECORD
(Events.EventRec)
change*: StateChange; (* new state *)
resource*: Resource;
END;
TYPE
Key* = POINTER TO KeyRec;
KeyRec* =
RECORD
(Objects.ObjectRec)
valid: BOOLEAN;
resource: Resource;
END;
TYPE
List = POINTER TO ListRec;
ListRec =
RECORD
resource: Resource;
next: List;
END;
Discipline = POINTER TO DisciplineRec;
DisciplineRec =
RECORD
(Disciplines.DisciplineRec)
state: State; (* alive, unreferenced, or terminated *)
stopped: BOOLEAN; (* may be TRUE, if alive or unreferenced *)
refcnt: LONGINT; (* # of Attach - # of Detach *)
eventType: Events.EventType; (* may be NIL *)
dependants: List; (* list of resources which depends on us *)
dependsOn: Resource; (* we depend on this resource *)
key: Key; (* attach key for dependsOn *)
END;
VAR
discID: Disciplines.Identifier;
(* === private procedures ============================================ *)
PROCEDURE GetDisc(resource: Resource; VAR disc: Discipline);
BEGIN
(*IF ~Disciplines.Seek(resource, discID, disc) THEN*)
(* this line causes error
err 123 type of actual parameter is not identical with that of formal VAR-parameter
because Discipline defined in this module is an extention of the same type in module Disciplines
Disciplines.Seek expects Disciplines.Discipline, not the extended type.
voc (ofront, OP2, as well as oo2c) behaves right by not allowing this, while Ulm's Oberon system
accepts this.
So we introduce here a workaround, which makes usage of this module unsafe;
noch
*)
IF ~Disciplines.Seek(resource, discID, SYSTEM.VAL(Disciplines.Discipline, disc)) THEN (* noch *)
NEW(disc); disc.id := discID;
disc.state := alive; disc.refcnt := 0;
disc.eventType := NIL;
disc.dependants := NIL; disc.dependsOn := NIL;
Disciplines.Add(resource, disc);
END;
END GetDisc;
PROCEDURE GenEvent(resource: Resource; change: StateChange);
VAR
disc: Discipline;
event: Event;
BEGIN
GetDisc(resource, disc);
IF disc.eventType # NIL THEN
NEW(event);
event.type := disc.eventType;
event.message := "Resources: state change notification";
event.change := change;
event.resource := resource;
Events.Raise(event);
END;
END GenEvent;
PROCEDURE ^ Detach*(resource: Resource; key: Key);
PROCEDURE Unlink(dependant, resource: Resource);
(* undo DependsOn operation *)
VAR
dependantDisc, resourceDisc: Discipline;
prev, member: List;
BEGIN
GetDisc(resource, resourceDisc);
IF resourceDisc.state = terminated THEN
(* no necessity for clean up *)
RETURN
END;
GetDisc(dependant, dependantDisc);
prev := NIL; member := resourceDisc.dependants;
WHILE member.resource # dependant DO
prev := member; member := member.next;
END;
IF prev = NIL THEN
resourceDisc.dependants := member.next;
ELSE
prev.next := member.next;
END;
(* Detach reference from dependant to resource *)
Detach(dependantDisc.dependsOn, dependantDisc.key);
dependantDisc.dependsOn := NIL; dependantDisc.key := NIL;
END Unlink;
PROCEDURE InternalNotify(resource: Resource; change: StateChange);
VAR
disc: Discipline;
event: Event;
dependant: List;
BEGIN
GetDisc(resource, disc);
CASE change OF
| communicationResumed: disc.stopped := FALSE;
| communicationStopped: disc.stopped := TRUE;
| terminated: disc.stopped := FALSE; disc.state := terminated;
END;
GenEvent(resource, change);
(* notify all dependants *)
dependant := disc.dependants;
WHILE dependant # NIL DO
InternalNotify(dependant.resource, change);
dependant := dependant.next;
END;
(* remove dependency relation in case of termination, if present *)
IF (change = terminated) & (disc.dependsOn # NIL) THEN
Unlink(resource, disc.dependsOn);
END;
END InternalNotify;
(* === exported procedures =========================================== *)
PROCEDURE TakeInterest*(resource: Resource; VAR eventType: Events.EventType);
(* return resource specific event type for state notifications;
eventType is guaranteed to be # NIL even if
the given resource is already terminated
*)
VAR
disc: Discipline;
BEGIN
GetDisc(resource, disc);
IF disc.eventType = NIL THEN
Events.Define(disc.eventType);
Events.Ignore(disc.eventType);
END;
eventType := disc.eventType;
END TakeInterest;
PROCEDURE Attach*(resource: Resource; VAR key: Key);
(* mark the resource as being used until Detach gets called *)
VAR
disc: Discipline;
BEGIN
GetDisc(resource, disc);
IF disc.state IN {terminated, unreferenced} THEN
key := NIL;
ELSE
INC(disc.refcnt); NEW(key); key.valid := TRUE;
key.resource := resource;
END;
END Attach;
PROCEDURE Detach*(resource: Resource; key: Key);
(* mark the resource as unused; the returned key of Attach must
be given -- this allows to check for proper balances
of Attach/Detach calls;
the last Detach operation causes a state change to unreferenced
*)
VAR
disc: Discipline;
BEGIN
IF (key # NIL) & key.valid & (key.resource = resource) THEN
GetDisc(resource, disc);
IF disc.state # terminated THEN
key.valid := FALSE; DEC(disc.refcnt);
IF disc.refcnt = 0 THEN
GenEvent(resource, unreferenced);
disc.state := unreferenced;
IF disc.dependsOn # NIL THEN
Unlink(resource, disc.dependsOn);
END;
END;
END;
END;
END Detach;
PROCEDURE Notify*(resource: Resource; change: StateChange);
(* notify all interested parties about the new state;
only valid state changes are accepted:
- Notify doesn't accept any changes after termination
- unreferenced is generated conditionally by Detach only
- communicationResumed is valid after communicationStopped only
valid notifications are propagated to all dependants (see below);
*)
VAR
disc: Discipline;
event: Event;
dependant: List;
BEGIN
IF change # unreferenced THEN
GetDisc(resource, disc);
IF (disc.state # terminated) & (disc.state # change) &
((change # communicationResumed) OR disc.stopped) THEN
InternalNotify(resource, change);
END;
END;
END Notify;
PROCEDURE DependsOn*(dependant, resource: Resource);
(* states that `dependant' depends entirely on `resource' --
this is usually the case if operations on `dependant'
are delegated to `resource';
only one call of DependsOn may be given per `dependant' while
several DependsOn for one resource are valid;
DependsOn calls implicitly Attach for resource and
detaches if the dependant becomes unreferenced;
all other state changes propagate from `resource' to
`dependant'
*)
VAR
dependantDisc, resourceDisc: Discipline;
member: List;
BEGIN
GetDisc(resource, resourceDisc);
IF resourceDisc.state <= unreferenced THEN
(* do not create a relationship to dead or unreferenced objects
but propagate a termination immediately to dependant
*)
IF resourceDisc.state = terminated THEN
Notify(dependant, resourceDisc.state);
END;
RETURN
END;
GetDisc(dependant, dependantDisc);
IF dependantDisc.dependsOn # NIL THEN
(* don't accept changes *)
RETURN
END;
dependantDisc.dependsOn := resource;
NEW(member); member.resource := dependant;
member.next := resourceDisc.dependants;
resourceDisc.dependants := member;
Attach(resource, dependantDisc.key);
END DependsOn;
PROCEDURE Alive*(resource: Resource) : BOOLEAN;
(* returns TRUE if the resource is not yet terminated
and ready for communication (i.e. not communicationStopped)
*)
VAR
disc: Discipline;
BEGIN
GetDisc(resource, disc);
RETURN ~disc.stopped & (disc.state IN {alive, unreferenced})
END Alive;
PROCEDURE Stopped*(resource: Resource) : BOOLEAN;
(* returns TRUE if the object is currently not responsive
and not yet terminated
*)
VAR
disc: Discipline;
BEGIN
GetDisc(resource, disc);
RETURN disc.stopped
END Stopped;
PROCEDURE Terminated*(resource: Resource) : BOOLEAN;
(* returns TRUE if the resource is terminated *)
VAR
disc: Discipline;
BEGIN
GetDisc(resource, disc);
RETURN disc.state = terminated
END Terminated;
BEGIN
discID := Disciplines.Unique();
END ulmResources.

54
src/lib/ulm/ulmSYSTEM.Mod Normal file
View file

@ -0,0 +1,54 @@
MODULE ulmSYSTEM;
IMPORT SYSTEM(*, ulmObjects, ulmDisciplines, Console*);
(* test *)
(*
VAR d0, d1 : ulmDisciplines.Discipline;
*)
(* noch *)
(* PROCEDURE -getaddr*(obj: ulmObjects.Object): LONGINT
"(LONGINT)&obj";*)
(*
PROCEDURE -assignObjectPointers* (VAR src, dst : ulmObjects.Object)
"*dst=*src";
PROCEDURE assignObjectPointer*(src, dst : ulmObjects.Object);
BEGIN
assignObjectPointers(src, dst);
END assignObjectPointer;
PROCEDURE assignDisciplinePointer (src, dst : ulmDisciplines.Discipline);
BEGIN
assignObjectPointers(src, dst);
END assignDisciplinePointer;
*)
PROCEDURE TAS*(VAR flag:BOOLEAN): BOOLEAN; (* added for compatibility with ulmSYSTEM module; noch *)
VAR oldflag : BOOLEAN;
BEGIN
oldflag := flag;
flag := TRUE;
RETURN oldflag;
END TAS;
(*
BEGIN
NEW (d0);
NEW (d1);
d0.id := 0;
d1.id := 1;
Console.String ("d0.id=");Console.Int (d0.id, 0); Console.Ln;
Console.String ("d1.id=");Console.Int (d1.id, 0); Console.Ln;
(*
assignDisciplinePointer(d0, d1);
*)
Console.String ("d0.id=");Console.Int (d0.id, 0); Console.Ln;
Console.String ("d1.id=");Console.Int (d1.id, 0); Console.Ln;
*)
END ulmSYSTEM.

520
src/lib/ulm/ulmServices.Mod Normal file
View file

@ -0,0 +1,520 @@
(* Ulm's Oberon Library
Copyright (C) 1989-1994 by University of Ulm, SAI, D-89069 Ulm, Germany
----------------------------------------------------------------------------
Ulm's Oberon Library is free software; you can redistribute it
and/or modify it under the terms of the GNU Library General Public
License as published by the Free Software Foundation; either version
2 of the License, or (at your option) any later version.
Ulm's Oberon Library is distributed in the hope that it will be
useful, but WITHOUT ANY WARRANTY; without even the implied warranty
of MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU
Library General Public License for more details.
You should have received a copy of the GNU Library General Public
License along with this library; if not, write to the Free Software
Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA.
----------------------------------------------------------------------------
E-mail contact: oberon@mathematik.uni-ulm.de
----------------------------------------------------------------------------
$Id: Services.om,v 1.2 2004/09/03 09:34:24 borchert Exp $
----------------------------------------------------------------------------
$Log: Services.om,v $
Revision 1.2 2004/09/03 09:34:24 borchert
cache results of LoadService to avoid further attempts
Revision 1.1 1995/03/03 09:32:15 borchert
Initial revision
----------------------------------------------------------------------------
*)
MODULE ulmServices;
IMPORT Disciplines := ulmDisciplines, Objects := ulmObjects;
TYPE
Type* = POINTER TO TypeRec;
ServiceList = POINTER TO ServiceListRec;
Service* = POINTER TO ServiceRec;
Object* = POINTER TO ObjectRec;
ObjectRec* =
RECORD
(Disciplines.ObjectRec)
type: Type;
installed: ServiceList; (* set of installed services *)
END;
InstallProc = PROCEDURE (object: Object; service: Service);
ServiceRec* =
RECORD
(Disciplines.ObjectRec)
name: ARRAY 64 OF CHAR;
next: Service;
END;
ServiceListRec =
RECORD
service: Service;
type: Type;
install: InstallProc;
next: ServiceList;
END;
VAR
services: Service;
(* list of services -- needed to support Seek *)
TYPE
LoadModuleProc* = PROCEDURE (module: ARRAY OF CHAR) : BOOLEAN;
LoadServiceProc* = PROCEDURE (service, for: ARRAY OF CHAR) : BOOLEAN;
LoaderInterface* = POINTER TO LoaderInterfaceRec;
LoaderInterfaceRec* =
RECORD
loadModule*: LoadModuleProc;
loadService*: LoadServiceProc;
END;
VAR
loaderIF: LoaderInterface;
(* ==== name tables ================================================== *)
CONST
bufsize = 512; (* length of a name buffer in bytes *)
tabsize = 1171;
TYPE
BufferPosition = INTEGER;
Length = LONGINT;
HashValue = INTEGER;
Buffer = ARRAY bufsize OF CHAR;
NameList = POINTER TO NameListRec;
NameListRec =
RECORD
buffer: Buffer;
next: NameList;
END;
VAR
currentBuf: NameList; currentPos: BufferPosition;
TYPE
TypeRec* =
RECORD
(Disciplines.ObjectRec)
baseType: Type;
services: ServiceList;
cachedservices: ServiceList; (* of base types *)
(* table management *)
hashval: HashValue;
length: Length;
begin: NameList;
pos: BufferPosition;
next: Type; (* next type with same hash value *)
END;
BucketTable = ARRAY tabsize OF Type;
VAR
bucket: BucketTable;
(* ==== name table management ======================================== *)
PROCEDURE Hash(name: ARRAY OF CHAR; length: LONGINT) : HashValue;
CONST
shift = 4;
VAR
index: LONGINT;
val: LONGINT;
ch: CHAR;
ordval: INTEGER;
BEGIN
index := 0; val := length;
WHILE index < length DO
ch := name[index];
IF ch >= " " THEN
ordval := ORD(ch) - ORD(" ");
ELSE
ordval := ORD(MAX(CHAR)) - ORD(" ") + ORD(ch);
END;
val := ASH(val, shift) + ordval;
INC(index);
END;
val := val MOD tabsize;
RETURN SHORT(val)
END Hash;
PROCEDURE CreateBuf(VAR buf: NameList);
BEGIN
NEW(buf); buf.next := NIL;
IF currentBuf # NIL THEN
currentBuf.next := buf;
END;
currentBuf := buf;
currentPos := 0;
END CreateBuf;
PROCEDURE StringLength(string: ARRAY OF CHAR) : LONGINT;
VAR
index: LONGINT;
BEGIN
index := 0;
WHILE (index < LEN(string)) & (string[index] # 0X) DO
INC(index);
END;
RETURN index
END StringLength;
PROCEDURE InitName(name: Type; string: ARRAY OF CHAR);
VAR
index, length: LONGINT;
firstbuf, buf: NameList;
startpos: BufferPosition;
BEGIN
IF currentBuf = NIL THEN
CreateBuf(buf);
ELSE
buf := currentBuf;
END;
firstbuf := buf; startpos := currentPos;
index := 0;
WHILE (index < LEN(string)) & (string[index] # 0X) DO
IF currentPos = bufsize THEN
CreateBuf(buf);
END;
buf.buffer[currentPos] := string[index]; INC(currentPos);
INC(index);
END;
length := index;
name.hashval := Hash(string, length);
name.length := length;
name.begin := firstbuf;
name.pos := startpos;
name.next := bucket[name.hashval];
bucket[name.hashval] := name;
END InitName;
PROCEDURE EqualName(name: Type; string: ARRAY OF CHAR) : BOOLEAN;
(* precondition: both have the same length *)
VAR
index: LONGINT;
buf: NameList;
pos: INTEGER;
BEGIN
buf := name.begin; pos := name.pos;
index := 0;
WHILE index < name.length DO
IF pos = bufsize THEN
buf := buf.next; pos := 0;
END;
IF string[index] # buf.buffer[pos] THEN
RETURN FALSE
END;
INC(pos);
INC(index);
END;
RETURN TRUE
END EqualName;
PROCEDURE SeekName(string: ARRAY OF CHAR; VAR name: Type) : BOOLEAN;
VAR
length: LONGINT;
hashval: HashValue;
p: Type;
BEGIN
length := StringLength(string);
hashval := Hash(string, length);
p := bucket[hashval];
WHILE (p # NIL) & ((length # p.length) OR ~EqualName(p, string)) DO
p := p.next;
END;
name := p;
RETURN p # NIL
END SeekName;
PROCEDURE ExtractName(name: Type; VAR string: ARRAY OF CHAR);
VAR
index: LONGINT;
buf: NameList;
pos: INTEGER;
BEGIN
buf := name.begin; pos := name.pos;
index := 0;
WHILE (index + 1 < LEN(string)) & (index < name.length) DO
IF pos = bufsize THEN
buf := buf.next; pos := 0;
END;
string[index] := buf.buffer[pos];
INC(pos);
INC(index);
END;
string[index] := 0X;
END ExtractName;
PROCEDURE LoadModule(module: ARRAY OF CHAR) : BOOLEAN;
BEGIN
IF (loaderIF # NIL) & (loaderIF.loadModule # NIL) THEN
RETURN loaderIF.loadModule(module)
ELSE
RETURN FALSE
END;
END LoadModule;
PROCEDURE LoadService(service, for: ARRAY OF CHAR) : BOOLEAN;
BEGIN
IF (loaderIF # NIL) & (loaderIF.loadService # NIL) THEN
RETURN loaderIF.loadService(service, for)
ELSE
RETURN FALSE
END;
END LoadService;
PROCEDURE MemberOf(list: ServiceList; service: Service;
VAR member: ServiceList) : BOOLEAN;
VAR
p: ServiceList;
BEGIN
p := list;
WHILE (p # NIL) & (p.service # service) DO
p := p.next;
END;
member := p;
RETURN p # NIL
END MemberOf;
PROCEDURE SeekService(type: Type; service: Service;
VAR member: ServiceList;
VAR baseType: Type) : BOOLEAN;
VAR
btype: Type;
cachedservice: ServiceList;
PROCEDURE Seek(type: Type; service: Service;
VAR member: ServiceList) : BOOLEAN;
VAR
typeName: ARRAY 512 OF CHAR;
BEGIN
IF MemberOf(type.services, service, member) OR
MemberOf(type.cachedservices, service, member) THEN
RETURN TRUE
END;
ExtractName(type, typeName);
RETURN LoadService(service.name, typeName) &
MemberOf(type.services, service, member)
END Seek;
BEGIN (* SeekService *)
btype := type;
WHILE (btype # NIL) & ~Seek(btype, service, member) DO
btype := btype.baseType;
END;
IF (member # NIL) & (btype # type) THEN
(* cache result to avoid further tries to load
a more fitting variant dynamically
*)
NEW(cachedservice);
cachedservice.service := service;
cachedservice.type := member.type;
cachedservice.install := member.install;
cachedservice.next := type.cachedservices;
type.cachedservices := cachedservice;
baseType := member.type;
RETURN TRUE
END;
IF member = NIL THEN
RETURN FALSE
ELSE
baseType := member.type;
RETURN TRUE
END;
END SeekService;
PROCEDURE GetModule(name: ARRAY OF CHAR; VAR module: ARRAY OF CHAR);
(* get the name of the module where 'name' was defined *)
VAR
index: INTEGER;
BEGIN
index := 0;
WHILE (name[index] # ".") & (name[index] # 0X) &
(index < LEN(module)-1) DO
module[index] := name[index]; INC(index);
END;
module[index] := 0X;
END GetModule;
(* ==== exported procedures ========================================== *)
PROCEDURE InitLoader*(if: LoaderInterface);
BEGIN
ASSERT((loaderIF = NIL) & (if # NIL));
loaderIF := if;
END InitLoader;
PROCEDURE InitType*(type: Type; name, baseName: ARRAY OF CHAR);
VAR
baseType: Type;
otherType: Type;
ok: BOOLEAN;
BEGIN
IF baseName = "" THEN
baseType := NIL;
ELSE
ok := SeekName(baseName, baseType); ASSERT(ok);
END;
ASSERT(~SeekName(name, otherType));
InitName(type, name);
type.baseType := baseType;
type.services := NIL;
type.cachedservices := NIL;
END InitType;
PROCEDURE CreateType*(VAR type: Type; name, baseName: ARRAY OF CHAR);
BEGIN
NEW(type); InitType(type, name, baseName);
END CreateType;
PROCEDURE Init*(object: Object; type: Type);
BEGIN
ASSERT(type # NIL);
ASSERT(object.type = NIL);
object.type := type;
object.installed := NIL;
END Init;
PROCEDURE GetType*(object: Object; VAR type: Type);
BEGIN
type := object.type;
END GetType;
PROCEDURE GetTypeName*(type: Type; VAR name: ARRAY OF CHAR);
BEGIN
ExtractName(type, name);
END GetTypeName;
PROCEDURE GetBaseType*(type: Type; VAR baseType: Type);
BEGIN
baseType := type.baseType;
END GetBaseType;
PROCEDURE IsExtensionOf*(type, baseType: Type) : BOOLEAN;
BEGIN
ASSERT(baseType # NIL);
WHILE (type # NIL) & (type # baseType) DO
type := type.baseType;
END;
RETURN type = baseType
END IsExtensionOf;
PROCEDURE SeekType*(name: ARRAY OF CHAR; VAR type: Type);
VAR
module: ARRAY 64 OF CHAR;
BEGIN
IF ~SeekName(name, type) THEN
(* try to load the associated module *)
GetModule(name, module);
IF ~LoadModule(module) OR ~SeekName(name, type) THEN
type := NIL;
END;
END;
END SeekType;
PROCEDURE Seek*(name: ARRAY OF CHAR; VAR service: Service);
BEGIN
service := services;
WHILE (service # NIL) & (service.name # name) DO
service := service.next;
END;
(* try to load a module named after `name', if not successful *)
IF (service = NIL) & LoadModule(name) THEN
service := services;
WHILE (service # NIL) & (service.name # name) DO
service := service.next;
END;
END;
END Seek;
PROCEDURE Create*(VAR service: Service; name: ARRAY OF CHAR);
PROCEDURE Created(name: ARRAY OF CHAR) : BOOLEAN;
VAR
service: Service;
BEGIN
service := services;
WHILE (service # NIL) & (service.name # name) DO
service := service.next;
END;
RETURN service # NIL
END Created;
BEGIN
ASSERT(~Created(name));
NEW(service);
COPY(name, service.name);
service.next := services; services := service;
END Create;
PROCEDURE Define*(type: Type; service: Service; install: InstallProc);
VAR
member: ServiceList;
BEGIN
ASSERT(service # NIL);
(* protect against multiple definitions: *)
ASSERT(~MemberOf(type.services, service, member));
NEW(member); member.service := service;
member.install := install; member.type := type;
member.next := type.services; type.services := member;
END Define;
PROCEDURE Install*(object: Object; service: Service) : BOOLEAN;
VAR
member, installed: ServiceList;
baseType: Type;
BEGIN
IF object.type = NIL THEN RETURN FALSE END;
IF ~SeekService(object.type, service, member, baseType) THEN
(* service not supported for this object type *)
RETURN FALSE
END;
IF ~MemberOf(object.installed, service, installed) THEN
(* install services only once *)
IF member.install # NIL THEN
member.install(object, service);
END;
NEW(installed);
installed.service := service;
installed.next := object.installed;
object.installed := installed;
END;
RETURN TRUE
END Install;
PROCEDURE Supported*(object: Object; service: Service) : BOOLEAN;
VAR
member: ServiceList;
baseType: Type;
BEGIN
RETURN (object.type # NIL) &
SeekService(object.type, service, member, baseType)
END Supported;
PROCEDURE Installed*(object: Object; service: Service) : BOOLEAN;
VAR
member: ServiceList;
BEGIN
RETURN MemberOf(object.installed, service, member)
END Installed;
PROCEDURE GetSupportedBaseType*(object: Object; service: Service;
VAR baseType: Type);
VAR
member: ServiceList;
BEGIN
IF ~SeekService(object.type, service, member, baseType) THEN
baseType := NIL;
END;
END GetSupportedBaseType;
BEGIN
currentBuf := NIL; currentPos := 0; loaderIF := NIL;
END ulmServices.

208
src/lib/ulm/ulmSets.Mod Normal file
View file

@ -0,0 +1,208 @@
(* Ulm's Oberon Library
Copyright (C) 1989-1994 by University of Ulm, SAI, D-89069 Ulm, Germany
----------------------------------------------------------------------------
Ulm's Oberon Library is free software; you can redistribute it
and/or modify it under the terms of the GNU Library General Public
License as published by the Free Software Foundation; either version
2 of the License, or (at your option) any later version.
Ulm's Oberon Library is distributed in the hope that it will be
useful, but WITHOUT ANY WARRANTY; without even the implied warranty
of MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU
Library General Public License for more details.
You should have received a copy of the GNU Library General Public
License along with this library; if not, write to the Free Software
Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA.
----------------------------------------------------------------------------
E-mail contact: oberon@mathematik.uni-ulm.de
----------------------------------------------------------------------------
$Id: Sets.om,v 1.3 1999/06/06 06:44:56 borchert Exp $
----------------------------------------------------------------------------
$Log: Sets.om,v $
Revision 1.3 1999/06/06 06:44:56 borchert
bug fix: CharSet was too small
Revision 1.2 1995/03/16 16:25:33 borchert
assertions of Assertions replaced by real assertions
Revision 1.1 1994/02/22 20:10:14 borchert
Initial revision
----------------------------------------------------------------------------
AFB 9/89
----------------------------------------------------------------------------
*)
MODULE ulmSets;
CONST
setsize* = MAX(SET) + 1;
TYPE
CharSet* = ARRAY ORD(MAX(CHAR)) + 1 DIV setsize OF SET;
PROCEDURE InitSet*(VAR set: ARRAY OF SET);
VAR i: LONGINT;
BEGIN
i := 0;
WHILE i < LEN(set) DO
set[i] := {}; INC(i);
END;
END InitSet;
PROCEDURE Complement*(VAR set: ARRAY OF SET);
VAR i: LONGINT;
BEGIN
i := 0;
WHILE i < LEN(set) DO
set[i] := - set[i]; INC(i);
END;
END Complement;
PROCEDURE In*(VAR set: ARRAY OF SET; i: LONGINT) : BOOLEAN;
BEGIN
RETURN (i MOD setsize) IN set[i DIV setsize]
END In;
PROCEDURE Incl*(VAR set: ARRAY OF SET; i: LONGINT);
BEGIN
INCL(set[i DIV setsize], i MOD setsize);
END Incl;
PROCEDURE Excl*(VAR set: ARRAY OF SET; i: LONGINT);
BEGIN
EXCL(set[i DIV setsize], i MOD setsize);
END Excl;
PROCEDURE CharIn*(VAR charset: CharSet; ch: CHAR) : BOOLEAN;
BEGIN
RETURN (ORD(ch) MOD setsize) IN charset[ORD(ch) DIV setsize]
END CharIn;
PROCEDURE InclChar*(VAR charset: CharSet; ch: CHAR);
BEGIN
INCL(charset[ORD(ch) DIV setsize], ORD(ch) MOD setsize);
END InclChar;
PROCEDURE ExclChar*(VAR charset: CharSet; ch: CHAR);
BEGIN
EXCL(charset[ORD(ch) DIV setsize], ORD(ch) MOD setsize);
END ExclChar;
PROCEDURE Intersection*(set1, set2: ARRAY OF SET; VAR result: ARRAY OF SET);
VAR
index: INTEGER;
BEGIN
ASSERT((LEN(result) = LEN(set1)) & (LEN(result) = LEN(set2)));
index := 0;
WHILE index < LEN(result) DO
result[index] := set1[index] * set2[index];
INC(index);
END;
END Intersection;
PROCEDURE SymDifference*(set1, set2: ARRAY OF SET; VAR result: ARRAY OF SET);
VAR
index: INTEGER;
BEGIN
ASSERT((LEN(result) = LEN(set1)) & (LEN(result) = LEN(set2)));
index := 0;
WHILE index < LEN(result) DO
result[index] := set1[index] / set2[index];
INC(index);
END;
END SymDifference;
PROCEDURE Union*(set1, set2: ARRAY OF SET; VAR result: ARRAY OF SET);
VAR
index: INTEGER;
BEGIN
ASSERT((LEN(result) = LEN(set1)) & (LEN(result) = LEN(set2)));
index := 0;
WHILE index < LEN(result) DO
result[index] := set1[index] + set2[index];
INC(index);
END;
END Union;
PROCEDURE Difference*(set1, set2: ARRAY OF SET; VAR result: ARRAY OF SET);
VAR
index: INTEGER;
BEGIN
ASSERT((LEN(result) = LEN(set1)) & (LEN(result) = LEN(set2)));
index := 0;
WHILE index < LEN(result) DO
result[index] := set1[index] - set2[index];
INC(index);
END;
END Difference;
PROCEDURE Equal*(set1, set2: ARRAY OF SET) : BOOLEAN;
VAR
index: INTEGER;
BEGIN
index := 0;
WHILE (index < LEN(set1)) & (index < LEN(set2)) DO
IF set1[index] # set2[index] THEN
RETURN FALSE
END;
INC(index);
END;
WHILE index < LEN(set1) DO
IF set1[index] # {} THEN
RETURN FALSE
END;
INC(index);
END;
WHILE index < LEN(set2) DO
IF set2[index] # {} THEN
RETURN FALSE
END;
INC(index);
END;
RETURN TRUE
END Equal;
PROCEDURE Subset*(set1, set2: ARRAY OF SET) : BOOLEAN;
VAR
index: INTEGER;
BEGIN
index := 0;
WHILE (index < LEN(set1)) & (index < LEN(set2)) DO
IF set1[index] - set2[index] # {} THEN
RETURN FALSE
END;
INC(index);
END;
WHILE index < LEN(set1) DO
IF set1[index] # {} THEN
RETURN FALSE
END;
INC(index);
END;
RETURN TRUE
END Subset;
PROCEDURE Card*(set: ARRAY OF SET) : INTEGER;
VAR
index: INTEGER;
i: INTEGER;
card: INTEGER;
BEGIN
card := 0;
index := 0;
WHILE index < LEN(set) DO
i := 0;
WHILE i <= MAX(SET) DO
IF i IN set[index] THEN
INC(card);
END;
INC(i);
END;
INC(index);
END;
RETURN card
END Card;
END ulmSets.

859
src/lib/v4/CmdlnTexts.Mod Normal file
View file

@ -0,0 +1,859 @@
MODULE CmdlnTexts; (** CAS/HM 23.9.93 -- interface based on Texts by JG/NW 6.12.91**) (* << RC, MB, JT *)
IMPORT
Files, Modules, Reals;
(*--- insert field e: Elem into Texts.Scanner and change Texts.Scan to set it in case of class=6 *)
CONST
Displaywhite = 15;
ElemChar* = 1CX;
TAB = 9X; CR = 0DX; maxD = 9;
(**FileMsg.id**)
load* = 0; store* = 1;
(**Notifier op**)
replace* = 0; insert* = 1; delete* = 2;
(**Scanner.class**)
Inval* = 0; Name* = 1; String* = 2; Int* = 3; Real* = 4; LongReal* = 5; Char* = 6;
textTag = 0F0X; DocBlockId = 0F7X; version = 01X;
TYPE
FontsFont = POINTER TO FontDesc;
FontDesc = RECORD
name: ARRAY 32 OF CHAR;
END ;
Run = POINTER TO RunDesc;
RunDesc = RECORD
prev, next: Run;
len: LONGINT;
fnt: FontsFont;
col, voff: SHORTINT;
ascii: BOOLEAN (* << *)
END;
Piece = POINTER TO PieceDesc;
PieceDesc = RECORD (RunDesc)
file: Files.File;
org: LONGINT
END;
Elem* = POINTER TO ElemDesc;
Buffer* = POINTER TO BufDesc;
Text* = POINTER TO TextDesc;
ElemMsg* = RECORD END;
Handler* = PROCEDURE (e: Elem; VAR msg: ElemMsg);
ElemDesc* = RECORD (RunDesc)
W*, H*: LONGINT;
handle*: Handler;
base: Text
END;
FileMsg* = RECORD (ElemMsg)
id*: INTEGER;
pos*: LONGINT;
r*: Files.Rider
END;
CopyMsg* = RECORD (ElemMsg)
e*: Elem
END;
IdentifyMsg* = RECORD (ElemMsg)
mod*, proc*: ARRAY 32 OF CHAR
END;
BufDesc* = RECORD
len*: LONGINT;
head: Run
END;
TextDesc* = RECORD
len*: LONGINT;
head, cache: Run;
corg: LONGINT
END;
Reader* = RECORD
eot*: BOOLEAN;
fnt*: FontsFont;
col*, voff*: SHORTINT;
elem*: Elem;
rider: Files.Rider;
run: Run;
org, off: LONGINT
END;
Scanner* = RECORD (Reader)
nextCh*: CHAR;
line*, class*: INTEGER;
i*: LONGINT;
x*: REAL;
y*: LONGREAL;
c*: CHAR;
len*: SHORTINT;
s*: ARRAY 64 OF CHAR (* << *)
END;
Writer* = RECORD
buf*: Buffer;
fnt*: FontsFont;
col*, voff*: SHORTINT;
rider: Files.Rider;
file: Files.File
END;
Alien = POINTER TO RECORD (ElemDesc)
file: Files.File;
org, span: LONGINT;
mod, proc: ARRAY 32 OF CHAR
END;
VAR
new*: Elem;
del: Buffer;
FontsDefault: FontsFont;
PROCEDURE FontsThis(VAR name: ARRAY OF CHAR): FontsFont;
VAR F: FontsFont;
BEGIN
NEW(F); COPY(name, F.name); RETURN F
END FontsThis;
(* run primitives *)
PROCEDURE Find (T: Text; VAR pos: LONGINT; VAR u: Run; VAR org, off: LONGINT);
VAR v: Run; m: LONGINT;
BEGIN
IF pos >= T.len THEN pos := T.len; u := T.head; org := T.len; off := 0; T.cache := T.head; T.corg := 0
ELSE v := T.cache.next; m := pos - T.corg;
IF pos >= T.corg THEN
WHILE m >= v.len DO DEC(m, v.len); v := v.next END
ELSE
WHILE m < 0 DO v := v.prev; INC(m, v.len) END;
END;
u := v; org := pos - m; off := m; T.cache := v.prev; T.corg := org
END
END Find;
PROCEDURE Split (off: LONGINT; VAR u, un: Run);
VAR p, U: Piece;
BEGIN
IF off = 0 THEN un := u; u := un.prev
ELSIF off >= u.len THEN un := u.next
ELSE NEW(p); un := p; U := u(Piece);
p^ := U^; INC(p.org, off); DEC(p.len, off); DEC(U.len, p.len);
p.ascii := u.ascii; p.prev := U; p.next := U.next; p.next.prev := p; U.next := p (* << *)
END
END Split;
PROCEDURE Merge (T: Text; u: Run; VAR v: Run);
VAR p, q: Piece;
BEGIN
IF (u IS Piece) & (v IS Piece) & (u.fnt.name = v.fnt.name) & (u.col = v.col) & (u.voff = v.voff)
& (u(Piece).ascii = v(Piece).ascii) THEN (* << *)
p := u(Piece); q := v(Piece);
IF (p.file = q.file) & (p.org + p.len = q.org) THEN
IF T.cache = u THEN INC(T.corg, q.len)
ELSIF T.cache = v THEN T.cache := T.head; T.corg := 0
END;
INC(p.len, q.len); v := v.next
END
END
END Merge;
PROCEDURE Splice (un, v, w: Run; base: Text); (* (u, un) -> (u, v, w, un) *)
VAR u: Run;
BEGIN
IF v # w.next THEN u := un.prev;
u.next := v; v.prev := u; un.prev := w; w.next := un;
REPEAT
IF v IS Elem THEN v(Elem).base := base END;
v := v.next
UNTIL v = un
END
END Splice;
PROCEDURE ClonePiece (p: Piece): Piece;
VAR q: Piece;
BEGIN NEW(q); q^ := p^; RETURN q
END ClonePiece;
PROCEDURE CloneElem (e: Elem): Elem;
VAR msg: CopyMsg;
BEGIN msg.e := NIL; e.handle(e, msg); RETURN msg.e
END CloneElem;
(** Elements **)
PROCEDURE CopyElem* (SE, DE: Elem);
BEGIN DE.len := SE.len; DE.fnt := SE.fnt; DE.col := SE.col; DE.voff := SE.voff;
DE.W := SE.W; DE.H := SE.H; DE.handle := SE.handle
END CopyElem;
PROCEDURE ElemBase* (E: Elem): Text;
BEGIN RETURN E.base
END ElemBase;
PROCEDURE ElemPos* (E: Elem): LONGINT;
VAR u: Run; pos: LONGINT;
BEGIN u := E.base.head.next; pos := 0;
WHILE u # E DO pos := pos + u.len; u := u.next END;
RETURN pos
END ElemPos;
PROCEDURE HandleAlien (E: Elem; VAR msg: ElemMsg);
VAR e: Alien; r: Files.Rider; i: LONGINT; ch: CHAR;
BEGIN
WITH E: Alien DO
IF msg IS CopyMsg THEN
WITH msg: CopyMsg DO NEW(e); CopyElem(E, e);
e.file := E.file; e.org := E.org; e.span := E.span; e.mod := E.mod; e.proc := E.proc;
msg.e := e
END
ELSIF msg IS IdentifyMsg THEN
WITH msg: IdentifyMsg DO
COPY(E.mod, msg.mod); COPY(E.proc, msg.proc); msg.mod[31] := 1X (*alien*)
END
ELSIF msg IS FileMsg THEN
WITH msg: FileMsg DO
IF msg.id = store THEN Files.Set(r, E.file, E.org); i := E.span;
WHILE i > 0 DO Files.Read(r, ch); Files.Write(msg.r, ch); DEC(i) END
END
END
END
END
END HandleAlien;
(** Buffers **)
PROCEDURE OpenBuf* (B: Buffer);
VAR u: Run;
BEGIN NEW(u); u.next := u; u.prev := u; B.head := u; B.len := 0
END OpenBuf;
PROCEDURE Copy* (SB, DB: Buffer);
VAR u, v, vn: Run;
BEGIN u := SB.head.next; v := DB.head.prev;
WHILE u # SB.head DO
IF u IS Piece THEN vn := ClonePiece(u(Piece)) ELSE vn := CloneElem(u(Elem)) END;
v.next := vn; vn.prev := v; v := vn; u := u.next
END;
v.next := DB.head; DB.head.prev := v;
INC(DB.len, SB.len)
END Copy;
PROCEDURE Recall* (VAR B: Buffer);
BEGIN B := del; del := NIL
END Recall;
(** Texts **)
PROCEDURE Save* (T: Text; beg, end: LONGINT; B: Buffer);
VAR u, v, w, wn: Run; uo, ud, vo, vd: LONGINT;
BEGIN Find(T, beg, u, uo, ud); Find(T, end, v, vo, vd);
w := B.head.prev;
WHILE u # v DO
IF u IS Piece THEN wn := ClonePiece(u(Piece)); DEC(wn.len, ud); INC(wn(Piece).org, ud)
ELSE wn := CloneElem(u(Elem))
END;
w.next := wn; wn.prev := w; w := wn; u := u.next; ud := 0
END;
IF vd > 0 THEN (*v IS Piece*) wn := ClonePiece(v(Piece)); wn.len := vd - ud; INC(wn(Piece).org, ud);
w.next := wn; wn.prev := w; w := wn
END;
w.next := B.head; B.head.prev := w;
INC(B.len, end - beg)
END Save;
PROCEDURE Insert* (T: Text; pos: LONGINT; B: Buffer);
VAR u, un, v: Run; p, q: Piece; uo, ud, len: LONGINT;
BEGIN Find(T, pos, u, uo, ud); Split(ud, u, un);
len := B.len; v := B.head.next;
Merge(T, u, v); Splice(un, v, B.head.prev, T);
INC(T.len, len); B.head.next := B.head; B.head.prev := B.head; B.len := 0;
END Insert;
PROCEDURE Append* (T: Text; B: Buffer);
VAR v: Run; pos, len: LONGINT;
BEGIN pos := T.len; len := B.len; v := B.head.next;
Merge(T, T.head.prev, v); Splice(T.head, v, B.head.prev, T);
INC(T.len, len); B.head.next := B.head; B.head.prev := B.head; B.len := 0;
END Append;
PROCEDURE Delete* (T: Text; beg, end: LONGINT);
VAR c, u, un, v, vn: Run; co, uo, ud, vo, vd: LONGINT;
BEGIN
Find(T, beg, u, uo, ud); Split(ud, u, un); c := T.cache; co := T.corg;
Find(T, end, v, vo, vd); Split(vd, v, vn); T.cache := c; T.corg := co;
NEW(del); OpenBuf(del); del.len := end - beg;
Splice(del.head, un, v, NIL);
Merge(T, u, vn); u.next := vn; vn.prev := u;
DEC(T.len, end - beg);
END Delete;
PROCEDURE ChangeLooks* (T: Text; beg, end: LONGINT; sel: SET; fnt: FontsFont; col, voff: SHORTINT);
VAR c, u, un, v, vn: Run; co, uo, ud, vo, vd: LONGINT;
BEGIN Find(T, beg, u, uo, ud); Split(ud, u, un); c := T.cache; co := T.corg;
Find(T, end, v, vo, vd); Split(vd, v, vn); T.cache := c; T.corg := co;
WHILE un # vn DO
IF (0 IN sel) & (fnt # NIL) THEN un.fnt := fnt END;
IF 1 IN sel THEN un.col := col END;
IF 2 IN sel THEN un.voff := voff END;
Merge(T, u, un);
IF u.next = un THEN u := un; un := un.next ELSE u.next := un; un.prev := u END
END;
Merge(T, u, un); u.next := un; un.prev := u;
END ChangeLooks;
(** Readers **)
PROCEDURE OpenReader* (VAR R: Reader; T: Text; pos: LONGINT);
VAR u: Run;
BEGIN
IF pos >= T.len THEN pos := T.len END;
Find(T, pos, u, R.org, R.off); R.run := u; R.eot := FALSE;
IF u IS Piece THEN
Files.Set(R.rider, u(Piece).file, u(Piece).org + R.off)
END
END OpenReader;
PROCEDURE Read* (VAR R: Reader; VAR ch: CHAR);
VAR u: Run;
BEGIN u := R.run; R.fnt := u.fnt; R.col := u.col; R.voff := u.voff; INC(R.off);
IF u IS Piece THEN Files.Read(R.rider, ch); R.elem := NIL;
IF (ch = 0AX) & u(Piece).ascii THEN ch := CR END (* << LF to CR *)
ELSIF u IS Elem THEN ch := ElemChar; R.elem := u(Elem)
ELSE ch := 0X; R.elem := NIL; R.eot := TRUE
END;
IF R.off = u.len THEN INC(R.org, u.len); u := u.next;
IF u IS Piece THEN
WITH u: Piece DO Files.Set(R.rider, u.file, u.org) END
END;
R.run := u; R.off := 0
END
END Read;
PROCEDURE ReadElem* (VAR R: Reader);
VAR u, un: Run;
BEGIN u := R.run;
WHILE u IS Piece DO INC(R.org, u.len); u := u.next END;
IF u IS Elem THEN un := u.next; R.run := un; INC(R.org); R.off := 0;
R.fnt := u.fnt; R.col := u.col; R.voff := u.voff; R.elem := u(Elem);
IF un IS Piece THEN
WITH un: Piece DO Files.Set(R.rider, un.file, un.org) END
END
ELSE R.eot := TRUE; R.elem := NIL
END
END ReadElem;
PROCEDURE ReadPrevElem* (VAR R: Reader);
VAR u: Run;
BEGIN u := R.run.prev;
WHILE u IS Piece DO DEC(R.org, u.len); u := u.prev END;
IF u IS Elem THEN R.run := u; DEC(R.org); R.off := 0;
R.fnt := u.fnt; R.col := u.col; R.voff := u.voff; R.elem := u(Elem)
ELSE R.eot := TRUE; R.elem := NIL
END
END ReadPrevElem;
PROCEDURE Pos* (VAR R: Reader): LONGINT;
BEGIN RETURN R.org + R.off
END Pos;
(** Scanners --------------- NW --------------- **)
PROCEDURE OpenScanner* (VAR S: Scanner; T: Text; pos: LONGINT);
BEGIN OpenReader(S, T, pos); S.line := 0; S.nextCh := " "
END OpenScanner;
(*IEEE floating point formats:
x = 2^(e-127) * 1.m bit 0: sign, bits 1- 8: e, bits 9-31: m
x = 2^(e-1023) * 1.m bit 0: sign, bits 1-11: e, bits 12-63: m *)
PROCEDURE Scan* (VAR S: Scanner);
CONST maxD = 32;
VAR ch, term: CHAR;
neg, negE, hex: BOOLEAN;
i, j, h: SHORTINT;
e: INTEGER; k: LONGINT;
x, f: REAL; y, g: LONGREAL;
d: ARRAY maxD OF CHAR;
PROCEDURE ReadScaleFactor;
BEGIN Read(S, ch);
IF ch = "-" THEN negE := TRUE; Read(S, ch)
ELSE negE := FALSE;
IF ch = "+" THEN Read(S, ch) END
END;
WHILE ("0" <= ch) & (ch <= "9") DO
e := e*10 + ORD(ch) - 30H; Read(S, ch)
END
END ReadScaleFactor;
BEGIN ch := S.nextCh; i := 0;
LOOP
IF ch = CR THEN INC(S.line)
ELSIF (ch # " ") & (ch # TAB) THEN EXIT
END ;
Read(S, ch)
END;
IF ("A" <= CAP(ch)) & (CAP(ch) <= "Z") OR (ch = "/") OR (ch = ".") THEN (*name*) (* << *)
REPEAT S.s[i] := ch; INC(i); Read(S, ch)
UNTIL (CAP(ch) > "Z") & (ch # "_") (* << *)
OR ("A" > CAP(ch)) & (ch > "9")
OR ("0" > ch) & (ch # ".") & (ch # "/") (* << *)
OR (i = 63); (* << *)
S.s[i] := 0X; S.len := i; S.class := 1
ELSIF ch = 22X THEN (*literal string*)
Read(S, ch);
WHILE (ch # 22X) & (ch >= " ") & (i # 63) DO (* << *)
S.s[i] := ch; INC(i); Read(S, ch)
END;
S.s[i] := 0X; S.len := i+1; Read(S, ch); S.class := 2
ELSE
IF ch = "-" THEN neg := TRUE; Read(S, ch) ELSE neg := FALSE END ;
IF ("0" <= ch) & (ch <= "9") THEN (*number*)
hex := FALSE; j := 0;
LOOP d[i] := ch; INC(i); Read(S, ch);
IF ch < "0" THEN EXIT END;
IF "9" < ch THEN
IF ("A" <= ch) & (ch <= "F") THEN hex := TRUE; ch := CHR(ORD(ch)-7)
ELSIF ("a" <= ch) & (ch <= "f") THEN hex := TRUE; ch := CHR(ORD(ch)-27H)
ELSE EXIT
END
END
END;
IF ch = "H" THEN (*hex number*)
Read(S, ch); S.class := 3;
IF i-j > 8 THEN j := i-8 END ;
k := ORD(d[j]) - 30H; INC(j);
IF (i-j = 7) & (k >= 8) THEN DEC(k, 16) END ;
WHILE j < i DO k := k*10H + (ORD(d[j]) - 30H); INC(j) END ;
IF neg THEN S.i := -k ELSE S.i := k END
ELSIF ch = "." THEN (*read real*)
Read(S, ch); h := i;
WHILE ("0" <= ch) & (ch <= "9") DO d[i] := ch; INC(i); Read(S, ch) END ;
IF ch = "D" THEN
e := 0; y := 0; g := 1;
REPEAT y := y*10 + (ORD(d[j]) - 30H); INC(j) UNTIL j = h;
WHILE j < i DO g := g/10; y := (ORD(d[j]) - 30H)*g + y; INC(j) END ;
ReadScaleFactor;
IF negE THEN
IF e <= 308 THEN y := y / Reals.TenL(e) ELSE y := 0 END
ELSIF e > 0 THEN
IF e <= 308 THEN y := Reals.TenL(e) * y ELSE HALT(40) END
END ;
IF neg THEN y := -y END ;
S.class := 5; S.y := y
ELSE e := 0; x := 0; f := 1;
REPEAT x := x*10 + (ORD(d[j]) - 30H); INC(j) UNTIL j = h;
WHILE j < i DO f := f/10; x := (ORD(d[j])-30H)*f + x; INC(j) END;
IF ch = "E" THEN ReadScaleFactor END ;
IF negE THEN
IF e <= 38 THEN x := x / Reals.Ten(e) ELSE x := 0 END
ELSIF e > 0 THEN
IF e <= 38 THEN x := Reals.Ten(e) * x ELSE HALT(40) END
END ;
IF neg THEN x := -x END ;
S.class := 4; S.x := x
END ;
IF hex THEN S.class := 0 END
ELSE (*decimal integer*)
S.class := 3; k := 0;
REPEAT k := k*10 + (ORD(d[j]) - 30H); INC(j) UNTIL j = i;
IF neg THEN S.i := -k ELSE S.i := k END;
IF hex THEN S.class := 0 ELSE S.class := 3 END
END
ELSE S.class := 6;
IF neg THEN S.c := "-" ELSE S.c := ch; Read(S, ch) END
END
END;
S.nextCh := ch
END Scan;
(** Writers **)
PROCEDURE OpenWriter* (VAR W: Writer);
BEGIN NEW(W.buf); OpenBuf(W.buf);
W.fnt := FontsDefault; W.col := Displaywhite; W.voff := 0;
W.file := Files.New(""); Files.Set(W.rider, W.file, 0)
END OpenWriter;
PROCEDURE SetFont* (VAR W: Writer; fnt: FontsFont);
BEGIN W.fnt := fnt
END SetFont;
PROCEDURE SetColor* (VAR W: Writer; col: SHORTINT);
BEGIN W.col := col
END SetColor;
PROCEDURE SetOffset* (VAR W: Writer; voff: SHORTINT);
BEGIN W.voff := voff
END SetOffset;
PROCEDURE Write* (VAR W: Writer; ch: CHAR);
VAR u, un: Run; p: Piece;
BEGIN Files.Write(W.rider, ch); INC(W.buf.len); un := W.buf.head; u := un.prev;
IF (u IS Piece) & (u(Piece).file = W.file) & (u.fnt.name = W.fnt.name) & (u.col = W.col) & (u.voff = W.voff)
& ~u(Piece).ascii THEN (* << *)
INC(u.len)
ELSE NEW(p); u.next := p; p.prev := u; p.next := un; un.prev := p;
p.len := 1; p.fnt := W.fnt; p.col := W.col; p.voff := W.voff;
p.file := W.file; p.org := Files.Length(W.file) - 1; p.ascii := FALSE (* << *)
END
END Write;
PROCEDURE WriteElem* (VAR W: Writer; e: Elem);
VAR u, un: Run;
BEGIN
IF e.base # NIL THEN HALT(99) END;
INC(W.buf.len); e.len := 1; e.fnt := W.fnt; e.col := W.col; e.voff := W.voff;
un := W.buf.head; u := un.prev; u.next := e; e.prev := u; e.next := un; un.prev := e
END WriteElem;
PROCEDURE WriteLn* (VAR W: Writer);
BEGIN Write(W, CR)
END WriteLn;
PROCEDURE WriteString* (VAR W: Writer; s: ARRAY OF CHAR);
VAR i: INTEGER;
BEGIN i := 0;
WHILE s[i] >= " " DO Write(W, s[i]); INC(i) END
END WriteString;
PROCEDURE WriteInt* (VAR W: Writer; x, n: LONGINT);
VAR i: INTEGER; x0: LONGINT;
a: ARRAY 11 OF CHAR;
BEGIN i := 0;
IF x < 0 THEN
IF x = MIN(LONGINT) THEN WriteString(W, " -2147483648"); RETURN
ELSE DEC(n); x0 := -x
END
ELSE x0 := x
END;
REPEAT
a[i] := CHR(x0 MOD 10 + 30H); x0 := x0 DIV 10; INC(i)
UNTIL x0 = 0;
WHILE n > i DO Write(W, " "); DEC(n) END;
IF x < 0 THEN Write(W, "-") END;
REPEAT DEC(i); Write(W, a[i]) UNTIL i = 0
END WriteInt;
PROCEDURE WriteHex* (VAR W: Writer; x: LONGINT);
VAR i: INTEGER; y: LONGINT;
a: ARRAY 10 OF CHAR;
BEGIN i := 0; Write(W, " ");
REPEAT y := x MOD 10H;
IF y < 10 THEN a[i] := CHR(y + 30H) ELSE a[i] := CHR(y + 37H) END;
x := x DIV 10H; INC(i)
UNTIL i = 8;
REPEAT DEC(i); Write(W, a[i]) UNTIL i = 0
END WriteHex;
PROCEDURE WriteReal* (VAR W: Writer; x: REAL; n: INTEGER);
VAR e: INTEGER; x0: REAL;
d: ARRAY maxD OF CHAR;
BEGIN e := Reals.Expo(x);
IF e = 0 THEN
WriteString(W, " 0");
REPEAT Write(W, " "); DEC(n) UNTIL n <= 3
ELSIF e = 255 THEN
WriteString(W, " NaN");
WHILE n > 4 DO Write(W, " "); DEC(n) END
ELSE
IF n <= 9 THEN n := 3 ELSE DEC(n, 6) END;
REPEAT Write(W, " "); DEC(n) UNTIL n <= 8;
(*there are 2 < n <= 8 digits to be written*)
IF x < 0.0 THEN Write(W, "-"); x := -x ELSE Write(W, " ") END;
e := (e - 127) * 77 DIV 256;
IF e >= 0 THEN x := x / Reals.Ten(e) ELSE x := Reals.Ten(-e) * x END;
IF x >= 10.0 THEN x := 0.1*x; INC(e) END;
x0 := Reals.Ten(n-1); x := x0*x + 0.5;
IF x >= 10.0*x0 THEN x := x*0.1; INC(e) END;
Reals.Convert(x, n, d);
DEC(n); Write(W, d[n]); Write(W, ".");
REPEAT DEC(n); Write(W, d[n]) UNTIL n = 0;
Write(W, "E");
IF e < 0 THEN Write(W, "-"); e := -e ELSE Write(W, "+") END;
Write(W, CHR(e DIV 10 + 30H)); Write(W, CHR(e MOD 10 + 30H))
END
END WriteReal;
PROCEDURE WriteRealFix* (VAR W: Writer; x: REAL; n, k: INTEGER);
VAR e, i: INTEGER; sign: CHAR; x0: REAL;
d: ARRAY maxD OF CHAR;
PROCEDURE seq(ch: CHAR; n: INTEGER);
BEGIN WHILE n > 0 DO Write(W, ch); DEC(n) END
END seq;
PROCEDURE dig(n: INTEGER);
BEGIN
WHILE n > 0 DO
DEC(i); Write(W, d[i]); DEC(n)
END
END dig;
BEGIN e := Reals.Expo(x);
IF k < 0 THEN k := 0 END;
IF e = 0 THEN seq(" ", n-k-2); Write(W, "0"); seq(" ", k+1)
ELSIF e = 255 THEN WriteString(W, " NaN"); seq(" ", n-4)
ELSE e := (e - 127) * 77 DIV 256;
IF x < 0 THEN sign := "-"; x := -x ELSE sign := " " END;
IF e >= 0 THEN (*x >= 1.0, 77/256 = log 2*) x := x/Reals.Ten(e)
ELSE (*x < 1.0*) x := Reals.Ten(-e) * x
END;
IF x >= 10.0 THEN x := 0.1*x; INC(e) END;
(* 1 <= x < 10 *)
IF k+e >= maxD-1 THEN k := maxD-1-e
ELSIF k+e < 0 THEN k := -e; x := 0.0
END;
x0 := Reals.Ten(k+e); x := x0*x + 0.5;
IF x >= 10.0*x0 THEN INC(e) END;
(*e = no. of digits before decimal point*)
INC(e); i := k+e; Reals.Convert(x, i, d);
IF e > 0 THEN
seq(" ", n-e-k-2); Write(W, sign); dig(e);
Write(W, "."); dig(k)
ELSE seq(" ", n-k-3);
Write(W, sign); Write(W, "0"); Write(W, ".");
seq("0", -e); dig(k+e)
END
END
END WriteRealFix;
PROCEDURE WriteRealHex* (VAR W: Writer; x: REAL);
VAR i: INTEGER;
d: ARRAY 8 OF CHAR;
BEGIN Reals.ConvertH(x, d); i := 0;
REPEAT Write(W, d[i]); INC(i) UNTIL i = 8
END WriteRealHex;
PROCEDURE WriteLongReal* (VAR W: Writer; x: LONGREAL; n: INTEGER);
CONST maxD = 16;
VAR e: INTEGER; x0: LONGREAL;
d: ARRAY maxD OF CHAR;
BEGIN e := Reals.ExpoL(x);
IF e = 0 THEN
WriteString(W, " 0");
REPEAT Write(W, " "); DEC(n) UNTIL n <= 3
ELSIF e = 2047 THEN
WriteString(W, " NaN");
WHILE n > 4 DO Write(W, " "); DEC(n) END
ELSE
IF n <= 10 THEN n := 3 ELSE DEC(n, 7) END;
REPEAT Write(W, " "); DEC(n) UNTIL n <= maxD;
(*there are 2 <= n <= maxD digits to be written*)
IF x < 0 THEN Write(W, "-"); x := -x ELSE Write(W, " ") END;
e := SHORT(LONG(e - 1023) * 77 DIV 256);
IF e >= 0 THEN x := x / Reals.TenL(e) ELSE x := Reals.TenL(-e) * x END ;
IF x >= 10.0D0 THEN x := 0.1D0 * x; INC(e) END ;
x0 := Reals.TenL(n-1); x := x0*x + 0.5D0;
IF x >= 10.0D0*x0 THEN x := 0.1D0 * x; INC(e) END ;
Reals.ConvertL(x, n, d);
DEC(n); Write(W, d[n]); Write(W, ".");
REPEAT DEC(n); Write(W, d[n]) UNTIL n = 0;
Write(W, "D");
IF e < 0 THEN Write(W, "-"); e := -e ELSE Write(W, "+") END;
Write(W, CHR(e DIV 100 + 30H)); e := e MOD 100;
Write(W, CHR(e DIV 10 + 30H));
Write(W, CHR(e MOD 10 + 30H))
END
END WriteLongReal;
PROCEDURE WriteLongRealHex* (VAR W: Writer; x: LONGREAL);
VAR i: INTEGER;
d: ARRAY 16 OF CHAR;
BEGIN Reals.ConvertHL(x, d); i := 0;
REPEAT Write(W, d[i]); INC(i) UNTIL i = 16
END WriteLongRealHex;
PROCEDURE WriteDate* (VAR W: Writer; t, d: LONGINT);
PROCEDURE WritePair(ch: CHAR; x: LONGINT);
BEGIN Write(W, ch);
Write(W, CHR(x DIV 10 + 30H)); Write(W, CHR(x MOD 10 + 30H))
END WritePair;
BEGIN
WritePair(" ", d MOD 32); WritePair(".", d DIV 32 MOD 16); WritePair(".", d DIV 512 MOD 128);
WritePair(" ", t DIV 4096 MOD 32); WritePair(":", t DIV 64 MOD 64); WritePair(":", t MOD 64)
END WriteDate;
(** Text Filing **)
PROCEDURE Load0 (VAR r: Files.Rider; T: Text);
VAR u, un: Run; p: Piece; e: Elem;
org, pos, hlen, plen: LONGINT; ecnt, fno, fcnt, col, voff: SHORTINT;
f: Files.File;
msg: FileMsg;
mods, procs: ARRAY 64, 32 OF CHAR;
name: ARRAY 32 OF CHAR;
fnts: ARRAY 32 OF FontsFont;
PROCEDURE LoadElem (VAR r: Files.Rider; pos, span: LONGINT; VAR e: Elem);
VAR M: Modules.Module; Cmd: Modules.Command; a: Alien;
org, ew, eh: LONGINT; eno: SHORTINT;
BEGIN new := NIL;
Files.ReadLInt(r, ew); Files.ReadLInt(r, eh); Files.Read(r, eno);
IF eno > ecnt THEN ecnt := eno; Files.ReadString(r, mods[eno]); Files.ReadString(r, procs[eno]) END;
org := Files.Pos(r); M := Modules.ThisMod(mods[eno]);
IF M # NIL THEN Cmd := Modules.ThisCommand(M, procs[eno]);
IF Cmd # NIL THEN Cmd END
END;
e := new;
IF e # NIL THEN e.W := ew; e.H := eh; e.base := T;
msg.pos := pos; e.handle(e, msg);
IF Files.Pos(r) # org + span THEN e := NIL END
END;
IF e = NIL THEN Files.Set(r, f, org + span);
NEW(a); a.W := ew; a.H := eh; a.handle := HandleAlien; a.base := T;
a.file := f; a.org := org; a.span := span;
COPY(mods[eno], a.mod); COPY(procs[eno], a.proc);
e := a
END
END LoadElem;
BEGIN pos := Files.Pos(r); f := Files.Base(r);
NEW(u); u.len := MAX(LONGINT); (*u.fnt := FontsDefault;*)u.fnt := NIL; u.col := Displaywhite;
T.head := u; ecnt := 0; fcnt := 0;
msg.id := load; msg.r := r;
Files.ReadLInt(msg.r, hlen); (*!!!org := pos + hlen;*) org := pos -2 + hlen; pos := org; Files.Read(msg.r, fno);
WHILE fno # 0 DO
IF fno > fcnt THEN fcnt := fno; Files.ReadString(msg.r, name); fnts[fno] := FontsThis(name) END;
Files.Read(msg.r, col); Files.Read(msg.r, voff); Files.ReadLInt(msg.r, plen);
IF plen > 0 THEN NEW(p); p.file := f; p.org := pos; p.ascii := FALSE; un := p; un.len := plen
ELSE LoadElem(msg.r, pos - org, -plen, e); un := e; un.len := 1
END;
un.fnt := fnts[fno]; un.col := col; un.voff := voff;
INC(pos, un.len); u.next := un; un.prev := u; u := un; Files.Read(msg.r, fno)
END;
u.next := T.head; T.head.prev := u; T.cache := T.head; T.corg := 0;
Files.ReadLInt(msg.r, T.len); Files.Set(r, f, Files.Pos(msg.r) + T.len)
END Load0;
PROCEDURE Load* (VAR r: Files.Rider; T: Text);
CONST oldTag = -4095;
VAR tag: INTEGER;
BEGIN
(* for compatibility inner text tags are checked and skipped; remove this in a later version *)
Files.ReadInt(r, tag); IF tag # oldTag THEN Files.Set(r, Files.Base(r), Files.Pos(r)-2) END;
Load0(r, T)
END Load;
PROCEDURE Open* (T: Text; name: ARRAY OF CHAR);
VAR f: Files.File; r: Files.Rider; u: Run; p: Piece; tag, version: CHAR; hlen: LONGINT;
BEGIN f := Files.Old(name);
IF f = NIL THEN f := Files.New("") END;
Files.Set(r, f, 0); Files.Read(r, tag); Files.Read(r, version);
IF (tag = textTag) OR (tag = 01X) & (version = textTag) THEN Load0(r, T)
ELSE (*ascii*)
NEW(u); u.len := MAX(LONGINT); u.fnt := NIL; u.col := Displaywhite;
NEW(p);
IF (tag = DocBlockId) & (version = 07X) THEN (* extract ascii text from System 3 text document *)
Files.Set(r, f, 28); Files.ReadLInt(r, hlen);
Files.Set(r, f, 22 + hlen); Files.ReadLInt(r, T.len); p.org := 26 + hlen
ELSE
T.len := Files.Length(f); p.org := 0
END ;
IF T.len > 0 THEN p.len := T.len; p.fnt := FontsDefault;
p.col := Displaywhite; p.voff := 0; p.file := f; p.ascii := TRUE;
u.next := p; u.prev := p; p.next := u; p.prev := u
ELSE u.next := u; u.prev := u
END;
T.head := u; T.cache := T.head; T.corg := 0
END
END Open;
PROCEDURE Store* (VAR r: Files.Rider; T: Text);
VAR r1: Files.Rider; u, un: Run; e: Elem; org, pos, delta, hlen, rlen: LONGINT; ecnt, fno, fcnt: SHORTINT; ch: CHAR; (* << *)
msg: FileMsg; iden: IdentifyMsg;
mods, procs: ARRAY 64, 32 OF CHAR;
fnts: ARRAY 32 OF FontsFont;
block: ARRAY 1024 OF CHAR;
PROCEDURE StoreElem (VAR r: Files.Rider; pos: LONGINT; e: Elem);
VAR r1: Files.Rider; org, span: LONGINT; eno: SHORTINT;
BEGIN COPY(iden.mod, mods[ecnt]); COPY(iden.proc, procs[ecnt]); eno := 1;
WHILE (mods[eno] # iden.mod) OR (procs[eno] # iden.proc) DO INC(eno) END;
Files.Set(r1, Files.Base(r), Files.Pos(r));
Files.WriteLInt(r, 0); Files.WriteLInt(r, 0); Files.WriteLInt(r, 0); (*fixup slot*)
Files.Write(r, eno);
IF eno = ecnt THEN INC(ecnt); Files.WriteString(r, iden.mod); Files.WriteString(r, iden.proc) END;
msg.pos := pos; org := Files.Pos(r); e.handle(e, msg); span := Files.Pos(r) - org;
Files.WriteLInt(r1, -span); Files.WriteLInt(r1, e.W); Files.WriteLInt(r1, e.H) (*fixup*)
END StoreElem;
BEGIN
org := Files.Pos(r); msg.id := store; msg.r := r; Files.WriteLInt(msg.r, 0); (*fixup slot*)
u := T.head.next; pos := 0; delta := 0; fcnt := 1; ecnt := 1;
WHILE u # T.head DO
IF u IS Elem THEN iden.mod[0] := 0X; u(Elem).handle(u(Elem), iden) ELSE iden.mod[0] := 1X END;
IF iden.mod[0] # 0X THEN
fnts[fcnt] := u.fnt; fno := 1;
WHILE fnts[fno].name # u.fnt.name DO INC(fno) END;
Files.Write(msg.r, fno);
IF fno = fcnt THEN INC(fcnt); Files.WriteString(msg.r, u.fnt.name) END;
Files.Write(msg.r, u.col); Files.Write(msg.r, u.voff)
END;
IF u IS Piece THEN rlen := u.len; un := u.next;
WHILE (un IS Piece) & (un.fnt = u.fnt) & (un.col = u.col) & (un.voff = u.voff) DO
INC(rlen, un.len); un := un.next
END;
Files.WriteLInt(msg.r, rlen); INC(pos, rlen); u := un
ELSIF iden.mod[0] # 0X THEN StoreElem(msg.r, pos, u(Elem)); INC(pos); u := u.next
ELSE INC(delta); u := u.next
END
END;
Files.Write(msg.r, 0); Files.WriteLInt(msg.r, T.len - delta);
(*!!!hlen := Files.Pos(msg.r) - org;*) hlen := Files.Pos(msg.r) - org + 2;
Files.Set(r1, Files.Base(msg.r), org); Files.WriteLInt(r1, hlen); (*fixup*)
u := T.head.next;
WHILE u # T.head DO
IF u IS Piece THEN
WITH u: Piece DO
IF u.ascii THEN Files.Set(r1, u.file, u.org); delta := u.len; (* << LF to CR *)
WHILE delta > 0 DO Files.Read(r1, ch); DEC(delta);
IF ch = 0AX THEN Files.Write(msg.r, CR) ELSE Files.Write(msg.r, ch) END
END
ELSE Files.Set(r1, u.file, u.org); delta := u.len;
WHILE delta > LEN(block) DO Files.ReadBytes(r1, block, LEN(block));
Files.WriteBytes(msg.r, block, LEN(block)); DEC(delta, LEN(block))
END;
Files.ReadBytes(r1, block, delta); Files.WriteBytes(msg.r, block, delta)
END
END
ELSE iden.mod[0] := 0X; u(Elem).handle(u(Elem), iden);
IF iden.mod[0] # 0X THEN Files.Write(msg.r, ElemChar) END
END;
u := u.next
END;
r := msg.r;
END Store;
PROCEDURE Close* (T: Text; name: ARRAY OF CHAR);
VAR f: Files.File; r: Files.Rider; i, res: INTEGER; bak: ARRAY 64 OF CHAR;
BEGIN
f := Files.New(name); Files.Set(r, f, 0); Files.Write(r, textTag); Files.Write(r, version); Store(r, T);
i := 0; WHILE name[i] # 0X DO INC(i) END;
COPY(name, bak); bak[i] := "."; bak[i+1] := "B"; bak[i+2] := "a"; bak[i+3] := "k"; bak[i+4] := 0X;
Files.Rename(name, bak, res); Files.Register(f)
END Close;
BEGIN del := NIL; NEW(FontsDefault); FontsDefault.name := "Syntax10.Scn.Fnt"
END CmdlnTexts.

627
src/lib/v4/Files.Mod Normal file
View file

@ -0,0 +1,627 @@
MODULE Files; (* J. Templ 1.12. 89/12.4.95 Oberon files mapped onto Unix files *)
IMPORT SYSTEM, Unix, Kernel, Args, Console;
(* standard data type I/O
little endian,
Sint:1, Int:2, Lint:4
ORD({0}) = 1,
false = 0, true =1
IEEE real format,
null terminated strings,
compact numbers according to M.Odersky *)
CONST
nofbufs = 4;
bufsize = 4096;
fileTabSize = 64;
noDesc = -1;
notDone = -1;
(* file states *)
open = 0; create = 1; close = 2;
TYPE
FileName = ARRAY 101 OF CHAR;
File* = POINTER TO Handle;
Buffer = POINTER TO BufDesc;
Handle = RECORD
workName, registerName: FileName;
tempFile: BOOLEAN;
dev, ino, mtime: LONGINT;
fd-, len, pos: LONGINT;
bufs: ARRAY nofbufs OF Buffer;
swapper, state: INTEGER
END ;
BufDesc = RECORD
f: File;
chg: BOOLEAN;
org, size: LONGINT;
data: ARRAY bufsize OF SYSTEM.BYTE
END ;
Rider* = RECORD
res*: LONGINT;
eof*: BOOLEAN;
buf: Buffer;
org, offset: LONGINT
END ;
Time = POINTER TO TimeDesc;
TimeDesc = RECORD
sec*, min*, hour*, mday*, mon*, year*, wday*, isdst*, zone*, gmtoff*: LONGINT;
(* sec*, min*, hour*, mday*, mon*, year*, wday*, isdst*, zone*, gmtoff*: INTEGER;*)
END ;
VAR
fileTab: ARRAY fileTabSize OF LONGINT (*=File*);
tempno: INTEGER;
(* for localtime *)
PROCEDURE -includetime()
'#include "time.h"';
PROCEDURE -localtime(VAR clock: LONGINT): Time
"(Files_Time) localtime(clock)";
PROCEDURE -getcwd(VAR cwd: Unix.Name)
"getcwd(cwd, cwd__len)";
PROCEDURE -IdxTrap "__HALT(-1)";
PROCEDURE^ Finalize(o: SYSTEM.PTR);
PROCEDURE Err(s: ARRAY OF CHAR; f: File; errno: LONGINT);
BEGIN
Console.Ln; Console.String("-- "); Console.String(s); Console.String(": ");
IF f # NIL THEN
IF f.registerName # "" THEN Console.String(f.registerName) ELSE Console.String(f.workName) END
END ;
IF errno # 0 THEN Console.String(" errno = "); Console.Int(errno, 1) END ;
Console.Ln;
HALT(99)
END Err;
PROCEDURE MakeFileName(dir, name: ARRAY OF CHAR; VAR dest: ARRAY OF CHAR);
VAR i, j: INTEGER;
BEGIN i := 0; j := 0;
WHILE dir[i] # 0X DO dest[i] := dir[i]; INC(i) END ;
IF dest[i-1] # "/" THEN dest[i] := "/"; INC(i) END ;
WHILE name[j] # 0X DO dest[i] := name[j]; INC(i); INC(j) END ;
dest[i] := 0X
END MakeFileName;
PROCEDURE GetTempName(finalName: ARRAY OF CHAR; VAR name: ARRAY OF CHAR);
VAR n, i, j: LONGINT;
BEGIN
INC(tempno); n := tempno; i := 0;
IF finalName[0] # "/" THEN (* relative pathname *)
WHILE Kernel.CWD[i] # 0X DO name[i] := Kernel.CWD[i]; INC(i) END;
IF Kernel.CWD[i-1] # "/" THEN name[i] := "/"; INC(i) END
END;
j := 0;
WHILE finalName[j] # 0X DO name[i] := finalName[j]; INC(i); INC(j) END;
DEC(i);
WHILE name[i] # "/" DO DEC(i) END;
name[i+1] := "."; name[i+2] := "t"; name[i+3] := "m"; name[i+4] := "p"; name[i+5] := "."; INC(i, 6);
WHILE n > 0 DO name[i] := CHR(n MOD 10 + ORD("0")); n := n DIV 10; INC(i) END;
name[i] := "."; INC(i); n := SHORT(Unix.Getpid());
WHILE n > 0 DO name[i] := CHR(n MOD 10 + ORD("0")); n := n DIV 10; INC(i) END;
name[i] := 0X
END GetTempName;
PROCEDURE Create(f: File);
VAR stat: Unix.Status; done: BOOLEAN;
errno: LONGINT; err: ARRAY 32 OF CHAR;
BEGIN
IF f.fd = noDesc THEN
IF f.state = create THEN GetTempName(f.registerName, f.workName); f.tempFile := TRUE
ELSIF f.state = close THEN
f.workName := f.registerName; f.registerName := ""; f.tempFile := FALSE
END ;
errno := Unix.Unlink(f.workName); (*unlink first to avoid stale NFS handles and to avoid reuse of inodes*)
f.fd := Unix.Open(f.workName, Unix.rdwr + Unix.creat + Unix.trunc, {2, 4,5, 7,8});
done := f.fd >= 0; errno := Unix.errno();
IF (~done & ((errno = Unix.ENFILE) OR (errno = Unix.EMFILE))) OR (done & (f.fd >= fileTabSize)) THEN
IF done & (f.fd >= fileTabSize) THEN errno := Unix.Close(f.fd) END ;
Kernel.GC(TRUE);
f.fd := Unix.Open(f.workName, Unix.rdwr + Unix.creat + Unix.trunc, {2, 4,5, 7,8});
done := f.fd >= 0
END ;
IF done THEN
IF f.fd >= fileTabSize THEN errno := Unix.Close(f.fd); Err("too many files open", f, 0)
ELSE fileTab[f.fd] := SYSTEM.VAL(LONGINT, f); INC(Kernel.nofiles); Kernel.RegisterObject(f, Finalize);
f.state := open; f.pos := 0; errno := Unix.Fstat(f.fd, stat);
f.dev := stat.dev; f.ino := stat.ino; f.mtime := stat.mtime
END
ELSE errno := Unix.errno();
IF errno = Unix.ENOENT THEN err := "no such directory"
ELSIF (errno = Unix.ENFILE) OR (errno = Unix.EMFILE) THEN err := "too many files open"
ELSE err := "file not created"
END ;
Err(err, f, errno)
END
END
END Create;
PROCEDURE Flush(buf: Buffer);
VAR res: LONGINT; f: File; stat: Unix.Status;
BEGIN
IF buf.chg THEN f := buf.f; Create(f);
IF buf.org # f.pos THEN res := Unix.Lseek(f.fd, buf.org, 0) END ;
res := Unix.Write(f.fd, SYSTEM.ADR(buf.data), buf.size);
IF res < 0 THEN Err("error in writing file", f, Unix.errno()) END ;
f.pos := buf.org + buf.size;
buf.chg := FALSE;
res := Unix.Fstat(f.fd, stat);
f.mtime := stat.mtime
END
END Flush;
PROCEDURE Close* (f: File);
VAR i, res: LONGINT;
BEGIN
IF (f.state # create) OR (f.registerName # "") THEN
Create(f); i := 0;
WHILE (i < nofbufs) & (f.bufs[i] # NIL) DO Flush(f.bufs[i]); INC(i) END ;
res := Unix.Fsync(f.fd);
IF res < 0 THEN Err("error in writing file", f, Unix.errno()) END
END
END Close;
PROCEDURE Length* (f: File): LONGINT;
BEGIN RETURN f.len
END Length;
PROCEDURE New* (name: ARRAY OF CHAR): File;
VAR f: File;
BEGIN
NEW(f); f.workName := ""; COPY(name, f.registerName);
f.fd := noDesc; f.state := create; f.len := 0; f.pos := 0; f.swapper := -1; (*all f.buf[i] = NIL*)
RETURN f
END New;
PROCEDURE ScanPath(VAR pos: INTEGER; VAR dir: ARRAY OF CHAR); (* supports ~, ~user and blanks inside path *)
VAR i: INTEGER; ch: CHAR; home: ARRAY 256 OF CHAR;
BEGIN
i := 0; ch := Kernel.OBERON[pos];
WHILE (ch = " ") OR (ch = ":") DO INC(pos); ch := Kernel.OBERON[pos] END ;
IF ch = "~" THEN
INC(pos); ch := Kernel.OBERON[pos];
home := ""; Args.GetEnv("HOME", home);
WHILE home[i] # 0X DO dir[i] := home[i]; INC(i) END ;
IF (ch # "/") & (ch # 0X) & (ch # ":") & (ch # " ") THEN
WHILE (i > 0) & (dir[i-1] # "/") DO DEC(i) END
END
END ;
WHILE (ch # 0X) & (ch # ":") DO dir[i] := ch; INC(i); INC(pos); ch := Kernel.OBERON[pos] END ;
WHILE (i > 0) & (dir[i-1] = " ") DO DEC(i) END ;
dir[i] := 0X
END ScanPath;
PROCEDURE HasDir(VAR name: ARRAY OF CHAR): BOOLEAN;
VAR i: INTEGER; ch: CHAR;
BEGIN i := 0; ch := name[0];
WHILE (ch # 0X) & (ch # "/") DO INC(i); ch := name[i] END ;
RETURN ch = "/"
END HasDir;
PROCEDURE CacheEntry(dev, ino: LONGINT; mtime: LONGINT): File;
VAR f: File; i: INTEGER; stat: Unix.Status; res: LONGINT;
BEGIN i := 0;
WHILE i < fileTabSize DO
f := SYSTEM.VAL(File, fileTab[i]);
IF (f # NIL) & (ino = f.ino) & (dev = f.dev) THEN
IF mtime # f.mtime THEN i := 0;
WHILE i < nofbufs DO
IF f.bufs[i] # NIL THEN f.bufs[i].org := -1; f.bufs[i] := NIL END ;
INC(i)
END ;
f.swapper := -1; f.mtime := mtime;
res := Unix.Fstat(f.fd, stat); f.len := stat.size
END ;
RETURN f
END ;
INC(i)
END ;
RETURN NIL
END CacheEntry;
PROCEDURE Old* (name: ARRAY OF CHAR): File;
VAR f: File; fd, res, errno: LONGINT; pos: INTEGER; done: BOOLEAN;
dir, path: ARRAY 256 OF CHAR;
stat: Unix.Status;
BEGIN
IF name # "" THEN
IF HasDir(name) THEN dir := ""; COPY(name, path)
ELSE pos := 0; ScanPath(pos, dir); MakeFileName(dir, name, path); ScanPath(pos, dir)
END ;
LOOP
fd := Unix.Open(path, Unix.rdwr, {}); done := fd >= 0; errno := Unix.errno();
IF (~done & ((errno = Unix.ENFILE) OR (errno = Unix.EMFILE))) OR (done & (fd >= fileTabSize)) THEN
IF done & (fd >= fileTabSize) THEN res := Unix.Close(fd) END ;
Kernel.GC(TRUE);
fd := Unix.Open(path, Unix.rdwr, {});
done := fd >= 0; errno := Unix.errno();
IF ~done & ((errno = Unix.ENFILE) OR (errno = Unix.EMFILE)) THEN Err("too many files open", f, errno) END
END ;
IF ~done & ((errno = Unix.EACCES) OR (errno = Unix.EROFS) OR (errno = Unix.EAGAIN)) THEN
(* errno EAGAIN observed on Solaris 2.4 *)
fd := Unix.Open(path, Unix.rdonly, {}); done := fd >= 0; errno := Unix.errno()
END ;
IF (~done) & (errno # Unix.ENOENT) THEN
Console.String("warning Files.Old "); Console.String(name);
Console.String(" errno = "); Console.Int(errno, 0); Console.Ln;
END ;
IF done THEN
res := Unix.Fstat(fd, stat);
f := CacheEntry(stat.dev, stat.ino, stat.mtime);
IF f # NIL THEN res := Unix.Close(fd); RETURN f
ELSIF fd >= fileTabSize THEN res := Unix.Close(fd); Err("too many files open", f, 0)
ELSE NEW(f); fileTab[fd] := SYSTEM.VAL(LONGINT, f); INC(Kernel.nofiles); Kernel.RegisterObject(f, Finalize);
f.fd := fd; f.state := open; f.len := stat.size; f.pos := 0; f.swapper := -1; (*all f.buf[i] = NIL*)
COPY(name, f.workName); f.registerName := ""; f.tempFile := FALSE;
f.dev := stat.dev; f.ino := stat.ino; f.mtime := stat.mtime;
RETURN f
END
ELSIF dir = "" THEN RETURN NIL
ELSE MakeFileName(dir, name, path); ScanPath(pos, dir)
END
END
ELSE RETURN NIL
END
END Old;
PROCEDURE Purge* (f: File);
VAR i: INTEGER; stat: Unix.Status; res: LONGINT;
BEGIN i := 0;
WHILE i < nofbufs DO
IF f.bufs[i] # NIL THEN f.bufs[i].org := -1; f.bufs[i] := NIL END ;
INC(i)
END ;
IF f.fd # noDesc THEN res := Unix.Ftruncate(f.fd, 0); res := Unix.Lseek(f.fd, 0, 0) END ;
f.pos := 0; f.len := 0; f.swapper := -1;
res := Unix.Fstat(f.fd, stat); f.mtime := stat.mtime
END Purge;
PROCEDURE GetDate* (f: File; VAR t, d: LONGINT);
VAR stat: Unix.Status; clock, res: LONGINT; time: Time;
BEGIN
Create(f); res := Unix.Fstat(f.fd, stat);
time := localtime(stat.mtime);
t := time.sec + ASH(time.min, 6) + ASH(time.hour, 12);
d := time.mday + ASH(time.mon+1, 5) + ASH(time.year MOD 100, 9)
END GetDate;
PROCEDURE Pos* (VAR r: Rider): LONGINT;
BEGIN RETURN r.org + r.offset
END Pos;
PROCEDURE Set* (VAR r: Rider; f: File; pos: LONGINT);
VAR org, offset, i, n, res: LONGINT; buf: Buffer;
BEGIN
IF f # NIL THEN
IF pos > f.len THEN pos := f.len ELSIF pos < 0 THEN pos := 0 END ;
offset := pos MOD bufsize; org := pos - offset; i := 0;
WHILE (i < nofbufs) & (f.bufs[i] # NIL) & (org # f.bufs[i].org) DO INC(i) END ;
IF i < nofbufs THEN
IF f.bufs[i] = NIL THEN NEW(buf); buf.chg := FALSE; buf.org := -1; buf.f := f; f.bufs[i] := buf
ELSE buf := f.bufs[i]
END
ELSE
f.swapper := (f.swapper + 1) MOD nofbufs;
buf := f.bufs[f.swapper];
Flush(buf)
END ;
IF buf.org # org THEN
IF org = f.len THEN buf.size := 0
ELSE Create(f);
IF f.pos # org THEN res := Unix.Lseek(f.fd, org, 0) END ;
n := Unix.ReadBlk(f.fd, buf.data);
IF n < 0 THEN Err("read from file not done", f, Unix.errno()) END ;
f.pos := org + n;
buf.size := n
END ;
buf.org := org; buf.chg := FALSE
END
ELSE buf := NIL; org := 0; offset := 0
END ;
r.buf := buf; r.org := org; r.offset := offset; r.eof := FALSE; r.res := 0
END Set;
PROCEDURE Read* (VAR r: Rider; VAR x: SYSTEM.BYTE);
VAR offset: LONGINT; buf: Buffer;
BEGIN
buf := r.buf; offset := r.offset;
IF r.org # buf.org THEN Set(r, buf.f, r.org + offset); buf := r.buf; offset := r.offset END ;
IF (offset < buf.size) THEN
x := buf.data[offset]; r.offset := offset + 1
ELSIF r.org + offset < buf.f.len THEN
Set(r, r.buf.f, r.org + offset);
x := r.buf.data[0]; r.offset := 1
ELSE
x := 0X; r.eof := TRUE
END
END Read;
PROCEDURE ReadBytes* (VAR r: Rider; VAR x: ARRAY OF SYSTEM.BYTE; n: LONGINT);
VAR xpos, min, restInBuf, offset: LONGINT; buf: Buffer;
BEGIN
IF n > LEN(x) THEN IdxTrap END ;
xpos := 0; buf := r.buf; offset := r.offset;
WHILE n > 0 DO
IF (r.org # buf.org) OR (offset >= bufsize) THEN
Set(r, buf.f, r.org + offset);
buf := r.buf; offset := r.offset
END ;
restInBuf := buf.size - offset;
IF restInBuf = 0 THEN r.res := n; r.eof := TRUE; RETURN
ELSIF n > restInBuf THEN min := restInBuf ELSE min := n END ;
SYSTEM.MOVE(SYSTEM.ADR(buf.data) + offset, SYSTEM.ADR(x) + xpos, min);
INC(offset, min); r.offset := offset; INC(xpos, min); DEC(n, min)
END ;
r.res := 0; r.eof := FALSE
END ReadBytes;
PROCEDURE Base* (VAR r: Rider): File;
BEGIN RETURN r.buf.f
END Base;
PROCEDURE Write* (VAR r: Rider; x: SYSTEM.BYTE);
VAR buf: Buffer; offset: LONGINT;
BEGIN
buf := r.buf; offset := r.offset;
IF (r.org # buf.org) OR (offset >= bufsize) THEN
Set(r, buf.f, r.org + offset);
buf := r.buf; offset := r.offset
END ;
buf.data[offset] := x;
buf.chg := TRUE;
IF offset = buf.size THEN
INC(buf.size); INC(buf.f.len)
END ;
r.offset := offset + 1; r.res := 0
END Write;
PROCEDURE WriteBytes* (VAR r: Rider; VAR x: ARRAY OF SYSTEM.BYTE; n: LONGINT);
VAR xpos, min, restInBuf, offset: LONGINT; buf: Buffer;
BEGIN
IF n > LEN(x) THEN IdxTrap END ;
xpos := 0; buf := r.buf; offset := r.offset;
WHILE n > 0 DO
IF (r.org # buf.org) OR (offset >= bufsize) THEN
Set(r, buf.f, r.org + offset);
buf := r.buf; offset := r.offset
END ;
restInBuf := bufsize - offset;
IF n > restInBuf THEN min := restInBuf ELSE min := n END ;
SYSTEM.MOVE(SYSTEM.ADR(x) + xpos, SYSTEM.ADR(buf.data) + offset, min);
INC(offset, min); r.offset := offset;
IF offset > buf.size THEN INC(buf.f.len, offset - buf.size); buf.size := offset END ;
INC(xpos, min); DEC(n, min); buf.chg := TRUE
END ;
r.res := 0
END WriteBytes;
(* another solution would be one that is similar to ReadBytes, WriteBytes.
No code duplication, more symmetric, only two ifs for
Read and Write in buffer, buf.size replaced by bufsize in Write ops, buf.size and len
must be made consistent with offset (if offset > buf.size) in a lazy way.
PROCEDURE Write* (VAR r: Rider; x: SYSTEM.BYTE);
VAR buf: Buffer; offset: LONGINT;
BEGIN
buf := r.buf; offset := r.offset;
IF (offset >= bufsize) OR (r.org # buf.org) THEN
Set(r, buf.f, r.org + offset); buf := r.buf; offset := r.offset;
END ;
buf.data[offset] := x; r.offset := offset + 1; buf.chg := TRUE
END Write;
PROCEDURE WriteBytes ...
PROCEDURE Read* (VAR r: Rider; VAR x: SYSTEM.BYTE);
VAR offset: LONGINT; buf: Buffer;
BEGIN
buf := r.buf; offset := r.offset;
IF (offset >= buf.size) OR (r.org # buf.org) THEN
IF r.org + offset >= buf.f.len THEN x := 0X; r.eof := TRUE; RETURN
ELSE Set(r, buf.f, r.org + offset); buf := r.buf; offset := r.offset
END
END ;
x := buf.data[offset]; r.offset := offset + 1
END Read;
but this would also affect Set, Length, and Flush.
Especially Length would become fairly complex.
*)
PROCEDURE Delete* (name: ARRAY OF CHAR; VAR res: INTEGER);
BEGIN
res := SHORT(Unix.Unlink(name));
res := SHORT(Unix.errno())
END Delete;
PROCEDURE Rename* (old, new: ARRAY OF CHAR; VAR res: INTEGER);
VAR fdold, fdnew, n, errno, r: LONGINT;
ostat, nstat: Unix.Status;
buf: ARRAY 4096 OF CHAR;
BEGIN
r := Unix.Stat(old, ostat);
IF r >= 0 THEN
r := Unix.Stat(new, nstat);
IF (r >= 0) & ((ostat.dev # nstat.dev) OR (ostat.ino # nstat.ino)) THEN
Delete(new, res); (* work around stale nfs handles *)
END ;
r := Unix.Rename(old, new);
IF r < 0 THEN res := SHORT(Unix.errno());
IF res = Unix.EXDEV THEN (* cross device link, move the file *)
fdold := Unix.Open(old, Unix.rdonly, {});
IF fdold < 0 THEN res := 2; RETURN END ;
fdnew := Unix.Open(new, Unix.rdwr + Unix.creat + Unix.trunc, {2, 4,5, 7,8});
IF fdnew < 0 THEN r := Unix.Close(fdold); res := 3; RETURN END ;
n := Unix.Read(fdold, SYSTEM.ADR(buf), bufsize);
WHILE n > 0 DO
r := Unix.Write(fdnew, SYSTEM.ADR(buf), n);
IF r < 0 THEN errno := Unix.errno(); r := Unix.Close(fdold); r := Unix.Close(fdnew);
Err("cannot move file", NIL, errno)
END ;
n := Unix.Read(fdold, SYSTEM.ADR(buf), bufsize)
END ;
errno := Unix.errno();
r := Unix.Close(fdold); r := Unix.Close(fdnew);
IF n = 0 THEN r := Unix.Unlink(old); res := 0
ELSE Err("cannot move file", NIL, errno)
END ;
ELSE RETURN (* res is Unix.Rename return code *)
END
END ;
res := 0
ELSE res := 2 (* old file not found *)
END
END Rename;
PROCEDURE Register* (f: File);
VAR idx, errno: INTEGER; f1: File; file: ARRAY 104 OF CHAR;
BEGIN
IF (f.state = create) & (f.registerName # "") THEN f.state := close (* shortcut renaming *) END ;
Close(f);
IF f.registerName # "" THEN
Rename(f.workName, f.registerName, errno);
IF errno # 0 THEN COPY(f.registerName, file); HALT(99) END ;
f.workName := f.registerName; f.registerName := ""; f.tempFile := FALSE
END
END Register;
PROCEDURE ChangeDirectory*(path: ARRAY OF CHAR; VAR res: INTEGER);
BEGIN
res := SHORT(Unix.Chdir(path));
getcwd(Kernel.CWD)
END ChangeDirectory;
PROCEDURE FlipBytes(VAR src, dest: ARRAY OF SYSTEM.BYTE);
VAR i, j: LONGINT;
BEGIN
IF ~Kernel.littleEndian THEN i := LEN(src); j := 0;
WHILE i > 0 DO DEC(i); dest[j] := src[i]; INC(j) END
ELSE SYSTEM.MOVE(SYSTEM.ADR(src), SYSTEM.ADR(dest), LEN(src))
END
END FlipBytes;
PROCEDURE ReadBool* (VAR R: Rider; VAR x: BOOLEAN);
BEGIN Read(R, SYSTEM.VAL(CHAR, x))
END ReadBool;
PROCEDURE ReadInt* (VAR R: Rider; VAR x: INTEGER);
VAR b: ARRAY 2 OF CHAR;
BEGIN ReadBytes(R, b, 2);
x := ORD(b[0]) + ORD(b[1])*256
END ReadInt;
PROCEDURE ReadLInt* (VAR R: Rider; VAR x: LONGINT);
VAR b: ARRAY 4 OF CHAR;
BEGIN ReadBytes(R, b, 4);
x := ORD(b[0]) + ORD(b[1])*100H + ORD(b[2])*10000H + ORD(b[3])*1000000H
END ReadLInt;
PROCEDURE ReadSet* (VAR R: Rider; VAR x: SET);
VAR b: ARRAY 4 OF CHAR;
BEGIN ReadBytes(R, b, 4);
x := SYSTEM.VAL(SET, ORD(b[0]) + ORD(b[1])*100H + ORD(b[2])*10000H + ORD(b[3])*1000000H)
END ReadSet;
PROCEDURE ReadReal* (VAR R: Rider; VAR x: REAL);
VAR b: ARRAY 4 OF CHAR;
BEGIN ReadBytes(R, b, 4); FlipBytes(b, x)
END ReadReal;
PROCEDURE ReadLReal* (VAR R: Rider; VAR x: LONGREAL);
VAR b: ARRAY 8 OF CHAR;
BEGIN ReadBytes(R, b, 8); FlipBytes(b, x)
END ReadLReal;
PROCEDURE ReadString* (VAR R: Rider; VAR x: ARRAY OF CHAR);
VAR i: INTEGER; ch: CHAR;
BEGIN i := 0;
REPEAT Read(R, ch); x[i] := ch; INC(i) UNTIL ch = 0X
END ReadString;
PROCEDURE ReadNum* (VAR R: Rider; VAR x: LONGINT);
VAR s: SHORTINT; ch: CHAR; n: LONGINT;
BEGIN s := 0; n := 0; Read(R, ch);
WHILE ORD(ch) >= 128 DO INC(n, ASH(ORD(ch) - 128, s) ); INC(s, 7); Read(R, ch) END;
INC(n, ASH(ORD(ch) MOD 64 - ORD(ch) DIV 64 * 64, s) );
x := n
END ReadNum;
PROCEDURE WriteBool* (VAR R: Rider; x: BOOLEAN);
BEGIN Write(R, SYSTEM.VAL(CHAR, x))
END WriteBool;
PROCEDURE WriteInt* (VAR R: Rider; x: INTEGER);
VAR b: ARRAY 2 OF CHAR;
BEGIN b[0] := CHR(x); b[1] := CHR(x DIV 256);
WriteBytes(R, b, 2);
END WriteInt;
PROCEDURE WriteLInt* (VAR R: Rider; x: LONGINT);
VAR b: ARRAY 4 OF CHAR;
BEGIN
b[0] := CHR(x); b[1] := CHR(x DIV 100H); b[2] := CHR(x DIV 10000H); b[3] := CHR(x DIV 1000000H);
WriteBytes(R, b, 4);
END WriteLInt;
PROCEDURE WriteSet* (VAR R: Rider; x: SET);
VAR b: ARRAY 4 OF CHAR; i: LONGINT;
BEGIN i := SYSTEM.VAL(LONGINT, x);
b[0] := CHR(i); b[1] := CHR(i DIV 100H); b[2] := CHR(i DIV 10000H); b[3] := CHR(i DIV 1000000H);
WriteBytes(R, b, 4);
END WriteSet;
PROCEDURE WriteReal* (VAR R: Rider; x: REAL);
VAR b: ARRAY 4 OF CHAR;
BEGIN FlipBytes(x, b); WriteBytes(R, b, 4)
END WriteReal;
PROCEDURE WriteLReal* (VAR R: Rider; x: LONGREAL);
VAR b: ARRAY 8 OF CHAR;
BEGIN FlipBytes(x, b); WriteBytes(R, b, 8)
END WriteLReal;
PROCEDURE WriteString* (VAR R: Rider; x: ARRAY [1] OF CHAR);
VAR i: INTEGER;
BEGIN i := 0;
WHILE x[i] # 0X DO INC(i) END ;
WriteBytes(R, x, i+1)
END WriteString;
PROCEDURE WriteNum* (VAR R: Rider; x: LONGINT);
BEGIN
WHILE (x < - 64) OR (x > 63) DO Write(R, CHR(x MOD 128 + 128)); x := x DIV 128 END;
Write(R, CHR(x MOD 128))
END WriteNum;
PROCEDURE Finalize(o: SYSTEM.PTR);
VAR f: File; res: LONGINT;
BEGIN
f := SYSTEM.VAL(File, o);
IF f.fd >= 0 THEN
fileTab[f.fd] := 0; res := Unix.Close(f.fd); f.fd := -1; DEC(Kernel.nofiles);
IF f.tempFile THEN res := Unix.Unlink(f.workName) END
END
END Finalize;
PROCEDURE Init;
VAR i: LONGINT;
BEGIN
i := 0; WHILE i < fileTabSize DO fileTab[i] := 0; INC(i) END ;
tempno := -1; Kernel.nofiles := 0
END Init;
BEGIN Init
END Files.

175
src/lib/v4/Kernel.Mod Normal file
View file

@ -0,0 +1,175 @@
MODULE Kernel;
(*
J. Templ, 16.4.95
communication with C-runtime and storage management
*)
IMPORT SYSTEM, Unix, Args, Strings := oocOakStrings, version;
TYPE
RealTime = POINTER TO TimeDesc;
TimeDesc = RECORD
sec, min, hour, mday, mon, year, wday, isdst, zone, gmtoff: LONGINT
(* sec, min, hour, mday, mon, year, wday, isdst, zone, gmtoff: INTEGER*)
END ;
KeyCmd* = PROCEDURE;
ObjFinalizer* = PROCEDURE(obj: SYSTEM.PTR);
VAR
(* trap handling *)
trapEnv*: Unix.JmpBuf; (* saved stack environment for trap handling *)
(* oberon heap management *)
nofiles*: LONGINT;
(* input event handling *)
readSet*, readySet*: Unix.FdSet;
FKey*: ARRAY 16 OF KeyCmd;
littleEndian*: BOOLEAN;
TimeUnit*: LONGINT; (* 1 sec *)
LIB*, CWD*: ARRAY 256 OF CHAR;
OBERON*: ARRAY 1024 OF CHAR;
MODULES-: ARRAY 1024 OF CHAR;
prefix*, fullprefix* : ARRAY 256 OF CHAR;
timeStart: LONGINT; (* milliseconds *)
PROCEDURE -includesetjmp()
'#include "setjmp.h"';
(* for localtime *)
PROCEDURE -includetime()
'#include "time.h"';
PROCEDURE -Lock*()
"SYSTEM_lock++";
PROCEDURE -Unlock*()
"SYSTEM_lock--; if (SYSTEM_interrupted && SYSTEM_lock == 0) __HALT(-9)";
PROCEDURE -Exit*(n: LONGINT)
"exit(n)";
PROCEDURE -sigsetjmp*(VAR env: Unix.JmpBuf; savemask: LONGINT): LONGINT
"__sigsetjmp(env, savemask)";
PROCEDURE -siglongjmp*(VAR env:Unix.JmpBuf; val: LONGINT)
"siglongjmp(env, val)";
PROCEDURE -heapsize*(): LONGINT
"SYSTEM_heapsize";
PROCEDURE -allocated*(): LONGINT
"SYSTEM_allocated";
PROCEDURE -localtime(VAR clock: LONGINT): RealTime
"(Kernel_RealTime)localtime(clock)";
PROCEDURE -malloc*(size: LONGINT): LONGINT
"(LONGINT)malloc(size)";
PROCEDURE -free*(adr: LONGINT)
"(void)free(adr)";
PROCEDURE -getcwd(VAR cwd: Unix.Name)
"getcwd(cwd, cwd__len)";
PROCEDURE GetClock* (VAR t, d: LONGINT);
VAR tv: Unix.Timeval; tz: Unix.Timezone; time: RealTime;
BEGIN
Unix.Gettimeofday(tv, tz);
time := localtime(tv.sec);
t := time.sec + ASH(time.min, 6) + ASH(time.hour, 12);
d := time.mday + ASH(time.mon+1, 5) + ASH(time.year MOD 100, 9);
END GetClock;
PROCEDURE SetClock* (t, d: LONGINT);
VAR err: ARRAY 25 OF CHAR;
BEGIN err := "not yet implemented"; HALT(99)
END SetClock;
PROCEDURE Time*(): LONGINT;
VAR timeval: Unix.Timeval; timezone: Unix.Timezone;
BEGIN
Unix.Gettimeofday(timeval, timezone);
RETURN (timeval.usec DIV 1000 + timeval.sec * 1000 - timeStart) MOD 7FFFFFFFH
END Time;
(*
PROCEDURE UserTime*(): LONGINT;
VAR rusage: Unix.Rusage;
BEGIN
Unix.Getrusage(0, S.ADR(rusage));
RETURN rusage.utime.sec*1000 + rusage.utime.usec DIV 1000
(* + rusage.stime.sec*1000 + rusage.stime.usec DIV 1000*)
END UserTime;
*)
PROCEDURE Select*(delay: LONGINT);
VAR rs, ws, xs: Unix.FdSet; n: LONGINT; tv: Unix.Timeval;
BEGIN
rs := readSet;
FOR n := 0 TO 7 DO ws[n] := {}; xs[n] := {}; readySet[n] := {} END;
IF delay < 0 THEN delay := 0 END ;
tv.sec := delay DIV 1000; tv.usec := delay MOD 1000 * 1000;
n := Unix.Select(256, rs, ws, xs, tv);
IF n >= 0 THEN readySet := rs END
END Select;
PROCEDURE -GC*(markStack: BOOLEAN)
"SYSTEM_GC(markStack)";
PROCEDURE -RegisterObject*(obj: SYSTEM.PTR; finalize: ObjFinalizer)
"SYSTEM_REGFIN(obj, finalize)";
PROCEDURE -SetHalt*(p: PROCEDURE(n: LONGINT))
"SYSTEM_Halt = p";
PROCEDURE InstallTermHandler*(p: PROCEDURE);
(* not yet supported; no Modules.Free *)
END InstallTermHandler;
PROCEDURE LargestAvailable*(): LONGINT;
BEGIN
(* dummy proc for System 3 compatibility
no meaningful value except may be the remaining swap space can be returned
in the context of an extensible heap *)
RETURN MAX(LONGINT)
END LargestAvailable;
PROCEDURE Halt(n: LONGINT);
VAR res: LONGINT;
BEGIN res := Unix.Kill(Unix.Getpid(), 4);
END Halt;
PROCEDURE EndianTest;
VAR i: LONGINT; dmy: INTEGER;
BEGIN
dmy := 1; i := SYSTEM.ADR(dmy);
SYSTEM.GET(i, littleEndian); (* indirection via i avoids warning on SUN cc -O *)
END EndianTest;
BEGIN
EndianTest();
SetHalt(Halt);
CWD := ""; OBERON := "."; LIB := "";
MODULES := ""; (* additional modules path which can be specified on commandline and will be added to the OBERON variable; noch *)
getcwd(CWD);
Args.GetEnv ("MODULES", MODULES);
Args.GetEnv("OBERON", OBERON);
(* always have current directory in module search path, noch *)
Strings.Append(":.:", OBERON);
Strings.Append(version.prefix, OBERON);
Strings.Append("/lib/voc/sym:", OBERON);
Strings.Append(MODULES, OBERON);
Args.GetEnv("OBERON_LIB", LIB);
TimeUnit := 1000; timeStart := 0; timeStart := Time()
END Kernel.

96
src/lib/v4/Modules.Mod Normal file
View file

@ -0,0 +1,96 @@
MODULE Modules; (* jt 6.1.96 *)
(* access to list of modules and commands, based on ETH Oberon *)
IMPORT SYSTEM, Console;
CONST
ModNameLen* = 20;
TYPE
ModuleName* = ARRAY ModNameLen OF CHAR;
Module* = POINTER TO ModuleDesc;
Cmd* = POINTER TO CmdDesc;
ModuleDesc* = RECORD (* cf. SYSTEM.Mod *)
next-: Module;
name-: ModuleName;
refcnt-: LONGINT;
cmds-: Cmd;
types-: LONGINT;
enumPtrs-: PROCEDURE (P: PROCEDURE(p: LONGINT));
reserved1, reserved2: LONGINT;
END ;
Command* = PROCEDURE;
CmdDesc* = RECORD
next-: Cmd;
name-: ARRAY 24 OF CHAR;
cmd-: Command
END ;
VAR
res*: INTEGER;
resMsg*: ARRAY 256 OF CHAR;
imported*, importing*: ModuleName;
PROCEDURE -modules*(): Module
"(Modules_Module)SYSTEM_modules";
PROCEDURE -setmodules*(m: Module)
"SYSTEM_modules = m";
PROCEDURE Append(VAR a: ARRAY OF CHAR; b: ARRAY OF CHAR);
VAR i, j: INTEGER;
BEGIN
i := 0; WHILE a[i] # 0X DO INC(i) END;
j := 0; WHILE b[j] # 0X DO a[i] := b[j]; INC(i); INC(j) END;
a[i] := 0X
END Append;
PROCEDURE ThisMod* (name: ARRAY OF CHAR): Module;
VAR m: Module; bodyname: ARRAY 64 OF CHAR; body: Command;
BEGIN m := modules();
WHILE (m # NIL) & (m.name # name) DO m := m.next END ;
IF m # NIL THEN res := 0; resMsg := ""
ELSE res := 1; COPY(name, importing);
resMsg := ' module "'; Append(resMsg, name); Append(resMsg, '" not found');
END ;
RETURN m
END ThisMod;
PROCEDURE ThisCommand* (mod: Module; name: ARRAY OF CHAR): Command;
VAR c: Cmd;
BEGIN c := mod.cmds;
WHILE (c # NIL) & (c.name # name) DO c := c.next END ;
IF c # NIL THEN res := 0; resMsg := ""; RETURN c.cmd
ELSE res := 2; resMsg := ' command "'; COPY(name, importing);
Append(resMsg, mod.name); Append(resMsg, "."); Append(resMsg, name); Append(resMsg, '" not found');
RETURN NIL
END
END ThisCommand;
PROCEDURE Free*(name: ARRAY OF CHAR; all: BOOLEAN);
VAR m, p: Module;
BEGIN m := modules();
IF all THEN
res := 1; resMsg := 'unloading "all" not yet supported'
ELSE
WHILE (m # NIL) & (m.name # name) DO p := m; m := m.next END ;
IF (m # NIL) & (m.refcnt = 0) THEN
IF m = modules() THEN setmodules(m.next)
ELSE p.next := m.next
END ;
res := 0
ELSE res := 1;
IF m = NIL THEN resMsg := "module not found"
ELSE resMsg := "clients of this module exist"
END
END
END
END Free;
END Modules.

BIN
src/lib/v4/Reals.Mod Normal file
View file

Binary file not shown.