Programmer's ROM - The Computer Language Library/programmersrom.iso/ada/edit/wpcommon.src

Text File | 1988-05-03 | 147.0 KB | 3,667 lines

--::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::
--stringli
--::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::

  --$$$+ stringli

  --
  -- File 001
  --
  -- Editor Written By Robert S. Cymbalski
  --                   Science Applications International Corporation
  --                   Energy Systems Group
  --                   Ada Software Development Project Team
  --                   2280 U.S. Highway 19 North, Suite 120
  --                   Clearwater, Florida  33575
  --
  -- Program Revised from text Copyright (c) 1984 , R.S.Cymbalski

  package String_Library is

    user_abort : exception ;

    MaxStrIndex : constant Integer := 255 ;
    Subtype StrIndex Is Integer Range 0..MaxStrIndex; -- Maximum string index
    type Pstring is
           record
             actual_length  : strindex := 0           ;
             maximum_length : strindex := maxstrindex ;
             data           : string ( 1 .. maxstrindex ) ;
           end record ;

    Subtype Number_Base is integer range 2 .. 16 ;

    blank_line : pstring ;

    Function Length (str : In Pstring) Return Integer;
      -- Returns the length of the given pstring

    Procedure Set_Length( Str : In Out Pstring ; Len : in Integer ) ;
      -- Sets the  length of the given Pstring

    Function Position (pattern,str : Pstring) Return Integer;
      -- Returns the position of the first occurance of pattern in str,
      -- or 0 if there is none

    Function Position ( Pattern : character ;
                        Str     : pstring   ) return Integer ;

    Function Position ( Pattern : string    ;
                        Str     : pstring   ) return Integer ;

    Function Position ( Pattern : character ;
                        Str     : string    ) return Integer ;

    Function Position ( Pattern : string    ;
                        Str     : string    ) return Integer ;

    Function char_to_str (char : character) Return String;
      -- Converts the given character into a string of length 1

    Function str_to_int (str : Pstring) Return Integer;
      -- Converts the given pstring into an integer

    Function int_to_str (int : Integer ; base : number_base := 10 )
                       return pstring ;
      -- Converts the given integer in base 10 to an equivalent number in the
      -- given base and Returns the result in a pstring

    Function string_to_pstring ( s : string ) Return Pstring ;
      -- Converts the string into a pstring

    Function "&" ( Left_String  : Pstring ;
                   Right_String : Pstring ) return Pstring ;

    Function "&" ( Left_String  :  string ;
                   Right_String : Pstring ) return Pstring ;

    Function "&" ( Left_String  : Pstring ;
                   Right_String :  string ) return Pstring ;

    function "&" ( c : character ; s : string ) return string ;

    function "&" ( s : string ; c : character ) return string ;

    function "&" ( c , d : character          ) return string ;

    Function equal( Left_String  : Pstring ;
                    Right_String : Pstring ) return Boolean ;

    Function compress( comp_string : in string  ) return Pstring ;

    Function compress( comp_string : in Pstring ) return Pstring ;

    Function MIN ( FIRST , SECOND : in INTEGER ) return INTEGER ;
       -- return minimum of first and second

    Function MAX ( FIRST , SECOND : in INTEGER ) return INTEGER ;
       -- return maximum of first and second

  end String_Library ;

  package body String_Library is

    Function Length (str : In Pstring) Return Integer Is
      -- Returns the length of the string
    Begin
      Return Str.Actual_Length ;
    End Length;

    Procedure Set_Length( Str : In Out Pstring ; Len : in Integer ) is
      -- Set Length Of String
    begin
      if len <= Str.Maximum_Length then
        Str.Actual_Length := Len ;
      end if ;
    end set_length ;

    Function Position (pattern,str : Pstring) Return Integer Is
      -- Returns the position of the first occurance of pattern in str,
      -- or 0 if there is none
      len : Integer := Length(str);
      len2 : Integer := Length(pattern);
      j : Integer;
    Begin
      For i In 0..len-len2 Loop
        j := 1;
        While j <= len2 And Then pattern.data(j) = str.data(i + j) Loop
          j := j + 1;
        End Loop;
        If j > len2 Then -- Pattern found
          Return i+1; -- Return the position
        End If;
          -- Otherwise, go around again
      End Loop;
      Return 0; -- Pattern is not found
    End Position;

    Function Position ( Pattern : character ;
                        Str     : pstring   ) return integer is
      s : string ( 1 .. 1 ) ;
    begin -- position
      s(1) := Pattern ;
      return position(s,str);
    end position ;

    Function Position ( Pattern : string    ;
                        Str     : pstring   ) return integer is
      s : pstring ;
    begin -- position
      s := string_to_pstring(pattern);
      return position(s,str);
    end position ;

    Function Position ( Pattern : character ;
                        Str     : string    ) return integer is
      s : pstring ;
    begin -- position
      s := string_to_pstring(str);
      return position(pattern,s);
    end position ;

    Function Position ( Pattern : string    ;
                        Str     : string    ) return integer is
      s1 , s2 : pstring ;
    begin -- position
      s1 := string_to_pstring(pattern);
      s2 := string_to_pstring(str);
      return position(s1,s2);
    end position ;

    Function char_to_str (char : character) Return String Is
      -- Converts a character into a string of length 1
      ch : string(1 .. 1);
    Begin
      ch := " ";
      ch(1) := char;
      Return ch;
    End char_to_str;

    Function str_to_int (str : Pstring) Return Integer Is
      -- Converts a string into an integer
      pos,temp : Integer;
      len : Integer := Length(str);
      sign : Boolean := False; -- Positive until otherwise determined
    Begin
      temp := 0; -- Value is zero so far
      pos := 1; -- Start at the beginning of the string
      If len = 0 Then
        Return 0;
      End If;
      While (str.data(pos) = ' ')  -- Strip Blanks
          or (str.data(pos) = '-')  -- Strip Signs
          or (str.data(pos) = '+')  --             both types
          or (str.data(pos) = ascii.ht  ) Loop -- Strip Tabs
        If str.data(pos) = '-' Then -- Flip the sign
          sign := Not sign;
        End If;
        If pos = len Then
          Return 0;
        End If;
        pos := pos + 1;
      End Loop;
      While (str.data(pos) In '0'..'9') Loop
        If temp > 3276 Then
          null ;
        End If;
        temp := temp * 10 + (Character'Pos(str.data(pos))
                          -  Character'Pos('0'));
        If pos = len Then
          If sign Then Return - temp;
          Else Return temp;
          End If;
        End If;
        pos := pos + 1;
      End Loop;
      If sign Then
        Return - temp;
      Else
        Return temp;
      End If;
    End str_to_int;

    Function string_to_pstring ( s : string ) Return Pstring is
      -- Converts the string into a pstring
      real_string : string ( 1 .. s'length ) ;
      pstr : Pstring ;
      len : integer := s'length ;
    Begin
      -- put(s);
      real_string := s ;
      set_length(pstr,len);
      for ind in 1 .. len loop
        pstr.data(ind) := real_string(ind) ;
      end loop ;
      return pstr ;
    End string_to_pstring ;

    Function int_to_str (int : Integer ; base : number_base := 10 )
                       return pstring is
      longest_string : constant integer := 40 ;
        -- In fact, we will only get good numbers when the length
        -- (not including the base) is less than 40
      place : integer ;
      do_negative : boolean;
      ada_string  : string ( 1 .. longest_string ) ;
      new_string  : pstring ;
      base_string : pstring ;
      number      : integer;
      a_number    : integer;
      new_place   : integer;
    begin
      if Int < 0 then
        do_negative := true;
        number := - Int ;
      else
        do_negative := false;
        number := Int ;
      end if;
      for lopr in 1 .. longest_string loop
        ada_string(lopr) := ' ';
      end loop;
      place := longest_string ;
      loop
        a_number := number mod base ;
        if a_number < 10 then
          a_number := 48 + a_number;
        else
          a_number := 65 + a_number - 10 ;
        end if;
        ada_string(place) := character'val(a_number) ;
        place := place - 1 ;
        number := number / base ;
        exit when ( place = 0 ) or ( number = 0 ) ;
      end loop;
      -- put_line("  Current Ada String Is """ & ada_string & """");
      -- Now, we have the number in the right part of the string
      if do_negative then
        ada_string(1) := '-' ;
        -- Note that we had better not have put a number into (1)
      end if;
      new_place := 0 ;
      for looper in 1 .. ada_string'length loop
        if ada_string(looper) /= ' ' then
          new_place := new_place + 1 ;
          new_string.data(new_place) := ada_string(looper);
        end if;
      end loop ;
      set_length(new_string,new_place);
        -- Now, to work on the base string
      if base /= 10 then
        -- We need to put all the info into the string
        base_string:= int_to_str(base,10) ;
        new_string := new_string & "#" & base_string & "#" ;
      end if;
      return new_string;
    End int_to_str;

    Function "&" ( Left_String  : Pstring ;
                   Right_String : Pstring ) return Pstring is
      len_left : integer ;
      len_right : integer ;
      new_string : pstring ;
    begin
      new_string := Left_String ;
      len_left := length(left_string);
      len_right := length(right_string);
      if len_left + len_right <= maxstrindex then
        if len_right > 0 then
          new_string.data(len_left+1..len_left+len_right) :=
                                  Right_String.data(1..len_right);
          set_length(new_string,len_left + len_right);
        end if;
      end if;
      return new_string ;
    end;

    Function "&" ( Left_String  :  string ;
                   Right_String : Pstring ) return Pstring is
      len_left : integer ;
      len_right : integer ;
      new_string : pstring ;
    begin
      new_string := string_to_pstring(Left_String) ;
      len_left := length(new_string);
      len_right := length(right_string);
      if len_left + len_right <= maxstrindex then
        if len_right > 0 then
          new_string.data(len_left+1..len_left+len_right) :=
                                  Right_String.data(1..len_right);
          set_length(new_string,len_left + len_right);
        end if;
      end if;
      return new_string ;
    end;

    Function "&" ( Left_String  : Pstring ;
                   Right_String :  string ) return Pstring is
      len_left : integer ;
      len_right : integer ;
      new_string : pstring ;
      real_right : string ( 1 .. right_string'length ) ;
    begin
      new_string := Left_String ;
      real_right := right_string ;
      len_left := length(left_string);
      len_right := real_right'length ;
      if len_left + len_right <= maxstrindex then
        if len_right > 0 then
          new_string.data(len_left+1..len_left+len_right) :=
                                  real_right(1..len_right);
          set_length(new_string,len_left + len_right);
        end if;
      end if;
      return new_string ;
    end;

    function "&" ( c : character ; s : string ) return string is
      new_string : string ( 1 .. s'length + 1 ) ;
    begin
      new_string := " " & s ;
      new_string(1) := c ;
      return new_string ;
    end;

    function "&" ( s : string ; c : character ) return string is
      new_string : string ( 1 .. s'length + 1 ) ;
    begin
      new_string := s & " " ;
      new_string( new_string'length ) := c ;
      return new_string ;
    end;

    function "&" ( c , d : character          ) return string is
      new_string : string ( 1 .. 2 ) := "  " ;
    begin
      new_string(1) := c ;
      new_string(2) := d ;
      return new_string ;
    end;

    Function equal( Left_String  : Pstring ;
                    Right_String : Pstring ) return Boolean is
      len : integer ;
    begin
      if left_string.actual_length /= right_string.actual_length then
        return false ;
      else
        len := left_string.actual_length ;
        return left_string.data( 1 .. len ) = right_string.data( 1 .. len ) ;
      end if ;
    end;

    Function compress( comp_string : in string ) return Pstring is
      start_ind : integer := 1 ;
      ending_ind : integer := comp_string'length ;
      real_string : string ( 1 .. comp_string'length ) ;
    begin
      real_string := comp_string ;
      While start_ind <= ending_ind
      and then real_string(start_ind) = ' ' loop
        start_ind := start_ind + 1 ;
      end loop ;
      while ending_ind >= start_ind
      and then real_string(ending_ind) = ' ' loop
        ending_ind := ending_ind - 1 ;
      end loop ;
      if start_ind > ending_ind then
        return blank_line ;
      else
        return string_to_pstring(real_string(start_ind .. ending_ind)) ;
      end if ;
    end compress ;

    Function compress( comp_string : in Pstring ) return Pstring is
    begin
      return compress(comp_string.data( 1 .. comp_string.actual_length ) ) ;
    end compress ;

    Function MIN ( FIRST , SECOND : in INTEGER ) return INTEGER is
      -- return minimum of first and second
    begin
      if FIRST < SECOND then
        return ( FIRST ) ;
      else
        return ( SECOND ) ;
      end if ;
    end MIN ;

    Function MAX ( FIRST , SECOND : in INTEGER ) return INTEGER is
      -- return maximum of first and second
    begin
      if FIRST < SECOND then
        return ( SECOND ) ;
      else
        return ( FIRST ) ;
      end if ;
    end  MAX ;

  begin -- String_Library
    -- stringli by SAIC/Clearwater General Primatives          31 Dec 84
    -- STRLIB   by SAIC/Clearwater UCSD String Library         21 Dec 84
    blank_line := string_to_pstring("");
  end String_Library ;

  --$$$- stringli

--::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::
--basicios
--::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::

  --$$$+ BasicIOS

  --
  -- File 002
  --
  -- Editor Written By Robert S. Cymbalski
  --                   Science Applications International Corporation
  --                   Energy Systems Group
  --                   Ada Software Development Project Team
  --                   2280 U.S. Highway 19 North, Suite 120
  --                   Clearwater, Florida  33575
  --
  -- Program Revised from text Copyright (c) 1984 , R.S.Cymbalski
  -- Basic I/O Routines revised 18 Dec 84 - RSC
  --

  with calendar           ;

  with direct_io          ;                                            --###--

  with text_io            ;                                            --###--

  with string_library     ;
  use  string_library     ;

  package Basic_IO_System is

    subtype extended_character is integer range 0 .. 255 ;

    procedure put_transparent( a_character : in character ) ;
      -- Outputs a character to the CRT device without any interpretation

    procedure put_transparent( a_string : in string ) ;
      -- Outputs a string to the CRT device without any interpretation
      -- Only for constants...

    procedure put_transparent( a_string : in pstring ) ;
      -- Outputs a pstring to the CRT device without any interpretaion
      -- This is just a short-cut for the character routine

    procedure put_transparent( an_integer : in integer ) ;
      -- Outputs a number to the CRT device without any interpretation

    function get_transparent return extended_character ;
      -- Get extended_character from the CRT device without any interpretation

    function key_is_pressed return boolean ;
      -- Return true if a key has been pressed but the value has not been
      -- read in; false otherwise.

    procedure replace_transparent_input( an_extended_character
                                                        : extended_character ) ;
      -- Saves the given extended_character back in the input buffer in the
      -- correct place so it may be gotten on the next get_transparent

    -- The IO portions will use the following

    max_screen_columns : constant integer := 132 ; -- maximum screen columns
    max_screen_lines   : constant integer :=  66 ; -- maximum screen lines

    subtype a_screen_column_number is integer range 0 .. max_screen_columns ;
    subtype a_screen_line_number   is integer range 0 .. max_screen_lines   ;

    CRT_LINE       : a_screen_line_number   := 1 ; -- current crt line
    CRT_COL        : a_screen_column_number := 1 ; -- current crt column
    TOTAL_CRT_LINE : a_screen_line_number   := max_screen_lines ;
                        -- total number of crt lines allowed....
                        -- can be changed by the caller....
    TOTAL_CRT_COL  : a_screen_column_number := max_screen_columns ;
                        -- same for columns ...

    -- Now, we have the non-transparent I/O routines

    subtype NUMBER_BASE is INTEGER range 2 .. 16 ;
    DEFAULT_WIDTH  : constant INTEGER     :=  0 ;
    DEFAULT_BASE   : constant NUMBER_BASE := 10 ;
      -- Is there supposed to be a way that the above two can be
      -- variables?  For some reason, the compiler will not accept
      -- the values assigned as default values for input to procedures
      -- unless constant.

    procedure put( item : in character ) ;
      -- Outputs the given character to the CRT screen

    procedure put( item : in string    ) ;
      -- Outputs the given string to the CRT screen

    procedure put( item : in pstring    ) ;
      -- Outputs the given pstring to the CRT screen

    procedure put( item : in INTEGER     ;
                   width: in INTEGER     := default_width  ;
                   base : in number_base := default_base ) ;
      -- Converts the base 10 number to its equivalent value with the
      -- given base, and then outputs that value using the given width
      -- to the CRT screen.

    procedure put_line ;
      -- Outputs a <return> to the CRT screen;  cursor moves to
      -- column 1 of the next line

    function num_to_pstring( i : integer ;
                             base : number_base := default_base )
                             return pstring ;
      -- Converts the given base 10 integer to its equivalent value
      -- in the given base and returns this value in a pstring

    -- Now, We have the special information for reading the clock

    procedure terminate_Basic_IO_System ;

    subtype year_number         is integer range 1901 .. 2099 ;
    subtype month_number        is integer range 1    .. 12   ;
    subtype day_number          is integer range 1    .. 31   ;
    subtype day_duration        is calendar.day_duration      ;        --###--

    type day_of_week_name       is ( sunday , monday , tuesday , wednesday ,
                                     thursday , friday , saturday ) ;
    subtype hour_number         is integer range 0    .. 23   ;
    subtype minute_number       is integer range 0    .. 59   ;
    subtype second_number       is integer range 0    .. 59   ;

    type timer is
           record
             year         : year_number    ;
             month        : month_number   ;
             day          : day_number     ;
             d_duration   : day_duration   ;
             day_of_week  : day_of_week_name ;
             hour         : hour_number    ;
             minute       : minute_number  ;
             second       : second_number  ;
           end record ;

    function clock return timer ;

    function year    ( date : timer ) return year_number  ;
    function month   ( date : timer ) return month_number ;
    function day     ( date : timer ) return day_number   ;
    function seconds ( date : timer ) return day_duration ;

    function day_of_week ( date : timer ) return day_of_week_name ;
    function hour    ( date : timer ) return hour_number  ;
    function minute  ( date : timer ) return minute_number;
    function second  ( date : timer ) return second_number;

    procedure split  ( date     : in timer           ;
                       year     : out year_number    ;
                       month    : out month_number   ;
                       day      : out day_number     ;
                       seconds  : out day_duration ) ;

    procedure split  ( date     : in timer           ;
                       year     : out year_number    ;
                       month    : out month_number   ;
                       day      : out day_number     ;
                       seconds  : out day_duration   ;
                       weekday  : out day_of_week_name ;
                       hour     : out hour_number    ;
                       minute   : out minute_number  ;
                       second   : out second_number) ;

    function time_of ( year     : in year_number     ;
                       month    : in month_number    ;
                       day      : in day_number      ;
                       seconds  : in day_duration := 0.0 )
                                                        return timer ; --###--

    function time_of ( year     : in year_number     ;
                       month    : in month_number    ;
                       day      : in day_number      ;
                       weekday  : in day_of_week_name;
                       hour     : in hour_number     ;
                       minute   : in minute_number   ;
                       second   : in second_number   ) return timer ;

    function figure_week_day ( date : timer ) return day_of_week_name ;

    timer_error : exception ;

    -- These last routines are special because they need to be changed
    -- when you move computers

    function word_processor_directory return pstring ;
      -- Return the string defining where the word processor program
      -- files reside (such as the help files and default environment)
      -- If unknown, return blank_line

    function user_directory  return pstring ;
      -- Return the string defining where the user files reside.
      -- If unknown, return blank_line

    function directory_separator return character ;
      -- Return the character which is used to separate the directory name
      -- from the file name.  If unknown or unimplemented, return space

    procedure wait ;

    input_name  : constant string := "SYS$INPUT:"    ;                 --###--
    output_name : constant string := "SYS$OUTPUT:"   ;                 --###--
    print_name  : constant string := "SYS$PRINT:"    ;                 --###--

  private

    max_input_buffer : constant INTEGER := 200 ;

    input_buffer : array ( 1 .. max_input_buffer ) of character ;
    place_put_into_input_buffer : integer := 1 ;
    place_get_from_input_buffer : integer := 1 ;
      -- When into = from no data is waiting

    procedure real_put_transparent( a_character : in character ) ;

    procedure terminate_physical_io ;

  end Basic_IO_System ;

  package body Basic_IO_System is

  --
  -- VAX/VMS I/O Code        Revised 07 Jan 85 - Bob Cymbalski
  --
  -- Portions of this package taken from WIS/JPMO code.
  -- All implementations must implement the routine to fill the input buffer

    package c_io is new direct_io(character) ;                         --###--

    ot_file : c_io.file_type ;

    Task null_task is       -- does nothing except kill time and stimulate
            Entry wait;     -- other tasks to run.  ROS characteristic.
            Entry kill;
    End;

    Task RKB is             -- reads the keyboard.
            Entry kill;
    End;

    Task Body null_task is
    begin
      nt:loop
           select
             accept wait;
           or
             accept kill;
             exit nt;
           end select;
         end loop nt;
    end null_task;

    Task body RKB is        -- Reads the KeyBoard.
      kb_file            : c_io.file_type ;                            --###--
      kb_name            : constant string       := input_name ;       --###--
      D               : character;
      new_place       : integer ;

      function get_a_new_transparent return character is
        d : character ;                                                --###--
      begin
        c_io.read(KB_file,D);   -- task hangs waiting for byte         --###--
        return d ;
      end;

      function difference ( a , b , len : integer ) return integer is
       -- in a circular buffer, return the number which must be
       -- added to a to get b , when len is the length of the
       -- buffer .
      begin -- difference
        if a < b then
          -- nothing special here, because both are in normal order
          return b - a ;
        else
          -- here, b has moved to the start, but a has not
          return ( b + len ) - a ;
        end if ;
      end difference ;

    Begin
      c_io.Open(KB_File,c_io.IN_file,KB_Name);                         --###--
      r:loop

        -- Here we really need to only read if a char is waiding!
        d := get_a_new_transparent ;
        input_buffer(place_put_into_input_buffer) := d ;
        new_place := place_put_into_input_buffer + 1 ;
        if new_place > max_input_buffer then
          new_place := 1 ;
        end if ;
        -- while new_place = place_get_from_input_buffer loop
        --   null_task.wait ; -- other tasks take care of this.
        -- end loop ;
        -- The above code replaced 7 Jan 85 to take into account for
        -- the replacement of up to 9 characters in the input buffer
        -- (which can happen when trying to match up a function key
        while difference( new_place , place_get_from_input_buffer ,
                          max_input_buffer ) < 10 loop
          null_task.wait ; -- only necessary for wicat?
        end loop ;
        place_put_into_input_buffer := new_place ;

        -- Now, just check to see if we should abort
        select
          accept kill ;
          exit r ;
        else
          null_task.wait ;
        end select ;
      end loop r;
    End RKB;

    procedure real_put_transparent( a_character : in character ) is
      -- Outputs a character to the CRT device without any interpretation
    begin
      c_io.write( ot_file , a_character ) ;                            --###--
    end ;

    procedure wait is
    begin
      null_task.wait ;
    end;

    procedure terminate_physical_io is
    begin -- terminate_physical_io
      null_task.kill ;
      rkb.kill       ;
    end terminate_physical_io ;

    function word_processor_directory return pstring is
      -- Return the string defining where the word processor program
      -- files reside (such as the help files and default environment)
      -- If unknown, return blank_line
      -- If known, then the directory name, with directory_separator
      -- must be returned
    begin -- word_processor_directory
      return blank_line ;
    end word_processor_directory ;

    function user_directory  return pstring is
      -- Return the string defining where the user files reside.
      -- If unknown, return blank_line
      -- If known, then the directory name, with directory_separator
      -- must be returned
    begin -- user_directory
      return blank_line ;
    end user_directory ;

    function directory_separator return character is
      -- Return the character which is used to separate the directory name
      -- from the file name.  If unknown or unimplemented, return space
    begin -- directory_separator
      return ' ' ;
    end directory_separator ;

    procedure put_transparent( a_character : in character ) is
    begin
      real_put_transparent( a_character ) ;
    end ;

    procedure put_transparent( a_string : in string ) is
      -- This is just a short-cut for the character routine
    begin
      for loop_param in 1 .. a_string'length loop
        real_put_transparent( a_string(loop_param) ) ;
      end loop;
    end;

    procedure put_transparent( a_string : in pstring ) is
      -- This is just a short-cut for the character routine
      -- The in/out is just so the string will not be copied over
    begin
      for loop_param in 1 .. length(a_string) loop
        real_put_transparent( a_string.data(loop_param) ) ;
      end loop;
    end;

    procedure put_transparent( an_integer : in integer ) is
      ps : pstring ;
    begin
      put_transparent( int_to_str(an_integer) ) ;
    end;

    function get_transparent return extended_character is
      -- Get an extended_character from CRT device without any interpretation
      c : character ;
    begin
      if place_put_into_input_buffer = place_get_from_input_buffer then
        -- No characters waiting for input from CRT
        loop
          wait ;
          exit when place_put_into_input_buffer /= place_get_from_input_buffer ;
        end loop ;
      end if ;
      -- We know that we have a character here...
      c := input_buffer(place_get_from_input_buffer);
      if place_get_from_input_buffer = max_input_buffer then
        place_get_from_input_buffer := 1 ;
      else
        place_get_from_input_buffer := place_get_from_input_buffer + 1 ;
      end if ;
      return extended_character( character'pos(c) ) ;
    end;

    function key_is_pressed return boolean is
      -- Return true if a key has been pressed but the value has not been
      -- read in.  This routine copied from Janus/Ada IO Utility Package
    begin
      return place_put_into_input_buffer /= place_get_from_input_buffer ;
    end;

    procedure replace_transparent_input( an_extended_character
                                                       : extended_character ) is
      -- saves the given extended_character back in the input buffer in the
      -- correct place so it may be gotten next
      new_place : integer ;
    begin
      if place_get_from_input_buffer = 1 then
        new_place := max_input_buffer ;
      else
        new_place := place_get_from_input_buffer - 1 ;
      end if;
      -- now, did we move back past the put into buffer loc?
      -- we will always allow at least one character between the two pointers
      -- ( so on putting in in the forward direction, we never inc to make
      -- both pointers equal)
      if new_place = place_put_into_input_buffer then
        -- decrement it too.
        if place_put_into_input_buffer = 1 then
          place_put_into_input_buffer := max_input_buffer;
        else
          place_put_into_input_buffer := place_put_into_input_buffer - 1 ;
        end if;
      end if;
      place_get_from_input_buffer := new_place ;
      --now, save extended_character into the correct place to be gotten next...
      input_buffer(place_get_from_input_buffer)
                  := character'val(integer(an_extended_character));
    end;

    -- Now, we have the non-transparent I/O routines

    procedure move_crt( c : character ) is
    begin
      if c = ASCII.CR then
        CRT_COL := 1 ;
      elsif c = ASCII.LF then
        if CRT_LINE < TOTAL_CRT_LINE then
          CRT_LINE := CRT_LINE + 1 ;
        end if;
      elsif c = ASCII.BS then
        if crt_col = 1 then
          -- we are at the first character on the line
          CRT_COL := TOTAL_CRT_COL;
          if crt_line = 1 then
            -- we are at the first line on the screen
            CRT_LINE := TOTAL_CRT_LINE;
          else
            CRT_LINE := CRT_LINE - 1 ;
          end if;
        else
          CRT_COL := CRT_COL - 1 ;
        end if;
      elsif c = ASCII.BEL then
        null;  -- No printable character
      else
        if crt_col = total_crt_col then
          -- at the last column on the screen
          CRT_COL := 1 ;
          if CRT_LINE < TOTAL_CRT_LINE then
            CRT_LINE := CRT_LINE + 1 ;
          end if;
        else
          CRT_COL := CRT_COL + 1 ;
        end if;
      end if;
    end;

    procedure put( item : in character ) is
    begin
      put_transparent(item);
      move_crt(item);
    end;

    procedure put( item : in pstring    ) is
      c : CHARACTER;
    begin
      put_transparent(item);
      for place in 1 .. length(item) loop
        c := item.data(place);
        move_crt(c);
      end loop;
    end;

    procedure put( item : in string    ) is
      c : CHARACTER;
    begin
      put_transparent(item);
      for place in 1 .. item'length loop
        c := item(place);
        move_crt(c);
      end loop;
    end;

    procedure put_spaces( number : integer ) is
    begin
      for i in 1 .. number loop
        put(' ');
      end loop;
    end;

    procedure put( item : in INTEGER     ;
                   width: in INTEGER     := default_width  ;
                   base : in number_base := default_base ) is
      new_string : pstring ;
    begin
      new_string := int_to_str(item,base);
      if width > 0 then
        --  We need to check for leading spaces
        put_spaces( width - length(new_string) );
      end if;
      put(new_string);
    end;

    procedure put_line is
    begin
      put_transparent(ASCII.CR);
      -- put_transparent(ASCII.LF);
      CRT_COL := 1 ;
      if CRT_LINE < TOTAL_CRT_LINE then
        CRT_LINE := CRT_LINE + 1 ;
      end if;
    end;

    function num_to_pstring( i : integer ;
                             base : number_base := default_base )
                             return pstring is
    begin
      return int_to_str(i,base);
    end;

    procedure terminate_Basic_IO_System is
    begin
      terminate_physical_io ;
    end terminate_Basic_IO_System ;

    function clock return timer is                                     --###--
      new_timer     : timer ;                                          --###--
    begin -- clock                                                     --###--
      calendar.split(calendar.clock,new_timer.year, new_timer.month ,  --###--
                      new_timer.day  , new_timer.d_duration       ) ;  --###--
      return time_of( new_timer.year , new_timer.month              ,  --###--
                      new_timer.day  , new_timer.d_duration       ) ;  --###--
    end clock ;

    function year    ( date : timer ) return year_number   is
    begin -- year
      return date.year ;
    end year ;

    function month   ( date : timer ) return month_number  is
    begin -- month
      return date.month ;
    end month ;

    function day     ( date : timer ) return day_number    is
    begin -- day
      return date.day ;
    end day ;

    function seconds ( date : timer ) return day_duration  is
    begin -- seconds
      return date.d_duration ;
    end seconds ;

    function day_of_week ( date : timer ) return day_of_week_name is
    begin -- day_of_week
      return date.day_of_week ;
    end day_of_week ;

    function hour    ( date : timer ) return hour_number   is
    begin -- hour
      return date.hour ;
    end hour ;

    function minute  ( date : timer ) return minute_number is
    begin -- minute
      return date.minute ;
    end minute ;

    function second  ( date : timer ) return second_number is
    begin -- second
      return date.second ;
    end second ;

    procedure split  ( date     : in timer           ;
                       year     : out year_number    ;
                       month    : out month_number   ;
                       day      : out day_number     ;
                       seconds  : out day_duration ) is
    begin -- split
      year    := date.year ;
      month   := date.month ;
      day     := date.day ;
      seconds := date.d_duration ;
    end split ;

    procedure split  ( date     : in timer           ;
                       year     : out year_number    ;
                       month    : out month_number   ;
                       day      : out day_number     ;
                       seconds  : out day_duration   ;
                       weekday  : out day_of_week_name ;
                       hour     : out hour_number    ;
                       minute   : out minute_number  ;
                       second   : out second_number) is
    begin -- split
      year      := date.year ;
      month     := date.month ;
      day       := date.day ;
      seconds   := date.d_duration ;
      weekday   := date.day_of_week ;
      hour      := date.hour ;
      minute    := date.minute ;
      second    := date.second ;
    end split ;

    function time_of ( year     : in year_number     ;
                       month    : in month_number    ;
                       day      : in day_number      ;
                       seconds  : in day_duration := 0.0 )
                                   return timer is                     --###--
      h : hour_number   ;
      m : minute_number ;
      s : second_number ;
      remaining : day_duration ;
      new_timer : timer ;
      temp_float    : float   ;                                        --###--
      temp_duration : integer ;                                        --###--
    begin -- time_of
      new_timer.year := year ;
      new_timer.month := month ;
      new_timer.day   := day   ;
      new_timer.d_duration := seconds ;
      temp_float := float( new_timer.d_duration ) ;                    --###--
      new_timer.hour := integer ( temp_float / 60.0 / 60.0 ) ;         --###--
      temp_float := temp_float - float( new_timer.hour ) * 60.0 * 60.0;--###--
      if temp_float < 0.0 then                                         --###--
        temp_float := 0.0 ; -- in cases of rounding could be negative..--###--
      end if ;                                                         --###--
      temp_duration := integer( temp_float ) ; -- 0 .. 3600            --###--
      new_timer.minute := temp_duration / 60 ;                         --###--
      new_timer.second := temp_duration - (new_timer.minute * 60) ;    --###--
      new_timer.day_of_week := figure_week_day( new_timer ) ;          --###--
      return new_timer ;                                               --###--
    end time_of ;

    function time_of ( year     : in year_number     ;
                       month    : in month_number    ;
                       day      : in day_number      ;
                       weekday  : in day_of_week_name;
                       hour     : in hour_number     ;
                       minute   : in minute_number   ;
                       second   : in second_number   ) return timer is
      new_week_day : day_of_week_name ;
      temp_float   : float ;                                           --###--
    begin -- time_of
      new_week_day := figure_week_day ( timer'( year , month , day , 0.0 ,
                                                sunday , 0, 0, 0 ) ) ; --###--
      temp_float := float( second ) +                                  --###--
              60.0 * ( float( minute ) + 60.0 * float( hour ) ) ;      --###--
      return ( year , month , day , day_duration( temp_float ) ,       --###--
                      new_week_day , hour , minute , second) ;         --###--
    end time_of ;                                                      --###--


    function figure_week_day ( date : timer ) return day_of_week_name is
      -- assume unknown week day and return correct one
      val : integer ;
      years  : integer ;
      pre_days : integer ;
    begin -- figure_week_day
      val := 0 ;
      years :=  date.year - 1 - 1900 ;
        -- figure the number of days since December 31, 1900
      val   :=  ( years mod 7 ) * 365 ;  -- tells number of days within year grp
      val   :=  val + ( date.year - 1 - 1900 ) / 4 ;
        -- add a day for each leap year
      val   :=  val - ( date.year - 1 - 1900 ) / 100 ;
        -- subtract a day for each century
      case date.month is
        when 01     => pre_days := 000 ;
        when 02     => pre_days := 031 ;
        when 03     => pre_days := 059 ;
        when 04     => pre_days := 090 ;
        when 05     => pre_days := 120 ;
        when 06     => pre_days := 151 ;
        when 07     => pre_days := 181 ;
        when 08     => pre_days := 212 ;
        when 09     => pre_days := 243 ;
        when 10     => pre_days := 273 ;
        when 11     => pre_days := 304 ;
        when 12     => pre_days := 334 ;
      end case ;
      if date.month > 2
      and then ( ( date.year mod   4 )  = 0 )
      and then ((( date.year mod 100 ) /= 0 ) or ( ( date.year mod 400 ) = 0 ) )
                then
        pre_days := pre_days + 1 ;
      end if ;
      val := val + pre_days + date.day + 1 ;
      val := val mod 7 ; -- seven days per week
      case val is
        when 00     => return sunday    ;
        when 01     => return monday    ;
        when 02     => return tuesday   ;
        when 03     => return wednesday ;
        when 04     => return thursday  ;
        when 05     => return friday    ;
        when 06     => return saturday  ;
        when others => return sunday    ;
      end case ;
    end figure_week_day ;

  begin -- Basic_IO_System
    -- PHYSICAL_IO   by SAIC/Clearwater Wicat I/O Routines     07 Jan 85
    -- Basic_IO_System by SAIC/Clearwater Primary I/O Routines        11 Jan 85
    c_io.Open(ot_file,c_io.out_file,output_name);                       --###--
  end Basic_IO_System ;

  --$$$- BasicIOS

--::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::
--crt
--::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::

--::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::
--dwindows
--::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::

  --$$$+ CWINDOWS

  --
  -- File 004 (part 1)
  --
  -- Editor Written By Robert S. Cymbalski
  --                   Science Applications International Corporation
  --                   Energy Systems Group
  --                   Ada Software Development Project Team
  --                   2280 U.S. Highway 19 North, Suite 120
  --                   Clearwater, Florida  33575
  --
  -- Window Manager Revised from text Copyright (c) 1984 , R.S.Cymbalski

  with text_io ;

  with string_library     ;
  use  string_library     ;

  with basic_io_system    ;

  with crt_customization  ;
  use  crt_customization  ;
  use  crt ;
  use  editor_customization ;

  package crt_windows is

    maximum_prompt_lines : constant integer := 1 ;

    subtype prompt_line_index is integer range 1 .. maximum_prompt_lines ;

    subtype window_line_number         is basic_io_system.a_screen_line_number ;
    subtype window_column_number       is integer ;
      -- integer because we don't know the limits on columns over

    type WINDOW_POINTER is private ;

    Function current_window return window_pointer ;

    Function no_window return window_pointer ;

    Procedure set_current_window ( to : in window_pointer ) ;
      -- *** set the current window as requested

    procedure clear_window ( which_window : in window_pointer ) ;
      -- Clear the entire window of all text

    procedure clear_prompt ( which_window : in window_pointer ) ;
      -- Clear the prompt line(s) of a window

    procedure Clear_Line       ( which_window : in window_pointer       ;
                                 line         : in window_line_number   ) ;
      -- Clear the Line Specified

    procedure Clear_End_Of_Line( which_window : in window_pointer       ;
                                 line         : in window_line_number   ;
                                 column       : in window_column_number ) ;
      -- Clear the Line Specified, from line,column to end of line

    procedure Clear_Prompt_End_Of_Line( which_window : in window_pointer ;
                                        line         : in window_line_number   ;
                                        column       : in window_column_number);
      -- Clear the Prompt Line Specified, from line,column to end of line

    procedure Clear_End_Of_Screen( which_window : in window_pointer     ;
                                 line         : in window_line_number   ;
                                 column       : in window_column_number ) ;
      -- Clear from Line, Column to the end of the window

    procedure goto_line_column ( which_window : in window_pointer ;
                                 line         : in window_line_number ;
                                 column       : in window_column_number ) ;
      -- Move to the specified line and column within a window.  Note that
      -- the first column and line are numbered #1.  A Window area is
      -- exclusive of any prompt area

    procedure goto_Prompt_line_column ( which_window : in window_pointer ;
                                 line         : in window_line_number ;
                                 column       : in window_column_number ) ;
      -- Move to the specified line and column within a window's Prompt
      -- Area.  Note that the first column and line are numbered #1.

    procedure set_prompt ( which_window : in window_pointer ;
                           which_prompt_line : in integer     ;
                           prompt_line  : in string           ) ;
      -- Set the prompt line as specified

    procedure set_prompt ( which_window : in window_pointer ;
                           which_prompt_line : in integer     ;
                           prompt_line  : in pstring          ) ;
      -- Set the prompt line as specified

    procedure save_prompt_temporarily ;
      -- save the prompt area because an error message will be written

    procedure restore_prompt_after_temporary_save ;
      -- and restore the prompt area after that error message

    Function Lowest_Column_Number  ( which_window : in window_pointer )
                                   return window_column_number ;
       -- Return the lowest column number available on the window

    Function Highest_Column_Number ( which_window : in window_pointer )
                                   return window_column_number ;
       -- Return the highest column number available on the window

    Function Window_Height         ( which_window : in window_pointer )
                                   return window_line_number ;
       -- return the number of text lines available in window

    Function current_line   return window_line_number ;

    Function current_col    return window_column_number ;

    function current_shift  return integer ;

    procedure set_reverse ( do_reverse : boolean ) ;
       -- set current_window.next_will_be_reverse and do the
       -- appropriate crt command

    procedure set_reverse_if_necessary ( do_reverse : boolean ) ;
       -- set current_window.next_will_be_reverse and do the
       -- appropriate crt command only if we are not set correctly

    function current_reverse return boolean ;
       -- return the current setting of the reverse flag

    procedure put( c : character ) ;
      -- puts a character into the current window.  We only recognize
      -- ' ' .. tilde and ascii.cr.  Ascii.cr moves to the first column
      -- of the next line

    procedure put( s : string ) ;
      -- puts out a string of all printable characters

    procedure put( s : pstring ) ;
      -- puts out a pstring of all printable characters

    procedure put( num : integer ;
                   width: in INTEGER     := basic_io_system.default_width  ;
                   base : in number_base := basic_io_system.default_base ) ;

    Procedure ADJUST_WINDOW ( which_window : in out WINDOW_POINTER ;
                             ADD_TO_TOP, ADD_TO_BOTTOM : in INTEGER ) ;
      -- *** modifies the number of screen lines the window occupies

    Function CREATE_WINDOW ( left_screen_column ,
                 right_screen_column : basic_io_system.a_screen_column_number ;
                 top_screen_line,
                 bottom_screen_line  : in window_line_number   ;
                 status_line_on_top  : in boolean := false    ;
                 prompt_height       : in window_line_number := 0 )
                                             return WINDOW_POINTER  ;
      -- *** defines a new screen area

    procedure redisplay ( which_window : window_pointer ) ;
      -- redisplay the entire window

    Procedure SHIFT ( SHIFT_WINDOW : in out WINDOW_POINTER ;
                      SHIFT_AMOUNT : in INTEGER ) ;
      -- *** change which relative character position on the line will be
      --     displayed in column 1 on the screen.  Applies to any buffer
      --     mapped to the window.

    procedure dispose_window ( old_window : in out window_pointer ) ;
      -- get rid of an old window

    procedure bell ;

    procedure scroll_up_entire_window (
                        number_of_lines_to_scroll : window_line_number ) ;

    procedure scroll_down_entire_window (
                        number_of_lines_to_scroll : window_line_number ) ;

    -- special functions

    procedure KEY_INPUT( CH : out CHARACTER; OR_SPECIAL : out SPECIAL_KEYS);
      -- Reads in a character from the keyboard and returns the character
      -- and its special meaning.  If a function key or an escape sequence
      -- is entered then CH contains the function number.

    procedure flush_input ;
      -- Clears the input buffer of any characters entered from the
      -- keyboard, but not yet read

    function read_character return character ;
      -- read in a character and return.  This routine cannot read in
      -- special characters......only ' ' .. '~'

    procedure wait_for_character ( character_to_wait_for : character ) ;
      -- wait until the specified character is typed.  Beep in case
      -- of mistakes

    type CHARACTER_SET is array (CHARACTER) of BOOLEAN;

    procedure CLEAR_SET( A_SET : in out character_set ) ;

    function IN_SET( ELEMENT : in CHARACTER ;
                     A_SET   : in character_set ) return BOOLEAN ;

    function map_up ( c : character ) return character ;

    function map_down ( c : character ) return character ;

    function goodchar( allowed : character_set ; default : character ;
                       map_to_upper_case : boolean := true )
                       return character ;
      -- get in a single character.  Map to upper case.  Keep
      -- reading until a <return> (in which case default is returned) or
      -- else a character is read which is in the allowed set.  Then,
      -- echo the character to the screen and return

    function char_within_range_or_abort ( default , lowest_item ,
                                                    highest_item : character )
                                          return character ;
      -- get a character which is within the range specified

    function char_or_abort ( default , c_1 , c_2 , c_3 , c_4 ,
                                       c_5 , c_6 , c_7 , c_8 ,
                                       c_9 : in character := ascii.nul )
                             return character ;
      -- get in a character which is an ascii.cr or else one of the nine
      -- allowed characters or else a <reject>.  In case of the <reject>,
      -- return ascii.nul , otherwise, if a ascii.cr, return default
      -- (as long as it is allowed in 1..9)

    function STRING_READ( FORMAT : in PSTRING         ;
                          DEFAULT: in PSTRING         ; -- := "";
                          LENGTH : in window_column_number := 0 ;
                          COL    : in window_column_number := 0 ;
                          LINE   : in window_line_number   := 0 ;
                          ALLOW_LOWER_CASE : in BOOLEAN  := TRUE
                        ) return PSTRING;
      -- Reads in characters from the keyboard depending on what format
      -- characters are in the format string, and returns this input string.
      -- The default string is returned if a <return> is typed at the
      -- request for an input string.
      -- The cursor is repositioned on the screen to COL,LINE in preparation
      -- for this input request.  If either is 0, then the cursor is not
      -- re-positioned. If ALLOW_LOWER_CASE tells if you want characters
      -- typed in lower case to remain in lower case (true), or if they should
      -- be transposed into their upper case equivalents (false).
      -- The input string length is determined by LENGTH.  If LENGTH is 0,
      -- then the length is controlled by the length of FORMAT.  If LENGTH
      -- is greater than the length of FORMAT, then FORMAT is assumed to be
      -- lengthened to the right with blanks.
      --      The following Format Characters Are Recognized:
      --         'A' - Read in an alphabetic character
      --         '9' - Read in a numeric character
      --         'Z' - Read in an alpha-numeric character
      --         '~' - Read in a numeric character or '+' or '-'
      --         '.' - Read in a real number
      --         '^' - Read in a money amount such as +/- 1,234,567.89
      --         ' ' - Read in anything
      --         All other characters are inserted into the input string as
      --             though typed by the user.

    procedure get_character ( new_c       : out character ;
                              new_command : out crt_editor_command ) ;
      -- get a character or a command from the keyboard

    function get_number ( line : in window_line_number   ;
                          col  : in window_column_number ;
                          smallest : in integer          ;
                          largest  : in integer          ;
                          len      : in integer          ;
                          default  : in integer          )
                          return integer ;
      -- get a number within the range if possible.  On reject/return
      -- simply return default

  private

    type window_character_position is
           record
             c         : character             := ' ' ;
             show_reverse : boolean            := false ;
           end record ;

    type window_actual_text is array
      ( 1 .. basic_io_system.max_screen_columns ) of window_character_position ;

    type window_line_of_text is
           record
             line_length : integer := 0 ;
             text        : window_actual_text ;
           end record ;

    type window_of_text is array ( 1 .. basic_io_system.max_screen_lines )
               of window_line_of_text ;

    blank_window_line : constant window_line_of_text :=
        ( 0 , ( 1 .. basic_io_system.max_screen_columns => ( ' ' , false ) ) ) ;

    type prompt_area is array ( prompt_line_index
                range 1 .. maximum_prompt_lines ) of window_line_of_text ;

    type screen_window is
      record
        -- The following are valid for both the Prompt and Text Areas
        left_screen_column ,
        right_screen_column : basic_io_system.a_screen_column_number ;
        screenwidth    : basic_io_system.a_screen_column_number ;

        -- The following are the actual physical boundries of the
        -- Window itself
        top_screen_line,
        bottom_screen_line  : window_line_number ;

        -- The following describe the Text Area
        text_window_height : window_line_number   ;
        top_text_line      : window_line_number   ; -- where text goes
        bottom_text_line   : window_line_number   ;

        -- The following describes the Prompt Area
        status_line_on_top : boolean ;
        prompt_height  : window_line_number   ;
        top_prompt_line: window_line_number   ; -- where prompts go
        bottom_prompt_line : window_line_number ;

        columns_over   : integer         ; -- because it is physical ;

        -- now, the text within the window
        text : window_of_text ;
        cursor_line : window_line_number ;
        cursor_col  : window_column_number ;
        next_will_be_reversed : boolean ;

        prompt_save_area : prompt_area ;

      end record ;

    type WINDOW_POINTER is access screen_window ;

    Real_Current_Window : window_Pointer ;

    char_in       : character ; -- what is the input character?

    compare_place : integer ;

    subtype extended_character is basic_io_system.extended_character ;

  end crt_windows ;

  package body crt_windows is

  --
  -- File 004 (part 2)
  --
  -- Editor Written By Robert S. Cymbalski
  --                   Science Applications International Corporation
  --                   Energy Systems Group
  --                   Ada Software Development Project Team
  --                   2280 U.S. Highway 19 North, Suite 120
  --                   Clearwater, Florida  33575
  --
  -- Window Manager Revised from text Copyright (c) 1984 , R.S.Cymbalski

    -- Current Assumption is that the prompt area is 1 line, and that
    -- it is at the top line on the screen.  The rest of the screen consists
    -- of a single window.

    procedure set_line_column ( which_window : in     window_pointer ;
                    line : in window_line_number ;
                    col  : in basic_io_system.a_screen_column_number ) is
               --  Position the cursor on the line and column specified
               --  we know that which_window is an access variable so that
               --  we can have it as an in item and still change the
               --  contents of what it points to... because the caller
               --  doesn't know that a simple cursor movement changes items
               --  contained in a window_pointer
    begin -- set_line_column
      crt.gotoxy( col , line ) ;
      which_window.cursor_line := line ;
      which_window.cursor_col  := col  ;
      if which_window.text(line).line_length < col - 1 then
        -- need to put in some spaces
        for posn in which_window.text(line).line_length + 1 .. col - 1 loop
          which_window.text(line).text(posn).c := ' ' ;
          which_window.text(line).text(posn).show_reverse := false ;
        end loop ;
        which_window.text(line).line_length := col - 1 ;
      end if ;
    end set_line_column ;

    -- Window Text Array
    -- Window.Text( Line_Number 1 .. basic_io_system.max_screen_lines)
    --            .line_length
    --            .text ( 1 .. basic_io_system.max_screen_columns )
    --                 .c
    --                 .show_reverse
    -- However, lines are really defined only for
    --  top_prompt_line .. top_prompt_line + prompt_height - 1
    --  top_text_line   .. top_text_line + text_window_height - 1
    -- and columns for
    --  left_screen_column .. right_screen_column

    function current_window return window_pointer is
    begin
      return real_current_window ;
    end current_window ;

    function no_window return window_pointer is
    begin -- no_window
      return null ;
    end no_window ;

    procedure set_current_window ( to : in window_pointer ) is
      -- *** set the current window as requested
    begin -- set_current_window
      real_current_window := to ;
    end set_current_window ;

    procedure clear_window ( which_window : in window_pointer ) is
      -- Clear the entire window of all text
    begin -- clear_window
      set_line_column( which_window , which_window.top_text_line ,
                       which_window.left_screen_column ) ;
      crt.do_crt(crt.erase_eos) ;  -- but really should stay in window
      for linen in which_window.top_text_line .. which_window.bottom_text_line
                                    loop
        which_window.text(linen) := blank_window_line ;
      end loop ;
    end clear_window ;

    procedure clear_prompt ( which_window : in window_pointer ) is
      -- Clear the prompt line(s) of a window
    begin -- clear_prompt
      for indx in which_window.top_prompt_line ..
                                          which_window.bottom_prompt_line loop
        set_line_column( which_window,Indx , which_window.left_screen_column ) ;
        crt.do_crt(crt.erase_eol); -- really should be only to end of window
        which_window.text(Indx) := blank_window_line ;
      end loop ;
    end clear_prompt ;

    procedure Clear_Line       ( which_window : in window_pointer       ;
                                 line         : in window_line_number   ) is
      -- Clear the Line Specified
    begin -- Clear_Line
      if ( line > 0 ) and ( line <= which_window.text_window_height ) then
        set_line_column( which_window ,
                         which_window.top_text_line + line - 1 ,
                         which_window.left_screen_column ) ;
        crt.do_crt(crt.erase_eol) ; -- really should be end of window
        which_window.text( which_window.top_text_line + line - 1 )
                       := blank_window_line ;
      end if ;
    end Clear_Line ;

    procedure Clear_End_Of_Line( which_window : in window_pointer       ;
                                 line         : in window_line_number   ;
                                 column       : in window_column_number ) is
      -- Clear the Line Specified, from line,column to end of line
      actual_window_column : window_column_number ;
      w_line               : window_line_number   ;
    begin -- Clear_End_Of_Line
      if ( line > 0 ) and ( line <= which_window.text_window_height ) then
        -- we can get onto the right line
        actual_window_column := which_window.columns_over + column ;
        w_line := which_window.top_text_line + line - 1 ;
        if  ( actual_window_column > 0 )
        and ( actual_window_column <= which_window.right_screen_column ) then
          set_line_column( which_window , w_line  , actual_window_column ) ;
          crt.do_crt(crt.erase_eol) ; -- really should be end of window
          if which_window.text(w_line).line_length >= actual_window_column then
            which_window.text(w_line).line_length := actual_window_column - 1 ;
          end if;
        end if ;
      end if ;
    end Clear_End_Of_Line ;

    procedure Clear_Prompt_End_Of_Line( which_window : in window_pointer ;
                                        line         : in window_line_number   ;
                                      column       : in window_column_number) is
      -- Clear the Prompt Line Specified, from line,column to end of line
      w_line               : window_line_number   ;
    begin -- clear_prompt_end_of_line
      if ( line > 0 ) and ( line <= which_window.prompt_height ) then
        if  ( column > 0 )
        and ( column <= which_window.right_screen_column ) then
          w_line := which_window.top_prompt_line + line - 1 ;
          set_line_column( which_window , w_line , column ) ;
          crt.do_crt(crt.erase_eol) ; -- really should be end of window
          if which_window.text(w_line).line_length >= column then
            which_window.text(w_line).line_length := column - 1 ;
          end if;
        end if ;
      end if ;
    end clear_prompt_end_of_line ;

    procedure Clear_End_Of_Screen( which_window : in window_pointer     ;
                                 line         : in window_line_number   ;
                                 column       : in window_column_number ) is
      -- Clear from Line, Column to the end of the window
      actual_window_column : window_column_number ;
      w_line               : window_line_number   ;
    begin -- Clear_End_Of_Screen
      if ( line > 0 ) and ( line <= which_window.text_window_height ) then
        actual_window_column := which_window.columns_over + column ;
        w_line := which_window.top_text_line + line - 1 ;
        if  ( actual_window_column > 0 )
        and ( actual_window_column <= which_window.right_screen_column ) then
          set_line_column( which_window , w_line , actual_window_column ) ;
          crt.do_crt(crt.erase_eos) ; -- really should be end of window
          if which_window.text(w_line).line_length >= actual_window_column then
            which_window.text(w_line).line_length := actual_window_column - 1 ;
          end if;
          if w_line < which_window.bottom_text_line then
            for ln in w_line + 1 .. which_window.bottom_text_line loop
              which_window.text(ln) := blank_window_line ;
            end loop ;
          end if ;
        end if ;
      end if ;
    end Clear_End_Of_Screen ;

    procedure goto_line_column ( which_window : in window_pointer ;
                                 line         : in window_line_number ;
                                 column       : in window_column_number ) is
      -- Move to the specified line and column within a window.  Note that
      -- the first column and line are numbered #1.  A Window area is
      -- exclusive of any prompt area
      actual_window_column : window_column_number ;
      w_line               : window_line_number   ;
    begin -- GoTo_Line_Column
      if ( line > 0 ) and ( line <= which_window.text_window_height ) then
        actual_window_column := which_window.columns_over + column ;
        if  ( actual_window_column > 0 )
        and ( actual_window_column <= which_window.right_screen_column ) then
          w_line := which_window.top_text_line + line - 1 ;
          set_line_column( which_window , w_line , actual_window_column ) ;
        end if ;
      end if ;
    end GoTo_Line_Column ;

    procedure goto_Prompt_line_column ( which_window : in window_pointer ;
                                 line         : in window_line_number ;
                                 column       : in window_column_number ) is
      -- Move to the specified line and column within a window's Prompt
      -- Area.  Note that the first column and line are numbered #1.
      w_line : window_line_number ;
    begin -- goto_prompt_line_column
      if ( line > 0 ) and ( line <= which_window.prompt_height ) then
        if  ( column > 0 )
        and ( column <= which_window.right_screen_column ) then
          w_line := which_window.top_prompt_line + line - 1 ;
          set_line_column( which_window , w_line , column ) ;
        end if ;
      end if ;
    end goto_prompt_line_column ;

    procedure set_prompt ( which_window : in window_pointer ;
                           which_prompt_line : in integer     ;
                           prompt_line  : in string           ) is
      -- Set the prompt line as specified
    begin -- Set_Prompt
      set_line_column( which_window ,
                       which_window.top_prompt_line + which_prompt_line - 1 ,
                       which_window.left_screen_column ) ;
      which_window.text( which_window.top_prompt_line
                       + which_prompt_line - 1 ) := blank_window_line ;
      crt.do_crt(crt.erase_eol); -- really should be only to end of window
      -- We don't do any error checking on the length!
      crt_windows.put(prompt_line) ;
    end Set_Prompt ;

    procedure set_prompt ( which_window : in window_pointer ;
                           which_prompt_line : in integer     ;
                           prompt_line  : in pstring          ) is
      -- Set the prompt line as specified
    begin -- Set_Prompt
      set_line_column( which_window ,
                       which_window.top_prompt_line + which_prompt_line - 1 ,
                       which_window.left_screen_column ) ;
      which_window.text( which_window.top_prompt_line
                       + which_prompt_line - 1 ) := blank_window_line ;
      crt.do_crt(crt.erase_eol); -- really should be only to end of window
      -- We don't do any error checking on the length!
      crt_windows.put(prompt_line) ;
    end Set_Prompt ;

    procedure save_prompt_temporarily is
      -- save the prompt area because an error message will be written
    begin -- save_prompt_temporarily
      if real_current_window.prompt_height > 0 then
        for which_prompt_line in real_current_window.top_prompt_line
               .. real_current_window.top_prompt_line
                + real_current_window.prompt_height - 1 loop
          real_current_window.prompt_save_area(which_prompt_line)
                          := real_current_window.text(
                                  real_current_window.top_prompt_line
                                   + which_prompt_line - 1 ) ;
        end loop ;
      end if ;
    end save_prompt_temporarily ;

    procedure restore_prompt_after_temporary_save is
      -- and restore the prompt area after that error message
      remember_reverse : boolean ;
    begin -- restore_prompt_after_temporary_save
      if real_current_window.prompt_height > 0 then
        clear_prompt( real_current_window ) ;
        remember_reverse := real_current_window.next_will_be_reversed ;
        for which_prompt_line in real_current_window.top_prompt_line
               .. real_current_window.top_prompt_line
                + real_current_window.prompt_height - 1 loop
          -- through each of the various prompt lines
          real_current_window.text(real_current_window.top_prompt_line
                                   + which_prompt_line - 1 ).line_length := 0 ;
          set_line_column( real_current_window ,
                           real_current_window.top_prompt_line
                                + which_prompt_line - 1,
                           real_current_window.left_screen_column ) ;
          -- We don't do any error checking on the length!
          -- now, we need to output each of the locations
          for posn in real_current_window.left_screen_column ..
                         real_current_window.right_screen_column loop
            if posn <= real_current_window.prompt_save_area(which_prompt_line)
                                  .line_length then
              set_reverse_if_necessary( real_current_window.prompt_save_area
                                      ( which_prompt_line ).text ( posn ).
                                        show_reverse ) ;
              put(real_current_window.prompt_save_area(which_prompt_line)
                  .text(posn).c ) ;
            end if ;
          end loop ;
        end loop ;
        set_reverse_if_necessary(remember_reverse);
      end if ;
    end restore_prompt_after_temporary_save ;

    Function Lowest_Column_Number ( which_window : in window_pointer )
                                   return window_column_number is
       -- Return the Lowest column number available on the window
    begin -- Lowest_column_number
      if which_window.columns_over >= 0 then
        return 1 ; -- because we don't allow writing in "magic" columns
      else
        return - ( which_window.columns_over ) + 1 ;
      end if ;
    end Lowest_column_number ;

    Function Highest_Column_Number ( which_window : in window_pointer )
                                   return window_column_number is
       -- Return the highest column number available on the window
    begin -- highest_column_number
      return which_window.right_screen_column - which_window.columns_over ;
    end highest_column_number ;

    Function Window_Height         ( which_window : in window_pointer )
                                   return window_line_number is
       -- return the number of text lines available in window
    begin -- window_height
      return which_window.text_window_height ;
    end window_height ;

    Function current_line       return window_line_number is
    begin -- current_line
      if real_current_window.status_line_on_top then
        return real_current_window.cursor_line
                    - real_current_window.prompt_height ;
      else
        return real_current_window.cursor_line ;
      end if ;
    end current_line ;

    Function current_col        return window_column_number is
    begin -- current_col
      return real_current_window.cursor_col
                  - real_current_window.left_screen_column + 1 ;
    end current_col ;

    function current_shift      return integer              is
    begin -- current_shift
      return real_current_window.columns_over ;
    end current_shift ;

    procedure set_reverse ( do_reverse : boolean ) is
       -- set current_window.next_will_be_reverse and do the
       -- appropriate crt command
    begin -- set_reverse
      real_current_window.next_will_be_reversed := do_reverse ;
      if do_reverse then
        crt.change_crt( other_intensity ) ;
      else
        crt.change_crt( normal ) ;
      end if ;
    end set_reverse ;

    procedure set_reverse_if_necessary ( do_reverse : boolean ) is
       -- set current_window.next_will_be_reverse and do the
       -- appropriate crt command only if we are not set correctly
    begin -- set_reverse_if_necessary
      if real_current_window.next_will_be_reversed /= do_reverse then
        set_reverse( do_reverse ) ;
      end if ;
    end set_reverse_if_necessary ;

    function current_reverse return boolean is
       -- return the current setting of the reverse flag
    begin -- current_reverse
      return real_current_window.next_will_be_reversed ;
    end current_reverse ;

    procedure put( c : character ) is
      -- puts c into current window.  only recognise ' ' .. tilde and ascii.cr
      -- Ascii.cr moves to the first column of the next line
      col : window_column_number ;
    begin -- put
      if c = ascii.cr then
        if real_current_window.cursor_line
                                   = real_current_window.bottom_screen_line then
          -- we need to scroll......
          scroll_up_entire_window(1);
          real_current_window.cursor_line
                                  := real_current_window.bottom_screen_line ;
        else
          real_current_window.cursor_line
                                        := real_current_window.cursor_line + 1 ;
        end if ;
        set_line_column( real_current_window ,
                         real_current_window.cursor_line ,
                         real_current_window.left_screen_column ) ;
      elsif c = ascii.bs then
        if real_current_window.cursor_col
                                  > real_current_window.left_screen_column then
          basic_io_system.put(ascii.bs);
          real_current_window.cursor_col  := real_current_window.cursor_col- 1 ;
        end if ;
      else
        col := real_current_window.cursor_col ;
        if col <= real_current_window.right_screen_column then
          basic_io_system.put(c);
          real_current_window.text(real_current_window.cursor_line).text(col)
                 := ( c , real_current_window.next_will_be_reversed ) ;
          if real_current_window.text(
                         real_current_window.cursor_line).line_length < col then
            real_current_window.text(
                              real_current_window.cursor_line).line_length:=col;
          end if ;
          if col = real_current_window.right_screen_column then
            crt_windows.put(ascii.cr);
          else
            real_current_window.cursor_col := col + 1 ;
          end if ;
        end if ;
      end if ;
    end put ;

    procedure put( s : string ) is
      -- all printable characters
    begin -- put
      crt_windows.put( string_to_pstring(s) ) ;
    end put ;

    procedure put( s : pstring ) is
      -- all printable characters
      col : window_column_number ;
      ps  : pstring ;
      w_line : window_line_number ;
      new_position : integer ; -- integer -- to skip the error checking...
      highest_position : window_column_number := real_current_window.
                                                    right_screen_column ;
    begin -- put
      col := real_current_window.cursor_col ;
      w_line := real_current_window.cursor_line ;
      ps := s ;
      new_position := col + length(ps ) ;
      if new_position <= highest_position + 1 then
        basic_io_system.put(ps);
      elsif col <= highest_position then
        -- truncate
        set_length(ps,highest_position - col + 1);
        basic_io_system.put(ps);
        new_position := highest_position + 1 ;
      else
        -- else at right edge of window
        ps := string_library.blank_line ;
      end if ;
      for clm in 1 .. length(ps) loop
        real_current_window.text(w_line).text(col + clm - 1 ) :=
            ( ps.data(clm) , real_current_window.next_will_be_reversed ) ;
      end loop ;
      if real_current_window.text(w_line).line_length < new_position - 1 then
        real_current_window.text(w_line).line_length := new_position - 1 ;
      end if ;
      if new_position > highest_position then
        crt_windows.put(ascii.cr);
      else
        real_current_window.cursor_col := new_position ;
      end if ;
    end put ;

    procedure put( num : integer ;
                   width: in INTEGER     := basic_io_system.default_width  ;
                   base : in number_base := basic_io_system.default_base ) is
      -- number within the width indicated
      temp_string : string_library.pstring ;
    begin -- put
      temp_string := int_to_str( num , base ) ;
      while length(temp_string) < width loop
        temp_string := " " & temp_string ;
      end loop ;
      put(temp_string);
    end put ;

    Procedure ADJUST_WINDOW ( which_window : in out WINDOW_POINTER ;
                              ADD_TO_TOP, ADD_TO_BOTTOM : in INTEGER ) is
      new_top , new_bottom : integer ;
    begin -- adjust_window
      new_top := which_window.top_screen_line - add_to_top ;
      new_bottom := which_window.bottom_screen_line + add_to_bottom ;
      if new_top < 1 then
        new_top := 1;
      end if ;
      if new_bottom > basic_io_system.total_crt_line then
        new_bottom := basic_io_system.total_crt_line ;
      end if ;
      which_window.top_screen_line     := new_top ;
      which_window.bottom_screen_line  := new_bottom ;
      -- status and text areas
      if which_window.status_line_on_top then
        -- do it
        which_window.top_prompt_line   := new_top ;
        which_window.top_text_line     := new_top
                                                + which_window.prompt_height ;
        which_window.text_window_height:= new_bottom
                                                - which_window.prompt_height ;
      else
        -- status line on bottom
        which_window.top_prompt_line   := new_bottom + 1
                                                - which_window.prompt_height ;
        which_window.top_text_line     := new_top ;
        which_window.text_window_height:= new_bottom
                                                - which_window.prompt_height ;
      end if ;
      which_window.bottom_text_line := which_window.top_text_line
                                       + which_window.text_window_height - 1 ;
      which_window.bottom_prompt_line:=which_window.top_prompt_line
                                       + which_window.prompt_height - 1 ;
    end adjust_window ;

    Function CREATE_WINDOW ( left_screen_column ,
                 right_screen_column : basic_io_system.a_screen_column_number ;
                 top_screen_line,
                 bottom_screen_line  : in window_line_number   ;
                 status_line_on_top  : in boolean := false    ;
                 prompt_height       : in window_line_number := 0 )
                                             return WINDOW_POINTER  is
      new_window : window_pointer ;
    begin -- create_window
      -- we do not do error checking here
      new_window := new screen_window  ;
      new_window.left_screen_column  := left_screen_column ;
      new_window.right_screen_column := right_screen_column ;
      new_window.screenwidth         := right_screen_column
                                               - left_screen_column + 1 ;
      new_window.top_screen_line     := top_screen_line ;
      new_window.bottom_screen_line  := bottom_screen_line ;
      new_window.text_window_height  := bottom_screen_line
                                               - top_screen_line + 1
                                               - prompt_height ;
      if status_line_on_top then
        new_window.top_text_line     := top_screen_line
                                               + prompt_height ;
        new_window.top_prompt_line   := top_screen_line ;
      else
        new_window.top_text_line     := top_screen_line ;
        new_window.top_prompt_line   := bottom_screen_line
                                               - prompt_height + 1 ;
      end if ;
      new_window.status_line_on_top  := status_line_on_top ;
      new_window.prompt_height       := prompt_height ;
      new_window.bottom_text_line := new_window.top_text_line
                                       + new_window.text_window_height - 1 ;
      new_window.bottom_prompt_line:=new_window.top_prompt_line
                                       + new_window.prompt_height - 1 ;
      new_window.cursor_line := 0 ;
      new_window.cursor_col  := 0 ;
      new_window.next_will_be_reversed := false ;
      new_window.columns_over := 0 ;
      return new_window ;
    end create_window ;

    procedure redisplay ( which_window : window_pointer ) is
      -- redisplay the entire window
      last_was_reverse : boolean ;
      old_reverse      : boolean ;
      next_pos         : window_character_position ;
    begin -- redisplay
      last_was_reverse := real_current_window.next_will_be_reversed ;
      old_reverse      := last_was_reverse ;
      for ln in which_window.top_screen_line ..
                which_window.bottom_screen_line loop
        if which_window.text(ln).line_length > 0 then
          set_line_column( which_window,ln,which_window.left_screen_column ) ;
          for posn in 1 .. which_window.text(ln).line_length loop
            next_pos := which_window.text(ln).text(posn) ;
            if next_pos.show_reverse /= last_was_reverse then
              last_was_reverse := not last_was_reverse ;
              set_reverse(last_was_reverse) ;
            end if ;
            basic_io_system.put(next_pos.c);
          end loop ;
        end if ;
      end loop ;
      if last_was_reverse /= old_reverse then
        -- must set reversed as appropriate
        set_reverse(old_reverse);
        -- sets it in current_window
      end if ;
    end redisplay ;

    Procedure SHIFT ( SHIFT_WINDOW : in out WINDOW_POINTER ;
                      SHIFT_AMOUNT : in INTEGER ) is
      -- *** change which relative character position on the line  *** --
      -- *** will be displayed in column 1 on the screen.  Applies *** --
      -- *** to any buffer mapped to the window.                   *** --
      -- *** + moves column 1 right on the screen      *** --
      -- *** A Minus moves it left.  If shift is set to 5 you      *** --
      -- ***   could put a line number in the first five columns   *** --
    begin -- shift
      shift_window.columns_over := shift_window.columns_over + shift_amount ;
    end shift ;

    procedure dispose_window ( old_window : in out window_pointer ) is
      -- get rid of an old window
    begin -- dispose_window
      null;
    end dispose_window ;

    procedure bell is
    begin
      basic_io_system.put(ascii.bel);
    end bell ;

    procedure scroll_up_entire_window (
                        number_of_lines_to_scroll : window_line_number ) is
    begin -- scroll_up_entire_window
      -- we want to scroll the text area up
      if crt_has( scroll_middle_screen_up ) then
        scroll_up_middle_screen ( real_current_window.top_text_line ,
                                  number_of_lines_to_scroll ) ;
      else
        save_prompt_temporarily ;
        scroll_up_entire_screen ( number_of_lines_to_scroll ) ;
        restore_prompt_after_temporary_save ;
      end if ;
      for ln in real_current_window.top_text_line ..
                real_current_window.bottom_text_line
                - number_of_lines_to_scroll loop
        real_current_window.text(ln)
          := real_current_window.text(ln + number_of_lines_to_scroll );
      end loop ;
      for posn in real_current_window.bottom_text_line
                              - number_of_lines_to_scroll + 1
                                 .. real_current_window.bottom_text_line loop
        real_current_window.text(posn) := blank_window_line ;
      end loop ;
    end scroll_up_entire_window ;

    procedure scroll_down_entire_window (
                        number_of_lines_to_scroll : window_line_number ) is
    begin -- scroll_down_entire_window
      null ;
    end scroll_down_entire_window ;

  --
  -- File 004 (part 3)
  --
  -- Editor Written By Robert S. Cymbalski
  --                   Science Applications International Corporation
  --                   Energy Systems Group
  --                   Ada Software Development Project Team
  --                   2280 U.S. Highway 19 North, Suite 120
  --                   Clearwater, Florida  33575
  --
  -- Window Manager Revised from text Copyright (c) 1984 , R.S.Cymbalski

    procedure KEY_INPUT( CH : out CHARACTER; OR_SPECIAL : out SPECIAL_KEYS) is
      -- Reads in a character from the keyboard and returns the character
      -- and its special meaning.  If a function key or an escape sequence
      -- is entered then CH contains the function number.

      extended_character_in : extended_character;
      temp_ch : character ;
      temp_or_special : special_keys ;

      procedure get_next_in is
        -- get the next character in;
      begin -- get_next_in
        extended_character_in := basic_io_system.get_transparent ;
        if extended_character_in < extended_character(128) then
          char_in := CHARACTER'VAL( INTEGER(extended_character_in) );
        else
          char_in := ASCII.NUL;
        end if;
      end get_next_in;

      procedure process_non_printing_character is
        complete : boolean;
        function_bank : integer ; -- What bank of the function keys have we
                                  -- examined last?

        function is_it_this_bank return boolean is
          -- use function_bank to determine if this key starts this bank

          procedure do_ansi is
            -- we get here after geting the lead in characters <esc> "["
            -- and now must read in umbers until we hit chr(cbefore) or
            -- until we have an alphabetic character
            new_i:integer;
          begin -- do_ansi
            new_i := 0 ;
            loop
              get_next_in ;
              if extended_character_in = extended_character(0) then
              -- this used to be chr(cbefore)
                exit ; -- loop
              else
                if char_in in '0' .. '9' then
                  new_i := new_i * 10 + extended_character_in
                                                          - character'pos('0') ;
                else
                  exit ; -- loop
                end if;
              end if;
            end loop;
            extended_character_in := extended_character(new_i);
          end do_ansi;

        begin -- is_it_this_bank
          -- is extended_character_IN = key_map(function_bank).lead_in(1) ?
          -- if we return TRUE, then we must have set CH and OR_SPECIAL
          compare_place := 1; -- where to compare first
          loop
            exit when compare_place > key_map(function_bank).lead_in_length ;
            -- we have to compare a character
            if key_map(function_bank).lead_in(compare_place) = char_in then
              -- we match this character...great...
              compare_place := compare_place + 1;
              get_next_in;
            else
              -- put back current character and all leading ones....
              -- make first of string the current extended_character_in/char_in
              if compare_place = 1 then
                return false ; -- nothing special on just plain old miss
              end if ;
              basic_io_system.replace_transparent_input(extended_character_in);
              for loop_pos in reverse 1 .. compare_place - 1 loop
                basic_io_system.replace_transparent_input(extended_character(character'pos(
                              key_map(function_bank).lead_in(loop_pos) ) ) ) ;
              end loop;
              get_next_in ;
              return false ;
            end if;  -- we are comparing the charcter to the string
          end loop; -- looking for a match on the lead in string
          -- have lead_in matched now determine which key
          for i in 1 .. num_keys_within_type loop
            if key_map(function_bank).each_key(i).key
                                                   /= extended_character(0) then
              if extended_character_in
                                   = key_map(function_bank).each_key(i).key then
                temp_ch:= character'val(
                   key_map(function_bank).each_key(i).final_key) ;
                temp_or_special :=
                  key_map(function_bank).each_key(i).special_meaning ;
                return true ;
              end if ;
            end if ;
          end loop ;
          -- never matched
          -- put back current char and leading ones....
          -- make first of string the current extended_character_in/char_in
          basic_io_system.replace_transparent_input(extended_character_in);
          for loop_pos in reverse 1 ..
                          key_map(function_bank).lead_in_length loop
            basic_io_system.replace_transparent_input(extended_character(character'pos(
                          key_map(function_bank).lead_in(loop_pos) ) ) ) ;
          end loop;
          get_next_in ;
          return false ;
        end is_it_this_bank ;

      begin -- process_non_printing_character
        -- extended_character_IN is < ' ' or >= '~'
        -- Note: the reason ~ is included here is because some OLD terminals
        -- use it as a lead in character
        --
        if extended_character_in > extended_character(127) then
          -- this is an alternate character and only needs to be mapped...
          temp_ch:= CHARACTER'VAL(INTEGER(real_key_on_input(
                                            integer( extended_character_in ))));
          temp_or_special := special_meaning_on_input (
                                            integer( extended_character_in ) ) ;
          return;
        end if;
        --
        -- we only get here if the above if statement is false...
        --
        function_bank := 1 ;
        loop
          complete := is_it_this_bank ;
          exit when complete;
          exit when ( function_bank = num_key_types ) ;
          function_bank := function_bank + 1 ; -- next bank to check
        end loop;
        if not complete then
          -- we did not find this extended_character to be a starter of the
          -- sequence.   Simply map this character into a new one and return...
          temp_ch:= CHARACTER'VAL(INTEGER(real_key_on_input(
                                            integer( extended_character_in ))));
          temp_or_special := special_meaning_on_input (
                                            integer( extended_character_in ) ) ;
        -- else do nothing, CH, and OR_SPECIAL are already set
        end if;
        --
        -- End up with CH and OR_SPECIAL set
      end process_non_printing_character ;

    begin -- key_input
      -- We are getting input text from the keyboard ...
      get_next_in; -- gets extended_character_in and char_in
      if  ( extended_character_in >= extended_character(32))
        --  extended_character( CHARACTER'POS(' ') ) )
      and ( extended_character_in <  extended_character(127)) then
        --  extended_character( CHARACTER'POS('~') ) ) then
        -- We have a printable character....
        -- Simply map this character into a new one and return...
        temp_ch:= CHARACTER'VAL(INTEGER(real_key_on_input(
                                          integer( extended_character_in ))));
        temp_or_special := special_meaning_on_input (
                                          integer( extended_character_in ) ) ;
        -- And, we are done!!
      else
        -- We have a non_printable character which must be looked at
        process_non_printing_character;
        -- Done, getting a character (string) which was (started with)
        -- a non-printable character
      end if ;
      -- Here after we have read in a character (string) from the keyboard
      ch := temp_ch ;
      or_special := temp_or_special ;
    end key_input;

    procedure flush_input is
      -- Clears the input buffer of any characters entered from the
      -- keyboard, but not yet read
      t_extended_character : extended_character ;
    begin
      while basic_io_system.key_is_pressed loop
        t_extended_character := basic_io_system.get_transparent ;
      end loop ;
    end;

    function read_character return character is
      -- read in a character and return.  This routine cannot read in
      -- special characters......only ' ' .. '~'
      chr : character ;
      spc : special_keys ;
    begin -- read_character
      loop
        key_input( chr , spc ) ;
      exit when ( spc = key_character ) ;
        bell;
      end loop ;
      return chr ;
    end read_character ;

    procedure wait_for_character ( character_to_wait_for : character ) is
      -- wait until the specified character is typed.  Beep in case
      -- of mistakes
    begin -- wait_for_character
      loop
      exit when read_character = character_to_wait_for ;
      end loop ;
    end wait_for_character ;

    procedure CLEAR_SET( A_SET : in out CHARACTER_SET ) is
    begin
      for A_CHARACTER in CHARACTER'FIRST .. CHARACTER'LAST
      loop
        A_SET(A_CHARACTER) := FALSE ;
      end loop;
    end CLEAR_SET;

    function IN_SET( ELEMENT : in CHARACTER ;
                     A_SET   : in CHARACTER_SET ) return BOOLEAN is
    begin
      return A_SET(ELEMENT);
    end;

    function goodchar( allowed : character_set ; default : character ;
                       map_to_upper_case : boolean := true )
                       return character is
      -- get in a single character.  Map to upper case.  Keep
      -- reading until a <return> (in which case default is returned) or
      -- else a character is read which is in the allowed set.  Then,
      -- echo the character to the screen and return
      chr : character ;
      spc : special_keys ;
      ValidSet : character_set ;
    begin -- goodchar
      ValidSet := allowed ;
      if map_to_upper_case then
        for c in 'a' .. 'z' loop
          if allowed(c) then
            ValidSet( map_up(c) ) := true ;
          end if ;
        end loop ;
      end if ;
      loop
        key_input( chr , spc ) ;
        if ( spc = key_carriage_return ) or ( spc = key_line_feed ) then
          spc := key_character ;
          chr := default ;
        elsif map_to_upper_case then
          chr := map_up(chr);
        end if ;
      exit when ( spc = key_character ) and then in_set( chr , ValidSet ) ;
        bell;
      end loop ;
      put(chr);
      return chr ;
    end goodchar ;

    procedure get_character ( new_c       : out character ;
                              new_command : out crt_editor_command ) is
      -- get a character or a command from the keyboard
      physical_c : character ;
      physical_command : crt.special_keys ;
    begin -- get_character
      key_input( physical_c , physical_command ) ;
      translate( physical_c , physical_command , new_c , new_command ) ;
    end get_character ;

    function map_up ( c : character ) return character is
    begin -- map_up
      if c in 'a' .. 'z' then
        return character'val( character'pos(c)
                              - character'pos('a')
                              + character'pos('A') );
      else
        return c ;
      end if ;
    end map_up ;

    function map_down ( c : character ) return character is
    begin
      if c in 'A' .. 'Z' then
        return character'val( character'pos(c)
                              - character'pos('A')
                              + character'pos('a') );
      else
        return c ;
      end if ;
    end map_down ;

    function char_within_range_or_abort ( default , lowest_item ,
                                                    highest_item : character )
                                          return character is
      -- get a character which is within the range specified
      ValidSet : character_set ;
      chr : character ;
      spc : special_keys ;
    begin --char_within_range_or_abort
      clear_set(ValidSet);
      for cc in lowest_item .. highest_item loop
        ValidSet ( cc ) := true ;
        if cc in 'a' .. 'z' then
          ValidSet ( map_up(cc )  ) := true ;
        end if ;
      end loop ;loop
        key_input( chr , spc ) ;
        if ( spc = key_carriage_return ) or ( spc = key_line_feed ) then
          spc := key_character ;
          chr := default ;
        else
          chr := map_up(chr) ;
        end if ;
      exit when ( ( spc = key_character ) and then in_set( chr, ValidSet ) )
      or   else ( spc = key_escape ) ;
        bell;
      end loop ;
      if spc = key_escape then
        return ascii.nul ;
      else
        put(chr);
        return chr ;
      end if ;
    end char_within_range_or_abort ;

    function char_or_abort ( default , c_1 , c_2 , c_3 , c_4 ,
                                       c_5 , c_6 , c_7 , c_8 ,
                                       c_9 : in character := ascii.nul )
                             return character is
      ValidSet : character_set ;
      chr : character ;
      spc : special_keys ;
    begin -- char_or_abort
      clear_set(ValidSet);
      ValidSet(c_1) := true ;
      ValidSet(c_2) := true ;
      ValidSet(c_3) := true ;
      ValidSet(c_4) := true ;
      ValidSet(c_5) := true ;
      ValidSet(c_6) := true ;
      ValidSet(c_7) := true ;
      ValidSet(c_8) := true ;
      ValidSet(c_9) := true ;
      ValidSet(ascii.nul ) := false ;
      -- Now, make sure that we get all upper/lower combinations
      for c in 'a' .. 'z' loop
        if ValidSet(c) then
          ValidSet( map_up(c) ) := true ;
        end if ;
      end loop ;
      loop
        key_input( chr , spc ) ;
        if ( spc = key_carriage_return ) or ( spc = key_line_feed ) then
          spc := key_character ;
          chr := default ;
        else
          chr := map_up(chr);
        end if ;
      exit when ( ( spc = key_character ) and then in_set( chr, ValidSet ) )
      or   else ( spc = key_escape ) ;
        bell;
      end loop ;
      if spc = key_escape then
        return ascii.nul ;
      else
        put(chr);
        return chr ;
      end if ;
    end char_or_abort ;

    function STRING_READ( FORMAT : in PSTRING ;
                          DEFAULT: in PSTRING ; -- := "" ;
                          LENGTH : in window_column_number := 0 ;
                          COL    : in window_column_number := 0 ;
                          LINE   : in window_line_number := 0 ;
                          ALLOW_LOWER_CASE : in BOOLEAN  := TRUE
                        ) return PSTRING is

      --  INPUTS
      --
      --  The FORMAT string must contain format characters telling the
      --    string read routine what type of characters to accept as
      --    input.  The length of the allowed input string is controlled
      --    by either the length variable or the length of the format
      --    string.  If LENGTH is 0, then the length is controlled by
      --    the length of FORMAT.  In all other cases, the input string
      --    length is determined by LENGTH.  If LENGTH is greater than
      --    the length of FORMAT, then FORMAT is assumed to be lengthened
      --    to the right with blanks.
      --  The DEFAULT string contains the default value of the field
      --    should the user type <return> in response to this input request.
      --  The LENGTH is the maximum input length allowed.
      --  The COL,LINE pair control where on the screen the cursor is
      --    positioned in preparation for this input request.  If either
      --    is 0, then the cursor is not re-positioned.
      --  If ALLOW_LOWER_CASE is true, then lower case characters are accepted
      --    from the keyboard and left as is.  Otherwise, lower case character
      --    are transposed into their upper case equivalents.
      --
      --  OPERATION
      --
      --  OUTPUTS
      --
      --  STRING_READ returns a string as a result of the reading of character
      --    from the terminal device.
      --
      FORMAT_CHARACTERS : CHARACTER_SET;
                              -- Valid Format Characters In Fmat Str
      ORIG_CRT_COLOR    : CRT_COLOR;
                              -- Origional CRT Color before call
      IN_STRING         : PSTRING;
                              -- The input string typed at CRT
      PLACE             : INTEGER;
      ALLOWED_LENGTH    : INTEGER;

      FINISHED          : BOOLEAN ;
      DONE              : BOOLEAN ;
      CHR               : CHARACTER ; -- character read in from CRT
      CHR_SPECIAL       : SPECIAL_KEYS ;

      GOOD_SET          : CHARACTER_SET;
      VALID_INPT_RESULT : BOOLEAN ;  -- returned from valid_input
      current_format    : character    ;

      procedure BACKSPACE is
      begin
        put(ASCII.BS);
      end;

      procedure INITIALIZE is
      begin -- initialize
        -- Set Format Initialization.  These are the valid format characters
        CLEAR_SET(FORMAT_CHARACTERS);
        FORMAT_CHARACTERS('A') := TRUE ;
        FORMAT_CHARACTERS('9') := TRUE ;
        FORMAT_CHARACTERS('Z') := TRUE ;
        FORMAT_CHARACTERS('~') := TRUE ;
        FORMAT_CHARACTERS('.') := TRUE ;
        FORMAT_CHARACTERS(' ') := TRUE ;
        -- Now, remember the color of characters on the screen for later
        ORIG_CRT_COLOR := CURRENT_CRT_COLOR;
        -- Now, determine the length of the input string
        if length > 0 then
          allowed_length := length;
        else
          allowed_length := string_library.length(format) ;
        end if;
        if (col > 0) and (line > 0) then
          goto_line_column ( current_window , line , col ) ;
        end if;
        -- Now, show the colored bar on the screen
        change_color(black,white);
        for index in 1..allowed_length
        loop
          if IN_SET(FORMAT.data(index),FORMAT_CHARACTERS) then
            put(' ');
          else
            put(FORMAT.data(index));
          end if;
        end loop;
        for index in 1..allowed_length
        loop
          backspace;
        end loop;
        -- Now, we are back to where we started...
        change_color(red);
        -- with red characters ready to appear
      end initialize;

      procedure CLEAR_BELL is
        -- This routine will:
        --   1) ring the bell
        --   2) wait 1 second
        --   3) clear the input buffer (if possible)
        --   4) and ring the bell again
      begin
        bell;
        delay 1.0 ;
        flush_input ; -- Clear the input buffer
        bell;
      end clear_bell;

      procedure BACKOUT is
      begin
        change_color(black,white);
        if IN_SET( format.data(place) , FORMAT_CHARACTERS ) then
          put(' ');
        else
          put(format.data(place));
        end if;
        backspace;
        change_color(red,black);
      end backout;

      procedure MY_BACKSPACE( ERROR : in BOOLEAN ) is
        DONE : BOOLEAN := false ;
      begin
        if error then
          clear_bell;
        else
          loop
            backspace;
            backout;
            IN_STRING.data(place) := ' ' ; -- Clear the old input characters
            place := place - 1 ;
          exit when ( place = 0 ) or else IN_SET(format.data(place+1),
                                                 FORMAT_CHARACTERS) ;
          end loop;
        end if;
      end my_backspace;

      function VALID_INPUT( A_CHARACTER : in CHARACTER;
                            ALLOWED_SET : in CHARACTER_SET ) return BOOLEAN is
        -- returns true if a_character is a valid input for the given
        -- character set
      begin
        if IN_SET(A_CHARACTER,ALLOWED_SET) then
          place := place + 1;
          IN_STRING.data(place) := A_CHARACTER;
          PUT(A_CHARACTER);
          return TRUE ;
        else
          MY_BACKSPACE(TRUE);
          return FALSE ;
        end if;
      end valid_input;

      Procedure SET_GOOD_SET ( start_rng , stop_rng : in character ) is
      begin
        for i in character'pos(start_rng) .. character'pos(stop_rng) loop
          good_set(character'val(i)) := true ;
        end loop ;
      end set_good_set;

    begin  -- string_read
      initialize;
      for place in 1 .. allowed_length loop
        in_string.data(place) := ' ' ;
      end loop ;
      place := 0 ;
      change_color(black , white) ;
      change_crt(crt.underline) ;
      for place in 1 .. allowed_length loop
        if place <= string_library.length(format) then
          if in_set(format.data(place) , format_characters) then
            put(' ');
          else
            put(format.data(place)) ;
          end if;
        else
          put(' ') ;
        end if ;
      end loop ;
      for place in 1 .. allowed_length loop
        backspace ;
      end loop ;
      change_color(red) ;
      -- now get the string in
      place := 0 ;  -- how many filled
      finished := false ;
      while (not finished) and (place < allowed_length) loop
        if string_library.length(format) <= place then
          -- assume format lengthed w/blanks
          current_format := ' ' ;
        else
          current_format := format.data(place+1);
        end if ;
        if not in_set(current_format,format_characters) then
          place := place + 1 ;
          in_string.data(place) := format.data(place) ;
          put(format.data(place)) ;
        else
          -- we need to get in a character
          key_input( chr , chr_special ) ;
          if not allow_lower_case then
            chr := map_up(chr) ;
          end if ;
          if (chr_special = key_carriage_return )
          or (chr_special = key_line_feed       ) then
            finished := TRUE ;
          elsif (chr_special = key_backspace )
             or (chr_special = key_delete    ) then
            my_backspace(place=0) ;
          elsif chr = ascii.etb then
            -- ^W
            done := false ;
            while not done loop
              if place = 0 then
                done := true ;
              elsif (in_string.data(place) >= '0'
                                            and in_string.data(place) <= '9')
                 or (in_string.data(place) >= 'A'
                                            and in_string.data(place) <= 'Z')
                 or (in_string.data(place) >= 'a'
                                            and in_string.data(place) <= 'z')
                            then
                my_backspace(false) ;
              else
                done := true ;
              end if ;
            end loop ;
          elsif chr < ' ' then
            clear_bell ; -- illegal response
          else
            clear_set( good_set ) ;
            case format.data(place+1) is
              when ' ' =>set_good_set(' ' ,  '~') ;
                         valid_inpt_result := valid_input( chr , good_set ) ;
              when '9' =>set_good_set('0' , '9') ;
                         good_set(',') := true ;
                         valid_inpt_result := valid_input( chr , good_set ) ;
              when 'A' =>set_good_set('A' , 'Z') ;
                         set_good_set('a' , 'z') ;
                         valid_inpt_result := valid_input( chr , good_set ) ;
              when 'Z' =>set_good_set('0' , '9') ;
                         set_good_set('A' , 'Z') ;
                         set_good_set('a' , 'z') ;
                         valid_inpt_result := valid_input( chr , good_set ) ;
              when '~' =>set_good_set('0' , '9') ;
                         good_set(',') := true ;
                         good_set('+') := true ;
                         good_set('-') := true ;
                         valid_inpt_result := valid_input( chr , good_set ) ;
              when '.' =>set_good_set('0' , '9') ;
                         good_set('E') := true ;
                         good_set('e') := true ;
                         good_set('+') := true ;
                         good_set('-') := true ;
                         good_set('.') := true ;
                         good_set(',') := true ;
                         valid_inpt_result := valid_input( chr , good_set ) ;
              when '^' =>set_good_set('0' , '9') ;
                         good_set('+') := true ;
                         good_set('-') := true ;
                         good_set(',') := true ;
                         good_set('.') := true ;
                         valid_inpt_result := valid_input( chr , good_set ) ;
              when others => null ; -- we can't get here
            end case ;
          end if ;
        end if ;
      end loop ;
      -- Set the crt color back to the original setting
      if place = 0 then
        for i in 1 .. allowed_length loop
          in_string.data(i) := default.data(i) ;
        end loop ;
        set_length(in_string,allowed_length) ;
      else
        set_length(in_string,place) ;
      end if ;
      for tmp in place+1 .. allowed_length loop
        put(' ');
      end loop ;
      CHANGE_COLOR(ORIG_CRT_COLOR);
      CHANGE_CRT(NORMAL);
      RETURN IN_STRING ;

    end STRING_READ;

    function get_number ( line : in window_line_number   ;
                          col  : in window_column_number ;
                          smallest : in integer          ;
                          largest  : in integer          ;
                          len      : in integer          ;
                          default  : in integer          )
                          return integer is
      -- get a number within the range if possible.  On reject/return
      -- simply return default
      new_string : pstring ;
      err_message: pstring ;
      num        : integer ;

      function n ( c : character ) return integer is
      begin -- n
        return character'pos(c) - character'pos('0') ;
      end n ;

    begin -- get_number
      loop
        new_string := string_read( string_to_pstring( "9999999999" ) ,
                                   string_to_pstring( "          " ) ,
                                   len , col , line ) ;
        if ( line > 0 ) and then ( col > 0 ) then
          goto_line_column ( current_window , line , col ) ;
        else
          for posn in 1 .. len loop
            put(ascii.bs);
          end loop ;
        end if ;
        if new_string.data(1) = ' ' then
          put( default , len ) ;
          return default ;
        else
          num := 0 ;
          for place in 1 .. string_library.length(new_string) loop
            num := num * 10 + n(new_string.data(place)) ;
          end loop ;
          if ( num < smallest ) or ( num > largest ) then
            -- we need to send out an error message
            -- err_message := " Error: Number must be in the range "
                              -- & int_to_str(smallest)
                              -- & " .. "
                              -- & int_to_str(largest)
                              -- & ".  " ;
            -- error(err_message, not_fatal_error, operator_wait, short_beep ) ;
            bell ;
          else
            put( num , len ) ;
            return num ;
          end if ;
        end if ;
      end loop ;
    end get_number ;

  begin -- crt_Windows
    -- WINDOWS  by SAIC/Clearwater Window Management Routines  07 Jan 85
    -- WINDOWIN by SAIC/Clearwater Extended I/O Routines       30 Jan 85
    --
      null ;
    --
  end crt_Windows ;

  --$$$- CWINDOWS

--::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::
--wpglobal
--::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::

  --$$$+ WPGLOBAL

  --
  -- File 005
  --
  -- Editor Written By Robert S. Cymbalski
  --                   Science Applications International Corporation
  --                   Energy Systems Group
  --                   Ada Software Development Project Team
  --                   2280 U.S. Highway 19 North, Suite 120
  --                   Clearwater, Florida  33575
  --
  -- Program Revised from text Copyright (c) 1984 , R.S.Cymbalski

  with text_io , io_exceptions ;

  with string_library  ;
  use  string_library  ;

  with basic_io_system ;

  with crt_customization  ;
  use  crt_customization  ;
  use  crt             ;

  with crt_windows     ;
  use  crt_windows     ;

  package Wordp_Globals is

    maximum_file_name_length : constant integer := 20 ;

    default_text_file_suffix : constant string ( 1 .. 5 ) := ".text" ;
    default_backup_ending    : constant string ( 1 .. 4 ) := ".bak"  ;

    subtype ascii_text_file_name is string ( 1 .. maximum_file_name_length ) ;

    no_file : constant ascii_text_file_name := "                    " ;

    editor_entry_input_file_name         : ascii_text_file_name := no_file ;
    editor_entry_output_file_name        : ascii_text_file_name := no_file ;
    editor_requested_input_file_name     : ascii_text_file_name := no_file ;
    editor_requested_output_file_name    : ascii_text_file_name := no_file ;

    formatter_entry_input_file_name      : ascii_text_file_name := no_file ;
    formatter_entry_output_file_name     : ascii_text_file_name := no_file ;
    formatter_requested_input_file_name  : ascii_text_file_name := no_file ;
    formatter_requested_output_file_name : ascii_text_file_name := no_file ;

    only_editor : constant boolean := true  ;
      -- tells editor if it should allow the "P" option on exit

    type type_what_to_run_next is ( master_menu , text_editor , text_formatter ,
                                    operating_system , format_editor_file ,
                                    edit_formatter_file ) ;

    what_to_run_next : type_what_to_run_next ;

    -- Each of the two main packages can have an entry input and output
    -- file name.  If so, those file names are used ( if possible ) .
    -- If the input file does not exist, then we ask for the file they
    -- really want.  If we do ask, we set the requested file name as
    -- appropriate.

    -- Now , we list the Predefined File Names --
    -- First , The SYSTEM Files

    -- Now , The USER Files

    Help_On_Editor_Commands_File_Name        : constant ascii_text_file_name
                                             := "EDITCMD.HLP         " ;
    Help_On_Set_Commands_File_Name           : constant ascii_text_file_name
                                             := "EDITSET.HLP         " ;
    Help_On_Environment_Commands_File_Name   : constant ascii_text_file_name
                                             := "EDITENV.HLP         " ;
    Default_Environment_File_Name            : constant ascii_text_file_name
                                             := "EDITENV.DEF         " ;

    -- a..z , 0 ..9 only chars allowed
    -- only  3 chars allowed after .

    function file_exists ( file_name : in  string ) return boolean ;
      -- look for this file name with no changes

    function file_exists ( file_name : in pstring ) return boolean ;
      -- look for this file name with no changes

    procedure ok_to_read    ( orig_file_name : in string      ;
                              final_file_name : out pstring   ;
                              successfull     : out boolean ) ;
      -- look for the orig_file_name on the appropriate disks.  Return
      -- successfull if found, and also set the final_file_name as
      -- the fully elaborated file path/name

    procedure ok_to_read    ( orig_file_name : in pstring     ;
                              final_file_name : out pstring   ;
                              successfull     : out boolean ) ;
      -- look for the orig_file_name on the appropriate disks.  Return
      -- successfull if found, and also set the final_file_name as
      -- the fully elaborated file path/name

    procedure ok_to_read    ( orig_file_name  : in  ascii_text_file_name ;
                              final_file_name : out ascii_text_file_name ;
                              successfull     : out boolean ) ;
      -- look for the orig_file_name on the appropriate disks.  Return
      -- successfull if found, and also set the final_file_name as
      -- the fully elaborated file path/name

    procedure open_for_read ( file_handle     : in out text_io.file_type ;
                              file_name       : in out ascii_text_file_name ;
                              successfull     : out boolean            ) ;
      -- Open the file setting the handle

    procedure open_for_write( file_handle     : in out text_io.file_type ;
                              file_name       : in out ascii_text_file_name ;
                              successfull     : out boolean            ) ;
      -- Open the file setting the handle

    procedure sok_to_read   ( orig_file_name : in string      ;
                              final_file_name : out pstring   ;
                              successfull     : out boolean ) ;
      -- For Editor Program Files (such as help)
      -- look for the orig_file_name on the appropriate disks.  Return
      -- successfull if found, and also set the final_file_name as
      -- the fully elaborated file path/name

    procedure sok_to_read   ( orig_file_name : in pstring     ;
                              final_file_name : out pstring   ;
                              successfull     : out boolean ) ;
      -- For Editor Program Files (such as help)
      -- look for the orig_file_name on the appropriate disks.  Return
      -- successfull if found, and also set the final_file_name as
      -- the fully elaborated file path/name

    procedure sok_to_read   ( orig_file_name  : in  ascii_text_file_name ;
                              final_file_name : out ascii_text_file_name ;
                              successfull     : out boolean ) ;
      -- For Editor Program Files (such as help)
      -- look for the orig_file_name on the appropriate disks.  Return
      -- successfull if found, and also set the final_file_name as
      -- the fully elaborated file path/name

    function ok_to_write    ( orig_file_name : in string    ) return boolean ;
      -- check that the file does not exist

    function ok_to_write    ( orig_file_name : in pstring   ) return boolean ;
      -- check that the file does not exist

    Procedure do_purge( s : in string ) ;
      -- purge that file from the system (if it exists)

    Procedure do_purge( s : in pstring ) ;
      -- purge that file from the system (if it exists)

    Procedure Rename_File ( Old_File_Name : in ascii_text_file_name ;
                            New_File_Name : in ascii_text_file_name ) ;

    Procedure no_file_found( s : in  string ; fatal : in  boolean) ;

    Procedure no_file_found( s : in pstring ; fatal : in  boolean) ;

    Function get_input_filename_or_return  return ascii_text_file_name ;
      -- Reads in file name discarding illegal characters , where
      -- A..Z , a..z , 0 ..9  are only characters allowed in a file name
      -- and only  3 characters are allowed after a period(.)
      -- If the file does not exist then esc & file-name(1 .. length-1)
      -- is returned.

    Function get_output_filename_or_return return ascii_text_file_name ;

    Function get_output_filename_or_return( default_suffix : in string )
                                            return ascii_text_file_name ;

    Function No_Blanks ( s : in string ) return string ;

    type a_beep_length is ( extra_short_beep , short_beep , medium_beep ,
                            long_beep , extra_long_beep );

    type a_wait_length is ( extra_short_wait , short_wait , medium_wait ,
                            long_wait , extra_long_wait , operator_wait );

    type type_of_error is ( fatal_error , not_fatal_error ) ;

    procedure error_beep( beep_length : in a_beep_length ) ;

    procedure error( error_message : in string     ;
                     is_it_fatal   : type_of_error ;
                     wait_length   : a_wait_length ;
                     beep_length   : a_beep_length ) ;
      -- We have an error.  Show the message, and then work as appropriate

    procedure error( error_message : in string_library.pstring ;
                     is_it_fatal   : type_of_error ;
                     wait_length   : a_wait_length ;
                     beep_length   : a_beep_length ) ;
      -- We have an error.  Show the message, and then work as appropriate

  end Wordp_Globals ;

  package body Wordp_Globals is

    function user_name ( s : in pstring ) return pstring is
      -- turn this file name into a user name
    begin -- user_name
      if basic_io_system.directory_separator = ' ' then
        -- nothing defined
        return s;
      else
        -- ok. we have a basic_io_system.directory separator to look for
        if position( basic_io_system.directory_separator , s ) /= 0 then
          -- they defined the basic_io_system.directory, so don't do anything
          return s;
        else
          -- ok, turn it into the appropriate one
          return basic_io_system.user_directory & s ;
        end if ;
      end if ;
    end user_name ;

    function user_name ( s : in string ) return pstring is
      -- turn this file name into a user name
    begin -- user_name
      return user_name( string_to_pstring(s) ) ;
    end user_name ;

    function wp_name ( s : in pstring ) return pstring is
      -- turn this file name into a wp name
    begin -- wp_name
      if basic_io_system.directory_separator = ' ' then
        -- nothing defined
        return s;
      else
        -- ok. we have a directory separator to look for
        if position( basic_io_system.directory_separator , s ) /= 0 then
          -- they defined the directory, so don't do anything
          return s;
        else
          -- ok, turn it into the appropriate one
          return basic_io_system.word_processor_directory & s ;
        end if ;
      end if ;
    end wp_name ;

    function wp_name ( s : in string ) return pstring is
      -- turn this file name into a wp name
    begin -- wp_name
      return wp_name( string_to_pstring(s) ) ;
    end wp_name ;

    function no_blanks ( s : in string ) return string is
      ot_string : string ( 1 .. s'length ) ;
      ot_length : integer ;
    begin -- no_blanks
      ot_length := 0 ;
      for place in 1 .. s'length loop
        if s(place) /= ' ' then
          ot_length := ot_length + 1 ;
          ot_string(ot_length) := s(place);
        end if ;
      end loop ;
      return ot_string( 1 .. ot_length ) ;
    end no_blanks ;

    function no_blanks ( s : in pstring ) return string is
      ot_string : string ( 1 .. length(s) ) ;
      ot_length : integer ;
    begin -- no_blanks
      ot_length := 0 ;
      for place in 1 .. length(s) loop
        if s.data(place) /= ' ' then
          ot_length := ot_length + 1 ;
          ot_string(ot_length) := s.data(place);
        end if ;
      end loop ;
      return ot_string( 1 .. ot_length ) ;
    end no_blanks ;

    function file_exists ( file_name : in string ) return boolean is
      -- look for this file name with no changes
      temp_file : text_io.file_type ;
    begin -- file_exists
      text_io.open(temp_file , text_io.in_file , no_blanks(file_name) ) ;
      text_io.close(temp_file) ;
      return true ;
    exception
      when io_exceptions.name_error
         | io_exceptions.use_error   => return false ;
      when others                    => return false ;
    end file_exists ;

    function file_exists ( file_name : in pstring ) return boolean is
      -- look for this file name with no changes
      temp_file : text_io.file_type ;
    begin -- file_exists
      text_io.open(temp_file , text_io.in_file , no_blanks(file_name) );
      text_io.close(temp_file) ;
      return true ;
    exception
      when io_exceptions.name_error
         | io_exceptions.use_error   => return false ;
      when others                    => return false ;
    end file_exists ;

    procedure ok_to_read    ( orig_file_name : in string      ;
                              final_file_name : out pstring   ;
                              successfull     : out boolean ) is
      -- look for the orig_file_name on the appropriate disks.  Return
      -- successfull if found, and also set the final_file_name as
      -- the fully elaborated file path/name
    begin -- ok_to_read
      ok_to_read( string_to_pstring( orig_file_name ) , final_file_name ,
                  successfull ) ;
    end ok_to_read ;

    procedure ok_to_read    ( orig_file_name : in pstring     ;
                              final_file_name : out pstring   ;
                              successfull     : out boolean ) is
      -- look for the orig_file_name on the appropriate disks.  Return
      -- successfull if found, and also set the final_file_name as
      -- the fully elaborated file path/name
      new_name : pstring ;
    begin -- ok_to_read
      if file_exists ( orig_file_name ) then
        final_file_name := orig_file_name ;
        successfull     := true ;
      else
        -- check for a user directory
        new_name := user_name( orig_file_name ) ;
        if new_name = orig_file_name then
          -- nothing we can do about it
          final_file_name := blank_line ;
          successfull     := false      ;
        else
          if file_exists( new_name ) then
            final_file_name := new_name ;
            successfull     := true     ;
          else
            final_file_name := blank_line ;
            successfull     := false      ;
          end if ;
        end if ;
      end if ;
    end ok_to_read ;

    procedure ok_to_read    ( orig_file_name  : in  ascii_text_file_name ;
                              final_file_name : out ascii_text_file_name ;
                              successfull     : out boolean ) is
      -- look for the orig_file_name on the appropriate disks.  Return
      -- successfull if found, and also set the final_file_name as
      -- the fully elaborated file path/name
      ps : string_library.pstring ;
    begin -- ok_to_read
      ok_to_read( string_to_pstring( orig_file_name ) , ps ,
                  successfull ) ;
      final_file_name := no_file ;
      for posn in 1 .. length(ps) loop
        final_file_name(posn) := ps.data(posn);
      end loop;
    end ok_to_read ;

    function return_name ( file_handle : in text_io.file_type )
                           return ascii_text_file_name is
      new_name : ascii_text_file_name := no_file ;
      current_name : constant string := text_io.name(file_handle) ;
    begin -- return_name
      if current_name'length <= new_name'length then
        new_name( 1 .. current_name'length ) := current_name ;
      end if ;
      return new_name ;
    exception
      when others => return new_name ;
    end return_name ;

    procedure open_for_read ( file_handle     : in out text_io.file_type ;
                              file_name       : in out ascii_text_file_name ;
                              successfull     : out boolean            ) is
      -- look for the orig_file_name on the appropriate disks.  Return
      -- successfull if found, and also set the final_file_name as
      -- the fully elaborated file path/name.  Open the file setting
      -- the handle
      new_name : ascii_text_file_name ;
    begin -- open_for_read
      if text_io.is_open(file_handle) then
        text_io.close(file_handle);
      end if ;
      text_io.open(file_handle,text_io.in_file,no_blanks(file_name));
      new_name := return_name( file_handle ) ;
      if new_name /= no_file then
        file_name := new_name ;
      end if ;
      successfull := true ;
    exception
      when others                    => successfull := false ;
    end open_for_read ;

    procedure open_for_write( file_handle     : in out text_io.file_type ;
                              file_name       : in out ascii_text_file_name ;
                              successfull     : out boolean            ) is
      -- Open the file setting the handle
      new_name : ascii_text_file_name ;
    begin -- open_for_write
      if text_io.is_open(file_handle) then
        text_io.close(file_handle);
      end if ;
      text_io.create(file_handle,text_io.out_file,no_blanks(file_name));
      new_name := return_name( file_handle ) ;
      if new_name /= no_file then
        file_name := new_name ;
      end if ;
      successfull := true ;
    exception
      when others                    => successfull := false ;
    end open_for_write ;

    procedure sok_to_read   ( orig_file_name : in string      ;
                              final_file_name : out pstring   ;
                              successfull     : out boolean ) is
      -- For Editor Program Files (such as help)
      -- look for the orig_file_name on the appropriate disks.  Return
      -- successfull if found, and also set the final_file_name as
      -- the fully elaborated file path/name
    begin -- sok_to_read
      sok_to_read( string_to_pstring( orig_file_name ) , final_file_name ,
                   successfull ) ;
    end sok_to_read ;

    procedure sok_to_read   ( orig_file_name : in pstring     ;
                              final_file_name : out pstring   ;
                              successfull     : out boolean ) is
      -- For Editor Program Files (such as help)
      -- look for the orig_file_name on the appropriate disks.  Return
      -- successfull if found, and also set the final_file_name as
      -- the fully elaborated file path/name
      new_name : pstring ;
      status   : boolean ;
    begin -- sok_to_read
      if file_exists ( orig_file_name ) then
        final_file_name := orig_file_name ;
        successfull     := true ;
      else
        -- check for a user directory
        new_name := user_name( orig_file_name ) ;
        if new_name = orig_file_name then
          -- nothing we can do about it
          final_file_name := blank_line ;
          status          := false      ;
        else
          if file_exists( new_name ) then
            final_file_name := new_name ;
            status          := true     ;
          else
            final_file_name := blank_line ;
            status          := false      ;
          end if ;
        end if ;
        -- just finished looking in the user directory
        if status then
          successfull := true ;
        else
          -- look in the system directory
          new_name := wp_name( orig_file_name ) ;
          if new_name = orig_file_name then
            -- nothing we can do about it
            final_file_name := blank_line ;
            successfull     := false      ;
          elsif file_exists( new_name ) then
            final_file_name := new_name ;
            successfull     := true     ;
          else
            final_file_name := blank_line ;
            successfull     := false      ;
          end if ;
        end if ;
      end if ;
    end sok_to_read ;

    procedure sok_to_read   ( orig_file_name  : in  ascii_text_file_name ;
                              final_file_name : out ascii_text_file_name ;
                              successfull     : out boolean ) is
      -- For Editor Program Files (such as help)
      -- look for the orig_file_name on the appropriate disks.  Return
      -- successfull if found, and also set the final_file_name as
      -- the fully elaborated file path/name
      ps : string_library.pstring ;
    begin -- sok_to_read
      sok_to_read( string_to_pstring( orig_file_name ) , ps ,
                  successfull ) ;
      final_file_name := no_file ;
      for posn in 1 .. length(ps) loop
        final_file_name(posn) := ps.data(posn);
      end loop;
    end sok_to_read ;

    function ok_to_write    ( orig_file_name : in string    ) return boolean is
      -- check that the file does not exist
    begin -- ok_to_write
      return not file_exists( orig_file_name ) ;
    end ok_to_write ;

    function ok_to_write    ( orig_file_name : in pstring   ) return boolean is
      -- check that the file does not exist
    begin -- ok_to_write
      return not file_exists( orig_file_name ) ;
    end ok_to_write ;

    Procedure do_purge( s : in string ) is
      -- purge that file from the system (if it exists)
      temp_file : text_io.file_type ;
    begin -- do_purge
      if file_exists(s) then
        -- purge it
        text_io.open(temp_file,text_io.out_file,no_blanks(s));
        text_io.delete(temp_file);
      end if ;
    exception
      when others => null ;
    end do_purge ;

    Procedure do_purge( s : in pstring ) is
      -- purge that file from the system (if it exists)
      temp_file : text_io.file_type ;
    begin -- do_purge
      if file_exists(s) then
        -- purge it
        text_io.open(temp_file,text_io.out_file,no_blanks(s));
        text_io.delete(temp_file);
      end if ;
    exception
      when others => null ;
    end do_purge ;

    Procedure Rename_File ( Old_File_Name : in ascii_text_file_name ;
                            New_File_Name : in ascii_text_file_name ) is
      -- rename the file with the old file name to have the new file
      -- name.
    begin -- rename_file
      raise user_abort ;
    end rename_file ;

    Procedure no_file_found( s : in  string ; fatal : in  boolean) is
    begin -- no_file_found
      no_file_found( string_to_pstring(s),fatal);
    end no_file_found ;

    Procedure no_file_found( s : in pstring ; fatal : in  boolean) is
      c : character ;
    begin -- no_file_found
      if fatal then
        crt.do_crt(crt.erase_all) ;
      end if ;
      crt.gotoxy(0,0) ;
      put("File """);
      put(s) ;
      put(""" Does Not Exist.   ");
      if fatal then
        crt.gotoxy(5,5) ;
        put("Please place the file on tha appropriate disk and retry");
      end if ;
      put("  Type <space> to continue.. ");
      crt_windows.wait_for_character(' ');
      if fatal then
        raise user_abort ;
      end if ;
    end no_file_found ;

    Function get_input_filename_or_return  return ascii_text_file_name is
      -- Reads in a file name discarding all illegal characters, where
      -- a..z , 0 ..9  are only characters allowed in a file name and
      -- only  3 characters are allowed after a period(.)
      -- If the file does not exist then esc & file-name(1 .. length-1)
      -- is returned.

      ret_file_name : ascii_text_file_name := no_file ;
      pfile_name    : pstring ;
      format ,
      default ,
      new_name      : pstring ;
      ok            : boolean ;

    begin
      -- First, read in the file name
      format   := string_to_pstring(no_file);
      default  := string_to_pstring(no_file);
      new_name := crt_windows.string_read( format , default ) ;
      if new_name = default then
        return no_file ;
      else
        -- Now, we will first allow the addition of .text
        if length(new_name) <= maximum_file_name_length -
                               default_text_file_suffix'length then
          if position('.',new_name) = 0 then
            new_name := compress(new_name) & default_text_file_suffix ;
          end if;
        end if ;
        if new_name.data( length(new_name) ) = '.' then
          set_length( new_name , length(new_name) - 1 ) ;
          -- eat last '.'
        end if ;
        ret_file_name( 1 .. length(new_name) ) :=
                        new_name.data( 1 .. length(new_name) ) ;
        -- Now, check for all valid characters
        ok       := true ;
        for posn in 1 .. maximum_file_name_length loop
          ok := ok and
            (  ( ( ret_file_name( posn ) = basic_io_system.directory_separator )
             and ( ret_file_name( posn ) /= ' ' ) )
            or ( ret_file_name( posn ) = '.' )
            or ( ( ret_file_name(posn)>='A' ) and ( ret_file_name(posn)<='Z' ) )
            or ( ( ret_file_name(posn)>='a' ) and ( ret_file_name(posn)<='z' ) )
            or ( ( ret_file_name(posn)>='0' ) and ( ret_file_name(posn)<='9' ) )
            or ( ret_file_name(posn) = ':' )
            or ( ret_file_name(posn) = ' ' ) -- eaten by no_blanks
            ) ;
        end loop ;
        if ok then
          -- Now, check for number of characters past '.'

          -- And finally, check for existance of file itself
          ok_to_read( ret_file_name , pfile_name , ok ) ;
        end if ;
        if ok then
          -- must turn pfile_name into correct format
          ret_file_name := no_file ; -- put blanks into file name
          for posn in 1 .. length(pfile_name) loop
            -- note that we are not checking here for string too long ...
            ret_file_name(posn) := pfile_name.data(posn);
          end loop ;
        else
          -- not ok
for looper in reverse 2 .. maximum_file_name_length - 1 loop
            ret_file_name(looper) := ret_file_name(looper-1) ;
          end loop ;
          ret_file_name(1) := ascii.esc ;
        end if;
        return ret_file_name ;
      end if ;
    end get_input_filename_or_return ;

    Function get_output_filename_or_return( default_suffix : in string )
                                            return ascii_text_file_name is

      ret_file_name : ascii_text_file_name := no_file ;
      pfile_name    : pstring ;
      format ,
      default ,
      new_name      : pstring ;
      ok            : boolean ;
    begin
      -- First, read in the file name
      format   := string_to_pstring(no_file);
      default  := string_to_pstring(no_file);
      new_name := crt_windows.string_read( format , default ) ;
      if new_name = default then
        return no_file ;
      else
        -- Now, we will first allow the addition of .text
        if length(new_name) <= maximum_file_name_length -
                               default_suffix'length then
          if position('.',new_name) = 0 then
            new_name := compress(new_name) & default_suffix ;
          end if;
        end if ;
        if new_name.data( length(new_name) ) = '.' then
          set_length( new_name , length(new_name) - 1 ) ;
          -- eat last '.'
        end if ;
        ret_file_name( 1 .. length(new_name) ) :=
                        new_name.data( 1 .. length(new_name) ) ;
        -- Now, check for all valid characters
        ok       := true ;
        for posn in 1 .. maximum_file_name_length loop
          ok := ok and
            (  ( ( ret_file_name( posn )
                                     = basic_io_system.directory_separator )
             and ( ret_file_name( posn ) /= ' ' ) )
            or ( ret_file_name( posn ) = '.' )
            or ((ret_file_name(posn)>='A' )
                                        and ( ret_file_name(posn)<='Z'))
            or ((ret_file_name(posn)>='a' )
                                        and ( ret_file_name(posn)<='z'))
            or ((ret_file_name(posn)>='0' )
                                        and ( ret_file_name(posn)<='9'))
            or ( ret_file_name(posn) = ':' )
            or ( ret_file_name(posn) = ' ' ) -- eaten by no_blanks
            ) ;
        end loop ;
        if not ok then
          -- not ok
for looper in reverse 2 .. maximum_file_name_length - 1 loop
            ret_file_name(looper) := ret_file_name(looper-1) ;
          end loop ;
          ret_file_name(1) := ascii.esc ;
        end if;
        return ret_file_name ;
      end if ;
    end get_output_filename_or_return ;

    Function get_output_filename_or_return return ascii_text_file_name is
    begin
      return get_output_filename_or_return( default_text_file_suffix ) ;
    end ;

    procedure error_beep( beep_length : in a_beep_length ) is
    -- type a_beep_length is ( extra_short_beep , short_beep , medium_beep ,
    --                         long_beep , extra_long_beep );
    begin -- error_beep
      basic_io_system.put(ascii.bel);
    end error_beep ;

    procedure error_wait( wait_length : a_wait_length ) is
    -- type a_wait_length is ( extra_short_wait , short_wait , medium_wait ,
    --                         long_wait , extra_long_wait , operator_wait );

    begin -- error_wait
      case wait_length is
        when extra_short_wait => delay 1.0 ;
        when short_wait       => delay 2.0 ;
        when medium_wait      => delay 4.0 ;
        when long_wait        => delay 8.0 ;
        when extra_long_wait  => delay 16.0 ;
        when operator_wait    => crt_windows.wait_for_character(' ') ;
      end case ;
    end error_wait ;

    procedure error( error_message : in string     ;
                     is_it_fatal   : type_of_error ;
                     wait_length   : a_wait_length ;
                     beep_length   : a_beep_length ) is
      -- We have an error.  Show the message, and then work as appropriate
    begin -- error
      error( string_to_pstring ( error_message ) , is_it_fatal ,
             wait_length , beep_length );
    end error ;

    procedure error( error_message : in string_library.pstring ;
                     is_it_fatal   : type_of_error ;
                     wait_length   : a_wait_length ;
                     beep_length   : a_beep_length ) is
      -- We have an error.  Show the message, and then work as appropriate
      temp_window : window_pointer ;
    begin -- error
      -- first, erase the prompt area to make room for error message
      if current_window = no_window then
        -- we need to do something, just to make a window available
        temp_window := create_window( 1 , 80 , 1 , 24 , true , 1 ) ;
        set_current_window(temp_window);
      end if ;
      save_prompt_temporarily ;
      clear_prompt(current_window);
      -- Now, put out the error message
      set_reverse(true);
      if wait_length = operator_wait then
        set_prompt ( current_window , 1 ,
                     error_message.data( 1 .. length(error_message) )
                     & "  Type <space> to continue " );
      else
        set_prompt ( current_window , 1 ,
                     error_message.data( 1 .. length(error_message) ) );
      end if ;
      set_reverse(false);
      error_beep(beep_length);
      error_wait(wait_length);
      if is_it_fatal = fatal_error then
        raise user_abort ;
      else
        restore_prompt_after_temporary_save ;
      end if;
    end error ;

  begin -- Wordp_Globals
    -- WPGLOBAL by SAIC/Clearwater Word Processor Globals      10 Jan 85
    -- FILENAME by SAIC/Clearwater File Name Package           10 Jan 85
    -- ERRORS   by SAIC/Clearwater Error Package               10 Jan 85
    null ;
  end Wordp_Globals ;

  --$$$- WPGLOBAL