(******************************************************************************) (* TopSpeed compatible file i/o *) (* (C) 2009..2010 Steffen Solyga *) (******************************************************************************) IMPLEMENTATION MODULE FIO; IMPORT SysLib, ErrNumbers, Str, Lib; FROM SYSTEM IMPORT ADR, ADDRESS, BYTE; CONST stdIn = StandardInput; stdOut = StandardOutput; stdErr = ErrorOutput; chrEOF = 32C; (* = CHR(1AH) = CHR(26) = ASCII.sub (TopSpeed) *) chrBS = 10C; (* = CHR(08H) *) chrLF = 12C; (* = CHR(0AH) *) chrCR = 15C; (* = CHR(0DH) *) TYPE TStr32 = ARRAY [ 0 .. 31 ] OF CHAR; TStr128 = ARRAY [ 0 .. 127 ] OF CHAR; TRetVal = RECORD CASE : CARDINAL OF | 0: s: SysLib.SIGNED; | 1: u: SysLib.UNSIGNED; END; END; TCnvDesc = RECORD CASE : CARDINAL OF | 0: lc: LONGCARD; | 1: c : CARDINAL; | 2: sc: SHORTCARD; | 3: li: LONGINT; | 4: i : INTEGER; | 5: si: SHORTINT; END; END; VAR IOR: CARDINAL; (*** errors ***) PROCEDURE ErrWrStr( s: ARRAY OF CHAR ); VAR n: INTEGER; BEGIN n := SysLib.write( stdErr, ADR(s), Str.Length(s) ); END ErrWrStr; PROCEDURE ErrWrLn(); VAR n: INTEGER; c: CHAR; BEGIN c := CHAR( 0AH ); n := SysLib.write( stdErr, ADR(c), SIZE(c) ); END ErrWrLn; PROCEDURE ErrWrCard( x: CARDINAL ); VAR s: TStr32; ok: BOOLEAN; BEGIN Str.CardToStr( x, s, 10, ok ); IF ~ok THEN s := '???' END; ErrWrStr( s ); END ErrWrCard; PROCEDURE ErrorCheck( s, fn: ARRAY OF CHAR; f: File ); VAR r: CARDINAL; BEGIN r := ORD( ErrNumbers.ErrNo() ); IF IOcheck THEN ErrWrStr( s ); ErrWrStr( ' failed with code ' ); ErrWrCard( r ); ErrWrStr( ' for file ' ); IF Str.Length( fn ) > 0 THEN ErrWrStr( "'" ); ErrWrStr( fn ); ErrWrStr( "'" ); ELSE ErrWrCard( f ); END; ErrWrStr( "." ); ErrWrLn(); SysLib.exit( 1 ); END; IOR := r; END ErrorCheck; (*** utils ***) PROCEDURE IsSepDefault( c: CHAR ): BOOLEAN; BEGIN RETURN ( c = ' ' ) OR ( c = chrBS ) OR ( c = chrLF ) OR ( c = chrCR ); END IsSepDefault; PROCEDURE GetName( fn: ARRAY OF CHAR; VAR p: PathStr ); BEGIN IOR := resOk; Str.Copy( p, fn ); p[ HIGH(p) ] := 0C; END GetName; (*** basics ***) PROCEDURE IOresult(): CARDINAL; BEGIN RETURN IOR; END IOresult; PROCEDURE Exists( fn: ARRAY OF CHAR ): BOOLEAN; VAR p: PathStr; r: TRetVal; s: SysLib.Stat; BEGIN GetName( fn, p ); r.s := SysLib.stat( ADR(p), s ); RETURN r.s = 0; END Exists; PROCEDURE Erase( fn: ARRAY OF CHAR ); VAR p: PathStr; r: TRetVal; BEGIN GetName( fn, p ); r.s := SysLib.unlink( ADR(p) ); IF r.s = -1 THEN IF ErrNumbers.ErrNo() = ErrNumbers.eNOENT THEN RETURN END; ErrorCheck( 'Erase', p, noFile ) END; END Erase; PROCEDURE Open( fn: ARRAY OF CHAR ): File; VAR p: PathStr; r: TRetVal; BEGIN GetName( fn, p ); r.s := SysLib.open( ADR(p), SysLib.oRDWR ); IF r.s = -1 THEN ErrorCheck( 'Open', p, noFile ); RETURN noFile; END; RETURN r.u; END Open; PROCEDURE OpenRead( fn: ARRAY OF CHAR ): File; VAR p: PathStr; r: TRetVal; BEGIN GetName( fn, p ); r.s := SysLib.open( ADR(p), SysLib.oRDONLY ); IF r.s = -1 THEN ErrorCheck( 'OpenRead', p, noFile ); RETURN noFile; END; RETURN r.u; END OpenRead; PROCEDURE Create( fn: ARRAY OF CHAR ): File; CONST perm = SysLib.pROWNER + SysLib.pWOWNER + SysLib.pRGROUP + SysLib.pWGROUP + SysLib.pROTHERS + SysLib.pWOTHERS; VAR p: PathStr; r: TRetVal; BEGIN GetName( fn, p ); r.s := SysLib.creat( ADR(p), perm ); IF r.s = -1 THEN ErrorCheck( 'Create', p, noFile ); RETURN noFile; END; RETURN r.u; END Create; PROCEDURE Append( fn: ARRAY OF CHAR ): File; VAR p: PathStr; r: TRetVal; BEGIN GetName( fn, p ); r.s := SysLib.open( ADR(p), SysLib.oRDWR + SysLib.oAPPEND ); IF r.s = -1 THEN ErrorCheck( 'Append', p, noFile ); RETURN noFile; END; RETURN r.u; END Append; PROCEDURE Close( f: File ); VAR r: TRetVal; BEGIN IOR := resOk; r.s := SysLib.close( f ); IF r.s # 0 THEN ErrorCheck( 'Close', '', f ); END; END Close; PROCEDURE Size( f: File ): LONGCARD; VAR r: TRetVal; s: SysLib.Stat; BEGIN (* 2010-03-18 should I use lseek? *) IOR := resOk; r.s := SysLib.fstat( f, s ); IF r.s # 0 THEN ErrorCheck( 'Size', '', f ); RETURN 0; END; RETURN LONGCARD( s.stSize ); END Size; PROCEDURE GetPos( f: File ): LONGCARD; VAR o: SysLib.offT; BEGIN IOR := resOk; o := SysLib.lseek( f, 0, SysLib.rCUR ); IF o = -1 THEN ErrorCheck( 'GetPos', '', f ); RETURN 0; END; RETURN LONGCARD( o ); END GetPos; PROCEDURE Seek( f: File; p: LONGCARD ); VAR o: SysLib.offT; BEGIN IOR := resOk; o := SysLib.lseek( f, 0, SysLib.rSET ); IF o = -1 THEN ErrorCheck( 'Seek', '', f ) END; END Seek; PROCEDURE AssignBuffer( f: File; VAR b: ARRAY OF BYTE ); BEGIN IOR := resOk; END AssignBuffer; PROCEDURE RdBin( f: File; VAR b: ARRAY OF BYTE; n: CARDINAL ): CARDINAL; VAR r: TRetVal; BEGIN IOR := resOk; IF n > SIZE( b ) THEN n := SIZE( b ) END; r.s := SysLib.read( f, ADR(b), n ); IF r.s = -1 THEN ErrorCheck( 'RdBin', '', f ); r.u := 0; END; EOF := ( r.u = 0 ) & ( n > 0 ); OK := ( r.u > 0 ) OR ( n = 0 ); (* JPI like *) RETURN CARDINAL( r.u ); END RdBin; PROCEDURE WrBin( f: File; VAR b: ARRAY OF BYTE; n: CARDINAL ); VAR r: TRetVal; BEGIN IOR := resOk; IF n > SIZE( b ) THEN n := SIZE( b ) END; r.s := SysLib.write( f, ADR(b), n ); IF r.s = -1 THEN ErrorCheck( 'WrBin', '', f ) END; OK := ( IOR = resOk ) & ( r.u = n ); END WrBin; (*** higher writes ***) PROCEDURE WrStr( f: File; VAR s: ARRAY OF CHAR ); BEGIN (* like TopSpeed, mocka uses 1 byte for CHAR *) (* => Str.Length() is the byte length also *) WrBin( f, s, Str.Length(s) ); END WrStr; PROCEDURE WrChar( f: File; c: CHAR ); BEGIN WrBin( f, c, SIZE(c) ); END WrChar; PROCEDURE WrCharRep( f: File; c: CHAR; n: CARDINAL ); VAR s: TStr128; l: CARDINAL; BEGIN Lib.Fill( ADR(s), SIZE(s), c ); WHILE n > 0 DO l := n; IF l > SIZE( s ) THEN l := SIZE( s ) END; WrBin( f, s, l ); IF ~ OK THEN RETURN END; DEC( n, l ); END; END WrCharRep; PROCEDURE WrLn( f: File ); BEGIN WrChar( f, CHR(0AH) ); END WrLn; PROCEDURE WrStrAdj( f: File; VAR s: ARRAY OF CHAR; l: INTEGER ); VAR a : INTEGER; BEGIN a := ABS( l ) - INTEGER( Str.Length(s) ); IF ( a < 0 ) & ChopOff THEN WrCharRep( f, '?', CARDINAL(ABS(l)) ); RETURN; END; IF ( l > 0 ) & ( a > 0 ) THEN WrCharRep( f, PrefixChar, CARDINAL(a) ); END; WrStr( f, s ); IF ( l < 0 ) & ( a > 0 ) THEN WrCharRep( f, PrefixChar, CARDINAL(a) ); END; END WrStrAdj; PROCEDURE WrLngCard( f: File; x: LONGCARD; l: INTEGER ); VAR s: TStr32; BEGIN Str.CardToStr( x, s, 10, OK ); IF OK THEN WrStrAdj( f, s, l ) END; END WrLngCard; PROCEDURE WrCard( f: File; x: CARDINAL; l: INTEGER ); BEGIN WrLngCard( f, LONGCARD(x), l ); END WrCard; PROCEDURE WrShtCard( f: File; x: SHORTCARD; l: INTEGER ); BEGIN WrLngCard( f, x, l ); END WrShtCard; PROCEDURE WrLngHex( f: File; x: LONGCARD; l: INTEGER ); VAR s: TStr32; BEGIN Str.CardToStr( x, s, 16, OK ); IF OK THEN WrStrAdj( f, s, l ) END; END WrLngHex; PROCEDURE WrHex( f: File; x: CARDINAL; l: INTEGER ); BEGIN WrLngHex( f, x, l ); END WrHex; PROCEDURE WrShtHex( f: File; x: SHORTCARD; l: INTEGER ); BEGIN WrLngHex( f, x, l ); END WrShtHex; PROCEDURE WrLngInt( f: File; x: LONGINT; l: INTEGER ); VAR s: TStr32; BEGIN Str.IntToStr( x, s, 10, OK ); IF OK THEN WrStrAdj( f, s, l ) END; END WrLngInt; PROCEDURE WrInt( f: File; x: INTEGER; l: INTEGER ); BEGIN WrLngInt( f, x, l ); END WrInt; PROCEDURE WrShtInt( f: File; x: SHORTINT; l: INTEGER ); BEGIN WrLngInt( f, x, l ); END WrShtInt; (*** higher reads ***) PROCEDURE RdChar( f: File ): CHAR; VAR c: CHAR; BEGIN IF RdBin( f, c, SIZE(c) ) # SIZE(c) THEN OK := FALSE; c := chrEOF; END; EOF := ( c = chrEOF ); RETURN c; END RdChar; PROCEDURE RdStr( f: File; VAR s: ARRAY OF CHAR ); VAR i: CARDINAL; c: CHAR; BEGIN i := 0; LOOP IF i > HIGH( s ) THEN RETURN END; (* no read-ahead on full s (JPI like) *) c := RdChar( f ); CASE c OF | chrEOF, (* JPI & TS set EOF := ( i = 0 ) *) chrCR : s[ i ] := 0C; RETURN; | chrLF : ELSE s[ i ] := c; INC( i ); END; END; END RdStr; PROCEDURE RdItem( f: File; VAR s: ARRAY OF CHAR ); VAR i: CARDINAL; c: CHAR; BEGIN i := 0; REPEAT c := RdChar( f ) UNTIL ~OK OR ~isSep( c ); LOOP IF ~OK OR isSep( c ) THEN EXIT END; s[ i ] := c; INC( i ); IF i > HIGH( s ) THEN RETURN END; (* no read-ahead on full s (JPI like) *) c := RdChar( f ); END; IF i <= HIGH( s ) THEN s[ i ] := 0C END; IF ~OK & ( i > 0 ) & ( IOR = resOk ) THEN OK := TRUE END; END RdItem; PROCEDURE RdLngCard( f: File ): LONGCARD; VAR s: TStr32; BEGIN RdItem( f, s ); IF ~OK THEN RETURN 0 END; RETURN Str.StrToCard( s, 10, OK ); END RdLngCard; PROCEDURE RdCard( f: File ): CARDINAL; VAR x: LONGCARD; BEGIN x := RdLngCard( f ); OK := OK & ( x <= MAX(CARDINAL) ); RETURN x; END RdCard; PROCEDURE RdShtCard( f: File ): SHORTCARD; VAR x: LONGCARD; BEGIN x := RdLngCard( f ); OK := OK & ( x <= MAX(SHORTCARD) ); RETURN x; END RdShtCard; PROCEDURE RdLngHex( f: File ): LONGCARD; VAR s: TStr32; BEGIN RdItem( f, s ); IF ~OK THEN RETURN 0 END; RETURN Str.StrToCard( s, 16, OK ); END RdLngHex; PROCEDURE RdHex( f: File ): CARDINAL; VAR x: LONGCARD; BEGIN x := RdLngHex( f ); OK := OK & ( x <= MAX(CARDINAL) ); RETURN x; END RdHex; PROCEDURE RdShtHex( f: File ): SHORTCARD; VAR x: LONGCARD; BEGIN x := RdLngHex( f ); OK := OK & ( x <= MAX(SHORTCARD) ); RETURN x; END RdShtHex; PROCEDURE RdLngInt( f: File ): LONGINT; VAR s: TStr32; BEGIN RdItem( f, s ); IF ~OK THEN RETURN 0 END; RETURN Str.StrToInt( s, 10, OK ); END RdLngInt; PROCEDURE RdInt( f: File ): INTEGER; VAR x: LONGINT; BEGIN x := RdLngInt( f ); OK := OK & ( MIN(INTEGER) <= x ) & ( x <= MAX(INTEGER) ); RETURN x; END RdInt; PROCEDURE RdShtInt( f: File ): SHORTINT; VAR x: LONGINT; BEGIN x := RdLngInt( f ); OK := OK & ( MIN(SHORTINT) <= x ) & ( x <= MAX(SHORTINT) ); RETURN x; END RdShtInt; BEGIN IOcheck := defIOcheck; ChopOff := defChopOff; PrefixChar := defPrefixChar; EOF := FALSE; OK := TRUE; IOR := resOk; isSep := IsSepDefault; END FIO.