-- CORLPACK -- Package of utility functions -- Copyright (c) 2012 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, 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 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 Zascii7, -- zero-ended (or full) ascii_7 String_On, String_Off, -- 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; function Extract_String(V: Vuuid; K: Integer) return String; function Next_After(U: Uuid) return Integer; -- 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; 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; 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 Zascii7 => Str7: Ascii7str; when String_On => Len7on: Integer; Nch7on: Integer; when String_Off => Len7off: 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 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 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.AB18_Sym := S; return Rv; end Make_Sym_A18; function Make_Sym_B18(S: Abstring18) return Corlid is Rv: Corlid(Sym_B18); begin 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.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); Rvc: Cstring(1..22); 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 Qualified_Read(S: String; K: Integer) return Corlid is Tag: String:= S(S'First..(K-1)); Ki: Kind_Reg_Cursor; begin if Tag="string" then declare R: Corlid(String_On); begin return R; end; end if; 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 String_Off => -- 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 String_Off => return Pref(1..Preflen) & Utrim(Integer'Image(C.Len7off)); 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(String_Off); 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.Len7off := 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.Len7off := Uend.Len7off + 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 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 Zascii7 => return "strdata"; when String_On => return "string"; when String_Off => return "endstring"; 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 Zascii7 => return "DA"; when String_On => return "K"; when String_Off => 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)), 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)), String_off => (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 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 String_Off => if N=1 and then K=1 then return Int(Ci.Len7off); 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 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 String_Off => if N=1 and then K=1 then Ci.Len7off := 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 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(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; begin Reset(Default_Generator,Moment_Random); Init_Ch_To_Block; Init_Encodings; Init_Readtab; 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; 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.Issn is private procedure Test; end Corlpack.Issn; --with Corlpack; use Corlpack; package body Corlpack.Issn is function Make_Issn(F: Real:= 0.0; N: Int:= 0; S: String:= "") return Uuid is R: Corlid(Serial_A7); begin R.A7_Name := Abstring7(String_To_Encb("ISSN...")); R.A7_Serial := Uint64(N); return To_Uuid(R); end Make_Issn; function Read_Issn(S: String) return Uuid is Issn: array(1..8) of Integer; -- 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; 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; end Test; begin Register_Uuid_Kind("issn", Serial_A7, Make_Method => Make_Issn'Access, Read_Method => Read_Issn'Access, Format_Method => Format_Issn'Access); end Corlpack.Issn; with Corlpack; use Corlpack; with Corlpack.Issn; use Corlpack.Issn; procedure Kindregtest1 is begin Register_Uuid_Kind("pmid", Serial_A7); Register_Uuid_Kind("issm", Serial_A7); Register_Uuid_Kind("isbn", Serial_A7); Register_Uuid_Kind("isbn", Serial_A7); Register_Uuid_Kind("unii", Serial_A7); Register_Uuid_Kind("unii", Serial_A7); Register_Uuid_Kind("unii", Serial_A7); Register_Uuid_Kind("anii", Serial_A7); Register_Uuid_Kind("unii", 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("UNII is (6) " & Kind_Reg_Cursor'Image(Locate_Kind("UNII"))); Nl; Write("pmid is (5) " & Kind_Reg_Cursor'Image(Locate_Kind("pmid"))); Nl; Write("ISBN is (2) " & Kind_Reg_Cursor'Image(Locate_Kind("ISBN"))); 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")))); Nl; end Kindregtest1;