Programmer's ROM - The Computer Language Library/programmersrom.iso/ada/piwg/z000021.ada

Text File | 1988-05-03 | 12.3 KB | 469 lines

-- This is an attempt to create a file with at least one of each
-- kind of Ada statement, structure, lexical item, operator, etc.
--
-- The problem is the need for some ordering so that completeness can
-- be checked and excessive redundancy prevented. The LRM chapter order
-- is not convenient for Ada that can be compiled.
--
pragma LIST ( ON ) ;

package ALL_STATEMENTS_PACKAGE is

  task ALL_STATEMENTS_TASK is
    entry ALL_STATEMENTS_ENTRY_1 ;
    entry ALL_STATEMENTS_ENTRY_2 ( PARAM_1 : STRING ;
                                   PARAM_2 : INTEGER ) ;
    entry ALL_STATEMENTS_ENTRY_3 ;
    entry ALL_STATEMENTS_ENTRY_4 ( PARAM_1 : STRING ;
                                   PARAM_2 : FLOAT ) ;
  end ALL_STATEMENTS_TASK ;

  task type ALL_STATEMENTS_TASK_TYPE is
    entry ALL_STATEMENTS_ENTRY_1_TYPE ;
  end ALL_STATEMENTS_TASK_TYPE ;

  function FUNCTION_IN_PACKAGE return INTEGER ;

  function FUNCTION_WITH_ARGUMENTS_IN_PACKAGE ( A , B : INTEGER ;
                                                C , D : FLOAT ) return BOOLEAN
     ;

  procedure PROCEDURE_IN_PACKAGE ;

  procedure PROCEDURE_WITH_ARGUMENTS_IN_PACKAGE ( LONG_PARAMETER_NAME : FLOAT
     ;
                                                  SHORT : INTEGER ) ;
  NUMBER_1 : INTEGER := 12 ;
  NUMBER_2 : constant := 1E6 ;
  NUMBER_3 : constant INTEGER := 23_456 ;
  NUMBER_4 : INTEGER := 0_0_0 ;
  NUMBER_5 : FLOAT := 12.0 ;
  NUMBER_6 : constant := 1.0E+6 ;
  NUMBER_7 : constant FLOAT := - 314_159.26E-0_5 ;
  NUMBER_8 : constant := 2#101_101# + 16#FF# - 0_016#AB# ;
  NUMBER_9 : constant := 16#F.F_F#E-2 + 2.0 ;
  type MINE is limited private ;
private
  type MINE is new BOOLEAN ;
  subtype MY_BOOLEAN is BOOLEAN ;
  subtype MY_INT is INTEGER range - 5 .. 3 ;
  type GENDER is ( M , F ) ;
  type PERSON ( SEX : GENDER ) ;
  type PERSON_NAME is access PERSON ;
  type DATE is new INTEGER ;
  type PERSON ( SEX : GENDER ) is
    record
      NAME : STRING ( 1 .. 20 ) ;
      BIRTH : DATE ;
      AGE : INTEGER range 0 .. 130 ;
      case SEX is
        when M =>
          WIFE : PERSON_NAME ( SEX => F ) ;
        when F =>
          HUSBAND : PERSON_NAME ( SEX => M ) ;
      end case ;
    end record ;
  JOHN , PAUL : PERSON_NAME := new PERSON ( SEX => M ) ;
  JANE : PERSON_NAME := new PERSON ( SEX => F ) ;
  ME : PERSON_NAME renames JANE ;
  YOU : PERSON ( SEX => F ) := ME.all ;
  type REP_RECORD is
    record
      I : INTEGER range - 63 .. 63 ;
    end record ;

--  for REP_RECORD use
--    record at mod 4 ;
--      I at 0 range 0 .. 7 ;
--    end record ;
  OBJECT_REP_REC : REP_RECORD ;
  I : INTEGER := OBJECT_REP_REC.I ;
  MY_ERROR : exception ;
  ANOTHER_ERROR : exception renames MY_ERROR ;
  ARRAY_OBJECT : array ( INTEGER( - 1 ) .. 1) of FLOAT := ( - 1.0 , 0.0 , 1.0
     ) ;

  package MY_PACKAGE is  -- dummy for following  renames

    function MY_FUNCTION return INTEGER ;

    procedure MY_PROCEDURE ;
  end MY_PACKAGE ;

  package NEW_NAME renames MY_PACKAGE ; use NEW_NAME ;

  function ANOTHER_FUNCTION return INTEGER renames MY_FUNCTION ;

  procedure ANOTHER_PROCEDURE renames MY_PROCEDURE ;
