added an incomplete and experimental file package

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 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;
 	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);
 

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;
 

lib/h2-scheme.ads

@@ -35,8 +35,6 @@
 --
 ---------------------------------------------------------------------
 
-with System;
-with System.Storage_Pools;
 with Ada.Unchecked_Conversion;
 with H2.Ascii;
 

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;

lib/h2-sysapi.adb

@@ -0,0 +1,5 @@
+package body H2.Sysapi is
+
+	package body File is separate;
+
+end H2.Sysapi;

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;

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;	
+		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;
 
 	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_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);
 	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#);
+				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;
 
 			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 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
 		-- 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;
+	function Sequence_Length (Seq: in Utf8_Character) return System_Length is
-                                   UC:   out Unicode_Character) is
 	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
-		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;

lib/h2-utf8.ads

@@ -1,21 +1,49 @@
 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
 	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 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;

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);
+	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;

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;

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;

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;