vishapoberon/compiler
1
0
Fork 0
mirror of https://github.com/vishapoberon/compiler.git synced 2026-10-10 02:47:23 +00:00
Code Issues Projects Releases Packages Wiki Activity Actions

Rename lib to library.

Browse source
This commit is contained in:
David Brown 2016-06-16 13:56:12 +01:00
parent b7536a8446
commit 1304822769
130 changed files with 0 additions and 0 deletions
Download patch file Download diff file Expand all files Collapse all files

20
src/library/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.

529
src/library/ooc/oocBinaryRider.Mod Normal file
View file

@ -0,0 +1,529 @@
(* $Id: BinaryRider.Mod,v 1.10 1999/10/31 13:49:45 ooc-devel Exp $ *)
MODULE oocBinaryRider (*[OOC_EXTENSIONS]*);
(*
BinaryRider - Binary-level input/output of Oberon variables.
Copyright (C) 1998, 1999 Michael van Acken
Copyright (C) 1997 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
Strings := oocStrings, Channel := oocChannel, SYSTEM, Msg := oocMsg;
CONST
(* result codes *)
done* = Channel.done;
invalidFormat* = Channel.invalidFormat;
readAfterEnd* = Channel.readAfterEnd;
(* possible endian settings *)
nativeEndian* = 0; (* do whatever the host machine uses *)
littleEndian* = 1; (* read/write least significant byte first *)
bigEndian* = 2; (* read/write most significant byte first *)
TYPE
Reader* = POINTER TO ReaderDesc;
ReaderDesc* = RECORD
res*: Msg.Msg; (* READ-ONLY *)
byteOrder-: SHORTINT; (* endian settings for the reader *)
byteReader-: Channel.Reader; (* only to be used by extensions of Reader *)
base-: Channel.Channel;
END;
Writer* = POINTER TO WriterDesc;
WriterDesc* = RECORD
res*: Msg.Msg; (* READ-ONLY *)
byteOrder-: SHORTINT; (* endian settings for the writer *)
byteWriter-: Channel.Writer; (* only to be used by extensions of Writer *)
base-: Channel.Channel;
END;
VAR
systemByteOrder: SHORTINT; (* default CPU endian setting *)
TYPE
ErrorContext = POINTER TO ErrorContextDesc;
ErrorContextDesc* = RECORD
(* this record is exported, so that extensions of Channel can access the
error descriptions by extending `ErrorContextDesc' *)
(Channel.ErrorContextDesc)
END;
VAR
errorContext: ErrorContext;
PROCEDURE GetError (code: Msg.Code): Msg.Msg;
BEGIN
RETURN Msg.New (errorContext, code)
END GetError;
(* Reader methods
------------------------------------------------------------------------ *)
(* The following methods read a value of the given type from the current
position in the BinaryReader.
Iff the value is invalid for its type, 'r.res' is 'invalidFormat'
Iff there aren't enough bytes to satisfy the request, 'r.res' is
'readAfterEnd'.
*)
PROCEDURE (r: Reader) Pos* () : LONGINT;
BEGIN
RETURN r.byteReader.Pos()
END Pos;
PROCEDURE (r: Reader) SetPos* (newPos: LONGINT);
BEGIN
IF (r. res = done) THEN
r.byteReader.SetPos(newPos);
r.res := r.byteReader.res
END
END SetPos;
PROCEDURE (r: Reader) ClearError*;
BEGIN
r.byteReader.ClearError;
r.res := done
END ClearError;
PROCEDURE (r: Reader) Available * () : LONGINT;
BEGIN
RETURN r.byteReader.Available()
END Available;
PROCEDURE (r: Reader) ReadBytes * (VAR x: ARRAY OF SYSTEM.BYTE;
start, n: LONGINT);
(* Read the bytes according to the native machine byte order. *)
BEGIN
IF (r.res = done) THEN
r.byteReader.ReadBytes(x, start, n);
r.res := r.byteReader.res
END
END ReadBytes;
PROCEDURE (r: Reader) ReadBytesOrdered (VAR x: ARRAY OF SYSTEM.BYTE);
(* Read the bytes according to the Reader byte order setting. *)
VAR i: LONGINT;
BEGIN
IF (r.byteOrder=nativeEndian) OR (r.byteOrder=systemByteOrder) THEN
r.byteReader.ReadBytes(x, 0, LEN(x))
ELSE (* swap bytes of value *)
FOR i:=LEN(x)-1 TO 0 BY -1 DO r.byteReader.ReadByte(x[i]) END
END
END ReadBytesOrdered;
PROCEDURE (r: Reader) ReadBool*(VAR bool: BOOLEAN);
VAR byte: SHORTINT;
BEGIN
IF (r.res = done) THEN
r. byteReader. ReadByte (byte);
IF (r. byteReader. res = done) & (byte # 0) & (byte # 1) THEN
r. res := GetError (invalidFormat)
ELSE
r. res := r. byteReader. res
END;
bool := (byte # 0)
END
END ReadBool;
PROCEDURE (r: Reader) ReadChar* (VAR ch: CHAR);
BEGIN
IF (r.res = done) THEN
r. byteReader.ReadByte (ch);
r.res := r.byteReader.res
END
END ReadChar;
PROCEDURE (r: Reader) ReadLChar*(VAR ch: CHAR);
BEGIN
IF (r.res = done) THEN
r. ReadBytesOrdered (ch);
r.res := r.byteReader.res
END
END ReadLChar;
PROCEDURE (r: Reader) ReadString* (VAR s: ARRAY OF CHAR);
(* A string is filled until 0X is encountered, there are no more characters
in the channel or the string is filled. It is always terminated with 0X.
*)
VAR
cnt, len: INTEGER;
BEGIN
IF (r.res = done) THEN
len:=SHORT(LEN(s)-1); cnt:=-1;
REPEAT
INC(cnt); r.ReadChar(s[cnt])
UNTIL (s[cnt]=0X) OR (r.byteReader.res#done) OR (cnt=len);
IF (r. byteReader. res = done) & (s[cnt] # 0X) THEN
r.byteReader.res := GetError (invalidFormat);
s[cnt]:=0X
ELSE
r.res := r.byteReader.res
END
END
END ReadString;
PROCEDURE (r: Reader) ReadLString* (VAR s: ARRAY OF CHAR);
(* A string is filled until 0X is encountered, there are no more characters
in the channel or the string is filled. It is always terminated with 0X.
*)
VAR
cnt, len: INTEGER;
BEGIN
IF (r.res = done) THEN
len:=SHORT(LEN(s)-1); cnt:=-1;
REPEAT
INC(cnt); r.ReadLChar(s[cnt])
UNTIL (s[cnt]=0X) OR (r.byteReader.res#done) OR (cnt=len);
IF (r. byteReader. res = done) & (s[cnt] # 0X) THEN
r.byteReader.res := GetError (invalidFormat);
s[cnt]:=0X
ELSE
r.res := r.byteReader.res
END
END
END ReadLString;
PROCEDURE (r: Reader) ReadSInt*(VAR sint: SHORTINT);
BEGIN
IF (r.res = done) THEN
r.byteReader.ReadByte(sint); (* SIZE(SYSTEM.BYTE) = SIZE(SHORTINT) *) ;
r.res := r.byteReader.res
END
END ReadSInt;
PROCEDURE (r: Reader) ReadInt*(VAR int: INTEGER);
BEGIN
IF (r.res = done) THEN
r.ReadBytesOrdered(int);
r.res := r.byteReader.res
END
END ReadInt;
PROCEDURE (r: Reader) ReadLInt*(VAR lint: LONGINT);
(* see ReadInt *)
BEGIN
IF (r.res = done) THEN
r.ReadBytesOrdered(lint);
r.res := r.byteReader.res
END
END ReadLInt;
PROCEDURE (r: Reader) ReadNum*(VAR num: LONGINT);
(* Read integers in a compressed and portable format. *)
VAR s: SHORTINT; x: CHAR; y: LONGINT;
BEGIN
s:=0; y:=0; r.ReadChar(x);
WHILE (s < 28) & (x >= 80X) DO
INC(y, ASH(LONG(ORD(x))-128, s)); INC(s, 7);
r.ReadChar(x)
END;
(* Q: (s = 28) OR (x < 80X) *)
IF (x >= 80X) OR (* with s=28 this means we have more than 5 digits *)
(s = 28) & (8X <= x) & (x < 78X) & (* overflow in most sig byte *)
(r. byteReader. res = done) THEN
r. res := GetError (invalidFormat)
ELSE
num:=ASH(SYSTEM.LSH(LONG(ORD(x)), 25), s-25)+y;
r. res := r. byteReader. res
END
END ReadNum;
PROCEDURE (r: Reader) ReadReal*(VAR real: REAL);
(* see ReadInt *)
BEGIN
IF (r.res = done) THEN
r.ReadBytesOrdered(real);
r.res := r.byteReader.res
END
END ReadReal;
PROCEDURE (r: Reader) ReadLReal*(VAR lreal: LONGREAL);
(* see ReadInt *)
BEGIN
IF (r.res = done) THEN
r.ReadBytesOrdered(lreal);
r.res := r.byteReader.res
END
END ReadLReal;
PROCEDURE (r: Reader) ReadSet*(VAR s: SET);
BEGIN
IF (r.res = done) THEN
r.ReadBytesOrdered(s);
r.res := r.byteReader.res
END
END ReadSet;
PROCEDURE (r: Reader) SetByteOrder* (order: SHORTINT);
BEGIN
ASSERT((order>=nativeEndian) & (order<=bigEndian));
r.byteOrder:=order
END SetByteOrder;
(* Writer methods
------------------------------------------------------------------------ *)
(* The Write-methods write the value to the underlying channel. It is
possible that only part of the value is written
*)
PROCEDURE (w: Writer) Pos* () : LONGINT;
BEGIN
RETURN w.byteWriter.Pos()
END Pos;
PROCEDURE (w: Writer) SetPos* (newPos: LONGINT);
BEGIN
IF (w.res = done) THEN
w.byteWriter.SetPos(newPos);
w.res := w.byteWriter.res
END
END SetPos;
PROCEDURE (w: Writer) ClearError*;
BEGIN
w.byteWriter.ClearError;
w.res := done
END ClearError;
PROCEDURE (w: Writer) WriteBytes * (VAR x: ARRAY OF SYSTEM.BYTE;
start, n: LONGINT);
(* Write the bytes according to the native machine byte order. *)
BEGIN
IF (w.res = done) THEN
w.byteWriter.WriteBytes(x, start, n);
w.res := w.byteWriter.res
END
END WriteBytes;
PROCEDURE (w: Writer) WriteBytesOrdered (VAR x: ARRAY OF SYSTEM.BYTE);
(* Write the bytes according to the Writer byte order setting. *)
VAR i: LONGINT;
BEGIN
IF (w.byteOrder=nativeEndian) OR (w.byteOrder=systemByteOrder) THEN
w.byteWriter.WriteBytes(x, 0, LEN(x))
ELSE
FOR i:=LEN(x)-1 TO 0 BY -1 DO w.byteWriter.WriteByte(x[i]) END
END
END WriteBytesOrdered;
PROCEDURE (w: Writer) WriteBool*(bool: BOOLEAN);
BEGIN
IF (w.res = done) THEN
IF bool THEN
w. byteWriter. WriteByte (1)
ELSE
w. byteWriter. WriteByte (0)
END;
w. res := w. byteWriter. res
END
END WriteBool;
PROCEDURE (w: Writer) WriteChar*(ch: CHAR);
BEGIN
IF (w.res = done) THEN
w. byteWriter. WriteByte(ch);
w.res := w.byteWriter.res
END
END WriteChar;
PROCEDURE (w: Writer) WriteLChar*(ch: CHAR);
BEGIN
IF (w.res = done) THEN
w. WriteBytesOrdered (ch);
w.res := w.byteWriter.res
END
END WriteLChar;
PROCEDURE (w: Writer) WriteString*(s(*[NO_COPY]*): ARRAY OF CHAR);
(* The terminating 0X is also written *)
BEGIN
IF (w.res = done) THEN
w.byteWriter.WriteBytes (s, 0, Strings.Length (s)+1);
w.res := w.byteWriter.res
END
END WriteString;
PROCEDURE (w: Writer) WriteLString*(s(*[NO_COPY]*): ARRAY OF CHAR);
(* The terminating 0X is also written *)
VAR
i: LONGINT;
BEGIN
IF (w.res = done) THEN
i := -1;
REPEAT
INC (i);
w. WriteLChar (s[i])
UNTIL (s[i] = 0X);
w.res := w.byteWriter.res
END
END WriteLString;
PROCEDURE (w: Writer) WriteSInt*(sint: SHORTINT);
BEGIN
IF (w.res = done) THEN
w.byteWriter.WriteByte(sint);
w.res := w.byteWriter.res
END
END WriteSInt;
PROCEDURE (w: Writer) WriteInt*(int: INTEGER);
BEGIN
IF (w.res = done) THEN
w.WriteBytesOrdered(int);
w.res := w.byteWriter.res
END
END WriteInt;
PROCEDURE (w: Writer) WriteLInt*(lint: LONGINT);
(* see WriteInt *)
BEGIN
IF (w.res = done) THEN
w.WriteBytesOrdered(lint);
w.res := w.byteWriter.res
END
END WriteLInt;
PROCEDURE (w: Writer) WriteNum*(lint: LONGINT);
(* Write integers in a compressed and portable format. *)
BEGIN
IF (w.res = done) THEN
WHILE (lint<-64) OR (lint>63) DO
w.WriteChar(CHR(lint MOD 128+128));
lint:=lint DIV 128
END;
w.WriteChar(CHR(lint MOD 128));
w.res := w.byteWriter.res
END
END WriteNum;
(* see WriteInt *)
PROCEDURE (w: Writer) WriteReal*(real: REAL);
BEGIN
IF (w.res = done) THEN
w.WriteBytesOrdered(real);
w.res := w.byteWriter.res
END
END WriteReal;
PROCEDURE (w: Writer) WriteLReal*(lreal: LONGREAL);
(* see WriteInt *)
BEGIN
IF (w.res = done) THEN
w.WriteBytesOrdered(lreal);
w.res := w.byteWriter.res
END
END WriteLReal;
PROCEDURE (w: Writer) WriteSet*(s: SET);
BEGIN
IF (w.res = done) THEN
w.WriteBytesOrdered(s);
w.res := w.byteWriter.res
END
END WriteSet;
PROCEDURE (w: Writer) SetByteOrder* (order: SHORTINT);
BEGIN
ASSERT((order>=nativeEndian) & (order<=bigEndian));
w.byteOrder:=order
END SetByteOrder;
(* Reader Procedures
------------------------------------------------------------------------ *)
(* Create a new Reader and attach it to the Channel ch. NIL is
returned when it is not possible to read from the channel.
The Reader is positioned at the beginning for positionable
channels and at the current position for non-positionable channels.
*)
PROCEDURE InitReader* (r: Reader; ch: Channel.Channel; byteOrder: SHORTINT);
BEGIN
r. res := done;
r. byteReader := ch. NewReader();
r. byteOrder := byteOrder;
r. base := ch;
END InitReader;
PROCEDURE ConnectReader*(ch: Channel.Channel): Reader;
VAR
r: Reader;
BEGIN
NEW (r);
InitReader (r, ch, littleEndian);
IF (r. byteReader = NIL) THEN
RETURN NIL
ELSE
RETURN r
END
END ConnectReader;
(* Writer Procedures
------------------------------------------------------------------------ *)
(* Create a new Writer and attach it to the Channel ch. NIL is
returned when it is not possible to write to the channel.
The Writer is positioned at the beginning for positionable
channels and at the current position for non-positionable channels.
*)
PROCEDURE InitWriter* (w: Writer; ch: Channel.Channel; byteOrder: SHORTINT);
BEGIN
w. res := done;
w. byteWriter := ch. NewWriter();
w. byteOrder := byteOrder;
w. base := ch;
END InitWriter;
PROCEDURE ConnectWriter*(ch: Channel.Channel): Writer;
VAR
w: Writer;
BEGIN
NEW (w);
InitWriter (w, ch, littleEndian);
IF (w. byteWriter = NIL) THEN
RETURN NIL
ELSE
RETURN w
END
END ConnectWriter;
PROCEDURE SetDefaultByteOrder(VAR x: ARRAY OF SYSTEM.BYTE);
BEGIN
IF SYSTEM.VAL(CHAR, x[0])=1X THEN
systemByteOrder:=littleEndian
ELSE
systemByteOrder:=bigEndian
END
END SetDefaultByteOrder;
PROCEDURE Init;
VAR i: INTEGER;
BEGIN
i:=1; SetDefaultByteOrder(i)
END Init;
BEGIN
NEW (errorContext);
Msg.InitContext (errorContext, "OOC:Core:BinaryRider");
Init
END oocBinaryRider.

72
src/library/ooc/oocCILP32.Mod Normal file
View file

@ -0,0 +1,72 @@
(* $Id: C.Mod,v 1.9 1999/10/03 11:46:01 ooc-devel Exp $ *)
MODULE oocC;
(* Basic data types for interfacing to C code.
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.
*)
IMPORT
SYSTEM;
(*
These types are intended to be equivalent to their C counterparts.
They may vary depending on your system, but as long as you stick to a 32 Bit
Unix they should be fairly safe.
*)
TYPE
char* = CHAR;
signedchar* = SHORTINT; (* signed char *)
shortint* = INTEGER; (* short int *)
int* = LONGINT;
set* = SET; (* unsigned int, used as set *)
longint* = LONGINT; (* long int *)
(*longset* = SYSTEM.SET64; *) (* unsigned long, used as set *)
longset* = SET;
address* = LONGINT;
float* = REAL;
double* = LONGREAL;
enum1* = int;
enum2* = int;
enum4* = int;
(* if your C compiler uses short enumerations, you'll have to replace the
declarations above with
enum1* = SHORTINT;
enum2* = INTEGER;
enum4* = LONGINT;
*)
FILE* = address; (* this is acually a replacement for `FILE*', i.e., for a pointer type *)
sizet* = longint;
uidt* = int;
gidt* = int;
TYPE (* some commonly used C array types *)
charPtr1d* = POINTER TO ARRAY OF char;
charPtr2d* = POINTER TO ARRAY OF charPtr1d;
intPtr1d* = POINTER TO ARRAY OF int;
TYPE (* C string type, assignment compatible with character arrays and
string constants *)
string* = POINTER TO ARRAY OF char;
TYPE
Proc* = PROCEDURE;
END oocC.

71
src/library/ooc/oocCLLP64.Mod Normal file
View file

@ -0,0 +1,71 @@
(* $Id: C.Mod,v 1.9 1999/10/03 11:46:01 ooc-devel Exp $ *)
MODULE oocC;
(* Basic data types for interfacing to C code.
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.
*)
IMPORT
SYSTEM;
(*
These types are intended to be equivalent to their C counterparts.
They may vary depending on your system, but as long as you stick to a 32 Bit
Unix they should be fairly safe.
*)
TYPE
char* = CHAR;
signedchar* = SHORTINT; (* signed char *)
shortint* = RECORD a,b : SYSTEM.BYTE END; (* 2 bytes on x64_64 *) (* short int *)
int* = INTEGER;
set* = INTEGER;(*SET;*) (* unsigned int, used as set *)
longint* = LONGINT; (* long int *)
longset* = SET; (*SYSTEM.SET64; *) (* unsigned long, used as set *)
address* = LONGINT; (*SYSTEM.ADDRESS;*)
float* = REAL;
double* = LONGREAL;
enum1* = int;
enum2* = int;
enum4* = int;
(* if your C compiler uses short enumerations, you'll have to replace the
declarations above with
enum1* = SHORTINT;
enum2* = INTEGER;
enum4* = LONGINT;
*)
FILE* = address; (* this is acually a replacement for `FILE*', i.e., for a pointer type *)
sizet* = longint;
uidt* = int;
gidt* = int;
TYPE (* some commonly used C array types *)
charPtr1d* = POINTER TO ARRAY OF char;
charPtr2d* = POINTER TO ARRAY OF charPtr1d;
intPtr1d* = POINTER TO ARRAY OF int;
TYPE (* C string type, assignment compatible with character arrays and
string constants *)
string* = POINTER (*[CSTRING]*) TO ARRAY OF char;
TYPE
Proc* = PROCEDURE;
END oocC.

71
src/library/ooc/oocCLP64.Mod Normal file
View file

@ -0,0 +1,71 @@
(* $Id: C.Mod,v 1.9 1999/10/03 11:46:01 ooc-devel Exp $ *)
MODULE oocC;
(* Basic data types for interfacing to C code.
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.
*)
IMPORT
SYSTEM;
(*
These types are intended to be equivalent to their C counterparts.
They may vary depending on your system, but as long as you stick to a 32 Bit
Unix they should be fairly safe.
*)
TYPE
char* = CHAR;
signedchar* = SHORTINT; (* signed char *)
shortint* = RECORD a,b : SYSTEM.BYTE END; (* 2 bytes on x64_64 *) (* short int *)
int* = INTEGER;
set* = INTEGER;(*SET;*) (* unsigned int, used as set *)
longint* = LONGINT; (* long int *)
longset* = SET; (*SYSTEM.SET64; *) (* unsigned long, used as set *)
address* = LONGINT; (*SYSTEM.ADDRESS;*)
float* = REAL;
double* = LONGREAL;
enum1* = int;
enum2* = int;
enum4* = int;
(* if your C compiler uses short enumerations, you'll have to replace the
declarations above with
enum1* = SHORTINT;
enum2* = INTEGER;
enum4* = LONGINT;
*)
FILE* = address; (* this is acually a replacement for `FILE*', i.e., for a pointer type *)
sizet* = longint;
uidt* = int;
gidt* = int;
TYPE (* some commonly used C array types *)
charPtr1d* = POINTER TO ARRAY OF char;
charPtr2d* = POINTER TO ARRAY OF charPtr1d;
intPtr1d* = POINTER TO ARRAY OF int;
TYPE (* C string type, assignment compatible with character arrays and
string constants *)
string* = POINTER (*[CSTRING]*) TO ARRAY OF char;
TYPE
Proc* = PROCEDURE;
END oocC.

611
src/library/ooc/oocChannel.Mod Normal file
View file

@ -0,0 +1,611 @@
(* $Id: Channel.Mod,v 1.10 1999/10/31 13:35:12 ooc-devel Exp $ *)
MODULE oocChannel;
(* Provides abstract data types Channel, Reader, and Writer for stream I/O.
Copyright (C) 1997-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.
*)
(*
Note 0:
All types and procedures declared in this module have to be considered
abstract, i.e., they are never instanciated or called. The provided procedure
bodies are nothing but hints how a specific channel could start implementing
them.
Note 1:
A module implementing specific channels (e.g., files, or TCP streams) will
provide the procedures
PROCEDURE New* (...): Channel;
and (optionally)
PROCEDURE Old* (...): Channel.
For channels that correspond to a piece of data that can be both read
and changed, the first procedure will create a new channel for the
given data location, deleting all data previously contained in it.
The latter will open a channel to the existing data.
For channels representing a unidirectional byte stream (like output to
/ input from terminal, or a TCP stream), only a procedure New is
provided. It will create a connection with the designated location.
The formal parameters of these procedures will include some kind of
reference to the data being opened (e.g. a file name) and, optionally,
flags that modify the way the channel is opened (e.g. read-only,
write-only, etc). Their interface therefore depends on the channel
and is not part of this specification. The standard way to create new
channels is to call the type-bound procedures Locator.New and
Locator.Old (which in turn will call the above mentioned procedures).
Note 2:
A channel implementation should state how many channels can be open
simultaneously. It's common for the OS to support just so many open files or
so many open sockets at the same time. Since this value isn't a constant, it's
only required to give a statement on the number of open connections for the
best case, and which factors can lower this number.
Note 3:
A number of record fields in Channel, Reader, and Writer are exported
with write permissions. This is done to permit specializations of the
classes to change these fields. The user should consider them
read-only.
*)
IMPORT
SYSTEM, Strings := oocStrings, Time := oocTime, Msg := oocMsg;
TYPE
Result* = Msg.Msg;
CONST
noLength* = -1;
(* result value of Channel.Length if the queried channel has no fixed length
(e.g., if it models input from keybord, or output to terminal) *)
noPosition* = -2;
(* result value of Reader/Writer.Pos if the queried rider has no concept of
an indexed reading resp. writing position (e.g., if it models input from
keybord, or output to terminal) *)
(* Note: The below list of error codes only covers the most typical errors.
A specific channel implementation (like Files) will define its own list
own codes, containing aliases for the codes below (when appropriate) plus
error codes of its own. Every module will provide an error context (an
instance of Msg.Context) to translate any code into a human readable
message. *)
(* a `res' value of `done' means successful completion of the I/O
operation: *)
done* = NIL;
(* the following values may appear in the `res.code' field of `Channel',
`Reader', or `Writer': *)
(* indicates successful completion of last operation *)
invalidChannel* = 1;
(* the channel channel isn't valid, e.g. because it wasn't opened in the
first place or was corrupted somehow; for a rider this refers to the
channel in the `base' field *)
writeError* = 2;
(* a write error occured; usually this error happens with a writer, but for
buffered channels this may also occur during a `Flush' or a `Close' *)
noRoom* = 3;
(* set if a write operation failed because there isn't any space left on the
device, e.g. if the disk is full or you exeeded your quota; usually this
error happens with a writer, but for buffered channels this may also
occur during a `Flush' or a `Close' *)
(* symbolic values for `Reader.res.code' resp. `Writer.res.code': *)
outOfRange* = 4;
(* set if `SetPos' has been called with a negative argument or it has been
called on a rider that doesn't support positioning *)
readAfterEnd* = 5;
(* set if a call to `ReadByte' or `ReadBytes' tries to access a byte beyond
the end of the file (resp. channel); this means that there weren't enough
bytes left or the read operation started at (or after) the end *)
channelClosed* = 6;
(* set if the rider's channel has been closed, preventing any further read or
write operations; this means you called Channel.Close() (in which case you
made a programming error), or the process at the other end of the channel
closed the connection (examples for this are pipes, FIFOs, tcp streams) *)
readError* = 7;
(* unspecified read error *)
invalidFormat* = 8;
(* set by an interpreting Reader (e.g., TextRiders.Reader) if the byte stream
at the current reading position doesn't represent an object of the
requested type *)
(* symbolic values for `Channel.res.code': *)
noReadAccess* = 9;
(* set if NewReader was called to create a reader on a channel that doesn't
allow reading access *)
noWriteAccess* = 10;
(* set if NewWriter was called to create a reader on a channel that doesn't
allow reading access *)
closeError* = 11;
(* set if closing the channel failed for some reason *)
noModTime* = 12;
(* set if no modification time is available for the given channel *)
noTmpName* = 13;
(* creation of a temporary file failed because the system was unable to
assign an unique name to it; closing or registering an existing temporary
file beforehand might help *)
freeErrorCode* = 14;
(* specific channel implemenatations can start defining their own additional
error codes for Channel.res, Reader.res, and Writer.res here *)
TYPE
Channel* = POINTER TO ChannelDesc;
ChannelDesc* = RECORD (*[ABSTRACT]*)
res*: Result; (* READ-ONLY *)
(* Error flag signalling failure of a call to NewReader, NewWriter, Flush,
or Close. Initialized to `done' when creating the channel. Every
operation sets this to `done' on success, or to a message object to
indicate the error source. *)
readable*: BOOLEAN; (* READ-ONLY *)
(* TRUE iff readers can be attached to this channel with NewReader *)
writable*: BOOLEAN; (* READ-ONLY *)
(* TRUE iff writers can be attached to this channel with NewWriter *)
open*: BOOLEAN; (* READ-ONLY *)
(* Channel status. Set to TRUE on channel creation, set to FALSE by
calling Close. Closing a channel prevents all further read or write
operations on it. *)
END;
TYPE
Reader* = POINTER TO ReaderDesc;
ReaderDesc* = RECORD (*[ABSTRACT]*)
base*: Channel; (* READ-ONLY *)
(* This field refers to the channel the Reader is connected to. *)
res*: Result; (* READ-ONLY *)
(* Error flag signalling failure of a call to ReadByte, ReadBytes, or
SetPos. Initialized to `done' when creating a Reader or by calling
ClearError. The first failed reading (or SetPos) operation changes this
to indicate the error, all further calls to ReadByte, ReadBytes, or
SetPos will be ignored until ClearError resets this flag. This means
that the successful completion of an arbitrary complex sequence of read
operations can be ensured by asserting that `res' equals `done'
beforehand and also after the last operation. *)
bytesRead*: LONGINT; (* READ-ONLY *)
(* Set by ReadByte and ReadBytes to indicate the number of bytes that were
successfully read. *)
positionable*: BOOLEAN; (* READ-ONLY *)
(* TRUE iff the Reader can be moved to another position with `SetPos'; for
channels that can only be read sequentially, like input from keyboard,
this is FALSE. *)
END;
TYPE
Writer* = POINTER TO WriterDesc;
WriterDesc* = RECORD (*[ABSTRACT]*)
base*: Channel; (* READ-ONLY *)
(* This field refers to the channel the Writer is connected to. *)
res*: Result; (* READ-ONLY *)
(* Error flag signalling failure of a call to WriteByte, WriteBytes, or
SetPos. Initialized to `done' when creating a Writer or by calling
ClearError. The first failed writing (or SetPos) operation changes this
to indicate the error, all further calls to WriteByte, WriteBytes, or
SetPos will be ignored until ClearError resets this flag. This means
that the successful completion of an arbitrary complex sequence of write
operations can be ensured by asserting that `res' equals `done'
beforehand and also after the last operation. Note that due to
buffering a write error may occur when flushing or closing the
underlying file, so you have to check the channel's `res' field after
any Flush() or the final Close(), too. *)
bytesWritten*: LONGINT; (* READ-ONLY *)
(* Set by WriteByte and WriteBytes to indicate the number of bytes that
were successfully written. *)
positionable*: BOOLEAN; (* READ-ONLY *)
(* TRUE iff the Writer can be moved to another position with `SetPos'; for
channels that can only be written sequentially, like output to terminal,
this is FALSE. *)
END;
TYPE
ErrorContext = POINTER TO ErrorContextDesc;
ErrorContextDesc* = RECORD
(* this record is exported, so that extensions of Channel can access the
error descriptions by extending `ErrorContextDesc' *)
(Msg.ContextDesc)
END;
VAR
errorContext: ErrorContext;
PROCEDURE GetError (code: Msg.Code): Result;
BEGIN
RETURN Msg.New (errorContext, code)
END GetError;
PROCEDURE (context: ErrorContext) GetTemplate* (msg: Msg.Msg; VAR templ: Msg.LString);
(* Translates this module's error codes into strings. The string usually
contains a short error description, possibly followed by some attributes
to provide additional information for the problem.
The method should not be called directly by the user. It is invoked by
`res.GetText()' or `res.GetLText'. *)
VAR
str: ARRAY 128 OF CHAR;
BEGIN
CASE msg. code OF
| invalidChannel: str := "Invalid channel descriptor"
| writeError: str := "Write error"
| noRoom: str := "No space left on device"
| outOfRange: str := "Trying to set invalid position"
| readAfterEnd: str := "Trying to read past the end of the file"
| channelClosed: str := "Channel has been closed"
| readError: str := "Read error"
| invalidFormat: str := "Invalid token type in input stream"
| noReadAccess: str := "No read permission for channel"
| noWriteAccess: str := "No write permission for channel"
| closeError: str := "Error while closing the channel"
| noModTime: str := "No modification time available"
| noTmpName: str := "Failed to create unique name for temporary file"
ELSE
str := "[unknown error code]"
END;
COPY (str, templ)
END GetTemplate;
(* Reader methods
------------------------------------------------------------------------ *)
PROCEDURE (r: Reader) (*[ABSTRACT]*) Pos*(): LONGINT;
(* Returns the current reading position associated with the reader `r' in
channel `r.base', i.e. the index of the first byte that is read by the
next call to ReadByte resp. ReadBytes. This procedure will return
`noPosition' if the reader has no concept of a reading position (e.g. if it
corresponds to input from keyboard), otherwise the result is not negative.*)
END Pos;
PROCEDURE (r: Reader) (*[ABSTRACT]*) Available*(): LONGINT;
(* Returns the number of bytes available for the next reading operation. For
a file this is the length of the channel `r.base' minus the current reading
position, for an sequential channel (or a channel designed to handle slow
transfer rates) this is the number of bytes that can be accessed without
additional waiting. The result is -1 if Close() was called for the channel,
or no more byte are available and the remote end of the channel has been
closed.
Note that the number of bytes returned is always a lower approximation of
the number that could be read at once; for some channels or systems it might
be as low as 1 even if tons of bytes are waiting to be processed. *)
(* example:
BEGIN
IF r. base. open THEN
i := r. base. Length() - r. Pos();
IF (i < 0) THEN
RETURN 0
ELSE
RETURN i
END
ELSE
RETURN -1
END
*)
END Available;
PROCEDURE (r: Reader) (*[ABSTRACT]*) SetPos* (newPos: LONGINT);
(* Sets the reading position to `newPos'. A negative value of `newPos' or
calling this procedure for a reader that doesn't allow positioning will set
`r.res' to `outOfRange'. A value larger than the channel's length is legal,
but the following read operation will most likely fail with an
`readAfterEnd' error unless the channel has grown beyond this position in
the meantime.
Calls to this procedure while `r.res # done' will be ignored, in particular
a call with `r.res.code = readAfterEnd' error will not reset `res' to
`done'. *)
(* example:
BEGIN
IF (r. res = done) THEN
IF ~r. positionable OR (newPos < 0) THEN
r. res := GetError (outOfRange)
ELSIF r. base. open THEN
(* ... *)
ELSE (* channel has been closed *)
r. res := GetError (channelClosed)
END
END
*)
END SetPos;
PROCEDURE (r: Reader) (*[ABSTRACT]*) ReadByte* (VAR x: SYSTEM.BYTE);
(* Reads a single byte from the channel `r.base' at the reading position
associated with `r' and places it in `x'. The reading position is moved
forward by one byte on success, otherwise `r.res' is changed to indicate
the error cause. Calling this procedure with the reader `r' placed at the
end (or beyond the end) of the channel will set `r.res' to `readAfterEnd'.
`r.bytesRead' will be 1 on success and 0 on failure.
Calls to this procedure while `r.res # done' will be ignored. *)
(* example:
BEGIN
IF (r. res = done) THEN
IF r. base. open THEN
(* ... *)
ELSE (* channel has been closed *)
r. res := GetError (channelClosed);
r. bytesRead := 0
END
ELSE
r. bytesRead := 0
END
*)
END ReadByte;
PROCEDURE (r: Reader) (*[ABSTRACT]*) ReadBytes* (VAR x: ARRAY OF SYSTEM.BYTE;
start, n: LONGINT);
(* Reads `n' bytes from the channel `r.base' at the reading position associated
with `r' and places them in `x', starting at index `start'. The
reading position is moved forward by `n' bytes on success, otherwise
`r.res' is changed to indicate the error cause. Calling this procedure with
the reader `r' placed less than `n' bytes before the end of the channel will
will set `r.res' to `readAfterEnd'. `r.bytesRead' will hold the number of
bytes that were actually read (being equal to `n' on success).
Calls to this procedure while `r.res # done' will be ignored.
pre: (n >= 0) & (0 <= start) & (start+n <= LEN (x)) *)
(* example:
BEGIN
ASSERT ((n >= 0) & (0 <= start) & (start+n <= LEN (x)));
IF (r. res = done) THEN
IF r. base. open THEN
(* ... *)
ELSE (* channel has been closed *)
r. res := GetError (channelClosed);
r. bytesRead := 0
END
ELSE
r. bytesRead := 0
END
*)
END ReadBytes;
PROCEDURE (r: Reader) ClearError*;
(* Sets the result flag `r.res' to `done', re-enabling further read operations
on `r'. *)
BEGIN
r. res := done
END ClearError;
(* Writer methods
------------------------------------------------------------------------ *)
PROCEDURE (w: Writer) (*[ABSTRACT]*) Pos*(): LONGINT;
(* Returns the current writing position associated with the writer `w' in
channel `w.base', i.e. the index of the first byte that is written by the
next call to WriteByte resp. WriteBytes. This procedure will return
`noPosition' if the writer has no concept of a writing position (e.g. if it
corresponds to output to terminal), otherwise the result is not negative. *)
END Pos;
PROCEDURE (w: Writer) (*[ABSTRACT]*) SetPos* (newPos: LONGINT);
(* Sets the writing position to `newPos'. A negative value of `newPos' or
calling this procedure for a writer that doesn't allow positioning will set
`w.res' to `outOfRange'. A value larger than the channel's length is legal,
the following write operation will fill the gap between the end of the
channel and this position with zero bytes.
Calls to this procedure while `w.res # done' will be ignored. *)
(* example:
BEGIN
IF (w. res = done) THEN
IF ~w. positionable OR (newPos < 0) THEN
w. res := GetError (outOfRange)
ELSIF w. base. open THEN
(* ... *)
ELSE (* channel has been closed *)
w. res := GetError (channelClosed)
END
END
*)
END SetPos;
PROCEDURE (w: Writer) (*[ABSTRACT]*) WriteByte* (x: SYSTEM.BYTE);
(* Writes a single byte `x' to the channel `w.base' at the writing position
associated with `w'. The writing position is moved forward by one byte on
success, otherwise `w.res' is changed to indicate the error cause.
`w.bytesWritten' will be 1 on success and 0 on failure.
Calls to this procedure while `w.res # done' will be ignored. *)
(* example:
BEGIN
IF (w. res = done) THEN
IF w. base. open THEN
(* ... *)
ELSE (* channel has been closed *)
w. res := GetError (channelClosed);
w. bytesWritten := 0
END
ELSE
w. bytesWritten := 0
END
*)
END WriteByte;
PROCEDURE (w: Writer) (*[ABSTRACT]*) WriteBytes* (VAR x: ARRAY OF SYSTEM.BYTE;
start, n: LONGINT);
(* Writes `n' bytes from `x', starting at position `start', to the channel
`w.base' at the writing position associated with `w'. The writing position
is moved forward by `n' bytes on success, otherwise `w.res' is changed to
indicate the error cause. `w.bytesWritten' will hold the number of bytes
that were actually written (being equal to `n' on success).
Calls to this procedure while `w.res # done' will be ignored.
pre: (n >= 0) & (0 <= start) & (start+n <= LEN (x)) *)
(* example:
BEGIN
ASSERT ((n >= 0) & (0 <= start) & (start+n <= LEN (x)));
IF (w. res = done) THEN
IF w. base. open THEN
(* ... *)
ELSE (* channel has been closed *)
w. res := GetError (channelClosed);
w. bytesWritten := 0
END
ELSE
w. bytesWritten := 0
END
*)
END WriteBytes;
PROCEDURE (w: Writer) ClearError*;
(* Sets the result flag `w.res' to `done', re-enabling further write operations
on `w'. *)
BEGIN
w. res := done
END ClearError;
(* Channel methods
------------------------------------------------------------------------ *)
PROCEDURE (ch: Channel) (*[ABSTRACT]*) Length*(): LONGINT;
(* Result is the number of bytes of data that this channel refers to. If `ch'
represents a file, then this value is the file's size. If `ch' has no fixed
length (e.g. because it's interactive), the result is `noLength'. *)
END Length;
PROCEDURE (ch: Channel) (*[ABSTRACT]*) GetModTime* (VAR mtime: Time.TimeStamp);
(* Retrieves the modification time of the data accessed by the given channel.
If no such information is avaiblable, `ch.res' is set to `noModTime',
otherwise to `done'. *)
END GetModTime;
PROCEDURE (ch: Channel) NewReader*(): Reader;
(* Attaches a new reader to the channel `ch'. It is placed at the very start
of the channel, and its `res' field is initialized to `done'. `ch.res' is
set to `done' on success and the new reader is returned. Otherwise result
is NIL and `ch.res' is changed to indicate the error cause.
Note that always the same reader is returned if the channel does not support
multiple reading positions. *)
(* example:
BEGIN
IF ch. open THEN
IF ch. readable THEN
(* ... *)
ch. ClearError
ELSE
ch. res := noReadAccess;
RETURN NIL
END
ELSE
ch. res := channelClosed;
RETURN NIL
END
*)
BEGIN (* default: channel does not have read access *)
IF ch. open THEN
ch. res := GetError (noReadAccess)
ELSE
ch. res := GetError (channelClosed)
END;
RETURN NIL
END NewReader;
PROCEDURE (ch: Channel) NewWriter*(): Writer;
(* Attaches a new writer to the channel `ch'. It is placed at the very start
of the channel, and its `res' field is initialized to `done'. `ch.res' is
set to `done' on success and the new writer is returned. Otherwise result
is NIL and `ch.res' is changed to indicate the error cause.
Note that always the same reader is returned if the channel does not support
multiple writing positions. *)
(* example:
BEGIN
IF ch. open THEN
IF ch. writable THEN
(* ... *)
ch. ClearError
ELSE
ch. res := GetError (noWriteAccess);
RETURN NIL
END
ELSE
ch. res := GetError (channelClosed);
RETURN NIL
END
*)
BEGIN (* default: channel does not have write access *)
IF ch. open THEN
ch. res := GetError (noWriteAccess)
ELSE
ch. res := GetError (channelClosed)
END;
RETURN NIL
END NewWriter;
PROCEDURE (ch: Channel) (*[ABSTRACT]*) Flush*;
(* Flushes all buffers related to this channel. Any pending write operations
are passed to the underlying OS and all buffers are marked as invalid. The
next read operation will get its data directly from the channel instead of
the buffer. If a writing error occurs during flushing, the field `ch.res'
will be changed to `writeError', otherwise it's assigned `done'. Note that
you have to check the channel's `res' flag after an explicit flush yourself,
since none of the attached writers will notice any write error in this
case. *)
(* example:
BEGIN
(* ... *)
IF (* write error ... *) FALSE THEN
ch. res := GetError (writeError)
ELSE
ch. ClearError
END
*)
END Flush;
PROCEDURE (ch: Channel) (*[ABSTRACT]*) Close*;
(* Flushes all buffers associated with `ch', closes the channel, and frees all
system resources allocated to it. This invalidates all riders attached to
`ch', they can't be used further. On success, i.e. if all read and write
operations (including flush) completed successfully, `ch.res' is set to
`done'. An opened channel can only be closed once, successive calls of
`Close' are undefined.
Note that unlike the Oberon System all opened channels have to be closed
explicitly. Otherwise resources allocated to them will remain blocked. *)
(* example:
BEGIN
ch. Flush;
IF (ch. res = done) THEN
(* ... *)
END;
ch. open := FALSE
*)
END Close;
PROCEDURE (ch: Channel) ClearError*;
(* Sets the result flag `ch.res' to `done'. *)
BEGIN
ch. res := done
END ClearError;
BEGIN
NEW (errorContext);
Msg.InitContext (errorContext, "OOC:Core:Channel")
END oocChannel.

95
src/library/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.

274
src/library/ooc/oocComplexMath.Mod Normal file
View file

@ -0,0 +1,274 @@
(* $Id: ComplexMath.Mod,v 1.5 1999/09/02 13:05:36 acken Exp $ *)
MODULE oocComplexMath;
(*
ComplexMath - Mathematical functions for the type COMPLEX.
Copyright (C) 1995-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 m := oocRealMath;
TYPE
COMPLEX * = POINTER TO COMPLEXDesc;
COMPLEXDesc = RECORD
r, i : REAL
END;
CONST
ZERO=0.0; HALF=0.5; ONE=1.0; TWO=2.0;
VAR
i-, one-, zero- : COMPLEX;
PROCEDURE CMPLX * (r, i: REAL): COMPLEX;
VAR c: COMPLEX;
BEGIN
NEW(c); c.r:=r; c.i:=i;
RETURN c
END CMPLX;
(*
NOTE: This function provides the only way
of reliably assigning COMPLEX numbers. DO
NOT use ` a := b' where a, b are COMPLEX!
*)
PROCEDURE Copy * (z: COMPLEX): COMPLEX;
BEGIN
RETURN CMPLX(z.r, z.i)
END Copy;
PROCEDURE RealPart * (z: COMPLEX): REAL;
BEGIN
RETURN z.r
END RealPart;
PROCEDURE ImagPart * (z: COMPLEX): REAL;
BEGIN
RETURN z.i
END ImagPart;
PROCEDURE add * (z1, z2: COMPLEX): COMPLEX;
BEGIN
RETURN CMPLX(z1.r+z2.r, z1.i+z2.i)
END add;
PROCEDURE sub * (z1, z2: COMPLEX): COMPLEX;
BEGIN
RETURN CMPLX(z1.r-z2.r, z1.i-z2.i)
END sub;
PROCEDURE mul * (z1, z2: COMPLEX): COMPLEX;
BEGIN
RETURN CMPLX(z1.r*z2.r-z1.i*z2.i, z1.r*z2.i+z1.i*z2.r)
END mul;
PROCEDURE div * (z1, z2: COMPLEX): COMPLEX;
VAR d, h: REAL;
BEGIN
(* Note: this algorith avoids overflow by avoiding
multiplications and using divisions instead so that:
Re(z1/z2) = (z1.r*z2.r+z1.i*z2.i)/(z2.r^2+z2.i^2)
= (z1.r+z1.i*z2.i/z2.r)/(z2.r+z2.i^2/z2.r)
= (z1.r+h*z1.i)/(z2.r+h*z2.i)
Im(z1/z2) = (z1.i*z2.r-z1.r*z2.i)/(z2.r^2+z2.i^2)
= (z1.i-z1.r*z2.i/z2.r)/(z2.r+z2.i^2/z2.r)
= (z1.i-h*z1.r)/(z2.r+h*z2.i)
where h=z2.i/z2.r, provided z2.i<=z2.r and similarly
for z2.i>z2.r we have:
Re(z1/z2) = (h*z1.r+z1.i)/(h*z2.r+z2.i)
Im(z1/z2) = (h*z1.i-z1.r)/(h*z2.r+z2.i)
where h=z2.r/z2.i *)
(* we always guarantee h<=1 *)
IF ABS(z2.r)>ABS(z2.i) THEN
h:=z2.i/z2.r; d:=z2.r+h*z2.i;
RETURN CMPLX((z1.r+h*z1.i)/d, (z1.i-h*z1.r)/d)
ELSE
h:=z2.r/z2.i; d:=h*z2.r+z2.i;
RETURN CMPLX((h*z1.r+z1.i)/d, (h*z1.i-z1.r)/d)
END
END div;
PROCEDURE abs * (z: COMPLEX): REAL;
(* Returns the length of z *)
VAR
r, i, h: REAL;
BEGIN
(* Note: this algorithm avoids overflow by avoiding
multiplications and using divisions instead so that:
abs(z) = sqrt(z.r*z.r+z.i*z.i)
= sqrt(z.r^2*(1+(z.i/z.r)^2))
= z.r*sqrt(1+(z.i/z.r)^2)
where z.i/z.r <= 1.0 by swapping z.r & z.i so that
for z.r>z.i we have z.r*sqrt(1+(z.i/z.r)^2) and
otherwise we have z.i*sqrt(1+(z.r/z.i)^2) *)
r:=ABS(z.r); i:=ABS(z.i);
IF i>r THEN h:=i; i:=r; r:=h END; (* guarantees i<=r *)
IF i=ZERO THEN RETURN r END; (* i=0, so sqrt(0+r^2)=r *)
h:=i/r;
RETURN r*m.sqrt(ONE+h*h) (* r*sqrt(1+(i/r)^2) *)
END abs;
PROCEDURE arg * (z: COMPLEX): REAL;
(* Returns the angle that z subtends to the positive real axis, in the range [-pi, pi] *)
BEGIN
RETURN m.arctan2(z.i, z.r)
END arg;
PROCEDURE conj * (z: COMPLEX): COMPLEX;
(* Returns the complex conjugate of z *)
BEGIN
RETURN CMPLX(z.r, -z.i)
END conj;
PROCEDURE power * (base: COMPLEX; exponent: REAL): COMPLEX;
(* Returns the value of the number base raised to the power exponent *)
VAR c, s, r: REAL;
BEGIN
m.sincos(arg(base)*exponent, s, c); r:=m.power(abs(base), exponent);
RETURN CMPLX(c*r, s*r)
END power;
PROCEDURE sqrt * (z: COMPLEX): COMPLEX;
(* Returns the principal square root of z, with arg in the range [-pi/2, pi/2] *)
VAR u, v: REAL;
BEGIN
(* Note: the following algorithm is more efficient since
it doesn't require a sincos or arctan evaluation:
Re(sqrt(z)) = sqrt((abs(z)+z.r)/2), Im(sqrt(z)) = +/-sqrt((abs(z)-z.r)/2)
= u = +/-v
where z.r >= 0 and z.i = 2*u*v and unknown sign is sign of z.i *)
(* initially force z.r >= 0 to calculate u, v *)
u:=m.sqrt((abs(z)+ABS(z.r))*HALF);
IF z.i#ZERO THEN v:=(HALF*z.i)/u ELSE v:=ZERO END; (* slight optimization *)
(* adjust u, v for the signs of z.r and z.i *)
IF z.r>=ZERO THEN RETURN CMPLX(u, v) (* no change *)
ELSIF z.i>=ZERO THEN RETURN CMPLX(v, u) (* z.r<0 so swap u, v *)
ELSE RETURN CMPLX(-v, -u) (* z.r<0, z.i<0 *)
END
END sqrt;
PROCEDURE exp * (z: COMPLEX): COMPLEX;
(* Returns the complex exponential of z *)
VAR c, s, e: REAL;
BEGIN
m.sincos(z.i, s, c); e:=m.exp(z.r);
RETURN CMPLX(e*c, e*s)
END exp;
PROCEDURE ln * (z: COMPLEX): COMPLEX;
(* Returns the principal value of the natural logarithm of z *)
BEGIN
RETURN CMPLX(m.ln(abs(z)), arg(z))
END ln;
PROCEDURE sin * (z: COMPLEX): COMPLEX;
(* Returns the sine of z *)
VAR s, c: REAL;
BEGIN
m.sincos(z.r, s, c);
RETURN CMPLX(s*m.cosh(z.i), c*m.sinh(z.i))
END sin;
PROCEDURE cos * (z: COMPLEX): COMPLEX;
(* Returns the cosine of z *)
VAR s, c: REAL;
BEGIN
m.sincos(z.r, s, c);
RETURN CMPLX(c*m.cosh(z.i), -s*m.sinh(z.i))
END cos;
PROCEDURE tan * (z: COMPLEX): COMPLEX;
(* Returns the tangent of z *)
VAR s, c, y, d: REAL;
BEGIN
m.sincos(TWO*z.r, s, c);
y:=TWO*z.i; d:=c+m.cosh(y);
RETURN CMPLX(s/d, m.sinh(y)/d)
END tan;
PROCEDURE CalcAlphaBeta(z: COMPLEX; VAR a, b: REAL);
VAR x, x2, y, r, t: REAL;
BEGIN x:=z.r+ONE; x:=x*x; y:=z.i*z.i;
x2:=z.r-ONE; x2:=x2*x2;
r:=m.sqrt(x+y); t:=m.sqrt(x2+y);
a:=HALF*(r+t); b:=HALF*(r-t);
END CalcAlphaBeta;
PROCEDURE arcsin * (z: COMPLEX): COMPLEX;
(* Returns the arcsine of z *)
VAR a, b: REAL;
BEGIN
CalcAlphaBeta(z, a, b);
RETURN CMPLX(m.arcsin(b), m.ln(a+m.sqrt(a*a-1)))
END arcsin;
PROCEDURE arccos * (z: COMPLEX): COMPLEX;
(* Returns the arccosine of z *)
VAR a, b: REAL;
BEGIN
CalcAlphaBeta(z, a, b);
RETURN CMPLX(m.arccos(b), -m.ln(a+m.sqrt(a*a-1)))
END arccos;
PROCEDURE arctan * (z: COMPLEX): COMPLEX;
(* Returns the arctangent of z *)
VAR x, y, yp, x2, y2: REAL;
BEGIN
x:=TWO*z.r; y:=z.i+ONE; y:=y*y;
yp:=z.i-ONE; yp:=yp*yp;
x2:=z.r*z.r; y2:=z.i*z.i;
RETURN CMPLX(HALF*m.arctan(x/(ONE-x2-y2)), 0.25*m.ln((x2+y)/(x2+yp)))
END arctan;
PROCEDURE polarToComplex * (abs, arg: REAL): COMPLEX;
(* Returns the complex number with the specified polar coordinates *)
BEGIN
RETURN CMPLX(abs*m.cos(arg), abs*m.sin(arg))
END polarToComplex;
PROCEDURE scalarMult * (scalar: REAL; z: COMPLEX): COMPLEX;
(* Returns the scalar product of scalar with z *)
BEGIN
RETURN CMPLX(z.r*scalar, z.i*scalar)
END scalarMult;
PROCEDURE IsCMathException * (): BOOLEAN;
(* Returns TRUE if the current coroutine is in the exceptional execution state
because of the ComplexMath exception; otherwise returns FALSE.
*)
BEGIN
RETURN FALSE
END IsCMathException;
BEGIN
i:=CMPLX (ZERO, ONE);
one:=CMPLX (ONE, ZERO);
zero:=CMPLX (ZERO, ZERO)
END oocComplexMath.

33
src/library/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.

188
src/library/ooc/oocFilenames.Mod Normal file
View file

@ -0,0 +1,188 @@
(* This module is obsolete. Don't use it. *)
MODULE oocFilenames;
(* Note: It is not checked whether the concatenated strings fit into the
variables given for them or not *)
IMPORT
Strings := oocStrings, Strings2 := oocStrings2, Rts := oocRts;
PROCEDURE LocateCharLast(str: ARRAY OF CHAR; ch: CHAR): INTEGER;
(* Result is the position of the last occurence of 'ch' in the string 'str'.
If 'ch' does not occur in 'str', then -1 is returned *)
VAR
pos: INTEGER;
BEGIN
pos:=Strings.Length(str);
WHILE (pos >= 0) DO
IF (str[pos] = ch) THEN
RETURN(pos);
ELSE
DEC(pos);
END; (* IF *)
END; (* WHILE *)
RETURN -1
END LocateCharLast;
PROCEDURE SplitRChar(str: ARRAY OF CHAR; VAR str1, str2: ARRAY OF CHAR; ch: CHAR);
(* pre : 'str' contains the string to be splited after the rightmost 'ch' *)
(* post: 'str1' contains the left part (including 'ch') of 'str',
iff occurs(ch,str), otherwise "",
'str2' contains the right part of 'str'.
*)
(*
example:
str = "/aksdf/asdf/gasdfg/esscgd.asdfg"
result: str2 = "esscgd.asdfg"
str1 = "/aksdf/asdf/gasdfg/"
*)
VAR
len,pos: INTEGER;
BEGIN
len:=Strings.Length(str);
(* search for the rightmost occurence of 'ch' and
store it's position in 'pos' *)
pos:=LocateCharLast(str,ch);
COPY(str,str2); (* that has to be done all time *)
IF (pos >= 0) THEN
(* 'ch' occurs in 'str', (str[pos]=ch)=TRUE *)
COPY(str,str1); (* copy the whole string 'str' to 'str1' *)
INC(pos); (* we want to split _after_ 'ch' *)
Strings.Delete(str2,0,pos); (* remove left part from 'str2' *)
Strings.Delete(str1,pos,(len-pos)); (* remove right part from 'str1' *)
ELSE (* there is no pathinfo in 'file' *)
COPY("",str1); (* make 'str1' the empty string *)
END; (* IF *)
END SplitRChar;
(******************************)
(* decomposition of filenames *)
(******************************)
PROCEDURE GetPath*(full: ARRAY OF CHAR; VAR path, file: ARRAY OF CHAR);
(*
pre : "full" contains the (maybe) absolute path to a file.
post: "file" contains only the filename, "path" the path for it.
example:
pre : full = "/aksdf/asdf/gasdfg/esscgd.asdfg"
post: file = "esscgd.asdfg"
path = "/aksdf/asdf/gasdfg/"
*)
BEGIN
SplitRChar(full,path,file,Rts.pathSeperator);
END GetPath;
PROCEDURE GetExt*(full: ARRAY OF CHAR; VAR file, ext: ARRAY OF CHAR);
BEGIN
IF (LocateCharLast(full,Rts.pathSeperator) < LocateCharLast(full,".")) THEN
(* there is a "real" extension *)
SplitRChar(full,file,ext,".");
Strings.Delete(file,Strings.Length(file)-1,1); (* delete "." at the end of 'file' *)
ELSE
COPY(full,file);
COPY("",ext);
END; (* IF *)
END GetExt;
PROCEDURE GetFile*(full: ARRAY OF CHAR; VAR file: ARRAY OF CHAR);
(* removes both path & extension from 'full' and stores the result in 'file' *)
(* example:
GetFile("/tools/public/o2c-1.2/lib/Filenames.Mod",myname)
results in
myname="Filenames"
*)
VAR
dummy: ARRAY 256 OF CHAR; (* that should be enough... *)
BEGIN
GetPath(full,dummy,file);
GetExt(file,file,dummy);
END GetFile;
(****************************)
(* composition of filenames *)
(****************************)
PROCEDURE AddExt*(VAR full: ARRAY OF CHAR; file, ext: ARRAY OF CHAR);
(* pre : 'file' is a filename
'ext' is some extension
*)
(* post: 'full' contains 'file'"."'ext', iff 'ext'#"",
otherwise 'file'
*)
BEGIN
COPY(file,full);
IF (ext[0] # 0X) THEN
(* we only append 'real', i.e. nonempty extensions *)
Strings2.AppendChar(".", full);
Strings.Append(ext, full);
END; (* IF *)
END AddExt;
PROCEDURE AddPath*(VAR full: ARRAY OF CHAR; path, file: ARRAY OF CHAR);
(* pre : 'file' is a filename
'path' is a path (will not be interpreted) or ""
*)
(* post: 'full' will contain the contents of 'file' with
addition of 'path' at the beginning.
*)
BEGIN
COPY(file,full);
IF (path[0] # 0X) THEN
(* we only add something if there is something... *)
IF (path[Strings.Length(path) - 1] # Rts.pathSeperator) THEN
(* add a seperator, if none is at the end of 'path' *)
Strings.Insert(Rts.pathSeperator, 0, full);
END; (* IF *)
Strings.Insert(path, 0, full)
END; (* IF *)
END AddPath;
PROCEDURE BuildFilename*(VAR full: ARRAY OF CHAR; path, file, ext: ARRAY OF CHAR);
(* pre : 'file' is the name of a file,
'path' is its path and
'ext' is the extension to be added
*)
(* post: 'full' contains concatenation of 'path' with ('file' with 'ext')
*)
BEGIN
AddExt(full,file,ext);
AddPath(full,path,full);
END BuildFilename;
PROCEDURE ExpandPath*(VAR full: ARRAY OF CHAR; path: ARRAY OF CHAR);
(* Expands "~/" and "~user/" at the beginning of 'path' to it's
intended strings.
"~/" will result in the path to the current user's home,
"~user" will result in the path of "user"'s home. *)
VAR
len, posSep, posSuffix: INTEGER;
suffix, userpath: ARRAY 256 OF CHAR;
username: ARRAY 32 OF CHAR;
BEGIN
COPY (path, full);
IF (path[0] = "~") THEN (* we have to expand something *)
posSep := Strings2.PosChar (Rts.pathSeperator, path);
len := Strings.Length (path);
IF (posSep < 0) THEN (* no '/' in file name, just the path *)
posSep := len;
posSuffix := len
ELSE
posSuffix := posSep+1
END;
Strings.Extract (path, posSuffix, len-posSuffix, suffix);
Strings.Extract (path, 1, posSep-1, username);
Rts.GetUserHome (userpath, username);
IF (userpath[0] # 0X) THEN (* sucessfull search *)
AddPath (full, userpath, suffix)
END
END
END ExpandPath;
END oocFilenames.

240
src/library/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/library/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.

132
src/library/ooc/oocJulianDay.Mod Normal file
View file

@ -0,0 +1,132 @@
(* $Id: JulianDay.Mod,v 1.4 1999/09/02 13:08:31 acken Exp $ *)
MODULE oocJulianDay;
(*
JulianDay - convert to/from day/month/year and modified Julian days.
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
*)
CONST
daysPerYear = 365.25D0; (* used in Julian date calculations *)
daysPerMonth = 30.6001D0;
startMJD* = 2400000.5D0; (* zero basis for modified Julian Day in Julian days *)
startTJD* = startMJD+40000.0D0; (* zero basis for truncated modified Julian Day *)
VAR
UseGregorian-: BOOLEAN; (* TRUE when Gregorian calendar is in use *)
startGregor: LONGREAL; (* start of the Gregorian calendar in Julian days *)
(* ------------------------------------------------------------- *)
(* Conversion functions *)
PROCEDURE DateToJD * (day, month: SHORTINT; year: INTEGER) : LONGREAL;
(* Returns a Julian date in days for the given `day', `month',
and `year' at 0000 UTC. Any date with a positive year is valid.
Algorithm by William H. Jefferys (with some modifications) at:
http://quasar.as.utexas.edu/BillInfo/JulianDatesG.html *)
VAR
A, B, C: LONGINT; JD: LONGREAL;
BEGIN
IF month<3 THEN DEC(year); INC(month, 12) END;
IF UseGregorian THEN A:=year DIV 100; B:=A DIV 4; C:=2-A+B
ELSE C:=0
END;
JD:=C+day+ENTIER(daysPerYear*(year+4716))+ENTIER(daysPerMonth*(month+1))-1524.5D0;
IF UseGregorian & (JD>=startGregor) THEN RETURN JD
ELSE RETURN JD-C
END
END DateToJD;
PROCEDURE DateToDays * (day, month: SHORTINT; year: INTEGER) : LONGINT;
(* Returns a modified Julian date in days for the given `day', `month',
and `year' at 0000 UTC. Any date with a positive year is valid.
The returned value is the number of days since 17 November 1858. *)
BEGIN
RETURN ENTIER(DateToJD(day, month, year)-startMJD)
END DateToDays;
PROCEDURE DateToTJD * (day, month: SHORTINT; year: INTEGER) : LONGINT;
(* Returns a truncated modified Julian date in days for the given `day',
`month', and `year' at 0000 UTC. Any date with a positive year is
valid. The returned value is the *)
BEGIN
RETURN ENTIER(DateToJD(day, month, year)-startTJD)
END DateToTJD;
PROCEDURE JDToDate * (jd: LONGREAL; VAR day, month: SHORTINT; VAR year: INTEGER);
(* Converts a Julian date in days to a date given by the `day', `month', and
`year'. Algorithm by William H. Jefferys (with some modifications) at
http://quasar.as.utexas.edu/BillInfo/JulianDatesG.html *)
VAR
W, D, B: LONGINT;
BEGIN
jd:=jd+0.5;
IF UseGregorian & (jd>=startGregor) THEN
W:=ENTIER((jd-1867216.25D0)/36524.25D0);
B:=ENTIER(jd+1525+W-ENTIER(W/4.0D0))
ELSE B:=ENTIER(jd+1524)
END;
year:=SHORT(ENTIER((B-122.1D0)/daysPerYear));
D:=ENTIER(daysPerYear*year);
month:=SHORT(SHORT(ENTIER((B-D)/daysPerMonth)));
day:=SHORT(SHORT(B-D-ENTIER(daysPerMonth*month)));
IF month>13 THEN DEC(month, 13) ELSE DEC(month) END;
IF month<3 THEN DEC(year, 4715) ELSE DEC(year, 4716) END
END JDToDate;
PROCEDURE DaysToDate * (jd: LONGINT; VAR day, month: SHORTINT; VAR year: INTEGER);
(* Converts a modified Julian date in days to a date given by the `day',
`month', and `year'. *)
BEGIN
JDToDate(jd+startMJD, day, month, year)
END DaysToDate;
PROCEDURE TJDToDate * (jd: LONGINT; VAR day, month: SHORTINT; VAR year: INTEGER);
(* Converts a truncated modified Julian date in days to a date given by the `day',
`month', and `year'. *)
BEGIN
JDToDate(jd+startTJD, day, month, year)
END TJDToDate;
PROCEDURE SetGregorianStart * (day, month: SHORTINT; year: INTEGER);
(* Sets the start date when the Gregorian calendar was first used
where the date in `d' is in the Julian calendar. The default
date used is 3 Sep 1752 (when the calendar correction occurred
according to the Julian calendar).
The Gregorian calendar was introduced in 4 Oct 1582 by Pope
Gregory XIII but was not adopted by many Protestant countries
until 2 Sep 1752. In all cases, to make up for an inaccuracy
in the calendar, 10 days were skipped during adoption of the
new calendar. *)
VAR
gFlag: BOOLEAN;
BEGIN
gFlag:=UseGregorian; UseGregorian:=FALSE; (* use Julian calendar *)
startGregor:=DateToJD(day, month, year);
UseGregorian:=gFlag (* back to default *)
END SetGregorianStart;
BEGIN
(* by default we use the Gregorian calendar *)
UseGregorian:=TRUE; startGregor:=0;
(* Gregorian calendar default start date *)
SetGregorianStart(3, 9, 1752)
END oocJulianDay.

284
src/library/ooc/oocLComplexMath.Mod Normal file
View file

@ -0,0 +1,284 @@
(* $Id: LComplexMath.Mod,v 1.5 1999/09/02 13:08:49 acken Exp $ *)
MODULE oocLComplexMath;
(*
LComplexMath - Mathematical functions for the type LONGCOMPLEX.
Copyright (C) 1995-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 c := oocComplexMath, m := oocLRealMath;
TYPE
LONGCOMPLEX * = POINTER TO LONGCOMPLEXDesc;
LONGCOMPLEXDesc = RECORD
r, i : LONGREAL
END;
CONST
ZERO=0.0D0; HALF=0.5D0; ONE=1.0D0; TWO=2.0D0;
VAR
i-, one-, zero- : LONGCOMPLEX;
PROCEDURE CMPLX * (r, i: LONGREAL): LONGCOMPLEX;
VAR c: LONGCOMPLEX;
BEGIN
NEW(c); c.r:=r; c.i:=i;
RETURN c
END CMPLX;
(*
NOTE: This function provides the only way
of reliably assigning COMPLEX numbers. DO
NOT use ` a := b' where a, b are LONGCOMPLEX!
*)
PROCEDURE Copy * (z: LONGCOMPLEX): LONGCOMPLEX;
BEGIN
RETURN CMPLX(z.r, z.i)
END Copy;
PROCEDURE Long * (z: c.COMPLEX): LONGCOMPLEX;
BEGIN
RETURN CMPLX(c.RealPart(z), c.ImagPart(z))
END Long;
PROCEDURE Short * (z: LONGCOMPLEX): c.COMPLEX;
BEGIN
RETURN c.CMPLX(SHORT(z.r), SHORT(z.i))
END Short;
PROCEDURE RealPart * (z: LONGCOMPLEX): LONGREAL;
BEGIN
RETURN z.r
END RealPart;
PROCEDURE ImagPart * (z: LONGCOMPLEX): LONGREAL;
BEGIN
RETURN z.i
END ImagPart;
PROCEDURE add * (z1, z2: LONGCOMPLEX): LONGCOMPLEX;
BEGIN
RETURN CMPLX(z1.r+z2.r, z1.i+z2.i)
END add;
PROCEDURE sub * (z1, z2: LONGCOMPLEX): LONGCOMPLEX;
BEGIN
RETURN CMPLX(z1.r-z2.r, z1.i-z2.i)
END sub;
PROCEDURE mul * (z1, z2: LONGCOMPLEX): LONGCOMPLEX;
BEGIN
RETURN CMPLX(z1.r*z2.r-z1.i*z2.i, z1.r*z2.i+z1.i*z2.r)
END mul;
PROCEDURE div * (z1, z2: LONGCOMPLEX): LONGCOMPLEX;
VAR d, h: LONGREAL;
BEGIN
(* Note: this algorith avoids overflow by avoiding
multiplications and using divisions instead so that:
Re(z1/z2) = (z1.r*z2.r+z1.i*z2.i)/(z2.r^2+z2.i^2)
= (z1.r+z1.i*z2.i/z2.r)/(z2.r+z2.i^2/z2.r)
= (z1.r+h*z1.i)/(z2.r+h*z2.i)
Im(z1/z2) = (z1.i*z2.r-z1.r*z2.i)/(z2.r^2+z2.i^2)
= (z1.i-z1.r*z2.i/z2.r)/(z2.r+z2.i^2/z2.r)
= (z1.i-h*z1.r)/(z2.r+h*z2.i)
where h=z2.i/z2.r, provided z2.i<=z2.r and similarly
for z2.i>z2.r we have:
Re(z1/z2) = (h*z1.r+z1.i)/(h*z2.r+z2.i)
Im(z1/z2) = (h*z1.i-z1.r)/(h*z2.r+z2.i)
where h=z2.r/z2.i *)
(* we always guarantee h<=1 *)
IF ABS(z2.r)>ABS(z2.i) THEN
h:=z2.i/z2.r; d:=z2.r+h*z2.i;
RETURN CMPLX((z1.r+h*z1.i)/d, (z1.i-h*z1.r)/d)
ELSE
h:=z2.r/z2.i; d:=h*z2.r+z2.i;
RETURN CMPLX((h*z1.r+z1.i)/d, (h*z1.i-z1.r)/d)
END
END div;
PROCEDURE abs * (z: LONGCOMPLEX): LONGREAL;
(* Returns the length of z *)
VAR
r, i, h: LONGREAL;
BEGIN
(* Note: this algorithm avoids overflow by avoiding
multiplications and using divisions instead so that:
abs(z) = sqrt(z.r*z.r+z.i*z.i)
= sqrt(z.r^2*(1+(z.i/z.r)^2))
= z.r*sqrt(1+(z.i/z.r)^2)
where z.i/z.r <= 1.0 by swapping z.r & z.i so that
for z.r>z.i we have z.r*sqrt(1+(z.i/z.r)^2) and
otherwise we have z.i*sqrt(1+(z.r/z.i)^2) *)
r:=ABS(z.r); i:=ABS(z.i);
IF i>r THEN h:=i; i:=r; r:=h END; (* guarantees i<=r *)
IF i=ZERO THEN RETURN r END; (* i=0, so sqrt(0+r^2)=r *)
h:=i/r;
RETURN r*m.sqrt(ONE+h*h) (* r*sqrt(1+(i/r)^2) *)
END abs;
PROCEDURE arg * (z: LONGCOMPLEX): LONGREAL;
(* Returns the angle that z subtends to the positive real axis, in the range [-pi, pi] *)
BEGIN
RETURN m.arctan2(z.i, z.r)
END arg;
PROCEDURE conj * (z: LONGCOMPLEX): LONGCOMPLEX;
(* Returns the complex conjugate of z *)
BEGIN
RETURN CMPLX(z.r, -z.i)
END conj;
PROCEDURE power * (base: LONGCOMPLEX; exponent: LONGREAL): LONGCOMPLEX;
(* Returns the value of the number base raised to the power exponent *)
VAR c, s, r: LONGREAL;
BEGIN
m.sincos(arg(base)*exponent, s, c); r:=m.power(abs(base), exponent);
RETURN CMPLX(c*r, s*r)
END power;
PROCEDURE sqrt * (z: LONGCOMPLEX): LONGCOMPLEX;
(* Returns the principal square root of z, with arg in the range [-pi/2, pi/2] *)
VAR u, v: LONGREAL;
BEGIN
(* Note: the following algorithm is more efficient since
it doesn't require a sincos or arctan evaluation:
Re(sqrt(z)) = sqrt((abs(z)+z.r)/2), Im(sqrt(z)) = +/-sqrt((abs(z)-z.r)/2)
= u = +/-v
where z.r >= 0 and z.i = 2*u*v and unknown sign is sign of z.i *)
(* initially force z.r >= 0 to calculate u, v *)
u:=m.sqrt((abs(z)+ABS(z.r))*HALF);
IF z.i#ZERO THEN v:=(HALF*z.i)/u ELSE v:=ZERO END; (* slight optimization *)
(* adjust u, v for the signs of z.r and z.i *)
IF z.r>=ZERO THEN RETURN CMPLX(u, v) (* no change *)
ELSIF z.i>=ZERO THEN RETURN CMPLX(v, u) (* z.r<0 so swap u, v *)
ELSE RETURN CMPLX(-v, -u) (* z.r<0, z.i<0 *)
END
END sqrt;
PROCEDURE exp * (z: LONGCOMPLEX): LONGCOMPLEX;
(* Returns the complex exponential of z *)
VAR c, s, e: LONGREAL;
BEGIN
m.sincos(z.i, s, c); e:=m.exp(z.r);
RETURN CMPLX(e*c, e*s)
END exp;
PROCEDURE ln * (z: LONGCOMPLEX): LONGCOMPLEX;
(* Returns the principal value of the natural logarithm of z *)
BEGIN
RETURN CMPLX(m.ln(abs(z)), arg(z))
END ln;
PROCEDURE sin * (z: LONGCOMPLEX): LONGCOMPLEX;
(* Returns the sine of z *)
VAR s, c: LONGREAL;
BEGIN
m.sincos(z.r, s, c);
RETURN CMPLX(s*m.cosh(z.i), c*m.sinh(z.i))
END sin;
PROCEDURE cos * (z: LONGCOMPLEX): LONGCOMPLEX;
(* Returns the cosine of z *)
VAR s, c: LONGREAL;
BEGIN
m.sincos(z.r, s, c);
RETURN CMPLX(c*m.cosh(z.i), -s*m.sinh(z.i))
END cos;
PROCEDURE tan * (z: LONGCOMPLEX): LONGCOMPLEX;
(* Returns the tangent of z *)
VAR s, c, y, d: LONGREAL;
BEGIN
m.sincos(TWO*z.r, s, c);
y:=TWO*z.i; d:=c+m.cosh(y);
RETURN CMPLX(s/d, m.sinh(y)/d)
END tan;
PROCEDURE CalcAlphaBeta(z: LONGCOMPLEX; VAR a, b: LONGREAL);
VAR x, x2, y, r, t: LONGREAL;
BEGIN x:=z.r+ONE; x:=x*x; y:=z.i*z.i;
x2:=z.r-ONE; x2:=x2*x2;
r:=m.sqrt(x+y); t:=m.sqrt(x2+y);
a:=HALF*(r+t); b:=HALF*(r-t);
END CalcAlphaBeta;
PROCEDURE arcsin * (z: LONGCOMPLEX): LONGCOMPLEX;
(* Returns the arcsine of z *)
VAR a, b: LONGREAL;
BEGIN
CalcAlphaBeta(z, a, b);
RETURN CMPLX(m.arcsin(b), m.ln(a+m.sqrt(a*a-1)))
END arcsin;
PROCEDURE arccos * (z: LONGCOMPLEX): LONGCOMPLEX;
(* Returns the arccosine of z *)
VAR a, b: LONGREAL;
BEGIN
CalcAlphaBeta(z, a, b);
RETURN CMPLX(m.arccos(b), -m.ln(a+m.sqrt(a*a-1)))
END arccos;
PROCEDURE arctan * (z: LONGCOMPLEX): LONGCOMPLEX;
(* Returns the arctangent of z *)
VAR x, y, yp, x2, y2: LONGREAL;
BEGIN
x:=TWO*z.r; y:=z.i+ONE; y:=y*y;
yp:=z.i-ONE; yp:=yp*yp;
x2:=z.r*z.r; y2:=z.i*z.i;
RETURN CMPLX(HALF*m.arctan(x/(ONE-x2-y2)), 0.25D0*m.ln((x2+y)/(x2+yp)))
END arctan;
PROCEDURE polarToComplex * (abs, arg: LONGREAL): LONGCOMPLEX;
(* Returns the complex number with the specified polar coordinates *)
BEGIN
RETURN CMPLX(abs*m.cos(arg), abs*m.sin(arg))
END polarToComplex;
PROCEDURE scalarMult * (scalar: LONGREAL; z: LONGCOMPLEX): LONGCOMPLEX;
(* Returns the scalar product of scalar with z *)
BEGIN
RETURN CMPLX(z.r*scalar, z.i*scalar)
END scalarMult;
PROCEDURE IsCMathException * (): BOOLEAN;
(* Returns TRUE if the current coroutine is in the exceptional execution state
because of the LComplexMath exception; otherwise returns FALSE.
*)
BEGIN
RETURN FALSE
END IsCMathException;
BEGIN
i:=CMPLX (ZERO, ONE);
one:=CMPLX (ONE, ZERO);
zero:=CMPLX (ZERO, ZERO)
END oocLComplexMath.

414
src/library/ooc/oocLRealConv.Mod Normal file
View file

@ -0,0 +1,414 @@
(* $Id: LRealConv.Mod,v 1.7 1999/10/12 07:17:54 ooc-devel Exp $ *)
MODULE oocLRealConv;
(*
LRealConv - Low-level LONGREAL/string conversions.
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
Char := oocCharClass, Low := oocLowLReal, Str := oocStrings, Conv := oocConvTypes,
LInt := oocLongInts, SYSTEM;
CONST
ZERO=0.0D0;
SigFigs*=15; (* accuracy of LONGREALs *)
DEBUG = FALSE;
TYPE
ConvResults*= Conv.ConvResults; (* strAllRight, strOutOfRange, strWrongFormat, strEmpty *)
LongInt=LInt.LongInt;
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
RS, P, F, E, SE, WE, SR: Conv.ScanState;
PROCEDURE IsExponent (ch: CHAR) : BOOLEAN;
BEGIN
RETURN (ch="E") OR (ch="D")
END IsExponent;
PROCEDURE IsSign (ch: CHAR): BOOLEAN;
(* Return TRUE for '+' or '-' *)
BEGIN
RETURN (ch='+')OR(ch='-')
END IsSign;
(* internal state machine procedures *)
PROCEDURE RSState(inputCh: CHAR; VAR chClass: Conv.ScanClass; VAR nextState: Conv.ScanState);
BEGIN
IF Char.IsNumeric(inputCh) THEN chClass:=Conv.valid; nextState:=P
ELSE chClass:=Conv.invalid; nextState:=RS
END
END RSState;
PROCEDURE PState(inputCh: CHAR; VAR chClass: Conv.ScanClass; VAR nextState: Conv.ScanState);
BEGIN
IF Char.IsNumeric(inputCh) THEN chClass:=Conv.valid; nextState:=P
ELSIF inputCh="." THEN chClass:=Conv.valid; nextState:=F
ELSIF IsExponent(inputCh) THEN chClass:=Conv.valid; nextState:=E
ELSE chClass:=Conv.terminator; nextState:=NIL
END
END PState;
PROCEDURE FState(inputCh: CHAR; VAR chClass: Conv.ScanClass; VAR nextState: Conv.ScanState);
BEGIN
IF Char.IsNumeric(inputCh) THEN chClass:=Conv.valid; nextState:=F
ELSIF IsExponent(inputCh) THEN chClass:=Conv.valid; nextState:=E
ELSE chClass:=Conv.terminator; nextState:=NIL
END
END FState;
PROCEDURE EState(inputCh: CHAR; VAR chClass: Conv.ScanClass; VAR nextState: Conv.ScanState);
BEGIN
IF IsSign(inputCh) THEN chClass:=Conv.valid; nextState:=SE
ELSIF Char.IsNumeric(inputCh) THEN chClass:=Conv.valid; nextState:=WE
ELSE chClass:=Conv.invalid; nextState:=E
END
END EState;
PROCEDURE SEState(inputCh: CHAR; VAR chClass: Conv.ScanClass; VAR nextState: Conv.ScanState);
BEGIN
IF Char.IsNumeric(inputCh) THEN chClass:=Conv.valid; nextState:=WE
ELSE chClass:=Conv.invalid; nextState:=SE
END
END SEState;
PROCEDURE WEState(inputCh: CHAR; VAR chClass: Conv.ScanClass; VAR nextState: Conv.ScanState);
BEGIN
IF Char.IsNumeric(inputCh) THEN chClass:=Conv.valid; nextState:=WE
ELSE chClass:=Conv.terminator; nextState:=NIL
END
END WEState;
PROCEDURE Real (VAR x: LongInt; exp, digits: LONGINT; VAR outOfRange: BOOLEAN): LONGREAL;
CONST BR=LInt.B+ZERO; InvLOGB=0.221461873; (* real version *)
VAR cnt, len, scale, Bscale, start, bexp, max: LONGINT; r: LONGREAL;
BEGIN
(* scale by the exponent *)
scale:=exp+digits;
IF scale>=ABS(digits) THEN
Bscale:=0; LInt.TenPower(x, SHORT(scale))
ELSE
Bscale:=ENTIER(-scale*InvLOGB)+6;
LInt.BPower(x, SHORT(Bscale)); (* x*B^Bscale *)
LInt.TenPower(x, SHORT(scale)); (* x*B^BScale*10^scale *)
END;
(* prescale to left-justify the number *)
start:=LInt.MinDigit(x); bexp:=0; (* find starting digit *)
IF (start=LEN(x)-1)&(x[start]=0) THEN (* exit here for zero *)
outOfRange:=FALSE; RETURN ZERO
END;
WHILE x[start]<LInt.B DIV 2 DO
LInt.MultDigit(x, 2, 0); INC(bexp) (* normalize *)
END;
(* convert to a LONGREAL *)
r:=ZERO; len:=LEN(x)-1; max:=start+3;
IF max>len THEN max:=len END;
FOR cnt:=start TO max DO r:=r*BR+x[cnt] END;
(* post scaling *)
INC(bexp, (Bscale-len+max)*15);
(* quick check for overflow *)
max:=Low.exponent(r)-SHORT(bexp);
IF (max>Low.expoMax) OR (max<Low.expoMin) THEN
outOfRange:=TRUE;
RETURN ZERO
ELSE
outOfRange:=FALSE;
RETURN Low.scale(r, -SHORT(bexp))
END
END Real;
PROCEDURE ScanReal*(inputCh: CHAR; VAR chClass: Conv.ScanClass; VAR nextState: Conv.ScanState);
(*
Represents the start state of a finite state scanner for real numbers - assigns
class of inputCh to chClass and a procedure representing the next state to
nextState.
The call of ScanReal(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)
--------- --------- -------- ---------
ScanReal space padding ScanReal
sign valid RSState
decimal digit valid PState
other invalid ScanReal
RSState decimal digit valid PState
other invalid RSState
PState decimal digit valid PState
"." valid FState
"E", "D" valid EState
other terminator --
FState decimal digit valid FState
"E", "D" valid EState
other terminator --
EState sign valid SEState
decimal digit valid WEState
other invalid EState
SEState decimal digit valid WEState
other invalid SEState
WEState decimal digit valid WEState
other terminator --
For examples of how to use ScanReal, refer to FormatReal and
ValueReal below.
*)
BEGIN
IF Char.IsWhiteSpace(inputCh) THEN chClass:=Conv.padding; nextState:=SR
ELSIF IsSign(inputCh) THEN chClass:=Conv.valid; nextState:=RS
ELSIF Char.IsNumeric(inputCh) THEN chClass:=Conv.valid; nextState:=P
ELSE chClass:=Conv.invalid; nextState:=SR
END
END ScanReal;
PROCEDURE FormatReal*(str: ARRAY OF CHAR): ConvResults;
(* Returns the format of the string value for conversion to LONGREAL. *)
VAR
ch: CHAR;
rn: LONGREAL;
len, index, digit, nexp, exp: INTEGER;
state: Conv.ScanState;
inExp, posExp, decExp, outOfRange: BOOLEAN;
prev, class: Conv.ScanClass;
int: LongInt;
BEGIN
state:=SR; rn:=0.0; exp:=0; nexp:= 0;
class:=Conv.padding; prev:=class;
inExp:=FALSE; posExp:=TRUE; decExp:=FALSE;
(*FOR len:=0 TO SHORT(LEN(int))-1 DO int[len]:=0 END;*)
FOR len:=0 TO (LEN(int))-1 DO int[len]:=0 END; (* I don't understand why to SHORT it. LEN(int) will return 170 (defined in LongInts as ARRAY 170 OF INTEGER) both with voc and oo2c the same way; -- noch *)
len:=Str.Length(str); index:=0;
LOOP
IF index=len THEN EXIT END;
ch:=str[index];
state.p(ch, class, state);
CASE class OF
| Conv.padding: (* nothing to do *)
| Conv.valid:
IF inExp THEN
IF IsSign(ch) THEN posExp:=ch="+"
ELSE (* must be digits *)
digit:=ORD(ch)-ORD("0");
IF posExp THEN exp:=exp*10+digit
ELSE exp:=exp*10-digit
END
END
ELSIF IsExponent(ch) THEN inExp:=TRUE
ELSIF ch="." THEN decExp:=TRUE
ELSE (* must be a digit *)
LInt.MultDigit(int, 10, ORD(ch)-ORD("0"));
IF decExp THEN DEC(nexp) END;
END
| Conv.invalid, Conv.terminator: EXIT
END;
prev:=class; INC(index)
END;
IF class IN {Conv.invalid, Conv.terminator} THEN
RETURN strWrongFormat
ELSIF prev=Conv.padding THEN
RETURN strEmpty
ELSE
rn:=Real(int, exp, nexp, outOfRange);
IF outOfRange THEN RETURN strOutOfRange
ELSE RETURN strAllRight
END
END
END FormatReal;
PROCEDURE ValueReal*(str: ARRAY OF CHAR): LONGREAL;
VAR
ch: CHAR;
rn: LONGREAL;
len, index, digit, nexp, exp: INTEGER;
state: Conv.ScanState;
inExp, positive, posExp, decExp, outOfRange: BOOLEAN;
prev, class: Conv.ScanClass;
int: LongInt;
BEGIN
state:=SR; rn:=0.0; exp:=0; nexp:= 0;
class:=Conv.padding; prev:=class;
positive:=TRUE; inExp:=FALSE; posExp:=TRUE; decExp:=FALSE;
(*FOR len:=0 TO SHORT(LEN(int))-1 DO int[len]:=0 END;*)
FOR len:=0 TO (LEN(int))-1 DO int[len]:=0 END; (* I don't understand why to SHORT it; -- noch *)
len:=Str.Length(str); index:=0;
LOOP
IF index=len THEN EXIT END;
ch:=str[index];
state.p(ch, class, state);
CASE class OF
| Conv.padding: (* nothing to do *)
| Conv.valid:
IF inExp THEN
IF IsSign(ch) THEN posExp:=ch="+"
ELSE (* must be digits *)
digit:=ORD(ch)-ORD("0");
IF posExp THEN exp:=exp*10+digit
ELSE exp:=exp*10-digit
END
END
ELSIF IsExponent(ch) THEN inExp:=TRUE
ELSIF IsSign(ch) THEN positive:=ch="+"
ELSIF ch="." THEN decExp:=TRUE
ELSE (* must be a digit *)
LInt.MultDigit(int, 10, ORD(ch)-ORD("0"));
IF decExp THEN DEC(nexp) END;
END
| Conv.invalid, Conv.terminator: EXIT
END;
prev:=class; INC(index)
END;
IF class IN {Conv.invalid, Conv.terminator} THEN
RETURN ZERO
ELSIF prev=Conv.padding THEN
RETURN ZERO
ELSE
rn:=Real(int, exp, nexp, outOfRange);
IF outOfRange THEN RETURN Low.large END
END;
IF ~positive THEN rn:=-rn END;
RETURN rn
END ValueReal;
PROCEDURE LengthFloatReal*(real: LONGREAL; sigFigs: INTEGER): INTEGER;
(*
Returns the number of characters in the floating-point string
representation of real with sigFigs significant figures.
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 LongStr.RealToFloat(real,sigFigs,str).
*)
VAR
len, exp: INTEGER;
BEGIN
IF Low.IsNaN(real) THEN RETURN 3
ELSIF Low.IsInfinity(real) THEN
IF real<ZERO THEN RETURN 9 ELSE RETURN 8 END
END;
IF sigFigs=0 THEN sigFigs:=SigFigs END; len:=sigFigs; (* default digits -- if none given *)
IF real<ZERO THEN INC(len); real:=-real END; (* account for the sign *)
exp:=Low.exponent10(real);
IF sigFigs>1 THEN INC(len) END; (* account for the decimal point *)
IF exp>10 THEN INC(len, 4) (* account for the exponent *)
ELSIF exp#0 THEN INC(len, 3)
END;
RETURN len
END LengthFloatReal;
PROCEDURE LengthEngReal*(real: LONGREAL; sigFigs: INTEGER): INTEGER;
(*
Returns the number of characters in the floating-point engineering
string representation of real with sigFigs significant figures.
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 LongStr.RealToEng(real,sigFigs,str).
*)
VAR
len, exp, off: INTEGER;
BEGIN
IF Low.IsNaN(real) THEN RETURN 3
ELSIF Low.IsInfinity(real) THEN
IF real<ZERO THEN RETURN 9 ELSE RETURN 8 END
END;
IF sigFigs=0 THEN sigFigs:=SigFigs END; len:=sigFigs; (* default digits -- if none given *)
IF real<ZERO THEN INC(len); real:=-real END; (* account for the sign *)
exp:=Low.exponent10(real); off:=exp MOD 3; (* account for the exponent *)
IF exp-off>10 THEN INC(len, 4)
ELSIF exp-off#0 THEN INC(len, 3)
END;
IF sigFigs>off+1 THEN INC(len) END; (* account for the decimal point *)
IF off+1-sigFigs>0 THEN INC(len, off+1-sigFigs) END; (* account for extra padding digits *)
RETURN len
END LengthEngReal;
PROCEDURE LengthFixedReal*(real: LONGREAL; place: INTEGER): INTEGER;
(* Returns the number of characters in the fixed-point string
representation of real rounded to the given place relative
to the decimal point.
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 LongStr.RealToFixed(real,sigFigs,str).
*)
VAR
len, exp: INTEGER; addDecPt: BOOLEAN;
BEGIN
IF Low.IsNaN(real) THEN RETURN 3
ELSIF Low.IsInfinity(real) THEN
IF real<ZERO THEN RETURN 9 ELSE RETURN 8 END
END;
exp:=Low.exponent10(real); addDecPt:=place>=0;
IF place<0 THEN INC(place, 2) ELSE INC(place) END;
IF exp<0 THEN (* account for digits *)
IF place<=0 THEN len:=1 ELSE len:=place END
ELSE len:=exp+place;
IF 1-place>0 THEN INC(len, 1-place) END
END;
IF real<ZERO THEN INC(len) END; (* account for the sign *)
IF addDecPt THEN INC(len) END; (* account for decimal point *)
RETURN len
END LengthFixedReal;
PROCEDURE IsRConvException*(): BOOLEAN;
(* Returns TRUE if the current coroutine is in the exceptional execution state because
of the raising of the RealConv exception; otherwise returns FALSE.
*)
BEGIN
RETURN FALSE
END IsRConvException;
PROCEDURE Test;
VAR res: INTEGER; f: LONGREAL;
BEGIN
f:=ValueReal("-1.8770465240919248E+246");
f:=ValueReal("5.1059259362558051E-111");
f:=ValueReal("2.4312432637500083E-88");
res:=LengthFixedReal(100, 0);
res:=LengthEngReal(100, 0);
res:=LengthFloatReal(100, 0);
res:=LengthFixedReal(-100.123, 0);
res:=LengthEngReal(-100.123, 0);
res:=LengthFloatReal(-100.123, 0);
res:=LengthFixedReal(-1.0D20, 0);
res:=LengthEngReal(-1.0D20, 0);
res:=LengthFloatReal(-1.0D20, 0)
END Test;
BEGIN
NEW(RS); NEW(P); NEW(F); NEW(E); NEW(SE); NEW(WE); NEW(SR);
RS.p:=RSState; P.p:=PState; F.p:=FState; E.p:=EState;
SE.p:=SEState; WE.p:=WEState; SR.p:=ScanReal;
IF DEBUG THEN Test END
END oocLRealConv.

561
src/library/ooc/oocLRealMath.Mod Normal file
View file

@ -0,0 +1,561 @@
MODULE oocLRealMath;
(*
LRealMath - Target independent mathematical functions for LONGREAL
(IEEE double-precision) numbers.
Numerical approximations are taken from "Software Manual for the
Elementary Functions" by Cody & Waite and "Computer Approximations"
by Hart et al.
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
*)
IMPORT l := oocLowLReal, m := oocRealMath;
CONST
pi* = 3.1415926535897932384626433832795028841972D0;
exp1* = 2.7182818284590452353602874713526624977572D0;
ZERO=0.0D0; ONE=1.0D0; HALF=0.5D0; TWO=2.0D0; (* local constants *)
(* internally-used constants *)
huge=l.large; (* largest number this package accepts *)
miny=l.small; (* smallest number this package accepts *)
sqrtHalf=0.70710678118654752440D0;
Limit=1.0536712D-8; (* 2**(-MantBits/2) *)
eps=5.5511151D-17; (* 2**(-MantBits-1) *)
piInv=0.31830988618379067154D0; (* 1/pi *)
piByTwo=1.57079632679489661923D0;
lnv=0.6931610107421875D0; (* should be exact *)
vbytwo=0.13830277879601902638D-4; (* used in sinh/cosh *)
ln2Inv=1.44269504088896340735992468100189213D0;
(* error/exception codes *)
NoError*=m.NoError; IllegalRoot*=m.IllegalRoot; IllegalLog*=m.IllegalLog; Overflow*=m.Overflow;
IllegalPower*=m.IllegalPower; IllegalLogBase*=m.IllegalLogBase; IllegalTrig*=m.IllegalTrig;
IllegalInvTrig*=m.IllegalInvTrig; HypInvTrigClipped*=m.HypInvTrigClipped;
IllegalHypInvTrig*=m.IllegalHypInvTrig; LossOfAccuracy*=m.LossOfAccuracy;
VAR
a1: ARRAY 18 OF LONGREAL; (* lookup table for power function *)
a2: ARRAY 9 OF LONGREAL; (* lookup table for power function *)
em: LONGREAL; (* largest number such that 1+epsilon > 1.0 *)
LnInfinity: LONGREAL; (* natural log of infinity *)
LnSmall: LONGREAL; (* natural log of very small number *)
SqrtInfinity: LONGREAL; (* square root of infinity *)
TanhMax: LONGREAL; (* maximum Tanh value *)
t: LONGREAL; (* internal variables *)
(* internally used support routines *)
PROCEDURE SinCos (x, y, sign: LONGREAL): LONGREAL;
CONST
ymax=210828714; (* ENTIER(pi*2**(MantBits/2)) *)
c1=3.1416015625D0;
c2=-8.908910206761537356617D-6;
r1=-0.16666666666666665052D+0;
r2= 0.83333333333331650314D-2;
r3=-0.19841269841201840457D-3;
r4= 0.27557319210152756119D-5;
r5=-0.25052106798274584544D-7;
r6= 0.16058936490371589114D-9;
r7=-0.76429178068910467734D-12;
r8= 0.27204790957888846175D-14;
VAR
n: LONGINT; xn, f, x1, g: LONGREAL;
BEGIN
IF y>=ymax THEN l.ErrorHandler(LossOfAccuracy); RETURN ZERO END;
(* determine the reduced number *)
n:=ENTIER(y*piInv+HALF); xn:=n;
IF ODD(n) THEN sign:=-sign END;
x:=ABS(x);
IF x#y THEN xn:=xn-HALF END;
(* fractional part of reduced number *)
x1:=ENTIER(x);
f:=((x1-xn*c1)+(x-x1))-xn*c2;
(* Pre: |f| <= pi/2 *)
IF ABS(f)<Limit THEN RETURN sign*f END;
(* evaluate polynomial approximation of sin *)
g:=f*f; g:=(((((((r8*g+r7)*g+r6)*g+r5)*g+r4)*g+r3)*g+r2)*g+r1)*g;
g:=f+f*g; (* don't use less accurate f(1+g) *)
RETURN sign*g
END SinCos;
PROCEDURE div (x, y : LONGINT) : LONGINT;
(* corrected MOD function *)
BEGIN
IF x < 0 THEN RETURN -ABS(x) DIV y ELSE RETURN x DIV y END
END div;
(* forward declarations *)
PROCEDURE^ arctan2* (xn, xd: LONGREAL): LONGREAL;
PROCEDURE^ sincos* (x: LONGREAL; VAR Sin, Cos: LONGREAL);
PROCEDURE sqrt*(x: LONGREAL): LONGREAL;
(* Returns the positive square root of x where x >= 0 *)
CONST
P0=0.41731; P1=0.59016;
VAR
xMant, yEst, z: LONGREAL; xExp: INTEGER;
BEGIN
(* optimize zeros and check for illegal negative roots *)
IF x=ZERO THEN RETURN ZERO END;
IF x<ZERO THEN l.ErrorHandler(IllegalRoot); x:=-x END;
(* reduce the input number to the range 0.5 <= x <= 1.0 *)
xMant:=l.fraction(x)*HALF; xExp:=l.exponent(x)+1;
(* initial estimate of the square root *)
yEst:=P0+P1*xMant;
(* perform three newtonian iterations *)
z:=(yEst+xMant/yEst); yEst:=0.25*z+xMant/z;
yEst:=HALF*(yEst+xMant/yEst);
(* adjust for odd exponents *)
IF ODD(xExp) THEN yEst:=yEst*sqrtHalf; INC(xExp) END;
(* single Newtonian iteration to produce real number accuracy *)
RETURN l.scale(yEst, xExp DIV 2)
END sqrt;
PROCEDURE exp*(x: LONGREAL): LONGREAL;
(* Returns the exponential of x for x < Ln(MAX(REAL) *)
CONST
c1=0.693359375D0; c2=-2.1219444005469058277D-4;
P0=0.249999999999999993D+0; P1=0.694360001511792852D-2; P2=0.165203300268279130D-4;
Q1=0.555538666969001188D-1; Q2=0.495862884905441294D-3;
VAR xn, g, p, q, z: LONGREAL; n: INTEGER;
BEGIN
(* Ensure we detect overflows and return 0 for underflows *)
IF x>LnInfinity THEN l.ErrorHandler(Overflow); RETURN huge
ELSIF x<LnSmall THEN RETURN ZERO
ELSIF ABS(x)<eps THEN RETURN ONE
END;
(* Decompose and scale the number *)
IF x>=ZERO THEN n:=SHORT(ENTIER(ln2Inv*x+HALF))
ELSE n:=SHORT(ENTIER(ln2Inv*x-HALF))
END;
xn:=n; g:=(x-xn*c1)-xn*c2;
(* Calculate exp(g)/2 from "Software Manual for the Elementary Functions" *)
z:=g*g; p:=((P2*z+P1)*z+P0)*g; q:=(Q2*z+Q1)*z+HALF;
RETURN l.scale(HALF+p/(q-p), n+1)
END exp;
PROCEDURE ln*(x: LONGREAL): LONGREAL;
(* Returns the natural logarithm of x for x > 0 *)
CONST
c1=355.0D0/512.0D0; c2=-2.121944400546905827679D-4;
P0=-0.64124943423745581147D+2; P1=0.16383943563021534222D+2; P2=-0.78956112887491257267D+0;
Q0=-0.76949932108494879777D+3; Q1=0.31203222091924532844D+3; Q2=-0.35667977739034646171D+2;
VAR f, zn, zd, r, z, w, p, q, xn: LONGREAL; n: INTEGER;
BEGIN
(* ensure illegal inputs are trapped and handled *)
IF x<=ZERO THEN l.ErrorHandler(IllegalLog); RETURN -huge END;
(* reduce the range of the input *)
f:=l.fraction(x)*HALF; n:=l.exponent(x)+1;
IF f>sqrtHalf THEN zn:=(f-HALF)-HALF; zd:=f*HALF+HALF
ELSE zn:=f-HALF; zd:=zn*HALF+HALF; DEC(n)
END;
(* evaluate rational approximation from "Software Manual for the Elementary Functions" *)
z:=zn/zd; w:=z*z; q:=((w+Q2)*w+Q1)*w+Q0; p:=w*((P2*w+P1)*w+P0); r:=z+z*(p/q);
(* scale the output *)
xn:=n;
RETURN (xn*c2+r)+xn*c1
END ln;
(* The angle in all trigonometric functions is measured in radians *)
PROCEDURE sin* (x: LONGREAL): LONGREAL;
BEGIN
IF x<ZERO THEN RETURN SinCos(x, -x, -ONE)
ELSE RETURN SinCos(x, x, ONE)
END
END sin;
PROCEDURE cos* (x: LONGREAL): LONGREAL;
BEGIN
RETURN SinCos(x, ABS(x)+piByTwo, ONE)
END cos;
PROCEDURE tan*(x: LONGREAL): LONGREAL;
(* Returns the tangent of x where x cannot be an odd multiple of pi/2 *)
VAR Sin, Cos: LONGREAL;
BEGIN
sincos(x, Sin, Cos);
IF ABS(Cos)<miny THEN l.ErrorHandler(IllegalTrig); RETURN huge
ELSE RETURN Sin/Cos
END
END tan;
PROCEDURE arcsin*(x: LONGREAL): LONGREAL;
(* Returns the arcsine of x, in the range [-pi/2, pi/2] where -1 <= x <= 1 *)
BEGIN
IF ABS(x)>ONE THEN l.ErrorHandler(IllegalInvTrig); RETURN huge
ELSE RETURN arctan2(x, sqrt(ONE-x*x))
END
END arcsin;
PROCEDURE arccos*(x: LONGREAL): LONGREAL;
(* Returns the arccosine of x, in the range [0, pi] where -1 <= x <= 1 *)
BEGIN
IF ABS(x)>ONE THEN l.ErrorHandler(IllegalInvTrig); RETURN huge
ELSE RETURN arctan2(sqrt(ONE-x*x), x)
END
END arccos;
PROCEDURE arctan*(x: LONGREAL): LONGREAL;
(* Returns the arctangent of x, in the range [-pi/2, pi/2] for all x *)
BEGIN
RETURN arctan2(x, ONE)
END arctan;
PROCEDURE power*(base, exponent: LONGREAL): LONGREAL;
(* Returns the value of the number base raised to the power exponent
for base > 0 *)
CONST
P1=0.83333333333333211405D-1; P2=0.12500000000503799174D-1;
P3=0.22321421285924258967D-2; P4=0.43445775672163119635D-3;
K=0.44269504088896340736D0;
Q1=0.69314718055994529629D+0; Q2=0.24022650695909537056D+0;
Q3=0.55504108664085595326D-1; Q4=0.96181290595172416964D-2;
Q5=0.13333541313585784703D-2; Q6=0.15400290440989764601D-3;
Q7=0.14928852680595608186D-4;
OneOver16=0.0625D0; XMAX=16*l.expoMax-1; (*XMIN=16*l.expoMin+1;*) XMIN=-16351; (* noch *)
VAR z, g, R, v, u2, u1, w1, w2, y1, y2, w: LONGREAL; m, p, i: INTEGER; mp, pp, iw1: LONGINT;
BEGIN
(* handle all possible error conditions *)
IF ABS(exponent)<miny THEN RETURN ONE (* base**0 = 1 *)
ELSIF base<ZERO THEN l.ErrorHandler(IllegalPower); RETURN -huge
ELSIF ABS(base)<miny THEN
IF exponent>ZERO THEN RETURN ZERO ELSE l.ErrorHandler(Overflow); RETURN -huge END
END;
(* extract the exponent of base to m and clear exponent of base in g *)
g:=l.fraction(base)*HALF; m:=l.exponent(base)+1;
(* determine p table offset with an unrolled binary search *)
p:=1;
IF g<=a1[9] THEN p:=9 END;
IF g<=a1[p+4] THEN INC(p, 4) END;
IF g<=a1[p+2] THEN INC(p, 2) END;
(* compute scaled z so that |z| <= 0.044 *)
z:=((g-a1[p+1])-a2[(p+1) DIV 2])/(g+a1[p+1]); z:=z+z;
(* approximation for log2(z) from "Software Manual for the Elementary Functions" *)
v:=z*z; R:=(((P4*v+P3)*v+P2)*v+P1)*v*z; R:=R+K*R; u2:=(R+z*K)+z; u1:=(m*16-p)*OneOver16;
(* generate w with extra precision calculations *)
y1:=ENTIER(16*exponent)*OneOver16; y2:=exponent-y1; w:=u2*exponent+u1*y2;
w1:=ENTIER(16*w)*OneOver16; w2:=w-w1; w:=w1+u1*y1;
w1:=ENTIER(16*w)*OneOver16; w2:=w2+(w-w1); w:=ENTIER(16*w2)*OneOver16;
iw1:=ENTIER(16*(w+w1)); w2:=w2-w;
(* check for overflow/underflow *)
IF iw1>XMAX THEN l.ErrorHandler(Overflow); RETURN huge
ELSIF iw1<XMIN THEN RETURN ZERO (* underflow *)
END;
(* final approximation 2**w2-1 where -0.0625 <= w2 <= 0 *)
IF w2>ZERO THEN INC(iw1); w2:=w2-OneOver16 END; IF iw1<0 THEN i:=0 ELSE i:=1 END;
mp:=div(iw1, 16)+i; pp:=16*mp-iw1;
z:=((((((Q7*w2+Q6)*w2+Q5)*w2+Q4)*w2+Q3)*w2+Q2)*w2+Q1)*w2; z:=a1[pp+1]+a1[pp+1]*z;
RETURN l.scale(z, SHORT(mp))
END power;
PROCEDURE round*(x: LONGREAL): LONGINT;
(* Returns the value of x rounded to the nearest integer *)
BEGIN
IF x<ZERO THEN RETURN -ENTIER(HALF-x)
ELSE RETURN ENTIER(x+HALF)
END
END round;
PROCEDURE IsRMathException*(): BOOLEAN;
(* Returns TRUE if the current coroutine is in the exceptional execution state
because of the raising of the RealMath exception; otherwise returns FALSE.
*)
BEGIN
RETURN FALSE
END IsRMathException;
(*
Following routines are provided as extensions to the ISO standard.
They are either used as the basis of other functions or provide
useful functions which are not part of the ISO standard.
*)
PROCEDURE log* (x, base: LONGREAL): LONGREAL;
(* log(x,base) is the logarithm of x base b. All positive arguments are
allowed but base > 0 and base # 1. *)
BEGIN
(* log(x, base) = log2(x) / log2(base) *)
IF base<=ZERO THEN l.ErrorHandler(IllegalLogBase); RETURN -huge
ELSE RETURN ln(x)/ln(base)
END
END log;
PROCEDURE ipower* (x: LONGREAL; base: INTEGER): LONGREAL;
(* ipower(x, base) returns the x to the integer power base where base*Log2(x) < Log2(Max) *)
VAR y: LONGREAL; neg: BOOLEAN; Exp: LONGINT;
PROCEDURE Adjust(xadj: LONGREAL): LONGREAL;
BEGIN
IF (x<ZERO)&ODD(base) THEN RETURN -xadj ELSE RETURN xadj END
END Adjust;
BEGIN
(* handle all possible error conditions *)
IF base=0 THEN RETURN ONE (* x**0 = 1 *)
ELSIF ABS(x)<miny THEN
IF base>0 THEN RETURN ZERO ELSE l.ErrorHandler(Overflow); RETURN Adjust(huge) END
END;
(* trap potential overflows and underflows *)
Exp:=(l.exponent(x)+1)*base; y:=LnInfinity*ln2Inv;
IF Exp>y THEN l.ErrorHandler(Overflow); RETURN Adjust(huge)
ELSIF Exp<-y THEN RETURN ZERO
END;
(* compute x**base using an optimised algorithm from Knuth, slightly
altered : p442, The Art Of Computer Programming, Vol 2 *)
y:=ONE; IF base<0 THEN neg:=TRUE; base := -base ELSE neg:= FALSE END;
LOOP
IF ODD(base) THEN y:=y*x END;
base:=base DIV 2; IF base=0 THEN EXIT END;
x:=x*x;
END;
IF neg THEN RETURN ONE/y ELSE RETURN y END
END ipower;
PROCEDURE sincos* (x: LONGREAL; VAR Sin, Cos: LONGREAL);
(* More efficient sin/cos implementation if both values are needed. *)
BEGIN
Sin:=sin(x); Cos:=sqrt(ONE-Sin*Sin)
END sincos;
PROCEDURE arctan2* (xn, xd: LONGREAL): LONGREAL;
(* arctan2(xn,xd) is the quadrant-correct arc tangent atan(xn/xd). If the
denominator xd is zero, then the numerator xn must not be zero. All
arguments are legal except xn = xd = 0. *)
CONST
P0=0.216062307897242551884D+3; P1=0.3226620700132512059245D+3;
P2=0.13270239816397674701D+3; P3=0.1288838303415727934D+2;
Q0=0.2160623078972426128957D+3; Q1=0.3946828393122829592162D+3;
Q2=0.221050883028417680623D+3; Q3=0.3850148650835119501D+2;
PiOver2=pi/2; Sqrt3=1.7320508075688772935D0;
VAR atan, z, z2, p, q: LONGREAL; xnExp, xdExp: INTEGER; Quadrant: SHORTINT;
BEGIN
IF ABS(xd)<miny THEN
IF ABS(xn)<miny THEN l.ErrorHandler(IllegalInvTrig); atan:=ZERO
ELSE l.ErrorHandler(Overflow); atan:=PiOver2
END
ELSE xnExp:=l.exponent(xn); xdExp:=l.exponent(xd);
IF xnExp-xdExp>=l.expoMax-3 THEN l.ErrorHandler(Overflow); atan:=PiOver2
ELSIF xnExp-xdExp<l.expoMin+3 THEN atan:=ZERO
ELSE
(* ensure division of xn/xd always produces a number < 1 & resolve quadrant *)
IF ABS(xn)>ABS(xd) THEN z:=ABS(xd/xn); Quadrant:=2
ELSE z:=ABS(xn/xd); Quadrant:=0
END;
(* further reduce range to within 0 to 2-sqrt(3) *)
IF z>TWO-Sqrt3 THEN z:=(z*Sqrt3-ONE)/(Sqrt3+z); INC(Quadrant) END;
(* approximation from "Computer Approximations" table ARCTN 5075 *)
IF ABS(z)<Limit THEN atan:=z (* for small values of z2, return this value *)
ELSE z2:=z*z; p:=(((P3*z2+P2)*z2+P1)*z2+P0)*z; q:=(((z2+Q3)*z2+Q2)*z2+Q1)*z2+Q0; atan:=p/q;
END;
(* adjust for z's quadrant *)
IF Quadrant>1 THEN atan:=-atan END;
CASE Quadrant OF
1: atan:=atan+pi/6
| 2: atan:=atan+PiOver2
| 3: atan:=atan+pi/3
| ELSE (* angle is correct *)
END
END;
(* map negative xds into the correct quadrant *)
IF xd<ZERO THEN atan:=pi-atan END
END;
(* map negative xns into the correct quadrant *)
IF xn<ZERO THEN atan:=-atan END;
RETURN atan
END arctan2;
PROCEDURE sinh* (x: LONGREAL): LONGREAL;
(* sinh(x) is the hyperbolic sine of x. The argument x must not be so large
that exp(|x|) overflows. *)
CONST
P0=-0.35181283430177117881D+6; P1=-0.11563521196851768270D+5;
P2=-0.16375798202630751372D+3; P3=-0.78966127417357099479D+0;
Q0=-0.21108770058106271242D+7; Q1= 0.36162723109421836460D+5;
Q2=-0.27773523119650701667D+3;
VAR y, f, p, q: LONGREAL;
BEGIN y:=ABS(x);
IF y<=ONE THEN (* handle small arguments *)
IF y<Limit THEN RETURN x END;
(* use approximation from "Software Manual for the Elementary Functions" *)
f:=y*y; p:=((P3*f+P2)*f+P1)*f+P0; q:=((f+Q2)*f+Q1)*f+Q0; y:=f*(p/q); RETURN x+x*y
ELSIF y>LnInfinity THEN (* handle exp overflows *)
y:=y-lnv;
IF y>LnInfinity-lnv+0.69 THEN l.ErrorHandler(Overflow);
IF x>ZERO THEN RETURN huge ELSE RETURN -huge END
ELSE f:=exp(y); f:=f+f*vbytwo (* don't change to f(1+vbytwo) *)
END
ELSE f:=exp(y); f:=(f-ONE/f)*HALF
END;
(* reach here when 1 < ABS(x) < LnInfinity-lnv+0.69 *)
IF x>ZERO THEN RETURN f ELSE RETURN -f END
END sinh;
PROCEDURE cosh* (x: LONGREAL): LONGREAL;
(* cosh(x) is the hyperbolic cosine of x. The argument x must not be so large
that exp(|x|) overflows. *)
VAR y, f: LONGREAL;
BEGIN y:=ABS(x);
IF y>LnInfinity THEN (* handle exp overflows *)
y:=y-lnv;
IF y>LnInfinity-lnv+0.69 THEN l.ErrorHandler(Overflow);
IF x>ZERO THEN RETURN huge ELSE RETURN -huge END
ELSE f:=exp(y); RETURN f+f*vbytwo (* don't change to f(1+vbytwo) *)
END
ELSE f:=exp(y); RETURN (f+ONE/f)*HALF
END
END cosh;
PROCEDURE tanh* (x: LONGREAL): LONGREAL;
(* tanh(x) is the hyperbolic tangent of x. All arguments are legal. *)
CONST
P0=-0.16134119023996228053D+4; P1=-0.99225929672236083313D+2; P2=-0.96437492777225469787D+0;
Q0= 0.48402357071988688686D+4; Q1= 0.22337720718962312926D+4; Q2= 0.11274474380534949335D+3;
ln3over2=0.54930614433405484570D0;
BIG=19.06154747D0; (* (ln(2)+(t+1)*ln(B))/2 where t=mantissa bits, B=base *)
VAR f, t: LONGREAL;
BEGIN f:=ABS(x);
IF f>BIG THEN t:=ONE
ELSIF f>ln3over2 THEN t:=ONE-TWO/(exp(TWO*f)+ONE)
ELSIF f<Limit THEN t:=f
ELSE (* approximation from "Software Manual for the Elementary Functions" *)
t:=f*f; t:=t*(((P2*t+P1)*t+P0)/(((t+Q2)*t+Q1)*t+Q0)); t:=f+f*t
END;
IF x<ZERO THEN RETURN -t ELSE RETURN t END
END tanh;
PROCEDURE arcsinh* (x: LONGREAL): LONGREAL;
(* arcsinh(x) is the arc hyperbolic sine of x. All arguments are legal. *)
BEGIN
IF ABS(x)>SqrtInfinity*HALF THEN l.ErrorHandler(HypInvTrigClipped);
IF x>ZERO THEN RETURN ln(SqrtInfinity) ELSE RETURN -ln(SqrtInfinity) END;
ELSIF x<ZERO THEN RETURN -ln(-x+sqrt(x*x+ONE))
ELSE RETURN ln(x+sqrt(x*x+ONE))
END
END arcsinh;
PROCEDURE arccosh* (x: LONGREAL): LONGREAL;
(* arccosh(x) is the arc hyperbolic cosine of x. All arguments greater than
or equal to 1 are legal. *)
BEGIN
IF x<ONE THEN l.ErrorHandler(IllegalHypInvTrig); RETURN ZERO
ELSIF x>SqrtInfinity*HALF THEN l.ErrorHandler(HypInvTrigClipped); RETURN ln(SqrtInfinity)
ELSE RETURN ln(x+sqrt(x*x-ONE))
END
END arccosh;
PROCEDURE arctanh* (x: LONGREAL): LONGREAL;
(* arctanh(x) is the arc hyperbolic tangent of x. |x| < 1 - sqrt(em), where
em is machine epsilon. Note that |x| must not be so close to 1 that the
result is less accurate than half precision. *)
CONST TanhLimit=0.999984991D0; (* Tanh(5.9) *)
VAR t: LONGREAL;
BEGIN t:=ABS(x);
IF (t>=ONE) OR (t>(ONE-TWO*em)) THEN l.ErrorHandler(IllegalHypInvTrig);
IF x<ZERO THEN RETURN -TanhMax ELSE RETURN TanhMax END
ELSIF t>TanhLimit THEN l.ErrorHandler(LossOfAccuracy)
END;
RETURN arcsinh(x/sqrt(ONE-x*x))
END arctanh;
PROCEDURE ToLONGREAL (hi, lo: LONGINT): LONGREAL;
VAR ra: ARRAY 2 OF LONGINT;
BEGIN ra[0]:=hi; ra[1]:=lo;
RETURN l.Real(ra)
END ToLONGREAL;
BEGIN
(* determine some fundamental constants used by hyperbolic trig functions *)
em:=l.ulp(ONE);
LnInfinity:=ln(huge);
LnSmall:=ln(miny);
SqrtInfinity:=sqrt(huge);
t:=l.pred(ONE)/sqrt(em); TanhMax:=ln(t+sqrt(t*t+ONE));
(* initialize some tables for the power() function a1[i]=2**((1-i)/16) *)
(* disable compiler warnings about 32-bit negative integers *)
(*<* PUSH; Warnings := FALSE *>*)
a1[ 1]:=ONE;
a1[ 2]:=ToLONGREAL(3FEEA4AFH, 0A2A490DAH);
a1[ 3]:=ToLONGREAL(3FED5818H, 0DCFBA487H);
a1[ 4]:=ToLONGREAL(3FEC199BH, 0DD85529CH);
a1[ 5]:=ToLONGREAL(3FEAE89FH, 0995AD3ADH);
a1[ 6]:=ToLONGREAL(3FE9C491H, 082A3F090H);
a1[ 7]:=ToLONGREAL(3FE8ACE5H, 0422AA0DBH);
a1[ 8]:=ToLONGREAL(3FE7A114H, 073EB0186H);
a1[ 9]:=ToLONGREAL(3FE6A09EH, 0667F3BCCH);
a1[10]:=ToLONGREAL(3FE5AB07H, 0DD485429H);
a1[11]:=ToLONGREAL(3FE4BFDAH, 0D5362A27H);
a1[12]:=ToLONGREAL(3FE3DEA6H, 04C123422H);
a1[13]:=ToLONGREAL(3FE306FEH, 00A31B715H);
a1[14]:=ToLONGREAL(3FE2387AH, 06E756238H);
a1[15]:=ToLONGREAL(3FE172B8H, 03C7D517AH);
a1[16]:=ToLONGREAL(3FE0B558H, 06CF9890FH);
a1[17]:=HALF;
(* a2[i]=2**[(1-2i)/16] - a1[2i]; delta resolution *)
a2[1]:=ToLONGREAL(3C90B1EEH, 074320000H);
a2[2]:=ToLONGREAL(3C711065H, 089500000H);
a2[3]:=ToLONGREAL(3C6C7C46H, 0B0700000H);
a2[4]:=ToLONGREAL(3C9AFAA2H, 0047F0000H);
a2[5]:=ToLONGREAL(3C86324CH, 005460000H);
a2[6]:=ToLONGREAL(3C7ADA09H, 011F00000H);
a2[7]:=ToLONGREAL(3C89B07EH, 0B6C80000H);
a2[8]:=ToLONGREAL(3C88A62EH, 04ADC0000H);
(* reenable compiler warnings *)
(*<* POP *>*)
END oocLRealMath.

451
src/library/ooc/oocLRealStr.Mod Normal file
View file

@ -0,0 +1,451 @@
(* $Id: LRealStr.Mod,v 1.8 2001/07/15 14:59:29 ooc-devel Exp $ *)
MODULE oocLRealStr;
(*
LRealStr - LONGREAL/string conversions.
Copyright (C) 1996, 2001 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
Low := oocLowLReal, Conv := oocConvTypes, RC := oocLRealConv, Str := oocStrings,
LInt := oocLongInts;
CONST
ZERO=0.0D0; B=8000H;
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 *)
(* the string form of a signed fixed-point real number is
["+" | "-"], decimal digit, {decimal digit}, [".", {decimal digit}]
*)
(* the string form of a signed floating-point real number is
signed fixed-point real number, "E"|"e", ["+" | "-"], decimal digit, {decimal digit}
*)
PROCEDURE StrToReal*(str: ARRAY OF CHAR; VAR real: LONGREAL; VAR res: ConvResults);
(*
Ignores any leading spaces in str. If the subsequent characters in str
are in the format of a signed real number, and shall assign values to
`res' and `real' as follows:
strAllRight
if the remainder of `str' represents a complete signed real number
in the range of the type of `real' -- the value of this number shall
be assigned to `real';
strOutOfRange
if the remainder of `str' represents a complete signed real number
but its value is out of the range of the type of `real' -- the
maximum or minimum value of the type of `real' shall be assigned to
`real' according to the sign of the number;
strWrongFormat
if there are remaining characters in `str' but these are not in the
form of a complete signed real number -- the value of `real' is not
defined;
strEmpty
if there are no remaining characters in `str' -- the value of `real'
is not defined.
*)
BEGIN
res:=RC.FormatReal(str);
IF res IN {strAllRight, strOutOfRange} THEN real:=RC.ValueReal(str) END
END StrToReal;
PROCEDURE AppendChar(ch: CHAR; VAR str: ARRAY OF CHAR);
VAR ds: ARRAY 2 OF CHAR;
BEGIN
ds[0]:=ch; ds[1]:=0X; Str.Append(ds, str)
END AppendChar;
PROCEDURE AppendDigit(dig: LONGINT; VAR str: ARRAY OF CHAR);
BEGIN
AppendChar(CHR(dig+ORD("0")), str)
END AppendDigit;
PROCEDURE AppendExponent(exp: INTEGER; VAR str: ARRAY OF CHAR);
BEGIN
Str.Append("E", str);
IF exp<0 THEN exp:=-exp; Str.Append("-", str)
ELSE Str.Append("+", str)
END;
IF exp>=100 THEN AppendDigit(exp DIV 100, str) END;
IF exp>=10 THEN AppendDigit((exp DIV 10) MOD 10, str) END;
AppendDigit(exp MOD 10, str)
END AppendExponent;
PROCEDURE AppendFraction(VAR n: LInt.LongInt; sigFigs, place: INTEGER; VAR str: ARRAY OF CHAR);
VAR digs, end: INTEGER; d: LONGINT; lstr: ARRAY 64 OF CHAR;
BEGIN
(* write significant digits *)
lstr:="";
FOR digs:=1 TO sigFigs DO
LInt.DivDigit(n, 10, d); AppendDigit(d, lstr);
END;
(* reverse the real digits and append to str *)
end:=sigFigs-1;
FOR digs:=0 TO sigFigs-1 DO
IF digs=place THEN Str.Append(".", str) END;
AppendChar(lstr[end], str); DEC(end)
END;
(* pad out digits to the decimal position *)
FOR digs:=sigFigs TO place-1 DO Str.Append("0", str) END
END AppendFraction;
PROCEDURE RemoveLeadingZeros(VAR str: ARRAY OF CHAR);
VAR len: LONGINT;
BEGIN
len:=Str.Length(str);
WHILE (len>1)&(str[0]="0")&(str[1]#".") DO Str.Delete(str, 0, 1); DEC(len) END
END RemoveLeadingZeros;
PROCEDURE MaxDigit (VAR n: LInt.LongInt) : LONGINT;
VAR
i, max : LONGINT;
BEGIN
(* return the maximum digit in the specified LongInt number *)
FOR i:=0 TO LEN(n)-1 DO
IF n[i] # 0 THEN
max := n[i];
WHILE max>=10 DO max:=max DIV 10 END;
RETURN max;
END;
END;
RETURN 0;
END MaxDigit;
PROCEDURE Scale (x: LONGREAL; VAR n: LInt.LongInt; sigFigs: INTEGER; exp: INTEGER; VAR overflow : BOOLEAN);
CONST
MaxDigits=4; LOG2B=15;
VAR
i, m, ln, d: LONGINT; e1, e2: INTEGER;
max: LONGINT;
BEGIN
(* extract fraction & exponent *)
m:=0; overflow := FALSE;
WHILE Low.exponent(x)=Low.expoMin DO (* scale up subnormal numbers *)
x:=x*2.0D0; DEC(m)
END;
m:=m+Low.exponent(x); x:=Low.fraction(x);
x:=Low.scale(x, SHORT(m MOD LOG2B)); (* scale up the number *)
m:=m DIV LOG2B; (* base B exponent *)
(* convert to an extended integer MOD B *)
ln:=LEN(n)-1;
FOR i:=ln-MaxDigits TO ln DO
n[i]:=SHORT(ENTIER(x)); (* convert/store the number *)
x:=(x-n[i])*B
END;
FOR i:=0 TO ln-MaxDigits-1 DO n[i]:=0 END; (* zero the other digits *)
(* scale to get the number of significant digits *)
e1:=SHORT(m)-MaxDigits; e2:= sigFigs-exp-1;
IF e1>=0 THEN
LInt.BPower(n, e1+1); LInt.TenPower(n, e2);
max := MaxDigit(n); (* remember the original digit so we can check for round-up *)
LInt.AddDigit(n, B DIV 2); LInt.DivDigit(n, B, d) (* round *)
ELSIF e2>0 THEN
LInt.TenPower(n, e2);
IF e1>0 THEN LInt.BPower(n, e1-1) ELSE LInt.BPower(n, e1+1) END;
max := MaxDigit(n); (* remember the original digit so we can check for round-up *)
LInt.AddDigit(n, B DIV 2); LInt.DivDigit(n, B, d) (* round *)
ELSE (* e1<=0, e2<=0 *)
LInt.TenPower(n, e2); LInt.BPower(n, e1+1);
max := MaxDigit(n); (* remember the original digit so we can check for round-up *)
LInt.AddDigit(n, B DIV 2); LInt.DivDigit(n, B, d) (* round *)
END;
(* check if the upper digit was changed by rounding up *)
IF (max = 9) & (max # MaxDigit(n)) THEN
overflow := TRUE;
END
END Scale;
PROCEDURE RealToFloat*(real: LONGREAL; sigFigs: INTEGER; VAR str: ARRAY OF CHAR);
(*
The call RealToFloat(real,sigFigs,str) shall assign to `str' the
possibly truncated string corresponding to the value of `real' in
floating-point form. A sign shall be included only for negative
values. One significant digit shall be included in the whole number
part. The signed exponent part shall be included only if the exponent
value is not 0. If the value of `sigFigs' is greater than 0, that
number of significant digits shall be included, otherwise an
implementation-defined number of significant digits shall be
included. The decimal point shall not be included if there are no
significant digits in the fractional part.
For example:
value: 3923009 39.23009 0.0003923009
sigFigs
1 4E+6 4E+1 4E-4
2 3.9E+6 3.9E+1 3.9E-4
5 3.9230E+6 3.9230E+1 3.9230E-4
*)
VAR
exp: INTEGER; in: LInt.LongInt;
lstr: ARRAY 64 OF CHAR;
overflow: BOOLEAN;
d: LONGINT;
BEGIN
(* set significant digits, extract sign & exponent *)
lstr:="";
IF sigFigs<=0 THEN sigFigs:=RC.SigFigs END;
(* check for illegal numbers *)
IF Low.IsNaN(real) THEN COPY("NaN", str); RETURN END;
IF real<ZERO THEN Str.Append("-", lstr); real:=-real END;
IF Low.IsInfinity(real) THEN Str.Append("Infinity", lstr); COPY(lstr, str); RETURN END;
exp:=Low.exponent10(real);
(* round the number and extract exponent again *)
Scale(real, in, sigFigs, exp, overflow);
IF overflow THEN
IF exp>=0 THEN INC(exp) ELSE DEC(exp) END;
LInt.DivDigit(in, 10, d)
END;
(* output number like x[.{x}][E+n[n]] *)
AppendFraction(in, sigFigs, 1, lstr);
IF exp#0 THEN AppendExponent(exp, lstr) END;
(* possibly truncate the result *)
COPY(lstr, str)
END RealToFloat;
PROCEDURE RealToEng*(real: LONGREAL; sigFigs: INTEGER; VAR str: ARRAY OF CHAR);
(*
Converts the value of real to floating-point string form, with
sigFigs significant figures, and copies the possibly truncated
result to str. The number is scaled with one to three digits in
the whole number part and with an exponent that is a multiple of
three.
For example:
value: 3923009 39.23009 0.0003923009
sigFigs
1 4E+6 40 400E-6
2 3.9E+6 39 390E-6
5 3.9230E+6 39.230 392.30E-6
*)
VAR
in: LInt.LongInt; exp, offset: INTEGER;
lstr: ARRAY 64 OF CHAR;
d: LONGINT;
overflow: BOOLEAN;
BEGIN
(* set significant digits, extract sign & exponent *)
lstr:="";
IF sigFigs<=0 THEN sigFigs:=RC.SigFigs END;
(* check for illegal numbers *)
IF Low.IsNaN(real) THEN COPY("NaN", str); RETURN END;
IF real<ZERO THEN Str.Append("-", lstr); real:=-real END;
IF Low.IsInfinity(real) THEN Str.Append("Infinity", lstr); COPY(lstr, str); RETURN END;
exp:=Low.exponent10(real);
(* round the number and extract exponent again (ie. 9.9 => 10.0) *)
Scale(real, in, sigFigs, exp, overflow);
IF overflow THEN
IF exp>=0 THEN INC(exp) ELSE DEC(exp) END;
LInt.DivDigit(in, 10, d)
END;
(* find the offset to make the exponent a multiple of three *)
offset:=exp MOD 3;
(* output number like x[x][x][.{x}][E+n[n]] *)
AppendFraction(in, sigFigs, offset+1, lstr);
exp:=exp-offset;
IF exp#0 THEN AppendExponent(exp, lstr) END;
(* possibly truncate the result *)
COPY(lstr, str)
END RealToEng;
PROCEDURE RealToFixed*(real: LONGREAL; place: INTEGER; VAR str: ARRAY OF CHAR);
(*
The call RealToFixed(real,place,str) shall assign to `str' the
possibly truncated string corresponding to the value of `real' in
fixed-point form. A sign shall be included only for negative values.
At least one digit shall be included in the whole number part. The
value shall be rounded to the given value of `place' relative to the
decimal point. The decimal point shall be suppressed if `place' is
less than 0.
For example:
value: 3923009 3.923009 0.0003923009
sigFigs
-5 3920000 0 0
-2 3923010 0 0
-1 3923009 4 0
0 3923009. 4. 0.
1 3923009.0 3.9 0.0
4 3923009.0000 3.9230 0.0004
*)
VAR
in: LInt.LongInt; exp, digs: INTEGER;
overflow, addDecPt: BOOLEAN;
lstr: ARRAY 256 OF CHAR;
BEGIN
(* set significant digits, extract sign & exponent *)
lstr:=""; addDecPt:=place=0;
(* check for illegal numbers *)
IF Low.IsNaN(real) THEN COPY("NaN", str); RETURN END;
IF real<ZERO THEN Str.Append("-", lstr); real:=-real END;
IF Low.IsInfinity(real) THEN Str.Append("Infinity", lstr); COPY(lstr, str); RETURN END;
exp:=Low.exponent10(real);
IF place<0 THEN digs:=place+exp+2 ELSE digs:=place+exp+1 END;
(* round the number and extract exponent again (ie. 9.9 => 10.0) *)
Scale(real, in, digs, exp, overflow);
IF overflow THEN
INC(digs); INC(exp);
addDecPt := place=0;
END;
(* output number like x[{x}][.{x}] *)
IF exp<0 THEN
IF place<0 THEN AppendFraction(in, 1, 1, lstr)
ELSE AppendFraction(in, place+1, 1, lstr)
END
ELSE AppendFraction(in, digs, exp+1, lstr);
RemoveLeadingZeros(lstr)
END;
(* special formatting *)
IF addDecPt THEN Str.Append(".", lstr) END;
(* possibly truncate the result *)
COPY(lstr, str)
END RealToFixed;
PROCEDURE RealToStr*(real: LONGREAL; VAR str: ARRAY OF CHAR);
(*
If the sign and magnitude of `real' can be shown within the capacity
of `str', the call RealToStr(real,str) shall behave as the call
RealToFixed(real,place,str), with a value of `place' chosen to fill
exactly the remainder of `str'. Otherwise, the call shall behave as
the call RealToFloat(real,sigFigs,str), with a value of `sigFigs' of
at least one, but otherwise limited to the number of significant
digits that can be included together with the sign and exponent part
in `str'.
*)
VAR
cap, exp, fp, len, pos: INTEGER;
found: BOOLEAN;
BEGIN
cap:=SHORT(LEN(str))-1; (* determine the capacity of the string with space for trailing 0X *)
(* check for illegal numbers *)
IF Low.IsNaN(real) THEN COPY("NaN", str); RETURN END;
IF real<ZERO THEN COPY("-", str); fp:=-1 ELSE COPY("", str); fp:=0 END;
IF Low.IsInfinity(ABS(real)) THEN Str.Append("Infinity", str); RETURN END;
(* extract exponent *)
exp:=Low.exponent10(real);
(* format number *)
INC(fp, RC.SigFigs-exp-2);
len:=RC.LengthFixedReal(real, fp);
IF cap>=len THEN
RealToFixed(real, fp, str);
(* pad with remaining zeros *)
IF fp<0 THEN Str.Append(".", str); INC(len) END; (* add decimal point *)
WHILE len<cap DO Str.Append("0", str); INC(len) END
ELSE
fp:=RC.LengthFloatReal(real, RC.SigFigs); (* check actual length *)
IF fp<=cap THEN
RealToFloat(real, RC.SigFigs, str);
(* pad with remaining zeros *)
Str.FindNext("E", str, 2, found, pos);
WHILE fp<cap DO Str.Insert("0", pos, str); INC(fp) END
ELSE fp:=RC.SigFigs-fp+cap;
IF fp<1 THEN fp:=1 END;
RealToFloat(real, fp, str)
END
END
END RealToStr;
END oocLRealStr.

101
src/library/ooc/oocLongInts.Mod Normal file
View file

@ -0,0 +1,101 @@
(* $Id: LongInts.Mod,v 1.3 1999/09/02 13:14:52 acken Exp $ *)
MODULE oocLongInts;
(*
LongInts - Simple extended integer implementation.
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
*)
CONST
B*=8000H;
TYPE
LongInt*=ARRAY 170 OF INTEGER;
PROCEDURE MinDigit * (VAR w: LongInt) : LONGINT;
VAR min, l: LONGINT;
BEGIN
min:=1; l:=LEN(w)-1;
WHILE (min<l) & (w[min]=0) DO INC(min) END;
RETURN min
END MinDigit;
PROCEDURE MultDigit * (VAR w: LongInt; digit, k: LONGINT);
VAR i, t, min: LONGINT;
BEGIN
i:=LEN(w)-1; min:=MinDigit(w)-2;
REPEAT
t:=w[i]*digit+k; (* multiply *)
w[i]:=SHORT(t MOD B); k:=t DIV B; (* generate result & carry *)
DEC(i)
UNTIL i=min
END MultDigit;
PROCEDURE AddDigit * (VAR w: LongInt; k: LONGINT);
VAR i, t, min: LONGINT;
BEGIN
i:=LEN(w)-1; min:=MinDigit(w)-2;
REPEAT
t:=w[i]+k; (* add *)
w[i]:=SHORT(t MOD B); k:=t DIV B; (* generate result & carry *)
DEC(i)
UNTIL i=min
END AddDigit;
PROCEDURE DivDigit * (VAR w: LongInt; digit: LONGINT; VAR r: LONGINT);
VAR j, t, m: LONGINT;
BEGIN
j:=MinDigit(w)-1; r:=0; m:=LEN(w)-1;
REPEAT
t:=r*B+w[j];
w[j]:=SHORT(t DIV digit); r:=t MOD digit; (* generate result & remainder *)
INC(j)
UNTIL j>m
END DivDigit;
PROCEDURE TenPower * (VAR x: LongInt; power: INTEGER);
VAR exp, i: INTEGER; d: LONGINT;
BEGIN
IF power>0 THEN
exp:=power DIV 4; power:=power MOD 4;
FOR i:=1 TO exp DO MultDigit(x, 10000, 0) END;
FOR i:=1 TO power DO MultDigit(x, 10, 0) END
ELSIF power<0 THEN
power:=-power;
exp:=power DIV 4; power:=power MOD 4;
FOR i:=1 TO exp DO DivDigit(x, 10000, d) END;
FOR i:=1 TO power DO DivDigit(x, 10, d) END
END
END TenPower;
PROCEDURE BPower * (VAR x: LongInt; power: INTEGER);
VAR i, lx: LONGINT;
BEGIN
lx:=LEN(x);
IF power>0 THEN
FOR i:=1 TO lx-1-power DO x[i]:=x[i+power] END;
FOR i:=lx-power TO lx-1 DO x[i]:=0 END
ELSIF power<0 THEN
power:=-power;
FOR i:=lx-1-power TO 1 BY -1 DO x[i+power]:=x[i] END;
FOR i:=1 TO power DO x[i]:=0 END
END
END BPower;
END oocLongInts.

484
src/library/ooc/oocLowLReal.Mod Normal file
View file

@ -0,0 +1,484 @@
(* $Id: LowLReal.Mod,v 1.6 1999/09/02 13:15:35 acken Exp $ *)
MODULE oocLowLReal;
(*
LowLReal - Gives access to the underlying properties of the type LONGREAL
for IEEE double-precision numbers.
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 Low := oocLowReal, S := SYSTEM;
(*
Real number properties are defined as follows:
radix--The whole number value of the radix used to represent the
corresponding read number values.
places--The whole number value of the number of radix places used
to store values of the corresponding real number type.
expoMin--The whole number value of the exponent minimum.
expoMax--The whole number value of the exponent maximum.
large--The largest value of the corresponding real number type.
small--The smallest positive value of the corresponding real number
type, represented to maximal precision.
IEC559--A Boolean value that is TRUE if and only if the implementation
of the corresponding real number type conforms to IEC 559:1989
(IEEE 754:1987) in all regards.
NOTES
6 -- If `IEC559' is TRUE, the value of `radix' is 2.
7 -- If LowReal.IEC559 is TRUE, the 32-bit format of IEC 559:1989
is used for the type REAL.
7 -- If LowLong.IEC559 is TRUE, the 64-bit format of IEC 559:1989
is used for the type REAL.
LIA1--A Boolean value that is TRUE if and only if the implementation of
the corresponding real number type conforms to ISO/IEC 10967-1:199x
(LIA-1) in all regards: parameters, arithmetic, exceptions, and
notification.
rounds--A Boolean value that is TRUE if and only if each operation produces
a result that is one of the values of the corresponding real number
type nearest to the mathematical result.
gUnderflow--A Boolean value that is TRUE if and only if there are values of
the corresponding real number type between 0.0 and `small'.
exception--A Boolean value that is TRUE if and only if every operation that
attempts to produce a real value out of range raises an exception.
extend--A Boolean value that is TRUE if and only if expressions of the
corresponding real number type are computed to higher precision than
the stored values.
nModes--The whole number value giving the number of bit positions needed for
the status flags for mode control.
*)
CONST
radix*= 2;
places*= 53;
expoMax*= 1023;
expoMin*= 1-expoMax;
large*= MAX(LONGREAL); (*1.7976931348623157D+308;*) (* MAX(LONGREAL) *)
(*small*= 2.2250738585072014D-308;*)
small*= 2.2250738585072014/9.9999999999999981D307(*/10^308)*);
IEC559*= TRUE;
LIA1*= FALSE;
rounds*= FALSE;
gUnderflow*= TRUE; (* there are IEEE numbers smaller than `small' *)
exception*= FALSE; (* at least in the default implementation *)
extend*= FALSE;
nModes*= 0;
ONE=1.0D0; (* some commonly-used constants *)
ZERO=0.0D0;
TEN=1.0D1;
DEBUG = TRUE;
expOffset=expoMax;
hiBit=19;
expBit=hiBit+1;
nMask={0..hiBit,31}; (* number mask *)
expMask={expBit..30}; (* exponent mask *)
TYPE
Modes*= SET;
LongInt=ARRAY 2 OF LONGINT;
LongSet=ARRAY 2 OF SET;
VAR
(*sml* : LONGREAL; tmp: LONGREAL;*) (* this was a test to get small as a variable at runtime. obviously, compile time preferred; -- noch *)
isBigEndian-: BOOLEAN; (* set when target is big endian *)
(*
PROCEDURE power0(i, j : INTEGER) : LONGREAL; (* used to calculate sml at runtime; -- noch *)
VAR k : INTEGER;
p : LONGREAL;
BEGIN
k := 1;
p := i;
REPEAT
p := p * i;
INC(k);
UNTIL k=j;
RETURN p;
END power0;
*)
(* Errors are handled through the LowReal module *)
PROCEDURE err*(): INTEGER;
BEGIN
RETURN Low.err
END err;
PROCEDURE ClearError*;
BEGIN
Low.ClearError
END ClearError;
PROCEDURE ErrorHandler*(err: INTEGER);
BEGIN
Low.ErrorHandler(err)
END ErrorHandler;
(* type-casting utilities *)
PROCEDURE Move (VAR x: LONGREAL; VAR ra: ARRAY OF LONGINT);
(* typecast a LONGREAL to an array of LONGINTs *)
VAR t: LONGINT;
BEGIN
S.MOVE(S.ADR(x),S.ADR(ra),SIZE(LONGREAL));
IF ~isBigEndian THEN t:=ra[0]; ra[0]:=ra[1]; ra[1]:=t END
END Move;
PROCEDURE MoveSet (VAR x: LONGREAL; VAR ra: ARRAY OF SET);
(* typecast a LONGREAL to an array of LONGINTs *)
VAR t: SET;
BEGIN
S.MOVE(S.ADR(x),S.ADR(ra),SIZE(LONGREAL));
IF ~isBigEndian THEN t:=ra[0]; ra[0]:=ra[1]; ra[1]:=t END
END MoveSet;
(* Note: The below should be done with a type cast --
once the compiler supports such things. *)
(*<* PUSH; Warnings := FALSE *>*)
PROCEDURE Real * (ra: ARRAY OF LONGINT): LONGREAL;
(* typecast an array of big endian LONGINTs to a LONGREAL *)
VAR t: LONGINT; x: LONGREAL;
BEGIN
IF ~isBigEndian THEN t:=ra[0]; ra[0]:=ra[1]; ra[1]:=t END;
S.MOVE(S.ADR(ra),S.ADR(x),SIZE(LONGREAL));
RETURN x
END Real;
PROCEDURE ToReal (ra: ARRAY OF SET): LONGREAL;
(* typecast an array of LONGINTs to a LONGREAL *)
VAR t: SET; x: LONGREAL;
BEGIN
IF ~isBigEndian THEN t:=ra[0]; ra[0]:=ra[1]; ra[1]:=t END;
S.MOVE(S.ADR(ra),S.ADR(x),SIZE(LONGREAL));
RETURN x
END ToReal;
(*<* POP *> *)
PROCEDURE exponent*(x: LONGREAL): INTEGER;
(*
The value of the call exponent(x) shall be the exponent value of `x'
that lies between `expoMin' and `expoMax'. An exception shall occur
and may be raised if `x' is equal to 0.0.
*)
VAR ra: LongInt;
BEGIN
(* NOTE: x=0.0 should raise exception *)
IF x=ZERO THEN RETURN 0
ELSE Move(x, ra);
RETURN SHORT(S.LSH(ra[0],-expBit) MOD 2048)-expOffset
END
END exponent;
PROCEDURE exponent10*(x: LONGREAL): INTEGER;
(*
The value of the call exponent10(x) shall be the base 10 exponent
value of `x'. An exception shall occur and may be raised if `x' is
equal to 0.0.
*)
VAR exp: INTEGER;
BEGIN
IF x=ZERO THEN RETURN 0 END; (* exception could be raised here *)
exp:=0; x:=ABS(x);
WHILE x>=TEN DO x:=x/TEN; INC(exp) END;
WHILE x<1 DO x:=x*TEN; DEC(exp) END;
RETURN exp
END exponent10;
PROCEDURE fraction*(x: LONGREAL): LONGREAL;
(*
The value of the call fraction(x) shall be the significand (or
significant) part of `x'. Hence the following relationship shall
hold: x = scale(fraction(x), exponent(x)).
*)
CONST eZero={(hiBit+2)..29};
VAR ra: LongInt;
BEGIN
IF x=ZERO THEN RETURN ZERO
ELSE Move(x, ra);
ra[0]:=S.VAL(LONGINT, S.VAL(SET,ra[0])*nMask+eZero);
RETURN Real(ra)*2.0D0
END
END fraction;
PROCEDURE IsInfinity * (real: LONGREAL) : BOOLEAN;
CONST signMask={0..30};
VAR ra: LongSet;
BEGIN
MoveSet(real, ra);
RETURN (ra[0]*signMask=expMask) & (ra[1]={})
END IsInfinity;
PROCEDURE IsNaN * (real: LONGREAL) : BOOLEAN;
CONST fracMask={0..hiBit};
VAR ra: LongSet;
BEGIN
MoveSet(real, ra);
RETURN (ra[0]*expMask=expMask) & ((ra[1]#{}) OR (ra[0]*fracMask#{}))
END IsNaN;
PROCEDURE sign*(x: LONGREAL): LONGREAL;
(*
The value of the call sign(x) shall be 1.0 if `x' is greater than 0.0,
or shall be -1.0 if `x' is less than 0.0, or shall be either 1.0 or
-1.0 if `x' is equal to 0.0.
*)
BEGIN
IF x<ZERO THEN RETURN -ONE ELSE RETURN ONE END
END sign;
PROCEDURE scale*(x: LONGREAL; n: INTEGER): LONGREAL;
(*
The value of the call scale(x,n) shall be the value x*radix^n if such
a value exists; otherwise an exception shall occur and may be raised.
*)
VAR exp: LONGINT; lexp: SET; ra: LongInt;
BEGIN
IF x=ZERO THEN RETURN ZERO END; (* can't scale zero *)
exp:= exponent(x)+n; (* new exponent *)
IF exp>expoMax THEN RETURN large*sign(x) (* exception raised here *)
ELSIF exp<expoMin THEN RETURN small*sign(x) (* exception here as well *)
END;
lexp:=S.VAL(SET,S.LSH(exp+expOffset,expBit)); (* shifted exponent bits *)
Move(x, ra);
ra[0]:=S.VAL(LONGINT, S.VAL(SET,ra[0])*nMask+lexp); (* insert new exponent *)
RETURN Real(ra)
END scale;
PROCEDURE ulp*(x: LONGREAL): LONGREAL;
(*
The value of the call ulp(x) shall be the value of the corresponding
real number type equal to a unit in the last place of `x', if such a
value exists; otherwise an exception shall occur and may be raised.
*)
BEGIN
RETURN scale(ONE, exponent(x)-places+1)
END ulp;
PROCEDURE succ*(x: LONGREAL): LONGREAL;
(*
The value of the call succ(x) shall be the next value of the
corresponding real number type greater than `x', if such a type
exists; otherwise an exception shall occur and may be raised.
*)
BEGIN
RETURN x+ulp(x)*sign(x)
END succ;
PROCEDURE pred*(x: LONGREAL): LONGREAL;
(*
The value of the call pred(x) shall be the next value of the
corresponding real number type less than `x', if such a type exists;
otherwise an exception shall occur and may be raised.
*)
BEGIN
RETURN x-ulp(x)*sign(x)
END pred;
PROCEDURE MaskReal(x: LONGREAL; lo: INTEGER): LONGREAL;
VAR ra: LongSet;
BEGIN
MoveSet(x, ra); (* type-cast into sets for masking *)
IF lo<32 THEN ra[1]:=ra[1]*{lo..31} (* just need to mask lower word *)
ELSE ra[0]:=ra[0]*{lo-32..31}; ra[1]:={} (* mask upper word & clear lower word *)
END;
RETURN ToReal(ra)
END MaskReal;
PROCEDURE intpart*(x: LONGREAL): LONGREAL;
(*
The value of the call intpart(x) shall be the integral part of `x'.
For negative values, this shall be -intpart(abs(x)).
*)
VAR lo, hi: INTEGER;
BEGIN hi:=hiBit+32; (* account for low 32-bits as well *)
lo:=(hi+1)-exponent(x);
IF lo<=0 THEN RETURN x (* no fractional part *)
ELSIF lo<=hi+1 THEN RETURN MaskReal(x, lo) (* integer part is extracted *)
ELSE RETURN 0 (* no whole part *)
END
END intpart;
PROCEDURE fractpart*(x: LONGREAL): LONGREAL;
(*
The value of the call fractpart(x) shall be the fractional part of
`x'. This satifies the relationship fractpart(x)+intpart(x)=x.
*)
BEGIN
RETURN x-intpart(x)
END fractpart;
PROCEDURE trunc*(x: LONGREAL; n: INTEGER): LONGREAL;
(*
The value of the call trunc(x,n) shall be the value of the most
significant `n' places of `x'. An exception shall occur and may be
raised if `n' is less than or equal to zero.
*)
VAR loBit: INTEGER;
BEGIN loBit:=places-n;
IF n<=0 THEN RETURN ZERO (* exception should be raised *)
ELSIF loBit<=0 THEN RETURN x (* nothing was truncated *)
ELSE RETURN MaskReal(x, loBit) (* clear all lower bits *)
END
END trunc;
PROCEDURE In (bit: INTEGER; x: LONGREAL): BOOLEAN;
VAR ra: LongSet;
BEGIN
MoveSet(x, ra); (* type-cast into sets for masking *)
IF bit<32 THEN RETURN bit IN ra[1] (* check bit in lower word *)
ELSE RETURN bit-32 IN ra[0] (* check bit in upper word *)
END
END In;
PROCEDURE round*(x: LONGREAL; n: INTEGER): LONGREAL;
(*
The value of the call round(x,n) shall be the value of `x' rounded to
the most significant `n' places. An exception shall occur and may be
raised if such a value does not exist, or if `n' is less than or equal
to zero.
*)
VAR loBit: INTEGER; t, r: LONGREAL;
BEGIN loBit:=places-n;
IF n<=0 THEN RETURN ZERO (* exception should be raised *)
ELSIF loBit<=0 THEN RETURN x (* nothing was rounded *)
ELSE t:=MaskReal(x, loBit); (* truncated result *)
IF In(loBit-1, x) THEN (* check if result should be rounded *)
r:=scale(ONE,exponent(x)-n+1); (* rounding fraction *)
IF In(31+32, x) THEN RETURN t-r (* negative rounding toward -infinity *)
ELSE RETURN t+r (* positive rounding toward +infinity *)
END
ELSE RETURN t (* return truncated result *)
END
END
END round;
PROCEDURE synthesize*(expart: INTEGER; frapart: LONGREAL): LONGREAL;
(*
The value of the call synthesize(expart,frapart) shall be a value of
the corresponding real number type contructed from the value of
`expart' and `frapart'. This value shall satisfy the relationship
synthesize(exponent(x),fraction(x)) = x.
*)
BEGIN
RETURN scale(frapart, expart)
END synthesize;
PROCEDURE setMode*(m: Modes);
(*
The call setMode(m) shall set status flags from the value of `m',
appropriate to the underlying implementation of the corresponding real
number type.
NOTES
3 -- Many implementations of floating point provide options for
setting flags within the system which control details of the handling
of the type. Although two procedures are provided, one for each real
number type, the effect may be the same. Typical effects that can be
obtained by this means are:
a) Ensuring that overflow will raise an exception;
b) Allowing underflow to raise an exception;
c) Controlling the rounding;
d) Allowing special values to be produced (e.g. NaNs in
implementations conforming to IEC 559:1989 (IEEE 754:1987));
e) Ensuring that special valu access will raise an exception;
Since these effects are so varied, the values of type `Modes' that may
be used are not specified by this International Standard.
4 -- The effects of `setMode' on operation on values of the
corresponding real number type in coroutines other than the calling
coroutine is not defined. Implementations are not require to preserve
the status flags (if any) with the coroutine state.
*)
BEGIN
(* hardware dependent mode setting of coprocessor *)
END setMode;
PROCEDURE currentMode*(): Modes;
(*
The value of the call currentMode() shall be the current status flags
(in the form set by `setMode'), or the default status flags (if
`setMode' is not used).
NOTE 5 -- The value of the call currentMode() is not necessarily the
value of set by `setMode', since a call of `setMode' might attempt to
set flags that cannot be set by the program.
*)
BEGIN
RETURN {}
END currentMode;
PROCEDURE IsLowException*(): BOOLEAN;
(* Returns TRUE if the current coroutine is in the exceptional execution state
because of the raising of the LowReal exception; otherwise returns FALSE.
*)
BEGIN
RETURN FALSE
END IsLowException;
PROCEDURE InitEndian;
VAR endianTest: INTEGER; c: CHAR;
BEGIN
endianTest:=1;
S.GET(S.ADR(endianTest), c);
isBigEndian:=c#1X
END InitEndian;
PROCEDURE Test;
CONST n1=1.234D39; n2=-1.23343D-20; n3=123.456;
VAR n: LONGREAL; exp: INTEGER;
BEGIN
exp:=exponent(n1); exp:=exponent(n2);
n:=fraction(n1); n:=fraction(n2);
n:=scale(ONE, -8); n:=scale(ONE, 8);
n:=succ(10);
n:=intpart(n3);
n:=trunc(n3, 5); (* n=120 *)
n:=trunc(n3, 7); (* n=123 *)
n:=trunc(n3, 12); (* n=123.4375 *)
n:=round(n3, 5); (* n=124 *)
n:=round(n3, 7); (* n=123 *)
n:=round(n3, 12); (* n=123.46875 *)
END Test;
BEGIN
InitEndian; (* check whether target is big endian *)
(*
tmp := power0(10,308); (* this is test to calculate small as a variable at runtime; -- noch *)
sml := 2.2250738585072014/tmp;
sml := 2.2250738585072014/power0(10, 308);
*)
IF DEBUG THEN Test END
END oocLowLReal.

387
src/library/ooc/oocLowReal.Mod Normal file
View file

@ -0,0 +1,387 @@
(* $Id: LowReal.Mod,v 1.5 1999/09/02 13:17:38 acken Exp $ *)
MODULE oocLowReal;
(*
LowReal - Gives access to the underlying properties of the type REAL
for IEEE single-precision numbers.
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 S := SYSTEM, Console;
(*
Real number properties are defined as follows:
radix--The whole number value of the radix used to represent the
corresponding read number values.
places--The whole number value of the number of radix places used
to store values of the corresponding real number type.
expoMin--The whole number value of the exponent minimum.
expoMax--The whole number value of the exponent maximum.
large--The largest value of the corresponding real number type.
small--The smallest positive value of the corresponding real number
type, represented to maximal precision.
IEC559--A Boolean value that is TRUE if and only if the implementation
of the corresponding real number type conforms to IEC 559:1989
(IEEE 754:1987) in all regards.
NOTES
6 -- If `IEC559' is TRUE, the value of `radix' is 2.
7 -- If LowReal.IEC559 is TRUE, the 32-bit format of IEC 559:1989
is used for the type REAL.
7 -- If LowLong.IEC559 is TRUE, the 64-bit format of IEC 559:1989
is used for the type REAL.
LIA1--A Boolean value that is TRUE if and only if the implementation of
the corresponding real number type conforms to ISO/IEC 10967-1:199x
(LIA-1) in all regards: parameters, arithmetic, exceptions, and
notification.
rounds--A Boolean value that is TRUE if and only if each operation produces
a result that is one of the values of the corresponding real number
type nearest to the mathematical result.
gUnderflow--A Boolean value that is TRUE if and only if there are values of
the corresponding real number type between 0.0 and `small'.
exception--A Boolean value that is TRUE if and only if every operation that
attempts to produce a real value out of range raises an exception.
extend--A Boolean value that is TRUE if and only if expressions of the
corresponding real number type are computed to higher precision than
the stored values.
nModes--The whole number value giving the number of bit positions needed for
the status flags for mode control.
*)
CONST
radix*= 2;
places*= 24;
expoMax*= 127;
expoMin*= 1-expoMax;
large*= MAX(REAL);(*3.40282347E+38;*) (* MAX(REAL) *)
(*small*= 1.17549435E-38; (* 2^(-126) *)*)
small* = 1/8.50705917E37; (* don't know better way; -- noch *)
IEC559*= TRUE;
LIA1*= FALSE;
rounds*= FALSE;
gUnderflow*= TRUE; (* there are IEEE numbers smaller than `small' *)
exception*= FALSE; (* at least in the default implementation *)
extend*= FALSE;
nModes*= 0;
TEN=10.0; (* some commonly-used constants *)
ONE=1.0;
ZERO=0.0;
expOffset=expoMax;
hiBit=22;
expBit=hiBit+1;
nMask={0..hiBit,31}; (* number mask *)
expMask={expBit..30}; (* exponent mask *)
TYPE
Modes*= SET;
VAR
(*small* : REAL; tmp: REAL;*) (* this was a test to get small as a variable at runtime. obviously, compile time preferred; -- noch *)
ErrorHandler*: PROCEDURE (errno : INTEGER);
err-: INTEGER;
(* Error handler default stub which can be replaced *)
(* PROCEDURE power0(i, j : INTEGER) : REAL; (* used to calculate sml at runtime; -- noch *)
VAR k : INTEGER;
p : REAL;
BEGIN
k := 1;
p := i;
REPEAT
p := p * i;
INC(k);
UNTIL k=j;
RETURN p;
END power0;*)
PROCEDURE DefaultHandler (errno : INTEGER);
BEGIN
err:=errno
END DefaultHandler;
PROCEDURE ClearError*;
BEGIN
err:=0
END ClearError;
PROCEDURE exponent*(x: REAL): INTEGER;
(*
The value of the call exponent(x) shall be the exponent value of `x'
that lies between `expoMin' and `expoMax'. An exception shall occur
and may be raised if `x' is equal to 0.0.
*)
BEGIN
(* NOTE: x=0.0 should raise exception *)
IF x=ZERO THEN RETURN 0
ELSE RETURN SHORT(S.LSH(S.VAL(LONGINT,x),-expBit) MOD 256)-expOffset
END
END exponent;
PROCEDURE exponent10*(x: REAL): INTEGER;
(*
The value of the call exponent10(x) shall be the base 10 exponent
value of `x'. An exception shall occur and may be raised if `x' is
equal to 0.0.
*)
VAR exp: INTEGER;
BEGIN
exp:=0; x:=ABS(x);
IF x=ZERO THEN RETURN exp END; (* exception could be raised here *)
WHILE x>=TEN DO x:=x/TEN; INC(exp) END;
WHILE (x>ZERO) & (x<1.0) DO x:=x*TEN; DEC(exp) END;
RETURN exp
END exponent10;
PROCEDURE fraction*(x: REAL): REAL;
(*
The value of the call fraction(x) shall be the significand (or
significant) part of `x'. Hence the following relationship shall
hold: x = scale(fraction(x), exponent(x)).
*)
CONST eZero={(hiBit+2)..29};
BEGIN
IF x=ZERO THEN RETURN ZERO
ELSE RETURN S.VAL(REAL,(S.VAL(SET,x)*nMask)+eZero)*2.0 (* set the mantissa's exponent to zero *)
END
END fraction;
PROCEDURE IsInfinity * (real: REAL) : BOOLEAN;
CONST signMask={0..30};
BEGIN
RETURN S.VAL(SET,real)*signMask=expMask
END IsInfinity;
PROCEDURE IsNaN * (real: REAL) : BOOLEAN;
CONST fracMask={0..hiBit};
VAR sreal: SET;
BEGIN
sreal:=S.VAL(SET, real);
RETURN (sreal*expMask=expMask) & (sreal*fracMask#{})
END IsNaN;
PROCEDURE sign*(x: REAL): REAL;
(*
The value of the call sign(x) shall be 1.0 if `x' is greater than 0.0,
or shall be -1.0 if `x' is less than 0.0, or shall be either 1.0 or
-1.0 if `x' is equal to 0.0.
*)
BEGIN
IF x<ZERO THEN RETURN -ONE ELSE RETURN ONE END
END sign;
PROCEDURE scale*(x: REAL; n: INTEGER): REAL;
(*
The value of the call scale(x,n) shall be the value x*radix^n if such
a value exists; otherwise an execption shall occur and may be raised.
*)
VAR exp: LONGINT; lexp: SET;
BEGIN
IF x=ZERO THEN RETURN ZERO END;
exp:= exponent(x)+n; (* new exponent *)
IF exp>expoMax THEN RETURN large*sign(x) (* exception raised here *)
ELSIF exp<expoMin THEN RETURN small*sign(x) (* exception here as well *)
END;
lexp:=S.VAL(SET,S.LSH(exp+expOffset,expBit)); (* shifted exponent bits *)
RETURN S.VAL(REAL,(S.VAL(SET,x)*nMask)+lexp) (* insert new exponent *)
END scale;
PROCEDURE ulp*(x: REAL): REAL;
(*
The value of the call ulp(x) shall be the value of the corresponding
real number type equal to a unit in the last place of `x', if such a
value exists; otherwise an exception shall occur and may be raised.
*)
BEGIN
RETURN scale(ONE, exponent(x)-places+1)
END ulp;
PROCEDURE succ*(x: REAL): REAL;
(*
The value of the call succ(x) shall be the next value of the
corresponding real number type greater than `x', if such a type
exists; otherwise an exception shall occur and may be raised.
*)
BEGIN
RETURN x+ulp(x)*sign(x)
END succ;
PROCEDURE pred*(x: REAL): REAL;
(*
The value of the call pred(x) shall be the next value of the
corresponding real number type less than `x', if such a type exists;
otherwise an exception shall occur and may be raised.
*)
BEGIN
RETURN x-ulp(x)*sign(x)
END pred;
PROCEDURE intpart*(x: REAL): REAL;
(*
The value of the call intpart(x) shall be the integral part of `x'.
For negative values, this shall be -intpart(abs(x)).
*)
VAR loBit: INTEGER;
BEGIN
loBit:=(hiBit+1)-exponent(x);
IF loBit<=0 THEN RETURN x (* no fractional part *)
ELSIF loBit<=hiBit+1 THEN
RETURN S.VAL(REAL,S.VAL(SET,x)*{loBit..31}) (* integer part is extracted *)
ELSE RETURN ZERO (* no whole part *)
END
END intpart;
PROCEDURE fractpart*(x: REAL): REAL;
(*
The value of the call fractpart(x) shall be the fractional part of
`x'. This satifies the relationship fractpart(x)+intpart(x)=x.
*)
BEGIN
RETURN x-intpart(x)
END fractpart;
PROCEDURE trunc*(x: REAL; n: INTEGER): REAL;
(*
The value of the call trunc(x,n) shall be the value of the most
significant `n' places of `x'. An exception shall occur and may be
raised if `n' is less than or equal to zero.
*)
VAR loBit: INTEGER; mask: SET;
BEGIN loBit:=places-n;
IF n<=0 THEN RETURN ZERO (* exception should be raised *)
ELSIF loBit<=0 THEN RETURN x (* nothing was truncated *)
ELSE mask:={loBit..31}; (* truncation bit mask *)
RETURN S.VAL(REAL,S.VAL(SET,x)*mask)
END
END trunc;
PROCEDURE round*(x: REAL; n: INTEGER): REAL;
(*
The value of the call round(x,n) shall be the value of `x' rounded to
the most significant `n' places. An exception shall occur and may be
raised if such a value does not exist, or if `n' is less than or equal
to zero.
*)
VAR loBit: INTEGER; num, mask: SET; r: REAL;
BEGIN loBit:=places-n;
IF n<=0 THEN RETURN ZERO (* exception should be raised *)
ELSIF loBit<=0 THEN RETURN x (* nothing was rounded *)
ELSE mask:={loBit..31}; num:=S.VAL(SET,x); (* truncation bit mask and number as SET *)
x:=S.VAL(REAL,num*mask); (* truncated result *)
IF loBit-1 IN num THEN (* check if result should be rounded *)
r:=scale(ONE,exponent(x)-n+1); (* rounding fraction *)
IF 31 IN num THEN RETURN x-r (* negative rounding toward -infinity *)
ELSE RETURN x+r (* positive rounding toward +infinity *)
END
ELSE RETURN x (* return truncated result *)
END
END
END round;
PROCEDURE synthesize*(expart: INTEGER; frapart: REAL): REAL;
(*
The value of the call synthesize(expart,frapart) shall be a value of
the corresponding real number type contructed from the value of
`expart' and `frapart'. This value shall satisfy the relationship
synthesize(exponent(x),fraction(x)) = x.
*)
BEGIN
RETURN scale(frapart, expart)
END synthesize;
PROCEDURE setMode*(m: Modes);
(*
The call setMode(m) shall set status flags from the value of `m',
appropriate to the underlying implementation of the corresponding real
number type.
NOTES
3 -- Many implementations of floating point provide options for
setting flags within the system which control details of the handling
of the type. Although two procedures are provided, one for each real
number type, the effect may be the same. Typical effects that can be
obtained by this means are:
a) Ensuring that overflow will raise an exception;
b) Allowing underflow to raise an exception;
c) Controlling the rounding;
d) Allowing special values to be produced (e.g. NaNs in
implementations conforming to IEC 559:1989 (IEEE 754:1987));
e) Ensuring that special valu access will raise an exception;
Since these effects are so varied, the values of type `Modes' that may
be used are not specified by this International Standard.
4 -- The effects of `setMode' on operation on values of the
corresponding real number type in coroutines other than the calling
coroutine is not defined. Implementations are not require to preserve
the status flags (if any) with the coroutine state.
*)
BEGIN
(* hardware dependent mode setting of coprocessor *)
END setMode;
PROCEDURE currentMode*(): Modes;
(*
The value of the call currentMode() shall be the current status flags
(in the form set by `setMode'), or the default status flags (if
`setMode' is not used).
NOTE 5 -- The value of the call currentMode() is not necessarily the
value of set by `setMode', since a call of `setMode' might attempt to
set flags that cannot be set by the program.
*)
BEGIN
RETURN {}
END currentMode;
PROCEDURE IsLowException*(): BOOLEAN;
(*
Returns TRUE if the current coroutine is in the exceptional execution state
because of the raising of the LowReal exception; otherwise returns FALSE.
*)
BEGIN
RETURN FALSE
END IsLowException;
BEGIN
(* install the default error handler -- just sets err variable *)
ErrorHandler:=DefaultHandler;
(* tmp := power0(2,126); (* this is test to calculate small as a variable at runtime; -- noch *)
small := sml;
small := 1/power0(2,126);
*)
END oocLowReal.

552
src/library/ooc/oocMsg.Mod Normal file
View file

@ -0,0 +1,552 @@
(* $Id: Msg.Mod,v 1.11 2000/10/09 14:38:06 ooc-devel Exp $ *)
MODULE oocMsg;
(* Framework for messages (creation, expansion, conversion to text).
Copyright (C) 1999, 2000 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.
*)
(**
This module combines several concepts: messages, message attributes,
message contexts, and message lists. This four aspects make this
module a little bit involved, but at the core it is actually very
simple.
The topics attributes and contexts are primarily of interest for
modules that generate messages. They determine the content of the
message, and how it can be translated into readable text. A user will
mostly be in the position of message consumer, and will be handed
filled in message objects. For a user, the typical operation will be
to convert a message into descriptive text (see methods
@oproc{Msg.GetText} and @oproc{Msg.GetLText}).
Message lists are a convenience feature for modules like parsers,
which normally do not abort after a single error message. Usually,
they try to continue their work after an error, looking for more
problems and possibly emitting more error messages.
*)
IMPORT
CharClass := oocCharClass, Strings := oocStrings, IntStr := oocIntStr;
CONST
sizeAttrName* = 128-1;
(**Maximum length of the attribute name for @oproc{InitAttribute},
@oproc{NewIntAttrib}, @oproc{NewStringAttrib}, @oproc{NewLStringAttrib},
or @oproc{NewMsgAttrib}. *)
sizeAttrReplacement* = 16*1024-1;
(**Maximum length of an attribute's replacement text. *)
TYPE (* the basic string and character types used by this module: *)
Char* = CHAR;
String* = ARRAY OF Char;
StringPtr* = POINTER TO String;
LChar* = CHAR;
LString* = ARRAY OF LChar;
LStringPtr* = POINTER TO LString;
Code* = LONGINT;
(**Identifier for a message's content. Together with the message context,
this value uniquely identifies the type of the message. *)
TYPE
Attribute* = POINTER TO AttributeDesc;
AttributeDesc* = RECORD (*[ABSTRACT]*)
(**An attribute is a @samp{(name, value)} tuple, which can be associated
with a message. When a message is tranlated into its readable version
through the @oproc{Msg.GetText} function, the value part is first
converted to some textual representation, and then inserted into the
message's text. Within a message, an attribute is uniquely identified
by its name. *)
nextAttrib-: Attribute;
(**Points to the next attribute in the message's attribute list. *)
name-: StringPtr;
(**The attribute name. Note that it is restricted to @oconst{sizeAttrName}
characters. *)
END;
TYPE
Context* = POINTER TO ContextDesc;
ContextDesc* = RECORD
(**Describes the context under which messages are converted into their
textual representation. Together, a message's context and its code
identify the message type. As a debugging aid, an identification string
can be associated with a context object (see procedure
@oproc{InitContext}). *)
id-: StringPtr;
(**The textual id associated with the context instance. See procedure
@oproc{InitContext}. *)
END;
TYPE
Msg* = POINTER TO MsgDesc;
MsgDesc* = RECORD
(**A message is an object that can be converted to human readable text and
presented to a program's user. Within the OOC library, messages are
used to store errors in the I/O modules, and the XML library uses them
to create an error list when parsing an XML document.
A message's type is uniquely identified by its context and its code.
Using these two attributes, a message can be converted to text. The
text may contain placeholders, which are filled by the textual
representation of attribute values associated with the message. *)
nextMsg-, prevMsg-: Msg;
(**Used by @otype{MsgList}. Initialized to @code{NIL}. *)
code-: Code;
(**The message code. *)
context-: Context;
(**The context in which the message was created. Within a given context,
the message code @ofield{code} uniquely identifies the message type. *)
attribList-: Attribute;
(**The list of attributes associated with the message. They are sorted by
name. *)
END;
TYPE
MsgList* = POINTER TO MsgListDesc;
MsgListDesc* = RECORD
(**A message list is an often used contruct to collect several error messages
that all refer to the same resource. For example within a parser,
multiple messages are collected before aborting processing and presenting
all messages to the user. *)
msgCount-: LONGINT;
(**The number of messages in the list. An empty list has a
@ofield{msgCount} of zero. *)
msgList-, lastMsg: Msg;
(**The error messages in the list. The messages are linked using the
fields @ofield{Msg.nextMsg} and @ofield{Msg.prevMsg}. *)
END;
TYPE (* default implementations for some commonly used message attributes: *)
IntAttribute* = POINTER TO IntAttributeDesc;
IntAttributeDesc = RECORD
(AttributeDesc)
int-: LONGINT;
END;
StringAttribute* = POINTER TO StringAttributeDesc;
StringAttributeDesc = RECORD
(AttributeDesc)
string-: StringPtr;
END;
LStringAttribute* = POINTER TO LStringAttributeDesc;
LStringAttributeDesc = RECORD
(AttributeDesc)
string-: LStringPtr;
END;
MsgAttribute* = POINTER TO MsgAttributeDesc;
MsgAttributeDesc = RECORD
(AttributeDesc)
msg-: Msg;
END;
(* Context
------------------------------------------------------------------------ *)
PROCEDURE InitContext* (context: Context; id: String);
(**The string argument @oparam{id} should describe the message context to the
programmer. It should not appear in output generated for a program's user,
or at least it should not be necessary for a user to interpret ths string to
understand the message. It is a good idea to use the module name of the
context variable for the identifier. If this is not sufficient to identify
the variable, add the variable name to the string. *)
BEGIN
NEW (context. id, Strings.Length (id)+1);
COPY (id, context. id^)
END InitContext;
PROCEDURE (context: Context) GetTemplate* (msg: Msg; VAR templ: LString);
(**Returns a template string for the message @oparam{msg}. The string may
contain attribute references. Instead of the reference @samp{$@{foo@}}, the
procedure @oproc{Msg.GetText} will insert the textual representation of the
attribute with the name @samp{foo}. The special reference
@samp{$@{MSG_CONTEXT@}} is replaced by the value of @ofield{context.id}, and
@samp{$@{MSG_CODE@}} with @ofield{msg.code}.
The default implementation returns this string:
@example
MSG_CONTEXT: $@{MSG_CONTEXT@}
MSG_CODE: $@{MSG_CODE@}
attribute_name: $@{attribute_name@}
@end example
The last line is repeated for every attribute name. The lines are separated
by @oconst{CharClass.eol}.
@precond
@oparam{msg} is not @code{NIL}.
@end precond *)
VAR
attrib: Attribute;
buffer: ARRAY sizeAttrReplacement+1 OF CHAR;
eol : ARRAY 2 OF CHAR;
BEGIN
eol := "|";
(* default implementation: the template contains the context identifier,
the error number, and the full list of attributes *)
COPY ("MSG_CONTEXT: ${MSG_CONTEXT}", templ);
Strings.Append ((*CharClass.eol*)eol, templ);
Strings.Append ("MSG_CODE: ${MSG_CODE}", templ);
Strings.Append ((*CharClass.eol*)eol, templ);
attrib := msg. attribList;
WHILE (attrib # NIL) DO
COPY (attrib. name^, buffer); (* extend to LONGCHAR *)
Strings.Append (buffer, templ);
Strings.Append (": ${", templ);
Strings.Append (buffer, templ);
Strings.Append ("}", templ);
Strings.Append ((*CharClass.eol*)eol, templ); (* CharClass.eol replaced by other symbol because generated C code with end of line symbols inside strings may not be compiled by all C compilers, and causes problems in gcc 4 with default settings. *)
attrib := attrib. nextAttrib
END
END GetTemplate;
(* Attribute Functions
------------------------------------------------------------------------ *)
PROCEDURE InitAttribute* (attr: Attribute; name: String);
(**Initializes attribute object and sets its name. *)
BEGIN
attr. nextAttrib := NIL;
NEW (attr. name, Strings.Length (name)+1);
COPY (name, attr. name^)
END InitAttribute;
PROCEDURE (attr: Attribute) (*[ABSTRACT]*) ReplacementText* (VAR text: LString);
(**Converts attribute value into some textual representation. The length of
the resulting string must not exceed @oconst{sizeAttrReplacement}
characters: @oproc{Msg.GetLText} calls this procedure with a text buffer of
@samp{@oconst{sizeAttrReplacement}+1} bytes. *)
END ReplacementText;
(* Message Functions
------------------------------------------------------------------------ *)
PROCEDURE New* (context: Context; code: Code): Msg;
(**Creates a new message object for the given context, using the specified
message code. The message's attribute list is empty. *)
VAR
msg: Msg;
BEGIN
NEW (msg);
msg. prevMsg := NIL;
msg. nextMsg := NIL;
msg. code := code;
msg. context := context;
msg. attribList := NIL;
RETURN msg
END New;
PROCEDURE (msg: Msg) SetAttribute* (attr: Attribute);
(**Appends an attribute to the message's attribute list. If an attribute of
the same name exists already, it is replaced by the new one.
@precond
@samp{Length(attr.name^)<=sizeAttrName} and @oparam{attr} has not been
attached to any other message.
@end precond *)
PROCEDURE Insert (VAR aList: Attribute; attr: Attribute);
BEGIN
IF (aList = NIL) THEN (* append to list *)
aList := attr
ELSIF (aList. name^ = attr. name^) THEN (* replace element aList *)
attr. nextAttrib := aList. nextAttrib;
aList := attr
ELSIF (aList. name^ > attr.name^) THEN (* insert element before aList *)
attr. nextAttrib := aList;
aList := attr
ELSE (* continue with next element *)
Insert (aList. nextAttrib, attr)
END
END Insert;
BEGIN
Insert (msg. attribList, attr)
END SetAttribute;
PROCEDURE (msg: Msg) GetAttribute* (name: String): Attribute;
(**Returns the attribute @oparam{name} of the message object. If no such
attribute exists, the value @code{NIL} is returned. *)
VAR
a: Attribute;
BEGIN
a := msg. attribList;
WHILE (a # NIL) & (a. name^ # name) DO
a := a. nextAttrib
END;
RETURN a
END GetAttribute;
PROCEDURE (msg: Msg) GetLText* (VAR text: LString);
(**Converts a message into a string. The basic format of the string is
determined by calling @oproc{msg.context.GetTemplate}. Then the attributes
are inserted into the template string: the placeholder string
@samp{$@{foo@}} is replaced with the textual representation of attribute.
@precond
@samp{LEN(@oparam{text}) < 2^15}
@end precond
Note: Behaviour is undefined if replacement text of attribute contains an
attribute reference. *)
VAR
attr: Attribute;
attrName: ARRAY sizeAttrName+4 OF CHAR;
insert: ARRAY sizeAttrReplacement+1 OF CHAR;
found: BOOLEAN;
pos, len: INTEGER;
num: ARRAY 48 OF CHAR;
BEGIN
msg. context. GetTemplate (msg, text);
attr := msg. attribList;
WHILE (attr # NIL) DO
COPY (attr. name^, attrName);
Strings.Insert ("${", 0, attrName);
Strings.Append ("}", attrName);
Strings.FindNext (attrName, text, 0, found, pos);
WHILE found DO
len := Strings.Length (attrName);
Strings.Delete (text, pos, len);
attr. ReplacementText (insert);
Strings.Insert (insert, pos, text);
Strings.FindNext (attrName, text, pos+Strings.Length (insert),
found, pos)
END;
attr := attr. nextAttrib
END;
Strings.FindNext ("${MSG_CONTEXT}", text, 0, found, pos);
IF found THEN
Strings.Delete (text, pos, 14);
COPY (msg. context. id^, insert);
Strings.Insert (insert, pos, text)
END;
Strings.FindNext ("${MSG_CODE}", text, 0, found, pos);
IF found THEN
Strings.Delete (text, pos, 11);
IntStr.IntToStr (msg. code, num);
COPY (num, insert);
Strings.Insert (insert, pos, text)
END
END GetLText;
PROCEDURE (msg: Msg) GetText* (VAR text: String);
(**Like @oproc{Msg.GetLText}, but the message text is truncated to ISO-Latin1
characters. All characters that are not part of ISO-Latin1 are mapped to
question marks @samp{?}. *)
VAR
buffer: ARRAY ASH(2,15)-1 OF LChar;
i: INTEGER;
BEGIN
msg. GetLText (buffer);
i := -1;
REPEAT
INC (i);
IF (buffer[i] <= 0FFX) THEN
text[i] := (*SHORT*) (buffer[i]) (* no need to short *)
ELSE
text[i] := "?"
END
UNTIL (text[i] = 0X)
END GetText;
(* Message List
------------------------------------------------------------------------ *)
PROCEDURE InitMsgList* (l: MsgList);
BEGIN
l. msgCount := 0;
l. msgList := NIL;
l. lastMsg := NIL
END InitMsgList;
PROCEDURE NewMsgList* (): MsgList;
VAR
l: MsgList;
BEGIN
NEW (l);
InitMsgList (l);
RETURN l
END NewMsgList;
PROCEDURE (l: MsgList) Append* (msg: Msg);
(**Appends the message @oparam{msg} to the list @oparam{l}.
@precond
@oparam{msg} is not part of another message list.
@end precond *)
BEGIN
msg. nextMsg := NIL;
IF (l. msgList = NIL) THEN
msg. prevMsg := NIL;
l. msgList := msg
ELSE
msg. prevMsg := l. lastMsg;
l. lastMsg. nextMsg := msg
END;
l. lastMsg := msg;
INC (l. msgCount)
END Append;
PROCEDURE (l: MsgList) AppendList* (source: MsgList);
(**Appends the messages of list @oparam{source} to @oparam{l}. Afterwards,
@oparam{source} is an empty list, and the elements of @oparam{source} can be
found at the end of the list @oparam{l}. *)
BEGIN
IF (source. msgCount # 0) THEN
IF (l. msgCount = 0) THEN
l^ := source^
ELSE (* both `source' and `l' are not empty *)
INC (l. msgCount, source. msgCount);
l. lastMsg. nextMsg := source. msgList;
source. msgList. prevMsg := l. lastMsg;
l. lastMsg := source. lastMsg;
InitMsgList (source)
END
END
END AppendList;
(* Standard Attributes
------------------------------------------------------------------------ *)
PROCEDURE NewIntAttrib* (name: String; value: LONGINT): IntAttribute;
(* pre: Length(name)<=sizeAttrName *)
VAR
attr: IntAttribute;
BEGIN
NEW (attr);
InitAttribute (attr, name);
attr. int := value;
RETURN attr
END NewIntAttrib;
PROCEDURE (msg: Msg) SetIntAttrib* (name: String; value: LONGINT);
(* pre: Length(name)<=sizeAttrName *)
BEGIN
msg. SetAttribute (NewIntAttrib (name, value))
END SetIntAttrib;
PROCEDURE (attr: IntAttribute) ReplacementText* (VAR text: LString);
VAR
num: ARRAY 48 OF CHAR;
BEGIN
IntStr.IntToStr (attr. int, num);
COPY (num, text)
END ReplacementText;
PROCEDURE NewStringAttrib* (name: String; value: StringPtr): StringAttribute;
(* pre: Length(name)<=sizeAttrName *)
VAR
attr: StringAttribute;
BEGIN
NEW (attr);
InitAttribute (attr, name);
attr. string := value;
RETURN attr
END NewStringAttrib;
PROCEDURE (msg: Msg) SetStringAttrib* (name: String; value: StringPtr);
(* pre: Length(name)<=sizeAttrName *)
BEGIN
msg. SetAttribute (NewStringAttrib (name, value))
END SetStringAttrib;
PROCEDURE (attr: StringAttribute) ReplacementText* (VAR text: LString);
BEGIN
COPY (attr. string^, text)
END ReplacementText;
PROCEDURE NewLStringAttrib* (name: String; value: LStringPtr): LStringAttribute;
(* pre: Length(name)<=sizeAttrName *)
VAR
attr: LStringAttribute;
BEGIN
NEW (attr);
InitAttribute (attr, name);
attr. string := value;
RETURN attr
END NewLStringAttrib;
PROCEDURE (msg: Msg) SetLStringAttrib* (name: String; value: LStringPtr);
(* pre: Length(name)<=sizeAttrName *)
BEGIN
msg. SetAttribute (NewLStringAttrib (name, value))
END SetLStringAttrib;
PROCEDURE (attr: LStringAttribute) ReplacementText* (VAR text: LString);
BEGIN
COPY (attr. string^, text)
END ReplacementText;
PROCEDURE NewMsgAttrib* (name: String; value: Msg): MsgAttribute;
(* pre: Length(name)<=sizeAttrName *)
VAR
attr: MsgAttribute;
BEGIN
NEW (attr);
InitAttribute (attr, name);
attr. msg := value;
RETURN attr
END NewMsgAttrib;
PROCEDURE (msg: Msg) SetMsgAttrib* (name: String; value: Msg);
(* pre: Length(name)<=sizeAttrName *)
BEGIN
msg. SetAttribute (NewMsgAttrib (name, value))
END SetMsgAttrib;
PROCEDURE (attr: MsgAttribute) ReplacementText* (VAR text: LString);
BEGIN
attr. msg. GetLText (text)
END ReplacementText;
(* Auxiliary functions
------------------------------------------------------------------------ *)
PROCEDURE GetStringPtr* (str: String): StringPtr;
(**Creates a copy of @oparam{str} on the heap and returns a pointer to it. *)
VAR
s: StringPtr;
BEGIN
NEW (s, Strings.Length (str)+1);
COPY (str, s^);
RETURN s
END GetStringPtr;
PROCEDURE GetLStringPtr* (str: LString): LStringPtr;
(**Creates a copy of @oparam{str} on the heap and returns a pointer to it. *)
VAR
s: LStringPtr;
BEGIN
NEW (s, Strings.Length (str)+1);
COPY (str, s^);
RETURN s
END GetLStringPtr;
END oocMsg.

137
src/library/ooc/oocOakMath.Mod Normal file
View file

@ -0,0 +1,137 @@
(* $Id: OakMath.Mod,v 1.1 1997/02/07 07:45:32 oberon1 Exp $ *)
MODULE oocOakMath;
IMPORT RealMath := oocRealMath;
CONST
pi* = RealMath.pi;
e* = RealMath.exp1;
PROCEDURE sqrt* (x: REAL): REAL;
(* sqrt(x) returns the square root of x, where x must be positive. *)
BEGIN
RETURN RealMath.sqrt (x)
END sqrt;
PROCEDURE power* (x, base: REAL): REAL;
(* power(x, base) returns the x to the power base. *)
BEGIN
RETURN RealMath.power (x, base)
END power;
PROCEDURE exp* (x: REAL): REAL;
(* exp(x) is the exponential of x base e. x must not be so small that this
exponential underflows nor so large that it overflows. *)
BEGIN
RETURN RealMath.exp (x)
END exp;
PROCEDURE ln* (x: REAL): REAL;
(* ln(x) returns the natural logarithm (base e) of x. *)
BEGIN
RETURN RealMath.ln (x)
END ln;
PROCEDURE log* (x, base: REAL): REAL;
(* log(x,base) is the logarithm of x base b. All positive arguments are
allowed. The base b must be positive. *)
BEGIN
RETURN RealMath.log (x, base)
END log;
PROCEDURE round* (x: REAL): REAL;
(* round(x) if fraction part of x is in range 0.0 to 0.5 then the result is
the largest integer not greater than x, otherwise the result is x rounded
up to the next highest whole number. Note that integer values cannot always
be exactly represented in REAL or REAL format. *)
BEGIN
RETURN RealMath.round (x)
END round;
PROCEDURE sin* (x: REAL): REAL;
BEGIN
RETURN RealMath.sin (x)
END sin;
PROCEDURE cos* (x: REAL): REAL;
BEGIN
RETURN RealMath.cos (x)
END cos;
PROCEDURE tan* (x: REAL): REAL;
(* sin, cos, tan(x) returns the sine, cosine or tangent value of x, where x is
in radians. *)
BEGIN
RETURN RealMath.tan (x)
END tan;
PROCEDURE arcsin* (x: REAL): REAL;
BEGIN
RETURN RealMath.arcsin (x)
END arcsin;
PROCEDURE arccos* (x: REAL): REAL;
BEGIN
RETURN RealMath.arccos (x)
END arccos;
PROCEDURE arctan* (x: REAL): REAL;
(* arcsin, arcos, arctan(x) returns the arcsine, arcos, arctan value in radians
of x, where x is in the sine, cosine or tangent value. *)
BEGIN
RETURN RealMath.arctan (x)
END arctan;
PROCEDURE arctan2* (xn, xd: REAL): REAL;
(* arctan2(xn,xd) is the quadrant-correct arc tangent atan(xn/xd). If the
denominator xd is zero, then the numerator xn must not be zero. All
arguments are legal except xn = xd = 0. *)
BEGIN
RETURN RealMath.arctan2 (xn, xd)
END arctan2;
PROCEDURE sinh* (x: REAL): REAL;
(* sinh(x) is the hyperbolic sine of x. The argument x must not be so large
that exp(|x|) overflows. *)
BEGIN
RETURN RealMath.sinh (x)
END sinh;
PROCEDURE cosh* (x: REAL): REAL;
(* cosh(x) is the hyperbolic cosine of x. The argument x must not be so large
that exp(|x|) overflows. *)
BEGIN
RETURN RealMath.cosh (x)
END cosh;
PROCEDURE tanh* (x: REAL): REAL;
(* tanh(x) is the hyperbolic tangent of x. All arguments are legal. *)
BEGIN
RETURN RealMath.tanh (x)
END tanh;
PROCEDURE arcsinh* (x: REAL): REAL;
(* arcsinh(x) is the arc hyperbolic sine of x. All arguments are legal. *)
BEGIN
RETURN RealMath.arcsinh (x)
END arcsinh;
PROCEDURE arccosh* (x: REAL): REAL;
(* arccosh(x) is the arc hyperbolic cosine of x. All arguments greater than
or equal to 1 are legal. *)
BEGIN
RETURN RealMath.arccosh (x)
END arccosh;
PROCEDURE arctanh* (x: REAL): REAL;
(* arctanh(x) is the arc hyperbolic tangent of x. |x| < 1 - sqrt(em), where
em is machine epsilon. Note that |x| must not be so close to 1 that the
result is less accurate than half precision. *)
BEGIN
RETURN RealMath.arctanh (x)
END arctanh;
END oocOakMath.

181
src/library/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.

75
src/library/ooc/oocRandomNumbers.Mod Normal file
View file

@ -0,0 +1,75 @@
(* $Id: RandomNumbers.Mod,v 1.1 1997/02/07 07:45:32 oberon1 Exp $ *)
MODULE oocRandomNumbers;
(*
For details on this algorithm take a look at
Park S.K. and Miller K.W. (1988). Random number generators, good ones are
hard to find. Communications of the ACM, 31, 1192-1201.
*)
CONST
modulo* = 2147483647; (* =2^31-1 *)
VAR
z : LONGINT;
PROCEDURE GetSeed* (VAR seed : LONGINT);
(* Returns the currently used seed value. *)
BEGIN
seed := z
END GetSeed;
PROCEDURE PutSeed* (seed : LONGINT);
(* Set 'seed' as the new seed value. Any values for 'seed' are allowed, but
values beyond the intervall [1..2^31-2] will be mapped into this range. *)
BEGIN
seed := seed MOD modulo;
IF (seed = 0) THEN
z := 1
ELSE
z := seed
END
END PutSeed;
PROCEDURE NextRND;
CONST
a = 16807;
q = 127773; (* m div a *)
r = 2836; (* m mod a *)
VAR
lo, hi, test : LONGINT;
BEGIN
hi := z DIV q;
lo := z MOD q;
test := a * lo - r * hi;
IF (test > 0) THEN
z := test
ELSE
z := test + modulo
END
END NextRND;
PROCEDURE RND* (range : LONGINT) : LONGINT;
(* Calculates a new number. 'range' has to be in the intervall
[1..2^31-2]. Result is a number from 0,1,..,range-1. *)
BEGIN
NextRND;
RETURN z MOD range
END RND;
PROCEDURE Random*() : REAL;
(* Calculates a number x with 0.0 <= x < 1.0. *)
BEGIN
NextRND;
RETURN (z-1)*(1 / (modulo-1))
END Random;
(*
PROCEDURE Randomize*;
BEGIN
PutSeed (Unix.time (Unix.NULL))
END Randomize;
*)
BEGIN
z := 1
END oocRandomNumbers.

389
src/library/ooc/oocRealConv.Mod Normal file
View file

@ -0,0 +1,389 @@
(* $Id: RealConv.Mod,v 1.6 1999/09/02 13:18:59 acken Exp $ *)
MODULE oocRealConv;
(*
RealConv - Low-level REAL/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
Char := oocCharClass, Low := oocLowReal, Str := oocStrings, Conv := oocConvTypes;
CONST
ZERO=0.0;
TEN=10.0;
ExpCh="E";
SigFigs*=7; (* accuracy of REALs *)
DEBUG = FALSE;
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
RS, P, F, E, SE, WE, SR: Conv.ScanState;
PROCEDURE IsSign (ch: CHAR): BOOLEAN;
(* Return TRUE for '+' or '-' *)
BEGIN
RETURN (ch='+')OR(ch='-')
END IsSign;
(* internal state machine procedures *)
PROCEDURE RSState(inputCh: CHAR; VAR chClass: Conv.ScanClass; VAR nextState: Conv.ScanState);
BEGIN
IF Char.IsNumeric(inputCh) THEN chClass:=Conv.valid; nextState:=P
ELSE chClass:=Conv.invalid; nextState:=RS
END
END RSState;
PROCEDURE PState(inputCh: CHAR; VAR chClass: Conv.ScanClass; VAR nextState: Conv.ScanState);
BEGIN
IF Char.IsNumeric(inputCh) THEN chClass:=Conv.valid; nextState:=P
ELSIF inputCh="." THEN chClass:=Conv.valid; nextState:=F
ELSIF inputCh=ExpCh THEN chClass:=Conv.valid; nextState:=E
ELSE chClass:=Conv.terminator; nextState:=NIL
END
END PState;
PROCEDURE FState(inputCh: CHAR; VAR chClass: Conv.ScanClass; VAR nextState: Conv.ScanState);
BEGIN
IF Char.IsNumeric(inputCh) THEN chClass:=Conv.valid; nextState:=F
ELSIF inputCh=ExpCh THEN chClass:=Conv.valid; nextState:=E
ELSE chClass:=Conv.terminator; nextState:=NIL
END
END FState;
PROCEDURE EState(inputCh: CHAR; VAR chClass: Conv.ScanClass; VAR nextState: Conv.ScanState);
BEGIN
IF IsSign(inputCh) THEN chClass:=Conv.valid; nextState:=SE
ELSIF Char.IsNumeric(inputCh) THEN chClass:=Conv.valid; nextState:=WE
ELSE chClass:=Conv.invalid; nextState:=E
END
END EState;
PROCEDURE SEState(inputCh: CHAR; VAR chClass: Conv.ScanClass; VAR nextState: Conv.ScanState);
BEGIN
IF Char.IsNumeric(inputCh) THEN chClass:=Conv.valid; nextState:=WE
ELSE chClass:=Conv.invalid; nextState:=SE
END
END SEState;
PROCEDURE WEState(inputCh: CHAR; VAR chClass: Conv.ScanClass; VAR nextState: Conv.ScanState);
BEGIN
IF Char.IsNumeric(inputCh) THEN chClass:=Conv.valid; nextState:=WE
ELSE chClass:=Conv.terminator; nextState:=NIL
END
END WEState;
PROCEDURE ScanReal*(inputCh: CHAR; VAR chClass: Conv.ScanClass; VAR nextState: Conv.ScanState);
(*
Represents the start state of a finite state scanner for real numbers - assigns
class of inputCh to chClass and a procedure representing the next state to
nextState.
The call of ScanReal(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)
--------- --------- -------- ---------
ScanReal space padding ScanReal
sign valid RSState
decimal digit valid PState
other invalid ScanReal
RSState decimal digit valid PState
other invalid RSState
PState decimal digit valid PState
"." valid FState
"E" valid EState
other terminator --
FState decimal digit valid FState
"E" valid EState
other terminator --
EState sign valid SEState
decimal digit valid WEState
other invalid EState
SEState decimal digit valid WEState
other invalid SEState
WEState decimal digit valid WEState
other terminator --
For examples of how to use ScanReal, refer to FormatReal and
ValueReal below.
*)
BEGIN
IF Char.IsWhiteSpace(inputCh) THEN chClass:=Conv.padding; nextState:=SR
ELSIF IsSign(inputCh) THEN chClass:=Conv.valid; nextState:=RS
ELSIF Char.IsNumeric(inputCh) THEN chClass:=Conv.valid; nextState:=P
ELSE chClass:=Conv.invalid; nextState:=SR
END
END ScanReal;
PROCEDURE FormatReal*(str: ARRAY OF CHAR): ConvResults;
(* Returns the format of the string value for conversion to REAL. *)
VAR
ch: CHAR;
rn: LONGREAL;
len, index, digit, nexp, exp: INTEGER;
state: Conv.ScanState;
inExp, posExp, decExp: BOOLEAN;
prev, class: Conv.ScanClass;
BEGIN
len:=Str.Length(str); index:=0;
class:=Conv.padding; prev:=class;
state:=SR; rn:=0.0; exp:=0; nexp:= 0;
inExp:=FALSE; posExp:=TRUE; decExp:=FALSE;
LOOP
IF index=len THEN EXIT END;
ch:=str[index];
state.p(ch, class, state);
CASE class OF
| Conv.padding: (* nothing to do *)
| Conv.valid:
IF inExp THEN
IF IsSign(ch) THEN posExp:=ch="+"
ELSE (* must be digits *)
digit:=ORD(ch)-ORD("0");
IF posExp THEN exp:=exp*10+digit
ELSE exp:=exp*10-digit
END
END
ELSIF CAP(ch)=ExpCh THEN inExp:=TRUE
ELSIF ch="." THEN decExp:=TRUE
ELSE (* must be a digit *)
rn:=rn*TEN+(ORD(ch)-ORD("0"));
IF decExp THEN DEC(nexp) END;
END
| Conv.invalid, Conv.terminator: EXIT
END;
prev:=class; INC(index)
END;
IF class IN {Conv.invalid, Conv.terminator} THEN
RETURN strWrongFormat
ELSIF prev=Conv.padding THEN
RETURN strEmpty
ELSE
INC(exp, nexp);
IF rn#ZERO THEN
WHILE exp>0 DO
IF (-3.4028235677973366D+38 < rn) &
((rn>=3.4028235677973366D+38) OR
(SHORT(rn)>Low.large/TEN)) THEN RETURN strOutOfRange
ELSE rn:=rn*TEN
END;
DEC(exp)
END;
WHILE exp<0 DO
IF (rn < 3.4028235677973366D+38) &
((rn<=-3.4028235677973366D+38) OR
(SHORT(rn)<Low.small*TEN)) THEN RETURN strOutOfRange
ELSE rn:=rn/TEN
END;
INC(exp)
END
END;
RETURN strAllRight
END
END FormatReal;
PROCEDURE ValueReal*(str: ARRAY OF CHAR): REAL;
(*
Returns the value corresponding to the real number string value str
if str is well-formed; otherwise raises the RealConv exception.
*)
VAR
ch: CHAR;
x: REAL;
rn: LONGREAL;
len, index, digit, nexp, exp: INTEGER;
state: Conv.ScanState;
positive, inExp, posExp, decExp: BOOLEAN;
prev, class: Conv.ScanClass;
BEGIN
len:=Str.Length(str); index:=0;
class:=Conv.padding; prev:=class;
state:=SR; rn:=0.0; exp:=0; nexp:= 0;
positive:=TRUE; inExp:=FALSE; posExp:=TRUE; decExp:=FALSE;
LOOP
IF index=len THEN EXIT END;
ch:=str[index];
state.p(ch, class, state);
CASE class OF
| Conv.padding: (* nothing to do *)
| Conv.valid:
IF inExp THEN
IF IsSign(ch) THEN posExp:=ch="+"
ELSE (* must be digits *)
digit:=ORD(ch)-ORD("0");
IF posExp THEN exp:=exp*10+digit
ELSE exp:=exp*10-digit
END
END
ELSIF CAP(ch)=ExpCh THEN inExp:=TRUE
ELSIF IsSign(ch) THEN positive:=ch="+"
ELSIF ch="." THEN decExp:=TRUE
ELSE (* must be a digit *)
rn:=rn*TEN+(ORD(ch)-ORD("0"));
IF decExp THEN DEC(nexp) END;
END
| Conv.invalid, Conv.terminator: EXIT
END;
prev:=class; INC(index)
END;
IF class IN {Conv.invalid, Conv.terminator} THEN
RETURN ZERO
ELSIF prev=Conv.padding THEN
RETURN ZERO
ELSE
INC(exp, nexp);
IF rn#ZERO THEN
WHILE exp>0 DO rn:=rn*TEN; DEC(exp) END;
WHILE exp<0 DO rn:=rn/TEN; INC(exp) END
END;
x:=SHORT(rn)
END;
IF ~positive THEN x:=-x END;
RETURN x
END ValueReal;
PROCEDURE LengthFloatReal*(real: REAL; sigFigs: INTEGER): INTEGER;
(*
Returns the number of characters in the floating-point string
representation of real with sigFigs significant figures.
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 RealStr.RealToFloat(real,sigFigs,str).
*)
VAR
len, exp: INTEGER;
BEGIN
IF Low.IsNaN(real) THEN RETURN 3
ELSIF Low.IsInfinity(real) THEN
IF real<ZERO THEN RETURN 9 ELSE RETURN 8 END
END;
IF sigFigs=0 THEN sigFigs:=SigFigs END; len:=sigFigs; (* default digits -- if none given *)
IF real<ZERO THEN INC(len); real:=-real END; (* account for the sign *)
exp:=Low.exponent10(real);
IF sigFigs>1 THEN INC(len) END; (* account for the decimal point *)
IF exp>10 THEN INC(len, 4) (* account for the exponent *)
ELSIF exp#0 THEN INC(len, 3)
END;
RETURN len
END LengthFloatReal;
PROCEDURE LengthEngReal*(real: REAL; sigFigs: INTEGER): INTEGER;
(*
Returns the number of characters in the floating-point engineering
string representation of real with sigFigs significant figures.
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 RealStr.RealToEng(real,sigFigs,str).
*)
VAR
len, exp, off: INTEGER;
BEGIN
IF Low.IsNaN(real) THEN RETURN 3
ELSIF Low.IsInfinity(real) THEN
IF real<ZERO THEN RETURN 9 ELSE RETURN 8 END
END;
IF sigFigs=0 THEN sigFigs:=SigFigs END; len:=sigFigs; (* default digits -- if none given *)
IF real<ZERO THEN INC(len); real:=-real END; (* account for the sign *)
exp:=Low.exponent10(real); off:=exp MOD 3; (* account for the exponent *)
IF exp-off>10 THEN INC(len, 4)
ELSIF exp-off#0 THEN INC(len, 3)
END;
IF sigFigs>off+1 THEN INC(len) END; (* account for the decimal point *)
IF off+1-sigFigs>0 THEN INC(len, off+1-sigFigs) END; (* account for extra padding digits *)
RETURN len
END LengthEngReal;
PROCEDURE LengthFixedReal*(real: REAL; place: INTEGER): INTEGER;
(*
Returns the number of characters in the fixed-point string
representation of real rounded to the given place relative
to the decimal point.
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 RealStr.RealToFixed(real,sigFigs,str).
*)
VAR
len, exp: INTEGER; addDecPt: BOOLEAN;
BEGIN
IF Low.IsNaN(real) THEN RETURN 3
ELSIF Low.IsInfinity(real) THEN
IF real<0 THEN RETURN 9 ELSE RETURN 8 END
END;
exp:=Low.exponent10(real); addDecPt:=place>=0;
IF place<0 THEN INC(place, 2) ELSE INC(place) END;
IF exp<0 THEN (* account for digits *)
IF place<=0 THEN len:=1 ELSE len:=place END
ELSE len:=exp+place;
IF 1-place>0 THEN INC(len, 1-place) END
END;
IF real<ZERO THEN INC(len) END; (* account for the sign *)
IF addDecPt THEN INC(len) END; (* account for decimal point *)
RETURN len
END LengthFixedReal;
PROCEDURE IsRConvException*(): BOOLEAN;
(*
Returns TRUE if the current coroutine is in the exceptional
execution state because of the raising of the RealConv exception;
otherwise returns FALSE.
*)
BEGIN
RETURN FALSE
END IsRConvException;
PROCEDURE Test;
VAR f: REAL; res: INTEGER;
BEGIN
f:=MAX(REAL);
f:=ValueReal("3.40282347E+38");
res:=LengthFixedReal(100, 0);
res:=LengthEngReal(100, 0);
res:=LengthFloatReal(100, 0);
res:=LengthFixedReal(-100.123, 0);
res:=LengthEngReal(-100.123, 0);
res:=LengthFloatReal(-100.123, 0);
res:=LengthFixedReal(-1.0E20, 0);
res:=LengthEngReal(-1.0E20, 0);
res:=LengthFloatReal(-1.0E20, 0);
END Test;
BEGIN
NEW(RS); NEW(P); NEW(F); NEW(E); NEW(SE); NEW(WE); NEW(SR);
RS.p:=RSState; P.p:=PState; F.p:=FState; E.p:=EState;
SE.p:=SEState; WE.p:=WEState; SR.p:=ScanReal;
IF DEBUG THEN Test END
END oocRealConv.

609
src/library/ooc/oocRealMath.Mod Normal file
View file

@ -0,0 +1,609 @@
(* $Id: RealMath.Mod,v 1.6 1999/09/02 13:19:17 acken Exp $ *)
MODULE oocRealMath;
(*
RealMath - Target independent mathematical functions for REAL
(IEEE single-precision) numbers.
Numerical approximations are taken from "Software Manual for the
Elementary Functions" by Cody & Waite and "Computer Approximations"
by Hart et al.
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 l := oocLowReal, S := SYSTEM;
CONST
pi* = 3.1415926535897932384626433832795028841972;
exp1* = 2.7182818284590452353602874713526624977572;
ZERO=0.0; ONE=1.0; HALF=0.5; TWO=2.0; (* local constants *)
(* internally-used constants *)
huge=l.large; (* largest number this package accepts *)
miny=ONE/huge; (* smallest number this package accepts *)
sqrtHalf=0.70710678118654752440;
Limit=2.4414062E-4; (* 2**(-MantBits/2) *)
eps=2.9802322E-8; (* 2**(-MantBits-1) *)
piInv=0.31830988618379067154; (* 1/pi *)
piByTwo=1.57079632679489661923132;
piByFour=0.78539816339744830962;
lnv=0.6931610107421875; (* should be exact *)
vbytwo=0.13830277879601902638E-4; (* used in sinh/cosh *)
ln2Inv=1.44269504088896340735992468100189213;
(* error/exception codes *)
NoError*=0; IllegalRoot*=1; IllegalLog*=2; Overflow*=3; IllegalPower*=4; IllegalLogBase*=5;
IllegalTrig*=6; IllegalInvTrig*=7; HypInvTrigClipped*=8; IllegalHypInvTrig*=9;
LossOfAccuracy*=10; Underflow*=11;
VAR
a1: ARRAY 18 OF REAL; (* lookup table for power function *)
a2: ARRAY 9 OF REAL; (* lookup table for power function *)
em: REAL; (* largest number such that 1+epsilon > 1.0 *)
LnInfinity: REAL; (* natural log of infinity *)
LnSmall: REAL; (* natural log of very small number *)
SqrtInfinity: REAL; (* square root of infinity *)
TanhMax: REAL; (* maximum Tanh value *)
t: REAL; (* internal variables *)
(* internally used support routines *)
PROCEDURE SinCos (x, y, sign: REAL): REAL;
CONST
ymax=9099; (* ENTIER(pi*2**(MantBits/2)) *)
r1=-0.1666665668E+0;
r2= 0.8333025139E-2;
r3=-0.1980741872E-3;
r4= 0.2601903036E-5;
VAR
n: LONGINT; xn, f, g: REAL;
BEGIN
IF y>=ymax THEN l.ErrorHandler(LossOfAccuracy); RETURN ZERO END;
(* determine the reduced number *)
n:=ENTIER(y*piInv+HALF); xn:=n;
IF ODD(n) THEN sign:=-sign END;
x:=ABS(x);
IF x#y THEN xn:=xn-HALF END;
(* fractional part of reduced number *)
f:=SHORT(ABS(LONG(x)) - LONG(xn)*pi);
(* Pre: |f| <= pi/2 *)
IF ABS(f)<Limit THEN RETURN sign*f END;
(* evaluate polynomial approximation of sin *)
g:=f*f; g:=(((r4*g+r3)*g+r2)*g+r1)*g;
g:=f+f*g; (* don't use less accurate f(1+g) *)
RETURN sign*g
END SinCos;
PROCEDURE div (x, y : LONGINT) : LONGINT;
(* corrected MOD function *)
BEGIN
IF x < 0 THEN RETURN -ABS(x) DIV y ELSE RETURN x DIV y END
END div;
(* forward declarations *)
PROCEDURE^ arctan2* (xn, xd: REAL): REAL;
PROCEDURE^ sincos* (x: REAL; VAR Sin, Cos: REAL);
PROCEDURE round*(x: REAL): LONGINT;
(* Returns the value of x rounded to the nearest integer *)
BEGIN
IF x<ZERO THEN RETURN -ENTIER(HALF-x)
ELSE RETURN ENTIER(x+HALF)
END
END round;
PROCEDURE sqrt*(x: REAL): REAL;
(* Returns the positive square root of x where x >= 0 *)
CONST
P0=0.41731; P1=0.59016;
VAR
xMant, yEst, z: REAL; xExp: INTEGER;
BEGIN
(* optimize zeros and check for illegal negative roots *)
IF x=ZERO THEN RETURN ZERO END;
IF x<ZERO THEN l.ErrorHandler(IllegalRoot); x:=-x END;
(* reduce the input number to the range 0.5 <= x <= 1.0 *)
xMant:=l.fraction(x)*HALF; xExp:=l.exponent(x)+1;
(* initial estimate of the square root *)
yEst:=P0+P1*xMant;
(* perform two newtonian iterations *)
z:=(yEst+xMant/yEst); yEst:=0.25*z+xMant/z;
(* adjust for odd exponents *)
IF ODD(xExp) THEN yEst:=yEst*sqrtHalf; INC(xExp) END;
(* single Newtonian iteration to produce real number accuracy *)
RETURN l.scale(yEst, xExp DIV 2)
END sqrt;
PROCEDURE exp*(x: REAL): REAL;
(* Returns the exponential of x for x < Ln(MAX(REAL)) *)
CONST
ln2=0.6931471805599453094172321D0;
P0=0.24999999950E+0; P1=0.41602886268E-2; Q1=0.49987178778E-1;
VAR xn, g, p, q, z: REAL; n: LONGINT;
BEGIN
(* Ensure we detect overflows and return 0 for underflows *)
IF x>=LnInfinity THEN l.ErrorHandler(Overflow); RETURN huge
ELSIF x<LnSmall THEN l.ErrorHandler(Underflow); RETURN ZERO
ELSIF ABS(x)<eps THEN RETURN ONE
END;
(* Decompose and scale the number *)
n:=round(ln2Inv*x);
xn:=n; g:=SHORT(LONG(x)-LONG(xn)*ln2);
(* Calculate exp(g)/2 from "Software Manual for the Elementary Functions" *)
z:=g*g; p:=(P1*z+P0)*g; q:=Q1*z+HALF;
RETURN l.scale(HALF+p/(q-p), SHORT(n+1))
END exp;
PROCEDURE ln*(x: REAL): REAL;
(* Returns the natural logarithm of x for x > 0 *)
CONST
c1=355.0/512.0; c2=-2.121944400546905827679E-4;
A0=-0.5527074855E+0; B0=-0.6632718214E+1;
VAR f, zn, zd, r, z, w, xn: REAL; n: INTEGER;
BEGIN
(* ensure illegal inputs are trapped and handled *)
IF x<=ZERO THEN l.ErrorHandler(IllegalLog); RETURN -huge END;
(* reduce the range of the input *)
f:=l.fraction(x)*HALF; n:=l.exponent(x)+1;
IF f>sqrtHalf THEN zn:=(f-HALF)-HALF; zd:=f*HALF+HALF
ELSE zn:=f-HALF; zd:=zn*HALF+HALF; DEC(n)
END;
(* evaluate rational approximation from "Software Manual for the Elementary Functions" *)
z:=zn/zd; w:=z*z; r:=z+z*(w*A0/(w+B0));
(* scale the output *)
xn:=n;
RETURN (xn*c2+r)+xn*c1
END ln;
(* The angle in all trigonometric functions is measured in radians *)
PROCEDURE sin*(x: REAL): REAL;
(* Returns the sine of x for all x *)
BEGIN
IF x<ZERO THEN RETURN SinCos(x, -x, -ONE)
ELSE RETURN SinCos(x, x, ONE)
END
END sin;
PROCEDURE cos*(x: REAL): REAL;
(* Returns the cosine of x for all x *)
BEGIN
RETURN SinCos(x, ABS(x)+piByTwo, ONE)
END cos;
PROCEDURE tan*(x: REAL): REAL;
(* Returns the tangent of x where x cannot be an odd multiple of pi/2 *)
CONST
ymax = 6434; (* ENTIER(2**(MantBits/2)*pi/2) *)
twoByPi = 0.63661977236758134308;
P1=-0.958017723E-1; Q1=-0.429135777E+0; Q2=0.971685835E-2;
VAR
n: LONGINT;
y, xn, f, xnum, xden, g: REAL;
BEGIN
(* check for error limits *)
y:=ABS(x);
IF y>ymax THEN l.ErrorHandler(LossOfAccuracy); RETURN ZERO END;
(* determine n and the fraction f *)
n:=round(x*twoByPi); xn:=n;
f:=SHORT(LONG(x)-LONG(xn)*piByTwo);
(* check for underflow *)
IF ABS(f)<Limit THEN xnum:=f; xden:=ONE
ELSE g:=f*f; xnum:=P1*g*f+f; xden:=(Q2*g+Q1)*g+HALF+HALF
END;
(* find the final result *)
IF ODD(n) THEN RETURN xden/(-xnum)
ELSE RETURN xnum/xden
END
END tan;
PROCEDURE asincos (x: REAL; flag: LONGINT; VAR i: LONGINT; VAR res: REAL);
CONST
P1=0.933935835E+0; P2=-0.504400557E+0;
Q0=0.560363004E+1; Q1=-0.554846723E+1;
VAR
y, g, r: REAL;
BEGIN
y:=ABS(x);
IF y>HALF THEN
i:=1-flag;
IF y>ONE THEN l.ErrorHandler(IllegalInvTrig); res:=huge; RETURN END;
(* reduce the input argument *)
g:=(ONE-y)*HALF; r:=-sqrt(g); y:=r+r;
(* compute approximation *)
r:=((P2*g+P1)*g)/((g+Q1)*g+Q0);
res:=y+(y*r)
ELSE
i:=flag;
IF y<Limit THEN res:=y
ELSE
g:=y*y;
(* compute approximation *)
g:=((P2*g+P1)*g)/((g+Q1)*g+Q0);
res:=y+y*g
END
END
END asincos;
PROCEDURE arcsin*(x: REAL): REAL;
(* Returns the arcsine of x, in the range [-pi/2, pi/2] where -1 <= x <= 1 *)
VAR
res: REAL; i: LONGINT;
BEGIN
asincos(x, 0, i, res);
IF l.err#0 THEN RETURN res END;
(* adjust result for the correct quadrant *)
IF i=1 THEN res:=piByFour+(piByFour+res) END;
IF x<0 THEN res:=-res END;
RETURN res
END arcsin;
PROCEDURE arccos*(x: REAL): REAL;
(* Returns the arccosine of x, in the range [0, pi] where -1 <= x <= 1 *)
VAR
res: REAL; i: LONGINT;
BEGIN
asincos(x, 1, i, res);
IF l.err#0 THEN RETURN res END;
(* adjust result for the correct quadrant *)
IF x<0 THEN
IF i=0 THEN res:=piByTwo+(piByTwo+res)
ELSE res:=piByFour+(piByFour+res)
END
ELSE
IF i=1 THEN res:=piByFour+(piByFour-res)
ELSE res:=-res
END;
END;
RETURN res
END arccos;
PROCEDURE atan(f: REAL): REAL;
(* internal arctan algorithm *)
CONST
rt32=0.26794919243112270647;
rt3=1.73205080756887729353;
a=rt3-ONE;
P0=-0.4708325141E+0; P1=-0.5090958253E-1; Q0=0.1412500740E+1;
piByThree=1.04719755119659774615;
piBySix=0.52359877559829887308;
VAR
n: LONGINT; res, g: REAL;
BEGIN
IF f>ONE THEN f:=ONE/f; n:=2
ELSE n:=0
END;
(* check if f should be scaled *)
IF f>rt32 THEN f:=(((a*f-HALF)-HALF)+f)/(rt3+f); INC(n) END;
(* check for underflow *)
IF ABS(f)<Limit THEN res:=f
ELSE
g:=f*f; res:=(P1*g+P0)*g/(g+Q0); res:=f+f*res
END;
IF n>1 THEN res:=-res END;
CASE n OF
| 1: res:=res+piBySix
| 2: res:=res+piByTwo
| 3: res:=res+piByThree
| ELSE (* do nothing *)
END;
RETURN res
END atan;
PROCEDURE arctan*(x: REAL): REAL;
(* Returns the arctangent of x, in the range [-pi/2, pi/2] for all x *)
BEGIN
IF x<0 THEN RETURN -atan(-x)
ELSE RETURN atan(x)
END
END arctan;
PROCEDURE power*(base, exponent: REAL): REAL;
(* Returns the value of the number base raised to the power exponent
for base > 0 *)
CONST P1=0.83357541E-1; K=0.4426950409;
Q1=0.69314675; Q2=0.24018510; Q3=0.54360383E-1;
OneOver16=0.0625; XMAX=16*(l.expoMax+1)-1; (*XMIN=16*l.expoMin;*) XMIN=-2016; (* to make it easier for voc; -- noch *)
VAR z, g, R, v, u2, u1, w1, w2: REAL; w: LONGREAL;
m, p, i: INTEGER; mp, pp, iw1: LONGINT;
BEGIN
(* handle all possible error conditions *)
IF base<=ZERO THEN
IF base#ZERO THEN l.ErrorHandler(IllegalPower); base:=-base
ELSIF exponent>ZERO THEN RETURN ZERO
ELSE l.ErrorHandler(IllegalPower); RETURN huge
END
END;
(* extract the exponent of base to m and clear exponent of base in g *)
g:=l.fraction(base)*HALF; m:=l.exponent(base)+1;
(* determine p table offset with an unrolled binary search *)
p:=1;
IF g<=a1[9] THEN p:=9 END;
IF g<=a1[p+4] THEN INC(p, 4) END;
IF g<=a1[p+2] THEN INC(p, 2) END;
(* compute scaled z so that |z| <= 0.044 *)
z:=((g-a1[p+1])-a2[(p+1) DIV 2])/(g+a1[p+1]); z:=z+z;
(* approximation for log2(z) from "Software Manual for the Elementary Functions" *)
v:=z*z; R:=P1*v*z; R:=R+K*R; u2:=(R+z*K)+z;
u1:=(m*16-p)*OneOver16; w:=LONG(exponent)*(LONG(u1)+LONG(u2)); (* need extra precision *)
(* calculations below were modified to work properly -- incorrect in cited reference? *)
iw1:=ENTIER(16*w); w1:=iw1*OneOver16; w2:=SHORT(w-w1);
(* check for overflow/underflow *)
IF iw1>XMAX THEN l.ErrorHandler(Overflow); RETURN huge
ELSIF iw1<XMIN THEN l.ErrorHandler(Underflow); RETURN ZERO
END;
(* final approximation 2**w2-1 where -0.0625 <= w2 <= 0 *)
IF w2>ZERO THEN INC(iw1); w2:=w2-OneOver16 END; IF iw1<0 THEN i:=0 ELSE i:=1 END;
mp:=div(iw1, 16)+i; pp:=16*mp-iw1; z:=((Q3*w2+Q2)*w2+Q1)*w2; z:=a1[pp+1]+a1[pp+1]*z;
RETURN l.scale(z, SHORT(mp))
END power;
PROCEDURE IsRMathException*(): BOOLEAN;
(* Returns TRUE if the current coroutine is in the exceptional execution state
because of the raising of the RealMath exception; otherwise returns FALSE.
*)
BEGIN
RETURN FALSE
END IsRMathException;
(*
Following routines are provided as extensions to the ISO standard.
They are either used as the basis of other functions or provide
useful functions which are not part of the ISO standard.
*)
PROCEDURE log* (x, base: REAL): REAL;
(* log(x,base) is the logarithm of x base 'base'. All positive arguments are
allowed but base > 0 and base # 1 *)
BEGIN
(* log(x, base) = ln(x) / ln(base) *)
IF base<=ZERO THEN l.ErrorHandler(IllegalLogBase); RETURN -huge
ELSE RETURN ln(x)/ln(base)
END
END log;
PROCEDURE ipower* (x: REAL; base: INTEGER): REAL;
(* ipower(x, base) returns the x to the integer power base where Log2(x) < expoMax *)
VAR Exp: INTEGER; y: REAL; neg: BOOLEAN;
PROCEDURE Adjust(xadj: REAL): REAL;
BEGIN
IF (x<ZERO)&ODD(base) THEN RETURN -xadj ELSE RETURN xadj END
END Adjust;
BEGIN
(* handle all possible error conditions *)
IF base=0 THEN RETURN ONE (* x**0 = 1 *)
ELSIF ABS(x)<miny THEN
IF base>0 THEN RETURN ZERO ELSE l.ErrorHandler(Overflow); RETURN Adjust(huge) END
END;
(* trap potential overflows and underflows *)
Exp:=(l.exponent(x)+1)*base; y:=LnInfinity*ln2Inv;
IF Exp>y THEN l.ErrorHandler(Overflow); RETURN Adjust(huge)
ELSIF Exp<-y THEN RETURN ZERO
END;
(* compute x**base using an optimised algorithm from Knuth, slightly
altered : p442, The Art Of Computer Programming, Vol 2 *)
y:=ONE; IF base<0 THEN neg:=TRUE; base := -base ELSE neg:= FALSE END;
LOOP
IF ODD(base) THEN y:=y*x END;
base:=base DIV 2; IF base=0 THEN EXIT END;
x:=x*x;
END;
IF neg THEN RETURN ONE/y ELSE RETURN y END
END ipower;
PROCEDURE sincos* (x: REAL; VAR Sin, Cos: REAL);
(* More efficient sin/cos implementation if both values are needed. *)
BEGIN
Sin:=sin(x); Cos:=sqrt(ONE-Sin*Sin)
END sincos;
PROCEDURE arctan2* (xn, xd: REAL): REAL;
(* arctan2(xn,xd) is the quadrant-correct arc tangent atan(xn/xd). If the
denominator xd is zero, then the numerator xn must not be zero. All
arguments are legal except xn = xd = 0. *)
VAR
res: REAL; xpdiff: LONGINT;
BEGIN
(* check for error conditions *)
IF xd=ZERO THEN
IF xn=ZERO THEN l.ErrorHandler(IllegalTrig); RETURN ZERO
ELSIF xn<0 THEN RETURN -piByTwo
ELSE RETURN piByTwo
END;
ELSE
xpdiff:=l.exponent(xn)-l.exponent(xd);
IF ABS(xpdiff)>=l.expoMax-3 THEN
(* overflow detected *)
IF xn<0 THEN RETURN -piByTwo
ELSE RETURN piByTwo
END
ELSE
res:=ABS(xn/xd);
IF res#ZERO THEN res:=atan(res) END;
IF xd<ZERO THEN res:=pi-res END;
IF xn<ZERO THEN RETURN -res
ELSE RETURN res
END
END
END
END arctan2;
PROCEDURE sinh* (x: REAL): REAL;
(* sinh(x) is the hyperbolic sine of x. The argument x must not be so large
that exp(|x|) overflows. *)
CONST P0=-7.13793159; P1=-0.190333399; Q0=-42.8277109;
VAR y, f: REAL;
BEGIN y:=ABS(x);
IF y<=ONE THEN (* handle small arguments *)
IF y<Limit THEN RETURN x END;
(* use approximation from "Software Manual for the Elementary Functions" *)
f:=y*y; y:=f*((f*P1+P0)/(f+Q0)); RETURN x+x*y
ELSIF y>LnInfinity THEN (* handle exp overflows *)
y:=y-lnv;
IF y>LnInfinity-lnv+0.69 THEN l.ErrorHandler(Overflow);
IF x>ZERO THEN RETURN huge ELSE RETURN -huge END
ELSE f:=exp(y); f:=f+f*vbytwo (* don't change to f(1+vbytwo) *)
END
ELSE f:=exp(y); f:=(f-ONE/f)*HALF
END;
(* reach here when 1 < ABS(x) < LnInfinity-lnv+0.69 *)
IF x>ZERO THEN RETURN f ELSE RETURN -f END
END sinh;
PROCEDURE cosh* (x: REAL): REAL;
(* cosh(x) is the hyperbolic cosine of x. The argument x must not be so large
that exp(|x|) overflows. *)
VAR y, f: REAL;
BEGIN y:=ABS(x);
IF y>LnInfinity THEN (* handle exp overflows *)
y:=y-lnv;
IF y>LnInfinity-lnv+0.69 THEN l.ErrorHandler(Overflow);
IF x>ZERO THEN RETURN huge ELSE RETURN -huge END
ELSE f:=exp(y); RETURN f+f*vbytwo (* don't change to f(1+vbytwo) *)
END
ELSE f:=exp(y); RETURN (f+ONE/f)*HALF
END
END cosh;
PROCEDURE tanh* (x: REAL): REAL;
(* tanh(x) is the hyperbolic tangent of x. All arguments are legal. *)
CONST P0=-0.8237728127; P1=-0.3831010665E-2; Q0=2.471319654; ln3over2=0.5493061443;
BIG=9.010913347; (* (ln(2)+(t+1)*ln(B))/2 where t=mantissa bits, B=base *)
VAR f, t: REAL;
BEGIN f:=ABS(x);
IF f>BIG THEN t:=ONE
ELSIF f>ln3over2 THEN t:=ONE-TWO/(exp(TWO*f)+ONE)
ELSIF f<Limit THEN t:=f
ELSE (* approximation from "Software Manual for the Elementary Functions" *)
t:=f*f; t:=t*(P1*t+P0)/(t+Q0); t:=f+f*t
END;
IF x<ZERO THEN RETURN -t ELSE RETURN t END
END tanh;
PROCEDURE arcsinh* (x: REAL): REAL;
(* arcsinh(x) is the arc hyperbolic sine of x. All arguments are legal. *)
BEGIN
IF ABS(x)>SqrtInfinity*HALF THEN l.ErrorHandler(HypInvTrigClipped);
IF x>ZERO THEN RETURN ln(SqrtInfinity) ELSE RETURN -ln(SqrtInfinity) END;
ELSIF x<ZERO THEN RETURN -ln(-x+sqrt(x*x+ONE))
ELSE RETURN ln(x+sqrt(x*x+ONE))
END
END arcsinh;
PROCEDURE arccosh* (x: REAL): REAL;
(* arccosh(x) is the arc hyperbolic cosine of x. All arguments greater than
or equal to 1 are legal. *)
BEGIN
IF x<ONE THEN l.ErrorHandler(IllegalHypInvTrig); RETURN ZERO
ELSIF x>SqrtInfinity*HALF THEN l.ErrorHandler(HypInvTrigClipped); RETURN ln(SqrtInfinity)
ELSE RETURN ln(x+sqrt(x*x-ONE))
END
END arccosh;
PROCEDURE arctanh* (x: REAL): REAL;
(* arctanh(x) is the arc hyperbolic tangent of x. |x| < 1 - sqrt(em), where
em is machine epsilon. Note that |x| must not be so close to 1 that the
result is less accurate than half precision. *)
CONST TanhLimit=0.999984991; (* Tanh(5.9) *)
VAR t: REAL;
BEGIN t:=ABS(x);
IF (t>=ONE) OR (t>(ONE-TWO*em)) THEN l.ErrorHandler(IllegalHypInvTrig);
IF x<ZERO THEN RETURN -TanhMax ELSE RETURN TanhMax END
ELSIF t>TanhLimit THEN l.ErrorHandler(LossOfAccuracy)
END;
RETURN arcsinh(x/sqrt(ONE-x*x))
END arctanh;
BEGIN
(* determine some fundamental constants used by hyperbolic trig functions *)
em:=l.ulp(ONE);
LnInfinity:=ln(huge);
LnSmall:=ln(miny);
SqrtInfinity:=sqrt(huge);
t:=l.pred(ONE)/sqrt(em); TanhMax:=ln(t+sqrt(t*t+ONE));
(* initialize some tables for the power() function a1[i]=2**((1-i)/16) *)
a1[1] :=ONE;
a1[2] :=S.VAL(REAL, 3F75257DH);
a1[3] :=S.VAL(REAL, 3F6AC0C7H);
a1[4] :=S.VAL(REAL, 3F60CCDFH);
a1[5] :=S.VAL(REAL, 3F5744FDH);
a1[6] :=S.VAL(REAL, 3F4E248CH);
a1[7] :=S.VAL(REAL, 3F45672AH);
a1[8] :=S.VAL(REAL, 3F3D08A4H);
a1[9] :=S.VAL(REAL, 3F3504F3H);
a1[10]:=S.VAL(REAL, 3F2D583FH);
a1[11]:=S.VAL(REAL, 3F25FED7H);
a1[12]:=S.VAL(REAL, 3F1EF532H);
a1[13]:=S.VAL(REAL, 3F1837F0H);
a1[14]:=S.VAL(REAL, 3F11C3D3H);
a1[15]:=S.VAL(REAL, 3F0B95C2H);
a1[16]:=S.VAL(REAL, 3F05AAC3H);
a1[17]:=HALF;
(* a2[i]=2**[(1-2i)/16] - a1[2i]; delta resolution *)
a2[1]:=S.VAL(REAL, 31A92436H);
a2[2]:=S.VAL(REAL, 336C2A95H);
a2[3]:=S.VAL(REAL, 31A8FC24H);
a2[4]:=S.VAL(REAL, 331F580CH);
a2[5]:=S.VAL(REAL, 336A42A1H);
a2[6]:=S.VAL(REAL, 32C12342H);
a2[7]:=S.VAL(REAL, 32E75624H);
a2[8]:=S.VAL(REAL, 32CF9890H)
END oocRealMath.

390
src/library/ooc/oocRealStr.Mod Normal file
View file

@ -0,0 +1,390 @@
(* $Id: RealStr.Mod,v 1.7 1999/09/02 13:25:39 acken Exp $ *)
MODULE oocRealStr;
(* RealStr - REAL/string conversions.
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
Low := oocLowReal, Conv := oocConvTypes, RC := oocRealConv, Real := oocLRealMath,
Str := oocStrings;
CONST
ZERO=0.0; FIVE=5.0; TEN=10.0;
DEBUG = FALSE;
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 fixed-point real number is
["+" | "-"] decimal_digit {decimal_digit} ["." {decimal_digit}]
*)
(* the string form of a signed floating-point real number is
signed_fixed-point_real_number ("E" | "e") ["+" | "-"]
decimal_digit {decimal_digit}
*)
PROCEDURE StrToReal*(str: ARRAY OF CHAR; VAR real: REAL; VAR res: ConvResults);
(* Ignores any leading spaces in `str'. If the subsequent characters in `str'
are in the format of a signed real number, and shall assign values to
`res' and `real' as follows:
strAllRight
if the remainder of `str' represents a complete signed real number
in the range of the type of `real' -- the value of this number shall
be assigned to `real';
strOutOfRange
if the remainder of `str' represents a complete signed real number
but its value is out of the range of the type of `real' -- the
maximum or minimum value of the type of `real' shall be assigned to
`real' according to the sign of the number;
strWrongFormat
if there are remaining characters in `str' but these are not in the
form of a complete signed real number -- the value of `real' is not
defined;
strEmpty
if there are no remaining characters in `str' -- the value of `real'
is not defined. *)
BEGIN
res:=RC.FormatReal(str);
IF res IN {strAllRight, strOutOfRange} THEN real:=RC.ValueReal(str) END
END StrToReal;
PROCEDURE AppendDigit(dig: LONGINT; VAR str: ARRAY OF CHAR);
VAR ds: ARRAY 2 OF CHAR;
BEGIN
ds[0]:=CHR(dig+ORD("0")); ds[1]:=0X; Str.Append(ds, str)
END AppendDigit;
PROCEDURE AppendExponent(exp: INTEGER; VAR str: ARRAY OF CHAR);
BEGIN
Str.Append("E", str);
IF exp<0 THEN exp:=-exp; Str.Append("-", str)
ELSE Str.Append("+", str)
END;
IF exp>=10 THEN AppendDigit(exp DIV 10, str) END;
AppendDigit(exp MOD 10, str)
END AppendExponent;
PROCEDURE NextFraction(VAR real: LONGREAL; dec: INTEGER; VAR str: ARRAY OF CHAR);
VAR dig: LONGINT;
BEGIN
dig:=ENTIER(real*Real.ipower(TEN, dec)); AppendDigit(dig, str); real:=real-Real.ipower(TEN, -dec)*dig
END NextFraction;
PROCEDURE AppendFraction(real: LONGREAL; sigFigs, exp, place: INTEGER; VAR str: ARRAY OF CHAR);
VAR digs: INTEGER;
BEGIN
(* write significant digits *)
FOR digs:=0 TO sigFigs-1 DO
IF digs=place THEN Str.Append(".", str) END;
NextFraction(real, digs-exp, str)
END;
(* pad out digits to the decimal position *)
FOR digs:=sigFigs TO place-1 DO Str.Append("0", str) END
END AppendFraction;
PROCEDURE RemoveLeadingZeros(VAR str: ARRAY OF CHAR);
VAR len: LONGINT;
BEGIN
len:=Str.Length(str);
WHILE (len>1)&(str[0]="0")&(str[1]#".") DO Str.Delete(str, 0, 1); DEC(len) END
END RemoveLeadingZeros;
PROCEDURE ExtractExpScale(VAR real: LONGREAL; VAR exp, expoff: INTEGER);
CONST
SCALE=1.0D10;
BEGIN
exp:=Low.exponent10(SHORT(real));
(* adjust number to avoid overflow/underflows *)
IF exp>20 THEN real:=real/SCALE; DEC(exp, 10); expoff:=10
ELSIF exp<-20 THEN real:=real*SCALE; INC(exp, 10); expoff:=-10
ELSE expoff:=0
END
END ExtractExpScale;
PROCEDURE RealToFloat*(real: REAL; sigFigs: INTEGER; VAR str: ARRAY OF CHAR);
(* The call `RealToFloat(real,sigFigs,str)' shall assign to `str' the possibly
truncated string corresponding to the value of `real' in floating-point
form. A sign shall be included only for negative values. One significant
digit shall be included in the whole number part. The signed exponent part
shall be included only if the exponent value is not 0. If the value of
`sigFigs' is greater than 0, that number of significant digits shall be
included, otherwise an implementation-defined number of significant digits
shall be included. The decimal point shall not be included if there are no
significant digits in the fractional part.
For example:
value: 3923009 39.23009 0.0003923009
sigFigs
1 4E+6 4E+1 4E-4
2 3.9E+6 3.9E+1 3.9E-4
5 3.9230E+6 3.9230E+1 3.9230E-4
*)
VAR
x: LONGREAL; expoff, exp: INTEGER; lstr: ARRAY 32 OF CHAR;
BEGIN
(* set significant digits, extract sign & exponent *)
lstr:=""; x:=real;
IF sigFigs<=0 THEN sigFigs:=RC.SigFigs END;
(* check for illegal numbers *)
IF Low.IsNaN(real) THEN COPY("NaN", str); RETURN END;
IF x<ZERO THEN Str.Append("-", lstr); x:=-x END;
IF Low.IsInfinity(real) THEN Str.Append("Infinity", lstr); COPY(lstr, str); RETURN END;
ExtractExpScale(x, exp, expoff);
(* round the number and extract exponent again (ie. 9.9 => 10.0) *)
IF real#ZERO THEN
x:=x+FIVE*Real.ipower(TEN, exp-sigFigs);
exp:=Low.exponent10(SHORT(x))
END;
(* output number like x[.{x}][E+n[n]] *)
AppendFraction(x, sigFigs, exp, 1, lstr);
IF exp#0 THEN AppendExponent(exp+expoff, lstr) END;
(* possibly truncate the result *)
COPY(lstr, str)
END RealToFloat;
PROCEDURE RealToEng*(real: REAL; sigFigs: INTEGER; VAR str: ARRAY OF CHAR);
(* Converts the value of `real' to floating-point string form, with `sigFigs'
significant figures, and copies the possibly truncated result to `str'. The
number is scaled with one to three digits in the whole number part and with
an exponent that is a multiple of three.
For example:
value: 3923009 39.23009 0.0003923009
sigFigs
1 4E+6 40 400E-6
2 3.9E+6 39 390E-6
5 3.9230E+6 39.230 392.30E-6
*)
VAR
x: LONGREAL; exp, expoff, offset: INTEGER; lstr: ARRAY 32 OF CHAR;
BEGIN
(* set significant digits, extract sign & exponent *)
lstr:=""; x:=real;
IF sigFigs<=0 THEN sigFigs:=RC.SigFigs END;
(* check for illegal numbers *)
IF Low.IsNaN(real) THEN COPY("NaN", str); RETURN END;
IF x<ZERO THEN Str.Append("-", lstr); x:=-x END;
IF Low.IsInfinity(real) THEN Str.Append("Infinity", lstr); COPY(lstr, str); RETURN END;
ExtractExpScale(x, exp, expoff);
(* round the number and extract exponent again (ie. 9.9 => 10.0) *)
IF real#ZERO THEN
x:=x+FIVE*Real.ipower(TEN, exp-sigFigs);
exp:=Low.exponent10(SHORT(x))
END;
(* find the offset to make the exponent a multiple of three *)
offset:=(exp+expoff) MOD 3;
(* output number like x[x][x][.{x}][E+n[n]] *)
AppendFraction(x, sigFigs, exp, offset+1, lstr);
exp:=exp-offset+expoff;
IF exp#0 THEN AppendExponent(exp, lstr) END;
(* possibly truncate the result *)
COPY(lstr, str)
END RealToEng;
PROCEDURE RealToFixed*(real: REAL; place: INTEGER; VAR str: ARRAY OF CHAR);
(* The call `RealToFixed(real,place,str)' shall assign to `str' the possibly
truncated string corresponding to the value of `real' in fixed-point form.
A sign shall be included only for negative values. At least one digit shall
be included in the whole number part. The value shall be rounded to the
given value of `place' relative to the decimal point. The decimal point
shall be suppressed if `place' is less than 0.
For example:
value: 3923009 3.923009 0.0003923009
sigFigs
-5 3920000 0 0
-2 3923010 0 0
-1 3923009 4 0
0 3923009. 4. 0.
1 3923009.0 3.9 0.0
4 3923009.0000 3.9230 0.0004
*)
VAR
x: LONGREAL; exp, expoff: INTEGER; addDecPt: BOOLEAN; lstr: ARRAY 256 OF CHAR;
BEGIN
(* set significant digits, extract sign & exponent *)
lstr:=""; addDecPt:=place=0; x:=real;
(* check for illegal numbers *)
IF Low.IsNaN(real) THEN COPY("NaN", str); RETURN END;
IF x<ZERO THEN Str.Append("-", lstr); x:=-x END;
IF Low.IsInfinity(real) THEN Str.Append("Infinity", lstr); COPY(lstr, str); RETURN END;
ExtractExpScale(x, exp, expoff);
(* round the number and extract exponent again (ie. 9.9 => 10.0) *)
IF place<0 THEN INC(place, 2) ELSE INC(place) END;
IF real#ZERO THEN
x:=x+FIVE*Real.ipower(TEN, -place);
exp:=Low.exponent10(SHORT(x))
END;
(* output number like x[{x}][.{x}] *)
INC(place, expoff);
IF exp+expoff<0 THEN
IF place<=0 THEN Str.Append("0", lstr)
ELSE AppendFraction(x, place, 0, 1, lstr)
END
ELSE AppendFraction(x, exp+place, exp, exp+expoff+1, lstr);
RemoveLeadingZeros(lstr)
END;
(* special formatting ?? *)
IF addDecPt THEN Str.Append(".", lstr) END;
(* possibly truncate the result *)
COPY(lstr, str)
END RealToFixed;
PROCEDURE RealToStr*(real: REAL; VAR str: ARRAY OF CHAR);
(* If the sign and magnitude of `real' can be shown within the capacity of
`str', the call RealToStr(real,str) shall behave as the call
`RealToFixed(real,place,str)', with a value of `place' chosen to fill
exactly the remainder of `str'. Otherwise, the call shall behave as
the call `RealToFloat(real,sigFigs,str)', with a value of `sigFigs' of
at least one, but otherwise limited to the number of significant
digits that can be included together with the sign and exponent part
in `str'. *)
VAR
cap, exp, fp, len, pos: INTEGER;
found: BOOLEAN;
BEGIN
cap:=SHORT(LEN(str))-1; (* determine the capacity of the string with space for trailing 0X *)
(* check for illegal numbers *)
IF Low.IsNaN(real) THEN COPY("NaN", str); RETURN END;
IF real<ZERO THEN COPY("-", str); fp:=-1 ELSE COPY("", str); fp:=0 END;
IF Low.IsInfinity(ABS(real)) THEN Str.Append("Infinity", str); RETURN END;
(* extract exponent *)
exp:=Low.exponent10(real);
(* format number *)
INC(fp, RC.SigFigs-exp-2);
len:=RC.LengthFixedReal(real, fp);
IF cap>=len THEN
RealToFixed(real, fp, str);
(* pad with remaining zeros *)
IF fp<0 THEN Str.Append(".", str); INC(len) END; (* add decimal point *)
WHILE len<cap DO Str.Append("0", str); INC(len) END
ELSE
fp:=RC.LengthFloatReal(real, RC.SigFigs); (* check actual length *)
IF fp<=cap THEN
RealToFloat(real, RC.SigFigs, str);
(* pad with remaining zeros *)
Str.FindNext("E", str, 2, found, pos);
WHILE fp<cap DO Str.Insert("0", pos, str); INC(fp) END
ELSE fp:=RC.SigFigs-fp+cap;
IF fp<1 THEN fp:=1 END;
RealToFloat(real, fp, str)
END
END
END RealToStr;
PROCEDURE Test;
CONST n1=3923009.0; n2=39.23009; n3=0.0003923009; n4=3.923009;
VAR str: ARRAY 80 OF CHAR; len: INTEGER;
BEGIN
RealToFloat(MAX(REAL), 9, str);
RealToEng(MAX(REAL), 9, str);
RealToFixed(MAX(REAL), 9, str);
RealToFloat(MIN(REAL), 9, str);
RealToFloat(1.0E10, 9, str);
RealToFloat(0.0, 0, str);
RealToFloat(n1, 0, str);
RealToFloat(n2, 0, str);
RealToFloat(n3, 0, str);
RealToFloat(n4, 0, str);
RealToFloat(n1, 1, str); len:=RC.LengthFloatReal(n1, 1);
RealToFloat(n1, 2, str); len:=RC.LengthFloatReal(n1, 2);
RealToFloat(n1, 5, str); len:=RC.LengthFloatReal(n1, 5);
RealToFloat(n2, 1, str); len:=RC.LengthFloatReal(n2, 1);
RealToFloat(n2, 2, str); len:=RC.LengthFloatReal(n2, 2);
RealToFloat(n2, 5, str); len:=RC.LengthFloatReal(n2, 5);
RealToFloat(n3, 1, str); len:=RC.LengthFloatReal(n3, 1);
RealToFloat(n3, 2, str); len:=RC.LengthFloatReal(n3, 2);
RealToFloat(n3, 5, str); len:=RC.LengthFloatReal(n3, 5);
RealToEng(n1, 1, str); len:=RC.LengthEngReal(n1, 1);
RealToEng(n1, 2, str); len:=RC.LengthEngReal(n1, 2);
RealToEng(n1, 5, str); len:=RC.LengthEngReal(n1, 5);
RealToEng(n2, 1, str); len:=RC.LengthEngReal(n2, 1);
RealToEng(n2, 2, str); len:=RC.LengthEngReal(n2, 2);
RealToEng(n2, 5, str); len:=RC.LengthEngReal(n2, 5);
RealToEng(n3, 1, str); len:=RC.LengthEngReal(n3, 1);
RealToEng(n3, 2, str); len:=RC.LengthEngReal(n3, 2);
RealToEng(n3, 5, str); len:=RC.LengthEngReal(n3, 5);
RealToFixed(n1, -5, str); len:=RC.LengthFixedReal(n1, -5);
RealToFixed(n1, -2, str); len:=RC.LengthFixedReal(n1, -2);
RealToFixed(n1, -1, str); len:=RC.LengthFixedReal(n1, -1);
RealToFixed(n1, 0, str); len:=RC.LengthFixedReal(n1, 0);
RealToFixed(n1, 1, str); len:=RC.LengthFixedReal(n1, 1);
RealToFixed(n1, 4, str); len:=RC.LengthFixedReal(n1, 4);
RealToFixed(n4, -5, str); len:=RC.LengthFixedReal(n4, -5);
RealToFixed(n4, -2, str); len:=RC.LengthFixedReal(n4, -2);
RealToFixed(n4, -1, str); len:=RC.LengthFixedReal(n4, -1);
RealToFixed(n4, 0, str); len:=RC.LengthFixedReal(n4, 0);
RealToFixed(n4, 1, str); len:=RC.LengthFixedReal(n4, 1);
RealToFixed(n4, 4, str); len:=RC.LengthFixedReal(n4, 4);
RealToFixed(n3, -5, str); len:=RC.LengthFixedReal(n3, -5);
RealToFixed(n3, -2, str); len:=RC.LengthFixedReal(n3, -2);
RealToFixed(n3, -1, str); len:=RC.LengthFixedReal(n3, -1);
RealToFixed(n3, 0, str); len:=RC.LengthFixedReal(n3, 0);
RealToFixed(n3, 1, str); len:=RC.LengthFixedReal(n3, 1);
RealToFixed(n3, 4, str); len:=RC.LengthFixedReal(n3, 4);
END Test;
BEGIN
IF DEBUG THEN Test END
END oocRealStr.

78
src/library/ooc/oocRts.Mod Normal file
View file

@ -0,0 +1,78 @@
MODULE oocRts; (* module is written from scratch by noch to wrap around Unix.Mod and Args.Mod and provide compatibility for some ooc libraries *)
IMPORT Args, Unix, Files, Strings := oocStrings(*, Console*);
CONST
pathSeperator* = "/";
VAR i : INTEGER;
b : BOOLEAN;
str0 : ARRAY 128 OF CHAR;
PROCEDURE System* (command : ARRAY OF CHAR) : INTEGER;
(* Executes `command' as a shell command. Result is the value returned by
the libc `system' function. *)
BEGIN
RETURN Unix.System(command)
END System;
PROCEDURE GetEnv* (VAR var: ARRAY OF CHAR; name: ARRAY OF CHAR): BOOLEAN;
(* If an environment variable `name' exists, copy its value into `var' and
return TRUE. Otherwise return FALSE. *)
BEGIN
RETURN Args.getEnv(name, var);
END GetEnv;
PROCEDURE GetUserHome* (VAR home: ARRAY OF CHAR; user: ARRAY OF CHAR);
(* Get the user's home directory path (stored in /etc/passwd)
or the current user's home directory if user="". *)
VAR
f : Files.File;
r : Files.Rider;
str, str1 : ARRAY 1024 OF CHAR;
found, found1 : BOOLEAN;
p, p1, p2 : INTEGER;
BEGIN
f := Files.Old("/etc/passwd");
Files.Set(r, f, 0);
REPEAT
Files.ReadLine(r, str);
(* Console.String(str); Console.Ln;*)
Strings.Extract(str, 0, SHORT(LEN(user)-1), str1);
(* Console.String(str1); Console.Ln;*)
IF Strings.Equal(user, str1) THEN found := TRUE END;
UNTIL found OR r.eof;
IF found THEN
found1 := FALSE;
Strings.FindNext(":", str, SHORT(LEN(user)), found1, p); p2 := p + 1;
Strings.FindNext(":", str, p2, found1, p); p2 := p + 1;
Strings.FindNext(":", str, p2, found1, p); p2 := p + 1;
Strings.FindNext(":", str, p2, found1, p); p2 := p + 1;
Strings.FindNext(":", str, p2, found1, p1);
Strings.Extract(str,p+1,p1-p-1, home);
(*Console.String(home); Console.Ln;*)
ELSE
(* current user's home *)
found1 := GetEnv(home, "HOME");
(*Console.String("not found"); Console.Ln; Console.String (home); Console.Ln;*)
END
END GetUserHome;
BEGIN
(* test *)
(*
i := System("ls");
b := GetEnv(str0, "HOME");
IF b THEN Console.String(str0); Console.Ln END;
GetUserHome(str0, "noch");
*)
END oocRts.

497
src/library/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/library/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.

110
src/library/ooc/oocSysClock.Mod Normal file
View file

@ -0,0 +1,110 @@
MODULE oocSysClock;
IMPORT Unix;
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 CanGetClock*(): BOOLEAN;
(* Returns TRUE if a system clock can be read; FALSE otherwise. *)
VAR timeval: Unix.Timeval; timezone: Unix.Timezone;
l : LONGINT;
BEGIN
l := Unix.Gettimeofday(timeval, timezone);
IF l = 0 THEN RETURN TRUE ELSE RETURN FALSE END
END CanGetClock;
(*
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 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 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. *)
VAR timeval: Unix.Timeval; timezone: Unix.Timezone;
l : LONGINT;
BEGIN
l := Unix.Gettimeofday (timeval, timezone);
IF l = 0 THEN
sec := timeval.sec;
usec := timeval.usec;
ELSE
sec := 0;
usec := 0;
END;
RETURN l;
END GetTimeOfDay;
END oocSysClock.

1620
src/library/ooc/oocTextRider.Mod Normal file
View file

File diff suppressed because it is too large Load diff

205
src/library/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.