diff --git a/makefile b/makefile index 4d10be06..7e59a1be 100644 --- a/makefile +++ b/makefile @@ -142,6 +142,7 @@ stage6: $(VOCSTATIC) -sP oocRealConv.Mod oocRealStr.Mod $(VOCSTATIC) -sP oocMsg.Mod oocChannel.Mod $(VOCSTATIC) -sP oocStrings2.Mod oocRts.Mod oocFilenames.Mod + $(VOCSTATIC) -sP oocTextRider.Mod oocBinaryRider.Mod oocJulianDay.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 987a1f67..b984a6d0 100644 --- a/makefile.gnuc.armv6j +++ b/makefile.gnuc.armv6j @@ -142,6 +142,7 @@ stage6: $(VOCSTATIC) -sP oocRealConv.Mod oocRealStr.Mod $(VOCSTATIC) -sP oocMsg.Mod oocChannel.Mod $(VOCSTATIC) -sP oocStrings2.Mod oocRts.Mod oocFilenames.Mod + $(VOCSTATIC) -sP oocTextRider.Mod oocBinaryRider.Mod oocJulianDay.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 7a4b730a..033a1503 100644 --- a/makefile.gnuc.armv6j_hardfp +++ b/makefile.gnuc.armv6j_hardfp @@ -142,6 +142,7 @@ stage6: $(VOCSTATIC) -sP oocRealConv.Mod oocRealStr.Mod $(VOCSTATIC) -sP oocMsg.Mod oocChannel.Mod $(VOCSTATIC) -sP oocStrings2.Mod oocRts.Mod oocFilenames.Mod + $(VOCSTATIC) -sP oocTextRider.Mod oocBinaryRider.Mod oocJulianDay.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 6664890e..39bc13d6 100644 --- a/makefile.gnuc.armv7a_hardfp +++ b/makefile.gnuc.armv7a_hardfp @@ -142,6 +142,7 @@ stage6: $(VOCSTATIC) -sP oocRealConv.Mod oocRealStr.Mod $(VOCSTATIC) -sP oocMsg.Mod oocChannel.Mod $(VOCSTATIC) -sP oocStrings2.Mod oocRts.Mod oocFilenames.Mod + $(VOCSTATIC) -sP oocTextRider.Mod oocBinaryRider.Mod oocJulianDay.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 9f5ccb38..08913545 100644 --- a/makefile.gnuc.x86 +++ b/makefile.gnuc.x86 @@ -142,6 +142,7 @@ stage6: $(VOCSTATIC) -sP oocRealConv.Mod oocRealStr.Mod $(VOCSTATIC) -sP oocMsg.Mod oocChannel.Mod $(VOCSTATIC) -sP oocStrings2.Mod oocRts.Mod oocFilenames.Mod + $(VOCSTATIC) -sP oocTextRider.Mod oocBinaryRider.Mod oocJulianDay.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 4d10be06..7e59a1be 100644 --- a/makefile.gnuc.x86_64 +++ b/makefile.gnuc.x86_64 @@ -142,6 +142,7 @@ stage6: $(VOCSTATIC) -sP oocRealConv.Mod oocRealStr.Mod $(VOCSTATIC) -sP oocMsg.Mod oocChannel.Mod $(VOCSTATIC) -sP oocStrings2.Mod oocRts.Mod oocFilenames.Mod + $(VOCSTATIC) -sP oocTextRider.Mod oocBinaryRider.Mod oocJulianDay.Mod $(VOCSTATIC) -sP oocwrapperlibc.Mod $(VOCSTATIC) -sP ulmSYSTEM.Mod $(VOCSTATIC) -sP ulmASCII.Mod ulmSets.Mod diff --git a/src/lib/ooc/oocBinaryRider.Mod b/src/lib/ooc/oocBinaryRider.Mod new file mode 100644 index 00000000..18fbb904 --- /dev/null +++ b/src/lib/ooc/oocBinaryRider.Mod @@ -0,0 +1,529 @@ +(* $Id: BinaryRider.Mod,v 1.10 1999/10/31 13:49:45 ooc-devel Exp $ *) +MODULE oocBinaryRider (*[OOC_EXTENSIONS]*); + +(* + BinaryRider - Binary-level input/output of Oberon variables. + Copyright (C) 1998, 1999 Michael van Acken + Copyright (C) 1997 Michael Griebling + + This module is free software; you can redistribute it and/or modify + it under the terms of the GNU Lesser General Public License as + published by the Free Software Foundation; either version 2 of the + License, or (at your option) any later version. + + This module is distributed in the hope that it will be useful, + but WITHOUT ANY WARRANTY; without even the implied warranty of + MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the + GNU Lesser General Public License for more details. + + You should have received a copy of the GNU Lesser General Public + License along with this program; if not, write to the Free Software + Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA 02111-1307 USA + +*) + +IMPORT + Strings := oocStrings, Channel := oocChannel, SYSTEM, Msg := oocMsg; + +CONST + (* result codes *) + done* = Channel.done; + invalidFormat* = Channel.invalidFormat; + readAfterEnd* = Channel.readAfterEnd; + + (* possible endian settings *) + nativeEndian* = 0; (* do whatever the host machine uses *) + littleEndian* = 1; (* read/write least significant byte first *) + bigEndian* = 2; (* read/write most significant byte first *) + +TYPE + Reader* = POINTER TO ReaderDesc; + ReaderDesc* = RECORD + res*: Msg.Msg; (* READ-ONLY *) + byteOrder-: SHORTINT; (* endian settings for the reader *) + byteReader-: Channel.Reader; (* only to be used by extensions of Reader *) + base-: Channel.Channel; + END; + + Writer* = POINTER TO WriterDesc; + WriterDesc* = RECORD + res*: Msg.Msg; (* READ-ONLY *) + byteOrder-: SHORTINT; (* endian settings for the writer *) + byteWriter-: Channel.Writer; (* only to be used by extensions of Writer *) + base-: Channel.Channel; + END; + +VAR + systemByteOrder: SHORTINT; (* default CPU endian setting *) + + +TYPE + ErrorContext = POINTER TO ErrorContextDesc; + ErrorContextDesc* = RECORD + (* this record is exported, so that extensions of Channel can access the + error descriptions by extending `ErrorContextDesc' *) + (Channel.ErrorContextDesc) + END; + +VAR + errorContext: ErrorContext; + + +PROCEDURE GetError (code: Msg.Code): Msg.Msg; + BEGIN + RETURN Msg.New (errorContext, code) + END GetError; + + +(* Reader methods + ------------------------------------------------------------------------ *) + +(* The following methods read a value of the given type from the current + position in the BinaryReader. + Iff the value is invalid for its type, 'r.res' is 'invalidFormat' + Iff there aren't enough bytes to satisfy the request, 'r.res' is + 'readAfterEnd'. + *) + +PROCEDURE (r: Reader) Pos* () : LONGINT; + BEGIN + RETURN r.byteReader.Pos() + END Pos; + +PROCEDURE (r: Reader) SetPos* (newPos: LONGINT); + BEGIN + IF (r. res = done) THEN + r.byteReader.SetPos(newPos); + r.res := r.byteReader.res + END + END SetPos; + +PROCEDURE (r: Reader) ClearError*; + BEGIN + r.byteReader.ClearError; + r.res := done + END ClearError; + +PROCEDURE (r: Reader) Available * () : LONGINT; + BEGIN + RETURN r.byteReader.Available() + END Available; + +PROCEDURE (r: Reader) ReadBytes * (VAR x: ARRAY OF SYSTEM.BYTE; + start, n: LONGINT); +(* Read the bytes according to the native machine byte order. *) + BEGIN + IF (r.res = done) THEN + r.byteReader.ReadBytes(x, start, n); + r.res := r.byteReader.res + END + END ReadBytes; + +PROCEDURE (r: Reader) ReadBytesOrdered (VAR x: ARRAY OF SYSTEM.BYTE); +(* Read the bytes according to the Reader byte order setting. *) + VAR i: LONGINT; + BEGIN + IF (r.byteOrder=nativeEndian) OR (r.byteOrder=systemByteOrder) THEN + r.byteReader.ReadBytes(x, 0, LEN(x)) + ELSE (* swap bytes of value *) + FOR i:=LEN(x)-1 TO 0 BY -1 DO r.byteReader.ReadByte(x[i]) END + END + END ReadBytesOrdered; + +PROCEDURE (r: Reader) ReadBool*(VAR bool: BOOLEAN); + VAR byte: SHORTINT; + BEGIN + IF (r.res = done) THEN + r. byteReader. ReadByte (byte); + IF (r. byteReader. res = done) & (byte # 0) & (byte # 1) THEN + r. res := GetError (invalidFormat) + ELSE + r. res := r. byteReader. res + END; + bool := (byte # 0) + END + END ReadBool; + +PROCEDURE (r: Reader) ReadChar* (VAR ch: CHAR); + BEGIN + IF (r.res = done) THEN + r. byteReader.ReadByte (ch); + r.res := r.byteReader.res + END + END ReadChar; + +PROCEDURE (r: Reader) ReadLChar*(VAR ch: CHAR); + BEGIN + IF (r.res = done) THEN + r. ReadBytesOrdered (ch); + r.res := r.byteReader.res + END + END ReadLChar; + +PROCEDURE (r: Reader) ReadString* (VAR s: ARRAY OF CHAR); +(* A string is filled until 0X is encountered, there are no more characters + in the channel or the string is filled. It is always terminated with 0X. + *) + VAR + cnt, len: INTEGER; + BEGIN + IF (r.res = done) THEN + len:=SHORT(LEN(s)-1); cnt:=-1; + REPEAT + INC(cnt); r.ReadChar(s[cnt]) + UNTIL (s[cnt]=0X) OR (r.byteReader.res#done) OR (cnt=len); + IF (r. byteReader. res = done) & (s[cnt] # 0X) THEN + r.byteReader.res := GetError (invalidFormat); + s[cnt]:=0X + ELSE + r.res := r.byteReader.res + END + END + END ReadString; + +PROCEDURE (r: Reader) ReadLString* (VAR s: ARRAY OF CHAR); +(* A string is filled until 0X is encountered, there are no more characters + in the channel or the string is filled. It is always terminated with 0X. + *) + VAR + cnt, len: INTEGER; + BEGIN + IF (r.res = done) THEN + len:=SHORT(LEN(s)-1); cnt:=-1; + REPEAT + INC(cnt); r.ReadLChar(s[cnt]) + UNTIL (s[cnt]=0X) OR (r.byteReader.res#done) OR (cnt=len); + IF (r. byteReader. res = done) & (s[cnt] # 0X) THEN + r.byteReader.res := GetError (invalidFormat); + s[cnt]:=0X + ELSE + r.res := r.byteReader.res + END + END + END ReadLString; + +PROCEDURE (r: Reader) ReadSInt*(VAR sint: SHORTINT); + BEGIN + IF (r.res = done) THEN + r.byteReader.ReadByte(sint); (* SIZE(SYSTEM.BYTE) = SIZE(SHORTINT) *) ; + r.res := r.byteReader.res + END + END ReadSInt; + +PROCEDURE (r: Reader) ReadInt*(VAR int: INTEGER); + BEGIN + IF (r.res = done) THEN + r.ReadBytesOrdered(int); + r.res := r.byteReader.res + END + END ReadInt; + +PROCEDURE (r: Reader) ReadLInt*(VAR lint: LONGINT); +(* see ReadInt *) + BEGIN + IF (r.res = done) THEN + r.ReadBytesOrdered(lint); + r.res := r.byteReader.res + END + END ReadLInt; + +PROCEDURE (r: Reader) ReadNum*(VAR num: LONGINT); +(* Read integers in a compressed and portable format. *) + VAR s: SHORTINT; x: CHAR; y: LONGINT; + BEGIN + s:=0; y:=0; r.ReadChar(x); + WHILE (s < 28) & (x >= 80X) DO + INC(y, ASH(LONG(ORD(x))-128, s)); INC(s, 7); + r.ReadChar(x) + END; + (* Q: (s = 28) OR (x < 80X) *) + IF (x >= 80X) OR (* with s=28 this means we have more than 5 digits *) + (s = 28) & (8X <= x) & (x < 78X) & (* overflow in most sig byte *) + (r. byteReader. res = done) THEN + r. res := GetError (invalidFormat) + ELSE + num:=ASH(SYSTEM.LSH(LONG(ORD(x)), 25), s-25)+y; + r. res := r. byteReader. res + END + END ReadNum; + +PROCEDURE (r: Reader) ReadReal*(VAR real: REAL); +(* see ReadInt *) + BEGIN + IF (r.res = done) THEN + r.ReadBytesOrdered(real); + r.res := r.byteReader.res + END + END ReadReal; + +PROCEDURE (r: Reader) ReadLReal*(VAR lreal: LONGREAL); +(* see ReadInt *) + BEGIN + IF (r.res = done) THEN + r.ReadBytesOrdered(lreal); + r.res := r.byteReader.res + END + END ReadLReal; + +PROCEDURE (r: Reader) ReadSet*(VAR s: SET); + BEGIN + IF (r.res = done) THEN + r.ReadBytesOrdered(s); + r.res := r.byteReader.res + END + END ReadSet; + +PROCEDURE (r: Reader) SetByteOrder* (order: SHORTINT); + BEGIN + ASSERT((order>=nativeEndian) & (order<=bigEndian)); + r.byteOrder:=order + END SetByteOrder; + +(* Writer methods + ------------------------------------------------------------------------ *) + +(* The Write-methods write the value to the underlying channel. It is + possible that only part of the value is written + *) + +PROCEDURE (w: Writer) Pos* () : LONGINT; + BEGIN + RETURN w.byteWriter.Pos() + END Pos; + +PROCEDURE (w: Writer) SetPos* (newPos: LONGINT); + BEGIN + IF (w.res = done) THEN + w.byteWriter.SetPos(newPos); + w.res := w.byteWriter.res + END + END SetPos; + +PROCEDURE (w: Writer) ClearError*; + BEGIN + w.byteWriter.ClearError; + w.res := done + END ClearError; + +PROCEDURE (w: Writer) WriteBytes * (VAR x: ARRAY OF SYSTEM.BYTE; + start, n: LONGINT); +(* Write the bytes according to the native machine byte order. *) + BEGIN + IF (w.res = done) THEN + w.byteWriter.WriteBytes(x, start, n); + w.res := w.byteWriter.res + END + END WriteBytes; + +PROCEDURE (w: Writer) WriteBytesOrdered (VAR x: ARRAY OF SYSTEM.BYTE); +(* Write the bytes according to the Writer byte order setting. *) + VAR i: LONGINT; + BEGIN + IF (w.byteOrder=nativeEndian) OR (w.byteOrder=systemByteOrder) THEN + w.byteWriter.WriteBytes(x, 0, LEN(x)) + ELSE + FOR i:=LEN(x)-1 TO 0 BY -1 DO w.byteWriter.WriteByte(x[i]) END + END + END WriteBytesOrdered; + +PROCEDURE (w: Writer) WriteBool*(bool: BOOLEAN); + BEGIN + IF (w.res = done) THEN + IF bool THEN + w. byteWriter. WriteByte (1) + ELSE + w. byteWriter. WriteByte (0) + END; + w. res := w. byteWriter. res + END + END WriteBool; + +PROCEDURE (w: Writer) WriteChar*(ch: CHAR); + BEGIN + IF (w.res = done) THEN + w. byteWriter. WriteByte(ch); + w.res := w.byteWriter.res + END + END WriteChar; + +PROCEDURE (w: Writer) WriteLChar*(ch: CHAR); + BEGIN + IF (w.res = done) THEN + w. WriteBytesOrdered (ch); + w.res := w.byteWriter.res + END + END WriteLChar; + +PROCEDURE (w: Writer) WriteString*(s(*[NO_COPY]*): ARRAY OF CHAR); +(* The terminating 0X is also written *) + BEGIN + IF (w.res = done) THEN + w.byteWriter.WriteBytes (s, 0, Strings.Length (s)+1); + w.res := w.byteWriter.res + END + END WriteString; + +PROCEDURE (w: Writer) WriteLString*(s(*[NO_COPY]*): ARRAY OF CHAR); +(* The terminating 0X is also written *) + VAR + i: LONGINT; + BEGIN + IF (w.res = done) THEN + i := -1; + REPEAT + INC (i); + w. WriteLChar (s[i]) + UNTIL (s[i] = 0X); + w.res := w.byteWriter.res + END + END WriteLString; + +PROCEDURE (w: Writer) WriteSInt*(sint: SHORTINT); + BEGIN + IF (w.res = done) THEN + w.byteWriter.WriteByte(sint); + w.res := w.byteWriter.res + END + END WriteSInt; + +PROCEDURE (w: Writer) WriteInt*(int: INTEGER); + BEGIN + IF (w.res = done) THEN + w.WriteBytesOrdered(int); + w.res := w.byteWriter.res + END + END WriteInt; + +PROCEDURE (w: Writer) WriteLInt*(lint: LONGINT); +(* see WriteInt *) + BEGIN + IF (w.res = done) THEN + w.WriteBytesOrdered(lint); + w.res := w.byteWriter.res + END + END WriteLInt; + +PROCEDURE (w: Writer) WriteNum*(lint: LONGINT); +(* Write integers in a compressed and portable format. *) + BEGIN + IF (w.res = done) THEN + WHILE (lint<-64) OR (lint>63) DO + w.WriteChar(CHR(lint MOD 128+128)); + lint:=lint DIV 128 + END; + w.WriteChar(CHR(lint MOD 128)); + w.res := w.byteWriter.res + END + END WriteNum; + +(* see WriteInt *) +PROCEDURE (w: Writer) WriteReal*(real: REAL); + BEGIN + IF (w.res = done) THEN + w.WriteBytesOrdered(real); + w.res := w.byteWriter.res + END + END WriteReal; + +PROCEDURE (w: Writer) WriteLReal*(lreal: LONGREAL); +(* see WriteInt *) + BEGIN + IF (w.res = done) THEN + w.WriteBytesOrdered(lreal); + w.res := w.byteWriter.res + END + END WriteLReal; + +PROCEDURE (w: Writer) WriteSet*(s: SET); + BEGIN + IF (w.res = done) THEN + w.WriteBytesOrdered(s); + w.res := w.byteWriter.res + END + END WriteSet; + +PROCEDURE (w: Writer) SetByteOrder* (order: SHORTINT); + BEGIN + ASSERT((order>=nativeEndian) & (order<=bigEndian)); + w.byteOrder:=order + END SetByteOrder; + +(* Reader Procedures + ------------------------------------------------------------------------ *) + +(* Create a new Reader and attach it to the Channel ch. NIL is + returned when it is not possible to read from the channel. + The Reader is positioned at the beginning for positionable + channels and at the current position for non-positionable channels. + *) + +PROCEDURE InitReader* (r: Reader; ch: Channel.Channel; byteOrder: SHORTINT); + BEGIN + r. res := done; + r. byteReader := ch. NewReader(); + r. byteOrder := byteOrder; + r. base := ch; + END InitReader; + +PROCEDURE ConnectReader*(ch: Channel.Channel): Reader; + VAR + r: Reader; + BEGIN + NEW (r); + InitReader (r, ch, littleEndian); + IF (r. byteReader = NIL) THEN + RETURN NIL + ELSE + RETURN r + END + END ConnectReader; + +(* Writer Procedures + ------------------------------------------------------------------------ *) + +(* Create a new Writer and attach it to the Channel ch. NIL is + returned when it is not possible to write to the channel. + The Writer is positioned at the beginning for positionable + channels and at the current position for non-positionable channels. + *) +PROCEDURE InitWriter* (w: Writer; ch: Channel.Channel; byteOrder: SHORTINT); + BEGIN + w. res := done; + w. byteWriter := ch. NewWriter(); + w. byteOrder := byteOrder; + w. base := ch; + END InitWriter; + +PROCEDURE ConnectWriter*(ch: Channel.Channel): Writer; + VAR + w: Writer; + BEGIN + NEW (w); + InitWriter (w, ch, littleEndian); + IF (w. byteWriter = NIL) THEN + RETURN NIL + ELSE + RETURN w + END + END ConnectWriter; + +PROCEDURE SetDefaultByteOrder(VAR x: ARRAY OF SYSTEM.BYTE); + BEGIN + IF SYSTEM.VAL(CHAR, x[0])=1X THEN + systemByteOrder:=littleEndian + ELSE + systemByteOrder:=bigEndian + END + END SetDefaultByteOrder; + +PROCEDURE Init; + VAR i: INTEGER; + BEGIN + i:=1; SetDefaultByteOrder(i) + END Init; + +BEGIN + NEW (errorContext); + Msg.InitContext (errorContext, "OOC:Core:BinaryRider"); + Init +END oocBinaryRider. diff --git a/src/lib/ooc/oocJulianDay.Mod b/src/lib/ooc/oocJulianDay.Mod new file mode 100644 index 00000000..6670bfe7 --- /dev/null +++ b/src/lib/ooc/oocJulianDay.Mod @@ -0,0 +1,132 @@ +(* $Id: JulianDay.Mod,v 1.4 1999/09/02 13:08:31 acken Exp $ *) +MODULE oocJulianDay; + +(* + JulianDay - convert to/from day/month/year and modified Julian days. + Copyright (C) 1996 Michael Griebling + + This module is free software; you can redistribute it and/or modify + it under the terms of the GNU Lesser General Public License as + published by the Free Software Foundation; either version 2 of the + License, or (at your option) any later version. + + This module is distributed in the hope that it will be useful, + but WITHOUT ANY WARRANTY; without even the implied warranty of + MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the + GNU Lesser General Public License for more details. + + You should have received a copy of the GNU Lesser General Public + License along with this program; if not, write to the Free Software + Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA 02111-1307 USA + +*) + +CONST + daysPerYear = 365.25D0; (* used in Julian date calculations *) + daysPerMonth = 30.6001D0; + startMJD* = 2400000.5D0; (* zero basis for modified Julian Day in Julian days *) + startTJD* = startMJD+40000.0D0; (* zero basis for truncated modified Julian Day *) + +VAR + UseGregorian-: BOOLEAN; (* TRUE when Gregorian calendar is in use *) + startGregor: LONGREAL; (* start of the Gregorian calendar in Julian days *) + + +(* ------------------------------------------------------------- *) +(* Conversion functions *) + +PROCEDURE DateToJD * (day, month: SHORTINT; year: INTEGER) : LONGREAL; +(* Returns a Julian date in days for the given `day', `month', + and `year' at 0000 UTC. Any date with a positive year is valid. + Algorithm by William H. Jefferys (with some modifications) at: + http://quasar.as.utexas.edu/BillInfo/JulianDatesG.html *) +VAR + A, B, C: LONGINT; JD: LONGREAL; +BEGIN + IF month<3 THEN DEC(year); INC(month, 12) END; + IF UseGregorian THEN A:=year DIV 100; B:=A DIV 4; C:=2-A+B + ELSE C:=0 + END; + JD:=C+day+ENTIER(daysPerYear*(year+4716))+ENTIER(daysPerMonth*(month+1))-1524.5D0; + IF UseGregorian & (JD>=startGregor) THEN RETURN JD + ELSE RETURN JD-C + END +END DateToJD; + +PROCEDURE DateToDays * (day, month: SHORTINT; year: INTEGER) : LONGINT; +(* Returns a modified Julian date in days for the given `day', `month', + and `year' at 0000 UTC. Any date with a positive year is valid. + The returned value is the number of days since 17 November 1858. *) +BEGIN + RETURN ENTIER(DateToJD(day, month, year)-startMJD) +END DateToDays; + +PROCEDURE DateToTJD * (day, month: SHORTINT; year: INTEGER) : LONGINT; +(* Returns a truncated modified Julian date in days for the given `day', + `month', and `year' at 0000 UTC. Any date with a positive year is + valid. The returned value is the *) +BEGIN + RETURN ENTIER(DateToJD(day, month, year)-startTJD) +END DateToTJD; + +PROCEDURE JDToDate * (jd: LONGREAL; VAR day, month: SHORTINT; VAR year: INTEGER); +(* Converts a Julian date in days to a date given by the `day', `month', and + `year'. Algorithm by William H. Jefferys (with some modifications) at + http://quasar.as.utexas.edu/BillInfo/JulianDatesG.html *) +VAR + W, D, B: LONGINT; +BEGIN + jd:=jd+0.5; + IF UseGregorian & (jd>=startGregor) THEN + W:=ENTIER((jd-1867216.25D0)/36524.25D0); + B:=ENTIER(jd+1525+W-ENTIER(W/4.0D0)) + ELSE B:=ENTIER(jd+1524) + END; + year:=SHORT(ENTIER((B-122.1D0)/daysPerYear)); + D:=ENTIER(daysPerYear*year); + month:=SHORT(SHORT(ENTIER((B-D)/daysPerMonth))); + day:=SHORT(SHORT(B-D-ENTIER(daysPerMonth*month))); + IF month>13 THEN DEC(month, 13) ELSE DEC(month) END; + IF month<3 THEN DEC(year, 4715) ELSE DEC(year, 4716) END +END JDToDate; + +PROCEDURE DaysToDate * (jd: LONGINT; VAR day, month: SHORTINT; VAR year: INTEGER); +(* Converts a modified Julian date in days to a date given by the `day', + `month', and `year'. *) +BEGIN + JDToDate(jd+startMJD, day, month, year) +END DaysToDate; + +PROCEDURE TJDToDate * (jd: LONGINT; VAR day, month: SHORTINT; VAR year: INTEGER); +(* Converts a truncated modified Julian date in days to a date given by the `day', + `month', and `year'. *) +BEGIN + JDToDate(jd+startTJD, day, month, year) +END TJDToDate; + +PROCEDURE SetGregorianStart * (day, month: SHORTINT; year: INTEGER); +(* Sets the start date when the Gregorian calendar was first used + where the date in `d' is in the Julian calendar. The default + date used is 3 Sep 1752 (when the calendar correction occurred + according to the Julian calendar). + + The Gregorian calendar was introduced in 4 Oct 1582 by Pope + Gregory XIII but was not adopted by many Protestant countries + until 2 Sep 1752. In all cases, to make up for an inaccuracy + in the calendar, 10 days were skipped during adoption of the + new calendar. *) +VAR + gFlag: BOOLEAN; +BEGIN + gFlag:=UseGregorian; UseGregorian:=FALSE; (* use Julian calendar *) + startGregor:=DateToJD(day, month, year); + UseGregorian:=gFlag (* back to default *) +END SetGregorianStart; + +BEGIN + (* by default we use the Gregorian calendar *) + UseGregorian:=TRUE; startGregor:=0; + + (* Gregorian calendar default start date *) + SetGregorianStart(3, 9, 1752) +END oocJulianDay. diff --git a/src/lib/ooc/oocTextRider.Mod b/src/lib/ooc/oocTextRider.Mod new file mode 100644 index 00000000..464b9665 --- /dev/null +++ b/src/lib/ooc/oocTextRider.Mod @@ -0,0 +1,1620 @@ +(* $Id: TextRider.Mod,v 1.29 2001/07/15 15:51:16 ooc-devel Exp $ *) +MODULE oocTextRider; + +(* + TextRider - Text-based input/output of Oberon variables. + Copyright (C) 1998, 1999 Michael van Acken + Copyright (C) 1997 Michael Griebling + + This module is free software; you can redistribute it and/or modify + it under the terms of the GNU Lesser General Public License as + published by the Free Software Foundation; either version 2 of the + License, or (at your option) any later version. + + This module is distributed in the hope that it will be useful, + but WITHOUT ANY WARRANTY; without even the implied warranty of + MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the + GNU Lesser General Public License for more details. + + You should have received a copy of the GNU Lesser General Public + License along with this program; if not, write to the Free Software + Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA 02111-1307 USA + +*) + +IMPORT + Ascii := oocAscii, Channel := oocChannel, CharClass := oocCharClass, Strings := oocStrings, LRealStr := oocLRealStr, RealStr := oocRealStr, IntStr := oocIntStr, LRealConv := oocLRealConv, ConvTypes := oocConvTypes, Msg := oocMsg; + +CONST + done* = Channel.done; + invalidFormat* = Channel.invalidFormat; + valueOutOfRange* = 1; + + (* Scanner types *) + undefined*=-1; + char*=0; string*=1; int*=2; real*=3; bool*=4; set*=5; + tab*=6; line*=7; ident*=8; error*=9; invalid*=10; + + (* Writer options *) + noBuffering*=0; (* when set output is not buffered. This allows + interactive output prompts to appear as soon as + they are written *) + + (* Reader/Scanner options *) + returnCtrlChars*=0; (* when set returns EOL & TAB characters; otherwise + they are treated like whitespace *) + + (* additional Scanner options *) + interpretBools*=1; (* when set returns truth values of the strings "TRUE" + and "FALSE"; otherwise returns the strings *) + interpretSets*=2; (* when set returns a set value of the string set + representation; otherwise returns the brace and + comma characters, and the numbers individually *) + interpretStrings*=3; (* when set returns a complete string contained + within open and closing quotes; otherwise returns + the quote characters and string contents as + separate tokens. *) + useSignedNumbers*=4; (* when set returns a complete signed number; + otherwise returns the sign characters and the + number tokens separately. *) + + defReaderOptions* = {}; + defWriterOptions* = {}; + defScannerOptions* = defReaderOptions + {interpretBools..useSignedNumbers}; + +CONST + maxLengthEol* = 2; (* system dependent, >= 2 *) + maxLookahead = 2; (* must be >= maxLengthEol and >=2 *) + +TYPE + Reader* = POINTER TO ReaderDesc; + ReaderDesc* = RECORD + res*: Msg.Msg; (* READ-ONLY *) + opt-: SET; (* current reader options (see above) *) + byteReader-: Channel.Reader;(* only to be used by extensions of Reader *) + base-: Channel.Channel; + + (* the end of line marker may contain the character 0X, which means its + length must be stored in a separate field; the eol marker cannot be + empty, and it is required to contain control characters with an + ASCII code in 00X..1FX *) + eol-: ARRAY maxLengthEol OF CHAR; + (* character sequence of end of line marker; all chars < 20X *) + eolLen-: INTEGER; + (* number of characters in `eol'; -1 means auto detect (the default) *) + deferredEol: BOOLEAN; (* TRUE iff eol detection is progress *) + + (* la: small buffer of characters, used to "peek" to the following + characters in the input stream; managed as a FIFO + laRes: result `res' of read operation for corresponding character of + `lookahead' + laLen: number of characters in the lookahead FIFO + invariant: 0 <= laLen < maxLookahead *) + la: ARRAY maxLookahead OF CHAR; + laRes: ARRAY maxLookahead OF Msg.Msg; + laLen: INTEGER; + END; + + Writer* = POINTER TO WriterDesc; + WriterDesc* = RECORD + res*: Msg.Msg; (* READ-ONLY *) + opt-: SET; (* current writer options (see above) *) + byteWriter-: Channel.Writer;(* only to be used by extensions of Writer *) + base-: Channel.Channel; + + eol: ARRAY maxLengthEol OF CHAR; + (* character sequence of end of line marker *) + eolLen: INTEGER; (* number of characters in `eol' *) + END; + + String* = ARRAY 256 OF CHAR; + Scanner* = POINTER TO ScannerDesc; + ScannerDesc* = RECORD + res*: Msg.Msg; (* READ-ONLY *) + r-: Reader; (* attached reader; exported only for extensions of Scanner *) + base-: Channel.Channel; + opt-: SET; (* current scanner options (see above) *) + type-: INTEGER; (* scanned token type (see above) *) + pos-: LONGINT; (* position of current token in the channel *) + lines-: LONGINT; (* total of scanner eol markers; starts at 0 *) + int-: LONGINT; (* integer from channel *) + real-: LONGREAL; (* real from channel *) + char-: CHAR; (* char from channel *) + string-: String; (* string from channel *) + set-: SET; (* set from channel *) + bool-: BOOLEAN; (* boolean from channel *) + END; + + + +(* +> > Btw: I did _not_ fix the potential string buffer overruns in ReadLReal +> > and Scanner.ReadNum. +> +> What should we do about this? Make it POINTER TO ARRAY OF CHAR? Or ADT +> Lib's dynamic String type? + +IMO, the correct way to do this is to have the procedures accept +strings of arbitrary length, and return the nearest LONGREAL value in +any case. The trick is to discard stuff like leading zeroes, cutoff +digits beyond the maximum number of significant digits, and to detect +overflows just by counting digits. With these techniques and +MAX(LONGREAL) < 2E308, one could store any valid read number in a +buffer of 330 characters, and detect overflows and underflows for +longer real strings "by hand". I implemented something similar for +integers, but it is a little bit more complex for reals. Right now I +only signal "valueOutOfRange" if the real string is longer than 1023 +characters, although I do scan to the end of the number before +reporting this. +*) + + + +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): Msg.Msg; + BEGIN + RETURN Msg.New (errorContext, code) + END GetError; + +PROCEDURE (context: ErrorContext) GetTemplate* (msg: Msg.Msg; VAR templ: Msg.LString); + VAR + str: ARRAY 128 OF CHAR; + BEGIN + CASE msg. code OF + | valueOutOfRange: str := "Number exceeded limits or string was too long" + ELSE + str := ""; + context. GetTemplate^ (msg, templ) + END; + IF (str # "") THEN + COPY (str, templ) + END + END GetTemplate; + + + +(* Reader methods + ------------------------------------------------------------------------ *) + +PROCEDURE EolDetect (r: Reader; ch: CHAR); +(* pre: (r. eolLen < 0) & + (r. deferredEol OR (ch = Ascii.lf) OR (ch = Ascii.cr)) *) + BEGIN + IF (r. res = done) THEN + IF r. deferredEol THEN (* previous character was Ascii.cr *) + IF (ch = Ascii.lf) THEN (* eol sequence is cr+lf *) + r. eol[1] := ch; + r. eolLen := 2 + ELSE (* eol is just cr *) + r. eolLen := 1 + END; + r. deferredEol := FALSE + ELSE + r. eol[0] := ch; + IF (ch = Ascii.lf) THEN (* eol is just lf *) + r. eolLen := 1 + ELSE (* (ch = Ascii.cr) *) + r. deferredEol := TRUE + END + END + END + END EolDetect; + +PROCEDURE Lookahead (r: Reader; len: INTEGER): BOOLEAN; +(* Tries to read `len' characters past the current position from the input + stream. Characters present in the lookahead FIFO are taken into account. + After successful completion, `len' characters or more are available in + the lookahead FIFO and result is TRUE. Less than `len' characters + may be available if the operation is aborted due to a read error. In this + case result is FALSE. + pre: (len >= 1) & (r.res = done) & (len <= maxLookahead) + post: (r.res = done) *) + VAR + ch: CHAR; + BEGIN + ASSERT (r. res = done); + IF (r. laLen = 0) OR (r. laRes[r. laLen-1] = done) THEN + WHILE (r. laLen < len) & (r. byteReader. res = done) DO + r. byteReader. ReadByte (ch); + + IF (r. eolLen < 0) & + (r. deferredEol OR (ch = Ascii.lf) OR (ch = Ascii.cr)) THEN + EolDetect (r, ch) + END; + + r. la[r. laLen] := ch; + r. laRes[r. laLen] := r. byteReader. res; + INC (r. laLen) + END + END; + RETURN (len <= r. laLen) & (r. laRes[len-1] = done) + END Lookahead; + +PROCEDURE Consume (r: Reader): CHAR; +(* note: it is safe to call this procedure with `r.res#done' + post: r.res holds the result code for the returned character *) + VAR + ch: CHAR; + i: INTEGER; + BEGIN + IF (r. res = done) THEN + IF (r. laLen > 0) THEN + ch := r. la[0]; + r. res := r. laRes[0]; + FOR i := 1 TO r. laLen-1 DO + r. la[i-1] := r. la[i]; + r. laRes[i-1] := r. laRes[i] + END; + DEC (r. laLen) + ELSE + r. byteReader. ReadByte (ch); + + IF (r. byteReader. res # done) THEN + r. res := r. byteReader. res; + ch := 0X + ELSIF (r. eolLen < 0) & + (r. deferredEol OR (ch = Ascii.lf) OR (ch = Ascii.cr)) THEN + EolDetect (r, ch) + END + END + ELSE + ch := 0X + END; + RETURN ch + END Consume; + + + +(* The following methods read a value of the given type from the current + position in the TextReader. Iff the value is invalid for its type, + 'r.Res' returns 'invalidFormat'. + *) + +PROCEDURE (r: Reader) Pos* () : LONGINT; + BEGIN + RETURN r.byteReader.Pos()-r. laLen + END Pos; + +PROCEDURE (r: Reader) ClearError*; + BEGIN + r. byteReader. ClearError; + r. res := done; + r. deferredEol := FALSE + END ClearError; + +PROCEDURE (r: Reader) Available* () : LONGINT; + VAR + avail, laChars: LONGINT; + BEGIN + avail := r. byteReader. Available(); + laChars := 0; + WHILE (laChars # r. laLen) & (r. laRes[laChars] = done) DO + INC (laChars) + END; + IF (avail < 0) & (laChars > 0) THEN + RETURN laChars + ELSE + RETURN avail+laChars + END + END Available; + +PROCEDURE (r: Reader) SetPos* (newPos: LONGINT); + BEGIN + IF (r. res = done) THEN + r. byteReader. SetPos(newPos); + r. laLen := 0; (* lookahead characters not valid *) + r. deferredEol := FALSE; (* interrupt any eol detection *) + r. res := r. byteReader. res + END + END SetPos; + +PROCEDURE (r: Reader) SetOpts* (opts: SET); +(* Set the reader options `r.opt' which are defined above. *) + BEGIN + r.opt:=opts + END SetOpts; + +PROCEDURE (r: Reader) SetEol* (marker: ARRAY OF CHAR; markerLen: INTEGER); +(* Sets new end of line marker. If the passed string marker does not fit into + the field `eol', or it does contain a character >= " ", then + `r.Res()' is set to `invalidFormat'. + + A marker length `markerLen=-1' enables auto detection of the end-of-line + convention used by the channel. The channel is required to use one of the + following eol markers: + LF used by Unix + CR used by MacOS + CR/LF used by MS-DOS and Windows + + Enabling auto detection introduces a (small) inconsistency: if the first + line of the channel ends with a , then skipping over the complete eol + marker of this line is not done at once iff the next character is a . + All reading procedures except for `ReadChar' will automatically skip the + spurious . + + Example: + Input is "line1line2". + The first ReadLine leaves the reading position between and , + and a second ReadLine skips automagically the and returns "line2". + But if the second operation is a ReadChar, it will return , not + "l". + + The reason for this is that ReadChar is the only operation that can look + at parts of an multi-byte end-of-line marker, while such a marker is an + atomic entity for all other read operations if the channel is read + sequentially. + + pre: (r.Res() = done) & + ((markerLen = -1) OR (1 <= markerLen < LEN (marker))) & + (markerLen <= maxLengthEol) & (for all i: marker[i] < 20X) *) + VAR + i: INTEGER; + BEGIN + IF (r. res = done) THEN + IF (markerLen < 1) & (markerLen # -1) OR (markerLen > maxLengthEol) THEN + r. res := GetError (invalidFormat) + ELSE + FOR i := 0 TO markerLen-1 DO + IF (marker[i] >= 20X) THEN + r. res := GetError (invalidFormat) + END; + r. eol[i] := marker[i] + END; + r. eolLen := markerLen + END + END + END SetEol; + +PROCEDURE (r: Reader) ReadChar* (VAR ch: CHAR); +(* Read a character. NOTE: no new characters will be read + if an error has occurred. *) + BEGIN + ch := Consume (r) + END ReadChar; + +PROCEDURE (r: Reader) Eol*(): BOOLEAN; +(* Return TRUE if the character at the current position is the system-dependent + end-of-line character sequence or the last character has been read. + If `r.res # done', then result is TRUE. *) + VAR + i: INTEGER; + BEGIN + IF (r. res = done) THEN + IF (r. eolLen > 0) THEN + FOR i := 0 TO r. eolLen-1 DO + IF Lookahead (r, i+1) THEN + IF (r. la[i] # r. eol[i]) THEN + RETURN FALSE + END + ELSE + RETURN (r. laLen = 1) + END + END; + RETURN TRUE + ELSIF Lookahead (r, 1) THEN + IF (r. eolLen > 0) THEN + RETURN r. Eol() (* the extra lookahead solved our problem *) + ELSE (* here holds: `r.la[0] # Ascii.lf' *) + RETURN (r. la[0] = Ascii.cr) + END + ELSE + RETURN TRUE (* low-level error for next character *) + END + ELSE + RETURN TRUE + END + END Eol; + +PROCEDURE SkipBlanks (r: Reader); + VAR + ch: CHAR; + BEGIN + (* note: Ascii.lf must be a whitespace character, or with eol auto + detection a ReadFoo procedure may find a spurious Ascii.lf in its + input that it should never have seen *) + IF (r. res = done) THEN + IF (returnCtrlChars IN r.opt) THEN + WHILE ~r. Eol() & Lookahead (r, 1) & + (r. la[0] <= " ") & + (r. la[0] # Ascii.ht) DO + ch := Consume (r) + END + ELSE + WHILE Lookahead (r, 1) & (r. la[0] <= " ") DO + ch := Consume (r) + END + END + END + END SkipBlanks; + +PROCEDURE SkipEol (r: Reader); + VAR + i: INTEGER; + ch: CHAR; + BEGIN + IF r. Eol() THEN + FOR i := 1 TO ABS (r. eolLen) DO + (* note: if r.eolLen<-1 and we are looking at a CR+LF, only the CR + will be skipped at this time *) + ch := Consume (r) + END + END + END SkipEol; + +PROCEDURE (r: Reader) ReadLn*; + VAR + ch: CHAR; + BEGIN + WHILE ~r. Eol() DO + ch := Consume (r) + END; + SkipEol (r) + END ReadLn; + +PROCEDURE (r: Reader) ReadString* (VAR s: ARRAY OF CHAR); +(* Pre: input = [whitespace] '"' {char} '"' | [whitespace] "'" {char} "'" + Illegal chars terminate with invalidFormat. + *) + VAR + cnt: INTEGER; + quote: CHAR; + BEGIN + SkipBlanks (r); + cnt := 0; + + IF (r. res = done) & Lookahead (r, 1) THEN + IF (r. la[0] # '"') & (r. la[0] # "'") THEN + r. res := GetError (invalidFormat) + ELSE + quote := Consume (r); + LOOP + IF ~Lookahead (r, 1) THEN + quote := Consume (r); (* low-level error *) + EXIT + ELSIF (r. la[0] < " ") THEN + r. res := GetError (invalidFormat); + EXIT + ELSIF (r. la[0] = quote) THEN + quote := Consume (r); (* end quote *) + EXIT + ELSIF (cnt = LEN (s)-1) THEN + r. res := GetError (valueOutOfRange); + EXIT + ELSE + s[cnt] := Consume (r); + INC (cnt) + END + END + END + ELSE + quote := Consume (r) (* low-level error *) + END; + + s[cnt] := 0X + END ReadString; + +PROCEDURE (r: Reader) ReadLine* (VAR s: ARRAY OF CHAR); +(* Reads characters until an end of line character is encountered, or the + array `s' is full. CAUTION: If reading multiple lines of input and an + integer, real, etc. has just been read, the channel may be positioned + at a eol character and this method will return an empty string. *) + VAR + cnt: INTEGER; + dummy: CHAR; + BEGIN + (* check if eol auto detection left us a spurious lf in the input *) + IF r. deferredEol & Lookahead (r, 1) & (r. la[0] = Ascii.lf) THEN + dummy := Consume (r) + END; + + (* read in the characters *) + cnt := 0; + WHILE ~r. Eol() & Lookahead (r, 1) & (cnt # LEN (s)-1) DO + s[cnt] := Consume (r); + INC (cnt) + END; + + IF r. Eol() THEN + SkipEol (r) + ELSIF (cnt = LEN (s)-1) THEN + r. res := GetError (valueOutOfRange) + END; + s[cnt]:=0X (* terminate string *) + END ReadLine; + +PROCEDURE (r: Reader) ReadIdentifier* (VAR s: ARRAY OF CHAR); +(* Pre: input = [whitespace] letter {letter | digit} + *) + VAR + cnt: INTEGER; + ch: CHAR; + BEGIN + SkipBlanks (r); + cnt := 0; + + IF (r. res = done) & Lookahead (r, 1) THEN + IF ~CharClass.IsLetter(r. la[0]) THEN + r. res := GetError (invalidFormat) + ELSE + s[0] := Consume (r); + cnt := 1; + LOOP + IF ~(Lookahead (r, 1) & + (CharClass.IsLetter(r. la[0]) OR + CharClass.IsNumeric(r. la[0]))) THEN + EXIT + ELSIF (cnt = LEN (s)-1) THEN + r. res := GetError (valueOutOfRange); + EXIT + ELSE + s[cnt] := Consume (r); + INC (cnt) + END + END + END + ELSE + ch := Consume (r) (* low-level error *) + END; + + s[cnt]:=0X (* terminate string *) + END ReadIdentifier; + +PROCEDURE (r: Reader) ReadBool* (VAR bool: BOOLEAN); +(* Pre: input=[whitespace] ["TRUE"|"FALSE"]; Post: bool=TRUE iff input="TRUE" + and bool=FALSE iff input="FALSE"; undefined otherwise *) + VAR + ident: ARRAY 8 OF CHAR; + BEGIN + r. ReadIdentifier (ident); + IF (r. res = done) THEN + IF (ident = "TRUE") THEN + bool := TRUE + ELSIF (ident = "FALSE") THEN + bool := FALSE + ELSE + r. res := GetError (invalidFormat) + END + END + END ReadBool; + +PROCEDURE HexDigit (ch: CHAR) : BOOLEAN; + BEGIN + RETURN ((ch>="0") & (ch<="9")) OR ((ch>="A") & (ch<="F")) + END HexDigit; + +PROCEDURE HexToInt (str: ARRAY OF CHAR; VAR lint: LONGINT): BOOLEAN; +(* Returns the long integer constant `lint' in the string `str' according + to the format: + IntConst = digit {hexdigit} + + Note: 80000000H-FFFFFFFFH are valid inputs which map to the negative + integers. *) + CONST + BASE = 16; + MAXPAT = 8000000H; + VAR + d, pos: INTEGER; + BEGIN + (* accept the hexadecimal input number *) + lint:=0; pos:=0; + LOOP + (* read a digit *) + d:=ORD(str[pos]); + IF d=0 THEN RETURN TRUE + ELSIF CharClass.IsNumeric(CHR(d)) THEN DEC(d, ORD("0")) + ELSE (* A-F *) DEC(d, ORD("A")-10) + END; + + (* check for overflow and adjustment *) + IF (lint>=MAXPAT*2) OR (lint<0) THEN + RETURN FALSE (* overflow *) + ELSIF (lint>=MAXPAT) & (d>=8) THEN + DEC(lint, MAXPAT*2) (* adjustment *) + END; + + (* build up the number *) + lint:=BASE*lint+d; + INC(pos) + END + END HexToInt; + +PROCEDURE (r: Reader) ReadLInt* (VAR lint: LONGINT); +(* Returns the long integer constant n at the current position according to the + format: + IntConst = [whitespace] ["+"|"-"] digit {digit} +*) + CONST + (* 2^31 has 11 digits, plus sign, plus 0, plus 0X = 14 *) + buffer = 14; + VAR + str: ARRAY buffer OF CHAR; + ch: CHAR; + pos: INTEGER; + res: SHORTINT; + ignoreZeros: BOOLEAN; + BEGIN + SkipBlanks (r); + pos := 0; + + IF (r. res = done) & Lookahead (r, 1) THEN + IF (r. la[0] = "+") OR (r. la[0] = "-") THEN + str[0] := Consume (r); + INC (pos); + IF ~Lookahead (r, 1) THEN + ch := Consume (r); (* low-level error *) + RETURN + END + END; + + IF CharClass.IsNumeric(r. la[0]) THEN + str[pos] := "0"; + INC (pos); + ignoreZeros := TRUE; + LOOP + IF ~(Lookahead (r, 1) & CharClass.IsNumeric(r. la[0])) THEN + EXIT + ELSE + (* accumulate the digits; avoid overflow because of excessive + leading zeros *) + ch := Consume (r); + IF ~ignoreZeros OR (ch # "0") THEN + IF (pos # buffer) THEN + str[pos] := ch; + INC (pos) + END; + ignoreZeros := FALSE + END + END + END; + + (* convert to an integer *) + IF (pos = buffer) THEN + res := IntStr.strOutOfRange + ELSE + str[pos] := 0X; + IntStr.StrToInt (str, lint, res) + END; + + (* set errors -- if needed *) + IF (res = IntStr.strOutOfRange) THEN + r. res := GetError (valueOutOfRange) + ELSIF (res # IntStr.strAllRight) THEN + r. res := GetError (invalidFormat) + END + ELSE + r. res := GetError (invalidFormat) + END + ELSE + ch := Consume (r) (* low-level error *) + END + END ReadLInt; + +PROCEDURE (r: Reader) ReadHex* (VAR lint: LONGINT); +(* Returns the long integer constant n at the current position according to the + format: + IntConst = [whitespace] digit {hexdigit} + where hexDigit = "0".."9" | "A".."F" + Note: Numbers in the range 80000000H-FFFFFFFFH are read in as negative + numbers. If numbers like 80H-FFH are to be interpreted as negatives for + SHORTINTs then neg = lint-100H or 8000H-FFFFH are to be interpreted as + negatives for INTEGERs then neg = lint-10000H. +*) + CONST + (* 2^32 has 8 digits, plus two digits, plus 0X = 11 *) + buffer = 11; + VAR + str: ARRAY buffer OF CHAR; + ch: CHAR; + pos: INTEGER; + ignoreZeros: BOOLEAN; + BEGIN + SkipBlanks (r); + pos := 0; + + IF (r. res = done) & Lookahead (r, 1) THEN + IF CharClass.IsNumeric(r. la[0]) THEN + str[pos] := "0"; + INC (pos); + ignoreZeros := TRUE; + LOOP + IF ~(Lookahead (r, 1) & HexDigit (r. la[0])) THEN + EXIT + ELSE + (* accumulate the digits; avoid overflow because of excessive + leading zeros *) + ch := Consume (r); + IF ~ignoreZeros OR (ch # "0") THEN + IF (pos # buffer) THEN + str[pos] := ch; + INC (pos) + END; + ignoreZeros := FALSE + END + END + END; + + (* convert to integer *) + IF (pos = buffer) THEN + r. res := GetError (valueOutOfRange) + ELSE + str[pos] := 0X; + IF ~HexToInt(str, lint) THEN + r. res := GetError (valueOutOfRange) + END + END + ELSE + r. res := GetError (invalidFormat) + END + ELSE + ch := Consume (r) (* low-level error *) + END + END ReadHex; + +PROCEDURE (r: Reader) ReadInt * (VAR int: INTEGER); +(* as ReadLInt *) + VAR + lint: LONGINT; + BEGIN + r.ReadLInt(lint); + IF (lint>MAX(INTEGER)) OR (lintMAX(SHORTINT)) OR (lint MAX (SET))) THEN + r. res := GetError (valueOutOfRange); + RETURN {} + ELSIF Lookahead (r, 2) & (r. la[0] = ".") & (r. la[1] = ".") THEN + ch := Consume (r); + ch := Consume (r); + SkipBlanks (r); + r. ReadSInt (high); + IF (r. res = done) & + ((high < 0) OR (high > MAX (SET)) OR (high < low)) THEN + r. res := GetError (valueOutOfRange); + RETURN {} + END + END + END; + SkipBlanks (r); + RETURN {low..high} + END ReadRange; + + BEGIN + (* ensure a valid start *) + SkipBlanks (r); + + IF (r. res = done) & Lookahead (r, 1) THEN + IF (r. la[0] = "{") THEN + s := {}; + ch := Consume (r); + SkipBlanks (r); + IF (r. res = done) & Lookahead (r, 1) THEN + IF (r. la[0] # "}") THEN + s := s + ReadRange(); + WHILE (r. res = done) & Lookahead (r, 1) & (r. la[0] = ",") DO + ch := Consume (r); + SkipBlanks (r); + s := s + ReadRange() + END + END; + IF (r. res = done) & (r. la[0] = "}") THEN + ch := Consume (r) + ELSE + r. res := GetError (invalidFormat) + END + ELSE + ch := Consume (r) (* low-level error *) + END + ELSE + r. res := GetError (invalidFormat) + END + ELSE + ch := Consume (r) (* low-level error *) + END + END ReadSet; + + +(* Scanner methods + ------------------------------------------------------------------------ *) + +PROCEDURE SkipSpaces (s: Scanner); +(* Skip white space as defined by the scanner options. *) + VAR + ch: CHAR; + BEGIN (* pre: (s. res = done) *) + (* note: Ascii.lf must be a whitespace character, or with eol auto + detection a ReadFoo procedure may find a spurious Ascii.lf in its + input that it should never have seen *) + ASSERT (s. res = done); + IF (returnCtrlChars IN s. opt) THEN + WHILE ~s. r. Eol() & Lookahead (s. r, 1) & + (s. r. la[0] <= " ") & + (s. r. la[0] # Ascii.ht) DO + ch := Consume (s. r) + END + ELSE + WHILE Lookahead (s. r, 1) & (s. r. la[0] <= " ") DO + IF s. r. Eol() THEN + INC (s. lines); + SkipEol (s. r) + ELSE + ch := Consume (s. r) + END + END + END; + s. res := s. r. res + END SkipSpaces; + +PROCEDURE (s: Scanner) Pos* () : LONGINT; +(* Position of the look-ahead character *) + BEGIN + RETURN s.r.Pos() + END Pos; + +PROCEDURE (s: Scanner) ClearError*; + BEGIN + s. r. ClearError; + s. res := done; + s. type := undefined + END ClearError; + +PROCEDURE (s: Scanner) Available* () : LONGINT; +(* Position of the look-ahead character *) + BEGIN + RETURN s.r.Available() + END Available; + +PROCEDURE (s: Scanner) SetPos* (pos: LONGINT); + BEGIN + IF (s. res = done) THEN + s. r. SetPos(pos); + s. res := s. r. res + END + END SetPos; + +(* Scan for the next token *) +PROCEDURE (s: Scanner) Scan*; +(* Note: Because of implementation restrictions, a real representation with + more than 1023 characters causes an `invalidFormat' error. *) + CONST + buffer = 1024; + VAR + ch: CHAR; str: ARRAY buffer OF CHAR; pos: INTEGER; res: SHORTINT; + + PROCEDURE ReadNum; + (* pre: current lookahead character is digit or sign *) + PROCEDURE Get; + VAR + dummy: BOOLEAN; + BEGIN + IF (pos < buffer) THEN + str[pos] := Consume (s. r) + END; + INC (pos); + IF (s. r. res = done) THEN + dummy := Lookahead (s. r, 1) + ELSE + s. r. la[0] := 0X + END + END Get; + + PROCEDURE LA (): CHAR; + BEGIN + RETURN s. r. la[0] + END LA; + + BEGIN + IF (s. r. res = done) & Lookahead (s. r, 1) THEN + pos:=0; + + IF (LA() = "-") OR (LA() = "+") THEN + Get + END; + + (* read leading digits *) + IF ~CharClass.IsNumeric (LA()) THEN + s. res := GetError (invalidFormat); + RETURN + ELSE + WHILE HexDigit (LA()) DO Get END + END; + + (* check for reals or hexadecimals *) + IF (LA() = ".") THEN (* real number *) + s.type:=real; + Get; + (* read trailing digits *) + WHILE CharClass.IsNumeric (LA()) DO Get END; + (* read the exponent *) + IF (LA() = "E") OR (LA() = "e") THEN + Get; + IF (pos-1 < buffer) THEN str[pos-1] := "E" END; + IF (LA() = "-") OR (LA() = "+") THEN Get END; + (* read leading digits *) + IF ~CharClass.IsNumeric (LA()) THEN + s. res := GetError (invalidFormat); + RETURN + ELSE + WHILE CharClass.IsNumeric (LA()) DO Get END + END + END; + + (* convert to real *) + IF (pos < buffer) THEN + str[pos]:=0X; + LRealStr.StrToReal(str, s.real, res); + + (* set errors -- if needed *) + IF (res # LRealStr.strAllRight) THEN + s. res := GetError (invalidFormat) + END + ELSE + s. res := GetError (invalidFormat) + END + + ELSIF (LA() = "H") THEN (* hexadecimal integer *) + s.type:=int; str[pos]:=0X; + IF ~HexToInt (str, s. int) THEN + s. res := GetError (invalidFormat) + END; + Get (* get rid of "H" *) + + ELSE (* just an integer *) + s.type:=int; + str[pos]:=0X; + IntStr.StrToInt(str, s.int, res); + IF res#IntStr.strAllRight THEN + s. res := GetError (invalidFormat) + END + END + END + END ReadNum; + + PROCEDURE SetType (type: SHORTINT); + BEGIN + s. type := type + END SetType; + + BEGIN + IF (s. type < error) THEN (* `error' and `invalid' are sticky *) + (* if `s.type' does not signal an error, then `s.res=done' *) + SkipSpaces (s); + + IF (s. res = done) & Lookahead (s. r, 1) THEN + s.pos:=s.Pos(); + + IF s. r. Eol() THEN + s. type := line; + SkipEol (s. r); + INC (s. lines) + ELSE + CASE s. r. la[0] OF + | '"', "'": + IF (interpretStrings IN s. opt) THEN + s. r. ReadString (s. string); + SetType (string) + ELSE + s. r. ReadChar (s.char); + SetType (char) + END + | "a".."z", "A".."Z": + s. r. ReadIdentifier (s. string); + IF (s. r. res = done) & (interpretBools IN s.opt) & + ((s. string = "TRUE") OR (s. string="FALSE")) THEN + s. bool := (s. string = "TRUE"); + SetType (bool) + ELSE + SetType (ident) + END + | "+", "-": + IF (useSignedNumbers IN s.opt) THEN + ReadNum + ELSE + s. r. ReadChar (s.char); + SetType (char) + END + | "0".."9": (* integer or real *) + ReadNum + | "{": + IF (interpretSets IN s. opt) THEN + s. r. ReadSet (s. set); + SetType (set) + ELSE + s. r. ReadChar (s.char); + SetType (char) + END + ELSE + s. r. ReadChar (s.char); + IF (s. char = Ascii.ht) THEN + SetType (tab) + ELSE + SetType (char) + END + END + END + ELSE + ch := Consume (s. r) (* low-level error *) + END; + + IF (s. r. res # done) & (s. res = done) THEN + s. res := s. r. res + END; + IF (s. res # done) & (s. res. context = errorContext) THEN + IF ((s. res. code = invalidFormat) OR + (s. res. code = valueOutOfRange)) THEN + s. type := invalid + ELSE + s. type := error + END + END + END + END Scan; + +(* Set the scanner options `s.opt' which are defined above. *) +PROCEDURE (s: Scanner) SetOpts* (opts: SET); + BEGIN + s.opt:=opts; + s.r.opt:=opts*{returnCtrlChars} (* adjust the reader options as well *) + END SetOpts; + +PROCEDURE (s: Scanner) SetEol* (marker: ARRAY OF CHAR; markerLen: INTEGER); +(* As Reader.SetEol. *) + BEGIN + s. r. SetEol (marker, markerLen) + END SetEol; + + +(* Writer methods + ------------------------------------------------------------------------ *) + +(* The following write methods write the value as a string to the + underlying Channel. + *) + +PROCEDURE (w: Writer) Pos* () : LONGINT; + BEGIN + RETURN w.byteWriter.Pos() + END Pos; + +PROCEDURE (w: Writer) SetPos* (newPos: LONGINT); + BEGIN + IF (w. res = done) THEN + w.byteWriter.SetPos(newPos); + w. res := w. byteWriter. res + END + END SetPos; + +PROCEDURE (w: Writer) ClearError*; + BEGIN + w.byteWriter.ClearError; + w.res := done + END ClearError; + +PROCEDURE (w: Writer) SetOpts* (opts: SET); +(* Set the writer options `w.opt' which are defined above. *) + BEGIN + w.opt:=opts + END SetOpts; + +PROCEDURE (w: Writer) SetEol* (marker: ARRAY OF CHAR; markerLen: INTEGER); +(* Sets new end of line marker. If the passed string marker does not fit into + the field `eol', then `w.res' is set to `invalidFormat'. The empty + marker is permitted. The default value for newly created writer is + `CharClass.systemEol'. + pre: (w.res = done) & (0 <= markerLen < LEN (marker)) & + (markerLen <= maxLengthEol) *) + VAR + i: INTEGER; + BEGIN + IF (w. res = done) THEN + IF (markerLen < 0) OR (markerLen > maxLengthEol) THEN + w. res := GetError (invalidFormat) + ELSE + FOR i := 0 TO markerLen-1 DO + w. eol[i] := marker[i] + END; + w. eolLen := markerLen + END + END + END SetEol; + +(* The terminating 0X is not written *) +PROCEDURE (w: Writer) WriteString*(s(*[NO_COPY]*): ARRAY OF CHAR); (* this will slow it down a little, but I cannot imagine a better and simpler solution; -- noch *) + BEGIN + IF (w. res = done) THEN + w. byteWriter. WriteBytes (s, 0, Strings.Length (s)); + w. res := w. byteWriter. res; + IF (noBuffering IN w.opt) & (w. res = done) THEN + w. base. Flush; + w. res := w. base. res + END + END + END WriteString; + +PROCEDURE (w: Writer) WriteBool*(bool: BOOLEAN); + BEGIN + IF bool THEN w. WriteString ("TRUE") + ELSE w. WriteString ("FALSE") + END + END WriteBool; + +PROCEDURE (w: Writer) WriteChar*(ch: CHAR); + BEGIN + IF (w. res = done) THEN + w.byteWriter.WriteByte(ch); + IF (noBuffering IN w.opt) & (w. res = done) THEN + w. base. Flush; + w. res := w. base. res + END + END + END WriteChar; + +PROCEDURE WritePad (w: Writer; n: LONGINT); + BEGIN + (* output padding *) + WHILE n>0 DO w.WriteChar(" "); DEC(n) END + END WritePad; + +(* Convert 'sint' to a string of at least 'n' chars and write it to the + underlying channel. If 'n' is too small it will be extended. If 'n' + is greater then nessesary spaces will be added after the number, i.e. + it is left justified. *) +PROCEDURE (w: Writer) WriteLInt*(lint: LONGINT; n: LONGINT); + VAR + val: ARRAY 16 OF CHAR; + BEGIN + (* convert to a string *) + IntStr.IntToStr(lint, val); + + (* output any required padding *) + WritePad(w, n-Strings.Length(val)); + + (* output the string *) + w.WriteString(val) + END WriteLInt; + +PROCEDURE (w: Writer) WriteSInt* (sint: SHORTINT; n: LONGINT); + BEGIN + w.WriteLInt(sint, n) + END WriteSInt; + +PROCEDURE (w: Writer) WriteInt* (int: INTEGER; n: LONGINT); + BEGIN + w.WriteLInt(int, n) + END WriteInt; + +(* Write `lint' as a heximal number using `d' digits. + If `d' <= 0 then `lint' is written using 8 digits. *) +PROCEDURE (w: Writer) WriteHex* (lint: LONGINT; d: LONGINT); + PROCEDURE WriteHexDigits(w: Writer; VAR n: LONGINT; digits: LONGINT); + CONST + BASE=16; + VAR + dig: LONGINT; + BEGIN + (* output padding digits *) + WHILE digits>8 DO + IF n<0 THEN w.WriteChar("F") ELSE w.WriteChar("0") END; + DEC(digits) + END; + + (* output the actual number *) + WHILE digits>0 DO + DEC(digits); + dig := ASH(n, -4*digits) MOD BASE; + IF dig<=9 THEN w.WriteChar(CHR(ORD("0") + dig)) + ELSE w.WriteChar(CHR(ORD("A") - 10 + dig)) + END + END + END WriteHexDigits; + + BEGIN + IF d<=0 THEN d:=8 END; + WriteHexDigits(w, lint, d) + END WriteHex; + +PROCEDURE (w: Writer) WriteLReal*(lreal: LONGREAL; n, k: LONGINT); + (* The call to WriteLongReal(lreal, n, k) shall write to the underlying + channel a formatted string corresponding to the value of `lreal' 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 `k' 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. The complete formatted + number will be right-justified in a field of width `n'. If 'n' is + too small it will be extended. + + For example: (n=9) + + value: 3923009 39.23009 0.0003923009 + k + 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 + val: ARRAY 128 OF CHAR; + BEGIN + (* convert to a string *) + LRealStr.RealToFloat(lreal, SHORT(k), val); + + (* output any required padding *) + WritePad(w, n-Strings.Length(val)); + + (* output the string *) + w.WriteString(val); + END WriteLReal; + +PROCEDURE (w: Writer) WriteReal*(real: REAL; n, k: LONGINT); +(* As WriteLReal *) + VAR + val: ARRAY 128 OF CHAR; + BEGIN + (* convert to a string *) + RealStr.RealToFloat(real, SHORT(k), val); + + (* output any required padding *) + WritePad(w, n-Strings.Length(val)); + + (* output the string *) + w.WriteString(val) + END WriteReal; + +PROCEDURE (w: Writer) WriteLRealFix*(VAR lreal: LONGREAL; n, k: LONGINT); + (* + The call WriteLRealFix(lreal, n, k) shall output to the underlying + channel the formatted string corresponding to the value of `lreal' 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 `k' relative to the + decimal point. The decimal point shall be suppressed if `k' is + less than 0. The complete formatted number will be right-justified + in a field of width `n'. If 'n' is too small it will be extended. + + For example: (n=12) + + value: 3923009 3.923009 0.0003923009 + k + -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 + val: ARRAY 128 OF CHAR; + BEGIN + (* convert to a string *) + LRealStr.RealToFixed(lreal, SHORT(k), val); + + (* output any required padding *) + WritePad(w, n-Strings.Length(val)); + + (* output the string *) + w.WriteString(val) + END WriteLRealFix; + +PROCEDURE (w: Writer) WriteRealFix*(real: REAL; n, k: LONGINT); +(* As WriteLongRealFix *) + VAR + val: ARRAY 128 OF CHAR; + BEGIN + (* convert to a string *) + RealStr.RealToFixed(real, SHORT(k), val); + + (* output any required padding *) + WritePad(w, n-Strings.Length(val)); + + (* output the string *) + w.WriteString(val) + END WriteRealFix; + +PROCEDURE (w: Writer) WriteLRealEng*(VAR lreal: LONGREAL; n, k: LONGINT); + (* + Converts the value of real to floating-point string form, with + `k' significant figures, and writes the resultant value, + right-justified in a field of width `n' to the underlying channel. + If 'n' is too small it will be extended. 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: n=9 + + value: 3923009 39.23009 0.0003923009 + k + 1 4E+6 40 400E-6 + 2 3.9E+6 39 390E-6 + 5 3.9230E+6 39.230 392.30E-6 + *) + VAR + val: ARRAY 128 OF CHAR; + BEGIN + (* convert to a string *) + LRealStr.RealToEng(lreal, SHORT(k), val); + + (* output any required padding *) + WritePad(w, n-Strings.Length(val)); + + (* output the string *) + w.WriteString(val) + END WriteLRealEng; + +PROCEDURE (w: Writer) WriteRealEng*(real: REAL; n, k: LONGINT); +(* As WriteLRealEng *) + VAR + val: ARRAY 128 OF CHAR; + BEGIN + (* convert to a string *) + RealStr.RealToEng(real, SHORT(k), val); + + (* output any required padding *) + WritePad(w, n-Strings.Length(val)); + + (* output the string *) + w.WriteString(val) + END WriteRealEng; + +PROCEDURE (w: Writer) WriteSet*(s: SET); +(* Write 's' in mathematical set notation. + Pre: x = {Element, ..., Element}; Post: write "{Element, ..., Element}" + where Element = number [".." number] and 0 <= number <= 31 *) + VAR + bit, lo: SHORTINT; addComma: BOOLEAN; + BEGIN + w.WriteChar("{"); bit:=0; addComma:=FALSE; + WHILE bit<=MAX(SET) DO + IF bit IN s THEN + lo:=bit; + WHILE (bit