-- CORLPACK -- Package of utility functions for application developers
-- Copyright (c) 2012,2013 Alexandru Dan Corlan M.D. PhD
--
-- Home page: http://dan.corlan.net/software/corlpack
--
-- CORLPACK is free software; you can redistribute it and/or modify it
-- under terms of the GNU General Public License as published by the
-- Free Software Foundation; either version 3, or (at your option)
-- any later version. CORLPACK is distributed in the hope that it
-- will be useful, but WITHOUT ANY WARRANTY; without even the
-- implied warranty of MERCHANTABILITY or FITNESS FOR A PARTICULAR
-- PURPOSE. As a special exception under Section 7 of GPL version 3,
-- you are granted additional permissions described in the GCC
-- Runtime Library Exception, version 3.1, as published by the Free
-- Software Foundation, only for the packages (not for the tests
-- and utilities) included in this distribution.
--
-- You should have received a copy of the GNU General Public License
-- and a copy of the GCC Runtime Library Exception along with this
-- program; see the files COPYING3 and COPYING.RUNTIME respectively.
-- If not, see .
--
-- CORLPACK tries to make programming in Ada more strightforward for the
-- novice programmer as well as for the non-IT specialist needing a
-- basic library for simple computational applications.
-- Release 0.4.2, january 8, 2013 (alpha):
-- Added matrices, lists and pointers as structures inside a vector of UUIDs.
-- Support for pluggable loaders and savers of files of various formats
-- into/from UUID vectors.
-- Release 0.4.1, january 1, 2013 (alpha):
--
-- Extended UUID suport for PubMed ID (pmid), Unique ingredient identifier (unii)
-- Logical Intervention Indentifiers, Names and Codes (loinc),
-- webcitation (wbct)
-- Release 0.4, december 27, 2012 (alpha):
--
-- complete UUID APIs with pluggable types (by registering make, read and format
-- methods for new uuid types); corlpack.issn as an example
-- added VUUIDs, vectors of (extended) uuids
-- added string UUIDs that do not exist independently, but as a data structure
-- inside a VUUID (or represented by an uuid)
-- fixed some errors in reading/writing time
-- more tests
-- Release 0.3, october 18, 2012 (alpha):
--
-- - support for reading and writing RFC-4122 UUIDs
-- - extended UUID scheme, providing, besides symbols, for physical units
-- and ammounts, time, financial ammounts, serial numbering schemes
-- Release 0.2, october 4, 2012 (alpha):
--
-- - simplified I/O, numerics and random generation functions
-- - support for symbols unified with UUIDs
-- - an R-like data structure: named lists and vectors
with Ada.Text_Io; use Ada.Text_Io;
with Ada.Strings.Unbounded; use Ada.Strings.Unbounded;
with Ada.Numerics; use Ada.Numerics;
with Ada.Numerics.Float_Random; use Ada.Numerics.Float_Random;
with Ada.Numerics.Generic_Elementary_Functions;
with Ada.Finalization; use Ada.Finalization;
with Ada.Unchecked_Deallocation;
with Direct_Io;
with Ada.Characters;
with Ada.Characters.Handling; use Ada.Characters.Handling;
with Ada.Io_Exceptions;
with Ada.Command_Line; use Ada.Command_Line;
with Ada.Calendar; use Ada.Calendar;
with Gnat.Calendar; use Gnat.Calendar;
with Gnat.Calendar.Time_Io;
with Ada.Exceptions; use Ada.Exceptions;
with Ada.Unchecked_Conversion;
package Corlpack is
pragma Elaborate_Body(Corlpack);
type Real is digits 18;
subtype Text is Unbounded_String;
type Int is new Long_Long_Integer;
function To_Text(Source: String) return Text renames Ada.Strings.Unbounded.To_Unbounded_String;
function To_String(Source: Text) return String renames Ada.Strings.Unbounded.To_String;
function To_Upper(S: String) return String;
function To_Lower(S: String) return String;
Empty_Text: Text:= To_Text("");
package Real_Fun is new Ada.Numerics.Generic_Elementary_Functions(Real);
function Sqrt(X: Real) return Real renames Real_Fun.Sqrt;
function Log (X: Real) return Real renames Real_Fun.Log;
function Log (X, Base: Real) return Real renames Real_Fun.Log;
function Exp (X: Real) return Real renames Real_Fun.Exp;
function "**" (Left, Right : Real) return Real renames Real_Fun."**";
function Sin (X: Real) return Real renames Real_Fun.Sin;
function Cos (X: Real) return Real renames Real_Fun.Cos;
function Tan (X: Real) return Real renames Real_Fun.Tan;
function Cot (X: Real) return Real renames Real_Fun.Cot;
function Arcsin (X: Real) return Real renames Real_Fun.Arcsin;
function Arccos (X: Real) return Real renames Real_Fun.Arccos;
function Arctan (Y: Real; X: Real := 1.0) return Real renames Real_Fun.Arctan;
function Arccot (X: Real; Y: Real := 1.0) return Real renames Real_Fun.Arccot;
function Sinh (X: Real) return Real renames Real_Fun.Sinh;
function Cosh (X: Real) return Real renames Real_Fun.Cosh;
function Tanh (X: Real) return Real renames Real_Fun.Tanh;
function Coth (X: Real) return Real renames Real_Fun.Coth;
function Arcsinh (X: Real) return Real renames Real_Fun.Arcsinh;
function Arccosh (X: Real) return Real renames Real_Fun.Arccosh;
function Arctanh (X: Real) return Real renames Real_Fun.Arctanh;
function Arccoth (X: Real) return Real renames Real_Fun.Arccoth;
Version: Real := 20121004.0;
function Read return String; -- reads standard input in a very basic way
function Read return Text;
function Read return Float;
function Read return Long_Float;
function Read return Long_Long_Float;
function Read return Real;
function Read return Integer;
function Format(V: Real; Width: Integer:= 10; Decimals: Integer:= 2; Exp: Integer:= 0) return String;
function Format(K: Int; Width: Integer:= 1) return String;
function Format(K: Integer; Width: Integer:= 1) return String;
function Format(K: Boolean; Width: Integer:= 1) return String;
procedure Write(S: String; Width: Integer:= 0);
procedure Write(T: Text; Width: Integer:= 0);
procedure Write(V: Float; Width: Integer:= 10; Decimals: Integer:= 2; Exp: Integer:= 0);
procedure Write(V: Long_Float; Width: Integer:= 10; Decimals: Integer:= 2; Exp: Integer:= 0);
procedure Write(V: Real; Width: Integer:= 10; Decimals: Integer:= 2; Exp: Integer:= 0);
procedure Write(K: Long_Integer; Width: Integer:= 1);
procedure Write(K: Long_Long_Integer; Width: Integer:= 1);
procedure Write(K: Integer; Width: Integer:= 1);
procedure Write(K: Boolean; Width: Integer:= 1);
procedure Write(Into: in out Text; S: String; Width: Integer:= 0);
procedure Write(Into: in out Text; T: Text; Width: Integer:= 0);
procedure Write(Into: in out Text; V: Float;
Width: Integer:= 10;
Decimals: Integer:= 2; Exp: Integer:= 0);
procedure Write(Into: in out Text; V: Long_Float;
Width: Integer:= 10; Decimals: Integer:= 2; Exp: Integer:= 0);
procedure Write(Into: in out Text; V: Real;
Width: Integer:= 10; Decimals: Integer:= 2; Exp: Integer:= 0);
procedure Write(Into: in out Text; K: Long_Integer; Width: Integer:= 1);
procedure Write(Into: in out Text; K: Int; Width: Integer:= 1);
procedure Write(Into: in out Text; K: Long_Long_Integer; Width: Integer:= 1);
procedure Write(Into: in out Text; K: Integer; Width: Integer:= 1);
procedure Write(Into: in out Text; K: Boolean; Width: Integer:= 1);
procedure Nl(Spacing : in Positive_Count := 1) renames Ada.Text_Io.New_Line;
procedure Nl(Into: in out Text; Spacing: in Positive_Count := 1);
procedure Load(T: in out Text; Filename: String);
procedure Save(Object: Text;
Filename: String;
Append: Boolean:= False;
Format: String:= "text";
Lock: String:= "process");
-- the object is saved in a new file and left unchanged; if append
-- is true, then the file must exist, it is not created and the
-- objects is added to the file; only the text format is currently
-- supported and only text objects locking is only implemented at
-- the process level (that is, between tasks in the same process);
-- in the future, locking at the operating system level or at
-- other levels to be specified by the lock syntax in the future
-- say 'none' or anything else to avoid locking
procedure Log(Object: in out Text;
Filename: String;
Format: String:= "text";
Lock: String:= "process");
-- the text is appended (as with Save(... append => true)) to the file
-- that must already exist;
-- the text is then cleared (made empty) allowing further log text
-- accumulation
-- string functions
function Trim(S: String) return String;
-- return the same string, indexed from 1, without
-- initial or trailing space characters
function Moment_Random return Integer;
-- returns a new random each run; you can initialize (reset) the generator
-- with the above value in order to avoid having the same sequence of numbers
-- at each run.
function Random(N: Integer) return Integer; -- 1..N
function Random(Distribution: String:= "uniform"; -- can also be 'normal' meaning truncated Gaussian
Min: Real:= 0.0;
Max: Real:= 1.0;
M1: Real:= 0.0; -- mu for a normal
M2: Real:= 1.0 -- standard deviation for a normal
) return Real;
procedure Reset_Generator(Seed: Integer);
procedure Reset_Generator(State: String);
function Generator_State return String;
Bad_Random_Generator_Parameters: exception;
-- time
subtype Time is Ada.Calendar.Time;
function Clock return Time renames Ada.Calendar.Clock;
function To_String(T: Time; Accuracy: Positive:= 10) return String;
-- uuid
type Uuid is record
Lo,Hi: Long_Long_Integer;
end record;
pragma Pack(Uuid);
type Corlidtype is (Fixed_Bitvec, -- only the type is specified, 120 bits
Serial_Bitvec, -- only the type is specified, 120 bits
Vector_Bitvec, -- only the type is specified, 120 bits
Fixed_B7, -- 15 bits overhead + 6*7 + 64 = 121 (1 bit left); 4 decimals assumed
Sym_A18, -- only the symbol, no place for serial
Sym_B18, -- only the symbol, no place for serial
Sym_C22, -- only the symbol, no place for serial
Serial_C3, -- 96 bits left for the number
Serial_A7, -- 64 bits left for the number
Serial_A12, -- 32 bits left for the number
Serial_A15, -- 16 bits left for the number
Serial_A18, -- it is a serial, but represented as an alphanumeric string
-- the name is separated by the value by '_'. Ending dots ignored
Matrix, List, Pointer,
Zascii7, -- zero-ended (or full) ascii_7
String_On, Endstruct, -- start and end of an ascii7 long string
Nstime, -- time with nano-second resolution
Longfloat, Longint, -- not so fond of them
Float_80, Float_64, Float_1, Float_2, Float_3, --- standard float types
Uintv1, Uintv2, Uintv3, -- uint vector with B coding for the name
Intv1, Intv2, Intv3, -- uint vector with B coding for the name
Quant, -- this is clear :)
Uuid_Zero,
Uuid_V1_0, Uuid_V1_1, Uuid_V1_2, Uuid_V1_3,
Uuid_V2_0, Uuid_V2_1, Uuid_V2_2, Uuid_V2_3,
Uuid_V3_0, Uuid_V3_1, Uuid_V3_2, Uuid_V3_3,
Uuid_V4_0, Uuid_V4_1, Uuid_V4_2, Uuid_V4_3,
Uuid_V5_0, Uuid_V5_1, Uuid_V5_2, Uuid_V5_3);
for Corlidtype'Size use 8;
type Base64char is new Integer range 0..63; -- 0-9,a-z,A-Z,_,:
type Base32char is new Integer range 0..31; -- A-Z,+,-,*,/,_,:
type Base128char is new Integer range 0..127; -- 7 bit
subtype Utype_Len is Integer range 1..20;
subtype User_Type is String(Utype_Len);
type Make_Uuid_Method is access function (F: Real:= 0.0; N: Int:= 0; S: String:= "")
return Uuid;
type Read_Uuid_Method is access function (S: String) return Uuid;
type Format_Uuid_Method is access function (U: Uuid;
W,D,E: Integer:= 0;
M1,M2,M3: Boolean:= False;
Flag: Character:= 'U';
Style: Character:= 'K';
Pic: String:= "") return String;
type Kind_Entry is record
Utype: User_Type:= ( others => '.');
Ulen: Utype_Len;
Ct: Corlidtype;
Maker: Make_Uuid_Method := null;
Reader: Read_Uuid_Method := null;
Formatter: Format_Uuid_Method := null;
end record;
Kind_Reg_Len: constant Natural:= 1000;
subtype Kind_Reg_Cursor is Natural range 0..Kind_Reg_Len;
subtype Kind_Reg_Range is Kind_Reg_Cursor range 1..Kind_Reg_Len;
Kind_Reg_Fill: Kind_Reg_Cursor:= 0;
No_Kind: constant Kind_Reg_Cursor := 0;
Kind_Reg_Index: array(Base64char, Base64char, Base64char) of Kind_Reg_Cursor :=
(others => (others => (others => No_Kind)));
Kind_Reg: array(Kind_Reg_Range) of Kind_Entry;
function Locate_Kind(Kind: String) return Kind_Reg_Cursor;
-- the string is case insensitive, converted to upper for encoding-b purposes
procedure Register_Uuid_Kind(Kind: String; -- but must be an alphanumeric string corresponding
-- to the corlidtype
Corlid_Type: Corlidtype;
Make_Method: Make_Uuid_Method:= null;
Read_Method: Read_Uuid_Method:= null;
Format_Method: Format_Uuid_Method:= null);
function Make_Uuid(Kind: String; F: Real:= 0.0; N: Int:= 0; S: String:= "") return Uuid;
function Kind(U: Uuid) return String; -- case insensitive, returned as lower case
function Kinn(U: Uuid) return String; -- case insensititve, returned as upper case
function Kint(U: Uuid) return String; -- case insensitive, returned as upper case
-- components can be
type Attribute is (Nint, Isize, Min, Max, Nchar, Encoding, Nfloat, Decimals,
Emin, Emax, Fsize);
subtype Attribute_Vector is Integer range 1..4;
Nattr: Int:= -998987987698765;
function Attr(U: Uuid; A: Attribute; N: Integer) return Int;
function Get(U: Uuid; N,K: Integer:= 1) return Int;
function Get(U: Uuid; N,K: Integer:= 1) return Real;
function Get(U: Uuid; N,K: Integer:= 1) return String;
procedure Set(U: in out Uuid; V: Int; N,K: Integer:= 1);
procedure Set(U: in out Uuid; V: Real; N,K: Integer:= 1);
procedure Set(U: in out Uuid; V: String; N,K: Integer:= 1);
function Format(U: Uuid;
W,D,E: Integer:= 0;
M1,M2,M3: Boolean:= False;
Flag: Character:= 'U';
Style: Character:= 'K';
Pic: String:= "") return String;
-- Lisp, Fortran, C, R, Edited (ada/cobol)
-- S--just usef the pic string ignore the others
-- K--kind specific, not a classic style
function Read(S: String) return Uuid;
-- vuuid
type Vuuid is array(Integer range <>) of Uuid;
function "&"(A,B: Vuuid) return Vuuid;
function "&"(A: Vuuid; B: Uuid) return Vuuid;
function "&"(A: Uuid; B: Vuuid) return Vuuid;
function "&"(A,B: Uuid) return Vuuid;
function To_Vuuid(A: Uuid) return Vuuid; -- of length 1
function Read(S: String) return Vuuid; -- low level read of a string into a vector of uuids
function Extract_String(V: Vuuid; K: Integer) return String;
function Next_After(U: Uuid) return Integer;
-- installable loaders and savers of files of various types
-- into/from vuuids
function Load(File: String; Form: String) return Vuuid;
procedure Save(V: Vuuid; File: String; Form: String);
type Vuuid_Loader is access function (File: String) return Vuuid;
type Vuuid_Saver is access procedure (V: Vuuid; File: String);
procedure Register_Filetype(Form: String; Loader: Vuuid_Loader; Saver: Vuuid_Saver);
-- the following should probably be private
type Filetype is record
Form: Uuid; -- a read of the form string argument
Loader: Vuuid_Loader;
Saver: Vuuid_Saver;
end record;
type Filetype_Register is array(Integer range <>) of Filetype;
Filetype_Reg_Len: constant Integer:= 100;
subtype Filetype_Reg_Cursor is Natural range 0..Filetype_Reg_Len;
subtype Filetype_Reg_Range is Filetype_Reg_Cursor range 1..Filetype_Reg_Len;
Filetype_Reg_Fill: Filetype_Reg_Cursor:= 0;
No_Filetype: constant Filetype_Reg_Cursor := 0;
Filetype_Reg: array(Filetype_Reg_Range) of Filetype;
function Locate_Filetype(Filetype: Uuid) return Filetype_Reg_Cursor;
function Locate_Filetype(Filetype: String) return Filetype_Reg_Cursor;
-- exceptions
Incompatible_Types_In_Set: exception;
Out_Of_Bounds_Set: exception;
Parameter_Combination_Not_Supported: exception;
Wrong_Dimensionality_Assumed: exception;
Subcomponent_Of_Nonlist: exception;
Wrong_Type: exception;
Internal_Error: exception;
-- **************************************************************************
-- The following should be private, the user specification mostly ends above
-- **************************************************************************
-- UUIDS
-- This section is the new UUID/CORLID/EXTUUID specification
-- since version 0.3
--- UUID is a (very probably unique) 128 bit representation of an object
--- EXTUUID is a compatible extension (variant 6, or another variant)
--- of the UUID; it has types and subtypes with a complex scheme
--- currently (16 oct 2012) the EXTUUID specification is being finalised
--- You can find the latest version at:
--- http://dan.corlan.net/software/corlpack/extuuid.html
--- Encoding common identiļ¬ers into UUIDs
--- Alexandru D. Corlan, oct 12, 2012
---
--- CORLID is a unique 128 bit representation of an object
--- that is relatively strightforward and fast to program into
--- in Ada, but has the bits stored in a specific way, not
--- bit by bit compatible with the UUID (RFC-4122) or the EXTUUID specification;
--- the CORLID format however accomodates the most commonly useful
--- EXTUUID forms and all UUID forms version 1-5
---
--- UNUUID is the unpacked form of the uuid; it stores the same information as
--- the CORLID but it occupies several (6.5) times that ammount of memory
--- it still doesn't cover all the extuuid specification though;
--- it is the most strightforward and easy to use type by far
--- the unuuid; most information and internal consistency is maintained by the user
--- not currently used
type Si_Base_Unit is (Metre, Kilogram, Second, Ampere, Kelvin, Candela, Mole);
for Si_Base_Unit use (Metre => 1, Kilogram => 2, Second => 3, Ampere => 4,
Kelvin => 5, Candela => 6, Mole => 7);
type Unuuid_Type is (V1,V2,V3,V4,V5, Xsym, Xfix, Xtime, Xquant, Xint, Xfloat,
Xivec1, Xivec2, Xivec3,
Xuivec1, Xuivec2, Xuivec3,
Xfloat1, Xfloat2, Xfloat3);
type Powerset is array(Si_Base_Unit) of Short_Short_Integer;
type Unuuid is record
Uutype: Unuuid_Type;
Name: String(1..32); -- include comments if you like :)
Name_Len, L, N, Encoding, Sign: Short_Short_Integer;
Pow,Rad: Powerset;
Hi,Lo: Long_Long_Integer;
F: Long_Long_Float;
F2,F3: Float;
I2,I3: Integer;
end record;
--- the corlid type
--- it has 128 bits, like the other types, but it only covers
--- some of the more frequently used types and is (much) faster
--- than using bit fields; will be converted to uuid/extuuid format
--- by two specific functions
--- the more common types, that we use, are below
--- symbols ending in any number of dots ('.') are not supported
type Unit_Power is range -7..8;
for Unit_Power'Size use 4;
type Unit_Radical is range 0..7;
for Unit_Radical'Size use 3;
type Si_Unit is array(Si_Base_Unit) of Unit_Power;
pragma Pack(Si_Unit);
type Si_Radical is array(Si_Base_Unit) of Unit_Radical;
pragma Pack(Si_Radical);
subtype Cobolnr is Long_Long_Integer range -999_999_999_999_999_999..999_999_999_999_999_999;
subtype Float32 is Float; -- must be made portable
subtype Float64 is Long_Float; -- must be made portable
subtype Float80 is Long_Long_Float; -- must be made portable
type Int32 is new Integer;
for Int32'Size use 32;
type Int4 is new Integer range 0..7;
for Int4'Size use 4;
type Int8 is new Integer range 0..15;
for Int8'Size use 8;
type Uint14 is new Integer range 0..(2**14-1);
for Uint14'Size use 14;
type Uint16 is new Integer range 0..(2**16-1);
for Uint16'Size use 16;
type Uint48 is new Long_Long_Integer range 0..(2**48-1);
for Uint48'Size use 48;
type Int48 is new Long_Long_Integer range -2**47..(2**47-1);
for Int48'Size use 48;
type Uint32 is new Long_Long_Integer range 0..(2**32-1);
for Uint32'Size use 32;
type Uint64 is new Long_Long_Integer;
type Uint58 is new Long_Long_Integer range 0..(2**58-1);
for Uint58'Size use 58;
type Abstring is array(Integer range <>) of Base64char;
type Cstring is array(Integer range <>) of Base32char;
type Dstring is array(Integer range <>) of Base128char;
type Abstring18 is new Abstring(1..18);
pragma Pack(Abstring18);
type Abstring7 is new Abstring(1..7);
pragma Pack(Abstring7);
type Abstring12 is new Abstring(1..12);
pragma Pack(Abstring12);
type Abstring15 is new Abstring(1..15);
pragma Pack(Abstring15);
type Abstring4 is new Abstring(1..4);
pragma Pack(Abstring4);
type Cstring3 is new Cstring(1..3);
pragma Pack(Cstring3);
type Cstring7 is new Cstring(1..7);
pragma Pack(Cstring7);
type Cstring8 is new Cstring(1..8);
pragma Pack(Cstring8);
type Cstring22 is new Cstring(1..22);
pragma Pack(Cstring22);
type Ascii7str is new Dstring(1..16); -- 16 * 7 = 112
pragma Pack(Ascii7str);
type Fourchars is array(1..4) of Base32char;
pragma Pack(Fourchars);
type Twentychars is array(1..20) of Base64char;
pragma Pack(Twentychars);
type Eightchars is array(1..8) of Base64char;
pragma Pack(Eightchars);
type Bitstring is array(Integer range <>) of Boolean;
type Qw is new Bitstring(0..127);
pragma Pack(Qw);
type Uuid_Bits is new Bitstring(0..119);
pragma Pack(Uuid_Bits);
for Uuid_Bits'Size use 120;
type Nibble is new Integer range 0..15;
for Nibble'Size use 4;
type Uuid_Nibbles is array(1..30) of Nibble;
pragma Pack(Uuid_Nibbles);
function String_To_Encb(S: String) return Abstring;
function String_To_Enca(S: String) return Abstring;
function Enca_To_String(S: Abstring) return String;
function Dot_Trim(S: String) return String;
function Dot_Fill(S: String; N: Integer) return String;
type Corlid(Ctype: Corlidtype) is record -- THE DISCRIMINANT MUST HAVE AT LEAST 8 BITS!!
-- or corlid??
-- ALSO POSSIBLY AS SEPPARATE TYPES WITH individual STORAGE_on_128_bit PROCEDURES
-- but then a function like: function read returns corl; would not be possible
-- and it is quite useful; we could also give up requiring that this type is 128
-- bits long, but that would complicated storage procedures
case Ctype is
when Fixed_Bitvec | Serial_Bitvec | Vector_Bitvec =>
Bvdat: Uuid_Bits;
when Quant => -- also represents durations; KINT:Q
Unit: Si_Unit:= ( others => 0); -- 28
Radical: Si_Radical:= (others => 1); -- 21
Value: Float64; -- 64 = 113 bits
when Fixed_B7 => -- 4 decimal places assumed; kint:mm
B7_Name: Abstring7; -- 42
B7_Decimals: Short_Short_Integer:= 4; -- +8 = 50 [but should be 3 bits]
B7_Value: Long_Long_Integer; -- +64 = 114, 19 digits
when Sym_A18 | Sym_B18 =>
AB18_Sym: Abstring18;
Nuly: Short_Short_Integer:= 0;
when Sym_C22 =>
C22_Sym: Cstring22;
when Serial_C3 =>
C3_Name: Cstring3;
C3_Ext: Uint32;
C3_Serial: Uint64;
when Serial_A7 =>
A7_Name: Abstring7;
A7_Serial: Uint64;
when Serial_A12 =>
A12_Name: Abstring12;
A12_Serial: Uint32;
when Serial_A15 =>
A15_Name: Abstring15;
A15_Serial: Uint16;
when Serial_A18 =>
A18: Abstring18;
when Matrix =>
Matype: Abstring4; -- supplementary matrix configuration user type; just matrix is "..."
Colheads, Rowheads: Short_Short_Integer;
-- nr of items that have a non-strictly-positive index and atypical
-- interpretation; for example, the first column tag may be the
-- name while the second may be the type or the unit
Cols: Integer; -- nr of columns
Rows: Integer; -- nr of rows
-- the number of uuids in the structure is _exactly_
-- N=(colhead+cols)*(rowhead+rows)
-- the following element, after n uuids, must be endstruct:N
-- if an element of the matrix is a more complex object, then
-- it should be refered to using a pointer
-- syntax: matrix:30+1,20+0 means 30 cols, 1 colhead, 20 rows, no rowhead
when List =>
Listype: Abstring7; -- supplementary list type; "list" has no value, just ...
Len: Integer; -- number of elements in the list
Lisz: Integer; -- number of uuids in the list
when Pointer => -- it means a pointer in the same UUID
Index: Integer; -- should in fact be natural? probably not,
-- we do not want to index more than 4Gbytes and we index
-- 16 bytes at a time (an UUID)
when Zascii7 =>
Str7: Ascii7str;
when String_On =>
Len7on: Integer;
Nch7on: Integer;
when Endstruct =>
Endlen: Integer;
when Nstime =>
Ada_Time: Time;
when Longint =>
Hi: Int48;
Lo: Long_Long_Integer;
when Longfloat =>
Val: Long_Long_Float; -- not long enough, true ...
when Float_80 =>
F80Name: Abstring4;
f80Val: Float80;
when Float_64 =>
F64Name: Cstring8;
f64Val: Float64;
when Float_1 =>
F1Name: Abstring12;
fVal: Float32;
when Float_2 =>
F2Name: Cstring8;
fVal1v1, fVal2v2: Float32;
when Float_3 =>
F3Name: Int8;
fVal1v3, fVal2v3, fVal3v3: Float32;
when Intv1 =>
Namei1: Abstring12;
IVal1v1: Int32;
when Intv2 =>
Namei2: Cstring8;
IVal1v2, IVal2v2: Int32;
when Intv3 =>
Namei3: Int8;
IVal1v3, IVal2v3, IVal3v3: Int32;
when Uintv1 =>
Nameui1: Abstring12;
UiVal: Uint32;
when Uintv2 =>
Nameui2: Cstring8;
UiVal1v2, UiVal2v2: Int32;
when Uintv3 =>
Nameui3: Int8;
UiVal1v3, UiVal2v3, UiVal3v3: Uint32;
when Uuid_Zero =>
Uudat: Uuid_Bits := ( others => False); -- 120 of them
when
Uuid_V1_0 | Uuid_V1_1 | Uuid_V1_2 | Uuid_V1_3
| Uuid_V2_0 | Uuid_V2_1 | Uuid_V2_2 | Uuid_V2_3
| Uuid_V3_0 | Uuid_V3_1 | Uuid_V3_2 | Uuid_V3_3
| Uuid_V5_0 | Uuid_V5_1 | Uuid_V5_2 | Uuid_V5_3
| Uuid_V4_0 | Uuid_V4_1 | Uuid_V4_2 | Uuid_V4_3 =>
Uunib: Uuid_Nibbles; -- 120
end case;
end record;
pragma Pack(Corlid);
for Corlid'Size use 128;
function To_Qw is new Ada.Unchecked_Conversion(Corlid,Qw);
function To_Corlid is new Ada.Unchecked_Conversion(Qw,Corlid);
Zerocorl: Corlid:= (Ctype => Uuid_Zero, Uudat => ( others => False));
Joule: constant Corlid :=
(Ctype => Quant, Radical => (others => 1),
Unit => (Metre => 2, Kilogram => 1, Second => -2, Ampere => 0,
Kelvin => 0, Candela => 0, Mole => 0),
Value => 1.0);
Kwh: constant Corlid :=
(Ctype => Quant, Radical => (others => 1),
Unit => (Metre => 2, Kilogram => 1, Second => -2, Ampere => 0,
Kelvin => 0, Candela => 0, Mole => 0),
Value => 3_600_000.0);
Adimensional: constant Corlid :=
(Ctype => Quant, Radical => (others => 1), Unit => (others => 0), Value => 1.0);
function "+"(A,B: Corlid) return Corlid;
function "*"(A: Long_Float; B: Corlid) return Corlid;
function "*"(A: Corlid; B: Long_Float) return Corlid;
function Format(C: Corlid; Prefix: Boolean:= False) return String;
function Read(S: String) return Corlid;
-- OBSOLETE UUID SPECIFICATION, WILL BE REPLACED WITH CORLIDS
-- subtype Uuid_Version is Integer range 0..15;
-- subtype Uuid_Variant is Integer range 0..3;
subtype Uuid_Block is Long_Long_Integer;-- range 0..(2**61 - 1);
type Uuid_Syntax is (Hex, Dash_Hex, Prefix, Symbol);
Zeroid: Uuid:= ( --Version => 0, Variant => 0,
Lo => 0, Hi => 0);
-- Hex: xxxx... (exactly 32 x)
-- Dash_Hex: xxxxxxxx-xxxx-xxxx-xxxx-xxxxxxxxxxxx
-- Prefix: xx:AAAA... (exactly 20 A)
-- Symbol A... (any number of A, from 1 to 20)
-- A: case sensitive alphanumeric or _ or : ; the later are also called
-- horizontal and vertical punctuation, or dash and sep and may be variable
-- x: case insensitive hex digit (0-9 or A-F)
function To_String(U: Uuid; Syntax: Uuid_Syntax:= Symbol;
Dash: Character:= '_'; Sep: Character:= ':') return String;
function To_Uuid(S: String; Dash: Character:= '_'; Sep: Character:= ':') return Uuid;
Uuid_Syntax_Not_Supported: exception;
function Random_Uuid_Symbol(Prefix: String; Time_Bytes: Integer:= 10) return String;
-- the rest are purely random, but the non-prefix
-- string may be restricted to alphabetic, uppercase,
-- lower case, numeric, or various other conventions to increase readability
-- the uuid is a symbolic uuid; iff the restriction is negative, then
-- the uuid will be a non-symbolic uuid, the absolut value of the
-- restriction indicating the version; it is possible to generate
-- an uuid type 1 by specifying the right prefix (that must be 8 characters
-- representing 48 bits), the time_bits as 60 bits
-- function Md5_Uuid(From: String) return Uuid;
subtype Ix is Integer range 0..100_000_000;
type Realset is array(Integer range <>) of Real;
type Intset is array(Integer range <>) of Int;
type Boolset is array(Integer range <>) of Boolean;
pragma Pack(Boolset);
type Elem_Ix_Set is array(Integer range <>) of Ix;
-- uuids could be numbers also!!
type Hq_Type is (Plain_Real_Vector, Plain_Int_Vector, Plain_String,
Plain_Bool_Vector, Plain_Id_Vector, Real_Vector,
Quant, String_Vector, Int_Vector, Id_Vector, Bool_Vector,
Data_Frame, List, Dimension, Dimension_Set,
Accesor, Na, Void);
-- Plain_Real_Vector: first=1, length, reals, name(opt)
-- Plain_Int_Vector: first=1, length, ints, name(opt)
-- Plain_String: first=1, length, chars, name(opt)
-- Plain_Bool_Vector: first=1, length, chars, name(opt)
-- Plain_Id_Vector: first=1, length, ids, name(opt)
-- real_vector, bool_vector, int_vector, id_vector: same, but also a list
-- of ids refer to
-- List: could be everything else with suitable names
-- that are easy to identify; essentially a plain_element_vector
-- but some substructures would be especially identified
-- and have predefined formats; we need to implement this _anyway_
-- and we do it with some primitives; this includes naming objects,
-- dimensions, etc
-- Data_Frame, -- is in fact a list
-- Dimension,
-- Dimension_Set,
-- Accesor -- is a list as well
-- Na,
-- Void
type El_Type is (Structs, Ints, Reals, Chars, Bools, Ids, Empty);
type Element is record
Eltype: El_Type;
Length: Natural := 0; -- size of the vector defined by this element; this is the
-- invisible, allocated length
Fill: Natural:= 0; -- how much of the vector is filled with objects; this is the 'visible size'
First: Natural := 0; -- first element in the value space specified by the element type
Names: Natural:= 0; -- the first in the idspace with length name elements for this object
Na: Natural:= 0; -- the first in the boolset that starts the length NA elements for this obj
Up: Ix:= 0;
end record;
pragma Pack(Element);
type Elementset is array(Positive range <>) of Element;
pragma Pack(Elementset);
type Hq(Max_Elements, Max_Chars, Max_Ints, Max_Ids,
Max_Reals, Max_Bools, Max_Ix: Ix) is record
Hqtype: Hq_Type; -- if structs, first+length are indices in the element list
Elems: Elementset(1..Max_Elements);
Elem_Fill: Ix:= 0;
Start: Ix:= 0; -- the first element that references all the data in the structure
-- or nothing if there is a single element or a simple collection of elements
Chars: String(1..Max_Chars);
Char_Fill: Ix:= 0;
Ints: Intset(1..Max_Ints);
Int_Fill: Ix:= 0;
Ids: Vuuid(1..Max_Ids);
Id_Fill: Ix:= 0;
Reals: Realset(1..Max_Reals);
Real_Fill: Ix:= 0;
Bools: Boolset(1..Max_Bools);
Bool_Fill: Ix:= 0;
Elemixs: Elem_Ix_Set(1..Max_Ix);
Elemix_Fill: Ix:= 0;
end record;
Empty_Hq_Element: constant Element:=
( Eltype => Empty,
Length => 0,
Na => 0,
First => 0,
Fill => 0,
Names => 0,
Up => 0
);
Noelems: constant Elementset(1..0) := (others => Empty_Hq_Element);
Nochars: constant String(1..0) := "";
Noints: constant Intset(1..0) := (others => 0);
Noreals: constant Realset(1..0) := (others => 0.0);
Nobools: constant Boolset(1..0) := (others => False);
Noelemixs: constant Elem_Ix_Set(1..0) := (others => 0);
Noids: constant Vuuid(1..0) := ( others => Zeroid);
--function Elt(H: Hq; N: Integer) return Real;
Voidhq: constant Hq :=
(Max_Elements => 0, Max_Chars => 0, Max_Ints => 0, Max_Ids => 0,
Max_Reals => 0, Max_Bools => 0, Max_Ix => 0, Hqtype => Void,
Elems => Noelems, Elem_Fill => 0, Start => 0, Chars => Nochars,
Char_Fill => 0, Ints => Noints, Int_Fill => 0, Ids => Noids, Id_Fill => 0, Reals => Noreals,
Real_Fill => 0, Bools => Nobools, Bool_Fill => 0, Elemixs => Noelemixs,
Elemix_Fill => 0 );
Nahq: constant Hq :=
(Max_Elements => 0, Max_Chars => 0, Max_Ints => 0, Max_Ids => 0,
Max_Reals => 0, Max_Bools => 0, Max_Ix => 0, Hqtype => Na,
Elems => Noelems, Elem_Fill => 0, Start => 0, Chars => Nochars,
Char_Fill => 0, Ints => Noints, Int_Fill => 0, Ids => Noids, Id_Fill => 0, Reals => Noreals,
Real_Fill => 0, Bools => Nobools, Bool_Fill => 0, Elemixs => Noelemixs,
Elemix_Fill => 0 );
type Hq_ptr is access constant Hq; -- one cannot change the object via the pointer
type Cursor(H: access Hq) is record
El: Ix:= H.all.start; -- the element in the Hq object that is pointed to
Inel: Ix:= 0; -- index in the vectors referenced by el, that may be void (0)
Name: Uuid:= Zeroid; -- name of the object that is pointed to
Na: Boolean:= False; -- whether the value is void
-- the latest are needed in order to avoid locating the relevant
-- information in parts of the hq that are not accessible via the el/inel
end record;
-- it is a cursor in a Hq, that is a reference to an internal component
-- of a Hq; there is always a balance between
-- using cursors, dynamically allocated Hq's or copies of a Hq;
-- if the Hq is small, a copy is faster; if it is large, copying
-- it repeatedly on the stack, as a parameter, especially
-- in recursive functions, will be very slow
-- elementary constructors
function Plain_Int_Vector(N: Ix) return Hq; -- no names, no unit
function Plain_Real_Vector(N: Ix) return Hq;
function Real_Vector(N: Ix) return Hq; -- returns a real vector of maximum size N,
-- but with not element: its actual length is 0
function List(Size: Ix; Nelem,Nchar,Nint,Nreal,Nid,Nbool,Nix: Ix:= 0) return Hq;
function Plain_String(S: String:= ""; Size: Ix:= 128) return Hq;
function Plain_Id_Vector(N: Ix:= 1) return Hq;
function Plain_Bool_Vector(N: Ix) return Hq;
function Bool_Vector(N: Ix) return Hq;
function Is_Void(H:Hq) return Boolean;
function Is_Plain_Int_Vector(H: Hq) return Boolean;
function Is_Plain_Real_Vector(H: Hq) return Boolean;
function Is_Plain_String(H: Hq) return Boolean;
function Is_Plain_Bool_Vector(H: Hq) return Boolean;
function Is_Plain_Id_Vector(H: Hq) return Boolean;
-- CURSOR OPERATORS
-- CURSOR PREDICATES
-- --
function Is_At_Start(C: cursor) return Boolean;
function Is_List(C: cursor) return Boolean;
function Is_Na(C: cursor) return Boolean;
function Is_Real(C: cursor) return Boolean;
function Is_Real_Vector(C: cursor) return Boolean;
function Is_Plain_Real_Vector(C: Cursor) return Boolean;
function Is_Id(C: Cursor) return Boolean;
function Is_Id_Vector(C: Cursor) return Boolean;
function Is_Plain_Id_Vector(C: Cursor) return Boolean;
function Is_String(C: Cursor) return Boolean; -- or plain string, the same thing
function Is_Plain_String(C: Cursor) return Boolean; -- or plain string, the same thing
function Is_Char(C: Cursor) return Boolean;
function Is_Bool(C: Cursor) return Boolean;
function Is_Bool_Vector(C: Cursor) return Boolean;
function Is_Plain_Bool_Vector(C: Cursor) return Boolean;
function Is_Int(C: Cursor) return Boolean;
function Is_Int_Vector(C: Cursor) return Boolean;
function Is_Plain_Int_Vector(C: Cursor) return Boolean;
-- --
-- -- -- SELECTORS
-- -- function Maxpos(C: Cursor) return Ix; -- maximum position in the current vector/list, that is its len
-- -- function Name(C: Cursor) return Id; -- name of the current object
-- --
function Data(C: Cursor) return Real;
function Real_Data(C: Cursor) return Real renames Data;
function Data(C: Cursor) return Int;
function Int_Data(C: Cursor) return Int renames Data;
function Data(C: Cursor) return Boolean;
function Boolean_Data(C: Cursor) return Boolean renames Data;
function Data(C: Cursor) return Uuid;
function Uuid_Data(C: Cursor) return Uuid renames Data;
function Data(C: Cursor) return String;
function String_Data(C: Cursor) return String renames Data;
-- function Data(C: Cursor) return Character;
-- function Character_Data(C: Cursor) return Character renames Data;
-- function Data(C: Cursor) return Hq;
-- function Hq_Data(C: Cursor) return Hq renames Data;
function Length(C: Cursor) return Ix;
function Size(C: Cursor) return Ix;
-- --
-- --
-- -- -- movement of the cursor
procedure Ascend(C: in out Cursor); -- up
procedure Descend(C: in out Cursor; I: Ix:= 1); -- down
-- -- procedure Inc(C: in out Cursor; By: Ix:= 1); -- right
-- -- procedure Dec(C: in out Cursor; By: Ix:= 1); -- left
procedure Move(C: in out Cursor; To: Ix); -- set position in the current list or vector
-- --
-- -- -- CONSTRUCTORS
-- -- -- replacement of the current value
procedure Store(Into: Cursor; V: Real);
procedure Store(Into: Cursor; V: Int);
procedure Store(Into: Cursor; V: Boolean);
procedure Store(Into: Cursor; V: Character);
-- -- procedure Store(Into: Cursor; V: String);
procedure Store(Into: Cursor; V: Uuid);
-- -- procedure Store(Into: Cursor; V: Cursor); -- store another object into this place
-- --
procedure Set_Na(Into: Cursor; Na: Boolean:= True);
procedure Set_Name(Into: Cursor; Name: Uuid);
-- --
-- -- -- appending objects of the suitable type when the cursor designates a list or vector
-- -- -- into the subcomponent vector
-- --
procedure Append(Into: Cursor; V: Real; Name: Uuid:= Zeroid);
procedure Append(Into: Cursor; V: Int; Name: Uuid:= Zeroid);
procedure Append(Into: Cursor; V: Boolean; Name: Uuid:= Zeroid);
-- -- procedure Append(Into: Cursor; V: Character; Name: Id:= Zeroid);
-- -- procedure Append(Into: Cursor; V: String; Name: Id:= Zeroid);
procedure Append(Into: Cursor; V: Uuid; Name: Uuid:= Zeroid);
procedure Append(Into: Cursor; V: Hq; Name: Uuid:= Zeroid);
-- -- procedure Append_Empty_List(Into: Cursor; Size: Ix:= 10; Name: Id:= Zeroid);
procedure Append_Na(Into: Cursor; Name: Uuid:= Zeroid);
-- --
-- insertion and deletion could also be supported
-- highest level selector primitives
-- PLEASE DO NOT USE THESE YET, they are currently being redesigned;
-- use the cursor operators
-- function Cons(Base, Addition: Hq) return Hq; -- simply add a new vector in hq
-- procedure Add_String(H: in out Hq; Nr: out Ix; S: String);
-- procedure Add_Real_Vector(H: in out Hq; Nr: out Ix; N: Ix; Default_Value: Real:= 0.0);
-- procedure Add_Int_Vector(H: in out Hq; Nr: out Ix; N: Ix; Default_Value: Integer:= 0.0);
-- procedure Add_Bool_Vector(H: in out Hq; Nr: out Ix; N: Ix; Default_Value: Boolean:= False);
-- procedure Add_Elem_Vector(H: in out Hq; Nr: out Ix; N: Ix);
-- procedure Set_String(H: in out Hq; Nr: Ix; Offset: Ix; S: String:= " ");
-- procedure Set_String(H: in out Hq; Nr: Ix; Offset: Ix; C: char:= ' ');
-- procedure Set_Real(H: in out Hq; Nr: Ix; Offset: Ix; V: Real:= 0.0);
-- procedure Set_Int(H: in out Hq; Nr: Ix; Offset: Ix; V: Int:= 0);
-- procedure Set_Bool(H: in out Hq; Nr: Ix; Offset: Ix; V: Boolean:= False);
-- procedure Set_Elem(H: in out Hq; Nr: Ix; Offset: Ix; V: Ix:= 0);
-- function Concat(A,B: Hq) return Hq;
-- return a an object of the same type as A and B with their top levels concatenated
function Data(H: Hq; Acc: Hq; I1,I2,I3: Integer:= -1) return Hq;
function Data(H: Hq; Acc: Hq; I1,I2,I3: Integer:= -1) return Int;
function Data(H: Hq; I1,I2,I3: Integer:= -1) return Int;
function Data(H: Hq; Acc: Hq; I1,I2,I3: Integer:= -1) return Real;
function Data(H: Hq; I1,I2,I3: Integer:= -1) return Real;
function Data(H: Hq; Acc: Hq; I1,I2,I3: Integer:= -1) return String;
function Data(H: Hq; I1,I2,I3: Integer:= -1) return String;
function Data(H: Hq; Acc: Hq; I1,I2,I3: Integer:= -1) return Uuid;
function Data(H: Hq; I1,I2,I3: Integer:= -1) return Uuid;
-- procedure Set(What: in out Hq; Acc:Hq; I1,I2,I3: Integer:= -1; From: Hq);
-- replace in What, at Acc, with the data from From
procedure Set(What: in out Hq; I: Ix; From: Int);
--; Name: Uuid: Zeroid);
--always refers to the first list
-- procedure Set(What: in out Hq; I: Integer; From: String);
procedure Set(What: in out Hq; I: Ix; From: Real);
procedure Set(What: in out Hq; I: Ix; From: Uuid);
procedure Append(To: in out Hq; Acc: Hq:= Voidhq; What: Real; Name: Uuid:= Zeroid);
procedure Append(To: in out Hq; What: Hq; Name: Uuid:= Zeroid);
procedure Append_Na(To: in out Hq; Acc: Hq:= Voidhq; Name: Uuid:= Zeroid);
function Is_Na(H: Hq; Acc: Hq:= Voidhq; I1,I2,I3: Integer:= -1) return Boolean;
function Name(H: Hq; Acc: Hq:= Voidhq; I1,I2,I3: Integer:= -1) return Uuid;
-- procedure Set(What: in out Hq; I: Integer; From: Boolean);
-- procedure Set(What: in out Hq; I: Integer; From: Hq); -- for general vectors
-- procedure Set_Name(What: in out Hq; I: Integer; From: String);
-- procedure Set_Na(What: in out Hq; I: Integer; From: Boolean);
-- function Names(H: Hq; Acc: Hq; I1,I2,I3: Integer:= -1) return Hq; -- plain_string_vector
-- function Name(H: Hq; Acc: Hq; I1,I2,I3: Integer:= -1) return String;
function Length(H: Hq; Acc: Hq; I1,I2,I3: Integer:= -1) return Integer;
function Length(H: Hq; I1,I2,I3: Integer:= -1) return Integer;
-- function Dimensions(H: Hq; Acc: Hq; I1,I2,I3: Integer:= -1) return Hq; -- plain_int_vector
-- function Load(Filename, Format: String) return Hq;
-- procedure Load(H: in out Hq; Filename, Format: String);
-- procedure Save(H: Hq; Filename, Format: String);
-- function Acc_Parse(S: String) return Hq; -- from the URI syntax
-- function Accons_Level(Acc1, Acc2: Hq) return Hq;
-- function Acc_Or(Acc1, Acc2: Hq) return Hq; -- / syntax
-- function Acc_And(Acc1, Acc2: Hq) return Hq; -- , syntax
-- function Acc(V: Hq) return Hq; -- transform an integer, string or general vector into an acc
-- function Acc_Level(I1,I2,I3,I4,I5: Integer:= -1) return Hq;
-- accessors from integers in successive levels
-- function Acc_Or(I1,I2,I3,I4,I5: Integer:= -1) return Hq; -- a single level
-- function Acc_Or(S1,S2,S3,S4,S5: String:= "") return Hq; -- make a single level from names
-- function Acc_Range(I1,I2: Integer:= -1) return Hq; -- range of integers as an acc
-- function Acc_Allbut(Acc:Hq) return Hq; -- negate a single_level hq
-- VUUID API
function To_Uuid is new Ada.Unchecked_Conversion(Corlid,Uuid);
function To_Corlid is new Ada.Unchecked_Conversion(Uuid,Corlid);
function Corlidtype_Of(U: Uuid) return Corlidtype;
private
Default_Generator: Generator;
end Corlpack;
with Ada.Text_Io; use Ada.Text_Io;
with Ada.Tags; use Ada.Tags;
with Ada.Characters.Latin_1; use Ada.Characters.Latin_1;
with Ada.Characters.Handling; use Ada.Characters.Handling;
with Unchecked_Deallocation;
with Ada.Unchecked_Conversion;
with System.Storage_elements;
with System.Address_To_Access_Conversions;
with Gnat.Os_Lib; use Gnat.Os_Lib;
with Ada.Strings.Maps.Constants;
with Ada.Strings.Fixed;
package body Corlpack is
package Real_Io is new Float_Io(Real); use Real_Io;
package Int_Io is new Integer_Io(Int); use Int_Io;
function To_Upper(S: String) return String is
begin
return Ada.Strings.Fixed.Translate(S, Ada.Strings.Maps.Constants.Upper_Case_Map);
end To_Upper;
function To_Lower(S: String) return String is
begin
return Ada.Strings.Fixed.Translate(S, Ada.Strings.Maps.Constants.Upper_Case_Map);
end To_Lower;
procedure Load(T: in out Text; Filename: String) is
F: File_Type;
Line: String(1..10_000);
Last: Natural;
begin
T := To_Text("");
Open(F, Name => Filename, Mode => In_File);
loop
Get_Line(F,Line,Last);
Append(T, Line(1..Last) & Ascii.Lf);
exit when End_Of_File(F);
end loop;
end Load;
function Read return String is
Buf: String(1..1000);
Len: Natural;
begin
Get_Line(Buf,Len);
return Buf(1..Len);
end Read;
function Read return Text is
Buf: String(1..1000);
Len: Natural;
begin
Get_Line(Buf,Len);
return To_Unbounded_String(Buf(1..Len));
end Read;
function Read return Float is
R: Real;
begin
Real_Io.Get(R);
return Float(R);
end Read;
function Read return Real is
R: Real;
begin
Real_Io.Get(R);
return R;
end Read;
function Read return Long_Float is
R: Real;
begin
Real_Io.Get(R);
return Long_Float(R);
end Read;
function Read return Long_Long_Float is
R: Real;
begin
Real_Io.Get(R);
return Long_Long_Float(R);
end Read;
function Read return Integer is
R: Int;
begin
Int_Io.Get(R);
return Integer(R);
end Read;
procedure Write(S: String; Width: Integer:= 0) is
begin
Put(S);
end Write;
procedure Write(Into: in out Text; S: String; Width: Integer:= 0) is
begin
Append(Into,S);
end Write;
procedure Write(V: Float; Width: Integer:= 10; Decimals: Integer:= 2; Exp: Integer:= 0) is
begin
Put(Format(Real(V), Width, Decimals, Exp));
end Write;
procedure Write(Into: in out Text; V: Float; Width: Integer:= 10;
Decimals: Integer:= 2; Exp: Integer:= 0) is
begin
Append(Into, Format(Real(V), Width, Decimals, Exp));
end Write;
procedure Write(V: Long_Float; Width: Integer:= 10; Decimals: Integer:= 2; Exp: Integer:= 0) is
begin
Put(Format(Real(V), Width, Decimals, Exp));
end Write;
procedure Write(Into: in out Text; V: Long_Float; Width: Integer:= 10;
Decimals: Integer:= 2; Exp: Integer:= 0) is
begin
Append(Into, Format(Real(V), Width, Decimals, Exp));
end Write;
-- procedure Write(V: Long_Long_Float; Width: Integer:= 0; Decimals: Integer:= 2; Exp: Integer:= 0) is
-- begin
-- Put(Format(Real(V), Width, Decimals, Exp));
-- end Write;
procedure Write(V: Real; Width: Integer:= 10; Decimals: Integer:= 2; Exp: Integer:= 0) is
begin
Put(Format(V, Width, Decimals, Exp));
end Write;
procedure Write(Into: in out Text; V: Real; Width: Integer:= 10;
Decimals: Integer:= 2; Exp: Integer:= 0) is
begin
Append(Into, Format(Real(V), Width, Decimals, Exp));
end Write;
procedure Write(K: Integer; Width: Integer:= 1) is
begin
Put(Format(Int(K),Width));
end Write;
procedure Write(Into: in out Text; K: Integer; Width: Integer:= 1) is
begin
Append(Into, Format(Int(K),Width));
end Write;
procedure Write(K: Boolean; Width: Integer:= 1) is
begin
Put(Boolean'Image(K));
end Write;
procedure Write(Into: in out Text; K: Boolean; Width: Integer:= 1) is
begin
Append(Into, Boolean'Image(K));
end Write;
procedure Write(K: Long_Integer; Width: Integer:= 1) is
begin
Put(Format(Int(K),Width));
end Write;
procedure Write(Into: in out Text; K: Long_Integer; Width: Integer:= 1) is
begin
Append(Into, Format(Int(K),Width));
end Write;
procedure Write(K: Long_Long_Integer; Width: Integer:= 1) is
begin
Put(Format(Int(K),Width));
end Write;
procedure Write(Into: in out Text; K: Int; Width: Integer:= 1) is
begin
Append(Into, Format(K,Width));
end Write;
procedure Write(Into: in out Text; K: Long_Long_Integer; Width: Integer:= 1) is
begin
Append(Into, Format(Int(K),Width));
end Write;
procedure Write(T: Text; Width: Integer:= 0) is
begin
Put(To_String(T));
end Write;
procedure Write(Into: in out Text; T: Text; Width: Integer:= 0) is
begin
Append(Into,T);
end Write;
function Format(V: Real; Width: Integer:= 10; Decimals: Integer:= 2; Exp: Integer:= 0)
return String is
S: String(1..Width);
begin
Real_Io.Put(S,V,Aft=>Decimals,Exp=>Exp);
return S; -- To_Unbounded_String(S);
end Format;
function Format(K: Integer; Width: Integer:= 1) return String is
begin
return Format(Int(K), Width);
end Format;
Ts: String:= "TRUE ";
Fs: String:= "FALSE ";
function Format(K: Boolean; Width: Integer:= 1) return String is
begin
if K then
return Ts(1..Width);
else
return Fs(1..Width);
end if;
end Format;
function Format(K: Int; Width: Integer:= 1) return String is
Im: String:= Int'Image(K);
Rv: String(1..Width):= ( others => ' ');
begin
if Width<=Im'Length then
return Trim(Im);
end if;
return Rv(1..(Width-Im'Length)) & Trim(Int'Image(K));
end Format;
procedure Nl(Into: in out Text; Spacing: in Positive_Count := 1) is
Lfs: String(1..Integer(Spacing)):= ( others => Ascii.Lf );
begin
Append(Into, Lfs);
end Nl;
-- save/log with lock
protected type File_Lock is
entry Lock;
entry Unlock;
private
Locked: Boolean:= False;
end File_Lock;
protected body File_Lock is
entry Lock when not Locked is
begin
Locked := True;
end Lock;
entry Unlock when Locked is
begin
Locked := False;
end Unlock;
end File_Lock;
Per_Process_Lock: File_Lock;
procedure Save(Object: Text;
Filename: String;
Append: Boolean:= False;
Format: String:= "text";
Lock: String:= "process") is
F: File_Type;
begin
if Lock="process" then
Per_Process_Lock.Lock;
null;
end if;
if Append then
Open(File => F,
Mode => Append_File,
Name => Filename);
else
Create(File => F,
Mode => Out_File,
Name => Filename);
end if;
Put(F,To_String(Object));
Close(F);
if Lock="process" then
Per_Process_Lock.unlock;
null;
end if;
exception
when others =>
Per_Process_Lock.Unlock;
null;
raise;
end Save;
procedure Log(Object: in out Text;
Filename: String;
Format: String:= "text";
Lock: String:= "process") is
F: File_Type;
begin
Save(Object => Object,
Filename => Filename,
Append => True,
Format => Format,
Lock => Lock);
Object := Empty_Text;
end Log;
function Trim(S: String) return String is
Fr,To: Integer;
begin
Fr := S'Last+1;
To := S'Last;
for K in S'Range loop
if S(K)/=' ' then
Fr := K;
exit;
end if;
end loop;
if Fr=To+1 then
return "";
end if;
for K in reverse S'Range loop
if S(K)/=' ' then
To := K;
exit;
end if;
end loop;
return "" & S(Fr..To);
end Trim;
function Moment_Random return Integer is
begin
return Integer(Float(Sub_Second(Clock)) * Float(Integer'Last - 1));
end Moment_Random;
function Random(N: Integer) return Integer is
Rv: Integer;
begin
Rv := Integer(Random(Default_Generator)*Float(N));
if Rv=0 then
Rv := 1;
end if;
return Rv;
end Random;
function Random(Distribution: String:= "uniform";
Min: Real:= 0.0;
Max: Real:= 1.0;
M1: Real:= 0.0; -- mu for a normal
M2: Real:= 1.0 -- standard deviation for a normal
) return Real is
function Normal_Density(X,Mu,Sigma: Real) return Real is
begin
return 1.0/(Sqrt(2.0 * Pi) * Sigma) * Exp(-((X - Mu)**2/(2.0*(Sigma**2))));
end Normal_Density;
function Normal_Gen(Mu,Si: Real) return Real is
U,V: Real;
begin
U := Real(Random(Default_Generator));
V := Real(Random(Default_Generator));
return Mu + (Si * Sqrt(-2.0 * Log(U)) * Cos(2.0*Pi*V));
end Normal_Gen;
Xx: Real;
begin
Xx := Real(Random(Default_Generator));
if Distribution = "uniform" or else Distribution = "unif" or else
Distribution = "u" or else Distribution = "Uniform" or else Distribution = "Unif" or else
Distribution = "U" or else Distribution = "UNIFORM" or else Distribution = "UNIF" then
return Xx * (Max - Min) + Min;
end if;
if Distribution = "normal" or else Distribution = "norm" or else
Distribution = "n" or else Distribution = "Normal" or else Distribution = "Norm" or else
Distribution = "N" or else Distribution = "NORMAL" or else Distribution = "NORM" then
for K in 1..1_000_000 loop
Xx := Normal_Gen(M1,M2);
if Xx>=Min and then Xx <= Max then
return Xx;
end if;
end loop;
raise Internal_Error;
end if;
raise Bad_Random_Generator_Parameters;
end Random;
procedure Reset_Generator(Seed: Integer) is
begin
Reset(Default_Generator,Seed);
end Reset_Generator;
procedure Reset_Generator(State: String) is
begin
Reset(Default_Generator, Value(State));
end Reset_Generator;
function Generator_State return String is
Gs: State;
begin
Save(Default_Generator,Gs);
return Image(Gs);
end Generator_State;
--------------------------------
-- uuids --
--------------------------------
-- CURRENT, V0.3 UUID CODE
type Zero_Corlid is array(1..16) of Short_Short_Integer;
pragma Pack(Zero_Corlid);
function To_Zero is new Ada.Unchecked_Conversion(Corlid,Zero_Corlid);
function To_Corlid is new Ada.Unchecked_Conversion(Zero_Corlid,Corlid);
function Enzero(C: Corlid) return Corlid is
Z: Zero_Corlid;
begin
Z := To_Zero(C);
Z(2..16) := (others => 0);
return To_Corlid(Z);
end Enzero;
function "+"(A,B: Corlid) return Corlid is
Rv: Corlid(Quant);
begin
if A.Ctype/=Quant or else B.Ctype/=Quant then
raise Wrong_Type;
end if;
if A.Unit/=B.Unit then
raise Wrong_Type;
end if;
Rv.Unit := A.Unit;
Rv.Value := A.Value + B.Value;
return Rv;
end "+";
function "*"(A: Long_Float; B: Corlid) return Corlid is
Rv: Corlid(Quant);
begin
if B.Ctype /= Quant then
raise Wrong_Type;
end if;
Rv.Unit := B.Unit;
Rv.Value := B.Value * A;
return Rv;
end "*";
function "*"(A: Corlid; B: Long_Float) return Corlid is
begin
return B*A;
end "*";
-- type Flclass is (Decimal,Alpha,Sign,Err);
--
-- Firstl: array(Character) of Flclass;
--
-- procedure Initialize_Read_Tables is
--
-- begin
-- for C in Character loop
-- Firstl(C) := Err;
-- end loop;
-- for C in Character'('0')..'9' loop
-- Firstl(C) := Decimal;
-- end loop;
-- for C in 'A'..'Z' loop
-- Firstl(C) := Alpha;
-- end loop;
-- for C in 'a'..'z' loop
-- Firstl(C) := Alpha;
-- end loop;
-- Firstl('-') := Sign;
-- Firstl('+') := Sign;
-- end Initialize_Read_Tables;
--
function Adimensional_Quant_Read(S: String) return Corlid is
Rv: Corlid(Quant):= Adimensional;
begin
Rv.Value := Long_Float'Value(S);
return Rv;
end Adimensional_Quant_Read;
pragma Inline(Adimensional_Quant_Read);
Rfc4122_Uuid_Types: constant array(1..5,0..3) of Corlidtype:=
( (Uuid_V1_0, Uuid_V1_1, Uuid_V1_2, Uuid_V1_3),
(Uuid_V2_0, Uuid_V2_1, Uuid_V2_2, Uuid_V2_3),
(Uuid_V3_0, Uuid_V3_1, Uuid_V3_2, Uuid_V3_3),
(Uuid_V4_0, Uuid_V4_1, Uuid_V4_2, Uuid_V4_3),
(Uuid_V5_0, Uuid_V5_1, Uuid_V5_2, Uuid_V5_3) );
function Uuid_Read(S: String) return Corlid is
Uu: array(1..32) of Nibble;
N,K,Uutype,Version: Integer;
function Hex2nibble(C: Character) return Nibble is
begin
if C<='f' and then C>='a' then
return Nibble(10 + (Character'Pos(C) - Character'Pos('a')));
end if;
if C<='F' and then C>='A' then
return Nibble(10 + (Character'Pos(C) - Character'Pos('A')));
end if;
if C<='9' and then C>='0' then
return Nibble(Character'Pos(C) - Character'Pos('0'));
end if;
raise Wrong_Type;
end Hex2nibble;
begin
K := S'First;
N := 1;
while K <= S'Last loop
if S(K)/='-' then
Uu(N) := Hex2nibble(S(K));
N := N+1;
end if;
K := K+1;
end loop;
if N/=33 then
raise Wrong_Type;
end if;
if (Uu(17)/4)/=Nibble(2) then
-- if the version is not 2, it is out of luck! must deal with zero thouh
raise Wrong_Type;
end if;
Uutype := Integer(Uu(17) mod 4);
Version := Integer(Uu(13));
if Version<1 or else Version>=5 then
raise Wrong_Type; -- sorry
end if;
declare
Rv: Corlid(Rfc4122_Uuid_Types(Version,Uutype));
begin
N := 1; -- cursor in uu
K := 1; -- cursor in Rv.Uunib
while N<=32 loop
if N/=13 and then N/=17 then
Rv.Uunib(K) := Uu(N);
K := K+1;
end if;
N := N+1;
end loop;
return Rv;
end;
end Uuid_Read;
Uuid_Version: constant array(Corlidtype) of Nibble :=
( Uuid_V1_0 => 1, Uuid_V1_1 => 1, Uuid_V1_2 => 1, Uuid_V1_3 => 1,
Uuid_V2_0 => 2, Uuid_V2_1 => 2, Uuid_V2_2 => 2, Uuid_V2_3 => 2,
Uuid_V3_0 => 3, Uuid_V3_1 => 3, Uuid_V3_2 => 3, Uuid_V3_3 => 3,
Uuid_V4_0 => 4, Uuid_V4_1 => 4, Uuid_V4_2 => 4, Uuid_V4_3 => 4,
Uuid_V5_0 => 5, Uuid_V5_1 => 5, Uuid_V5_2 => 5, Uuid_V5_3 => 5,
others => 0);
Uuid_Databits: constant array(Corlidtype) of Nibble :=
( Uuid_V1_0 => 0, Uuid_V1_1 => 1, Uuid_V1_2 => 2, Uuid_V1_3 => 3,
Uuid_V2_0 => 0, Uuid_V2_1 => 1, Uuid_V2_2 => 2, Uuid_V2_3 => 3,
Uuid_V3_0 => 0, Uuid_V3_1 => 1, Uuid_V3_2 => 2, Uuid_V3_3 => 3,
Uuid_V4_0 => 0, Uuid_V4_1 => 1, Uuid_V4_2 => 2, Uuid_V4_3 => 3,
Uuid_V5_0 => 0, Uuid_V5_1 => 1, Uuid_V5_2 => 2, Uuid_V5_3 => 3,
others => 15);
Tohex: constant array(Nibble) of Character :=
('0', '1', '2', '3', '4', '5', '6', '7', '8', '9', 'a', 'b', 'c', 'd', 'e', 'f');
function Uuid_To_String(C: Corlid) return String is
Rv: String(1..36);
K: Integer;
begin
if Uuid_Databits(C.Ctype)=15 or else Uuid_Version(C.Ctype)=0 then
raise Wrong_Type;
end if;
K := 1;
for N in 1..8 loop
Rv(K) := Tohex(C.Uunib(N));
K := K+1;
end loop;
Rv(K) := '-';
K := K+1;
for N in 9..12 loop
Rv(K) := Tohex(C.Uunib(N));
K := K+1;
end loop;
Rv(K) := '-';
K := K+1;
Rv(K) := Tohex(Uuid_Version(C.Ctype));
K := K+1;
for N in 13..15 loop
Rv(K) := Tohex(C.Uunib(N));
K := K+1;
end loop;
Rv(K) := '-';
K := K+1;
Rv(K) := Tohex(8+Uuid_Databits(C.Ctype));
K := K+1;
for N in 16..18 loop
Rv(K) := Tohex(C.Uunib(N));
K := K+1;
end loop;
Rv(K) := '-';
K := K+1;
for N in 19..30 loop
Rv(K) := Tohex(C.Uunib(N));
K := K+1;
end loop;
return Rv;
end Uuid_To_String;
-- -- char encodings A, B and C
Badchar: Short_Short_Integer:= 111;
Char_To_Enca: array(Character) of Short_Short_Integer := ( others => Badchar );
Enca_To_Char: constant array(Base64char) of Character :=
( 'A', 'B', 'C', 'D', 'E', 'F',
'G', 'H', 'I', 'J', 'K', 'L',
'M', 'N', 'O', 'P', 'Q', 'R',
'S', 'T', 'U', 'V', 'W', 'X',
'Y', 'Z', '.', '_', '0', '1',
'2', '3', '4', '5', '6', '7',
'8', '9', 'a', 'b', 'c', 'd',
'e', 'f', 'g', 'h', 'i', 'j',
'k', 'l', 'm', 'n', 'o', 'p',
'q', 'r', 's', 't', 'u', 'v',
'w', 'x', 'y', 'z' );
Char_To_Encb: array(Character) of Short_Short_Integer := (others => Badchar);
Encb_To_Char: constant array(Base64char) of Character :=
( 'A', 'B', 'C', 'D', 'E', 'F',
'G', 'H', 'I', 'J', 'K', 'L',
'M', 'N', 'O', 'P', 'Q', 'R',
'S', 'T', 'U', 'V', 'W', 'X',
'Y', 'Z', '.', '_', '0', '1',
'2', '3', '4', '5', '6', '7',
'8', '9', '!', '@', '#', '$',
'%', '^', '&', '+', '-', '*',
'/', '\', '~', ',', ''', '`',
'<', '=', '>', '?', '|', ' ',
'[', ']', '(', ')' );
Char_To_Encc: array(Character) of Short_Short_Integer := (others => Badchar);
Encc_To_Char: constant array(Base32char) of Character :=
( 'A', 'B', 'C', 'D', 'E', 'F',
'G', 'H', 'I', 'J', 'K', 'L',
'M', 'N', 'O', 'P', 'Q', 'R',
'S', 'T', 'U', 'V', 'W', 'X',
'Y', 'Z', '.', '_', '+', '-',
'*', '/');
procedure Init_Encodings is
begin
for K in Base64char loop
Char_To_Enca(Enca_To_Char(K)) := Short_Short_Integer(K);
Char_To_Encb(Encb_To_Char(K)) := Short_Short_Integer(K);
end loop;
for K in Base32char loop
Char_To_Encc(Encc_To_Char(K)) := Short_Short_Integer(K);
end loop;
end Init_Encodings;
function String_To_Enca(S: String) return Abstring is
Rv: Abstring(1..S'Length);
C: Short_Short_Integer;
begin
for K in S'Range loop
C := Char_To_Enca(S(K));
if C=Badchar then
raise Wrong_Type;
end if;
Rv(1+K-S'First) := Base64char(C);
end loop;
return Rv;
end String_To_Enca;
function Enca_To_String(S: Abstring) return String is
Rv: String(1..S'Length);
begin
for K in S'Range loop
Rv(1+K-S'First):= Enca_To_Char(S(K));
end loop;
return Rv;
end Enca_To_String;
function String_To_Encb(S: String) return Abstring is
Rv: Abstring(1..S'Length);
C: Short_Short_Integer;
begin
for K in S'Range loop
C := Char_To_Encb(S(K));
if C=Badchar then
raise Wrong_Type;
end if;
Rv(1+K-S'First) := Base64char(C);
end loop;
return Rv;
end String_To_Encb;
function Encb_To_String(S: Abstring) return String is
Rv: String(1..S'Length);
begin
for K in S'Range loop
Rv(1+K-S'First):= Encb_To_Char(S(K));
end loop;
return Rv;
end Encb_To_String;
function String_To_Encc(S: String) return Cstring is
Rv: Cstring(1..S'Length);
C: Short_Short_Integer;
begin
for K in S'Range loop
C := Char_To_Encc(S(K));
if C=Badchar then
raise Wrong_Type;
end if;
Rv(1+K-S'First) := Base32char(C);
end loop;
return Rv;
end String_To_Encc;
function Encc_To_String(S: Cstring) return String is
Rv: String(1..S'Length);
begin
for K in S'Range loop
Rv(1+K-S'First):= Encc_To_Char(S(K));
end loop;
return Rv;
end Encc_To_String;
-- -- earlier char encoding, will dissapear from here
CH_To_Base64: array(Character) of Base64char;
procedure Init_Ch_To_Base64 is
begin
for C in Character loop
CH_To_base64(C) := 62;
if C>='0' and then C<='9' then
CH_To_base64(C) := Character'Pos(C) - Character'Pos('0');
end if;
if C>='a' and then C<='z' then
CH_To_base64(C) := Character'Pos(C) - Character'Pos('a') + 10;
end if;
if C>='A' and then C<='Z' then
CH_To_base64(C) := Character'Pos(C) - Character'Pos('A') + 36;
end if;
end loop;
Ch_To_base64('.') := 62;
Ch_To_base64('_') := 63;
end Init_Ch_To_Base64;
function Base64_To_Ch(B: Base64char) return Character is
-- b must be less than 64
begin
if B < 10 then
return Character'Val(B + Character'Pos('0'));
end if;
if B < 36 then
return Character'Val(B + Character'Pos('a') - 10);
end if;
if B < 62 then
return Character'Val(B + Character'Pos('A') - 36);
end if;
if B=62 then
return '.';
end if;
if B=63 then
return '_';
end if;
raise Constraint_Error;
end Base64_To_Ch;
function To_Eightchars(S: String) return Eightchars is
Rv: Eightchars;
begin
for K in S'Range loop
Rv(K-S'First+1) := Ch_To_Base64(S(K));
end loop;
for K in S'Last+1..(Rv'Last+S'First-1) loop
Rv(K-S'First+1) := Ch_To_Base64('.');
end loop;
return Rv;
end To_Eightchars;
function To_String(Ei: Eightchars) return String is
Rv: String(1..8);
begin
for K in 1..8 loop
Rv(K) := Base64_To_Ch(Ei(K));
end loop;
for K in reverse 1..8 loop
if Rv(K)/='.' then
return Rv(1..K);
end if;
end loop;
return "";
end To_String;
function Is_Added_Physical_Dimension(Sd: String) return Boolean is
begin
return Sd="kWh" or else Sd="J";
end Is_Added_Physical_Dimension;
function Added_Physical_Dimension(Sd: String) return Corlid is
Sd1: String:= "" & Sd;
begin
if Sd1="kWh" then
return Kwh;
end if;
if Sd1="J" then
return Joule;
end if;
return Adimensional; -- not yet, let's see it works
end Added_Physical_Dimension;
function Is_Physical_Dimension(Sd: String) return Boolean is
K,Loc: Integer;
begin
if Is_Added_Physical_Dimension(Sd) then
return True;
end if;
K := Sd'First;
-- get them one by one
Loc := 0; -- before possible elementary dimension
while K<=Sd'Last loop
if Loc=0 then -- / or * may follow or not (implicit *)
if Sd(K)='/' or else Sd(K)='*' then
K := K+1;
end if;
Loc := 1;
elsif Loc=1 then -- a fundamental unit must be present
if Sd(K)='m' or else Sd(K)='s' or else Sd(K)='K' or else Sd(K)='A' then
K := K+1;
Loc := 2;
elsif K+1<=Sd'Last and then (Sd(K..K+1)="cd" or else Sd(K..K+1)="kg") then
K := K+2;
Loc := 2;
elsif K+2<=Sd'Last and then Sd(K..K+2)="mol" then
K := K+3;
Loc := 2;
else
return False;
end if;
elsif Loc=2 then -- we are past the unit; it may be a number or a power or a new unit
-- may start, so if it is not a number we get back to loc=0
if Sd(K)<='8' and then Sd(K)>='0' then
K := K+1; -- we are past now
end if;
Loc := 0; -- we don't support fractional powers yet, a new unit must follow or be the end
end if;
end loop;
if Loc/=2 and then Loc/=0 then
return False;
end if;
return True;
end Is_Physical_Dimension;
function Physical_Dimension(Sd: String) return Corlid is -- in fact, quant
K,Loc: Integer;
Mode: Integer; -- 1 if the next to be multiplied, -1 if to be divided
Rv: Corlid:= Adimensional;
Crt: Si_Base_Unit:= Metre;
begin
if Is_Added_Physical_Dimension(Sd) then
return Added_Physical_Dimension(Sd);
end if;
K := Sd'First;
-- get them one by one
Loc := 0; -- before possible elementary dimension
Mode := 1; -- assume multiplication
while K<=Sd'Last loop
if Loc=0 then -- / or * may follow or not (implicit *)
Mode := 1;
if Sd(K)='/' or else Sd(K)='*' then
if Sd(K)='/' then
Mode := -1;
end if;
K := K+1;
end if;
Loc := 1;
elsif Loc=1 then -- a fundamental unit must be present
if Sd(K)='m' or else Sd(K)='s' or else Sd(K)='K' or else Sd(K)='A' then
if Sd(K)='m' then
Crt := Metre;
elsif Sd(K)='s' then
Crt := Second;
elsif Sd(K)='A' then
Crt := Ampere;
elsif Sd(K)='K' then
Crt := Kelvin;
end if;
K := K+1;
Loc := 2;
elsif K+1<=Sd'Last and then (Sd(K..K+1)="cd" or else Sd(K..K+1)="kg") then
if Sd(K..K+1)="cd" then
Crt := Candela;
elsif Sd(K..K+1)="kg" then
Crt := Kilogram;
end if;
K := K+2;
Loc := 2;
elsif K+2<=Sd'Last and then Sd(K..K+2)="mol" then
Crt := Mole;
K := K+3;
Loc := 2;
else
return Adimensional; -- an exception would be more suitable
end if;
elsif Loc=2 then -- we are past the unit; it may be a number or a power or a new unit
-- may start, so if it is not a number we get back to loc=0
if Sd(K)<='8' and then Sd(K)>='0' then
Mode := Mode * Integer(Character'Pos(Sd(K)) - Character'Pos('0'));
K := K+1; -- we are past now
end if;
Rv.Unit(Crt) := Rv.Unit(Crt) + Unit_Power(Mode);
Loc := 0; -- we don't support fractional powers yet, a new unit must follow or be the end
end if;
end loop;
if Loc/=2 and then Loc/=0 then
return Adimensional;
end if;
if Loc=2 and then (Mode=1 or else Mode=-1) then
Rv.Unit(Crt) := Rv.Unit(Crt) + Unit_Power(Mode);
end if;
return Rv;
end Physical_Dimension;
function Dimensional_Read(S: String; K: Integer) return Corlid is
begin
if Is_Physical_Dimension("" & S(K..S'Last)) then
declare
Rv: Corlid(Quant):= Physical_Dimension(S(K..S'Last)); -- converts the unit into that
begin
Rv.Value := Rv.Value * Long_Float'Value(S(S'First..(K-1)));
return Rv;
end;
else
declare
Rv: Corlid(Fixed_b7);
Vu: Long_Long_Float:= Long_Long_Float'Value(S(S'First..(K-1)));
Padded: String(1..7):= ( others => '.');
begin
-- will always have two decimals currently, but this may need adjusting
-- some policy must be introduced
Rv.B7_Value := Cobolnr(Vu*10000.0);
Rv.B7_Decimals := 4;
Padded(1..S'Last-K+1) := S(K..S'Last);
Rv.B7_Name := Abstring7(String_To_Encb(Padded));
return Rv;
end;
end if;
end Dimensional_Read;
function Fast_String_Match(S, Pic: String) return Boolean is
begin
for K in S'Range loop
if Pic(Pic'First+K-S'First)<='9' and then Pic(Pic'First+K-S'First)>='0' then
if S(K)<=Pic(Pic'First+K-S'First) and then S(K)>='0' then
null; -- ok, test passed
else
return False;
end if;
elsif Pic(Pic'First+K-S'First)/=S(K) and then Pic(Pic'First+K-S'First)/='X' then
return False;
end if;
end loop;
return True;
end Fast_String_Match;
Time_Multiplier: constant array(1..19) of Long_Float:=
( 36_000.0, 3_600.0, 0.0, 600.0, 60.0, 0.0, 10.0, 1.0, 0.0, 0.1,
0.01, 0.001, 0.0001, 0.00001, 0.000001, 0.000_000_1, 0.000_000_01,
0.000_000_001, 0.000_000_0001 );
function Time_Read(S: String) return Corlid is
-- it may return a nstime object or a quant with a number of seconds!
Rvt: Corlid(Nstime);
Rvq: Corlid := (Ctype => Quant, Radical => (others => 1),
Unit => (Metre => 0, Kilogram => 0, Second => 1, Ampere => 0,
Kelvin => 0, Candela => 0, Mole => 0),
Value => 1.0);
function Is_Daytime_String(S: String) return Boolean is
Daytime_Pic_1: String:= "23:59:59.9999999999";
Daytime_Pic_2: String:= "9:59:59.9999999999";
Daytime_Pic_3: String:= "19:59:59.9999999999";
begin
return Fast_String_Match(S,Daytime_Pic_1(1..S'Length)) or else
Fast_String_Match(S,Daytime_Pic_2(1..S'Length)) or else
Fast_String_Match(S,Daytime_Pic_3(1..S'Length));
end Is_Daytime_String;
function Daytime_To_Seconds(S: String) return Long_Float is
Rv: Long_Float:= 0.0;
begin
for K in S'Range loop
Rv := Rv+Long_Float(Character'Pos(S(K))-Character'Pos('0'))*
Time_Multiplier(K-S'First+1);
end loop;
return Rv;
end Daytime_To_Seconds;
begin
if Is_Daytime_String(S) then
if S(S'First+1)=':' then
Rvq.Value := Daytime_To_Seconds('0' & S);
else
Rvq.Value := Daytime_To_Seconds(S);
end if;
return Rvq;
end if;
Rvt.Ada_Time := Gnat.Calendar.Time_Io.Value(S);
return Rvt;
end Time_Read;
function Make_Sym_A18(S: Abstring18) return Corlid is
Rv: Corlid(Sym_A18);
begin
-- Rv := Enzero(Rv);
Rv.AB18_Sym := S;
return Rv;
end Make_Sym_A18;
function Make_Sym_B18(S: Abstring18) return Corlid is
Rv: Corlid(Sym_B18);
begin
-- Rv := Enzero(Rv);
Rv.AB18_Sym := S;
return Rv;
end Make_Sym_B18;
function Make_Sym_C22(S: Cstring22) return Corlid is
Rv: Corlid(Sym_C22);
begin
-- Rv := Enzero(Rv);
Rv.C22_Sym := S;
return Rv;
end Make_Sym_C22;
function Symbol_Read(S: String; Encoding: Character:= 'x') return Corlid is
Padded: String(1..22):= ( others => '.');
Rvab: Abstring(1..18):= (others => 0);
Rvc: Cstring(1..22):= (others => 0);
begin
if S'Length>22 then
raise Wrong_Type;
end if;
Padded(1..S'Length) := S;
if S'Length>18 then
if Encoding='x' or else Encoding='C' then
Rvc(1..22) := String_To_Encc(Padded(1..22));
return Make_Sym_C22(Cstring22(Rvc(1..22)));
else
raise Wrong_Type; -- this time, seriously
end if;
end if;
-- attempt to read it as type a if allowed
if Encoding='x' or else Encoding='A' then
begin
Rvab(1..18) := String_To_Enca(Padded(1..18));
return Make_Sym_A18(Abstring18(Rvab(1..18)));
exception
when Wrong_Type =>
if Encoding='A' then
raise; -- truly wrong type
else
null; -- maybe another encoding works
end if;
end;
end if;
if Encoding='x' or else Encoding='B' then
Rvab(1..18) := String_To_Encb(Padded(1..18));
return Make_Sym_B18(Abstring18(Rvab(1..18)));
end if;
raise Wrong_Type;
end Symbol_Read;
function Read_String_On(S: String) return Uuid is
R: Corlid(String_On);
-- following syntax: n_uuids,n_chars
Ni,Nc: Integer:= 0;
Ki: Integer:= S'First;
begin
while S(Ki)/=',' loop -- must be a digit
if S(Ki)>'9' or else S(Ki)<'0' then
raise Wrong_Type; -- wrong string start syntax
end if;
Ni := Ni*10 + Character'Pos(S(Ki))-Character'Pos('0');
Ki := Ki+1;
end loop;
Ki := Ki+1;
while Ki < S'Last loop -- must be a digit
if S(Ki)>'9' or else S(Ki)<'0' then
raise Wrong_Type; -- wrong string start syntax, non numeric in nr of characters
end if;
Nc := Nc*10 + Character'Pos(S(Ki))-Character'Pos('0');
Ki := Ki+1;
end loop;
R.Len7on := Ni;
R.Nch7on := Nc;
return To_Uuid(R);
end Read_String_On;
function Read_List(S: String) return Uuid is
R: Corlid(List);
-- following syntax: n_uuids,n_chars
Ni,Ns: Integer:= 0;
Ki: Integer:= S'First;
begin
while S(Ki)/=',' loop -- must be a digit
if S(Ki)>'9' or else S(Ki)<'0' then
raise Wrong_Type; -- wrong string start syntax
end if;
Ni := Ni*10 + Character'Pos(S(Ki))-Character'Pos('0');
Ki := Ki+1;
end loop;
Ki := Ki+1;
while Ki < S'Last loop -- must be a digit
if S(Ki)>'9' or else S(Ki)<'0' then
raise Wrong_Type; -- wrong string start syntax, non numeric in nr of characters
end if;
Ns := Ns*10 + Character'Pos(S(Ki))-Character'Pos('0');
Ki := Ki+1;
end loop;
R.Len := Ni;
R.Lisz := Ns;
R.Listype := Abstring7(String_To_Encb(".......")); -- 7 dots
return To_Uuid(R);
end Read_List;
function Read_Pointer(S: String) return Uuid is
R: Corlid(Pointer);
-- following syntax: n_uuids,n_chars
Ni: Integer:= 0;
Ki: Integer:= S'First;
begin
while Ki < S'Last loop -- must be a digit
if S(Ki)>'9' or else S(Ki)<'0' then
raise Wrong_Type; -- wrong string start syntax, non numeric in nr of characters
end if;
Ni := Ni*10 + Character'Pos(S(Ki))-Character'Pos('0');
Ki := Ki+1;
end loop;
R.Index := Ni;
return To_Uuid(R);
end Read_Pointer;
function Read_Matrix(S: String) return Uuid is
R: Corlid(Matrix);
-- following syntax: n_uuids,n_chars
Nc,Nch,Nr,Nrh: Integer:= 0;
Ki: Integer:= S'First;
begin
while S(Ki)/='+' loop -- must be a digit
if S(Ki)>'9' or else S(Ki)<'0' then
raise Wrong_Type; -- wrong string start syntax
end if;
Nc := Nc*10 + Character'Pos(S(Ki))-Character'Pos('0');
Ki := Ki+1;
end loop;
Ki := Ki+1;
while S(Ki)/=',' loop -- must be a digit
if S(Ki)>'9' or else S(Ki)<'0' then
raise Wrong_Type; -- wrong string start syntax
end if;
Nch := Nch*10 + Character'Pos(S(Ki))-Character'Pos('0');
Ki := Ki+1;
end loop;
Ki := Ki+1;
while S(Ki)/='+' loop -- must be a digit
if S(Ki)>'9' or else S(Ki)<'0' then
raise Wrong_Type; -- wrong string start syntax
end if;
Nr := Nr*10 + Character'Pos(S(Ki))-Character'Pos('0');
Ki := Ki+1;
end loop;
Ki := Ki+1;
while Ki < S'Last loop -- must be a digit
if S(Ki)>'9' or else S(Ki)<'0' then
raise Wrong_Type; -- wrong string start syntax, non numeric in nr of characters
end if;
Nrh := Nrh*10 + Character'Pos(S(Ki))-Character'Pos('0');
Ki := Ki+1;
end loop;
R.Colheads := Short_Short_Integer(Nch);
R.Rowheads := Short_Short_Integer(Nrh);
R.Cols := Nc;
R.Rows := Nr;
R.Matype := Abstring4(String_To_Encb("....")); -- 4 dots
return To_Uuid(R);
end Read_Matrix;
function Read_Endstruct(S: String) return Uuid is
R: Corlid(Endstruct);
-- following syntax: n_uuids,n_chars
Ni: Integer:= 0;
Ki: Integer:= S'First;
begin
while Ki < S'Last loop -- must be a digit
if S(Ki)>'9' or else S(Ki)<'0' then
raise Wrong_Type; -- wrong string start syntax, non numeric in nr of characters
end if;
Ni := Ni*10 + Character'Pos(S(Ki))-Character'Pos('0');
Ki := Ki+1;
end loop;
R.Endlen := Ni;
return To_Uuid(R);
end Read_Endstruct;
function Qualified_Read(S: String; K: Integer) return Corlid is
Tag: String:= S(S'First..(K-1));
Ki: Kind_Reg_Cursor;
begin
Ki := Locate_Kind(Tag);
if Ki=No_Kind then
return Read(S(K+1..S'Last));
end if;
if Kind_Reg(Ki).Reader=null then
return Read(S(K+1..S'Last));
end if;
return To_Corlid(Kind_Reg(Ki).Reader(S(K+1..S'Last)));
end Qualified_Read;
function Read(S: String) return Corlid is
-- given a token that is parseable, for example as it contains
-- no spaces, try to determine the corlid type, parse it and return
-- as a corlid
Uuidf: Boolean:= True;
K: Integer;
begin
if S'Length=32 or else S'Length=36 then
for K in S'Range loop
if not ((S(K)<='9' and then S(K)>='0') or else
(S(K)<='f' and then S(K)>='a') or else
(S(K)<='F' and then S(K)>='A') or else
S(K)='-') then
Uuidf := False;
exit;
end if;
end loop;
if Uuidf then -- test passed
return Uuid_Read(S);
end if;
end if;
-- not an uuid, we can proceed
if S(S'First)='-' or else S(S'First)='+' or else
-- each of these must be replaced with a char boolean vector
(S(S'First)<='9' and then S(S'First)>='0') then
-- looks numerish
K := S'First+1;
while K<=S'Last and then S(K)<='9' and then S(K)>='0' loop
K := K+1;
end loop;
-- is it the end of it? the it is an integer
if K>S'Last then
return Adimensional_Quant_Read(S);
end if;
if S(K)='.' then
K := K+1;
while K<=S'Last and then S(K)<='9' and then S(K)>='0' loop
K := K+1;
end loop;
if K > S'Last then
return Adimensional_Quant_Read(S); -- simple decimal notation
end if;
end if;
if S(K)='e' or else S(K)='E' then -- it may be exponential notation
K := K+1;
if K>S'Last then -- it is something like [+-]*[.*][Ee]
-- we interpret that as meaning E0
return Adimensional_Quant_Read(S(S'First..S'Last-1));
end if;
if S(K)='-' or else S(K)='+' or else (S(K)>='0' and then S(K)<='9') then
-- it is an exponent
K := K+1;
while K<=S'Last and then S(K)<='9' and then S(K)>='0' loop
K := K+1;
end loop;
if K>S'Last then -- in principle, -12e+ is possible
return Adimensional_Quant_Read(S);
end if;
else
K := K-1; -- go back, e is from 'EUR' or something :)
end if;
end if;
if S(K)='-' or else S(K)='/' or else S(K)=':' then -- it could be a date
if (K-S'First)<=4 and then S(S'First)<='9' and then S(S'First)>='0' then
-- more detailed verifications would be welcome
-- Put_line(S);
for U in K..S'Last loop
if not ((S(U)<='9' and then S(U)>='0') or else S(U)='-' or else S(U)='/'
or else S(U)=':') then
-- Put_Line(" (" & S(S'First..U-1) & ")");
return Time_Read(S(S'First..U-1));
end if;
end loop;
return Time_Read(S);
end if;
end if;
-- otherwise, it was a number so far and a unit must follow
if (S(K)>='a' and then S(K)<='z') or else (S(K)>='A' and then S(K)<='Z')
or else S(K)='*' or else S(K)='/' then
return Dimensional_Read(S,K);
end if;
-- a unit doesn't follow, but something else does, we don't know what, error
raise Wrong_Type;
else -- not starting with a decimal number; it could be a symbol or
-- some identifier; if we find a colon after at most 8 alphanumeric
-- characters then we consider it a qualified object; otherwise,
-- we try to read it as a normal symbol
K := S'First;
if (S(K)>='a' and then S(K)<='z') or else (S(K)>='A' and then S(K)<='Z') or else
S(K)='_' or else S(K)='.' then
K := K+1;
while K<=S'Last and then
((S(K)>='a' and then S(K)<='z')
or else (S(K)>='A' and then S(K)<='Z')
or else (S(K)>='0' and then S(K)<='9')) loop
K := K+1;
end loop;
if K>S'Last then -- its a symbol
return Symbol_Read(S);
end if;
if S(K)=':' then
return Qualified_Read(S,K);
end if;
return Symbol_Read(S);
else
raise Wrong_Type; -- it doesn't start with something interpretable by us
end if;
end if;
end Read;
function Dot_Trim(S: String) return String is
begin
for K in reverse S'Range loop
if S(K)/='.' then
return S(S'First..K);
end if;
end loop;
return "";
end Dot_Trim;
function Format(Su: Si_Unit) return String is
Rv: String(1..128); -- enough space, man
Ri,K: Integer;
procedure Addu(Pwi: Unit_Power; U: String) is
Pw: Integer:= Integer(Pwi);
begin
if Pw<0 then
Rv(Ri) := '/';
Ri := Ri+1;
Pw := -Pw;
end if;
if Pw/=0 then
for J in U'Range loop
Rv(Ri) := U(J);
Ri := Ri+1;
end loop;
if Pw>1 then
Rv(Ri) := Character'Val(Character'Pos('0') + Pw);
Ri := Ri+1;
end if;
end if;
-- K := 0;
--
-- while KPw loop
-- Rv(Ri) := '/';
-- Ri := Ri+1;
-- for J in U'Range loop
-- Rv(Ri) := U(J);
-- Ri := Ri+1;
-- end loop;
-- K := K-1;
-- end loop;
end Addu;
begin
Ri:= 1;
Addu(Su(Metre),"m");
Addu(Su(Kilogram),"kg");
Addu(Su(Second),"s");
Addu(Su(Ampere),"A");
Addu(Su(Kelvin),"K");
Addu(Su(Candela),"cd");
Addu(Su(Mole),"mol");
return Rv(1..(Ri-1));
end Format;
function Format(C: Corlid; Prefix: Boolean:= False) return String is
function Utrim(C: String) return String is
begin
if C(C'First)=' ' then
return C(C'First+1..C'Last);
end if;
return C;
end Utrim;
Pref: String:= Kind(To_Uuid(C)) & ':';
Preflen: Integer:= Pref'Length;
begin
-- case C.Ctype is
-- when Quant =>
-- Pref(1..2) := "q:";
-- Preflen:= 2;
-- when Sym_A18 =>
-- Pref(1..5) := "syma:";
-- Preflen:= 5;
-- when Sym_B18 =>
-- Pref(1..5) := "symb:";
-- Preflen:= 5;
-- when Sym_C22 =>
-- Pref(1..5) := "symc:";
-- Preflen:= 5;
-- when Fixed_B7 =>
-- Pref(1..7) := "fixedb:";
-- Preflen:= 7;
-- when Nstime =>
-- Pref(1..2) := "t:";
-- Preflen := 2;
-- when String_On =>
-- Pref(1..7) := "string:";
-- Preflen := 7;
-- when Endstruct =>
-- Pref(1..10) := "endstring:";
-- Preflen := 10;
-- when Zascii7 =>
-- Pref(1..8) := "zascii7:";
-- Preflen := 8;
-- when Uuid_V1_0 | Uuid_V1_1 | Uuid_V1_2 | Uuid_V1_3
-- | Uuid_V2_0 | Uuid_V2_1 | Uuid_V2_2 | Uuid_V2_3
-- | Uuid_V3_0 | Uuid_V3_1 | Uuid_V3_2 | Uuid_V3_3
-- | Uuid_V5_0 | Uuid_V5_1 | Uuid_V5_2 | Uuid_V5_3
-- | Uuid_V4_0 | Uuid_V4_1 | Uuid_V4_2 | Uuid_V4_3 =>
-- Pref(1..5) := "uuid:";
-- Preflen := 5;
-- when others =>
-- raise Wrong_Type;
-- end case;
if not Prefix then
Preflen := 0;
end if;
case C.Ctype is
when Quant =>
return Pref(1..Preflen) & Utrim(Long_Float'Image(C.Value)) & Format(C.Unit);
when Sym_A18 =>
return Pref(1..Preflen) & Dot_Trim(Enca_To_String(Abstring(C.AB18_Sym)));
when Sym_B18 =>
return Pref(1..Preflen) & Dot_Trim(Encb_To_String(Abstring(C.AB18_Sym)));
when Sym_C22 =>
return Pref(1..Preflen) & Dot_Trim(Encc_To_String(Cstring(C.C22_Sym)));
when Fixed_B7 =>
return Pref(1..Preflen) & Utrim(Long_Long_Integer'Image(C.B7_Value/10000)) & "." &
Utrim(Long_Long_integer'Image(C.B7_Value mod 10000)) &
Dot_Trim(Encb_To_String(Abstring(C.B7_Name)));
-- we must in fact use one of ada's fixed point formats
when String_On =>
return Pref(1..Preflen) & Utrim(Integer'Image(C.Len7on)) & "," &
Utrim(Integer'Image(C.Nch7on));
when Matrix =>
-- if matype is not "...." we'll see, but now..
return Pref(1..Preflen) & Utrim(Integer'Image(C.Cols)) & '+' &
Utrim(Short_Short_Integer'Image(C.Colheads)) & ',' & Utrim(Integer'Image(C.Rows)) &
'+' & Utrim(Short_Short_Integer'Image(C.Rowheads));
when List =>
return Pref(1..Preflen) & Utrim(Integer'Image(C.Len)) & ',' & Utrim(Integer'Image(C.Lisz));
when Pointer =>
return Pref(1..Preflen) & Utrim(Integer'Image(C.Index));
when Endstruct =>
return Pref(1..Preflen) & Utrim(Integer'Image(C.Endlen));
when Zascii7 =>
declare
Rs: String(1..50);
Ri: Integer:= 1;
begin
for K in C.Str7'Range loop
if C.Str7(K)=0 then
exit;
end if;
if C.Str7(K) < 32 then
Rs(Ri) := '\';
Ri := Ri+1;
Rs(Ri) := '0';
Ri := Ri+1;
Rs(Ri) := Character'Val(Character'Pos('0') + C.Str7(K)/8);
Ri := Ri+1;
Rs(Ri) := Character'Val(Character'Pos('0') + C.Str7(K) mod 8);
Ri := Ri+1;
elsif C.Str7(K)=Character'Pos('"') or else C.Str7(K)=Character'Pos('\') then
Rs(Ri) := '\';
Ri := Ri+1;
Rs(Ri) := Character'Val(C.Str7(K));
Ri := Ri+1;
else
Rs(Ri) := Character'Val(C.Str7(K));
Ri := Ri+1;
end if;
end loop;
Ri := Ri-1;
return Pref(1..Preflen) & Rs(1..Ri);
end;
when Nstime =>
return Pref(1..Preflen) &
Gnat.Calendar.Time_Io.Image(C.Ada_Time, Gnat.Calendar.Time_Io.Iso_Date);
when Uuid_V1_0 | Uuid_V1_1 | Uuid_V1_2 | Uuid_V1_3
| Uuid_V2_0 | Uuid_V2_1 | Uuid_V2_2 | Uuid_V2_3
| Uuid_V3_0 | Uuid_V3_1 | Uuid_V3_2 | Uuid_V3_3
| Uuid_V5_0 | Uuid_V5_1 | Uuid_V5_2 | Uuid_V5_3
| Uuid_V4_0 | Uuid_V4_1 | Uuid_V4_2 | Uuid_V4_3 =>
return Pref(1..Preflen) & Uuid_To_String(C);
when others =>
raise Wrong_Type;
end case;
end Format;
-- OBSOLETE V0.2 UUID CODE
-- the code below, for building uuids is obsolete, replaced with the code above
-- it will be removed in a future version
CH_To_Block: array(Character) of Uuid_Block;
procedure Init_Ch_To_Block is
begin
for C in Character loop
CH_To_Block(C) := 999;
if C>='0' and then C<='9' then
CH_To_Block(C) := Character'Pos(C) - Character'Pos('0');
end if;
if C>='a' and then C<='z' then
CH_To_Block(C) := Character'Pos(C) - Character'Pos('a') + 10;
end if;
if C>='A' and then C<='Z' then
CH_To_Block(C) := Character'Pos(C) - Character'Pos('A') + 36;
end if;
end loop;
Ch_To_Block(':') := 62;
Ch_To_Block('_') := 63;
end Init_Ch_To_Block;
function Block_To_Ch(B: Uuid_Block) return Character is
-- b must be less than 64
begin
if B < 10 then
return Character'Val(B + Character'Pos('0'));
end if;
if B < 36 then
return Character'Val(B + Character'Pos('a') - 10);
end if;
if B < 62 then
return Character'Val(B + Character'Pos('A') - 36);
end if;
if B=62 then
return ':';
end if;
if B=63 then
return '_';
end if;
raise Constraint_Error;
end Block_To_Ch;
function To_String(U: Uuid; Syntax: Uuid_Syntax:= Symbol;
Dash: Character:= '_'; Sep: Character:= ':') return String is
Rv: String(1..20):= ( others => ':') ;
V: Uuid_Block;
L: Integer;
begin
V := U.Lo;
for K in reverse 11..20 loop
Rv(K) := Block_To_Ch(V mod 64);
V := V / 64;
end loop;
V := U.Hi;
for K in reverse 1..10 loop
Rv(K) := Block_To_Ch(V mod 64);
V := V / 64;
end loop;
L := 20;
while L>1 and then Rv(L)=':' loop
L := L-1;
end loop;
return Rv(1..L);
end To_String;
function To_Uuid(S: String; Dash: Character:= '_'; Sep: Character:= ':') return Uuid is
U,V: Uuid_Block:= 0;
Rv: Uuid;
begin
if S'Length <= 20 then
for K in 0..9 loop
if K+S'First <= S'Last then
if Ch_To_Block(S(K+S'First))=999 then
raise Uuid_Syntax_Not_Supported;
end if;
U := U * 64 + Ch_To_Block(S(K+S'First));
else
U := U * 64 + Ch_To_Block(':');
end if;
end loop;
for K in 10..19 loop
if K+S'First <= S'Last then
if Ch_To_Block(S(K+S'First))=999 then
raise Uuid_Syntax_Not_Supported;
end if;
V := V * 64 + Ch_To_Block(S(K+S'First));
else
V := V * 64 + Ch_To_Block(':');
end if;
end loop;
Rv.Hi := U;
Rv.Lo := V;
return Rv;
end if;
if Dash/= '_' then
raise Uuid_Syntax_Not_Supported;
end if;
if Sep/= ':' then
raise Uuid_Syntax_Not_Supported;
end if;
raise Uuid_Syntax_Not_Supported;
end To_Uuid;
function To_String(T: Time; Accuracy: Positive:= 10) return String is
Rv: String(1..10);
Sec: Float;
Subsec: Integer;
begin
-- compact representation of time in the 2000-2060 inteval, 6 characters to the second
-- 10 to or 1/16 of a microsecond
Rv(1) := Block_To_Ch(Uuid_Block(Year(T) - 2000));
Rv(2) := Block_To_Ch(Uuid_Block(Month(T)));
Rv(3) := Block_To_Ch(Uuid_Block(Day(T)));
Sec := Float(Seconds(T));
Rv(4) := Block_To_Ch(Uuid_Block(Integer(Sec)/3600));
Rv(5) := Block_To_Ch(Uuid_Block((Integer(Sec) mod 3600)/60));
Rv(6) := Block_To_Ch(Uuid_Block(Integer(Sec) mod 60));
Sec := Sec - Float(Integer(Sec));
Subsec := Integer(Sec * Float(60**4));
for K in reverse 7..10 loop
Rv(K) := Block_To_Ch(Uuid_Block(Subsec mod 60));
Subsec := Subsec / 60;
end loop;
return Rv(1..Accuracy);
end To_String;
function Base_60(V: Integer) return String is
Z: Integer:= V;
Rv,Rvi: String(1..20);
K: Integer:= 1;
begin
loop
Rv(K) := Block_To_Ch(Uuid_Block(Z mod 60));
Z := Z/60;
if Z=0 then
exit;
end if;
K := K+1;
end loop;
for J in reverse 1..K loop
Rvi(K-J+1) := Rv(J);
end loop;
return Rvi(1..K);
end Base_60;
function Random_Uuid_Symbol(Prefix: String; Time_Bytes: Integer:= 10) return String is
Nrd: Integer;
Now: String:= To_String(Clock);
begin
Nrd := 20 - Time_Bytes - Prefix'Length;
if Prefix'Length > 20 then
return Prefix(Prefix'First..Prefix'First+19);
end if;
if Prefix'Length + Time_Bytes >= 20 then
return Prefix & Now(1..(20-Prefix'Length));
end if;
return Prefix & Now(1..Time_Bytes) & Base_60(Random(60**Nrd));
end Random_Uuid_Symbol;
function Plain_Real_Vector(N: Ix) return Hq is
Rv: Hq :=
(Max_Elements => 1, Max_Chars => 0, Max_Ints => 0, Max_Reals => N, Max_Ids => 0,
Max_Bools => 0, Max_Ix => 0, Hqtype => Plain_Real_Vector,
Elems => (others => ( ElType => Reals, Length => N, Na => 0, First => 1, Fill => N,
Names => 0, Up => 0 )),
Elem_Fill => 1, Start => 1, Chars => Nochars,
Char_Fill => 0, Ints => Noints, Ids => Noids, Id_Fill => 0,
Int_Fill => 0, Reals => (others => 0.0),
Real_Fill => 0, Bools => Nobools, Bool_Fill => 0, Elemixs => Noelemixs,
Elemix_Fill => 0 );
begin
return Rv;
end Plain_Real_Vector;
pragma Inline(Plain_Real_Vector);
function Real_Vector(N: Ix) return Hq is
Rv: Hq :=
(Max_Elements => 1, Max_Chars => 0, Max_Ints => 0, Max_Reals => N, Max_Ids => N,
Max_Bools => N, Max_Ix => 0, Hqtype => Real_Vector,
Elems => (others => ( ElType => Reals, Length => N, Na => 1, First => 1, Fill => 0,
Names => 1, Up => 0 )),
Elem_Fill => 1, Start => 1, Chars => Nochars,
Char_Fill => 0, Ints => Noints, Ids => (others => Zeroid), Id_Fill => N,
Int_Fill => 0, Reals => (others => 0.0),
Real_Fill => N, Bools => (others => False), Bool_Fill => N, Elemixs => Noelemixs,
Elemix_Fill => 0 );
begin
return Rv;
end Real_Vector;
pragma Inline(Real_Vector);
function Is_Real_Vector(H: Hq) return Boolean is
begin
return H.Hqtype=Real_Vector;
end Is_Real_Vector;
pragma Inline(Is_Real_Vector);
function Plain_String(S: String:= ""; Size: Ix:= 128) return Hq is
Rv: Hq :=
(Max_Elements => 1, Max_Chars => Size, Max_Ints => 0, Max_Reals => 0, Max_Ids => 0,
Max_Bools => 0, Max_Ix => 0, Hqtype => Plain_String,
Elems => (others => ( ElType => Chars, Length => Size, Na => 0, First => 1, Fill => S'Length,
Names => 0, Up => 0 )),
Elem_Fill => 1, Start => 1, Chars => (others => ' '),
Char_Fill => Size, Ints => Noints, Ids => Noids, Id_Fill => 0,
Int_Fill => 0, Reals => Noreals,
Real_Fill => 0, Bools => Nobools, Bool_Fill => 0, Elemixs => Noelemixs,
Elemix_Fill => 0 );
begin
Rv.Chars(1..S'Length) := "" & S;
return Rv;
end Plain_String;
pragma Inline(Plain_String);
function Is_Plain_String(H: Hq) return Boolean is
begin
return H.Hqtype=Plain_String;
end Is_Plain_String;
pragma Inline(Is_Plain_String);
function List(Size: Ix; Nelem,Nchar,Nint,Nreal,Nid,Nbool,Nix: Ix:= 0) return Hq is
Rv: Hq :=
(Max_Elements => Nelem, Max_Chars => Nchar, Max_Ints => Nint, Max_Reals => Nreal, Max_Ids => Nid,
Max_Bools => Nbool, Max_Ix => Nix, Hqtype => List,
Elems => (others => ( ElType => Structs, Length => Size, Na => 1, First => 2, Fill => 0,
Names => 1, Up => 0 )),
Elem_Fill => Size+1, Start => 1, Chars => (others => ' '),
Char_Fill => 0, Ints => (others => 0), Ids => (others => Zeroid), Id_Fill => Size,
Int_Fill => 0, Reals => (others => 0.0),
Real_Fill => 0, Bools => (others => False), Bool_Fill => Size, Elemixs => (others => 0),
Elemix_Fill => 0 );
begin
return Rv;
end List;
function Is_Plain_Real_Vector(H: Hq) return Boolean is
begin
return H.Hqtype=Plain_Real_Vector;
end Is_Plain_Real_Vector;
pragma Inline(Is_Plain_Real_Vector);
function Is_List(H: Hq) return Boolean is
begin
return H.Hqtype=List;
end Is_List;
pragma Inline(Is_List);
function Plain_Int_Vector(N: Ix) return Hq is
Rv: Hq :=
(Max_Elements => 1, Max_Chars => 0, Max_Ints => N, Max_Reals => 0, Max_Ids => 0,
Max_Bools => 0, Max_Ix => 0, Hqtype => Plain_Int_Vector,
Elems => (others => ( ElType => Ints, Length => N, Na => 0, First => 1, Fill => N,
Names => 0, Up => 0)),
Elem_Fill => 1, Start => 1, Chars => Nochars,
Char_Fill => 0, Ints => (others => 0), Ids => Noids, Id_Fill => 0,
Int_Fill => N, Reals => Noreals,
Real_Fill => 0, Bools => Nobools, Bool_Fill => 0, Elemixs => Noelemixs,
Elemix_Fill => 0 );
begin
return Rv;
end Plain_Int_Vector;
pragma Inline(Plain_Int_Vector);
function Is_Plain_Int_Vector(H: Hq) return Boolean is
begin
return H.Hqtype=Plain_Int_Vector;
end Is_Plain_Int_Vector;
pragma Inline(Is_Plain_Int_Vector);
function Plain_Bool_Vector(N: Ix) return Hq is
Rv: Hq :=
(Max_Elements => 1, Max_Chars => 0, Max_Ints => 0, Max_Reals => 0, Max_Ids => 0,
Max_Bools => N, Max_Ix => 0, Hqtype => Plain_Bool_Vector,
Elems => (others => ( ElType => Bools, Length => N, Na => 0, First => 1, Fill => N,
Names => 0, Up => 0)),
Elem_Fill => 1, Start => 1, Chars => Nochars,
Char_Fill => 0, Ints => Noints, Ids => Noids, Id_Fill => 0,
Int_Fill => 0, Reals => Noreals,
Real_Fill => 0, Bools => ( others => False), Bool_Fill => N, Elemixs => Noelemixs,
Elemix_Fill => 0 );
begin
return Rv;
end Plain_Bool_Vector;
pragma Inline(Plain_Bool_Vector);
function Is_Plain_Bool_Vector(H: Hq) return Boolean is
begin
return H.Hqtype=Plain_Bool_Vector;
end Is_Plain_Bool_Vector;
pragma Inline(Is_Plain_Bool_Vector);
function Bool_Vector(N: Ix) return Hq is
Rv: Hq :=
(Max_Elements => 1, Max_Chars => 0, Max_Ints => 0, Max_Reals => 0, Max_Ids => N,
Max_Bools => N*2, Max_Ix => 0, Hqtype => Bool_Vector,
Elems => (others => ( ElType => Bools, Length => N, Na => N+1, First => 1, Fill => 0,
Names => 1, Up => 0 )),
Elem_Fill => 1, Start => 1, Chars => Nochars,
Char_Fill => 0, Ints => Noints, Ids => (others => Zeroid), Id_Fill => N,
Int_Fill => 0, Reals => Noreals,
Real_Fill => 0, Bools => (others => False), Bool_Fill => N*2, Elemixs => Noelemixs,
Elemix_Fill => 0 );
begin
return Rv;
end Bool_Vector;
pragma Inline(Bool_Vector);
function Plain_Id_Vector(N: Ix:= 1) return Hq is
Rv: Hq :=
(Max_Elements => 1, Max_Chars => 0, Max_Ints => 0, Max_Reals => 0, Max_Ids => N,
Max_Bools => 0, Max_Ix => 0, Hqtype => Plain_Id_Vector,
Elems => (others => ( ElType => Ids, Length => N, Na => 0, First => 1, Fill => N,
Names => 0, Up => 0)),
Elem_Fill => 1, Start => 1, Chars => Nochars,
Char_Fill => 0, Ints => Noints, Ids => ( others => Zeroid) , Id_Fill => 0,
Int_Fill => 0, Reals => Noreals,
Real_Fill => 0, Bools => Nobools, Bool_Fill => 0, Elemixs => Noelemixs,
Elemix_Fill => 0 );
begin
return Rv;
end Plain_Id_Vector;
pragma Inline(Plain_Id_Vector);
function Is_Plain_Id_Vector(H: Hq) return Boolean is
begin
return H.Hqtype=Plain_Id_Vector;
end Is_Plain_Id_Vector;
pragma Inline(Is_Plain_Id_Vector);
procedure Set(What: in out Hq; I: Ix; From: Real) is
begin
if Is_Plain_Real_Vector(What) then
if What.Elems(What.Start).Fill < I or else I<1 then
raise Out_Of_Bounds_Set;
end if;
What.Reals(What.Elems(What.Start).First+I-1) := From;
end if;
if Is_Real_Vector(What) then
if What.Elems(What.Start).Fill < I or else I<1 then
raise Out_Of_Bounds_Set;
end if;
What.Reals(What.Elems(What.Start).First+I-1) := From;
end if;
end Set;
procedure Set(What: in out Hq; I: Ix; From: Int) is
begin
if not Is_Plain_Int_Vector(What) then
raise Incompatible_Types_In_Set;
end if;
if What.Elems(What.Start).Length < I or else I<1 then
raise Out_Of_Bounds_Set;
end if;
What.Ints(What.Elems(What.Start).First+I-1) := From;
end Set;
procedure Set(What: in out Hq; I: Ix; From: Uuid) is
begin
if not Is_Plain_Id_Vector(What) then
raise Incompatible_Types_In_Set;
end if;
if What.Elems(What.Start).Length < I or else I<1 then
raise Out_Of_Bounds_Set;
end if;
What.Ids(What.Elems(What.Start).First+I-1) := From;
end Set;
function Is_Void(H: Hq) return Boolean is
begin
return H.Hqtype=Void;
end Is_Void;
function Is_Na(H: Hq; Acc: Hq:= Voidhq; I1,I2,I3: Integer:= -1) return Boolean is
begin
if H.Hqtype = Na then
return True;
end if;
if Acc=Voidhq and then I1>0 and then I2=-1 then -- very peculiar case for vectors
if Is_Plain_Real_Vector(H) or else Is_Plain_Int_Vector(H) then
if I1<=H.Elems(1).Length then
return False;
else
raise Constraint_Error;
end if;
end if;
if Is_Real_Vector(H) then
if I1<=H.Elems(1).Fill then
return H.Bools(H.Elems(1).Na + I1 -1);
else
raise Constraint_Error;
end if;
end if;
if Is_List(H) then
if I1<=H.Elems(1).Fill then
return H.Bools(H.Elems(1).Na + I1 -1);
else
raise Constraint_Error;
end if;
end if;
end if;
raise Parameter_Combination_Not_Supported;
end Is_Na;
procedure Append(To: in out Hq; Acc: Hq:= Voidhq; What: Real; Name: Uuid:= Zeroid) is
begin
if Acc/=Voidhq or else not Is_Real_Vector(To) then
raise Parameter_Combination_Not_Supported;
end if;
if To.Elems(1).Fill >= To.Elems(1).Length then
raise Out_Of_Bounds_Set;
end if;
To.Elems(1).Fill := To.Elems(1).Fill + 1;
To.Reals(To.Elems(1).Fill+To.Elems(1).First-1) := What;
To.Ids(To.Elems(1).Fill+To.Elems(1).Names-1) := Name;
To.Bools(To.Elems(1).Fill+To.Elems(1).Na-1) := False;
end Append;
procedure Append(To: in out Hq; What: Hq; Name: Uuid:= Zeroid) is
J: Integer;
begin
if Is_List(To) then
if To.Elems(1).Fill > To.Elems(1).Length then
raise Constraint_Error;
end if;
case What.Hqtype is
when Plain_Real_Vector =>
To.Elems(1).Fill := To.Elems(1).Fill + 1;
J := To.Elems(1).Fill + To.Elems(1).First -1;
To.Elems(J) :=
( ElType => Reals, Length => Length(What), Na => 0, First => To.Real_Fill+1,
Fill => Length(What), Names => 0, Up => 1 );
To.Real_Fill := To.Real_Fill + To.Elems(J).length;
for K in 1..To.Elems(J).length loop
To.Reals(To.Elems(J).First + K - 1) := What.Reals(K);
-- assumes what reals start from 1
end loop;
To.Ids(To.Elems(1).Names + To.Elems(1).Fill - 1) := Name;
To.Bools(To.Elems(1).Na + To.Elems(1).Fill - 1) := False;
when Real_Vector =>
To.Elems(1).Fill := To.Elems(1).Fill + 1;
J := To.Elems(1).Fill + To.Elems(1).First -1;
To.Elems(J) :=
( ElType => Reals,
Length => What.Elems(1).Length,
Na => To.Bool_Fill+1, First => To.Real_Fill+1,
Fill => What.Elems(1).Fill,
Names => To.Id_Fill+1, Up => 1 );
To.Real_Fill := To.Real_Fill + To.Elems(J).length;
To.Id_Fill := To.Id_Fill + To.Elems(J).length;
To.Bool_Fill := To.Bool_Fill + To.Elems(J).length;
for K in 1..To.Elems(J).Fill loop
To.Reals(To.Elems(J).First + K - 1) := What.Reals(K);
To.Bools(To.Elems(J).Na + K - 1) := What.Bools(K);
To.Ids(To.Elems(J).Names + K - 1) := What.Ids(K);
-- assumes what reals start from 1
end loop;
To.Ids(To.Elems(1).Names + To.Elems(1).Fill - 1) := Name;
To.Bools(To.Elems(1).Na + To.Elems(1).Fill - 1) := False;
when others =>
raise Parameter_Combination_Not_Supported;
end case;
else
raise Parameter_Combination_Not_Supported;
end if;
end Append;
procedure Append_Na(To: in out Hq; Acc: Hq:= Voidhq; Name: Uuid:= Zeroid) is
begin
if Acc=Voidhq then
if To.Elems(To.Start).Fill >= To.Elems(To.Start).Length then
raise Out_Of_Bounds_Set;
end if;
if Is_Real_Vector(To) then
To.Elems(1).Fill := To.Elems(1).Fill + 1;
To.Reals(To.Elems(1).Fill+To.Elems(1).First-1) := 0.0;
To.Ids(To.Elems(1).Fill+To.Elems(1).Names-1) := Name;
To.Bools(To.Elems(1).Fill+To.Elems(1).Na-1) := True;
elsif Is_List(To) then
To.Elems(1).Fill := To.Elems(1).Fill + 1;
To.Elems(To.Elems(1).Fill+To.Elems(1).First-1) :=
( ElType => Structs, Length => 0, Na => 0, First => 0,
Fill => 0, Names => 0, Up => 1 );
To.Ids(To.Elems(1).Fill+To.Elems(1).Names-1) := Name;
To.Bools(To.Elems(1).Fill+To.Elems(1).Na-1) := True;
end if;
else
raise Parameter_Combination_Not_Supported;
end if;
end Append_Na;
function Name(H: Hq; Acc: Hq:= Voidhq; I1,I2,I3: Integer:= -1) return Uuid is
begin
if Acc=Voidhq and then I1>0 and then I2=-1 then -- very peculiar case for vectors
if Is_Plain_Real_Vector(H) or else Is_Plain_Int_Vector(H) then
if I1<=H.Elems(1).Length then
return Zeroid;
else
raise Constraint_Error;
end if;
end if;
if Is_Real_Vector(H) then
if I1<=H.Elems(1).Fill then
return H.Ids(H.Elems(1).Names + I1 -1);
else
raise Constraint_Error;
end if;
end if;
if Is_List(H) then
if I1<=H.Elems(1).Fill then
return H.Ids(H.Elems(1).Names + I1 -1);
else
raise Constraint_Error;
end if;
end if;
end if;
raise Parameter_Combination_Not_Supported;
end Name;
function Subcomponent(H: Hq; Subc: Ix; I: Integer) return Ix is
-- the subcomponent is an index in the elems vector of h
begin
if H.Elems(Subc).Eltype /= Structs then
raise Subcomponent_Of_Nonlist;
end if;
if Subc>H.Elems(Subc).Fill then
raise Constraint_Error;
end if;
return H.Elems(Subc).First + I - 1;
end Subcomponent;
function Subcomponent(Subc: Cursor; I: Integer) return Cursor is
-- the subcomponent is an index in the elems vector of h
Rv: Cursor:= Subc;
begin
if I<1 then
raise Constraint_Error;
end if;
if Subc.H.all.Elems(Subc.El).Eltype /= Structs then
if Subc.Inel/=0 then
raise Subcomponent_Of_Nonlist;
else
if Subc.H.all.Elems(Subc.El).Fill < I then
raise Constraint_Error;
else
Rv.Inel := I;
return Rv;
end if;
end if;
end if;
if I>Subc.H.all.Elems(Subc.El).Fill then
raise Constraint_Error;
end if;
Rv.El := Subc.H.all.Elems(Subc.El).Fill + I - 1;
if Subc.H.all.Elems(Subc.El).Na > 0 then
Rv.Na := Subc.H.all.Bools(Subc.H.all.Elems(Subc.El).Na + I -1);
end if;
if Subc.H.all.Elems(Subc.El).Names > 0 then
Rv.Name := Subc.H.all.Ids(Subc.H.all.Elems(Subc.El).Names + I -1);
end if;
return Rv;
end Subcomponent;
procedure Ascend(C: in out Cursor) is
begin
if C.Inel/=0 then
C.Inel := 0;
return;
end if;
if C.H.Elems(C.El).Up=0 then
raise Constraint_Error;
end if;
C.El := C.H.Elems(C.El).Up;
end Ascend;
procedure Descend(C: in out Cursor; I: Ix:= 1) is
begin
if C.Inel /= 0 then
raise Constraint_Error;
end if;
if I > C.H.Elems(C.El).Fill or else I<1 then
raise Constraint_Error;
end if;
if C.H.Elems(C.El).Eltype = Structs then -- it will be another elem
C.El := C.H.Elems(C.El).First + I - 1;
else
C.Inel := I;
end if;
end Descend;
-- also internal
-- this is internal
function Length(H: Hq; Subc: Ix; I1, I2, I3: Integer:= -1) return Integer is
begin
if I1=-1 then
return H.Elems(Subc).Fill;
end if;
return Length(H, Subc => Subcomponent(H,Subc,I1), I1 => I2, I2 => I3);
end Length;
function Length(C: Cursor) return Ix is
begin
if C.Inel=0 then -- el is an element and that is the object the length of which we need
return C.H.all.Elems(C.El).Fill;
else
return 1; -- it is a single scalar element of an array or something
end if;
end Length;
function Size(C: Cursor) return Ix is
begin
if C.Inel=0 then -- el is an element and that is the object the length of which we need
return C.H.all.Elems(C.El).Length;
else
return 1; -- it is a single scalar element of an array or something
end if;
end Size;
function Length(H: Hq; Acc: Hq; I1,I2,I3: Integer:= -1) return Integer is
begin
if Acc=Voidhq then
return Length(H,I1 => I1, I2 => I2, I3 => I3);
end if;
raise Parameter_Combination_Not_Supported;
end Length;
function Length(H: Hq; I1,I2,I3: Integer:= -1) return Integer is
begin
return Length(H,H.Start,I1,I2,I3);
end Length;
function Data(H: Hq; Acc: Hq; I1,I2,I3: Integer:= -1) return String is
begin
if Is_Plain_String(H) then
return H.Chars(1..H.Elems(1).Fill);
end if;
raise Parameter_Combination_Not_Supported;
end Data;
function Data(H: Hq; I1,I2,I3: Integer:= -1) return String is
begin
return Data(H,Voidhq,I1,I2,I3);
end Data;
function Data(H: Hq; Acc: Hq; I1,I2,I3: Integer:= -1) return Hq is
begin
if Acc=Voidhq then
case H.Hqtype is
when Plain_Real_Vector =>
declare
Rvv: Real;
Rv: Hq:= Plain_Real_Vector(1);
begin
Rvv := Data(H,I1,I2,I3);
Set(Rv,1,Rvv);
return Rv;
end;
when Real_Vector =>
declare
Rvv: Real;
Rv: Hq:= Plain_Real_Vector(1);
begin
if not Is_Na(H,Voidhq,I1) then
Rvv := Data(H,I1,I2,I3);
Set(Rv,1,Rvv);
return Rv;
else
return Nahq;
end if;
end;
when Plain_Int_Vector =>
declare
Rvv: Int;
Rv: Hq:= Plain_Int_Vector(1);
begin
Rvv := Data(H,I1,I2,I3);
Set(Rv,1,Rvv);
return Rv;
end;
when others =>
raise Parameter_Combination_Not_Supported;
end case;
end if;
if Is_Plain_Int_Vector(Acc) and then I1=-1 then
case H.Hqtype is
when Plain_Real_Vector =>
declare
L: Integer:= Length(Acc);
Rvv: Real;
Ri: Int;
Rv: Hq:= Plain_Real_Vector(L);
begin
for K in 1..L loop
Ri := Data(Acc,K);
Rvv := Data(H,Voidhq,Integer(Ri));
Set(Rv,K,Rvv);
end loop;
return Rv;
end;
when Real_Vector =>
declare
L: Integer:= Length(Acc);
Rvv: Real;
Ri: Int;
Rv: Hq:= Real_Vector(L);
begin
for K in 1..L loop
Ri := Data(Acc,K);
Rvv := Data(H,Voidhq,Integer(Ri));
if (Is_Na(H,Voidhq,Integer(Ri))) then
Append_Na(Rv,Voidhq,Name(H,Voidhq,Integer(Ri)));
else
Append(Rv,Voidhq,Rvv,Name(H,Voidhq,Integer(Ri)));
end if;
end loop;
return Rv;
end;
when Plain_Int_Vector =>
declare
L: Integer:= Length(Acc);
Rvv: Int;
Ri: Int;
Rv: Hq:= Plain_Int_Vector(L);
begin
for K in 1..L loop
Ri := Data(Acc,K);
Rvv := Data(H,Voidhq,Integer(Ri));
Set(Rv,K,Rvv);
end loop;
return Rv;
end;
when others =>
raise Parameter_Combination_Not_Supported;
end case;
end if;
raise Parameter_Combination_Not_Supported;
end Data;
function Data(H: Hq; Acc: Hq; I1,I2,I3: Integer:= -1) return Real is
begin
if Is_Void(Acc) then -- it is a plain access
return Data(H,I1,I2,I3);
end if;
raise Parameter_Combination_Not_Supported;
end Data;
function Data(H: Hq; Acc: Hq; I1,I2,I3: Integer:= -1) return Int is
begin
if Is_Void(Acc) then -- it is a plain access
return Data(H,I1,I2,I3);
end if;
raise Parameter_Combination_Not_Supported;
end Data;
function Data(H: Hq; I1,I2,I3: Integer:= -1) return Real is
begin
if Is_Plain_Real_Vector(H) then
if I2 /= -1 and then I3 /= -1 then
raise Wrong_Dimensionality_Assumed;
end if;
if I1 >= 1 and then I1 <= H.Elems(H.Start).Length then
return H.Reals(H.Elems(H.Start).First+I1-1);
end if;
end if;
if Is_Real_Vector(H) then
if I2 /= -1 and then I3 /= -1 then
raise Wrong_Dimensionality_Assumed;
end if;
if I1 >= 1 and then I1 <= H.Elems(H.Start).Fill then
return H.Reals(H.Elems(H.Start).First+I1-1);
end if;
end if;
raise Parameter_Combination_Not_Supported;
end Data;
function Data(H: Hq; I1,I2,I3: Integer:= -1) return Int is
begin
if Is_Plain_Int_Vector(H) then
if I2 /= -1 and then I3 /= -1 then
raise Wrong_Dimensionality_Assumed;
end if;
if I1 >= 1 and then I1 <= H.Elems(H.Start).Length then
return H.Ints(H.Elems(H.Start).First+I1-1);
end if;
end if;
raise Parameter_Combination_Not_Supported;
end Data;
function Data(H: Hq; I1,I2,I3: Integer:= -1) return Uuid is
begin
if Is_Plain_Id_Vector(H) then
if I2 /= -1 and then I3 /= -1 then
raise Wrong_Dimensionality_Assumed;
end if;
if I1 >= 1 and then I1 <= H.Elems(H.Start).Length then
return H.Ids(H.Elems(H.Start).First+I1-1);
end if;
end if;
raise Parameter_Combination_Not_Supported;
end Data;
function Data(H: Hq; Acc: Hq; I1,I2,I3: Integer:= -1) return Uuid is
begin
if Is_Void(Acc) then -- it is a plain access
return Data(H,I1,I2,I3);
end if;
raise Parameter_Combination_Not_Supported;
end Data;
--- cursor functions
procedure Unchecked_Store(Into: Cursor; V: Real) is
begin
Into.H.Reals(Into.H.all.Elems(Into.El).First + Into.Inel - 1) := V;
if Into.H.Elems(Into.El).Na > 0 then
Into.H.Bools(Into.H.Elems(Into.El).Na + Into.Inel - 1) := False;
end if;
end Unchecked_Store;
pragma Inline(Unchecked_Store);
procedure Store(Into: Cursor; V: Real) is
begin
if Into.Inel=0 then
raise Constraint_Error;
end if;
if Into.H.Elems(Into.El).Eltype /= Reals then
-- Write(El_Type'Image(Into.H.Elems(Into.El).Eltype));Nl;
-- Write(Into.El);Nl;
-- Write(Into.Inel);Nl;
raise Wrong_Type;
end if;
Unchecked_Store(Into,V);
end Store;
pragma Inline(Store);
procedure Unchecked_Store(Into: Cursor; V: Int) is
begin
Into.H.Ints(Into.H.all.Elems(Into.El).First + Into.Inel - 1) := V;
if Into.H.Elems(Into.El).Na > 0 then
Into.H.Bools(Into.H.Elems(Into.El).Na + Into.Inel - 1) := False;
end if;
end Unchecked_Store;
pragma Inline(Unchecked_Store);
procedure Store(Into: Cursor; V: Int) is
begin
if Into.Inel=0 then
raise Constraint_Error;
end if;
if Into.H.Elems(Into.El).Eltype /= Ints then
raise Wrong_Type;
end if;
Unchecked_Store(Into,V);
end Store;
pragma Inline(Store);
procedure Unchecked_Store(Into: Cursor; V: Uuid) is
begin
Into.H.Ids(Into.H.all.Elems(Into.El).First + Into.Inel - 1) := V;
if Into.H.Elems(Into.El).Na > 0 then
Into.H.Bools(Into.H.Elems(Into.El).Na + Into.Inel - 1) := False;
end if;
end Unchecked_Store;
pragma Inline(Unchecked_Store);
procedure Store(Into: Cursor; V: Uuid) is
begin
if Into.Inel=0 then
raise Constraint_Error;
end if;
if Into.H.Elems(Into.El).Eltype /= Ids then
raise Wrong_Type;
end if;
Unchecked_Store(Into,V);
end Store;
pragma Inline(Store);
procedure Unchecked_Store(Into: Cursor; V: Boolean) is
begin
Into.H.Bools(Into.H.all.Elems(Into.El).First + Into.Inel - 1) := V;
if Into.H.Elems(Into.El).Na > 0 then
Into.H.Bools(Into.H.Elems(Into.El).Na + Into.Inel - 1) := False;
end if;
end Unchecked_Store;
pragma Inline(Unchecked_Store);
procedure Store(Into: Cursor; V: Boolean) is
begin
if Into.Inel=0 then
raise Constraint_Error;
end if;
if Into.H.Elems(Into.El).Eltype /= Bools then
raise Wrong_Type;
end if;
Unchecked_Store(Into,V);
end Store;
pragma Inline(Store);
procedure Unchecked_Store(Into: Cursor; V: Character) is
begin
Into.H.Chars(Into.H.all.Elems(Into.El).First + Into.Inel - 1) := V;
end Unchecked_Store;
pragma Inline(Unchecked_Store);
procedure Store(Into: Cursor; V: Character) is
begin
if Into.Inel=0 then
raise Constraint_Error;
end if;
if Into.H.Elems(Into.El).Eltype /= Chars then
raise Wrong_Type;
end if;
Unchecked_Store(Into,V);
end Store;
pragma Inline(Store);
procedure Set_Na(Into: Cursor; Na: Boolean:= True) is
begin
if Into.H.Elems(Into.El).Na > 0 then
Into.H.Bools(Into.H.Elems(Into.El).Na + Into.Inel - 1) := Na;
end if;
end Set_Na;
procedure Set_Name(Into: Cursor; Name: Uuid) is
begin
if Into.H.Elems(Into.El).Names > 0 then
Into.H.Ids(Into.H.Elems(Into.El).Na + Into.Inel - 1) := Name;
end if;
end Set_Name;
function Is_At_Start(C: cursor) return Boolean is
begin
return C.El=C.H.Start and then C.Inel=0;
end Is_At_Start;
function Is_List(C: cursor) return Boolean is
begin
return C.Inel=0 and then C.H.Elems(C.El).Eltype=Structs;
end Is_List;
function Is_Na(C: cursor) return Boolean is
Ell: Ix;
Posit: Ix;
begin
if C.Inel=0 then
Ell := C.H.Elems(C.El).Up;
if Ell=0 then
return False; -- it is the start element or in the top list; this cannot be na??
-- the first cannot be NA!! but any in the top level list can
else
Posit := C.El - C.H.Elems(Ell).First + 1; -- position of this element in the upper list
-- Write(Posit);
if C.H.Elems(Ell).Na=0 then
return False;
else
return C.H.Bools(C.H.Elems(Ell).Na+Posit - 1);
end if;
end if;
end if;
if (C.H.Elems(C.El).Na=0) then
return False;
end if;
return C.H.Bools(C.H.Elems(C.El).Na+C.Inel - 1);
end Is_Na;
function Is_Real(C: cursor) return Boolean is
begin
return C.Inel/=0 and then C.H.Elems(C.El).Eltype=Reals;
end Is_Real;
function Is_Real_Vector(C: cursor) return Boolean is
begin
return C.Inel=0 and then C.H.Elems(C.El).Eltype=Reals;
end Is_Real_Vector;
function Is_Plain_Real_Vector(C: cursor) return Boolean is
begin
return C.Inel=0 and then C.H.Elems(C.El).Eltype=Reals
and then C.H.Elems(C.El).Na=0 and then C.H.Elems(C.El).Names=0;
end Is_Plain_Real_Vector;
function Is_Int(C: cursor) return Boolean is
begin
return C.Inel/=0 and then C.H.Elems(C.El).Eltype=Ints;
end Is_Int;
function Is_Int_Vector(C: cursor) return Boolean is
begin
return C.Inel=0 and then C.H.Elems(C.El).Eltype=Ints;
end Is_Int_Vector;
function Is_Plain_Int_Vector(C: cursor) return Boolean is
begin
return C.Inel=0 and then C.H.Elems(C.El).Eltype=Ints
and then C.H.Elems(C.El).Na=0 and then C.H.Elems(C.El).Names=0;
end Is_Plain_Int_Vector;
function Is_Bool(C: cursor) return Boolean is
begin
return C.Inel/=0 and then C.H.Elems(C.El).Eltype=Bools;
end Is_Bool;
function Is_Bool_Vector(C: cursor) return Boolean is
begin
return C.Inel=0 and then C.H.Elems(C.El).Eltype=Bools;
end Is_Bool_Vector;
function Is_Plain_Bool_Vector(C: cursor) return Boolean is
begin
return C.Inel=0 and then C.H.Elems(C.El).Eltype=Bools
and then C.H.Elems(C.El).Na=0 and then C.H.Elems(C.El).Names=0;
end Is_Plain_Bool_Vector;
function Is_Char(C: cursor) return Boolean is
begin
return C.Inel/=0 and then C.H.Elems(C.El).Eltype=Chars;
end Is_Char;
function Is_String(C: cursor) return Boolean is
begin
return C.Inel=0 and then C.H.Elems(C.El).Eltype=Chars;
end Is_String;
function Is_Plain_String(C: cursor) return Boolean is
begin
return C.Inel=0 and then C.H.Elems(C.El).Eltype=Chars
and then C.H.Elems(C.El).Na=0 and then C.H.Elems(C.El).Names=0;
end Is_Plain_String;
function Is_Id_Vector(C: cursor) return Boolean is
begin
return C.Inel=0 and then C.H.Elems(C.El).Eltype=Ids;
end Is_Id_Vector;
function Is_Plain_Id_Vector(C: cursor) return Boolean is
begin
return C.Inel=0 and then C.H.Elems(C.El).Eltype=ids
and then C.H.Elems(C.El).Na=0 and then C.H.Elems(C.El).Names=0;
end Is_Plain_Id_Vector;
function Is_Id(C: cursor) return Boolean is
begin
return C.Inel/=0 and then C.H.Elems(C.El).Eltype=Ids;
end Is_Id;
-- -- function Is_String(C: Cursor) return Boolean; -- or plain string, the same thing
-- -- function Is_Character(C: Cursor) return Boolean;
-- -- function Is_Bool(C: Cursor) return Boolean;
-- -- function Is_Bool_String(C: Cursor) return Boolean;
-- -- function Is_Plain_Bool_String(C: Cursor) return Boolean;
function Unchecked_Data(C: Cursor) return Real is
begin
return C.H.Reals(C.H.all.Elems(C.El).First + C.Inel - 1);
end Unchecked_Data;
function Data(C: Cursor) return Real renames Unchecked_Data;
function Unchecked_Data(C: Cursor) return Int is
begin
return C.H.Ints(C.H.all.Elems(C.El).First + C.Inel - 1);
end Unchecked_Data;
function Data(C: Cursor) return Int renames Unchecked_Data;
function Unchecked_Data(C: Cursor) return Boolean is
begin
return C.H.Bools(C.H.all.Elems(C.El).First + C.Inel - 1);
end Unchecked_Data;
function Data(C: Cursor) return Boolean renames Unchecked_Data;
function Unchecked_Data(C: Cursor) return Uuid is
begin
return C.H.Ids(C.H.all.Elems(C.El).First + C.Inel - 1);
end Unchecked_Data;
function Data(C: Cursor) return Uuid renames Unchecked_Data;
function Unchecked_Data(C: Cursor) return String is
begin
return "" & C.H.Chars(C.H.all.Elems(C.El).First ..
C.H.all.Elems(C.El).First+C.H.all.Elems(C.El).Fill);
end Unchecked_Data;
function Data(C: Cursor) return String renames Unchecked_Data;
procedure Unchecked_Move(C: in out Cursor; To: Ix) is
begin
if C.Inel>0 then
C.Inel := To;
return;
end if;
if C.H.Elems(C.El).Up=0 then
raise Wrong_Type;
end if;
C.El := C.H.Elems(C.H.Elems(C.El).Up).First + To - 1;
end Unchecked_Move;
procedure Move(C: in out Cursor; To: Ix) renames Unchecked_Move;
procedure Append(Into: Cursor; V: Real; Name: Uuid:= Zeroid) is
begin
if not Is_Real_Vector(Into) then
raise Wrong_Type;
end if;
if Into.H.Elems(Into.El).Fill >= Into.H.Elems(Into.El).Length then
raise Constraint_Error;
end if;
Into.H.Elems(Into.El).Fill := Into.H.Elems(Into.El).Fill + 1;
Into.H.Reals(Into.H.Elems(Into.El).First + Into.H.Elems(Into.El).Fill - 1) := V;
Into.H.Bools(Into.H.Elems(Into.El).Na + Into.H.Elems(Into.El).Fill - 1) := False;
Into.H.Ids(Into.H.Elems(Into.El).Names + Into.H.Elems(Into.El).Fill - 1) := Name;
end Append;
procedure Append(Into: Cursor; V: Int; Name: Uuid:= Zeroid) is
begin
if not Is_Int_Vector(Into) then
raise Wrong_Type;
end if;
if Into.H.Elems(Into.El).Fill >= Into.H.Elems(Into.El).Length then
raise Constraint_Error;
end if;
Into.H.Elems(Into.El).Fill := Into.H.Elems(Into.El).Fill + 1;
Into.H.Ints(Into.H.Elems(Into.El).First + Into.H.Elems(Into.El).Fill - 1) := V;
Into.H.Bools(Into.H.Elems(Into.El).Na + Into.H.Elems(Into.El).Fill - 1) := False;
Into.H.Ids(Into.H.Elems(Into.El).Names + Into.H.Elems(Into.El).Fill - 1) := Name;
end Append;
procedure Append(Into: Cursor; V: Boolean; Name: Uuid:= Zeroid) is
begin
if not Is_Bool_Vector(Into) then
raise Wrong_Type;
end if;
if Into.H.Elems(Into.El).Fill >= Into.H.Elems(Into.El).Length then
raise Constraint_Error;
end if;
Into.H.Elems(Into.El).Fill := Into.H.Elems(Into.El).Fill + 1;
Into.H.Bools(Into.H.Elems(Into.El).First + Into.H.Elems(Into.El).Fill - 1) := V;
Into.H.Bools(Into.H.Elems(Into.El).Na + Into.H.Elems(Into.El).Fill - 1) := False;
Into.H.Ids(Into.H.Elems(Into.El).Names + Into.H.Elems(Into.El).Fill - 1) := Name;
end Append;
procedure Append(Into: Cursor; V: Uuid; Name: Uuid:= Zeroid) is
begin
if not Is_Id_Vector(Into) then
raise Wrong_Type;
end if;
if Into.H.Elems(Into.El).Fill >= Into.H.Elems(Into.El).Length then
raise Constraint_Error;
end if;
Into.H.Elems(Into.El).Fill := Into.H.Elems(Into.El).Fill + 1;
Into.H.Ids(Into.H.Elems(Into.El).First + Into.H.Elems(Into.El).Fill - 1) := V;
Into.H.Bools(Into.H.Elems(Into.El).Na + Into.H.Elems(Into.El).Fill - 1) := False;
Into.H.Ids(Into.H.Elems(Into.El).Names + Into.H.Elems(Into.El).Fill - 1) := Name;
end Append;
procedure Append_Na(Into: Cursor; Name: Uuid:= Zeroid) is
begin
if not Is_Id_Vector(Into) and then not Is_Real_Vector(Into) and then not Is_Bool_Vector(Into)
and then not Is_Int_Vector(Into) and then not Is_List(Into) then
raise Wrong_Type;
end if;
if Into.H.Elems(Into.El).Fill >= Into.H.Elems(Into.El).Length then
raise Constraint_Error;
end if;
Into.H.Elems(Into.El).Fill := Into.H.Elems(Into.El).Fill + 1;
Into.H.Bools(Into.H.Elems(Into.El).Na + Into.H.Elems(Into.El).Fill - 1) := True;
Into.H.Ids(Into.H.Elems(Into.El).Names + Into.H.Elems(Into.El).Fill - 1) := Name;
end Append_Na;
procedure Append(Into: Cursor; V: Hq; Name: Uuid:= Zeroid) is
-- the cursor must point to an element that is a list
-- with space left, into which V will be appeded as a new element
J: Ix;
begin
if not Is_List(Into) then
raise Wrong_Type;
end if;
if Length(Into)>=Size(Into) then -- no, it can never be larger
raise Constraint_Error;
end if;
case V.Hqtype is
when Plain_Real_Vector =>
Into.H.Elems(Into.El).Fill := Into.H.Elems(Into.El).Fill + 1;
J := Into.H.Elems(Into.El).Fill + Into.H.Elems(Into.El).First -1;
Into.H.Elems(J) :=
( ElType => Reals, Length => Length(V), Na => 0, First => Into.H.Real_Fill+1,
Fill => Length(V), Names => 0, Up => Into.El );
Into.H.Real_Fill := Into.H.Real_Fill + Into.H.Elems(J).length;
for K in 1..Into.H.Elems(J).length loop
Into.H.Reals(Into.H.Elems(J).First + K - 1) := V.Reals(K);
-- assumes v reals start from 1
end loop;
Into.H.Ids(Into.H.Elems(Into.El).Names + Into.H.Elems(Into.El).Fill - 1) := Name;
Into.H.Bools(Into.H.Elems(Into.El).Na + Into.H.Elems(Into.El).Fill - 1) := False;
when Plain_Int_Vector =>
Into.H.Elems(Into.El).Fill := Into.H.Elems(Into.El).Fill + 1;
J := Into.H.Elems(Into.El).Fill + Into.H.Elems(Into.El).First -1;
Into.H.Elems(J) :=
( ElType => Ints, Length => Length(V), Na => 0, First => Into.H.Int_Fill+1,
Fill => Length(V), Names => 0, Up => Into.El );
Into.H.Int_Fill := Into.H.Int_Fill + Into.H.Elems(J).length;
for K in 1..Into.H.Elems(J).length loop
Into.H.Ints(Into.H.Elems(J).First + K - 1) := V.Ints(K);
-- assumes v ints start from 1
end loop;
Into.H.Ids(Into.H.Elems(Into.El).Names + Into.H.Elems(Into.El).Fill - 1) := Name;
Into.H.Bools(Into.H.Elems(Into.El).Na + Into.H.Elems(Into.El).Fill - 1) := False;
when Plain_Id_Vector =>
Into.H.Elems(Into.El).Fill := Into.H.Elems(Into.El).Fill + 1;
J := Into.H.Elems(Into.El).Fill + Into.H.Elems(Into.El).First -1;
Into.H.Elems(J) :=
( ElType => Ids, Length => Length(V), Na => 0, First => Into.H.Id_Fill+1,
Fill => Length(V), Names => 0, Up => Into.El );
Into.H.Id_Fill := Into.H.Id_Fill + Into.H.Elems(J).Length;
for K in 1..Into.H.Elems(J).length loop
Into.H.Ids(Into.H.Elems(J).First + K - 1) := V.Ids(K);
-- assumes v ints start from 1
end loop;
Into.H.Ids(Into.H.Elems(Into.El).Names + Into.H.Elems(Into.El).Fill - 1) := Name;
Into.H.Bools(Into.H.Elems(Into.El).Na + Into.H.Elems(Into.El).Fill - 1) := False;
when Plain_Bool_Vector =>
Into.H.Elems(Into.El).Fill := Into.H.Elems(Into.El).Fill + 1;
J := Into.H.Elems(Into.El).Fill + Into.H.Elems(Into.El).First -1;
Into.H.Elems(J) :=
( ElType => Bools, Length => Length(V), Na => 0, First => Into.H.Bool_Fill+1,
Fill => Length(V), Names => 0, Up => Into.El );
Into.H.Bool_Fill := Into.H.Bool_Fill + Into.H.Elems(J).Length;
for K in 1..Into.H.Elems(J).length loop
Into.H.Bools(Into.H.Elems(J).First + K - 1) := V.Bools(K);
-- assumes v ints start from 1
end loop;
Into.H.Ids(Into.H.Elems(Into.El).Names + Into.H.Elems(Into.El).Fill - 1) := Name;
Into.H.Bools(Into.H.Elems(Into.El).Na + Into.H.Elems(Into.El).Fill - 1) := False;
when Real_Vector =>
Into.H.Elems(Into.El).Fill := Into.H.Elems(Into.El).Fill + 1;
J := Into.H.Elems(Into.El).Fill + Into.H.Elems(Into.El).First -1;
Into.H.Elems(J) :=
( ElType => Reals,
Length => V.Elems(1).Length,
Na => Into.H.Bool_Fill+1, First => Into.H.Real_Fill+1,
Fill => V.Elems(Into.El).Fill,
Names => Into.H.Id_Fill+1, Up => Into.El );
Into.H.Real_Fill := Into.H.Real_Fill + Into.H.Elems(J).length;
Into.H.Id_Fill := Into.H.Id_Fill + Into.H.Elems(J).length;
Into.H.Bool_Fill := Into.H.Bool_Fill + Into.H.Elems(J).length;
for K in 1..Into.H.Elems(J).Fill loop
Into.H.Reals(Into.H.Elems(J).First + K - 1) := V.Reals(K);
Into.H.Bools(Into.H.Elems(J).Na + K - 1) := V.Bools(K);
Into.H.Ids(Into.H.Elems(J).Names + K - 1) := V.Ids(K);
-- assumes v reals start from 1
end loop;
Into.H.Ids(Into.H.Elems(Into.El).Names + Into.H.Elems(Into.El).Fill - 1) := Name;
Into.H.Bools(Into.H.Elems(Into.El).Na + Into.H.Elems(Into.El).Fill - 1) := False;
when Int_Vector =>
Into.H.Elems(Into.El).Fill := Into.H.Elems(Into.El).Fill + 1;
J := Into.H.Elems(Into.El).Fill + Into.H.Elems(Into.El).First -1;
Into.H.Elems(J) :=
( ElType => Ints,
Length => Length(V),
Na => Into.H.Bool_Fill+1, First => Into.H.Int_Fill+1,
Fill => V.Elems(Into.El).Fill,
Names => Into.H.Id_Fill+1, Up => Into.El );
Into.H.Int_Fill := Into.H.Int_Fill + Into.H.Elems(J).length;
Into.H.Id_Fill := Into.H.Id_Fill + Into.H.Elems(J).length;
Into.H.Bool_Fill := Into.H.Bool_Fill + Into.H.Elems(J).length;
for K in 1..Into.H.Elems(J).Fill loop
Into.H.Ints(Into.H.Elems(J).First + K - 1) := V.Ints(K);
Into.H.Bools(Into.H.Elems(J).Na + K - 1) := V.Bools(K);
Into.H.Ids(Into.H.Elems(J).Names + K - 1) := V.Ids(K);
-- assumes v ints start from 1
end loop;
Into.H.Ids(Into.H.Elems(Into.El).Names + Into.H.Elems(Into.El).Fill - 1) := Name;
Into.H.Bools(Into.H.Elems(Into.El).Na + Into.H.Elems(Into.El).Fill - 1) := False;
when Bool_Vector =>
Into.H.Elems(Into.El).Fill := Into.H.Elems(Into.El).Fill + 1;
J := Into.H.Elems(Into.El).Fill + Into.H.Elems(Into.El).First -1;
Into.H.Elems(J) :=
( ElType => Bools,
Length => Length(V),
Na => Into.H.Bool_Fill+Length(V)+1, First => Into.H.Bool_Fill+1,
Fill => V.Elems(Into.El).Fill,
Names => Into.H.Id_Fill+1, Up => Into.El );
Into.H.Bool_Fill := Into.H.Bool_Fill + Into.H.Elems(J).length;
Into.H.Id_Fill := Into.H.Id_Fill + Into.H.Elems(J).length;
Into.H.Bool_Fill := Into.H.Bool_Fill + Into.H.Elems(J).length;
for K in 1..Into.H.Elems(J).Fill loop
Into.H.Bools(Into.H.Elems(J).First + K - 1) := V.Bools(K);
Into.H.Bools(Into.H.Elems(J).Na + K - 1) := V.Bools(K+Into.H.Elems(J).Length);
Into.H.Ids(Into.H.Elems(J).Names + K - 1) := V.Ids(K);
-- assumes v ints start from 1
end loop;
Into.H.Ids(Into.H.Elems(Into.El).Names + Into.H.Elems(Into.El).Fill - 1) := Name;
Into.H.Bools(Into.H.Elems(Into.El).Na + Into.H.Elems(Into.El).Fill - 1) := False;
when Id_Vector =>
Into.H.Elems(Into.El).Fill := Into.H.Elems(Into.El).Fill + 1;
J := Into.H.Elems(Into.El).Fill + Into.H.Elems(Into.El).First -1;
Into.H.Elems(J) :=
( ElType => Ids,
Length => Length(V),
Na => Into.H.Bool_Fill+1, First => Into.H.Int_Fill+1,
Fill => V.Elems(Into.El).Fill,
Names => Into.H.Id_Fill+1, Up => Into.El );
Into.H.Id_Fill := Into.H.Id_Fill + Into.H.Elems(J).length;
Into.H.Id_Fill := Into.H.Id_Fill + Into.H.Elems(J).length;
Into.H.Bool_Fill := Into.H.Bool_Fill + Into.H.Elems(J).length;
for K in 1..Into.H.Elems(J).Fill loop
Into.H.Ids(Into.H.Elems(J).First + K - 1) := V.Ids(K);
Into.H.Bools(Into.H.Elems(J).Na + K - 1) := V.Bools(K);
Into.H.Ids(Into.H.Elems(J).Names + K - 1) := V.Ids(K);
-- assumes v ints start from 1
end loop;
Into.H.Ids(Into.H.Elems(Into.El).Names + Into.H.Elems(Into.El).Fill - 1) := Name;
Into.H.Bools(Into.H.Elems(Into.El).Na + Into.H.Elems(Into.El).Fill - 1) := False;
when Plain_String =>
Into.H.Elems(Into.El).Fill := Into.H.Elems(Into.El).Fill + 1;
J := Into.H.Elems(Into.El).Fill + Into.H.Elems(Into.El).First -1;
Into.H.Elems(J) :=
( ElType => Chars, Length => Length(V), Na => 0, First => Into.H.Int_Fill+1,
Fill => Length(V), Names => 0, Up => Into.El );
Into.H.Char_Fill := Into.H.Char_Fill + Into.H.Elems(J).length;
for K in 1..Into.H.Elems(J).length loop
Into.H.Chars(Into.H.Elems(J).First + K - 1) := V.Chars(K);
-- assumes v ints start from 1
end loop;
Into.H.Ids(Into.H.Elems(Into.El).Names + Into.H.Elems(Into.El).Fill - 1) := Name;
Into.H.Bools(Into.H.Elems(Into.El).Na + Into.H.Elems(Into.El).Fill - 1) := False;
when others =>
raise Parameter_Combination_Not_Supported;
end case;
end Append;
-- vuuid api
function "&"(A,B: Vuuid) return Vuuid is
R: Vuuid(1..A'Length+B'Length);
begin
R(1..A'Length) := A;
R(A'Length+1..R'Length) := B;
return R;
end "&";
function "&"(A: Vuuid; B: Uuid) return Vuuid is
R: Vuuid(1..A'Length+1);
begin
R(1..A'Length) := A;
R(A'Length+1) := B;
return R;
end "&";
function "&"(A: Uuid; B: Vuuid) return Vuuid is
begin
return B & A;
end "&";
function "&"(A,B: Uuid) return Vuuid is
R: Vuuid(1..2);
begin
R(1) := A;
R(2) := B;
return R;
end "&";
function To_Vuuid(A: Uuid) return Vuuid is
R: Vuuid(1..1);
begin
R(1) := A;
return R;
end To_Vuuid;
type Read_Type is ( Invalid, White, Id, Macro );
Readtab: array(Character) of Read_Type := ( others => Invalid );
procedure Init_Readtab is
begin
for C in Character'('!')..Character'('~') loop
Readtab(C) := Id;
end loop;
Readtab(' ') := White;
Readtab(Ascii.Lf) := White;
Readtab(Ascii.Cr) := White;
-- Readtab(Ascii.Tab) := White;
Readtab('"') := Macro;
Readtab('(') := Macro;
end Init_Readtab;
procedure String_Read(S: String;
Six: in out Integer;
V: in out Vuuid; Vix: in out Integer) is
-- specification as for read, but S(Six) must be '"'
Start: Integer:= Vix;
Send: Integer:= Vix+2; -- smallest possible value
Crts: Integer:= Vix+1; -- current string
Ustart: Corlid(String_On);
Uend: Corlid(Endstruct);
Ucrts: Corlid(Zascii7);
Ins, Len, Nch: Integer:= 0;
begin
if S(Six)/='"' then
raise Internal_Error;
end if;
Six := Six+1;
Ustart.Len7on := 1;
Uend.Endlen := 1;
Ustart.Nch7on := 0;
Ins := Ucrts.Str7'First;
loop
if S(Six)='"' then
Ucrts.Str7(Ins) := 0;
V(Start) := To_Uuid(Ustart);
V(Crts) := To_Uuid(Ucrts);
Send := Crts+1;
V(Send) := To_Uuid(Uend);
Vix := Send+1;
Six := Six+1;
return;
end if;
Ucrts.Str7(Ins) := Character'Pos(S(Six));
Ins := Ins + 1;
Six := Six+1;
Ustart.Nch7on := Ustart.Nch7on+1;
if Ins>Ucrts.Str7'Last then
V(Crts) := To_Uuid(Ucrts);
Ins := Ucrts.Str7'First;
Crts := Crts+1;
Uend.Endlen := Uend.Endlen + 1;
Ustart.Len7on := Ustart.Len7on + 1;
end if;
end loop;
end String_Read;
procedure Read(S: String;
Six: in out Integer;
V: in out Vuuid; Vix: in out Integer) is
-- reads one sequence of uuids into V starting at Vix,
-- from S starting with character Six
-- adjusts Six and Vix accordingly
-- this reads one UUID or UUID chain (connected sequence of UUID chains) in the VUUID
Sixs: Integer;
begin
while Six <= S'Last and then Readtab(S(Six))=White loop
Six := Six+1;
end loop;
if Six>S'Last then
return;
end if;
case Readtab(S(Six)) is
when White => -- impossible
raise Internal_Error;
when Id =>
Sixs := Six;
while Sixs<=S'Last and then Readtab(S(Sixs))=Id loop
Sixs := Sixs + 1;
end loop;
Sixs := Sixs-1;
V(Vix) := To_Uuid(Read(S(Six..Sixs)));
Six := Sixs + 1;
Vix := Vix + 1;
return;
when Invalid =>
raise Wrong_Type;
when Macro =>
if S(Six)='"' then
String_Read(S,Six,V,Vix);
else
raise Internal_Error; -- not implemented yet
end if;
end case;
end Read;
function Corlidtype_Of(U: Uuid) return Corlidtype is
begin
return To_Corlid(U).Ctype;
end Corlidtype_Of;
function Next_After(U: Uuid) return Integer is
Cid: Corlid:= To_Corlid(U);
begin
case Cid.Ctype is
when String_On =>
return Cid.Len7on+2;
when List =>
return Cid.Lisz+2;
when Matrix =>
return (Cid.Cols+Integer(Cid.Colheads))*(Cid.Rows+Integer(Cid.Rowheads))+2;
when others =>
return 1;
end case;
end Next_After;
function Extract_String(V: Vuuid; K: Integer) return String is
-- v(k) must be string_on
Cid: Corlid:= To_Corlid(V(K));
Nc,Nu: Integer;
begin
if Corlidtype_Of(V(K))/=String_On then
raise Wrong_Type;
end if;
Nc := Cid.Nch7on;
Nu := Cid.Len7on;
declare
R: String(1..Nc);
Ri: Integer:= 1;
begin
for I in 1..Nu loop
declare
Cu: Corlid:= To_Corlid(V(K+I));
begin
if Cu.Ctype /= Zascii7 then
raise Wrong_Type;
end if;
for J in 1..16 loop
if Cu.Str7(J)=0 then
exit;
else
R(Ri) := Character'Val(Cu.Str7(J));
Ri := Ri+1;
end if;
end loop;
end;
end loop;
if Ri/=Nc+1 then
raise Wrong_Type;
end if;
return R;
end;
end Extract_String;
function Read(S: String) return Vuuid is
Rv: Vuuid(1..S'Length/2);
Si: Integer:= S'First;
Vi: Integer:= Rv'First;
begin
loop
Read(S,Si,Rv,Vi);
if Si>S'Last then
return Rv(1..Vi-1);
end if;
end loop;
end Read;
-- function Read(T: Text) return Vuuid;
function Dispatch_Make_Uuid(Kind: String; F: Real:= 0.0; N: Int:= 0; S: String:= "")
return Uuid is
Ki: Kind_Reg_Cursor;
begin
Ki := Locate_Kind(Kind);
if Ki=No_Kind then
raise Wrong_Type;
end if;
if Kind_Reg(Ki).Maker=null then
raise Wrong_Type;
end if;
return Kind_Reg(Ki).Maker(F,N,S);
end Dispatch_Make_Uuid;
function Make_Uuid(Kind: String; F: Real:= 0.0; N: Int:= 0; S: String:= "") return Uuid is
begin
case Kind(Kind'First) is
when 'm' =>
if Kind="mark" then
declare
R: Corlid(Fixed_B7);
Mk: String(1..7) := ( others => '.');
begin
if S'Length>7 then
raise Wrong_Type;
end if;
Mk(1..S'Length) := S;
R.B7_Name := Abstring7(String_To_Encb(Mk));
R.B7_Decimals:= 2; -- must be assigned separately
R.B7_Value:= Long_Long_Integer(N);
return To_Uuid(R);
end;
else
raise Wrong_Type;
end if;
when 's' =>
if Kind="symbol" then
return To_Uuid(Symbol_Read(S));
elsif Kind="serial" then
if S'Length<=3 then
declare
R: Corlid(Serial_C3);
Rn: String(1..3) := ( others => '.');
begin
if S'Length>3 then
raise Wrong_Type;
end if;
Rn(1..S'Length) := S;
R.C3_Name := Cstring3(String_To_Encc(Rn));
R.C3_Ext:= 0; -- must be assigned separately
R.C3_Serial:= Uint64(N);
return To_Uuid(R);
end;
elsif S'Length<=7 then
declare
R: Corlid(Serial_A7);
Rn: String(1..7) := ( others => '.');
begin
if S'Length>7 then
raise Wrong_Type;
end if;
Rn(1..S'Length) := S;
R.A7_Name := Abstring7(String_To_Enca(Rn));
R.A7_Serial:= Uint64(N);
return To_Uuid(R);
end;
elsif S'Length<=12 then
declare
R: Corlid(Serial_A12);
Rn: String(1..12) := ( others => '.');
begin
if S'Length>12 then
raise Wrong_Type;
end if;
Rn(1..S'Length) := S;
R.A12_Name := Abstring12(String_To_Enca(Rn));
R.A12_Serial:= Uint32(N);
return To_Uuid(R);
end;
elsif S'Length<=15 then
declare
R: Corlid(Serial_A15);
Rn: String(1..15) := ( others => '.');
begin
if S'Length>15 then
raise Wrong_Type;
end if;
Rn(1..S'Length) := S;
R.A15_Name := Abstring15(String_To_Enca(Rn));
R.A15_Serial:= Uint16(N);
return To_Uuid(R);
end;
else
return Dispatch_Make_Uuid(Kind,F,N,S);
end if;
else
return Dispatch_Make_Uuid(Kind,F,N,S);
end if;
when others =>
return Dispatch_Make_Uuid(Kind,F,N,S);
end case;
end Make_Uuid;
function Kinn(U: Uuid) return String is
C: Corlid:= To_Corlid(U);
begin
return Trim(Corlidtype'Image(C.Ctype));
end Kinn;
function Kind(U: Uuid) return String is
C: Corlid:= To_Corlid(U);
begin
case C.Ctype is
when Fixed_B7 =>
return "mark";
when Sym_A18 | Sym_B18 | Sym_C22 =>
return "symbol";
when Serial_C3 =>
return Dot_Trim(Encc_To_String(Cstring(C.C3_Name)));
when Serial_A7 =>
return Dot_Trim(Enca_To_String(Abstring(C.A7_Name)));
when Serial_A12 =>
return Dot_Trim(Enca_To_String(Abstring(C.A12_Name)));
when Serial_A15 =>
return Dot_Trim(Enca_To_String(Abstring(C.A15_Name)));
when Serial_A18 =>
declare
S: String:= Dot_Trim(Enca_To_String(Abstring(C.A18)));
begin
for K in S'Range loop
if S(K)='_' then
return To_Lower(S(1..K-1));
end if;
end loop;
raise Wrong_Type; -- it is a serial, but the name is not specified
end;
when Zascii7 =>
return "strdata";
when String_On =>
return "string";
when Matrix =>
return "matrix";
when Pointer =>
return "pointer";
when List =>
return "list";
when Endstruct =>
return "endstruct";
when Nstime =>
return "date";
when Longfloat | Float_80 | Float_64 | Float_1 =>
-- but these should also be the respective strings as they will be specific types
return "float";
when Float_2 =>
return "float";
when Float_3 =>
return "float";
when Longint =>
return "int";
when Quant =>
return "quant";
when Uuid_Zero =>
return "zero";
when Uuid_V1_0 | Uuid_V1_1 | Uuid_V1_2 | Uuid_V1_3 =>
return "uuid";
when Uuid_V2_0 | Uuid_V2_1 | Uuid_V2_2 | Uuid_V2_3 =>
return "uuid";
when Uuid_V3_0 | Uuid_V3_1 | Uuid_V3_2 | Uuid_V3_3 =>
return "uuid";
when Uuid_V4_0 | Uuid_V4_1 | Uuid_V4_2 | Uuid_V4_3 =>
return "uuid";
when Uuid_V5_0 | Uuid_V5_1 | Uuid_V5_2 | Uuid_V5_3 =>
return "uuid";
when others =>
return "unknown";
end case;
end Kind;
function Kint(U: Uuid) return String is
C: Corlid:= To_Corlid(U);
begin
case C.Ctype is
when Fixed_B7 =>
return "MM";
when Sym_A18 =>
return "A" & Character'Val(Character'Pos('A') +
Dot_Trim(Enca_To_String(Abstring(C.Ab18_Sym)))'Length);
-- except it cannot be just "AA"
when Sym_B18 =>
return "B" & Character'Val(Character'Pos('B') +
Dot_Trim(Encb_To_String(Abstring(C.Ab18_Sym)))'Length);
when Sym_C22 =>
return "C" & Character'Val(Character'Pos('C') +
Dot_Trim(Encc_To_String(Cstring(C.C22_Sym)))'Length);
when Serial_C3 =>
return "C" & Character'Val(Character'Pos('C') +
Dot_Trim(Encc_To_String(Cstring(C.C3_Name)))'Length);
when Serial_A7 =>
return "A" & Character'Val(Character'Pos('A') +
Dot_Trim(Enca_To_String(Abstring(C.A7_Name)))'Length);
when Serial_A12 =>
return "A" & Character'Val(Character'Pos('A') +
Dot_Trim(Enca_To_String(Abstring(C.A12_Name)))'Length);
when Serial_A15 =>
return "A" & Character'Val(Character'Pos('A') +
Dot_Trim(Enca_To_String(Abstring(C.A15_Name)))'Length);
when Serial_A18 =>
return "A" & Character'Val(Character'Pos('A') +
Dot_Trim(Enca_To_String(Abstring(C.A18)))'Length);
when Zascii7 =>
return "DA";
when String_On | Matrix | List | Pointer =>
return "K";
when Endstruct =>
return "KEND";
when Nstime =>
return "TBA";
when Longfloat | Float_80 =>
return "FK";
when Float_64 =>
return "FI";
when Float_1 | Float_2 | Float_3 =>
return "FE";
when Longint =>
return "II";
when Quant =>
return "Q";
when Uuid_Zero =>
return "NOTT";
when Uuid_V1_0 | Uuid_V1_1 | Uuid_V1_2 | Uuid_V1_3 =>
return "NOTT";
when Uuid_V2_0 | Uuid_V2_1 | Uuid_V2_2 | Uuid_V2_3 =>
return "NOTT";
when Uuid_V3_0 | Uuid_V3_1 | Uuid_V3_2 | Uuid_V3_3 =>
return "NOTT";
when Uuid_V4_0 | Uuid_V4_1 | Uuid_V4_2 | Uuid_V4_3 =>
return "NOTT";
when Uuid_V5_0 | Uuid_V5_1 | Uuid_V5_2 | Uuid_V5_3 =>
return "NOTT";
when others =>
return "NOTT";
end case;
end Kint;
Attrs: array(Corlidtype, Attribute, Attribute_Vector) of Int :=
(Uuid_V5_0 => (Nint => (others => 0),
Isize => (others => 0),
Min => (others => Nattr),
Max => (others => Nattr),
Nchar => (others => 0),
Encoding => (others => Nattr),
Nfloat => (others => 0),
Decimals => (others => Nattr),
Emin => (others => Nattr),
Emax => (others => Nattr),
Fsize => (others => Nattr)),
Fixed_B7 => (Nint => (1, others => 0),
Isize => (64, others => 0),
Min => (Int'First, others => Nattr),
Max => (Int'Last, Others => Nattr),
Nchar => (7, others => 0),
Encoding => (2, others => Nattr),
Nfloat => (1, others => 0),
Decimals => (others => Nattr),
Emin => (others => Nattr),
Emax => (others => Nattr),
Fsize => (others => Nattr)),
Sym_A18 => (Nint => (others => 0),
Isize => (others => 0),
Min => (others => Nattr),
Max => (others => Nattr),
Nchar => (18, others => 0),
Encoding => (1, others => Nattr),
Nfloat => (others => 0),
Decimals => (others => Nattr),
Emin => (others => Nattr),
Emax => (others => Nattr),
Fsize => (others => Nattr)),
Sym_B18 => (Nint => (others => 0),
Isize => (others => 0),
Min => (others => Nattr),
Max => (others => Nattr),
Nchar => (18, others => 0),
Encoding => (2, others => Nattr),
Nfloat => (others => 0),
Decimals => (others => Nattr),
Emin => (others => Nattr),
Emax => (others => Nattr),
Fsize => (others => Nattr)),
Sym_C22 => (Nint => (others => 0),
Isize => (others => 0),
Min => (others => Nattr),
Max => (others => Nattr),
Nchar => (22, others => 0),
Encoding => (3, others => Nattr),
Nfloat => (others => 0),
Decimals => (others => Nattr),
Emin => (others => Nattr),
Emax => (others => Nattr),
Fsize => (others => Nattr)),
Serial_C3 => (Nint => (1, 1, others => 0),
Isize => (64, 32, others => 0),
Min => (0, 0, others => Nattr),
Max => (others => Nattr), -- there is a problem with encoding all 96 bits
Nchar => (3, others => 0),
Encoding => (3, others => Nattr),
Nfloat => (others => 0),
Decimals => (others => Nattr),
Emin => (others => Nattr),
Emax => (others => Nattr),
Fsize => (others => Nattr)),
Serial_A7 => (Nint => (1, others => 0),
Isize => (64, others => 0),
Min => (0, others => Nattr),
Max => (Int'Last, Others => Nattr),
Nchar => (7, others => 0),
Encoding => (1, others => Nattr),
Nfloat => (others => 0),
Decimals => (others => Nattr),
Emin => (others => Nattr),
Emax => (others => Nattr),
Fsize => (others => Nattr)),
Serial_A12 => (Nint => (1, others => 0),
Isize => (32, others => 0),
Min => (0, others => Nattr),
Max => (Int(Integer'Last), Others => Nattr),
Nchar => (12, others => 0),
Encoding => (1, others => Nattr),
Nfloat => (others => 0),
Decimals => (others => Nattr),
Emin => (others => Nattr),
Emax => (others => Nattr),
Fsize => (others => Nattr)),
Serial_A15 => (Nint => (1, others => 0),
Isize => (15, others => 0),
Min => (0, others => Nattr),
Max => (Int(Short_Integer'Last), Others => Nattr),
Nchar => (15, others => 0),
Encoding => (1, others => Nattr),
Nfloat => (others => 0),
Decimals => (others => Nattr),
Emin => (others => Nattr),
Emax => (others => Nattr),
Fsize => (others => Nattr)),
Serial_A18 => (Nint => (others => 0),
Isize => (others => 0),
Min => (others => Nattr),
Max => (others => Nattr),
Nchar => (others => Nattr),
Encoding => (1, 1, others => Nattr),
Nfloat => (others => 0),
Decimals => (others => Nattr),
Emin => (others => Nattr),
Emax => (others => Nattr),
Fsize => (others => Nattr)),
String_On => (Nint => (2, others => 0),
Isize => (32, others => 0),
Min => (0, others => Nattr),
Max => (Int(Integer'Last), Others => Nattr),
Nchar => (others => 0),
Encoding => (others => Nattr),
Nfloat => (others => 0),
Decimals => (others => Nattr),
Emin => (others => Nattr),
Emax => (others => Nattr),
Fsize => (others => Nattr)),
Matrix => (Nint => (2, 2, others => 0),
Isize => (32, 8, others => 0),
Min => (0, others => Nattr),
Max => (Int(Integer'Last), Int(Short_Short_Integer'Last), Others => Nattr),
Nchar => (4, others => 0),
Encoding => (2, others => Nattr),
Nfloat => (others => 0),
Decimals => (others => Nattr),
Emin => (others => Nattr),
Emax => (others => Nattr),
Fsize => (others => Nattr)),
Endstruct => (Nint => (1, others => 0),
Isize => (32, others => 0),
Min => (0, others => Nattr),
Max => (Int(Integer'Last), Others => Nattr),
Nchar => (others => 0),
Encoding => (others => Nattr),
Nfloat => (others => 0),
Decimals => (others => Nattr),
Emin => (others => Nattr),
Emax => (others => Nattr),
Fsize => (others => Nattr)),
List => (Nint => (2, others => 0),
Isize => (32, others => 0),
Min => (0, others => Nattr),
Max => (Int(Integer'Last), Others => Nattr),
Nchar => (7, others => 0),
Encoding => (2, others => Nattr),
Nfloat => (others => 0),
Decimals => (others => Nattr),
Emin => (others => Nattr),
Emax => (others => Nattr),
Fsize => (others => Nattr)),
Pointer => (Nint => (1, others => 0),
Isize => (32, others => 0),
Min => (0, others => Nattr),
Max => (Int(Integer'Last), Others => Nattr),
Nchar => (others => 0),
Encoding => (others => Nattr),
Nfloat => (others => 0),
Decimals => (others => Nattr),
Emin => (others => Nattr),
Emax => (others => Nattr),
Fsize => (others => Nattr)),
Longint => (Nint => (1, 1, others => 0),
Isize => (64, 48, others => 0),
Min => (Int'First, Int(Int48'First), others => Nattr),
Max => (Int'Last, Int(Int48'Last), others => Nattr),
Nchar => (others => 0),
Encoding => (others => Nattr),
Nfloat => (others => 0),
Decimals => (others => Nattr),
Emin => (others => Nattr),
Emax => (others => Nattr),
Fsize => (others => Nattr)),
Longfloat => (Nint => (others => 0),
Isize => (others => 0),
Min => (others => Nattr),
Max => (others => Nattr),
Nchar => (others => 0),
Encoding => (others => Nattr),
Nfloat => (1, others => 0),
Decimals => (Int(Long_Long_Float'Digits), Others => Nattr),
Emin => (Int(Long_Long_Float'Machine_Emin), Others => Nattr),
Emax => (Int(Long_Long_Float'Machine_Emax), Others => Nattr),
Fsize => (80, others => Nattr)),
Float_80 => (Nint => (others => 0),
Isize => (others => 0),
Min => (others => Nattr),
Max => (others => Nattr),
Nchar => (4, others => 0),
Encoding => (2, others => Nattr),
Nfloat => (1, others => 0),
Decimals => (Int(Long_Long_Float'Digits), Others => Nattr),
Emin => (Int(Long_Long_Float'Machine_Emin), Others => Nattr),
Emax => (Int(Long_Long_Float'Machine_Emax), Others => Nattr),
Fsize => (80, others => Nattr)),
Quant => (Nint => (7,7, others => 0),
Isize => (4,3, others => 0),
Min => (-7,1, others => Nattr),
Max => (8,4, others => Nattr),
Nchar => (0, others => 0),
Encoding => (0, others => Nattr),
Nfloat => (1, others => 0),
Decimals => (Int(Long_Float'Digits), Others => Nattr),
Emin => (Int(Long_Float'Machine_Emin), Others => Nattr),
Emax => (Int(Long_Float'Machine_Emax), Others => Nattr),
Fsize => (64, others => Nattr)),
Float_64 => (Nint => (others => 0),
Isize => (others => 0),
Min => (others => Nattr),
Max => (others => Nattr),
Nchar => (8, others => 0),
Encoding => (3, others => Nattr),
Nfloat => (1, others => 0),
Decimals => (Int(Long_Float'Digits), Others => Nattr),
Emin => (Int(Long_Float'Machine_Emin), Others => Nattr),
Emax => (Int(Long_Float'Machine_Emax), Others => Nattr),
Fsize => (64, others => Nattr)),
Float_1 => (Nint => (others => 0),
Isize => (others => 0),
Min => (others => Nattr),
Max => (others => Nattr),
Nchar => (12, others => 0),
Encoding => (2, others => Nattr),
Nfloat => (1, others => 0),
Decimals => (Int(Float'Digits), Others => Nattr),
Emin => (Int(Float'Machine_Emin), Others => Nattr),
Emax => (Int(Float'Machine_Emax), Others => Nattr),
Fsize => (32, others => Nattr)),
Float_2 => (Nint => (others => 0),
Isize => (others => 0),
Min => (others => Nattr),
Max => (others => Nattr),
Nchar => (8, others => 0),
Encoding => (3, others => Nattr),
Nfloat => (2, others => 0),
Decimals => (Int(Float'Digits), Others => Nattr),
Emin => (Int(Float'Machine_Emin), Others => Nattr),
Emax => (Int(Float'Machine_Emax), Others => Nattr),
Fsize => (32, others => Nattr)),
Float_3 => (Nint => (1, others => 0),
Isize => (8, others => 0),
Min => (Int(Int8'First), others => Nattr),
Max => (Int(Int8'Last), others => Nattr),
Nchar => (others => 0),
Encoding => (others => Nattr),
Nfloat => (3, others => 0),
Decimals => (Int(Float'Digits), Others => Nattr),
Emin => (Int(Float'Machine_Emin), Others => Nattr),
Emax => (Int(Float'Machine_Emax), Others => Nattr),
Fsize => (32, others => Nattr)),
others => ( others => (others => Nattr))
);
function Attr(U: Uuid; A: Attribute; N: Integer) return Int is
Ci: Corlid:= To_Corlid(U);
Rattr: Int;
begin
Rattr := Attrs(Ci.Ctype,A,N);
if Rattr /= Nattr then
return Rattr;
end if;
case Ci.Ctype is
when Fixed_B7 =>
case A is
when Decimals =>
return Int(Ci.B7_Decimals); -- nr of decimals
when others =>
null;
end case;
when Serial_A18 =>
case A is
when Nchar =>
declare
S: String:= Dot_Trim(Enca_To_String(Abstring(Ci.A18)));
begin
for K in S'Range loop
if S(K)='_' then
if (N=1) then
return Int(K-S'First);
elsif N=2 then
return Int(S'Last-K);
else
return 0;
end if;
end if;
end loop;
raise Wrong_Type; -- it is a serial, but the name is not specified
end;
when others => null;
end case;
when others =>
null;
end case;
raise Wrong_Type;
end Attr;
function Get(U: Uuid; N,K: Integer:= 1) return Real is
Ci: Corlid:= To_Corlid(U);
begin
case Ci.Ctype is
when Fixed_Bitvec | Serial_Bitvec | Vector_Bitvec =>
raise Wrong_Type;
when Fixed_B7 =>
return Real(Ci.B7_Value) * (10.0 ** (- Integer(Ci.B7_Decimals)));
when Quant =>
if N/=1 or else K/=1 then
raise Wrong_Type;
end if;
return Real(Ci.Value);
when Longfloat =>
return Real(Ci.Val);
when Float_80 =>
return Real(Ci.F80val);
when Float_64 =>
return Real(Ci.F64val);
when Float_1 =>
return Real(Ci.Fval);
when Float_2 =>
if K=1 then
return Real(Ci.Fval1v1);
else
return Real(Ci.Fval2v2);
end if;
when Float_3 =>
case K is
when 1 =>
return Real(Ci.Fval1v3);
when 2 =>
return Real(Ci.Fval2v3);
when 3 =>
return Real(Ci.Fval3v3);
when others => raise Wrong_Type;
end case;
when others => raise Wrong_Type;
end case;
end Get;
function Get(U: Uuid; N,K: Integer:= 1) return Int is
Ci: Corlid:= To_Corlid(U);
begin
case Ci.Ctype is
when Fixed_B7 =>
return Int(Ci.B7_Value);
when Serial_C3 =>
if N=1 then
if K=1 then
return Int(Ci.C3_Serial);
elsif K=2 then
return Int(Ci.C3_Ext);
end if;
end if;
when Serial_A7 =>
if N=1 and then K=1 then
return Int(Ci.A7_Serial);
end if;
when Serial_A12 =>
if N=1 and then K=1 then
return Int(Ci.A12_Serial);
end if;
when Serial_A15 =>
if N=1 and then K=1 then
return Int(Ci.A15_Serial);
end if;
when String_On =>
if N=1 then
if K=1 then
return Int(Ci.Len7on);
elsif K=2 then
return Int(Ci.Nch7on);
end if;
end if;
when Matrix =>
if N=1 then
if K=1 then
return Int(Ci.Cols);
elsif K=2 then
return Int(Ci.Rows);
end if;
elsif N=2 then
if K=1 then
return Int(Ci.Colheads);
elsif K=2 then
return Int(Ci.Rowheads);
end if;
end if;
when List =>
if N=1 then
if K=1 then
return Int(Ci.Len);
elsif K=2 then
return Int(Ci.Lisz);
end if;
end if;
when Endstruct =>
if N=1 and then K=1 then
return Int(Ci.Endlen);
end if;
when Pointer =>
if N=1 and then K=1 then
return Int(Ci.Index);
end if;
when Longint =>
if K=1 then
if N=1 then
return Int(Ci.Lo);
else
return Int(Ci.Hi);
end if;
end if;
when Quant =>
if N=1 then
return Int(Ci.Unit(Si_Base_Unit'Val(K)));
elsif N=2 then
return Int(Ci.Radical(Si_Base_Unit'Val(K)));
end if;
when others =>
raise Wrong_Type;
end case;
raise Wrong_Type;
end Get;
function Get(U: Uuid; N,K: Integer:= 1) return String is
Ci: Corlid:= To_Corlid(U);
begin
case Ci.Ctype is
when Fixed_B7 =>
return Dot_Trim(Encb_To_String(Abstring(Ci.B7_Name)));
when Sym_A18 =>
return Dot_Trim(Enca_To_String(Abstring(Ci.Ab18_Sym)));
-- except it cannot be just "AA"
when Sym_B18 =>
return Dot_Trim(Encb_To_String(Abstring(Ci.Ab18_Sym)));
when Sym_C22 =>
return Dot_Trim(Encc_To_String(Cstring(Ci.C22_Sym)));
when Serial_C3 =>
return Dot_Trim(Encc_To_String(Cstring(Ci.C3_Name)));
when Serial_A7 =>
return Dot_Trim(Enca_To_String(Abstring(Ci.A7_Name)));
when Serial_A12 =>
return Dot_Trim(Enca_To_String(Abstring(Ci.A12_Name)));
when Serial_A15 =>
return Dot_Trim(Enca_To_String(Abstring(Ci.A15_Name)));
when Serial_A18 =>
declare
S: String:= Dot_Trim(Enca_To_String(Abstring(Ci.A18)));
begin
for K in S'Range loop
if S(K)='_' then
if (N=1) then
return S(S'First..K-1);
else
return S(K+1..S'Last);
end if;
end if;
end loop;
raise Wrong_Type; -- serial a18 without :
end;
when Zascii7 =>
declare
R: String(1..16);
Ri: Integer:= 1;
begin
for J in 1..16 loop
if Ci.Str7(J)=0 then
exit;
else
R(Ri) := Character'Val(Ci.Str7(J));
Ri := Ri+1;
end if;
end loop;
return R(1..(Ri-1));
end;
when Float_80 =>
return Dot_Trim(Encb_To_String(Abstring(Ci.F80name)));
when Float_64 =>
return Dot_Trim(Encc_To_String(Cstring(Ci.F64name)));
when Float_1 =>
return Dot_Trim(Encb_To_String(Abstring(Ci.F1name)));
when Float_2 =>
return Dot_Trim(Encc_To_String(Cstring(Ci.F2name)));
when Intv1 =>
return Dot_Trim(Encb_To_String(Abstring(Ci.Namei1)));
when Intv2 =>
return Dot_Trim(Encc_To_String(Cstring(Ci.Namei2)));
when Uintv1 =>
return Dot_Trim(Encb_To_String(Abstring(Ci.Nameui1)));
when Uintv2 =>
return Dot_Trim(Encc_To_String(Cstring(Ci.Nameui2)));
when others =>
return "NOTT";
end case;
end Get;
procedure Set(U: in out Uuid; V: Int; N,K: Integer:= 1) is
Ci: Corlid:= To_Corlid(U);
begin
case Ci.Ctype is
when Fixed_B7 =>
if N=1 then
Ci.B7_Value := Long_Long_Integer(V);
elsif N=2 then
Ci.B7_Decimals := Short_Short_Integer(V);
end if;
when Serial_C3 =>
if N=1 then
if K=1 then
Ci.C3_Serial := Uint64(V);
elsif K=2 then
Ci.C3_Ext := Uint32(V);
end if;
end if;
when Serial_A7 =>
if N=1 and then K=1 then
Ci.A7_Serial := Uint64(V);
end if;
when Serial_A12 =>
if N=1 and then K=1 then
Ci.A12_Serial := Uint32(V);
end if;
when Serial_A15 =>
if N=1 and then K=1 then
Ci.A15_Serial := Uint16(V);
end if;
when String_On =>
if N=1 then
if K=1 then
Ci.Len7on := Integer(V);
elsif K=2 then
Ci.Nch7on := Integer(V);
end if;
end if;
when List =>
if N=1 then
if K=1 then
Ci.Len := Integer(V);
elsif K=2 then
Ci.Lisz := Integer(V);
end if;
end if;
when Matrix =>
if N=1 then
if K=1 then
Ci.Cols := Integer(V);
elsif K=2 then
Ci.Rows := Integer(V);
end if;
elsif N=2 then
if K=1 then
Ci.Colheads := Short_Short_Integer(V);
elsif K=2 then
Ci.Rowheads := Short_Short_Integer(V);
end if;
end if;
when Endstruct =>
if N=1 and then K=1 then
Ci.Endlen := Integer(V);
end if;
when Pointer =>
if N=1 and then K=1 then
Ci.Index := Integer(V);
end if;
when Longint =>
if K=1 then
if N=1 then
Ci.Lo := Long_Long_Integer(V);
else
Ci.Hi := Int48(V);
end if;
end if;
when Quant =>
if N=1 then
Ci.Unit(Si_Base_Unit'Val(K)) := Unit_Power(V);
elsif N=2 then
Ci.Radical(Si_Base_Unit'Val(K)) := Unit_Radical(V);
end if;
when others =>
raise Wrong_Type;
end case;
end Set;
procedure Set(U: in out Uuid; V: Real; N,K: Integer:= 1) is
Ci: Corlid:= To_Corlid(U);
begin
case Ci.Ctype is
when Fixed_B7 =>
Ci.B7_Value := Long_Long_Integer (V * (10.0 ** Integer(Ci.B7_Decimals)));
when Quant =>
Ci.Value := Float64(V);
when Longfloat =>
Ci.Val := Long_Long_Float(V);
when Float_80 =>
Ci.F80val := Float80(V);
when Float_64 =>
Ci.F64val := Float64(V);
when Float_1 =>
Ci.Fval := Float32(V);
when Float_2 =>
if K=1 then
Ci.Fval1v1 := Float32(V);
else
Ci.Fval2v2 := Float32(V);
end if;
when Float_3 =>
case K is
when 1 =>
Ci.Fval1v3 := Float32(V);
when 2 =>
Ci.Fval2v3 := Float32(V);
when 3 =>
Ci.Fval3v3 := Float32(V);
when others =>
raise Wrong_Type;
end case;
when others => raise Wrong_Type;
end case;
end Set;
function Dot_Fill(S: String; N: Integer) return String is
R: String(1..N):= ( others => '.');
begin
R(1..S'Length) := S; -- raises constraint error if S is too large
return R;
end Dot_Fill;
procedure Set(U: in out Uuid; V: String; N,K: Integer:= 1) is
Ci: Corlid:= To_Corlid(U);
begin
case Ci.Ctype is
when Fixed_B7 =>
Ci.B7_Name := Abstring7(String_To_Encb(Dot_Fill(V,7)));
when Sym_A18 =>
Ci.Ab18_Sym := Abstring18(String_To_Enca(Dot_Fill(V,18)));
when Sym_B18 =>
Ci.Ab18_Sym := Abstring18(String_To_Encb(Dot_Fill(V,18)));
when Sym_C22 =>
Ci.C22_Sym := Cstring22(String_To_Encc(Dot_Fill(V,22)));
when Serial_C3 =>
Ci.C3_Name := Cstring3(String_To_Encc(Dot_Fill(V,3)));
when Serial_A7 =>
Ci.A7_Name := Abstring7(String_To_Enca(Dot_Fill(V,7)));
when Serial_A12 =>
Ci.A12_Name := Abstring12(String_To_Enca(Dot_Fill(V,12)));
when Serial_A15 =>
Ci.A15_Name := Abstring15(String_To_Enca(Dot_Fill(V,15)));
when Serial_A18 =>
declare
S: String:= Dot_Trim(Enca_To_String(Abstring(Ci.A18)));
begin
for K in S'Range loop
if S(K)='_' then
if (N=1) then
Ci.A18 := Abstring18(String_To_Enca(Dot_Fill(V & '_' & S(K+1..S'Last),18)));
elsif N=2 then
Ci.A18 := Abstring18(String_To_Enca(Dot_Fill(S(S'First..K-1) & "_" & V,18)));
else
raise Wrong_Type; -- N>2 when assigning to a serial_a18
end if;
return;
end if;
end loop;
end;
when Zascii7 =>
for J in V'range loop
Ci.Str7(J-V'First+1) := Character'Pos(V(J));
end loop;
if V'Length < 16 then
Ci.Str7(V'Length+1) := 0;
end if;
when Float_80 =>
Ci.F80name := Abstring4(String_To_Encb(Dot_Fill(V,4)));
when Float_64 =>
Ci.F64name := Cstring8(String_To_Encc(Dot_Fill(V,8)));
when Float_1 =>
Ci.F1name := Abstring12(String_To_Encb(Dot_Fill(V,12)));
when Float_2 =>
Ci.F2name := Cstring8(String_To_Encc(Dot_Fill(V,8)));
when Intv1 =>
Ci.Namei1 := Abstring12(String_To_Encb(Dot_Fill(V,12)));
when Intv2 =>
Ci.Namei2 := Cstring8(String_To_Encc(Dot_Fill(V,8)));
when Uintv1 =>
Ci.Nameui1 := Abstring12(String_To_Encb(Dot_Fill(V,12)));
when Uintv2 =>
Ci.Nameui2 := Cstring8(String_To_Encc(Dot_Fill(V,8)));
when others => raise Wrong_Type;
end case;
end Set;
function Format(U: Uuid; W,D,E: Integer:= 0;
M1,M2,M3: Boolean:= False;
Flag: Character:= 'U';
Style: Character:= 'K';
Pic: String:= "") return String is
Ki: Kind_Reg_Cursor;
begin
Ki := Locate_Kind(Kind(U));
if Ki=No_Kind then
return Format(To_Corlid(U),M1);
end if;
if Kind_Reg(Ki).Formatter=null then
return Format(To_Corlid(U),M1);
end if;
return Kind_Reg(Ki).Formatter(U,W,D,E,M1,M2,M3,Flag,Style,Pic);
end Format;
function Read(S: String) return Uuid is
R: Uuid;
begin
return To_Uuid(Corlid'(Read(S)));
end Read;
function Encb_Earlier(S,U: String) return Boolean is
-- S ASSUMED to be strictly shorter and also that both start at 1
-- U assumed to be padded by '.'
begin
for K in S'Range loop
if Char_To_Encb(S(K)) > Char_To_Encb(U(K)) then
return True;
end if;
if Char_To_Encb(S(K)) < Char_To_Encb(U(K)) then
return False;
end if;
end loop;
return U(S'Last+1)/='.';
end Encb_Earlier;
function Locate_Kind(Kind: String) return Kind_Reg_Cursor is
-- this is critical, must be as fast as possible
Kd: String := "" & To_Upper(Kind) & "...";
Tls: String(1..3);
K: Kind_Reg_Cursor;
begin
Tls := Kd(Kd'First..Kd'First+2);
K := Kind_Reg_Index(Base64char(Char_To_Encb(Tls(1))),
Base64char(Char_To_Encb(Tls(2))),
Base64char(Char_To_Encb(Tls(3))));
if K=No_Kind then
return No_Kind;
end if;
while K <= Kind_Reg_Fill loop
if Kd=Kind_Reg(K).Utype(Kd'Range) then
return K;
end if;
if not Encb_Earlier(Kd, Kind_Reg(K).Utype) then
return No_Kind;
end if;
K := K+1;
end loop;
return No_Kind;
end Locate_Kind;
procedure Register_Uuid_Kind(Kind: String; -- but must be an alphanumeric string corresponding
-- to the corlidtype
Corlid_Type: Corlidtype;
Make_Method: Make_Uuid_Method:= null;
Read_Method: Read_Uuid_Method:= null;
Format_Method: Format_Uuid_Method:= null) is
-- this may not be that fast; also, it is not reentrant, but
-- should only be called, normally, during elaboration
Kd: String := "" & To_Upper(Kind) ;
Ki: Kind_Reg_Cursor;
B1,B2,B3: Base64char;
begin
Ki := Locate_Kind(Kind);
if Ki=No_Kind then -- we assume it is not there; a new entry must be inserted
for I in 1..Kind_Reg_Fill loop
if not Encb_Earlier(Kd, Kind_Reg(I).Utype) then
-- move the following
for J in reverse I..Kind_Reg_Fill loop
Kind_Reg(J+1) := Kind_Reg(J);
end loop;
Ki := I;
Kind_Reg_Fill := Kind_Reg_Fill + 1;
exit;
end if;
end loop;
end if;
if Ki = No_Kind then -- larger than the last value
Ki := Kind_Reg_Fill + 1;
Kind_Reg_Fill := Kind_Reg_Fill + 1;
end if;
-- no matter how the place was found, put the data into it
Kind_Reg(Ki).Utype := (others => '.');
Kind_Reg(Ki).Utype(Kd'Range) := Kd;
Kind_Reg(Ki).Ulen := Kd'Length;
Kind_Reg(Ki).Ct := Corlid_Type;
Kind_Reg(Ki).Maker := Make_Method;
Kind_Reg(Ki).Reader := Read_Method;
Kind_Reg(Ki).Formatter := Format_Method;
-- remake the index
Kind_Reg_Index := (others => (others => (others => No_Kind)));
for K in 1..Kind_Reg_Fill loop
B1 := Base64char(Char_To_Encb(Kind_Reg(K).Utype(1)));
B2 := Base64char(Char_To_Encb(Kind_Reg(K).Utype(2)));
B3 := Base64char(Char_To_Encb(Kind_Reg(K).Utype(3)));
if Kind_Reg_Index(B1,B2,B3)=No_Kind then
Kind_Reg_Index(B1,B2,B3) := K;
end if;
end loop;
end Register_Uuid_Kind;
function Locate_Filetype(Filetype: Uuid) return Filetype_Reg_Cursor is
begin
for K in 1..Filetype_Reg_Fill loop
-- Write(Format(To_Corlid(Filetype_Reg(K).Form),True)); Write(Filetype_Reg(K).Form.Lo); Nl;
-- Write(Filetype_Reg(K).Form.Hi); Nl;
-- Write(Format(To_Corlid(Filetype),True));
-- Write(Filetype.Lo); Nl; Write(Filetype.Hi); Nl;
-- this is an unpleasant problem: due to some reason, when converting a symbol
-- or another corlid to uuid, unspecified bits are put randomly
-- which makes uuids of equal corlids unequal to each other
-- this needs to be addressed!! identical corlids must lead to identical uuids
if To_Corlid(Filetype_Reg(K).Form)=To_Corlid(Filetype) then
return K;
end if;
end loop;
return 0;
end Locate_Filetype;
function Locate_Filetype(Filetype: String) return Filetype_Reg_Cursor is
begin
return Locate_Filetype(Read(To_Upper(Filetype)));
end Locate_Filetype;
procedure Register_Filetype(Form: String; Loader: Vuuid_Loader; Saver: Vuuid_Saver) is
Crs: Filetype_Reg_Cursor;
Uf: Uuid:= Read(To_Upper(Form));
begin
Crs := Locate_Filetype(Uf);
if Crs=No_Filetype then
Filetype_Reg_Fill := Filetype_Reg_Fill + 1;
Crs := Filetype_Reg_Fill;
end if;
Filetype_Reg(Crs).Form := Uf;
Filetype_Reg(Crs).Loader := Loader;
Filetype_Reg(Crs).Saver := Saver;
end Register_Filetype;
function Load(File: String; Form: String) return Vuuid is
Crs: Filetype_Reg_Cursor;
begin
Crs:= Locate_Filetype(Form);
if Crs = No_Filetype then
raise Wrong_Type;
end if;
return Filetype_Reg(Crs).Loader(File);
end Load;
procedure Save(V:Vuuid; File: String; Form: String) is
Crs: Filetype_Reg_Cursor;
begin
Crs:= Locate_Filetype(Form);
if Crs = No_Filetype then
raise Wrong_Type;
end if;
Filetype_Reg(Crs).Saver(V, File);
end Save;
-- some common file types to be loaded and saved as uuid vectors
function Load_Ids(File: String) return Vuuid is
T: Text;
begin
Load(T,File);
declare
Zz: Vuuid:= Read(To_String(T));
begin
return Zz;
end;
end Load_Ids;
procedure Save_Ids(V: Vuuid; File: String) is
T: Text;
begin
for K in V'Range loop
Append(T, Format(To_Corlid(V(K)),True) & Ascii.Lf);
end loop;
Save(T,File);
end Save_Ids;
begin
Reset(Default_Generator,Moment_Random);
Init_Ch_To_Block;
Init_Encodings;
Init_Readtab;
Register_Uuid_Kind("string", String_On,
Make_Method => null,
Read_Method => Read_String_On'Access,
Format_Method => null);
Register_Uuid_Kind("matrix", Matrix, -- that is, generic, unnamed, uni/bidimensional matrix
Make_Method => null,
Read_Method => Read_Matrix'Access,
Format_Method => null);
Register_Uuid_Kind("list", List, -- that is, generic, unnamed, simple list
Make_Method => null,
Read_Method => Read_List'Access,
Format_Method => null);
Register_Uuid_Kind("pointer", Pointer,
Make_Method => null,
Read_Method => Read_Pointer'Access,
Format_Method => null);
Register_Filetype("ids",
Loader => Load_Ids'Access,
Saver => Save_Ids'Access);
end Corlpack;
with Corlpack; use Corlpack;
procedure Testuuid is
begin
Write(To_String(To_Uuid("ZUZU_NESTI:22"))); Nl;
Write(To_String(Clock));Nl;
Write(Random_Uuid_Symbol("ZU_",10));Nl;
end Testuuid;
with Corlpack; use Corlpack;
procedure Hqtest is
Hq1: aliased Hq := Voidhq;
Inhq1: Cursor(Hq1'Access);
Hq2: aliased Hq := Plain_Real_Vector(300);
Inhq2: Cursor(Hq2'Access);
Hqi: aliased Hq := Plain_Int_Vector(4);
Inhqi: Cursor(Hqi'Access);
Hqr: aliased Hq := Real_Vector(300);
Inhqr: Cursor(Hqr'Access);
Hqs: aliased Hq := Plain_String("hello stringy world", 200);
Inhqs: Cursor(Hqs'Access);
Hqid: aliased Hq := Plain_Id_Vector(3);
Inhqid: Cursor(Hqid'Access);
Hql: aliased Hq := List(10,1500,1500,1500,1500,1500,1500,1500);
Inhql: Cursor(Hql'Access);
Hqb: aliased Hq := Plain_Bool_Vector(8);
Hqbv: aliased Hq := Bool_Vector(80);
procedure Certify(Testname: String; Result,Shouldbe: String; Mode: Integer:= 1) is
begin
if Result=Shouldbe then
if Mode=1 then
Write("test "); Write(Testname); Write(" result """); Write(Result);
Write(""" dg ok _"); Nl;
end if;
else
if Mode=1 then
Write("test "); Write(Testname); Write(" result """); Write(Result);
Write(""" should_have_been """); Write(Shouldbe);
Write(""" dg _F_A_I_L_E_D_ _"); Nl;
end if;
end if;
end Certify;
procedure Parameter(Paraname, Paraval: String; Mode: Integer:= 1) is
begin
Write("para " & Paraname & " eq " & Paraval & " _"); Nl;
end Parameter;
begin
for K in 1..300 loop
Set(Hq2,K,Real(K)**2);
end loop;
for K in 1..4 loop
Set(Hqi,K,Int(K*K));
end loop;
Set(Hqid,1,To_Uuid("alpha"));
Set(Hqid,2,To_Uuid("beta"));
Set(Hqid,3,To_Uuid("omega"));
Parameter("Voidhq_Size",Format(Int(Voidhq'Size)));
Parameter("PRV300_Size",Format(Int(Hq2'Size)));
Parameter("PIV4_Size",Format(Int(Hqi'Size)));
Parameter("PId3_Size",Format(Int(Hqid'Size)));
Parameter("RV300_Size",Format(Int(Hqr'Size)));
Parameter("L500_Size",Format(Int(Hql'Size)));
Parameter("PBV8_Size",Format(Int(Hqb'Size)));
Parameter("BV80_Size",Format(Int(Hqbv'Size)));
Certify("first uuid",To_String(Data(Hqid,1)),"alpha");
Certify("second uuid",To_String(Data(Hqid,2)),"beta");
Certify("third uuid",To_String(Data(Hqid,3)),"omega");
Certify("len_prv",Format(Length(Hq2)),"300");
Certify("plain_int_store_1", Format(Int'(Data(Hqi,1))), "1");
Certify("plain_int_store_2", Format(Int'(Data(Hqi,2))), "4");
Certify("plain_int_store_3", Format(Int'(Data(Hqi,3))), "9");
Certify("plain_int_store_4", Format(Int'(Data(Hqi,4))), "16");
declare
Hri: Hq:= Data(Hq2,Hqi);
begin
Certify("prv_gather_len",Format(Length(Hri)),"4");
Certify("prv_gather_v1",Format(Real'(Data(Hri,1)),6,2)," 1.00");
Certify("prv_gather_v1",Format(Real'(Data(Hri,2)),6,2)," 16.00");
Certify("prv_gather_v1",Format(Real'(Data(Hri,3)),6,2)," 81.00");
Certify("prv_gather_v1",Format(Real'(Data(Hri,4)),6,2),"256.00");
end;
Certify("prv_len_initial",Format(Length(Hq2)),"300");
Certify("piv_len_initial",Format(Length(Hqi)),"4");
Append(Hqr,Voidhq,11.1,To_Uuid("primul"));
Certify("prv_name_1",To_String(Name(Hqr,Voidhq,1)),"primul");
Certify("prv_len_1",Format(Length(Hqr)),"1");
Certify("prv_val_1",Format(Real'(Data(Hqr,Voidhq,1)),6,2)," 11.10");
for U in 1..30 loop
Append(Hqr, Voidhq, What => Real(U)**2, Name => To_Uuid("zet" & Format(U)));
end loop;
Set(Hqr,2,22.2);
Certify("prv_val_2",Format(Real'(Data(Hqr,Voidhq,6)),6,2)," 25.00");
Descend(Inhqr,1);
Certify("inprv_val_1",Format(Real_Data(Inhqr),6,2)," 11.10");
Move(Inhqr,15);
Certify("inprv_val_2",Format(Real_Data(Inhqr),6,2),"196.00");
Certify("prv_name_5",To_String(Name(Hqr,Voidhq,1)),"primul");
Append_Na(Hqr,Voidhq,To_Uuid("al_doilea"));
Certify("prv_name_2",To_String(Name(Hqr,Voidhq,2)),"zet1");
Certify("prv_name_3",To_String(Name(Hqr,Voidhq,1)),"primul");
Certify("prv_val_3",Format(Is_Na(Hqr,Voidhq,2)),"F");
Certify("prv_name_5",To_String(Name(Hqr,Voidhq,32)),"al_doilea");
Certify("prv_val_5",Format(Is_Na(Hqr,Voidhq,32)),"T");
Certify("prv_val_4",Format(Is_Na(Hqr,Voidhq,1)),"F");
Certify("prv_name_4",To_String(Name(Hqr,Voidhq,1)),"primul");
Certify("ps_val_1",Data(Hqs),"hello stringy world");
Append(Hql,Hq2,To_Uuid("primul_are_300"));
Certify("l_name_1",To_String(Name(Hql,Voidhq,1)),"primul_are_300");
Append_Na(Hql,Voidhq,To_Uuid("al_doilea_lipseste"));
Append(Hql,Hq2,To_Uuid("al_treilea_300"));
Append(Inhql,Hqr,To_Uuid("al_4lea_nu_e_plain"));
Append(Inhql,Hqi,To_Uuid("al_5lea_plain_int"));
Certify("l_name_2",To_String(Name(Hql,Voidhq,2)),"al_doilea_lipseste");
Certify("l_na_1",Format(Is_Na(Hql,Voidhq,2)),"T");
Certify("l_na_2",Format(Is_Na(Hql,Voidhq,1)),"F");
Certify("l_len_1",Format(Length(Hql)),"5");
Certify("l_len_2",Format(Length(Inhql)),"5");
Certify("l_atstart_1",Format(Is_At_Start(Inhql)),"T");
Certify("l_list_1",Format(Is_List(Inhql)),"T");
Certify("l_real_1",Format(Is_Real(Inhql)),"F");
Descend(Inhql,1);
Move(Inhql,1);
Certify("l_atstart_2",Format(Is_At_Start(Inhql)),"F");
Certify("l_len_3",Format(Length(Inhql)),"300");
Move(Inhql,2);
Certify("l_len_4",Format(Length(Inhql)),"0");
Certify("l_isna_0",Format(Is_Na(Inhql)),"T");
Move(Inhql,3);
Certify("l_len_5",Format(Length(Inhql)),"300");
Certify("l_list_2",Format(Is_List(Inhql)),"F");
Certify("l_real_2",Format(Is_Real(Inhql)),"F");
Ascend(Inhql);
Descend(Inhql,1);
Certify("l_realv_1",Format(Is_Real_Vector(Inhql)),"T");
Certify("l_prealv_1",Format(Is_Plain_Real_Vector(Inhql)),"T");
Descend(Inhql,20);
Certify("l_real_3",Format(Is_Real(Inhql)),"T");
Certify("l_realv_2",Format(Is_Real_Vector(Inhql)),"F");
Certify("l_prealv_2",Format(Is_Plain_Real_Vector(Inhql)),"F");
Certify("l_list_3",Format(Is_List(Inhql)),"F");
Certify("l_isna_1",Format(Is_Na(Inhql)),"F");
Store(Inhql,40.0);
Move(Inhql,21);
Store(Inhql,11.79);
Move(Inhql,20);
Certify("l_set_data_1",Format(Real_Data(Inhql),6,2)," 40.00");
Move(Inhql,21);
Certify("l_set_data_2",Format(Real_Data(Inhql),6,2)," 11.79");
Ascend(Inhql);
Move(Inhql,3);
Certify("l_realv_3",Format(Is_Real_Vector(Inhql)),"T");
Descend(Inhql);
Move(Inhql,11);
Certify("l_set_data_3",Format(Real_Data(Inhql),6,2),"121.00");
Ascend(Inhql);
Move(Inhql,4);
Certify("l_prealv_4",Format(Is_Plain_Real_Vector(Inhql)),"F");
Certify("l_realv_4",Format(Is_Real_Vector(Inhql)),"T");
Move(Inhql,5);
Certify("l_pintv_4",Format(Is_Plain_Int_Vector(Inhql)),"T");
Ascend(Inhql);
Append(Inhql,Hqid,To_Uuid("al_6lea_uuids"));
Append(Inhql,Hqs,To_Uuid("dastring"));
Append(Inhql,Hqb,To_Uuid("al8lea_bools"));
Append(Inhql,Hqbv,To_Uuid("al8lea_boolvect"));
Descend(Inhql,6);
Certify("l_pidv_1",Format(Is_Plain_Id_Vector(Inhql)),"T");
Certify("l_pidv_2",Format(Is_Id_Vector(Inhql)),"T");
Descend(Inhql,2);
Certify("l_pidv_3",Format(Is_Id(Inhql)),"T");
Ascend(Inhql);
Move(Inhql,7);
Certify("l_ps_1",Format(Is_Plain_String(Inhql)),"T");
Move(Inhql,8);
Certify("l_bv_1",Format(Is_Plain_Bool_Vector(Inhql)),"T");
Descend(Inhql,3);
Certify("l_b_1",Format(Is_Bool(Inhql)),"T");
Ascend(Inhql);
Move(Inhql,9);
Certify("l_bv_2",Format(Is_Bool_Vector(Inhql)),"T");
Certify("l_bv_3",Format(Is_Plain_Bool_Vector(Inhql)),"F");
Move(Inhql,8);
Descend(Inhql,3);
Certify("l_b_3",Format(Is_Bool(Inhql)),"T");
Ascend(Inhql);
Ascend(Inhql);
Append(Inhql,Hqr,To_Uuid("realagain10"));
Descend(Inhql,10);
Move(Inhql,10);
Certify("is_rv_1",Format(Is_Real_Vector(Inhql)),"T");
Certify("is_prv_2",Format(Is_Plain_Real_Vector(Inhql)),"F");
Certify("len_rv",Format(Length(Inhql)),"32");
Certify("size_rv",Format(Size(Inhql)),"300");
Ascend(Inhqr);
Certify("len_hqr",Format(Length(Inhqr)),"32");
Certify("size_hqr",Format(Size(Inhqr)),"300");
Append(Inhqr,1121.1121,To_Uuid("adaugat"));
Certify("len_hqr",Format(Length(Inhqr)),"33");
Descend(Inhqr,33);
Certify("val_ap_hqr",Format(Real_Data(Inhqr),10,4)," 1121.1121");
end Hqtest;
with Corlpack; use Corlpack;
with Text_Io; use Text_Io;
with Ada.Exceptions; use Ada.Exceptions;
procedure Corlidtest is
U: aliased Corlid(Quant):= Kwh;
Uq: Qw:= To_Qw(U);
V: Corlid(Quant):= To_Corlid(Uq);
function Newcorlid(T: Corlidtype) return Corlid is
U: Corlid(T);
begin
return U;
end Newcorlid;
procedure Rw(S: String) is
begin
Put(S & " reads as: ");
declare
Fs: String:= Format(Corlid'(Read(S)));
begin
Put("|"&Fs&"|");
Put(" then reread as... ");
-- if Fs(Fs'First)=' ' then
-- Put_Line(Format(Read(Fs(2..Fs'Last)),True));
-- else
Put_Line(Format(Read(Fs),True));
-- end if;
end;
end Rw;
Unu: Unuuid;
U1,U2: Uuid;
begin
Put_Line("unpacked size: " & Integer'Image(Unu'Size));
Put_Line(Integer'Image(U'size));
Put_Line(Integer'Image(Uq'size));
Put_Line(Integer'Image(V'size));
U := Kwh;
Put_Line(Format(U));
Put_Line(Format(U*5.0));
Put_Line(Format(V));
Rw("123");
Rw("-123");
Rw("-12.3");
Rw("-12.3e23");
Rw("-12.3e23m2/s2");
Rw("22kWh");
Rw("112.33RON");
Rw("112.33RON$");
Rw("112RON");
Rw("zuzun_SymAB");
Rw("ZUZUN*&_SYMB");
Rw("ZUZUN_VERY_LONG_SYMC");
Rw("10:23");
Rw("2011-09-02");
Rw("2011-09-02 12:20:22");
Rw("12m2");
Rw("12kgm/s2");
Rw("12m2/kgs");
Rw("b3fcbeac-1897-11e2-9fdf-20cf30beac11");
Rw("773aa59a-8e50-4b5c-ad29-9e3ae6431dd0");
begin
Rw("zuzun_very_long_symc");
exception
when Wrong_Type =>
Put_Line("Correctly raised wrong type");
end;
U1 := To_Uuid(Read("13.2m2"));
U2 := To_Uuid(Read("11RON"));
declare
Vu: Vuuid:= To_Vuuid(U1) & U2;
Vv: Vuuid:= To_Vuuid(U1) & Vu & Vu;
Zz: Vuuid:= Read("azu """" zu mu ""Jinx"" ""verificare" & Ascii.Lf &
" de string lung"" for you 22m2 31.4m/s2 ");
begin
Put_Line("vu(1)=" & Format(To_Corlid(Vu(1)),True));
Put_Line("vu(2)=" & Format(To_Corlid(Vu(2)),True));
Put_Line("vv(1)=" & Format(To_Corlid(Vv(1)),True));
Put_Line("vv(2)=" & Format(To_Corlid(Vv(2)),True));
Put_Line("vv(3)=" & Format(To_Corlid(Vv(3)),True));
Put_Line("vv(4)=" & Format(To_Corlid(Vv(4)),True));
Put_Line("vv(5)=" & Format(To_Corlid(Vv(5)),True));
for V in Zz'Range loop
Put_Line("zz(" & Format(V) & ")=" &
Format(To_Corlid(Zz(V)), True) & " of kind " & Kind(Zz(V)) & Ascii.Lf);
if Corlidtype_Of(Zz(V))=String_On then
Put_Line(">" & Extract_String(Zz,V) & "<");
end if;
end loop;
Put_Line("symbol zuzu: " & Format(Make_Uuid("symbol",S => "zuzu")));
end;
end Corlidtest;
with Corlpack; use Corlpack;
procedure Dantest1 is
T: Text;
-- dantest is a file that contains uuids
begin
Load(T,"dantest.dan");
declare
Zz: Vuuid:= Read(To_String(T));
begin
for V in Zz'Range loop
Write(Format(To_Corlid(Zz(V)), True)); Nl;
if Corlidtype_Of(Zz(V))=String_On then
Write(">" & Extract_String(Zz,V) & "<"); Nl;
end if;
end loop;
end;
end Dantest1;
with Corlpack; use Corlpack;
package Corlpack.Serials is
procedure Test;
end Corlpack.Serials;
--with Corlpack; use Corlpack;
package body Corlpack.Serials is
type Intset is array(Integer range <>) of Integer;
function Loinc_Checksum(Lo: Intset) return Integer is
-- http://loinc.org/downloads/files/LOINCManual.pdf appendix C
K, Sum, Odds, Evens: Integer:= 0;
begin
K := Lo'Last;
loop
Odds := Odds * 10 + Lo(K);
K := K - 2;
if K0 loop
Sum := Sum + (Odds mod 10);
Odds := Odds / 10;
end loop;
while Evens>0 loop
Sum := Sum + (Evens mod 10);
Evens := Evens / 10;
end loop;
if Sum mod 10 = 0 then
return 0;
end if;
return 10 - (Sum mod 10);
end Loinc_Checksum;
function Make_Loinc(F: Real:= 0.0; N: Int:= 0; S: String:= "") return Uuid is
R: Corlid(Serial_A7);
begin
R.A7_Name := Abstring7(String_To_Enca("LOINC.."));
R.A7_Serial := Uint64(N);
return To_Uuid(R);
end Make_Loinc;
function Read_Loinc(S: String) return Uuid is
Loinc: Intset(1..20); -- each digit in part
I: Integer:= 1;
Dashok: Boolean:= False;
Sum: Integer:= 0;
begin
for K in S'Range loop
if S(K)>='0' and then S(K)<='9' then
Loinc(I) := Character'Pos(S(K)) - Character'Pos('0');
I := I+1;
elsif S(K)='-' and then K=S'Last-1 then
Dashok := True; -- one dash is ok in the middle of the issn
else
raise Wrong_Type;
end if;
end loop;
if not Dashok then
raise Wrong_Type; -- checksum not present
end if;
if Loinc_Checksum(Loinc(1..I-2))/=Loinc(I-1) then
raise Wrong_Type; -- checksum in error
end if;
for K in 1..I-2 loop
Sum := Sum*10 + Loinc(K);
end loop;
return Make_Loinc(N => Int(Sum));
end Read_Loinc;
function Format_Loinc(U: Uuid;
W,D,E: Integer:= 0;
M1,M2,M3: Boolean:= False;
Flag: Character:= 'U';
Style: Character:= 'K';
Pic: String:= "") return String is
R: Corlid:= To_Corlid(U);
Loinc: Intset(1..20); -- each digit in part
I: Integer:= 1;
S: Integer;
Cs: Integer;
begin
I := 20;
S := Integer(R.A7_Serial); -- has to be an a7_serial
while S>0 loop
Loinc(I) := S mod 10;
S := S / 10;
I := I-1;
end loop;
Cs := Loinc_Checksum(Loinc(I+1..Loinc'Last));
S := Integer(R.A7_Serial);
if M1 then
return "loinc:" & Trim(Integer'Image(S)) & "-" & Character'Val(Character'Pos('0')+Cs);
else
return Trim(Integer'Image(S)) & "-" & Character'Val(Character'Pos('0')+Cs);
end if;
end Format_Loinc;
function Make_Issn(F: Real:= 0.0; N: Int:= 0; S: String:= "") return Uuid is
-- should change this representation to avoid recording the checksum as well
R: Corlid(Serial_A7);
begin
R.A7_Name := Abstring7(String_To_Enca("ISSN..."));
R.A7_Serial := Uint64(N);
return To_Uuid(R);
end Make_Issn;
function Read_Issn(S: String) return Uuid is
Issn: Intset(1..8); -- each digit in part
Ii: Integer:= 1;
begin
for K in S'Range loop
if S(K)>='0' and then S(K)<='9' then
Issn(Ii) := Character'Pos(S(K)) - Character'Pos('0');
Ii := Ii+1;
elsif S(K)='-' and then Ii=5 then
null; -- one dash is ok in the middle of the issn
elsif S(K)=' ' and then (Ii=1 or else Ii=9) then
null; -- spaces before and after are ok, but not inside
else
raise Wrong_Type;
end if;
end loop;
if Ii/=9 then
raise Wrong_Type;
end if;
-- compute the checksum as in en.wikipedia.org/wiki/International_Standard_Serial_Number
Ii := 8 * Issn(1) + 7 * Issn(2) + 6 * Issn(3) + 5 * Issn(4) +
4 * Issn(5) + 3 * Issn(6) + 2 * Issn(7);
if (Ii mod 11)=0 then
Ii := 0;
else
Ii := 11 - (Ii mod 11);
end if;
if Ii/=Issn(8) then
raise Wrong_Type;
end if;
return Make_Issn(N => Int(Issn(8) + 10*Issn(7) + 100*Issn(6) + 1_000*Issn(5) +
10_000*Issn(4) + 100_000*Issn(3) + 1_000_000*Issn(2) +
10_000_000*Issn(1)));
end Read_Issn;
function Format_Issn(U: Uuid;
W,D,E: Integer:= 0;
M1,M2,M3: Boolean:= False;
Flag: Character:= 'U';
Style: Character:= 'K';
Pic: String:= "") return String is
R: Corlid:= To_Corlid(U);
Im: String:= "00000000" & Trim(Uint64'Image(R.A7_Serial));
Ima: String:= Im(Im'Last-7..Im'Last);
begin
-- no need to check for the type, this is entered only by dispatching by type
if M1 then
if not M2 then
return "issn:" & Ima(Ima'First..Ima'First+3) & "-" & Ima(Ima'First+4..Ima'Last);
else
return "issn:" & Ima;
end if;
else
if not M2 then
return Ima(Ima'First..Ima'First+3) & "-" & Ima(Ima'First+4..Ima'Last);
else
return Ima;
end if;
end if;
end Format_Issn;
function Make_Isbn(F: Real:= 0.0; N: Int:= 0; S: String:= "") return Uuid is
R: Corlid(Serial_A7);
begin
R.A7_Name := Abstring7(String_To_Enca("ISBN..."));
R.A7_Serial := Uint64(N);
return To_Uuid(R);
end Make_Isbn;
function Read_Isbn(S: String) return Uuid is
Isbn: Intset(1..10); -- each digit in part
Ii: Integer:= 1;
begin
for K in S'Range loop
if S(K)>='0' and then S(K)<='9' then
Isbn(Ii) := Character'Pos(S(K)) - Character'Pos('0');
Ii := Ii+1;
elsif S(K)='-' then
null; -- one dash is ok in the middle of the isbn
elsif (S(K)='X' or else S(K)='x') and then Ii=10 then
Isbn(Ii) := 10;
Ii := Ii+1;
elsif S(K)=' ' and then (Ii=1 or else Ii=11) then
null; -- spaces before and after are ok, but not inside
else
raise Wrong_Type;
end if;
end loop;
if Ii/=11 then
raise Wrong_Type; -- too many or too few characters
end if;
-- check the checksum as in http://forums.morovia.com/how-isbn-checksum-works-p35.html
Ii := 1 * Isbn(1) + 2 * Isbn(2) + 3 * Isbn(3) + 4 * Isbn(4) +
5 * Isbn(5) + 6 * Isbn(6) + 7 * Isbn(7) + 8 * Isbn(8) + 9 * Isbn(9);
Ii := Ii mod 11;
if Ii/=Isbn(10) then
raise Wrong_Type;
end if;
return Make_Isbn(N => Int(Isbn(9) + 10*Isbn(8) + 100*Isbn(7) + 1_000*Isbn(6) +
10_000*Isbn(5) + 100_000*Isbn(4) + 1_000_000*Isbn(3) +
10_000_000*Isbn(2) + 100_000_000*Isbn(1)));
-- checksum not included in the recorded number; it is not in the 0-9 range
end Read_Isbn;
function Format_Isbn(U: Uuid;
W,D,E: Integer:= 0;
M1,M2,M3: Boolean:= False;
Flag: Character:= 'U';
Style: Character:= 'K';
Pic: String:= "") return String is
R: Corlid:= To_Corlid(U);
Ima: String(1..10);
Isbn: Intset(1..10); -- each digit in part
Ii: Int:= 1;
begin
-- no need to check for the type, serial_a7, this is entered only by dispatching by type
Ii := Int(R.A7_Serial); -- implicit check
for K in reverse 1..9 loop
Isbn(K) := Integer(Ii mod 10);
Ii := Ii / 10;
end loop;
Ii := Int(1 * Isbn(1) + 2 * Isbn(2) + 3 * Isbn(3) + 4 * Isbn(4) +
5 * Isbn(5) + 6 * Isbn(6) + 7 * Isbn(7) + 8 * Isbn(8) + 9 * Isbn(9));
Isbn(10) := Integer(Ii mod 11);
for K in 1..10 loop
if Isbn(K)<10 then
Ima(K) := Character'Val(Isbn(K)+Character'Pos('0'));
else
Ima(K) := 'X';
end if;
end loop;
if M1 then
if not M2 then
return "isbn:" & Ima(1) & "-" & Ima(2..4) & "-" & Ima(5..9) & "-" & Ima(10);
else
return "isbn:" & Ima;
end if;
else
if not M2 then
return Ima(1) & "-" & Ima(2..4) & "-" &
Ima(5..9) & "-" & Ima(10);
else
return Ima;
end if;
end if;
end Format_Isbn;
function Make_Pmid(F: Real:= 0.0; N: Int:= 0; S: String:= "") return Uuid is
R: Corlid(Serial_A7);
begin
R.A7_Name := Abstring7(String_To_Enca("PMID..."));
R.A7_Serial := Uint64(N);
return To_Uuid(R);
end Make_Pmid;
function Format_Pmid(U: Uuid;
W,D,E: Integer:= 0;
M1,M2,M3: Boolean:= False;
Flag: Character:= 'U';
Style: Character:= 'K';
Pic: String:= "") return String is
R: Corlid:= To_Corlid(U);
begin
if M1 then
return "pmid:" & Trim(Uint64'Image(R.A7_Serial));
else
return Trim(Uint64'Image(R.A7_Serial));
end if;
end Format_Pmid;
function Read_Pmid(S: String) return Uuid is
begin
return Make_Pmid(N => Int'Value(S));
end Read_Pmid;
function Make_Wbct(F: Real:= 0.0; N: Int:= 0; S: String:= "") return Uuid is
R: Corlid(Serial_A18);
begin
if S'Length>13 then
raise Wrong_Type; -- can't accomodate web citations of more than 13 characters
end if;
R.A18 := Abstring18(String_To_Enca(Dot_Fill("WBCT_" & S,18)));
return To_Uuid(R);
end Make_Wbct;
function Format_Wbct(U: Uuid;
W,D,E: Integer:= 0;
M1,M2,M3: Boolean:= False;
Flag: Character:= 'U';
Style: Character:= 'K';
Pic: String:= "") return String is
R: Corlid:= To_Corlid(U);
S: String:= Dot_Trim(Enca_To_String(Abstring((R.A18))));
begin
if M1 then
return "wbct:" & S(S'First+5..S'Last);
else
return S(S'First+5..S'Last);
end if;
end Format_Wbct;
function Read_Wbct(S: String) return Uuid is
begin
return Make_Wbct(S => S);
end Read_Wbct;
function Make_Unii(F: Real:= 0.0; N: Int:= 0; S: String:= "") return Uuid is
R: Corlid(Serial_A18);
begin
if S'Length/=10 then
raise Wrong_Type; -- can't accomodate web citations of more than 13 characters
end if;
R.A18 := Abstring18(String_To_Enca(Dot_Fill("UNII_" & S,18)));
return To_Uuid(R);
end Make_Unii;
function Format_Unii(U: Uuid;
W,D,E: Integer:= 0;
M1,M2,M3: Boolean:= False;
Flag: Character:= 'U';
Style: Character:= 'K';
Pic: String:= "") return String is
R: Corlid:= To_Corlid(U);
S: String:= Dot_Trim(Enca_To_String(Abstring((R.A18))));
begin
if M1 then
return "unii:" & S(S'First+5..S'Last);
else
return S(S'First+5..S'Last);
end if;
end Format_Unii;
function Read_Unii(S: String) return Uuid is
begin
-- should add here a reference, once I find it
return Make_Unii(S => S);
end Read_Unii;
procedure Test is
begin
Write(Format_Issn(Make_Issn(N => 03178471), M1=>True)); Nl;
Write(Format_Issn(Read_Issn("0317-8471"))); Nl;
Write(Format_Issn(Make_Uuid("issn",N => 03178471))); Nl;
Write(Format_Isbn(Make_Isbn(N => 156592371), M1=>True)); Nl;
Write(Format_Isbn(Read_Isbn("1-5659-2371-5"))); Nl;
Write(Format_Isbn(Make_Uuid("isbn",N => 156592371))); Nl;
Write(Format_Loinc(Make_Loinc(N => 7665), M1=>True)); Nl;
Write(Format_Loinc(Read_Loinc("7665-3"))); Nl;
Write(Format_Loinc(Make_Uuid("loinc",N => 7665))); Nl;
Write(Format_Wbct(Make_Wbct(S => "6DEFVLH7m"), M1=>True)); Nl;
Write(Format_Wbct(Read_Wbct("6DEFVLH7m"))); Nl;
Write(Format_Wbct(Make_Uuid("wbct",S => "6DEFVLH7m"))); Nl;
Write(Format_Unii(Make_Unii(S => "0X8Q245Y7B"), M1=>True)); Nl;
Write(Format_Unii(Read_Unii("0X8Q245Y7B"))); Nl;
Write(Format_Unii(Make_Uuid("unii",S => "0X8Q245Y7B"))); Nl;
end Test;
begin
Register_Uuid_Kind("issn", Serial_A7,
Make_Method => Make_Issn'Access,
Read_Method => Read_Issn'Access,
Format_Method => Format_Issn'Access);
Register_Uuid_Kind("isbn", Serial_A7,
Make_Method => Make_Isbn'Access,
Read_Method => Read_Isbn'Access,
Format_Method => Format_Isbn'Access);
Register_Uuid_Kind("loinc", Serial_A7,
Make_Method => Make_Loinc'Access,
Read_Method => Read_Loinc'Access,
Format_Method => Format_Loinc'Access);
Register_Uuid_Kind("pmid", Serial_A7,
Make_Method => Make_Pmid'Access,
Read_Method => Read_Pmid'Access,
Format_Method => Format_Pmid'Access);
Register_Uuid_Kind("wbct", Serial_A18,
Make_Method => Make_Wbct'Access,
Read_Method => Read_Wbct'Access,
Format_Method => Format_Wbct'Access);
Register_Uuid_Kind("unii", Serial_A18,
Make_Method => Make_Unii'Access,
Read_Method => Read_Unii'Access,
Format_Method => Format_Unii'Access);
end Corlpack.Serials;
with Corlpack; use Corlpack;
with Corlpack.Serials; use Corlpack.Serials;
procedure Kindregtest1 is
begin
Register_Uuid_Kind("issm", Serial_A7);
Register_Uuid_Kind("anii", Serial_A7);
Register_Uuid_Kind("unii2", Serial_A7);
Register_Uuid_Kind("unij", Serial_A7);
Write(Kind_Reg_Fill); Nl;
Write("issn is (4) " & Kind_Reg_Cursor'Image(Locate_Kind("issn"))); Nl;
Write("Issn is (4) " & Kind_Reg_Cursor'Image(Locate_Kind("Issn"))); Nl;
Write("pmid is (5) " & Kind_Reg_Cursor'Image(Locate_Kind("pmid"))); Nl;
for K in 1..Kind_Reg_Fill loop
Write(Kind_Reg(K).Utype); Nl;
end loop;
Write(Format(Make_Uuid("issn",N => 03178471))); Nl;
Write("with read:"); Nl;
Write(Format(Uuid'(Read("issn:03178471")),M1=>True)); Nl;
Write(Format(Uuid'(Read("isbn:1565923715")),M1=>True)); Nl;
Write(Format(Uuid'(Read("loinc:9594-3")),M1=>True)); Nl;
Write(Format(Uuid'(Read("loinc:8273-5")),M1=>True)); Nl;
Write(Format(Uuid'(Read("loinc:49572-1")),M1=>True)); Nl;
begin
Write(Format(Uuid'(Read("loinc:9594-9")))); Nl; -- wrong checksum
exception
when Wrong_Type =>
Write("correctly raised wrong type for loinc:9594-9 that has wrong checksum"); Nl;
end;
Write(Format(Uuid'(Read("pmid:21239879")),M1=>True)); Nl;
Write(Format(Uuid'(Read("wbct:6DEFVLH7m")),M1=>True)); Nl;
Write(Format(Uuid'(Read("unii:0X8Q245Y7B")),M1=>True)); Nl; -- that is, chicken
Write("testing ..."); Nl;
Test;
end Kindregtest1;
with Corlpack; use Corlpack;
procedure Corlpack_Demo is
-- demonstration
procedure Hello_World is
V: Vuuid:= Read("hello world");
begin
for K in V'Range loop
Write(Format(V(K)));
Write(" ");
end loop;
Nl;
end Hello_World;
procedure Test_Load_Save is
begin
Save(Load("dantest.dan","ids"),"dantest-resaved.dan","ids");
end Test_Load_Save;
begin
Nl(2);
Write("Corlpack demo");
Nl(2);
Hello_World;
Nl(2);
Write("Doing load/save test");
Nl;
Test_Load_Save;
Write("Done, look at dantest-resaved.dan");
Nl(2);
end Corlpack_Demo;