end ALL_STATEMENTS_PACKAGE ;

with TEXT_IO ; use TEXT_IO ;

package body ALL_STATEMENTS_PACKAGE is

  task body ALL_STATEMENTS_TASK is
  begin
    loop
      select
        when I > 2 =>
          accept ALL_STATEMENTS_ENTRY_1 do
            PUT_LINE ( " accepted 1" ) ;
          end ALL_STATEMENTS_ENTRY_1 ;
          I := I + 1 ;
      or
        when I >= 3 =>
          accept ALL_STATEMENTS_ENTRY_2 ( PARAM_1 : STRING ;
                                          PARAM_2 : INTEGER ) do
            PUT_LINE ( " accepted 2" ) ;
          end ALL_STATEMENTS_ENTRY_2 ;
          accept ALL_STATEMENTS_ENTRY_3 ;  -- no "do"
          accept ALL_STATEMENTS_ENTRY_4 ( PARAM_1 : STRING ;
                                          PARAM_2 : FLOAT ) ;
          I := I + 1 ;
      or
        terminate ;
      end select ;
    end loop ;
  exception
    when CONSTRAINT_ERROR =>
      PUT_LINE ( " too bad " ) ;
  end ALL_STATEMENTS_TASK ;

  task body ALL_STATEMENTS_TASK_TYPE is
  begin
    select
      accept ALL_STATEMENTS_ENTRY_1_TYPE do
        PUT_LINE ( " accepted " ) ;
      end ALL_STATEMENTS_ENTRY_1_TYPE ;
      abort ALL_STATEMENTS_TASK ;
    else
      null ;
    end select ;
    select
      accept ALL_STATEMENTS_ENTRY_1_TYPE do
        PUT_LINE ( " accepted " ) ;
      end ALL_STATEMENTS_ENTRY_1_TYPE ;
    or
      delay 3.5 ;
    end select ;
  exception
    when CONSTRAINT_ERROR =>
      PUT_LINE ( " too bad " ) ;
  end ALL_STATEMENTS_TASK_TYPE ;

  function FUNCTION_IN_PACKAGE return INTEGER is
    B : BOOLEAN ;
    I : INTEGER ;
  begin
    I := abs ( I mod 1 ) rem 1 ;
    B := B or ( B and( not( B xor B ))) ;
    return ( 1 +( 2 * 3 / 4 ) ** ( 3 )) ;
  exception
    when CONSTRAINT_ERROR =>
      raise PROGRAM_ERROR ;
    when others =>
      raise STORAGE_ERROR ;
  end FUNCTION_IN_PACKAGE ;

  function FUNCTION_WITH_ARGUMENTS_IN_PACKAGE ( A , B : INTEGER ;
                                                C , D : FLOAT ) return BOOLEAN
     is
    AA : INTEGER := - 1 ;
    LONG_EXPRESSION : INTEGER := A + A + A + A + A + A + A + A + B + B + B +
       INTEGER ( C ) + INTEGER ( D ) ;
  begin
    raise CONSTRAINT_ERROR ;
  exception
    when NUMERIC_ERROR =>
      raise TASKING_ERROR ;
    when others =>
      return TRUE ;
  end FUNCTION_WITH_ARGUMENTS_IN_PACKAGE ;

  procedure PROCEDURE_IN_PACKAGE is
  begin
    return ;
  exception
    when others =>
      return ;
  end PROCEDURE_IN_PACKAGE ;

  procedure PROCEDURE_WITH_ARGUMENTS_IN_PACKAGE ( LONG_PARAMETER_NAME : FLOAT
     ;
                                                  SHORT : INTEGER ) is
  begin
    null ;
  end PROCEDURE_WITH_ARGUMENTS_IN_PACKAGE ;

  package body MY_PACKAGE is  -- dummy for following  renames

    function MY_FUNCTION return INTEGER is
    begin
      return 1 ;
    end MY_FUNCTION ;

    procedure MY_PROCEDURE is
    begin
      null ;
    end MY_PROCEDURE ;
  end MY_PACKAGE ;
begin
  I := I + 1 ;
