Re: discriminant

[mfb@mbunix.mitre.org (Michael F Brenner)]

q: what is a discriminant. Why do some types carry discriminant.
q2:  I have a project.  I have to simulate a scheduler of tasks.  What
would the body the main sccheduler be like.  This is my first ada project
and I haven't a clue how to procceed.

A: A discriminant is an element of an object that that tells you which
of several choices of forms the object takes. It is a little like
God creating animals with a paramete called gender. The gender
then Discriminates between various genders and also Determines what
parts are glued onto the animal. Ada records can have discriminants
which determine what elements are glued onto the record in each
instance. In the following Free (copyleft) code, variable length
character strings are defined to have a discriminant which is the
length which then decides how many characters are included in the 
record. 

You could have downloaded this code from the Net, but if you had
access to Net search utilities, you would not have posted such
a basic question to a newsgroup. You could also have gotten a very
similar package to this from the PAL, a text book, or several
universities. You should get on the Net as soon as possible.

Meanwhile, the most effective way to learn how to do discriminants is
to do them, and the fastest way to do them is to see a working example
of one. The following example was written by me and has no bugs.

The sentence that is contains no bugs means the following: it is not
warranted or guaranteed, but it has been tested for each of the 
preconditions it was designed for, and every one is welcome to come
up with additional preconditions, which would require it to be
enhanced or further tested, if you desire it to meet those preconditions.
Since it is subject to the Ada modification to the FSF GPPL, you are
welcome to make those modifications yourself, even if you are a 
commercial company, but you may not do anything that would detract
from the Free status of the code.

The design is fully represented by the test program that follows
the package, and, like all software, any uses of the package not
tested by the test program, should first be done by upgrading the
test package to test the software for what you wish it would do.

packagy variable_string_control is
  pragma elaborate_body (variable_string_control);

-- Variable strings are each allocated to any maximum length, and vary
-- from 0 to that maximum in length. Compiler enforces specifying that
-- maximum length when each variable is declared.

   type variable_strings (size: natural) is private;
   null_variable_string: constant variable_strings;

-- The concatenation of variable_strings is an unconstrained string.

  function "&" (left: variable_strings;
                right: variable_strings)
                return string;
  function "&" (left: string;
                right: variable_strings)
                return string;
  function "&" (left: variable_strings;
                right: string)
                return string;

-- When strings agree up to the minimum of their lengths,
-- the shorter string is considered less than the longer string.

  function "<" (left, right: variable_strings) return boolean;
  function ">" (left, right: variable_strings) return boolean;

-- The assignment method is used to change variable_strings.

  procedure assign(message: in out variable_strings; value: string);
  procedure assign(message: in out variable_strings; value: variable_strings);

-- The concatenation method is used to append a string onto the end
-- of a variable_string.

  procedure concat(onto: in out variable_strings; appendage: string);

-- The ELEMENT method returns a column of a variable_string just like
-- array references get columns from ordinary_strings.

  function element (message: variable_strings;
                    col: natural) return character;

-- The IMAGE method returns the string image of a variable_string.

  function image (message: variable_strings) return string;

-- The in_place_lower_case function converts
-- alphabetic character from upper to lower
-- case, ignoring all other characters.
-- It is done in place on a variable_string.

  procedure in_place_lower_case (message: in out variable_strings);

-- The in_place_truncate method is a procedure instead of a function,
-- for efficiency.

  procedure in_place_truncate (message: in out variable_strings;
                               ch: character := ' ');

-- The in_place_upper_case function converts
-- alphabetic character from lower to upper
-- case, ignoring all other characters.

  procedure in_place_upper_case (message: in out variable_strings);

-- The LENGTH method returns the length of the variable_string.

  function length (message: variable_strings) return natural;

-- The SAME method is the equality operator for variable_strings. To
-- be equal, the two strings must be of the same length, and agree
-- for each of their characters.

  function same (left, right: variable_strings) return boolean;
  function same (left: variable_strings; right: string) return boolean;

