From mboxrd@z Thu Jan 1 00:00:00 1970 X-Spam-Checker-Version: SpamAssassin 3.4.4 (2020-01-24) on polar.synack.me X-Spam-Level: X-Spam-Status: No, score=-1.9 required=5.0 tests=BAYES_00 autolearn=ham autolearn_force=no version=3.4.4 X-Google-Language: ENGLISH,ASCII-7-bit X-Google-Thread: 103376,1dca1cee347390dd X-Google-Attributes: gid103376,public From: mfb@mbunix.mitre.org (Michael F Brenner) Subject: Re: DOS interrupts with GNAT 3.04 Date: 1996/12/24 Message-ID: <59p725$ff4@top.mitre.org> X-Deja-AN: 205815387 references: <1996Dec23.124409.5432@news> organization: The MITRE Corporation, Bedford Mass. newsgroups: comp.lang.ada Date: 1996-12-24T00:00:00+00:00 List-Id: 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;