Simtel MSDOS 1992 June/SIMTEL_0692.cdr/msdos/ddjmag/ddj8611.arc/SHAMMAS.NOV

Text File | 1986-12-01 | 15.3 KB | 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]