Programmer's ROM - The Computer Language Library/programmersrom.iso/ada/tools/calc.src

Text File | 1988-05-03 | 25.4 KB | 941 lines

--::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::
--auxlex.src
--::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::
  package AUXLEX_PKG is

   function UPPERCASE ( C: CHARACTER ) return CHARACTER;
   function SPACEP ( C : CHARACTER ) return BOOLEAN;
   function DIGITP ( C : CHARACTER ) return BOOLEAN;
   function LETTERP ( C : CHARACTER ) return BOOLEAN;

  end AUXLEX_PKG;

  package body AUXLEX_PKG is

-- The following are auxilliary procedures used by LRLEX

   function UPPERCASE ( C: CHARACTER ) return CHARACTER is

   -- convert input 'a..z' to 'A..Z'.  All other input returned as is.

   CHAR_POS    : INTEGER;
   CASE_OFFSET : CONSTANT INTEGER := 32;
   -- assuming ASCII character set

   begin

     CHAR_POS := CHARACTER'POS ( C );

     if ( C >= 'a' ) and ( C <= 'z' ) then
       return CHARACTER'VAL ( CHAR_POS - CASE_OFFSET );
     else
       return C;
     end if;

   end UPPERCASE;


--   procedure GETC ( INPTR : in out INTEGER; C : out CHARACTER ) is

   -- This procedure gets an input character if neither the end_of_line
   -- nor the end_of_file has been reached.

--   MAXLINLEN : INTEGER := 80;
--   EOLC       : CHARACTER := CHARACTER'VAL ( 1 );
--   EOFC       : CHARACTER := CHARACTER'VAL ( 2 );
--   INBUF     : array ( 1..Maxlinlen ) of CHARACTER;


--   begin

--   end GETC;


   function SPACEP ( C : CHARACTER ) return BOOLEAN is

      RESULT : BOOLEAN;

   begin

     RESULT := C = ' ';

     return RESULT;

   end SPACEP;



   function DIGITP ( C : CHARACTER ) return BOOLEAN is

    RESULT : BOOLEAN;

   BEGIN

     RESULT := ( C >= '0' and C <= '9'  );

     return RESULT;

   end DIGITP;



   function LETTERP ( C : CHARACTER ) return BOOLEAN is

     RESULT : BOOLEAN;

   begin

     RESULT := ( C >= 'a' and C <= 'z' ) or ( C >= 'A' and C <= 'Z' );

     return RESULT;

   end LETTERP;

  begin -- package body

  --  null program
  null;
  end AUXLEX_PKG;



--::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::
--tok.src
--::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::
package TOK_PKG is
type TOK is (
DIGIT                           ,
DIV_OP                          ,
ENDT                            ,
EOL                             ,
EQUALS                          ,
ERROR                           ,
LEFT_PAREN                      ,
LETTER                          ,
MINUS_OP                        ,
PLUS_OP                         ,
RIGHT_PAREN                     ,
TIMES_OP
 );
end TOK_PKG;
package body TOK_PKG is
  begin
    null;
end TOK_PKG;



--::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::
--lex.src
--::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::
with AUXLEX_PKG; use AUXLEX_PKG;
with TOK_PKG; use TOK_PKG;
with TEXT_IO; use TEXT_IO;

package LEX_PKG is
  procedure LRLEX ( CURTOK : out TOK ; LEXVAL : out INTEGER );
  function LRERR  return INTEGER;
end LEX_PKG;


  -- This package was developed specifically for the CALC_PROG program.
  -- The syntactic parser (PARSER_PKG) was generated by the LR parser generator
  -- program (written in FORTRAN) on the VAX.  LR also generates a list of
  -- tokens the parser looks for; these are assembled in a type called TOK and
  -- placed in an Ada package called TOK_PKG.  The lexical scanner/analyzer for
  -- any given grammar can be hand-coded on the Wicat (in Ada) for that
  -- particular language.  LRLEX uses another package, AUXLEX_PKG, that
  -- contains a number of low-level auxiliary routines that are useful in
  -- any lexical scanning task.  We expect to add additional functions and
  -- procedures to AUXLEX_PKG as time goes on.  Note that this package also
  -- uses TOK_PKG, since it is LRLEX that identifies legal tokens in the
  -- input stream.  LRLEX also uses the package, TOK_PKG, generated by LR,
  -- since the token number is the means of communication between LRLEX and
  -- LRPARSE.

  package body LEX_PKG is

