From fb38248e595e9a51f1aa00e9063de794080cb418 Mon Sep 17 00:00:00 2001 From: Norayr Chilingarian Date: Mon, 21 Oct 2013 16:53:56 +0400 Subject: [PATCH] added Channel, Msg, RealConv, RealStr --- makefile | 5 +- makefile.gnuc.armv6j | 5 +- makefile.gnuc.armv6j_hardfp | 7 +- makefile.gnuc.armv7a_hardfp | 5 +- makefile.gnuc.x86 | 5 +- makefile.gnuc.x86_64 | 5 +- src/lib/ooc/oocChannel.Mod | 611 ++++++++++++++++++++++++++++++++++++ src/lib/ooc/oocMsg.Mod | 552 ++++++++++++++++++++++++++++++++ src/lib/ooc/oocRealConv.Mod | 389 +++++++++++++++++++++++ src/lib/ooc/oocRealStr.Mod | 390 +++++++++++++++++++++++ 10 files changed, 1967 insertions(+), 7 deletions(-) create mode 100644 src/lib/ooc/oocChannel.Mod create mode 100644 src/lib/ooc/oocMsg.Mod create mode 100644 src/lib/ooc/oocRealConv.Mod create mode 100644 src/lib/ooc/oocRealStr.Mod diff --git a/makefile b/makefile index 1cce6d7a..e93568a9 100644 --- a/makefile +++ b/makefile @@ -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 diff --git a/makefile.gnuc.armv6j b/makefile.gnuc.armv6j index 38132d60..c31e495a 100644 --- a/makefile.gnuc.armv6j +++ b/makefile.gnuc.armv6j @@ -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 diff --git a/makefile.gnuc.armv6j_hardfp b/makefile.gnuc.armv6j_hardfp index 0dbe1b41..e85c25b7 100644 --- a/makefile.gnuc.armv6j_hardfp +++ b/makefile.gnuc.armv6j_hardfp @@ -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 diff --git a/makefile.gnuc.armv7a_hardfp b/makefile.gnuc.armv7a_hardfp index 186d15ee..d5f604d1 100644 --- a/makefile.gnuc.armv7a_hardfp +++ b/makefile.gnuc.armv7a_hardfp @@ -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 diff --git a/makefile.gnuc.x86 b/makefile.gnuc.x86 index f6356fb8..726def8d 100644 --- a/makefile.gnuc.x86 +++ b/makefile.gnuc.x86 @@ -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 diff --git a/makefile.gnuc.x86_64 b/makefile.gnuc.x86_64 index 1cce6d7a..e93568a9 100644 --- a/makefile.gnuc.x86_64 +++ b/makefile.gnuc.x86_64 @@ -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 diff --git a/src/lib/ooc/oocChannel.Mod b/src/lib/ooc/oocChannel.Mod new file mode 100644 index 00000000..aac0b1e7 --- /dev/null +++ b/src/lib/ooc/oocChannel.Mod @@ -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. diff --git a/src/lib/ooc/oocMsg.Mod b/src/lib/ooc/oocMsg.Mod new file mode 100644 index 00000000..9a57829a --- /dev/null +++ b/src/lib/ooc/oocMsg.Mod @@ -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. diff --git a/src/lib/ooc/oocRealConv.Mod b/src/lib/ooc/oocRealConv.Mod new file mode 100644 index 00000000..9eaca9ed --- /dev/null +++ b/src/lib/ooc/oocRealConv.Mod @@ -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)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 real1 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 real10 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=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 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 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 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=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