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

improved h2-io-file a bit

Browse Source
This commit is contained in:
hyung-hwan 2014-06-21 16:31:49 +00:00
parent 710109bc28
commit 91cd073f8b
16 changed files with 750 additions and 367 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

26
cmd/scheme.adb
View File

@ -33,8 +33,8 @@ procedure scheme is
String_Stream: Stream.String_Input_Stream_Record (String'Unchecked_Access); String_Stream: Stream.String_Input_Stream_Record (String'Unchecked_Access);
--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 Scheme.Object_Character_Array := "test.adb";
File_Name: aliased constant Scheme.Object_Character_Array := "시험.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;
@ -107,33 +107,41 @@ ada.text_io.put_line ("------------------");
File.Set_Flag_Bits (FL, File.FLAG_NONBLOCK); File.Set_Flag_Bits (FL, File.FLAG_NONBLOCK);
File.Open (F, H2.Slim.String'("/tmp/xxx"), FL); File.Open (F, H2.Slim.String'("/tmp/xxx"), FL);
--Option := File.Get_Option(F2);
File.Clear_Flag_Bits (FL, FL.Bits); File.Clear_Flag_Bits (FL, FL.Bits);
File.Set_Flag_Bits (FL, File.FLAG_WRITE); File.Set_Flag_Bits (FL, File.FLAG_WRITE);
File.Set_Flag_Bits (FL, File.FLAG_CREATE); File.Set_Flag_Bits (FL, File.FLAG_CREATE);
File.Set_Flag_Bits (FL, File.FLAG_TRUNCATE); File.Set_Flag_Bits (FL, File.FLAG_TRUNCATE);
File.Open (F2, H2.Wide.String'("/tmp/yyy"), FL); File.Open (F2, H2.Wide.String'("/tmp/yyy"), FL);
File.Set_Option_Bits (Option, File.Option_CRLF);
File.Set_Option_Bits (Option, File.Option_CRLF_IN);
--File.Set_Option_Bits (Option, File.Option_CRLF_OUT);
--Option.LF := IO.Ascii.Code.Colon;
File.Set_Option (F2, Option); File.Set_Option (F2, Option);
File.Set_Option (F, Option);
loop loop
File.Get_Line (F, Buffer, IL); --File.Get_Line (F, Buffer, IL);
File.Get_Line (F, BufferW, IL);
--ada.text_io.put_line (standard.string(buffer(1..il)));
--ada.wide_text_io.put_line (standard.wide_string(bufferw(1..il))); --ada.wide_text_io.put_line (standard.wide_string(bufferw(1..il)));
--File.Read (F, BufferW, IL); --File.Read (F, BufferW, IL);
exit when IL <= 0; exit when IL <= 0;
File.Put_Line (F2, Buffer(Buffer'First .. Buffer'First + IL - 1), OL); --File.Put_Line (F2, Buffer(Buffer'First .. Buffer'First + IL - 1), OL);
File.Put_Line (F2, BufferW(Buffer'First .. Buffer'First + IL - 1), OL);
pragma Assert (IL = OL); pragma Assert (IL = OL);
--Ada.Text_IO.PUt (Standard.String(Buffer(Buffer'First .. Buffer'First + IL - 1))); --Ada.Text_IO.PUt (Standard.String(Buffer(Buffer'First .. Buffer'First + IL - 1)));
--Ada.Wide_Text_IO.Put_Line (Standard.Wide_String(BufferW(BufferW'First .. BufferW'First + IL - 1))); --Ada.Wide_Text_IO.Put_Line (Standard.Wide_String(BufferW(BufferW'First .. BufferW'First + IL - 1)));
end loop; end loop;
File.Write (F2, H2.Wide.String'("나는 피리부는 사나이 정말로 멋있는 사나이"), OL); --File.Write (F2, H2.Wide.String'("나는 피리부는 사나이 정말로 멋있는 사나이"), OL);
File.Write_Line (F2, H2.Wide.String'("이세상에 문디없어면 무슨재미로 너도 나도 만세."), OL); --File.Write_Line (F2, H2.Wide.String'("이세상에 문디없어면 무슨재미로 너도 나도 만세."), OL);
File.Write_Line (F2, H2.Wide.String'("이세상에 for the first time 우하."), OL); --File.Write_Line (F2, H2.Wide.String'("이세상에 for the first time 우하."), OL);
File.Write_Line (F2, H2.Wide.String'(""), OL); --File.Write_Line (F2, H2.Wide.String'(""), OL);
File.Close (F2); File.Close (F2);
File.Close (F); File.Close (F);

26
lib/ascii.awk
View File