procedure LRLEX ( CURTOK : out TOK ; LEXVAL : out INTEGER ) is

-- NOTE... LRLEX IS NOW A PROCEDURE, NOT A FUNCTION, SINCE IT
-- HAS OUTPUT PARAMETERS.


C   : CHARACTER;

EOLC : CHARACTER := ';'; -- delimiter for the end of an input line.
EOFC : CHARACTER := CHARACTER'VAL ( 2 );  -- Ada version of a CTRL B.
                                          -- This is the end-of-file
                                          -- character that terminates
                                          -- the program.
INPTR : INTEGER := 0;  -- input buffer pointer

   procedure GETC ( INPTR : in out INTEGER; C : out CHARACTER ) is

   -- This procedure gets an input character if the end_of_line
   -- has not been reached.

   MAXLINLEN : INTEGER := 80;
   EOLC       : CHARACTER := ';';
   INBUF     : array ( 1..MAXLINLEN ) of CHARACTER;


   begin

     if (INPTR > MAXLINLEN) then
       C := EOLC;
       INPTR := 0;
     else
          GET ( C );
       INPTR := INPTR + 1;
     end if;

   end GETC;

 -- *********************** NOW THE MAIN BODY OF LRLEX **********************


 begin   -- LRLEX



     GETC (INPTR, C);

     while (SPACEP (C)) loop
        GETC (INPTR, C);
     end LOOP;

        LEXVAL := 0;

     if (DIGITP (C)) then
       LEXVAL := CHARACTER'POS ( C ) - 48;
       CURTOK := DIGIT;
     elsif (LETTERP (C)) then
       LEXVAL := CHARACTER'POS ( UPPERCASE ( C ) ) - 64 ;
       CURTOK := LETTER;
     elsif (C = '+') then
       CURTOK := PLUS_OP;
     elsif (C = '-') then
       CURTOK := MINUS_OP;
     elsif (C = '*') then
       CURTOK := TIMES_OP;
        elsif (C = '/') then
       CURTOK := DIV_OP;
        elsif (C = '=') then
       CURTOK := EQUALS;
     elsif (C = '(') then
       CURTOK := LEFT_PAREN;
     elsif (C = ')') then
       CURTOK := RIGHT_PAREN;
     elsif (C = EOLC) then
       CURTOK := EOL;
     elsif (C = EOFC) then
       CURTOK := ENDT;
     else
       CURTOK := ERROR;
     end if;

 end LRLEX;


 function LRERR return INTEGER is

  begin

  -- user can put custom error processing here, such as printing out
  -- the offending input line, etc.

  return 0;

  end LRERR;

begin -- body of LEX_PKG
  null;
end LEX_PKG;

