vishapoberon/compiler
1
0
Fork 0
mirror of https://github.com/vishapoberon/compiler.git synced 2026-04-06 04:02:25 +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.

12
src/par/voc.par.gnuc.armv6j Normal file
View file

@ -0,0 +1,12 @@
CHAR 1 1
BOOLEAN 1 1
SHORTINT 1 1
INTEGER 2 2
LONGINT 4 4
SET 4 4
REAL 4 4
LONGREAL 8 8
PTR 4 4
PROC 4 4
RECORD 1 1
ENDIAN 1 0

12
src/par/voc.par.gnuc.armv6j_hardfp Normal file
View file

@ -0,0 +1,12 @@
CHAR 1 1
BOOLEAN 1 1
SHORTINT 1 1
INTEGER 2 2
LONGINT 4 4
SET 4 4
REAL 4 4
LONGREAL 8 8
PTR 4 4
PROC 4 4
RECORD 1 1
ENDIAN 1 0

12
src/par/voc.par.gnuc.armv7a_hardfp Normal file
View file

@ -0,0 +1,12 @@
CHAR 1 1
BOOLEAN 1 1
SHORTINT 1 1
INTEGER 2 2
LONGINT 4 4
SET 4 4
REAL 4 4
LONGREAL 8 8
PTR 4 4
PROC 4 4
RECORD 1 1
ENDIAN 1 0

12
src/par/voc.par.gnuc.x86 Normal file
View file

@ -0,0 +1,12 @@
CHAR 1 1
BOOLEAN 1 1
SHORTINT 1 1
INTEGER 2 2
LONGINT 4 4
SET 4 4
REAL 4 4
LONGREAL 8 4
PTR 4 4
PROC 4 4
RECORD 1 1
ENDIAN 1 0

12
src/par/voc.par.gnuc.x86_64 Normal file
View file

@ -0,0 +1,12 @@
CHAR 1 1
BOOLEAN 1 1
SHORTINT 1 1
INTEGER 4 4
LONGINT 8 8
SET 8 8
REAL 4 4
LONGREAL 8 8
PTR 8 8
PROC 8 8
RECORD 1 1
ENDIAN 1 0

34
src/test/testFiles.Mod Normal file
View file

@ -0,0 +1,34 @@
MODULE testFiles;
IMPORT Files, Texts := CmdlnTexts, Console;
CONST file="makefile";
VAR
T : Texts.Text;
R : Texts.Reader;
F : Files.File;
ch : CHAR;
BEGIN
F := Files.Old (file);
IF F # NIL THEN
NEW(T);
Texts.Open(T, file);
Texts.OpenReader(R, T, 0);
Texts.Read (R, ch);
WHILE ~R.eot DO
Texts.Read (R, ch);
Console.Char(ch);
END;
ELSE
Console.String ("cannot open"); Console.Ln;
END;
END testFiles.

303
src/tools/browser/BrowserCmd.Mod Normal file
View file

