I2010506%DBSTU1.BITNET@cunyvm.cuny.edu (02/20/90)
TURBO PASCAL
procedure READ_VALUE
The READVALUe UNIT for TP4.0 ++ is a unit that makes it possible to
simulate the INPUT^ (Standard PASCAL) in TP. The PROCEDURE READ_VALUE is
used just like the standard procedure READ, except that it works only on
external TEXT files. Called once, it returnes the value of the NEXT
figure in the input file, regardless of anything standing before that
figure. Comments, SPACE, CR, LF and all other characters are skipped.
The type of the returned value is EXTENDED, if you do not want this,
change it. READ_VALUE does handle figures written by BASIC programs
(".78" instead of "0.78") correctly. If you are trying to read a value
after EOF, READ_VALUE returns zero as a value, so alway be sure to check
EOF after calling READ_VALUE to assure that the returned value is
indeed valid.
In case of I/O-Error READ_VALUE displays the complete DOS error in plain
text and prompts you for akey to press. This does ONLY work with DOS 3.0
or higher. In any other case, you are on your own for an error routine.
READ_VALUE.TPU is compiled under TP5.5, if you have another version, you
will have to re-compile the source code.
Other sources included: Cursor_Vanish : makes the cursor vanish
Cursor_Restore : restores the previous cursor
Extended_Error_code : returnes the complete DOS
error
StandBy : waits for the user to press a key
Thanks to all the people cited in the source code for their
contributions.
This is PUBLIC DOMAIN software. If you have any suggestions to improve
this software, please contact me.
Christian Bttger
________________________________________________________________________________
Christian Boettger phone: (+49) (0)531/391-5113
mail: Institut fuer Metallphysik und Nukleare Festkoerperphysik,
(room -167/-168), Technische Universitaet Braunschweig,
Mendelssohnstrasse 3, D-3300 Braunschweig,
Bundesrepublik Deutschland; FRG / RFA
________________________________________________________________________________
EARN: I2010506DBSTU1.BITNET
InterNet: boettgerria.ccs.uwo.CA
boettgerrz.tu-braunschweig.dbp.DE
X.400: S=boettger; OU=rz; P=tu-braunschweig; A=dbp; C=de;
UUCP / UseNet:
boettgerria.UUCP
(whereever)|uunet|watmath|ria|boettger
(whereever)|uunet|boettgerhydra.uwo.CA
(whereever)|uunet|mcvax|unido|i2010506DBSTU1.BITNET
********************************************************************************I2010506%DBSTU1.BITNET@cunyvm.cuny.edu (02/20/90)
(******************************************************************
This TP UNIT simulates STANDARD PASCAL input^ for real values.
I wrote this using the ERRORCODe UNIT written by Nelson Ard.
________________________________________________________________________________
Christian Boettger phone: (+49) (0)531/391-5113
mail: Institut fuer Metallphysik und Nukleare Festkoerperphysik,
(room -167/-168), Technische Universitaet Braunschweig,
Mendelssohnstrasse 3, D-3300 Braunschweig, Bundesrepublik Deutschland
FRG / RFA
________________________________________________________________________________
EARN: I2010506@DBSTU1.BITNET InterNet: boettger@julian.uwo.CA
UseNet: boettger@julian.UUCP
X.400: boettger@rz.tu-braunschweig.dbp.DE
( S=boettger; OU=rz; P=tu-braunschweig; A=dbp; C=de; )
UUCP / UseNet:
(whereever)!uunet!watmath!julian!boettger
(whereever)!uunet!boettger@hydra.uwo.CA
(whereever)!uunet!mcvax!unido!i2010506@DBSTU1.BITNET
******************************************************************************)
{$A+,B+,D+,E+,F-,I+,L+,N+,O+,R-,S+,V+}
{$M 65520,0,655360}
unit readvalu;
interface
uses dos,crt;
{ERRORCOD}
(************************************************************************
Received: from CUNYVM by CUNYVM.BITNET (Mailer R2.03B) with BSMTP id 6339; Tue,
13 Feb 90 21:05:12 EST
Received: from cod.nosc.mil by CUNYVM.CUNY.EDU (IBM VM SMTP R1.2.2MX) with TCP;
Tue, 13 Feb 90 21:05:09 EST
Received: by cod.nosc.mil (5.59/1.27)
id AA01529; Tue, 13 Feb 90 18:06:29 PST
Date: Tue, 13 Feb 90 18:06:29 PST
From: howell@cod.nosc.mil (Susan Howell)
Message-Id: <9002140206.AA01529@cod.nosc.mil>
To: ADD.@BOETT
Cc: howell@cod.nosc.mil
Subject: Source for supporting unit ERRORCOD
@
SOURCE LISTING FOR UNIT ERRORCOD
***********************************************************************)
(*******************************************************************)
(**** ERRORCOD.PAS ****)
(**** This unit maps MS-DOS error codes returned by the ****)
(**** operating system to strings to give the operator a ****)
(**** human readable response. ****)
(**** ****)
(**** Reference: MS-DOS Version 3 Programmer's Utility Pack ****)
(**** MS-DOS Reference Guide Volume 1 ****)
(**** 1986, pp. 4.86-4.88, 4.254-4.257. ****)
(**** ****)
(**** Developed by Nelson Ard ****)
(**** ****)
(**** Last modificaton Sep 89 ****)
(*******************************************************************)
CONST Error_Code : ARRAY [0..88] OF
string[40] = ('No errors',
'Invalid function code',
'File not found',
'Path not found',
'No file handles left',
'Access denied',
'Invalid handle',
'Memory control blocks destroyed',
'Insufficient memory',
'Invalid memory block address',
'Invalid environment',
'Invalid format',
'Invalid access code',
'Invalid data',
'RESERVED error code',
'Invalid drive',
'Attempt to remove the current directory',
'Not same device',
'No more files',
'Disk is write-protected',
'Bad disk unit',
'Drive not ready',
'Invalid disk command',
'CRC error',
'Invalid length (disk operation)',
'Seek error',
'Not an MS-DOS disk',
'Sector not found',
'Out of paper',
'Write fault',
'Read fault',
'General failure',
'Sharing violation',
'Lock violation',
'Wrong disk',
'FCB unavailable',
'RESERVED error code',
'RESERVED error code',
'RESERVED error code',
'RESERVED error code',
'RESERVED error code',
'RESERVED error code',
'RESERVED error code',
'RESERVED error code',
'RESERVED error code',
'RESERVED error code',
'RESERVED error code',
'RESERVED error code',
'RESERVED error code',
'RESERVED error code',
'Network request not supported',
'Remote computer not listening',
'Duplicate name on network',
'Network name not found',
'Network busy',
'Network device no longer exists',
'Net BIOS command limit exceeded',
'Network adapter hardware error',
'Incorrect response from network',
'Unexpected network error',
'Incompatible remote adapt',
'Print queue full',
'Queue not full',
'Not enough space for print file',
'Network name was deleted',
'Access denied',
'Network device type incorrect',
'Network name not found',
'Network name limit exceeded',
'Net BIOS session time exceeded',
'Temporarily paused',
'Network request not accepted',
'Print or disk redirection is paused',
'RESERVED error code',
'RESERVED error code',
'RESERVED error code',
'RESERVED error code',
'RESERVED error code',
'RESERVED error code',
'RESERVED error code',
'File exits',
'Duplicate File Control Block',
'Cannot make',
'Interrupt 24 failure',
'Out of structures',
'Already assigned',
'Invalid password',
'Invalid parameter',
'Net write fault');
CONST Error_Class : ARRAY [1..12] OF string[40] =
('Out of a resource',
'Temporary situation',
'Permission problem',
'Internal error in system software',
'Hardware failure',
'System software failure',
'Application program error',
'File or item not found',
'File or item of invalid format',
'File or item interlocked',
'Media failure - storage medium',
'Unknown error');
Recommended_Error_Action : ARRAY [1..7] OF String[40] =
('Retry, then prompt user',
'Retry after a pause',
'Reprompt user to reenter',
'Terminate with clean up',
'Terminate immediately',
'Observe only',
'Retry after correcting fault');
Error_Locus : ARRAY [1..5] OF String[40] =
('Unknown',
'Random Access block device',
'Related to a network',
'Related to serial access device',
'Related to RAM');
PROCEDURE Extended_Error_Code (VAR Error_Code : INTEGER;
VAR Error_Class : Byte;
VAR Error_Locus : Byte);
{ Following an error code returned by an MS-DOS function call or
I/O function, this may be called for amplification on the
error }
{END OF ERRORCOD}
Procedure Cursor_Vanish(VAR W : Word);
Procedure Cursor_Restore(VAR W : Word );
procedure Ende(var raus : boolean);
procedure StandBy;
procedure GetDOSErrorMessage (code : integer; var message : string);
procedure GetCompleteDOSErrorMessage (code : integer;
var Error,error_cl,error_l : string);
procedure read_value(var datei : text; var wert : extended);
implementation
PROCEDURE Extended_Error_Code (VAR Error_Code : INTEGER;
VAR Error_Class : Byte;
VAR Error_Locus : Byte);
Var Regs : Registers;
BEGIN
Regs.AH := $59;
Regs.BX := 0;
Intr($21, Regs);
Error_Code := Regs.AX;
Error_Class := Regs.BH;
Error_Locus := Regs.CH;
END;
(***********************************************************************
Received: by DEARN (Mailer R2.03B) id 8469; Wed, 14 Feb 90 18:27:58 MEZ
Date: Wed, 14 Feb 90 01:19:57 CST
Reply-To: Borland Pascal Discussion Group <PASCAL-L@YALEVM>
Sender: Borland Pascal Discussion Group <PASCAL-L@YALEVM>
From: "John M. Kelsey" <C445585@UMCVMB.BITNET>
Subject: Cursor questions
To: "Christian Boettger, TU Braunschweig, FRG" <I2010506@DBSTU1>
I finally got around to looking up the three BIOS interrupst I needed
to call and got a working package to make the cursor vanish, then restore
it to the same kind of cursor it was before. (Otherwise, a program which
uses different cursor-sizes at different times, and uses a generic routine
to set the cursor off and back to the small cursor, may have the cursor
size change every time, say, a window is blown open.) I'll type these two
procedures in here.
*************************************************************************)
Procedure Cursor_Vanish(VAR W : Word);
VAR Regs : Registers;
Begin WITH Regs DO Begin
AH := $03;
BH := $00;
Intr($10,Regs);
W := CX;
AH := $01;
CL := $20;
CH := $20;
Intr($10,Regs);
End End; { End procedure }
Procedure Cursor_Restore(VAR W : Word );
VAR Regs : Registers;
Begin WITH Regs DO Begin
AH := $01;
BH := $00;
CX := W;
Intr($10,Regs);
End End; { End procedure }
(*************************************************************************
These two procedures have to be compiled with the DOS unit available.
(After the Program line, put uses DOS;)
I've tried to be pretty careful typing these in, but I don't even pretend
to be perfect, so if you want to use these procedures, I'd recommend typing
them in, then saving them, then running a program once as a test. (A test
program for these two should be pretty simple.)
Also, regarding the screen saving procedures in _Turbo Pascal, the
Complete Reference_, I've written some routines that implement a simple
stack of saved screens, so that you can simply push the present screen
state, draw your menu, then pop the last screen state off the stack.
If anyone's interested, I should be able to upload the routines from a PC
disk....
--John Kelsey, C445585@UMCVMB
**************************************************************************)
procedure Ende (var raus : boolean);
var screen : string;
x_pos : 1..80;
antwort : char;
BEGIN
raus := FALSE;
ClrScr;
screen := 'Programm wirklich beenden (j/n) ? ';
x_pos := (80-length(screen)) DIV 2;
GotoXY(x_pos,12);
Write(screen);
Readln(antwort);
IF antwort = 'j' THEN raus := TRUE;
END;
procedure StandBy;
var x,y : byte;
muell : char;
cursor : word;
begin
Cursor_Vanish(cursor);
x:=whereX; y:= WhereY;
GotoXY(20,25);
HighVideo;
write('Weiter mit beliebiger Taste');
NormVideo;
repeat until keypressed;
muell := ReadKey;
GotoXY(20,25); write(' ');
GotoXY(x,y);
Cursor_Restore(cursor);
end;
procedure GetDOSErrorMessage (code : integer; var message : string);
begin
case code of
0 : message := 'OK';
2 : message := 'Datei nicht gefunden';
3 : message := 'Suchweg nicht gefunden';
5 : message := 'Zugriff verweigert';
6 : message := 'Handle nicht definiert/ung}ltig';
8 : message := 'nicht gen}gend Hauptspeicher frei';
10 : message := 'Environment-Parameter ung}ltig';
11 : message := 'ung}ltiges Befehlsformat';
18 : message := 'keine weiteren Dateieintr{ge/Datei nicht vorhanden';
else begin
Str(code,message);
message := 'DOS - Fehler Nr. ' + message + ' = ' + Error_Code[code];
end;
end;
end;
procedure GetCompleteDOSErrorMessage (code : integer;
var Error,error_cl,error_l : string);
var class,locus : byte;
fehler : integer;
begin
Extended_Error_Code(fehler,class,locus);
Error := Error_Code[fehler];
error_cl := Error_Class[class];
error_l := Error_Locus[locus];
if code <> fehler then writeln('NANUNANA!!!');
end;
procedure read_value(var datei : text; var wert : extended);
type vorzeichen = (plus,minus,none);
zeichentyp = (trennung,sign,value,point,garbage);
const o_komma = Ord(',');
o_space = Ord(' ');
o_semi = Ord(';');
o_lf = 10;
o_cr = 13;
o_null = Ord('0');
o_neun = Ord('9');
o_punkt = Ord('.');
o_e_kl = Ord('e');
o_e_gr = Ord('E');
o_plus = Ord('+');
o_minus = Ord('-');
null = '0';
var puffer1,puffer2 : char;
weiter,raus,basic : boolean;
akt_vorz,alt_vorz,
vorz2 : vorzeichen;
puffer_art,
puffer_art_2 : zeichentyp;
function CheckDelimiter(test : char) : boolean;
var o_test : byte;
begin
o_test := Ord(test);
if ((o_test=o_komma) or (o_test=o_space) or (o_test=o_semi)
or (o_test=o_lf) or (o_test=o_cr))
then CheckDelimiter := true
else CheckDelimiter := false;
end;
function CheckValue(test : char) : boolean;
var o_test : byte;
begin
o_test := Ord(test);
if ((o_test>=o_null) and (o_test<=o_neun))
then CheckValue := true
else CheckValue := false;
end;
function CheckPunkt(test : char) : boolean;
begin
if (Ord(test)=o_punkt)
then CheckPunkt := true
else CheckPunkt := false;
end;
function CheckE(test : char) : boolean;
var o_test : byte;
begin
o_test := Ord(test);
if ((o_test=o_e_kl) or (o_test=o_e_gr))
then CheckE := true
else CheckE := false;
end;
function CheckPlus(test : char) : boolean;
begin
if (Ord(test)=o_plus)
then CheckPlus := true
else CheckPlus := false;
end;
function CheckMinus(test : char) : boolean;
begin
if (Ord(test)=o_minus)
then CheckMinus := true
else CheckMinus := false;
end;
function CheckIOResult : boolean;
var code : integer;
error_m,error_cl,error_l : string;
begin
{$I-}
code := IOResult;
if code<>0
then begin
CheckIOResult := false;
GetCompleteDOSErrorMessage(code,error_m,error_cl,error_l);
writeln('I/O-Fehler ',code,' --> ',error_m);
writeln('I/O-Fehler-Klasse ',error_cl);
writeln('I/O-Fehler-Locus ',error_l);
StandBy;
end
else CheckIOResult := true;
end;
function puffertest(puffer : char; var vorz : vorzeichen) : zeichentyp;
begin {of puffertest}
puffertest := garbage;
if CheckMinus(puffer) then vorz := minus
else if CheckPlus(puffer)
then vorz := plus
else vorz := none;
if vorz<>none
then puffertest := sign
else if CheckDelimiter(puffer)
then puffertest := trennung
else if CheckPunkt(puffer)
then puffertest := point
else if CheckValue(puffer) then puffertest := value;
end; {of puffertest}
procedure skip(var datei : text; var vorz : vorzeichen; var puffer : char;
var puffertyp : zeichentyp);
begin {of skip}
{$I-}
vorz := none;
puffertyp := garbage;
repeat
if eoln(datei) then readln(datei);
read(datei,puffer);
if not CheckIOResult then begin
ende(raus);
if raus then halt(300);
end;
puffertyp := puffertest(puffer,vorz);
{
case vorz of
plus : write('P');
minus: write('M');
none : write('n');
end;
}
until ((puffertyp<>garbage) or eof(datei));
end; {of skip}
procedure PickUp(var datei : text; basic : boolean; puffer : char;
VAR wert : extended );
var zahl : string;
stop,punkt,raus : boolean;
puffer2 : char;
fehler : integer;
begin {of PickUp}
{$I-}
zahl := '';
punkt := false;
stop := false;
if basic then begin zahl := '0.'; punkt := true; end;
zahl := zahl+puffer;
while ((not eoln(datei) and (not stop))) do
begin
read(datei,puffer);
if not CheckIOResult then begin
ende(raus);
if raus then halt(300);
end;
if ((CheckPunkt(puffer) and punkt) or CheckDelimiter(puffer))
then stop := true
else if (CheckValue(puffer) or (CheckPunkt(puffer) and (not punkt)))
then begin
zahl := zahl+puffer;
if CheckPunkt(puffer) then punkt := true;
end
else if (not CheckE(puffer))
then stop := true
else begin
if (not eoln(datei))
then begin
read(datei,puffer2);
if not CheckIOResult
then begin
ende(raus);
if raus then halt(300);
end;
if (CheckMinus(puffer2) or (CheckPlus(puffer2)))
then zahl := zahl+puffer+puffer2
else stop := true;
end
else stop := true;
end;
end;
Val(zahl,wert,fehler);
if fehler<>0 then begin
HighVideo;
writeln('Fehler beim Einlesen von >',zahl,'< an Position ',fehler,' !!');
NormVideo;
StandBy;
ende(raus);
if raus then halt(301);
end;
end; {of PickUp}
begin {of READ_VALUE}
{$I-}
akt_vorz := none;
alt_vorz := none;
weiter := true;
wert :=0;
while ((not eof(datei)) and weiter) do
begin
basic := false;
alt_vorz := akt_vorz;
skip(datei,akt_vorz,puffer1,puffer_art);
case puffer_art of
value : begin
akt_vorz := alt_vorz;
PickUp(datei,basic,puffer1,wert);
weiter := false;
end;
point : begin
read(datei,puffer2);
if not CheckIOResult then begin
ende(raus);
if raus then halt(300);
end;
puffer_art_2 := puffertest(puffer2,vorz2);
case puffer_art_2 of
value : begin
basic := true;
akt_vorz := alt_vorz;
PickUp(datei,basic,puffer2,wert);
weiter := false;
end;
sign : akt_vorz := vorz2;
trennung : akt_vorz := none;
point : akt_vorz := none;
end;
end;
trennung : akt_vorz := none;
sign : begin
read(datei,puffer2);
if not CheckIOResult then begin
ende(raus);
if raus then halt(300);
end;
puffer_art_2 := puffertest(puffer2,vorz2);
case puffer_art_2 of
value : begin
basic := false;
PickUp(datei,basic,puffer2,wert);
weiter := false;
end;
sign : akt_vorz := vorz2;
trennung : akt_vorz := none;
point : begin
read(datei,puffer2);
if not CheckIOResult
then begin
ende(raus);
if raus then halt(300);
end;
puffer_art_2 := puffertest(puffer2,vorz2);
case puffer_art_2 of
value : begin
basic := true;
PickUp(datei,basic,puffer2,wert);
weiter := false;
end;
sign : akt_vorz := vorz2;
trennung : akt_vorz := none;
point : akt_vorz := none;
end;
end;
end;
end;
end;
end;
if akt_vorz=minus then wert :=-wert;
{$I+}
end; {of READ_VALUE}
begin
end.