Back to home page
ISO textfile semantics using Borland products
| Author: |
|
cbfalconer <> |
| Date: |
|
1998/08/14 |
| Forum: |
|
comp.lang.pascal.ansi-iso |
|
|
Following are some of my old files, previously published. They will enable
users of some Borland products to experience ISO i/o semantics. These have
only been tested on TP4 and TP5, and I request any adaptations to later
versions and/or Delphi to be published and freely available.
------------------------------------------------------------
This software is Copyright (c) 1988, 1989 by C.B. Falconer.
This is FREEWARE. To encourage the use of Standard Pascal semantics
I have removed it from the shareware category, and am specifically
permitting use anywhere, including commercial applications. I AM
retaining copyright, and insisting that commercial or shareware
applications acknowledge the origin.
C.B. Falconer, 680 Hartford Tpk, Hamden CT 06517, USA.
-----------------------------------------------------------------
This module provides the same input semantics as ANSI/ISO standard
Pascal for integers, reals, and the extended longint type.
The standard method is far easier to use that the normal Turbo
methods, because input can be parsed on the fly, and no information
is lost. The termination of a field can be detected by the one
character lookahead, missing in Turbo, but provided here by the
function fptr(f), and the associated get(f) procedure.
This system provides an extension over standard Pascal, in that
versions of the read procedures are available which DO NOT ABORT
programs on invalid input, but rather return a boolean function
value (true for error).
For example, if you wish your user to supply an integer value,
with an optional comma delimiter, (and possibly further information
on the same entry), you can do:
write('some prompting message'); prompt(output);
WHILE readx(input, i) THEN BEGIN (* an input error occured *)
readln; (* to flush the remainder of the faulty entry line *)
write('error message and revised prompt'); prompt(output); END;
(* We can now apply all sorts of tests on the delimiter *)
(* using fptr(f) to replace the ISO standard f^ *)
IF fptr(input) = ',' THEN get(input) (* flush a comma delimiter *)
ELSE IF fptr(input) = ' ' THEN skipblks(input)
ELSE IF eoln THEN readln
ELSE BEGIN
(* code for an unrecognized delimiter *); END;
(* and now we can parse the next field, using similar techniques *)
(* Input fields can thus be integers, reals, longs, chars, strings *)
(* or anything else desired. Delimiters can be anything at all. *)
Note that, in accordance with the ANSI/ISO standards, these procedures
all skip leading whitespace, and that line endings are considered to be
whitespace. If you do not want to give the user this option (i.e. an
empty line entry has a special meaning), you can do:
IF eoln THEN (* the special case *)
ELSE BEGIN
skipblks(input); (* remove leading blanks on this line *)
IF eoln THEN (* another special case, only blanks on the line *)
ELSE BEGIN
IF readx???(input, VAR) THEN (* a user input error *)
ELSE (* all is well *)
END; (* something was on the line *)
END; (* the line was non-null *)
Notice that you are getting all your input without assigning, reading
into, and parsing input buffer strings. Rather you can say exactly
what you wish to get.
ESPECIALLY note that, unlike Turbo Pascals procedures, (which do very
funny things when an input field is terminated by anything other than
a blank or eoln), you ALWAYS CAN DETECT the terminating character.
This system has been designed to fit into the usual Turbo system, so
that existing routines will function unchanged.
Please bear in mind the following: (I am omitting the file VAR)
1. readln really means "flush the input line, get any
further input from a new line"
2. readln(VAR) really means "read(VAR); readln". The compiler
expands it to this.
3. read(VAR, VAR) really means "read(var); read(var)". Again, the
compiler expands it to this.
Since the compiler does not know about the TXTFILES unit, it cannot
do the expansions for these procedures. Thus "readint(f, i1, i2)"
will be flagged as an error (equivalent to item 3 above). However
you can easily do the expansion yourself by writing out the code as
"readint(f, i1); readint(f, i2)", and you have the additional option
of testing for errors with "IF readxint(f, i1) THEN ....".
This semantic meaning was not possible across all files (console and
disk) under Turbo3, but is under Turbo 4 and up. This meaning is
specified by the ANSI/ISO standards.
Similar comments apply to write and writeln.
----------------------------------
The following source file is dated 23 April 1989, 7:23:58
----------------------------------
{$IFDEF ver50}
{$A-,B-,D-,E+,F-,I+,L-,N-,O-,R-,S+,V+} (* MUST REMOVE FOR TP4 *)
{$ELSE}
{$R-,S-,I+,D-,T+,F-,V+,B-,N-,L+ }
{$ENDIF}
UNIT txtfiles;
(* Kluges to replace missing STANDARD constructs in Turbo *)
(* Unfortunately these routines cannot be overloaded, as *)
(* are the standard procedures, and must also be referred *)
(* to by new (but similar) names. A proper system imple- *)
(* mentation would avoid these nuisances. *)
(* With this module in place text input can be programmed *)
(* with STANDARD Pascal semantics. The resultant source *)
(* is then portable to any ISO standard system with a *)
(* minimum of fuss. It is bad enough to have to alter std *)
(* procedure names, but absolutely impossible to have to *)
(* rethink the entire i/o process. *)
(* Note that "exists" and "readx" are inserted underneath *)
(* the standard implementations of "reset" and "read". *)
(* These extensions are not normally available in ISO std. *)
(* 1.20 Added filename, page, prompt, overprint. *)
(* 1.10 Added stdin, stdout, stderr, blockdev to report *)
(* on any redirection imposed or general destination *)
(* Copyright (c) 1988 by C.B. Falconer, *)
(* 680 Hartford Tpk., *)
(* Hamden, Ct 06517 (203) 281-1438 *)
(* All rights reserved. *)
(* This is NOT free software, but SHAREWARE. If you use *)
(* this after a suitable test period (1 month suggested) *)
(* you must register it, for a fee of $20. This will *)
(* entitle you to a reasonable amount of telephone advice *)
(* (on your paid call) and future upgrades and support. *)
(* I will also supply registered owners with the source so *)
(* that they can recompile for 80x87 processors. *)
(* The compiled TPU supplied was compiled under Turbo *)
(* Pascal 4, without using any numeric processor. Thus *)
(* it is incompatible with programs using the 80x87. *)
(* This module functions with Turbo Pascal 4.0. *)
(* No warranty whatsover is made, and C.B. Falconer will *)
(* not be liable for any damages or failures. *)
(* If you use this module with the CRT unit, the EOF char *)
(* (CTL-Z) will never appear, UNLESS your program does *)
(* checkeof := true; somewhere before using this *)
(* A note on naming: *)
(* All replacement read procedures are either READ???? or *)
(* READX??? functions. The read procedures abort the *)
(* program on invalid input, while the readx functions *)
(* return TRUE for any error. The ??? is INT, WD, LONG *)
(* or REAL, depending on the input type desired. *)
INTERFACE
USES dos;
TYPE
fntype = string[80]; (* holds a complete file name *)
(* 1---------------1 *)
FUNCTION existxt(VAR f : text) : boolean;
(* Exists is a standard feature of PascalP. *)
(* 1---------------1 *)
PROCEDURE get(VAR f : text);
(* since Turbo never supplied it, we can use the original name *)
(* 1---------------1 *)
PROCEDURE filename(VAR f : text; VAR fn : fntype);
(* Highly Turbo specific. This allows other procedures/functions *)
(* to extract the filename when passed only the actual file. You *)
(* thus do not need to retain a user supplied name elsewhere. *)
(* THIS IS NOT A FUNCTION - thus can be ported to Std. Systems. *)
(* 1---------------1 *)
PROCEDURE page(VAR f : text); (* Missing in Turbo *)
(* 1---------------1 *)
PROCEDURE overprint(VAR f : text);
(* Next line overprints this one. Use like "writeln" *)
(* 1---------------1 *)
PROCEDURE prompt(VAR f : text);
(* Forces buffer flushing without eoln. Null in Turbo. *)
(* For logical equivalence with output buffered systems *)
(* If your source uses this whenever prompting the user *)
(* the code will be portable to other Pascal systems. *)
(* e.g "write(Enter your name:); prompt(output);" *)
(* 1---------------1 *)
FUNCTION version(show : boolean) : integer;
(* returns the version number. Show causes a console message *)
(* 1---------------1 *)
FUNCTION fptr(VAR f : text) : char;
(* Allows replacing the STANDARD construct f^ by "fptr(f)" *)
(* A proper system implementation actually returns a pointer *)
(* so that "f^ := char" is possible. Not allowed here. *)
(* 1---------------1 *)
PROCEDURE skipblks(VAR f : text);
(* Skips blanks, but NOT eolns until first non-blank char *)
(* A tab is considerd a blank. Must be separated due to the *)
(* non-standard Turbo eoln implementation. *)
(* 1---------------1 *)
PROCEDURE skipwhite(VAR f : text);
(* skips blanks and eolns until first non-blank char *)
(* This hides the lack of f^ = ' ' in Turbo when eoln is true *)
(* 1---------------1 *)
FUNCTION readxwd(VAR f : text; VAR w : word) : boolean;
(* returns true for input error, when fptr(f) is bad char *)
(* Replacement for standard read(word) with error checks. *)
(* Unlike Turbo, reading terminates on the 1st non digit, *)
(* but only after leading blanks have been skipped. *)
(* A feature of PascalP for reals/integers/words (readx). *)
(* Note that, apart from the non-standard Std procedure *)
(* nomenclature, this is written entirely in STD Pascal. *)
(* On exit fptr(f) will return the terminating character *)
(* On overflow input is scanned to a non-numeric char. *)
(* 1---------------1 *)
FUNCTION readxint(VAR f : text; VAR i : integer) : boolean;
(* returns true for input error, when fptr(f) is bad char *)
(* Replacement for standard read(integer) with error chks *)
(* Unlike Turbo, reading terminates on the 1st non digit, *)
(* but only after leading blanks and (optional) sign have *)
(* been skipped. A feature of PascalP for reals/integers *)
(* Note that, apart from the non-standard Std procedure *)
(* nomenclature, this is written entirely in STD Pascal. *)
(* On exit fptr(f) will return the terminating character *)
(* On overflow input is scanned to a non-numeric char. *)
(* 1---------------1 *)
PROCEDURE readint(VAR f : text; VAR i : integer);
(* replacement for STANDARD Pascal read(f, integer), which is *)
(* defined to cause a system error and halt on invalid input. *)
(* Unlike Turbo, reading terminates on the 1st non digit, but *)
(* only after leading blanks and (optional) sign have been *)
(* skipped. Again, written in STD Pascal. *)
(* On exit fptr(f) will return the terminating character. *)
(* On overflow input is scanned to a non-numeric character. *)
(* 1---------------1 *)
PROCEDURE readwd(VAR f : text; VAR w : word);
(* This does not exist in STANDARD Pascal (only integer), but *)
(* this is how it would look if it did. This is defined to *)
(* cause a system error and halt on invalid input. *)
(* Unlike Turbo, reading terminates on the 1st non digit, but *)
(* only after leading blanks and (optional) sign have been *)
(* skipped. Again, written in STD Pascal. *)
(* On exit fptr(f) will return the terminating character. *)
(* On overflow input is scanned to a non-numeric character. *)
(* 1---------------1 *)
FUNCTION readxlong(VAR f : text; VAR l : longint) : boolean;
(* Just like readxint, but for longints. Always signed. *)
(* 1---------------1 *)
FUNCTION readxreal(VAR f : text; VAR r : real) : boolean;
(* Again, like readxint, but for reals. Also see readreal below *)
(* 1---------------1 *)
PROCEDURE readreal(VAR f : text; VAR r : real);
(* Replacement for the standard read(f, r : real), which aborts *)
(* on bad entries. As in STD Pascal, the real is terminated by *)
(* the first character which cannot be a part of the value, and *)
(* fptr(f) accesses that terminating character. Note that this *)
(* can accept an unlimited length string of digits, eg leading *)
(* zeroes, and trailing zeroes after the decimal pt, none of *)
(* which really affect the value. Leading blanks and eolns are *)
(* skipped. Action on real over/underflow depends on the system *)
(* 1---------------1 *)
FUNCTION blockdev(VAR f : text) : boolean;
(* Is the file attached to a disk file *)
(* 1---------------1 *)
FUNCTION stdin(VAR f : text) : boolean;
(* Is the file attached to the console device for input *)
(* 1---------------1 *)
FUNCTION stdout(VAR f : text) : boolean;
(* is the file attached to the console device for output *)
(* 1---------------1 *)
FUNCTION stderr(VAR f : text) : boolean;
(* is the file attached to the monitor for output *)
IMPLEMENTATION
CONST (* really initialized variables *)
digs : SET OF char = ['0'..'9'];
signs : SET OF char = ['+', '-'];
errornum : integer = 0;
errorat : pointer = NIL;
saverrproc : pointer = NIL;
ver = 120;
copyrite = ' Copyright (c) 1988 by C.B. Falconer';
chrdev = $80; (* 0 bit implies file (block) device *)
istdin = $01;
istdout = $02;
istderr = $04;
(* 1---------------1 *)
FUNCTION version(show : boolean) : integer;
(* returns the version number. Show causes a console message *)
BEGIN (* version *)
version := ver;
IF show THEN BEGIN
write('TXTFILES module Version ', ver DIV 100 : 1, '.');
IF ver MOD 100 < 10 THEN write('0');
writeln(ver MOD 100, '.', copyrite); END;
END; (* version *)
(* 1---------------1 *)
FUNCTION existxt(VAR f : text) : boolean;
BEGIN (* existxt *)
{$i-}
reset(f);
existxt := ioresult = 0; {$i+}
END; (* existxt *)
(* 1---------------1 *)
PROCEDURE filename(VAR f : text; VAR fn : fntype);
(* Highly Turbo specific *)
TYPE
textbuf = ARRAY[0..127] OF char;
textrec = RECORD
handle : word; (* MSDOS file handle *)
mode : word; (* 0=read, 1=write, 2=rdwrt *)
bufsize : word; (* of textbuf *)
private : word;
bufpos : word; (* next char pointer *)
bufend : word; (* size of buffer valide *)
bufptr : ^textbuf; (* location, may not be buffer below *)
openfunc : pointer; (* pointers to routines, normally *)
inoutfunc : pointer; (* in system unit, but may not be *)
flushfunc : pointer;
closefunc : pointer;
(* reuse the userdata field for ISO std i/o semantics (plan) *)
getpends : boolean; (* assumed initialized to false *)
eolnflag : boolean; (* so we can have fchar = ' ' *)
eoflag : boolean; (* delay so final get functions *)
fchar : char;
userdata : ARRAY[5..16] OF byte; (* available *)
name : ARRAY[0..79] OF char;
buffer : textbuf;
END; (* textrec *)
VAR
i : integer;
BEGIN (* filename *)
fn := ''; i := 0;
WHILE (i < 79) AND (textrec(f).name[i] <> chr(0)) DO BEGIN
fn := concat(fn, textrec(f).name[i]); i := succ(i); END;
END; (* filename *)
(* 1---------------1 *)
PROCEDURE page(VAR f : text); (* Missing in Turbo *)
BEGIN (* page *)
write(f, chr(12));
END; (* page *)
(* 1---------------1 *)
PROCEDURE overprint(VAR f : text);
(* Next line overprints this one *)
BEGIN (* overprint *)
write(f, chr(13));
END; (* overprint *)
(* 1---------------1 *)
PROCEDURE prompt(VAR f : text);
(* forces buffer flushing without eoln *)
BEGIN (* prompt *)
END; (* prompt *)
(* 1---------------1 *)
PROCEDURE get(VAR f : text);
(* Together with fptr below, implements the ISO/ANSI semantics *)
VAR
junk : char;
BEGIN (* get *)
read(f, junk); (* discarding the old value of fptr *)
END; (* get *)
(* 1---------------1 *)
FUNCTION fptr(VAR f : text) : char;
(* A replacement for the ISO/ANSI Standard Pascal operation f^ *)
(* With this it is possible to build well behaved input routines *)
(* to convert text to integers, reals, etc. and avoid crashies *)
(* on erroneous user input. The standard usage of f^ = ' ' at *)
(* EOF is not implemented, because of Turbos internal operation. *)
CONST
eofmark = 26; (* 01ah = CTL-Z *)
(* 2---------------2 *)
FUNCTION fptrc(VAR f : text) : char;
(* For this to function, on a text file, you MUST call eof(f) *)
(* first, which ensures the char is present in the internal *)
(* file buffer. This procedure extracts it. *)
inline(
$5f/ {pop di; ^file (off) }
$07/ {pop es (seg) }
$26/ $8B/ $5D/ $08/ {mov bx,es:[di+8]; buffer index }
$26/ $C4/ $7D/ $0C/ {les di,es:[di+0ch]; ^buffer }
$26/ $8A/ $01); {mov al,es:[bx+di]; get char }
(* 2---------------2 *)
BEGIN (* fptr *)
{$i-}
IF eof(f) {$i+} THEN fptr := chr(eofmark)
ELSE IF ioresult <> 0 THEN fptr := chr(eofmark)
ELSE fptr := fptrc(f);
END; (* fptr *)
(* 1---------------1 *)
PROCEDURE skipblks(VAR f : text);
VAR
ch : char;
BEGIN (* skipblks *)
ch := fptr(f);
WHILE (ch = ' ') OR (ch = chr(9)) DO BEGIN
get(f); ch := fptr(f); END;
END; (* skipblks *)
(* 1---------------1 *)
PROCEDURE skipwhite(VAR f : text);
BEGIN (* skipwhite *)
REPEAT (* caution - Turbo returns eoln at eof *)
IF eoln(f) AND NOT eof(f) THEN readln(f);
skipblks(f);
UNTIL eof(f) OR NOT eoln(f);
END; (* skipwhite *)
(* 1---------------1 *)
FUNCTION readxwd(VAR f : text; VAR w : word) : boolean;
VAR
value,
digit : word;
BEGIN (* readxwd *)
digs := ['0'..'9'];
readxwd := true; w := 0; value := 0; (* default error *)
skipwhite(f);
IF NOT eof(f) THEN BEGIN
IF fptr(f) IN digs THEN readxwd := false; (* found value *)
WHILE fptr(f) IN digs DO BEGIN
digit := ord(fptr(f)) - ord('0');
IF (value < 6553) OR ((value = 6553) AND (digit < 6)) THEN
value := 10 * value + digit
ELSE readxwd := true; (* overflow *)
get(f); END;
w := value; END;
END; (* readxwd *)
(* 1---------------1 *)
FUNCTION readxint(VAR f : text; VAR i : integer) : boolean;
VAR
negative : boolean;
value : word;
BEGIN (* readxint *)
readxint := true; i := 0; negative := false; (* default error *)
skipwhite(f);
IF NOT eof(f) THEN BEGIN
value := 0; negative := false;
IF fptr(f) IN signs THEN BEGIN (* absorbing any '+' *)
negative := fptr(f) = '-'; get(f); END;
IF fptr(f) IN digs THEN (* found value *)
readxint := readxwd(f, value);
IF negative AND (value <= 32768) THEN i := -value
ELSE IF value <= 32767 THEN i := value
ELSE readxint := true; END; (* overflow *)
END; (* readxint *)
(* 1---------------1 *)
FUNCTION callersaddr : pointer;
(* relies on the fact that bp always points to the return addr *)
(* and that this is a FAR return, i.e. via an entry to a unit. *)
inline(
$C4/ $46/ $02/ {les ax,[bp+2] }
$8C/ $C2); {mov dx,es; now dx:ax is address}
(* 1---------------1 *)
PROCEDURE readint(VAR f : text; VAR i : integer);
BEGIN (* readint *)
IF readxint(f, i) THEN BEGIN (* invalid numeric format error *)
errorat := callersaddr; errornum := 106;
halt(errornum); END;
END; (* readint *)
(* 1---------------1 *)
PROCEDURE readwd(VAR f : text; VAR w : word);
BEGIN (* readwd *)
IF readxwd(f, w) THEN BEGIN (* invalid numeric format error *)
errorat := callersaddr; errornum := 106;
halt(errornum); END;
END; (* readwd *)
(* 1---------------1 *)
FUNCTION readxlong(VAR f : text; VAR l : longint) : boolean;
CONST
threshold = 214748363;
VAR
negative : boolean;
digit : integer;
value : longint;
BEGIN (* readxlong *)
readxlong := true; l := 0; negative := false; (* default error *)
skipwhite(f);
IF NOT eof(f) THEN BEGIN
value := 0; negative := false;
IF fptr(f) IN signs THEN BEGIN (* absorbing any '+' *)
negative := fptr(f) = '-'; get(f); END;
IF fptr(f) IN digs THEN BEGIN (* found value *)
readxlong := false; (* no error unless overflow *)
WHILE fptr(f) IN digs DO BEGIN
digit := ord(fptr(f)) - ord('0');
IF value <= threshold THEN value := value * 10 + digit
ELSE readxlong := true; (* overflow *)
get(f); END;
IF negative THEN l := -value
ELSE l := value; END;
END;
END; (* readxlong *)
(* 1---------------1 *)
FUNCTION readxreal(VAR f : text; VAR r : real) : boolean;
(* true for error *)
LABEL 10; (* error exit *)
VAR
maxsig,
significand : longint;
exponent : integer;
decpt : integer;
havedigit,
minus : boolean;
BEGIN (* readxreal *)
minus := false; r := 0.0; readxreal := true; havedigit := false;
significand := 0; decpt := 0; exponent := 0; (* defaults *)
maxsig := $7ffffff5 DIV 10; (* before nextch can overflow *)
skipwhite(f);
IF fptr(f) IN signs THEN BEGIN
minus := fptr(f) = '-'; get(f); END;
IF fptr(f) IN digs + ['.'] THEN BEGIN
readxreal := false; (* should be able to get a value *)
WHILE (fptr(f) IN digs) AND (significand < maxsig) DO BEGIN
significand := significand * 10 + (ord(fptr(f)) - ord('0'));
havedigit := true; get(f); END;
WHILE fptr(f) IN digs DO BEGIN (* gobble non-significants *)
decpt := succ(decpt); get(f); END;
IF fptr(f) = '.' THEN BEGIN
get(f);
IF NOT (havedigit OR (fptr(f) IN digs)) THEN BEGIN
readxreal := true; GOTO 10; END
ELSE BEGIN
WHILE (fptr(f) IN digs) AND (significand < maxsig) DO BEGIN
significand := significand * 10 + (ord(fptr(f)) - ord('0'));
decpt := pred(decpt); get(f); END;
WHILE fptr(f) IN digs DO get(f); END; (* eat non-significants *)
END;
(* now have to worry about E+-nn appended *)
IF fptr(f) IN ['E', 'e'] THEN BEGIN
get(f);
IF NOT (fptr(f) IN digs + signs) THEN BEGIN
readxreal := true; GOTO 10; END
ELSE IF readxint(f, exponent) THEN BEGIN
readxreal := true; GOTO 10; END;
END;
(* Now we have valid significand, decpt, exponent *)
exponent := exponent + decpt;
r := significand;
WHILE exponent > 0 DO BEGIN
r := 10.0 * r; exponent := pred(exponent); END;
WHILE exponent < 0 DO BEGIN
r := r / 10.0; exponent := succ(exponent); END;
IF minus THEN r := -r; END;
10: END; (* readxreal *)
(* 1---------------1 *)
PROCEDURE readreal(VAR f : text; VAR r : real);
BEGIN (* readreal *)
IF readxreal(f, r) THEN BEGIN (* invalid numeric format error *)
errorat := callersaddr; errornum := 106;
halt(errornum); END;
END; (* readreal *)
(* 1---------------1 *)
{$F+}
PROCEDURE txterrproc; (* MUST be a FAR procedure *)
VAR
errorptr : RECORD
offset : integer;
segment : integer;
END ABSOLUTE errorat;
BEGIN (* txterrproc *)
exitproc := saverrproc;
IF errornum <> 0 THEN BEGIN
exitcode := errornum;
writeln('Invalid numerical entry or overflow ');
errorptr.segment := errorptr.segment - prefixseg - 16;
erroraddr := errorat; END;
END; (* txterrproc *)
(* 1---------------1 *)
FUNCTION qfstatus(VAR f; VAR s : integer) : boolean;
(* returns false if file not open or open for random access *)
VAR
ff : text ABSOLUTE f;
regs : registers;
BEGIN (* qfstatus *)
qfstatus := false; (* default *)
WITH regs, textrec(ff) DO
IF (mode = fminput) OR (mode = fmoutput) OR (mode = fminout) THEN BEGIN
ax := $4400; bx := handle;
msdos(regs); (* get device info *)
IF (flags AND fcarry) = 0 THEN BEGIN
qfstatus := true; s := integer(dx); END;
END;
END; (* qfstatus *)
(* 1---------------1 *)
FUNCTION blockdev(VAR f : text) : boolean;
(* Is the file attached to a disk file *)
VAR
fstatus : integer;
BEGIN (* blockdev *)
IF qfstatus(f, fstatus) THEN
blockdev := ((fstatus AND chrdev = 0))
ELSE blockdev := false;
END; (* blockdev *)
(* 1---------------1 *)
FUNCTION stdin(VAR f : text) : boolean;
(* Is the file attached to the console device *)
VAR
fstatus : integer;
BEGIN (* stdin *)
IF qfstatus(f, fstatus) THEN
stdin := ((fstatus AND chrdev <> 0)) AND
((fstatus AND istdin) <> 0)
ELSE stdin := false;
END; (* stdin *)
(* 1---------------1 *)
FUNCTION stdout(VAR f : text) : boolean;
VAR
fstatus : integer;
BEGIN (* stdout *)
IF qfstatus(f, fstatus) THEN
stdout := ((fstatus AND chrdev <> 0)) AND
((fstatus AND istdout) <> 0)
ELSE stdout := false;
END; (* stdout *)
(* 1---------------1 *)
FUNCTION stderr(VAR f : text) : boolean;
VAR
fstatus : integer;
BEGIN (* stderr *)
IF qfstatus(f, fstatus) THEN
stderr := ((fstatus AND chrdev <> 0)) AND
((fstatus AND istderr) <> 0)
ELSE stderr := false;
END; (* stderr *)
(* 1---------------1 *)
BEGIN (* txtfiles initialization routine *)
saverrproc := exitproc; exitproc := addr(txterrproc);
IF version(false) <> ver THEN halt;
END. (* txtfiles *)
--------------------------------------
Chuck Falconer <>
-----== Posted via Deja News, The Leader in Internet Discussion ==-----
Back to home page