From mboxrd@z Thu Jan 1 00:00:00 1970 X-Spam-Checker-Version: SpamAssassin 3.4.4 (2020-01-24) on polar.synack.me X-Spam-Level: X-Spam-Status: No, score=-1.9 required=5.0 tests=BAYES_00, T_FILL_THIS_FORM_SHORT,WEIRD_QUOTING autolearn=ham autolearn_force=no version=3.4.4 X-Google-Language: ENGLISH,ASCII-7-bit X-Google-Thread: 103376,fba0bee5733dc30e X-Google-Attributes: gid103376,public From: mfb@mbunix.mitre.org (Michael F Brenner) Subject: Re: Image processing File I/O Date: 1998/09/24 Message-ID: <6udfdv$cl3@top.mitre.org> X-Deja-AN: 394357174 References: <360a1583.9058580@news.kreonet.re.kr> Organization: The MITRE Corporation, Bedford Mass. Newsgroups: comp.lang.ada Date: 1998-09-24T00:00:00+00:00 List-Id: 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; -------------------------------------------------------------------------------