--::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::
--decl.src
--::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::
  package DECL_PKG is

    REG : array (1..26) of INTEGER := (1..REG'LAST => 0);

      -- This array is used in the semantic routines of the CALC program
      -- parser to store values in single-letter-named variables that the
      -- user defines.

    TEMP : INTEGER;  -- Temporary variable used in semantic routines.

  end DECL_PKG;

  package body DECL_PKG is

    begin

    null;  -- this package exists only to provide variable declarations used
           -- by the semantic routines in package PARSER_PKG.

    end DECL_PKG;



--::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::
--parser.src
--::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::
 with DECL_PKG; use DECL_PKG;
 with TEXT_IO;  use TEXT_IO;
 with LEX_PKG;  use LEX_PKG;
 with TOK_PKG;  use TOK_PKG;
 package PARSER_PKG is
    function LRPARSE return integer;
 end PARSER_PKG;
 package body PARSER_PKG is
   function LRPARSE return integer is

         --  Start of %INCLUDE lrparse.dim

     type LRENT1 is array( 1 ..   31) of integer;
     type LRFRED1 is array( 1 ..   32) of integer;
     type LRFTRN1 is array( 1 ..   32) of integer;
     type LRTRAN1 is array( 1 ..   78) of integer;
     type LRNSET1 is array( 1 ..   20) of integer;
     type LRPROD1 is array( 1 ..   20) of integer;
     type LRLSET1 is array( 1 ..    9) of integer;
     type LRLS1 is array( 1 ..   36) of integer;
     type LRLEN1 is array( 1 ..   19) of integer;
     type LRLHS1 is array( 1 ..   19) of integer;

         --  End of %INCLUDE from lrparse.dim


         --  Start of %INCLUDE lrparse.dat

     LRENT : LRENT1 := (
                    3,
                    3,
                   19,
                    1,
                    3,
                    6,
                    7,
                    8,
                    9,
                   15,
                   16,
                   17,
                   18,
                   20,
                    8,
                   15,
                    5,
                   16,
                    9,
                   10,
                    1,
                   14,
                    2,
                   12,
                   11,
                   15,
                   20,
                   20,
                    4,
                   16,
                   16 );
     LRFRED : LRFRED1 := (
                    1,
                    1,
                    2,
                    2,
                    3,
                    4,
                    5,
                    5,
                    6,
                    6,
                    7,
                    8,
                    9,
                   10,
                   11,
                   12,
                   12,
                   12,
                   13,
                   13,
                   13,
                   14,
                   14,
                   14,
                   14,
                   15,
                   16,
                   17,
                   18,
                   19,
                   20,
                   21 );
     LRFTRN : LRFTRN1 := (
                    1,
                    2,
                    3,
                   14,
                   14,
                   14,
                   14,
                   22,
                   23,
                   29,
                   31,
                   31,
                   32,
                   33,
                   35,
                   35,
                   38,
                   46,
                   46,
                   53,
                   60,
                   60,
                   61,
                   67,
                   73,
                   73,
                   75,
                   77,
                   79,
                   79,
                   79,
                   79 );
     LRTRAN : LRTRAN1 := (
                    2,
                    3,
                    4,
                    5,
                    6,
                    7,
                    8,
                    9,
                   10,
                   11,
                   12,
                   13,
                   14,
                    4,
                    7,
                   15,
                    9,
                   16,
                   11,
                   12,
                   14,
                   17,
                    4,
                    7,
                   15,
                    9,
                   18,
                   12,
                   19,
                   20,
                   21,
                   22,
                   23,
                   24,
                   19,
                   20,
                   25,
                    4,
                    7,
                   15,
                    9,
                   26,
                   11,
                   12,
                   14,
                    4,
                    7,
                   15,
                    9,
                   11,
                   12,
                   27,
                    4,
                    7,
                   15,
                    9,
                   11,
                   12,
                   28,
                   29,
                    4,
                    7,
                   15,
                    9,
                   30,
                   12,
                    4,
                    7,
                   15,
                    9,
                   31,
                   12,
                   19,
                   20,
                   23,
                   24,
                   23,
                   24 );
     LRNSET : LRNSET1 := (
                    3,
                    1,
                    6,
                    8,
                    5,
                    8,
                    4,
                    4,
                    8,
                    7,
                    4,
                    4,
                    1,
                    4,
                    8,
                    7,
                    7,
                    3,
                    4,
                    4 );
     LRPROD : LRPROD1 := (
                    2,
                   18,
                    1,
                    7,
                   15,
                    5,
                   11,
                   14,
                    4,
                    8,
                   15,
                   17,
                   19,
                   16,
                    6,
                   10,
                    9,
                    3,
                   13,
                   12 );
     LRLS : LRLS1 := (
                    1,
                    2,
                    4,
                    9,
                   10,
                   11,
                   12,
                    1,
                    2,
                    4,
                    9,
                   10,
                   12,
                    1,
                    3,
                    6,
                    7,
                    8,
                    9,
                    2,
                    4,
                    9,
                   10,
                   11,
                   12,
                    2,
                    4,
                    9,
                   10,
                   12,
                    3,
                    4,
                    9,
                   10,
                   11,
                    4 );
     LRLSET : LRLSET1 := (
                    1,
                    8,
                   14,
                   20,
                   26,
                   31,
                   32,
                   36,
                   37 );
     LRLEN : LRLEN1 := (
                    3,
                    0,
                    4,
                    0,
                    1,
                    3,
                    1,
                    1,
                    3,
                    3,
                    1,
                    3,
                    3,
                    1,
                    1,
                    3,
                    2,
                    1,
                    2 );
     LRLHS : LRLHS1 := (
                   13,
                   19,
                   19,
                   14,
                   18,
                   18,
                   18,
                   15,
                   15,
                   15,
                   20,
                   20,
                   20,
                   16,
                   16,
                   16,
                   16,
                   17,
                   17 );
     LRIFINAL : integer :=   5;
     LRIENDTK : integer :=   3;
     LRIERRTK : integer :=   6;

         --  End of %INCLUDE from lrparse.dat


         --  Start of %INCLUDE sia0:[tools.lrada]other.ada

     LRSTASTK : array (1..100) of integer;
     LRTOKSTK : array (1..100) of integer;
     LRNOWSTA : integer;
     LRCURTOK : integer;
     LRLEXVAL : integer;
     LRMAXSTK : integer;
     LRERRFLG : integer;
     LRS      : array (1..101) of integer;

     LRP      : integer;                           --  ###########?????


         --  End of %INCLUDE from sia0:[tools.lrada]other.ada

     procedure LRACTN_A( LRPROD : in integer ) is
       begin
         case LRPROD is
         when     1 =>  null;
         when     2 =>  null;
         when     3 =>  null;
                        NEW_LINE;
                        PUT( "*" );   -- prompt for inPUT
         when     4 =>  null;
                        NEW_LINE;
                        PUT( "Result is " );
                        TEMP := LRS( LRP + 1);
                        INTEGER_IO.PUT( TEMP );
         when     5 =>  null;
                        REG( LRS( LRP + 1) ):= LRS( LRP + 3);
         when     6 =>  null;
                        NEW_LINE;
                        PUT( "? illegal statement" );
         when     7 =>  null;
                        LRS( LRP + 1) := LRS( LRP + 1);
         when     8 =>  null;
                        LRS( LRP + 1) := LRS( LRP + 1) + LRS( LRP + 3);
         when     9 =>  null;
                        LRS( LRP + 1) := LRS( LRP + 1) - LRS( LRP + 3);
         when    10 =>  null;
                        LRS( LRP + 1) := LRS( LRP + 1);
         when OTHERS => NEW_LINE;
                        PUT( "Bad production number in LRACTN_A" );
                        INTEGER_IO.PUT( LRPROD );
       end case;
   end LRACTN_A;
   procedure LRACTN_B( LRPROD : in integer ) is
     begin
       case LRPROD is
         when    11 =>  null;
                        LRS( LRP + 1) := LRS( LRP + 1) * LRS( LRP + 3);
         when    12 =>  null;
                        LRS( LRP + 1) := LRS( LRP + 1) / LRS( LRP + 3);
         when    13 =>  null;
                        LRS( LRP + 1) := LRS( LRP + 1);
         when    14 =>  null;
                        LRS( LRP + 1) := REG( LRS( LRP + 1) );
         when    15 =>  null;
                        LRS( LRP + 1) := LRS( LRP + 2);
         when    16 =>  null;
                        LRS( LRP + 1) := -LRS( LRP + 2);
         when    17 =>  null;
                        LRS( LRP + 1) := LRS( LRP + 1);
         when    18 =>  null;
                        LRS( LRP + 1) := 10 * LRS( LRP + 1) + LRS( LRP + 2);
         when OTHERS => NEW_LINE;
                        PUT( "Bad production number in LRACTN_B" );
                        INTEGER_IO.PUT( LRPROD );
         end case;
     end LRACTN_B;
     procedure LRACTN( LRPROD : in integer ) is
       begin
         case LRPROD is
           when    1..   10 =>  LRACTN_A( LRPROD );
           when   11..   18 =>  LRACTN_B( LRPROD );
           when   OTHERS    =>  NEW_LINE;
                                PUT( "Bad production number in LRACTN");
                                INTEGER_IO.PUT( LRPROD );
         end case;
     end LRACTN;

         --  Start of %INCLUDE sia0:[tools.lrada]lraux.ada

    procedure LRINIT is
      begin
        LRERRFLG := 0;
        LRMAXSTK := 100;
        LRNOWSTA := 1;
        LRSTASTK( 1 ) := 1;
        LRP := 1;
        LRCURTOK := LRIENDTK;
        LRLEXVAL := 0;
    end LRINIT;
    function LRFINDR( ISTATE,
                      ITOKEN : in integer ) return integer is
      ISTART,
      IEND,
      JSTART,
      JEND,
      I,
      J : integer;
      begin
        ISTART := LRFRED( ISTATE );
        IEND := LRFRED( ISTATE + 1 ) - 1;
        I := ISTART;
        while I <= IEND loop
          J := LRNSET( I );
          JSTART := LRLSET( J );
          JEND := LRLSET( J + 1 ) - 1;
          J := JSTART;
          while J <= JEND loop
            if ( LRLS( J ) = ITOKEN ) then
               return LRPROD( I );
               I := IEND;
               J := JEND;
            end if;
            J := J + 1;
          end loop;
          I := I + 1;
        end loop;
        return -1;
    end LRFINDR;
    function LRFINDT( ISS,
                      IT : in integer ) return integer is
      ISTART,
      IEND,
      I,
      J : integer;
      begin
        ISTART := LRFTRN( ISS );
        IEND := LRFTRN( ISS + 1 ) - 1;
        I := ISTART;
        while I <= IEND loop
          J := LRTRAN( I );
          if ( LRENT( J ) = IT ) then
             return J;
             I := IEND;
          end if;
          I := I + 1;
        end loop;
        return -1;
    end LRFINDT;
    procedure LRDOTR( ISTA : in integer ) is
      begin
        LRP := LRP + 1;
        if ( LRP > LRMAXSTK ) then
           LRERRFLG := 2;
        else
           LRTOKSTK( LRP ) := LRCURTOK;
           LRSTASTK( LRP ) := ISTA;
           LRS( LRP + 1 ) := LRLEXVAL;
           LRNOWSTA := ISTA;
        end if;
    end LRDOTR;
    procedure LRDORE( IPROD : in integer ) is
      LEPTR : integer;
      begin
        LEPTR := LRP - LRLEN( IPROD ) + 1;
        if ( LEPTR > LRMAXSTK ) then
           LRERRFLG := 2;
        else
           LRTOKSTK( LEPTR ) := LRLHS( IPROD );
           LRNOWSTA := LRFINDT( LRSTASTK( LEPTR - 1 ), LRLHS( IPROD ) );
           LRSTASTK( LEPTR ) := LRNOWSTA;
           LRP := LEPTR;
           LRACTN( IPROD - 1 );
        end if;
    end LRDORE;
    procedure LRERROR is
      FOUND : boolean;
      ISTA,
      IPROD : integer;
      TOK1  : TOK;
      begin
        if lrerr = 0 then
           FOUND := false;
            while ( not FOUND ) and ( LRP > 0 ) loop
             ISTA := LRFINDT( LRSTASTK( LRP ), LRIERRTK );
             if ISTA > 0 then
                LRDOTR( ISTA );
                FOUND := true;
             else
                LRP := LRP - 1;
             end if;
             if not FOUND then
                LRERRFLG := 1;
             else
                FOUND := false;
                while not FOUND loop
                  IPROD := LRFINDR( LRNOWSTA, LRCURTOK );
                  if IPROD > 0 then
                     LRDORE( IPROD );
                     FOUND := true;
                  else
                     ISTA := LRFINDT( LRNOWSTA, LRCURTOK );
                     if ISTA > 0 then
                        LRDOTR( ISTA );
                        FOUND := true;
                     elsif LRCURTOK = LRIENDTK then
                           LRERRFLG := 3;
                           FOUND := true;
                     else
                         -- NOTE THAT LRLEX IS NOW A PROCEDURE,
                         -- NOT A FUNCTION, SINCE IT HAS AN OUTPUT PARAMETER.
                         LRLEX( TOK1, LRLEXVAL );
                         LRCURTOK := TOK'POS( TOK1 ) + 1;
                     end if;
                  end if;
                end loop;
             end if;
          end loop;
       end if;
    end LRERROR;
    procedure LRINPRT is
      DONE : boolean;
      IPROD,
      ISTA : integer;
      TOK1 : TOK;
      begin
        DONE := false;
         while ( LRERRFLG = 0 ) and ( not DONE ) loop
          IPROD := LRFINDR( LRNOWSTA, LRCURTOK );
          if ( IPROD > 0 ) then
             LRDORE( IPROD );
             if IPROD = 1 then
                DONE := true;
             end if;
          else
             ISTA := LRFINDT( LRNOWSTA, LRCURTOK );
             if ( ISTA > 0 ) then
                LRDOTR( ISTA );
                if ISTA = LRIFINAL then
                   DONE := true;
                else
                   -- NOTE THAT LRLEX IS NOW A PROCEDURE, NOT A FUNCTION,
                   -- SINCE IT HAS AN OUTPUT PARAMETER.
                   LRLEX( TOK1, LRLEXVAL );
                   LRCURTOK := TOK'POS( TOK1 ) + 1;
                end if;
             else
                LRERROR;
             end if;
          end if;
        end loop;
    end LRINPRT;

         --  End of %INCLUDE from sia0:[tools.lrada]lraux.ada

     begin   -- main body of function LRPARSE
       LRINIT;
       LRINPRT;
       return  LRERRFLG;
     end LRPARSE;
   begin
     null;
 end PARSER_PKG;
--::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::
--main.src
--::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::

-- ******************************* MAIN PROCEDURE BODY *********************
  with PARSER_PKG; use PARSER_PKG;
  with TERMINAL_IO; use TERMINAL_IO;
  with TEXT_IO; use TEXT_IO;

    -- This is the main routine for an on-line calculator program.  It is
    -- set up to handle only integers at the present time.  One-letter
    -- variables may be defined and used.  The parser for expressions was
    -- generated by LR on the VAX.  Lexical scanning routines were written
    -- in Ada on the Wicat.

    -- Expressions are terminated by a semi-colon.  The program (normally)
    -- terminates with a CTRL B.  Error handling is non-existent at this
    -- time, so syntactic errors will also cause the program to exit.

procedure MAIN is

MY_STATUS : integer;

   begin-- body of the main procedure


   --- prompt user

      NEW_LINE;

      PUT ( "* " );


   --- call the parser

    MY_STATUS := LRPARSE;


     case MY_STATUS is

       when 1 => PUT ("*** fatal syntactic error  *** ");

       when 2 => PUT ("*** parser stack overflow  *** ");

       when 3 => PUT ("*** premature end of input *** ");

       when 4 => PUT ("*** normal completion      *** ");

       when OTHERS => NULL;  -- unused values

    end case;

     NEW_LINE;

   end MAIN;