added an incomplete and experimental file package
This commit is contained in:
parent
8ef3eabe78
commit
bf0477cfbf
@ -7,13 +7,15 @@ with Slim_Stream;
|
|||||||
with Wide_Stream;
|
with Wide_Stream;
|
||||||
with Ada.Text_IO;
|
with Ada.Text_IO;
|
||||||
with Ada.Unchecked_Deallocation;
|
with Ada.Unchecked_Deallocation;
|
||||||
|
with H2.Sysapi;
|
||||||
|
|
||||||
|
with Interfaces.C;
|
||||||
|
|
||||||
procedure scheme is
|
procedure scheme is
|
||||||
--package Stream renames Wide_Stream;
|
package Stream renames Wide_Stream;
|
||||||
--package Scheme renames H2.Wide.Scheme;
|
package Scheme renames H2.Wide.Scheme;
|
||||||
|
--package Stream renames Slim_Stream;
|
||||||
package Stream renames Slim_Stream;
|
--package Scheme renames H2.Slim.Scheme;
|
||||||
package Scheme renames H2.Slim.Scheme;
|
|
||||||
|
|
||||||
Pool: aliased Storage.Global_Pool;
|
Pool: aliased Storage.Global_Pool;
|
||||||
SI: Scheme.Interpreter_Record;
|
SI: Scheme.Interpreter_Record;
|
||||||
@ -27,7 +29,7 @@ procedure scheme is
|
|||||||
--String_Stream: Stream.String_Input_Stream_Record := (Len => String'Length, Str => String, Pos => 0);
|
--String_Stream: Stream.String_Input_Stream_Record := (Len => String'Length, Str => String, Pos => 0);
|
||||||
|
|
||||||
--File_Name: aliased S.Object_Character_Array := "test.adb";
|
--File_Name: aliased S.Object_Character_Array := "test.adb";
|
||||||
File_Name: aliased constant Scheme.Object_Character_Array := "test.scm";
|
File_Name: aliased constant Scheme.Object_Character_Array := "시험.scm";
|
||||||
--File_Stream: Stream.File_Stream_Record (File_Name'Unchecked_Access);
|
--File_Stream: Stream.File_Stream_Record (File_Name'Unchecked_Access);
|
||||||
--File_Stream: Stream.File_Stream_Record := (Name => File_Name'Unchecked_Access);
|
--File_Stream: Stream.File_Stream_Record := (Name => File_Name'Unchecked_Access);
|
||||||
File_Stream: Stream.File_Stream_Record;
|
File_Stream: Stream.File_Stream_Record;
|
||||||
@ -35,10 +37,41 @@ procedure scheme is
|
|||||||
--procedure h2init;
|
--procedure h2init;
|
||||||
--pragma Import (C, h2init, "h2init");
|
--pragma Import (C, h2init, "h2init");
|
||||||
|
|
||||||
|
|
||||||
begin
|
begin
|
||||||
--h2init;
|
--h2init;
|
||||||
|
|
||||||
|
declare
|
||||||
|
package Sysapi is new H2.Sysapi (
|
||||||
|
H2.Slim.Character,
|
||||||
|
H2.Wide.Character,
|
||||||
|
H2.Slim.String,
|
||||||
|
H2.Wide.String,
|
||||||
|
H2.Wide.Utf8.To_Unicode_String,
|
||||||
|
H2.Wide.Utf8.From_Unicode_String);
|
||||||
|
|
||||||
|
F: Sysapi.File_Pointer;
|
||||||
|
M: Sysapi.Mode_Record;
|
||||||
|
LG: Sysapi.Flag_Record;
|
||||||
|
begin
|
||||||
|
Sysapi.File.Open (F, H2.Slim.String'("/etc/passwd"), LG, M);
|
||||||
|
Sysapi.File.Close (F);
|
||||||
|
end;
|
||||||
|
|
||||||
|
|
||||||
|
declare
|
||||||
|
|
||||||
|
LC_ALL : constant Interfaces.C.int := 0;
|
||||||
|
procedure setlocale (
|
||||||
|
category : Interfaces.C.int;
|
||||||
|
locale : Interfaces.C.char_array);
|
||||||
|
pragma Import (C, setlocale);
|
||||||
|
Empty : aliased Interfaces.C.char_array := (0 => Interfaces.C.nul);
|
||||||
|
|
||||||
|
begin
|
||||||
|
setlocale (LC_ALL, Empty);
|
||||||
|
end;
|
||||||
|
|
||||||
|
|
||||||
Scheme.Open (SI, 2_000_000, Pool'Unchecked_Access);
|
Scheme.Open (SI, 2_000_000, Pool'Unchecked_Access);
|
||||||
--Scheme.Open (SI, null);
|
--Scheme.Open (SI, null);
|
||||||
|
|
||||||
|
@ -2,6 +2,7 @@ with H2.Pool;
|
|||||||
with Ada.Unchecked_Conversion;
|
with Ada.Unchecked_Conversion;
|
||||||
|
|
||||||
with Ada.Text_IO; -- for debugging
|
with Ada.Text_IO; -- for debugging
|
||||||
|
with Ada.Exceptions;
|
||||||
|
|
||||||
package body Wide_Stream is
|
package body Wide_Stream is
|
||||||
|
|
||||||
@ -54,9 +55,9 @@ Ada.Text_IO.Put_Line ("****** CLOSE WIDE STRING STREAM ******");
|
|||||||
|
|
||||||
procedure Open (Stream: in out File_Stream_Record) is
|
procedure Open (Stream: in out File_Stream_Record) is
|
||||||
begin
|
begin
|
||||||
Ada.Text_IO.Put_Line (">>>>> OPEN WIDE FILE STREAM <<<<< " & Standard.String(Utf8.Unicode_To_Utf8(Utf8.Unicode_String(Stream.Name.all))));
|
Ada.Text_IO.Put_Line (">>>>> OPEN WIDE FILE STREAM <<<<< " & Standard.String(Utf8.From_Unicode_String(Utf8.Unicode_String(Stream.Name.all))));
|
||||||
--Ada.Wide_Text_IO.Open (Stream.Handle, Ada.Wide_Text_IO.In_File, Ada.Characters.Conversions.To_String(Standard.Wide_String(Stream.Name.all)));
|
--Ada.Wide_Text_IO.Open (Stream.Handle, Ada.Wide_Text_IO.In_File, Ada.Characters.Conversions.To_String(Standard.Wide_String(Stream.Name.all)));
|
||||||
Ada.Wide_Text_IO.Open (Stream.Handle, Ada.Wide_Text_IO.In_File, Standard.String(Utf8.Unicode_To_Utf8(Utf8.Unicode_String(Stream.Name.all))));
|
Ada.Wide_Text_IO.Open (Stream.Handle, Ada.Wide_Text_IO.In_File, Standard.String(Utf8.From_Unicode_String(Utf8.Unicode_String(Stream.Name.all))));
|
||||||
end Open;
|
end Open;
|
||||||
|
|
||||||
procedure Close (Stream: in out File_Stream_Record) is
|
procedure Close (Stream: in out File_Stream_Record) is
|
||||||
@ -64,7 +65,17 @@ Ada.Text_IO.Put_Line (">>>>> OPEN WIDE FILE STREAM <<<<< " & Standard.String(Utf
|
|||||||
function To_Wide_String is new Ada.Unchecked_Conversion (S.Object_Character_Array, Wide_String);
|
function To_Wide_String is new Ada.Unchecked_Conversion (S.Object_Character_Array, Wide_String);
|
||||||
begin
|
begin
|
||||||
--Ada.Wide_Text_IO.Put_Line (">>>>> CLOSE File STREAM <<<<< " & Standard.Wide_String(Stream.Name.all));
|
--Ada.Wide_Text_IO.Put_Line (">>>>> CLOSE File STREAM <<<<< " & Standard.Wide_String(Stream.Name.all));
|
||||||
Ada.Text_IO.Put_Line (">>>>> CLOSE WIDE FILE STREAM <<<<< " & Standard.String(Utf8.Unicode_To_Utf8(Utf8.Unicode_String(Stream.Name.all))));
|
Ada.Text_IO.Put_Line (">>>>> CLOSE WIDE FILE STREAM <<<<< " & Standard.String(Utf8.From_Unicode_String(Utf8.Unicode_String(Stream.Name.all))));
|
||||||
|
begin
|
||||||
|
ada.wide_text_io.put_line (">> " & Standard.Wide_String(Utf8.To_Unicode_String(Utf8.From_Unicode_String(Utf8.Unicode_String(Stream.Name.all)))));
|
||||||
|
exception
|
||||||
|
when Ex: others =>
|
||||||
|
ada.text_io.put_line ("fuck - " & Ada.Exceptions.Exception_Name(Ex) & Ada.Exceptions.Exception_Information(Ex));
|
||||||
|
end;
|
||||||
|
ada.text_io.put_line (">>");
|
||||||
|
|
||||||
|
|
||||||
|
|
||||||
Ada.Wide_Text_IO.Close (Stream.Handle);
|
Ada.Wide_Text_IO.Close (Stream.Handle);
|
||||||
end Close;
|
end Close;
|
||||||
|
|
||||||
|
@ -35,8 +35,6 @@
|
|||||||
--
|
--
|
||||||
---------------------------------------------------------------------
|
---------------------------------------------------------------------
|
||||||
|
|
||||||
with System;
|
|
||||||
with System.Storage_Pools;
|
|
||||||
with Ada.Unchecked_Conversion;
|
with Ada.Unchecked_Conversion;
|
||||||
with H2.Ascii;
|
with H2.Ascii;
|
||||||
|
|
||||||
|
@ -2,6 +2,8 @@ with H2.Scheme;
|
|||||||
|
|
||||||
package H2.Slim is
|
package H2.Slim is
|
||||||
|
|
||||||
package Scheme is new H2.Scheme (Standard.Character);
|
subtype Character is Standard.Character;
|
||||||
|
type String is array(System_Index range<>) of Character;
|
||||||
|
package Scheme is new H2.Scheme (Character);
|
||||||
|
|
||||||
end H2.Slim;
|
end H2.Slim;
|
||||||
|
5
lib/h2-sysapi.adb
Normal file
5
lib/h2-sysapi.adb
Normal file
@ -0,0 +1,5 @@
|
|||||||
|
package body H2.Sysapi is
|
||||||
|
|
||||||
|
package body File is separate;
|
||||||
|
|
||||||
|
end H2.Sysapi;
|
49
lib/h2-sysapi.ads
Normal file
49
lib/h2-sysapi.ads
Normal file
@ -0,0 +1,49 @@
|
|||||||
|
|
||||||
|
generic
|
||||||
|
type Slim_Character is (<>);
|
||||||
|
type Wide_Character is (<>);
|
||||||
|
type Slim_String is array(System_Index range<>) of Slim_Character;
|
||||||
|
type Wide_String is array(System_Index range<>) of Wide_Character;
|
||||||
|
with function Slim_To_Wide (Slim: in Slim_String) return Wide_String;
|
||||||
|
with function Wide_To_Slim (Wide: in Wide_String) return Slim_String;
|
||||||
|
|
||||||
|
package H2.Sysapi is
|
||||||
|
|
||||||
|
type Flag_Record is record
|
||||||
|
x: integer;
|
||||||
|
end record;
|
||||||
|
|
||||||
|
type Mode_Record is record
|
||||||
|
x: integer;
|
||||||
|
end record;
|
||||||
|
|
||||||
|
type File_Record is tagged null record;
|
||||||
|
type File_Pointer is access all File_Record'Class;
|
||||||
|
|
||||||
|
type File_Flag is (
|
||||||
|
RDONLY,
|
||||||
|
RDWR
|
||||||
|
);
|
||||||
|
|
||||||
|
package File is
|
||||||
|
procedure Open (File: out File_Pointer;
|
||||||
|
Name: in Slim_String;
|
||||||
|
Flag: in Flag_Record;
|
||||||
|
Mode: in Mode_Record;
|
||||||
|
Pool: in Storage_Pool_Pointer := null);
|
||||||
|
|
||||||
|
procedure Open (File: out File_Pointer;
|
||||||
|
Name: in Wide_String;
|
||||||
|
Flag: in Flag_Record;
|
||||||
|
Mode: in Mode_Record;
|
||||||
|
Pool: in Storage_Pool_Pointer := null);
|
||||||
|
|
||||||
|
procedure Close (File: in out File_Pointer);
|
||||||
|
end File;
|
||||||
|
|
||||||
|
--procedure Open_File (File: out File_Pointer;
|
||||||
|
-- Flag: in Flag_Record;
|
||||||
|
-- Mode: in Mode_Record) renames File.Open;
|
||||||
|
--procedure Close_File (File: in out File_Pointer) renames File.Close;
|
||||||
|
|
||||||
|
end H2.Sysapi;
|
183
lib/h2-utf8.adb
183
lib/h2-utf8.adb
@ -1,29 +1,51 @@
|
|||||||
|
with Interfaces;
|
||||||
|
|
||||||
package body H2.Utf8 is
|
package body H2.Utf8 is
|
||||||
|
|
||||||
type Uint8 is mod 2 ** 8;
|
--|----------------------------------------------------------------------------
|
||||||
type Uint32 is mod 2 ** 32;
|
--| From RFC 2279 UTF-8, a transformation format of ISO 10646
|
||||||
|
--|
|
||||||
|
--| UCS-4 range (hex.) UTF-8 octet sequence (binary)
|
||||||
|
--| 1:2 00000000-0000007F 0xxxxxxx
|
||||||
|
--| 2:2 00000080-000007FF 110xxxxx 10xxxxxx
|
||||||
|
--| 3:2 00000800-0000FFFF 1110xxxx 10xxxxxx 10xxxxxx
|
||||||
|
--| 4:4 00010000-001FFFFF 11110xxx 10xxxxxx 10xxxxxx 10xxxxxx
|
||||||
|
--| inv 00200000-03FFFFFF 111110xx 10xxxxxx 10xxxxxx 10xxxxxx 10xxxxxx
|
||||||
|
--| inv 04000000-7FFFFFFF 1111110x 10xxxxxx 10xxxxxx 10xxxxxx 10xxxxxx 10xxxxxx
|
||||||
|
--|----------------------------------------------------------------------------
|
||||||
|
|
||||||
|
--type Uint8 is mod 2 ** 8;
|
||||||
|
--type Uint32 is mod 2 ** 32;
|
||||||
|
use type Interfaces.Unsigned_8;
|
||||||
|
use type Interfaces.Unsigned_32;
|
||||||
|
subtype Uint8 is Interfaces.Unsigned_8;
|
||||||
|
subtype Uint32 is Interfaces.Unsigned_32;
|
||||||
|
|
||||||
type Conv_Record is record
|
type Conv_Record is record
|
||||||
Lower: Uint32;
|
Lower: Uint32;
|
||||||
Upper: Uint32;
|
Upper: Uint32;
|
||||||
Fbyte: Uint8; -- Mask to the first utf8 byte */
|
|
||||||
Mask: Uint8;
|
Fbyte: Uint8;
|
||||||
Fmask: Uint8;
|
Mask: Uint8; -- Mask for getting the fixed bits in the first byte.
|
||||||
Length: Uint8; -- number of bytes
|
-- (First-Byte and Mask) = Fbyte
|
||||||
|
|
||||||
|
Fmask: Uint8; -- Mask for getting the actual values bits off the first byte.
|
||||||
|
|
||||||
|
Length: System_Length; -- Number of bytes
|
||||||
end record;
|
end record;
|
||||||
|
|
||||||
type Conv_Record_Array is array(System_Index range<>) of Conv_Record;
|
type Conv_Record_Array is array(System_Index range<>) of Conv_Record;
|
||||||
|
|
||||||
Conv_Table: constant Conv_Record_Array := (
|
Conv_Table: constant Conv_Record_Array := (
|
||||||
(16#0000_0000#, 16#0000_007F#, 16#00#, 16#80#, 16#7F#, 1),
|
(16#0000_0000#, 16#0000_007F#, 2#0000_0000#, 2#1000_0000#, 2#0111_1111#, 1),
|
||||||
(16#0000_0080#, 16#0000_07FF#, 16#C0#, 16#E0#, 16#1F#, 2),
|
(16#0000_0080#, 16#0000_07FF#, 2#1100_0000#, 2#1110_0000#, 2#0001_1111#, 2),
|
||||||
(16#0000_0800#, 16#0000_FFFF#, 16#E0#, 16#F0#, 16#0F#, 3),
|
(16#0000_0800#, 16#0000_FFFF#, 2#1110_0000#, 2#1111_0000#, 2#0000_1111#, 3),
|
||||||
(16#0001_0000#, 16#001F_FFFF#, 16#F0#, 16#F8#, 16#07#, 4),
|
(16#0001_0000#, 16#001F_FFFF#, 2#1111_0000#, 2#1111_1000#, 2#0000_0111#, 4),
|
||||||
(16#0020_0000#, 16#03FF_FFFF#, 16#F8#, 16#FC#, 16#03#, 5),
|
(16#0020_0000#, 16#03FF_FFFF#, 2#1111_1000#, 2#1111_1100#, 2#0000_0011#, 5),
|
||||||
(16#0400_0000#, 16#7FFF_FFFF#, 16#FC#, 16#FE#, 16#01#, 6)
|
(16#0400_0000#, 16#7FFF_FFFF#, 2#1111_1100#, 2#1111_1110#, 2#0000_0001#, 6)
|
||||||
);
|
);
|
||||||
|
|
||||||
function Get_Utf8_Slot (UV: in Uint32) return System_Size is
|
function Get_Utf8_Slot (UV: in Uint32) return System_Length is
|
||||||
pragma Inline (Get_Utf8_Slot);
|
pragma Inline (Get_Utf8_Slot);
|
||||||
begin
|
begin
|
||||||
for I in Conv_Table'Range loop
|
for I in Conv_Table'Range loop
|
||||||
@ -31,14 +53,14 @@ package body H2.Utf8 is
|
|||||||
return I;
|
return I;
|
||||||
end if;
|
end if;
|
||||||
end loop;
|
end loop;
|
||||||
return System_Size'First;
|
return System_Length'First;
|
||||||
end Get_Utf8_Slot;
|
end Get_Utf8_Slot;
|
||||||
|
|
||||||
function Unicode_To_Utf8 (UC: in Unicode_Character) return Utf8_String is
|
function From_Unicode_Character (Chr: in Unicode_Character) return Utf8_String is
|
||||||
UV: Uint32;
|
UV: Uint32;
|
||||||
I: System_Size;
|
I: System_Length;
|
||||||
begin
|
begin
|
||||||
UV := Unicode_Character'Pos(UC);
|
UV := Unicode_Character'Pos(Chr);
|
||||||
|
|
||||||
I := Get_Utf8_Slot(UV);
|
I := Get_Utf8_Slot(UV);
|
||||||
if I not in System_Index'Range then
|
if I not in System_Index'Range then
|
||||||
@ -51,25 +73,26 @@ package body H2.Utf8 is
|
|||||||
for J in reverse Result'First + 1 .. Result'Last loop
|
for J in reverse Result'First + 1 .. Result'Last loop
|
||||||
-- 2#0011_1111#: 16#3F#
|
-- 2#0011_1111#: 16#3F#
|
||||||
-- 2#1000_0000#: 16#80#
|
-- 2#1000_0000#: 16#80#
|
||||||
Result(J) := Utf8_Character'Val((UV and 2#0011_1111#) or 2#1000_0000#);
|
Result(J) := Utf8_Character'Val((UV and Uint32'(2#0011_1111#)) or Uint32'(2#1000_0000#));
|
||||||
UV := UV / (2 ** 6); --UV := UV >> 6;
|
--UV := UV / (2 ** 6); --UV := UV >> 6;
|
||||||
|
UV := Interfaces.Shift_Right (UV, 6);
|
||||||
end loop;
|
end loop;
|
||||||
|
|
||||||
Result(Result'First) := Utf8_Character'Val(UV or Uint32(Conv_Table(I).Fbyte));
|
Result(Result'First) := Utf8_Character'Val(UV or Uint32(Conv_Table(I).Fbyte));
|
||||||
return Result;
|
return Result;
|
||||||
end;
|
end;
|
||||||
end Unicode_To_Utf8;
|
end From_Unicode_Character;
|
||||||
|
|
||||||
|
function From_Unicode_String (Str: in Unicode_String) return Utf8_String is
|
||||||
function Unicode_To_Utf8 (US: in Unicode_String) return Utf8_String is
|
|
||||||
-- this function has high stack pressure if the input string is too long
|
-- this function has high stack pressure if the input string is too long
|
||||||
-- TODO: create a procedure to overcome this problem.
|
-- TODO: create a procedure to overcome this problem.
|
||||||
Tmp: System_Size;
|
Tmp: System_Length;
|
||||||
begin
|
begin
|
||||||
|
-- Calculate the length first
|
||||||
Tmp := 0;
|
Tmp := 0;
|
||||||
for I in US'Range loop
|
for I in Str'Range loop
|
||||||
declare
|
declare
|
||||||
Utf8: Utf8_String := Unicode_To_Utf8(US(I));
|
Utf8: Utf8_String := From_Unicode_Character(Chr => Str(I));
|
||||||
begin
|
begin
|
||||||
Tmp := Tmp + Utf8'Length;
|
Tmp := Tmp + Utf8'Length;
|
||||||
end;
|
end;
|
||||||
@ -79,9 +102,9 @@ package body H2.Utf8 is
|
|||||||
Result: Utf8_String (1 .. Tmp);
|
Result: Utf8_String (1 .. Tmp);
|
||||||
begin
|
begin
|
||||||
Tmp := Result'First;
|
Tmp := Result'First;
|
||||||
for I in US'Range loop
|
for I in Str'Range loop
|
||||||
declare
|
declare
|
||||||
Utf8: Utf8_String := Unicode_To_Utf8(US(I));
|
Utf8: Utf8_String := From_Unicode_Character(Str(I));
|
||||||
begin
|
begin
|
||||||
Result(Tmp .. Tmp + Utf8'Length - 1) := Utf8;
|
Result(Tmp .. Tmp + Utf8'Length - 1) := Utf8;
|
||||||
Tmp := Tmp + Utf8'Length;
|
Tmp := Tmp + Utf8'Length;
|
||||||
@ -89,18 +112,106 @@ package body H2.Utf8 is
|
|||||||
end loop;
|
end loop;
|
||||||
return Result;
|
return Result;
|
||||||
end;
|
end;
|
||||||
end Unicode_To_Utf8;
|
end From_Unicode_String;
|
||||||
|
|
||||||
procedure Utf8_To_Unicode (Utf8: in Utf8_String;
|
function Sequence_Length (Seq: in Utf8_Character) return System_Length is
|
||||||
UC: out Unicode_Character) is
|
|
||||||
begin
|
begin
|
||||||
null;
|
for I in Conv_Table'Range loop
|
||||||
end Utf8_To_Unicode;
|
if (Utf8_Character'Pos(Seq) and Conv_Table(I).Mask) = Conv_Table(I).Fbyte then
|
||||||
|
return Conv_Table(I).Length;
|
||||||
|
end if;
|
||||||
|
end loop;
|
||||||
|
return System_Length'First;
|
||||||
|
end Sequence_Length;
|
||||||
|
|
||||||
procedure Utf8_To_Unicode (Utf8: in Utf8_String;
|
procedure To_Unicode_Character (Seq: in Utf8_String;
|
||||||
US: in out Unicode_String) is
|
Seq_Len: out System_Length;
|
||||||
|
Chr: out Unicode_Character) is
|
||||||
|
W: Uint32;
|
||||||
begin
|
begin
|
||||||
null;
|
for I in Conv_Table'Range loop
|
||||||
end Utf8_To_Unicode;
|
|
||||||
|
-- Check if the first byte matches the desired bit patterns.
|
||||||
|
if (Utf8_Character'Pos(Seq(Seq'First)) and Conv_Table(I).Mask) = Conv_Table(I).Fbyte then
|
||||||
|
|
||||||
|
if Seq'Length < Conv_Table(I).Length then
|
||||||
|
raise Insufficient_Utf8_Sequence;
|
||||||
|
end if;
|
||||||
|
|
||||||
|
-- Get the values bits off the first byte.
|
||||||
|
W := Utf8_Character'Pos(Seq(Seq'First)) and Uint32(Conv_Table(I).Fmask);
|
||||||
|
|
||||||
|
-- Get the values bits off subsequent bytes.
|
||||||
|
for J in 1 .. Conv_Table(I).Length - 1 loop
|
||||||
|
if (Utf8_Character'Pos(Seq(Seq'First + J)) and Uint32'(2#1100_0000#)) /= Uint32'(2#1000_0000#) then
|
||||||
|
-- Each UTF8 byte except the first must be set with 2#1000_0000.
|
||||||
|
raise Invalid_Utf8_Sequence;
|
||||||
|
end if;
|
||||||
|
W := Interfaces.Shift_Left(W, 6) or (Utf8_Character'Pos(Seq(Seq'First + J)) and Uint32'(2#0011_1111#));
|
||||||
|
end loop;
|
||||||
|
|
||||||
|
-- Return the character matching the word
|
||||||
|
Chr := Unicode_Character'Val(W);
|
||||||
|
Seq_Len := Conv_Table(I).Length;
|
||||||
|
return;
|
||||||
|
end if;
|
||||||
|
end loop;
|
||||||
|
|
||||||
|
raise Invalid_Utf8_Sequence;
|
||||||
|
end To_Unicode_Character;
|
||||||
|
|
||||||
|
function To_Unicode_Character (Seq: in Utf8_String) return Unicode_Character is
|
||||||
|
Seq_Len: System_Length;
|
||||||
|
Chr: Unicode_Character;
|
||||||
|
begin
|
||||||
|
To_Unicode_Character (Seq, Seq_Len, Chr);
|
||||||
|
return Chr;
|
||||||
|
end To_Unicode_Character;
|
||||||
|
|
||||||
|
procedure To_Unicode_String (Seq: in Utf8_String;
|
||||||
|
Seq_Len: out System_Length;
|
||||||
|
Str: in out Unicode_String;
|
||||||
|
Str_Len: out System_Length) is
|
||||||
|
Seq_Pos: System_Index := Seq'First;
|
||||||
|
Str_Pos: System_Index := Str'First;
|
||||||
|
Len: System_Length;
|
||||||
|
begin
|
||||||
|
while Seq_Pos <= Seq'Last and then Str_Pos <= Str'Last loop
|
||||||
|
To_Unicode_Character(Seq(Seq_Pos .. Seq'Last), Len, Str(Str_Pos));
|
||||||
|
Seq_Pos := Seq_Pos + Len;
|
||||||
|
Str_Pos := Str_Pos + 1;
|
||||||
|
end loop;
|
||||||
|
|
||||||
|
Seq_Len := Seq_Pos - Seq'First;
|
||||||
|
Str_Len := Str_Pos - Str'First;
|
||||||
|
end To_Unicode_String;
|
||||||
|
|
||||||
|
function To_Unicode_String (Seq: in Utf8_String) return Unicode_String is
|
||||||
|
UL: System_Length := 0;
|
||||||
|
begin
|
||||||
|
declare
|
||||||
|
Chr: Unicode_Character;
|
||||||
|
Pos: System_Index := Seq'First;
|
||||||
|
Seq_Len: System_Length;
|
||||||
|
begin
|
||||||
|
while Pos <= Seq'Last loop
|
||||||
|
To_Unicode_Character(Seq(Pos .. Seq'Last), Seq_Len, Chr);
|
||||||
|
UL := UL + 1;
|
||||||
|
Pos := Pos + Seq_Len;
|
||||||
|
end loop;
|
||||||
|
end;
|
||||||
|
|
||||||
|
declare
|
||||||
|
Str: Unicode_String (1 .. UL);
|
||||||
|
Pos: System_Index := Seq'First;
|
||||||
|
Seq_Len: System_Length;
|
||||||
|
begin
|
||||||
|
for I in Str'Range loop
|
||||||
|
To_Unicode_Character(Seq(Pos .. Seq'Last), Seq_Len, Str(I));
|
||||||
|
Pos := Pos + Seq_Len;
|
||||||
|
end loop;
|
||||||
|
return Str;
|
||||||
|
end;
|
||||||
|
end To_Unicode_String;
|
||||||
|
|
||||||
end H2.Utf8;
|
end H2.Utf8;
|
||||||
|
@ -1,21 +1,49 @@
|
|||||||
generic
|
generic
|
||||||
type Utf8_Character_Type is (<>);
|
type Slim_Character is (<>);
|
||||||
type Unicode_Character_Type is (<>);
|
type Wide_Character is (<>);
|
||||||
|
type Slim_String is array(System_Index range<>) of Slim_Character;
|
||||||
|
type Wide_String is array(System_Index range<>) of Wide_Character;
|
||||||
package H2.Utf8 is
|
package H2.Utf8 is
|
||||||
pragma Preelaborate (Utf8);
|
pragma Preelaborate (Utf8);
|
||||||
|
|
||||||
Invalid_Unicode_Character: exception;
|
Invalid_Unicode_Character: exception;
|
||||||
|
Invalid_Utf8_Sequence: exception;
|
||||||
|
Insufficient_Utf8_Sequence: exception;
|
||||||
|
|
||||||
subtype Unicode_Character is Unicode_Character_Type;
|
subtype Utf8_Character is Slim_Character;
|
||||||
subtype Utf8_Character is Utf8_Character_Type;
|
subtype Unicode_Character is Wide_Character;
|
||||||
|
subtype Utf8_String is Slim_String;
|
||||||
|
subtype Unicode_String is Wide_String;
|
||||||
|
subtype Utf8_Sequence is Utf8_String;
|
||||||
|
|
||||||
type Utf8_String is array(System_Index range<>) of Utf8_Character;
|
--type Unicode_Character_Kit is record
|
||||||
type Unicode_String is array(System_Index range<>) of Unicode_Character;
|
-- Seq: System_Length; -- sequence length
|
||||||
|
-- Chr: Unicode_Character;
|
||||||
|
--end record;
|
||||||
|
|
||||||
function Unicode_To_Utf8 (UC: in Unicode_Character) return Utf8_String;
|
--type Unicode_String_Kit(Length: System_Length) is record
|
||||||
function Unicode_To_Utf8 (US: in Unicode_String) return Utf8_String;
|
-- Seq: System_Length;
|
||||||
|
-- Str: Unicode_String(System_Index'First .. Length);
|
||||||
|
--end record;
|
||||||
|
|
||||||
--procedure Utf8_To_Unicode (Utf8: in Utf8_String;
|
function From_Unicode_Character (Chr: in Unicode_Character) return Utf8_String;
|
||||||
-- UC: out Unicode_Character_Type);
|
function From_Unicode_String (Str: in Unicode_String) return Utf8_String;
|
||||||
|
|
||||||
|
--| The Sequence_Length function returns the length of a full UTF8
|
||||||
|
--| sequence representing a single Unicode character given the first
|
||||||
|
--| sequence byte. It returns 0 if the first byte is invalid.
|
||||||
|
function Sequence_Length (Seq: in Utf8_Character) return System_Length;
|
||||||
|
|
||||||
|
procedure To_Unicode_Character (Seq: in Utf8_String;
|
||||||
|
Seq_Len: out System_Length;
|
||||||
|
Chr: out Unicode_Character);
|
||||||
|
|
||||||
|
procedure To_Unicode_String (Seq: in Utf8_String;
|
||||||
|
Seq_Len: out System_Length;
|
||||||
|
Str: in out Unicode_String;
|
||||||
|
Str_Len: out System_Length);
|
||||||
|
|
||||||
|
function To_Unicode_Character (Seq: in Utf8_String) return Unicode_Character;
|
||||||
|
function To_Unicode_String (Seq: in Utf8_String) return Unicode_String;
|
||||||
|
|
||||||
end H2.Utf8;
|
end H2.Utf8;
|
||||||
|
@ -1,9 +1,21 @@
|
|||||||
with H2.Scheme;
|
with H2.Scheme;
|
||||||
with H2.Utf8;
|
with H2.Utf8;
|
||||||
|
with H2.Slim;
|
||||||
|
|
||||||
package H2.Wide is
|
package H2.Wide is
|
||||||
|
|
||||||
package Scheme is new H2.Scheme (Standard.Wide_Character);
|
subtype Character is Standard.Wide_Character;
|
||||||
package Utf8 is new H2.Utf8 (Standard.Character, Standard.Wide_Character);
|
type String is array(System_Index range<>) of Character;
|
||||||
|
|
||||||
|
package Scheme is new H2.Scheme (Standard.Wide_Character);
|
||||||
|
package Utf8 is new H2.Utf8 (H2.Slim.Character, Character, H2.Slim.String, H2.Wide.String);
|
||||||
|
|
||||||
|
--package Stream is new H2.IO (
|
||||||
|
-- Standard.Wide_Character,
|
||||||
|
-- Standard.Character,
|
||||||
|
-- H2.System.Open,
|
||||||
|
-- H2.System.Close,
|
||||||
|
-- H2.System.Read,
|
||||||
|
-- H2.System.Write
|
||||||
|
--);
|
||||||
end H2.Wide;
|
end H2.Wide;
|
||||||
|
12
lib/h2-wide_wide.ads
Normal file
12
lib/h2-wide_wide.ads
Normal file
@ -0,0 +1,12 @@
|
|||||||
|
with H2.Scheme;
|
||||||
|
with H2.Utf8;
|
||||||
|
with H2.Slim;
|
||||||
|
|
||||||
|
package H2.Wide_Wide is
|
||||||
|
|
||||||
|
type String is array(System_Index range<>) of Standard.Wide_Wide_Character;
|
||||||
|
|
||||||
|
package Scheme is new H2.Scheme (Standard.Wide_Wide_Character);
|
||||||
|
package Utf8 is new H2.Utf8 (Standard.Character, Standard.Wide_Wide_Character, H2.Slim.String, H2.Wide_Wide.String);
|
||||||
|
|
||||||
|
end H2.Wide_Wide;
|
13
lib/h2.ads
13
lib/h2.ads
@ -18,9 +18,22 @@ package H2 is
|
|||||||
--for System_Signed_Word'Size use System_Word_Bits;
|
--for System_Signed_Word'Size use System_Word_Bits;
|
||||||
|
|
||||||
type System_Size is new System_Word range 0 .. (2 ** System_Word_Bits) - 1;
|
type System_Size is new System_Word range 0 .. (2 ** System_Word_Bits) - 1;
|
||||||
|
subtype System_Length is System_Size;
|
||||||
subtype System_Index is System_Size range 1 .. System_Size'Last;
|
subtype System_Index is System_Size range 1 .. System_Size'Last;
|
||||||
|
|
||||||
type Storage_Pool_Pointer is
|
type Storage_Pool_Pointer is
|
||||||
access all System.Storage_Pools.Root_Storage_Pool'Class;
|
access all System.Storage_Pools.Root_Storage_Pool'Class;
|
||||||
|
|
||||||
|
|
||||||
|
-- TODO: move this to H2.XXXX???
|
||||||
|
type File_Record is tagged null record;
|
||||||
|
type File_Pointer is access all File_Record'Class;
|
||||||
|
|
||||||
|
type Flag_Record is record
|
||||||
|
x: integer;
|
||||||
|
end record;
|
||||||
|
|
||||||
|
type Mode_Record is record
|
||||||
|
x: integer;
|
||||||
|
end record;
|
||||||
end H2;
|
end H2;
|
||||||
|
81
lib/posix/h2-sysapi-file.adb
Normal file
81
lib/posix/h2-sysapi-file.adb
Normal file
@ -0,0 +1,81 @@
|
|||||||
|
with Interfaces.C;
|
||||||
|
with H2.Pool;
|
||||||
|
|
||||||
|
separate (H2.Sysapi)
|
||||||
|
|
||||||
|
package body File is
|
||||||
|
|
||||||
|
package C renames Interfaces.C;
|
||||||
|
use type C.int;
|
||||||
|
|
||||||
|
--function sys_open (path: ; flags: C.int; mode: C.int) return C.int;
|
||||||
|
function sys_open (path: Slim_String; flags: C.int; mode: C.int) return C.int;
|
||||||
|
pragma Import (C, sys_open, "open");
|
||||||
|
|
||||||
|
procedure sys_close (fd: C.int);
|
||||||
|
pragma Import (C, sys_close, "close");
|
||||||
|
|
||||||
|
type Posix_File_Record is new File_Record with record
|
||||||
|
Pool: Storage_Pool_Pointer := null;
|
||||||
|
Handle: C.int := Interfaces.C."-"(1);
|
||||||
|
end record;
|
||||||
|
type Posix_File_Pointer is access all Posix_File_Record;
|
||||||
|
|
||||||
|
function Flag_To_System (Flag: in Flag_Record) return C.int is
|
||||||
|
begin
|
||||||
|
return 0;
|
||||||
|
end Flag_To_System;
|
||||||
|
|
||||||
|
function Mode_To_System (Mode: in Mode_Record) return C.int is
|
||||||
|
begin
|
||||||
|
return 0;
|
||||||
|
end Mode_To_System;
|
||||||
|
|
||||||
|
procedure Open (File: out File_Pointer;
|
||||||
|
Name: in Slim_String;
|
||||||
|
Flag: in Flag_Record;
|
||||||
|
Mode: in Mode_Record;
|
||||||
|
Pool: in Storage_Pool_Pointer := null) is
|
||||||
|
|
||||||
|
package P is new H2.Pool (Posix_File_Record, Posix_File_Pointer, Pool);
|
||||||
|
F: Posix_File_Pointer;
|
||||||
|
|
||||||
|
begin
|
||||||
|
F := P.Allocate;
|
||||||
|
F.Pool := Pool;
|
||||||
|
|
||||||
|
--F.Handle := sys_open (Interfaces.C.char_array(Name & Slim.Character'Val(0)), 0, 0);
|
||||||
|
F.Handle := sys_open (Name, Flag_To_System(Flag), Mode_To_System(Mode));
|
||||||
|
if F.Handle <= -1 then
|
||||||
|
raise Constraint_Error; -- TODO: raise a proper exception.
|
||||||
|
end if;
|
||||||
|
|
||||||
|
File := File_Pointer(F);
|
||||||
|
end Open;
|
||||||
|
|
||||||
|
procedure Open (File: out File_Pointer;
|
||||||
|
Name: in Wide_String;
|
||||||
|
Flag: in Flag_Record;
|
||||||
|
Mode: in Mode_Record;
|
||||||
|
Pool: in Storage_Pool_Pointer := null) is
|
||||||
|
begin
|
||||||
|
Open (File, Wide_To_Slim(Name), Flag, Mode, Pool);
|
||||||
|
end Open;
|
||||||
|
|
||||||
|
procedure Close (File: in out File_Pointer) is
|
||||||
|
F: Posix_File_Pointer;
|
||||||
|
begin
|
||||||
|
F := Posix_File_Pointer(File);
|
||||||
|
sys_close (F.Handle);
|
||||||
|
F.Handle := Interfaces.C."-"(1);
|
||||||
|
|
||||||
|
declare
|
||||||
|
package P is new H2.Pool (Posix_File_Record, Posix_File_Pointer, F.Pool);
|
||||||
|
begin
|
||||||
|
P.Deallocate (F);
|
||||||
|
end;
|
||||||
|
|
||||||
|
File := null;
|
||||||
|
end Close;
|
||||||
|
|
||||||
|
end File;
|
Loading…
Reference in New Issue
Block a user