From bf0477cfbf669e4722239d3dbc2d645c1ebbc015 Mon Sep 17 00:00:00 2001 From: hyung-hwan Date: Fri, 30 May 2014 03:15:40 +0000 Subject: [PATCH] added an incomplete and experimental file package --- cmd/scheme.adb | 47 +++++++-- cmd/wide_stream.adb | 17 ++- lib/h2-scheme.ads | 2 - lib/h2-slim.ads | 4 +- lib/h2-sysapi.adb | 5 + lib/h2-sysapi.ads | 49 +++++++++ lib/h2-utf8.adb | 195 +++++++++++++++++++++++++++-------- lib/h2-utf8.ads | 48 +++++++-- lib/h2-wide.ads | 16 ++- lib/h2-wide_wide.ads | 12 +++ lib/h2.ads | 13 +++ lib/posix/h2-sysapi-file.adb | 81 +++++++++++++++ 12 files changed, 422 insertions(+), 67 deletions(-) create mode 100644 lib/h2-sysapi.adb create mode 100644 lib/h2-sysapi.ads create mode 100644 lib/h2-wide_wide.ads create mode 100644 lib/posix/h2-sysapi-file.adb diff --git a/cmd/scheme.adb b/cmd/scheme.adb index 74c1a0f..755d10b 100644 --- a/cmd/scheme.adb +++ b/cmd/scheme.adb @@ -7,13 +7,15 @@ with Slim_Stream; with Wide_Stream; with Ada.Text_IO; with Ada.Unchecked_Deallocation; +with H2.Sysapi; + +with Interfaces.C; procedure scheme is - --package Stream renames Wide_Stream; - --package Scheme renames H2.Wide.Scheme; - - package Stream renames Slim_Stream; - package Scheme renames H2.Slim.Scheme; + package Stream renames Wide_Stream; + package Scheme renames H2.Wide.Scheme; + --package Stream renames Slim_Stream; + --package Scheme renames H2.Slim.Scheme; Pool: aliased Storage.Global_Pool; 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); --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 := (Name => File_Name'Unchecked_Access); File_Stream: Stream.File_Stream_Record; @@ -35,10 +37,41 @@ procedure scheme is --procedure h2init; --pragma Import (C, h2init, "h2init"); - begin --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, null); diff --git a/cmd/wide_stream.adb b/cmd/wide_stream.adb index 17d1616..ef343fa 100644 --- a/cmd/wide_stream.adb +++ b/cmd/wide_stream.adb @@ -2,6 +2,7 @@ with H2.Pool; with Ada.Unchecked_Conversion; with Ada.Text_IO; -- for debugging +with Ada.Exceptions; 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 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, 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; 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); begin --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); end Close; diff --git a/lib/h2-scheme.ads b/lib/h2-scheme.ads index 8b0b898..e5f36c6 100644 --- a/lib/h2-scheme.ads +++ b/lib/h2-scheme.ads @@ -35,8 +35,6 @@ -- --------------------------------------------------------------------- -with System; -with System.Storage_Pools; with Ada.Unchecked_Conversion; with H2.Ascii; diff --git a/lib/h2-slim.ads b/lib/h2-slim.ads index 4f21175..a94b2fc 100755 --- a/lib/h2-slim.ads +++ b/lib/h2-slim.ads @@ -2,6 +2,8 @@ with H2.Scheme; 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; diff --git a/lib/h2-sysapi.adb b/lib/h2-sysapi.adb new file mode 100644 index 0000000..8e9ca86 --- /dev/null +++ b/lib/h2-sysapi.adb @@ -0,0 +1,5 @@ +package body H2.Sysapi is + + package body File is separate; + +end H2.Sysapi; diff --git a/lib/h2-sysapi.ads b/lib/h2-sysapi.ads new file mode 100644 index 0000000..e74eeab --- /dev/null +++ b/lib/h2-sysapi.ads @@ -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; diff --git a/lib/h2-utf8.adb b/lib/h2-utf8.adb index 7419626..7fb8532 100644 --- a/lib/h2-utf8.adb +++ b/lib/h2-utf8.adb @@ -1,29 +1,51 @@ +with Interfaces; + 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 - Lower: Uint32; - Upper: Uint32; - Fbyte: Uint8; -- Mask to the first utf8 byte */ - Mask: Uint8; - Fmask: Uint8; - Length: Uint8; -- number of bytes + Lower: Uint32; + Upper: Uint32; + + Fbyte: Uint8; + Mask: Uint8; -- Mask for getting the fixed bits in the first byte. + -- (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; type Conv_Record_Array is array(System_Index range<>) of Conv_Record; Conv_Table: constant Conv_Record_Array := ( - (16#0000_0000#, 16#0000_007F#, 16#00#, 16#80#, 16#7F#, 1), - (16#0000_0080#, 16#0000_07FF#, 16#C0#, 16#E0#, 16#1F#, 2), - (16#0000_0800#, 16#0000_FFFF#, 16#E0#, 16#F0#, 16#0F#, 3), - (16#0001_0000#, 16#001F_FFFF#, 16#F0#, 16#F8#, 16#07#, 4), - (16#0020_0000#, 16#03FF_FFFF#, 16#F8#, 16#FC#, 16#03#, 5), - (16#0400_0000#, 16#7FFF_FFFF#, 16#FC#, 16#FE#, 16#01#, 6) + (16#0000_0000#, 16#0000_007F#, 2#0000_0000#, 2#1000_0000#, 2#0111_1111#, 1), + (16#0000_0080#, 16#0000_07FF#, 2#1100_0000#, 2#1110_0000#, 2#0001_1111#, 2), + (16#0000_0800#, 16#0000_FFFF#, 2#1110_0000#, 2#1111_0000#, 2#0000_1111#, 3), + (16#0001_0000#, 16#001F_FFFF#, 2#1111_0000#, 2#1111_1000#, 2#0000_0111#, 4), + (16#0020_0000#, 16#03FF_FFFF#, 2#1111_1000#, 2#1111_1100#, 2#0000_0011#, 5), + (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); begin for I in Conv_Table'Range loop @@ -31,45 +53,46 @@ package body H2.Utf8 is return I; end if; end loop; - return System_Size'First; + return System_Length'First; 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; - I: System_Size; + I: System_Length; begin - UV := Unicode_Character'Pos(UC); - + UV := Unicode_Character'Pos(Chr); + I := Get_Utf8_Slot(UV); if I not in System_Index'Range then raise Invalid_Unicode_Character; end if; - + declare Result: Utf8_String (1 .. System_Index(Conv_Table(I).Length)); begin 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# - Result(J) := Utf8_Character'Val((UV and 2#0011_1111#) or 2#1000_0000#); - UV := UV / (2 ** 6); --UV := UV >> 6; + Result(J) := Utf8_Character'Val((UV and Uint32'(2#0011_1111#)) or Uint32'(2#1000_0000#)); + --UV := UV / (2 ** 6); --UV := UV >> 6; + UV := Interfaces.Shift_Right (UV, 6); end loop; Result(Result'First) := Utf8_Character'Val(UV or Uint32(Conv_Table(I).Fbyte)); return Result; end; - end Unicode_To_Utf8; + end From_Unicode_Character; - - function Unicode_To_Utf8 (US: in Unicode_String) return Utf8_String is + function From_Unicode_String (Str: in Unicode_String) return Utf8_String is -- this function has high stack pressure if the input string is too long -- TODO: create a procedure to overcome this problem. - Tmp: System_Size; + Tmp: System_Length; begin + -- Calculate the length first Tmp := 0; - for I in US'Range loop + for I in Str'Range loop declare - Utf8: Utf8_String := Unicode_To_Utf8(US(I)); + Utf8: Utf8_String := From_Unicode_Character(Chr => Str(I)); begin Tmp := Tmp + Utf8'Length; end; @@ -79,9 +102,9 @@ package body H2.Utf8 is Result: Utf8_String (1 .. Tmp); begin Tmp := Result'First; - for I in US'Range loop + for I in Str'Range loop declare - Utf8: Utf8_String := Unicode_To_Utf8(US(I)); + Utf8: Utf8_String := From_Unicode_Character(Str(I)); begin Result(Tmp .. Tmp + Utf8'Length - 1) := Utf8; Tmp := Tmp + Utf8'Length; @@ -89,18 +112,106 @@ package body H2.Utf8 is end loop; return Result; end; - end Unicode_To_Utf8; + end From_Unicode_String; - procedure Utf8_To_Unicode (Utf8: in Utf8_String; - UC: out Unicode_Character) is + function Sequence_Length (Seq: in Utf8_Character) return System_Length is begin - null; - end Utf8_To_Unicode; + for I in Conv_Table'Range loop + 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; - US: in out Unicode_String) is + procedure To_Unicode_Character (Seq: in Utf8_String; + Seq_Len: out System_Length; + Chr: out Unicode_Character) is + W: Uint32; begin - null; - end Utf8_To_Unicode; + for I in Conv_Table'Range loop + + -- 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; diff --git a/lib/h2-utf8.ads b/lib/h2-utf8.ads index 084d674..2a44273 100644 --- a/lib/h2-utf8.ads +++ b/lib/h2-utf8.ads @@ -1,21 +1,49 @@ generic - type Utf8_Character_Type is (<>); - type Unicode_Character_Type is (<>); + 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; package H2.Utf8 is pragma Preelaborate (Utf8); Invalid_Unicode_Character: exception; + Invalid_Utf8_Sequence: exception; + Insufficient_Utf8_Sequence: exception; - subtype Unicode_Character is Unicode_Character_Type; - subtype Utf8_Character is Utf8_Character_Type; + subtype Utf8_Character is Slim_Character; + 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_String is array(System_Index range<>) of Unicode_Character; + --type Unicode_Character_Kit is record + -- Seq: System_Length; -- sequence length + -- Chr: Unicode_Character; + --end record; - function Unicode_To_Utf8 (UC: in Unicode_Character) return Utf8_String; - function Unicode_To_Utf8 (US: in Unicode_String) return Utf8_String; + --type Unicode_String_Kit(Length: System_Length) is record + -- Seq: System_Length; + -- Str: Unicode_String(System_Index'First .. Length); + --end record; - --procedure Utf8_To_Unicode (Utf8: in Utf8_String; - -- UC: out Unicode_Character_Type); + function From_Unicode_Character (Chr: in Unicode_Character) return Utf8_String; + 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; diff --git a/lib/h2-wide.ads b/lib/h2-wide.ads index 5f815c0..c7a1754 100644 --- a/lib/h2-wide.ads +++ b/lib/h2-wide.ads @@ -1,9 +1,21 @@ with H2.Scheme; with H2.Utf8; +with H2.Slim; package H2.Wide is - package Scheme is new H2.Scheme (Standard.Wide_Character); - package Utf8 is new H2.Utf8 (Standard.Character, Standard.Wide_Character); + subtype Character is 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; diff --git a/lib/h2-wide_wide.ads b/lib/h2-wide_wide.ads new file mode 100644 index 0000000..ebf0de5 --- /dev/null +++ b/lib/h2-wide_wide.ads @@ -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; diff --git a/lib/h2.ads b/lib/h2.ads index a76b6bb..fc44b91 100644 --- a/lib/h2.ads +++ b/lib/h2.ads @@ -18,9 +18,22 @@ package H2 is --for System_Signed_Word'Size use System_Word_Bits; 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; type Storage_Pool_Pointer is 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; diff --git a/lib/posix/h2-sysapi-file.adb b/lib/posix/h2-sysapi-file.adb new file mode 100644 index 0000000..cb97142 --- /dev/null +++ b/lib/posix/h2-sysapi-file.adb @@ -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;