home *** CD-ROM | disk | FTP | other *** search
/ The Unsorted BBS Collection / thegreatunsorted.tar / thegreatunsorted / programming / misc_programming / ADAUTIL / W.ADA < prev   
Encoding:
Text File  |  1990-06-28  |  2.8 KB  |  121 lines
  1. -- w - write args to standard output.
  2. --
  3. -- This is a program similar to the PC-DOS ECHO command, with a
  4. -- few bells and whistles thrown in.
  5. --
  6. -- usage: w [-s n] [-r n] [-n n] [text ...]
  7. --
  8. --   -s n = print n spaces before text
  9. --   -r n = print n copies of text on same line
  10. --   -n n = print n newlines before text
  11. --            (at least one newline is always printed at the end)
  12. --
  13. -- original: 5 Apr 87, jns, Meridian Software Systems, Inc.
  14.  
  15. with arg;
  16. with text_io;   use text_io;
  17. procedure w is
  18.   type string_p is access string;
  19.  
  20.   thisarg: string_p;
  21.   argno: integer := 2;
  22.   argpos: integer;
  23.   space_count: integer := 0;
  24.   rept_count: integer := 1;
  25.   newline_count: integer := 0;
  26.   printed_newline: Boolean := false;
  27.   print_thisarg: Boolean := false;
  28.  
  29.   function next_arg return string_p is
  30.     a: string_p;
  31.   begin
  32.     if argno <= arg.count then
  33.       a := new string'(arg.data(argno));
  34.       argno := argno + 1;
  35.     else
  36.       a := new string'("");
  37.     end if;
  38.  
  39.     return a;
  40.   end;
  41.  
  42.   function numarg return integer is
  43.     thisarg: string_p;
  44.     i: integer := 1;
  45.     n: integer := 0;
  46.   begin
  47.     thisarg := next_arg;
  48.     if thisarg'length = 0 then
  49.       put_line("w: numeric argument expected");
  50.     else
  51.       while i <= thisarg'length and then thisarg(i) in '0'..'9' loop
  52.     n := (n * 10) + (character'pos(thisarg(i)) - character'pos('0'));
  53.     i := i + 1;
  54.       end loop;
  55.     end if;
  56.  
  57.     return n;
  58.   end;
  59.  
  60.   procedure put_thisarg is
  61.   begin
  62.     while rept_count > 0 loop
  63.       put(thisarg.all);
  64.       rept_count := rept_count - 1;
  65.     end loop;
  66.     rept_count := 1;
  67.     print_thisarg := false;
  68.   end put_thisarg;
  69.  
  70. begin -- w
  71.   while argno <= arg.count loop
  72.     thisarg := next_arg;
  73.     if thisarg'length > 0 then
  74.       argpos := thisarg'first;
  75.       if thisarg(argpos) = '-' then
  76.     print_thisarg := false;
  77.     argpos := argpos + 1;
  78.     while argpos <= thisarg'length loop
  79.       case thisarg(argpos) is
  80.         when 's'    => space_count   := numarg;
  81.         when 'r'    => rept_count    := numarg;
  82.         when 'n'    => newline_count := numarg;
  83.         when others => print_thisarg := true;
  84.       end case;
  85.       argpos := argpos + 1;
  86.     end loop;
  87.       else
  88.     print_thisarg := true;
  89.       end if;
  90.  
  91.       while space_count > 0 loop
  92.     put(' ');
  93.     space_count := space_count - 1;
  94.       end loop;
  95.       if not print_thisarg then
  96.     space_count := 0;
  97.       else
  98.     space_count := 1;
  99.       end if;
  100.  
  101.       printed_newline := false;
  102.       if newline_count > 0 then
  103.     while newline_count > 0 loop
  104.       new_line;
  105.       newline_count := newline_count - 1;
  106.     end loop;
  107.     space_count := 0;
  108.     printed_newline := true;
  109.       end if;
  110.  
  111.       if print_thisarg then
  112.     put_thisarg;
  113.       end if;
  114.     end if;
  115.   end loop;
  116.  
  117.   if not printed_newline then
  118.     new_line;
  119.   end if;
  120. end w;
  121.