Re: DOS interrupts with GNAT 3.04

[mfb@mbunix.mitre.org (Michael F Brenner)]

Dos interrupts are done a little differently on several different compilers.
On Janus and Meridian they are provided. On Alsys only the interrupts which
did not pass an address were provided, otherwise you need access to assembly
code. On gnat the following code seems to work, and is subject to the Ada
modification to the Gnu GPPL which permits commercial companies to use it
but not change its free stataus:


with unsign;
package memory is
  use unsign;

  -- Memory:
  --
  -- Purpose:
  --    Provide physical memory access
  --
  -- Architecture:
  --   ADO (Abstract Data Object)
  --   SDS (Semantically Dependent Specification)
  --
  -- History
  --   1986-09-17 added pragma inline (put) which cut the drawing time for
  --   1986-09-17   the SV PCX 2%, from 36 down to 35 seconds.
  --   1986-02-25 created

  type addresses is new unsigned_32;
  type byte_arrays is array (addresses range <>) of unsigned_8;

  procedure put (address: addresses; data: in unsigned_8);
  procedure put (address: addresses; data: in unsigned_16);
  procedure put (address: addresses; data: in unsigned_32);
  procedure put (address: addresses; data: in byte_arrays);
  procedure put (address: addresses; data: in string);

  procedure get (address: addresses; data: out unsigned_8);
  procedure get (address: addresses; data: out unsigned_16);
  procedure get (address: addresses; data: out unsigned_32);
  procedure get (address: addresses; length: addresses; data: out byte_arrays);

  function  get (address: addresses) return unsigned_8;
  function  get (address: addresses) return unsigned_16;
  function  get (address: addresses) return unsigned_32;
  function  get (address: addresses; length: addresses)
    return byte_arrays;
  function  get (address: addresses; length: addresses)
    return string;
  pragma inline (put);
end memory;
with unsign;
package dos16bit is

  -- These objects and methods are common to all 16-bit and and 32-bit DOSs.
  -- They comprise all DOS calls that do not pass addresses or 32-bit lengths.
  -- DOS16bit is complemented by dos_utils which differs for each compiler.
  --
  -- Warning: DOS and Unix are not thread-safe for memory allocation, I/O, etc.
  -- Warning: DOS blocks on all I/O, Unix blocks on most I/O.
  -- Warning: DOS is not even re-entrant, as some Unixen are


  procedure init; -- not to be used by Alsys to avoid random reboots


  -- DOS SYSTEM CALLS

  DOS_interrupt: constant := 16#21#;

  type interrupts is range 0..255;
  for interrupts'size use 8;

  subtype register_data is unsign.unsigned_16;
  type registers_16 is record

    -- Half of the 16-bit and 32-bit DOS calls (those that do not pass
    -- addresses  or 32-bit lengths) can use the simplified registers
    -- (registers_16) to do their work. These DOS calls are identical
    -- across 16- and 32-bit systems.

    ax, bx, cx, dx, flags: register_data := 0;
  end record;

  procedure interrupt_16 (interrupt: interrupts; 
                          register: in out registers_16);

        -- flags is used in many DOS calls as an error indicator:
        -- flags bit 0: carry
        -- flags bit 2: parity
        -- flags bit 6: zero
        -- flags bit 7: sign

  type dos_error_numbers is range -2**15..2**15-1;

  function  command_line           return string; -- not to be used by Alsys
  function  error                  return dos_error_numbers;
  function  error_interpretation   return string;

end dos16bit;

