reorganized h2

h2/bin/wide_stream.adb

@@ -0,0 +1,140 @@
+with H2.Pool;
+with Ada.Unchecked_Conversion;
+
+with Ada.Text_IO; -- for debugging
+with Ada.Exceptions;
+
+package body Wide_Stream is
+
+	package Utf8 renames H2.Wide.Utf8;
+	use type S.Object_Size;
+
+	------------------------------------------------------------------
+
+	procedure Open (Stream: in out String_Input_Stream_Record) is
+	begin
+Ada.Text_IO.Put_Line ("****** OPEN WIDE STRING STREAM ******");
+		Stream.Pos := 0;
+	end Open;
+
+	procedure Close (Stream: in out String_Input_Stream_Record) is
+	begin
+Ada.Text_IO.Put_Line ("****** CLOSE WIDE STRING STREAM ******");
+		Stream.Pos := Stream.Str'Last;
+	end Close;
+
+	procedure Read (Stream: in out String_Input_Stream_Record;
+	                Data:   out    S.Object_Character_Array;
+	                Last:   out    S.Object_Size) is
+		Avail: S.Object_Size;
+	begin
+		Avail := Stream.Str'Last - Stream.Pos;
+		if Avail <= 0 then
+			-- EOF
+			Last := Data'First - 1;
+		else
+			if Avail > Data'Length then
+				Avail := Data'Length;
+			end if;
+
+			Data(Data'First .. Avail) := Stream.Str(Stream.Pos + 1..Stream.Pos + Avail);
+			Stream.Pos := Stream.Pos + Avail;
+			Last := Data'First + Avail - 1;
+		end if;
+	end Read;
+
+	procedure Write (Stream: in out String_Input_Stream_Record;
+	                 Data:   out    S.Object_Character_Array;
+	                 Last:   out    S.Object_Size) is
+	begin
+		--raise S.Stream_Error;
+		Last := Data'First - 1;
+	end Write;
+
+	------------------------------------------------------------------
+
+	procedure Open (Stream: in out File_Stream_Record) is
+	begin
+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.From_Unicode_String(Utf8.Unicode_String(Stream.Name.all))));
+	end Open;
+
+	procedure Close (Stream: in out File_Stream_Record) is
+		subtype Wide_String is Standard.Wide_String(1 .. Standard.Natural(Stream.Name'Length));
+		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.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;
+
+	procedure Read (Stream: in out File_Stream_Record;
+	                Data:   out    S.Object_Character_Array;
+	                Last:   out    S.Object_Size) is
+	begin
+		for I in Data'First .. Data'Last loop
+			begin
+				if Ada.Wide_Text_IO.End_Of_File (Stream.Handle) then
+					Last := I - 1;
+					return;
+				end if;
+				Ada.Wide_Text_IO.Get_Immediate (Stream.Handle, Data(I));
+			exception
+				when Ada.Wide_Text_IO.End_Error =>
+					Last := I - 1;
+					return;
+				-- other exceptions must be just raised to indicate errors
+			end;
+		end loop;
+		Last := Data'Last;
+	end Read;
+
+	procedure Write (Stream: in out File_Stream_Record;
+	                 Data:   out    S.Object_Character_Array;
+	                 Last:   out    S.Object_Size) is
+	begin
+		--raise S.Stream_Error;
+		Last := Data'First - 1;
+	end Write;
+
+	------------------------------------------------------------------
+
+	procedure Allocate_Stream (Interp: in out S.Interpreter_Record;
+	                           Name:   access S.Object_Character_Array;
+	                           Result: out    S.Stream_Pointer) is
+		subtype FSR is File_Stream_Record;
+		type FSP is access all FSR;
+		package P is new H2.Pool (FSR, FSP);
+
+		X: FSP;
+		for X'Address use Result'Address;
+		pragma Import (Ada, X);
+	begin
+		X := P.Allocate (S.Get_Storage_Pool(Interp));
+		X.Name := S.Constant_Object_Character_Array_Pointer(Name);
+	end Allocate_Stream;
+
+	procedure Deallocate_Stream (Interp: in out S.Interpreter_Record;
+	                             Source: in out S.Stream_Pointer) is
+		subtype FSR is File_Stream_Record;
+		type FSP is access all FSR;
+		package P is new H2.Pool (FSR, FSP);
+
+		X: FSP;
+		for X'Address use Source'Address;
+		pragma Import (Ada, X);
+	begin
+		P.Deallocate (X, S.Get_Storage_Pool(Interp));
+	end Deallocate_Stream;
+end Wide_Stream;