hyung-hwan/hcl
1
0
Fork 0
Code Issues Pull Requests Packages Projects Releases Wiki Activity

added an incomplete and experimental file package

Browse Source
This commit is contained in:
hyung-hwan 2014-05-30 03:15:40 +00:00
parent 8ef3eabe78
commit bf0477cfbf
12 changed files with 422 additions and 67 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

47
cmd/scheme.adb
View File

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

17
cmd/wide_stream.adb
View File

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

2
lib/h2-scheme.ads
View File

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

4
lib/h2-slim.ads
View File

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

5
lib/h2-sysapi.adb Normal file
View 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
View 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
View File

@ -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
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,14 +53,14 @@ 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
@ -51,25 +73,26 @@ package body H2.Utf8 is
for J in reverse Result'First + 1 .. Result'Last loop
-- 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;

48
lib/h2-utf8.ads
View File

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

16
lib/h2-wide.ads
View File

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

12
lib/h2-wide_wide.ads Normal file
View 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
View File

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

81
lib/posix/h2-sysapi-file.adb Normal file
View 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;