|
DataMuseum.dkPresents historical artifacts from the history of: Rational R1000/400 |
This is an automatic "excavation" of a thematic subset of
See our Wiki for more about Rational R1000/400 Excavated with: AutoArchaeologist - Free & Open Source Software. |
top - download
Length: 22528 (0x5800)
Types: Ada Source
Notes: 03_class, FILE, R1k_Segment, e3_tag, package body Misc, seg_030b21
└─⟦8527c1e9b⟧ Bits:30000544 8mm tape, Rational 1000, Arrival backup of disks in PAM's R1000
└─ ⟦cfc2e13cd⟧ »Space Info Vol 2«
└─⟦this⟧
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 $
nblk1=15
nid=0
hdr6=2a
[0x00] rec0=20 rec1=00 rec2=01 rec3=010
[0x01] rec0=26 rec1=00 rec2=02 rec3=002
[0x02] rec0=21 rec1=00 rec2=03 rec3=004
[0x03] rec0=24 rec1=00 rec2=04 rec3=030
[0x04] rec0=1a rec1=00 rec2=05 rec3=05a
[0x05] rec0=1c rec1=00 rec2=06 rec3=02a
[0x06] rec0=17 rec1=00 rec2=07 rec3=042
[0x07] rec0=1c rec1=00 rec2=08 rec3=058
[0x08] rec0=1b rec1=00 rec2=09 rec3=01e
[0x09] rec0=1d rec1=00 rec2=0a rec3=046
[0x0a] rec0=1e rec1=00 rec2=0b rec3=022
[0x0b] rec0=27 rec1=00 rec2=0c rec3=040
[0x0c] rec0=26 rec1=00 rec2=0d rec3=010
[0x0d] rec0=1c rec1=00 rec2=0e rec3=040
[0x0e] rec0=20 rec1=00 rec2=0f rec3=058
[0x0f] rec0=20 rec1=00 rec2=10 rec3=01c
[0x10] rec0=1f rec1=00 rec2=11 rec3=030
[0x11] rec0=1e rec1=00 rec2=12 rec3=048
[0x12] rec0=24 rec1=00 rec2=13 rec3=014
[0x13] rec0=15 rec1=00 rec2=14 rec3=03e
[0x14] rec0=06 rec1=00 rec2=15 rec3=000
tail 0x2172a3ff284a64e8c26f3 0x42a00088462060003