OS_Develop/dos_compilers
OS_Develop/dos_compilers
1
0
Fork 0
Code Issues Pull Requests Actions Packages Projects Releases Wiki Activity
main
dos_compilers/Artek Ada v125/TEXTIOB.ADA

2417 lines
68 KiB
Plaintext
Raw Permalink Normal View History

Artek Ada v1.25
2024-07-08 18:31:49 +02:00
--
-- 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;

Reference in New Issue Copy Permalink