@ -3,9 +3,12 @@
BEGIN { BEGIN {
printf ("-- Generated with ascii.txt and ascii.awk\n"); printf ("-- Generated with ascii.txt and ascii.awk\n");
printf ("-- Run qseawk -f ascii.awk ascii.txt > h2-ascii.ads for regeneration\n\n"); printf ("-- Run qseawk -f ascii.awk ascii.txt > h2-ascii.ads for regeneration\n\n");
printf ("generic\n\ttype Character_Type is (<>);\npackage H2.Ascii is\n\n"); printf ("generic\n");
printf ("\tpragma Preelaborate (Ascii);\n\n"); printf ("\ttype Slim_Character is (<>);\n");
printf ("\tpackage Pos is\n"); printf ("\ttype Wide_Character is (<>);\n");
printf ("package H2.Ascii is\n\n");
#printf ("\tpragma Preelaborate (Ascii);\n\n");
printf ("\tpackage Code is\n");
} }
{ {
@ -17,10 +20,23 @@ BEGIN {
} }
END { END {
printf ("\tend Pos;\n\n"); printf ("\tend Code;\n\n");
printf ("\tpackage Slim is\n");
for (i = 0; i < length(X); i++) for (i = 0; i < length(X); i++)
{ {
printf ("\t%-20s: constant Character_Type := Character_Type'Val(Pos.%s);\n", X[i], X[i]); printf ("\t\t%-20s: constant Slim_Character := Slim_Character'Val(Code.%s);\n", X[i], X[i]);
} }
printf ("\tend Slim;\n");
printf ("\n");
printf ("\tpackage Wide is\n");
for (i = 0; i < length(X); i++)
{
printf ("\t\t%-20s: constant Wide_Character := Wide_Character'Val(Code.%s);\n", X[i], X[i]);
}
printf ("\tend Wide;\n");
printf ("\nend H2.Ascii;\n"); printf ("\nend H2.Ascii;\n");
} }

398
lib/h2-ascii.ads
View File

@ -2,12 +2,11 @@
-- Run qseawk -f ascii.awk ascii.txt > h2-ascii.ads for regeneration -- Run qseawk -f ascii.awk ascii.txt > h2-ascii.ads for regeneration
generic generic
type Character_Type is (<>); type Slim_Character is (<>);
type Wide_Character is (<>);
package H2.Ascii is package H2.Ascii is
--pragma Preelaborate (Ascii); package Code is
package Pos is
NUL : constant := 0; NUL : constant := 0;
SOH : constant := 1; SOH : constant := 1;
STX : constant := 2; STX : constant := 2;
@ -136,135 +135,268 @@ package H2.Ascii is
Right_Curly_Bracket : constant := 125; -- } Right_Curly_Bracket : constant := 125; -- }
Tilde : constant := 126; -- ~ Tilde : constant := 126; -- ~
DEL : constant := 127; DEL : constant := 127;
end Pos; end Code;
NUL : constant Character_Type := Character_Type'Val(Pos.NUL); package Slim is
SOH : constant Character_Type := Character_Type'Val(Pos.SOH); NUL : constant Slim_Character := Slim_Character'Val(Code.NUL);
STX : constant Character_Type := Character_Type'Val(Pos.STX); SOH : constant Slim_Character := Slim_Character'Val(Code.SOH);
ETX : constant Character_Type := Character_Type'Val(Pos.ETX); STX : constant Slim_Character := Slim_Character'Val(Code.STX);
EOT : constant Character_Type := Character_Type'Val(Pos.EOT); ETX : constant Slim_Character := Slim_Character'Val(Code.ETX);
ENQ : constant Character_Type := Character_Type'Val(Pos.ENQ); EOT : constant Slim_Character := Slim_Character'Val(Code.EOT);
ACK : constant Character_Type := Character_Type'Val(Pos.ACK); ENQ : constant Slim_Character := Slim_Character'Val(Code.ENQ);
BEL : constant Character_Type := Character_Type'Val(Pos.BEL); ACK : constant Slim_Character := Slim_Character'Val(Code.ACK);
BS : constant Character_Type := Character_Type'Val(Pos.BS); BEL : constant Slim_Character := Slim_Character'Val(Code.BEL);
HT : constant Character_Type := Character_Type'Val(Pos.HT); BS : constant Slim_Character := Slim_Character'Val(Code.BS);
LF : constant Character_Type := Character_Type'Val(Pos.LF); HT : constant Slim_Character := Slim_Character'Val(Code.HT);
VT : constant Character_Type := Character_Type'Val(Pos.VT); LF : constant Slim_Character := Slim_Character'Val(Code.LF);
FF : constant Character_Type := Character_Type'Val(Pos.FF); VT : constant Slim_Character := Slim_Character'Val(Code.VT);
CR : constant Character_Type := Character_Type'Val(Pos.CR); FF : constant Slim_Character := Slim_Character'Val(Code.FF);
SO : constant Character_Type := Character_Type'Val(Pos.SO); CR : constant Slim_Character := Slim_Character'Val(Code.CR);
SI : constant Character_Type := Character_Type'Val(Pos.SI); SO : constant Slim_Character := Slim_Character'Val(Code.SO);
DLE : constant Character_Type := Character_Type'Val(Pos.DLE); SI : constant Slim_Character := Slim_Character'Val(Code.SI);
DC1 : constant Character_Type := Character_Type'Val(Pos.DC1); DLE : constant Slim_Character := Slim_Character'Val(Code.DLE);
DC2 : constant Character_Type := Character_Type'Val(Pos.DC2); DC1 : constant Slim_Character := Slim_Character'Val(Code.DC1);
DC3 : constant Character_Type := Character_Type'Val(Pos.DC3); DC2 : constant Slim_Character := Slim_Character'Val(Code.DC2);
DC4 : constant Character_Type := Character_Type'Val(Pos.DC4); DC3 : constant Slim_Character := Slim_Character'Val(Code.DC3);
NAK : constant Character_Type := Character_Type'Val(Pos.NAK); DC4 : constant Slim_Character := Slim_Character'Val(Code.DC4);
SYN : constant Character_Type := Character_Type'Val(Pos.SYN); NAK : constant Slim_Character := Slim_Character'Val(Code.NAK);
ETB : constant Character_Type := Character_Type'Val(Pos.ETB); SYN : constant Slim_Character := Slim_Character'Val(Code.SYN);
CAN : constant Character_Type := Character_Type'Val(Pos.CAN); ETB : constant Slim_Character := Slim_Character'Val(Code.ETB);
EM : constant Character_Type := Character_Type'Val(Pos.EM); CAN : constant Slim_Character := Slim_Character'Val(Code.CAN);
SUB : constant Character_Type := Character_Type'Val(Pos.SUB); EM : constant Slim_Character := Slim_Character'Val(Code.EM);
ESC : constant Character_Type := Character_Type'Val(Pos.ESC); SUB : constant Slim_Character := Slim_Character'Val(Code.SUB);
FS : constant Character_Type := Character_Type'Val(Pos.FS); ESC : constant Slim_Character := Slim_Character'Val(Code.ESC);
GS : constant Character_Type := Character_Type'Val(Pos.GS); FS : constant Slim_Character := Slim_Character'Val(Code.FS);
RS : constant Character_Type := Character_Type'Val(Pos.RS); GS : constant Slim_Character := Slim_Character'Val(Code.GS);
US : constant Character_Type := Character_Type'Val(Pos.US); RS : constant Slim_Character := Slim_Character'Val(Code.RS);
Space : constant Character_Type := Character_Type'Val(Pos.Space); US : constant Slim_Character := Slim_Character'Val(Code.US);
Exclamation : constant Character_Type := Character_Type'Val(Pos.Exclamation); Space : constant Slim_Character := Slim_Character'Val(Code.Space);
Quotation : constant Character_Type := Character_Type'Val(Pos.Quotation); Exclamation : constant Slim_Character := Slim_Character'Val(Code.Exclamation);
Number_Sign : constant Character_Type := Character_Type'Val(Pos.Number_Sign); Quotation : constant Slim_Character := Slim_Character'Val(Code.Quotation);
Dollar_Sign : constant Character_Type := Character_Type'Val(Pos.Dollar_Sign); Number_Sign : constant Slim_Character := Slim_Character'Val(Code.Number_Sign);
Percent_Sign : constant Character_Type := Character_Type'Val(Pos.Percent_Sign); Dollar_Sign : constant Slim_Character := Slim_Character'Val(Code.Dollar_Sign);
Ampersand : constant Character_Type := Character_Type'Val(Pos.Ampersand); Percent_Sign : constant Slim_Character := Slim_Character'Val(Code.Percent_Sign);
Apostrophe : constant Character_Type := Character_Type'Val(Pos.Apostrophe); Ampersand : constant Slim_Character := Slim_Character'Val(Code.Ampersand);
Left_Parenthesis : constant Character_Type := Character_Type'Val(Pos.Left_Parenthesis); Apostrophe : constant Slim_Character := Slim_Character'Val(Code.Apostrophe);
Right_Parenthesis : constant Character_Type := Character_Type'Val(Pos.Right_Parenthesis); Left_Parenthesis : constant Slim_Character := Slim_Character'Val(Code.Left_Parenthesis);
Asterisk : constant Character_Type := Character_Type'Val(Pos.Asterisk); Right_Parenthesis : constant Slim_Character := Slim_Character'Val(Code.Right_Parenthesis);
Plus_Sign : constant Character_Type := Character_Type'Val(Pos.Plus_Sign); Asterisk : constant Slim_Character := Slim_Character'Val(Code.Asterisk);
Comma : constant Character_Type := Character_Type'Val(Pos.Comma); Plus_Sign : constant Slim_Character := Slim_Character'Val(Code.Plus_Sign);
Minus_Sign : constant Character_Type := Character_Type'Val(Pos.Minus_Sign); Comma : constant Slim_Character := Slim_Character'Val(Code.Comma);
Period : constant Character_Type := Character_Type'Val(Pos.Period); Minus_Sign : constant Slim_Character := Slim_Character'Val(Code.Minus_Sign);
Slash : constant Character_Type := Character_Type'Val(Pos.Slash); Period : constant Slim_Character := Slim_Character'Val(Code.Period);
Zero : constant Character_Type := Character_Type'Val(Pos.Zero); Slash : constant Slim_Character := Slim_Character'Val(Code.Slash);
One : constant Character_Type := Character_Type'Val(Pos.One); Zero : constant Slim_Character := Slim_Character'Val(Code.Zero);
Two : constant Character_Type := Character_Type'Val(Pos.Two); One : constant Slim_Character := Slim_Character'Val(Code.One);
Three : constant Character_Type := Character_Type'Val(Pos.Three); Two : constant Slim_Character := Slim_Character'Val(Code.Two);
Four : constant Character_Type := Character_Type'Val(Pos.Four); Three : constant Slim_Character := Slim_Character'Val(Code.Three);
Five : constant Character_Type := Character_Type'Val(Pos.Five); Four : constant Slim_Character := Slim_Character'Val(Code.Four);
Six : constant Character_Type := Character_Type'Val(Pos.Six); Five : constant Slim_Character := Slim_Character'Val(Code.Five);
Seven : constant Character_Type := Character_Type'Val(Pos.Seven); Six : constant Slim_Character := Slim_Character'Val(Code.Six);
Eight : constant Character_Type := Character_Type'Val(Pos.Eight); Seven : constant Slim_Character := Slim_Character'Val(Code.Seven);
Nine : constant Character_Type := Character_Type'Val(Pos.Nine); Eight : constant Slim_Character := Slim_Character'Val(Code.Eight);
Colon : constant Character_Type := Character_Type'Val(Pos.Colon); Nine : constant Slim_Character := Slim_Character'Val(Code.Nine);
Semicolon : constant Character_Type := Character_Type'Val(Pos.Semicolon); Colon : constant Slim_Character := Slim_Character'Val(Code.Colon);
Less_Than_Sign : constant Character_Type := Character_Type'Val(Pos.Less_Than_Sign); Semicolon : constant Slim_Character := Slim_Character'Val(Code.Semicolon);
Equal_Sign : constant Character_Type := Character_Type'Val(Pos.Equal_Sign); Less_Than_Sign : constant Slim_Character := Slim_Character'Val(Code.Less_Than_Sign);
Greater_Than_Sign : constant Character_Type := Character_Type'Val(Pos.Greater_Than_Sign); Equal_Sign : constant Slim_Character := Slim_Character'Val(Code.Equal_Sign);
Question : constant Character_Type := Character_Type'Val(Pos.Question); Greater_Than_Sign : constant Slim_Character := Slim_Character'Val(Code.Greater_Than_Sign);
Commercial_At : constant Character_Type := Character_Type'Val(Pos.Commercial_At); Question : constant Slim_Character := Slim_Character'Val(Code.Question);
UC_A : constant Character_Type := Character_Type'Val(Pos.UC_A); Commercial_At : constant Slim_Character := Slim_Character'Val(Code.Commercial_At);
UC_B : constant Character_Type := Character_Type'Val(Pos.UC_B); UC_A : constant Slim_Character := Slim_Character'Val(Code.UC_A);
UC_C : constant Character_Type := Character_Type'Val(Pos.UC_C); UC_B : constant Slim_Character := Slim_Character'Val(Code.UC_B);
UC_D : constant Character_Type := Character_Type'Val(Pos.UC_D); UC_C : constant Slim_Character := Slim_Character'Val(Code.UC_C);
UC_E : constant Character_Type := Character_Type'Val(Pos.UC_E); UC_D : constant Slim_Character := Slim_Character'Val(Code.UC_D);
UC_F : constant Character_Type := Character_Type'Val(Pos.UC_F); UC_E : constant Slim_Character := Slim_Character'Val(Code.UC_E);
UC_G : constant Character_Type := Character_Type'Val(Pos.UC_G); UC_F : constant Slim_Character := Slim_Character'Val(Code.UC_F);
UC_H : constant Character_Type := Character_Type'Val(Pos.UC_H); UC_G : constant Slim_Character := Slim_Character'Val(Code.UC_G);
UC_I : constant Character_Type := Character_Type'Val(Pos.UC_I); UC_H : constant Slim_Character := Slim_Character'Val(Code.UC_H);
UC_J : constant Character_Type := Character_Type'Val(Pos.UC_J); UC_I : constant Slim_Character := Slim_Character'Val(Code.UC_I);
UC_K : constant Character_Type := Character_Type'Val(Pos.UC_K); UC_J : constant Slim_Character := Slim_Character'Val(Code.UC_J);
UC_L : constant Character_Type := Character_Type'Val(Pos.UC_L); UC_K : constant Slim_Character := Slim_Character'Val(Code.UC_K);
UC_M : constant Character_Type := Character_Type'Val(Pos.UC_M); UC_L : constant Slim_Character := Slim_Character'Val(Code.UC_L);
UC_N : constant Character_Type := Character_Type'Val(Pos.UC_N); UC_M : constant Slim_Character := Slim_Character'Val(Code.UC_M);
UC_O : constant Character_Type := Character_Type'Val(Pos.UC_O); UC_N : constant Slim_Character := Slim_Character'Val(Code.UC_N);
UC_P : constant Character_Type := Character_Type'Val(Pos.UC_P); UC_O : constant Slim_Character := Slim_Character'Val(Code.UC_O);
UC_Q : constant Character_Type := Character_Type'Val(Pos.UC_Q); UC_P : constant Slim_Character := Slim_Character'Val(Code.UC_P);
UC_R : constant Character_Type := Character_Type'Val(Pos.UC_R); UC_Q : constant Slim_Character := Slim_Character'Val(Code.UC_Q);
UC_S : constant Character_Type := Character_Type'Val(Pos.UC_S); UC_R : constant Slim_Character := Slim_Character'Val(Code.UC_R);
UC_T : constant Character_Type := Character_Type'Val(Pos.UC_T); UC_S : constant Slim_Character := Slim_Character'Val(Code.UC_S);
UC_U : constant Character_Type := Character_Type'Val(Pos.UC_U); UC_T : constant Slim_Character := Slim_Character'Val(Code.UC_T);
UC_V : constant Character_Type := Character_Type'Val(Pos.UC_V); UC_U : constant Slim_Character := Slim_Character'Val(Code.UC_U);
UC_W : constant Character_Type := Character_Type'Val(Pos.UC_W); UC_V : constant Slim_Character := Slim_Character'Val(Code.UC_V);
UC_X : constant Character_Type := Character_Type'Val(Pos.UC_X); UC_W : constant Slim_Character := Slim_Character'Val(Code.UC_W);
UC_Y : constant Character_Type := Character_Type'Val(Pos.UC_Y); UC_X : constant Slim_Character := Slim_Character'Val(Code.UC_X);
UC_Z : constant Character_Type := Character_Type'Val(Pos.UC_Z); UC_Y : constant Slim_Character := Slim_Character'Val(Code.UC_Y);
Left_Square_Bracket : constant Character_Type := Character_Type'Val(Pos.Left_Square_Bracket); UC_Z : constant Slim_Character := Slim_Character'Val(Code.UC_Z);
Backslash : constant Character_Type := Character_Type'Val(Pos.Backslash); Left_Square_Bracket : constant Slim_Character := Slim_Character'Val(Code.Left_Square_Bracket);
Right_Square_Bracket: constant Character_Type := Character_Type'Val(Pos.Right_Square_Bracket); Backslash : constant Slim_Character := Slim_Character'Val(Code.Backslash);
Circumflex : constant Character_Type := Character_Type'Val(Pos.Circumflex); Right_Square_Bracket: constant Slim_Character := Slim_Character'Val(Code.Right_Square_Bracket);
Low_Line : constant Character_Type := Character_Type'Val(Pos.Low_Line); Circumflex : constant Slim_Character := Slim_Character'Val(Code.Circumflex);
Grave : constant Character_Type := Character_Type'Val(Pos.Grave); Low_Line : constant Slim_Character := Slim_Character'Val(Code.Low_Line);
LC_A : constant Character_Type := Character_Type'Val(Pos.LC_A); Grave : constant Slim_Character := Slim_Character'Val(Code.Grave);
LC_B : constant Character_Type := Character_Type'Val(Pos.LC_B); LC_A : constant Slim_Character := Slim_Character'Val(Code.LC_A);
LC_C : constant Character_Type := Character_Type'Val(Pos.LC_C); LC_B : constant Slim_Character := Slim_Character'Val(Code.LC_B);
LC_D : constant Character_Type := Character_Type'Val(Pos.LC_D); LC_C : constant Slim_Character := Slim_Character'Val(Code.LC_C);
LC_E : constant Character_Type := Character_Type'Val(Pos.LC_E); LC_D : constant Slim_Character := Slim_Character'Val(Code.LC_D);
LC_F : constant Character_Type := Character_Type'Val(Pos.LC_F); LC_E : constant Slim_Character := Slim_Character'Val(Code.LC_E);
LC_G : constant Character_Type := Character_Type'Val(Pos.LC_G); LC_F : constant Slim_Character := Slim_Character'Val(Code.LC_F);
LC_H : constant Character_Type := Character_Type'Val(Pos.LC_H); LC_G : constant Slim_Character := Slim_Character'Val(Code.LC_G);
LC_I : constant Character_Type := Character_Type'Val(Pos.LC_I); LC_H : constant Slim_Character := Slim_Character'Val(Code.LC_H);
LC_J : constant Character_Type := Character_Type'Val(Pos.LC_J); LC_I : constant Slim_Character := Slim_Character'Val(Code.LC_I);
LC_K : constant Character_Type := Character_Type'Val(Pos.LC_K); LC_J : constant Slim_Character := Slim_Character'Val(Code.LC_J);
LC_L : constant Character_Type := Character_Type'Val(Pos.LC_L); LC_K : constant Slim_Character := Slim_Character'Val(Code.LC_K);
LC_M : constant Character_Type := Character_Type'Val(Pos.LC_M); LC_L : constant Slim_Character := Slim_Character'Val(Code.LC_L);
LC_N : constant Character_Type := Character_Type'Val(Pos.LC_N); LC_M : constant Slim_Character := Slim_Character'Val(Code.LC_M);
LC_O : constant Character_Type := Character_Type'Val(Pos.LC_O); LC_N : constant Slim_Character := Slim_Character'Val(Code.LC_N);
LC_P : constant Character_Type := Character_Type'Val(Pos.LC_P); LC_O : constant Slim_Character := Slim_Character'Val(Code.LC_O);
LC_Q : constant Character_Type := Character_Type'Val(Pos.LC_Q); LC_P : constant Slim_Character := Slim_Character'Val(Code.LC_P);
LC_R : constant Character_Type := Character_Type'Val(Pos.LC_R); LC_Q : constant Slim_Character := Slim_Character'Val(Code.LC_Q);
LC_S : constant Character_Type := Character_Type'Val(Pos.LC_S); LC_R : constant Slim_Character := Slim_Character'Val(Code.LC_R);
LC_T : constant Character_Type := Character_Type'Val(Pos.LC_T); LC_S : constant Slim_Character := Slim_Character'Val(Code.LC_S);
LC_U : constant Character_Type := Character_Type'Val(Pos.LC_U); LC_T : constant Slim_Character := Slim_Character'Val(Code.LC_T);
LC_V : constant Character_Type := Character_Type'Val(Pos.LC_V); LC_U : constant Slim_Character := Slim_Character'Val(Code.LC_U);
LC_W : constant Character_Type := Character_Type'Val(Pos.LC_W); LC_V : constant Slim_Character := Slim_Character'Val(Code.LC_V);
LC_X : constant Character_Type := Character_Type'Val(Pos.LC_X); LC_W : constant Slim_Character := Slim_Character'Val(Code.LC_W);
LC_Y : constant Character_Type := Character_Type'Val(Pos.LC_Y); LC_X : constant Slim_Character := Slim_Character'Val(Code.LC_X);
LC_Z : constant Character_Type := Character_Type'Val(Pos.LC_Z); LC_Y : constant Slim_Character := Slim_Character'Val(Code.LC_Y);
Left_Curly_Bracket : constant Character_Type := Character_Type'Val(Pos.Left_Curly_Bracket); LC_Z : constant Slim_Character := Slim_Character'Val(Code.LC_Z);
Vertical_Line : constant Character_Type := Character_Type'Val(Pos.Vertical_Line); Left_Curly_Bracket : constant Slim_Character := Slim_Character'Val(Code.Left_Curly_Bracket);
Right_Curly_Bracket : constant Character_Type := Character_Type'Val(Pos.Right_Curly_Bracket); Vertical_Line : constant Slim_Character := Slim_Character'Val(Code.Vertical_Line);
Tilde : constant Character_Type := Character_Type'Val(Pos.Tilde); Right_Curly_Bracket : constant Slim_Character := Slim_Character'Val(Code.Right_Curly_Bracket);
DEL : constant Character_Type := Character_Type'Val(Pos.DEL); Tilde : constant Slim_Character := Slim_Character'Val(Code.Tilde);
DEL : constant Slim_Character := Slim_Character'Val(Code.DEL);
end Slim;
package Wide is
NUL : constant Wide_Character := Wide_Character'Val(Code.NUL);
SOH : constant Wide_Character := Wide_Character'Val(Code.SOH);
STX : constant Wide_Character := Wide_Character'Val(Code.STX);
ETX : constant Wide_Character := Wide_Character'Val(Code.ETX);
EOT : constant Wide_Character := Wide_Character'Val(Code.EOT);
ENQ : constant Wide_Character := Wide_Character'Val(Code.ENQ);
ACK : constant Wide_Character := Wide_Character'Val(Code.ACK);
BEL : constant Wide_Character := Wide_Character'Val(Code.BEL);
BS : constant Wide_Character := Wide_Character'Val(Code.BS);
HT : constant Wide_Character := Wide_Character'Val(Code.HT);
LF : constant Wide_Character := Wide_Character'Val(Code.LF);
VT : constant Wide_Character := Wide_Character'Val(Code.VT);
FF : constant Wide_Character := Wide_Character'Val(Code.FF);
CR : constant Wide_Character := Wide_Character'Val(Code.CR);
SO : constant Wide_Character := Wide_Character'Val(Code.SO);
SI : constant Wide_Character := Wide_Character'Val(Code.SI);
DLE : constant Wide_Character := Wide_Character'Val(Code.DLE);
DC1 : constant Wide_Character := Wide_Character'Val(Code.DC1);
DC2 : constant Wide_Character := Wide_Character'Val(Code.DC2);
DC3 : constant Wide_Character := Wide_Character'Val(Code.DC3);
DC4 : constant Wide_Character := Wide_Character'Val(Code.DC4);
NAK : constant Wide_Character := Wide_Character'Val(Code.NAK);
SYN : constant Wide_Character := Wide_Character'Val(Code.SYN);
ETB : constant Wide_Character := Wide_Character'Val(Code.ETB);
CAN : constant Wide_Character := Wide_Character'Val(Code.CAN);
EM : constant Wide_Character := Wide_Character'Val(Code.EM);
SUB : constant Wide_Character := Wide_Character'Val(Code.SUB);
ESC : constant Wide_Character := Wide_Character'Val(Code.ESC);
FS : constant Wide_Character := Wide_Character'Val(Code.FS);
GS : constant Wide_Character := Wide_Character'Val(Code.GS);
RS : constant Wide_Character := Wide_Character'Val(Code.RS);
US : constant Wide_Character := Wide_Character'Val(Code.US);
Space : constant Wide_Character := Wide_Character'Val(Code.Space);
Exclamation : constant Wide_Character := Wide_Character'Val(Code.Exclamation);
Quotation : constant Wide_Character := Wide_Character'Val(Code.Quotation);
Number_Sign : constant Wide_Character := Wide_Character'Val(Code.Number_Sign);
Dollar_Sign : constant Wide_Character := Wide_Character'Val(Code.Dollar_Sign);
Percent_Sign : constant Wide_Character := Wide_Character'Val(Code.Percent_Sign);
Ampersand : constant Wide_Character := Wide_Character'Val(Code.Ampersand);
Apostrophe : constant Wide_Character := Wide_Character'Val(Code.Apostrophe);
Left_Parenthesis : constant Wide_Character := Wide_Character'Val(Code.Left_Parenthesis);
Right_Parenthesis : constant Wide_Character := Wide_Character'Val(Code.Right_Parenthesis);
Asterisk : constant Wide_Character := Wide_Character'Val(Code.Asterisk);
Plus_Sign : constant Wide_Character := Wide_Character'Val(Code.Plus_Sign);
Comma : constant Wide_Character := Wide_Character'Val(Code.Comma);
Minus_Sign : constant Wide_Character := Wide_Character'Val(Code.Minus_Sign);
Period : constant Wide_Character := Wide_Character'Val(Code.Period);
Slash : constant Wide_Character := Wide_Character'Val(Code.Slash);
Zero : constant Wide_Character := Wide_Character'Val(Code.Zero);
One : constant Wide_Character := Wide_Character'Val(Code.One);
Two : constant Wide_Character := Wide_Character'Val(Code.Two);
Three : constant Wide_Character := Wide_Character'Val(Code.Three);
Four : constant Wide_Character := Wide_Character'Val(Code.Four);
Five : constant Wide_Character := Wide_Character'Val(Code.Five);
Six : constant Wide_Character := Wide_Character'Val(Code.Six);
Seven : constant Wide_Character := Wide_Character'Val(Code.Seven);
Eight : constant Wide_Character := Wide_Character'Val(Code.Eight);
Nine : constant Wide_Character := Wide_Character'Val(Code.Nine);
Colon : constant Wide_Character := Wide_Character'Val(Code.Colon);
Semicolon : constant Wide_Character := Wide_Character'Val(Code.Semicolon);
Less_Than_Sign : constant Wide_Character := Wide_Character'Val(Code.Less_Than_Sign);
Equal_Sign : constant Wide_Character := Wide_Character'Val(Code.Equal_Sign);
Greater_Than_Sign : constant Wide_Character := Wide_Character'Val(Code.Greater_Than_Sign);
Question : constant Wide_Character := Wide_Character'Val(Code.Question);
Commercial_At : constant Wide_Character := Wide_Character'Val(Code.Commercial_At);
UC_A : constant Wide_Character := Wide_Character'Val(Code.UC_A);
UC_B : constant Wide_Character := Wide_Character'Val(Code.UC_B);
UC_C : constant Wide_Character := Wide_Character'Val(Code.UC_C);
UC_D : constant Wide_Character := Wide_Character'Val(Code.UC_D);
UC_E : constant Wide_Character := Wide_Character'Val(Code.UC_E);
UC_F : constant Wide_Character := Wide_Character'Val(Code.UC_F);
UC_G : constant Wide_Character := Wide_Character'Val(Code.UC_G);
UC_H : constant Wide_Character := Wide_Character'Val(Code.UC_H);
UC_I : constant Wide_Character := Wide_Character'Val(Code.UC_I);
UC_J : constant Wide_Character := Wide_Character'Val(Code.UC_J);
UC_K : constant Wide_Character := Wide_Character'Val(Code.UC_K);
UC_L : constant Wide_Character := Wide_Character'Val(Code.UC_L);
UC_M : constant Wide_Character := Wide_Character'Val(Code.UC_M);
UC_N : constant Wide_Character := Wide_Character'Val(Code.UC_N);
UC_O : constant Wide_Character := Wide_Character'Val(Code.UC_O);
UC_P : constant Wide_Character := Wide_Character'Val(Code.UC_P);
UC_Q : constant Wide_Character := Wide_Character'Val(Code.UC_Q);
UC_R : constant Wide_Character := Wide_Character'Val(Code.UC_R);
UC_S : constant Wide_Character := Wide_Character'Val(Code.UC_S);
UC_T : constant Wide_Character := Wide_Character'Val(Code.UC_T);
UC_U : constant Wide_Character := Wide_Character'Val(Code.UC_U);
UC_V : constant Wide_Character := Wide_Character'Val(Code.UC_V);
UC_W : constant Wide_Character := Wide_Character'Val(Code.UC_W);
UC_X : constant Wide_Character := Wide_Character'Val(Code.UC_X);
UC_Y : constant Wide_Character := Wide_Character'Val(Code.UC_Y);
UC_Z : constant Wide_Character := Wide_Character'Val(Code.UC_Z);
Left_Square_Bracket : constant Wide_Character := Wide_Character'Val(Code.Left_Square_Bracket);
Backslash : constant Wide_Character := Wide_Character'Val(Code.Backslash);
Right_Square_Bracket: constant Wide_Character := Wide_Character'Val(Code.Right_Square_Bracket);
Circumflex : constant Wide_Character := Wide_Character'Val(Code.Circumflex);
Low_Line : constant Wide_Character := Wide_Character'Val(Code.Low_Line);
Grave : constant Wide_Character := Wide_Character'Val(Code.Grave);
LC_A : constant Wide_Character := Wide_Character'Val(Code.LC_A);
LC_B : constant Wide_Character := Wide_Character'Val(Code.LC_B);
LC_C : constant Wide_Character := Wide_Character'Val(Code.LC_C);
LC_D : constant Wide_Character := Wide_Character'Val(Code.LC_D);
LC_E : constant Wide_Character := Wide_Character'Val(Code.LC_E);
LC_F : constant Wide_Character := Wide_Character'Val(Code.LC_F);
LC_G : constant Wide_Character := Wide_Character'Val(Code.LC_G);
LC_H : constant Wide_Character := Wide_Character'Val(Code.LC_H);
LC_I : constant Wide_Character := Wide_Character'Val(Code.LC_I);
LC_J : constant Wide_Character := Wide_Character'Val(Code.LC_J);
LC_K : constant Wide_Character := Wide_Character'Val(Code.LC_K);
LC_L : constant Wide_Character := Wide_Character'Val(Code.LC_L);
LC_M : constant Wide_Character := Wide_Character'Val(Code.LC_M);
LC_N : constant Wide_Character := Wide_Character'Val(Code.LC_N);
LC_O : constant Wide_Character := Wide_Character'Val(Code.LC_O);
LC_P : constant Wide_Character := Wide_Character'Val(Code.LC_P);
LC_Q : constant Wide_Character := Wide_Character'Val(Code.LC_Q);
LC_R : constant Wide_Character := Wide_Character'Val(Code.LC_R);
LC_S : constant Wide_Character := Wide_Character'Val(Code.LC_S);
LC_T : constant Wide_Character := Wide_Character'Val(Code.LC_T);
LC_U : constant Wide_Character := Wide_Character'Val(Code.LC_U);
LC_V : constant Wide_Character := Wide_Character'Val(Code.LC_V);
LC_W : constant Wide_Character := Wide_Character'Val(Code.LC_W);
LC_X : constant Wide_Character := Wide_Character'Val(Code.LC_X);
LC_Y : constant Wide_Character := Wide_Character'Val(Code.LC_Y);
LC_Z : constant Wide_Character := Wide_Character'Val(Code.LC_Z);
Left_Curly_Bracket : constant Wide_Character := Wide_Character'Val(Code.Left_Curly_Bracket);
Vertical_Line : constant Wide_Character := Wide_Character'Val(Code.Vertical_Line);
Right_Curly_Bracket : constant Wide_Character := Wide_Character'Val(Code.Right_Curly_Bracket);
Tilde : constant Wide_Character := Wide_Character'Val(Code.Tilde);
DEL : constant Wide_Character := Wide_Character'Val(Code.DEL);
end Wide;
end H2.Ascii; end H2.Ascii;