-- The set_element method sets a character in a single column
-- of a variable_string like array references do for character
-- strings.

  procedure set_element (message: in out variable_strings;
                         col: natural;
                         value:  character);

-- The set_length method truncates a string to a given length or else
-- extends its current length with blanks.

  procedure set_length (message: in out variable_strings;
                        new_length: natural);

-- The SLICE method emulates array slices for variable_strings. The
-- SUBSTR method is similar, but based on length instead of final column.
-- The two-argument SUBSTR gets all characters on or after the given column.
-- All of these permit the START argument to take on a value equal to the
-- length of the variable_string plus 1, returning the null ordinary_string.

  function slice  (message: variable_strings;
                   start, finish: natural) return string;
  function substr (message: variable_strings;
                   start, length: natural) return string;
  function substr (message: variable_strings;
                   start: natural) return string;

-- The variable_string method converts an ordinary_string to a variable string.

  function variable_string (size: natural;
                            message: string) return variable_strings;

private
  type variable_strings (size: natural) is record
    length: integer := -1; -- Causes arrays of strings to fully Allocate.
    list:   string (1..size);
  end record;

  null_variable_string: constant variable_strings (0) :=
    (size => 0, length => 0, list => string'(""));
end variable_string_control;                                             


package body variable_string_control is

 type char_to_char is array (character) of character;
 to_lower_case,
 to_upper_case: char_to_char;
 initialized: boolean := False;

 not_init:     exception;
 out_of_range: exception;
 too_long:     exception;

 procedure initialize_variable_strings is
   cc: character;
 begin
   for c in char_to_char'range loop
     to_lower_case(c) := c;
     to_upper_case(c) := c;
   end loop;

   for c in character'('a')..'z' loop
     cc                  := character'val (character'pos (c) - 32);
     to_upper_case(c)    := cc;
     to_lower_case(cc)   := c;
   end loop;
 end initialize_variable_strings;

 procedure is_okay (message: variable_strings) is
 begin
   if message.length < 0 then
     raise not_init;
   end if;
 end is_okay;

 function "&" (left: variable_strings;
               right: variable_strings)
               return string is
   hold: variable_strings (left.length + right.length);
 begin
   is_okay (left);
   is_okay (right);
   assign (hold, left);
   concat (hold, right.list(1..right.length));
   return hold.list(1..hold.length);
 end "&";

 function "&" (left: string; right: variable_strings) return string is
   hold: variable_strings (left'length + right.length);
 begin
   is_okay (right);
   assign (hold, left);
   concat (hold, right.list(1..right.length));
   return hold.list(1..hold.length);
 end "&";

 function "&" (left: variable_strings; right: string)    return string is
   hold: variable_strings (left.length + right'length);
 begin
   is_okay (left);
   assign (hold, left);
   concat (hold, right);
   return hold.list(1..hold.length);
 end "&";

 function "<" (left, right: variable_strings) return boolean is
 begin
   is_okay(left);
   is_okay(right);
   if    left.length < right.length then
     return left.list(1..left.length)  <= right.list(1..left.length);
   elsif left.length = right.length then
     return left.list(1..left.length)  <  right.list(1..left.length);
   else -- left.length > right.length
     return left.list(1..right.length) <  right.list(1..right.length);
   end if;
 end "<";

 function ">" (left, right: variable_strings) return boolean is
 begin
   is_okay(left);
   is_okay(right);
   if    left.length < right.length then
     return left.list(1..left.length)  >  right.list(1..left.length);
   elsif left.length = right.length then
     return left.list(1..left.length)  >  right.list(1..left.length);
   else -- left.length > right.length
     return left.list(1..right.length) >= right.list(1..right.length);
   end if;
 end ">";

 procedure assign (message: in out variable_strings; value: string) is
 begin
   if value'length > message.size then
     raise too_long;
   else
     message.length := value'length;
     message.list (1..value'length) := value;
   end if;
 end assign;

 procedure assign (message: in out variable_strings;
                   value: variable_strings) is
 begin
   is_okay (value);
   if value.length > message.size then
     raise too_long;
   end if;
   message.length:=value.length;
   message.list (1..value.length) := value.list (1..value.length);
 end assign;

 procedure concat (onto: in out variable_strings; appendage: string) is
   new_length: constant integer := onto.length + appendage'length;
 begin
   is_okay (onto);
   if    new_length > onto.size then
     raise too_long;
   else
     onto.list(onto.length+1..new_length) := appendage;
     onto.length := new_length;
   end if;
 end concat;

 function element (message: variable_strings;
                   col: natural) return character is
 begin
   is_okay (message);
   if    col not in 1..message.length then
     raise out_of_range;
   end if;
   return message.list (col);
 end element;

 function image (message: variable_strings) return string is
 begin
   is_okay (message);
   if message.length=0 then return "";
   else                     return message.list (1..message.length);
   end if;
 end image;

 procedure in_place_lower_case (message: in out variable_strings) is
 begin
   is_okay (message);
   if not initialized then
     initialize_variable_strings;
   end if;
   for i in 1..message.length loop
     message.list(i) := to_lower_case (message.list(i));
   end loop;
 end in_place_lower_case;

 procedure in_place_truncate (message: in out variable_strings;
                              ch: character := ' ') is
 begin
   is_okay (message);

   -- This is a good example of an Ada loop. Compare the following
   -- loop to loops in other computer languages familiar to you, to
   -- see how easy it is to check this loop for termination and for
   -- effectiveness. Also compare how easy it is to see that the
   -- loop is not "off by 1." This style was created in 1978 as part
   -- of the DOD-I HOLWG goals, long before DOD-1 was named Ada as
   -- part of the solution to ever increasing software maintenance
   -- costs. It uses the idea that structured code must have a single
   -- entrance at the top, but may (and often should) have multiple exits.

   loop
     exit when message.length = 0;
     exit when message.list (message.length) /= ch;
     message.length := message.length - 1;
   end loop;
 end in_place_truncate;

 procedure in_place_upper_case (message: in out variable_strings) is
 begin
   is_okay (message);
   if not initialized then
     initialize_variable_strings;
   end if;
   for i in 1..message.length loop
     message.list(i) := to_upper_case (message.list(i));
   end loop;
 end in_place_upper_case;

 function length (message: variable_strings) return natural is
 begin
   is_okay (message);
   return message.length;
 end length;

 function same (left, right: variable_strings) return boolean is
 begin
   is_okay (left);
   is_okay(right);
   return left.length=right.length and then
          left.list(1..left.length) = right.list(1..left.length);
 end same;

 function same   (left: variable_strings; right: string) return boolean is
 begin
   is_okay (left);
   return left.length=right'length and then
          left.list(1..left.length) = right;
 end same;

 procedure set_element (message: in out variable_strings;
                        col: natural;
                        value: character) is
 begin
   is_okay (message);
   if    col > message.size then
     raise out_of_range;
   elsif col = message.length+1 then
     message.length     := message.length + 1;
     message.list (col) := value;
   elsif col > message.length then
     raise too_long;
   else
     message.list (col) := value;
   end if;
 end set_element;

 procedure set_length (message: in out variable_strings;
                       new_length: natural) is
   hold_length: integer := message.length;
 begin
   if hold_length > message.size then
     raise too_long;
   end if;
   message.length := new_length;
   if hold_length < 0 then
     for i in 1..message.size loop
       message.list (i) := ' ';
     end loop;
   end if;
   if    hold_length > 0 then
     for i in hold_length+1 .. new_length loop
       message.list (i) := ' ';
     end loop;
   end if;
 end set_length;

 function slice (message: variable_strings;
                 start, finish: natural) return string is
   hold: variable_strings (finish+1-start);
 begin
   is_okay (message);
   if    start not in 1..message.length then
     raise out_of_range;
   elsif finish not in 0..message.length then
     raise out_of_range;
   end if;
   if finish < start then
     return "";
   else
     hold.length := finish+1-start;
     hold.list (1..hold.length) := message.list (start..finish);
     return hold.list (1..hold.length);
   end if;
 end slice;

 function substr (message: variable_strings;
                  start, length: natural) return string is
 begin
   is_okay (message);
   return slice (message, start, start+length-1);
 end substr;

 function substr (message: variable_strings;
                  start: natural)
                  return string is
 begin
   is_okay (message);
   return slice (message, start, message.length);
 end substr;

 function variable_string (size: natural;
                           message: string) return variable_strings is
   temp: variable_strings (size);
 begin
   if message'length > size then
     raise too_long;
   end if;
   temp.length := message'length;
   if message'length>0 then
     temp.list (1..message'length) := message;
   end if;
   return temp;
 end variable_string;

end variable_string_control;

-- Status is a package with tell and telln (like text_io.put and
-- text_io.put_line, only it puts it to both the console and the
-- error accumulation file. It also provides the method REPORT
-- which does a telln and then raises an exception. 

with variable_string_control;
with status;
procedure tsstrvar is
  use variable_string_control;
  use status;

  test_message: constant string := " Now  is tHe time k1!";

  procedure test_assign_1 is
    x: variable_strings (4);
  begin
    assign(x,"");
    if image(x)/="" then
      report("Failed variable_strings.test_assign_1 bad null");
    end if;
    assign(X,"A");
    if image(x)/="A" then
      report("Failed var_str.test_assing_2");
    end if;
    status.telln("test_assign_1 passed");
  end test_assign_1;

  procedure test_case_1 is
    message: variable_strings (5000) :=
             variable_string  (5000, "okay, I have - UPs &  96 Downs");
    upped:   variable_strings (200):=
             variable_string  (200, "OKAY, I HAVE - UPS &  96 DOWNS");
    lowed:   variable_strings (200) :=
             variable_string  (200, "okay, i have - ups &  96 downs");
    work:    variable_strings(60);
  begin
    assign(work,"abc");
    in_place_upper_case(work);
    if not same(work,"ABC") then
      report("Failed variable_strings.test_case_1 abc [" & work & ']');
    end if;

    assign(work,message);
    in_place_upper_case(work);
    if not same (work, upped) then
      report("Failed variable_strings.test_case_1 a [" & work & ']');
    end if;

    assign(work,message);
    in_place_lower_case(work);

    if not same (work, lowed) then
      report("Failed variable_strings.test_case_1 b");
    end if;
  end test_case_1;

  procedure test_concat_1 is
    f,g,h,k: variable_strings (5);
  begin
    assign(f, "A");
    assign(g, "B");
    assign(h, "AB");
    assign(k, f&g);
    if not same (k,h) then
      report("Failed variable_strings.test_concat_1 a ");
    end if;
  end test_concat_1;

  procedure test_element_1 is
    d: variable_strings(3) := variable_string (3, "");
  begin
    set_element (d, 1, 'a');
    set_element (d, 2, 'b');
    set_element (d, 3, 'c');
    if element (d, 2) /= 'b' then
      report("Failed variable_strings.test_element_1 a ");
    end if;
  end test_element_1;

  procedure test_in_place_truncate_1 is
    message: variable_strings(10) := variable_string(10, "abc  ");
  begin
    in_place_truncate (message);
    if not same (message, "abc") then
      report("Failed variable_strings.test_in_place_truncate_1 a");
    end if;
    if length(message)/=3 then
      report("Failed variable_strings.length b");
    end if;
  end test_in_place_truncate_1;

  procedure test_lessthan_1 is
  begin
    if         variable_string(25, "abc")<variable_string(25, "ab")   then
      report("Failed variable_strings test <1 got abc<ab");
    elsif not (variable_string(25, "ab") <variable_string(25, "abc")) then
      report("Failed variable_strings test <1 got ab>=abc");
    elsif      variable_string(25, "ac") <variable_string(25, "ab")   then
      report("Failed variable_strings test <1 got ac<ab");
    elsif not (variable_string(25, "ab") <variable_string(25, "ac"))  then
      report("Failed variable_strings test <1 got ab>=ac");
    elsif      variable_string(25, "abc")<variable_string(25, "aa")   then
      report("Failed variable_strings test <1 got abc<aa");
    elsif not (variable_string(25, "aa") <variable_string(25, "abc")) then
      report("Failed variable_strings test <1 got aa>=abc");
    elsif      variable_string(25, "ac") <variable_string(25, "abc")  then
      report("Failed variable_strings test <1 got ac<abc");
    elsif not (variable_string(25, "abc")<variable_string(25, "ac"))  then
      report("Failed variable_strings test <1 got abc>=ac");
    elsif not (variable_string(25, "abc")>variable_string(25, "ab"))  then
      report("Failed variable_strings test >1 got abc<ab");
    elsif not (variable_string(25, "abc")<variable_string(25, "ac"))  then
      report("Failed variable_strings test <1 got abc>=ac");
    elsif     (variable_string(25, "ab") >variable_string(25, "abc")) then
      report("Failed variable_strings test <1 got ab>=abc");
    elsif not (variable_string(25, "ac") >variable_string(25, "ab"))  then
      report("Failed variable_strings test <1 got ac<ab");
    elsif     (variable_string(25, "ab") >variable_string(25, "ac"))  then
      report("Failed variable_strings test <1 got ab>=ac");
    elsif not (variable_string(25, "abc")>variable_string(25, "aa"))  then
      report("Failed variable_strings test <1 got abc<aa");
    elsif     (variable_string(25, "aa") >variable_string(25, "abc")) then
      report("Failed variable_strings test <1 got aa>=abc");
    elsif not (variable_string(25, "ac") >variable_string(25, "abc"))  then
      report("Failed variable_strings test <1 got ac<abc");
    end if;
  end test_lessthan_1;

  procedure test_same_1 is
    SS: constant string :="Now is the time for all good men to come to the";
    a,b,c,d: variable_strings(100);
  begin
    assign(a,"Now");
    assign(b,"Now");
    assign(c,"Now ");
    assign(d," Now");
    if not same (a, b) then
      report("Failed variable_strings.test_same_1 1");
    elsif same (a,c) then
      report("Failed variable_strings.test_same_1 2");
    elsif same (a,d) then
      report("Failed variable_strings.test_same_1 3");
    end if;
    assign(c,SS);
    assign(d,SS);
    if not same (c,d) then
      report("Failed variable_strings.test_same_1 4");
    end if;
  end test_same_1;

  procedure test_slice_1 is
    x, y, z: variable_strings(10);
    okay: constant string := "abcd";
  begin
    assign(x, "abc");
    assign(y, okay(2..3));
    assign(z, slice(x, 2, 3));
    if not same (y,z) then
      report("Failed variable_strings.test_slice_1 a");
    end if;
    assign(z, substr(x,2,2));
    if not same (z,y) then
      report("Failed variable_strings.test_slice_1 b");
    end if;
    if substr(z,1,0)/="" then
      report("Failed variable_strings.test_slice_1 c");
    end if;
  end test_slice_1;

  procedure test_variable_string is
    temp: constant string:= "(abcdefg)";
    temp_fixed: variable_strings(10);
  begin
    temp_fixed:= variable_string (10, temp (2..8));
    if not same(temp_fixed, "abcdefg") then
      report ("Failed variable_string_MANAGMENT.fixed string A");
    end if;
  end test_variable_string;

begin
  test_variable_string;
  test_assign_1;
  test_case_1;
  test_concat_1;
  test_element_1;
  test_in_place_truncate_1;
  test_lessthan_1;
  test_same_1;
  test_slice_1;
  status.telln("tsstrvar passed");
end tsstrvar;