exception
  when CONSTRAINT_ERROR =>
    PUT_LINE ( " woopse " ) ;
    if I = 1 then
      I := 2 ;
      if I /= 1 then
        case I is
          when 1 =>
            I := 2 ;
          when 2 | 3 =>
            I := 3 ;
            if 1 > 2 and then
               2 >= 3 then
              raise NUMERIC_ERROR ;
            elsif 2 < 1 or else
               3 <= 2 then
              raise NUMERIC_ERROR ;
            end if ;
          when others =>
            I := 4 ;
        end case ;
      elsif I = 2 then
        I := 4 ;
      else
        I := 3 ;
      end if ;
    end if ;
end ALL_STATEMENTS_PACKAGE ;

with ALL_STATEMENTS_PACKAGE ;

procedure Z000021 ;

procedure ALL_STATEMENTS_PROCEDURE_2 ( I : INTEGER ;
                                       J : INTEGER := 2 ) ;
with ALL_STATEMENTS_PROCEDURE_2 ;
with TEXT_IO ; use TEXT_IO ;

procedure Z000021 is
  I : INTEGER := 2 ;

  procedure DEEP is separate ;

  function SEA return INTEGER is separate ;

  task FISH is
  end FISH ;

  task body FISH is separate ;

  package BAG is

  end BAG ;

  package body BAG is separate ;

begin
  ALL_STATEMENTS_PROCEDURE_2 ( J => 1 , I => 2 ) ;
  BLOCK_NAME_1 :
  begin
    null ;
  end BLOCK_NAME_1 ;
  BLOCK_NAME_2 :
  declare

    package INT_IO is new INTEGER_IO ( INTEGER ) ;

    use INT_IO ;
    S : STRING ( 1 .. 4 ) ;
  begin
    NESTED_BLOCK_NAME :
    declare

      package I_IO is new INTEGER_IO ( INTEGER ) ;

    begin
      null ;
    end NESTED_BLOCK_NAME ;
    S := 'A' & "BC" & 'D' ;
  exception
    when CONSTRAINT_ERROR =>
      PUT_LINE ( " ouch " ) ;
      WHILE_NAME :
      while S /= "----" loop
        S := "-" & "--" & "-" ;
      end loop WHILE_NAME ;
  end BLOCK_NAME_2 ;
  FOR_NAME :
  for I in 1 .. 2 loop
    null ;
  end loop FOR_NAME ;
  PUT_LINE ( " into LOOP_NAME_1 " ) ;
  LOOP_NAME_1 :
  loop
    LOOP_NAME_2 :
    loop
      LOOP_NAME_3 :
      for J in reverse 3 .. 4 loop
        LOOP_NAME_4 :
        loop
          exit ;
        end loop LOOP_NAME_4 ;
        exit LOOP_NAME_2 ;
      end loop LOOP_NAME_3 ;
      exit when I = 3 ;
    end loop LOOP_NAME_2 ;
    exit LOOP_NAME_1 when I = 2 ;
  end loop LOOP_NAME_1 ;
  goto GOTO_LABEL ;
<< GOTO_LABEL >>
  abort FISH ;
  PUT_LINE ( " Z000021 finished " ) ;
end Z000021 ;

function ALL_STATEMENTS_FUNCTION_1 return INTEGER ;
with Z000021 ;
generic
  type FORMAL_TYPE_1 is private ;
  type FORMAL_TYPE_2 is limited private ;
  type FORMAL_TYPE_3 is ( <> ) ;
  type FORMAL_TYPE_4 is range <> ;
  type FORMAL_TYPE_5 is digits <> ;
  type FORMAL_TYPE_6 is delta <> ;
  type FORMAL_TYPE_7 is array ( FORMAL_TYPE_3 ) of FORMAL_TYPE_4 ;
  type FORMAL_TYPE_8 is access FORMAL_TYPE_7 ;

-- the operator symblols on the next 3 functions are formal generic parameters
  with function "+" ( DUMMY_1 , DUMMY_2 : FORMAL_TYPE_1 ) return FORMAL_TYPE_1
     is <> ;
  with function "+" ( DUMMY_1 , DUMMY_2 : FORMAL_TYPE_5 ) return FORMAL_TYPE_5
     is "-" ;
  with function "+" ( DUMMY_1 , DUMMY_2 : FORMAL_TYPE_1 ) return FORMAL_TYPE_6
     ;
  with procedure FORMAL_PROC_1 ( DUMMY_1 : out FORMAL_TYPE_4 ;
                                 DUMMY_2 : in FORMAL_TYPE_6 ) is <> ;
  with procedure FORMAL_PROC_2 is Z000021 ;
  with procedure FORMAL_PROC_3 ( DUMMY_1 : out FORMAL_TYPE_4 ;
                                 DUMMY_2 : in FORMAL_TYPE_5 ) ;