with dos_utils;
with memory;
package body dos16bit is
  -- compiler_this_package_is_dependent_on: constant string := "any DOS";



  -- GLOBAL VARIABLES

  cmd_line:            string (1..255);
  cmd_line_length:     integer := 0;
  initialized:         boolean:=False;
  x:                   constant string (1..2):=ascii.nul & '$';
  interrupt_62_failed: exception;
  why_are_you_calling_dos16bit_Instead_Of_os_command_Line: exception;


  function odd (number: register_data) return boolean is
    use unsign;
  begin
    return (number and 1) = 1;
  end odd;

  -- INTERRUPTS

  procedure get_original_command_line is

    -- WARNING: not to be called by Alsys
    -- WARNING: not to be called twice

    use memory;
    use unsign;
    DOS_get_psp:      constant := 16#6200#;
    sixteen:          constant := 16#10#;
    offset_to_length: constant := 16#80#;
    reg:    dos16bit.registers_16;
    psp:    memory.addresses;
    length: unsigned_8;
    byte:   unsigned_8;
    char:   character;
    j:      natural := 1;
  begin
    if initialized then
      raise interrupt_62_failed;
    end if;
    reg.ax      := DOS_get_PSP;
    dos16bit.interrupt_16 (16#21#, reg);
    if (reg.flags and 1)=1 then
      raise interrupt_62_failed;
    end if;
    psp         := addresses (reg.bx) * sixteen;
    length      := memory.get (psp + offset_to_length);
    cmd_line_length := natural(length);
    for i in 1 .. cmd_line_length loop
      byte := memory.get (psp+offset_to_length+addresses(i));
      char := character'val (byte);
      cmd_line (i) := char;
    end loop;
    loop
      exit when j > cmd_line_length;
      exit when cmd_line(j) /= ' ';
      j:=j+1;
    end loop;
    if j>1 then
      for i in j..cmd_line_length loop
        cmd_line (i+1-j) := cmd_line (i);
      end loop;
      cmd_line_length := cmd_line_length+1-j;
    end if;
  end get_original_command_line;

  function command_line return string is
  begin
    if not initialized then
      raise why_are_you_calling_dos16bit_Instead_Of_os_command_Line;
    end if;
    return cmd_line (1..cmd_line_length);
  end command_line;

  function error return dos_error_numbers is
    reg: registers_16;
    dos_get_error: constant := 16#5900#;
  begin
    reg.ax := dos_get_error;
    reg.bx := 0;
    interrupt_16 (interrupt => DOS_interrupt, register => reg);
    return dos_error_numbers (reg.ax);
  end error;

  function error_interpretation return string is

    bh, bl, ch: register_data;
    reg: registers_16;

    type classes is (non_recognized_error,
                     non_available_resource,  busy_network,
                     wrong_password,          dos_failure,
                     hardware_failure,        bad_dos_system_file,
                     programmer_inserted_bug, missing_object,
                     wrong_control_block,     locked_item,
                     bad_spot_on_media,       duplicate_file,
                     surprize);

    type locuses is (plenum,
                     computer_somewhere,      block_device_driver,
                     network,                 character_device_driver,
                     memory,                  new_dos_feature);

    type errors  is (no_error,
                     bad_function,      file_not_found,     path_not_found,
                     file_too_many,     denied_access,      bad_handle,
                     memory_overwrite,  lack_of_memory,     bad_address,
                     bad_environment,   bad_format,         datum_bad,
                     bad_drive,         delete_current_dir, dissimilar_device,
                     file_no_more,      write_protect,      unit_unknown,
                     drive_not_ready,   command_unknown,    data_CRC_error,
                     bad_length,        seek_error,         medium_unknown,
                     sector_not_found,  printer_outa_paper, write_fault,
                     read_fault,        general_failure,    sharing_violation,
                     lock_violation,    sudden_disk_change,
                     hard_to_describe_file_error);

    type actions is (take_no_action,
                     retry_now,               retry_after_a_delay,
                     fix_the_incorrect_name,  terminate_after_cleanup,
                     abort_without_cleanup,   ignore_and_investigate_later,
                     make_it_available_now,   call_a_hacker);

    dos_get_error: constant := 16#5900#;
  begin
    reg.ax := dos_get_error;
    reg.bx := 0;
    interrupt_16 (interrupt => DOS_interrupt, register => reg);

    if natural (reg.ax)=0 then
      return ""; --No error to interpret
    end if;
    if natural (reg.ax) > errors'pos(errors'last) then
      reg.ax := errors'pos(errors'last);
    end if;

    bh := register_data (natural (reg.bx) / 256);
    if natural (bh) > natural (classes'pos(classes'last)) then
      bh := classes'pos(classes'last);
    end if;
    bl := register_data (natural (reg.bx) mod 256);
    if natural (bl) > actions'pos(actions'last) then
      bl := actions'pos(actions'last);
    end if;

    ch := register_data (natural (reg.cx) / 256);
    if natural (ch)>locuses'pos(locuses'last) then
      ch := locuses'pos(locuses'last);
    end if;

    return ascii.cr & ascii.lf                &
           "Error "                           &
           register_data'image(reg.ax)        &
           " occurred because a "             &
           classes'image(classes'val(bh))     &
           " in the "                         &
           locuses'image (locuses'val (ch))   &
           ascii.cr & ascii.lf                &
           " had a "                          &
           errors'image (errors'val (reg.ax)) &
           ". Your best hope is to "          &
           actions'image (actions'val (bl))   &
           ascii.cr & ascii.lf;
  end error_interpretation;

  procedure interrupt_16 (interrupt: interrupts;
                          register: in out registers_16) is
  begin
    dos_utils.interrupt_16 (interrupt, register);
  end interrupt_16;



  -- SYSTEM CALLS

  procedure init is
  begin
    if not initialized then
      get_original_command_line;
    end if;
    initialized:=True;
  end init;



end dos16bit;
with dos16bit;
with system;
package DOS_utils is

  --  DOS_utils: Gnat Version
  --
  --  Purpose:
  --     Provide interface to 80x86 software interrupts
  --
  --  Architecture:
  --    ADO (Abstract Data Object)
  --    SIS (Semantically Dependent Specification)

  subtype interrupts is dos16bit.interrupts;

  procedure interrupt_16 (interrupt: interrupts;
                          register:  in out dos16bit.registers_16);

  type register_data is mod 2**32;
  type short_register_data is mod 2**16;
  type flag_data is mod 2**8;
  type registers is record
    di, si, bp, cflag, bx, dx, cx, ax: register_data := 0;
    flags: flag_data := 0;
  end record; -- This register order is for gnat3.05 (djgpp 2.0)

  procedure interrupt (interrupt: interrupts; register: in out registers);
end DOS_utils;
with System.Storage_Elements;
package body DOS_utils is

  -- compiler_this_package_is_dependent_on: constant string := "gnat3";

  procedure os_interrupt (interrupt: interrupts;
                          register:  system.address;
                          results:   system.address);
  pragma Import (C, os_interrupt, "int86");

  procedure interrupt_16 (interrupt: interrupts;
                          register:  in out dos16bit.registers_16) is
    reg: registers;
  begin
    reg.ax := register_data (register.ax);
    reg.bx := register_data (register.bx);
    reg.cx := register_data (register.cx);
    reg.dx := register_data (register.dx);
    os_interrupt (interrupt, reg'address, reg'address);
    register.ax    := dos16bit.register_data (reg.ax);
    register.bx    := dos16bit.register_data (reg.bx);
    register.cx    := dos16bit.register_data (reg.cx);
    register.dx    := dos16bit.register_data (reg.dx);
    register.flags := dos16bit.register_data (reg.flags);
  end interrupt_16;

  procedure interrupt (interrupt: interrupts; register: in out registers) is
  begin
    os_interrupt (interrupt, register'address, register'address);
  end interrupt;

end DOS_utils;