Category : Files from Magazines
Archive   : DDJ8611.ZIP
Filename : SHAMMAS.NOV

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 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]