procedure ALL_STATEMENTS_GENPROC ( PARAM : in out FORMAL_TYPE_1 ) ;

procedure ALL_STATEMENTS_GENPROC ( PARAM : in out FORMAL_TYPE_1 ) is
  A : FORMAL_TYPE_1 := PARAM ;
begin
  PARAM := PARAM + A ;
end ALL_STATEMENTS_GENPROC ;

generic
  type FORMAL_1 is private ;
  with function "+" ( DUMMY_1 , DUMMY_2 : FORMAL_1 ) return FORMAL_1 is <> ;

function ALL_STATEMENTS_GENFUNC ( PARAM : FORMAL_1 ) return FORMAL_1 ;

function ALL_STATEMENTS_GENFUNC ( PARAM : FORMAL_1 ) return FORMAL_1 is
  A : FORMAL_1 := PARAM ;
begin
  return PARAM + A ;
end ALL_STATEMENTS_GENFUNC ;

generic

package ALL_STATEMENTS_GENPACK is

end ALL_STATEMENTS_GENPACK ;

package body ALL_STATEMENTS_GENPACK is

begin
  null ;
exception
  when others =>
    raise PROGRAM_ERROR ;
end ALL_STATEMENTS_GENPACK ;

separate ( Z000021 )

procedure DEEP is
begin
  null ;
exception
  when others =>
    null ;
end DEEP ;

separate ( Z000021 )

function SEA return INTEGER is
begin
  return 1 ;
end SEA ;

with ALL_STATEMENTS_GENFUNC ;
with ALL_STATEMENTS_GENPACK , ALL_STATEMENTS_GENPROC ;
separate ( Z000021 )

task body FISH is

  function INSTANTIATE_FUNCTION is new ALL_STATEMENTS_GENFUNC ( INTEGER , "-"
     ) ;

  package INSTANTIATE_PACKAGE is new ALL_STATEMENTS_GENPACK ;

  use INSTANTIATE_PACKAGE ;
  type BOOLEAN_ARRAY_OF_INTEGER is array ( BOOLEAN ) of INTEGER ;
  type ACCESS_TO_ARRAY is access BOOLEAN_ARRAY_OF_INTEGER ;
  subtype INT is INTEGER range 5 .. 7 ;
  type FIX is delta 0.01 range - 1.0 .. 1.0 ;
  MY_FIXED : FIX := FIX'LAST ;
--  type FLT is digits 4 range - 0.01 .. 0.01 ;
  subtype FLT is FLOAT range - 0.01 .. 0.01 ;

  procedure DUMMY_PROC ( A : out INT ;
                         B : in FIX ) is
  begin
    A := INTEGER ( B ) ;
  end DUMMY_PROC ;

  procedure DUMMY_PROC_2 ( A : out INT ;
                           B : in FLT ) is
  begin
    A := INTEGER ( B ) ;
  end DUMMY_PROC_2 ;

  function SUM ( LEFT , RIGHT : INTEGER ) return FIX ;

  procedure INSTANTIATE_PROCEDURE is new ALL_STATEMENTS_GENPROC ( INTEGER ,
     INTEGER , BOOLEAN , INTEGER , FLOAT , FIX , BOOLEAN_ARRAY_OF_INTEGER ,
     ACCESS_TO_ARRAY , "+" , "*" , SUM , DUMMY_PROC , FORMAL_PROC_3 =>
     DUMMY_PROC_2 ) ;

  function SUM ( LEFT , RIGHT : INTEGER ) return FIX is
  begin
    return FIX ( LEFT ) + FIX ( RIGHT ) + FIX'FIRST ;
  end SUM ;
begin
  PUT_LINE ( " gone fishing " ) ;
  MY_FIXED := SUM ( 1 , -1 ) ;
  PUT_LINE ( " end FISH " ) ;
end FISH ;

separate ( Z000021 )

package body BAG is

-- someone was left holding an empty bag
begin
  PUT_LINE ( " in the bag " ) ;
end BAG ;

with TEXT_IO ; use TEXT_IO ;

procedure ALL_STATEMENTS_PROCEDURE_2 ( I : INTEGER ;
                                       J : INTEGER := 2 ) is
begin
  PUT_LINE ( " ALL_STATEMENTS_PROCEDURE_2 " ) ;
end ALL_STATEMENTS_PROCEDURE_2 ;