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

voc compiler first commit

Browse source
This commit is contained in:
Norayr Chilingarian 2013-09-27 22:34:17 +04:00
parent 4a7dc4b549
commit 760d826948
119 changed files with 30394 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.