2417 lines
68 KiB
Ada
2417 lines
68 KiB
Ada
--
|
||
-- T E X T I N P U T / O U T P U T
|
||
--
|
||
-- Body of the Package Text_IO
|
||
--
|
||
-- According to ANSI/MIL-STD 1815A (1983)
|
||
-- Implemented for Artek Ada
|
||
--
|
||
-- Copyright (C) 1986, 1987 Artek Corporation
|
||
-- Authors : O. Karlsson & V. Thorsteinsson
|
||
--
|
||
--
|
||
-- Version: 1.00 February 1986
|
||
-- Deviations from the standard:
|
||
--
|
||
-- ENUMERATION_IO not implemented
|
||
-- FIXED_IO not implemented
|
||
-- CHARACTER PUT and GET accept 8 bit characters
|
||
-- GET and PUT floating point to/from string not implemented
|
||
--
|
||
-- Version: 1.01 June 1986
|
||
-- PUT and GET floating point to/from string implemented
|
||
-- GET_LINE for console input corrected
|
||
--
|
||
-- Version: 1.02 November 1986
|
||
-- ENUMERATION_IO implemented
|
||
--
|
||
|
||
with DOS_INTERFACE, SYSTEM;
|
||
use DOS_INTERFACE, SYSTEM, ASCII;
|
||
|
||
package body TEXT_IO is
|
||
|
||
-- Data types and objects
|
||
|
||
R : REG_8086;
|
||
|
||
EOF : constant CHARACTER := CHARACTER (26);
|
||
|
||
IN_CONSOLE_HANDLE : constant INTEGER := 0; -- DOS Handle for STDIN
|
||
OUT_CONSOLE_HANDLE : constant INTEGER := 1; -- DOS Handle for STDOUT
|
||
|
||
DOS_INPUT, DOS_OUTPUT : FILE_TYPE;
|
||
|
||
CURR_INPUT, CURR_OUTPUT : FILE_TYPE;
|
||
|
||
DOS_IO_NAME : FILE_NAME_STRING :=
|
||
(1 => 'C', 2 => 'O', 3 => 'N', others => ' '); -- CON file
|
||
|
||
PREV_CHAR : CHARACTER;
|
||
UNGET_RAISED : BOOLEAN := FALSE;
|
||
|
||
--
|
||
-- Utility procedure to skip last character read from a file
|
||
-- Same as " lseek (file, -1) " relative from the file position
|
||
--
|
||
|
||
procedure UNGET (FILE : in FILE_TYPE) is
|
||
|
||
begin
|
||
if FILE . HANDLE = 0 then -- Can't do UNGET on console input
|
||
UNGET_RAISED := TRUE;
|
||
else
|
||
R . AX := 16#4201#; -- DOS function 42, lseek
|
||
R . BX := WORD (FILE . HANDLE);
|
||
R . CX := -1; -- Desired location from current position
|
||
R . DX := -1;
|
||
CALL_DOS (R);
|
||
if R . FLAGS mod 2 = 1 then -- Carry was set
|
||
raise USE_ERROR; -- There should never be error here
|
||
end if;
|
||
end if;
|
||
end UNGET;
|
||
|
||
--
|
||
-- procedures READ and WRITE are used internally
|
||
--
|
||
|
||
procedure READ (FILE : in FILE_TYPE; ITEM : out CHARACTER) is
|
||
|
||
begin
|
||
-- See comment at start of WRITE regarding checks on FILE
|
||
if FILE . HANDLE = 0 and UNGET_RAISED then -- Called UNGET on console
|
||
ITEM := PREV_CHAR;
|
||
UNGET_RAISED := FALSE;
|
||
elsif FILE . HANDLE = 0 then -- Input from console
|
||
R . AX := 16#0100#; -- DOS function 01, keyboard input
|
||
CALL_DOS (R);
|
||
PREV_CHAR := CHARACTER (R . AX mod 256);
|
||
ITEM := PREV_CHAR;
|
||
else
|
||
R . AX := 16#3F00#; -- DOS function 3F, read from a file or device
|
||
R . BX := WORD (FILE . HANDLE);
|
||
R . CX := 1; -- Read one byte
|
||
R . DX := WORD (ITEM'ADDRESS); -- Address of ITEM
|
||
CALL_DOS (R);
|
||
if R . AX = 0 then -- Read past EOF
|
||
raise END_ERROR;
|
||
end if;
|
||
if R . FLAGS mod 2 = 1 then -- Carry set
|
||
raise USE_ERROR; -- Access denied or invalid file handle
|
||
end if;
|
||
end if;
|
||
end READ;
|
||
|
||
procedure WRITE (FILE : in FILE_TYPE; ITEM : in CHARACTER) is
|
||
|
||
begin
|
||
-- The following checks are not needed since WRITE is never called
|
||
-- if one of the conditions is true
|
||
-- if FILE = null then
|
||
-- raise STATUS_ERROR;
|
||
-- elsif FILE . MODE /= OUT_FILE then
|
||
-- raise MODE_ERROR;
|
||
-- end if;
|
||
R . AX := 16#4000#; -- DOS function 40, write to a file or device
|
||
R . BX := WORD (FILE . HANDLE);
|
||
R . CX := 1; -- Write one byte
|
||
R . DX := WORD (ITEM'ADDRESS); -- Address of ITEM
|
||
CALL_DOS (R);
|
||
if R . AX = 0 then -- No output made, probably disk full error
|
||
raise USE_ERROR;
|
||
end if;
|
||
if R . FLAGS mod 2 = 1 then -- Carry set
|
||
raise USE_ERROR; -- Access denied or invalid file handle
|
||
end if;
|
||
end WRITE;
|
||
|
||
procedure WRITE_STRING (FILE : in FILE_TYPE; ITEM : in STRING) is
|
||
|
||
begin
|
||
R . AX := 16#4000#; -- DOS function 40, write to a file or device
|
||
R . BX := WORD (FILE . HANDLE);
|
||
R . CX := WORD (ITEM'LENGTH); -- Write LENGTH bytes
|
||
R . DX := WORD (ITEM'ADDRESS); -- Address of ITEM
|
||
CALL_DOS (R);
|
||
if R . AX /= WORD (ITEM'LENGTH) then -- Probably disk full error
|
||
raise USE_ERROR;
|
||
end if;
|
||
if R . FLAGS mod 2 = 1 then -- Carry set
|
||
raise USE_ERROR; -- Access denied or invalid file handle
|
||
end if;
|
||
end WRITE_STRING;
|
||
|
||
--
|
||
-- File management
|
||
--
|
||
|
||
procedure CREATE (
|
||
FILE : in out FILE_TYPE;
|
||
MODE : in FILE_MODE := OUT_FILE;
|
||
NAME : in STRING := "";
|
||
FORM : in STRING := "") is
|
||
|
||
ASCIIZ_NAME : FILE_NAME_STRING;
|
||
BLANK_NAME : FILE_NAME_STRING := (others => ' ');
|
||
BLANK_FORM : FORM_NAME_STRING := (others => ' ');
|
||
|
||
-- See chapter 14.3.1
|
||
|
||
begin -- Concatenate a null character
|
||
if FILE /= null then -- Already open
|
||
raise STATUS_ERROR;
|
||
end if;
|
||
ASCIIZ_NAME (1..NAME'LENGTH) := NAME;
|
||
ASCIIZ_NAME (NAME'LENGTH + 1) := NUL;
|
||
R . AX := 16#3C00#; -- Function 3C, Create a file
|
||
R . DX := WORD (ASCIIZ_NAME'ADDRESS); -- Address of the filename
|
||
R . CX := 16#0000#; -- No attributes
|
||
CALL_DOS (R);
|
||
if R . FLAGS mod 2 = 1 then -- Carry was set
|
||
if R . AX > 3 then -- 4 = Too many open files, 5 = access denied
|
||
raise USE_ERROR;
|
||
else
|
||
raise NAME_ERROR; -- 3 = Path not found
|
||
end if;
|
||
end if;
|
||
FILE := new FILE_DESCR'
|
||
(NAMELEN => NAME'LENGTH, NAME => BLANK_NAME,
|
||
FORMLEN => FORM'LENGTH, FORM => BLANK_FORM,
|
||
MODE => MODE,
|
||
COL => 1, LINE => 1, PAGE => 1,
|
||
LINE_LENGTH => UNBOUNDED, PAGE_LENGTH => UNBOUNDED,
|
||
HANDLE => INTEGER (R . AX));
|
||
FILE . NAME (1..NAME'LENGTH) := NAME;
|
||
FILE . FORM (1..FORM'LENGTH) := FORM;
|
||
end CREATE;
|
||
|
||
procedure OPEN (
|
||
FILE : in out FILE_TYPE;
|
||
MODE : in FILE_MODE;
|
||
NAME : in STRING;
|
||
FORM : in STRING := "") is
|
||
|
||
ASCIIZ_NAME : FILE_NAME_STRING;
|
||
BLANK_NAME : FILE_NAME_STRING := (others => ' ');
|
||
BLANK_FORM : FORM_NAME_STRING := (others => ' ');
|
||
|
||
-- See chapter 14.3.1
|
||
|
||
begin
|
||
if FILE /= null then -- File already open
|
||
raise STATUS_ERROR;
|
||
end if;
|
||
ASCIIZ_NAME (1..NAME'LENGTH) := NAME;
|
||
ASCIIZ_NAME (NAME'LENGTH + 1) := NUL;
|
||
case MODE is
|
||
when IN_FILE => R . AX := 16#3D00#; -- AH = 3D, Open a file
|
||
when OUT_FILE => R . AX := 16#3D01#; -- AL = 00, Open for input
|
||
end case; -- AL = 01, Open for output
|
||
R . DX := WORD (ASCIIZ_NAME'ADDRESS);
|
||
CALL_DOS (R);
|
||
if R . FLAGS mod 2 = 1 then -- Carry was set
|
||
if R . AX > 3 then
|
||
raise USE_ERROR; -- Access denied and to many files open
|
||
else
|
||
raise NAME_ERROR; -- File not found
|
||
end if;
|
||
end if;
|
||
FILE := new FILE_DESCR'
|
||
(NAMELEN => NAME'LENGTH, NAME => BLANK_NAME,
|
||
FORMLEN => FORM'LENGTH, FORM => BLANK_FORM,
|
||
COL => 1, LINE => 1, PAGE => 1,
|
||
LINE_LENGTH => UNBOUNDED, PAGE_LENGTH => UNBOUNDED,
|
||
MODE => MODE,
|
||
HANDLE => INTEGER (R . AX));
|
||
FILE . NAME (1..NAME'LENGTH) := NAME;
|
||
FILE . FORM (1..FORM'LENGTH) := FORM;
|
||
end OPEN;
|
||
|
||
procedure CLOSE (FILE : in out FILE_TYPE) is
|
||
|
||
-- See chapter 14.3.1
|
||
|
||
begin
|
||
if FILE = null then
|
||
raise STATUS_ERROR;
|
||
end if;
|
||
if FILE . MODE = OUT_FILE then
|
||
NEW_PAGE (FILE);
|
||
WRITE (FILE, EOF);
|
||
end if;
|
||
R . AX := 16#3E00#; -- DOS function 3E, Close a file handle
|
||
R . BX := WORD (FILE . HANDLE);
|
||
CALL_DOS (R);
|
||
if R . FLAGS mod 2 = 1 then -- Carry was set
|
||
raise USE_ERROR; -- Invalid handle. This error should never
|
||
end if; -- occur. Something is wrong in the file system.
|
||
FILE := null;
|
||
end CLOSE;
|
||
|
||
procedure DELETE (FILE : in out FILE_TYPE) is
|
||
|
||
ASCIIZ_NAME : FILE_NAME_STRING;
|
||
|
||
-- See chapter 14.3.1
|
||
|
||
begin
|
||
CLOSE (FILE);
|
||
ASCIIZ_NAME (1..FILE . NAMELEN) := FILE . NAME (1..FILE . NAMELEN);
|
||
ASCIIZ_NAME (FILE . NAMELEN + 1) := NUL;
|
||
R . AX := 16#4100#; -- DOS function 41, delete a file
|
||
R . DX := WORD (ASCIIZ_NAME'ADDRESS);
|
||
CALL_DOS (R);
|
||
if R . FLAGS mod 2 = 1 then -- Carry was set
|
||
raise USE_ERROR; -- Access denied
|
||
end if;
|
||
end DELETE;
|
||
|
||
procedure RESET (FILE : in out FILE_TYPE; MODE : in FILE_MODE) is
|
||
|
||
TL, TP : COUNT;
|
||
|
||
-- See chapter 14.3.1
|
||
|
||
begin
|
||
if FILE = null then
|
||
raise STATUS_ERROR;
|
||
elsif (FILE = CURR_INPUT and MODE /= IN_FILE) or
|
||
(FILE = CURR_OUTPUT and MODE /= OUT_FILE) then
|
||
raise MODE_ERROR;
|
||
end if;
|
||
TL := FILE . LINE_LENGTH;
|
||
TP := FILE . PAGE_LENGTH;
|
||
CLOSE (FILE); -- Must close and reopen since MODE changes
|
||
OPEN (FILE, MODE, FILE . NAME, FILE . FORM);
|
||
if FILE . MODE = IN_FILE then -- Restore line and page lengths
|
||
FILE . LINE_LENGTH := TL;
|
||
FILE . PAGE_LENGTH := TP;
|
||
end if;
|
||
end RESET;
|
||
|
||
procedure RESET (FILE : in out FILE_TYPE) is
|
||
|
||
-- See chapter 14.3.1
|
||
|
||
begin
|
||
if FILE = null then
|
||
raise STATUS_ERROR;
|
||
end if;
|
||
if FILE . MODE = OUT_FILE then
|
||
NEW_PAGE (FILE);
|
||
WRITE (FILE, EOF);
|
||
end if;
|
||
-- Do an LSEEK (FILE, 0);
|
||
R . AX := 16#4200#; -- DOS function 42, lseek
|
||
R . BX := WORD (FILE . HANDLE);
|
||
R . CX := 0; -- Desired location from BOF
|
||
R . DX := 0;
|
||
CALL_DOS (R);
|
||
if R . FLAGS mod 2 = 1 then -- Carry was set
|
||
raise USE_ERROR;
|
||
end if;
|
||
FILE . COL := 1;
|
||
FILE . LINE := 1;
|
||
FILE . PAGE := 1;
|
||
end RESET;
|
||
|
||
function MODE (FILE : in FILE_TYPE) return FILE_MODE is
|
||
|
||
-- See chapter 14.3.1
|
||
|
||
begin
|
||
if FILE = null then
|
||
raise STATUS_ERROR;
|
||
end if;
|
||
return FILE . MODE;
|
||
end MODE;
|
||
|
||
function NAME (FILE : in FILE_TYPE) return STRING is
|
||
|
||
-- See chapter 14.3.1
|
||
|
||
begin
|
||
if FILE = null then
|
||
raise STATUS_ERROR;
|
||
end if;
|
||
return FILE . NAME;
|
||
end NAME;
|
||
|
||
function FORM (FILE : in FILE_TYPE) return STRING is
|
||
|
||
-- See chapter 14.3.1
|
||
|
||
begin
|
||
if FILE = null then
|
||
raise STATUS_ERROR;
|
||
end if;
|
||
return FILE . FORM;
|
||
end FORM;
|
||
|
||
function IS_OPEN (FILE : in FILE_TYPE) return BOOLEAN is
|
||
|
||
-- See chapter 14.3.1
|
||
|
||
begin
|
||
return FILE /= null;
|
||
end IS_OPEN;
|
||
|
||
--
|
||
-- Control of default input and output files
|
||
--
|
||
|
||
procedure SET_INPUT (FILE : in FILE_TYPE) is
|
||
|
||
-- See chapter 14.3.2
|
||
|
||
begin
|
||
if FILE = null then
|
||
raise STATUS_ERROR;
|
||
elsif FILE . MODE /= IN_FILE then
|
||
raise MODE_ERROR;
|
||
end if;
|
||
CURR_INPUT := FILE;
|
||
end SET_INPUT;
|
||
|
||
procedure SET_OUTPUT (FILE : in FILE_TYPE) is
|
||
|
||
-- See chapter 14.3.2
|
||
|
||
begin
|
||
if FILE = null then
|
||
raise STATUS_ERROR;
|
||
elsif FILE . MODE /= OUT_FILE then
|
||
raise MODE_ERROR;
|
||
end if;
|
||
CURR_OUTPUT := FILE;
|
||
end SET_OUTPUT;
|
||
|
||
function STANDARD_INPUT return FILE_TYPE is
|
||
|
||
-- See chapter 14.3.2
|
||
|
||
begin
|
||
return DOS_INPUT;
|
||
end STANDARD_INPUT;
|
||
|
||
function STANDARD_OUTPUT return FILE_TYPE is
|
||
|
||
-- See chapter 14.3.2
|
||
|
||
begin
|
||
return DOS_OUTPUT;
|
||
end STANDARD_OUTPUT;
|
||
|
||
function CURRENT_INPUT return FILE_TYPE is
|
||
|
||
-- See chapter 14.3.2
|
||
|
||
begin
|
||
return CURR_INPUT;
|
||
end CURRENT_INPUT;
|
||
|
||
function CURRENT_OUTPUT return FILE_TYPE is
|
||
|
||
-- See chapter 14.3.2
|
||
|
||
begin
|
||
return CURR_OUTPUT;
|
||
end CURRENT_OUTPUT;
|
||
|
||
--
|
||
-- Specification of line and page lengths
|
||
--
|
||
|
||
procedure SET_LINE_LENGTH (FILE : in FILE_TYPE; TO : in COUNT) is
|
||
|
||
-- See chapter 14.3.3
|
||
|
||
begin
|
||
if FILE = null then
|
||
raise STATUS_ERROR;
|
||
elsif FILE . MODE /= OUT_FILE then
|
||
raise MODE_ERROR;
|
||
end if;
|
||
FILE . LINE_LENGTH := TO;
|
||
end SET_LINE_LENGTH;
|
||
|
||
procedure SET_LINE_LENGTH (TO : in COUNT) is
|
||
|
||
-- See chapter 14.3.3
|
||
|
||
begin
|
||
SET_LINE_LENGTH (CURR_OUTPUT, TO);
|
||
end SET_LINE_LENGTH;
|
||
|
||
procedure SET_PAGE_LENGTH (FILE : in FILE_TYPE; TO : in COUNT) is
|
||
|
||
-- See chapter 14.3.3
|
||
|
||
begin
|
||
if FILE = null then
|
||
raise STATUS_ERROR;
|
||
elsif FILE . MODE /= OUT_FILE then
|
||
raise MODE_ERROR;
|
||
end if;
|
||
FILE . PAGE_LENGTH := TO;
|
||
end SET_PAGE_LENGTH;
|
||
|
||
procedure SET_PAGE_LENGTH (TO : in COUNT) is
|
||
|
||
-- See chapter 14.3.3
|
||
|
||
begin
|
||
SET_PAGE_LENGTH (CURR_OUTPUT, TO);
|
||
end SET_PAGE_LENGTH;
|
||
|
||
function LINE_LENGTH (FILE : in FILE_TYPE) return COUNT is
|
||
|
||
-- See chapter 14.3.3
|
||
|
||
begin
|
||
if FILE = null then
|
||
raise STATUS_ERROR;
|
||
elsif FILE . MODE /= OUT_FILE then
|
||
raise MODE_ERROR;
|
||
end if;
|
||
return FILE . LINE_LENGTH;
|
||
end LINE_LENGTH;
|
||
|
||
function LINE_LENGTH return COUNT is
|
||
|
||
-- See chapter 14.3.3
|
||
|
||
begin
|
||
return LINE_LENGTH (CURR_OUTPUT);
|
||
end LINE_LENGTH;
|
||
|
||
function PAGE_LENGTH (FILE : in FILE_TYPE) return COUNT is
|
||
|
||
-- See chapter 14.3.3
|
||
|
||
begin
|
||
if FILE = null then
|
||
raise STATUS_ERROR;
|
||
elsif FILE . MODE /= OUT_FILE then
|
||
raise MODE_ERROR;
|
||
end if;
|
||
return FILE . PAGE_LENGTH;
|
||
end PAGE_LENGTH;
|
||
|
||
function PAGE_LENGTH return COUNT is
|
||
|
||
-- See chapter 14.3.3
|
||
|
||
begin
|
||
return PAGE_LENGTH (CURR_OUTPUT);
|
||
end PAGE_LENGTH;
|
||
|
||
--
|
||
-- Column, Line, and Page Contril
|
||
--
|
||
|
||
procedure NEW_LINE (FILE : in FILE_TYPE;
|
||
SPACING : in POSITIVE_COUNT := 1) is
|
||
|
||
-- See chapter 14.3.4
|
||
|
||
begin
|
||
if FILE = null then
|
||
raise STATUS_ERROR;
|
||
elsif FILE . MODE /= OUT_FILE then
|
||
raise MODE_ERROR;
|
||
else
|
||
for I in 1 .. SPACING loop
|
||
WRITE (FILE, CR);
|
||
WRITE (FILE, LF);
|
||
FILE . LINE := FILE . LINE + 1;
|
||
if (FILE . PAGE_LENGTH /= UNBOUNDED) and
|
||
(FILE . LINE >= FILE . PAGE_LENGTH) then
|
||
WRITE (FILE, FF);
|
||
FILE . PAGE := FILE . PAGE + 1;
|
||
end if;
|
||
end loop;
|
||
FILE . COL := 1;
|
||
end if;
|
||
end NEW_LINE;
|
||
|
||
procedure NEW_LINE (SPACING : in POSITIVE_COUNT := 1) is
|
||
|
||
-- See chapter 14.3.4
|
||
|
||
begin
|
||
NEW_LINE (CURR_OUTPUT, SPACING);
|
||
end NEW_LINE;
|
||
|
||
procedure SKIP_LINE (FILE : in FILE_TYPE;
|
||
SPACING : in POSITIVE_COUNT := 1) is
|
||
|
||
PREVCH, CH : CHARACTER;
|
||
|
||
-- See chapter 14.3.4
|
||
|
||
begin
|
||
if FILE = null then
|
||
raise STATUS_ERROR;
|
||
elsif FILE . MODE /= IN_FILE then
|
||
raise MODE_ERROR;
|
||
end if;
|
||
for I in 1..SPACING loop
|
||
PREVCH := ' ';
|
||
loop
|
||
READ (FILE, CH);
|
||
case CH is
|
||
when CR =>
|
||
FILE . COL := 1;
|
||
if FILE . HANDLE = 0 then -- Input from console
|
||
FILE . LINE := FILE . LINE + 1;
|
||
if (FILE . PAGE_LENGTH /= UNBOUNDED) and
|
||
(FILE . LINE >= FILE . PAGE_LENGTH) then
|
||
FILE . PAGE := FILE . PAGE + 1;
|
||
FILE . LINE := 1;
|
||
end if;
|
||
exit;
|
||
end if;
|
||
when LF =>
|
||
FILE . LINE := FILE . LINE + 1;
|
||
if (FILE . PAGE_LENGTH /= UNBOUNDED) and
|
||
(FILE . LINE >= FILE . PAGE_LENGTH) then
|
||
FILE . PAGE := FILE . PAGE + 1;
|
||
FILE . LINE := 1;
|
||
end if;
|
||
when FF =>
|
||
FILE . PAGE := FILE . PAGE + 1;
|
||
FILE . COL := 1;
|
||
FILE . LINE := 1;
|
||
when EOF =>
|
||
if (PREVCH = CR) or (PREVCH = LF) or (PREVCH = FF) then
|
||
UNGET (FILE);
|
||
exit;
|
||
else
|
||
raise END_ERROR;
|
||
end if;
|
||
when others =>
|
||
if (PREVCH = CR) or (PREVCH = LF) or (PREVCH = FF) then
|
||
UNGET (FILE);
|
||
exit;
|
||
end if;
|
||
end case;
|
||
PREVCH := CH;
|
||
end loop;
|
||
end loop;
|
||
end SKIP_LINE;
|
||
|
||
procedure SKIP_LINE (SPACING : in POSITIVE_COUNT := 1) is
|
||
|
||
-- See chapter 14.3.4
|
||
|
||
begin
|
||
SKIP_LINE (CURR_INPUT, SPACING);
|
||
end SKIP_LINE;
|
||
|
||
function END_OF_LINE (FILE : in FILE_TYPE) return BOOLEAN is
|
||
|
||
CH : CHARACTER;
|
||
|
||
-- See chapter 14.3.4
|
||
|
||
begin
|
||
if FILE = null then
|
||
raise STATUS_ERROR;
|
||
elsif FILE . MODE /= IN_FILE then
|
||
raise MODE_ERROR;
|
||
end if;
|
||
READ (FILE, CH);
|
||
UNGET (FILE);
|
||
return (CH = CR) or (CH = LF) or (CH = EOF);
|
||
exception
|
||
when END_ERROR => -- If already EOF return TRUE
|
||
UNGET (FILE);
|
||
return TRUE;
|
||
end END_OF_LINE;
|
||
|
||
function END_OF_LINE return BOOLEAN is
|
||
|
||
-- See chapter 14.3.4
|
||
|
||
begin
|
||
return END_OF_LINE (CURR_INPUT);
|
||
end END_OF_LINE;
|
||
|
||
procedure NEW_PAGE (FILE : in FILE_TYPE) is
|
||
|
||
-- See chapter 14.3.4
|
||
|
||
begin
|
||
if FILE = null then
|
||
raise STATUS_ERROR;
|
||
elsif FILE . MODE /= OUT_FILE then
|
||
raise MODE_ERROR;
|
||
end if;
|
||
if (FILE . COL > 1) or (FILE . COL = 1 and FILE . LINE = 1) then
|
||
NEW_LINE (FILE); -- Sets FILE . COL := 1
|
||
end if;
|
||
WRITE (FILE, FF); -- Form Feed
|
||
FILE . LINE := 1;
|
||
FILE . PAGE := FILE . PAGE + 1;
|
||
end NEW_PAGE;
|
||
|
||
procedure NEW_PAGE is
|
||
|
||
-- See chapter 14.3.4
|
||
|
||
begin
|
||
NEW_PAGE (CURR_OUTPUT);
|
||
end NEW_PAGE;
|
||
|
||
procedure SKIP_PAGE (FILE : in FILE_TYPE) is
|
||
|
||
CH : CHARACTER;
|
||
|
||
-- See chapter 14.3.4
|
||
|
||
begin
|
||
if FILE = null then
|
||
raise STATUS_ERROR;
|
||
elsif FILE . MODE /= IN_FILE then
|
||
raise MODE_ERROR;
|
||
end if;
|
||
loop
|
||
READ (FILE, CH);
|
||
if CH = EOF then
|
||
raise END_ERROR;
|
||
end if;
|
||
exit when CH = FF;
|
||
end loop;
|
||
FILE . LINE := 1;
|
||
FILE . COL := 1;
|
||
FILE . PAGE := FILE . PAGE + 1;
|
||
end SKIP_PAGE;
|
||
|
||
procedure SKIP_PAGE is
|
||
|
||
-- See chapter 14.3.4
|
||
|
||
begin
|
||
SKIP_PAGE (CURR_INPUT);
|
||
end SKIP_PAGE;
|
||
|
||
function END_OF_PAGE (FILE : in FILE_TYPE) return BOOLEAN is
|
||
|
||
CH : CHARACTER;
|
||
|
||
-- See chapter 14.3.4
|
||
|
||
begin
|
||
if FILE = null then
|
||
raise STATUS_ERROR;
|
||
elsif FILE . MODE /= IN_FILE then
|
||
raise MODE_ERROR;
|
||
end if;
|
||
READ (FILE, CH); -- returns TRUE if (CR LF FF), (FF) or (EOF)
|
||
if CH = CR or CH = LF then
|
||
READ (FILE, CH);
|
||
if CH = CR or CH = LF then
|
||
READ (FILE, CH);
|
||
UNGET (FILE);
|
||
end if;
|
||
UNGET (FILE);
|
||
end if;
|
||
UNGET (FILE);
|
||
return CH = FF or CH = EOF;
|
||
exception
|
||
when END_ERROR =>
|
||
UNGET (FILE);
|
||
return TRUE;
|
||
end END_OF_PAGE;
|
||
|
||
function END_OF_PAGE return BOOLEAN is
|
||
|
||
-- See chapter 14.3.4
|
||
|
||
begin
|
||
return END_OF_PAGE (CURR_INPUT);
|
||
end END_OF_PAGE;
|
||
|
||
function END_OF_FILE (FILE : in FILE_TYPE) return BOOLEAN is
|
||
|
||
CH : CHARACTER;
|
||
|
||
-- See chapter 14.3.4
|
||
|
||
begin
|
||
if FILE = null then
|
||
raise STATUS_ERROR;
|
||
elsif FILE . MODE /= IN_FILE then
|
||
raise MODE_ERROR;
|
||
end if;
|
||
READ (FILE, CH); -- returns TRUE if (CR LF FF EOF), (FF EOF)
|
||
-- or (CR LF EOF) or (EOF)
|
||
if CH = CR or CH = LF or CH = FF then
|
||
READ (FILE, CH);
|
||
if CH = CR or CH = LF or CH = FF then
|
||
READ (FILE, CH);
|
||
if CH = CR or CH = LF or CH = FF then
|
||
READ (FILE, CH);
|
||
UNGET (FILE);
|
||
end if;
|
||
UNGET (FILE);
|
||
end if;
|
||
UNGET (FILE);
|
||
end if;
|
||
UNGET (FILE);
|
||
return CH = EOF;
|
||
exception
|
||
when END_ERROR =>
|
||
UNGET (FILE);
|
||
return TRUE;
|
||
end END_OF_FILE;
|
||
|
||
function END_OF_FILE return BOOLEAN is
|
||
|
||
-- See chapter 14.3.4
|
||
|
||
begin
|
||
return END_OF_FILE (CURR_INPUT);
|
||
end;
|
||
|
||
procedure SET_COL (FILE : in FILE_TYPE; TO : in POSITIVE_COUNT) is
|
||
|
||
CH : CHARACTER;
|
||
|
||
-- See chapter 14.3.4
|
||
|
||
begin
|
||
if FILE = null then
|
||
raise STATUS_ERROR;
|
||
elsif FILE . MODE = OUT_FILE and FILE . LINE_LENGTH /= UNBOUNDED
|
||
and TO > FILE . LINE_LENGTH then
|
||
raise LAYOUT_ERROR;
|
||
end if;
|
||
if FILE . MODE = IN_FILE then
|
||
if FILE . COL /= TO then
|
||
loop
|
||
READ (FILE, CH); -- Read until (FILE . COL = TO) or EOF
|
||
case CH is
|
||
when CR =>
|
||
FILE . COL := 1;
|
||
when LF =>
|
||
FILE . LINE := FILE . LINE + 1;
|
||
if (FILE . PAGE_LENGTH /= UNBOUNDED) and
|
||
(FILE . LINE >= FILE . PAGE_LENGTH) then
|
||
FILE . PAGE := FILE . PAGE + 1;
|
||
FILE . LINE := 1;
|
||
end if;
|
||
when FF =>
|
||
FILE . PAGE := FILE . PAGE + 1;
|
||
FILE . COL := 1;
|
||
FILE . LINE := 1;
|
||
when EOF =>
|
||
raise END_ERROR;
|
||
when others =>
|
||
FILE . COL := FILE . COL + 1;
|
||
end case;
|
||
exit when FILE . COL = TO;
|
||
end loop;
|
||
end if;
|
||
else -- For file in OUT_MODE
|
||
if FILE . COL > TO then
|
||
NEW_LINE (FILE);
|
||
end if;
|
||
if FILE . COL < TO then
|
||
for I in FILE . COL .. TO - 1 loop
|
||
WRITE (FILE, ' ');
|
||
FILE . COL := FILE . COL + 1;
|
||
end loop;
|
||
end if;
|
||
end if;
|
||
end SET_COL;
|
||
|
||
procedure SET_COL (TO : in POSITIVE_COUNT) is
|
||
|
||
-- See chapter 14.3.4
|
||
|
||
begin
|
||
SET_COL (CURR_OUTPUT, TO); -- Default output file, see page 14-15
|
||
end SET_COL;
|
||
|
||
procedure SET_LINE (FILE : in FILE_TYPE; TO : in POSITIVE_COUNT) is
|
||
|
||
-- See chapter 14.3.4
|
||
|
||
begin
|
||
if FILE = null then
|
||
raise STATUS_ERROR;
|
||
elsif FILE . MODE = OUT_FILE and FILE . PAGE_LENGTH /= UNBOUNDED
|
||
and TO > FILE . PAGE_LENGTH then
|
||
raise LAYOUT_ERROR;
|
||
end if;
|
||
if FILE . MODE = IN_FILE then
|
||
if FILE . LINE /= TO then
|
||
loop
|
||
SKIP_LINE (FILE); -- This raises END_ERROR if EOF
|
||
exit when FILE . LINE = TO;
|
||
end loop;
|
||
end if;
|
||
else -- FILE . MODE = OUT_FILE
|
||
if FILE . LINE < TO then
|
||
loop
|
||
NEW_LINE (FILE); -- Spacing 1, see page 14-16
|
||
exit when FILE . LINE = TO;
|
||
end loop;
|
||
elsif FILE . LINE > TO then
|
||
NEW_PAGE (FILE);
|
||
NEW_LINE (FILE, TO - 1);
|
||
end if;
|
||
end if;
|
||
end SET_LINE;
|
||
|
||
procedure SET_LINE (TO : in POSITIVE_COUNT) is
|
||
|
||
-- See chapter 14.3.4
|
||
|
||
begin
|
||
SET_LINE (CURR_OUTPUT, TO);
|
||
end SET_LINE;
|
||
|
||
function COL (FILE : in FILE_TYPE) return POSITIVE_COUNT is
|
||
|
||
-- See chapter 14.3.4
|
||
|
||
begin
|
||
if FILE = null then
|
||
raise STATUS_ERROR;
|
||
end if;
|
||
return FILE . COL;
|
||
end COL;
|
||
|
||
function COL return POSITIVE_COUNT is
|
||
|
||
-- See chapter 14.3.4
|
||
|
||
begin
|
||
return COL (CURR_OUTPUT); -- Def. current output file, see page 14-15
|
||
end COL;
|
||
|
||
function LINE (FILE : in FILE_TYPE) return POSITIVE_COUNT is
|
||
|
||
-- See chapter 14.3.4
|
||
|
||
begin
|
||
if FILE = null then
|
||
raise STATUS_ERROR;
|
||
end if;
|
||
return FILE . LINE;
|
||
end LINE;
|
||
|
||
function LINE return POSITIVE_COUNT is
|
||
|
||
-- See chapter 14.3.4
|
||
|
||
|
||
begin
|
||
return LINE (CURR_OUTPUT); -- Def. current output file, see page 14-15
|
||
end LINE;
|
||
|
||
function PAGE (FILE : in FILE_TYPE) return POSITIVE_COUNT is
|
||
|
||
-- See chapter 14.3.4
|
||
|
||
begin
|
||
if FILE = null then
|
||
raise STATUS_ERROR;
|
||
end if;
|
||
return FILE . PAGE;
|
||
end PAGE;
|
||
|
||
function PAGE return POSITIVE_COUNT is
|
||
|
||
-- See chapter 14.3.4
|
||
|
||
begin
|
||
return PAGE (CURR_OUTPUT); -- Def. curr. output file, see page 14-15
|
||
end PAGE;
|
||
|
||
--
|
||
-- Character input/output
|
||
--
|
||
|
||
procedure GET (FILE : in FILE_TYPE; ITEM : out CHARACTER) is
|
||
|
||
INCHAR : CHARACTER;
|
||
|
||
-- See chapter 14.3.6
|
||
|
||
begin
|
||
if FILE = null then
|
||
raise STATUS_ERROR;
|
||
elsif FILE . MODE /= IN_FILE then
|
||
raise MODE_ERROR;
|
||
end if;
|
||
loop
|
||
READ (FILE, INCHAR); -- There is no DATA_ERROR eight bit characters
|
||
case INCHAR is
|
||
when CR =>
|
||
FILE . COL := 1;
|
||
when LF =>
|
||
FILE . LINE := FILE . LINE + 1;
|
||
if (FILE . PAGE_LENGTH /= UNBOUNDED) and
|
||
(FILE . LINE >= FILE . PAGE_LENGTH) then
|
||
FILE . PAGE := FILE . PAGE + 1;
|
||
FILE . LINE := 1;
|
||
end if;
|
||
when FF =>
|
||
FILE . PAGE := FILE . PAGE + 1;
|
||
FILE . COL := 1;
|
||
FILE . LINE := 1;
|
||
when EOF =>
|
||
raise END_ERROR;
|
||
when others =>
|
||
FILE . COL := FILE . COL + 1;
|
||
exit; -- This is a legal character
|
||
end case;
|
||
end loop;
|
||
ITEM := INCHAR;
|
||
end GET;
|
||
|
||
procedure GET (ITEM : out CHARACTER) is
|
||
|
||
-- See chapter 14.3.6
|
||
|
||
begin
|
||
GET (CURR_INPUT, ITEM);
|
||
end GET;
|
||
|
||
procedure PUT (FILE : in FILE_TYPE; ITEM : in CHARACTER) is
|
||
|
||
-- See chapter 14.3.6
|
||
|
||
begin
|
||
if FILE = null then
|
||
raise STATUS_ERROR;
|
||
elsif FILE . MODE = IN_FILE then
|
||
raise MODE_ERROR;
|
||
end if;
|
||
if FILE . LINE_LENGTH /= UNBOUNDED and
|
||
FILE . COL >= FILE . LINE_LENGTH then
|
||
if FILE . PAGE_LENGTH /= UNBOUNDED and
|
||
FILE . PAGE_LENGTH >= FILE . PAGE then
|
||
NEW_PAGE (FILE);
|
||
else
|
||
NEW_LINE (FILE);
|
||
end if;
|
||
end if;
|
||
WRITE (FILE, ITEM);
|
||
FILE . COL := FILE . COL + 1;
|
||
end PUT;
|
||
|
||
procedure PUT (ITEM : in CHARACTER) is
|
||
|
||
-- See chapter 14.3.6
|
||
|
||
begin
|
||
PUT (CURR_OUTPUT, ITEM);
|
||
end PUT;
|
||
|
||
--
|
||
-- String input/output
|
||
--
|
||
|
||
procedure GET (FILE : in FILE_TYPE; ITEM : out STRING) is
|
||
|
||
-- See chapter 14.3.6
|
||
|
||
begin
|
||
if FILE = null then
|
||
raise STATUS_ERROR;
|
||
elsif FILE . MODE /= IN_FILE then
|
||
raise MODE_ERROR;
|
||
end if;
|
||
for I in ITEM'RANGE loop
|
||
GET (FILE, ITEM (I));
|
||
end loop;
|
||
end GET;
|
||
|
||
procedure GET (ITEM : out STRING) is
|
||
|
||
-- See chapter 14.3.6
|
||
|
||
begin
|
||
GET (CURR_INPUT, ITEM);
|
||
end GET;
|
||
|
||
procedure PUT (FILE : in FILE_TYPE; ITEM : in STRING) is
|
||
|
||
-- See chapter 14.3.6
|
||
|
||
begin
|
||
if FILE = null then
|
||
raise STATUS_ERROR;
|
||
elsif FILE . MODE /= OUT_FILE then
|
||
raise MODE_ERROR;
|
||
end if;
|
||
if FILE . LINE_LENGTH /= UNBOUNDED and
|
||
FILE . COL >= FILE . LINE_LENGTH then
|
||
if FILE . PAGE_LENGTH /= UNBOUNDED and
|
||
FILE . PAGE_LENGTH >= FILE . PAGE then
|
||
NEW_PAGE (FILE);
|
||
else
|
||
NEW_LINE (FILE);
|
||
end if;
|
||
end if;
|
||
WRITE_STRING (FILE, ITEM);
|
||
FILE . COL := FILE . COL + COUNT (ITEM'LENGTH);
|
||
end PUT;
|
||
|
||
procedure PUT (ITEM : in STRING) is
|
||
|
||
-- See chapter 14.3.6
|
||
|
||
begin
|
||
PUT (CURR_OUTPUT, ITEM);
|
||
end;
|
||
|
||
procedure GET_LINE (FILE : in FILE_TYPE;
|
||
ITEM : out STRING; LAST : out NATURAL) is
|
||
|
||
INCHAR : CHARACTER;
|
||
POINTER : NATURAL := ITEM'FIRST - 1;
|
||
|
||
-- See chapter 14.3.6
|
||
|
||
begin
|
||
if FILE = null then
|
||
raise STATUS_ERROR;
|
||
elsif FILE . MODE /= IN_FILE then
|
||
raise MODE_ERROR;
|
||
end if;
|
||
loop
|
||
READ (FILE, INCHAR);
|
||
case INCHAR is
|
||
when CR | LF =>
|
||
UNGET (FILE);
|
||
SKIP_LINE (FILE);
|
||
if FILE . HANDLE = 0 then -- Input from console
|
||
if INCHAR = CR then
|
||
PUT (DOS_OUTPUT, LF);
|
||
else
|
||
PUT (DOS_OUTPUT, CR);
|
||
end if;
|
||
end if;
|
||
exit;
|
||
when FF =>
|
||
UNGET (FILE);
|
||
SKIP_PAGE (FILE);
|
||
exit;
|
||
when EOF =>
|
||
exit;
|
||
when others =>
|
||
FILE . COL := FILE . COL + 1;
|
||
POINTER := POINTER + 1;
|
||
ITEM (POINTER) := INCHAR;
|
||
exit when POINTER = ITEM'LAST;
|
||
end case;
|
||
end loop;
|
||
LAST := POINTER;
|
||
end GET_LINE;
|
||
|
||
procedure GET_LINE (ITEM : out STRING; LAST : out NATURAL) is
|
||
|
||
-- See chapter 14.3.6
|
||
|
||
begin
|
||
GET_LINE (CURR_INPUT, ITEM, LAST);
|
||
end GET_LINE;
|
||
|
||
procedure PUT_LINE (FILE : in FILE_TYPE; ITEM : in STRING) is
|
||
|
||
-- See chapter 14.3.6
|
||
|
||
begin
|
||
if FILE = null then
|
||
raise STATUS_ERROR;
|
||
elsif FILE . MODE /= OUT_FILE then
|
||
raise MODE_ERROR;
|
||
end if;
|
||
PUT (FILE, ITEM);
|
||
NEW_LINE (FILE);
|
||
end PUT_LINE;
|
||
|
||
procedure PUT_LINE (ITEM : in STRING) is
|
||
|
||
-- See chapter 14.3.6
|
||
|
||
begin
|
||
PUT_LINE (CURR_OUTPUT, ITEM);
|
||
end PUT_LINE;
|
||
|
||
--
|
||
-- Integer I/O
|
||
--
|
||
-- The following utility procedures are not included in
|
||
-- the INTEGER_IO package in order to decrease instantiation overhead.
|
||
--
|
||
|
||
function VALID_INT (BASE : in NUMBER_BASE;
|
||
CH : in CHARACTER) return INTEGER is
|
||
|
||
N : INTEGER;
|
||
|
||
begin
|
||
if CH >= 'a' then
|
||
N := INTEGER (CH) - INTEGER ('a') + 10;
|
||
elsif CH >= 'A' then
|
||
N := INTEGER (CH) - INTEGER ('A') + 10;
|
||
else
|
||
N := INTEGER (CH) - INTEGER ('0');
|
||
end if;
|
||
if N > BASE - 1 then -- illegal digit for base
|
||
return -1;
|
||
else
|
||
return N;
|
||
end if;
|
||
end VALID_INT;
|
||
|
||
procedure READ_INT (FILE : in FILE_TYPE;
|
||
MAX_WIDTH : in FIELD;
|
||
INT : out INTEGER;
|
||
BASE : in out NUMBER_BASE;
|
||
HAS_EXP : in BOOLEAN := FALSE) is
|
||
|
||
COUNTER : INTEGER := 0;
|
||
BASE_CHANGED : BOOLEAN := FALSE;
|
||
INCHAR : CHARACTER;
|
||
TEMP : INTEGER;
|
||
MINUS : BOOLEAN := FALSE;
|
||
ONUM : INTEGER;
|
||
|
||
begin
|
||
ONUM := 0;
|
||
loop
|
||
READ (FILE, INCHAR);
|
||
COUNTER := COUNTER + 1;
|
||
case INCHAR is
|
||
when '0'..'9' | 'a'..'f' | 'A'..'F' =>
|
||
if not BASE_CHANGED and (INCHAR = 'e' or INCHAR = 'E') then
|
||
UNGET (FILE);
|
||
exit;
|
||
else
|
||
TEMP := VALID_INT (BASE, INCHAR);
|
||
if TEMP > -1 then
|
||
ONUM := BASE * ONUM + TEMP;
|
||
FILE . COL := FILE . COL + 1;
|
||
else -- Illegal character
|
||
raise DATA_ERROR;
|
||
end if;
|
||
end if;
|
||
when '#' | ':' =>
|
||
FILE . COL := FILE . COL + 1;
|
||
if not BASE_CHANGED and not HAS_EXP and
|
||
(ONUM > 1 and ONUM < 17) then -- We have read the base
|
||
BASE := ONUM;
|
||
ONUM := 0;
|
||
BASE_CHANGED := TRUE;
|
||
elsif BASE_CHANGED and not HAS_EXP then
|
||
exit;
|
||
elsif MAX_WIDTH = 0 or
|
||
(MAX_WIDTH > 0 and COUNTER = MAX_WIDTH) then
|
||
exit;
|
||
else
|
||
raise DATA_ERROR;
|
||
end if;
|
||
when '-' =>
|
||
FILE . COL := FILE . COL + 1;
|
||
if HAS_EXP then
|
||
MINUS := TRUE;
|
||
else
|
||
exit;
|
||
end if;
|
||
when '+' =>
|
||
FILE . COL := FILE . COL + 1;
|
||
if not HAS_EXP then
|
||
exit;
|
||
end if;
|
||
when CR | LF | FF | EOF =>
|
||
UNGET (FILE);
|
||
exit;
|
||
when others =>
|
||
if MAX_WIDTH = 0 then
|
||
UNGET (FILE);
|
||
exit;
|
||
else
|
||
raise DATA_ERROR;
|
||
end if;
|
||
end case;
|
||
exit when COUNTER = MAX_WIDTH and MAX_WIDTH > 0;
|
||
end loop;
|
||
if MINUS then
|
||
ONUM := - ONUM;
|
||
end if;
|
||
INT := ONUM;
|
||
end READ_INT;
|
||
|
||
procedure GET (FILE : in FILE_TYPE;
|
||
ITEM : out INTEGER;
|
||
WIDTH : in FIELD;
|
||
INBASE : NUMBER_BASE) is
|
||
|
||
COUNTER : INTEGER := 0;
|
||
INCHAR : CHARACTER;
|
||
BASE : NUMBER_BASE := INBASE;
|
||
INT : INTEGER;
|
||
ONUM : INTEGER;
|
||
ALREADY_SOMETHING : BOOLEAN := FALSE;
|
||
|
||
-- See chapter 14.3.7
|
||
|
||
begin
|
||
if FILE = null then
|
||
raise STATUS_ERROR;
|
||
elsif FILE . MODE /= IN_FILE then
|
||
raise MODE_ERROR;
|
||
end if;
|
||
ONUM:= 0;
|
||
loop
|
||
READ (FILE, INCHAR);
|
||
case INCHAR is
|
||
when FF | CR | LF =>
|
||
if WIDTH /= 0 or ALREADY_SOMETHING then
|
||
UNGET (FILE);
|
||
exit;
|
||
end if;
|
||
when EOF =>
|
||
UNGET (FILE);
|
||
exit;
|
||
when ' ' =>
|
||
FILE . COL := FILE . COL + 1;
|
||
if WIDTH > 0 then
|
||
COUNTER := COUNTER + 1;
|
||
end if;
|
||
when '-' =>
|
||
if ALREADY_SOMETHING then
|
||
raise DATA_ERROR;
|
||
end if;
|
||
FILE . COL := FILE . COL + 1;
|
||
if WIDTH > 0 then
|
||
COUNTER := COUNTER + 1;
|
||
end if;
|
||
READ_INT (FILE, WIDTH - COUNTER, ONUM, BASE);
|
||
ONUM := - ONUM;
|
||
ALREADY_SOMETHING := TRUE;
|
||
when '+' =>
|
||
if ALREADY_SOMETHING then
|
||
raise DATA_ERROR;
|
||
end if;
|
||
FILE . COL := FILE . COL + 1;
|
||
if WIDTH > 0 then
|
||
COUNTER := COUNTER + 1;
|
||
end if;
|
||
READ_INT (FILE, WIDTH - COUNTER, ONUM, BASE);
|
||
ALREADY_SOMETHING := TRUE;
|
||
when '0' .. '9' =>
|
||
UNGET (FILE);
|
||
READ_INT (FILE, WIDTH - COUNTER, ONUM, BASE);
|
||
ALREADY_SOMETHING := TRUE;
|
||
when 'e' | 'E' =>
|
||
if not ALREADY_SOMETHING then
|
||
raise DATA_ERROR;
|
||
end if;
|
||
FILE . COL := FILE . COL + 1;
|
||
if WIDTH > 0 then
|
||
COUNTER := COUNTER + 1;
|
||
end if;
|
||
READ_INT (FILE, WIDTH - COUNTER, INT, BASE, TRUE);
|
||
ONUM := ONUM * BASE ** INT;
|
||
exit;
|
||
when others =>
|
||
raise DATA_ERROR;
|
||
end case;
|
||
exit when COUNTER = WIDTH and WIDTH > 0;
|
||
end loop;
|
||
ITEM := ONUM;
|
||
exception
|
||
when NUMERIC_ERROR =>
|
||
raise DATA_ERROR;
|
||
end GET;
|
||
|
||
procedure PUT (
|
||
FILE : in FILE_TYPE;
|
||
ITEM : in INTEGER;
|
||
WIDTH : in FIELD;
|
||
BASE : in NUMBER_BASE) is
|
||
|
||
IMAGE : STRING (1..19); -- Max possible is "-2#[15 bits]#"
|
||
DIGIT : constant STRING (1..16) := "0123456789ABCDEF";
|
||
POINTER : POSITIVE := IMAGE'LAST;
|
||
REST : INTEGER := abs ITEM;
|
||
|
||
-- See chapter 14.3.7
|
||
|
||
begin
|
||
if BASE /= 10 then -- Make Ada standard based literal syntax
|
||
IMAGE (POINTER) := '#';
|
||
POINTER := POINTER - 1;
|
||
end if;
|
||
if REST = 0 then
|
||
IMAGE (POINTER) := '0';
|
||
POINTER := POINTER - 1;
|
||
end if;
|
||
while REST /= 0 loop -- Code the digits
|
||
IMAGE (POINTER) := DIGIT ((REST mod BASE) + 1);
|
||
POINTER := POINTER - 1;
|
||
REST := REST / BASE;
|
||
end loop;
|
||
if BASE /= 10 then
|
||
IMAGE (POINTER) := '#';
|
||
POINTER := POINTER - 1;
|
||
REST := BASE; -- Code the base itself
|
||
while REST /= 0 loop
|
||
IMAGE (POINTER) := DIGIT ((REST mod 10) + 1);
|
||
POINTER := POINTER - 1;
|
||
REST := REST / 10;
|
||
end loop;
|
||
end if;
|
||
if ITEM < 0 then -- Put minus sign
|
||
IMAGE (POINTER) := '-';
|
||
POINTER := POINTER - 1;
|
||
end if;
|
||
for I in IMAGE'LAST - POINTER + 1 .. WIDTH loop -- Put preceding spaces
|
||
PUT (FILE, ' ');
|
||
end loop;
|
||
PUT (FILE, IMAGE (POINTER + 1 .. IMAGE'LAST)); -- Put the slice
|
||
end PUT;
|
||
|
||
procedure GET_INT (FROM : in STRING;
|
||
INDEX : in out POSITIVE;
|
||
INT : out INTEGER;
|
||
BASE : in out NUMBER_BASE;
|
||
HAS_EXP : in BOOLEAN := FALSE) is
|
||
|
||
BASE_CHANGED : BOOLEAN := FALSE;
|
||
INCHAR : CHARACTER;
|
||
TEMP : INTEGER;
|
||
MINUS : BOOLEAN := FALSE;
|
||
ONUM : INTEGER;
|
||
|
||
begin
|
||
ONUM := 0;
|
||
loop
|
||
INCHAR := FROM (INDEX);
|
||
case INCHAR is
|
||
when '0'..'9' | 'a'..'f' | 'A'..'F' =>
|
||
if not BASE_CHANGED and (INCHAR = 'e' or INCHAR = 'E') then
|
||
exit;
|
||
else
|
||
TEMP := VALID_INT (BASE, INCHAR);
|
||
if TEMP > -1 then
|
||
ONUM := BASE * ONUM + TEMP;
|
||
else
|
||
raise DATA_ERROR;
|
||
end if;
|
||
end if;
|
||
when '#' | ':' =>
|
||
if not BASE_CHANGED and not HAS_EXP and
|
||
(ONUM > 1 and ONUM < 17) then -- We have read the base
|
||
BASE := ONUM;
|
||
ONUM := 0;
|
||
BASE_CHANGED := TRUE;
|
||
else
|
||
INDEX := INDEX + 1;
|
||
exit;
|
||
end if;
|
||
when '-' =>
|
||
if HAS_EXP then
|
||
MINUS := TRUE;
|
||
else
|
||
exit;
|
||
end if;
|
||
when '+' =>
|
||
if not HAS_EXP then
|
||
exit;
|
||
end if;
|
||
when others =>
|
||
exit;
|
||
end case;
|
||
exit when INDEX = FROM'LAST;
|
||
INDEX := INDEX + 1;
|
||
end loop;
|
||
if MINUS then
|
||
ONUM := - ONUM;
|
||
end if;
|
||
INT := ONUM;
|
||
end GET_INT;
|
||
|
||
procedure GET (
|
||
FROM : in STRING;
|
||
ITEM : out INTEGER;
|
||
LAST : out POSITIVE;
|
||
INBASE : in NUMBER_BASE) is
|
||
|
||
INT : INTEGER;
|
||
BASE : NUMBER_BASE := INBASE;
|
||
L : POSITIVE;
|
||
ONUM : INTEGER;
|
||
ALREADY_SOMETHING : BOOLEAN := FALSE;
|
||
|
||
-- See chapter 14.3.7
|
||
|
||
begin
|
||
L := FROM'FIRST;
|
||
loop
|
||
case FROM (L) is
|
||
when ' ' =>
|
||
L := L + 1;
|
||
if ALREADY_SOMETHING then
|
||
exit;
|
||
end if;
|
||
when '-' =>
|
||
if ALREADY_SOMETHING then
|
||
raise DATA_ERROR;
|
||
end if;
|
||
L := L + 1;
|
||
GET_INT (FROM, L, ONUM, BASE);
|
||
ONUM := - ONUM;
|
||
ALREADY_SOMETHING := TRUE;
|
||
when '+' =>
|
||
if ALREADY_SOMETHING then
|
||
raise DATA_ERROR;
|
||
end if;
|
||
L := L + 1;
|
||
GET_INT (FROM, L, ONUM, BASE);
|
||
ALREADY_SOMETHING := TRUE;
|
||
when '0' .. '9' =>
|
||
GET_INT (FROM, L, ONUM, BASE);
|
||
ALREADY_SOMETHING := TRUE;
|
||
when 'e' | 'E' =>
|
||
if not ALREADY_SOMETHING then
|
||
raise DATA_ERROR;
|
||
end if;
|
||
L := L + 1;
|
||
GET_INT (FROM, L, INT, BASE, TRUE);
|
||
ONUM := ONUM * BASE ** INT;
|
||
exit;
|
||
when others =>
|
||
raise DATA_ERROR;
|
||
end case;
|
||
exit when L = FROM'LAST;
|
||
end loop;
|
||
LAST := L;
|
||
ITEM := ONUM;
|
||
exception
|
||
when NUMERIC_ERROR =>
|
||
raise DATA_ERROR;
|
||
end GET;
|
||
|
||
procedure PUT (
|
||
TO : out STRING;
|
||
ITEM : in INTEGER;
|
||
BASE : in NUMBER_BASE) is
|
||
|
||
DIGIT : constant STRING (1..16) := "0123456789ABCDEF";
|
||
POINTER : POSITIVE := TO'LAST;
|
||
REST : INTEGER := abs ITEM;
|
||
|
||
-- See chapter 14.3.7
|
||
|
||
begin
|
||
if BASE /= 10 then -- Make Ada standard based literal syntax
|
||
TO (POINTER) := '#';
|
||
POINTER := POINTER - 1;
|
||
end if;
|
||
if REST = 0 then
|
||
TO (POINTER) := '0';
|
||
POINTER := POINTER - 1;
|
||
end if;
|
||
while REST /= 0 loop -- Code the digits
|
||
TO (POINTER) := DIGIT ((REST mod BASE) + 1);
|
||
POINTER := POINTER - 1;
|
||
REST := REST / BASE;
|
||
end loop;
|
||
if BASE /= 10 then
|
||
TO (POINTER) := '#';
|
||
POINTER := POINTER - 1;
|
||
REST := BASE; -- Code the base itself
|
||
while REST /= 0 loop
|
||
TO (POINTER) := DIGIT ((REST mod 10) + 1);
|
||
POINTER := POINTER - 1;
|
||
REST := REST / 10;
|
||
end loop;
|
||
end if;
|
||
if ITEM < 0 then -- Put minus sign
|
||
TO (POINTER) := '-';
|
||
POINTER := POINTER - 1;
|
||
end if;
|
||
TO (TO'FIRST .. POINTER) := (others => ' ');
|
||
end PUT;
|
||
|
||
package body INTEGER_IO is
|
||
|
||
procedure GET (FILE : in FILE_TYPE;
|
||
ITEM : out NUM;
|
||
WIDTH : in FIELD := DEFAULT_WIDTH) is
|
||
|
||
ONUM : INTEGER;
|
||
|
||
begin
|
||
GET (FILE, ONUM, WIDTH, DEFAULT_BASE);
|
||
ITEM := NUM (ONUM);
|
||
end GET;
|
||
|
||
procedure GET (ITEM : out NUM; WIDTH : in FIELD := 0) is
|
||
|
||
ONUM : INTEGER;
|
||
|
||
begin
|
||
GET (CURR_INPUT, ONUM, WIDTH, DEFAULT_BASE);
|
||
ITEM := NUM (ONUM);
|
||
end GET;
|
||
|
||
procedure PUT (
|
||
FILE : in FILE_TYPE;
|
||
ITEM : in NUM;
|
||
WIDTH : in FIELD := DEFAULT_WIDTH;
|
||
BASE : in NUMBER_BASE := DEFAULT_BASE) is
|
||
begin
|
||
PUT (FILE, INTEGER (ITEM), WIDTH, BASE);
|
||
end PUT;
|
||
|
||
procedure PUT (
|
||
ITEM : in NUM;
|
||
WIDTH : in FIELD := DEFAULT_WIDTH;
|
||
BASE : in NUMBER_BASE := DEFAULT_BASE) is
|
||
|
||
begin
|
||
PUT (CURR_OUTPUT, INTEGER (ITEM), WIDTH, BASE);
|
||
end PUT;
|
||
|
||
procedure GET (
|
||
FROM : in STRING;
|
||
ITEM : out NUM;
|
||
LAST : out POSITIVE) is
|
||
|
||
ONUM : INTEGER;
|
||
|
||
begin
|
||
GET (FROM, ONUM, LAST, DEFAULT_BASE);
|
||
ITEM := NUM (ONUM);
|
||
end GET;
|
||
|
||
procedure PUT (
|
||
TO : out STRING;
|
||
ITEM : in NUM;
|
||
BASE : in NUMBER_BASE := DEFAULT_BASE) is
|
||
|
||
begin
|
||
PUT (TO, INTEGER (ITEM), BASE);
|
||
end PUT;
|
||
|
||
end INTEGER_IO;
|
||
|
||
--
|
||
-- Floating point I/O
|
||
--
|
||
-- The following utility procedures are not included in the body
|
||
-- of FLOAT_IO to decrease instantiation overhead.
|
||
|
||
type SUCCESS_TYPE is
|
||
(NOTHING, BEFORE_PERIOD, AFTER_PERIOD, EXPONENT);
|
||
|
||
procedure READ_INT (FILE : in FILE_TYPE;
|
||
MAX_WIDTH : in FIELD;
|
||
BASE : in out NUMBER_BASE;
|
||
NUMBER : in out FLOAT;
|
||
WHERE : in SUCCESS_TYPE;
|
||
COUNTER : out INTEGER;
|
||
STR : in STRING;
|
||
STR_INDEX : in out INTEGER;
|
||
USE_STRING: in BOOLEAN) is
|
||
|
||
BASE_CHANGED : BOOLEAN := FALSE;
|
||
INCHAR : CHARACTER;
|
||
INT : INTEGER := 0;
|
||
TEMP : INTEGER;
|
||
MINUS : BOOLEAN := FALSE;
|
||
CTR : INTEGER;
|
||
|
||
begin
|
||
CTR := 0;
|
||
STR_INDEX := STR_INDEX - 1;
|
||
loop
|
||
STR_INDEX := STR_INDEX + 1;
|
||
if USE_STRING then
|
||
INCHAR := STR (STR_INDEX);
|
||
else
|
||
READ (FILE, INCHAR);
|
||
end if;
|
||
CTR := CTR + 1;
|
||
case INCHAR is
|
||
when '0'..'9' | 'a'..'f' | 'A'..'F' =>
|
||
if not BASE_CHANGED and (INCHAR = 'e' or INCHAR = 'E') then
|
||
if USE_STRING then
|
||
STR_INDEX := STR_INDEX - 1;
|
||
else
|
||
UNGET (FILE);
|
||
end if;
|
||
exit;
|
||
else
|
||
TEMP := VALID_INT (BASE, INCHAR);
|
||
if TEMP > -1 then
|
||
case WHERE is
|
||
when BEFORE_PERIOD =>
|
||
NUMBER := BASE * NUMBER + FLOAT (TEMP);
|
||
when AFTER_PERIOD =>
|
||
NUMBER := NUMBER + TEMP * FLOAT (BASE)
|
||
**(- CTR);
|
||
when EXPONENT =>
|
||
INT := INT * 10 + TEMP; -- Get the exponent
|
||
when NOTHING => -- This should not happen
|
||
raise DATA_ERROR;
|
||
end case;
|
||
if not USE_STRING then
|
||
FILE . COL := FILE . COL + 1;
|
||
end if;
|
||
else -- Illegal character
|
||
raise DATA_ERROR;
|
||
end if;
|
||
end if;
|
||
when '#' | ':' =>
|
||
if not USE_STRING then
|
||
FILE . COL := FILE . COL + 1;
|
||
end if;
|
||
if not BASE_CHANGED and WHERE = BEFORE_PERIOD and
|
||
(INT > 1 and INT < 17) then -- We have read the base
|
||
BASE := INT;
|
||
INT := 0;
|
||
BASE_CHANGED := TRUE;
|
||
elsif WHERE = AFTER_PERIOD then
|
||
exit;
|
||
else
|
||
raise DATA_ERROR;
|
||
end if;
|
||
when '-' =>
|
||
if WHERE = EXPONENT then
|
||
MINUS := TRUE;
|
||
if not USE_STRING then
|
||
FILE . COL := FILE . COL + 1;
|
||
end if;
|
||
else
|
||
raise DATA_ERROR;
|
||
end if;
|
||
when '+' =>
|
||
if WHERE /= EXPONENT then
|
||
raise DATA_ERROR;
|
||
end if;
|
||
if not USE_STRING then
|
||
FILE . COL := FILE . COL + 1;
|
||
end if;
|
||
when '.' =>
|
||
if WHERE = BEFORE_PERIOD or MAX_WIDTH = 0 then
|
||
if USE_STRING then
|
||
STR_INDEX := STR_INDEX - 1;
|
||
else
|
||
UNGET (FILE);
|
||
end if;
|
||
exit;
|
||
else
|
||
raise DATA_ERROR;
|
||
end if;
|
||
when CR | LF | FF | EOF => -- Termination of input
|
||
if WHERE = BEFORE_PERIOD then
|
||
raise DATA_ERROR;
|
||
else
|
||
if USE_STRING then
|
||
STR_INDEX := STR_INDEX - 1;
|
||
else
|
||
UNGET (FILE);
|
||
end if;
|
||
exit;
|
||
end if;
|
||
when others =>
|
||
if MAX_WIDTH = 0 then -- Termination of input
|
||
if USE_STRING then
|
||
STR_INDEX := STR_INDEX - 1;
|
||
else
|
||
UNGET (FILE);
|
||
end if;
|
||
exit;
|
||
else
|
||
raise DATA_ERROR;
|
||
end if;
|
||
end case;
|
||
exit when (CTR = MAX_WIDTH and MAX_WIDTH > 0) or
|
||
(USE_STRING and STR_INDEX = STR'LAST);
|
||
end loop;
|
||
if WHERE = EXPONENT then
|
||
if MINUS then
|
||
INT := - INT;
|
||
end if;
|
||
NUMBER := NUMBER * FLOAT (BASE) ** INT;
|
||
end if;
|
||
COUNTER := CTR;
|
||
end READ_INT;
|
||
|
||
function EXPO (F : in FLOAT) return INTEGER is
|
||
|
||
-- Returns the binary exponent of an IEEE floating-point
|
||
-- number. The bias (1023) is subtracted.
|
||
|
||
E : INTEGER;
|
||
|
||
begin
|
||
pragma NATIVE (
|
||
16#8B#, 16#44#, 16#06#, 16#25#, 16#F0#, 16#7F#, 16#D1#, 16#E8#,
|
||
16#D1#, 16#E8#, 16#D1#, 16#E8#, 16#D1#, 16#E8#, 16#2D#, 16#FF#,
|
||
16#03#, 16#89#, 16#05#);
|
||
return E;
|
||
end EXPO;
|
||
|
||
procedure GET_STR_FILE (FILE : in FILE_TYPE;
|
||
ITEM : out FLOAT;
|
||
WIDTH : in FIELD := 0;
|
||
STR : in STRING;
|
||
STR_INDEX : in out INTEGER;
|
||
USE_STRING : in BOOLEAN) is
|
||
|
||
SUCCESS : SUCCESS_TYPE := NOTHING;
|
||
INDEX : INTEGER;
|
||
COUNTER : INTEGER := 0;
|
||
INCHAR : CHARACTER;
|
||
BASE : NUMBER_BASE := 10;
|
||
ONUM : FLOAT;
|
||
MINUS : BOOLEAN := FALSE;
|
||
|
||
-- See chapter 14.3.8
|
||
|
||
begin
|
||
if FILE = null then
|
||
raise STATUS_ERROR;
|
||
elsif FILE . MODE /= IN_FILE then
|
||
raise MODE_ERROR;
|
||
end if;
|
||
STR_INDEX := STR'FIRST - 1;
|
||
ONUM := 0.0;
|
||
loop
|
||
STR_INDEX := STR_INDEX + 1;
|
||
if USE_STRING then
|
||
INCHAR := STR (STR_INDEX);
|
||
else
|
||
READ (FILE, INCHAR);
|
||
end if;
|
||
case INCHAR is
|
||
when FF | CR | LF =>
|
||
if WIDTH /= 0 or SUCCESS = AFTER_PERIOD or
|
||
SUCCESS = EXPONENT then
|
||
if USE_STRING then
|
||
STR_INDEX := STR_INDEX - 1;
|
||
else
|
||
UNGET (FILE);
|
||
end if;
|
||
exit;
|
||
end if;
|
||
when EOF =>
|
||
if USE_STRING then
|
||
STR_INDEX := STR_INDEX - 1;
|
||
else
|
||
UNGET (FILE);
|
||
end if;
|
||
exit;
|
||
when ' ' =>
|
||
if SUCCESS = NOTHING then
|
||
if not USE_STRING then
|
||
FILE . COL := FILE . COL + 1;
|
||
end if;
|
||
if WIDTH > 0 then
|
||
COUNTER := COUNTER + 1;
|
||
end if;
|
||
elsif SUCCESS = AFTER_PERIOD then
|
||
if USE_STRING then
|
||
STR_INDEX := STR_INDEX - 1;
|
||
else
|
||
UNGET (FILE);
|
||
end if;
|
||
exit;
|
||
else
|
||
raise DATA_ERROR;
|
||
end if;
|
||
when '-' =>
|
||
if SUCCESS = NOTHING then
|
||
SUCCESS := BEFORE_PERIOD;
|
||
else
|
||
raise DATA_ERROR;
|
||
end if;
|
||
if USE_STRING then
|
||
STR_INDEX := STR_INDEX + 1;
|
||
else
|
||
FILE . COL := FILE . COL + 1;
|
||
end if;
|
||
if WIDTH > 0 then
|
||
COUNTER := COUNTER + 1;
|
||
end if;
|
||
READ_INT (FILE, WIDTH - COUNTER, BASE, ONUM,
|
||
SUCCESS, INDEX, STR, STR_INDEX, USE_STRING);
|
||
if WIDTH > 0 then
|
||
COUNTER := COUNTER + INDEX;
|
||
end if;
|
||
MINUS := TRUE;
|
||
when '+' =>
|
||
if SUCCESS = NOTHING then
|
||
SUCCESS := BEFORE_PERIOD;
|
||
else
|
||
raise DATA_ERROR;
|
||
end if;
|
||
if USE_STRING then
|
||
STR_INDEX := STR_INDEX + 1;
|
||
else
|
||
FILE . COL := FILE . COL + 1;
|
||
end if;
|
||
if WIDTH > 0 then
|
||
COUNTER := COUNTER + 1;
|
||
end if;
|
||
READ_INT (FILE, WIDTH - COUNTER, BASE, ONUM,
|
||
SUCCESS, INDEX, STR, STR_INDEX, USE_STRING);
|
||
if WIDTH > 0 then
|
||
COUNTER := COUNTER + INDEX;
|
||
end if;
|
||
when '0' .. '9' =>
|
||
if SUCCESS = NOTHING then
|
||
SUCCESS := BEFORE_PERIOD;
|
||
end if;
|
||
if not USE_STRING then
|
||
UNGET (FILE);
|
||
end if;
|
||
READ_INT (FILE, WIDTH - COUNTER, BASE, ONUM,
|
||
SUCCESS, INDEX, STR, STR_INDEX, USE_STRING);
|
||
if WIDTH > 0 then
|
||
COUNTER := COUNTER + INDEX;
|
||
end if;
|
||
when '.' =>
|
||
if USE_STRING then
|
||
STR_INDEX := STR_INDEX + 1;
|
||
else
|
||
FILE . COL := FILE . COL + 1;
|
||
end if;
|
||
if WIDTH > 0 then
|
||
COUNTER := COUNTER + 1;
|
||
end if;
|
||
if SUCCESS = BEFORE_PERIOD then
|
||
SUCCESS := AFTER_PERIOD;
|
||
READ_INT (FILE, WIDTH - COUNTER, BASE, ONUM,
|
||
SUCCESS, INDEX, STR, STR_INDEX, USE_STRING);
|
||
if WIDTH > 0 then
|
||
COUNTER := COUNTER + INDEX;
|
||
end if;
|
||
else
|
||
raise DATA_ERROR;
|
||
end if;
|
||
when 'e' | 'E' =>
|
||
if USE_STRING then
|
||
STR_INDEX := STR_INDEX + 1;
|
||
else
|
||
FILE . COL := FILE . COL + 1;
|
||
end if;
|
||
if WIDTH > 0 then
|
||
COUNTER := COUNTER + 1;
|
||
end if;
|
||
if SUCCESS = AFTER_PERIOD then
|
||
SUCCESS := EXPONENT;
|
||
READ_INT (FILE, WIDTH - COUNTER, BASE, ONUM,
|
||
SUCCESS, INDEX, STR, STR_INDEX, USE_STRING);
|
||
if WIDTH > 0 then
|
||
COUNTER := COUNTER + INDEX;
|
||
end if;
|
||
else
|
||
raise DATA_ERROR;
|
||
end if;
|
||
when others =>
|
||
raise DATA_ERROR;
|
||
end case;
|
||
exit when (COUNTER >= WIDTH and WIDTH > 0) or (SUCCESS = EXPONENT) or
|
||
(USE_STRING and STR_INDEX = STR'LAST);
|
||
end loop;
|
||
if MINUS then
|
||
ONUM := - ONUM;
|
||
end if;
|
||
ITEM := ONUM;
|
||
exception
|
||
when NUMERIC_ERROR =>
|
||
raise DATA_ERROR;
|
||
end GET_STR_FILE;
|
||
|
||
INDEX : INTEGER; -- Index for FLOAT_STR
|
||
FLOAT_STR : STRING (1..30); -- Temporary string for PUT FLOAT to
|
||
-- a file or a string
|
||
|
||
procedure PUT_STR
|
||
(ITEM : in FLOAT;
|
||
FORE, AFT, EXP : in FIELD) is
|
||
|
||
X : FLOAT := ITEM;
|
||
T : FLOAT;
|
||
E, TEMP_INDEX : INTEGER;
|
||
D : INTEGER range 0..9;
|
||
MINUS_NUM : BOOLEAN;
|
||
AFTER : FIELD := AFT;
|
||
|
||
-- See chapter 14.3.8
|
||
|
||
function TEN (EX : in INTEGER) return FLOAT is
|
||
|
||
begin
|
||
return 10.0 ** EX;
|
||
end TEN;
|
||
|
||
function CUT_SPACE (S : in STRING) return STRING is
|
||
|
||
begin
|
||
return S (2..S'LAST);
|
||
end CUT_SPACE;
|
||
|
||
function LENGTH (S : in STRING) return INTEGER is
|
||
|
||
begin
|
||
return S'LENGTH;
|
||
end;
|
||
|
||
begin -- PUT for FLOAT
|
||
FLOAT_STR (FLOAT_STR'FIRST .. FLOAT_STR'LAST) := (others => ' ');
|
||
INDEX := 1;
|
||
if AFTER = 0 then
|
||
AFTER := 1;
|
||
end if;
|
||
MINUS_NUM := X < 0.0;
|
||
X := abs X;
|
||
if X = 0.0 then -- Avoid peculiar exponent if zero
|
||
E := 0;
|
||
else
|
||
E := EXPO (FLOAT (X)); -- Process exponent
|
||
end if;
|
||
if X /= 0.0 then
|
||
E := ((E + 1) * 77) / 256; -- Convert to base 10 exponent
|
||
end if;
|
||
if TEN (E) > X then
|
||
E := E - 1; -- Correct integer arithmetic error
|
||
end if;
|
||
if EXP > 0 then
|
||
X := X / TEN (E);
|
||
end if;
|
||
if X /= 0.0 then
|
||
X := X + 0.5 * TEN (- AFTER); -- Rounding
|
||
end if;
|
||
if EXP > 0 and X >= 10.0 then
|
||
X := X / 10.0;
|
||
E := E + 1;
|
||
elsif EXP = 0 and X >= TEN (E + 1) then
|
||
E := E + 1;
|
||
end if;
|
||
-- Handle FORE
|
||
if X = 0.0 then -- X = 0: Special case
|
||
for I in 2 .. FORE loop
|
||
FLOAT_STR (INDEX) := ' ';
|
||
INDEX := INDEX + 1;
|
||
end loop;
|
||
FLOAT_STR (INDEX) := '0';
|
||
INDEX := INDEX + 1;
|
||
elsif EXP > 0 then -- EXP > 0: Only one digit in FORE
|
||
if MINUS_NUM then
|
||
for I in 3 .. FORE loop
|
||
FLOAT_STR (INDEX) := ' ';
|
||
INDEX := INDEX + 1;
|
||
end loop;
|
||
FLOAT_STR (INDEX) := '-';
|
||
INDEX := INDEX + 1;
|
||
else
|
||
for I in 2 .. FORE loop
|
||
FLOAT_STR (INDEX) := ' ';
|
||
INDEX := INDEX + 1;
|
||
end loop;
|
||
end if;
|
||
D := INTEGER (X - 0.5); -- Convert to TRUNC
|
||
if X - FLOAT (D) >= 1.0 then -- Rounded too much
|
||
D := D + 1; -- Add one to digit
|
||
end if;
|
||
FLOAT_STR (INDEX) := CHARACTER (D + 48);
|
||
INDEX := INDEX + 1;
|
||
X := (X - FLOAT (D)) * 10.0;
|
||
else -- EXP = 0: Put all digits in FORE
|
||
if E < 0 then
|
||
if MINUS_NUM then
|
||
for I in 3 .. FORE loop
|
||
FLOAT_STR (INDEX) := ' ';
|
||
INDEX := INDEX + 1;
|
||
end loop;
|
||
FLOAT_STR (INDEX) := '-';
|
||
INDEX := INDEX + 1;
|
||
FLOAT_STR (INDEX) := '0';
|
||
INDEX := INDEX + 1;
|
||
else
|
||
for I in 2 .. FORE loop
|
||
FLOAT_STR (INDEX) := ' ';
|
||
INDEX := INDEX + 1;
|
||
end loop;
|
||
FLOAT_STR (INDEX) := '0';
|
||
INDEX := INDEX + 1;
|
||
end if;
|
||
elsif MINUS_NUM then -- E > 0
|
||
for I in E + 3 .. FORE loop
|
||
FLOAT_STR (INDEX) := ' ';
|
||
INDEX := INDEX + 1;
|
||
end loop;
|
||
FLOAT_STR (INDEX) := '-';
|
||
INDEX := INDEX + 1;
|
||
else -- E > 0
|
||
for I in E + 2 .. FORE loop
|
||
FLOAT_STR (INDEX) := ' ';
|
||
INDEX := INDEX + 1;
|
||
end loop;
|
||
end if;
|
||
for I in reverse 0 .. E loop -- Take all the digits
|
||
T := TEN (I);
|
||
D := INTEGER (X / T - 0.5); -- Convert to TRUNC
|
||
X := X - D * T;
|
||
if X >= T then -- Rounded too much
|
||
D := D + 1;
|
||
X := X - T;
|
||
end if;
|
||
FLOAT_STR (INDEX) := CHARACTER (D + 48);
|
||
INDEX := INDEX + 1;
|
||
end loop;
|
||
X := X * 10.0; -- Prepare for AFT
|
||
end if;
|
||
-- Handle AFT
|
||
FLOAT_STR (INDEX) := '.';
|
||
INDEX := INDEX + 1;
|
||
for I in 1..AFTER loop -- Put the mantissa
|
||
D := INTEGER (X - 0.5); -- Convert to TRUNC
|
||
if X - FLOAT (D) >= 1.0 then -- Rounded too much
|
||
D := D + 1; -- Add one to digit
|
||
end if;
|
||
FLOAT_STR (INDEX) := CHARACTER (D + 48);
|
||
INDEX := INDEX + 1;
|
||
X := (X - FLOAT (D)) * 10.0;
|
||
end loop;
|
||
-- Handle EXP
|
||
if EXP > 0 then
|
||
FLOAT_STR (INDEX) := 'E';
|
||
INDEX := INDEX + 1;
|
||
if E >= 0 then
|
||
FLOAT_STR (INDEX) := '+';
|
||
INDEX := INDEX + 1;
|
||
else
|
||
FLOAT_STR (INDEX) := '-';
|
||
INDEX := INDEX + 1;
|
||
end if;
|
||
if E > 99 then
|
||
for I in 5 .. EXP loop
|
||
FLOAT_STR (INDEX) := '0';
|
||
INDEX := INDEX + 1;
|
||
end loop;
|
||
elsif E > 9 then
|
||
for I in 4 .. EXP loop
|
||
FLOAT_STR (INDEX) := '0';
|
||
INDEX := INDEX + 1;
|
||
end loop;
|
||
else
|
||
for I in 3 .. EXP loop
|
||
FLOAT_STR (INDEX) := '0';
|
||
INDEX := INDEX + 1;
|
||
end loop;
|
||
end if;
|
||
TEMP_INDEX := INDEX + LENGTH (INTEGER'IMAGE (abs E)) - 2;
|
||
FLOAT_STR (INDEX..TEMP_INDEX) := CUT_SPACE (INTEGER'IMAGE (abs E));
|
||
INDEX := TEMP_INDEX + 1;
|
||
end if;
|
||
INDEX := INDEX - 1;
|
||
end PUT_STR;
|
||
|
||
package body FLOAT_IO is
|
||
|
||
procedure GET (FILE : in FILE_TYPE;
|
||
ITEM : out NUM;
|
||
WIDTH : in FIELD := 0) is
|
||
|
||
ONUM : FLOAT;
|
||
DUMMY: INTEGER;
|
||
|
||
begin
|
||
GET_STR_FILE (FILE, ONUM, WIDTH, "", DUMMY, FALSE);
|
||
ITEM := NUM (ONUM);
|
||
end GET;
|
||
|
||
procedure GET (ITEM : out NUM; WIDTH : in FIELD := 0) is
|
||
|
||
-- See chapter 14.3.8
|
||
|
||
ONUM : FLOAT;
|
||
DUMMY : INTEGER;
|
||
|
||
begin
|
||
GET_STR_FILE (CURR_INPUT, ONUM, WIDTH, "", DUMMY, FALSE);
|
||
ITEM := NUM (ONUM);
|
||
end GET;
|
||
|
||
procedure PUT
|
||
(FILE : in FILE_TYPE;
|
||
ITEM : in NUM;
|
||
FORE : in FIELD := DEFAULT_FORE;
|
||
AFT : in FIELD := DEFAULT_AFT;
|
||
EXP : in FIELD := DEFAULT_EXP) is
|
||
|
||
begin
|
||
PUT_STR (FLOAT (ITEM), FORE, AFT, EXP);
|
||
PUT (FILE, FLOAT_STR (FLOAT_STR'FIRST..INDEX));
|
||
end PUT;
|
||
|
||
procedure PUT (ITEM : in NUM;
|
||
FORE : in FIELD := DEFAULT_FORE;
|
||
AFT : in FIELD := DEFAULT_AFT;
|
||
EXP : in FIELD := DEFAULT_EXP) is
|
||
|
||
-- See chapter 14.3.8
|
||
|
||
begin
|
||
PUT_STR (FLOAT (ITEM), FORE, AFT, EXP);
|
||
PUT (CURR_OUTPUT, FLOAT_STR (FLOAT_STR'FIRST..INDEX));
|
||
end PUT;
|
||
|
||
procedure GET (FROM : in STRING;
|
||
ITEM : out NUM;
|
||
LAST : out POSITIVE) is
|
||
|
||
-- See chapter 14.3.8
|
||
|
||
ONUM : FLOAT;
|
||
LEN : INTEGER;
|
||
|
||
begin
|
||
GET_STR_FILE (CURR_INPUT, ONUM, 0, FROM, LEN, TRUE);
|
||
ITEM := NUM (ONUM);
|
||
LAST := POSITIVE (LEN);
|
||
end GET;
|
||
|
||
procedure PUT (TO : out STRING;
|
||
ITEM : in NUM;
|
||
AFT : in FIELD := DEFAULT_AFT;
|
||
EXP : in FIELD := DEFAULT_EXP) is
|
||
|
||
-- See chapter 14.3.8
|
||
|
||
LEN : INTEGER;
|
||
|
||
begin
|
||
LEN := FLOAT_STR'LENGTH - AFT - EXP - 3; -- 3 is for . E sign of E
|
||
if EXP = 0 then
|
||
LEN := LEN + 2;
|
||
end if;
|
||
PUT_STR (FLOAT (ITEM), LEN, AFT, EXP);
|
||
if TO'LENGTH = FLOAT_STR'LENGTH then
|
||
TO := FLOAT_STR;
|
||
elsif TO'LENGTH < FLOAT_STR'LENGTH then
|
||
TO := FLOAT_STR (FLOAT_STR'LAST - TO'LENGTH + 1..FLOAT_STR'LAST);
|
||
else
|
||
TO (TO'FIRST .. TO'LAST - FLOAT_STR'LENGTH) := (others => ' ');
|
||
TO (TO'LAST - FLOAT_STR'LENGTH + 1 .. TO'LAST) := FLOAT_STR;
|
||
end if;
|
||
end PUT;
|
||
|
||
end FLOAT_IO;
|
||
|
||
--
|
||
-- Input / Output for Enumeration Types
|
||
--
|
||
|
||
-- The following utility subprograms are not included
|
||
-- in the body of ENUMERATION_IO to decrease instantiation overhead
|
||
|
||
function LEGAL_ID_CHAR
|
||
(CH : in CHARACTER; FIRST : in BOOLEAN) return BOOLEAN is
|
||
|
||
begin
|
||
if FIRST and CH in '0'..'9' then -- Id cannot begin with digit
|
||
return FALSE;
|
||
end if;
|
||
case CH is
|
||
when 'a'..'z' | 'A'..'Z' | '0'..'9' | '_' =>
|
||
return TRUE;
|
||
when others =>
|
||
return FALSE;
|
||
end case;
|
||
end LEGAL_ID_CHAR;
|
||
|
||
procedure ASSIGN_STR
|
||
(S1 : out STRING; S2 : in STRING; L : out INTEGER) is
|
||
|
||
begin
|
||
L := S2'LENGTH;
|
||
S1 (S2'RANGE) := S2;
|
||
end ASSIGN_STR;
|
||
|
||
package body ENUMERATION_IO is
|
||
|
||
MAX_IDENT_LENGTH : constant := 132;
|
||
|
||
procedure GET (FILE : in FILE_TYPE; ITEM : out ENUM) is
|
||
|
||
-- See chapter 14.3.9
|
||
|
||
CH : CHARACTER;
|
||
STR : STRING (1..MAX_IDENT_LENGTH);
|
||
I : INTEGER := 0;
|
||
|
||
begin
|
||
GET (FILE, CH); -- Skipped leading garbage
|
||
if CH = ''' then -- Special case: Character literal, f.ex 'A'
|
||
STR (1) := CH; -- if TEXT_IO . ENUMERATION (CHARACTER)
|
||
READ (FILE, STR (2)); -- has been instantiated
|
||
READ (FILE, STR (3));
|
||
FILE . COL := FILE . COL + 2;
|
||
I := 3;
|
||
else -- Input an identifier
|
||
while LEGAL_ID_CHAR (CH, I = 0) loop
|
||
I := I + 1;
|
||
STR (I) := CH;
|
||
READ (FILE, CH);
|
||
FILE . COL := FILE . COL + 2;
|
||
end loop; -- The identifier is now in STR (1..I)
|
||
UNGET (FILE);
|
||
end if;
|
||
ITEM := ENUM'VALUE (STR (1..I));
|
||
exception
|
||
when CONSTRAINT_ERROR => -- Raised by ENUM'VALUE
|
||
raise DATA_ERROR; -- This was an illegal enum identifier
|
||
end;
|
||
|
||
procedure GET (ITEM : out ENUM) is
|
||
|
||
-- See chapter 14.3.9
|
||
|
||
begin
|
||
GET (CURR_INPUT, ITEM);
|
||
end GET;
|
||
|
||
procedure PUT (FILE : in FILE_TYPE;
|
||
ITEM : in ENUM;
|
||
WIDTH : in FIELD := DEFAULT_WIDTH;
|
||
SET : in TYPE_SET := DEFAULT_SETTING) is
|
||
|
||
-- See chapter 14.3.9
|
||
|
||
STR : STRING (1..MAX_IDENT_LENGTH);
|
||
LENGTH : INTEGER;
|
||
|
||
begin
|
||
ASSIGN_STR (STR, ENUM'IMAGE (ITEM), LENGTH);
|
||
if (SET = LOWER_CASE) AND (STR (1) /= ''') then
|
||
for J in 1..LENGTH loop
|
||
if STR (J) in 'A'..'Z' then -- Convert to lower case
|
||
STR (J) := CHARACTER (INTEGER (STR (J)) + 32);
|
||
end if;
|
||
end loop;
|
||
end if;
|
||
PUT (FILE, STR (1..LENGTH));
|
||
for I in LENGTH + 1..WIDTH loop
|
||
PUT (FILE, ' ');
|
||
end loop;
|
||
end PUT;
|
||
|
||
procedure PUT (ITEM : in ENUM;
|
||
WIDTH : in FIELD := DEFAULT_WIDTH;
|
||
SET : in TYPE_SET := DEFAULT_SETTING) is
|
||
|
||
-- See chapter 14.3.9
|
||
|
||
begin
|
||
PUT (CURR_OUTPUT, ITEM, WIDTH, SET);
|
||
end PUT;
|
||
|
||
procedure GET (FROM : in STRING;
|
||
ITEM : out ENUM;
|
||
LAST : out POSITIVE) is
|
||
|
||
-- See chapter 14.3.9
|
||
|
||
CH : CHARACTER;
|
||
I : INTEGER := FROM'FIRST;
|
||
FI : INTEGER;
|
||
L : POSITIVE;
|
||
|
||
begin
|
||
loop
|
||
CH := FROM (I);
|
||
exit when (CH /= LF) or (CH /= CR) or (CH /= FF) or
|
||
(CH /= ' ') or (I = FROM'LAST);
|
||
I := I + 1;
|
||
end loop; -- Skipped leading blanks and line and page terminators
|
||
FI := I;
|
||
if CH = ''' then -- Special case: Character literal, for example 'A'
|
||
L := FI + 3;
|
||
ITEM := ENUM'VALUE (FROM (FI..L));
|
||
else -- Input an identifier
|
||
while LEGAL_ID_CHAR (FROM (I), I = FI) AND (I < FROM'LAST) loop
|
||
I := I + 1;
|
||
end loop;
|
||
if I = FROM'LAST then
|
||
L := I;
|
||
else
|
||
L := I - 1;
|
||
end if;
|
||
ITEM := ENUM'VALUE (FROM (FI..L));
|
||
end if;
|
||
LAST := L;
|
||
exception
|
||
when CONSTRAINT_ERROR => -- Raised by ENUM'VALUE
|
||
raise DATA_ERROR; -- This was an illegal enum identifier
|
||
end GET;
|
||
|
||
procedure PUT (
|
||
TO : out STRING;
|
||
ITEM : in ENUM;
|
||
SET : in TYPE_SET := DEFAULT_SETTING) is
|
||
|
||
-- See chapter 14.3.9
|
||
|
||
LENGTH : INTEGER;
|
||
STR : STRING (1..MAX_IDENT_LENGTH);
|
||
|
||
begin
|
||
ASSIGN_STR (STR, ENUM'IMAGE (ITEM), LENGTH);
|
||
if LENGTH > TO'LENGTH then
|
||
raise LAYOUT_ERROR;
|
||
end if;
|
||
if (SET = LOWER_CASE) AND (STR (1) /= ''') then
|
||
for J in 1..LENGTH loop
|
||
if STR (J) in 'A'..'Z' then -- Convert to lower case
|
||
STR (J) := CHARACTER (INTEGER (STR (J)) + 32);
|
||
end if;
|
||
end loop;
|
||
end if;
|
||
TO (TO'FIRST..TO'FIRST + LENGTH - 1) := STR (1..LENGTH);
|
||
for I in TO'FIRST + LENGTH..TO'LAST loop
|
||
TO (I) := ' ';
|
||
end loop;
|
||
end PUT;
|
||
|
||
end ENUMERATION_IO;
|
||
|
||
begin
|
||
-- Pre-opened files
|
||
DOS_INPUT := new FILE_DESCR'(
|
||
NAMELEN => 3, NAME => DOS_IO_NAME,
|
||
FORMLEN => 0, FORM => (others => ' '),
|
||
MODE => IN_FILE,
|
||
COL => 1,
|
||
LINE => 1, LINE_LENGTH => UNBOUNDED,
|
||
PAGE => 1, PAGE_LENGTH => UNBOUNDED,
|
||
HANDLE => IN_CONSOLE_HANDLE);
|
||
DOS_OUTPUT := new FILE_DESCR'(
|
||
NAMELEN => 3, NAME => DOS_IO_NAME,
|
||
FORMLEN => 0, FORM => (others => ' '),
|
||
MODE => OUT_FILE,
|
||
COL => 1,
|
||
LINE => 1, LINE_LENGTH => UNBOUNDED,
|
||
PAGE => 1, PAGE_LENGTH => UNBOUNDED,
|
||
HANDLE => OUT_CONSOLE_HANDLE);
|
||
CURR_INPUT := DOS_INPUT;
|
||
CURR_OUTPUT := DOS_OUTPUT;
|
||
end TEXT_IO;
|
||
|