⟦b71750c38⟧

TextFile

with Misc_Defs, Tstring, Text_Io, Misc, Main_Body;
with Int_Io, Calendar, External_File_Manager;
use Misc, Misc_Defs, Text_Io, External_File_Manager;

package body Misc is
    use Tstring;
    -- action_out - write the actions from the temporary file to lex.yy.c

    procedure Action_Out is
        Buf : Vstring;
    begin
        while (not Text_Io.End_Of_File (Temp_Action_File)) loop
            Tstring.Get_Line (Temp_Action_File, Buf);
            if ((Tstring.Len (Buf) >= 2) and then
                ((Char (Buf, 1) = '%') and (Char (Buf, 2) = '%'))) then
                exit;
            else
                Tstring.Put_Line (Buf);
            end if;
        end loop;
    end Action_Out;

    -- bubble - bubble sort an integer array in increasing order
    --
    -- description
    --   sorts the first n elements of array v and replaces them in
    --   increasing order.
    --
    -- passed
    --   v - the array to be sorted
    --   n - the number of elements of 'v' to be sorted

    procedure Bubble (V : in Int_Ptr; N : in Integer) is
        K : Integer;
    begin
        for I in reverse 2 .. N loop
            for J in 1 .. I - 1 loop
                if (V (J) > V (J + 1)) then

                    -- compare
                    K := V (J);

                    -- exchange
                    V (J) := V (J + 1);
                    V (J + 1) := K;
                end if;
            end loop;
        end loop;
    end Bubble;


    -- clower - replace upper-case letter to lower-case

    function Clower (C : in Integer) return Integer is
    begin
        if (Isupper (Character'Val (C))) then
            return Tolower (C);
        else
            return C;
        end if;
    end Clower;


    -- cshell - shell sort a character array in increasing order
    --
    -- description
    --   does a shell sort of the first n elements of array v.
    --
    -- passed
    --   v - array to be sorted
    --   n - number of elements of v to be sorted

    procedure Cshell (V : in out Char_Array; N : in Integer) is
        Gap, J, Jg : Integer;
        K : Character;
        Lower_Bound : Integer := V'First;
    begin
        Gap := N / 2;
        while Gap > 0 loop
            for I in Gap .. N - 1 loop
                J := I - Gap;
                while (J >= 0) loop
                    Jg := J + Gap;

                    if (V (J + Lower_Bound) <= V (Jg + Lower_Bound)) then
                        exit;
                    end if;

                    K := V (J + Lower_Bound);
                    V (J + Lower_Bound) := V (Jg + Lower_Bound);
                    V (Jg + Lower_Bound) := K;
                    J := J - Gap;
                end loop;
            end loop;
            Gap := Gap / 2;
        end loop;
    end Cshell;


    -- dataend - finish up a block of data declarations

    procedure Dataend is
    begin
        if (Datapos > 0) then
            Dataflush;

            -- add terminator for initialization
            Text_Io.Put_Line ("    ) ;");
            Text_Io.New_Line;

            Dataline := 0;
        end if;
    end Dataend;


    -- dataflush - flush generated data statements

    procedure Dataflush (File : in File_Type) is
    begin
        Text_Io.New_Line (File);
        Dataline := Dataline + 1;
        if (Dataline >= Numdatalines) then

            -- put out a blank line so that the table is grouped into
            -- large blocks that enable the user to find elements easily
            Text_Io.New_Line (File);
            Dataline := 0;
        end if;

        -- reset the number of characters written on the current line
        Datapos := 0;
    end Dataflush;

    procedure Dataflush is
    begin
        Dataflush (Current_Output);
    end Dataflush;
    -- aflex_gettime - return current time

    function Aflex_Gettime return Vstring is
        use Tstring, Calendar;
        Current_Time : Time;
        Current_Year : Year_Number;
        Current_Month : Month_Number;
        Current_Day : Day_Number;
        Current_Seconds : Day_Duration;
        Month_String, Hour_String, Minute_String, Second_String : Vstring;
        Hour, Minute, Second : Integer;
        Seconds_Per_Hour : constant Day_Duration := 3600.0;
    begin
        Current_Time := Clock;
        Split (Current_Time, Current_Year, Current_Month,
               Current_Day, Current_Seconds);
        case Current_Month is
            when 1 =>
                Month_String := Vstr ("Jan");
            when 2 =>
                Month_String := Vstr ("Feb");
            when 3 =>
                Month_String := Vstr ("Mar");
            when 4 =>
                Month_String := Vstr ("Apr");
            when 5 =>
                Month_String := Vstr ("May");
            when 6 =>
                Month_String := Vstr ("Jun");
            when 7 =>
                Month_String := Vstr ("Jul");
            when 8 =>
                Month_String := Vstr ("Aug");
            when 9 =>
                Month_String := Vstr ("Sep");
            when 10 =>
                Month_String := Vstr ("Oct");
            when 11 =>
                Month_String := Vstr ("Nov");
            when 12 =>
                Month_String := Vstr ("Dec");
        end case;

        Hour := Integer (Current_Seconds) / Integer (Seconds_Per_Hour);
        Minute := Integer ((Current_Seconds - (Hour * Seconds_Per_Hour)) / 60);
        Second := Integer (Current_Seconds -
                           Hour * Seconds_Per_Hour - Minute * 60.0);

        if (Hour >= 10) then
            Hour_String := Vstr (Integer'Image (Hour));
        else
            Hour_String := Vstr ("0" & Integer'Image (Hour));
        end if;

        if (Minute >= 10) then
            Minute_String := Vstr (Integer'Image (Minute)
                                      (2 .. Integer'Image (Minute)'Length));
        else
            Minute_String := Vstr ("0" &
                                   Integer'Image (Minute)
                                      (2 .. Integer'Image (Minute)'Length));
        end if;

        if (Second >= 10) then
            Second_String := Vstr (Integer'Image (Second)
                                      (2 .. Integer'Image (Second)'Length));
        else
            Second_String := Vstr ("0" &
                                   Integer'Image (Second)
                                      (2 .. Integer'Image (Second)'Length));
        end if;

        return Month_String & Vstr (Integer'Image (Current_Day)) &
                  Hour_String & ":" & Minute_String & ":" &
                  Second_String & Integer'Image (Current_Year);
    end Aflex_Gettime;

    -- aflexerror - report an error message and terminate
    -- overloaded function, one for vstring, one for string.
    procedure Aflexerror (Msg : in Vstring) is
        use Text_Io;
    begin
        Tstring.Put (Standard_Error, "aflex: " & Msg);
        Text_Io.New_Line (Standard_Error);
        Main_Body.Aflexend (1);
    end Aflexerror;

    procedure Aflexerror (Msg : in String) is
        use Text_Io;
    begin
        Text_Io.Put (Standard_Error, "aflex: " & Msg);
        Text_Io.New_Line (Standard_Error);
        Main_Body.Aflexend (1);
    end Aflexerror;

    -- aflexfatal - report a fatal error message and terminate
    -- overloaded function, one for vstring, one for string.
    procedure Aflexfatal (Msg : in Vstring) is
        use Text_Io;
    begin
        Tstring.Put (Standard_Error, "aflex: fatal internal error " & Msg);
        Text_Io.New_Line (Standard_Error);
        Main_Body.Aflexend (1);
    end Aflexfatal;

    procedure Aflexfatal (Msg : in String) is
        use Text_Io;
    begin
        Text_Io.Put (Standard_Error, "aflex: fatal internal error " & Msg);
        Text_Io.New_Line (Standard_Error);
        Main_Body.Aflexend (1);
    end Aflexfatal;

    -- basename - find the basename of a file
    function Basename return Vstring is
        End_Char_Pos : Integer := Len (Infilename);
        Start_Char_Pos : Integer;
    begin
        if (End_Char_Pos = 0) then
            -- if reading standard input give everything this name
            return Vstr ("aflex_yy");
        end if;

        -- find out where the end of the basename is
        while ((End_Char_Pos >= 1) and then
               (Char (Infilename, End_Char_Pos) /= '.')) loop
            End_Char_Pos := End_Char_Pos - 1;
        end loop;

        -- find out where the beginning of the basename is
        Start_Char_Pos := End_Char_Pos; -- start at the end of the basename
        while ((Start_Char_Pos > 1) and then
               (Char (Infilename, Start_Char_Pos) /= '/')) loop
            Start_Char_Pos := Start_Char_Pos - 1;
        end loop;

        if (Char (Infilename, Start_Char_Pos) = '/') then
            Start_Char_Pos := Start_Char_Pos + 1;
        end if;

        if (End_Char_Pos >= 1) then
            return Slice (Infilename, Start_Char_Pos, End_Char_Pos - 1);
        else
            return Infilename;
        end if;
    end Basename;

    -- line_directive_out - spit out a "# line" statement

    procedure Line_Directive_Out (Output_File_Name : in File_Type) is
    begin
        if (Gen_Line_Dirs) then
            Text_Io.Put (Output_File_Name, "--# line ");
            Int_Io.Put (Output_File_Name, Linenum, 1);
            Text_Io.Put (Output_File_Name, " """);
            Tstring.Put (Output_File_Name, Infilename);
            Text_Io.Put_Line (Output_File_Name, """");
        end if;
    end Line_Directive_Out;


    procedure Line_Directive_Out is
    begin
        if (Gen_Line_Dirs) then
            Text_Io.Put ("--# line ");
            Int_Io.Put (Linenum, 1);
            Text_Io.Put (" """);
            Tstring.Put (Infilename);
            Text_Io.Put_Line ("""");
        end if;
    end Line_Directive_Out;

    -- all_upper - returns true if a string is all upper-case
    function All_Upper (Str : in Vstring) return Boolean is
    begin
        for I in 1 .. Len (Str) loop
            if (not ((Char (Str, I) >= 'A') and (Char (Str, I) <= 'Z'))) then
                return False;
            end if;
        end loop;
        return True;
    end All_Upper;

    -- all_lower - returns true if a string is all lower-case
    function All_Lower (Str : in Vstring) return Boolean is
    begin
        for I in 1 .. Len (Str) loop
            if (not ((Char (Str, I) >= 'a') and (Char (Str, I) <= 'z'))) then
                return False;
            end if;
        end loop;
        return True;
    end All_Lower;

    -- mk2data - generate a data statement for a two-dimensional array
    --
    --  generates a data statement initializing the current 2-D array to "value"

    procedure Mk2data (File : in File_Type; Value : in Integer) is
    begin

        if (Datapos >= Numdataitems) then
            Text_Io.Put (File, ',');
            Dataflush (File);
        end if;

        if (Datapos = 0) then

            -- indent
            Text_Io.Put (File, "    ");
        else
            Text_Io.Put (File, ',');
        end if;

        Datapos := Datapos + 1;

        Int_Io.Put (File, Value, 5);
    end Mk2data;

    procedure Mk2data (Value : in Integer) is
    begin
        Mk2data (Current_Output, Value);
    end Mk2data;

    --
    --  generates a data statement initializing the current array element to
    --  "value"

    procedure Mkdata (Value : in Integer) is
    begin
        if (Datapos >= Numdataitems) then
            Text_Io.Put (',');
            Dataflush;
        end if;

        if (Datapos = 0) then

            -- indent
            Text_Io.Put ("    ");
        else
            Text_Io.Put (',');
        end if;

        Datapos := Datapos + 1;

        Int_Io.Put (Value, 5);
    end Mkdata;


    -- myctoi - return the integer represented by a string of digits

    function Myctoi (Num_Array : in Vstring) return Integer is
        Total : Integer := 0;
        Cnt : Integer := Tstring.First;
    begin
        while (Cnt <= Tstring.Len (Num_Array)) loop
            Total := Total * 10;
            Total := Total + Character'Pos (Char (Num_Array, Cnt)) -
                        Character'Pos ('0');
            Cnt := Cnt + 1;
        end loop;
        return Total;
    end Myctoi;


    -- myesc - return character corresponding to escape sequence

    function Myesc (Arr : in Vstring) return Character is
        use Text_Io;
    begin
        case (Char (Arr, Tstring.First + 1)) is
            when 'a' =>
                return Ascii.Bel;
            when 'b' =>
                return Ascii.Bs;
            when 'f' =>
                return Ascii.Ff;
            when 'n' =>
                return Ascii.Lf;
            when 'r' =>
                return Ascii.Cr;
            when 't' =>
                return Ascii.Ht;
            when 'v' =>
                return Ascii.Vt;

            when '0' | '1' | '2' | '3' | '4' | '5' | '6' | '7' | '8' | '9' =>

                -- \<octal>
                declare
                    C, Esc_Char : Character;
                    Sptr : Integer := Tstring.First + 1;
                begin
                    Esc_Char := Otoi (Tstring.Slice (Arr, Tstring.First + 1,
                                                     Tstring.Len (Arr)));
                    if (Esc_Char = Ascii.Nul) then
                        Misc.Synerr ("escape sequence for null not allowed");
                        return Ascii.Soh;
                    end if;

                    return Esc_Char;
                end;
            when others =>
                return Char (Arr, Tstring.First + 1);
        end case;
    end Myesc;


    -- otoi - convert an octal digit string to an integer value

    function Otoi (Str : in Vstring) return Character is
        Total : Integer := 0;
        Cnt : Integer := Tstring.First;
    begin
        while (Cnt <= Tstring.Len (Str)) loop
            Total := Total * 8;
            Total := Total + Character'Pos (Char (Str, Cnt)) -
                        Character'Pos ('0');
            Cnt := Cnt + 1;
        end loop;
        return Character'Val (Total);
    end Otoi;


    -- readable_form - return the the human-readable form of a character
    --
    -- The returned string is in static storage.

    function Readable_Form (C : in Character) return Vstring is
    begin
        if ((Character'Pos (C) >= 0 and Character'Pos (C) < 32) or
            (C = Ascii.Del)) then
            case C is
                when Ascii.Lf =>
                    return (Vstr ("\n"));

                    -- Newline
                when Ascii.Ht =>
                    return (Vstr ("\t"));

                    -- Horizontal Tab
                when Ascii.Ff =>
                    return (Vstr ("\f"));

                    -- Form Feed
                when Ascii.Cr =>
                    return (Vstr ("\r"));

                    -- Carriage Return
                when Ascii.Bs =>
                    return (Vstr ("\b"));

                    -- Backspace
                when others =>
                    return Vstr ("\" & Integer'Image (Character'Pos (C)));
            end case;
        elsif (C = ' ') then
            return Vstr ("' '");
        else
            return Vstr (C);
        end if;
    end Readable_Form;

    -- transition_struct_out - output a yy_trans_info structure
    --
    -- outputs the yy_trans_info structure with the two elements, element_v and
    -- element_n.  Formats the output with spaces and carriage returns.

    procedure Transition_Struct_Out (Element_V, Element_N : in Integer) is
    begin
        Int_Io.Put (Element_V, 7);
        Text_Io.Put (", ");
        Int_Io.Put (Element_N, 5);
        Text_Io.Put (",");
        Datapos := Datapos + Trans_Struct_Print_Length;

        if (Datapos >= 75) then
            Text_Io.New_Line;

            Dataline := Dataline + 1;
            if (Dataline mod 10 = 0) then
                Text_Io.New_Line;
            end if;

            Datapos := 0;
        end if;
    end Transition_Struct_Out;

    function Set_Yy_Trailing_Head_Mask (Src : in Integer) return Integer is
    begin
        if (Check_Yy_Trailing_Head_Mask (Src) = 0) then
            return Src + Yy_Trailing_Head_Mask;
        else
            return Src;
        end if;
    end Set_Yy_Trailing_Head_Mask;

    function Check_Yy_Trailing_Head_Mask (Src : in Integer) return Integer is
    begin
        if (Src >= Yy_Trailing_Head_Mask) then
            return Yy_Trailing_Head_Mask;
        else
            return 0;
        end if;
    end Check_Yy_Trailing_Head_Mask;

    function Set_Yy_Trailing_Mask (Src : in Integer) return Integer is
    begin
        if (Check_Yy_Trailing_Mask (Src) = 0) then
            return Src + Yy_Trailing_Mask;
        else
            return Src;
        end if;
    end Set_Yy_Trailing_Mask;

    function Check_Yy_Trailing_Mask (Src : in Integer) return Integer is
    begin

-- this test is whether both bits are on, or whether onlyy TRAIL_MASK is set
        if ((Src >= Yy_Trailing_Head_Mask + Yy_Trailing_Mask) or
            ((Check_Yy_Trailing_Head_Mask (Src) = 0) and
             (Src >= Yy_Trailing_Mask))) then
            return Yy_Trailing_Mask;
        else
            return 0;
        end if;
    end Check_Yy_Trailing_Mask;

    function Islower (C : in Character) return Boolean is
    begin
        return (C in 'a' .. 'z');
    end Islower;


    function Isupper (C : in Character) return Boolean is
    begin
        return (C in 'A' .. 'Z');
    end Isupper;

    function Isdigit (C : in Character) return Boolean is
    begin
        return (C in '0' .. '9');
    end Isdigit;

    function Tolower (C : in Integer) return Integer is
    begin
        return C - Character'Pos ('A') + Character'Pos ('a');
    end Tolower;

    procedure Synerr (Str : in String) is
        use Text_Io;
    begin
        Syntaxerror := True;
        Text_Io.Put (Standard_Error, "Syntax error at line ");
        Int_Io.Put (Standard_Error, Linenum);
        Text_Io.Put (Standard_Error, Str);
        Text_Io.New_Line (Standard_Error);
    end Synerr;

end Misc;
-- Copyright (c) 1990 Regents of the University of California.
-- All rights reserved.
--
-- This software was developed by John Self of the Arcadia project
-- at the University of California, Irvine.
--
-- Redistribution and use in source and binary forms are permitted
-- provided that the above copyright notice and this paragraph are
-- duplicated in all such forms and that any documentation,
-- advertising materials, and other materials related to such
-- distribution and use acknowledge that the software was developed
-- by the University of California, Irvine.  The name of the
-- University may not be used to endorse or promote products derived
-- from this software without specific prior written permission.
-- THIS SOFTWARE IS PROVIDED ``AS IS'' AND WITHOUT ANY EXPRESS OR
-- IMPLIED WARRANTIES, INCLUDING, WITHOUT LIMITATION, THE IMPLIED
-- WARRANTIES OF MERCHANTIBILITY AND FITNESS FOR A PARTICULAR PURPOSE.

-- TITLE  miscellaneous aflex routines
-- AUTHOR: John Self (UCI)
-- DESCRIPTION
-- NOTES contains functions used in various places throughout aflex.
-- $Header: /co/ua/self/arcadia/aflex/ada/src/RCS/miscS.a,v 1.9 90/01/12 15:20:19 self Exp Locker: self $
DataMuseum.dk

Rational R1000/400 Tapes

⟦b71750c38⟧ TextFile

Derivation

TextFile
