Path: utzoo!utgpu!jarvis.csri.toronto.edu!mailrus!cs.utexas.edu!usc!zaphod.mps.ohio-state.edu!uakari.primate.wisc.edu!aplcen!haven!adm!news From: I2010506%DBSTU1.BITNET@cunyvm.cuny.edu Newsgroups: comp.lang.pascal Subject: PD software, TP Message-ID: <22510@adm.BRL.MIL> Date: 19 Feb 90 19:39:43 GMT Sender: news@adm.BRL.MIL Lines: 633 (****************************************************************** 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 Sender: Borland Pascal Discussion Group From: "John M. Kelsey" Subject: Cursor questions To: "Christian Boettger, TU Braunschweig, FRG" 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.