OS/2 Shareware BBS: 10 Tools/10-Tools.zip/sa104os2.zip/SATHR104.ZIP/SATHER/LIBRARY/STR_CURS.SA

Text File | 1995-02-05 | 17KB | 889 lines

-- Copyright (C) International Computer Science Institute, 1994.  COPYRIGHT  --
-- NOTICE: This code is provided "AS IS" WITHOUT ANY WARRANTY and is subject --
-- to the terms of the SATHER LIBRARY GENERAL PUBLIC LICENSE contained in    --
-- the file "Doc/License" of the Sather distribution.  The license is also   --
-- available from ICSI, 1947 Center St., Suite 600, Berkeley CA 94704, USA.  --
--------> Please email comments to "[e-mail]". <----------

class STR_CURSOR is
   attr error:INT;

   readonly attr line_no:INT;
   readonly attr index:INT;
   readonly attr buf:STR;
   readonly attr is_done:BOOL;

   const Max_Real_Digits:INT := 30;
   const Max_Int_Digits:INT := 9;
   const Int_No_Bits:INT := 32;

   --error codes:
   const No_Error:INT := 0;
   const Bad_Digit:INT := 1;
   const Past_EOBuf:INT := 2;
   const Past_BOBuf:INT := 3;
   const Too_Many_Digits:INT := 4;
   const Cut_Set_Member_Not_Found:INT := 5;
   const Bad_Prefix:INT := 6;
   const Bad_Boolean:INT := 7;



   create(s:STR):SAME is
      res ::= new;

      if (void(s)) then
         res := void;
      else
         res.reassign(s);
      end;
      --(if)

      return (res);
   end;
   --(create(STR):SAME)


   reassign(s:STR) is
      if (~void(self)) then
         buf := s;
         index := 0;
         line_no := 1;
         is_done := false;
         clear_error;

         if (void(buf) or (buf.length = 0)) then
            is_done := true;
         end;
         --(if)
      end;
      --(if)
   end;
   --(reassign(STR))



   clear_error is
      error := No_Error;
   end;
   --(clear_error)



   clear is
      reassign(#STR);
   end;
   --(clear)


   item:CHAR is
      if (is_done) then
     return ('\0');
--    else                                                                      -- NLP
--       return (buf[index]);                                                   -- NLP
      end;
      --(if)
      return (buf[index]);                                                      -- NLP
   end;
   --(item:CHAR)



   skip_space is
      loop while!(~is_done and item.is_space);
     advance_one_char;
      end;
      --(loop)
   end;
   --(skip_space)



   skip_space:SAME is
      skip_space;
      return self;
   end;
   --(skip_space:SAME)



   skip_word is
      loop until!(is_done or item.is_space);
     advance_one_char;
      end;
      --(loop)
   end;
   --(skip_word)



   skip_word:SAME is
      skip_word;
      return self;
   end;
   --(skip_word:SAME)



   skip_thru(c:CHAR) is
      loop until!(is_done or (item = c));
     advance_one_char;
      end;
      --(loop)
   end;
   --(skip_to(CHAR))



   skip_thru(c:CHAR):SAME is
      skip_thru(c);
      return self;
   end;
   --(skip_thru(CHAR):SAME)


    skip_thru(s:STR) is
       -- Translated from STR::search.
       if void(s) then return end;
       loop r:INT:=index.upto!(buf.size-s.size); match::=true;
        loop if buf.elt!(r)/=s.elt! then
           match:=false; break! end end;
        if match then
           index:=r;
           return;
        end;
       end;
       is_done:=true;
       return;
    end;
    --(skip_thru(STR))

    skip_thru(s:STR):SAME is
       skip_thru(s);
       return self;
    end;
    --(skip_thru(STR):SAME)

    skip_over(s:STR) is
     skip_thru(s);
     if (~is_done) then
      index:=index+s.size;
     end;
    end;




   advance_one_char is
      if (is_done) then
     error := Past_EOBuf;
      else
     index := index + 1;

     if (index >= buf.length) then
        is_done := true;
     elsif (item = '\n') then
        line_no := line_no + 1;
     end;
     --(if)
      end;
      --(if)
   end;
   --(advance_one_char)



   advance_one_char:SAME is
      advance_one_char;
      return self;
   end;
   --(advance_one_char:SAME)



   retract_one_char is
      if (index <= 0) then
     error := Past_BOBuf;
      else
     index := index - 1;

     if (item = '\n') then
        line_no := line_no - 1;
     end;
     --(if)

     is_done := false;
      end;
      --(if)
   end;
   --(retract_one_char)



   retract_one_char:SAME is
      retract_one_char;
      return self;
   end;
   --(retract_one_char:SAME)



   get_char:CHAR is
      res ::= item;
      advance_one_char;
      return (res);
   end;
   --(get_char)



   get_word:STR is
      res ::= #STR;

      skip_space;

      loop until!(is_done or item.is_space);
     res := res + get_char;
      end;
      --(loop)

      return (res);
   end;
   --(get_word:STR)



   get_word(max_char_count:INT):STR is
      --get a word up to max_char_count CHAR's long

      res ::= #STR;

      skip_space;

      loop until!(is_done or (max_char_count <= 0) or item.is_space);
     res := res + get_char;
     max_char_count := max_char_count - 1;
      end;
      --(loop)

      return (res);
   end;
   --(get_word(INT):STR)


    get_up_to(c:CHAR):STR is
       res ::= #STR;

       loop until!(is_done or item = c);
        res := res + get_char;
       end;
       --(loop)

       return (res);
    end;
    --(get_up_to:STR)



   int:INT is
      --to support str_curs.sa's int which accepts any of the 4 formats:
      --1) decimal, 2) binary, 3) hex, 4) octal.
      --unlike str_curs.sa, this only sets error code and doesn't raise an
      --exception.

      --leading 0's in any format do not contribute towards an overflow error
      --all formats may use '-' to give the 2's complement of the int.

      res:INT;
      neg_sign:BOOL;

      skip_space;
      neg_sign := get_opt_sign;

      if (item = '0') then
     advance_one_char;

     case (item)
     when 'b' then
        advance_one_char;
        res := get_unsigned_unprefixed_binary;
     when 'o' then
         advance_one_char;
         res := get_unsigned_unprefixed_octal;
     when 'x' then
         advance_one_char;
         res := get_unsigned_unprefixed_hex;
     else
        retract_one_char;
        res := get_unsigned_int;
     end;
     --(case)
      else
     res := get_unsigned_int;
      end;
      --(if)

      if (neg_sign) then
     res := -res;
      end;
      --(if)

      return (res);
   end;
   --(int:INT)



   get_int:INT is
      --decimal format optionally signed with '+', '-', or '\0'

      res:INT;
      neg_sign:BOOL;

      skip_space;
      neg_sign := get_opt_sign;
      res := get_unsigned_int;

      if (neg_sign) then
     res := -res;
      end;
      --(if)

      return (res);
   end;
   --(get_int:INT)



   get_binary:INT is
      -- BIN ::= OPT_SIGN '0b' (0 | 1)+
      -- OPT_SIGN ::= '+' | '-' | '\0'
      --and stops at the first non-binary digit found.
      --leading 0's ignored.

      -- '-' prefix gives 2's complement of following binary number.

      res:INT;
      neg_sign:BOOL;

      skip_space;
      neg_sign := get_opt_sign;

      if (get_char /= '0') then
     error := Bad_Prefix;
     return (res);
      elsif (get_char /= 'b') then
     error := Bad_Prefix;
     return (res);
      end;
      --(if)

      res := get_unsigned_unprefixed_binary;

      if (neg_sign) then
     res := -res;
      end;
      --(if)

      return (res);
   end;
   --(get_binary:INT)



   get_octal:INT is
      -- OCT ::= '0o' (0 .. 7)+  stoping at first non-octal digit found.
      --leading 0's ignored.

      -- '-' prefix gives 2's complement of following octal number.

      res:INT;
      neg_sign:BOOL;

      skip_space;
      neg_sign := get_opt_sign;

      if (get_char /= '0') then
     error := Bad_Prefix;
     return (res);
      elsif (get_char /= 'o') then
     error := Bad_Prefix;
     return (res);
      end;
      --(if)

      res := get_unsigned_unprefixed_octal;

      if (neg_sign) then
     res := -res;
      end;
      --(if)

      return (res);
   end;
   --(get_octal:INT)



   get_hex:INT is
      -- HEX ::= OPT_SIGN ('0x' | '0X') HEX_DIGIT+
      -- OPT_SIGN ::= '+' | '-' | '\0'
      -- HEX_DIGIT ::= ('0' .. '9') | ('a' .. 'f') | ('A' .. 'F')

      -- '-' prefix gives 2's complement of following hex dnumber

      res:INT;
      neg_sign:BOOL;

      skip_space;
      neg_sign := get_opt_sign;

      if (get_char /= '0') then
     error := Bad_Prefix;
     return (res);
      elsif ((item /= 'x') and  (item /= 'X')) then
     advance_one_char;
     error := Bad_Prefix;
     return (res);
      else
     --i.e., was 'x' or 'X'
     advance_one_char;
      end;
      --(if)

      res := get_unsigned_unprefixed_hex;

      if (neg_sign) then
     res := -res;
      end;
      --(if)

      return (res);
   end;
   --(get_hex:INT)



   get_flt:FLT is
      return (get_fltd.flt);
   end;
   --(get_flt:FLT)



   get_fltd:FLTD is
      --accepts real numbers of format:
      -- FLTD         ::= SIGNED_INT {'.' {UNSIGNED_INT} {'e' SIGNED_INT}
      -- SIGNED_INT   ::= {'+' | '-' | '\0'} UNSIGNED_INT
      -- UNSIGNED_INT ::= (0 .. 9)+
      --
      --no spaces allowed between components of FLTD

      res:FLTD;
      neg_sign:BOOL;

      skip_space;

      neg_sign := get_opt_sign;
      res := get_unsigned_int_as_fltd;

      if (item = '.') then
     --eat the '.' and read in an unsigned int as decimal fraction l->r.
     advance_one_char;
     res := res + get_frac;
      end;
      --(if)

      if (item = 'e') then
     --eat the 'e' and get the integer exponent
     advance_one_char;
     res := res * get_opt_int.fltd.exp10;
      end;
      --(if)

      if (neg_sign) then
     res := -res;
      end;
      --(if)

      return (res);
   end;
   --(get_fltd:FLTD)



   get_opt_sign:BOOL is
      --returns 'true' if '-' is found,  else 'false'.
      --advances index by 1 if '-' or '+' is found, else index not advanced.

      res:BOOL;

      if (item = '-') then
     --unary minus:
     res := true;
     advance_one_char;
      elsif (item = '+') then
     --unary plus:
     advance_one_char;
      end;
      --(if)

      return (res);
   end;
   --(get_opt_sign:BOOL)



   get_str:STR is
      --get string up to and including '\n' or end of buf.

      res ::= #STR;
      skip_space;

      loop until!(is_done);
     res := res + get_char;

     if (item = '\n') then
        break!;
     end;
     --(if)
      end;
      --(loop)

      return (res);
   end;
   --(get_str:STR)



   get_str_cut(cut_set:STR):STR is
      -- get string up to and including cut_set member found.

      res ::= #STR;
      c:CHAR;

      skip_space;

      loop until!(is_done);
     c := get_char;
     res := res + c;

     if (cut_set.search(c) /= -1) then
        return (res);
     end;
     --(if)
      end;
      --(loop)

      error := Cut_Set_Member_Not_Found;
      return (res);
   end;
   --(get_s_cut(STR):STR)




   private get_unsigned_int:INT is
      --doesn't skip spaces:  assumes that
      --  either "sign" or "decimal point" has just been fetched.

      res:INT;
      num_digits:INT;

      loop while!(~is_done and item.is_digit);
     if ((res /= 0) and (num_digits > Max_Int_Digits)) then
        error := Too_Many_Digits;
        break!;
     end;
     --(if)

     if ((res = 0) and (item /= '0')) then
        --found first non-zero digit:  throw leading 0's away.
        num_digits := 1;
     end;
     --(if)

     num_digits := num_digits + 1;
     res := (res * 10) + get_char.digit_value;
      end;
     --(loop)

      if (num_digits = 0) then
     error := Bad_Digit;
      end;
      --(if)

      return (res);
   end;
   --(get_unsigned_int:INT)



   private get_unsigned_unprefixed_binary:INT is
      res:INT;
      count:INT;
      bit:CHAR;

      loop
     if ((count >= Int_No_Bits) and (res /= 0)) then
        error := Too_Many_Digits;
        break!;
     end;
     --(if)

     bit := item;

     case (bit)
     when '0' then
        --do nothing
     when '1' then
        if (res = 1) then
           count := 0;
        end;
        --(if)
     else
        break!;
     end;
     --(case)

     res := res.lshift(1).bor(get_char.digit_value);
     count := count + 1;
     until!(is_done);
      end;
      --(loop)

      if (count = 0) then
     --never started the number!
     error := Bad_Digit;
      end;
      --(if)

      return (res);
   end;
   --(get_unsigned_unprefixed_binary)



   private get_unsigned_unprefixed_octal:INT is
      res:INT;
      count:INT;
      oct:CHAR;

      loop
     if ((count >= Int_No_Bits) and (res /= 0)) then
        error := Too_Many_Digits;
        break!;
     end;
     --(if)

     oct := item;

     case (oct)
     when '0' then
        --do nothing
     when '1' then
        if (res = 0) then
           --first non-zero digit found: bit count = 1 = (-2) + 3
           count := -2;
        end;
        --(if)
     when '2', '3' then
        --first non-zero digit found: bit count = 2 = (-1) + 3
        if (res = 0) then
           count := -1;
        end;
        --(if)
     when '4', '5', '6', '7' then
        if (res = 0) then
           count := 0;
        end;
        --(if)
     else
        break!;
     end;
     --(case)

     res := res.lshift(3).bor(get_char.octal_digit_value);
     count := count + 3;
     until!(is_done);
      end;
      --(loop)

      if (count = 0) then
     --never started the number!
     error := Bad_Digit;
      end;
      --(if)

      return (res);
   end;
   --(get_unsigned_unprefixed_octal:INT)



   private get_unsigned_unprefixed_hex:INT is
      res:INT;
      count:INT;
      hex:CHAR;

      if (~item.is_hex_digit) then
     error := Bad_Digit;
     return 0;
      end;
      --(if)

      loop
     if ((count >= Int_No_Bits) and (res /= 0)) then
        error := Too_Many_Digits;
        break!;
     end;
     --(if)

     hex := item;

     case (hex)
     when '0' then
        --do nothing
     when '1' then
        if (res = 0) then
           --first non-zero digit found
           count := -3;
        end;
        --(if)
     when '2', '3' then
        if (res = 0) then
           --first non-zero digit found
           count := -2;
        end;
        --(if)
     when '4', '5', '6', '7'  then
        if (res = 0) then
           --first non-zero digit found
           count := -1;
        end;
        --(if)
     when '8', '9',
        'a', 'b', 'c', 'd', 'e', 'f',
        'A', 'B', 'C', 'D', 'E', 'F'
     then
        --do nothing
     else
        break!;
     end;
     --(case)


     res := res.lshift(4).bor(get_char.hex_digit_value);
     count := count + 4;
     until!(is_done);
      end;
      --(loop)

      return (res);
   end;
   --(get_unsigned_unprefixed_hex:INT)



   private get_unsigned_int_as_fltd:FLTD is
      --doesn't skip spaces:  assumes that
      --  either "sign" or "decimal point" has just been fetched.
      res:FLTD;
      num_digits:INT;

      if (~item.is_digit) then
     error := Bad_Digit;
      else
     loop while!(~is_done and item.is_digit);
       num_digits := num_digits + 1;

           if ((res /= 0.0d) and (num_digits > Max_Real_Digits)) then
          error := Too_Many_Digits;
          break!;
           end;
           --(if)

        if ((res = 0.0d) and (item /= '0')) then
           --found first non-zero digit:  throw leading 0's away.
           num_digits := 1;
        end;
        --(if)

        res := (res * 10.0d) + get_char.digit_value.fltd;
     end;
     --(loop)
      end;
      --(if)

      return (res);
     end;
   --(get_unsigned_int_as_fltd:FLTD)



   private get_frac:FLTD is
      --starting at leftmost digit, read in decimal fraction

      res:FLTD;
      multiplier:FLTD := 0.1d;

      loop until!(is_done or ~item.is_digit);
     res := res + (get_char.digit_value.fltd * multiplier);
     multiplier := multiplier / 10.0d;
      end;
      --(loop)

      return (res);
   end;
   --(get_frac:FLTD)



   get_opt_int:INT is
      --if int is not present then no error.

      res:INT;

      if (error /= No_Error) then
         --entered with error: cannot do anything.  Don't reset exisiting
         --  error.
         return 0;
      end;
      --(if)

      res := get_int;

      if (error /= No_Error) then
         --no int present: eliminate error set
         error := No_Error;
         res := 0;
      end;
      --(if)

      return (res);
   end;
   --(get_opt_int:INT)

   get_bool:BOOL is
      res:BOOL;
      boolean ::= get_word.lower;

      case (boolean)
      when "true", "t", "True", "T", "TRUE" then
         res := true;
      when "false", "f", "False", "F", "FALSE" then
         res := false;
      else
         error := Bad_Boolean;
      end;
      --(case)

      return (res);
   end;
   --(get_bool:BOOL)


end;
   --(STR_CURSOR)