home
***
CD-ROM
|
disk
|
FTP
|
other
***
search
/
Simtel MSDOS - Coast to Coast
/
simteldosarchivecoasttocoast2.iso
/
ddjmag
/
ddj8611.zip
/
SHAMMAS.NOV
< prev
Wrap
Text File
|
1986-12-01
|
16KB
|
690 lines
Listing 1. Using the predefined NUMERIC_ERROR Ada exception.
function Power(BASE, EXPONENT : FLOAT) return FLOAT is
begin
return Exp(Exponent * Ln(Base));
-- This is the area to handle exceptions
exception
when NUMERIC_ERROR =>
if Base = 0 then
return 0;
else -- return "infinity"
return FLOAT'FIRST;
end if;
end Power;
-*-
Listing 2. General form of exception handling block.
procedure Big_Trouble is
Negative_Absolute_Temperature,
Negative_Pressure, Negative_Volume : exception;
Temperature, Pressure, Volume : FLOAT;
begin
-- procedure to calculate temperature, Pressure and volume
-- Calculate temperature in Rankin
if Temperature < 0.0 then
raise Negative_Absolute_Temperature;
end if;
-- Calculate pressure and volume
if Pressure < 0.0 then
raise Negative_Pressure;
end if;
if Volume < 0.0 then
raise Negative_Volume;
end if;
-- other procedure statements
exception -- handling block
when NUMERIC_ERROR =>
-- handle bad function arguments, underflow or overflow
when Negative_Absolute_Temperature =>
-- handle negative absolute temperature results
when Negative_Pressure | Negative_Volume =>
-- handle negative pressure or volume values
when others =>
-- handle all other problems
end Big_trouble;
-*-
Listing 3. Ada exception handling scope.
procedure The_Boss is
Boss_Angry : exception;
procedure Command_Worker is
begin
-- sequence of statements
if income < 0.0 then raise Boss_Angry; end if;
-- sequence of statements
end Command_Worker;
procedure Command_Foreman is
begin
-- sequence of statements
Command_Worker;
-- sequence of statements
exception
when Boss_Angry =>
-- Try to deal with the boss
end Command_Foreman;
begin
-- sequence of statements
Command_Worker;
Command_Foreman;
- sequence of statements
exception
when Boss_Angry =>
-- fire foreman
end The_Boss;
-*-
Listing 4. The retry approach with exception handlers.
with TEXT_IO; use TEXT_IO;
procedure Days_of_our_lives;
type Day_Name is (Sun, Mon, Tue, Wed, Thu, Fir, Sat);
package DAY_IO is new TEXT_IO.ENUMERATION_IO (Day_Name);
use Day_IO;
-- define time-out
Time_Out : constant integer := 5;
-- define variable
Day : Day_Name;
-- define exception
Wrong_Day : exception;
begin
for Count in 1..Time_Out loop
PUT("What day is it?"); NEW_LINE;
begin -- exception handling block starts here
GET(Day); NEW_LINE;
PUT("Have a nice "); PUT(Day); NEW_LINE;
exit; -- exit for loop when answer is correct
exception
when CONSTRAINT_ERROR =>
if Count = Time_Out then
PUT("Sorry! Loop time-out");
raise Wrong_Day;
else
PUT("Sorry! No such weekday"); NEW_LINE;
PUT("You have "); PUT(Time_Out - Count);
PUT(" more times to try); NEW_LINE;
PUT("Let us try once more"); NEW_LINE;
end if;
end; -- end error handler
end loop; -- end for loop
end Days_of_our_lives;
-*-
Listing 5. Using an alternative method with exception handlers.
with TEXT_IO; use TEXT_IO;
procedure Root is
Result, Guess1, Guess2, Accuracy : FLOAT;
Max_Iter : INTEGER;
Diverge, Fatal_Error : exception;
function F(X : FLOAT) return FLOAT is
begin
return X * X * X - 5.0;
end F;
procedure Newton(Guess, Accuracy : FLOAT; Max_Iter : INTEGER) is
-- Newton's method to find the root of a function
Funct, Derivative, h, Diff : FLOAT;
begin
loop
if ABS(Guess) > 1.0 then h := 0.01 * Guess;
else h := 0.01;
end if;
Funct := F(Guess);
Derivative := (F(Guess + h) - Funct) / h;
Diff := Funct / Derivative;
Guess := Guess - Diff;
Max_Iter := Max_Iter - 1;
if Max_Iter < 0 then
raise Diverge;
end if;
if ABS(Diff) <= Accuracy then exit; end if;
end loop;
PUT(Guess);
end Newton;
procedure Bisection(A, B, Accuracy : FLOAT; Max_Iter : INTEGER) is
-- Bisection method to find the root of a function
Mean, FA, FB, FM : FLOAT;
begin
FA := F(A); FB := F(B);
-- Get midpoint estimate for the root
Mean := (A + B) / 2.0;
while ABS(A - B) > Accuracy loop
FM := F(Mean);
-- Does A and Mean have same function sign?
if FM * FA > 0.0
then
A := Mean; FA := FM;
else
B := Mean; FB := FM;
end if;
-- Get midpoint estimate for the root
Mean := (A + B) / 2.0;
Max_Iter := Max_Iter - 1;
if Max_Iter < 0 then
raise Fatal_Error;
end if;
end loop;
PUT(Mean);
end Bisection;
begin -- Root --
PUT("Enter first guess for the root "); GET(Guess1); NEW_LINE;
PUT("Enter second guess for the root "); GET(Guess2); NEW_LINE;
PUT("Enter desired accuracy"); GET(Accuracy); NEW_LINE;
PUT("Enter maximum number of iterations "); GET(Max_Iter);
NEW_LINE; NEW_LINE;
PUT("Root = ");
begin -- start outer exception handler
-- Try Newton's method first
Newton(Guess1, Accuracy, Max_Iter);
exit; -- terminate program successfully
exception
when NUMERIC_ERROR | Diverge =>
begin -- start inner exception handler
-- This method will definitely work, but is slower
Bisection(Guess1, Guess2, Accuracy);
exit; -- terminate successfully with second method
exception
when others =>
PUT("Fatal Error. Cannot recover");
NEW_LINE;
end; -- inner exception handler
end; -- outer exception handler
end Root;
-*-
Listing 6. The clean up method used in exception handlers.
with TEXT_IO; use TEXT_IO;
procedure Root is
Result, Guess, Accuracy : FLOAT;
Max_Iter : INTEGER)
Diverge : exception;
function F(X : FLOAT) return FLOAT is
begin
return X * X * X - 5.0;
end F;
procedure Newton(Guess, Accuracy : FLOAT; Max_Iter : INTEGER) is
-- Newton's method to find the root of a function
Funct, Derivative, h, Diff : FLOAT;
begin
loop
if ABS(Guess) > 1.0 then h := 0.01 * Guess;
else h := 0.01;
end if;
Funct := F(Guess);
Derivative := (F(Guess + h) - Funct) / h;
Diff := Funct / Derivative;
Guess := Guess - Diff;
Max_Iter := Max_Iter - 1;
if Max_Iter < 0 then
raise Diverge;
end if;
if ABS(Diff) <= Accuracy then exit; end if;
end loop;
NEW_LINE; NEW_LINE;
PUT("Root = "); PUT(Guess);
NEW_LINE; NEW_LINE;
end Newton;
begin -- Root --
PUT("Enter guess for the root "); GET(Guess); NEW_LINE;
PUT("Enter desired accuracy"); GET(Accuracy); NEW_LINE;
PUT("Enter maximum number of iterations "); GET(Max_Iter);
loop
begin -- start exception handler
-- Try Newton's method first
Newton(Guess, Accuracy, Max_Iter);
exit; -- exit open loop and terminate program successfully
exception
when Diverge =>
PUT("Enter guess for the root ");
GET(Guess); NEW_LINE;
end; -- exception handler
end loop;
end Root;
-*-
Listing 7. Module SafeLib0, a subset of MathLib0 with error
trapping features.
DEFINITION MODULE SafeLib0;
(* Definition module of SafeLib0, the safer version of MathLib0 *)
(* The EXPORT is not needed for new Modula-2 definition *)
EXPORT QUALIFIED SQRT, LN, EXP, EXPRANGE;
(* Largest argument for exp(X) that yields exp() = 9.9999E+99 *)
CONST EXPRANGE = 230.26;
PROCEDURE SQRT(X : REAL; VAR ArgumentERROR : BOOLEAN) : REAL;
(* Square root function with an argument error flag *)
PROCEDURE LN(X : REAL; VAR ArgumentERROR : BOOLEAN) : REAL;
(* Natural logarithm function with an argument error flag *)
PROCEDURE EXP(X : REAL; VAR ArgumentERROR : BOOLEAN) : REAL;
(* Exponential function with an argument error flag *)
PROCEDURE GetNext(Current, MaxFlag : CARDINAL;
VAR Found : BOOLEAN;
ErrorFlag : ARRAY OF BOOLEAN) : CARDINAL
END SafeLib0.
IMPLEMENTATION MODULE SafeLib0;
FROM MathLib0 IMPORT sqrt, exp, ln;
PROCEDURE SQRT(X : REAL; VAR ArgumentERROR : BOOLEAN) : REAL;
(* Square root function with an argument error flag *)
BEGIN
ArgumentERROR := FALSE;
IF X < 0.0 THEN
ArgumentERROR := TRUE;
X := ABS(X)
END;
RETURN sqrt(X)
END SQRT;
PROCEDURE LN(X : REAL; VAR ArgumentERROR : BOOLEAN) : REAL;
(* Natural logarithm function with an argument error flag *)
BEGIN
ArgumentERROR := FALSE;
IF X <= 0.0 THEN
ArgumentERROR := TRUE;
IF X < 0.0 THEN X := ABS(X)
ELSE X := 10.0
END;
END;
RETURN ln(X)
END LN;
PROCEDURE EXP(X : REAL; VAR ArgumentERROR : BOOLEAN) : REAL;
(* Exponential function with an argument error flag *)
BEGIN
ArgumentERROR := FALSE;
IF X > EXPRANGE
THEN
ArgumentERROR := TRUE;
X := 1.0 / EXPRANGE
END;
RETURN exp(X)
END EXP;
PROCEDURE GetNext(Current, MaxFlag : CARDINAL;
VAR Found : BOOLEAN;
ErrorFlag : ARRAY OF BOOLEAN) : CARDINAL;
VAR Last : CARDINAL;
BEGIN
Last := HIGH(ErrorFlag);
IF MaxFlag > Last THEN MaxFlag := Last END;
Found := FALSE;
WHILE (Current <= Last) AND (NOT Found) DO
IF ErrorFlag[Current] THEN Found := TRUE END;
INC(Current);
END;
RETURN Current
END GetNext;
END SafeLib0.
-*-
Listing 8. Module SafeLib1, a second alternate subset of
MathLib0 with error trapping features.
DEFINITION MODULE SafeLib1;
(* Definition module of SafeLib1, the safer version of MathLib1 *)
(* The EXPORT is not needed for new Modula-2 definition *)
EXPORT QUALIFIED SQRT, LN, EXP, EXPRANGE,
MAXERRORSTACK, ErrorStack;
(* Largest argument for exp(X) that yields exp() = 9.9999E+99 *)
CONST EXPRANGE = 230.26;
MAXERRORSTACK = 50;
VAR ErrorStack : RECORD
HeightErrorStack : [0..MAXERRORSTACK];
FuncName : ARRAY [1..MAXERRORSTACK] OF
ARRAY [0..3] OF CHAR
END;
PROCEDURE SQRT(X : REAL) : REAL;
(* Square root function *)
PROCEDURE LN(X : REAL) : REAL;
(* Natural logarithm function *)
PROCEDURE EXP(X : REAL) : REAL;
(* Exponential function *)
END SafeLib1.
IMPLEMENTATION MODULE SafeLib1;
FROM MathLib0 IMPORT sqrt, exp, ln;
PROCEDURE SQRT(X : REAL) : REAL;
(* Square root function *)
BEGIN
IF X < 0. THEN
PushErrorStack("SQRT");
X := ABS(X);
END;
RETURN sqrt(X)
END SQRT;
PROCEDURE LN(X : REAL) : REAL;
(* Natural logarithm function *)
BEGIN
IF X <= 0.0 THEN
ArgumentERROR := TRUE;
IF X < 0.0 THEN X := ABS(X)
ELSE X := 10.0
END;
END;
RETURN ln(X)
END LN;
PROCEDURE EXP(X : REAL) : REAL;
(* Exponential function *)
BEGIN
IF X > EXPRANGE
THEN
ArgumentERROR := TRUE;
X := 1.0 / EXPRANGE
END;
RETURN exp(X)
END EXP;
PROCEDURE ClearErrorStack;
BEGIN
ErrorStack.HeightErrorStack := 0
END ClearErrorStack;
PROCEDURE PushErrorStack(Name : ARRAY OF CHAR);
VAR I : CARDINAL;
BEGIN
WITH ErrorStack DO
INC(HeightErrorStack);
I := 0;
WHILE (I <= HIGH(Name)) AND (Name[I] <> 0C) DO
FuncName[HeightErrorStack,I] := Name[I]
END;
IF I < HIGH(Name) THEN FuncName[I+1] := 0C END;
END; (* WITH *)
END PushErrorStack;
PROCEDURE InError() : BOOLEAN;
BEGIN
RETURN (ErrorStack.HeightErrorStack > 0)
END InError;
BEGIN (* Module initialization *)
ClearErrorStack
END SafeLib1.
-*-
Listing 9. Turbo Pascal matrix inversion program using Turbo
Extender utilities.
PROGRAM INVERT;
(* Program to test speed of floating point matrix inversion. *)
(* The program will form a matrix with ones' in every member *)
(* except the diagonals which will have values of 2. *)
CONST MAX = 140;
RArowsPerPage = 20;
RAcolsPerPage = 20;
RApagesDown = 7;
RApagesAcross = 7;
TYPE RAelementType = REAL;
(*$I RARRAY.INC*)
VAR J, K, L : INTEGER;
DET, PIVOT, TEMPO : REAL;
A : RAarrayPtr;
CH : CHAR;
PROCEDURE SHOW_MATRIX;
BEGIN
FOR J := 1 TO MAX DO BEGIN
FOR K := 1 TO MAX DO BEGIN
WRITE(getRA(A,K,J));
WRITE(' ');
END;
WRITELN;
END;
END;
BEGIN
setupRa; (* SETUP BIGARRAY *)
makeRA(A, 1.0, noinit);
(* Creating test matrix *)
FOR J := 1 TO MAX DO BEGIN
FOR K := 1 TO MAX DO
setRA(A, K, J, 1.0);
setRA(A, J, J, 2.0)
END;
(* The test below will ensure that the user does not spend *)
(* a lot of time looking at a rather obvious matrix when its *)
(* size is large. *)
IF MAX <= 10 THEN BEGIN
WRITELN('Matrix is ');
SHOW_MATRIX;
WRITELN; WRITELN;
END;
WRITELN('Starting matrix invertion');
DET := 1.0;
FOR J := 1 TO MAX DO BEGIN
PIVOT := getRA(A,J,J);
DET := DET * PIVOT;
setRA(A,J,J,1.0);
FOR K := 1 TO MAX DO
setRA(A,J,K,(getRA(A,J,K) / PIVOT));
FOR K := 1 TO MAX DO
IF K <> J THEN BEGIN
TEMPO := getRA(A,K,J);
setRA(A,K,J,0.0);
FOR L := 1 TO MAX DO
setRA(A,K,L, (getRA(A,K,L) - getRA(A,J,L) * TEMPO));
END;
END; (* End of outer for-loop *)
WRITELN('PRESS <CR> to view matrix '); READLN(CH); WRITELN;
WRITELN('The inverse matrix is ');
SHOW_MATRIX;
WRITE('Determinant = ');
WRITE(DET);
WRITELN; WRITELN;
END.
-*-
Table 1. Matrix inversion timings. The 8087 chip was used in all of
the benchmarks.
Square Matrix Size Inversion Time Comments
(hh:mm:ss.ff)
------------------ -------------- -------------
10 00:00:00.71 Turbo Pascal
20 00:00:05.16 " "
30 00:00:17.30 " "
50 00:01:19.42 " "
75 00:04:26.61 " "
90 00:07:40.33 " "
100 overflow " "
140 01:16:33.47 Turbo Extender
20 by 20 page size,
7 pages
140 01:16:32.32 28 by 28 page size,
5 pages
140 01:16:33.75 35 by 35 page size,
4 pages
[EOF]