212
lib/h2-io-file.adb
View File

@ -4,9 +4,6 @@ separate (H2.IO)
package body File is package body File is
package Slim_Ascii renames IO.Slim_Ascii;
package Wide_Ascii renames IO.Wide_Ascii;
--|----------------------------------------------------------------------- --|-----------------------------------------------------------------------
--| PRIVATE ROUTINES --| PRIVATE ROUTINES
--|----------------------------------------------------------------------- --|-----------------------------------------------------------------------
@ -52,13 +49,8 @@ package body File is
Buf.Last := Buf.Pos + Length; Buf.Last := Buf.Pos + Length;
end Set_Length; end Set_Length;
Slim_Line_Terminator: Slim_String := Get_Line_Terminator;
--Wide_Line_Terminator: Wide_String := Get_Line_Terminator;
procedure Set_Option_Bits (Option: in out Option_Record; procedure Set_Option_Bits (Option: in out Option_Record;
Bits: in Option_Bits) is Bits: in Option_Bits) is
begin begin
Option.Bits := Option.Bits or Bits; Option.Bits := Option.Bits or Bits;
end Set_Option_Bits; end Set_Option_Bits;
@ -69,6 +61,11 @@ package body File is
Option.Bits := Option.Bits and not Bits; Option.Bits := Option.Bits and not Bits;
end Clear_Option_Bits; end Clear_Option_Bits;
-- This function is platform dependent. It is placed separately in a
-- platform specific directory.
function Get_Default_Option return Option_Record is separate;
--|----------------------------------------------------------------------- --|-----------------------------------------------------------------------
--| OPEN AND CLOSE --| OPEN AND CLOSE
--|----------------------------------------------------------------------- --|-----------------------------------------------------------------------
@ -88,9 +85,8 @@ package body File is
Set_Length (File.Rbuf, 0); Set_Length (File.Rbuf, 0);
Set_Length (File.Wbuf, 0); Set_Length (File.Wbuf, 0);
File.Option := Get_Default_Option;
File.EOF := Standard.False; File.EOF := Standard.False;
--File.Slim_Line_Break := Get_Line_Terminator;
--File.Wide_Line_Break := Get_Line_Terminator;
end Open; end Open;
procedure Open (File: in out File_Record; procedure Open (File: in out File_Record;
@ -104,9 +100,8 @@ package body File is
Set_Length (File.Rbuf, 0); Set_Length (File.Rbuf, 0);
Set_Length (File.Wbuf, 0); Set_Length (File.Wbuf, 0);
File.Option := Get_Default_Option;
File.EOF := Standard.False; File.EOF := Standard.False;
--File.Slim_Line_Break := Get_Line_Terminator;
--File.Wide_Line_Break := Get_Line_Terminator;
end Open; end Open;
procedure Close (File: in out File_Record) is procedure Close (File: in out File_Record) is
@ -119,6 +114,11 @@ package body File is
procedure Set_Option (File: in out File_Record; Option: in Option_Record) is procedure Set_Option (File: in out File_Record; Option: in Option_Record) is
begin begin
if Slim_Character'Val(Option.LF) = Slim_Character'First or else
Wide_Character'Val(Option.LF) = Wide_Character'First then
raise Constraint_Error; -- TODO: different exception name
end if;
File.Option := Option; File.Option := Option;
end Set_Option; end Set_Option;
@ -256,7 +256,7 @@ package body File is
K := K + 1; K := K + 1;
File.Rbuf.Pos := File.Rbuf.Pos + 1; File.Rbuf.Pos := File.Rbuf.Pos + 1;
Outbuf(K) := File.Rbuf.Data(File.Rbuf.Pos); Outbuf(K) := File.Rbuf.Data(File.Rbuf.Pos);
if K >= Outbuf'Last or else Outbuf(K) = Slim_Ascii.Pos.LF then -- TODO: different line terminator if K >= Outbuf'Last or else Outbuf(K) = File.Option.LF then
exit outer; -- Done exit outer; -- Done
end if; end if;
end loop; end loop;
@ -275,29 +275,39 @@ package body File is
begin begin
Read_Line (File, Buffer, Length); Read_Line (File, Buffer, Length);
if Length >= 1 then if Length <= 0 or else (File.Option.Bits and OPTION_CRLF_IN) = 0 then
Last := Buffer'First + Length - 1; return;
if Buffer(Last) = Slim_Ascii.LF then end if;
if Last > Buffer'First and then Buffer(Last - 1) = Slim_Ascii.CR then
-- Switch CR/LF to LF
Length := Length - 1;
Buffer(Last - 1) := Slim_Ascii.LF;
end if;
elsif Buffer(Last) = Slim_Ascii.CR then
if Is_Empty(File.Rbuf) then
Load_Bytes (File);
end if;
if not Is_Empty(File.Rbuf) then Last := Buffer'First + Length - 1;
if File.Rbuf.Data(File.Rbuf.Pos + 1) = Slim_Ascii.Pos.LF then if Buffer(Last) = Slim_Character'Val(File.Option.LF) then
-- Consume LF held in the internal read buffer. if Last > Buffer'First and then
File.Rbuf.Pos := File.Rbuf.Pos + 1; Buffer(Last - 1) = Slim_Character'Val(File.Option.CR) then
-- Switch CR to LF (End-result: CR/LF to LF)
Buffer(Last) := Slim_Ascii.LF;
end if; -- Switch CR/LF to LF
Length := Length - 1;
Buffer(Last - 1) := Slim_Character'Val(File.Option.LF);
end if;
elsif Buffer(Last) = Slim_Character'Val(File.Option.CR) then
if Is_Empty(File.Rbuf) then
Load_Bytes (File);
if Is_Empty(File.Rbuf) then
return;
end if; end if;
end if; end if;
if File.Rbuf.Data(File.Rbuf.Pos + 1) = File.Option.LF then
-- Consume LF held in the internal read buffer.
File.Rbuf.Pos := File.Rbuf.Pos + 1;
-- Switch CR to LF (End-result: CR/LF to LF)
Buffer(Last) := Slim_Character'Val(File.Option.LF);
end if;
end if; end if;
end Get_Line; end Get_Line;
--|----------------------------------------------------------------------- --|-----------------------------------------------------------------------
@ -306,7 +316,7 @@ package body File is
procedure Read_Wide (File: in out File_Record; procedure Read_Wide (File: in out File_Record;
Buffer: out Wide_String; Buffer: out Wide_String;
Length: out System_Length; Length: out System_Length;
Terminator: in Wide_String) is Terminator: in Wide_Character) is
pragma Assert (Is_Open(File)); pragma Assert (Is_Open(File));
pragma Assert (Buffer'Length > 0); pragma Assert (Buffer'Length > 0);
@ -332,7 +342,7 @@ package body File is
if L3 <= 0 then if L3 <= 0 then
-- Potentially illegal sequence -- Potentially illegal sequence
K := K + 1; K := K + 1;
Outbuf(K) := Wide_Ascii.Question; Outbuf(K) := Ascii.Wide.Question;
File.Rbuf.Pos := I; File.Rbuf.Pos := I;
else else
L4 := File.Rbuf.Last - File.Rbuf.Pos; -- Avaliable number of bytes available in the internal buffer L4 := File.Rbuf.Last - File.Rbuf.Pos; -- Avaliable number of bytes available in the internal buffer
@ -347,15 +357,13 @@ package body File is
Outbuf(K..K) := Slim_To_Wide(Inbuf(I .. J)); Outbuf(K..K) := Slim_To_Wide(Inbuf(I .. J));
exception exception
when others => when others =>
Outbuf(K) := Wide_Ascii.Question; Outbuf(K) := Ascii.Wide.Question;
J := I; -- Override J to skip 1 byte only. J := I; -- Override J to skip 1 byte only.
end; end;
File.Rbuf.Pos := J; File.Rbuf.Pos := J;
end if; end if;
if Terminator'Length > 0 and then if Terminator /= Wide_Character'First and then Outbuf(K) = Terminator then
Outbuf(K) = Terminator(Terminator'First) then
-- TODO: compare more characters in terminator, not just the first charactrer
exit outer; exit outer;
end if; end if;
end loop; end loop;
@ -367,17 +375,15 @@ package body File is
procedure Read (File: in out File_Record; procedure Read (File: in out File_Record;
Buffer: out Wide_String; Buffer: out Wide_String;
Length: out System_Length) is Length: out System_Length) is
Terminator: Wide_String(1..0);
begin begin
Read_Wide (File, Buffer, Length, Terminator); Read_Wide (File, Buffer, Length, Wide_Character'First);
end Read; end Read;
procedure Read_Line (File: in out File_Record; procedure Read_Line (File: in out File_Record;
Buffer: out Wide_String; Buffer: out Wide_String;
Length: out System_Length) is Length: out System_Length) is
Terminator: constant Wide_String(1..1) := (1 => Wide_Ascii.LF);
begin begin
Read_Wide (File, Buffer, Length, Terminator); Read_Wide (File, Buffer, Length, Wide_Character'Val(File.Option.LF));
end Read_Line; end Read_Line;
procedure Get_Line (File: in out File_Record; procedure Get_Line (File: in out File_Record;
@ -390,50 +396,70 @@ package body File is
begin begin
Read_Line (File, Buffer, Length); Read_Line (File, Buffer, Length);
if Length >= 1 then if Length <= 0 or else (File.Option.Bits and OPTION_CRLF_IN) = 0 then
Last := Buffer'First + Length - 1; return;
if Buffer(Last) = Wide_Ascii.LF then end if;
if Last > Buffer'First and then Buffer(Last - 1) = Wide_Ascii.CR then
-- Switch CR/LF to LF Last := Buffer'First + Length - 1;
Length := Length - 1;
Buffer(Last - 1) := Wide_Ascii.LF;
end if;
elsif Buffer(Last) = Wide_Ascii.CR then
-- if the last character in the output buffer is CR,
-- i need to inspect the first character in the internal
-- read buffer to determine if it's CR/LF.
if Is_Empty(File.Rbuf) then
Load_Bytes (File);
end if;
if not Is_Empty(File.Rbuf) then if Buffer(Last) = Wide_Character'Val(File.Option.LF) then
declare -- if the last character in the output bufer is LF.
Inbuf: Slim_String (File.Rbuf.Data'Range); -- inspect the previous character to check if it's CR.
for Inbuf'Address use File.Rbuf.Data'Address;
L3, I, J: System_Length; if Last > Buffer'First and then
W: Wide_String(1..1); Buffer(Last - 1) = Wide_Character'Val(File.Option.CR) then
begin -- Switch CR/LF to LF
I := File.Rbuf.Pos + 1; Length := Length - 1;
L3 := Sequence_Length(Inbuf(I)); -- Required number of bytes to compose a wide character Buffer(Last - 1) := Wide_Character'Val(File.Option.LF);
if L3 in 1 .. File.Rbuf.Last - File.Rbuf.Pos then end if;
J := File.Rbuf.Pos + L3;
begin elsif Buffer(Last) = Wide_Character'Val(File.Option.CR) then
W := Slim_To_Wide(Inbuf(I .. J));
exception -- if the last character in the output buffer is CR,
when others => -- i need to inspect the first character in the internal
W(1) := Wide_Ascii.NUL; -- read buffer to determine if it's CR/LF.
end; if Is_Empty(File.Rbuf) then
if W(1) = Wide_Ascii.LF then
-- Consume LF held in the internal read buffer. Load_Bytes (File);
File.Rbuf.Pos := J;
-- Switch CR to LF (End-result: CR/LF to LF) if Is_Empty(File.Rbuf) then
Buffer(Last) := Wide_Ascii.LF; -- no more data available.
end if; return;
end if;
end;
end if; end if;
end if; end if;
-- At least the first byte is available.
declare
Inbuf: Slim_String (File.Rbuf.Data'Range);
for Inbuf'Address use File.Rbuf.Data'Address;
L3, I, J: System_Length;
W: Wide_String(1..1);
begin
I := File.Rbuf.Pos + 1;
L3 := Sequence_Length(Inbuf(I)); -- Required number of bytes to compose a wide character
if L3 in 1 .. File.Rbuf.Last - File.Rbuf.Pos then
-- The next byte in the internal read buffer is a valid sequence leader and
-- the internal buffer has enough bytes to build a wide character.
J := File.Rbuf.Pos + L3;
begin
W := Slim_To_Wide(Inbuf(I .. J));
exception
when others =>
-- Don't do anything special despite the conversion error.
-- The next call should encounter the error again.
J := File.Rbuf.Pos;
end;
if J > File.Rbuf.Pos and then W(1) = Wide_Character'Val(File.Option.LF) then
-- Consume LF held in the internal read buffer.
File.Rbuf.Pos := J;
-- Switch CR to LF (End-result: CR/LF to LF)
Buffer(Last) := Wide_Character'Val(File.Option.LF);
end if;
end if;
end;
end if; end if;
end Get_Line; end Get_Line;
--|----------------------------------------------------------------------- --|-----------------------------------------------------------------------
@ -521,7 +547,7 @@ package body File is
I := I + 1; I := I + 1;
File.Wbuf.Last := File.Wbuf.Last + 1; File.Wbuf.Last := File.Wbuf.Last + 1;
File.Wbuf.Data(File.Wbuf.Last) := Inbuf(I); File.Wbuf.Data(File.Wbuf.Last) := Inbuf(I);
if File.Wbuf.Data(File.Wbuf.Last) = Slim_Ascii.Pos.LF then -- TODO: different line terminator if File.Wbuf.Data(File.Wbuf.Last) = File.Option.LF then
-- Remeber the index of the line terminator -- Remeber the index of the line terminator
LF := File.Wbuf.Last; LF := File.Wbuf.Last;
end if; end if;
@ -560,9 +586,9 @@ package body File is
I := Inbuf'First - 1; I := Inbuf'First - 1;
while I < Inbuf'Last loop while I < Inbuf'Last loop
if (File.Option.Bits and OPTION_CRLF) /= 0 and then if (File.Option.Bits and OPTION_CRLF_OUT) /= 0 and then
not Injected and then Inbuf(I + 1) = Slim_Ascii.Pos.LF then not Injected and then Inbuf(I + 1) = File.Option.LF then
X := Slim_Ascii.Pos.CR; X := File.Option.CR;
Injected := Standard.True; Injected := Standard.True;
else else
I := I + 1; I := I + 1;
@ -578,7 +604,7 @@ package body File is
File.Wbuf.Last := File.Wbuf.Last + 1; File.Wbuf.Last := File.Wbuf.Last + 1;
File.Wbuf.Data(File.Wbuf.Last) := X; File.Wbuf.Data(File.Wbuf.Last) := X;
if File.Wbuf.Data(File.Wbuf.Last) = Slim_Ascii.Pos.LF then -- TODO: different line terminator if File.Wbuf.Data(File.Wbuf.Last) = File.Option.LF then
-- Remeber the index of the line terminator -- Remeber the index of the line terminator
LF := File.Wbuf.Last; LF := File.Wbuf.Last;
end if; end if;
@ -667,7 +693,7 @@ package body File is
LF := File.Wbuf.Data'First - 1; LF := File.Wbuf.Data'First - 1;
end if; end if;
if Buffer(I) = Wide_Ascii.LF then -- TODO: different line terminator if Buffer(I) = Wide_Character'Val(File.Option.LF) then
LF := L; LF := L;
end if; end if;
@ -696,7 +722,7 @@ package body File is
pragma Assert (Is_Open(File)); pragma Assert (Is_Open(File));
F, L, I, LF: System_Length; F, L, I, LF: System_Length;
X: Wide_String(1..2) := (Wide_Ascii.CR, Wide_Ascii.LF); X: Wide_String(1..2) := (Wide_Character'Val(File.Option.CR), Wide_Character'Val(File.Option.LF));
begin begin
LF := File.Wbuf.Data'First - 1; LF := File.Wbuf.Data'First - 1;
@ -705,8 +731,8 @@ package body File is
I := I + 1; I := I + 1;
X(2) := Buffer(I); X(2) := Buffer(I);
if (File.Option.Bits and OPTION_CRLF) /= 0 and then if (File.Option.Bits and OPTION_CRLF_OUT) /= 0 and then
Buffer(I) = Wide_Ascii.LF then Buffer(I) = Wide_Character'Val(File.Option.LF) then
F := 1; F := 1;
else else
F := 2; F := 2;
@ -729,7 +755,7 @@ package body File is
LF := File.Wbuf.Data'First - 1; LF := File.Wbuf.Data'First - 1;
end if; end if;
if Buffer(I) = Wide_Ascii.LF then if Buffer(I) = Wide_Character'Val(File.Option.LF) then
LF := L; LF := L;
end if; end if;

4
lib/h2-io.adb
View File

@ -4,8 +4,4 @@ package body H2.IO is
package body File is separate; package body File is separate;
function Get_Line_Terminator return Slim_String is separate;
--function Get_Line_Terminator return Wide_String is separate;
end H2.IO; end H2.IO;

15
lib/h2-io.ads
View File

@ -13,11 +13,7 @@ generic
package H2.IO is package H2.IO is
package OS is new H2.OS (Slim_Character, Wide_Character, Slim_String, Wide_String, Slim_To_Wide, Wide_To_Slim); package OS is new H2.OS (Slim_Character, Wide_Character, Slim_String, Wide_String, Slim_To_Wide, Wide_To_Slim);
package Slim_Ascii is new H2.Ascii (Slim_Character); package Ascii is new H2.Ascii (Slim_Character, Wide_Character);
package Wide_Ascii is new H2.Ascii (Wide_Character);
function Get_Line_Terminator return Slim_String;
--function Get_Line_Terminator return Wide_String;
package File is package File is
@ -37,10 +33,13 @@ package H2.IO is
type Option_Bits is new System_Word; type Option_Bits is new System_Word;
type Option_Record is record type Option_Record is record
Bits: Option_Bits := 0; Bits: Option_Bits := 0;
LF: System_Byte := Ascii.Code.LF;
CR: System_Byte := Ascii.Code.CR;
end record; end record;
-- Convert LF to CR/LF in Put_Line -- Convert LF to CR/LF in Put_Line
OPTION_CRLF: constant Option_Bits := 2#0000_0000_0000_0001#; OPTION_CRLF_IN: constant Option_Bits := 2#0000_0000_0000_0001#;
OPTION_CRLF_OUT: constant Option_Bits := 2#0000_0000_0000_0010#;
type File_Buffer is private; type File_Buffer is private;
type File_Record is limited private; type File_Record is limited private;
@ -52,7 +51,7 @@ package H2.IO is
Bits: in Flag_Bits) renames OS.File.Clear_Flag_Bits; Bits: in Flag_Bits) renames OS.File.Clear_Flag_Bits;
procedure Set_Option_Bits (Option: in out Option_Record; procedure Set_Option_Bits (Option: in out Option_Record;
Bits: in Option_Bits); Bits: in Option_Bits);
procedure Clear_Option_Bits (Option: in out Option_Record; procedure Clear_Option_Bits (Option: in out Option_Record;
Bits: in Option_Bits); Bits: in Option_Bits);
@ -155,10 +154,10 @@ package H2.IO is
type File_Record is limited record type File_Record is limited record
File: OS.File.File_Pointer := null; File: OS.File.File_Pointer := null;
Option: Option_Record;
Rbuf: File_Buffer; Rbuf: File_Buffer;
Wbuf: File_Buffer; Wbuf: File_Buffer;
EOF: Standard.Boolean := false; EOF: Standard.Boolean := false;
Option: Option_Record;
end record; end record;
end File; end File;

28
lib/h2-scheme-bigint.adb
View File

@ -121,9 +121,9 @@ package body Bigint is
V := W rem Object_Word(Radix); V := W rem Object_Word(Radix);
if V in 0 .. 9 then if V in 0 .. 9 then
Buffer(Buffer'First + Len) := Object_Character'Val(Object_Character'Pos(Ch.Zero) + V); Buffer(Buffer'First + Len) := Object_Character'Val(Object_Character'Pos(Ch_Val.Zero) + V);
else else
Buffer(Buffer'First + Len) := Object_Character'Val(Object_Character'Pos(Ch.UC_A) + V - 10); Buffer(Buffer'First + Len) := Object_Character'Val(Object_Character'Pos(Ch_Val.UC_A) + V - 10);
end if; end if;
Len := Len + 1; Len := Len + 1;
@ -1009,7 +1009,7 @@ package body Bigint is
Convert_Word_To_Text (W, Radix, Buf, Len); Convert_Word_To_Text (W, Radix, Buf, Len);
if Sign = Negative_Sign then if Sign = Negative_Sign then
Len := Len + 1; Len := Len + 1;
Buf(Len) := Ch.Minus_Sign; Buf(Len) := Ch_Val.Minus_Sign;
end if; end if;
return Make_String(Interp, Source => Buf(1 .. Len), Invert => Standard.True); return Make_String(Interp, Source => Buf(1 .. Len), Invert => Standard.True);
end; end;
@ -1102,7 +1102,7 @@ package body Bigint is
--for I in Seglen + 1 .. Block_Divisors(Radix).Length loop --for I in Seglen + 1 .. Block_Divisors(Radix).Length loop
for I in Seglen + 1 .. BD.Length loop for I in Seglen + 1 .. BD.Length loop
Totlen := Totlen + 1; Totlen := Totlen + 1;
Buf(Totlen) := Object_Character'Val(Object_Character'Pos(Ch.Zero)); Buf(Totlen) := Object_Character'Val(Object_Character'Pos(Ch_Val.Zero));
end loop; end loop;
end loop; end loop;
@ -1110,7 +1110,7 @@ package body Bigint is
if Sign = Negative_Sign then if Sign = Negative_Sign then
Totlen := Totlen + 1; Totlen := Totlen + 1;
Buf(Totlen) := Ch.Minus_Sign; Buf(Totlen) := Ch_Val.Minus_Sign;
end if; end if;
Z := Make_String(Interp.Self, Source => Buf(1 .. Totlen), Invert => Standard.True); Z := Make_String(Interp.Self, Source => Buf(1 .. Totlen), Invert => Standard.True);
@ -1142,14 +1142,14 @@ package body Bigint is
begin begin
Pos := Object_Character'Pos(C); Pos := Object_Character'Pos(C);
case Pos is case Pos is
when Ch.Pos.Zero .. Ch.Pos.Nine => when Ch_Code.Zero .. Ch_Code.Nine =>
Pos := Pos - Ch.Pos.Zero; Pos := Pos - Ch_Code.Zero;
when Ch.Pos.LC_A .. Ch.Pos.LC_Z => when Ch_Code.LC_A .. Ch_Code.LC_Z =>
Pos := Pos - Ch.Pos.LC_A + 10; Pos := Pos - Ch_Code.LC_A + 10;
when Ch.Pos.UC_A .. Ch.Pos.UC_Z => when Ch_Code.UC_A .. Ch_Code.UC_Z =>
Pos := Pos - Ch.Pos.UC_A + 10; Pos := Pos - Ch_Code.UC_A + 10;
when others => when others =>
Pos := -1; Pos := -1;
@ -1173,9 +1173,9 @@ package body Bigint is
Sign := Positive_Sign; Sign := Positive_Sign;
Idx := X'First; Idx := X'First;
if Idx <= X'Last then if Idx <= X'Last then
if X(Idx) = Ch.Plus_Sign then if X(Idx) = Ch_Val.Plus_Sign then
Idx := Idx + 1; Idx := Idx + 1;
elsif X(Idx) = Ch.Minus_Sign then elsif X(Idx) = Ch_Val.Minus_Sign then
Idx := Idx + 1; Idx := Idx + 1;
Sign := Negative_Sign; Sign := Negative_Sign;
end if; end if;
@ -1190,7 +1190,7 @@ package body Bigint is
-- Find the first non-zero digit -- Find the first non-zero digit
while Idx <= X'Last loop while Idx <= X'Last loop
exit when X(Idx) /= Ch.Zero; exit when X(Idx) /= Ch_Val.Zero;
Idx := Idx + 1; Idx := Idx + 1;
end loop; end loop;
if Idx > X'Last then if Idx > X'Last then

68
lib/h2-scheme-execute.adb
View File

@ -583,14 +583,14 @@ procedure Execute (Interp: in out Interpreter_Record) is
function Is_White_Space (X: in Object_Character) return Standard.Boolean is function Is_White_Space (X: in Object_Character) return Standard.Boolean is
begin begin
return X = Ch.Space or else X = Ch.HT or else X = Ch.VT or else return X = Ch_Val.Space or else X = Ch_Val.HT or else X = Ch_Val.VT or else
X = Ch.CR or else X = Ch.LF or else X = Ch.FF; X = Ch_Val.CR or else X = Ch_Val.LF or else X = Ch_Val.FF;
end Is_White_Space; end Is_White_Space;
function Is_Delimiter (X: in Object_Character) return Standard.Boolean is function Is_Delimiter (X: in Object_Character) return Standard.Boolean is
begin begin
return X = Ch.Left_Parenthesis or else X = Ch.Right_Parenthesis or else return X = Ch_Val.Left_Parenthesis or else X = Ch_Val.Right_Parenthesis or else
X = Ch.Quotation or else X = Ch.Semicolon or else X = Ch_Val.Quotation or else X = Ch_Val.Semicolon or else
Is_White_Space(X); Is_White_Space(X);
end Is_Delimiter; end Is_Delimiter;
@ -602,13 +602,13 @@ procedure Execute (Interp: in out Interpreter_Record) is
-- Normal character -- Normal character
if Is_White_Space(LC.Value) then if Is_White_Space(LC.Value) then
Fetch_Character; Fetch_Character;
elsif LC.Value = Ch.Semicolon then elsif LC.Value = Ch_Val.Semicolon then
-- Comment. -- Comment.
loop loop
Fetch_Character; Fetch_Character;
exit when LC.Kind = End_Character; -- EOF before LF exit when LC.Kind = End_Character; -- EOF before LF
if LC.Kind = Normal_Character and then LC.Value = Ch.LF then -- TODO: handle different line ending convention if LC.Kind = Normal_Character and then LC.Value = Ch_Val.LF then -- TODO: handle different line ending convention
Fetch_Character; -- Read the next character after LF Fetch_Character; -- Read the next character after LF
exit; exit;
end if; end if;
@ -636,24 +636,24 @@ procedure Execute (Interp: in out Interpreter_Record) is
-- TODO: Pass Token Location when calling Token.Set -- TODO: Pass Token Location when calling Token.Set
-- Use Ch.Pos.XXX values instead of Ch.XXX values as gnat complained that -- Use Ch_Code.XXX values instead of Ch_Val.XXX values as gnat complained that
-- Ch.XXX values are not static. For this reason, "case LC.Value is ..." -- Ch_Val.XXX values are not static. For this reason, "case LC.Value is ..."
-- changed to use Object_Character'Pos(LC.Value). -- changed to use Object_Character'Pos(LC.Value).
case Object_Character'Pos(LC.Value) is case Object_Character'Pos(LC.Value) is
when Ch.Pos.Left_Parenthesis => when Ch_Code.Left_Parenthesis =>
Token.Set (Interp, Left_Parenthesis_Token, LC.Value); Token.Set (Interp, Left_Parenthesis_Token, LC.Value);
when Ch.Pos.Right_Parenthesis => when Ch_Code.Right_Parenthesis =>
Token.Set (Interp, Right_Parenthesis_Token, LC.Value); Token.Set (Interp, Right_Parenthesis_Token, LC.Value);
when Ch.Pos.Period => when Ch_Code.Period =>
Token.Set (Interp, Period_Token, LC.Value); Token.Set (Interp, Period_Token, LC.Value);
when Ch.Pos.Apostrophe => when Ch_Code.Apostrophe =>
Token.Set (Interp, Single_Quote_Token, LC.Value); Token.Set (Interp, Single_Quote_Token, LC.Value);
when Ch.Pos.Number_Sign => when Ch_Code.Number_Sign =>
Fetch_Character; Fetch_Character;
if LC.Kind /= Normal_Character then if LC.Kind /= Normal_Character then
-- ended prematurely. -- ended prematurely.
@ -672,15 +672,15 @@ procedure Execute (Interp: in out Interpreter_Record) is
-- #< > -- xxx -- #< > -- xxx
case Object_Character'Pos(LC.Value) is case Object_Character'Pos(LC.Value) is
when Ch.Pos.LC_T => -- #t when Ch_Code.LC_T => -- #t
Token.Set (Interp, True_Token, Ch.Number_Sign); Token.Set (Interp, True_Token, Ch_Val.Number_Sign);
Token.Append_Character (Interp, LC.Value); Token.Append_Character (Interp, LC.Value);
when Ch.Pos.LC_F => -- #f when Ch_Code.LC_F => -- #f
Token.Set (Interp, False_Token, Ch.Number_Sign); Token.Set (Interp, False_Token, Ch_Val.Number_Sign);
Token.Append_Character (Interp, LC.Value); Token.Append_Character (Interp, LC.Value);
when Ch.Pos.Backslash => -- #\C, #\space, #\newline when Ch_Code.Backslash => -- #\C, #\space, #\newline
Fetch_Character; Fetch_Character;
if LC.Kind /= Normal_Character then if LC.Kind /= Normal_Character then
ada.text_io.put_line ("ERROR: NO CHARACTER AFTER #\"); ada.text_io.put_line ("ERROR: NO CHARACTER AFTER #\");
@ -702,9 +702,9 @@ procedure Execute (Interp: in out Interpreter_Record) is
-- TODO: case insensitive match. binary search for more diverse words -- TODO: case insensitive match. binary search for more diverse words
-- TODO: #\xHHHH.... -- TODO: #\xHHHH....
if Interp.Token.Value.Ptr.all(1..Interp.Token.Value.Last) = Label_Newline then if Interp.Token.Value.Ptr.all(1..Interp.Token.Value.Last) = Label_Newline then
Token.Set (Interp, Character_Token, Ch.LF); -- reset the token to LF Token.Set (Interp, Character_Token, Ch_Val.LF); -- reset the token to LF
elsif Interp.Token.Value.Ptr.all(1..Interp.Token.Value.Last) = Label_Space then elsif Interp.Token.Value.Ptr.all(1..Interp.Token.Value.Last) = Label_Space then
Token.Set (Interp, Character_Token, Ch.Space); -- reset the token to Space Token.Set (Interp, Character_Token, Ch_Val.Space); -- reset the token to Space
else else
-- unknown character name. -- unknown character name.
ada.text_io.put ("ERROR: UNKNOWN CHARACTER NAME "); ada.text_io.put ("ERROR: UNKNOWN CHARACTER NAME ");
@ -717,16 +717,16 @@ procedure Execute (Interp: in out Interpreter_Record) is
end if; end if;
end if; end if;
--when Ch.Pos.Left_Parenthesis => -- #( --when Ch_Code.Left_Parenthesis => -- #(
-- Token.Set (Interp, Vector_Token, Ch.Number_Sign); -- Token.Set (Interp, Vector_Token, Ch_Val.Number_Sign);
-- Token.Append_Character (Interp, LC.Value); -- Token.Append_Character (Interp, LC.Value);
--when Ch.Pos.Left_Bracket => -- $[ --when Ch_Code.Left_Bracket => -- $[
-- Token.Set (Interp, List_Token, Ch.Number_Sign); -- Token.Set (Interp, List_Token, Ch_Val.Number_Sign);
-- Token.Append_Character (Interp, LC.Value); -- Token.Append_Character (Interp, LC.Value);
--when Ch.Pos.Left_Bracket => -- ${ --when Ch_Code.Left_Bracket => -- ${
-- Token.Set (Interp, Table_Token, Ch.Number_Sign); -- Token.Set (Interp, Table_Token, Ch_Val.Number_Sign);
-- Token.Append_Character (Interp, LC.Value); -- Token.Append_Character (Interp, LC.Value);
when others => when others =>
@ -736,7 +736,7 @@ procedure Execute (Interp: in out Interpreter_Record) is
end case; end case;
when Ch.Pos.Quotation => when Ch_Code.Quotation =>
Fetch_Character; Fetch_Character;
Token.Set (Interp, String_Token); Token.Set (Interp, String_Token);
loop loop
@ -746,7 +746,7 @@ procedure Execute (Interp: in out Interpreter_Record) is
raise Syntax_Error; raise Syntax_Error;
end if; end if;
if LC.Value = Ch.Backslash then if LC.Value = Ch_Val.Backslash then
Fetch_Character; Fetch_Character;
if LC.Kind /= Normal_Character then if LC.Kind /= Normal_Character then
-- String ended prematurely. -- String ended prematurely.
@ -755,7 +755,7 @@ procedure Execute (Interp: in out Interpreter_Record) is
end if; end if;
-- TODO: escape letters??? \n \r \\ etc.... -- TODO: escape letters??? \n \r \\ etc....
Token.Append_Character (Interp, LC.Value); Token.Append_Character (Interp, LC.Value);
elsif LC.Value = Ch.Quotation then elsif LC.Value = Ch_Val.Quotation then
exit; exit;
else else
Token.Append_Character (Interp, LC.Value); Token.Append_Character (Interp, LC.Value);
@ -764,33 +764,33 @@ procedure Execute (Interp: in out Interpreter_Record) is
end loop; end loop;
when Ch.Pos.Zero .. Ch.Pos.Nine => when Ch_Code.Zero .. Ch_Code.Nine =>
-- TODO; negative number, floating-point number, bignum, hexdecimal, etc -- TODO; negative number, floating-point number, bignum, hexdecimal, etc
Token.Set (Interp, Integer_Token); Token.Set (Interp, Integer_Token);
loop loop
Token.Append_Character (Interp, LC.Value); Token.Append_Character (Interp, LC.Value);
Fetch_Character; Fetch_Character;
if LC.Kind /= Normal_Character or else if LC.Kind /= Normal_Character or else
LC.Value not in Ch.Zero .. Ch.Nine then LC.Value not in Ch_Val.Zero .. Ch_Val.Nine then
-- Unfetch the last character -- Unfetch the last character
Unfetch_Character; Unfetch_Character;
exit; exit;
end if; end if;
end loop; end loop;
when Ch.Pos.Plus_Sign | Ch.Pos.Minus_Sign => when Ch_Code.Plus_Sign | Ch_Code.Minus_Sign =>
Tmp(1) := LC.Value; Tmp(1) := LC.Value;
Fetch_Character; Fetch_Character;
if LC.Kind = Normal_Character and then if LC.Kind = Normal_Character and then
LC.Value in Ch.Zero .. Ch.Nine then LC.Value in Ch_Val.Zero .. Ch_Val.Nine then
Token.Set (Interp, Integer_Token, Tmp(1..1)); Token.Set (Interp, Integer_Token, Tmp(1..1));
loop loop
Token.Append_Character (Interp, LC.Value); Token.Append_Character (Interp, LC.Value);
Fetch_Character; Fetch_Character;
if LC.Kind /= Normal_Character or else if LC.Kind /= Normal_Character or else
LC.Value not in Ch.Zero .. Ch.Nine then LC.Value not in Ch_Val.Zero .. Ch_Val.Nine then
Unfetch_Character; Unfetch_Character;
exit; exit;
end if; end if;

112
lib/h2-scheme.adb
View File

@ -60,64 +60,64 @@ package body H2.Scheme is
-- Why doesn't ada include a formal type support for different character -- Why doesn't ada include a formal type support for different character
-- and string types? This limitation is caused because the generic -- and string types? This limitation is caused because the generic
-- type I chosed to use to represent a character type is a discrete type. -- type I chosed to use to represent a character type is a discrete type.
Label_And: constant Object_Character_Array := (Ch.LC_A, Ch.LC_N, Ch.LC_D); -- "and" Label_And: constant Object_Character_Array := (Ch_Val.LC_A, Ch_Val.LC_N, Ch_Val.LC_D); -- "and"
Label_Begin: constant Object_Character_Array := (Ch.LC_B, Ch.LC_E, Ch.LC_G, Ch.LC_I, Ch.LC_N); -- "begin" Label_Begin: constant Object_Character_Array := (Ch_Val.LC_B, Ch_Val.LC_E, Ch_Val.LC_G, Ch_Val.LC_I, Ch_Val.LC_N); -- "begin"
Label_Case: constant Object_Character_Array := (Ch.LC_C, Ch.LC_A, Ch.LC_S, Ch.LC_E); -- "case" Label_Case: constant Object_Character_Array := (Ch_Val.LC_C, Ch_Val.LC_A, Ch_Val.LC_S, Ch_Val.LC_E); -- "case"
Label_Cond: constant Object_Character_Array := (Ch.LC_C, Ch.LC_O, Ch.LC_N, Ch.LC_D); -- "cond" Label_Cond: constant Object_Character_Array := (Ch_Val.LC_C, Ch_Val.LC_O, Ch_Val.LC_N, Ch_Val.LC_D); -- "cond"
Label_Define: constant Object_Character_Array := (Ch.LC_D, Ch.LC_E, Ch.LC_F, Ch.LC_I, Ch.LC_N, Ch.LC_E); -- "define" Label_Define: constant Object_Character_Array := (Ch_Val.LC_D, Ch_Val.LC_E, Ch_Val.LC_F, Ch_Val.LC_I, Ch_Val.LC_N, Ch_Val.LC_E); -- "define"
Label_Do: constant Object_Character_Array := (Ch.LC_D, Ch.LC_O); -- "do" Label_Do: constant Object_Character_Array := (Ch_Val.LC_D, Ch_Val.LC_O); -- "do"
Label_If: constant Object_Character_Array := (Ch.LC_I, Ch.LC_F); -- "if" Label_If: constant Object_Character_Array := (Ch_Val.LC_I, Ch_Val.LC_F); -- "if"
Label_Lambda: constant Object_Character_Array := (Ch.LC_L, Ch.LC_A, Ch.LC_M, Ch.LC_B, Ch.LC_D, Ch.LC_A); -- "lambda" Label_Lambda: constant Object_Character_Array := (Ch_Val.LC_L, Ch_Val.LC_A, Ch_Val.LC_M, Ch_Val.LC_B, Ch_Val.LC_D, Ch_Val.LC_A); -- "lambda"
Label_Let: constant Object_Character_Array := (Ch.LC_L, Ch.LC_E, Ch.LC_T); -- "let" Label_Let: constant Object_Character_Array := (Ch_Val.LC_L, Ch_Val.LC_E, Ch_Val.LC_T); -- "let"
Label_Letast: constant Object_Character_Array := (Ch.LC_L, Ch.LC_E, Ch.LC_T, Ch.Asterisk); -- "let*" Label_Letast: constant Object_Character_Array := (Ch_Val.LC_L, Ch_Val.LC_E, Ch_Val.LC_T, Ch_Val.Asterisk); -- "let*"
Label_Letrec: constant Object_Character_Array := (Ch.LC_L, Ch.LC_E, Ch.LC_T, Ch.LC_R, Ch.LC_E, Ch.LC_C); -- "letrec" Label_Letrec: constant Object_Character_Array := (Ch_Val.LC_L, Ch_Val.LC_E, Ch_Val.LC_T, Ch_Val.LC_R, Ch_Val.LC_E, Ch_Val.LC_C); -- "letrec"
Label_Or: constant Object_Character_Array := (Ch.LC_O, Ch.LC_R); -- "or" Label_Or: constant Object_Character_Array := (Ch_Val.LC_O, Ch_Val.LC_R); -- "or"
Label_Quasiquote: constant Object_Character_Array := (Ch.LC_Q, Ch.LC_U, Ch.LC_A, Ch.LC_S, Ch.LC_I, Label_Quasiquote: constant Object_Character_Array := (Ch_Val.LC_Q, Ch_Val.LC_U, Ch_Val.LC_A, Ch_Val.LC_S, Ch_Val.LC_I,
Ch.LC_Q, Ch.LC_U, Ch.LC_O, Ch.LC_T, Ch.LC_E); -- "quasiquote" Ch_Val.LC_Q, Ch_Val.LC_U, Ch_Val.LC_O, Ch_Val.LC_T, Ch_Val.LC_E); -- "quasiquote"
Label_Quote: constant Object_Character_Array := (Ch.LC_Q, Ch.LC_U, Ch.LC_O, Ch.LC_T, Ch.LC_E); -- "quote" Label_Quote: constant Object_Character_Array := (Ch_Val.LC_Q, Ch_Val.LC_U, Ch_Val.LC_O, Ch_Val.LC_T, Ch_Val.LC_E); -- "quote"
Label_Set: constant Object_Character_Array := (Ch.LC_S, Ch.LC_E, Ch.LC_T, Ch.Exclamation); -- "set!" Label_Set: constant Object_Character_Array := (Ch_Val.LC_S, Ch_Val.LC_E, Ch_Val.LC_T, Ch_Val.Exclamation); -- "set!"
Label_Callcc: constant Object_Character_Array := (Ch.LC_C, Ch.LC_A, Ch.LC_L, Ch.LC_L, Ch.Minus_Sign, Label_Callcc: constant Object_Character_Array := (Ch_Val.LC_C, Ch_Val.LC_A, Ch_Val.LC_L, Ch_Val.LC_L, Ch_Val.Minus_Sign,
Ch.LC_W, Ch.LC_I, Ch.LC_T, Ch.LC_H, Ch.Minus_Sign, Ch_Val.LC_W, Ch_Val.LC_I, Ch_Val.LC_T, Ch_Val.LC_H, Ch_Val.Minus_Sign,
Ch.LC_C, Ch.LC_U, Ch.LC_R, Ch.LC_R, Ch.LC_E, Ch.LC_N, Ch.LC_T, Ch.Minus_Sign, Ch_Val.LC_C, Ch_Val.LC_U, Ch_Val.LC_R, Ch_Val.LC_R, Ch_Val.LC_E, Ch_Val.LC_N, Ch_Val.LC_T, Ch_Val.Minus_Sign,
Ch.LC_C, Ch.LC_O, Ch.LC_N, Ch.LC_T, Ch.LC_I, Ch.LC_N, Ch.LC_U, Ch.LC_A, Ch_Val.LC_C, Ch_Val.LC_O, Ch_Val.LC_N, Ch_Val.LC_T, Ch_Val.LC_I, Ch_Val.LC_N, Ch_Val.LC_U, Ch_Val.LC_A,
Ch.LC_T, Ch.LC_I, Ch.LC_O, Ch.LC_N); -- "call-with-current-continuation" Ch_Val.LC_T, Ch_Val.LC_I, Ch_Val.LC_O, Ch_Val.LC_N); -- "call-with-current-continuation"
Label_Car: constant Object_Character_Array := (Ch.LC_C, Ch.LC_A, Ch.LC_R); -- "car" Label_Car: constant Object_Character_Array := (Ch_Val.LC_C, Ch_Val.LC_A, Ch_Val.LC_R); -- "car"
Label_Cdr: constant Object_Character_Array := (Ch.LC_C, Ch.LC_D, Ch.LC_R); -- "cdr" Label_Cdr: constant Object_Character_Array := (Ch_Val.LC_C, Ch_Val.LC_D, Ch_Val.LC_R); -- "cdr"
Label_Cons: constant Object_Character_Array := (Ch.LC_C, Ch.LC_O, Ch.LC_N, Ch.LC_S); -- "cons" Label_Cons: constant Object_Character_Array := (Ch_Val.LC_C, Ch_Val.LC_O, Ch_Val.LC_N, Ch_Val.LC_S); -- "cons"
Label_Not: constant Object_Character_Array := (Ch.LC_N, Ch.LC_O, Ch.LC_T); -- "not" Label_Not: constant Object_Character_Array := (Ch_Val.LC_N, Ch_Val.LC_O, Ch_Val.LC_T); -- "not"
Label_N_Add: constant Object_Character_Array := (1 => Ch.Plus_Sign); -- "+" Label_N_Add: constant Object_Character_Array := (1 => Ch_Val.Plus_Sign); -- "+"
Label_N_EQ: constant Object_Character_Array := (1 => Ch.Equal_Sign); -- "=" Label_N_EQ: constant Object_Character_Array := (1 => Ch_Val.Equal_Sign); -- "="
Label_N_GE: constant Object_Character_Array := (Ch.Greater_Than_Sign, Ch.Equal_Sign); -- ">=" Label_N_GE: constant Object_Character_Array := (Ch_Val.Greater_Than_Sign, Ch_Val.Equal_Sign); -- ">="
Label_N_GT: constant Object_Character_Array := (1 => Ch.Greater_Than_Sign); -- ">" Label_N_GT: constant Object_Character_Array := (1 => Ch_Val.Greater_Than_Sign); -- ">"
Label_N_LE: constant Object_Character_Array := (Ch.Less_Than_Sign, Ch.Equal_Sign); -- "<=" Label_N_LE: constant Object_Character_Array := (Ch_Val.Less_Than_Sign, Ch_Val.Equal_Sign); -- "<="
Label_N_LT: constant Object_Character_Array := (1 => Ch.Less_Than_Sign); -- "<" Label_N_LT: constant Object_Character_Array := (1 => Ch_Val.Less_Than_Sign); -- "<"
Label_N_Multiply: constant Object_Character_Array := (1 => Ch.Asterisk); -- "*" Label_N_Multiply: constant Object_Character_Array := (1 => Ch_Val.Asterisk); -- "*"
Label_N_Quotient: constant Object_Character_Array := (Ch.LC_Q, Ch.LC_U, Ch.LC_O, Ch.LC_T, Ch.LC_I, Ch.LC_E, Ch.LC_N, Ch.LC_T); -- "quotient" Label_N_Quotient: constant Object_Character_Array := (Ch_Val.LC_Q, Ch_Val.LC_U, Ch_Val.LC_O, Ch_Val.LC_T, Ch_Val.LC_I, Ch_Val.LC_E, Ch_Val.LC_N, Ch_Val.LC_T); -- "quotient"
Label_N_Remainder: constant Object_Character_Array := (Ch.LC_R, Ch.LC_E, Ch.LC_M, Ch.LC_A, Ch.LC_I, Ch.LC_N, Ch.LC_D, Ch.LC_E, Ch.LC_R); -- "remainder" Label_N_Remainder: constant Object_Character_Array := (Ch_Val.LC_R, Ch_Val.LC_E, Ch_Val.LC_M, Ch_Val.LC_A, Ch_Val.LC_I, Ch_Val.LC_N, Ch_Val.LC_D, Ch_Val.LC_E, Ch_Val.LC_R); -- "remainder"
Label_N_Subtract: constant Object_Character_Array := (1 => Ch.Minus_Sign); -- "-" Label_N_Subtract: constant Object_Character_Array := (1 => Ch_Val.Minus_Sign); -- "-"
Label_Q_Boolean: constant Object_Character_Array := (Ch.LC_B, Ch.LC_O, Ch.LC_O, Ch.LC_L, Ch.LC_E, Ch.LC_A, Ch.LC_N, Ch.Question); -- "boolean?" Label_Q_Boolean: constant Object_Character_Array := (Ch_Val.LC_B, Ch_Val.LC_O, Ch_Val.LC_O, Ch_Val.LC_L, Ch_Val.LC_E, Ch_Val.LC_A, Ch_Val.LC_N, Ch_Val.Question); -- "boolean?"
Label_Q_Eq: constant Object_Character_Array := (Ch.LC_E, Ch.LC_Q, Ch.Question); -- "eq?" Label_Q_Eq: constant Object_Character_Array := (Ch_Val.LC_E, Ch_Val.LC_Q, Ch_Val.Question); -- "eq?"
Label_Q_Eqv: constant Object_Character_Array := (Ch.LC_E, Ch.LC_Q, Ch.LC_V, Ch.Question); -- "eqv?" Label_Q_Eqv: constant Object_Character_Array := (Ch_Val.LC_E, Ch_Val.LC_Q, Ch_Val.LC_V, Ch_Val.Question); -- "eqv?"
Label_Q_Null: constant Object_Character_Array := (Ch.LC_N, Ch.LC_U, Ch.LC_L, Ch.LC_L, Ch.Question); -- "null?" Label_Q_Null: constant Object_Character_Array := (Ch_Val.LC_N, Ch_Val.LC_U, Ch_Val.LC_L, Ch_Val.LC_L, Ch_Val.Question); -- "null?"
Label_Q_Number: constant Object_Character_Array := (Ch.LC_N, Ch.LC_U, Ch.LC_M, Ch.LC_B, Ch.LC_E, Ch.LC_R, Ch.Question); -- "number?" Label_Q_Number: constant Object_Character_Array := (Ch_Val.LC_N, Ch_Val.LC_U, Ch_Val.LC_M, Ch_Val.LC_B, Ch_Val.LC_E, Ch_Val.LC_R, Ch_Val.Question); -- "number?"
Label_Q_Pair: constant Object_Character_Array := (Ch.LC_P, Ch.LC_A, Ch.LC_I, Ch.LC_R, Ch.Question); -- "pair?" Label_Q_Pair: constant Object_Character_Array := (Ch_Val.LC_P, Ch_Val.LC_A, Ch_Val.LC_I, Ch_Val.LC_R, Ch_Val.Question); -- "pair?"
Label_Q_Procedure: constant Object_Character_Array := (Ch.LC_P, Ch.LC_R, Ch.LC_O, Ch.LC_C, Ch.LC_E, Ch.LC_D, Ch.LC_U, Ch.LC_R, Ch.LC_E, Ch.Question); -- "procedure?" Label_Q_Procedure: constant Object_Character_Array := (Ch_Val.LC_P, Ch_Val.LC_R, Ch_Val.LC_O, Ch_Val.LC_C, Ch_Val.LC_E, Ch_Val.LC_D, Ch_Val.LC_U, Ch_Val.LC_R, Ch_Val.LC_E, Ch_Val.Question); -- "procedure?"
Label_Q_String: constant Object_Character_Array := (Ch.LC_S, Ch.LC_T, Ch.LC_R, Ch.LC_I, Ch.LC_N, Ch.LC_G, Ch.Question); -- "string?" Label_Q_String: constant Object_Character_Array := (Ch_Val.LC_S, Ch_Val.LC_T, Ch_Val.LC_R, Ch_Val.LC_I, Ch_Val.LC_N, Ch_Val.LC_G, Ch_Val.Question); -- "string?"
Label_Q_String_EQ: constant Object_Character_Array := (Ch.LC_S, Ch.LC_T, Ch.LC_R, Ch.LC_I, Ch.LC_N, Ch.LC_G, Ch.Equal_Sign, Ch.Question); -- "string=?" Label_Q_String_EQ: constant Object_Character_Array := (Ch_Val.LC_S, Ch_Val.LC_T, Ch_Val.LC_R, Ch_Val.LC_I, Ch_Val.LC_N, Ch_Val.LC_G, Ch_Val.Equal_Sign, Ch_Val.Question); -- "string=?"
Label_Q_Symbol: constant Object_Character_Array := (Ch.LC_S, Ch.LC_Y, Ch.LC_M, Ch.LC_B, Ch.LC_O, Ch.LC_L, Ch.Question); -- "symbol?" Label_Q_Symbol: constant Object_Character_Array := (Ch_Val.LC_S, Ch_Val.LC_Y, Ch_Val.LC_M, Ch_Val.LC_B, Ch_Val.LC_O, Ch_Val.LC_L, Ch_Val.Question); -- "symbol?"
Label_Setcar: constant Object_Character_Array := (Ch.LC_S, Ch.LC_E, Ch.LC_T, Ch.Minus_Sign, Ch.LC_C, Ch.LC_A, Ch.LC_R, Ch.Exclamation); -- "set-car!" Label_Setcar: constant Object_Character_Array := (Ch_Val.LC_S, Ch_Val.LC_E, Ch_Val.LC_T, Ch_Val.Minus_Sign, Ch_Val.LC_C, Ch_Val.LC_A, Ch_Val.LC_R, Ch_Val.Exclamation); -- "set-car!"
Label_Setcdr: constant Object_Character_Array := (Ch.LC_S, Ch.LC_E, Ch.LC_T, Ch.Minus_Sign, Ch.LC_C, Ch.LC_D, Ch.LC_R, Ch.Exclamation); -- "set-cdr!" Label_Setcdr: constant Object_Character_Array := (Ch_Val.LC_S, Ch_Val.LC_E, Ch_Val.LC_T, Ch_Val.Minus_Sign, Ch_Val.LC_C, Ch_Val.LC_D, Ch_Val.LC_R, Ch_Val.Exclamation); -- "set-cdr!"
Label_Newline: constant Object_Character_Array := (Ch.LC_N, Ch.LC_E, Ch.LC_W, Ch.LC_L, Ch.LC_I, Ch.LC_N, Ch.LC_E); -- "newline" Label_Newline: constant Object_Character_Array := (Ch_Val.LC_N, Ch_Val.LC_E, Ch_Val.LC_W, Ch_Val.LC_L, Ch_Val.LC_I, Ch_Val.LC_N, Ch_Val.LC_E); -- "newline"
Label_Space: constant Object_Character_Array := (Ch.LC_S, Ch.LC_P, Ch.LC_A, Ch.LC_C, Ch.LC_E); -- "space" Label_Space: constant Object_Character_Array := (Ch_Val.LC_S, Ch_Val.LC_P, Ch_Val.LC_A, Ch_Val.LC_C, Ch_Val.LC_E); -- "space"
Label_Arrow: constant Object_Character_Array := (Ch.Equal_Sign, Ch.Greater_Than_Sign); -- "=>" Label_Arrow: constant Object_Character_Array := (Ch_Val.Equal_Sign, Ch_Val.Greater_Than_Sign); -- "=>"
Label_Else: constant Object_Character_Array := (Ch.LC_E, Ch.LC_L, Ch.LC_S, Ch.LC_E); -- "else" Label_Else: constant Object_Character_Array := (Ch_Val.LC_E, Ch_Val.LC_L, Ch_Val.LC_S, Ch_Val.LC_E); -- "else"
----------------------------------------------------------------------------- -----------------------------------------------------------------------------
-- INTERNAL EXCEPTIONS -- INTERNAL EXCEPTIONS
@ -393,14 +393,14 @@ package body H2.Scheme is
pragma Assert (Source'Length > 0); pragma Assert (Source'Length > 0);
First := Source'First; First := Source'First;
if Source(First) = Ch.Minus_Sign then if Source(First) = Ch_Val.Minus_Sign then
First := First + 1; First := First + 1;
Negative := Standard.True; Negative := Standard.True;
elsif Source(First) = Ch.Plus_Sign then elsif Source(First) = Ch_Val.Plus_Sign then
First := First + 1; First := First + 1;
end if; end if;
for I in First .. Source'Last loop for I in First .. Source'Last loop
V := V * 10 + Object_Character'Pos(Source(I)) - Object_Character'Pos(Ch.Zero); V := V * 10 + Object_Character'Pos(Source(I)) - Object_Character'Pos(Ch_Val.Zero);
end loop; end loop;
if Negative then if Negative then
@ -1071,8 +1071,8 @@ end if;
Tag => Unknown_Object, Tag => Unknown_Object,
Scode => Syntax_Code'Val(0), Scode => Syntax_Code'Val(0),
Sign => Positive_Sign, Sign => Positive_Sign,
Character_Slot => (others => Ch.NUL), Character_Slot => (others => Ch_Val.NUL),
Character_Terminator => Ch.NUL Character_Terminator => Ch_Val.NUL
); );
return Result; return Result;

7
lib/h2-scheme.ads
View File

@ -54,7 +54,6 @@ package H2.Scheme is
Divide_By_Zero_Error: exception; Divide_By_Zero_Error: exception;
Numeric_String_Error: exception; Numeric_String_Error: exception;
type Interpreter_Record is limited private; type Interpreter_Record is limited private;
type Interpreter_Pointer is access all Interpreter_Record; type Interpreter_Pointer is access all Interpreter_Record;
@ -494,8 +493,10 @@ package H2.Scheme is
-- ----------------------------------------------------------------------------- -- -----------------------------------------------------------------------------
private private
package Ch is new Ascii(Object_Character); package Ch is new H2.Ascii(Object_Character, Object_Character);
package Ch_Code renames Ch.Code;
package Ch_Val renames Ch.Slim; -- Ch.Slim and Ch.Wide are the same as both are Object_Charater above.
type Heap_Element_Array is array(Heap_Size range <>) of aliased Heap_Element; type Heap_Element_Array is array(Heap_Size range <>) of aliased Heap_Element;
type Heap_Record(Size: Heap_Size) is record type Heap_Record(Size: Heap_Size) is record

8
lib/h2.ads
View File

@ -25,11 +25,7 @@ package H2 is
access all System.Storage_Pools.Root_Storage_Pool'Class; access all System.Storage_Pools.Root_Storage_Pool'Class;
type System_Byte_Array is array(System_Index range<>) of System_Byte; type System_Byte_Array is array(System_Index range<>) of System_Byte;
--package Chpos renames H2.Ascii.Code;
end H2; end H2;

2
lib/lib.gpr.in
View File

@ -27,7 +27,7 @@ project Lib is
"h2-io.ads", "h2-io.ads",
"h2-io.adb", "h2-io.adb",
"h2-io-file.adb", "h2-io-file.adb",
"h2-io-get_line_terminator.adb", "h2-io-file-get_default_option.adb",
"h2-scheme.adb", "h2-scheme.adb",
"h2-scheme.ads", "h2-scheme.ads",
"h2-scheme-bigint.adb", "h2-scheme-bigint.adb",

1
lib/posix/h2-os-file.adb
View File

@ -169,5 +169,4 @@ package body File is
end if; end if;
end Write; end Write;
end File; end File;

13
lib/win32/h2-io-file-get_default_option.adb Normal file
View File

@ -0,0 +1,13 @@
separate (H2.IO.File)
function Get_Default_Option return Option_Record is
Default_Option: constant Option_Record := (
Bits => (OPTION_CRLF_IN or OPTION_CRLF_OUT),
CR => Ascii.Code.CR,
LF => Ascii.Code.LF
);
begin
return Default_Option;
end Get_Default_Option;

187
lib/win32/h2-os-file.adb Normal file
View File

@ -0,0 +1,187 @@
with H2.Pool;
with H2.Sysdef;
separate (H2.OS)
package body File is
-- External functions and procedures
function CreateFileA (lpFileName : Slim_String;
dwDesiredAccess : Sysdef.DWORD;
dwShareMode : Sysdef.DWORD;
lpSecurityAttributes : Sysdef.PVOID; -- LPSECURITY_ATTRIBUTES;
dwCreationDisposition: Sysdef.DWORD;
dwFlagsAndAttributes : Sysdef.DWORD;
hTemplateFile : Sysdef.HANDLE) return Sysdef.HANDLE;
pragma Import (Stdcall, CreateFileA, "CreateFileA");
function CreateFileW (lpFileName : Wide_String;
dwDesiredAccess : Sysdef.DWORD;
dwShareMode : Sysdef.DWORD;
lpSecurityAttributes : Sysdef.PVOID; -- LPSECURITY_ATTRIBUTES;
dwCreationDisposition: Sysdef.DWORD;
dwFlagsAndAttributes : Sysdef.DWORD;
hTemplateFile : Sysdef.HANDLE) return Sysdef.HANDLE;
pragma Import (Stdcall, CreateFileW, "CreateFileW");
procedure CloseFile (fd: Sysdef.HANDLE);
pragma Import (Stdcall, CloseFile, "CloseFile");
function ReadFile (fd: Sysdef.HANDLE; buf: in System.Address; count: in Sysdef.size_t) return Sysdef.ssize_t;
pragma Import (Stdcall, ReadFile, "ReadFile");
function Sys_Write (fd: Sysdef.HANDLE; buf: in System.Address; count: in Sysdef.size_t) return Sysdef.ssize_t;
pragma Import (Stdcall, WriteFile, "WriteFile");
-- Common constants
INVALID_HANDLE: constant := -1;
ERROR_RETURN: constant := -1;
-- File record
type Posix_File_Record is new File_Record with record
Pool: Storage_Pool_Pointer := null;
Handle: Sysdef.int_t := INVALID_HANDLE;
end record;
type Posix_File_Pointer is access all Posix_File_Record;
-- Standard Files
Stdin: aliased Posix_File_Record := (null, 0);
Stdout: aliased Posix_File_Record := (null, 1);
Stderr: aliased Posix_File_Record := (null, 2);
function Flag_To_System (Bits: in Flag_Bits) return System_Word is
V: System_Word := 0;
begin
if ((Bits and FLAG_READ) /= 0) and then
((Bits and FLAG_WRITE) /= 0) then
V := V or Sysdef.O_RDWR;
elsif ((Bits and FLAG_WRITE) /= 0) then
V := V or Sysdef.O_WRONLY;
else
V := V or Sysdef.O_RDONLY;
end if;
if (Bits and FLAG_CREATE) /= 0 then
V := V or Sysdef.O_CREAT;
end if;
if (Bits and FLAG_TRUNCATE) /= 0 then
V := V or Sysdef.O_TRUNC;
end if;
if (Bits and FLAG_APPEND) /= 0 then
V := V or Sysdef.O_APPEND;
end if;
if (Bits and FLAG_NONBLOCK) /= 0 then
V := V or Sysdef.O_NONBLOCK;
end if;
if (Bits and FLAG_SYNC) /= 0 then
V := V or Sysdef.O_SYNC;
end if;
return V;
end Flag_To_System;
function Get_Stdin return File_Pointer is
begin
--return File_Pointer'(Stdin'Access);
return File_Record(Stdin)'Access;
end Get_Stdin;
function Get_Stdout return File_Pointer is
begin
--return File_Pointer'(Stdout'Access);
return File_Record(Stdout)'Access;
end Get_Stdout;
function Get_Stderr return File_Pointer is
begin
--return File_Pointer'(Stderr'Access);
return File_Record(Stdout)'Access;
end Get_Stderr;
procedure Open (File: out File_Pointer;
Name: in Slim_String;
Flag: in Flag_Record;
Mode: in Mode_Record := DEFAULT_MODE;
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 (Name & Slim_Character'Val(0),
Sysdef.int_t(Flag_To_System(Flag.Bits)),
Sysdef.int_t(Mode.Bits));
if Sysdef."<=" (F.Handle, INVALID_HANDLE) 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 := DEFAULT_MODE;
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 := Posix_File_Pointer(File);
begin
if F /= Stdin'Access and then F /= Stdout'Access and then F /= Stderr'Access then
-- Don't close standard files.
Sys_Close (F.Handle);
F.Handle := INVALID_HANDLE;
declare
package P is new H2.Pool (Posix_File_Record, Posix_File_Pointer, F.Pool);
begin
P.Deallocate (F);
end;
File := null;
end if;
end Close;
procedure Read (File: in File_Pointer;
Buffer: out System_Byte_Array;
Length: out System_Length) is
pragma Assert (Buffer'Length > 0);
F: Posix_File_Pointer := Posix_File_Pointer(File);
N: Sysdef.ssize_t;
begin
N := Sys_Read (F.Handle, Buffer'Address, Buffer'Length);
if Sysdef."<=" (N, ERROR_RETURN) then
raise Constraint_Error; -- TODO rename exception
else
Length := System_Length(N);
end if;
end Read;
procedure Write (File: in File_Pointer;
Buffer: in System_Byte_Array;
Length: out System_Length) is
pragma Assert (Buffer'Length > 0);
F: Posix_File_Pointer := Posix_File_Pointer(File);
N: Sysdef.ssize_t;
begin
N := Sys_Write (F.Handle, Buffer'Address, Buffer'Length);
if Sysdef."<=" (N, ERROR_RETURN) then
raise Constraint_Error; -- TODO rename exception
else
Length := System_Length(N);
end if;
end Write;
end File;

10
lib/win32/h2-sysdef.ads Normal file
View File

@ -0,0 +1,10 @@
with System;
package H2.Sysdef is
type PVOID is System.Address;
subtype HANDLE is PVOID;
type DWORD is mod 2 ** 32;
end H2.Sysdef;