* Re: Image processing File I/O
1998-09-24 0:00 ` Dale Stanbrough
@ 1998-09-24 0:00 ` Michael F Brenner
0 siblings, 0 replies; 5+ messages in thread
From: Michael F Brenner @ 1998-09-24 0:00 UTC (permalink / raw)
In addition to Sequential IO on an 8-bit NUMERICAL byte type in
the old Ada 83, you could use Stream IO in Ada. Here is a package
that permits you to read and write binary data using Stream IO
in DOS, Windows, and Linux (you need to change the one line
that is marked for the directory separator, forward or backwards
slash).
The package HAND below makes stream IO streams look like ordinary
files by giving them handle numbers you can open, close, read from,
and right to. The two features used in Ada that were not present
in the old Ada 83 are the streams themselves, and 8-bit characters.
Of course, Ada still permits you to do sequential IO on files of
numerical 8-bit bytes, but timing tests on Solaris, DOS, and
Windows NT (using the DOS compiler) all show that, in these
environments, stream IO is now quicker. (Earlier versions of
gnat had sequential IO quicker).
-----------------------------------------------------------------
package string_control is
pragma pure (string_control);
-- Ordinary String control
function caselessly_equal (left, right: character)
return boolean;
function caselessly_equal (object: string; start, length: natural;
pattern: string)
return boolean;
procedure concat (message: character;
onto: in out string;
length: in out natural);
procedure concat (message: string;
onto: in out string;
length: in out natural);
-- First-missing and first-occurring return 0 when not found.
function first_missing (message: string;
pattern: character := ' ')
return integer;
function first_occurring (message: string;
pattern: character := ' ')
return integer;
function first_occurring (message: string;
pattern: string)
return integer;
function image (message: string)
return string;
procedure in_place_insert (message: in out string;
message_length: in out natural;
insertion: string;
after: natural);
function indent (message: string)
return string;
function length (message: string)
return natural;
-- Last-missing and last-occuring return 0 when not found.
function last_missing (message: string;
pattern: character := ' ')
return integer;
function last_occurring (message: string;
pattern: character := ' ')
return integer;
function left_trim (message: string;
pattern: character := ' ')
return string;
procedure lower_case (message: in out string;
start: natural;
finish: natural);
function lower_case (c: character)
return character;
function lower_case (message: string)
return string;
function right_trim (message: string;
pattern: character := ' ')
return string;
function quotes_are_good (message: string;
quote: character := '"')
return boolean;
procedure quotes_inserted (message: string;
result: in out string; -- 2+2*message'length
length: out natural;
quote: character := '"');
procedure quotes_removed (message: string;
result: in out string; -- message'length
length: out natural;
quote: character := '"');
function same (left, right: string)
return boolean;
function substitute (base_string: string;
search_string: string;
replace_string: string)
return string;
procedure upper_case (message: in out string;
start: natural;
finish: natural);
function upper_case (c: character)
return character;
function upper_case (message: string)
return string;
-- http://email:port/disk:file1/file2/.../filen#anchor?arg1?arg2?...?argk
--
-- @ Separators (://, :, /, #, ?)
-- @ Words (protocol, email, port, disk, file, anchor, arg)
-- @ Nonquoted words may contain alphanumerics, ~, _, !, @, -, and periods.
-- @ Quoted words may contain anything, doubling the quotes
procedure url_break_apart (url: string;
protocol_start: out natural;
protocol_finish: out natural;
internet_start: out natural;
internet_finish: out natural;
port_start: out natural;
port_finish: out natural;
disk_start: out natural;
disk_finish: out natural;
file_start: out natural;
file_finish: out natural;
anchor_start: out natural;
anchor_finish: out natural;
args_start: out natural;
args_finish: out natural);
-- Lexical classes are sets of characters, here represented as bits.
type classes is array(character) of boolean;
pragma pack (classes);
small_letter_class: constant classes :=
(character'first .. character'val (96) => false,
'a' .. 'z' => true,
'{' .. character'last => false);
capital_letter_class: constant classes :=
(character'first .. '@' => false,
'A' .. 'Z' => true,
'[' .. character'last => false);
alphabetic_class: constant classes :=
(character'first .. '@' => false,
'A' .. 'Z' => true,
'[' .. character'val (96) => false,
'a' .. 'z' => true,
'{' .. character'last => false);
digit_class: constant classes :=
(character'first .. '/' => false,
'0'..'9' => true,
':'..character'last => false);
sign_class: constant classes :=
(character'first .. character'pred ('+') => false,
'+' => true,
character'succ('+')..character'pred('-') => false,
'-' => true,
character'succ('-').. character'last => false);
digit_or_sign_class: constant classes :=
(character'first .. character'pred ('+') => false,
'+' => true,
character'succ('+')..character'pred('-') => false,
'-' => true,
character'succ('-')..character'pred('0') => false,
'0'..'9' => true,
character'succ('9')..character'last => false);
underline_class: constant classes :=
(character'first .. '^' => false,
'_' => true,
character'val (96) ..character'last => false);
alphanumeric_class: constant classes :=
(character'first .. '@' => false,
'A' .. 'Z' => true,
'[' .. '^' => false,
'_' => true,
character'val (96) => false,
'a' .. 'z' => true,
'{' .. character'last => false);
null_class: constant classes := (others => false);
-- The MATCH method searches for a character class in the MESSAGE,
-- returning the column in which the pattern was found,
-- otherwise returning zero.
type recognitions is record
RSTART, RLENGTH: natural;
end record;
function match (message: string; class: classes) return recognitions;
end string_control;
package body string_control is
function caselessly_equal (left, right: character) return boolean is
begin
return
left=right or else
(left in 'A'..'Z' and then right=character'val(character'pos(left)+32))
or else
(left in 'a'..'z' and then right=character'val(character'pos(left)-32));
end caselessly_equal;
function caselessly_equal (object: string; start, length: natural;
pattern: string) return boolean is
begin
if length /= pattern'length then return FALSE;
else
for i in 1..length loop
if not caselessly_equal (object (start + i - 1),
pattern (pattern'first + i - 1)) then
return FALSE;
end if;
end loop;
end if;
return TRUE;
end caselessly_equal;
procedure concat (message: character;
onto: in out string;
length: in out natural) is
concat_too_long: exception;
begin
if length + 1 > onto'length then
raise concat_too_long;
end if;
onto (length + 1) := message;
length := length + 1;
end concat;
procedure concat (message: string;
onto: in out string;
length: in out natural) is
concat_too_long: exception;
begin
if length + message'length > onto'length then
raise concat_too_long;
end if;
onto (length + 1 .. length + message'length) := message;
length := length + message'length;
end concat;
function first_missing (message: string;
pattern: character := ' ') return integer is
begin
for i in message'range loop
if message(i) /= pattern then
return i;
end if; -- message (message'first..i) are patterns.
end loop;
return 0; -- Returns the first column without PATTERN.
end first_missing;
function first_occurring (message: string;
pattern: character := ' ') return integer is
begin
for i in message'range loop
if message(i) = pattern then
return i; -- message contains the pattern
end if; -- message (message'first..i) contains no pattern
end loop;
return 0; -- message contains no pattern
end first_occurring;
function first_occurring (message: string; pattern: string)
return integer is
upto: natural := message'first;
last: integer := message'last + 1 - pattern'length;
in_first_occuring_the_pattern_is_null: exception;
RSTART: natural := 0;
begin
RSTART := 0;
if pattern="" then
raise in_first_occuring_the_pattern_is_null;
end if;
loop
exit when upto>last;
if message(upto..upto+pattern'length-1)=pattern then
RSTART := upto;
return RSTART;
end if;
upto := upto + 1;
end loop;
return 0;
end first_occurring;
function image (message: string) return string is
hold: string (1..message'length) := message;
begin
return hold;
end image;
procedure in_place_insert (message: in out string;
message_length: in out natural;
insertion: string;
after: natural) is
string_control_in_place_insert_ml_plus_il_gt_ml: exception;
begin
if message_length + insertion'length > message'length then
raise string_control_in_place_insert_ml_plus_il_gt_ml;
end if;
message(insertion'length + 1 + after .. message_length+insertion'length) :=
message(after+1..message_length);
message(after+1..after+insertion'length) := insertion;
message_length := message_length + insertion'length;
end in_place_insert;
function indent(message: string) return string is
begin
return (1..message'length + 1 => ' ');
end indent;
function last_missing (message: string;
pattern: character := ' ') return integer is
begin
for i in reverse message'range loop
if message(i) /= pattern then
return i;
end if; -- message (i..message'last) are patterns.
end loop;
return 0; -- Returns the last column without PATTERN.
end last_missing;
function last_occurring (message: string;
pattern: character := ' ') return integer is
begin
for i in reverse message'range loop
if message (i) = pattern then
return i;
end if; -- message (i..message'last) contains no pattern
end loop;
return 0; -- Returns the last column with PATTERN.
end last_occurring;
function left_trim (message: string;
pattern: character := ' ') return string is
left_trim_last: constant natural := first_missing (message, pattern);
begin
if left_trim_last = 0 then
return ""; -- blank not found at all means null string
else
return message (left_trim_last .. message'last);
end if;
end left_trim;
function length (message: string) return natural is
begin
return message'length;
end length;
function lower_case (c: character) return character is
begin
if c in 'A'..'Z' then
return character'val (character'pos (c) + 32);
end if;
return c;
end lower_case;
procedure lower_case (message: in out string;
start: natural; finish: natural) is
begin
for i in start..finish loop
if message (i) in 'A'..'Z' then
message (i) := character'val (character'pos (message (i)) + 32);
end if;
end loop;
end lower_case;
function lower_case (message: string) return string is
hold_message: string (1..message'length) := message;
ch: character;
offset: constant := character'pos ('a') - character'pos ('A');
begin
for c in hold_message'range loop
ch := hold_message (c);
if ch in 'A'..'Z' then
hold_message (c) := character'val (character'pos (ch) + offset);
end if; -- MESSAGE (FIRST..C) is in lower_case.
end loop;
return hold_message; -- MESSAGE is in lower_case.
end lower_case;
function match (message: string; class: classes) return recognitions is
recognition: recognitions;
RSTART: natural renames recognition.RSTART;
RLENGTH: natural renames recognition.RLENGTH;
upto: natural := message'first;
begin
RSTART := 0;
loop
exit when upto > message'last;
exit when class (message (upto)) ;
upto := upto + 1;
end loop;
if upto > message'last then
return (0, 0);
else
RSTART := upto;
end if;
loop
exit when upto > message'last;
exit when not class (message (upto));
upto := upto + 1;
end loop;
RLENGTH := upto - RSTART;
return recognition;
end match;
function quotes_are_good (message: string;
quote: character := '"')
return boolean is
input: natural := message'first + 1;
begin
if message'length<2 or else
message(message'first)/=quote or else
message(message'last) /=quote then
return false;
end if;
loop
exit when input >= message'length;
if message(input)/='"' then
input:=input+1;
elsif message(input+1)/='"' then
return false;
elsif input=message'length-1 then
return false;
else
input:=input+2;
end if;
end loop;
return true;
end quotes_are_good;
procedure quotes_inserted (message: string;
result: in out string; -- 2+2*message'length
length: out natural;
quote: character := '"') is
output: natural := 0;
begin
concat (quote, result, output);
for input in message'range loop
if message(input) = quote then
concat (quote, result, output);
concat (quote, result, output);
else
concat (message(input), result, output);
end if;
end loop;
concat (quote, result, output);
length := output;
end quotes_inserted;
procedure quotes_removed (message: string;
result: in out string; -- message'length
length: out natural;
quote: character := '"') is
output: natural := result'first - 1;
input: natural := message'first+1;
quotation_is_not_proper1: exception;
quotation_is_not_proper2: exception;
begin
if message'length < 2 or else
message(message'first) /= quote or else
message(message'last) /= quote then
output := message'length;
result(result'first-1+1..result'first-1+message'length) := message;
else
loop
exit when input>=message'last; -- Since message(message'last)=quote.
if message(input)/=quote then
concat(message(input), result, output);
elsif message(input+1) /= quote then
raise quotation_is_not_proper2;
else -- Two quotes in a row
concat(message(input), result, output);
input:=input+1;
end if;
input:=input+1;
end loop;
end if;
length := output;
end quotes_removed;
function right_trim (message: string;
pattern: character := ' ') return string is
right_trim_last: constant natural := last_missing (message, pattern);
begin
return message (message'first .. right_trim_last);
end right_trim;
function same (left, right: string) return boolean is
-- String Comparison: Semantically, left=right.
begin
return left'length = right'length and then
left = right;
end same;
function substitute (base_string: string;
search_string: string;
replace_string: string)
return string is
location: constant natural := first_occurring (base_string, search_string);
begin
if location = 0 then
return base_string;
elsif location = 1 then -- this requires the base_string to start at 1
return replace_string &
base_string (location+
search_string'length..
base_string'last);
elsif location = base_string'last + 1 - search_string'length then
return base_string (base_string'first..
base_string'last-search_string'length) &
replace_string;
else
declare
left_part: constant string :=
base_string (base_string'first..location - 1);
begin
return left_part &
replace_string &
base_string (location + search_string'length ..
base_string'last);
end;
end if;
end substitute;
function upper_case (c: character) return character is
begin
if c in 'a'..'z' then
return character'val (character'pos (c) - 32);
end if;
return c;
end upper_case;
procedure upper_case (message: in out string;
start: natural; finish: natural) is
begin
for i in start..finish loop
if message (i) in 'a'..'z' then
message (i) := character'val (character'pos (message (i)) - 32);
end if;
end loop;
end upper_case;
function upper_case (message: string) return string is
hold_message: string (1..message'length) := message;
ch: character;
offset: constant := character'pos ('a') - character'pos ('A');
begin
for c in hold_message'range loop
ch := hold_message (c);
if ch in 'a'..'z' then
hold_message (c) := character'val (character'pos (ch) - offset);
end if; -- MESSAGE (FIRST..C) is in upper_case.
end loop;
return hold_message; -- MESSAGE is in upper case.
end upper_case;
procedure get_url_word (message: string;
message_start: natural;
message_finish: natural;
word_start: out natural;
word_finish: out natural;
separator_start: out natural;
separator_finish: out natural;
separators: string := ":/#?") is
-- Example 1: ~_.!a.7.@
-- Example 2: "http://email.address/cgi/bin#query?""what """" quote"""
c: character;
hold_quote: character := ascii.nul;
upto: natural := message_start;
something_cannot_arise_from_nothing: exception;
unclosed_quote: exception;
single_quote: constant character := ''';
double_quote: constant character := '"';
quotes: constant string(1..2) := single_quote & double_quote;
begin
word_start := message_start;
if message_start > message_finish or
message_finish < message'first or
message_start > message'last then
raise something_cannot_arise_from_nothing;
end if;
-- The range message_start..message_finish in contained in MESSAGE.
if first_occurring (quotes, message (message_start)) /= 0 then
-- Quote at start.
hold_quote := message (upto);
upto := upto + 1;
loop
exit when upto > message_finish;
c := message (upto);
if c = hold_quote then
if upto < message_finish and then
message (upto+1) = hold_quote then
upto := upto + 1;
else
word_finish := upto;
separator_start := upto+1;
separator_finish := upto+1;
return;
end if;
end if;
upto := upto + 1;
end loop;
raise unclosed_quote;
else -- No quote at start.
loop
exit when upto > message_finish;
c := message (upto);
if first_occurring (separators, c) /= 0 then
word_finish := upto-1;
separator_start := upto;
loop
exit when upto > message_finish;
c := message (upto);
exit when first_occurring (separators, c) = 0;
upto := upto + 1;
end loop;
separator_finish := upto - 1;
return;
end if;
upto := upto + 1;
end loop;
word_finish := upto - 1;
separator_start := upto;
separator_finish := 0;
end if;
end get_url_word;
procedure url_break_apart (url: string;
protocol_start: out natural;
protocol_finish: out natural;
internet_start: out natural;
internet_finish: out natural;
port_start: out natural;
port_finish: out natural;
disk_start: out natural;
disk_finish: out natural;
file_start: out natural;
file_finish: out natural;
anchor_start: out natural;
anchor_finish: out natural;
args_start: out natural;
args_finish: out natural) is
-- Under NT 4.0 the following rules apply:
-- @ the file part goes up to 255 characters long
-- @ permit as many periods anywhere in the file
-- @ forbid characters: question mark and asterisk in a file
-- @ permit as many blanks in the middle of the file
-- @ strip off all blanks at the beginning and end of the file's name
--
-- This code currently compiles under the first two rules, and
-- does not enforce the other 3 rules.
ws, wf, ss, sf: natural;
sl: integer;
type separators is (error, colon_slash_slash, colon, other, none);
separator: separators := error;
separator_c: character;
not_a_url: exception;
procedure ts_get_url_word is -- for unit test only
type expected_results is array (1..4) of natural;
ws, wf, ss, sf: natural; -- set by get_word
message1: constant string (2..19) := "~_.!a.7.@://aaa#b?";
message2: constant string (1..15) := """what """" quote""";
ts_get_url_word_failed: exception;
begin
get_url_word (message1, 2, 12, ws, wf, ss, sf);
if ws /= 2 then raise ts_get_url_word_failed;
elsif wf /= 10 then raise ts_get_url_word_failed;
elsif ss /= 11 then raise ts_get_url_word_failed;
elsif sf /= 12 then raise ts_get_url_word_failed;
end if;
get_url_word (message1, 15, 19, ws, wf, ss, sf);
if ws /= 15 or wf /=16 or ss /= 17 or sf /= 17 then
raise ts_get_url_word_failed;
end if;
get_url_word (message2, 1, 15, ws, wf, ss, sf);
if ws /= 1 then raise ts_get_url_word_failed;
elsif wf /= 15 then raise ts_get_url_word_failed;
elsif ss /= 16 then raise ts_get_url_word_failed;
elsif sf /= 16 then raise ts_get_url_word_failed;
end if;
end ts_get_url_word;
begin
ts_get_url_word;
protocol_start := 0;
protocol_finish := 0;
internet_start := 0;
internet_finish := 0;
port_start := 0;
port_finish := 0;
disk_start := 0;
disk_finish := 0;
file_start := 0;
file_finish := 0;
anchor_start := 0;
anchor_finish := 0;
args_start := 0;
args_finish := 0;
get_url_word (url, url'first, url'last, ws, wf, ss, sf);
sl:=sf+1-ss;
if ss not in url'first..url'last then
separator := none;
elsif sl=3 and then url (ss..sf) = "://" then -- it is a full URL
separator := colon_slash_slash;
elsif sl=1 and then url (ss) = ':' then -- it is a disk drive
separator := colon;
else
separator := other;
end if;
case separator is
when error => raise not_a_url;
when colon_slash_slash =>
protocol_start := ws;
protocol_finish := wf;
get_url_word (url, sf+1, url'last, ws, wf, ss, sf);
internet_start := ws;
internet_finish := wf;
if ss in url'range and then ss=sf and then url (ss) = ':' then -- port
get_url_word (url, sf+1, url'last, ws, wf, ss, sf);
port_start := ws;
port_finish := wf;
end if;
if ss not in url'range or else ss/=sf or else url (ss) /= '/' then
return;
end if;
get_url_word (url, sf+1, url'last, ws, wf, ss, sf);
when colon => null;
when none => null;
when other => null;
end case;
if ss=sf and ss in url'range then
separator_c := url (ss);
else
separator_c := ascii.lf;
end if;
if separator_c = ':' then
disk_start := ws;
disk_finish := wf;
get_url_word (url, sf+1, url'last, ws, wf, ss, sf);
end if;
if ss=sf and ss in url'range then
separator_c := url (ss);
else
separator_c := ascii.lf;
end if;
file_start := ws;
loop
file_finish := wf;
exit when separator_c /= '/';
get_url_word (url, sf+1, url'last, ws, wf, ss, sf);
if ss=sf and ss in url'range then
separator_c := url (ss);
else
separator_c := ascii.lf;
end if;
end loop;
if separator_c = '#' then -- that is, the PRIOR separator
get_url_word (url, sf+1, url'last, ws, wf, ss, sf);
if ss=sf and ss in url'range then
separator_c := url (ss);
else
separator_c := ascii.lf;
end if;
anchor_start := ws;
anchor_finish := wf;
end if;
if separator_c = '?' then -- that is, the PRIOR separator
get_url_word (url, sf+1, url'last, ws, wf, ss, sf);
args_start := ws;
loop
get_url_word (url, sf+1, url'last, ws, wf, ss, sf);
exit when ss /= sf or else ss not in url'range or else url (ss) /= '?';
end loop;
args_finish := wf;
end if;
end url_break_apart;
end string_control;
package variable_string_control is
pragma pure (variable_string_control);
-- Variable strings are each allocated to any maximum length, and vary
-- from 0 to that maximum in length. Compiler enforces specifying that
-- maximum length when each variable is declared.
type variable_strings (size: positive) is limited private;
-- The concatenation of variable strings is an unconstrained string.
function "&" (left: variable_strings;
right: variable_strings)
return string;
function "&" (left: string;
right: variable_strings)
return string;
function "&" (left: variable_strings;
right: string)
return string;
-- When strings agree up to the minimum of their lengths,
-- the shorter string is considered less than the longer string.
function "<" (left, right: variable_strings) return boolean;
function ">" (left, right: variable_strings) return boolean;
function "<=" (left, right: variable_strings) return boolean;
function ">=" (left, right: variable_strings) return boolean;
-- COPY is used to change variable strings.
procedure copy (source: variable_strings; target: in out variable_strings);
procedure copy (source: string; target: in out variable_strings);
-- The concatenation method is used to append onto the end of a v string.
procedure concat(appendage: string;
onto: in out variable_strings);
procedure concat(appendage: variable_strings;
onto: in out variable_strings);
-- The ELEMENT method returns a column of a variable string just like
-- array references get columns from ordinary_strings.
function element (message: variable_strings;
col: natural) return character;
-- The IMAGE method returns the string image of a variable string.
function image (message: variable_strings) return string;
-- The in_place_lower_case function converts
-- alphabetic character from upper to lower
-- case, ignoring all other characters.
procedure in_place_lower_case (message: in out variable_strings);
-- The in_place_truncate method is a procedure instead of a function,
-- for efficiency.
procedure in_place_truncate (message: in out variable_strings;
ch: character := ' ');
-- The in_place_upper_case function converts
-- alphabetic character from lower to upper
-- case, ignoring all other characters.
procedure in_place_upper_case (message: in out variable_strings);
-- The LENGTH method returns the length of the variablestring.
function length (message: variable_strings) return natural;
-- The length_allocated returns the maximum length of the v string.
function length_allocated (message: variable_strings) return natural;
-- The SAME method is the equality operator for variable strings. To
-- be equal, the two strings must be of the same length, and agree
-- for each of their characters.
function same (left, right: variable_strings) return boolean;
function same (left: variable_strings; right: string) return boolean;
-- The set_element method sets a character in a single column
-- of a variable string like array references do for character
-- strings.
procedure set_element (message: in out variable_strings;
col: natural;
value: character);
-- The set_length method truncates a string to a given length or else
-- extends its current length with blanks.
procedure set_length (message: in out variable_strings;
new_length: natural);
-- The SLICE method emulates array slices for variable strings. The
-- SUBSTR method is similar, but based on length instead of final column.
-- The two-argument SUBSTR gets all characters on or after the given column.
-- All of these permit the START argument to take on a value equal to the
-- length of the variable string plus 1, returning the null ordinary_string.
function slice (message: variable_strings;
start, finish: natural) return string;
function substr (message: variable_strings;
start, length: natural) return string;
function substr (message: variable_strings;
start: natural) return string;
private
type variable_strings (size: positive) is record
length: integer := -1; -- Causes arrays of strings to fully Allocate.
list: string (1..size);
end record;
end variable_string_control;
ith string_control;
package body variable_string_control is
procedure is_okay (message: variable_strings) is
varstring_never_init: exception;
begin
if message.length < 0 then
raise varstring_never_init;
end if;
end is_okay;
function "&" (left: variable_strings;
right: variable_strings)
return string is
hold: variable_strings (left.length + right.length);
begin
is_okay (left);
is_okay (right);
copy (left, hold);
concat (right.list(1..right.length), onto=>hold);
return hold.list(1..hold.length);
end "&";
function "&" (left: string; right: variable_strings) return string is
hold: variable_strings (left'length + right.length);
begin
is_okay (right);
copy (left, hold);
concat (right.list(1..right.length), onto=>hold);
return hold.list(1..hold.length);
end "&";
function "&" (left: variable_strings; right: string) return string is
hold: variable_strings (left.length + right'length);
begin
is_okay (left);
copy (left, hold);
concat (right, onto=>hold);
return hold.list(1..hold.length);
end "&";
function "<" (left, right: variable_strings) return boolean is
begin
is_okay(left);
is_okay(right);
if left.length < right.length then
return left.list(1..left.length) <= right.list(1..left.length);
elsif left.length = right.length then
return left.list(1..left.length) < right.list(1..left.length);
else -- left.length > right.length
return left.list(1..right.length) < right.list(1..right.length);
end if;
end "<";
function ">" (left, right: variable_strings) return boolean is
begin
is_okay(left);
is_okay(right);
if left.length < right.length then
return left.list(1..left.length) > right.list(1..left.length);
elsif left.length = right.length then
return left.list(1..left.length) > right.list(1..left.length);
else -- left.length > right.length
return left.list(1..right.length) >= right.list(1..right.length);
end if;
end ">";
function "<=" (left, right: variable_strings) return boolean is
begin
return left < right or else left = right;
end "<=";
function ">=" (left, right: variable_strings) return boolean is
begin
return left > right or else left = right;
end ">=";
procedure concat(appendage: string; onto: in out variable_strings) is
new_length: constant integer := onto.length + appendage'length;
concat_string_onto_varstring_too_long: exception;
begin
is_okay (onto);
if new_length > onto.size then
raise concat_string_onto_varstring_too_long;
end if;
onto.list(onto.length+1..new_length) := appendage;
onto.length := new_length;
end concat;
procedure concat(appendage: variable_strings;
onto: in out variable_strings) is
new_length: constant integer := onto.length + appendage.length;
concat_varstring_onto_varstring_too_long: exception;
begin
is_okay (onto);
if new_length > onto.size then
raise concat_varstring_onto_varstring_too_long;
end if;
onto.list(onto.length+1..new_length) :=
appendage.list(1..appendage.length);
onto.length := new_length;
end concat;
procedure copy (source: variable_strings; target: in out variable_strings) is
copy_varstring_to_varstring_too_long: exception;
begin
is_okay (source);
if source.length > target.size then
raise copy_varstring_to_varstring_too_long;
end if;
target.length := source.length;
target.list (1..source.length) := source.list (1..source.length);
end copy;
procedure copy (source: string; target: in out variable_strings) is
copy_string_to_varstring_too_long: exception;
begin
if source'length > target.size then
raise copy_string_to_varstring_too_long;
end if;
target.length := source'length;
if source'length>0 then
target.list (1..source'length) := source;
end if;
end copy;
function element (message: variable_strings;
col: natural) return character is
varstring_element_out_of_range: exception;
begin
is_okay (message);
if col not in 1..message.length then
raise varstring_element_out_of_range;
end if;
return message.list (col);
end element;
function image (message: variable_strings) return string is
begin
is_okay (message);
if message.length=0 then return "";
else return message.list (1..message.length);
end if;
end image;
procedure in_place_lower_case (message: in out variable_strings) is
begin
is_okay (message);
for i in 1..message.length loop
message.list(i) := string_control.lower_case (message.list(i));
end loop;
end in_place_lower_case;
procedure in_place_truncate (message: in out variable_strings;
ch: character := ' ') is
begin
is_okay (message);
loop
exit when message.length = 0;
exit when message.list (message.length) /= ch;
message.length := message.length - 1;
end loop;
end in_place_truncate;
procedure in_place_upper_case (message: in out variable_strings) is
begin
is_okay (message);
for i in 1..message.length loop
message.list(i) := string_control.upper_case (message.list(i));
end loop;
end in_place_upper_case;
function length (message: variable_strings) return natural is
begin
is_okay (message);
return message.length;
end length;
function length_allocated (message: variable_strings) return natural is
begin
return message.size;
end length_allocated;
function same (left, right: variable_strings) return boolean is
begin
is_okay (left);
is_okay(right);
return left.length=right.length and then
left.list(1..left.length) = right.list(1..left.length);
end same;
function same (left: variable_strings; right: string) return boolean is
begin
is_okay (left);
return left.length=right'length and then
left.list(1..left.length) = right;
end same;
procedure set_element (message: in out variable_strings;
col: natural;
value: character) is
varstring_set_element_index_out_of_range: exception;
varstring_set_element_index_way_out_of_range: exception;
begin
is_okay (message);
if col > message.size then
raise varstring_set_element_index_way_out_of_range;
elsif col = message.length+1 then
message.length := message.length + 1;
message.list (col) := value;
elsif col > message.length then
raise varstring_set_element_index_out_of_range;
else
message.list (col) := value;
end if;
end set_element;
procedure set_length (message: in out variable_strings;
new_length: natural) is
hold_length: integer := message.length;
varstring_set_length_too_long: exception;
begin
if hold_length > message.size then
raise varstring_set_length_too_long;
end if;
message.length := new_length;
if hold_length < 0 then
for i in 1..message.size loop
message.list (i) := ' ';
end loop;
end if;
if hold_length > 0 then
for i in hold_length+1 .. new_length loop
message.list (i) := ' ';
end loop;
end if;
end set_length;
function slice (message: variable_strings;
start, finish: natural) return string is
varstring_slice_start_out_of_range: exception;
varstring_slice_finish_out_of_range: exception;
begin
is_okay (message);
if start not in 1..message.length then
raise varstring_slice_start_out_of_range;
elsif finish not in 0..message.length then
raise varstring_slice_finish_out_of_range;
end if;
if finish < start then
return "";
else
declare
hold: constant string (1..finish+1-start) :=
message.list(start..finish);
begin
return hold;
end;
end if;
end slice;
function substr (message: variable_strings;
start, length: natural) return string is
begin
is_okay (message);
return slice (message, start, start+length-1);
end substr;
function substr (message: variable_strings;
start: natural)
return string is
begin
is_okay (message);
return slice (message, start, message.length);
end substr;
end variable_string_control;
with system;
package hand is
pragma elaborate_body;
-- Purpose:
--
-- Provide OS binding to file open, read, write, position, close
--
-- Warning: To compute the system.address do this: message(1)'address
--
--
-- Architecture:
--
-- ADO (Abstract Data Object)
-- SIS (Semantically Independent Specification)
type handles is range -1..32;
for handles'size use 16;
null_handle: constant handles := 0;
broken_handle: constant handles := -1; -- File does not exist.
standard_input: constant handles := 0;
standard_output: constant handles := 1;
standard_error: constant handles := 2;
type open_methods is (read_open, write_open, append_open);
type seek_methods is (from_BOF, from_current, from_EOF);
type file_positions is range -2147483648 .. 2147483647;
subtype string_8 is string (1..8);
subtype string_12 is string (1..12);
already_internally_open: exception;
could_not_check: exception;
could_not_create: exception;
could_not_open: exception;
could_not_read: exception;
could_not_reposition: exception;
could_not_seek: exception;
missing_slash_at_end_of_path: exception;
procedure close (handle: handles);
procedure commit (handle: handles);
function create (name: string)
return handles;
procedure create_unique (path: string;
name: out string;
handle: out handles);
function image (handle: handles)
return string;
function is_standard_input (handle: handles)
return boolean;
function is_standard_output (handle: handles)
return boolean;
function open (name: string;
open_method: open_methods)
return handles;
function position (handle: handles)
return file_positions;
procedure read (whereto: system.address;
length: in out file_positions;
handle: handles);
function seek (handle: handles;
position: file_positions;
seek_method: seek_methods)
return file_positions;
function size (handle: handles)
return file_positions;
procedure write (whereto: system.address;
length: in out file_positions;
handle: handles);
end hand;
with Ada.IO_exceptions;
with Ada.streams.stream_io;
with Ada.text_io.text_streams;
with variable_string_control;
package body hand is
-- compiler_this_package_is_dependent_on: constant string := "any Ada 95";
use Ada.streams.stream_io;
directory_separator: constant character := '\'; -- change to '/' for Linux
type unique_counts is mod 4;
unique_count: unique_counts := 0;
-- Streams
type selfs is record
soul: file_type;
incarnated: boolean:=false;
end record;
subtype usable_handles is handles range 3 .. handles'last;
type universes is array (usable_handles) of selfs;
self: universes;
handle_is_not_incarnated: exception;
procedure check (handle: handles; message: string) is
begin
if handle in usable_handles then
if not self (handle).incarnated then
raise handle_is_not_incarnated;
end if;
end if;
end check;
function stream (handle: handles) return stream_access is
broken_handle_detected: exception;
begin
case handle is
when standard_input=>
return Ada.streams.stream_io.stream_access(
Ada.text_io.text_streams.stream(Ada.text_io.standard_input));
when standard_output=>
return Ada.streams.stream_io.stream_access(
Ada.text_io.text_streams.stream(Ada.text_io.standard_output));
when standard_error =>
return Ada.streams.stream_io.stream_access(
Ada.text_io.text_streams.stream(Ada.text_io.standard_error));
when broken_handle=>
raise broken_handle_detected;
when usable_handles=>
return stream (self (handle).soul);
end case;
end stream;
function available return handles is
begin
for handle in usable_handles loop
if not self (handle).incarnated then
self (handle).incarnated := true;
return handle;
end if;
end loop;
raise could_not_create;
end available;
procedure commit (handle: handles) is
begin
check (handle, "commit");
if handle in usable_handles then
flush (self (handle).soul);
else
null;
end if;
end commit;
procedure close (handle: handles) is
begin
if handle in usable_handles then
-- Handle is not checked, so failed-open handles can be closed.
if self (handle).incarnated then
close (self (handle).soul);
self (handle).incarnated := false;
end if;
end if;
exception
when Ada.IO_exceptions.status_error =>
self (handle).incarnated := false;
end close;
function image (handle: handles) return string is
begin
return handles'image (handle);
end image;
function is_standard_input (handle: handles) return boolean is
begin
return handle=standard_input;
end is_standard_input;
function is_standard_output (handle: handles) return boolean is
begin
return handle=standard_output;
end is_standard_output;
function create (name: string) return handles is
handle: handles;
could_neither_create_it_nor_open_it_for_output: exception;
use variable_string_control;
begin
if name'length=0 then
handle := standard_output;
else
handle := available;
create (self (handle).soul, out_file, name);
end if;
return handle;
exception
when Ada.IO_exceptions.name_error =>
open (self (handle).soul, out_file, name);
return handle;
when Ada.IO_exceptions.use_error =>
begin
open (self (handle).soul, out_file, name);
return handle;
exception
when Ada.IO_exceptions.use_error =>
raise could_neither_create_it_nor_open_it_for_output;
return broken_handle;
end;
end create;
procedure create_unique (path: string;
name: out string;
handle: out handles) is
unique_image: string:=unique_counts'image(unique_count);
random_string: constant string := "tempxxx" &
unique_image(unique_image'first + 1) & ".tmp"; -- 9 only ?
-- random_string: constant string := "tempxxxx.tmp";
full_path: string := path & random_string;
begin
unique_count := unique_count + 1;
if path'length /= 0 and then
path (path'last) /= directory_separator then
raise missing_slash_at_end_of_path;
end if;
handle := create (full_path);
name := full_path (path'length+1 .. path'length+random_string'length);
end create_unique;
function open (name: string;
open_method: open_methods)
return handles is
handle: handles;
file_position: file_positions := 0;
use variable_string_control;
begin
if name'length=0 then
case open_method is
when read_open =>
handle := standard_input;
when write_open =>
handle := standard_output;
when append_open=>
handle := standard_output;
end case;
else
handle := available;
case open_method is
when read_open =>
open (self (handle).soul, in_file, name);
when write_open =>
open (self (handle).soul, out_file, name);
when append_open=>
open (self (handle).soul, append_file, name);
file_position := seek (handle, 0, from_EOF);
-- redundant because of bug in gnat 3.10. Needed in gnat3.11?
end case;
end if;
return handle;
exception
when Ada.IO_exceptions.name_error =>
self (handle).incarnated := false;
return broken_handle;
end open;
function position (handle: handles) return file_positions is
standard_handles_cannot_be_positioned: exception;
begin
check (handle, "position");
if handle not in usable_handles then
raise standard_handles_cannot_be_positioned;
end if;
return file_positions (index (self(handle).soul)) - 1;
end position;
procedure read (whereto: system.address;
length: in out file_positions;
handle: handles) is
use Ada.streams;
subtype buffers is stream_element_array(1..stream_element_offset(length));
buffer: buffers;
for buffer use at whereto;
seo: stream_element_offset:=stream_element_offset(length);
begin
check (handle, "read");
read(stream (handle).all, buffer, seo);
length:=file_positions(seo);
end read;
function is_keyboard_device (handle: handles) return boolean is
begin
return false; --?
end is_keyboard_device;
function seek (handle: handles;
position: file_positions;
seek_method: seek_methods)
return file_positions is
cannot_seek_standard_handles: exception;
p: constant file_positions := position + 1;
here: constant file_positions := hand.position (handle);
begin
check (handle, "seek");
if handle in usable_handles then
declare
file: file_type renames self(handle).soul;
begin
case seek_method is
when from_BOF=>
set_index (file, positive_count (p));
when from_EOF=>
set_index (file, positive_count (file_positions(size(file)) + p));
when from_current=>
set_index (file, positive_count (here + P));
end case;
return file_positions(index (file))-1;
end;
else
raise cannot_seek_standard_handles;
end if;
end seek;
function size (handle: handles) return file_positions is
my_size: count;
signed_size: file_positions;
begin
check (handle, "size");
if handle in usable_handles then
my_size := size (self (handle).soul);
signed_size := file_positions(my_size);
return signed_size;
else
return 0;
end if;
end size;
procedure write (whereto: system.address;
length: in out file_positions;
handle: handles) is
use Ada.streams;
subtype buffers is stream_element_array(1..stream_element_offset(length));
buffer: buffers;
for buffer use at whereto;
begin
check (handle, "write");
write (stream (handle).all, buffer);
end write;
end hand;
-------------------------------------------------------------------------------
^ permalink raw reply [flat|nested] 5+ messages in thread