@ -0,0 +1,303 @@
MODULE BrowserCmd; (* RC 29.10.93 *) (* object model 4.12.93, command line version jt 4.4.95 *)
IMPORT
OPM, OPS, OPT, OPV,
Texts := CmdlnTexts, Console, Args;
CONST
OptionChar = "-";
(* object modes *)
Var = 1; VarPar = 2; Con = 3; Fld = 4; Typ = 5; LProc = 6; XProc = 7;
SProc = 8; CProc = 9; IProc = 10; Mod = 11; Head = 12; TProc = 13;
(* structure forms *)
Undef = 0; Byte = 1; Bool = 2; Char = 3; SInt = 4; Int = 5; LInt = 6;
Real = 7; LReal = 8; Set = 9; String = 10; NilTyp = 11; NoTyp = 12;
Pointer = 13; ProcTyp = 14; Comp = 15;
(* composite structure forms *)
Basic = 1; Array = 2; DynArr = 3; Record = 4;
(* module visibility of objects *)
internal = 0; external = 1; externalR = 2;
(* symbol file items *)
Smname = 16; Send = 18; Stype = 19; Salias = 20; Svar = 21; Srvar = 22;
Svalpar = 23; Svarpar = 24; Sfld = 25; Srfld = 26; Shdptr = 27; Shdpro = 28; Stpro = 29; Shdtpro = 30;
Sxpro = 31; Sipro = 32; Scpro = 33; Sstruct = 34; Ssys = 35; Sptr = 36; Sarr = 37; Sdarr = 38; Srec = 39; Spro = 40;
VAR
W: Texts.Writer;
option: CHAR;
PROCEDURE Ws(s: ARRAY OF CHAR); BEGIN Texts.WriteString(W, s) END Ws;
PROCEDURE Wch(ch: CHAR); BEGIN Texts.Write(W, ch) END Wch;
PROCEDURE Wi(i: LONGINT); BEGIN Texts.WriteInt(W, i, 0) END Wi;
PROCEDURE Wln; BEGIN Texts.WriteLn(W) END Wln;
PROCEDURE Indent(i: INTEGER);
BEGIN WHILE i > 0 DO Wch(" "); Wch(" "); DEC(i) END
END Indent;
PROCEDURE ^Wtype(typ: OPT.Struct);
PROCEDURE ^Wstruct(typ: OPT.Struct);
PROCEDURE Wsign(result: OPT.Struct; par: OPT.Object);
VAR paren, res, first: BOOLEAN;
BEGIN first := TRUE;
res := (result # NIL) (* hidden mthd *) & (result # OPT.notyp);
paren := res OR (par # NIL);
IF paren THEN Wch("(") END ;
WHILE par # NIL DO
IF ~first THEN Ws("; ") ELSE first := FALSE END ;
IF option = "x" THEN Wi(par^.adr); Wch(" ") END ;
IF par^.mode = VarPar THEN Ws("VAR ") END ;
Ws(par^.name); Ws(": "); Wtype(par^.typ);
par := par^.link
END ;
IF paren THEN Wch(")") END ;
IF res THEN Ws(": "); Wtype(result) END
END Wsign;
PROCEDURE Objects(obj: OPT.Object; mode: SET);
VAR i: LONGINT; m: INTEGER; s: SET; ext: OPT.ConstExt;
BEGIN
IF obj # NIL THEN
Objects(obj^.left, mode);
IF obj^.mode IN mode THEN
CASE obj^.mode OF
| Con:
Indent(2); Ws(obj^.name); Ws(" = ");
CASE obj^.typ^.form OF
| Bool:
IF obj^.conval^.intval = 1 THEN Ws("TRUE") ELSE Ws("FALSE") END
| Char:
IF (obj^.conval^.intval >= 32) & (obj^.conval^.intval <= 126) THEN
Wch(22X); Wch(CHR(obj^.conval^.intval)); Wch(22X)
ELSE
i := obj^.conval^.intval DIV 16;
IF i > 9 THEN Wch(CHR(55 + i)) ELSE Wch(CHR(48 + i)) END ;
i := obj^.conval^.intval MOD 16;
IF i > 9 THEN Wch(CHR(55 + i)) ELSE Wch(CHR(48 + i)) END ;
Wch("X")
END
| SInt, Int, LInt:
Wi(obj^.conval^.intval)
| Set:
Wch("{"); i := 0; s := obj^.conval^.setval;
WHILE i <= MAX(SET) DO
IF i IN s THEN Wi(i); EXCL(s, i);
IF s # {} THEN Ws(", ") END
END ;
INC(i)
END ;
Wch("}")
| Real:
Texts.WriteReal(W, SHORT(obj^.conval^.realval), 16)
| LReal:
Texts.WriteLongReal(W, obj^.conval^.realval, 23)
| String:
Ws(obj^.conval^.ext^)
| NilTyp:
Ws("NIL")
END ;
Wch(";"); Wln
| Typ:
IF obj^.name # "" THEN Indent(2);
IF obj^.typ^.strobj = obj THEN (* canonical name *)
Wtype(obj^.typ); Ws(" = "); Wstruct(obj^.typ)
ELSE (* alias *)
Ws(obj^.name); Ws(" = "); Wtype(obj^.typ)
END ;
Wch(";"); Wln
END
| Var:
Indent(2); Ws(obj^.name);
IF obj^.vis = externalR THEN Ws("-: ") ELSE Ws(": ") END ;
Wtype(obj^.typ); Wch(";"); Wln
| XProc, CProc, IProc:
Indent(1); Ws("PROCEDURE ");
IF obj^.mode = IProc THEN Wch("+")
ELSIF obj^.mode = CProc THEN Wch("-")
END ;
Ws(obj^.name);
Wsign(obj^.typ, obj^.link);
IF obj^.mode = CProc THEN
ext := obj^.conval^.ext; m := ORD(ext^[0]); i := 1; Ws(' "');
WHILE i <= m DO Wch(ext^[i]); INC(i) END ;
Wch('"');
END ;
Wch(";"); Wln
END
END ;
Objects(obj^.right, mode)
END
END Objects;
PROCEDURE Wmthd(obj: OPT.Object);
VAR
BEGIN
IF obj # NIL THEN
Wmthd(obj^.left);
IF (obj^.mode = TProc) & ((obj^.name # OPM.HdTProcName) OR (option = "x")) THEN
Indent(3); Ws("PROCEDURE (");
IF obj^.name # OPM.HdTProcName THEN
IF obj^.link^.mode = VarPar THEN Ws("VAR ") END ;
Ws(obj^.link^.name); Ws(": "); Wtype(obj^.link^.typ)
END ;
Ws(") "); Ws(obj^.name);
Wsign(obj^.typ, obj^.link^.link);
Wch(";");
IF option = "x" THEN Indent(1);
Ws("(* methno: "); Wi(obj^.adr DIV 10000H); Ws(" *)")
END ;
Wln;
END ;
Wmthd(obj^.right)
END
END Wmthd;
PROCEDURE Wstruct(typ: OPT.Struct);
VAR fld: OPT.Object;
PROCEDURE SysFlag;
BEGIN
IF typ^.sysflag # 0 THEN
Wch("["); Wi(typ^.sysflag); Ws("] ")
END
END SysFlag;
BEGIN
CASE typ^.form OF
| Undef:
Ws("Undef")
| Pointer:
Ws("POINTER "); SysFlag; Ws("TO "); Wtype(typ^.BaseTyp)
| ProcTyp:
Ws("PROCEDURE "); SysFlag; Wsign(typ^.BaseTyp, typ^.link)
| Comp:
CASE typ^.comp OF
| Array:
Ws("ARRAY "); SysFlag; Wi(typ^.n); Ws(" OF "); Wtype(typ^.BaseTyp)
| DynArr:
Ws("ARRAY "); SysFlag; Ws("OF "); Wtype(typ^.BaseTyp)
| Record:
Ws("RECORD ");SysFlag;
IF typ^.BaseTyp # NIL THEN Wch("("); Wtype(typ^.BaseTyp); Wch(")") END ;
Wln; fld := typ^.link;
WHILE (fld # NIL) & (fld^.mode = Fld) DO
IF (option = "x") OR (fld^.name[0] # "@") THEN Indent(3);
IF option = "x" THEN Wi(fld^.adr); Wch(" ") END ;
Ws(fld^.name);
IF fld^.vis = externalR THEN Wch("-") END ;
Ws(": "); Wtype(fld^.typ); Wch(";");
Wln
END ;
fld := fld^.link
END ;
Wmthd(typ^.link);
Indent(2); Ws("END ");
IF option = "x" THEN Indent(1);
Ws("(* size: "); Wi(typ^.size); Ws(" align: "); Wi(typ^.align);
Ws(" nofm: "); Wi(typ^.n); Ws(" *)")
END
END
END
END Wstruct;
PROCEDURE Wtype(typ: OPT.Struct);
VAR obj: OPT.Object;
BEGIN
obj := typ^.strobj;
IF obj^.name # "" THEN
IF typ^.mno # 0 THEN Ws(OPT.GlbMod[typ^.mno].name); Wch(".")
ELSIF (typ = OPT.bytetyp) OR (typ = OPT.sysptrtyp) THEN Ws("SYSTEM.")
ELSIF obj^.vis = internal THEN Wch("#")
END ;
Ws(obj^.name)
ELSE
IF (option = "x") & (typ^.ref > OPM.MaxStruct) THEN Wch("#"); Wi(typ^.ref - OPM.MaxStruct); Wch(" ") END ;
Wstruct(typ)
END
END Wtype;
PROCEDURE WModule(name: OPS.Name; T: Texts.Text);
VAR i: INTEGER;
beg, end: LONGINT; first, done: BOOLEAN;
PROCEDURE Header(s: ARRAY OF CHAR);
BEGIN
beg := W.buf.len; Indent(1); Ws(s); Wln; end := W.buf.len
END Header;
PROCEDURE CheckHeader;
VAR len: LONGINT;
BEGIN
len := T.len;
IF end = W.buf.len THEN Texts.Append(T, W.buf); Texts.Delete(T, len+beg, len+end)
ELSE Wln
END
END CheckHeader;
BEGIN
OPT.Import("@notself", name, done);
IF done THEN
Ws("DEFINITION "); Ws(name); Wch(";"); Wln; Wln;
Header("IMPORT"); i := 1; first := TRUE;
WHILE i < OPT.nofGmod DO
IF first THEN first := FALSE; Indent(2) ELSE Ws(", ") END ;
Ws(OPT.GlbMod[i].name);
INC(i)
END ;
IF ~first THEN Wch(";"); Wln END ;
CheckHeader;
Header("CONST"); Objects(OPT.GlbMod[0].right, {Con}); CheckHeader;
Header("TYPE"); Objects(OPT.GlbMod[0].right, {Typ}); CheckHeader;
Header("VAR"); Objects(OPT.GlbMod[0].right, {Var}); CheckHeader;
Objects(OPT.GlbMod[0].right, {XProc, IProc, CProc});
Wln;
Ws("END "); Ws(name); Wch("."); Wln; Texts.Append(T, W.buf)
ELSE
Texts.WriteString(W, name); Texts.WriteString(W, " -- symbol file not found");
Texts.WriteLn(W); Texts.Append(T, W.buf)
END
END WModule;
PROCEDURE Ident(VAR name, first: ARRAY OF CHAR);
VAR i, j: INTEGER; ch: CHAR;
BEGIN i := 0;
WHILE name[i] # 0X DO INC(i) END ;
WHILE (i >= 0) & (name[i] # "/") DO DEC(i) END ;
INC(i); j := 0; ch := name[i];
WHILE (ch # ".") & (ch # 0X) DO first[j] := ch; INC(i); INC(j); ch := name[i] END ;
first[j] := 0X
END Ident;
PROCEDURE ShowDef*;
VAR T, dummyT: Texts.Text; S, vname, name: OPS.Name; R: Texts.Reader; ch: CHAR;
s: ARRAY 1024 OF CHAR; i: INTEGER;
BEGIN
option := 0X; Args.Get(1, S);
IF Args.argc > 2 THEN
IF S[0] = OptionChar THEN option := S[1]; Args.Get(2, S)
ELSE Args.Get(2, vname); option := vname[1]
END
END ;
IF Args.argc >= 2 THEN
Ident(S, name);
NEW(T); Texts.Open(T, "");
OPT.Init(name, {}); OPT.SelfName := "AvoidErr154"; WModule(name, T); OPT.Close;
Texts.OpenReader(R, T, 0); Texts.Read(R, ch); i := 0;
WHILE ~R.eot DO
IF ch = 0DX THEN s[i] := 0X; i := 0; Console.String(s); Console.Ln
ELSE s[i] := ch; INC(i)
END ;
Texts.Read(R, ch)
END ;
s[i] := 0X; Console.String(s)
END
END ShowDef;
BEGIN
OPT.typSize := OPV.TypSize; Texts.OpenWriter(W); ShowDef
END BrowserCmd.

376
src/tools/coco/CR.ATG Normal file
View file

@ -0,0 +1,376 @@
COMPILER CR (*H.Moessenboeck 17.11.93, Coco/R*)
(*---------------------- semantic declarations ----------------------------*)
IMPORT CRT, CRA, CRX, Sets, Texts := CmdlnTexts, Oberon;
CONST
ident = 0; string = 1; (*symbol kind*)
VAR
str: ARRAY 32 OF CHAR;
w: Texts.Writer;
genScanner: BOOLEAN;
PROCEDURE SemErr(nr: INTEGER);
BEGIN
CRS.Error(200+nr, CRS.pos);
END SemErr;
PROCEDURE MatchLiteral(sp: INTEGER); (*store string either as token or as literal*)
VAR sn, sn1: CRT.SymbolNode; matchedSp: INTEGER;
BEGIN
CRT.GetSym(sp, sn);
CRA.MatchDFA(sn.name, sp, matchedSp);
IF matchedSp # CRT.noSym THEN
CRT.GetSym(matchedSp, sn1); sn1.struct := CRT.classLitToken; CRT.PutSym(matchedSp, sn1);
sn.struct := CRT.litToken
ELSE sn.struct := CRT.classToken;
END;
CRT.PutSym(sp, sn)
END MatchLiteral;
PROCEDURE SetCtx(gp: INTEGER); (*set transition code to CRT.contextTrans*)
VAR gn: CRT.GraphNode;
BEGIN
WHILE gp > 0 DO
CRT.GetNode(gp, gn);
IF gn.typ IN {CRT.char, CRT.class} THEN
gn.p2 := CRT.contextTrans; CRT.PutNode(gp, gn)
ELSIF gn.typ IN {CRT.opt, CRT.iter} THEN SetCtx(gn.p1)
ELSIF gn.typ = CRT.alt THEN SetCtx(gn.p1); SetCtx(gn.p2)
END;
gp := gn.next
END
END SetCtx;
PROCEDURE SetDDT(s: ARRAY OF CHAR);
VAR name: ARRAY 64 OF CHAR; i: INTEGER; ch: CHAR;
BEGIN
i := 1;
WHILE s[i] # 0X DO
ch := s[i]; INC(i);
IF (ch >= "0") & (ch <= "9") THEN CRT.ddt[ORD(ch)-ORD("0")] := TRUE END
END
END SetDDT;
PROCEDURE FixString (VAR s: ARRAY OF CHAR; len: INTEGER);
VAR double: BOOLEAN; i: INTEGER;
BEGIN
double := FALSE;
FOR i := 0 TO len-2 DO
IF s[i] = '"' THEN double := TRUE END
END;
IF ~ double THEN s[0] := '"'; s[len-1] := '"' END
END FixString;
(*-------------------------------------------------------------------------*)
CHARACTERS
letter = "ABCDEFGHIJKLMNOPQRSTUVWXYZabcdefghijklmnopqrstuvwxyz".
digit = "0123456789".
eol = CHR(13).
tab = CHR(9).
noQuote1 = ANY - '"' - eol.
noQuote2 = ANY - "'" - eol.
IGNORE eol + tab + CHR(28)
TOKENS
ident = letter {letter | digit}.
string = '"' {noQuote1} '"' | "'" {noQuote2} "'".
number = digit {digit}.
PRAGMAS
ddtSym = "$" {digit}. (. CRS.GetName(CRS.nextPos, CRS.nextLen, str); SetDDT(str) .)
COMMENTS FROM "(*" TO "*)" NESTED
(*-------------------------------------------------------------------------*)
PRODUCTIONS
CR (. VAR undef, hasAttrs, ok, ok1: BOOLEAN; eofSy, gR: INTEGER;
gramLine, sp: INTEGER;
gn: CRT.GraphNode; sn: CRT.SymbolNode;
name, gramName: CRT.Name; .)
=
"COMPILER" (. Texts.OpenWriter(w);
CRT.Init; CRX.Init; CRA.Init;
gramLine := CRS.line;
eofSy := CRT.NewSym(CRT.t, "EOF", 0);
genScanner := TRUE;
CRT.ignoreCase := FALSE;
ok := TRUE;
Sets.Clear(CRT.ignored) .)
ident (. CRS.GetName(CRS.pos, CRS.len, gramName);
CRT.semDeclPos.beg := CRS.nextPos; CRT.importPos.beg := -1; .)
{ "IMPORT" (. CRT.importPos.beg := CRS.nextPos .)
{ANY} ";" (. CRT.importPos.len := SHORT(CRS.pos - CRT.importPos.beg);
CRT.importPos.col := 0;
CRT.semDeclPos.beg := CRS.nextPos .)
| ANY
} (. CRT.semDeclPos.len := SHORT(CRS.nextPos - CRT.semDeclPos.beg);
CRT.semDeclPos.col := 0 .)
{ Declaration }
SYNC
"PRODUCTIONS" (. IF genScanner THEN CRA.MakeDeterministic(ok) END;
CRT.nNodes := 0 .)
{ ident (. CRS.GetName(CRS.pos, CRS.len, name);
sp := CRT.FindSym(name); undef := sp = CRT.noSym;
IF undef THEN
sp := CRT.NewSym(CRT.nt, name, CRS.line);
CRT.GetSym(sp, sn);
ELSE
CRT.GetSym(sp, sn);
IF sn.typ = CRT.nt THEN
IF sn.struct > 0 THEN SemErr(7) END
ELSE SemErr(8)
END;
sn.line := CRS.line
END;
hasAttrs := sn.attrPos.beg >= 0 .)
( Attribs <sn.attrPos> (. IF ~undef & ~hasAttrs THEN SemErr(9) END;
CRT.PutSym(sp, sn) .)
| (. IF ~undef & hasAttrs THEN SemErr(10) END .)
)
[ SemText <sn.semPos>]
WEAK "="
Expression <sn.struct, gR> (. CRT.CompleteGraph(gR); CRT.PutSym(sp, sn);
IF CRT.ddt[2] THEN CRT.PrintGraph END .)
WEAK "."
} (. sp := CRT.FindSym(gramName);
IF sp = CRT.noSym THEN SemErr(11);
ELSE
CRT.GetSym(sp, sn);
IF sn.attrPos.beg >= 0 THEN SemErr(12) END;
CRT.root := CRT.NewNode(CRT.nt, sp, gramLine);
END .)
"END" ident (. CRS.GetName(CRS.pos, CRS.len, name);
IF name # gramName THEN SemErr(17) END;
IF CRS.errors = 0 THEN
Texts.WriteString(w, " checking"); Texts.Append(Oberon.Log, w.buf);
CRT.CompSymbolSets;
IF ok THEN CRT.TestCompleteness(ok) END;
IF ok THEN
CRT.TestIfAllNtReached(ok1); CRT.FindCircularProductions(ok)
END;
IF ok THEN CRT.TestIfNtToTerm(ok) END;
IF ok THEN CRT.LL1Test(ok1) END;
IF CRT.ddt[0] THEN CRA.PrintStates END;
IF CRT.ddt[7] THEN CRT.XRef END;
IF ok THEN
Texts.WriteString(w, " +parser");
Texts.Append(Oberon.Log, w.buf);
CRX.GenCompiler;
IF genScanner THEN
Texts.WriteString(w, " +scanner");
Texts.Append(Oberon.Log, w.buf);
CRA.WriteScanner
END;
IF CRT.ddt[8] THEN CRX.WriteStatistics END
END
ELSE ok := FALSE
END;
IF CRT.ddt[6] THEN CRT.PrintSymbolTable END;
IF ok THEN Texts.WriteString(w, " done") END;
Texts.WriteLn(w); Texts.Append(Oberon.Log, w.buf) .)
".".
(*------------------------------------------------------------------------------------*)
Declaration (. VAR gL1, gR1, gL2, gR2: INTEGER; nested: BOOLEAN; .)
=
"CHARACTERS" { SetDecl }
| "TOKENS" { TokenDecl <CRT.t> }
| "PRAGMAS" { TokenDecl <CRT.pr> }
| "COMMENTS"
"FROM" TokenExpr <gL1, gR1>
"TO" TokenExpr <gL2, gR2>
( "NESTED" (. nested := TRUE .)
| (. nested := FALSE .)
) (. CRA.NewComment(gL1, gL2, nested) .)
| "IGNORE"
( "CASE" (. CRT.ignoreCase := TRUE .)
| Set <CRT.ignored>
)
.
(*------------------------------------------------------------------------------------*)
SetDecl (. VAR c: INTEGER; set: CRT.Set; name: CRT.Name; .)
=
ident (. CRS.GetName(CRS.pos, CRS.len, name);
c := CRT.ClassWithName(name); IF c >= 0 THEN SemErr(7) END .)
"=" Set <set> (. c := CRT.NewClass(name, set) .)
".".
(*------------------------------------------------------------------------------------*)
Set <VAR set: CRT.Set> (. VAR set2: CRT.Set; .)
=
SimSet <set>
{ "+" SimSet <set2> (. Sets.Unite(set, set2) .)
| "-" SimSet <set2> (. Sets.Differ(set, set2) .)
}.
(*------------------------------------------------------------------------------------*)
SimSet <VAR set: CRT.Set> (. VAR c, n, i: INTEGER; name: CRT.Name; s: ARRAY 128 OF CHAR; .)
=
ident (. CRS.GetName(CRS.pos, CRS.len, name);
c := CRT.ClassWithName(name);
IF c < 0 THEN SemErr(15); Sets.Clear(set)
ELSE CRT.GetClass(c, set)
END .)
| string (. CRS.GetName(CRS.pos, CRS.len, s);
Sets.Clear(set); i := 1;
WHILE s[i] # s[0] DO
Sets.Incl(set, ORD(s[i])); INC(i)
END .)
| "CHR" "(" number (. CRS.GetName(CRS.pos, CRS.len, name);
n := 0; i := 0;
WHILE name[i] # 0X DO
n := 10 * n + (ORD(name[i]) - ORD("0"));
INC(i)
END;
Sets.Clear(set); Sets.Incl(set, n) .)
")"
| "ANY" (. Sets.Fill(set) .)
.
(*------------------------------------------------------------------------------------*)
TokenDecl <typ: INTEGER> (. VAR sp, kind, gL, gR: INTEGER; sn: CRT.SymbolNode;
pos: CRT.Position; name: CRT.Name; .)
=
Symbol <name, kind> (. IF CRT.FindSym(name) # CRT.noSym THEN SemErr(7)
ELSE
sp := CRT.NewSym(typ, name, CRS.line);
CRT.GetSym(sp, sn); sn.struct := CRT.classToken;
CRT.PutSym(sp, sn)
END .)
SYNC
( "=" TokenExpr <gL, gR> "." (. IF kind # ident THEN SemErr(13) END;
CRT.CompleteGraph(gR);
CRA.ConvertToStates(gL, sp) .)
| (. IF kind = ident THEN genScanner := FALSE
ELSE MatchLiteral(sp)
END .)
)
[ SemText <pos> (. IF typ = CRT.t THEN SemErr(14) END;
CRT.GetSym(sp, sn); sn.semPos := pos; CRT.PutSym(sp, sn) .)
].
(*------------------------------------------------------------------------------------*)
Expression <VAR gL, gR: INTEGER> (. VAR gL2, gR2: INTEGER; first: BOOLEAN; .)
=
Term <gL, gR> (. first := TRUE .)
{ WEAK "|"
Term <gL2, gR2> (. IF first THEN
CRT.MakeFirstAlt(gL, gR); first := FALSE
END;
CRT.ConcatAlt(gL, gR, gL2, gR2) .)
}.
(*------------------------------------------------------------------------------------*)
Term<VAR gL, gR: INTEGER> (. VAR gL2, gR2: INTEGER; .)
= (. gL := 0; gR := 0 .)
( Factor <gL, gR>
{ Factor <gL2, gR2> (. CRT.ConcatSeq(gL, gR, gL2, gR2) .)
}
| (. gL := CRT.NewNode(CRT.eps, 0, 0); gR := gL .)
).
(*------------------------------------------------------------------------------------*)
Factor <VAR gL, gR: INTEGER> (. VAR sp, kind, c: INTEGER; name: CRT.Name;
gn: CRT.GraphNode; sn: CRT.SymbolNode;
set: CRT.Set;
undef, weak: BOOLEAN;
pos: CRT.Position; .)
=
(. gL :=0; gR := 0; weak := FALSE .)
( [ "WEAK" (. weak := TRUE .)
]
Symbol <name, kind> (. sp := CRT.FindSym(name); undef := sp = CRT.noSym;
IF undef THEN
IF kind = ident THEN (*forward nt*)
sp := CRT.NewSym(CRT.nt, name, 0)
ELSE (*undefined string in production*)
sp := CRT.NewSym(CRT.t, name, CRS.line);
MatchLiteral(sp)
END
END;
CRT.GetSym(sp, sn);
IF ~(sn.typ IN {CRT.t,CRT.nt}) THEN SemErr(4) END;
IF weak THEN
IF sn.typ = CRT.t THEN sn.typ := CRT.wt ELSE SemErr(23) END
END;
gL := CRT.NewNode(sn.typ, sp, CRS.line); gR := gL .)
( Attribs <pos> (. CRT.GetNode(gL, gn); gn.pos := pos; CRT.PutNode(gL, gn);
CRT.GetSym(sp, sn);
IF undef THEN
sn.attrPos := pos; CRT.PutSym(sp, sn)
ELSIF sn.attrPos.beg < 0 THEN SemErr(5)
END;
IF kind # ident THEN SemErr(3) END .)
| (. CRT.GetSym(sp, sn);
IF sn.attrPos.beg >= 0 THEN SemErr(6) END .)
)
| "(" Expression <gL, gR> ")"
| "[" Expression <gL, gR> "]" (. CRT.MakeOption(gL, gR) .)
| "{" Expression <gL, gR> "}" (. CRT.MakeIteration(gL, gR) .)
| SemText <pos> (. gL := CRT.NewNode(CRT.sem, 0, 0);
gR := gL;
CRT.GetNode(gL, gn); gn.pos := pos; CRT.PutNode(gL, gn) .)
| "ANY" (. Sets.Fill(set); Sets.Excl(set, CRT.eofSy);
gL := CRT.NewNode(CRT.any, CRT.NewSet(set), 0); gR := gL .)
| "SYNC" (. gL := CRT.NewNode(CRT.sync, 0, 0); gR := gL .)
).
(*------------------------------------------------------------------------------------*)
TokenExpr <VAR gL, gR: INTEGER> (. VAR gL2, gR2: INTEGER; first: BOOLEAN; .)
=
TokenTerm <gL, gR> (. first := TRUE .)
{ WEAK "|"
TokenTerm <gL2, gR2> (. IF first THEN
CRT.MakeFirstAlt(gL, gR); first := FALSE
END;
CRT.ConcatAlt(gL, gR, gL2, gR2) .)
}.
(*------------------------------------------------------------------------------------*)
TokenTerm <VAR gL, gR: INTEGER> (. VAR gL2, gR2: INTEGER; .)
=
TokenFactor <gL, gR>
{ TokenFactor <gL2, gR2> (. CRT.ConcatSeq(gL, gR, gL2, gR2) .)
}
[ "CONTEXT"
"(" TokenExpr <gL2, gR2> (. SetCtx(gL2); CRT.ConcatSeq(gL, gR, gL2, gR2) .)
")"
].
(*------------------------------------------------------------------------------------*)
TokenFactor <VAR gL, gR: INTEGER> (. VAR kind, c: INTEGER; set: CRT.Set; name: CRT.Name; .)
=
(. gL :=0; gR := 0 .)
( Symbol <name, kind> (. IF kind = ident THEN
c := CRT.ClassWithName(name);
IF c < 0 THEN
SemErr(15);
Sets.Clear(set); c := CRT.NewClass(name, set)
END;
gL := CRT.NewNode(CRT.class, c, 0); gR := gL
ELSE (*string*)
CRT.StrToGraph(name, gL, gR)
END .)
| "(" TokenExpr <gL, gR> ")"
| "[" TokenExpr <gL, gR> "]" (. CRT.MakeOption(gL, gR) .)
| "{" TokenExpr <gL, gR> "}" (. CRT.MakeIteration(gL, gR) .)
).
(*------------------------------------------------------------------------------------*)
Symbol <VAR name: CRT.Name; VAR kind: INTEGER> =
( ident (. kind := ident .)
| string (. kind := string .)
) (. CRS.GetName(CRS.pos, CRS.len, name);
IF kind = string THEN FixString(name, CRS.len) END .) .
(*------------------------------------------------------------------------------------*)
Attribs <VAR attrPos: CRT.Position> =
"<" (. attrPos.beg := CRS.nextPos; attrPos.col := CRS.nextCol .)
{ ANY }
">" (. attrPos.len := SHORT(CRS.pos - attrPos.beg) .).
(*------------------------------------------------------------------------------------*)
SemText <VAR semPos: CRT.Position> =
"(." (. semPos.beg := CRS.nextPos; semPos.col := CRS.nextCol .)
{ ANY }
".)" (. semPos.len := SHORT(CRS.pos - semPos.beg) .).
END CR.

930
src/tools/coco/CRA.Mod Normal file
View file

@ -0,0 +1,930 @@
MODULE CRA; (* handles the DFA *)
IMPORT Oberon, Texts := CmdlnTexts, Sets, CRS, CRT;
CONST
maxStates = 300;
EOL = 0DX;
TYPE
State = POINTER TO StateNode;
Action = POINTER TO ActionNode;
Target = POINTER TO TargetNode;
StateNode = RECORD (*state of finite automaton*)
nr: INTEGER; (*state number*)
firstAction: Action; (*to first action of this state*)
endOf: INTEGER; (*nr. of recognized token if state is final*)
ctx: BOOLEAN; (*TRUE: state reached by contextTrans*)
next: State
END;
ActionNode = RECORD (*action of finite automaton*)
typ: INTEGER; (*type of action symbol: char, class*)
sym: INTEGER; (*action symbol*)
tc: INTEGER; (*transition code: normTrans, contextTrans*)
target: Target; (*states after transition with input symbol*)
next: Action;
END;
TargetNode = RECORD (*state after transition with input symbol*)
state: State; (*target state*)
next: Target;
END;
Comment = POINTER TO CommentNode;
CommentNode = RECORD (* info about a comment syntax *)
start,stop: ARRAY 2 OF CHAR;
nested: BOOLEAN;
next: Comment;
END;
Melted = POINTER TO MeltedNode;
MeltedNode = RECORD (* info about melted states *)
set: CRT.Set; (* set of old states *)
state: State; (* new state *)
next: Melted;
END;
VAR
firstState: State;
lastState: State; (* last allocated state *)
rootState: State; (* start state of DFA *)
lastSimState: INTEGER; (* last non melted state *)
stateNr: INTEGER; (*number of last allocated state*)
firstMelted: Melted; (* list of melted states *)
firstComment: Comment; (* list of comments *)
out: Texts.Writer; (* current output *)
fram: Texts.Reader; (* scanner frame input *)
PROCEDURE SemErr(nr: INTEGER);
BEGIN CRS.Error(200+nr, CRS.pos)
END SemErr;
PROCEDURE Put(ch: CHAR);
BEGIN Texts.Write(out, ch) END Put;
PROCEDURE PutS(s: ARRAY OF CHAR);
VAR i: INTEGER;
BEGIN i := 0;
WHILE (i < LEN(s)) & (s[i] # 0X) DO
IF s[i] = "$" THEN Texts.WriteLn(out) ELSE Texts.Write(out, s[i]) END;
INC(i)
END
END PutS;
PROCEDURE PutI(i: INTEGER);
BEGIN Texts.WriteInt(out, i, 0) END PutI;
PROCEDURE PutI2(i, n: INTEGER);
BEGIN Texts.WriteInt(out, i, n) END PutI2;
PROCEDURE PutC(ch: CHAR);
BEGIN
IF (ch < " ") OR (ORD(ch) = 34) THEN PutS("CHR("); PutI(ORD(ch)); Put(")")
ELSE Put(CHR(34)); Put(ch); Put(CHR(34))
END
END PutC;
PROCEDURE PutRange(s: CRT.Set);
VAR lo, hi: ARRAY 32 OF CHAR; top, i: INTEGER; s1: CRT.Set;
BEGIN
(*----- fill lo and hi *)
top := -1; i := 0;
WHILE i < 128 DO
IF Sets.In(s, i) THEN
INC(top); lo[top] := CHR(i); INC(i);
WHILE (i < 128) & Sets.In(s, i) DO INC(i) END;
hi[top] := CHR(i - 1)
ELSE INC(i)
END
END;
(*----- print ranges *)
IF (top = 1) & (lo[0] = 0X) & (hi[1] = 7FX) & (CHR(ORD(hi[0]) + 2) = lo[1]) THEN
Sets.Fill(s1); Sets.Differ(s1, s); PutS("~ ("); PutRange(s1); Put(")")
ELSE
i := 0;
WHILE i <= top DO
IF hi[i] = lo[i] THEN PutS("(ch="); PutC(lo[i])
ELSIF lo[i] = 0X THEN PutS("(ch<="); PutC(hi[i])
ELSIF hi[i] = 7FX THEN PutS("(ch>="); PutC(lo[i])
ELSE PutS("(ch>="); PutC(lo[i]); PutS(") & (ch<="); PutC(hi[i])
END;
Put(")");
IF i < top THEN PutS(" OR ") END;
INC(i)
END
END
END PutRange;
PROCEDURE PutChCond(ch: CHAR);
BEGIN
PutS("(ch ="); PutC(ch); Put(")")
END PutChCond;
PROCEDURE Length*(s: ARRAY OF CHAR): INTEGER;
VAR i: INTEGER;
BEGIN
i:=0; WHILE (i < LEN(s)) & (s[i] # 0X) DO INC(i) END;
RETURN i
END Length;
PROCEDURE AddAction(act:Action; VAR head:Action);
VAR a,lasta: Action;
BEGIN
a := head; lasta := NIL;
LOOP
IF (a = NIL) (*collecting classes at the front gives better*)
OR (act^.typ < a^.typ) THEN (*performance*)
act^.next := a;
IF lasta = NIL THEN head := act ELSE lasta^.next := act END;
EXIT;
END;
lasta := a; a := a^.next;
END;
END AddAction;
PROCEDURE DetachAction(a:Action; VAR L:Action);
BEGIN
IF L = a THEN L := a^.next ELSIF L # NIL THEN DetachAction(a, L^.next) END
END DetachAction;
PROCEDURE TheAction (state: State; ch: CHAR): Action;
VAR a: Action; set: CRT.Set;
BEGIN
a := state.firstAction;
WHILE a # NIL DO
IF a.typ = CRT.char THEN
IF ORD(ch) = a.sym THEN RETURN a END
ELSIF a.typ = CRT.class THEN
CRT.GetClass(a^.sym, set);
IF Sets.In(set, ORD(ch)) THEN RETURN a END
END;
a := a.next
END;
RETURN NIL
END TheAction;
PROCEDURE AddTargetList(VAR lista, listb: Target);
VAR p,t: Target;
PROCEDURE AddTarget(t: Target; VAR list:Target);
VAR p,lastp: Target;
BEGIN
p:=list; lastp:=NIL;
LOOP
IF (p = NIL) OR (t^.state.nr < p^.state.nr) THEN EXIT END;
IF p^.state = t^.state THEN RETURN END;
lastp := p; p := p^.next
END;
t^.next:=p;
IF lastp=NIL THEN list:=t ELSE lastp^.next:=t END
END AddTarget;
BEGIN
p := lista;
WHILE p # NIL DO
NEW(t); t^.state:=p^.state; AddTarget(t, listb);
p := p^.next
END
END AddTargetList;
PROCEDURE NewMelted(set: CRT.Set; state: State): Melted;
VAR melt: Melted;
BEGIN
NEW(melt); melt^.set := set; melt^.state := state;
melt^.next := firstMelted; firstMelted := melt;
RETURN melt
END NewMelted;
PROCEDURE NewState(): State;
VAR state: State;
BEGIN
NEW(state); INC(stateNr); state.nr := stateNr;
state.firstAction := NIL; state.endOf := CRT.noSym; state.ctx := FALSE; state.next := NIL;
IF firstState = NIL THEN firstState := state ELSE lastState.next := state END;
lastState := state;
RETURN state
END NewState;
PROCEDURE NewTransition(from, to: State; typ, sym, tc: INTEGER);
VAR a: Action; t: Target;
BEGIN
NEW(t); t^.state := to; t^.next := NIL;
NEW(a); a^.typ := typ; a^.sym := sym; a^.tc := tc; a^.target := t;
AddAction(a, from.firstAction)
END NewTransition;
PROCEDURE NewComment*(from, to: INTEGER; nested: BOOLEAN);
VAR com: Comment;
PROCEDURE MakeStr(gp: INTEGER; VAR s: ARRAY OF CHAR);
VAR i, n: INTEGER; gn: CRT.GraphNode; set: CRT.Set;
BEGIN
i := 0;
WHILE gp # 0 DO
CRT.GetNode(gp, gn);
IF gn.typ = CRT.char THEN
IF i < 2 THEN s[i] := CHR(gn.p1) END; INC(i)
ELSIF gn.typ = CRT.class THEN
CRT.GetClass(gn.p1, set);
IF Sets.Elements(set, n) # 1 THEN SemErr(26) END;
IF i < 2 THEN s[i] := CHR(n) END; INC(i)
ELSE SemErr(22)
END;
gp := gn.next
END;
IF i > 2 THEN SemErr(25) ELSIF i < 2 THEN s[i] := 0X END
END MakeStr;
BEGIN
NEW(com);
MakeStr(from, com^.start); MakeStr(to, com^.stop);
com^.nested := nested;
com^.next := firstComment; firstComment := com
END NewComment;
PROCEDURE MakeSet(p: Action; VAR set: CRT.Set);
BEGIN
IF p^.typ = CRT.class THEN CRT.GetClass(p^.sym, set)
ELSE Sets.Clear(set); Sets.Incl(set, p^.sym)
END
END MakeSet;
PROCEDURE ChangeAction(a: Action; set: CRT.Set);
VAR nr: INTEGER;
BEGIN
IF Sets.Elements(set, nr) = 1 THEN a^.typ := CRT.char; a^.sym := nr
ELSE
nr := CRT.ClassWithSet(set);
IF nr < 0 THEN nr := CRT.NewClass("#0", set) END; (*class with dummy name*)
a^.typ := CRT.class; a^.sym := nr
END
END ChangeAction;
PROCEDURE CombineShifts;
VAR state: State; n: INTEGER; a, b, c: Action; seta, setb: CRT.Set;
BEGIN
state := firstState;
WHILE state # NIL DO
a := state.firstAction;
WHILE a # NIL DO
b := a^.next;
WHILE b # NIL DO
IF (a^.target^.state = b^.target^.state) & (a^.tc = b^.tc) THEN
MakeSet(a, seta); MakeSet(b, setb); Sets.Unite(seta, setb);
ChangeAction(a, seta);
c := b; b := b^.next; DetachAction(c, a)
ELSE b := b^.next
END
END;
a := a^.next
END;
state := state.next
END
END CombineShifts;
PROCEDURE DeleteRedundantStates;
VAR
action: Action;
state, s1, s2: State;
used: CRT.Set;
newState: ARRAY maxStates OF State;
PROCEDURE FindUsedStates(state: State);
VAR action: Action;
BEGIN
IF Sets.In(used, state.nr) THEN RETURN END;
Sets.Incl(used, state.nr);
action := state.firstAction;
WHILE action # NIL DO
FindUsedStates(action^.target^.state);
action:=action^.next
END
END FindUsedStates;
PROCEDURE DelUnused;
VAR state: State;
BEGIN
state := firstState.next; lastState := firstState; stateNr := 0; (*firstState has number 0*)
WHILE state # NIL DO
IF Sets.In(used, state.nr) THEN INC(stateNr); state.nr := stateNr; lastState := state
ELSE lastState.next := state.next
END;
state := state.next
END
END DelUnused;
BEGIN
Sets.Clear(used); FindUsedStates(firstState);
(*---------- combine equal final states ------------*)
s1 := firstState.next; (*first state cannot be final*)
WHILE s1 # NIL DO
IF Sets.In(used, s1.nr) & (s1.endOf # CRT.noSym) & (s1.firstAction = NIL) & ~ s1.ctx THEN
s2 := s1.next;
WHILE s2 # NIL DO
IF Sets.In(used, s2.nr) & (s1.endOf = s2.endOf) & (s2.firstAction = NIL) & ~ s2.ctx THEN
Sets.Excl(used, s2.nr); newState[s2.nr] := s1
END;
s2 := s2.next
END
END;
s1 := s1.next
END;
state := firstState; (*> state := firstState.next*)
WHILE state # NIL DO
IF Sets.In(used, state.nr) THEN
action := state.firstAction;
WHILE action # NIL DO
IF ~ Sets.In(used, action.target.state.nr) THEN
action^.target^.state := newState[action.target.state.nr]
END;
action := action^.next
END
END;
state := state.next
END;
DelUnused
END DeleteRedundantStates;
PROCEDURE ConvertToStates*(gp0, sp: INTEGER);
(*note: gn.line is abused as a state number!*)
VAR n: INTEGER; S: ARRAY maxStates OF State; gn: CRT.GraphNode;
PROCEDURE TheState(gp: INTEGER): State;
VAR state: State; gn: CRT.GraphNode;
BEGIN
IF gp = 0 THEN state := NewState(); state.endOf := sp; RETURN state
ELSE CRT.GetNode(gp, gn); RETURN S[gn.line]
END
END TheState;
PROCEDURE Step(from: State; gp: INTEGER);
VAR gn: CRT.GraphNode;
BEGIN
IF gp = 0 THEN RETURN END;
CRT.GetNode(gp, gn);
CASE gn.typ OF
CRT.class, CRT.char: NewTransition(from, TheState(ABS(gn.next)), gn.typ, gn.p1, gn.p2)
| CRT.alt: Step(from, gn.p1); Step(from, gn.p2)
| CRT.opt, CRT.iter: Step(from, ABS(gn.next)); Step(from, gn.p1)
END
END Step;
PROCEDURE FindTrans(gp: INTEGER; state: State);
VAR gn: CRT.GraphNode; new: BOOLEAN;
BEGIN
IF gp = 0 THEN RETURN END; (*end of graph*)
CRT.GetNode(gp, gn);
IF gn.line # 0 THEN RETURN END; (*already visited*)
new := state = NIL;
IF new THEN state := NewState() END;
INC(n); S[n] := state; gn.line := n; CRT.PutNode(gp, gn);
IF CRT.DelGraph(gp) THEN state.endOf := sp END; (*state is end state*)
CASE gn.typ OF
CRT.class, CRT.char: FindTrans(ABS(gn.next), NIL);
| CRT.opt: FindTrans(ABS(gn.next), NIL); FindTrans(gn.p1, state)
| CRT.iter: FindTrans(ABS(gn.next), state); FindTrans(gn.p1, state)
| CRT.alt: FindTrans(gn.p1, state); FindTrans(gn.p2, state)
END;
IF new OR (state = firstState) & (gp = gp0) THEN (*start of a group of equally numbered nodes*)
Step(state, gp)
END
END FindTrans;
BEGIN
IF CRT.DelGraph(gp0) THEN SemErr(20) END;
CRT.GetNode(gp0, gn);
IF gn.typ = CRT.iter THEN SemErr(21) END;
n := 0; FindTrans(gp0, firstState)
END ConvertToStates;
PROCEDURE MatchDFA* (s: ARRAY OF CHAR; sp: INTEGER; VAR matchedSp: INTEGER);
VAR state, to: State; a: Action; i, len: INTEGER;
BEGIN (*s with quotes*)
state := firstState; i := 1; len := Length(s) - 1;
LOOP (*try to match s against existing DFA*)
IF i = len THEN EXIT END;
a := TheAction(state, s[i]);
IF a = NIL THEN EXIT END;
state := a.target.state; INC(i)
END;
WHILE i < len DO (*make new DFA for s[i..len-1]*)
to := NewState();
NewTransition(state, to, CRT.char, ORD(s[i]), CRT.normTrans);
state := to; INC(i)
END;
matchedSp := state.endOf;
IF state.endOf = CRT.noSym THEN state.endOf := sp END
END MatchDFA;
PROCEDURE SplitActions(a, b: Action);
VAR c: Action; seta, setb, setc: CRT.Set;
PROCEDURE CombineTransCodes(t1, t2: INTEGER; VAR result:INTEGER);
BEGIN
IF t1 = CRT.contextTrans THEN result := t1 ELSE result := t2 END
END CombineTransCodes;
BEGIN
MakeSet(a, seta); MakeSet(b, setb);
IF Sets.Equal(seta, setb) THEN
AddTargetList(b^.target, a^.target);
CombineTransCodes(a^.tc, b^.tc, a^.tc);
DetachAction(b, a)
ELSIF Sets.Includes(seta, setb) THEN
setc := seta; Sets.Differ(setc, setb);
AddTargetList(a^.target, b^.target);
CombineTransCodes(a^.tc, b^.tc, b^.tc);
ChangeAction(a, setc)
ELSIF Sets.Includes(setb, seta) THEN
setc := setb; Sets.Differ(setc, seta);
AddTargetList(b^.target, a^.target);
CombineTransCodes(a^.tc, b^.tc, a^.tc);
ChangeAction(b, setc)
ELSE
Sets.Intersect(seta, setb, setc);
Sets.Differ(seta, setc);
Sets.Differ(setb, setc);
ChangeAction(a, seta);
ChangeAction(b, setb);
NEW(c); c^.target:=NIL;
CombineTransCodes(a^.tc, b^.tc, c^.tc);
AddTargetList(a^.target, c^.target);
AddTargetList(b^.target, c^.target);
ChangeAction(c, setc);
AddAction(c, a)
END
END SplitActions;
PROCEDURE MakeUnique(state: State; VAR changed:BOOLEAN);
VAR a, b: Action;
PROCEDURE Overlap(a, b: Action): BOOLEAN;
VAR seta, setb: CRT.Set;
BEGIN
IF a^.typ = CRT.char THEN
IF b^.typ = CRT.char THEN RETURN a^.sym = b^.sym
ELSE CRT.GetClass(b^.sym, setb); RETURN Sets.In(setb, a^.sym)
END
ELSE
CRT.GetClass(a^.sym, seta);
IF b^.typ = CRT.char THEN RETURN Sets.In(seta, b^.sym)
ELSE CRT.GetClass(b^.sym, setb); RETURN ~ Sets.Different(seta, setb)
END
END
END Overlap;
BEGIN
a := state.firstAction; changed := FALSE;
WHILE a # NIL DO
b := a^.next;
WHILE b # NIL DO
IF Overlap(a, b) THEN SplitActions(a, b); changed:=TRUE END;
b := b^.next;
END;
a:=a^.next
END
END MakeUnique;
PROCEDURE MeltStates(state: State; VAR correct:BOOLEAN);
VAR
action: Action;
ctx: BOOLEAN;
endOf: INTEGER;
melt: Melted;
set: CRT.Set;
s: State;
changed: BOOLEAN;
PROCEDURE AddMeltedSet(nr: INTEGER; VAR set: CRT.Set);
VAR m: Melted;
BEGIN
m := firstMelted;
WHILE (m # NIL) & (m^.state.nr # nr) DO m := m^.next END;
IF m = NIL THEN HALT(98) END;
Sets.Unite(set, m^.set);
END AddMeltedSet;
PROCEDURE GetStateSet(t: Target; VAR set: CRT.Set; VAR endOf: INTEGER; VAR ctx:BOOLEAN);
VAR statenr: INTEGER; (*lastS: State;*)
BEGIN
Sets.Clear(set); endOf := CRT.noSym; ctx := FALSE; (*lastS := NIL;*)
WHILE t # NIL DO
statenr := t.state.nr;
IF statenr <= lastSimState THEN Sets.Incl(set, statenr)
ELSE AddMeltedSet(statenr, set)
END;
IF t^.state^.endOf # CRT.noSym THEN
IF (endOf = CRT.noSym) OR (endOf = t^.state^.endOf)
(*OR (lastS^.firstAction # NIL) & (t^.state^.firstAction = NIL)*) THEN
endOf := t^.state.endOf; (*lastS := t^.state*)
ELSE
PutS("$Tokens "); PutI(endOf); PutS(" and "); PutI(t^.state.endOf);
PutS(" cannot be distinguished.$");
correct:=FALSE
END
END;
IF t^.state.ctx THEN ctx := TRUE;
IF t.state.endOf # CRT.noSym THEN
PutS("$Ambiguous CONTEXT clause.$"); correct := FALSE
END
END;
t := t^.next
END
END GetStateSet;
PROCEDURE FillWithActions(state: State; targ: Target);
VAR action,a: Action;
BEGIN
WHILE targ # NIL DO
action := targ^.state.firstAction;
WHILE action # NIL DO
NEW(a); a^ := action^; a^.target := NIL;
AddTargetList(action^.target, a^.target);
AddAction(a, state.firstAction);
action:=action^.next
END;
targ:=targ^.next
END;
END FillWithActions;
PROCEDURE KnownMelted(set:CRT.Set; VAR melt: Melted): BOOLEAN;
BEGIN
melt := firstMelted;
WHILE melt # NIL DO
IF Sets.Equal(set, melt^.set) THEN RETURN TRUE END;
melt := melt^.next
END;
RETURN FALSE
END KnownMelted;
BEGIN
action := state.firstAction;
WHILE action # NIL DO
IF action^.target^.next # NIL THEN (*more than one target state*)
GetStateSet(action^.target, set, endOf, ctx);
IF ~ KnownMelted(set, melt) THEN
s := NewState(); s.endOf := endOf; s.ctx := ctx;
FillWithActions(s, action^.target);
REPEAT MakeUnique(s, changed) UNTIL ~ changed;
melt := NewMelted(set, s);
END;
action^.target^.next:=NIL;
action^.target^.state := melt^.state
END;
action := action^.next
END;
Texts.Append(Oberon.Log, out.buf)
END MeltStates;
PROCEDURE MakeDeterministic*(VAR correct: BOOLEAN);
VAR state: State; changed: BOOLEAN;
PROCEDURE FindCtxStates; (*find states reached by a context transition*)
VAR a: Action; state: State;
BEGIN
state := firstState;
WHILE state # NIL DO
a := state.firstAction;
WHILE a # NIL DO
IF a^.tc = CRT.contextTrans THEN a^.target^.state.ctx := TRUE END;
a := a^.next
END;
state := state.next
END;
END FindCtxStates;
BEGIN
IF lastState = NIL THEN lastSimState := 0 ELSE lastSimState := lastState.nr END;
FindCtxStates;
state := firstState;
WHILE state # NIL DO
REPEAT MakeUnique(state, changed) UNTIL ~ changed;
state := state.next
END;
correct := TRUE;
state := firstState;
WHILE state # NIL DO MeltStates(state, correct); state := state.next END;
DeleteRedundantStates;
CombineShifts
END MakeDeterministic;
PROCEDURE PrintSymbol(typ, val, width: INTEGER);
VAR name: CRT.Name; len: INTEGER;
BEGIN
IF typ = CRT.class THEN
CRT.GetClassName(val, name); PutS(name); len := Length(name)
ELSIF (val >= ORD(" ")) & (val < 127) & (val # 34) THEN
Put(CHR(34)); Put(CHR(val)); Put(CHR(34)); len:=3
ELSE
PutS("CHR("); PutI2(val, 2); Put(")"); len:=7
END;
WHILE len < width DO Put(" "); INC(len) END
END PrintSymbol;
PROCEDURE PrintStates*;
VAR action: Action; first: BOOLEAN; state: State; i: INTEGER; targ: Target; set: CRT.Set; name: CRT.Name;
BEGIN
PutS("$-------- states ---------$");
state := firstState;
WHILE state # NIL DO
action := state.firstAction; first:=TRUE;
IF state.endOf = CRT.noSym THEN PutS(" ")
ELSE PutS("E("); PutI2(state.endOf, 2); Put(")")
END;
PutI2(state.nr, 3); Put(":"); IF action = NIL THEN PutS(" $") END;
WHILE action # NIL DO
IF first THEN Put(" "); first:=FALSE ELSE PutS(" ") END;
PrintSymbol(action^.typ, action^.sym, 0); Put(" ");
targ := action^.target;
WHILE targ # NIL DO
PutI(targ^.state.nr); Put(" "); targ := targ^.next;
END;
IF action^.tc = CRT.contextTrans THEN PutS(" context$") ELSE PutS(" $") END;
action := action^.next
END;
state := state.next
END;
PutS("$-------- character classes ---------$");
i := 0;
WHILE i <= CRT.maxC DO
CRT.GetClass(i, set); CRT.GetClassName(i, name); PutS(name); PutS(": ");
Sets.Print(out, set, 80, 13); Texts.WriteLn(out);
INC(i)
END;
Texts.Append(Oberon.Log, out.buf)
END PrintStates;
PROCEDURE GenComment(com:Comment);
PROCEDURE GenBody;
BEGIN
PutS(" LOOP$");
PutS(" IF "); PutChCond(com^.stop[0]); PutS(" THEN$");
IF Length(com^.stop) = 1 THEN
PutS(" DEC(level); oldEols := chLine - startLine; NextCh;$");
PutS(" IF level = 0 THEN RETURN TRUE END;$");
ELSE
PutS(" NextCh;$");
PutS(" IF "); PutChCond(com^.stop[1]); PutS(" THEN$");
PutS(" DEC(level); oldEols := chLine - startLine; NextCh;$");
PutS(" IF level=0 THEN RETURN TRUE END$");
PutS(" END;$");
END;
IF com^.nested THEN
PutS(" ELSIF "); PutChCond(com^.start[0]); PutS(" THEN$");
IF Length(com^.start) = 1 THEN
PutS(" INC(level); NextCh;$");
ELSE
PutS(" NextCh;$");
PutS(" IF "); PutChCond(com^.start[1]); PutS(" THEN$");
PutS(" INC(level); NextCh;$");
PutS(" END;$");
END;
END;
PutS(" ELSIF ch = EOF THEN RETURN FALSE$");
PutS(" ELSE NextCh END;$");
PutS(" END;$");
END GenBody;
BEGIN
PutS(" IF "); PutChCond(com^.start[0]); PutS(" THEN$");
IF Length(com^.start) = 1 THEN
PutS(" NextCh;$");
GenBody;
PutS(" END;");
ELSE
PutS(" NextCh;$");
PutS(" IF "); PutChCond(com^.start[1]); PutS(" THEN$");
PutS(" NextCh;$");
GenBody;
PutS(" ELSE$");
PutS(" IF ch = EOL THEN DEC(chLine); lineStart := oldLineStart END;$");
PutS(" DEC(chPos, 2); Texts.OpenReader(r, src, chPos+1); NextCh; RETURN FALSE$");
PutS(" END$");
PutS(" END;");
END;
END GenComment;
PROCEDURE CopyFramePart (stopStr: ARRAY OF CHAR); (*Copy from file <fram> to file <out> until <stopStr>*)
VAR ch, startCh: CHAR; i, j, high: INTEGER;
BEGIN
startCh := stopStr[0]; high := Length(stopStr) - 1; Texts.Read (fram, ch);
WHILE ch # 0X DO
IF ch = startCh THEN (* check if stopString occurs *)
i := 0;
REPEAT
IF i = high THEN RETURN END; (*stopStr[0..i] found; no unrecognized character*)
Texts.Read (fram, ch); INC(i);
UNTIL ch # stopStr[i];
(*stopStr[0..i-1] found; 1 unrecognized character*)
j := 0; WHILE j < i DO Texts.Write(out, stopStr[j]); INC(j) END
ELSE Texts.Write (out, ch); Texts.Read(fram, ch)
END
END
END CopyFramePart;
PROCEDURE GenLiterals;
VAR
i, j, k, l: INTEGER;
key: ARRAY 128 OF CRT.Name;
knr: ARRAY 128 OF INTEGER;
ch: CHAR;
sn: CRT.SymbolNode;
BEGIN
(*-- sort literal list*)
i := 0; k := 0;
WHILE i <= CRT.maxT DO
CRT.GetSym(i, sn);
IF sn.struct = CRT.litToken THEN
j := k-1; WHILE (j >= 0) & (sn.name < key[j]) DO key[j+1] := key[j]; knr[j+1] := knr[j]; DEC(j) END;
key[j+1] := sn.name; knr[j+1] := i; INC(k)
END;
INC(i)
END;
(*-- print case statement*)
IF k > 0 THEN
PutS(" IF (lexeme[0] >= "); PutC(key[0, 1]); PutS(") & (lexeme[0] <= "); PutC(key[k-1, 1]); PutS(") THEN$");
PutS(" CASE lexeme[0] OF$");
i := 0;
WHILE i < k DO
ch := key[i, 1]; (*key[i, 0] = quote*)
PutS(" | "); PutC(ch); j := i;
REPEAT
IF i = j THEN PutS(": IF lexeme = ") ELSE PutS(" ELSIF lexeme = ") END;
PutS(key[i]); PutS(" THEN sym := "); PutI(knr[i]); Put(CHR(13));
INC(i)
UNTIL (i = k) OR (key[i, 1] # ch);
PutS(" END$");
END;
PutS(" ELSE$ END$ END;$")
END
END GenLiterals;
PROCEDURE WriteState(state: State);
VAR action: Action; first, ctxEnd: BOOLEAN; sn: CRT.SymbolNode; endOf: INTEGER;
set: CRT.Set;
BEGIN
endOf := state.endOf;
IF (endOf > CRT.maxT) & (endOf # CRT.noSym) THEN (*pragmas have been moved*)
endOf := CRT.maxT + CRT.maxSymbols - endOf
END;
PutS(" | "); PutI2(state.nr, 2); PutS(": ");
first:=TRUE; ctxEnd := state.ctx;
action := state.firstAction;
WHILE action # NIL DO
IF first THEN PutS("IF "); first:=FALSE ELSE PutS(" ELSIF ") END;
IF action^.typ = CRT.char THEN PutChCond(CHR(action^.sym))
ELSE CRT.GetClass(action^.sym, set); PutRange(set)
END;
PutS(" THEN");
IF action.target.state.nr # state.nr THEN
PutS(" state := "); PutI(action.target.state.nr); Put(";")
END;
IF action^.tc = CRT.contextTrans THEN PutS(" INC(apx)"); ctxEnd := FALSE
ELSIF state.ctx THEN PutS(" apx := 0")
END;
PutS(" $");
action := action^.next
END;
IF state.firstAction # NIL THEN PutS(" ELSE ") END;
IF endOf = CRT.noSym THEN PutS("sym := noSym; ")
ELSE (*final state*)
CRT.GetSym(endOf, sn);
IF ctxEnd THEN (*final context state: cut appendix*)
PutS("chPos := chPos - apx - 1; Texts.OpenReader(r, src, chPos+1); NextCh; ")
END;
PutS("sym := "); PutI(endOf); PutS("; ");
IF sn.struct = CRT.classLitToken THEN PutS("CheckLiteral; ") END
END;
PutS("RETURN$");
IF state.firstAction # NIL THEN PutS(" END;$") END
END WriteState;
PROCEDURE *Show (t: Texts.Text; op: INTEGER; beg, end: LONGINT);
END Show;
PROCEDURE WriteScanner*;
VAR
scanner: ARRAY 32 OF CHAR;
name: ARRAY 64 OF CHAR;
startTab: ARRAY 128 OF INTEGER;
com: Comment;
i, j, l: INTEGER;
gn: CRT.GraphNode;
sn: CRT.SymbolNode;
state: State;
t: Texts.Text;
PROCEDURE FillStartTab;
VAR action: Action; i, targetState: INTEGER; class: CRT.Set;
BEGIN
startTab[0] := stateNr + 1; (*eof*)
i := 1; WHILE i < 128 DO startTab[i] := 0; INC(i) END;
action := firstState.firstAction;
WHILE action # NIL DO
targetState := action.target.state.nr;
IF action^.typ = CRT.char THEN
startTab[action^.sym] := targetState
ELSE
CRT.GetClass(action^.sym, class); i := 0;
WHILE i < 128 DO
IF Sets.In(class, i) THEN startTab[i] := targetState END;
INC(i)
END
END;
action := action^.next
END
END FillStartTab;
BEGIN
FillStartTab;
CRT.GetNode(CRT.root, gn); CRT.GetSym(gn.p1, sn);
COPY(sn.name, scanner); l := Length(scanner); scanner[l] := "S"; scanner[l+1] := 0X;
NEW(t); Texts.Open(t, "Scanner.FRM"); Texts.OpenReader(fram, t, 0);
IF t.len = 0 THEN
Texts.WriteString(out, "Scanner.FRM not found"); Texts.WriteLn(out);
Texts.Append(Oberon.Log, out.buf); HALT(99)
END;
Texts.Append(Oberon.Log, out.buf);
(*------- *S.MOD -------*)
CopyFramePart("-->modulename"); PutS(scanner);
CopyFramePart("-->declarations"); PutS(" noSym = "); PutI(CRT.maxT); Put(";");
CopyFramePart("-->comment");
com := firstComment;
WHILE com # NIL DO GenComment(com); com := com^.next END;
CopyFramePart("-->literals"); GenLiterals;
CopyFramePart("-->GetSy1");
IF ~ Sets.In(CRT.ignored, ORD(EOL)) THEN PutS(" IF oldEols > 0 THEN DEC(oldEols); ch := EOL END;$") END;
PutS(" WHILE (ch=20X)"); IF ~ Sets.Empty(CRT.ignored) THEN PutS(" OR ") END;
PutRange(CRT.ignored); PutS(" DO NextCh END;");
IF firstComment # NIL THEN
PutS("$ IF ("); com := firstComment;
WHILE com # NIL DO
PutChCond(com^.start[0]);
IF com^.next # NIL THEN PutS(" OR ") END;
com := com^.next
END;
PutS(") & Comment() THEN Get(sym); RETURN END;")
END;
CopyFramePart("-->GetSy2");
state := firstState.next;
WHILE state # NIL DO WriteState(state); state := state.next END;
PutS(" | "); PutI2(stateNr + 1, 2); PutS(": sym := 0; ch := 0X; RETURN$");
CopyFramePart("-->initialization");
i := 0;
WHILE i < 32 DO
j := 0; PutS(" ");
WHILE j < 4 DO
PutS("start["); PutI(4*i+j); PutS("]:="); PutI(startTab[4*i+j]); PutS("; ");
INC(j)
END;
Texts.WriteLn(out);
INC(i)
END;
CopyFramePart("-->modulename"); PutS(scanner); Put(".");
NEW(t); (*t.notify := Show;*) Texts.Open(t, ""); Texts.Append(t, out.buf);
l := Length(scanner); scanner[l] := "."; scanner[l+1] := "M"; scanner[l+2] := "o"; scanner[l+3] := "d"; scanner[l+4] := 0X;
Texts.Close(t, scanner)
END WriteScanner;
PROCEDURE Init*;
BEGIN
firstState := NIL; lastState := NIL; stateNr := -1;
rootState := NewState();
firstMelted := NIL; firstComment := NIL
END Init;
BEGIN
Texts.OpenWriter(out)
END CRA.

703
src/tools/coco/CRP.Mod Normal file
View file

@ -0,0 +1,703 @@
(* parser module generated by Coco-R *)
MODULE CRP;
IMPORT CRS, CRT, CRA, CRX, Sets, Texts := CmdlnTexts, Oberon;
CONST
maxP = 39;
maxT = 38;
nrSets = 18;
setSize = 32; nSets = (maxT DIV setSize) + 1;
TYPE
SymbolSet = ARRAY nSets OF SET;
VAR
sym: INTEGER; (* current input symbol *)
symSet: ARRAY nrSets OF SymbolSet;
CONST
ident = 0; string = 1; (*symbol kind*)
VAR
str: ARRAY 32 OF CHAR;
w: Texts.Writer;
genScanner: BOOLEAN;
PROCEDURE SemErr(nr: INTEGER);
BEGIN
CRS.Error(200+nr, CRS.pos);
END SemErr;
PROCEDURE MatchLiteral(sp: INTEGER); (*store string either as token or as literal*)
VAR sn, sn1: CRT.SymbolNode; matchedSp: INTEGER;
BEGIN
CRT.GetSym(sp, sn);
CRA.MatchDFA(sn.name, sp, matchedSp);
IF matchedSp # CRT.noSym THEN
CRT.GetSym(matchedSp, sn1); sn1.struct := CRT.classLitToken; CRT.PutSym(matchedSp, sn1);
sn.struct := CRT.litToken
ELSE sn.struct := CRT.classToken;
END;
CRT.PutSym(sp, sn)
END MatchLiteral;
PROCEDURE SetCtx(gp: INTEGER); (*set transition code to CRT.contextTrans*)
VAR gn: CRT.GraphNode;
BEGIN
WHILE gp > 0 DO
CRT.GetNode(gp, gn);
IF gn.typ IN {CRT.char, CRT.class} THEN
gn.p2 := CRT.contextTrans; CRT.PutNode(gp, gn)
ELSIF gn.typ IN {CRT.opt, CRT.iter} THEN SetCtx(gn.p1)
ELSIF gn.typ = CRT.alt THEN SetCtx(gn.p1); SetCtx(gn.p2)
END;
gp := gn.next
END
END SetCtx;
PROCEDURE SetDDT(s: ARRAY OF CHAR);
VAR name: ARRAY 64 OF CHAR; i: INTEGER; ch: CHAR;
BEGIN
i := 1;
WHILE s[i] # 0X DO
ch := s[i]; INC(i);
IF (ch >= "0") & (ch <= "9") THEN CRT.ddt[ORD(ch)-ORD("0")] := TRUE END
END
END SetDDT;
PROCEDURE FixString (VAR s: ARRAY OF CHAR; len: INTEGER);
VAR double: BOOLEAN; i: INTEGER;
BEGIN
double := FALSE;
FOR i := 0 TO len-2 DO
IF s[i] = '"' THEN double := TRUE END
END;
IF ~ double THEN s[0] := '"'; s[len-1] := '"' END
END FixString;
(*-------------------------------------------------------------------------*)
PROCEDURE Error (n: INTEGER);
BEGIN CRS.Error(n, CRS.nextPos)
END Error;
PROCEDURE Get;
BEGIN
LOOP CRS.Get(sym);
IF sym > maxT THEN
IF sym = 39 THEN
CRS.GetName(CRS.nextPos, CRS.nextLen, str); SetDDT(str)
END;
CRS.nextPos := CRS.pos;
CRS.nextCol := CRS.col;
CRS.nextLine := CRS.line;
CRS.nextLen := CRS.len;
ELSE EXIT
END
END
END Get;
PROCEDURE Expect(n: INTEGER);
BEGIN IF sym = n THEN Get ELSE Error(n) END
END Expect;
PROCEDURE StartOf(s: INTEGER): BOOLEAN;
BEGIN RETURN (sym MOD setSize) IN symSet[s, sym DIV setSize]
END StartOf;
PROCEDURE ExpectWeak(n, follow: INTEGER);
BEGIN
IF sym = n THEN Get
ELSE Error(n); WHILE ~ StartOf(follow) DO Get END
END
END ExpectWeak;
PROCEDURE WeakSeparator(n, syFol, repFol: INTEGER): BOOLEAN;
VAR s: SymbolSet; i: INTEGER;
BEGIN
IF sym = n THEN Get; RETURN TRUE
ELSIF StartOf(repFol) THEN RETURN FALSE
ELSE
i := 0; WHILE i < nSets DO s[i] := symSet[syFol, i] + symSet[repFol, i] + symSet[0, i]; INC(i) END;
Error(n); WHILE ~ ((sym MOD setSize) IN s[sym DIV setSize]) DO Get END;
RETURN StartOf(syFol)
END
END WeakSeparator;
PROCEDURE ^TokenFactor(VAR gL, gR: INTEGER);
PROCEDURE ^TokenTerm(VAR gL, gR: INTEGER);
PROCEDURE ^Factor(VAR gL, gR: INTEGER);
PROCEDURE ^Term(VAR gL, gR: INTEGER);
PROCEDURE ^Symbol(VAR name: CRT.Name; VAR kind: INTEGER);
PROCEDURE ^SimSet(VAR set: CRT.Set);
PROCEDURE ^Set(VAR set: CRT.Set);
PROCEDURE ^TokenExpr(VAR gL, gR: INTEGER);
PROCEDURE ^TokenDecl(typ: INTEGER);
PROCEDURE ^SetDecl;
PROCEDURE ^Expression(VAR gL, gR: INTEGER);
PROCEDURE ^SemText(VAR semPos: CRT.Position);
PROCEDURE ^Attribs(VAR attrPos: CRT.Position);
PROCEDURE ^Declaration;
PROCEDURE ^CR;
PROCEDURE TokenFactor(VAR gL, gR: INTEGER);
VAR kind, c: INTEGER; set: CRT.Set; name: CRT.Name;
BEGIN
gL :=0; gR := 0 ;
IF (sym = 1) OR (sym = 2) THEN
Symbol(name, kind);
IF kind = ident THEN
c := CRT.ClassWithName(name);
IF c < 0 THEN
SemErr(15);
Sets.Clear(set); c := CRT.NewClass(name, set)
END;
gL := CRT.NewNode(CRT.class, c, 0); gR := gL
ELSE (*string*)
CRT.StrToGraph(name, gL, gR)
END ;
ELSIF (sym = 23) THEN
Get;
TokenExpr(gL, gR);
Expect(24);
ELSIF (sym = 28) THEN
Get;
TokenExpr(gL, gR);
Expect(29);
CRT.MakeOption(gL, gR) ;
ELSIF (sym = 30) THEN
Get;
TokenExpr(gL, gR);
Expect(31);
CRT.MakeIteration(gL, gR) ;
ELSE Error(39)
END;
END TokenFactor;
PROCEDURE TokenTerm(VAR gL, gR: INTEGER);
VAR gL2, gR2: INTEGER;
BEGIN
TokenFactor(gL, gR);
WHILE StartOf(1) DO
TokenFactor(gL2, gR2);
CRT.ConcatSeq(gL, gR, gL2, gR2) ;
END;
IF (sym = 33) THEN
Get;
Expect(23);
TokenExpr(gL2, gR2);
SetCtx(gL2); CRT.ConcatSeq(gL, gR, gL2, gR2) ;
Expect(24);
END;
END TokenTerm;
PROCEDURE Factor(VAR gL, gR: INTEGER);
VAR sp, kind, c: INTEGER; name: CRT.Name;
gn: CRT.GraphNode; sn: CRT.SymbolNode;
set: CRT.Set;
undef, weak: BOOLEAN;
pos: CRT.Position;
BEGIN
gL :=0; gR := 0; weak := FALSE ;
CASE sym OF
| 1,2,27: IF (sym = 27) THEN
Get;
weak := TRUE ;
END;
Symbol(name, kind);
sp := CRT.FindSym(name); undef := sp = CRT.noSym;
IF undef THEN
IF kind = ident THEN (*forward nt*)
sp := CRT.NewSym(CRT.nt, name, 0)
ELSE (*undefined string in production*)
sp := CRT.NewSym(CRT.t, name, CRS.line);
MatchLiteral(sp)
END
END;
CRT.GetSym(sp, sn);
IF ~(sn.typ IN {CRT.t,CRT.nt}) THEN SemErr(4) END;
IF weak THEN
IF sn.typ = CRT.t THEN sn.typ := CRT.wt ELSE SemErr(23) END
END;
gL := CRT.NewNode(sn.typ, sp, CRS.line); gR := gL ;
IF (sym = 34) THEN
Attribs(pos);
CRT.GetNode(gL, gn); gn.pos := pos; CRT.PutNode(gL, gn);
CRT.GetSym(sp, sn);
IF undef THEN
sn.attrPos := pos; CRT.PutSym(sp, sn)
ELSIF sn.attrPos.beg < 0 THEN SemErr(5)
END;
IF kind # ident THEN SemErr(3) END ;
ELSIF StartOf(2) THEN
CRT.GetSym(sp, sn);
IF sn.attrPos.beg >= 0 THEN SemErr(6) END ;
ELSE Error(40)
END;
| 23: Get;
Expression(gL, gR);
Expect(24);
| 28: Get;
Expression(gL, gR);
Expect(29);
CRT.MakeOption(gL, gR) ;
| 30: Get;
Expression(gL, gR);
Expect(31);
CRT.MakeIteration(gL, gR) ;
| 36: SemText(pos);
gL := CRT.NewNode(CRT.sem, 0, 0);
gR := gL;
CRT.GetNode(gL, gn); gn.pos := pos; CRT.PutNode(gL, gn) ;
| 25: Get;
Sets.Fill(set); Sets.Excl(set, CRT.eofSy);
gL := CRT.NewNode(CRT.any, CRT.NewSet(set), 0); gR := gL ;
| 32: Get;
gL := CRT.NewNode(CRT.sync, 0, 0); gR := gL ;
ELSE Error(41)
END;
END Factor;
PROCEDURE Term(VAR gL, gR: INTEGER);
VAR gL2, gR2: INTEGER;
BEGIN
gL := 0; gR := 0 ;
IF StartOf(3) THEN
Factor(gL, gR);
WHILE StartOf(3) DO
Factor(gL2, gR2);
CRT.ConcatSeq(gL, gR, gL2, gR2) ;
END;
ELSIF StartOf(4) THEN
gL := CRT.NewNode(CRT.eps, 0, 0); gR := gL ;
ELSE Error(42)
END;
END Term;
PROCEDURE Symbol(VAR name: CRT.Name; VAR kind: INTEGER);
BEGIN
IF (sym = 1) THEN
Get;
kind := ident ;
ELSIF (sym = 2) THEN
Get;
kind := string ;
ELSE Error(43)
END;
CRS.GetName(CRS.pos, CRS.len, name);
IF kind = string THEN FixString(name, CRS.len) END ;
END Symbol;
PROCEDURE SimSet(VAR set: CRT.Set);
VAR c, n, i: INTEGER; name: CRT.Name; s: ARRAY 128 OF CHAR;
BEGIN
IF (sym = 1) THEN
Get;
CRS.GetName(CRS.pos, CRS.len, name);
c := CRT.ClassWithName(name);
IF c < 0 THEN SemErr(15); Sets.Clear(set)
ELSE CRT.GetClass(c, set)
END ;
ELSIF (sym = 2) THEN
Get;
CRS.GetName(CRS.pos, CRS.len, s);
Sets.Clear(set); i := 1;
WHILE s[i] # s[0] DO
Sets.Incl(set, ORD(s[i])); INC(i)
END ;
ELSIF (sym = 22) THEN
Get;
Expect(23);
Expect(3);
CRS.GetName(CRS.pos, CRS.len, name);
n := 0; i := 0;
WHILE name[i] # 0X DO
n := 10 * n + (ORD(name[i]) - ORD("0"));
INC(i)
END;
Sets.Clear(set); Sets.Incl(set, n) ;
Expect(24);
ELSIF (sym = 25) THEN
Get;
Sets.Fill(set) ;
ELSE Error(44)
END;
END SimSet;
PROCEDURE Set(VAR set: CRT.Set);
VAR set2: CRT.Set;
BEGIN
SimSet(set);
WHILE (sym = 20) OR (sym = 21) DO
IF (sym = 20) THEN
Get;
SimSet(set2);
Sets.Unite(set, set2) ;
ELSE
Get;
SimSet(set2);
Sets.Differ(set, set2) ;
END;
END;
END Set;
PROCEDURE TokenExpr(VAR gL, gR: INTEGER);
VAR gL2, gR2: INTEGER; first: BOOLEAN;
BEGIN
TokenTerm(gL, gR);
first := TRUE ;
WHILE WeakSeparator(26, 1, 5) DO
TokenTerm(gL2, gR2);
IF first THEN
CRT.MakeFirstAlt(gL, gR); first := FALSE
END;
CRT.ConcatAlt(gL, gR, gL2, gR2) ;
END;
END TokenExpr;
PROCEDURE TokenDecl(typ: INTEGER);
VAR sp, kind, gL, gR: INTEGER; sn: CRT.SymbolNode;
pos: CRT.Position; name: CRT.Name;
BEGIN
Symbol(name, kind);
IF CRT.FindSym(name) # CRT.noSym THEN SemErr(7)
ELSE
sp := CRT.NewSym(typ, name, CRS.line);
CRT.GetSym(sp, sn); sn.struct := CRT.classToken;
CRT.PutSym(sp, sn)
END ;
WHILE ~( StartOf(6) ) DO Error(45); Get END;
IF (sym = 8) THEN
Get;
TokenExpr(gL, gR);
Expect(9);
IF kind # ident THEN SemErr(13) END;
CRT.CompleteGraph(gR);
CRA.ConvertToStates(gL, sp) ;
ELSIF StartOf(7) THEN
IF kind = ident THEN genScanner := FALSE
ELSE MatchLiteral(sp)
END ;
ELSE Error(46)
END;
IF (sym = 36) THEN
SemText(pos);
IF typ = CRT.t THEN SemErr(14) END;
CRT.GetSym(sp, sn); sn.semPos := pos; CRT.PutSym(sp, sn) ;
END;
END TokenDecl;
PROCEDURE SetDecl;
VAR c: INTEGER; set: CRT.Set; name: CRT.Name;
BEGIN
Expect(1);
CRS.GetName(CRS.pos, CRS.len, name);
c := CRT.ClassWithName(name); IF c >= 0 THEN SemErr(7) END ;
Expect(8);
Set(set);
c := CRT.NewClass(name, set) ;
Expect(9);
END SetDecl;
PROCEDURE Expression(VAR gL, gR: INTEGER);
VAR gL2, gR2: INTEGER; first: BOOLEAN;
BEGIN
Term(gL, gR);
first := TRUE ;
WHILE WeakSeparator(26, 2, 8) DO
Term(gL2, gR2);
IF first THEN
CRT.MakeFirstAlt(gL, gR); first := FALSE
END;
CRT.ConcatAlt(gL, gR, gL2, gR2) ;
END;
END Expression;
PROCEDURE SemText(VAR semPos: CRT.Position);
BEGIN
Expect(36);
semPos.beg := CRS.nextPos; semPos.col := CRS.nextCol ;
WHILE StartOf(9) DO
Get;
END;
Expect(37);
semPos.len := SHORT(CRS.pos - semPos.beg) ;
END SemText;
PROCEDURE Attribs(VAR attrPos: CRT.Position);
BEGIN
Expect(34);
attrPos.beg := CRS.nextPos; attrPos.col := CRS.nextCol ;
WHILE StartOf(10) DO
Get;
END;
Expect(35);
attrPos.len := SHORT(CRS.pos - attrPos.beg) ;
END Attribs;
PROCEDURE Declaration;
VAR gL1, gR1, gL2, gR2: INTEGER; nested: BOOLEAN;
BEGIN
IF (sym = 11) THEN
Get;
WHILE (sym = 1) DO
SetDecl;
END;
ELSIF (sym = 12) THEN
Get;
WHILE (sym = 1) OR (sym = 2) DO
TokenDecl(CRT.t);
END;
ELSIF (sym = 13) THEN
Get;
WHILE (sym = 1) OR (sym = 2) DO
TokenDecl(CRT.pr);
END;
ELSIF (sym = 14) THEN
Get;
Expect(15);
TokenExpr(gL1, gR1);
Expect(16);
TokenExpr(gL2, gR2);
IF (sym = 17) THEN
Get;
nested := TRUE ;
ELSIF StartOf(11) THEN
nested := FALSE ;
ELSE Error(47)
END;
CRA.NewComment(gL1, gL2, nested) ;
ELSIF (sym = 18) THEN
Get;
IF (sym = 19) THEN
Get;
CRT.ignoreCase := TRUE ;
ELSIF StartOf(12) THEN
Set(CRT.ignored);
ELSE Error(48)
END;
ELSE Error(49)
END;
END Declaration;
PROCEDURE CR;
VAR undef, hasAttrs, ok, ok1: BOOLEAN; eofSy, gR: INTEGER;
gramLine, sp: INTEGER;
gn: CRT.GraphNode; sn: CRT.SymbolNode;
name, gramName: CRT.Name;
BEGIN
Expect(4);
Texts.OpenWriter(w);
CRT.Init; CRX.Init; CRA.Init;
gramLine := CRS.line;
eofSy := CRT.NewSym(CRT.t, "EOF", 0);
genScanner := TRUE;
CRT.ignoreCase := FALSE;
ok := TRUE;
Sets.Clear(CRT.ignored) ;
Expect(1);
CRS.GetName(CRS.pos, CRS.len, gramName);
CRT.semDeclPos.beg := CRS.nextPos; CRT.importPos.beg := -1; ;
WHILE StartOf(13) DO
IF (sym = 5) THEN
Get;
CRT.importPos.beg := CRS.nextPos ;
WHILE StartOf(14) DO
Get;
END;
Expect(6);
CRT.importPos.len := SHORT(CRS.pos - CRT.importPos.beg);
CRT.importPos.col := 0;
CRT.semDeclPos.beg := CRS.nextPos ;
ELSE
Get;
END;
END;
CRT.semDeclPos.len := SHORT(CRS.nextPos - CRT.semDeclPos.beg);
CRT.semDeclPos.col := 0 ;
WHILE StartOf(15) DO
Declaration;
END;
WHILE ~( (sym = 0) OR (sym = 7)) DO Error(50); Get END;
Expect(7);
IF genScanner THEN CRA.MakeDeterministic(ok) END;
CRT.nNodes := 0 ;
WHILE (sym = 1) DO
Get;
CRS.GetName(CRS.pos, CRS.len, name);
sp := CRT.FindSym(name); undef := sp = CRT.noSym;
IF undef THEN
sp := CRT.NewSym(CRT.nt, name, CRS.line);
CRT.GetSym(sp, sn);
ELSE
CRT.GetSym(sp, sn);
IF sn.typ = CRT.nt THEN
IF sn.struct > 0 THEN SemErr(7) END
ELSE SemErr(8)
END;
sn.line := CRS.line
END;
hasAttrs := sn.attrPos.beg >= 0 ;
IF (sym = 34) THEN
Attribs(sn.attrPos);
IF ~undef & ~hasAttrs THEN SemErr(9) END;
CRT.PutSym(sp, sn) ;
ELSIF (sym = 8) OR (sym = 36) THEN
IF ~undef & hasAttrs THEN SemErr(10) END ;
ELSE Error(51)
END;
IF (sym = 36) THEN
SemText(sn.semPos);
END;
ExpectWeak(8, 16);
Expression(sn.struct, gR);
CRT.CompleteGraph(gR); CRT.PutSym(sp, sn);
IF CRT.ddt[2] THEN CRT.PrintGraph END ;
ExpectWeak(9, 17);
END;
sp := CRT.FindSym(gramName);
IF sp = CRT.noSym THEN SemErr(11);
ELSE
CRT.GetSym(sp, sn);
IF sn.attrPos.beg >= 0 THEN SemErr(12) END;
CRT.root := CRT.NewNode(CRT.nt, sp, gramLine);
END ;
Expect(10);
Expect(1);
CRS.GetName(CRS.pos, CRS.len, name);
IF name # gramName THEN SemErr(17) END;
IF CRS.errors = 0 THEN
Texts.WriteString(w, " checking"); Texts.Append(Oberon.Log, w.buf);
CRT.CompSymbolSets;
IF ok THEN CRT.TestCompleteness(ok) END;
IF ok THEN
CRT.TestIfAllNtReached(ok1); CRT.FindCircularProductions(ok)
END;
IF ok THEN CRT.TestIfNtToTerm(ok) END;
IF ok THEN CRT.LL1Test(ok1) END;
IF CRT.ddt[0] THEN CRA.PrintStates END;
IF CRT.ddt[7] THEN CRT.XRef END;
IF ok THEN
Texts.WriteString(w, " +parser");
Texts.Append(Oberon.Log, w.buf);
CRX.GenCompiler;
IF genScanner THEN
Texts.WriteString(w, " +scanner");
Texts.Append(Oberon.Log, w.buf);
CRA.WriteScanner
END;
IF CRT.ddt[8] THEN CRX.WriteStatistics END
END
ELSE ok := FALSE
END;
IF CRT.ddt[6] THEN CRT.PrintSymbolTable END;
IF ok THEN Texts.WriteString(w, " done") END;
Texts.WriteLn(w); Texts.Append(Oberon.Log, w.buf) ;
Expect(9);
END CR;
PROCEDURE Parse*;
BEGIN
Get;
CR;
END Parse;
BEGIN
symSet[0, 0] := {0,1,2,7,8,11,12,13,14,18};
symSet[0, 1] := {4};
symSet[1, 0] := {1,2,23,28,30};
symSet[1, 1] := {};
symSet[2, 0] := {1,2,9,23,24,25,26,27,28,29,30,31};
symSet[2, 1] := {0,4};
symSet[3, 0] := {1,2,23,25,27,28,30};
symSet[3, 1] := {0,4};
symSet[4, 0] := {9,24,26,29,31};
symSet[4, 1] := {};
symSet[5, 0] := {7,9,11,12,13,14,16,17,18,24,29,31};
symSet[5, 1] := {};
symSet[6, 0] := {0,1,2,7,8,11,12,13,14,18};
symSet[6, 1] := {4};
symSet[7, 0] := {1,2,7,11,12,13,14,18};
symSet[7, 1] := {4};
symSet[8, 0] := {9,24,29,31};
symSet[8, 1] := {};
symSet[9, 0] := {1,2,3,4,5,6,7,8,9,10,11,12,13,14,15,16,17,18,19,20,21,22,23,24,25,26,27,28,29,30,31};
symSet[9, 1] := {0,1,2,3,4,6,7,8,9,10,11,12,13,14,15,16,17,18,19,20,21,22,23,24,25,26,27,28,29,30,31};
symSet[10, 0] := {1,2,3,4,5,6,7,8,9,10,11,12,13,14,15,16,17,18,19,20,21,22,23,24,25,26,27,28,29,30,31};
symSet[10, 1] := {0,1,2,4,5,6,7,8,9,10,11,12,13,14,15,16,17,18,19,20,21,22,23,24,25,26,27,28,29,30,31};
symSet[11, 0] := {7,11,12,13,14,18};
symSet[11, 1] := {};
symSet[12, 0] := {1,2,22,25};
symSet[12, 1] := {};
symSet[13, 0] := {1,2,3,4,5,6,8,9,10,15,16,17,19,20,21,22,23,24,25,26,27,28,29,30,31};
symSet[13, 1] := {0,1,2,3,4,5,6,7,8,9,10,11,12,13,14,15,16,17,18,19,20,21,22,23,24,25,26,27,28,29,30,31};
symSet[14, 0] := {1,2,3,4,5,7,8,9,10,11,12,13,14,15,16,17,18,19,20,21,22,23,24,25,26,27,28,29,30,31};
symSet[14, 1] := {0,1,2,3,4,5,6,7,8,9,10,11,12,13,14,15,16,17,18,19,20,21,22,23,24,25,26,27,28,29,30,31};
symSet[15, 0] := {11,12,13,14,18};
symSet[15, 1] := {};
symSet[16, 0] := {0,1,2,7,8,9,11,12,13,14,18,23,25,26,27,28,30};
symSet[16, 1] := {0,4};
symSet[17, 0] := {0,1,2,7,8,10,11,12,13,14,18};
symSet[17, 1] := {4};
END CRP.
| 0: Msg("EOF expected")
| 1: Msg("ident expected")
| 2: Msg("string expected")
| 3: Msg("number expected")
| 4: Msg("'COMPILER' expected")
| 5: Msg("'IMPORT' expected")
| 6: Msg("';' expected")
| 7: Msg("'PRODUCTIONS' expected")
| 8: Msg("'=' expected")
| 9: Msg("'.' expected")
| 10: Msg("'END' expected")
| 11: Msg("'CHARACTERS' expected")
| 12: Msg("'TOKENS' expected")
| 13: Msg("'PRAGMAS' expected")
| 14: Msg("'COMMENTS' expected")
| 15: Msg("'FROM' expected")
| 16: Msg("'TO' expected")
| 17: Msg("'NESTED' expected")
| 18: Msg("'IGNORE' expected")
| 19: Msg("'CASE' expected")
| 20: Msg("'+' expected")
| 21: Msg("'-' expected")
| 22: Msg("'CHR' expected")
| 23: Msg("'(' expected")
| 24: Msg("')' expected")
| 25: Msg("'ANY' expected")
| 26: Msg("'|' expected")
| 27: Msg("'WEAK' expected")
| 28: Msg("'[' expected")
| 29: Msg("']' expected")
| 30: Msg("'{' expected")
| 31: Msg("'}' expected")
| 32: Msg("'SYNC' expected")
| 33: Msg("'CONTEXT' expected")
| 34: Msg("'<' expected")
| 35: Msg("'>' expected")
| 36: Msg("'(.' expected")
| 37: Msg("'.)' expected")
| 38: Msg("??? expected")
| 39: Msg("invalid TokenFactor")
| 40: Msg("invalid Factor")
| 41: Msg("invalid Factor")
| 42: Msg("invalid Term")
| 43: Msg("invalid Symbol")
| 44: Msg("invalid SimSet")
| 45: Msg("this symbol not expected in TokenDecl")
| 46: Msg("invalid TokenDecl")
| 47: Msg("invalid Declaration")
| 48: Msg("invalid Declaration")
| 49: Msg("invalid Declaration")
| 50: Msg("this symbol not expected in CR")
| 51: Msg("invalid CR")

230
src/tools/coco/CRS.Mod Normal file
View file

@ -0,0 +1,230 @@
(* scanner module generated by Coco-R *)
MODULE CRS;
IMPORT Texts := CmdlnTexts, SYSTEM;
CONST
EOL = 0DX;
EOF = 0X;
maxLexLen = 127;
noSym = 38;
TYPE
ErrorProc* = PROCEDURE (n: INTEGER; pos: LONGINT);
StartTable = ARRAY 128 OF INTEGER;
VAR
src*: Texts.Text; (*source text. To be set by the main pgm*)
pos*: LONGINT; (*position of current symbol*)
line*, col*, len*: INTEGER; (*line, column, length of current symbol*)
nextPos*: LONGINT; (*position of lookahead symbol*)
nextLine*, nextCol*, nextLen*: INTEGER; (*line, column, length of lookahead symbol*)
errors*: INTEGER; (*number of errors detected*)
Error*: ErrorProc;
ch: CHAR; (*current input character*)
r: Texts.Reader; (*global reader*)
chPos: LONGINT; (*position of current character*)
chLine: INTEGER; (*current line number*)
lineStart: LONGINT; (*start position of current line*)
apx: INTEGER; (*length of appendix*)
oldEols: INTEGER; (*nr. of EOLs in a comment*)
start: StartTable; (*start state for every character*)
PROCEDURE NextCh; (*return global variable ch*)
BEGIN
Texts.Read(r, ch); INC(chPos);
IF ch = EOL THEN INC(chLine); lineStart := chPos + 1 END
END NextCh;
PROCEDURE Comment(): BOOLEAN;
VAR level, startLine: INTEGER; oldLineStart: LONGINT;
BEGIN (*Comment*)
level := 1; startLine := chLine; oldLineStart := lineStart;
IF (ch ="(") THEN
NextCh;
IF (ch ="*") THEN
NextCh;
LOOP
IF (ch ="*") THEN
NextCh;
IF (ch =")") THEN
DEC(level); oldEols := chLine - startLine; NextCh;
IF level=0 THEN RETURN TRUE END
END;
ELSIF (ch ="(") THEN
NextCh;
IF (ch ="*") THEN
INC(level); NextCh;
END;
ELSIF ch = EOF THEN RETURN FALSE
ELSE NextCh END;
END;
ELSE
IF ch = EOL THEN DEC(chLine); lineStart := oldLineStart END;
DEC(chPos, 2); Texts.OpenReader(r, src, chPos+1); NextCh; RETURN FALSE
END
END;
END Comment;
PROCEDURE Get*(VAR sym: INTEGER);
VAR state: INTEGER; lexeme: ARRAY maxLexLen+1 OF CHAR;
PROCEDURE CheckLiteral;
BEGIN
IF nextLen < maxLexLen THEN lexeme[nextLen] := 0X END;
IF (lexeme[0] >= "A") & (lexeme[0] <= "W") THEN
CASE lexeme[0] OF
| "A": IF lexeme = "ANY" THEN sym := 25
END
| "C": IF lexeme = "CASE" THEN sym := 19
ELSIF lexeme = "CHARACTERS" THEN sym := 11
ELSIF lexeme = "CHR" THEN sym := 22
ELSIF lexeme = "COMMENTS" THEN sym := 14
ELSIF lexeme = "COMPILER" THEN sym := 4
ELSIF lexeme = "CONTEXT" THEN sym := 33
END
| "E": IF lexeme = "END" THEN sym := 10
END
| "F": IF lexeme = "FROM" THEN sym := 15
END
| "I": IF lexeme = "IGNORE" THEN sym := 18
ELSIF lexeme = "IMPORT" THEN sym := 5
END
| "N": IF lexeme = "NESTED" THEN sym := 17
END
| "P": IF lexeme = "PRAGMAS" THEN sym := 13
ELSIF lexeme = "PRODUCTIONS" THEN sym := 7
END
| "S": IF lexeme = "SYNC" THEN sym := 32
END
| "T": IF lexeme = "TO" THEN sym := 16
ELSIF lexeme = "TOKENS" THEN sym := 12
END
| "W": IF lexeme = "WEAK" THEN sym := 27
END
ELSE
END
END;
END CheckLiteral;
BEGIN
WHILE (ch=20X) OR (ch=CHR(9)) OR (ch=CHR(13)) OR (ch=CHR(28)) DO NextCh END;
IF ((ch ="(")) & Comment() THEN Get(sym); RETURN END;
IF ch > 7FX THEN ch := " " END;
pos := nextPos; col := nextCol; line := nextLine; len := nextLen;
nextPos := chPos; nextCol := SHORT(chPos - lineStart); nextLine := chLine; nextLen := 0;
state := start[ORD(ch)]; apx := 0;
LOOP
IF nextLen < maxLexLen THEN lexeme[nextLen] := ch END;
INC(nextLen);
NextCh;
IF state > 0 THEN
CASE state OF
| 1: IF (ch>="0") & (ch<="9") OR (ch>="A") & (ch<="Z") OR (ch>="a") & (ch<="z") THEN
ELSE sym := 1; CheckLiteral; RETURN
END;
| 2: IF (ch<=CHR(12)) OR (ch>=CHR(14)) & (ch<="!") OR (ch>="#") THEN
ELSIF (ch =CHR(34)) THEN state := 3;
ELSE sym := noSym; RETURN
END;
| 3: sym := 2; RETURN
| 4: IF (ch<=CHR(12)) OR (ch>=CHR(14)) & (ch<="&") OR (ch>="(") THEN
ELSIF (ch ="'") THEN state := 3;
ELSE sym := noSym; RETURN
END;
| 5: IF (ch>="0") & (ch<="9") THEN
ELSE sym := 3; RETURN
END;
| 6: IF (ch>="0") & (ch<="9") THEN
ELSE sym := 39; RETURN
END;
| 7: sym := 6; RETURN
| 8: sym := 8; RETURN
| 9: IF (ch =")") THEN state := 22;
ELSE sym := 9; RETURN
END;
| 10: sym := 20; RETURN
| 11: sym := 21; RETURN
| 12: IF (ch =".") THEN state := 21;
ELSE sym := 23; RETURN
END;
| 13: sym := 24; RETURN
| 14: sym := 26; RETURN
| 15: sym := 28; RETURN
| 16: sym := 29; RETURN
| 17: sym := 30; RETURN
| 18: sym := 31; RETURN
| 19: sym := 34; RETURN
| 20: sym := 35; RETURN
| 21: sym := 36; RETURN
| 22: sym := 37; RETURN
| 23: sym := 0; ch := 0X; RETURN
END (*CASE*)
ELSE sym := noSym; RETURN (*NextCh already done*)
END (*IF*)
END (*LOOP*)
END Get;
PROCEDURE GetName*(pos: LONGINT; len: INTEGER; VAR s: ARRAY OF CHAR);
VAR i: INTEGER; r: Texts.Reader;
BEGIN
Texts.OpenReader(r, src, pos);
IF len >= LEN(s) THEN len := SHORT(LEN(s)) - 1 END;
i := 0; WHILE i < len DO Texts.Read(r, s[i]); INC(i) END;
s[i] := 0X
END GetName;
PROCEDURE StdErrorProc* (n: INTEGER; pos: LONGINT);
BEGIN INC(errors) END StdErrorProc;
PROCEDURE Reset* (t: Texts.Text; pos: LONGINT; errProc: ErrorProc);
BEGIN
src := t; Error := errProc;
Texts.OpenReader(r, src, pos);
chPos := pos - 1; chLine := 1; lineStart := 0;
oldEols := 0; apx := 0; errors := 0;
NextCh
END Reset;
BEGIN
start[0]:=23; start[1]:=0; start[2]:=0; start[3]:=0;
start[4]:=0; start[5]:=0; start[6]:=0; start[7]:=0;
start[8]:=0; start[9]:=0; start[10]:=0; start[11]:=0;
start[12]:=0; start[13]:=0; start[14]:=0; start[15]:=0;
start[16]:=0; start[17]:=0; start[18]:=0; start[19]:=0;
start[20]:=0; start[21]:=0; start[22]:=0; start[23]:=0;
start[24]:=0; start[25]:=0; start[26]:=0; start[27]:=0;
start[28]:=0; start[29]:=0; start[30]:=0; start[31]:=0;
start[32]:=0; start[33]:=0; start[34]:=2; start[35]:=0;
start[36]:=6; start[37]:=0; start[38]:=0; start[39]:=4;
start[40]:=12; start[41]:=13; start[42]:=0; start[43]:=10;
start[44]:=0; start[45]:=11; start[46]:=9; start[47]:=0;
start[48]:=5; start[49]:=5; start[50]:=5; start[51]:=5;
start[52]:=5; start[53]:=5; start[54]:=5; start[55]:=5;
start[56]:=5; start[57]:=5; start[58]:=0; start[59]:=7;
start[60]:=19; start[61]:=8; start[62]:=20; start[63]:=0;
start[64]:=0; start[65]:=1; start[66]:=1; start[67]:=1;
start[68]:=1; start[69]:=1; start[70]:=1; start[71]:=1;
start[72]:=1; start[73]:=1; start[74]:=1; start[75]:=1;
start[76]:=1; start[77]:=1; start[78]:=1; start[79]:=1;
start[80]:=1; start[81]:=1; start[82]:=1; start[83]:=1;
start[84]:=1; start[85]:=1; start[86]:=1; start[87]:=1;
start[88]:=1; start[89]:=1; start[90]:=1; start[91]:=15;
start[92]:=0; start[93]:=16; start[94]:=0; start[95]:=0;
start[96]:=0; start[97]:=1; start[98]:=1; start[99]:=1;
start[100]:=1; start[101]:=1; start[102]:=1; start[103]:=1;
start[104]:=1; start[105]:=1; start[106]:=1; start[107]:=1;
start[108]:=1; start[109]:=1; start[110]:=1; start[111]:=1;
start[112]:=1; start[113]:=1; start[114]:=1; start[115]:=1;
start[116]:=1; start[117]:=1; start[118]:=1; start[119]:=1;
start[120]:=1; start[121]:=1; start[122]:=1; start[123]:=17;
start[124]:=14; start[125]:=18; start[126]:=0; start[127]:=0;
END CRS.

994
src/tools/coco/CRT.Mod Normal file
View file

@ -0,0 +1,994 @@
MODULE CRT; (* H.Moessenboeck 17.11.93, Cocol-R Tables *)
IMPORT Texts := CmdlnTexts, Oberon, Sets;
CONST
maxSymbols* = 300; (*max nr of t, nt, and pragmas*)
maxTerminals* = 256; (*max nr of terminals*)
maxNt* = 128; (*max nr of nonterminals*)
maxNodes* = 1500; (*max nr of graph nodes*)
normTrans* = 0; contextTrans* = 1; (*transition codes*)
maxSetNr = 128; (* max. number of symbol sets *)
maxClasses = 50; (* max. number of character classes *)
(* node types *)
t* = 1; pr* = 2; nt* = 3; class* = 4; char* = 5; wt* = 6; any* = 7; eps* = 8; sync* = 9; sem* = 10;
alt* = 11; iter* = 12; opt* = 13;
noSym* = -1;
eofSy* = 0;
(* token kinds *)
classToken* = 0; (*token class*)
litToken* = 1; (*literal (e.g. keyword) not recognized by DFA*)
classLitToken* = 2; (*token class that can also match a literal*)
TYPE
Name* = ARRAY 16 OF CHAR; (*symbol name*)
Position* = RECORD (*position of stretch of source text*)
beg*: LONGINT; (*start relative to beginning of file*)
len*: INTEGER; (*length*)
col*: INTEGER; (*column number of start position*)
END;
SymbolNode* = RECORD
typ*: INTEGER; (*nt, t, pr, unknown*)
name*: Name; (*symbol name*)
struct*: INTEGER; (*typ = nt: index of 1st node of syntax graph*)
(*typ = t: token kind: literal, class, ...*)
deletable*: BOOLEAN; (*typ = nt: TRUE, if nonterminal is deletable*)
attrPos*: Position; (*position of attributes in source text*)
semPos*: Position; (*typ = pr: pos of sem action in source text*)
(*typ = nt: pos of local decls in source text *)
line*: INTEGER; (*source text line number of item in this node*)
END;
Set* = ARRAY maxTerminals DIV Sets.size OF SET;
GraphNode* = RECORD
typ* : INTEGER; (* nt,sts,wts,char,class,any,eps,sem,sync,alt,iter,opt*)
next*: INTEGER; (* index of successor node *)
(* next < 0: to successor in enclosing structure *)
p1*: INTEGER; (* typ IN {nt, t, wt}: index to symbol list *)
(* typ = any: index to anyset *)
(* typ = sync: index to syncset *)
(* typ = alt: index of 1st node of 1st alternative*)
(* typ IN {iter, opt}: 1st node in subexpression *)
(* typ = char: ordinal character value *)
(* typ = class: index of character class *)
p2*: INTEGER; (* typ = alt: index of 1st node of 2nd alternative*)
(* typ IN {char, class}: transition code *)
pos*: Position; (* typ IN {nt, t, wt}: pos of actual attribs *)
(* typ = sem: pos of sem action in source text. *)
line*: INTEGER; (* source text line number of item in this node *)
END;
MarkList* = ARRAY maxNodes DIV Sets.size OF SET;
FirstSets = ARRAY maxNt OF RECORD
ts: Set; (*terminal symbols*)
ready: BOOLEAN; (*TRUE = ts is complete*)
END;
FollowSets = ARRAY maxNt OF RECORD
ts: Set; (*terminal symbols*)
nts: Set; (*nts whose start set is to be included*)
END;
CharClass = RECORD
name: Name; (*class name*)
set: INTEGER (* ptr to set representing the class*)
END;
SymbolTable = ARRAY maxSymbols OF SymbolNode;
ClassTable = ARRAY maxClasses OF CharClass;
GraphList = ARRAY maxNodes OF GraphNode;
VAR
maxSet*: INTEGER; (* index of last set *)
maxT*: INTEGER; (* terminals stored from 0 .. maxT *)
maxP*: INTEGER; (* pragmas stored from maxT+1 .. maxP *)
firstNt*: INTEGER; (* index of first nt: available after CompSymbolSets *)
lastNt*: INTEGER; (* index of last nt: available after CompSymbolSets *)
maxC*: INTEGER; (* index of last character class *)
semDeclPos*: Position; (*position of global semantic declarations*)
importPos*: Position; (*position of imported identifiers*)
ignored*: Set; (* characters ignored by the scanner *)
ignoreCase*: BOOLEAN; (* TRUE: scanner treats lower case as upper case*)
ddt*: ARRAY 10 OF BOOLEAN; (* debug and test switches *)
nNodes*: INTEGER; (* index of last graph node *)
root*: INTEGER; (* index of root node, filled by ATG *)
w: Texts.Writer;
st: SymbolTable;
gn: GraphList;
first: FirstSets; (*first[i] = first symbols of st[i+firstNt]*)
follow: FollowSets; (*follow[i] = followers of st[i+firstNt]*)
chClass: ClassTable; (*character classes*)
set: ARRAY 128 OF Set; (*set[0] reserved for union of all synchronisation sets*)
dummyName: INTEGER; (*for unnamed character classes*)
PROCEDURE ^MovePragmas;
PROCEDURE ^DelNode*(gn: GraphNode): BOOLEAN;
PROCEDURE Str(s: ARRAY OF CHAR);
BEGIN Texts.WriteString(w, s)
END Str;
PROCEDURE NL;
BEGIN Texts.WriteLn(w)
END NL;
PROCEDURE Length(s: ARRAY OF CHAR): INTEGER;
VAR i: INTEGER;
BEGIN
i:=0; WHILE (i < LEN(s)) & (s[i] # 0X) DO INC(i) END;
RETURN i
END Length;
PROCEDURE Restriction(n: INTEGER);
BEGIN
NL; Str("Restriction "); Texts.WriteInt(w, n, 0); NL; Texts.Append(Oberon.Log, w.buf);
HALT(99)
END Restriction;
PROCEDURE ClearMarkList(VAR m: MarkList);
VAR i: INTEGER;
BEGIN
i := 0; WHILE i < maxNodes DIV Sets.size DO m[i] := {}; INC(i) END;
END ClearMarkList;
PROCEDURE GetNode*(gp: INTEGER; VAR n: GraphNode);
BEGIN
n := gn[gp]
END GetNode;
PROCEDURE PutNode*(gp: INTEGER; n: GraphNode);
BEGIN gn[gp] := n
END PutNode;
PROCEDURE DelGraph*(gp: INTEGER): BOOLEAN;
VAR gn: GraphNode;
BEGIN
IF gp = 0 THEN RETURN TRUE END; (*end of graph found*)
GetNode(gp, gn);
RETURN DelNode(gn) & DelGraph(ABS(gn.next));
END DelGraph;
PROCEDURE NewSym*(typ: INTEGER; name: Name; line: INTEGER): INTEGER;
VAR i: INTEGER;
BEGIN
IF maxT + 1 = firstNt THEN Restriction(6)
ELSE
CASE typ OF
| t: INC(maxT); i := maxT
| pr: DEC(maxP); DEC(firstNt); DEC(lastNt); i := maxP
| nt: DEC(firstNt); i := firstNt
END;
IF maxT >= maxTerminals THEN Restriction(6) END;
st[i].typ := typ; st[i].name := name;
st[i].struct := 0; st[i].deletable := FALSE;
st[i].attrPos.beg := -1;
st[i].semPos.beg := -1;
st[i].line := line
END;
RETURN i
END NewSym;
PROCEDURE GetSym*(sp: INTEGER; VAR sn: SymbolNode);
BEGIN sn := st[sp]
END GetSym;
PROCEDURE PutSym*(sp: INTEGER; sn: SymbolNode);
BEGIN st[sp] := sn
END PutSym;
PROCEDURE FindSym*(name: Name): INTEGER;
VAR i: INTEGER;
BEGIN
i := 0; (*search in terminal list*)
WHILE (i <= maxT) & (st[i].name # name) DO INC(i) END;
IF i <= maxT THEN RETURN i END;
i := firstNt; (*search in nonterminal/pragma list*)
WHILE (i < maxSymbols) & (st[i].name # name) DO INC(i) END;
IF i < maxSymbols THEN RETURN i ELSE RETURN noSym END
END FindSym;
PROCEDURE NewSet*(s: Set): INTEGER;
BEGIN
INC(maxSet); IF maxSet > maxSetNr THEN Restriction(4) END;
set[maxSet] := s;
RETURN maxSet
END NewSet;
PROCEDURE PrintSet(s: ARRAY OF SET; indent: INTEGER);
CONST maxLineLen = 80;
VAR col, i, len: INTEGER; empty: BOOLEAN; sn: SymbolNode;
BEGIN
i := 0; col := indent; empty := TRUE;
WHILE i <= maxT DO
IF Sets.In(s, i) THEN
empty := FALSE; GetSym(i, sn); len := Length(sn.name);
IF col + len + 2 > maxLineLen THEN
NL; col := 1;
WHILE col < indent DO Texts.Write(w, " "); INC(col) END
END;
Str(sn.name); Str(" ");
INC(col, len + 2)
END;
INC(i)
END;
IF empty THEN Str("-- empty set --") END;
NL; Texts.Append(Oberon.Log, w.buf)
END PrintSet;
PROCEDURE CompFirstSet*(gp: INTEGER; VAR fs: Set);
VAR visited: MarkList;
PROCEDURE CompFirst(gp: INTEGER; VAR fs: Set);
VAR s: Set; gn: GraphNode; sn: SymbolNode;
BEGIN
Sets.Clear(fs);
WHILE (gp # 0) & ~ Sets.In(visited, gp) DO
GetNode(gp, gn); Sets.Incl(visited, gp);
CASE gn.typ OF
| nt:
IF first[gn.p1 - firstNt].ready THEN
Sets.Unite(fs, first[gn.p1 - firstNt].ts);
ELSE
GetSym(gn.p1, sn); CompFirst(sn.struct, s); Sets.Unite(fs, s);
END;
| t, wt: Sets.Incl(fs, gn.p1);
| any: Sets.Unite(fs, set[gn.p1])
| alt, iter, opt:
CompFirst(gn.p1, s); Sets.Unite(fs, s);
IF gn.typ = alt THEN CompFirst(gn.p2, s); Sets.Unite(fs, s) END
ELSE (* eps, sem, sync: nothing *)
END;
IF ~ DelNode(gn) THEN RETURN END;
gp := ABS(gn.next)
END
END CompFirst;
BEGIN (* ComputeFirstSet *)
ClearMarkList(visited);
CompFirst(gp, fs);
IF ddt[3] THEN
NL; Str("ComputeFirstSet: gp = "); Texts.WriteInt(w, gp, 0); NL;
PrintSet(fs, 0);
END;
END CompFirstSet;
PROCEDURE CompFirstSets;
VAR i: INTEGER; sn: SymbolNode;
BEGIN
i := firstNt; WHILE i <= lastNt DO first[i-firstNt].ready := FALSE; INC(i) END;
i := firstNt;
WHILE i <= lastNt DO (* for all nonterminals *)
GetSym(i, sn); CompFirstSet(sn.struct, first[i - firstNt].ts);
first[i - firstNt].ready := TRUE;
INC(i)
END;
END CompFirstSets;
PROCEDURE CompExpected*(gp, sp: INTEGER; VAR exp: Set);
BEGIN
CompFirstSet(gp, exp);
IF DelGraph(gp) THEN Sets.Unite(exp, follow[sp - firstNt].ts) END
END CompExpected;
PROCEDURE CompFollowSets;
VAR sn: SymbolNode; gn: GraphNode; curSy, i, size: INTEGER; visited: MarkList;
PROCEDURE CompFol(gp: INTEGER);
VAR s: Set; gn: GraphNode;
BEGIN
WHILE (gp > 0) & ~ Sets.In(visited, gp) DO
GetNode(gp, gn); Sets.Incl(visited, gp);
IF gn.typ = nt THEN
CompFirstSet(ABS(gn.next), s); Sets.Unite(follow[gn.p1 - firstNt].ts, s);
IF DelGraph(ABS(gn.next)) THEN
Sets.Incl(follow[gn.p1 - firstNt].nts, curSy - firstNt)
END
ELSIF gn.typ IN {opt, iter} THEN CompFol(gn.p1)
ELSIF gn.typ = alt THEN CompFol(gn.p1); CompFol(gn.p2)
END;
gp := gn.next
END
END CompFol;
PROCEDURE Complete(i: INTEGER);
VAR j: INTEGER;
BEGIN
IF Sets.In(visited, i) THEN RETURN END;
Sets.Incl(visited, i);
j := 0;
WHILE j <= lastNt - firstNt DO (* for all nonterminals *)
IF Sets.In(follow[i].nts, j) THEN
Complete(j); Sets.Unite(follow[i].ts, follow[j].ts);
Sets.Excl(follow[i].nts, j)
END;
INC(j)
END;
END Complete;
BEGIN (* CompFollowSets *)
curSy := firstNt; size := (lastNt - firstNt + 2) DIV Sets.size;
WHILE curSy <= lastNt + 1 DO (* also for dummy root nt*)
Sets.Clear(follow[curSy - firstNt].ts);
i := 0; WHILE i <= size DO follow[curSy - firstNt].nts[i] := {}; INC(i) END;
INC(curSy)
END;
curSy := firstNt; (*get direct successors of nonterminals*)
WHILE curSy <= lastNt DO
GetSym(curSy, sn); ClearMarkList(visited); CompFol(sn.struct);
INC(curSy)
END;
CompFol(root); (*curSy=lastNt+1*)
curSy := 0; (*add indirect successors to follow.ts*)
WHILE curSy <= lastNt - firstNt DO
ClearMarkList(visited); Complete(curSy);
INC(curSy);
END;
END CompFollowSets;
PROCEDURE CompAnySets;
VAR curSy, i: INTEGER; sn: SymbolNode;
PROCEDURE LeadingAny(gp: INTEGER; VAR a: GraphNode): BOOLEAN;
VAR gn: GraphNode;
BEGIN
IF gp <= 0 THEN RETURN FALSE END;
GetNode(gp, gn);
IF (gn.typ = any) THEN a := gn; RETURN TRUE
ELSE RETURN (gn.typ = alt) & (LeadingAny(gn.p1, a) OR LeadingAny(gn.p2, a))
OR (gn.typ IN {opt, iter}) & LeadingAny(gn.p1, a)
OR DelNode(gn) & LeadingAny(gn.next, a)
END
END LeadingAny;
PROCEDURE FindAS(gp: INTEGER);
VAR gn, gn2, a: GraphNode; s1, s2: Set; p: INTEGER;
BEGIN
WHILE gp > 0 DO
GetNode(gp, gn);
IF gn.typ IN {opt, iter} THEN
FindAS(gn.p1);
IF LeadingAny(gn.p1, a) THEN
CompFirstSet(ABS(gn.next), s1); Sets.Differ(set[a.p1], s1)
END
ELSIF gn.typ = alt THEN
p := gp; Sets.Clear(s1);
WHILE p # 0 DO
GetNode(p, gn2); FindAS(gn2.p1);
IF LeadingAny(gn2.p1, a) THEN
CompFirstSet(gn2.p2, s2); Sets.Unite(s2, s1); Sets.Differ(set[a.p1], s2)
ELSE
CompFirstSet(gn2.p1, s2); Sets.Unite(s1, s2)
END;
p := gn2.p2
END
END;
gp := gn.next
END
END FindAS;
BEGIN
curSy := firstNt;
WHILE curSy <= lastNt DO (* for all nonterminals *)
GetSym(curSy, sn); FindAS(sn.struct);
INC(curSy)
END
END CompAnySets;
PROCEDURE CompSyncSets;
VAR curSy, i: INTEGER; sn: SymbolNode; visited: MarkList;
PROCEDURE CompSync(gp: INTEGER);
VAR s: Set; gn: GraphNode;
BEGIN
WHILE (gp > 0) & ~ Sets.In(visited, gp) DO
GetNode(gp, gn); Sets.Incl(visited, gp);
IF gn.typ = sync THEN
CompExpected(ABS(gn.next), curSy, s);
Sets.Incl(s, eofSy); Sets.Unite(set[0], s);
gn.p1 := NewSet(s); PutNode(gp, gn)
ELSIF gn.typ = alt THEN CompSync(gn.p1); CompSync(gn.p2)
ELSIF gn.typ IN {iter, opt} THEN CompSync(gn.p1)
END;
gp := gn.next
END
END CompSync;
BEGIN
curSy := firstNt; ClearMarkList(visited);
WHILE curSy <= lastNt DO
GetSym(curSy, sn); CompSync(sn.struct);
INC(curSy);
END
END CompSyncSets;
PROCEDURE CompDeletableSymbols*;
VAR changed, del: BOOLEAN; i: INTEGER; sn: SymbolNode;
BEGIN
del := FALSE;
REPEAT
changed := FALSE;
i := firstNt;
WHILE i <= lastNt DO (*for all nonterminals*)
GetSym(i, sn);
IF ~sn.deletable & DelGraph(sn.struct) THEN
sn.deletable := TRUE; PutSym(i, sn); changed := TRUE; del := TRUE
END;
INC(i)
END;
UNTIL ~changed;
i := firstNt; IF del THEN NL END;
WHILE i <= lastNt DO
GetSym(i, sn);
IF sn.deletable THEN Str(" "); Str(sn.name); Str(" deletable"); NL END;
INC(i);
END;
Texts.Append(Oberon.Log, w.buf)
END CompDeletableSymbols;
PROCEDURE CompSymbolSets*;
VAR i: INTEGER; sn: SymbolNode;
BEGIN
i := NewSym(t, "???", 0); (*unknown symbols get code maxT*)
MovePragmas;
CompDeletableSymbols;
CompFirstSets;
CompFollowSets;
CompAnySets;
CompSyncSets;
IF ddt[1] THEN
i := firstNt; Str("First & follow symbols:"); NL;
WHILE i <= lastNt DO (* for all nonterminals *)
GetSym(i, sn); Str(sn.name); NL;
Str("first: "); PrintSet(first[i - firstNt].ts, 10);
Str("follow: "); PrintSet(follow[i - firstNt].ts, 10);
NL;
INC(i);
END;
IF maxSet >= 0 THEN NL; NL; Str("List of sets (ANY, SYNC): "); NL END;
i := 0;
WHILE i <= maxSet DO
Str(" set["); Texts.WriteInt (w, i, 2); Str("] = "); PrintSet(set[i], 16);
INC (i)
END;
NL; NL; Texts.Append(Oberon.Log, w.buf)
END;
END CompSymbolSets;
PROCEDURE GetFirstSet(sp: INTEGER; VAR s: Set);
BEGIN s := first[sp - firstNt].ts
END GetFirstSet;
PROCEDURE GetFollowSet(sp: INTEGER; VAR s: Set);
BEGIN s := follow[sp - firstNt].ts
END GetFollowSet;
PROCEDURE GetSet*(nr: INTEGER; VAR s: Set);
BEGIN s := set[nr]
END GetSet;
PROCEDURE MovePragmas;
VAR i: INTEGER;
BEGIN
IF maxP > firstNt THEN
i := maxSymbols - 1; maxP := maxT;
WHILE i > lastNt DO
INC(maxP); IF maxP >= firstNt THEN Restriction(6) END;
st[maxP] := st[i]; DEC(i)
END;
END
END MovePragmas;
PROCEDURE PrintSymbolTable*;
VAR i, j: INTEGER;
PROCEDURE WriteTyp(typ: INTEGER);
BEGIN
CASE typ OF
| t : Str(" t ");
| pr : Str(" pr ");
| nt : Str(" nt ");
END;
END WriteTyp;
BEGIN (* PrintSymbolTable *)
Str("Symbol Table:"); NL; NL;
Str("nr name typ hasAttribs struct del line"); NL; NL;
i := 0;
WHILE i < maxSymbols DO
Texts.WriteInt(w, i, 3); Str(" ");
j := 0; WHILE (j < 8) & (st[i].name[j] # 0X) DO Texts.Write(w, st[i].name[j]); INC(j) END;
WHILE j < 8 DO Texts.Write(w, " "); INC(j) END;
WriteTyp(st[i].typ);
IF st[i].attrPos.beg >= 0 THEN Str(" TRUE ") ELSE Str(" FALSE") END;
Texts.WriteInt(w, st[i].struct, 10);
IF st[i].deletable THEN Str(" TRUE ") ELSE Str(" FALSE") END;
Texts.WriteInt(w, st[i].line, 6); NL;
IF i = maxT THEN i := firstNt ELSE INC(i) END
END;
NL; NL; Texts.Append(Oberon.Log, w.buf)
END PrintSymbolTable;
PROCEDURE NewClass*(name: Name; set: Set): INTEGER;
BEGIN
INC(maxC); IF maxC >= maxClasses THEN Restriction(7) END;
IF name[0] = "#" THEN name[1] := CHR(ORD("A") + dummyName); INC(dummyName) END;
chClass[maxC].name := name; chClass[maxC].set := NewSet(set);
RETURN maxC
END NewClass;
PROCEDURE ClassWithName*(name: Name): INTEGER;
VAR i: INTEGER;
BEGIN
i := maxC; WHILE (i >= 0) & (chClass[i].name # name) DO DEC(i) END;
RETURN i
END ClassWithName;
PROCEDURE ClassWithSet*(s: Set): INTEGER;
VAR i: INTEGER;
BEGIN
i := maxC; WHILE (i >= 0) & ~ Sets.Equal(set[chClass[i].set], s) DO DEC(i) END;
RETURN i
END ClassWithSet;
PROCEDURE GetClass*(n: INTEGER; VAR s: Set);
BEGIN
GetSet(chClass[n].set, s)
END GetClass;
PROCEDURE GetClassName*(n: INTEGER; VAR name: Name);
BEGIN
name := chClass[n].name
END GetClassName;
PROCEDURE XRef*;
CONST maxLineLen = 80;
TYPE ListPtr = POINTER TO ListNode;
ListNode = RECORD
next: ListPtr;
line: INTEGER;
END;
ListHdr = RECORD
name: Name;
lptr: ListPtr;
END;
VAR gn: GraphNode; col, i, j: INTEGER; l, p, q: ListPtr;
sn: SymbolNode;
xList: ARRAY maxSymbols OF ListHdr;
BEGIN (* XRef *)
IF maxT <= 0 THEN RETURN END;
MovePragmas;
(* initialise cross reference list *)
i := 0;
WHILE i <= lastNt DO (* for all symbols *)
GetSym(i, sn); xList[i].name := sn.name; xList[i].lptr := NIL;
IF i = maxP THEN i := firstNt ELSE INC(i) END
END;
(* search lines where symbol has been referenced *)
i := 1;
WHILE i <= nNodes DO (* for all graph nodes *)
GetNode(i, gn);
IF gn.typ IN {t, wt, nt} THEN
NEW(l); l^.next := xList[gn.p1].lptr; l^.line := gn.line;
xList[gn.p1].lptr := l
END;
INC(i);
END;
(* search lines where symbol has been defined and insert in order *)
i := 1;
WHILE i <= lastNt DO (*for all symbols*)
GetSym(i, sn); p := xList[i].lptr; q := NIL;
WHILE (p # NIL) & (p^.line > sn.line) DO q := p; p := p^.next END;
NEW(l); l^.next := p;
l^.line := -sn.line;
IF q # NIL THEN q^.next := l ELSE xList[i].lptr := l END;
IF i = maxP THEN i := firstNt ELSE INC(i) END
END;
(* print cross reference listing *)
NL; Str("Cross reference list:"); NL; NL; Str("Terminals:"); NL; Str(" 0 EOF"); NL;
i := 1;
WHILE i <= lastNt DO (*for all symbols*)
Texts.WriteInt(w, i, 3); Str(" ");
j := 0; WHILE (j < 15) & (xList[i].name[j] # 0X) DO Texts.Write(w, xList[i].name[j]); INC(j) END;
l := xList[i].lptr; col := 25;
WHILE l # NIL DO
IF col + 5 > maxLineLen THEN
NL; col := 0; WHILE col < 25 DO Texts.Write(w, " "); INC(col) END
END;
IF l^.line = 0 THEN Str("undef") ELSE Texts.WriteInt(w, l^.line, 5) END;
INC(col, 5);
l := l^.next
END;
NL;
IF i = maxT THEN NL; Str("Pragmas:"); NL END;
IF i = maxP THEN NL; Str("Nonterminals:"); NL; i := firstNt ELSE INC(i) END
END;
NL; NL; Texts.Append(Oberon.Log, w.buf)
END XRef;
PROCEDURE NewNode*(typ, p1, line: INTEGER): INTEGER;
BEGIN
INC(nNodes); IF nNodes > maxNodes THEN Restriction(3) END;
gn[nNodes].typ := typ; gn[nNodes].next := 0;
gn[nNodes].p1 := p1; gn[nNodes].p2 := 0;
gn[nNodes].pos.beg := -1; gn[nNodes].line := line;
RETURN nNodes;
END NewNode;
PROCEDURE CompleteGraph*(gp: INTEGER);
VAR p: INTEGER;
BEGIN
WHILE gp # 0 DO
p := gn[gp].next; gn[gp].next := 0; gp := p
END
END CompleteGraph;
PROCEDURE ConcatAlt*(VAR gL1, gR1: INTEGER; gL2, gR2: INTEGER);
VAR p: INTEGER;
BEGIN
gL2 := NewNode(alt, gL2, 0);
p := gL1; WHILE gn[p].p2 # 0 DO p := gn[p].p2 END; gn[p].p2 := gL2;
p := gR1; WHILE gn[p].next # 0 DO p := gn[p].next END; gn[p].next := gR2
END ConcatAlt;
PROCEDURE ConcatSeq*(VAR gL1, gR1: INTEGER; gL2, gR2: INTEGER);
VAR p, q: INTEGER;
BEGIN
p := gn[gR1].next; gn[gR1].next := gL2; (*head node*)
WHILE p # 0 DO (*substructure*)
q := gn[p].next; gn[p].next := -gL2; p := q
END;
gR1 := gR2
END ConcatSeq;
PROCEDURE MakeFirstAlt*(VAR gL, gR: INTEGER);
BEGIN
gL := NewNode(alt, gL, 0); gn[gL].next := gR; gR := gL
END MakeFirstAlt;
PROCEDURE MakeIteration*(VAR gL, gR: INTEGER);
VAR p, q: INTEGER;
BEGIN
gL := NewNode(iter, gL, 0); p := gR; gR := gL;
WHILE p # 0 DO
q := gn[p].next; gn[p].next := - gL; p := q
END
END MakeIteration;
PROCEDURE MakeOption*(VAR gL, gR: INTEGER);
BEGIN
gL := NewNode(opt, gL, 0); gn[gL].next := gR; gR := gL
END MakeOption;
PROCEDURE StrToGraph*(str: ARRAY OF CHAR; VAR gL, gR: INTEGER);
VAR len, i: INTEGER;
BEGIN
gR := 0; i := 1; len := Length(str) - 1;
WHILE i < len DO
gn[gR].next := NewNode(char, ORD(str[i]), 0); gR := gn[gR].next;
INC(i)
END;
gL := gn[0].next; gn[0].next := 0
END StrToGraph;
PROCEDURE DelNode*(gn: GraphNode): BOOLEAN;
VAR sn: SymbolNode;
PROCEDURE DelAlt(gp: INTEGER): BOOLEAN;
VAR gn: GraphNode;
BEGIN
IF gp <= 0 THEN RETURN TRUE END; (*end of graph found*)
GetNode(gp, gn);
RETURN DelNode(gn) & DelAlt(gn.next);
END DelAlt;
BEGIN
IF gn.typ = nt THEN GetSym(gn.p1, sn); RETURN sn.deletable
ELSIF gn.typ = alt THEN RETURN DelAlt(gn.p1) OR (gn.p2 # 0) & DelAlt(gn.p2)
ELSE RETURN gn.typ IN {eps, iter, opt, sem, sync}
END
END DelNode;
PROCEDURE PrintGraph*;
VAR i: INTEGER;
PROCEDURE WriteTyp(typ: INTEGER);
BEGIN
CASE typ OF
| nt : Str("nt ")
| t : Str("t ")
| wt : Str("wt ")
| any : Str("any ")
| eps : Str("eps ")
| sem : Str("sem ")
| sync: Str("sync")
| alt : Str("alt ")
| iter: Str("iter")
| opt : Str("opt ")
ELSE Str("--- ")
END;
END WriteTyp;
BEGIN (* PrintGraph *)
Str("GraphList:"); NL; NL;
Str(" nr typ next p1 p2 line"); NL; NL;
i := 0;
WHILE i <= nNodes DO
Texts.WriteInt(w, i, 3); Str(" ");
WriteTyp(gn[i].typ); Texts.WriteInt(w, gn[i].next, 7);
Texts.WriteInt(w, gn[i].p1, 7);
Texts.WriteInt(w, gn[i].p2, 7);
Texts.WriteInt(w, gn[i].line, 7);
NL;
INC(i);
END;
NL; NL; Texts.Append(Oberon.Log, w.buf)
END PrintGraph;
PROCEDURE FindCircularProductions* (VAR ok: BOOLEAN);
CONST maxList = 150;
TYPE ListEntry = RECORD
left : INTEGER;
right : INTEGER;
deleted: BOOLEAN;
END;
VAR changed, onLeftSide, onRightSide: BOOLEAN; i, j, listLength: INTEGER;
list: ARRAY maxList OF ListEntry;
singles: MarkList;
sn: SymbolNode;
PROCEDURE GetSingles (gp: INTEGER; VAR singles: MarkList);
VAR gn: GraphNode;
BEGIN
IF gp <= 0 THEN RETURN END; (* end of graph found *)
GetNode (gp, gn);
IF gn.typ = nt THEN
IF DelGraph(ABS(gn.next)) THEN Sets.Incl(singles, gn.p1) END
ELSIF gn.typ IN {alt, iter, opt} THEN
IF DelGraph(ABS(gn.next)) THEN
GetSingles(gn.p1, singles);
IF gn.typ = alt THEN GetSingles(gn.p2, singles) END
END
END;
IF DelNode(gn) THEN GetSingles(gn.next, singles) END
END GetSingles;
BEGIN (* FindCircularProductions *)
i := firstNt; listLength := 0;
WHILE i <= lastNt DO (* for all nonterminals i *)
ClearMarkList (singles); GetSym (i, sn);
GetSingles (sn.struct, singles); (* get nt's j such that i-->j *)
j := firstNt;
WHILE j <= lastNt DO (* for all nonterminals j *)
IF Sets.In(singles, j) THEN
list[listLength].left := i; list[listLength].right := j;
list[listLength].deleted := FALSE;
INC (listLength)
END;
INC(j)
END;
INC(i)
END;
REPEAT
i := 0; changed := FALSE;
WHILE i < listLength DO
IF ~ list[i].deleted THEN
j := 0; onLeftSide := FALSE; onRightSide := FALSE;
WHILE j < listLength DO
IF ~ list[j].deleted THEN
IF list[i].left = list[j].right THEN onRightSide := TRUE END;
IF list[j].left = list[i].right THEN onLeftSide := TRUE END
END;
INC(j)
END;
IF ~ onRightSide OR ~ onLeftSide THEN
list[i].deleted := TRUE; changed := TRUE
END
END;
INC(i)
END
UNTIL ~ changed;
i := 0; ok := TRUE;
WHILE i < listLength DO
IF ~ list[i].deleted THEN
ok := FALSE;
GetSym(list[i].left, sn); NL; Str(" "); Str(sn.name); Str(" --> ");
GetSym(list[i].right, sn); Str(sn.name)
END;
INC(i)
END;
Texts.Append(Oberon.Log, w.buf)
END FindCircularProductions;
PROCEDURE LL1Test* (VAR ll1: BOOLEAN);
VAR sn: SymbolNode; curSy: INTEGER;
PROCEDURE LL1Error (cond, ts: INTEGER);
VAR sn: SymbolNode;
BEGIN
ll1 := FALSE;
GetSym (curSy, sn); Str(" LL1 error in "); Str(sn.name); Str(": ");
IF ts > 0 THEN GetSym (ts, sn); Str(sn.name); Str(" is ") END;
CASE cond OF
1: Str(" start of several alternatives.")
| 2: Str(" start & successor of deletable structure")
| 3: Str(" an ANY node that matchs no symbol")
END;
NL; Texts.Append(Oberon.Log, w.buf)
END LL1Error;
PROCEDURE Check (cond: INTEGER; VAR s1, s2: Set);
VAR i: INTEGER;
BEGIN
i := 0;
WHILE i <= maxT DO
IF Sets.In(s1, i) & Sets.In(s2, i) THEN LL1Error(cond, i) END;
INC(i)
END
END Check;
PROCEDURE CheckAlternatives (gp: INTEGER);
VAR gn, gn1: GraphNode; s1, s2: Set; p: INTEGER;
BEGIN
WHILE gp > 0 DO
GetNode(gp, gn);
IF gn.typ = alt THEN
p := gp; Sets.Clear(s1);
WHILE p # 0 DO (*for all alternatives*)
GetNode(p, gn1); CompExpected(gn1.p1, curSy, s2);
Check(1, s1, s2); Sets.Unite(s1, s2);
CheckAlternatives(gn1.p1);
p := gn1.p2
END
ELSIF gn.typ IN {opt, iter} THEN
CompExpected(gn.p1, curSy, s1);
CompExpected(ABS(gn.next), curSy, s2);
Check(2, s1, s2);
CheckAlternatives(gn.p1)
ELSIF gn.typ = any THEN
GetSet(gn.p1, s1);
IF Sets.Empty(s1) THEN LL1Error(3, 0) END (*e.g. {ANY} ANY or [ANY] ANY*)
END;
gp := gn.next
END
END CheckAlternatives;
BEGIN (* LL1Test *)
curSy := firstNt; ll1 := TRUE;
WHILE curSy <= lastNt DO (*for all nonterminals*)
GetSym(curSy, sn); CheckAlternatives (sn.struct);
INC (curSy)
END;
END LL1Test;
PROCEDURE TestCompleteness* (VAR ok: BOOLEAN);
VAR sp: INTEGER; sn: SymbolNode;
BEGIN
sp := firstNt; ok := TRUE;
WHILE sp <= lastNt DO (*for all nonterminals*)
GetSym (sp, sn);
IF sn.struct = 0 THEN
ok := FALSE; NL; Str(" No production for "); Str(sn.name); Texts.Append(Oberon.Log, w.buf)
END;
INC(sp)
END
END TestCompleteness;
PROCEDURE TestIfAllNtReached* (VAR ok: BOOLEAN);
VAR gn: GraphNode; sp: INTEGER; reached: MarkList; sn: SymbolNode;
PROCEDURE MarkReachedNts (gp: INTEGER);
VAR gn: GraphNode; sn: SymbolNode;
BEGIN
WHILE gp > 0 DO
GetNode(gp, gn);
IF gn.typ = nt THEN
IF ~ Sets.In(reached, gn.p1) THEN (*new nt reached*)
Sets.Incl(reached, gn.p1);
GetSym(gn.p1, sn); MarkReachedNts(sn.struct)
END
ELSIF gn.typ IN {alt, iter, opt} THEN
MarkReachedNts(gn.p1);
IF gn.typ = alt THEN MarkReachedNts(gn.p2) END
END;
gp := gn.next
END
END MarkReachedNts;
BEGIN (* TestIfAllNtReached *)
ClearMarkList(reached);
GetNode(root, gn); Sets.Incl(reached, gn.p1);
GetSym(gn.p1, sn); MarkReachedNts(sn.struct);
sp := firstNt; ok := TRUE;
WHILE sp <= lastNt DO (*for all nonterminals*)
IF ~ Sets.In(reached, sp) THEN
ok := FALSE; GetSym(sp, sn); NL; Str(" "); Str(sn.name); Str(" cannot be reached")
END;
INC(sp)
END;
Texts.Append(Oberon.Log, w.buf)
END TestIfAllNtReached;
PROCEDURE TestIfNtToTerm* (VAR ok: BOOLEAN);
VAR changed: BOOLEAN; gn: GraphNode; sp: INTEGER;
sn: SymbolNode;
termList: MarkList;
PROCEDURE IsTerm (gp: INTEGER): BOOLEAN;
VAR gn: GraphNode;
BEGIN
WHILE gp > 0 DO
GetNode(gp, gn);
IF (gn.typ = nt) & ~ Sets.In(termList, gn.p1)
OR (gn.typ = alt) & ~ IsTerm(gn.p1) & ~ IsTerm(gn.p2) THEN RETURN FALSE
END;
gp := gn.next
END;
RETURN TRUE
END IsTerm;
BEGIN (* TestIfNtToTerm *)
ClearMarkList(termList);
REPEAT
sp := firstNt; changed := FALSE;
WHILE sp <= lastNt DO
IF ~ Sets.In(termList, sp) THEN
GetSym(sp, sn);
IF IsTerm(sn.struct) THEN Sets.Incl(termList, sp); changed := TRUE END
END;
INC(sp)
END
UNTIL ~changed;
sp := firstNt; ok := TRUE;
WHILE sp <= lastNt DO
IF ~ Sets.In(termList, sp) THEN
ok := FALSE; GetSym(sp, sn); NL; Str(" "); Str(sn.name); Str(" cannot be derived to terminals")
END;
INC(sp)
END;
Texts.Append(Oberon.Log, w.buf)
END TestIfNtToTerm;
PROCEDURE Init*;
BEGIN
maxSet := 0; Sets.Clear(set[0]); Sets.Incl(set[0], eofSy);
firstNt := maxSymbols; maxP := maxSymbols; maxT := -1; maxC := -1;
lastNt := maxP - 1;
dummyName := 0;
nNodes := 0
END Init;
BEGIN (* CRT *)
(* The dummy node gn[0] ensures that none of the procedures
above have to check for 0 indices. *)
nNodes := 0;
gn[0].typ := -1; gn[0].p1 := 0; gn[0].p2 := 0; gn[0].next := 0; gn[0].line := 0;
Texts.OpenWriter(w)
END CRT.

474
src/tools/coco/CRX.Mod Normal file
View file

@ -0,0 +1,474 @@
MODULE CRX; (* H.Moessenboeck 17.11.93 *)
IMPORT Oberon, Texts := CmdlnTexts, Sets, CRS, CRT, SYSTEM;
CONST
symSetSize = 100;
maxTerm = 3; (* sets of size < maxTerm are enumerated *)
tErr = 0; altErr = 1; syncErr = 2;
EOL = 0DX;
VAR
maxSS: INTEGER; (* number of symbol sets *)
errorNr: INTEGER; (* highest parser error number *)
curSy: INTEGER; (* symbol whose production is currently generated *)
err, w: Texts.Writer;
fram: Texts.Reader;
src: Texts.Reader;
syn: Texts.Writer;
scanner: ARRAY 32 OF CHAR;
symSet: ARRAY symSetSize OF CRT.Set;
PROCEDURE Restriction(n: INTEGER);
BEGIN
Texts.WriteLn(w); Texts.WriteString(w, "Restriction ");
Texts.WriteInt(w, n, 0); Texts.WriteLn(w); Texts.Append(Oberon.Log, w.buf);
HALT(99)
END Restriction;
PROCEDURE PutS(s: ARRAY OF CHAR);
VAR i: INTEGER;
BEGIN i := 0;
WHILE (i < LEN(s)) & (s[i] # 0X) DO
IF s[i] = "$" THEN Texts.WriteLn(syn) ELSE Texts.Write(syn, s[i]) END;
INC(i)
END
END PutS;
PROCEDURE PutI(i: INTEGER);
BEGIN Texts.WriteInt(syn, i, 0)
END PutI;
PROCEDURE Indent(n: INTEGER);
VAR i: INTEGER;
BEGIN i := 0; WHILE i < n DO Texts.Write(syn, " "); INC(i) END
END Indent;
PROCEDURE PutSet(s: SET);
VAR i: INTEGER; first: BOOLEAN;
BEGIN
i := 0; first := TRUE;
WHILE i < Sets.size DO
IF i IN s THEN
IF first THEN first := FALSE ELSE Texts.Write(syn, ",") END;
PutI(i)
END;
INC(i)
END
END PutSet;
PROCEDURE PutSet1(s: CRT.Set);
VAR i: INTEGER; first: BOOLEAN;
BEGIN
i := 0; first := TRUE;
WHILE i <= CRT.maxT DO
IF Sets.In(s, i) THEN
IF first THEN first := FALSE ELSE Texts.Write(syn, ",") END;
PutI(i)
END;
INC(i)
END
END PutSet1;
PROCEDURE Length*(s: ARRAY OF CHAR): INTEGER;
VAR i: INTEGER;
BEGIN
i:=0; WHILE (i < LEN(s)) & (s[i] # 0X) DO INC(i) END;
RETURN i
END Length;
PROCEDURE Alternatives(gp: INTEGER): INTEGER;
VAR gn: CRT.GraphNode; n: INTEGER;
BEGIN
n := 0;
WHILE gp > 0 DO
CRT.GetNode(gp, gn); gp := gn.p2; INC(n)
END;
RETURN n
END Alternatives;
PROCEDURE CopyFramePart (stopStr: ARRAY OF CHAR); (*Copy from file <fram> to file <syn> until <stopStr>*)
VAR ch, startCh: CHAR; i, j, high: INTEGER;
BEGIN
startCh := stopStr[0]; high := Length(stopStr) - 1; Texts.Read (fram, ch);
WHILE ch # 0X DO
IF ch = startCh THEN (* check if stopString occurs *)
i := 0;
REPEAT
IF i = high THEN RETURN END; (*stopStr[0..i] found; no unrecognized character*)
Texts.Read (fram, ch); INC(i);
UNTIL ch # stopStr[i];
(*stopStr[0..i-1] found; 1 unrecognized character*)
j := 0; WHILE j < i DO Texts.Write(syn, stopStr[j]); INC(j) END
ELSE Texts.Write (syn, ch); Texts.Read(fram, ch)
END
END
END CopyFramePart;
PROCEDURE CopySourcePart (pos: CRT.Position; indent: INTEGER);
(*Copy sequence <position> from <src> to <syn>*)
VAR ch: CHAR; i: INTEGER; nChars: LONGINT; r: Texts.Reader;
BEGIN
IF (pos.beg >= 0) & (pos.len > 0) THEN
Texts.OpenReader(r, CRS.src, pos.beg); Texts.Read(r, ch);
nChars := pos.len - 1;
Indent(indent);
LOOP
WHILE ch = EOL DO
Texts.WriteLn(syn); Indent(indent);
IF nChars > 0 THEN Texts.Read(r, ch); DEC(nChars) ELSE EXIT END;
i := pos.col;
WHILE (ch = " ") & (i > 0) DO (* skip blanks at beginning of line *)
IF nChars > 0 THEN Texts.Read(r, ch); DEC (nChars) ELSE EXIT END;
DEC(i)
END
END;
Texts.Write (syn, ch);
IF nChars > 0 THEN Texts.Read(r, ch); DEC (nChars) ELSE EXIT END
END
END
(* IF pos.beg >= 0 THEN
Texts.OpenReader(r, CRS.src, pos.beg);
nChars := pos.len; col := pos.col - 1; ch := " ";
WHILE (nChars > 0) & (ch = " ") DO (*skip leading blanks*)
Texts.Read(r, ch); DEC(nChars); INC(col)
END;
Indent(indent);
LOOP
WHILE ch = EOL DO
Texts.WriteLn(syn); Indent(indent);
IF nChars > 0 THEN Texts.Read(r, ch); DEC(nChars) ELSE EXIT END;
i := col - 1;
WHILE (ch = " ") & (i > 0) DO (* skip blanks at beginning of line *)
IF nChars > 0 THEN Texts.Read(r, ch); DEC (nChars) ELSE EXIT END;
DEC(i)
END
END;
Texts.Write (syn, ch);
IF nChars > 0 THEN Texts.Read(r, ch); DEC (nChars) ELSE EXIT END
END (* LOOP *)
END *)
END CopySourcePart;
PROCEDURE GenErrorMsg (errTyp, errSym: INTEGER; VAR errNr: INTEGER);
VAR i: INTEGER; name: ARRAY 32 OF CHAR; sn: CRT.SymbolNode;
BEGIN
INC (errorNr); errNr := errorNr;
CRT.GetSym (errSym, sn); COPY(sn.name, name);
i := 0; WHILE name[i] # 0X DO IF name[i] = CHR(34) THEN name[i] := "'" END; INC(i) END;
Texts.WriteString(err, " |");
Texts.WriteInt (err, errNr, 3); Texts.WriteString (err, ": Msg("); Texts.Write(err, CHR(34));
CASE errTyp OF
| tErr : Texts.WriteString (err, name); Texts.WriteString (err, " expected")
| altErr : Texts.WriteString (err, "invalid "); Texts.WriteString (err, name)
| syncErr: Texts.WriteString (err, "this symbol not expected in "); Texts.WriteString (err, name)
END;
Texts.Write(err, CHR(34)); Texts.Write(err, ")"); Texts.WriteLn(err)
END GenErrorMsg;
PROCEDURE NewCondSet (set: CRT.Set): INTEGER;
VAR i: INTEGER;
BEGIN
i := 1; (*skip symSet[0]*)
WHILE i <= maxSS DO
IF Sets.Equal(set, symSet[i]) THEN RETURN i END;
INC(i)
END;
INC(maxSS); IF maxSS > symSetSize THEN Restriction (9) END;
symSet[maxSS] := set;
RETURN maxSS
END NewCondSet;
PROCEDURE GenCond (set: CRT.Set);
VAR sx, i, n: INTEGER;
PROCEDURE Small(s: CRT.Set): BOOLEAN;
BEGIN
i := Sets.size;
WHILE i <= CRT.maxT DO
IF Sets.In(set, i) THEN RETURN FALSE END;
INC(i)
END;
RETURN TRUE
END Small;
BEGIN
n := Sets.Elements(set, i);
(*IF n = 0 THEN PutS(" FALSE") (*this branch should never be taken*)
ELSIF (n > 1) & Small(set) THEN
PutS(" sym IN {"); PutSet(set[0]); PutS("} ")
ELSIF n <= maxTerm THEN
i := 0;
WHILE i <= CRT.maxT DO
IF Sets.In (set, i) THEN
PutS(" (sym = "); PutI(i); Texts.Write(syn, ")");
DEC(n); IF n > 0 THEN PutS(" OR") END
END;
INC(i)
END
ELSE PutS(" sym IN symSet["); PutI(NewCondSet(set)); PutS(",0]")
END;*)
IF n = 0 THEN PutS(" FALSE") (*this branch should never be taken*)
ELSIF n <= maxTerm THEN
i := 0;
WHILE i <= CRT.maxT DO
IF Sets.In (set, i) THEN
PutS(" (sym = "); PutI(i); Texts.Write(syn, ")");
DEC(n); IF n > 0 THEN PutS(" OR") END
END;
INC(i)
END
ELSE PutS(" StartOf("); PutI(NewCondSet(set)); PutS(") ")
END;
END GenCond;
PROCEDURE GenCode (gp, indent: INTEGER; checked: CRT.Set);
VAR gn, gn2: CRT.GraphNode; sn: CRT.SymbolNode; gp2: INTEGER;
s1, s2: CRT.Set; errNr, alts: INTEGER; equal: BOOLEAN;
BEGIN
WHILE gp > 0 DO
CRT.GetNode (gp, gn);
CASE gn.typ OF
| CRT.nt:
Indent(indent);
CRT.GetSym(gn.p1, sn); PutS(sn.name);
IF gn.pos.beg >= 0 THEN
Texts.Write(syn, "("); CopySourcePart(gn.pos, 0); Texts.Write(syn, ")")
END;
PutS(";$")
| CRT.t:
CRT.GetSym(gn.p1, sn); Indent(indent);
IF Sets.In(checked, gn.p1) THEN
PutS("Get;$")
ELSE
PutS("Expect("); PutI(gn.p1); PutS(");$")
END
| CRT.wt:
CRT.CompExpected(ABS(gn.next), curSy, s1);
CRT.GetSet(0, s2); Sets.Unite(s1, s2);
CRT.GetSym(gn.p1, sn); Indent(indent);
PutS("ExpectWeak("); PutI(gn.p1); PutS(", "); PutI(NewCondSet(s1)); PutS(");$")
| CRT.any:
Indent(indent); PutS("Get;$")
| CRT.eps: (* nothing *)
| CRT.sem:
CopySourcePart(gn.pos, indent); PutS(";$");
| CRT.sync:
CRT.GetSet(gn.p1, s1);
GenErrorMsg (syncErr, curSy, errNr);
Indent(indent);
PutS("WHILE ~("); GenCond(s1); PutS(") DO Error(");
PutI(errNr); PutS("); Get END;$")
| CRT.alt:
CRT.CompFirstSet(gp, s1); equal := Sets.Equal(s1, checked);
alts := Alternatives(gp);
IF alts > 5 THEN Indent(indent); PutS("CASE sym OF$") END;
gp2 := gp;
WHILE gp2 # 0 DO
CRT.GetNode(gp2, gn2);
CRT.CompExpected(gn2.p1, curSy, s1);
Indent(indent);
IF alts > 5 THEN PutS("| "); PutSet1(s1); PutS(": ") (*case labels*)
ELSIF gp2 = gp THEN PutS("IF"); GenCond(s1); PutS(" THEN$")
ELSIF (gn2.p2 = 0) & equal THEN PutS("ELSE$")
ELSE PutS("ELSIF"); GenCond(s1); PutS(" THEN$")
END;
Sets.Unite(s1, checked);
GenCode(gn2.p1, indent + 2, s1);
gp2 := gn2.p2
END;
IF ~ equal THEN
GenErrorMsg(altErr, curSy, errNr);
Indent(indent); PutS("ELSE Error("); PutI(errNr); PutS(")$")
END;
Indent(indent); PutS("END;$")
| CRT.iter:
CRT.GetNode(gn.p1, gn2);
Indent(indent); PutS("WHILE");
IF gn2.typ = CRT.wt THEN
CRT.CompExpected(ABS(gn2.next), curSy, s1);
CRT.CompExpected(ABS(gn.next), curSy, s2);
CRT.GetSym(gn2.p1, sn);
PutS(" WeakSeparator("); PutI(gn2.p1); PutS(", "); PutI(NewCondSet(s1));
PutS(", "); PutI(NewCondSet(s2)); PutS(") ");
Sets.Clear(s1); (*for inner structure*)
IF gn2.next > 0 THEN gp2 := gn2.next ELSE gp2 := 0 END
ELSE
gp2 := gn.p1; CRT.CompFirstSet(gp2, s1); GenCond(s1)
END;
PutS(" DO$");
GenCode(gp2, indent + 2, s1);
Indent(indent); PutS("END;$")
| CRT.opt:
CRT.CompFirstSet(gn.p1, s1);
IF ~ Sets.Equal(checked, s1) THEN
Indent(indent); PutS("IF"); GenCond(s1); PutS(" THEN$");
GenCode(gn.p1, indent + 2, s1);
Indent(indent); PutS("END;$")
ELSE GenCode(gn.p1, indent, checked)
END
END; (*CASE*)
IF ~ (gn.typ IN {CRT.eps, CRT.sem, CRT.sync}) THEN Sets.Clear(checked) END;
gp := gn.next
END
END GenCode;
PROCEDURE GenCodePragmas;
VAR i, p: INTEGER; sn: CRT.SymbolNode;
PROCEDURE P(s1, s2: ARRAY OF CHAR);
BEGIN
PutS(" "); PutS(scanner); PutS(s1); PutS(" := "); PutS(scanner); PutS(s2); PutS(";$")
END P;
BEGIN
i := CRT.maxT + 1;
WHILE i <= CRT.maxP DO
CRT.GetSym(i, sn);
PutS(" IF sym = "); PutI(i); PutS(" THEN$"); CopySourcePart(sn.semPos, 9); PutS("$ END;$");
INC(i)
END;
P(".nextPos", ".pos"); P(".nextCol", ".col"); P(".nextLine", ".line"); P(".nextLen", ".len")
END GenCodePragmas;
PROCEDURE GenProcedureHeading (sn: CRT.SymbolNode; forward: BOOLEAN);
BEGIN
PutS("PROCEDURE ");
IF forward THEN Texts.Write(syn, "^") END;
PutS(sn.name);
IF sn.attrPos.beg >= 0 THEN
Texts.Write(syn, "("); CopySourcePart(sn.attrPos, 0); Texts.Write(syn, ")")
END;
PutS(";$")
END GenProcedureHeading;
PROCEDURE GenForwardRefs;
VAR sp: INTEGER; sn: CRT.SymbolNode;
BEGIN
IF ~ CRT.ddt[5] THEN
sp := CRT.firstNt;
WHILE sp <= CRT.lastNt DO (* for all nonterminals *)
CRT.GetSym (sp, sn); GenProcedureHeading(sn, TRUE);
INC(sp)
END;
Texts.WriteLn(syn)
END
END GenForwardRefs;
PROCEDURE GenProductions;
VAR sn: CRT.SymbolNode; checked: CRT.Set;
BEGIN
curSy := CRT.firstNt;
WHILE curSy <= CRT.lastNt DO (* for all nonterminals *)
CRT.GetSym (curSy, sn); GenProcedureHeading (sn, FALSE);
IF sn.semPos.beg >= 0 THEN CopySourcePart(sn.semPos, 2); PutS(" $") END;
PutS("BEGIN$"); Sets.Clear(checked);
GenCode (sn.struct, 2, checked);
PutS("END "); PutS(sn.name); PutS(";$$");
INC (curSy);
END;
END GenProductions;
PROCEDURE InitSets;
VAR i, j: INTEGER;
BEGIN
i := 0; CRT.GetSet(0, symSet[0]);
WHILE i <= maxSS DO
j := 0;
WHILE j <= CRT.maxT DIV Sets.size DO
PutS(" symSet["); PutI(i); PutS(", ");PutI(j);
PutS("] := {"); PutSet(symSet[i, j]); PutS("};$");
INC(j)
END;
INC(i)
END
END InitSets;
PROCEDURE *Show(t: Texts.Text; op: INTEGER; beg, end: LONGINT);
BEGIN END Show;
PROCEDURE GenCompiler*;
VAR errNr, i: INTEGER; checked: CRT.Set;
gn: CRT.GraphNode; sn: CRT.SymbolNode;
parser: ARRAY 32 OF CHAR;
t: Texts.Text; pos: LONGINT;
ch1, ch2: CHAR;
BEGIN
CRT.GetNode(CRT.root, gn); CRT.GetSym(gn.p1, sn);
COPY(sn.name, parser); i := Length(parser); parser[i] := "P"; parser[i+1] := 0X;
COPY(parser, scanner); scanner[i] := "S";
NEW(t); Texts.Open(t, "Parser.FRM"); Texts.OpenReader(fram, t, 0);
IF t.len = 0 THEN
Texts.WriteString(w, "Parser.FRM not found"); Texts.WriteLn(w);
Texts.Append(Oberon.Log, w.buf); HALT(99)
END;
Texts.OpenWriter(err); Texts.WriteLn(err);
i := 0;
WHILE i <= CRT.maxT DO GenErrorMsg(tErr, i, errNr); INC(i) END;
(*----- write *P.Mod -----*)
Texts.OpenWriter(syn);
NEW(t); (*t.notify := Show;*) Texts.Open(t, "");
CopyFramePart("-->modulename"); PutS(parser);
CopyFramePart("-->scanner"); PutS(scanner);
IF CRT.importPos.beg >= 0 THEN PutS(", "); CopySourcePart(CRT.importPos, 0) END;
CopyFramePart("-->constants");
PutS("maxP = "); PutI(CRT.maxP); PutS(";$");
PutS(" maxT = "); PutI(CRT.maxT); PutS(";$");
PutS(" nrSets = ;$"); Texts.Append(t, syn.buf); pos := t.len - 2;
CopyFramePart("-->declarations"); CopySourcePart(CRT.semDeclPos, 0);
CopyFramePart("-->errors"); PutS(scanner); PutS(".Error(n, "); PutS(scanner); PutS(".nextPos)");
CopyFramePart("-->scanProc");
IF CRT.maxT = CRT.maxP THEN PutS(scanner); PutS(".Get(sym)")
ELSE
PutS("LOOP "); PutS(scanner); PutS(".Get(sym);$");
PutS(" IF sym > maxT THEN$");
GenCodePragmas;
PutS(" ELSE EXIT$");
PutS(" END$");
PutS("END$")
END;
CopyFramePart("-->productions"); GenForwardRefs; GenProductions;
CopyFramePart("-->parseRoot"); Sets.Clear(checked); GenCode (CRT.root, 2, checked);
CopyFramePart("-->initialization"); InitSets;
CopyFramePart("-->modulename"); PutS(parser); Texts.Write(syn, ".");
Texts.Append(t, syn.buf); Texts.Append(t, err.buf);
PutI(maxSS+1); (*if no set, maxSS = -1*) Texts.Insert(t, pos, syn.buf);
i := Length(parser); parser[i] := "."; parser[i+1] := "M"; parser[i+2] := "o"; parser[i+3] := "d"; parser[i+4] := 0X;
Texts.Close(t, parser)
END GenCompiler;
PROCEDURE WriteStatistics*;
BEGIN
Texts.WriteInt (w, CRT.maxT + 1, 0); Texts.WriteString(w, " t, ");
Texts.WriteInt (w, CRT.maxSymbols - CRT.firstNt + CRT.maxT + 1, 0); Texts.WriteString(w, " syms, ");
Texts.WriteInt (w, CRT.nNodes, 0); Texts.WriteString(w, " nodes, ");
Texts.WriteInt (w, maxSS, 0); Texts.WriteString(w, "sets");
Texts.WriteLn(w); Texts.Append(Oberon.Log, w.buf)
END WriteStatistics;
PROCEDURE Init*;
BEGIN
errorNr := -1; maxSS := 0 (*symSet[0] reserved for all SYNC sets*)
END Init;
BEGIN
Texts.OpenWriter(w)
END CRX.

180
src/tools/coco/Coco.Mod Normal file
View file

@ -0,0 +1,180 @@
(* Implementation restrictions
3 too many nodes in graph (>1500) CRG.NewNode
4 too many sets (ANY-symbols or SYNC symbols) CRT.NewAnySet,
CRT.ComputeSyncSet
6 too many symbols (>300) CRT.NewSym
7 too many character classes (>50) CRT.NewClass
9 too many conditions in generated code (>100) CRX.NewCondSet
Trace output (ddt settings: ${digit})
0 Prints states of automaton
1 Prints start symbols and followers of nonterminals (also option /s)
2 Prints the internal graph
3 Trace of start symbol set computation
4 Trace of follow set computation
5 suppresses FORWARD declarations in parser (for multipass compilers)
6 Prints the symbol list
7 Prints a cross reference list (also option /x)
8 Write statistics
==========================================================================*)
MODULE Coco;
IMPORT Oberon, (*TextFrames,*) Texts := CmdlnTexts,(* Viewers,*) CRS, CRP, CRT;
CONST minErrDist = 8;
VAR w: Texts.Writer; lastErrPos: LONGINT;
PROCEDURE Error (n: INTEGER; pos: LONGINT);
PROCEDURE Msg (s: ARRAY OF CHAR);
BEGIN Texts.WriteString(w, s)
END Msg;
BEGIN
INC(CRS.errors);
IF pos < lastErrPos + minErrDist THEN lastErrPos := pos; RETURN END;
lastErrPos := pos;
Texts.WriteInt(w, pos, 3); Texts.WriteString(w, ": ");
IF n < 200 THEN
CASE n OF
| 0: Msg("EOF expected")
| 1: Msg("ident expected")
| 2: Msg("string expected")
| 3: Msg("number expected")
| 4: Msg("'COMPILER' expected")
| 5: Msg("'IMPORT' expected")
| 6: Msg("';' expected")
| 7: Msg("'PRODUCTIONS' expected")
| 8: Msg("'=' expected")
| 9: Msg("'.' expected")
| 10: Msg("'END' expected")
| 11: Msg("'CHARACTERS' expected")
| 12: Msg("'TOKENS' expected")
| 13: Msg("'PRAGMAS' expected")
| 14: Msg("'COMMENTS' expected")
| 15: Msg("'FROM' expected")
| 16: Msg("'TO' expected")
| 17: Msg("'NESTED' expected")
| 18: Msg("'IGNORE' expected")
| 19: Msg("'CASE' expected")
| 20: Msg("'+' expected")
| 21: Msg("'-' expected")
| 22: Msg("'CHR' expected")
| 23: Msg("'(' expected")
| 24: Msg("')' expected")
| 25: Msg("'ANY' expected")
| 26: Msg("'|' expected")
| 27: Msg("'WEAK' expected")
| 28: Msg("'[' expected")
| 29: Msg("']' expected")
| 30: Msg("'{' expected")
| 31: Msg("'}' expected")
| 32: Msg("'SYNC' expected")
| 33: Msg("'CONTEXT' expected")
| 34: Msg("'<' expected")
| 35: Msg("'>' expected")
| 36: Msg("'(.' expected")
| 37: Msg("'.)' expected")
| 38: Msg("??? expected")
| 39: Msg("invalid TokenFactor")
| 40: Msg("invalid Factor")
| 41: Msg("invalid Factor")
| 42: Msg("invalid Term")
| 43: Msg("invalid Symbol")
| 44: Msg("invalid SimSet")
| 45: Msg("this symbol not expected in TokenDecl")
| 46: Msg("invalid TokenDecl")
| 47: Msg("invalid Declaration")
| 48: Msg("invalid Declaration")
| 49: Msg("invalid Declaration")
| 50: Msg("this symbol not expected in Coco")
| 51: Msg("invalid start of the program")
ELSE Texts.WriteString(w, "error "); Texts.WriteInt(w, n, 0)
END
ELSE
CASE n OF
| 201: Msg("unexpected end of file");
| 202: Msg("string terminator not on this line");
| 203: Msg("a literal must not have attributes");
| 204: Msg("this symbol kind not allowed in production");
| 205: Msg("symbol declared without attributes");
| 206: Msg("symbol declared with attributes");
| 207: Msg("name declared twice");
| 208: Msg("this type not allowed on left side of production");
| 209: Msg("symbol earlier referenced without attributes");
| 210: Msg("symbol earlier referenced with attributes");
| 211: Msg("missing production for grammar name");
| 212: Msg("grammar symbol must not have attributes");
| 213: Msg("a literal must not be declared with a structure")
| 214: Msg("semantic action not allowed here")
| 215: Msg("undefined name")
| 216: Msg("attributes not allowed in token declaration")
| 217: Msg("name does not match name in heading")
| 220: Msg("token may be empty")
| 221: Msg("token must not start with an iteration")
| 222: Msg("only characters allowed in comment declaration")
| 223: Msg("only terminals may be weak")
| 224:
| 225: Msg("comment delimiter must not exceed 2 characters")
| 226: Msg("character set contains more than one character")
ELSE Texts.WriteString(w, "error "); Texts.WriteInt(w, n, 0)
END
END;
Texts.WriteLn(w); Texts.Append(Oberon.Log, w.buf)
END Error;
PROCEDURE Options(VAR s: Texts.Scanner);
VAR i: INTEGER;
BEGIN
IF s.nextCh = "/" THEN Texts.Scan(s); Texts.Scan(s);
IF s.class = Texts.Name THEN i := 0;
WHILE s.s[i] # 0X DO
IF CAP(s.s[i]) = "X" THEN CRT.ddt[7] := TRUE
ELSIF CAP(s.s[i]) = "S" THEN CRT.ddt[1] := TRUE
END;
INC(i)
END
END
END;
END Options;
PROCEDURE Compile*;
VAR (*v: Viewers.Viewer;*)(* f: TextFrames.Frame; *) s: Texts.Scanner; src, t: Texts.Text;
pos, beg, end, time: LONGINT; i: INTEGER;
BEGIN
(* Texts.OpenScanner(s, Oberon.Par.text, Oberon.Par.pos); Texts.Scan(s);
f := Oberon.Par.frame(TextFrames.Frame);
src := NIL; pos := 0;
IF (s.class = Texts.Char) & (s.c = "^") THEN
Oberon.GetSelection(t, beg, end, time);
IF time >= 0 THEN Texts.OpenScanner(s, t, beg); Texts.Scan(s) END
END;*)
IF s.class = Texts.Name THEN
NEW(src); Texts.Open(src, s.s);
(*ELSIF (s.class = Texts.Char) & (s.c = "*") THEN
v := Oberon.MarkedViewer();
IF (v # NIL) & (v.dsc.next IS TextFrames.Frame) THEN
src := v.dsc.next(TextFrames.Frame).text;
Texts.OpenScanner(s, v.dsc(TextFrames.Frame).text, 0); Texts.Scan(s)
END
ELSIF (s.class = Texts.Char) & (s.c = "@") THEN
Oberon.GetSelection(t, beg, end, time);
IF time >= 0 THEN src := t; pos := beg; s.s := " " END*)
END;
IF src # NIL THEN
Texts.WriteString (w, "Coco/R - Compiler-Compiler V2.2"); Texts.Append(Oberon.Log, w.buf);
i := 0; WHILE i < 10 DO CRT.ddt[i] := FALSE; INC(i) END;
Options(s);
Texts.WriteLn(w); Texts.WriteString(w, s.s); Texts.Append(Oberon.Log, w.buf);
CRS.Reset(src, pos, Error); lastErrPos := -10;
CRP.Parse
END
END Compile;
BEGIN
Texts.OpenWriter(w);
Compile;
END Coco.

5
src/tools/coco/Coco.Report.ps.1 Normal file
View file

File diff suppressed because one or more lines are too long

83
src/tools/coco/Coco.Tool Normal file
View file

@ -0,0 +1,83 @@
Coco/R - the Oberon scanner and parser generator
For a complete documentation see the postscript file Coco.Report.ps.
Compiler.Compile
Sets.Mod CRS.Mod CRT.Mod CRA.Mod CRX.Mod CRP.Mod Coco.Mod ~
NOTE: the option character should be changed to "\" in Coco.Mod for Unix implementations.
Coco.Compile *
Coco.Compile ~
Coco.Compile ^
Coco.Compile @
(*________________________ usage ________________________*)
Coco.Compile <filename> [options]
The file CR.ATG is an example of an input file to Coco. If the grammar in the input file has the name X
the generated scanner has the name XS.Mod and the generated parser has the name XP.Mod.
Options:
/X generates a cross reference list of all syntax symbols
/S generates a list of all terminal start symbols and successors of nonterminal symbols.
Interface of the generated scanner:
DEFINITION XS;
IMPORT Texts;
TYPE
ErrorProc = PROCEDURE (n: INTEGER; pos: LONGINT);
VAR
Error: ErrorProc;
col, errors, len, line, nextCol, nextLen, nextLine: INTEGER;
nextPos, pos: LONGINT;
src: Texts.Text;
PROCEDURE Reset (t: Texts.Text; pos: LONGINT; errProc: ErrorProc);
PROCEDURE Get(VAR sym: INTEGER);
PROCEDURE GetName(pos: LONGINT; len: INTEGER; VAR name: ARRAY OF CHAR);
PROCEDURE StdErrorProc (n: INTEGER; pos: LONGINT);
END XS.
Interface of the generated parser:
DEFINITION XP;
PROCEDURE Parse;
END XP.
Example how to use the generated parts;
Texts.OpenScanner(s, Oberon.Par.Text, Oberon.Par.Pos); Texts.Scan(s);
IF s.class = Texts.Name THEN
NEW(text); Texts.Open(text, s.s);
XS.Reset(text, 0, MyErrorHandler);
XP.Parse;
END
Error handling in the generated parser:
The grammar has to contain hints, from which Coco can generate appropriate error handling.
The hints can be placed arbitrarily on the right-hand side of a production:
SYNC Denotes a synchronisation point. At such points symbols are skipped until a symbol
is found which is a legal continuation symbol at that point (or eof). SYNC is usually
placed at points where particularly "safe" symbols are expected, i.e., symbols that
are rarely missing or misspelled.
WEAK s s is an arbitrary terminal symbol (e.g., ";") which is considered "weak", because it is
frequently missing or misspelled (e.g., a semicolon between statements).
Example:
Statement =
SYNC
( ident WEAK ":=" Expression
| "IF" Expression "THEN" StatSeq ["ELSE" StatSeq] "END"
| "WHILE" Expression "DO" StatSeq "END"
).
StatSeq =
Statement { WEAK ";" Statement}.þ

8
src/tools/coco/Oberon.Mod Normal file
View file

@ -0,0 +1,8 @@
MODULE Oberon;
IMPORT Texts := CmdlnTexts;
VAR Log* : Texts.Text;
END Oberon.

65
src/tools/coco/Parser.FRM Normal file
View file

@ -0,0 +1,65 @@
(* parser module generated by Coco-R *)
MODULE -->modulename;
IMPORT -->scanner;
CONST
-->constants
setSize = 32; nSets = (maxT DIV setSize) + 1;
TYPE
SymbolSet = ARRAY nSets OF SET;
VAR
sym: INTEGER; (* current input symbol *)
symSet: ARRAY nrSets OF SymbolSet;
-->declarations
PROCEDURE Error (n: INTEGER);
BEGIN -->errors
END Error;
PROCEDURE Get;
BEGIN
-->scanProc
END Get;
PROCEDURE Expect(n: INTEGER);
BEGIN IF sym = n THEN Get ELSE Error(n) END
END Expect;
PROCEDURE StartOf(s: INTEGER): BOOLEAN;
BEGIN RETURN (sym MOD setSize) IN symSet[s, sym DIV setSize]
END StartOf;
PROCEDURE ExpectWeak(n, follow: INTEGER);
BEGIN
IF sym = n THEN Get
ELSE Error(n); WHILE ~ StartOf(follow) DO Get END
END
END ExpectWeak;
PROCEDURE WeakSeparator(n, syFol, repFol: INTEGER): BOOLEAN;
VAR s: SymbolSet; i: INTEGER;
BEGIN
IF sym = n THEN Get; RETURN TRUE
ELSIF StartOf(repFol) THEN RETURN FALSE
ELSE
i := 0; WHILE i < nSets DO s[i] := symSet[syFol, i] + symSet[repFol, i] + symSet[0, i]; INC(i) END;
Error(n); WHILE ~ ((sym MOD setSize) IN s[sym DIV setSize]) DO Get END;
RETURN StartOf(syFol)
END
END WeakSeparator;
-->productions
PROCEDURE Parse*;
BEGIN
Get;
-->parseRoot
END Parse;
BEGIN
-->initialization
END -->modulename.

103
src/tools/coco/Scanner.FRM Normal file
View file

@ -0,0 +1,103 @@
(* scanner module generated by Coco-R *)
MODULE -->modulename;
IMPORT Texts := CmdlnTexts, SYSTEM;
CONST
EOL = 0DX;
EOF = 0X;
maxLexLen = 127;
-->declarations
TYPE
ErrorProc* = PROCEDURE (n: INTEGER; pos: LONGINT);
StartTable = ARRAY 128 OF INTEGER;
VAR
src*: Texts.Text; (*source text. To be set by the main pgm*)
pos*: LONGINT; (*position of current symbol*)
line*, col*, len*: INTEGER; (*line, column, length of current symbol*)
nextPos*: LONGINT; (*position of lookahead symbol*)
nextLine*, nextCol*, nextLen*: INTEGER; (*line, column, length of lookahead symbol*)
errors*: INTEGER; (*number of errors detected*)
Error*: ErrorProc;
ch: CHAR; (*current input character*)
r: Texts.Reader; (*global reader*)
chPos: LONGINT; (*position of current character*)
chLine: INTEGER; (*current line number*)
lineStart: LONGINT; (*start position of current line*)
apx: INTEGER; (*length of appendix*)
oldEols: INTEGER; (*nr. of EOLs in a comment*)
start: StartTable; (*start state for every character*)
PROCEDURE NextCh; (*return global variable ch*)
BEGIN
Texts.Read(r, ch); INC(chPos);
IF ch = EOL THEN INC(chLine); lineStart := chPos + 1 END
END NextCh;
PROCEDURE Comment(): BOOLEAN;
VAR level, startLine: INTEGER; oldLineStart: LONGINT;
BEGIN (*Comment*)
level := 1; startLine := chLine; oldLineStart := lineStart;
-->comment
END Comment;
PROCEDURE Get*(VAR sym: INTEGER);
VAR state: INTEGER; lexeme: ARRAY maxLexLen+1 OF CHAR;
PROCEDURE CheckLiteral;
BEGIN
IF nextLen < maxLexLen THEN lexeme[nextLen] := 0X END;
-->literals
END CheckLiteral;
BEGIN
-->GetSy1
IF ch > 7FX THEN ch := " " END;
pos := nextPos; col := nextCol; line := nextLine; len := nextLen;
nextPos := chPos; nextCol := SHORT(chPos - lineStart); nextLine := chLine; nextLen := 0;
state := start[ORD(ch)]; apx := 0;
LOOP
IF nextLen < maxLexLen THEN lexeme[nextLen] := ch END;
INC(nextLen);
NextCh;
IF state > 0 THEN
CASE state OF
-->GetSy2
END (*CASE*)
ELSE sym := noSym; RETURN (*NextCh already done*)
END (*IF*)
END (*LOOP*)
END Get;
PROCEDURE GetName*(pos: LONGINT; len: INTEGER; VAR s: ARRAY OF CHAR);
VAR i: INTEGER; r: Texts.Reader;
BEGIN
Texts.OpenReader(r, src, pos);
IF len >= LEN(s) THEN len := SHORT(LEN(s)) - 1 END;
i := 0; WHILE i < len DO Texts.Read(r, s[i]); INC(i) END;
s[i] := 0X
END GetName;
PROCEDURE StdErrorProc* (n: INTEGER; pos: LONGINT);
BEGIN INC(errors) END StdErrorProc;
PROCEDURE Reset* (t: Texts.Text; pos: LONGINT; errProc: ErrorProc);
BEGIN
src := t; Error := errProc;
Texts.OpenReader(r, src, pos);
chPos := pos - 1; chLine := 1; lineStart := 0;
oldEols := 0; apx := 0; errors := 0;
NextCh
END Reset;
BEGIN
-->initialization
END -->modulename.

138
src/tools/coco/Sets.Mod Normal file
View file

@ -0,0 +1,138 @@
MODULE Sets;
IMPORT Texts := CmdlnTexts;
CONST size* = 32;
PROCEDURE Clear*(VAR s: ARRAY OF SET);
VAR i: INTEGER;
BEGIN
i := 0; WHILE i < LEN(s) DO s[i] := {}; INC(i) END
END Clear;
PROCEDURE Fill*(VAR s: ARRAY OF SET);
VAR i: INTEGER;
BEGIN
i := 0; WHILE i < LEN(s) DO s[i] := {0 .. size-1}; INC(i) END
END Fill;
PROCEDURE Incl*(VAR s: ARRAY OF SET; x: INTEGER);
BEGIN INCL(s[x DIV size], x MOD size)
END Incl;
PROCEDURE Excl*(VAR s: ARRAY OF SET; x: INTEGER);
BEGIN EXCL(s[x DIV size], x MOD size)
END Excl;
PROCEDURE In*(VAR s: ARRAY OF SET; x: INTEGER): BOOLEAN;
BEGIN RETURN x MOD size IN s[x DIV size]
END In;
PROCEDURE Includes*(VAR s1, s2: ARRAY OF SET): BOOLEAN;
VAR i: INTEGER;
BEGIN
i := 0;
WHILE i < LEN(s1) DO
IF s1[i] + s2[i] # s1[i] THEN RETURN FALSE END;
INC(i)
END;
RETURN TRUE;
END Includes;
PROCEDURE Elements*(VAR s: ARRAY OF SET; VAR lastElem: INTEGER): INTEGER;
VAR i, n, max: INTEGER;
BEGIN
i := 0; n := 0; max := SHORT(LEN(s)) * size;
WHILE i < max DO
IF (i MOD size) IN s[i DIV size] THEN INC(n); lastElem := i END;
INC(i)
END;
RETURN n
END Elements;
PROCEDURE Empty*(VAR s: ARRAY OF SET): BOOLEAN;
VAR i: INTEGER;
BEGIN
i := 0;
WHILE i < LEN(s) DO
IF s[i] # {} THEN RETURN FALSE END;
INC(i)
END;
RETURN TRUE
END Empty;
PROCEDURE Equal*(VAR s1, s2: ARRAY OF SET): BOOLEAN;
VAR i: INTEGER;
BEGIN
i := 0;
WHILE i < LEN(s1) DO
IF s1[i] # s2[i] THEN RETURN FALSE END;
INC(i)
END;
RETURN TRUE
END Equal;
PROCEDURE Different*(VAR s1, s2: ARRAY OF SET): BOOLEAN;
VAR i: INTEGER;
BEGIN
i := 0;
WHILE i < LEN(s1) DO
IF s1[i] * s2[i] # {} THEN RETURN FALSE END;
INC(i)
END;
RETURN TRUE
END Different;
PROCEDURE Unite*(VAR s1, s2: ARRAY OF SET);
VAR i: INTEGER;
BEGIN
i := 0; WHILE i < LEN(s1) DO s1[i] := s1[i] + s2[i]; INC(i) END
END Unite;
PROCEDURE Differ*(VAR s1, s2: ARRAY OF SET);
VAR i: INTEGER;
BEGIN
i := 0; WHILE i < LEN(s1) DO s1[i] := s1[i] - s2[i]; INC(i) END
END Differ;
PROCEDURE Intersect*(VAR s1, s2, s3: ARRAY OF SET);
VAR i: INTEGER;
BEGIN
i := 0; WHILE i < LEN(s1) DO s3[i] := s1[i] * s2[i]; INC(i) END
END Intersect;
PROCEDURE Print*(VAR f: Texts.Writer; s: ARRAY OF SET; w, indent: INTEGER);
VAR col, i, max: INTEGER;
BEGIN
i := 0; col := indent; max := SHORT(LEN(s)) * size;
Texts.Write(f, "{");
WHILE i < max DO
IF In(s, i) THEN
IF col + 4 > w THEN
Texts.WriteLn(f);
col := 0; WHILE col < indent DO Texts.Write(f, " "); INC(col) END
END;
Texts.WriteInt(f, i, 3); Texts.Write(f, ",");
INC(col, 4)
END;
INC(i)
END;
Texts.Write(f, "}")
END Print;
END Sets.

471
src/tools/coco/v4_compat/Oberon.Mod Executable file
View file

@ -0,0 +1,471 @@
MODULE Oberon; (*JG 6.9.90 / 23.9.93*)
IMPORT SYSTEM, Unix, Kernel, Modules, Input, Display, Fonts, Viewers, Texts, X11; (* << *)
CONST
(*message ids*)
consume* = 0; track* = 1;
defocus* = 0; neutralize* = 1; mark* = 2;
BasicCycle = 20;
ESC = 1BX; SETUP = 0A4X;
TYPE
Painter* = PROCEDURE (x, y: INTEGER);
Marker* = RECORD Fade*, Draw*: Painter END;
Cursor* = RECORD
marker*: Marker; on*: BOOLEAN; X*, Y*: INTEGER
END;
ParList* = POINTER TO ParRec;
ParRec* = RECORD
vwr*: Viewers.Viewer;
frame*: Display.Frame;
text*: Texts.Text;
pos*: LONGINT
END;
InputMsg* = RECORD (Display.FrameMsg)
id*: INTEGER;
keys*: SET;
X*, Y*: INTEGER;
ch*: CHAR;
fnt*: Fonts.Font;
col*, voff*: SHORTINT
END;
SelectionMsg* = RECORD (Display.FrameMsg)
time*: LONGINT;
text*: Texts.Text;
beg*, end*: LONGINT
END;
ControlMsg* = RECORD (Display.FrameMsg)
id*, X*, Y*: INTEGER
END;
CopyOverMsg* = RECORD (Display.FrameMsg)
text*: Texts.Text;
beg*, end*: LONGINT
END;
CopyMsg* = RECORD (Display.FrameMsg)
F*: Display.Frame
END;
Task* = POINTER TO TaskDesc;
Handler* = PROCEDURE;
TaskDesc* = RECORD
next: Task;
safe*: BOOLEAN;
time*: LONGINT;
handle*: Handler
END;
VAR
User*: ARRAY 12 OF CHAR; (* << *)
Arrow*, Star*: Marker;
Mouse*, Pointer*: Cursor;
FocusViewer*: Viewers.Viewer;
Log*: Texts.Text;
Par*: ParList; (*actual parameters*)
CurTask*, PrevTask: Task;
CurFnt*: Fonts.Font; CurCol*, CurOff*: SHORTINT;
Password*: LONGINT;
DW, DH, CL, H0, H1, H2, H3: INTEGER;
unitW: INTEGER;
ActCnt: INTEGER; (*action count for GC*)
Mod: Modules.Module;
ArrowFade: Painter; (* << *)
(*user identification*)
PROCEDURE Code(VAR s: ARRAY OF CHAR): LONGINT;
VAR i: INTEGER; a, b, c: LONGINT;
BEGIN
a := 0; b := 0; i := 0;
WHILE s[i] # 0X DO
c := b; b := a; a := (c MOD 509 + 1) * 127 + ORD(s[i]);
INC(i)
END;
IF b >= 32768 THEN b := b - 65536 END;
RETURN b * 65536 + a
END Code;
PROCEDURE SetUser* (VAR user, password: ARRAY OF CHAR);
BEGIN COPY(user, User); Password := Code(password)
END SetUser;
(*clocks*)
PROCEDURE GetClock* (VAR t, d: LONGINT);
BEGIN Kernel.GetClock(t, d)
END GetClock;
PROCEDURE SetClock* (t, d: LONGINT);
BEGIN Kernel.SetClock(t, d)
END SetClock;
PROCEDURE Time* (): LONGINT;
BEGIN RETURN Input.Time()
END Time;
(*cursor handling*)
PROCEDURE FlipArrow (X, Y: INTEGER); (* << *)
END FlipArrow;
PROCEDURE FlipStar (X, Y: INTEGER);
BEGIN
IF X < CL THEN
IF X < 7 THEN X := 7 ELSIF X > DW - 8 THEN X := DW - 8 END
ELSE
IF X < CL + 7 THEN X := CL + 7 ELSIF X > CL + DW - 8 THEN X := CL + DW - 8 END
END ;
IF Y < 7 THEN Y := 7 ELSIF Y > DH - 8 THEN Y := DH - 8 END;
Display.CopyPattern(Display.white, Display.star, X - 7, Y - 7, 2)
END FlipStar;
PROCEDURE OpenCursor* (VAR c: Cursor);
BEGIN c.on := FALSE; c.X := 0; c.Y := 0
END OpenCursor;
PROCEDURE FadeCursor* (VAR c: Cursor);
BEGIN IF c.on THEN c.marker.Fade(c.X, c.Y); c.on := FALSE END
END FadeCursor;
PROCEDURE DrawCursor* (VAR c: Cursor; VAR m: Marker; X, Y: INTEGER); (* << RC *)
BEGIN
IF c.on & ((X # c.X) OR (Y # c.Y) OR (m.Draw # c.marker.Draw)) THEN
c.marker.Fade(c.X, c.Y); c.on := FALSE
END;
IF c.marker.Fade = ArrowFade THEN
IF m.Fade # ArrowFade THEN X11.DefineCursor(X11.display, X11.primary, X11.noCursor) END
ELSE
IF m.Fade = ArrowFade THEN X11.DefineCursor(X11.display, X11.primary, X11.arrow) END
END ;
IF ~c.on THEN
m.Draw(X, Y); c.marker := m; c.X := X; c.Y := Y; c.on := TRUE
END
END DrawCursor;
(*display management*)
PROCEDURE RemoveMarks* (X, Y, W, H: INTEGER);
BEGIN
IF (Mouse.X > X - 16) & (Mouse.X < X + W + 16) & (Mouse.Y > Y - 16) & (Mouse.Y < Y + H + 16) THEN
FadeCursor(Mouse)
END;
IF (Pointer.X > X - 8) & (Pointer.X < X + W + 8) & (Pointer.Y > Y - 8) & (Pointer.Y < Y + H + 8) THEN
FadeCursor(Pointer)
END
END RemoveMarks;
PROCEDURE HandleFiller (V: Display.Frame; VAR M: Display.FrameMsg);
BEGIN
WITH V: Viewers.Viewer DO
IF M IS InputMsg THEN
WITH M: InputMsg DO
IF M.id = track THEN DrawCursor(Mouse, Arrow, M.X, M.Y) END
END;
ELSIF M IS ControlMsg THEN
WITH M: ControlMsg DO
IF M.id = mark THEN DrawCursor(Pointer, Star, M.X, M.Y) END
END
ELSIF M IS Viewers.ViewerMsg THEN
WITH M: Viewers.ViewerMsg DO
IF (M.id = Viewers.restore) & (V.W > 0) & (V.H > 0) THEN
RemoveMarks(V.X, V.Y, V.W, V.H);
Display.ReplConst(Display.black, V.X, V.Y, V.W, V.H, 0)
ELSIF (M.id = Viewers.modify) & (M.Y < V.Y) THEN
RemoveMarks(V.X, M.Y, V.W, V.Y - M.Y);
Display.ReplConst(Display.black, V.X, M.Y, V.W, V.Y - M.Y, 0)
END
END
END
END
END HandleFiller;
PROCEDURE OpenDisplay* (UW, SW, H: INTEGER);
VAR Filler: Viewers.Viewer;
BEGIN
Input.SetMouseLimits(Viewers.curW + UW + SW, H);
Display.ReplConst(Display.black, Viewers.curW, 0, UW + SW, H, 0);
NEW(Filler); Filler.handle := HandleFiller;
Viewers.InitTrack(UW, H, Filler); (*init user track*)
NEW(Filler); Filler.handle := HandleFiller;
Viewers.InitTrack(SW, H, Filler) (*init system track*)
END OpenDisplay;
PROCEDURE DisplayWidth* (X: INTEGER): INTEGER;
BEGIN RETURN DW
END DisplayWidth;
PROCEDURE DisplayHeight* (X: INTEGER): INTEGER;
BEGIN RETURN DH
END DisplayHeight;
PROCEDURE OpenTrack* (X, W: INTEGER);
VAR Filler: Viewers.Viewer;
BEGIN
NEW(Filler); Filler.handle := HandleFiller;
Viewers.OpenTrack(X, W, Filler)
END OpenTrack;
PROCEDURE UserTrack* (X: INTEGER): INTEGER;
BEGIN RETURN X DIV DW * DW
END UserTrack;
PROCEDURE SystemTrack* (X: INTEGER): INTEGER;
BEGIN RETURN X DIV DW * DW + DW DIV 8 * 5
END SystemTrack;
PROCEDURE UY (X: INTEGER): INTEGER;
VAR fil, bot, alt, max: Display.Frame;
BEGIN
Viewers.Locate(X, 0, fil, bot, alt, max);
IF fil.H >= DH DIV 8 THEN RETURN DH END;
RETURN max.Y + max.H DIV 2
END UY;
PROCEDURE AllocateUserViewer* (DX: INTEGER; VAR X, Y: INTEGER);
BEGIN
IF Pointer.on THEN X := Pointer.X; Y := Pointer.Y
ELSE X := DX DIV DW * DW; Y := UY(X)
END
END AllocateUserViewer;
PROCEDURE SY (X: INTEGER): INTEGER;
VAR fil, bot, alt, max: Display.Frame;
BEGIN
Viewers.Locate(X, DH, fil, bot, alt, max);
IF fil.H >= DH DIV 8 THEN RETURN DH END;
IF max.H >= DH - H0 THEN RETURN max.Y + H3 END;
IF max.H >= H3 - H0 THEN RETURN max.Y + H2 END;
IF max.H >= H2 - H0 THEN RETURN max.Y + H1 END;
IF max # bot THEN RETURN max.Y + max.H DIV 2 END;
IF bot.H >= H1 THEN RETURN bot.H DIV 2 END;
RETURN alt.Y + alt.H DIV 2
END SY;
PROCEDURE AllocateSystemViewer* (DX: INTEGER; VAR X, Y: INTEGER);
BEGIN
IF Pointer.on THEN X := Pointer.X; Y := Pointer.Y
ELSE X := DX DIV DW * DW + DW DIV 8 * 5; Y := SY(X)
END
END AllocateSystemViewer;
PROCEDURE MarkedViewer* (): Viewers.Viewer;
BEGIN RETURN Viewers.This(Pointer.X, Pointer.Y)
END MarkedViewer;
PROCEDURE PassFocus* (V: Viewers.Viewer);
VAR M: ControlMsg;
BEGIN M.id := defocus; FocusViewer.handle(FocusViewer, M); FocusViewer := V
END PassFocus;
(*command interpretation*)
PROCEDURE Call* (name: ARRAY OF CHAR; par: ParList; new: BOOLEAN; VAR res: INTEGER);
VAR Mod: Modules.Module; P: Modules.Command; i, j: INTEGER;
BEGIN res := 1;
i := 0; j := 0;
WHILE name[j] # 0X DO
IF name[j] = "." THEN i := j END;
INC(j)
END;
IF i > 0 THEN
name[i] := 0X;
Mod := Modules.ThisMod(name);
IF Modules.res = 0 THEN
INC(i); j := i;
WHILE name[j] # 0X DO name[j - i] := name[j]; INC(j) END;
name[j - i] := 0X;
P := Modules.ThisCommand(Mod, name);
IF Modules.res = 0 THEN
Par := par; Par.vwr := Viewers.This(par.frame.X, par.frame.Y); P; res := 0
ELSE res := -1
END
ELSE res := Modules.res
END
ELSE res := -1
END
END Call;
PROCEDURE GetSelection* (VAR text: Texts.Text; VAR beg, end, time: LONGINT);
VAR M: SelectionMsg;
BEGIN
M.time := -1; Viewers.Broadcast(M); time := M.time;
IF time >= 0 THEN text := M.text; beg := M.beg; end := M.end END
END GetSelection;
PROCEDURE GC;
BEGIN IF ActCnt <= 0 THEN Kernel.GC(FALSE); ActCnt := BasicCycle END
END GC;
PROCEDURE Install* (T: Task);
VAR t: Task;
BEGIN t := PrevTask;
WHILE (t.next # PrevTask) & (t.next # T) DO t := t.next END;
IF (t.next # T) & (CurTask # T) THEN
IF CurTask # NIL THEN (* called from a task *)
T.next := CurTask.next; CurTask.next := T
ELSE (* no task is currently running *)
T.next := PrevTask.next; PrevTask.next := T
END
END
END Install;
PROCEDURE Remove* (T: Task);
VAR t: Task;
BEGIN t := PrevTask;
WHILE (t.next # T) & (t.next # PrevTask) DO t := t.next END;
IF t.next = T THEN t.next := t.next.next; PrevTask := t.next END;
IF CurTask = T THEN CurTask := PrevTask.next END
END Remove;
PROCEDURE Collect* (count: INTEGER);
BEGIN ActCnt := count
END Collect;
PROCEDURE SetFont* (fnt: Fonts.Font);
BEGIN CurFnt := fnt
END SetFont;
PROCEDURE SetColor* (col: SHORTINT);
BEGIN CurCol := col
END SetColor;
PROCEDURE SetOffset* (voff: SHORTINT);
BEGIN CurOff := voff
END SetOffset;
PROCEDURE MinTime(): LONGINT; (* << *)
VAR minTime: LONGINT; t: Task;
BEGIN
minTime := MAX(LONGINT); t := PrevTask;
REPEAT
IF (t.time # -1) & (t.time < minTime) THEN minTime := t.time END ;
t := t.next;
UNTIL t = PrevTask ;
RETURN minTime
END MinTime;
PROCEDURE NotifyTasks; (* << *)
VAR t0, p: Task;
BEGIN t0 := PrevTask;
REPEAT
CurTask := PrevTask.next;
IF CurTask.time = -1 THEN
IF ~CurTask.safe THEN PrevTask.next := CurTask.next END;
p := CurTask; CurTask.handle; PrevTask.next := CurTask;
IF CurTask # p THEN RETURN END (*detect Remove(CurTask)*)
END;
PrevTask := CurTask
UNTIL CurTask = t0
END NotifyTasks;
PROCEDURE Loop*;
VAR V: Viewers.Viewer; M: InputMsg; N: ControlMsg;
prevX, prevY, X, Y: INTEGER; keys: SET; ch: CHAR;
VM: Viewers.ViewerMsg; i: INTEGER; res: LONGINT; (* << *)
BEGIN
res := Kernel.sigsetjmp(Kernel.trapEnv, 1); (* << *)
LOOP
CurTask := NIL;
Input.Mouse(keys, X, Y);
IF Input.Available() > 0 THEN Input.Read(ch);
IF ch < 0F0X THEN
IF ch = ESC THEN
N.id := neutralize; Viewers.Broadcast(N); FadeCursor(Pointer)
ELSIF ch = SETUP THEN
N.id := mark; N.X := X; N.Y := Y; V := Viewers.This(X, Y); V.handle(V, N)
ELSIF ch = 0CX THEN (* << *)
N.id := neutralize; Viewers.Broadcast(N); FadeCursor(Pointer);
VM.id := Viewers.suspend; Viewers.Broadcast(VM);
VM.id := Viewers.restore; Viewers.Broadcast(VM)
ELSE
M.id := consume; M.ch := ch; M.fnt := CurFnt; M.col := CurCol; M.voff := CurOff;
FocusViewer.handle(FocusViewer, M);
DEC(ActCnt); NotifyTasks
END
ELSIF ch = 0F1X THEN Display.SetMode(0, {})
ELSIF ch = 0F2X THEN Display.SetMode(0, {0})
ELSIF ch = 0F3X THEN Display.SetMode(0, {2})
ELSIF ch = 0F4X THEN X11.InitColors
ELSIF Kernel.FKey[ORD(ch) - 0F0H] # NIL THEN Kernel.FKey[ORD(ch) - 0F0H]
END
ELSIF keys # {} THEN
M.id := track; M.X := X; M.Y := Y; M.keys := keys;
REPEAT
V := Viewers.This(M.X, M.Y); V.handle(V, M);
Input.Mouse(M.keys, M.X, M.Y)
UNTIL M.keys = {};
DEC(ActCnt); NotifyTasks
ELSE
IF (X # prevX) OR (Y # prevY) OR ~Mouse.on THEN
M.id := track; M.X := X; M.Y := Y; M.keys := keys; V := Viewers.This(X, Y); V.handle(V, M);
prevX := X; prevY := Y
END;
X11.DoSync; (* << *)
IF X11.EventsQueued(X11.display, X11.QueuedAfterReading) = 0 THEN (* << *)
Kernel.Select(MinTime() - Input.Time()); NotifyTasks;
FOR i := 0 TO 7 DO Kernel.readySet[i] := {} END
END ;
CurTask := PrevTask.next;
IF (CurTask.time <= Input.Time()) & (CurTask.time # -1) THEN
IF ~CurTask.safe THEN PrevTask.next := CurTask.next END;
CurTask.handle; PrevTask.next := CurTask
END;
PrevTask := CurTask
END
END
END Loop;
BEGIN User[0] := 0X;
Arrow.Fade := FlipArrow; Arrow.Draw := FlipArrow;
ArrowFade := FlipArrow; (* << *)
Star.Fade := FlipStar; Star.Draw := FlipStar;
OpenCursor(Mouse); OpenCursor(Pointer);
DW := Display.Width; DH := Display.Height; CL := Display.ColLeft;
H3 := DH - DH DIV 3;
H2 := H3 - H3 DIV 2;
H1 := DH DIV 5;
H0 := DH DIV 10;
(* moved into Configuration.Mod
unitW := DW DIV 8;
OpenDisplay(unitW * 5, unitW * 3, DH);
FocusViewer := Viewers.This(0, 0);
*)
CurFnt := Fonts.Default;
CurCol := Display.white;
CurOff := 0;
Collect(BasicCycle);
NEW(PrevTask);
PrevTask.handle := GC;
PrevTask.safe := TRUE;
PrevTask.time := -1; (* << *)
PrevTask.next := PrevTask;
CurTask := NIL;
Display.SetMode(0, {});
END Oberon.

471
src/tools/coco/v4_compat/Oberon.Mod_orig Normal file
View file

@ -0,0 +1,471 @@
MODULE Oberon; (*JG 6.9.90 / 23.9.93*)
IMPORT SYSTEM, Unix, Kernel, Modules, Input, Display, Fonts, Viewers, Texts, X11; (* << *)
CONST
(*message ids*)
consume* = 0; track* = 1;
defocus* = 0; neutralize* = 1; mark* = 2;
BasicCycle = 20;
ESC = 1BX; SETUP = 0A4X;
TYPE
Painter* = PROCEDURE (x, y: INTEGER);
Marker* = RECORD Fade*, Draw*: Painter END;
Cursor* = RECORD
marker*: Marker; on*: BOOLEAN; X*, Y*: INTEGER
END;
ParList* = POINTER TO ParRec;
ParRec* = RECORD
vwr*: Viewers.Viewer;
frame*: Display.Frame;
text*: Texts.Text;
pos*: LONGINT
END;
InputMsg* = RECORD (Display.FrameMsg)
id*: INTEGER;
keys*: SET;
X*, Y*: INTEGER;
ch*: CHAR;
fnt*: Fonts.Font;
col*, voff*: SHORTINT
END;
SelectionMsg* = RECORD (Display.FrameMsg)
time*: LONGINT;
text*: Texts.Text;
beg*, end*: LONGINT
END;
ControlMsg* = RECORD (Display.FrameMsg)
id*, X*, Y*: INTEGER
END;
CopyOverMsg* = RECORD (Display.FrameMsg)
text*: Texts.Text;
beg*, end*: LONGINT
END;
CopyMsg* = RECORD (Display.FrameMsg)
F*: Display.Frame
END;
Task* = POINTER TO TaskDesc;
Handler* = PROCEDURE;
TaskDesc* = RECORD
next: Task;
safe*: BOOLEAN;
time*: LONGINT;
handle*: Handler
END;
VAR
User*: ARRAY 12 OF CHAR; (* << *)
Arrow*, Star*: Marker;
Mouse*, Pointer*: Cursor;
FocusViewer*: Viewers.Viewer;
Log*: Texts.Text;
Par*: ParList; (*actual parameters*)
CurTask*, PrevTask: Task;
CurFnt*: Fonts.Font; CurCol*, CurOff*: SHORTINT;
Password*: LONGINT;
DW, DH, CL, H0, H1, H2, H3: INTEGER;
unitW: INTEGER;
ActCnt: INTEGER; (*action count for GC*)
Mod: Modules.Module;
ArrowFade: Painter; (* << *)
(*user identification*)
PROCEDURE Code(VAR s: ARRAY OF CHAR): LONGINT;
VAR i: INTEGER; a, b, c: LONGINT;
BEGIN
a := 0; b := 0; i := 0;
WHILE s[i] # 0X DO
c := b; b := a; a := (c MOD 509 + 1) * 127 + ORD(s[i]);
INC(i)
END;
IF b >= 32768 THEN b := b - 65536 END;
RETURN b * 65536 + a
END Code;
PROCEDURE SetUser* (VAR user, password: ARRAY OF CHAR);
BEGIN COPY(user, User); Password := Code(password)
END SetUser;
(*clocks*)
PROCEDURE GetClock* (VAR t, d: LONGINT);
BEGIN Kernel.GetClock(t, d)
END GetClock;
PROCEDURE SetClock* (t, d: LONGINT);
BEGIN Kernel.SetClock(t, d)
END SetClock;
PROCEDURE Time* (): LONGINT;
BEGIN RETURN Input.Time()
END Time;
(*cursor handling*)
PROCEDURE FlipArrow (X, Y: INTEGER); (* << *)
END FlipArrow;
PROCEDURE FlipStar (X, Y: INTEGER);
BEGIN
IF X < CL THEN
IF X < 7 THEN X := 7 ELSIF X > DW - 8 THEN X := DW - 8 END
ELSE
IF X < CL + 7 THEN X := CL + 7 ELSIF X > CL + DW - 8 THEN X := CL + DW - 8 END
END ;
IF Y < 7 THEN Y := 7 ELSIF Y > DH - 8 THEN Y := DH - 8 END;
Display.CopyPattern(Display.white, Display.star, X - 7, Y - 7, 2)
END FlipStar;
PROCEDURE OpenCursor* (VAR c: Cursor);
BEGIN c.on := FALSE; c.X := 0; c.Y := 0
END OpenCursor;
PROCEDURE FadeCursor* (VAR c: Cursor);
BEGIN IF c.on THEN c.marker.Fade(c.X, c.Y); c.on := FALSE END
END FadeCursor;
PROCEDURE DrawCursor* (VAR c: Cursor; VAR m: Marker; X, Y: INTEGER); (* << RC *)
BEGIN
IF c.on & ((X # c.X) OR (Y # c.Y) OR (m.Draw # c.marker.Draw)) THEN
c.marker.Fade(c.X, c.Y); c.on := FALSE
END;
IF c.marker.Fade = ArrowFade THEN
IF m.Fade # ArrowFade THEN X11.DefineCursor(X11.display, X11.primary, X11.noCursor) END
ELSE
IF m.Fade = ArrowFade THEN X11.DefineCursor(X11.display, X11.primary, X11.arrow) END
END ;
IF ~c.on THEN
m.Draw(X, Y); c.marker := m; c.X := X; c.Y := Y; c.on := TRUE
END
END DrawCursor;
(*display management*)
PROCEDURE RemoveMarks* (X, Y, W, H: INTEGER);
BEGIN
IF (Mouse.X > X - 16) & (Mouse.X < X + W + 16) & (Mouse.Y > Y - 16) & (Mouse.Y < Y + H + 16) THEN
FadeCursor(Mouse)
END;
IF (Pointer.X > X - 8) & (Pointer.X < X + W + 8) & (Pointer.Y > Y - 8) & (Pointer.Y < Y + H + 8) THEN
FadeCursor(Pointer)
END
END RemoveMarks;
PROCEDURE HandleFiller (V: Display.Frame; VAR M: Display.FrameMsg);
BEGIN
WITH V: Viewers.Viewer DO
IF M IS InputMsg THEN
WITH M: InputMsg DO
IF M.id = track THEN DrawCursor(Mouse, Arrow, M.X, M.Y) END
END;
ELSIF M IS ControlMsg THEN
WITH M: ControlMsg DO
IF M.id = mark THEN DrawCursor(Pointer, Star, M.X, M.Y) END
END
ELSIF M IS Viewers.ViewerMsg THEN
WITH M: Viewers.ViewerMsg DO
IF (M.id = Viewers.restore) & (V.W > 0) & (V.H > 0) THEN
RemoveMarks(V.X, V.Y, V.W, V.H);
Display.ReplConst(Display.black, V.X, V.Y, V.W, V.H, 0)
ELSIF (M.id = Viewers.modify) & (M.Y < V.Y) THEN
RemoveMarks(V.X, M.Y, V.W, V.Y - M.Y);
Display.ReplConst(Display.black, V.X, M.Y, V.W, V.Y - M.Y, 0)
END
END
END
END
END HandleFiller;
PROCEDURE OpenDisplay* (UW, SW, H: INTEGER);
VAR Filler: Viewers.Viewer;
BEGIN
Input.SetMouseLimits(Viewers.curW + UW + SW, H);
Display.ReplConst(Display.black, Viewers.curW, 0, UW + SW, H, 0);
NEW(Filler); Filler.handle := HandleFiller;
Viewers.InitTrack(UW, H, Filler); (*init user track*)
NEW(Filler); Filler.handle := HandleFiller;
Viewers.InitTrack(SW, H, Filler) (*init system track*)
END OpenDisplay;
PROCEDURE DisplayWidth* (X: INTEGER): INTEGER;
BEGIN RETURN DW
END DisplayWidth;
PROCEDURE DisplayHeight* (X: INTEGER): INTEGER;
BEGIN RETURN DH
END DisplayHeight;
PROCEDURE OpenTrack* (X, W: INTEGER);
VAR Filler: Viewers.Viewer;
BEGIN
NEW(Filler); Filler.handle := HandleFiller;
Viewers.OpenTrack(X, W, Filler)
END OpenTrack;
PROCEDURE UserTrack* (X: INTEGER): INTEGER;
BEGIN RETURN X DIV DW * DW
END UserTrack;
PROCEDURE SystemTrack* (X: INTEGER): INTEGER;
BEGIN RETURN X DIV DW * DW + DW DIV 8 * 5
END SystemTrack;
PROCEDURE UY (X: INTEGER): INTEGER;
VAR fil, bot, alt, max: Display.Frame;
BEGIN
Viewers.Locate(X, 0, fil, bot, alt, max);
IF fil.H >= DH DIV 8 THEN RETURN DH END;
RETURN max.Y + max.H DIV 2
END UY;
PROCEDURE AllocateUserViewer* (DX: INTEGER; VAR X, Y: INTEGER);
BEGIN
IF Pointer.on THEN X := Pointer.X; Y := Pointer.Y
ELSE X := DX DIV DW * DW; Y := UY(X)
END
END AllocateUserViewer;
PROCEDURE SY (X: INTEGER): INTEGER;
VAR fil, bot, alt, max: Display.Frame;
BEGIN
Viewers.Locate(X, DH, fil, bot, alt, max);
IF fil.H >= DH DIV 8 THEN RETURN DH END;
IF max.H >= DH - H0 THEN RETURN max.Y + H3 END;
IF max.H >= H3 - H0 THEN RETURN max.Y + H2 END;
IF max.H >= H2 - H0 THEN RETURN max.Y + H1 END;
IF max # bot THEN RETURN max.Y + max.H DIV 2 END;
IF bot.H >= H1 THEN RETURN bot.H DIV 2 END;
RETURN alt.Y + alt.H DIV 2
END SY;
PROCEDURE AllocateSystemViewer* (DX: INTEGER; VAR X, Y: INTEGER);
BEGIN
IF Pointer.on THEN X := Pointer.X; Y := Pointer.Y
ELSE X := DX DIV DW * DW + DW DIV 8 * 5; Y := SY(X)
END
END AllocateSystemViewer;
PROCEDURE MarkedViewer* (): Viewers.Viewer;
BEGIN RETURN Viewers.This(Pointer.X, Pointer.Y)
END MarkedViewer;
PROCEDURE PassFocus* (V: Viewers.Viewer);
VAR M: ControlMsg;
BEGIN M.id := defocus; FocusViewer.handle(FocusViewer, M); FocusViewer := V
END PassFocus;
(*command interpretation*)
PROCEDURE Call* (name: ARRAY OF CHAR; par: ParList; new: BOOLEAN; VAR res: INTEGER);
VAR Mod: Modules.Module; P: Modules.Command; i, j: INTEGER;
BEGIN res := 1;
i := 0; j := 0;
WHILE name[j] # 0X DO
IF name[j] = "." THEN i := j END;
INC(j)
END;
IF i > 0 THEN
name[i] := 0X;
Mod := Modules.ThisMod(name);
IF Modules.res = 0 THEN
INC(i); j := i;
WHILE name[j] # 0X DO name[j - i] := name[j]; INC(j) END;
name[j - i] := 0X;
P := Modules.ThisCommand(Mod, name);
IF Modules.res = 0 THEN
Par := par; Par.vwr := Viewers.This(par.frame.X, par.frame.Y); P; res := 0
ELSE res := -1
END
ELSE res := Modules.res
END
ELSE res := -1
END
END Call;
PROCEDURE GetSelection* (VAR text: Texts.Text; VAR beg, end, time: LONGINT);
VAR M: SelectionMsg;
BEGIN
M.time := -1; Viewers.Broadcast(M); time := M.time;
IF time >= 0 THEN text := M.text; beg := M.beg; end := M.end END
END GetSelection;
PROCEDURE GC;
BEGIN IF ActCnt <= 0 THEN Kernel.GC(FALSE); ActCnt := BasicCycle END
END GC;
PROCEDURE Install* (T: Task);
VAR t: Task;
BEGIN t := PrevTask;
WHILE (t.next # PrevTask) & (t.next # T) DO t := t.next END;
IF (t.next # T) & (CurTask # T) THEN
IF CurTask # NIL THEN (* called from a task *)
T.next := CurTask.next; CurTask.next := T
ELSE (* no task is currently running *)
T.next := PrevTask.next; PrevTask.next := T
END
END
END Install;
PROCEDURE Remove* (T: Task);
VAR t: Task;
BEGIN t := PrevTask;
WHILE (t.next # T) & (t.next # PrevTask) DO t := t.next END;
IF t.next = T THEN t.next := t.next.next; PrevTask := t.next END;
IF CurTask = T THEN CurTask := PrevTask.next END
END Remove;
PROCEDURE Collect* (count: INTEGER);
BEGIN ActCnt := count
END Collect;
PROCEDURE SetFont* (fnt: Fonts.Font);
BEGIN CurFnt := fnt
END SetFont;
PROCEDURE SetColor* (col: SHORTINT);
BEGIN CurCol := col
END SetColor;
PROCEDURE SetOffset* (voff: SHORTINT);
BEGIN CurOff := voff
END SetOffset;
PROCEDURE MinTime(): LONGINT; (* << *)
VAR minTime: LONGINT; t: Task;
BEGIN
minTime := MAX(LONGINT); t := PrevTask;
REPEAT
IF (t.time # -1) & (t.time < minTime) THEN minTime := t.time END ;
t := t.next;
UNTIL t = PrevTask ;
RETURN minTime
END MinTime;
PROCEDURE NotifyTasks; (* << *)
VAR t0, p: Task;
BEGIN t0 := PrevTask;
REPEAT
CurTask := PrevTask.next;
IF CurTask.time = -1 THEN
IF ~CurTask.safe THEN PrevTask.next := CurTask.next END;
p := CurTask; CurTask.handle; PrevTask.next := CurTask;
IF CurTask # p THEN RETURN END (*detect Remove(CurTask)*)
END;
PrevTask := CurTask
UNTIL CurTask = t0
END NotifyTasks;
PROCEDURE Loop*;
VAR V: Viewers.Viewer; M: InputMsg; N: ControlMsg;
prevX, prevY, X, Y: INTEGER; keys: SET; ch: CHAR;
VM: Viewers.ViewerMsg; i: INTEGER; res: LONGINT; (* << *)
BEGIN
res := Kernel.sigsetjmp(Kernel.trapEnv, 1); (* << *)
LOOP
CurTask := NIL;
Input.Mouse(keys, X, Y);
IF Input.Available() > 0 THEN Input.Read(ch);
IF ch < 0F0X THEN
IF ch = ESC THEN
N.id := neutralize; Viewers.Broadcast(N); FadeCursor(Pointer)
ELSIF ch = SETUP THEN
N.id := mark; N.X := X; N.Y := Y; V := Viewers.This(X, Y); V.handle(V, N)
ELSIF ch = 0CX THEN (* << *)
N.id := neutralize; Viewers.Broadcast(N); FadeCursor(Pointer);
VM.id := Viewers.suspend; Viewers.Broadcast(VM);
VM.id := Viewers.restore; Viewers.Broadcast(VM)
ELSE
M.id := consume; M.ch := ch; M.fnt := CurFnt; M.col := CurCol; M.voff := CurOff;
FocusViewer.handle(FocusViewer, M);
DEC(ActCnt); NotifyTasks
END
ELSIF ch = 0F1X THEN Display.SetMode(0, {})
ELSIF ch = 0F2X THEN Display.SetMode(0, {0})
ELSIF ch = 0F3X THEN Display.SetMode(0, {2})
ELSIF ch = 0F4X THEN X11.InitColors
ELSIF Kernel.FKey[ORD(ch) - 0F0H] # NIL THEN Kernel.FKey[ORD(ch) - 0F0H]
END
ELSIF keys # {} THEN
M.id := track; M.X := X; M.Y := Y; M.keys := keys;
REPEAT
V := Viewers.This(M.X, M.Y); V.handle(V, M);
Input.Mouse(M.keys, M.X, M.Y)
UNTIL M.keys = {};
DEC(ActCnt); NotifyTasks
ELSE
IF (X # prevX) OR (Y # prevY) OR ~Mouse.on THEN
M.id := track; M.X := X; M.Y := Y; M.keys := keys; V := Viewers.This(X, Y); V.handle(V, M);
prevX := X; prevY := Y
END;
X11.DoSync; (* << *)
IF X11.EventsQueued(X11.display, X11.QueuedAfterReading) = 0 THEN (* << *)
Kernel.Select(MinTime() - Input.Time()); NotifyTasks;
FOR i := 0 TO 7 DO Kernel.readySet[i] := {} END
END ;
CurTask := PrevTask.next;
IF (CurTask.time <= Input.Time()) & (CurTask.time # -1) THEN
IF ~CurTask.safe THEN PrevTask.next := CurTask.next END;
CurTask.handle; PrevTask.next := CurTask
END;
PrevTask := CurTask
END
END
END Loop;
BEGIN User[0] := 0X;
Arrow.Fade := FlipArrow; Arrow.Draw := FlipArrow;
ArrowFade := FlipArrow; (* << *)
Star.Fade := FlipStar; Star.Draw := FlipStar;
OpenCursor(Mouse); OpenCursor(Pointer);
DW := Display.Width; DH := Display.Height; CL := Display.ColLeft;
H3 := DH - DH DIV 3;
H2 := H3 - H3 DIV 2;
H1 := DH DIV 5;
H0 := DH DIV 10;
(* moved into Configuration.Mod
unitW := DW DIV 8;
OpenDisplay(unitW * 5, unitW * 3, DH);
FocusViewer := Viewers.This(0, 0);
*)
CurFnt := Fonts.Default;
CurCol := Display.white;
CurOff := 0;
Collect(BasicCycle);
NEW(PrevTask);
PrevTask.handle := GC;
PrevTask.safe := TRUE;
PrevTask.time := -1; (* << *)
PrevTask.next := PrevTask;
CurTask := NIL;
Display.SetMode(0, {});
END Oberon.

1363
src/tools/coco/v4_compat/TextFrames.Mod Executable file
View file

File diff suppressed because it is too large Load diff

1362
src/tools/coco/v4_compat/TextFrames.Mod_orig Normal file
View file

File diff suppressed because it is too large Load diff

50
src/tools/ocat/OCatCmd.Mod Normal file
View file

@ -0,0 +1,50 @@
MODULE OCatCmd; (* J. Templ, 13-Jan-96 *)
(* looks at the OBERON search path and writes one or more Oberon or ascii texts to standard out *)
IMPORT Args, Console, Files, Texts := CmdlnTexts;
PROCEDURE Cat*;
VAR path: ARRAY 128 OF CHAR; i: INTEGER; T: Texts.Text; R: Texts.Reader; ch: CHAR; tab: BOOLEAN;
buf: ARRAY 1024 OF CHAR; bufpos: INTEGER;
PROCEDURE ConsoleChar(ch: CHAR); (* buffered write *)
BEGIN buf[bufpos] := ch; INC(bufpos);
IF bufpos = LEN(buf) - 1 THEN buf[bufpos] := 0X; Console.String(buf); bufpos := 0 END
END ConsoleChar;
BEGIN
path := ""; NEW(T);
Args.Get(1, path);
IF path = "-t" THEN tab := TRUE; i := 2; Args.Get(2, path)
ELSE tab := FALSE; i := 1
END ;
WHILE path # "" DO
IF Files.Old(path) # NIL THEN
Texts.Open(T, path);
Texts.OpenReader(R, T, 0); Texts.Read(R, ch); bufpos := 0;
WHILE ~R.eot DO
IF ch >= " " THEN ConsoleChar(ch)
ELSIF ch = 09X THEN
IF tab THEN ConsoleChar(ch) ELSE ConsoleChar(" "); ConsoleChar(" ") END
ELSIF ch = 0DX THEN ConsoleChar(0AX)
END ;
Texts.Read(R, ch)
END ;
buf[bufpos] := 0X; Console.String(buf) (* flush *)
ELSE
Console.String("ocat: cannot open "); Console.String(path); Console.Ln
END ;
INC(i); path := "";
Args.Get(i, path)
END
END Cat;
BEGIN Cat
END OCatCmd.
ocat [-t] files...
-t no tab conversion

69
src/tools/vocparam/vocparam.c Normal file
View file

@ -0,0 +1,69 @@
/* J. Templ 23.6.95
this program tests and outputs important characteristics of
the C compiler and SYSTEM.h file used to compile it.
The output of this program is accepted by voc as file voc.par.
% cc vocparam.c; a.out > voc.par
*/
#include "SYSTEM.h"
#include "stdio.h"
struct {CHAR ch; CHAR x;} c;
struct {CHAR ch; BOOLEAN x;} b;
struct {CHAR ch; SHORTINT x;} si;
struct {CHAR ch; INTEGER x;} i;
struct {CHAR ch; LONGINT x;} li;
struct {CHAR ch; SET x;} s;
struct {CHAR ch; REAL x;} r;
struct {CHAR ch; LONGREAL x;} lr;
struct {CHAR ch; void *x;} p;
struct {CHAR ch; void (*x)();} f;
struct {CHAR ch;} rec0;
struct {CHAR ch; LONGREAL x;} rec1;
struct {char x[65];} rec2;
void main()
{
long x, y;
/* get size and alignment of standard types */
printf("CHAR %d %d\n", sizeof(CHAR), (char*)&c.x - (char*)&c);
printf("BOOLEAN %d %d\n", sizeof(BOOLEAN), (char*)&b.x - (char*)&b);
printf("SHORTINT %d %d\n", sizeof(SHORTINT), (char*)&si.x - (char*)&si);
printf("INTEGER %d %d\n", sizeof(INTEGER), (char*)&i.x - (char*)&i);
printf("LONGINT %d %d\n", sizeof(LONGINT), (char*)&li.x - (char*)&li);
printf("SET %d %d\n", sizeof(SET), (char*)&s.x - (char*)&s);
printf("REAL %d %d\n", sizeof(REAL), (char*)&r.x - (char*)&r);
printf("LONGREAL %d %d\n", sizeof(LONGREAL), (char*)&lr.x - (char*)&lr);
printf("PTR %d %d\n", sizeof p.x, (char*)&p.x - (char*)&p);
printf("PROC %d %d\n", sizeof f.x, (char*)&f.x - (char*)&f);
printf("RECORD %d %d\n", (sizeof rec2 == 65) == (sizeof rec0 == 1), sizeof rec2 - 64);
x = 1;
printf("ENDIAN %d %d\n", *(char*)&x, 0);
if (sizeof(CHAR)!=1) printf("error: CHAR should have size 1\n");
if (sizeof(BOOLEAN)!=1) printf("error: BOOLEAN should have size 1\n");
if (sizeof(SHORTINT)!=1) printf("error: SHORTINT should have size 1\n");
if (sizeof(long)!=sizeof p.x) printf("error: LONGINT should have the same size as pointers\n");
if (sizeof(long)!=sizeof f.x) printf("error: LONGINT should have the same size as function pointers\n");
if (((sizeof rec2 == 65) == (sizeof rec0 == 1)) && ((sizeof rec2 - 64) != sizeof rec0))
printf("error: unsupported record layout sizeof rec0 = %d sizeof rec2 = %d\n", sizeof rec0, sizeof rec2);
/* test the __ASHR macro */
if (__ASHR(-1, 1) != -1) printf("error: ASH(-1, -1) # -1\n");
if (__ASHR(-2, 1) != -1) printf("error: ASH(-2, -1) # -1\n");
if (__ASHR(0, 1) != 0) printf("error: ASH(0, 1) # 0\n");
if (__ASHR(1, 1) != 0) printf("error: ASH(1, 1) # 0\n");
if (__ASHR(2, 1) != 1) printf("error: ASH(2, 1) # 1\n");
/* test the __SETRNG macro */
x = 0; y = sizeof(SET)*8 - 1;
if (__SETRNG(x, y) != -1) printf("error: SETRNG(0, MAX(SET)) != -1\n");
/* test string comparison for extended ascii */
{char a[10], b[10];
a[0] = (CHAR)128; a[1] = 0;
b[0] = 0;
if (__STRCMP(a, b) < 0) printf("error: __STRCMP(a, b) with extended ascii charcters; should be unsigned\n");
}
}

1538
src/voc/OPB.Mod Normal file
View file

File diff suppressed because it is too large Load diff

1378
src/voc/OPC.Mod Normal file
View file

File diff suppressed because it is too large Load diff

748
src/voc/OPM.cmdln.Mod Normal file
View file

@ -0,0 +1,748 @@
MODULE OPM; (* RC 6.3.89 / 28.6.89, J.Templ 10.7.89 / 22.7.96 *)
(* constants needed for C code generation
31.1.2007 jt synchronized with BlackBox version, in particular PromoteIntConstToLInt added
*)
IMPORT SYSTEM, Texts := CmdlnTexts, Files, Args, Console, errors, version;
CONST
OptionChar* = "-";
(* compiler options; don't change the encoding *)
inxchk* = 0; (* index check on *)
vcpp* = 1; (* VC++ support on; former ovflchk; neither used nor documented *)
ranchk* = 2; (* range check on *)
typchk* = 3; (* type check on *)
newsf* = 4; (* generation of new symbol file allowed *)
ptrinit* = 5; (* pointer initialization *)
ansi* = 6; (* ANSI or K&R style prototypes *)
assert* = 7; (* assert evaluation *)
include0* = 8; (* include M.h0 in header file and M.c0 in body file if such files exist *)
extsf* = 9; (* extension of old symbol file allowed *)
mainprog* = 10; (* translate module body into C main function *)
lineno* = 11; (* emit line numbers rather than text positions in error messages *)
useparfile* = 12; (* use .par file *)
dontasm* = 13; (* don't call external assembler/C compiler *)
dontlink* = 14; (* don't link *)
mainlinkstat* = 15; (* generate code for main module and then link object file statically *)
defopt* = {inxchk, typchk, ptrinit, ansi, assert}; (* default options *)
nilval* = 0;
(*
MinRealPat = 0FF7FFFFFH; (* most negative, 32-bit pattern, -3.40282346E38 *)
MinLRealPatL = 0FFFFFFFFH; (* most negative, lower 32-bit pattern *)
MinLRealPatH = 0FFEFFFFFH; (* most negative, higher 32-bit pattern *)
MaxRealPat = 7F7FFFFFH; (*3.40282346E38*)
MaxLRealPatL = -1;
MaxLRealPatH = 7FEFFFFFH;
*)
MaxRExp* = 38; MaxLExp* = 308; MaxHDig* = 8;
MinHaltNr* = 0;
MaxHaltNr* = 255;
MaxSysFlag* = 1;
MaxCC* = -1; (* SYSTEM.CC, GETREG, PUTREG; not implementable in C backend *)
MinRegNr* = 0;
MaxRegNr* = -1;
LANotAlloc* = -1; (* XProc link adr initialization *)
ConstNotAlloc* = -1; (* for allocation of string and real constants *)
TDAdrUndef* = -1; (* no type desc allocated *)
MaxCases* = 128;
MaxCaseRange* = 512;
MaxStruct* = 255;
(* maximal number of pointer fields in a record: *)
MaxPtr* = MAX(LONGINT);
(* maximal number of global pointers per module: *)
MaxGPtr* = MAX(LONGINT);
(* maximal number of hidden fields in an exported record: *)
MaxHdFld* = 512;
HdPtrName* = "@ptr";
HdProcName* = "@proc";
HdTProcName* = "@tproc";
ExpHdPtrFld* = TRUE;
ExpHdProcFld* = FALSE;
ExpHdTProc* = FALSE;
NEWusingAdr* = FALSE;
Eot* = 0X;
SFext = ".sym"; (* symbol file extension *)
BFext = ".c"; (* body file extension *)
HFext = ".h"; (* header file extension *)
SFtag = 0F7X; (* symbol file tag *)
HeaderFile* = 0;
BodyFile* = 1;
HeaderInclude* = 2;
TYPE
FileName = ARRAY 32 OF CHAR;
VAR
ByteSize*, CharSize*, BoolSize*, SIntSize*, IntSize*,
LIntSize*, SetSize*, RealSize*, LRealSize*, PointerSize*, ProcSize*, RecSize*,
CharAlign*, BoolAlign*, SIntAlign*, IntAlign*,
LIntAlign*, SetAlign*, RealAlign*, LRealAlign*, PointerAlign*, ProcAlign*, RecAlign*,
ByteOrder*, BitOrder*, MaxSet*: INTEGER;
MinSInt*, MinInt*, MinLInt*, MaxSInt*, MaxInt*, MaxLInt*, MaxIndex*: LONGINT;
MinReal*, MaxReal*, MinLReal*, MaxLReal*: LONGREAL;
noerr*: BOOLEAN;
curpos*, errpos*: LONGINT; (* character and error position in source file *)
breakpc*: LONGINT; (* set by OPV.Init *)
currFile*: INTEGER; (* current output file *)
level*: INTEGER; (* procedure nesting level *)
pc*, entno*: INTEGER; (* entry number *)
modName*: ARRAY 32 OF CHAR;
objname*: ARRAY 64 OF CHAR;
opt*, glbopt*: SET;
lasterrpos: LONGINT;
inR: Texts.Reader;
Log: Texts.Text;
W: Texts.Writer;
oldSF, newSF: Files.Rider;
R: ARRAY 3 OF Files.Rider;
oldSFile, newSFile, HFile, BFile, HIFile: Files.File;
S: INTEGER;
stop, useLineNo, useParFile, dontAsm-, dontLink-, mainProg-, mainLinkStat-: BOOLEAN;
(* ------------------------- Log Output ------------------------- *)
PROCEDURE LogW*(ch: CHAR);
BEGIN Console.Char(ch)
END LogW;
PROCEDURE LogWStr*(s: ARRAY OF CHAR);
BEGIN Console.String(s)
END LogWStr;
PROCEDURE LogWNum*(i, len: LONGINT);
BEGIN Console.Int(i, len)
END LogWNum;
PROCEDURE LogWLn*;
BEGIN Console.Ln
END LogWLn;
(* ------------------------- parameter handling -------------------------*)
PROCEDURE ScanOptions(VAR s: ARRAY OF CHAR; VAR opt: SET);
VAR i: INTEGER;
BEGIN
i := 1; (* skip - *)
WHILE s[i] # 0X DO
CASE s[i] OF
| "e": opt := opt / {extsf}
| "s": opt := opt / {newsf}
| "m": opt := opt / {mainprog}
| "x": opt := opt / {inxchk}
| "v": opt := opt / {vcpp};
| "r": opt := opt / {ranchk}
| "t": opt := opt / {typchk}
| "a": opt := opt / {assert}
| "k": opt := opt / {ansi}
| "p": opt := opt / {ptrinit}
| "i": opt := opt / {include0}
| "l": opt := opt / {lineno}
| "P": opt := opt / {useparfile}
| "S": opt := opt / {dontasm}
| "C": opt := opt / {dontlink}
| "M": opt := opt / {mainlinkstat}
ELSE LogWStr(" warning: option "); LogW(OptionChar); LogW(s[i]); LogWStr(" ignored"); LogWLn
END ;
INC(i)
END;
END ScanOptions;
PROCEDURE ^GetProperties;
PROCEDURE OpenPar*; (* prepare for a sequence of translations *)
VAR s: ARRAY 256 OF CHAR;
BEGIN
IF Args.argc = 1 THEN stop := TRUE;
Console.Ln;
Console.String("voc - Vishap Oberon-2 compiler ");
Console.String(version.version); Console.String (" ");
Console.String(version.date); Console.String (" for "); Console.String(version.arch);
Console.Ln;
Console.String("based on Ofront by Software Templ OEG"); Console.Ln;
Console.String("continued by Norayr Chilingarian and others"); Console.Ln;
Console.Ln;
Console.String(' command = "voc" options {file options}.'); Console.Ln;
Console.String(' options = ["-" {option} ].'); Console.Ln;
Console.String(' option = "m" | "M" | "s" | "e" | "i" | "l" | "k" | "r" | "x" | "a" | "p" | "t" | "P" | "S" | "C" .'); Console.Ln;
Console.Ln;
Console.String(" m - generate code for main module"); Console.Ln;
Console.String(" M - generate code for main module and link object statically"); Console.Ln;
Console.String(" s - generate new symbol file"); Console.Ln;
Console.String(" e - allow extending the module interface"); Console.Ln;
Console.String(" i - include header and body prefix files (c0)"); Console.Ln;
Console.String(" l - use line numbers"); Console.Ln;
Console.String(" r - check value ranges"); Console.Ln;
Console.String(" x - turn off array indices check"); Console.Ln;
Console.String(" a - don't check ASSERTs at runtime, use this option in tested production code"); Console.Ln;
Console.String(" p - turn off automatic pointer initialization"); Console.Ln;
Console.String(" t - don't check type guards (use in rare cases such as low-level modules where every cycle counts)"); Console.Ln;
Console.String(" P - use .par file"); Console.Ln;
Console.String(" S - don't call external assembler/compiler, only generate the asm/C code"); Console.Ln;
Console.String(" C - don't call linker"); Console.Ln;
Console.Ln;
ELSE
glbopt := defopt; S := 1; s := "";
Args.Get(1, s); stop := FALSE;
WHILE s[0] = OptionChar DO ScanOptions(s, glbopt); INC(S); s := ""; Args.Get(S, s) END;
IF lineno IN opt THEN (* this brought here from InitOptions which turned out to be unnecessary *)
useLineNo := TRUE; curpos := 256; errpos := curpos;
lasterrpos := curpos - 10
ELSE
useLineNo := FALSE;
END;
IF useparfile IN glbopt THEN useParFile := TRUE ELSE useParFile := FALSE END; (* this check must be made before calling getproperties, noch *)
IF dontasm IN glbopt THEN dontAsm := TRUE ELSE dontAsm := FALSE END;
IF dontlink IN glbopt THEN dontLink := TRUE ELSE dontLink := FALSE END;
IF mainprog IN glbopt THEN mainProg := TRUE ELSE mainProg := FALSE END;
IF mainlinkstat IN glbopt THEN INCL(glbopt, mainprog); mainLinkStat := TRUE ELSE mainLinkStat := FALSE END;
GetProperties; (* GetProperties moved here in order to call it after ScanOptions because we have an option whether to use par file or not, noch *)
END;
END OpenPar;
PROCEDURE InitOptions*; (* get the options for one translation *)
VAR s: ARRAY 256 OF CHAR;
BEGIN
opt := glbopt; s := ""; Args.Get(S, s);
WHILE s[0] = OptionChar DO ScanOptions(s, opt); INC(S); s := ""; Args.Get(S, s) END ;
IF lineno IN opt THEN useLineNo := TRUE; curpos := 256; errpos := curpos; lasterrpos := curpos - 10
ELSE useLineNo := FALSE;
END;
END InitOptions;
PROCEDURE Init*(VAR done: BOOLEAN; VAR mname : ARRAY OF CHAR); (* get the source for one translation *)
VAR T: Texts.Text; beg, end, time: LONGINT;
s: ARRAY 256 OF CHAR;
BEGIN
done := FALSE; curpos := 0;
IF stop OR (S >= Args.argc) THEN RETURN END ;
s := ""; Args.Get(S, s);
NEW(T); Texts.Open(T, s);
LogWStr(s);
COPY(s, mname);
IF T.len = 0 THEN LogWStr(" not found"); LogWLn
ELSE
Texts.OpenReader(inR, T, 0);
LogWStr(" translating");
done := TRUE
END ;
INC(S);
level := 0; noerr := TRUE; errpos := curpos; lasterrpos := curpos -10;
END Init;
(* ------------------------- read source text -------------------------*)
PROCEDURE Get*(VAR ch: CHAR); (* read next character from source text, 0X if eof *)
BEGIN
Texts.Read(inR, ch);
IF useLineNo THEN
IF ch = 0DX THEN curpos := (curpos DIV 256 + 1) * 256
ELSIF curpos MOD 256 # 255 THEN INC(curpos)
(* at 255 means: >= 255 *)
END
ELSE
INC(curpos)
END ;
IF (ch < 09X) & ~inR.eot THEN ch := " " END
END Get;
PROCEDURE MakeFileName(VAR name, FName: ARRAY OF CHAR; ext: ARRAY OF CHAR);
VAR i, j: INTEGER; ch: CHAR;
BEGIN i := 0;
LOOP ch := name[i];
IF ch = 0X THEN EXIT END ;
FName[i] := ch; INC(i)
END ;
j := 0;
REPEAT ch := ext[j]; FName[i] := ch; INC(i); INC(j)
UNTIL ch = 0X
END MakeFileName;
PROCEDURE LogErrMsg(n: INTEGER);
VAR S: Texts.Scanner; T: Texts.Text; ch: CHAR; i: INTEGER;
buf: ARRAY 1024 OF CHAR;
BEGIN
IF n >= 0 THEN LogWStr(" err ")
ELSE LogWStr(" warning "); n := -n
END ;
LogWNum(n, 1);
LogWStr(" ");
(*NEW(T); Texts.Open(T, "vocErrors.Text"); Texts.OpenScanner(S, T, 0);
REPEAT S.line := 0;
REPEAT Texts.Scan(S) UNTIL S.eot OR (S.line # 0)
UNTIL S.eot OR (S.class = Texts.Int) & (S.i = n);
IF ~S.eot THEN Texts.Read(S, ch); i := 0;
WHILE ~S.eot & (ch # 0DX) DO buf[i] := ch; INC(i); Texts.Read(S, ch) END ;
buf[i] := 0X; LogWStr(buf);
END*)
LogWStr(errors.errors[n]);
END LogErrMsg;
PROCEDURE Mark*(n: INTEGER; pos: LONGINT);
BEGIN
IF useLineNo THEN
IF n >= 0 THEN
noerr := FALSE;
IF (pos < lasterrpos) OR (lasterrpos + 9 < pos) THEN lasterrpos := pos; LogWLn; LogWStr(" ");
IF n < 249 THEN LogWStr(" line "); LogWNum(pos DIV 256, 1);
LogWStr(" pos "); LogWNum(pos MOD 256, 1); LogErrMsg(n)
ELSIF n = 255 THEN LogWStr(" line "); LogWNum(pos DIV 256, 1);
LogWStr(" pos "); LogWNum(pos MOD 256, 1); LogWStr(" pc "); LogWNum(breakpc, 1)
ELSIF n = 254 THEN LogWStr("pc not found")
ELSE LogWStr(objname);
IF n = 253 THEN LogWStr(" is new, compile with option e")
ELSIF n = 252 THEN LogWStr(" is redefined, compile with option s")
ELSIF n = 251 THEN LogWStr(" is redefined (private part only), compile with option s")
ELSIF n = 250 THEN LogWStr(" is no longer visible, compile with option s")
ELSIF n = 249 THEN LogWStr(" is not consistently imported, recompile imports")
END
END
END
ELSE
IF pos >= 0 THEN LogWLn;
LogWStr(" line "); LogWNum(pos DIV 256, 1); LogWStr(" pos "); LogWNum(pos MOD 256, 1)
END ;
LogErrMsg(n);
IF pos < 0 THEN LogWLn END
END
ELSE
IF n >= 0 THEN
noerr := FALSE;
IF (pos < lasterrpos) OR (lasterrpos + 9 < pos) THEN lasterrpos := pos; LogWLn; LogWStr(" ");
IF n < 249 THEN LogWStr(" pos"); LogWNum(pos, 6); LogErrMsg(n)
ELSIF n = 255 THEN LogWStr("pos"); LogWNum(pos, 6); LogWStr(" pc "); LogWNum(breakpc, 1)
ELSIF n = 254 THEN LogWStr("pc not found")
ELSE LogWStr(objname);
IF n = 253 THEN LogWStr(" is new, compile with option e")
ELSIF n = 252 THEN LogWStr(" is redefined, compile with option s")
ELSIF n = 251 THEN LogWStr(" is redefined (private part only), compile with option s")
ELSIF n = 250 THEN LogWStr(" is no longer visible, compile with option s")
ELSIF n = 249 THEN LogWStr(" is not consistently imported, recompile imports")
END
END
END
ELSE
IF pos >= 0 THEN LogWLn; LogWStr(" pos"); LogWNum(pos, 6) END ;
LogErrMsg(n);
IF pos < 0 THEN LogWLn END
END
END
END Mark;
PROCEDURE err*(n: INTEGER);
BEGIN
IF useLineNo & (errpos MOD 256 = 255) THEN (* line underflow from OPS.Get *)
Mark(n, errpos + 1)
ELSE
Mark(n, errpos)
END
END err;
PROCEDURE FPrint*(VAR fp: LONGINT; val: LONGINT);
BEGIN
fp := SYSTEM.ROT(SYSTEM.VAL(LONGINT, SYSTEM.VAL(SET, fp) / SYSTEM.VAL(SET, val)), 1)
END FPrint;
PROCEDURE FPrintSet*(VAR fp: LONGINT; set: SET);
BEGIN FPrint(fp, SYSTEM.VAL(LONGINT, set))
END FPrintSet;
PROCEDURE FPrintReal*(VAR fp: LONGINT; real: REAL);
BEGIN FPrint(fp, SYSTEM.VAL(LONGINT, real))
END FPrintReal;
PROCEDURE FPrintLReal*(VAR fp: LONGINT; lr: LONGREAL);
VAR l, h: LONGINT;
BEGIN
SYSTEM.GET(SYSTEM.ADR(lr), l); SYSTEM.GET(SYSTEM.ADR(lr)+4, h);
FPrint(fp, l); FPrint(fp, h)
END FPrintLReal;
(* ------------------------- initialization ------------------------- *)
PROCEDURE GetProperty(VAR S: Texts.Scanner; name: ARRAY OF CHAR; VAR size, align: INTEGER);
BEGIN
IF (S.class = Texts.Name) & (S.s = name) THEN Texts.Scan(S);
IF S.class = Texts.Int THEN size := SHORT(S.i); Texts.Scan(S) ELSE Mark(-157, -1) END ;
IF S.class = Texts.Int THEN align := SHORT(S.i); Texts.Scan(S) ELSE Mark(-157, -1) END
ELSE Mark(-157, -1)
END
END GetProperty;
PROCEDURE power0(i, j : INTEGER) : LONGINT; (* we would like to calculate exact Min Max values in GetProperties, not hardcode em, noch *)
VAR k : INTEGER;
p : LONGINT;
BEGIN
k := 1;
p := i;
REPEAT
p := p * i;
INC(k);
UNTIL k=j;
RETURN p;
END power0;
PROCEDURE GetProperties();
VAR T: Texts.Text; S: Texts.Scanner;
BEGIN
(* default characteristics *)
IF ~useParFile THEN
IF version.defaultTarget = version.gnux8664 THEN
Console.String (" GNU "); Console.String(version.arch); Console.String(" target"); Console.Ln;
ByteSize := 1; CharSize := 1; BoolSize := 1; SIntSize := 1; IntSize := 4; LIntSize := 8;
SetSize := 8; RealSize := 4; LRealSize := 8; ProcSize := 8; PointerSize := 8; RecSize := 1;
CharAlign := 1; BoolAlign := 1; SIntAlign := 1; IntAlign := 4; LIntAlign := 8;
SetAlign := 8; RealAlign := 4; LRealAlign := 8; ProcAlign := 8; PointerAlign := 8; RecAlign := 1;
(* not necessary, we will calculate values later
MinSInt := -80H; MaxSInt := 7FH;
MinInt := 80000000H(*-2147483648*);
MaxInt := 7FFFFFFFH (*2147483647*);
(*MinLInt := -8000000000000000H*) (*-9223372036854775808*) ; (* -2^63 *)
(*MaxLInt := 7FFFFFFFFFFFFFFFH *)(*9223372036854775807*) ;(* 2^63-1 *)
(*MaxSet := 31;*)
MaxSet := SetSize * 8 - 1; (*noch*)
*)
ELSIF (version.defaultTarget >= version.gnuarmv6j) & (version.defaultTarget <= version.gnuarmv7ahardfp) THEN
Console.String (" GNU ");
Console.String (version.arch); Console.String (" target"); Console.Ln;
ByteSize := 1; CharSize := 1; BoolSize := 1; SIntSize := 1; IntSize := 2; LIntSize := 4;
SetSize := 4; RealSize := 4; LRealSize := 8; ProcSize := 4; PointerSize := 4; RecSize := 1;
CharAlign := 1; BoolAlign := 1; SIntAlign := 1; IntAlign := 2; LIntAlign := 4;
SetAlign := 4; RealAlign := 4; LRealAlign := 8; ProcAlign := 4; PointerAlign := 4; RecAlign := 1;
(* not necessary, we will calculate values later
MinSInt := -80H; MinInt := -8000H; MinLInt := 80000000H; (*-2147483648*)
MaxSInt := 7FH; MaxInt := 7FFFH; MaxLInt := 7FFFFFFFH; (*2147483647*)
MaxSet := SetSize * 8 -1; (* noch *)
*)
ELSIF version.defaultTarget = version.gnux86 THEN
Console.String("GNU "); Console.String(version.arch); Console.String(" target"); Console.Ln;
ByteSize := 1; CharSize := 1; BoolSize := 1; SIntSize := 1; IntSize := 2; LIntSize := 4;
SetSize := 4; RealSize := 4; LRealSize := 8; ProcSize := 4; PointerSize := 4; RecSize := 1;
CharAlign := 1; BoolAlign := 1; SIntAlign := 1; IntAlign := 2; LIntAlign := 4;
SetAlign := 4; RealAlign := 4; LRealAlign := 4; ProcAlign := 4; PointerAlign := 4; RecAlign := 1;
ELSE (* this should suite any gnu x86 system *)
Console.String (" generic target, like GNU x86 system"); Console.Ln;
ByteSize := 1; CharSize := 1; BoolSize := 1; SIntSize := 1; IntSize := 2; LIntSize := 4;
SetSize := 4; RealSize := 4; LRealSize := 8; ProcSize := 4; PointerSize := 4; RecSize := 1;
CharAlign := 1; BoolAlign := 1; SIntAlign := 1; IntAlign := 2; LIntAlign := 4;
SetAlign := 4; RealAlign := 4; LRealAlign := 4; ProcAlign := 4; PointerAlign := 4; RecAlign := 1;
(* LRealAlign should be checked and confirmed *)
(* not necessary, will be calculated later
MinSInt := -80H; MinInt := -8000H; MinLInt := 80000000H; (*-2147483648*)
MaxSInt := 7FH; MaxInt := 7FFFH; MaxLInt := 7FFFFFFFH; (*2147483647*)
MaxSet := SetSize * 8 - 1;
*)
END; (* if defaultTarget *)
END; (* if ~useParFile *)
(* read voc.par *)
IF useParFile THEN (* noch *)
Console.String ("loading type sizes from voc.par"); Console.Ln;
NEW(T); Texts.Open(T, "voc.par");
IF T.len # 0 THEN
Texts.OpenScanner(S, T, 0); Texts.Scan(S);
GetProperty(S, "CHAR", CharSize, CharAlign);
GetProperty(S, "BOOLEAN", BoolSize, BoolAlign);
GetProperty(S, "SHORTINT", SIntSize, SIntAlign);
GetProperty(S, "INTEGER", IntSize, IntAlign);
GetProperty(S, "LONGINT", LIntSize, LIntAlign);
GetProperty(S, "SET", SetSize, SetAlign);
GetProperty(S, "REAL", RealSize, RealAlign);
GetProperty(S, "LONGREAL", LRealSize, LRealAlign);
GetProperty(S, "PTR", PointerSize, PointerAlign);
GetProperty(S, "PROC", ProcSize, ProcAlign);
GetProperty(S, "RECORD", RecSize, RecAlign);
(* Size = 0: natural size aligned to next power of 2 up to RecAlign; e.g. i960
Size = 1; size and alignment follows from field types but at least RecAlign; e.g, SPARC, MIPS, PowerPC
*)
GetProperty(S, "ENDIAN", ByteOrder, BitOrder); (*currently not used*)
(* add here Max and Min sizes, noch *)
ByteSize := CharSize;
ELSE Mark(-156, -1)
END ;
ELSE Console.String ("not using voc.par file"); Console.Ln;
END; (* if useParFile , noch *)
MinSInt := power0(-2, (SIntSize*8-1)); (* -2^(SIntSize*8-1)*)
MaxSInt := power0(2, (SIntSize*8-1))-1;
MinInt := power0(-2, (IntSize*8-1));
MaxInt := power0(2, (IntSize*8-1))-1;
MinLInt := power0(-2, (LIntSize*8-1));
MaxLInt := power0(2, (LIntSize*8-1))-1;
(*
Console.Int(MinSInt, 0); Console.Ln;
Console.Int(MaxSInt, 0); Console.Ln;
Console.Int(MinInt, 0); Console.Ln;
Console.Int(MaxInt, 0); Console.Ln;
Console.Int(MinLInt, 0); Console.Ln;
Console.Int(MaxLInt, 0); Console.Ln;
*)
IF RealSize = 4 THEN MaxReal := 3.40282346D38
ELSIF RealSize = 8 THEN MaxReal := 1.7976931348623157D307 * 9.999999
(*should be 1.7976931348623157D308 *)
END ;
IF LRealSize = 4 THEN MaxLReal := 3.40282346D38
ELSIF LRealSize = 8 THEN MaxLReal := 1.7976931348623157D307 * 9.999999
(*should be 1.7976931348623157D308 *)
END ;
MinReal := -MaxReal;
MinLReal := -MaxLReal;
(* commented this out, *)
(*IF IntSize = 4 THEN MinInt := MinLInt; MaxInt := MaxLInt END ;*)
(*IF IntSize = 4 THEN MinLInt := MinInt; MaxLInt := MaxInt END ;*)
MaxSet := SetSize * 8 - 1;
MaxIndex := MaxLInt; (* shouldn't it be like max(int)? so that for loop will be safe, noch *)
END GetProperties;
(* ------------------------- Read Symbol File ------------------------- *)
PROCEDURE SymRCh*(VAR ch: CHAR);
BEGIN Files.Read(oldSF, ch)
END SymRCh;
PROCEDURE SymRInt*(): LONGINT;
VAR k: LONGINT;
BEGIN Files.ReadNum(oldSF, k); RETURN k
END SymRInt;
PROCEDURE SymRSet*(VAR s: SET);
BEGIN Files.ReadNum(oldSF, SYSTEM.VAL(LONGINT, s))
END SymRSet;
PROCEDURE SymRReal*(VAR r: REAL);
BEGIN Files.ReadReal(oldSF, r)
END SymRReal;
PROCEDURE SymRLReal*(VAR lr: LONGREAL);
BEGIN Files.ReadLReal(oldSF, lr)
END SymRLReal;
PROCEDURE CloseOldSym*;
END CloseOldSym;
PROCEDURE OldSym*(VAR modName: ARRAY OF CHAR; VAR done: BOOLEAN);
VAR ch: CHAR; fileName: FileName;
BEGIN MakeFileName(modName, fileName, SFext);
oldSFile := Files.Old(fileName); done := oldSFile # NIL;
IF done THEN
Files.Set(oldSF, oldSFile, 0); Files.Read(oldSF, ch);
IF ch # SFtag THEN err(-306); (*possibly a symbol file from another Oberon implementation, e.g. HP-Oberon*)
CloseOldSym; done := FALSE
END
END
END OldSym;
PROCEDURE eofSF*(): BOOLEAN;
BEGIN RETURN oldSF.eof
END eofSF;
(* ------------------------- Write Symbol File ------------------------- *)
PROCEDURE SymWCh*(ch: CHAR);
BEGIN Files.Write(newSF, ch)
END SymWCh;
PROCEDURE SymWInt*(i: LONGINT);
BEGIN Files.WriteNum(newSF, i)
END SymWInt;
PROCEDURE SymWSet*(s: SET);
BEGIN Files.WriteNum(newSF, SYSTEM.VAL(LONGINT, s))
END SymWSet;
PROCEDURE SymWReal*(r: REAL);
BEGIN Files.WriteReal(newSF, r)
END SymWReal;
PROCEDURE SymWLReal*(lr: LONGREAL);
BEGIN Files.WriteLReal(newSF, lr)
END SymWLReal;
PROCEDURE RegisterNewSym*;
BEGIN
IF (modName # "SYSTEM") OR (mainprog IN opt) THEN Files.Register(newSFile) END
END RegisterNewSym;
PROCEDURE DeleteNewSym*;
END DeleteNewSym;
PROCEDURE NewSym*(VAR modName: ARRAY OF CHAR);
VAR fileName: FileName;
BEGIN MakeFileName(modName, fileName, SFext);
newSFile := Files.New(fileName);
IF newSFile # NIL THEN Files.Set(newSF, newSFile, 0); Files.Write(newSF, SFtag)
ELSE err(153)
END
END NewSym;
(* ------------------------- Write Header & Body Files ------------------------- *)
PROCEDURE Write*(ch: CHAR);
BEGIN Files.Write(R[currFile], ch)
END Write;
PROCEDURE WriteString*(s: ARRAY [1] OF CHAR);
VAR i: INTEGER;
BEGIN i := 0;
WHILE s[i] # 0X DO INC(i) END ;
Files.WriteBytes(R[currFile], s, i)
END WriteString;
PROCEDURE WriteStringVar*(VAR s: ARRAY OF CHAR);
VAR i: INTEGER;
BEGIN i := 0;
WHILE s[i] # 0X DO INC(i) END ;
Files.WriteBytes(R[currFile], s, i)
END WriteStringVar;
PROCEDURE WriteHex* (i: LONGINT);
VAR s: ARRAY 3 OF CHAR;
digit : INTEGER;
BEGIN
digit := SHORT(i) DIV 16;
IF digit < 10 THEN s[0] := CHR (ORD ("0") + digit); ELSE s[0] := CHR (ORD ("a") - 10 + digit ); END;
digit := SHORT(i) MOD 16;
IF digit < 10 THEN s[1] := CHR (ORD ("0") + digit); ELSE s[1] := CHR (ORD ("a") - 10 + digit ); END;
s[2] := 0X;
WriteString(s)
END WriteHex;
PROCEDURE WriteInt* (i: LONGINT);
VAR s: ARRAY 20 OF CHAR; i1, k: LONGINT;
BEGIN
IF i = MinLInt THEN Write("("); WriteInt(i+1); WriteString("-1)") (* requires special bootstrap for 64 bit *)
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 ;
IF i < 0 THEN s[k] := "-"; INC(k) END ;
WHILE k > 0 DO DEC(k); Write(s[k]) END
END ;
END WriteInt;
PROCEDURE WriteReal* (r: LONGREAL; suffx: CHAR);
VAR W: Texts.Writer; T: Texts.Text; R: Texts.Reader; s: ARRAY 32 OF CHAR; ch: CHAR; i: INTEGER;
BEGIN
(*should be improved *)
IF (r < MaxLInt) & (r > MinLInt) & (r = ENTIER(r)) THEN
IF suffx = "f" THEN WriteString("(REAL)") ELSE WriteString("(LONGREAL)") END ;
WriteInt(ENTIER(r))
ELSE
Texts.OpenWriter(W);
IF suffx = "f" THEN Texts.WriteLongReal(W, r, 16) ELSE Texts.WriteLongReal(W, r, 23) END ;
NEW(T); Texts.Open(T, ""); Texts.Append(T, W.buf);
Texts.OpenReader(R, T, 0); i := 0; Texts.Read(R, ch);
WHILE ch # 0X DO s[i] := ch; INC(i); Texts.Read(R, ch) END ;
(* s[i] := suffx; s[i+1] := 0X;
suffix does not work in K&R *)
s[i] := 0X;
i := 0; ch := s[0];
WHILE (ch # "D") & (ch # 0X) DO INC(i); ch := s[i] END ;
IF ch = "D" THEN s[i] := "e" END ;
WriteString(s)
END
END WriteReal;
PROCEDURE WriteLn* ();
BEGIN Files.Write(R[currFile], 0AX)
END WriteLn;
PROCEDURE Append(VAR R: Files.Rider; F: Files.File);
VAR R1: Files.Rider; buffer: ARRAY 4096 OF CHAR;
BEGIN
IF F # NIL THEN
Files.Set(R1, F, 0); Files.ReadBytes(R1, buffer, LEN(buffer));
WHILE LEN(buffer) - R1.res > 0 DO
Files.WriteBytes(R, buffer, LEN(buffer) - R1.res);
Files.ReadBytes(R1, buffer, LEN(buffer))
END
END
END Append;
PROCEDURE OpenFiles*(VAR moduleName: ARRAY OF CHAR);
VAR FName: ARRAY 32 OF CHAR;
BEGIN
COPY(moduleName, modName);
HFile := Files.New("");
IF HFile # NIL THEN Files.Set(R[HeaderFile], HFile, 0) ELSE err(153) END ;
MakeFileName(moduleName, FName, BFext);
BFile := Files.New(FName);
IF BFile # NIL THEN Files.Set(R[BodyFile], BFile, 0) ELSE err(153) END ;
MakeFileName(moduleName, FName, HFext);
HIFile := Files.New(FName);
IF HIFile # NIL THEN Files.Set(R[HeaderInclude], HIFile, 0) ELSE err(153) END ;
IF include0 IN opt THEN
MakeFileName(moduleName, FName, ".h0"); Append(R[HeaderInclude], Files.Old(FName));
MakeFileName(moduleName, FName, ".c0"); Append(R[BodyFile], Files.Old(FName))
END
END OpenFiles;
PROCEDURE CloseFiles*;
VAR FName: ARRAY 32 OF CHAR; res: INTEGER;
BEGIN
IF noerr THEN LogWStr(" "); LogWNum(Files.Pos(R[BodyFile]), 0) END ;
IF noerr THEN
IF modName = "SYSTEM" THEN
IF ~(mainprog IN opt) THEN Files.Register(BFile) END
ELSIF ~(mainprog IN opt) THEN
Append(R[HeaderInclude], HFile);
Files.Register(HIFile); Files.Register(BFile)
ELSE
MakeFileName(modName, FName, HFext); Files.Delete(FName, res);
MakeFileName(modName, FName, SFext); Files.Delete(FName, res);
Files.Register(BFile)
END
END ;
HFile := NIL; BFile := NIL; HIFile := NIL; newSFile := NIL; oldSFile := NIL;
Files.Set(R[0], NIL, 0); Files.Set(R[1], NIL, 0); Files.Set(R[2], NIL, 0); Files.Set(newSF, NIL, 0); Files.Set(oldSF, NIL, 0)
END CloseFiles;
PROCEDURE PromoteIntConstToLInt*();
BEGIN
(* ANSI C does not need explicit promotion.
K&R C implicitly promotes integer constants to type int in parameter lists.
if the formal parameter, however, is of type long, appending "L" is required in ordere to promote
the parameter explicitly to type long (if LONGINT corresponds to long, which we do not really know).
It works for all known K&R versions of voc and K&R is dying out anyway.
A cleaner solution would be to cast with type (LONGINT), but this requires a bit more changes.
*)
IF ~(ansi IN opt) THEN Write("L") END
END PromoteIntConstToLInt;
BEGIN Texts.OpenWriter(W)
END OPM.

1066
src/voc/OPP.Mod Normal file
View file

File diff suppressed because it is too large Load diff

315
src/voc/OPS.Mod Normal file
View file

@ -0,0 +1,315 @@
MODULE OPS; (* NW, RC 6.3.89 / 18.10.92 *) (* object model 3.6.92 *)
IMPORT OPM;
CONST
MaxStrLen* = 256;
MaxIdLen = 32;
TYPE
Name* = ARRAY MaxIdLen OF CHAR;
String* = ARRAY MaxStrLen OF CHAR;
(* name, str, numtyp, intval, realval, lrlval are implicit results of Get *)
VAR
name*: Name;
str*: String;
numtyp*: INTEGER; (* 1 = char, 2 = integer, 3 = real, 4 = longreal *)
intval*: LONGINT; (* integer value or string length *)
realval*: REAL;
lrlval*: LONGREAL;
(*symbols:
| 0 1 2 3 4
---|--------------------------------------------------------
0 | null * / DIV MOD
5 | & + - OR =
10 | # < <= > >=
15 | IN IS ^ . ,
20 | : .. ) ] }
25 | OF THEN DO TO BY
30 | ( [ { ~ :=
35 | number NIL string ident ;
40 | | END ELSE ELSIF UNTIL
45 | IF CASE WHILE REPEAT FOR
50 | LOOP WITH EXIT RETURN ARRAY
55 | RECORD POINTER BEGIN CONST TYPE
60 | VAR PROCEDURE IMPORT MODULE eof *)
CONST
(* numtyp values *)
char = 1; integer = 2; real = 3; longreal = 4;
(*symbol values*)
null = 0; times = 1; slash = 2; div = 3; mod = 4;
and = 5; plus = 6; minus = 7; or = 8; eql = 9;
neq = 10; lss = 11; leq = 12; gtr = 13; geq = 14;
in = 15; is = 16; arrow = 17; period = 18; comma = 19;
colon = 20; upto = 21; rparen = 22; rbrak = 23; rbrace = 24;
of = 25; then = 26; do = 27; to = 28; by = 29;
lparen = 30; lbrak = 31; lbrace = 32; not = 33; becomes = 34;
number = 35; nil = 36; string = 37; ident = 38; semicolon = 39;
bar = 40; end = 41; else = 42; elsif = 43; until = 44;
if = 45; case = 46; while = 47; repeat = 48; for = 49;
loop = 50; with = 51; exit = 52; return = 53; array = 54;
record = 55; pointer = 56; begin = 57; const = 58; type = 59;
var = 60; procedure = 61; import = 62; module = 63; eof = 64;
VAR
ch: CHAR; (*current character*)
PROCEDURE err(n: INTEGER);
BEGIN OPM.err(n)
END err;
PROCEDURE Str(VAR sym: SHORTINT);
VAR i: INTEGER; och: CHAR;
BEGIN i := 0; och := ch;
LOOP OPM.Get(ch);
IF ch = och THEN EXIT END ;
IF ch < " " THEN err(3); EXIT END ;
IF i = MaxStrLen-1 THEN err(241); EXIT END ;
str[i] := ch; INC(i)
END ;
OPM.Get(ch); str[i] := 0X; intval := i + 1;
IF intval = 2 THEN
sym := number; numtyp := 1; intval := ORD(str[0])
ELSE sym := string
END
END Str;
PROCEDURE Identifier(VAR sym: SHORTINT);
VAR i: INTEGER;
BEGIN i := 0;
REPEAT
name[i] := ch; INC(i); OPM.Get(ch)
UNTIL (ch < "0") OR ("9" < ch) & (CAP(ch) < "A") OR ("Z" < CAP(ch)) OR (i = MaxIdLen);
IF i = MaxIdLen THEN err(240); DEC(i) END ;
name[i] := 0X; sym := ident
END Identifier;
PROCEDURE Number;
VAR i, m, n, d, e: INTEGER; dig: ARRAY 24 OF CHAR; f: LONGREAL; expCh: CHAR; neg: BOOLEAN;
PROCEDURE Ten(e: INTEGER): LONGREAL;
VAR x, p: LONGREAL;
BEGIN x := 1; p := 10;
WHILE e > 0 DO
IF ODD(e) THEN x := x*p END;
e := e DIV 2;
IF e > 0 THEN p := p*p END (* prevent overflow *)
END;
RETURN x
END Ten;
PROCEDURE Ord(ch: CHAR; hex: BOOLEAN): INTEGER;
BEGIN (* ("0" <= ch) & (ch <= "9") OR ("A" <= ch) & (ch <= "F") *)
IF ch <= "9" THEN RETURN ORD(ch) - ORD("0")
ELSIF hex THEN RETURN ORD(ch) - ORD("A") + 10
ELSE err(2); RETURN 0
END
END Ord;
BEGIN (* ("0" <= ch) & (ch <= "9") *)
i := 0; m := 0; n := 0; d := 0;
LOOP (* read mantissa *)
IF ("0" <= ch) & (ch <= "9") OR (d = 0) & ("A" <= ch) & (ch <= "F") THEN
IF (m > 0) OR (ch # "0") THEN (* ignore leading zeros *)
IF n < LEN(dig) THEN dig[n] := ch; INC(n) END;
INC(m)
END;
OPM.Get(ch); INC(i)
ELSIF ch = "." THEN OPM.Get(ch);
IF ch = "." THEN (* ellipsis *) ch := 7FX; EXIT
ELSIF d = 0 THEN (* i > 0 *) d := i
ELSE err(2)
END
ELSE EXIT
END
END; (* 0 <= n <= m <= i, 0 <= d <= i *)
IF d = 0 THEN (* integer *)
IF n = m THEN intval := 0; i := 0;
IF ch = "X" THEN (* character *) OPM.Get(ch); numtyp := char;
IF n <= 2 THEN
WHILE i < n DO intval := intval*10H + Ord(dig[i], TRUE); INC(i) END
ELSE err(203)
END
ELSIF ch = "H" THEN (* hexadecimal *) OPM.Get(ch); numtyp := integer;
IF n <= OPM.MaxHDig THEN
IF (n = OPM.MaxHDig) & (dig[0] > "7") THEN (* prevent overflow *) intval := -1 END;
WHILE i < n DO intval := intval*10H + Ord(dig[i], TRUE); INC(i) END
ELSE err(203)
END
ELSE (* decimal *) numtyp := integer;
WHILE i < n DO d := Ord(dig[i], FALSE); INC(i);
IF intval <= (MAX(LONGINT) - d) DIV 10 THEN intval := intval*10 + d
ELSE err(203)
END
END
END
ELSE err(203)
END
ELSE (* fraction *)
f := 0; e := 0; expCh := "E";
WHILE n > 0 DO (* 0 <= f < 1 *) DEC(n); f := (Ord(dig[n], FALSE) + f)/10 END;
IF (ch = "E") OR (ch = "D") THEN expCh := ch; OPM.Get(ch); neg := FALSE;
IF ch = "-" THEN neg := TRUE; OPM.Get(ch)
ELSIF ch = "+" THEN OPM.Get(ch)
END;
IF ("0" <= ch) & (ch <= "9") THEN
REPEAT n := Ord(ch, FALSE); OPM.Get(ch);
IF e <= (MAX(INTEGER) - n) DIV 10 THEN e := e*10 + n
ELSE err(203)
END
UNTIL (ch < "0") OR ("9" < ch);
IF neg THEN e := -e END
ELSE err(2)
END
END;
DEC(e, i-d-m); (* decimal point shift *)
IF expCh = "E" THEN numtyp := real;
IF (1-OPM.MaxRExp < e) & (e <= OPM.MaxRExp) THEN
IF e < 0 THEN realval := SHORT(f / Ten(-e))
ELSE realval := SHORT(f * Ten(e))
END
ELSE err(203)
END
ELSE numtyp := longreal;
IF (1-OPM.MaxLExp < e) & (e <= OPM.MaxLExp) THEN
IF e < 0 THEN lrlval := f / Ten(-e)
ELSE lrlval := f * Ten(e)
END
ELSE err(203)
END
END
END
END Number;
PROCEDURE Get*(VAR sym: SHORTINT);
VAR s: SHORTINT;
PROCEDURE Comment; (* do not read after end of file *)
BEGIN OPM.Get(ch);
LOOP
LOOP
WHILE ch = "(" DO OPM.Get(ch);
IF ch = "*" THEN Comment END
END ;
IF ch = "*" THEN OPM.Get(ch); EXIT END ;
IF ch = OPM.Eot THEN EXIT END ;
OPM.Get(ch)
END ;
IF ch = ")" THEN OPM.Get(ch); EXIT END ;
IF ch = OPM.Eot THEN err(5); EXIT END
END
END Comment;
BEGIN
OPM.errpos := OPM.curpos-1;
WHILE ch <= " " DO (*ignore control characters*)
IF ch = OPM.Eot THEN sym := eof; RETURN
ELSE OPM.Get(ch)
END
END ;
CASE ch OF (* ch > " " *)
| 22X, 27X : Str(s)
| "#" : s := neq; OPM.Get(ch)
| "&" : s := and; OPM.Get(ch)
| "(" : OPM.Get(ch);
IF ch = "*" THEN Comment; Get(s)
ELSE s := lparen
END
| ")" : s := rparen; OPM.Get(ch)
| "*" : s := times; OPM.Get(ch)
| "+" : s := plus; OPM.Get(ch)
| "," : s := comma; OPM.Get(ch)
| "-" : s := minus; OPM.Get(ch)
| "." : OPM.Get(ch);
IF ch = "." THEN OPM.Get(ch); s := upto ELSE s := period END
| "/" : s := slash; OPM.Get(ch)
| "0".."9": Number; s := number
| ":" : OPM.Get(ch);
IF ch = "=" THEN OPM.Get(ch); s := becomes ELSE s := colon END
| ";" : s := semicolon; OPM.Get(ch)
| "<" : OPM.Get(ch);
IF ch = "=" THEN OPM.Get(ch); s := leq ELSE s := lss END
| "=" : s := eql; OPM.Get(ch)
| ">" : OPM.Get(ch);
IF ch = "=" THEN OPM.Get(ch); s := geq ELSE s := gtr END
| "A": Identifier(s); IF name = "ARRAY" THEN s := array END
| "B": Identifier(s);
IF name = "BEGIN" THEN s := begin
ELSIF name = "BY" THEN s := by
END
| "C": Identifier(s);
IF name = "CASE" THEN s := case
ELSIF name = "CONST" THEN s := const
END
| "D": Identifier(s);
IF name = "DO" THEN s := do
ELSIF name = "DIV" THEN s := div
END
| "E": Identifier(s);
IF name = "END" THEN s := end
ELSIF name = "ELSE" THEN s := else
ELSIF name = "ELSIF" THEN s := elsif
ELSIF name = "EXIT" THEN s := exit
END
| "F": Identifier(s); IF name = "FOR" THEN s := for END
| "I": Identifier(s);
IF name = "IF" THEN s := if
ELSIF name = "IN" THEN s := in
ELSIF name = "IS" THEN s := is
ELSIF name = "IMPORT" THEN s := import
END
| "L": Identifier(s); IF name = "LOOP" THEN s := loop END
| "M": Identifier(s);
IF name = "MOD" THEN s := mod
ELSIF name = "MODULE" THEN s := module
END
| "N": Identifier(s); IF name = "NIL" THEN s := nil END
| "O": Identifier(s);
IF name = "OR" THEN s := or
ELSIF name = "OF" THEN s := of
END
| "P": Identifier(s);
IF name = "PROCEDURE" THEN s := procedure
ELSIF name = "POINTER" THEN s := pointer
END
| "R": Identifier(s);
IF name = "RECORD" THEN s := record
ELSIF name = "REPEAT" THEN s := repeat
ELSIF name = "RETURN" THEN s := return
END
| "T": Identifier(s);
IF name = "THEN" THEN s := then
ELSIF name = "TO" THEN s := to
ELSIF name = "TYPE" THEN s := type
END
| "U": Identifier(s); IF name = "UNTIL" THEN s := until END
| "V": Identifier(s); IF name = "VAR" THEN s := var END
| "W": Identifier(s);
IF name = "WHILE" THEN s := while
ELSIF name = "WITH" THEN s := with
END
| "G".."H", "J", "K", "Q", "S", "X".."Z": Identifier(s)
| "[" : s := lbrak; OPM.Get(ch)
| "]" : s := rbrak; OPM.Get(ch)
| "^" : s := arrow; OPM.Get(ch)
| "a".."z": Identifier(s)
| "{" : s := lbrace; OPM.Get(ch)
| "|" : s := bar; OPM.Get(ch)
| "}" : s := rbrace; OPM.Get(ch)
| "~" : s := not; OPM.Get(ch)
| 7FX : s := upto; OPM.Get(ch)
ELSE s := null; OPM.Get(ch)
END ;
sym := s
END Get;
PROCEDURE Init*;
BEGIN ch := " "
END Init;
END OPS.

1243
src/voc/OPT.Mod Normal file
View file

File diff suppressed because it is too large Load diff

1023
src/voc/OPV.Mod Normal file
View file

File diff suppressed because it is too large Load diff

213
src/voc/errors.Mod Normal file
View file

@ -0,0 +1,213 @@
MODULE errors;
TYPE string* = ARRAY 128 OF CHAR;
VAR errors- : ARRAY 350 OF string;
BEGIN
(* Incorroct use of the language Oberon *)
errors[0] := "undeclared identifier";
errors[1] := "multiply defined identifier";
errors[2] := "illegal character in number";
errors[3] := "illegal character in string";
errors[4] := "identifier does not match procedure name";
errors[5] := "comment not closed";
errors[6] := "";
errors[6] := "";
errors[6] := "";
errors[9] := "'=' expected";
errors[10] :="";
errors[11] :="";
errors[12] := "type definition starts with incorrect symbol";
errors[13] := "factor starts with incorrect symbol";
errors[14] := "statement starts with incorrect symbol";
errors[15] := "declaration followed by incorrect symbol";
errors[16] := "MODULE expected";
errors[17] := "";
errors[18] := "'.' missing";
errors[19] := "',' missing";
errors[20] := "':' missing";
errors[21] := "";
errors[22] := "')' missing";
errors[23] := "']' missing";
errors[24] := "'}' missing";
errors[25] := "OF missing";
errors[26] := "THEN missing";
errors[27] := "DO missing";
errors[28] := "TO missing";
errors[29] := "";
errors[30] := "'(' missing";
errors[31] := "";
errors[32] := "";
errors[33] := "";
errors[34] := "':=' missing";
errors[35] := "',' or OF expected";
errors[36] := "";
errors[37] := "";
errors[38] := "identifier expected";
errors[39] := "';' missing";
errors[40] := "";
errors[41] := "END missing";
errors[42] := "";
errors[43] := "";
errors[44] := "UNTIL missing";
errors[45] := "";
errors[46] := "EXIT not within loop statement";
errors[47] := "illegally marked identifier";
errors[48] := "";
errors[49] := "";
errors[50] := "expression should be constant";
errors[51] := "constant not an integer";
errors[52] := "identifier does not denote a type";
errors[53] := "identifier does not denote a record type";
errors[54] := "result type of procedure is not a basic type";
errors[55] := "procedure call of a function";
errors[56] := "assignment to non-variable";
errors[57] := "pointer not bound to record or array type";
errors[58] := "recursive type definition";
errors[59] := "illegal open array parameter";
errors[60] := "wrong type of case label";
errors[61] := "inadmissible type of case label";
errors[62] := "case label defined more than once";
errors[63] := "illegal value of constant";
errors[64] := "more actual than formal parameters";
errors[65] := "fewer actual than formal parameters";
errors[66] := "element types of actual array and formal open array differ";
errors[67] := "actual parameter corresponding to open array is not an array";
errors[68] := "control variable must be integer";
errors[69] := "parameter must be an integer constant";
errors[70] := "pointer or VAR record required as formal receiver";
errors[71] := "pointer expected as actual receiver";
errors[72] := "procedure must be bound to a record of the same scope";
errors[73] := "procedure must have level 0";
errors[74] := "procedure unknown in base type";
errors[75] := "invalid call of base procedure";
errors[76] := "this variable (field) is read only";
errors[77] := "object is not a record";
errors[78] := "dereferenced object is not a variable";
errors[79] := "indexed object is not a variable";
errors[80] := "index expression is not an integer";
errors[81] := "index out of specified bounds";
errors[82] := "indexed variable is not an array";
errors[83] := "undefined record field";
errors[84] := "dereferenced variable is not a pointer";
errors[85] := "guard or test type is not an extension of variable type";
errors[86] := "guard or testtype is not a pointer";
errors[87] := "guarded or tested variable is neither a pointer nor a VAR-parameter record";
errors[88] := "open array not allowed as variable, record field or array element";
errors[89] := "";
errors[90] := "";
errors[91] := "";
errors[92] := "operand of IN not an integer, or not a set";
errors[93] := "set element type is not an integer";
errors[94] := "operand of & is not of type BOOLEAN";
errors[95] := "operand of OR is not of type BOOLEAN";
errors[96] := "operand not applicable to (unary) +";
errors[97] := "operand not applicable to (unary) -";
errors[98] := "operand of ~ is not of type BOOLEAN";
errors[99] := "ASSERT fault";
errors[100] := "incompatible operands of dyadic operator";
errors[101] := "operand type inapplicable to *";
errors[102] := "operand type inapplicable to /";
errors[103] := "operand type inapplicable to DIV";
errors[104] := "operand type inapplicable to MOD";
errors[105] := "operand type inapplicable to +";
errors[106] := "operand type inapplicable to -";
errors[107] := "operand type inapplicable to = or #";
errors[108] := "operand type inapplicable to relation";
errors[109] := "overriding method must be exported";
errors[110] := "operand is not a type";
errors[111] := "operand inapplicable to (this) function";
errors[112] := "operand is not a variable";
errors[113] := "incompatible assignment";
errors[114] := "string too long to be assigned";
errors[115] := "parameter doesn't match";
errors[116] := "number of parameters doesn't match";
errors[117] := "result type doesn't match";
errors[118] := "export mark doesn't match with forward declaration";
errors[119] := "redefinition textually precedes procedure bound to base type";
errors[120] := "type of expression following IF, WHILE, UNTIL or ASSERT is not BOOLEAN";
errors[121] := "called object is not a procedure (or is an interrupt procedure)";
errors[122] := "actual VAR-parameter is not a variable";
errors[123] := "type of actual parameter is not identical with that of formal VAR-parameter";
errors[124] := "type of result expression differs from that of procedure";
errors[125] := "type of case expression is neither INTEGER nor CHAR";
errors[126] := "this expression cannot be a type or a procedure";
errors[127] := "illegal use of object";
errors[128] := "unsatisfied forward reference";
errors[129] := "unsatisfied forward procedure";
errors[130] := "WITH clause does not specify a variable";
errors[131] := "LEN not applied to array";
errors[132] := "dimension in LEN too large or negative";
errors[135] := "SYSTEM not imported";
errors[150] := "key inconsistency of imported module";
errors[151] := "incorrect symbol file";
errors[152] := "symbol file of imported module not found";
errors[153] := "object or symbol file not opened (disk full?)";
errors[154] := "recursive import not allowed";
errors[155] := "generation of new symbol file not allowed";
errors[156] := "parameter file not found";
errors[157] := "syntax error in parameter file";
(* Limitations of implementation*)
errors[200] := "not yet implemented";
errors[201] := "lower bound of set range greater than higher bound";
errors[202] := "set element greater than MAX(SET) or less than 0";
errors[203] := "number too large";
errors[204] := "product too large";
errors[205] := "division by zero";
errors[206] := "sum too large";
errors[207] := "difference too large";
errors[208] := "overflow in arithmetic shift";
errors[209] := "case range too large";
errors[213] := "too many cases in case statement";
errors[218] := "illegal value of parameter (0 <= p < 256)";
errors[219] := "machine registers cannot be accessed";
errors[220] := "illegal value of parameter";
errors[221] := "too many pointers in a record";
errors[222] := "too many global pointers";
errors[223] := "too many record types";
errors[224] := "too many pointer types";
errors[225] := "address of pointer variable too large (move forward in text)";
errors[226] := "too many exported procedures";
errors[227] := "too many imported modules";
errors[228] := "too many exported structures";
errors[229] := "too many nested records for import";
errors[230] := "too many constants (strings) in module";
errors[231] := "too many link table entries (external procedures)";
errors[232] := "too many commands in module";
errors[233] := "record extension hierarchy too high";
errors[234] := "export of recursive type not allowed";
errors[240] := "identifier too long";
errors[241] := "string too long";
errors[242] := "address overflow";
errors[244] := "cyclic type definition not allowed";
errors[245] := "guarded pointer variable may be manipulated by non-local operations; use auxiliary pointer variable";
(* Compiler Warnings *)
errors[301] := "implicit type cast";
errors[306] := "inappropriate symbol file ignored";
END errors.
(*
Run-time Error Messages
SYSTEM_halt
0 silent HALT(0)
1..255 HALT(n), cf. SYSTEM_halt
-1 assertion failed, cf. SYSTEM_assert
-2 invalid array index
-3 function procedure without RETURN statement
-4 invalid case in CASE statement
-5 type guard failed
-6 implicit type guard in record assignment failed
-7 invalid case in WITH statement
-8 value out of range
-9 (delayed) interrupt
-10 NIL access
-11 alignment error
-12 zero divide
-13 arithmetic overflow/underflow
-14 invalid function argument
-15 internal error
*)

4
src/voc/gnuc/armv6j/architecture.Mod Normal file
View file

@ -0,0 +1,4 @@
MODULE architecture;
CONST arch* = "armv6j";
END architecture.

4
src/voc/gnuc/armv6j_hardfp/architecture.Mod Normal file
View file

@ -0,0 +1,4 @@
MODULE architecture;
CONST arch* = "armv6j_hardfp";
END architecture.

4
src/voc/gnuc/armv7a_hardfp/architecture.Mod Normal file
View file

@ -0,0 +1,4 @@
MODULE architecture;
CONST arch* = "armv7a_hardfp";
END architecture.

79
src/voc/gnuc/extTools.Mod Normal file
View file

@ -0,0 +1,79 @@
MODULE extTools;
IMPORT Args, Unix, Strings := oocOakStrings, Console, version;
(*
INCLUDEPATH = -Isrc/lib/system/gnuc/x86_64
CCOPT = -fPIC $(INCLUDEPATH) -g
CLOBERONOPTS = -fPIC $(INCLUDEPATH) -L. -L/usr/lib -lOberon -static -g
CC = cc $(CCOPT) -c
*)
VAR incPath0, incPath1, ccOpt, ccString, CFLAGS, tmp0, tmp1 : ARRAY 256 OF CHAR;
PROCEDURE Assemble*(m : ARRAY OF CHAR);
VAR cmd : ARRAY 256 OF CHAR;
cc : ARRAY 23 OF CHAR;
ext : ARRAY 5 OF CHAR;
BEGIN
COPY (ccString, cc);
Strings.Append (" -c ", cc);
COPY(cc, cmd);
Strings.Append (" ", cmd);
Strings.Append (ccOpt, cmd);
ext := ".c";
Strings.Append (ext, m);
Strings.Append(m, cmd);
Console.Ln; Console.String (cmd); Console.Ln;
Unix.system(cmd);
END Assemble;
PROCEDURE LinkMain*(VAR m : ARRAY OF CHAR; statically : BOOLEAN);
VAR lpath : ARRAY 256 OF CHAR;
cc : ARRAY 256 OF CHAR;
ccopt : ARRAY 256 OF CHAR;
cmd : ARRAY 256 OF CHAR;
ext : ARRAY 5 OF CHAR;
BEGIN
(*
gcc -g -o hello hello.c -I $RPATH/src/lib/system/gnuc/x86_64 -I. -I$RPATH -lOberon -L. -L$RPATH -static
*)
cmd := "";
cc := "";
ext := ".c";
COPY(ccString, cc);
COPY (cc, cmd);
Strings.Append(" ", cmd);
Strings.Append(m, cmd);
Strings.Append(ext, cmd);
IF statically THEN Strings.Append(" -static ", cmd) END;
Strings.Append(" -o ", cmd);
Strings.Append(m, cmd);
Strings.Append(" ", cmd);
Strings.Append(ccOpt, cmd);
Console.Ln; Console.String(cmd); Console.Ln;
Unix.system(cmd);
END LinkMain;
BEGIN
incPath0 := "src/lib/system/gnuc/x86_64 ";
incPath1 := "lib/voc/obj ";
ccOpt := " -fPIC -g -I ";
COPY (version.prefix, tmp1);
Strings.Append("/", tmp1);
Strings.Append(incPath0, tmp1);
Strings.Append(" -I ", tmp1);
Strings.Append(version.prefix, tmp1);
Strings.Append("/", tmp1);
Strings.Append(incPath1, tmp1);
Strings.Append(tmp1, ccOpt);
Strings.Append ("-lVishapOberon -L. -L", ccOpt);
Strings.Append (version.prefix, ccOpt);
Strings.Append ("/lib ", ccOpt);
Args.GetEnv("CFLAGS", CFLAGS);
Strings.Append (CFLAGS, ccOpt);
Strings.Append (" ", ccOpt);
ccString := "cc ";
(*Strings.Append (ccOpt, ccString);*)
END extTools.

4
src/voc/gnuc/x86/architecture.Mod Normal file
View file

@ -0,0 +1,4 @@
MODULE architecture;
CONST arch* = "x86";
END architecture.

4
src/voc/gnuc/x86_64/architecture.Mod Normal file
View file

@ -0,0 +1,4 @@
MODULE architecture;
CONST arch* = "x86_64";
END architecture.

38
src/voc/version.Mod Normal file
View file

@ -0,0 +1,38 @@
MODULE version;
IMPORT Strings := oocOakStrings, architecture;
CONST
(* targets *)
gnux86* = 0; gnux8664* = 1; gnuarmv6j* = 2; gnuarmv6jhardfp* = 3; gnuarmv7ahardfp* = 4;
VAR arch-, version-, date-, versionLong-, prefix0-, prefix- : ARRAY 23 OF CHAR;
defaultTarget* : INTEGER;
BEGIN
arch := architecture.arch;
date := " [2013/09/23]";
version := "1.0";
versionLong := "";
COPY(version, versionLong);
Strings.Append (" ", versionLong);
Strings.Append(date, versionLong);
prefix := "";
prefix0 := "/opt";
COPY (prefix0, prefix);
Strings.Append ("/voc-", prefix);
Strings.Append(version, prefix); (* /opt/voc-1.0 *)
(* will be used later in Kernel.Mod to set OBERON default path *)
IF arch = "x86_64" THEN
defaultTarget := gnux8664
ELSIF arch = "x86" THEN
defaultTarget := gnux86
ELSIF arch = "armv6j" THEN
defaultTarget := gnuarmv6j
ELSIF arch = "armv6j_hardfp" THEN
defaultTarget := gnuarmv6jhardfp
ELSIF arch = "armv7a_hardfp" THEN
defaultTarget := gnuarmv7ahardfp
ELSE
defaultTarget := gnux8664
END
END version.

111
src/voc/voc.Mod Normal file
View file

@ -0,0 +1,111 @@
MODULE voc; (* J. Templ 3.2.95 *)
IMPORT
SYSTEM, Unix, Kernel,
OPP, OPB, OPT,
OPV, OPC, OPM,
extTools;
VAR mname : ARRAY 256 OF CHAR; (* noch *)
PROCEDURE -signal(sig: LONGINT; func: Unix.SignalHandler)
"signal(sig, func)";
PROCEDURE -fin()
"SYSTEM_FINALL()";
PROCEDURE -halt(): LONGINT
"SYSTEM_halt";
(*
PROCEDURE -gclock()
"SYSTEM_gclock = 1";
*)
PROCEDURE Trap(sig, code: LONGINT; scp: Unix.SigCtxPtr);
BEGIN fin();
IF sig = 3 THEN Unix.Exit(0)
ELSE
IF (sig = 4) & (halt() = -15) THEN OPM.LogWStr(" --- voc: internal error"); OPM.LogWLn END ;
Unix.Exit(2)
END
END Trap;
PROCEDURE Module*(VAR done: BOOLEAN);
VAR ext, new: BOOLEAN; p: OPT.Node;
BEGIN
OPP.Module(p, OPM.opt);
IF OPM.noerr THEN
OPV.Init;
OPV.AdrAndSize(OPT.topScope);
OPT.Export(ext, new);
IF OPM.noerr THEN
OPM.OpenFiles(OPT.SelfName);
OPC.Init;
OPV.Module(p);
IF OPM.noerr THEN
(*IF (OPM.mainprog IN OPM.opt) & (OPM.modName # "SYSTEM") THEN*)
IF (OPM.mainProg OR OPM.mainLinkStat) & (OPM.modName # "SYSTEM") THEN
OPM.DeleteNewSym; OPM.LogWStr(" main program")
ELSE
IF new THEN OPM.LogWStr(" new symbol file"); OPM.RegisterNewSym
ELSIF ext THEN OPM.LogWStr(" extended symbol file"); OPM.RegisterNewSym
END
END;
ELSE OPM.DeleteNewSym
END
END
END ;
OPM.CloseFiles; OPT.Close;
OPM.LogWLn; done := OPM.noerr;
(* noch *)
IF done THEN
IF ~OPM.dontAsm THEN
IF ~(OPM.mainProg OR OPM.mainLinkStat) THEN
extTools.Assemble(OPM.modName);
ELSE
IF ~OPM.dontLink THEN
extTools.LinkMain (OPM.modName, OPM.mainLinkStat);
END;
END;
END;
END
END Module;
PROCEDURE Translate*;
VAR done: BOOLEAN;
BEGIN
OPM.OpenPar; (* gclock(); slightly faste rtranslation but may lead to opening "too many files" *)
OPT.bytetyp.size := OPM.ByteSize;
OPT.sysptrtyp.size := OPM.PointerSize;
OPT.chartyp.size := OPM.CharSize;
OPT.settyp.size := OPM.SetSize;
OPT.realtyp.size := OPM.RealSize;
OPT.inttyp.size := OPM.IntSize;
OPT.linttyp.size := OPM.LIntSize;
OPT.lrltyp.size := OPM.LRealSize;
OPT.sinttyp.size := OPM.SIntSize;
OPT.booltyp.size := OPM.BoolSize;
LOOP
OPM.Init(done, mname);
IF ~done THEN EXIT END ;
OPM.InitOptions;
Kernel.GC(FALSE);
Module(done);
IF ~done THEN Unix.Exit(1) END
END
END Translate;
BEGIN
signal(2, Trap); (* interrupt *)
signal(3, Trap); (* quit *)
signal(4, Trap); (* illegal instruction, HALT *)
OPB.typSize := OPV.TypSize; OPT.typSize := OPV.TypSize; Translate
END voc.