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

added Channel, Msg, RealConv, RealStr

Browse source 
Former-commit-id: fb38248e59
This commit is contained in:
Norayr Chilingarian 2013-10-21 16:53:56 +04:00
parent cac0ef9a24
commit eebc103f72
10 changed files with 1967 additions and 7 deletions
Download patch file Download diff file Expand all files Collapse all files

5
makefile
View file

@ -135,7 +135,10 @@ stage6:
$(VOCSTATIC) -sP oocLowReal.Mod oocLowLReal.Mod
$(VOCSTATIC) -sP oocRealMath.Mod oocOakMath.Mod
$(VOCSTATIC) -sP oocLRealMath.Mod
$(VOCSTATIC) -sP oocLongInts.Mod oocLRealConv.Mod oocLRealStr.Mod
$(VOCSTATIC) -sP oocLongInts.Mod
$(VOCSTATIC) -sP oocLRealConv.Mod oocLRealStr.Mod
$(VOCSTATIC) -sP oocRealConv.Mod oocRealStr.Mod
$(VOCSTATIC) -sP oocMsg.Mod oocChannel.Mod
$(VOCSTATIC) -sP oocwrapperlibc.Mod
$(VOCSTATIC) -sP ulmSYSTEM.Mod
$(VOCSTATIC) -sP ulmASCII.Mod ulmSets.Mod

5
makefile.gnuc.armv6j
View file

@ -135,7 +135,10 @@ stage6:
$(VOCSTATIC) -sP oocLowReal.Mod oocLowLReal.Mod
$(VOCSTATIC) -sP oocRealMath.Mod oocOakMath.Mod
$(VOCSTATIC) -sP oocLRealMath.Mod
$(VOCSTATIC) -sP oocLongInts.Mod oocLRealConv.Mod oocLRealStr.Mod
$(VOCSTATIC) -sP oocLongInts.Mod
$(VOCSTATIC) -sP oocLRealConv.Mod oocLRealStr.Mod
$(VOCSTATIC) -sP oocRealConv.Mod oocRealStr.Mod
$(VOCSTATIC) -sP oocMsg.Mod oocChannel.Mod
$(VOCSTATIC) -sP oocwrapperlibc.Mod
$(VOCSTATIC) -sP ulmSYSTEM.Mod
$(VOCSTATIC) -sP ulmASCII.Mod ulmSets.Mod

7
makefile.gnuc.armv6j_hardfp
View file

@ -1,7 +1,7 @@
#SHELL := /bin/bash
BUILDID=$(shell date +%Y/%m/%d)
TOS = linux
TARCH = armv6j_hardfp
TARCH = armv6j_hardfp
#TARCH = x86 x86_64 armv6j armv6j_hardfp armv7a_hardfp
CCOMP = gnuc
RELEASE = 1.0
@ -135,7 +135,10 @@ stage6:
$(VOCSTATIC) -sP oocLowReal.Mod oocLowLReal.Mod
$(VOCSTATIC) -sP oocRealMath.Mod oocOakMath.Mod
$(VOCSTATIC) -sP oocLRealMath.Mod
$(VOCSTATIC) -sP oocLongInts.Mod oocLRealConv.Mod oocLRealStr.Mod
$(VOCSTATIC) -sP oocLongInts.Mod
$(VOCSTATIC) -sP oocLRealConv.Mod oocLRealStr.Mod
$(VOCSTATIC) -sP oocRealConv.Mod oocRealStr.Mod
$(VOCSTATIC) -sP oocMsg.Mod oocChannel.Mod
$(VOCSTATIC) -sP oocwrapperlibc.Mod
$(VOCSTATIC) -sP ulmSYSTEM.Mod
$(VOCSTATIC) -sP ulmASCII.Mod ulmSets.Mod

5
makefile.gnuc.armv7a_hardfp
View file

@ -135,7 +135,10 @@ stage6:
$(VOCSTATIC) -sP oocLowReal.Mod oocLowLReal.Mod
$(VOCSTATIC) -sP oocRealMath.Mod oocOakMath.Mod
$(VOCSTATIC) -sP oocLRealMath.Mod
$(VOCSTATIC) -sP oocLongInts.Mod oocLRealConv.Mod oocLRealStr.Mod
$(VOCSTATIC) -sP oocLongInts.Mod
$(VOCSTATIC) -sP oocLRealConv.Mod oocLRealStr.Mod
$(VOCSTATIC) -sP oocRealConv.Mod oocRealStr.Mod
$(VOCSTATIC) -sP oocMsg.Mod oocChannel.Mod
$(VOCSTATIC) -sP oocwrapperlibc.Mod
$(VOCSTATIC) -sP ulmSYSTEM.Mod
$(VOCSTATIC) -sP ulmASCII.Mod ulmSets.Mod

5
makefile.gnuc.x86
View file

@ -135,7 +135,10 @@ stage6:
$(VOCSTATIC) -sP oocLowReal.Mod oocLowLReal.Mod
$(VOCSTATIC) -sP oocRealMath.Mod oocOakMath.Mod
$(VOCSTATIC) -sP oocLRealMath.Mod
$(VOCSTATIC) -sP oocLongInts.Mod oocLRealConv.Mod oocLRealStr.Mod
$(VOCSTATIC) -sP oocLongInts.Mod
$(VOCSTATIC) -sP oocLRealConv.Mod oocLRealStr.Mod
$(VOCSTATIC) -sP oocRealConv.Mod oocRealStr.Mod
$(VOCSTATIC) -sP oocMsg.Mod oocChannel.Mod
$(VOCSTATIC) -sP oocwrapperlibc.Mod
$(VOCSTATIC) -sP ulmSYSTEM.Mod
$(VOCSTATIC) -sP ulmASCII.Mod ulmSets.Mod

5
makefile.gnuc.x86_64
View file

@ -135,7 +135,10 @@ stage6:
$(VOCSTATIC) -sP oocLowReal.Mod oocLowLReal.Mod
$(VOCSTATIC) -sP oocRealMath.Mod oocOakMath.Mod
$(VOCSTATIC) -sP oocLRealMath.Mod
$(VOCSTATIC) -sP oocLongInts.Mod oocLRealConv.Mod oocLRealStr.Mod
$(VOCSTATIC) -sP oocLongInts.Mod
$(VOCSTATIC) -sP oocLRealConv.Mod oocLRealStr.Mod
$(VOCSTATIC) -sP oocRealConv.Mod oocRealStr.Mod
$(VOCSTATIC) -sP oocMsg.Mod oocChannel.Mod
$(VOCSTATIC) -sP oocwrapperlibc.Mod
$(VOCSTATIC) -sP ulmSYSTEM.Mod
$(VOCSTATIC) -sP ulmASCII.Mod ulmSets.Mod

611
src/lib/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.

552
src/lib/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.

389
src/lib/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.

390
src/lib/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.