diff --git a/cmd/scheme.adb b/cmd/scheme.adb index 9763807..e7cd8de 100644 --- a/cmd/scheme.adb +++ b/cmd/scheme.adb @@ -33,8 +33,8 @@ procedure scheme is String_Stream: Stream.String_Input_Stream_Record (String'Unchecked_Access); --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 := "시험.scm"; + File_Name: aliased Scheme.Object_Character_Array := "test.adb"; + --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; @@ -107,33 +107,41 @@ ada.text_io.put_line ("------------------"); File.Set_Flag_Bits (FL, File.FLAG_NONBLOCK); File.Open (F, H2.Slim.String'("/tmp/xxx"), FL); + --Option := File.Get_Option(F2); File.Clear_Flag_Bits (FL, FL.Bits); File.Set_Flag_Bits (FL, File.FLAG_WRITE); File.Set_Flag_Bits (FL, File.FLAG_CREATE); File.Set_Flag_Bits (FL, File.FLAG_TRUNCATE); 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 (F, Option); 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))); --File.Read (F, BufferW, IL); 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); --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))); end loop; - File.Write (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'(""), OL); + --File.Write (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'(""), OL); File.Close (F2); File.Close (F); diff --git a/lib/ascii.awk b/lib/ascii.awk index 837fe9d..9bee7ba 100644 --- a/lib/ascii.awk +++ b/lib/ascii.awk @@ -3,9 +3,12 @@ BEGIN { 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 ("generic\n\ttype Character_Type is (<>);\npackage H2.Ascii is\n\n"); - printf ("\tpragma Preelaborate (Ascii);\n\n"); - printf ("\tpackage Pos is\n"); + printf ("generic\n"); + printf ("\ttype Slim_Character 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 { - printf ("\tend Pos;\n\n"); + printf ("\tend Code;\n\n"); + + printf ("\tpackage Slim is\n"); 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"); } diff --git a/lib/h2-ascii.ads b/lib/h2-ascii.ads index dc65309..04aa60a 100644 --- a/lib/h2-ascii.ads +++ b/lib/h2-ascii.ads @@ -2,12 +2,11 @@ -- Run qseawk -f ascii.awk ascii.txt > h2-ascii.ads for regeneration generic - type Character_Type is (<>); + type Slim_Character is (<>); + type Wide_Character is (<>); package H2.Ascii is - --pragma Preelaborate (Ascii); - - package Pos is + package Code is NUL : constant := 0; SOH : constant := 1; STX : constant := 2; @@ -136,135 +135,268 @@ package H2.Ascii is Right_Curly_Bracket : constant := 125; -- } Tilde : constant := 126; -- ~ DEL : constant := 127; - end Pos; + end Code; - NUL : constant Character_Type := Character_Type'Val(Pos.NUL); - SOH : constant Character_Type := Character_Type'Val(Pos.SOH); - STX : constant Character_Type := Character_Type'Val(Pos.STX); - ETX : constant Character_Type := Character_Type'Val(Pos.ETX); - EOT : constant Character_Type := Character_Type'Val(Pos.EOT); - ENQ : constant Character_Type := Character_Type'Val(Pos.ENQ); - ACK : constant Character_Type := Character_Type'Val(Pos.ACK); - BEL : constant Character_Type := Character_Type'Val(Pos.BEL); - BS : constant Character_Type := Character_Type'Val(Pos.BS); - HT : constant Character_Type := Character_Type'Val(Pos.HT); - LF : constant Character_Type := Character_Type'Val(Pos.LF); - VT : constant Character_Type := Character_Type'Val(Pos.VT); - FF : constant Character_Type := Character_Type'Val(Pos.FF); - CR : constant Character_Type := Character_Type'Val(Pos.CR); - SO : constant Character_Type := Character_Type'Val(Pos.SO); - SI : constant Character_Type := Character_Type'Val(Pos.SI); - DLE : constant Character_Type := Character_Type'Val(Pos.DLE); - DC1 : constant Character_Type := Character_Type'Val(Pos.DC1); - DC2 : constant Character_Type := Character_Type'Val(Pos.DC2); - DC3 : constant Character_Type := Character_Type'Val(Pos.DC3); - DC4 : constant Character_Type := Character_Type'Val(Pos.DC4); - NAK : constant Character_Type := Character_Type'Val(Pos.NAK); - SYN : constant Character_Type := Character_Type'Val(Pos.SYN); - ETB : constant Character_Type := Character_Type'Val(Pos.ETB); - CAN : constant Character_Type := Character_Type'Val(Pos.CAN); - EM : constant Character_Type := Character_Type'Val(Pos.EM); - SUB : constant Character_Type := Character_Type'Val(Pos.SUB); - ESC : constant Character_Type := Character_Type'Val(Pos.ESC); - FS : constant Character_Type := Character_Type'Val(Pos.FS); - GS : constant Character_Type := Character_Type'Val(Pos.GS); - RS : constant Character_Type := Character_Type'Val(Pos.RS); - US : constant Character_Type := Character_Type'Val(Pos.US); - Space : constant Character_Type := Character_Type'Val(Pos.Space); - Exclamation : constant Character_Type := Character_Type'Val(Pos.Exclamation); - Quotation : constant Character_Type := Character_Type'Val(Pos.Quotation); - Number_Sign : constant Character_Type := Character_Type'Val(Pos.Number_Sign); - Dollar_Sign : constant Character_Type := Character_Type'Val(Pos.Dollar_Sign); - Percent_Sign : constant Character_Type := Character_Type'Val(Pos.Percent_Sign); - Ampersand : constant Character_Type := Character_Type'Val(Pos.Ampersand); - Apostrophe : constant Character_Type := Character_Type'Val(Pos.Apostrophe); - Left_Parenthesis : constant Character_Type := Character_Type'Val(Pos.Left_Parenthesis); - Right_Parenthesis : constant Character_Type := Character_Type'Val(Pos.Right_Parenthesis); - Asterisk : constant Character_Type := Character_Type'Val(Pos.Asterisk); - Plus_Sign : constant Character_Type := Character_Type'Val(Pos.Plus_Sign); - Comma : constant Character_Type := Character_Type'Val(Pos.Comma); - Minus_Sign : constant Character_Type := Character_Type'Val(Pos.Minus_Sign); - Period : constant Character_Type := Character_Type'Val(Pos.Period); - Slash : constant Character_Type := Character_Type'Val(Pos.Slash); - Zero : constant Character_Type := Character_Type'Val(Pos.Zero); - One : constant Character_Type := Character_Type'Val(Pos.One); - Two : constant Character_Type := Character_Type'Val(Pos.Two); - Three : constant Character_Type := Character_Type'Val(Pos.Three); - Four : constant Character_Type := Character_Type'Val(Pos.Four); - Five : constant Character_Type := Character_Type'Val(Pos.Five); - Six : constant Character_Type := Character_Type'Val(Pos.Six); - Seven : constant Character_Type := Character_Type'Val(Pos.Seven); - Eight : constant Character_Type := Character_Type'Val(Pos.Eight); - Nine : constant Character_Type := Character_Type'Val(Pos.Nine); - Colon : constant Character_Type := Character_Type'Val(Pos.Colon); - Semicolon : constant Character_Type := Character_Type'Val(Pos.Semicolon); - Less_Than_Sign : constant Character_Type := Character_Type'Val(Pos.Less_Than_Sign); - Equal_Sign : constant Character_Type := Character_Type'Val(Pos.Equal_Sign); - Greater_Than_Sign : constant Character_Type := Character_Type'Val(Pos.Greater_Than_Sign); - Question : constant Character_Type := Character_Type'Val(Pos.Question); - Commercial_At : constant Character_Type := Character_Type'Val(Pos.Commercial_At); - UC_A : constant Character_Type := Character_Type'Val(Pos.UC_A); - UC_B : constant Character_Type := Character_Type'Val(Pos.UC_B); - UC_C : constant Character_Type := Character_Type'Val(Pos.UC_C); - UC_D : constant Character_Type := Character_Type'Val(Pos.UC_D); - UC_E : constant Character_Type := Character_Type'Val(Pos.UC_E); - UC_F : constant Character_Type := Character_Type'Val(Pos.UC_F); - UC_G : constant Character_Type := Character_Type'Val(Pos.UC_G); - UC_H : constant Character_Type := Character_Type'Val(Pos.UC_H); - UC_I : constant Character_Type := Character_Type'Val(Pos.UC_I); - UC_J : constant Character_Type := Character_Type'Val(Pos.UC_J); - UC_K : constant Character_Type := Character_Type'Val(Pos.UC_K); - UC_L : constant Character_Type := Character_Type'Val(Pos.UC_L); - UC_M : constant Character_Type := Character_Type'Val(Pos.UC_M); - UC_N : constant Character_Type := Character_Type'Val(Pos.UC_N); - UC_O : constant Character_Type := Character_Type'Val(Pos.UC_O); - UC_P : constant Character_Type := Character_Type'Val(Pos.UC_P); - UC_Q : constant Character_Type := Character_Type'Val(Pos.UC_Q); - UC_R : constant Character_Type := Character_Type'Val(Pos.UC_R); - UC_S : constant Character_Type := Character_Type'Val(Pos.UC_S); - UC_T : constant Character_Type := Character_Type'Val(Pos.UC_T); - UC_U : constant Character_Type := Character_Type'Val(Pos.UC_U); - UC_V : constant Character_Type := Character_Type'Val(Pos.UC_V); - UC_W : constant Character_Type := Character_Type'Val(Pos.UC_W); - UC_X : constant Character_Type := Character_Type'Val(Pos.UC_X); - UC_Y : constant Character_Type := Character_Type'Val(Pos.UC_Y); - UC_Z : constant Character_Type := Character_Type'Val(Pos.UC_Z); - Left_Square_Bracket : constant Character_Type := Character_Type'Val(Pos.Left_Square_Bracket); - Backslash : constant Character_Type := Character_Type'Val(Pos.Backslash); - Right_Square_Bracket: constant Character_Type := Character_Type'Val(Pos.Right_Square_Bracket); - Circumflex : constant Character_Type := Character_Type'Val(Pos.Circumflex); - Low_Line : constant Character_Type := Character_Type'Val(Pos.Low_Line); - Grave : constant Character_Type := Character_Type'Val(Pos.Grave); - LC_A : constant Character_Type := Character_Type'Val(Pos.LC_A); - LC_B : constant Character_Type := Character_Type'Val(Pos.LC_B); - LC_C : constant Character_Type := Character_Type'Val(Pos.LC_C); - LC_D : constant Character_Type := Character_Type'Val(Pos.LC_D); - LC_E : constant Character_Type := Character_Type'Val(Pos.LC_E); - LC_F : constant Character_Type := Character_Type'Val(Pos.LC_F); - LC_G : constant Character_Type := Character_Type'Val(Pos.LC_G); - LC_H : constant Character_Type := Character_Type'Val(Pos.LC_H); - LC_I : constant Character_Type := Character_Type'Val(Pos.LC_I); - LC_J : constant Character_Type := Character_Type'Val(Pos.LC_J); - LC_K : constant Character_Type := Character_Type'Val(Pos.LC_K); - LC_L : constant Character_Type := Character_Type'Val(Pos.LC_L); - LC_M : constant Character_Type := Character_Type'Val(Pos.LC_M); - LC_N : constant Character_Type := Character_Type'Val(Pos.LC_N); - LC_O : constant Character_Type := Character_Type'Val(Pos.LC_O); - LC_P : constant Character_Type := Character_Type'Val(Pos.LC_P); - LC_Q : constant Character_Type := Character_Type'Val(Pos.LC_Q); - LC_R : constant Character_Type := Character_Type'Val(Pos.LC_R); - LC_S : constant Character_Type := Character_Type'Val(Pos.LC_S); - LC_T : constant Character_Type := Character_Type'Val(Pos.LC_T); - LC_U : constant Character_Type := Character_Type'Val(Pos.LC_U); - LC_V : constant Character_Type := Character_Type'Val(Pos.LC_V); - LC_W : constant Character_Type := Character_Type'Val(Pos.LC_W); - LC_X : constant Character_Type := Character_Type'Val(Pos.LC_X); - LC_Y : constant Character_Type := Character_Type'Val(Pos.LC_Y); - LC_Z : constant Character_Type := Character_Type'Val(Pos.LC_Z); - Left_Curly_Bracket : constant Character_Type := Character_Type'Val(Pos.Left_Curly_Bracket); - Vertical_Line : constant Character_Type := Character_Type'Val(Pos.Vertical_Line); - Right_Curly_Bracket : constant Character_Type := Character_Type'Val(Pos.Right_Curly_Bracket); - Tilde : constant Character_Type := Character_Type'Val(Pos.Tilde); - DEL : constant Character_Type := Character_Type'Val(Pos.DEL); + package Slim is + NUL : constant Slim_Character := Slim_Character'Val(Code.NUL); + SOH : constant Slim_Character := Slim_Character'Val(Code.SOH); + STX : constant Slim_Character := Slim_Character'Val(Code.STX); + ETX : constant Slim_Character := Slim_Character'Val(Code.ETX); + EOT : constant Slim_Character := Slim_Character'Val(Code.EOT); + ENQ : constant Slim_Character := Slim_Character'Val(Code.ENQ); + ACK : constant Slim_Character := Slim_Character'Val(Code.ACK); + BEL : constant Slim_Character := Slim_Character'Val(Code.BEL); + BS : constant Slim_Character := Slim_Character'Val(Code.BS); + HT : constant Slim_Character := Slim_Character'Val(Code.HT); + LF : constant Slim_Character := Slim_Character'Val(Code.LF); + VT : constant Slim_Character := Slim_Character'Val(Code.VT); + FF : constant Slim_Character := Slim_Character'Val(Code.FF); + CR : constant Slim_Character := Slim_Character'Val(Code.CR); + SO : constant Slim_Character := Slim_Character'Val(Code.SO); + SI : constant Slim_Character := Slim_Character'Val(Code.SI); + DLE : constant Slim_Character := Slim_Character'Val(Code.DLE); + DC1 : constant Slim_Character := Slim_Character'Val(Code.DC1); + DC2 : constant Slim_Character := Slim_Character'Val(Code.DC2); + DC3 : constant Slim_Character := Slim_Character'Val(Code.DC3); + DC4 : constant Slim_Character := Slim_Character'Val(Code.DC4); + NAK : constant Slim_Character := Slim_Character'Val(Code.NAK); + SYN : constant Slim_Character := Slim_Character'Val(Code.SYN); + ETB : constant Slim_Character := Slim_Character'Val(Code.ETB); + CAN : constant Slim_Character := Slim_Character'Val(Code.CAN); + EM : constant Slim_Character := Slim_Character'Val(Code.EM); + SUB : constant Slim_Character := Slim_Character'Val(Code.SUB); + ESC : constant Slim_Character := Slim_Character'Val(Code.ESC); + FS : constant Slim_Character := Slim_Character'Val(Code.FS); + GS : constant Slim_Character := Slim_Character'Val(Code.GS); + RS : constant Slim_Character := Slim_Character'Val(Code.RS); + US : constant Slim_Character := Slim_Character'Val(Code.US); + Space : constant Slim_Character := Slim_Character'Val(Code.Space); + Exclamation : constant Slim_Character := Slim_Character'Val(Code.Exclamation); + Quotation : constant Slim_Character := Slim_Character'Val(Code.Quotation); + Number_Sign : constant Slim_Character := Slim_Character'Val(Code.Number_Sign); + Dollar_Sign : constant Slim_Character := Slim_Character'Val(Code.Dollar_Sign); + Percent_Sign : constant Slim_Character := Slim_Character'Val(Code.Percent_Sign); + Ampersand : constant Slim_Character := Slim_Character'Val(Code.Ampersand); + Apostrophe : constant Slim_Character := Slim_Character'Val(Code.Apostrophe); + Left_Parenthesis : constant Slim_Character := Slim_Character'Val(Code.Left_Parenthesis); + Right_Parenthesis : constant Slim_Character := Slim_Character'Val(Code.Right_Parenthesis); + Asterisk : constant Slim_Character := Slim_Character'Val(Code.Asterisk); + Plus_Sign : constant Slim_Character := Slim_Character'Val(Code.Plus_Sign); + Comma : constant Slim_Character := Slim_Character'Val(Code.Comma); + Minus_Sign : constant Slim_Character := Slim_Character'Val(Code.Minus_Sign); + Period : constant Slim_Character := Slim_Character'Val(Code.Period); + Slash : constant Slim_Character := Slim_Character'Val(Code.Slash); + Zero : constant Slim_Character := Slim_Character'Val(Code.Zero); + One : constant Slim_Character := Slim_Character'Val(Code.One); + Two : constant Slim_Character := Slim_Character'Val(Code.Two); + Three : constant Slim_Character := Slim_Character'Val(Code.Three); + Four : constant Slim_Character := Slim_Character'Val(Code.Four); + Five : constant Slim_Character := Slim_Character'Val(Code.Five); + Six : constant Slim_Character := Slim_Character'Val(Code.Six); + Seven : constant Slim_Character := Slim_Character'Val(Code.Seven); + Eight : constant Slim_Character := Slim_Character'Val(Code.Eight); + Nine : constant Slim_Character := Slim_Character'Val(Code.Nine); + Colon : constant Slim_Character := Slim_Character'Val(Code.Colon); + Semicolon : constant Slim_Character := Slim_Character'Val(Code.Semicolon); + Less_Than_Sign : constant Slim_Character := Slim_Character'Val(Code.Less_Than_Sign); + Equal_Sign : constant Slim_Character := Slim_Character'Val(Code.Equal_Sign); + Greater_Than_Sign : constant Slim_Character := Slim_Character'Val(Code.Greater_Than_Sign); + Question : constant Slim_Character := Slim_Character'Val(Code.Question); + Commercial_At : constant Slim_Character := Slim_Character'Val(Code.Commercial_At); + UC_A : constant Slim_Character := Slim_Character'Val(Code.UC_A); + UC_B : constant Slim_Character := Slim_Character'Val(Code.UC_B); + UC_C : constant Slim_Character := Slim_Character'Val(Code.UC_C); + UC_D : constant Slim_Character := Slim_Character'Val(Code.UC_D); + UC_E : constant Slim_Character := Slim_Character'Val(Code.UC_E); + UC_F : constant Slim_Character := Slim_Character'Val(Code.UC_F); + UC_G : constant Slim_Character := Slim_Character'Val(Code.UC_G); + UC_H : constant Slim_Character := Slim_Character'Val(Code.UC_H); + UC_I : constant Slim_Character := Slim_Character'Val(Code.UC_I); + UC_J : constant Slim_Character := Slim_Character'Val(Code.UC_J); + UC_K : constant Slim_Character := Slim_Character'Val(Code.UC_K); + UC_L : constant Slim_Character := Slim_Character'Val(Code.UC_L); + UC_M : constant Slim_Character := Slim_Character'Val(Code.UC_M); + UC_N : constant Slim_Character := Slim_Character'Val(Code.UC_N); + UC_O : constant Slim_Character := Slim_Character'Val(Code.UC_O); + UC_P : constant Slim_Character := Slim_Character'Val(Code.UC_P); + UC_Q : constant Slim_Character := Slim_Character'Val(Code.UC_Q); + UC_R : constant Slim_Character := Slim_Character'Val(Code.UC_R); + UC_S : constant Slim_Character := Slim_Character'Val(Code.UC_S); + UC_T : constant Slim_Character := Slim_Character'Val(Code.UC_T); + UC_U : constant Slim_Character := Slim_Character'Val(Code.UC_U); + UC_V : constant Slim_Character := Slim_Character'Val(Code.UC_V); + UC_W : constant Slim_Character := Slim_Character'Val(Code.UC_W); + UC_X : constant Slim_Character := Slim_Character'Val(Code.UC_X); + UC_Y : constant Slim_Character := Slim_Character'Val(Code.UC_Y); + UC_Z : constant Slim_Character := Slim_Character'Val(Code.UC_Z); + Left_Square_Bracket : constant Slim_Character := Slim_Character'Val(Code.Left_Square_Bracket); + Backslash : constant Slim_Character := Slim_Character'Val(Code.Backslash); + Right_Square_Bracket: constant Slim_Character := Slim_Character'Val(Code.Right_Square_Bracket); + Circumflex : constant Slim_Character := Slim_Character'Val(Code.Circumflex); + Low_Line : constant Slim_Character := Slim_Character'Val(Code.Low_Line); + Grave : constant Slim_Character := Slim_Character'Val(Code.Grave); + LC_A : constant Slim_Character := Slim_Character'Val(Code.LC_A); + LC_B : constant Slim_Character := Slim_Character'Val(Code.LC_B); + LC_C : constant Slim_Character := Slim_Character'Val(Code.LC_C); + LC_D : constant Slim_Character := Slim_Character'Val(Code.LC_D); + LC_E : constant Slim_Character := Slim_Character'Val(Code.LC_E); + LC_F : constant Slim_Character := Slim_Character'Val(Code.LC_F); + LC_G : constant Slim_Character := Slim_Character'Val(Code.LC_G); + LC_H : constant Slim_Character := Slim_Character'Val(Code.LC_H); + LC_I : constant Slim_Character := Slim_Character'Val(Code.LC_I); + LC_J : constant Slim_Character := Slim_Character'Val(Code.LC_J); + LC_K : constant Slim_Character := Slim_Character'Val(Code.LC_K); + LC_L : constant Slim_Character := Slim_Character'Val(Code.LC_L); + LC_M : constant Slim_Character := Slim_Character'Val(Code.LC_M); + LC_N : constant Slim_Character := Slim_Character'Val(Code.LC_N); + LC_O : constant Slim_Character := Slim_Character'Val(Code.LC_O); + LC_P : constant Slim_Character := Slim_Character'Val(Code.LC_P); + LC_Q : constant Slim_Character := Slim_Character'Val(Code.LC_Q); + LC_R : constant Slim_Character := Slim_Character'Val(Code.LC_R); + LC_S : constant Slim_Character := Slim_Character'Val(Code.LC_S); + LC_T : constant Slim_Character := Slim_Character'Val(Code.LC_T); + LC_U : constant Slim_Character := Slim_Character'Val(Code.LC_U); + LC_V : constant Slim_Character := Slim_Character'Val(Code.LC_V); + LC_W : constant Slim_Character := Slim_Character'Val(Code.LC_W); + LC_X : constant Slim_Character := Slim_Character'Val(Code.LC_X); + LC_Y : constant Slim_Character := Slim_Character'Val(Code.LC_Y); + LC_Z : constant Slim_Character := Slim_Character'Val(Code.LC_Z); + Left_Curly_Bracket : constant Slim_Character := Slim_Character'Val(Code.Left_Curly_Bracket); + Vertical_Line : constant Slim_Character := Slim_Character'Val(Code.Vertical_Line); + Right_Curly_Bracket : constant Slim_Character := Slim_Character'Val(Code.Right_Curly_Bracket); + 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; diff --git a/lib/h2-io-file.adb b/lib/h2-io-file.adb index 6689081..067abac 100644 --- a/lib/h2-io-file.adb +++ b/lib/h2-io-file.adb @@ -4,9 +4,6 @@ separate (H2.IO) package body File is - package Slim_Ascii renames IO.Slim_Ascii; - package Wide_Ascii renames IO.Wide_Ascii; - --|----------------------------------------------------------------------- --| PRIVATE ROUTINES --|----------------------------------------------------------------------- @@ -52,13 +49,8 @@ package body File is Buf.Last := Buf.Pos + 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; - Bits: in Option_Bits) is + Bits: in Option_Bits) is begin Option.Bits := Option.Bits or Bits; end Set_Option_Bits; @@ -69,6 +61,11 @@ package body File is Option.Bits := Option.Bits and not 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 --|----------------------------------------------------------------------- @@ -88,9 +85,8 @@ package body File is Set_Length (File.Rbuf, 0); Set_Length (File.Wbuf, 0); + File.Option := Get_Default_Option; File.EOF := Standard.False; - --File.Slim_Line_Break := Get_Line_Terminator; - --File.Wide_Line_Break := Get_Line_Terminator; end Open; procedure Open (File: in out File_Record; @@ -104,9 +100,8 @@ package body File is Set_Length (File.Rbuf, 0); Set_Length (File.Wbuf, 0); + File.Option := Get_Default_Option; File.EOF := Standard.False; - --File.Slim_Line_Break := Get_Line_Terminator; - --File.Wide_Line_Break := Get_Line_Terminator; end Open; 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 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; end Set_Option; @@ -256,7 +256,7 @@ package body File is K := K + 1; File.Rbuf.Pos := File.Rbuf.Pos + 1; 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 end if; end loop; @@ -275,29 +275,39 @@ package body File is begin Read_Line (File, Buffer, Length); - if Length >= 1 then - Last := Buffer'First + Length - 1; - if Buffer(Last) = Slim_Ascii.LF then - 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 Length <= 0 or else (File.Option.Bits and OPTION_CRLF_IN) = 0 then + return; + end if; - if not Is_Empty(File.Rbuf) then - if File.Rbuf.Data(File.Rbuf.Pos + 1) = Slim_Ascii.Pos.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_Ascii.LF; - end if; + Last := Buffer'First + Length - 1; + if Buffer(Last) = Slim_Character'Val(File.Option.LF) then + if Last > Buffer'First and then + Buffer(Last - 1) = Slim_Character'Val(File.Option.CR) then + + + -- 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; + + 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 Get_Line; --|----------------------------------------------------------------------- @@ -306,7 +316,7 @@ package body File is procedure Read_Wide (File: in out File_Record; Buffer: out Wide_String; Length: out System_Length; - Terminator: in Wide_String) is + Terminator: in Wide_Character) is pragma Assert (Is_Open(File)); pragma Assert (Buffer'Length > 0); @@ -332,7 +342,7 @@ package body File is if L3 <= 0 then -- Potentially illegal sequence K := K + 1; - Outbuf(K) := Wide_Ascii.Question; + Outbuf(K) := Ascii.Wide.Question; File.Rbuf.Pos := I; else 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)); exception when others => - Outbuf(K) := Wide_Ascii.Question; + Outbuf(K) := Ascii.Wide.Question; J := I; -- Override J to skip 1 byte only. end; File.Rbuf.Pos := J; end if; - if Terminator'Length > 0 and then - Outbuf(K) = Terminator(Terminator'First) then - -- TODO: compare more characters in terminator, not just the first charactrer + if Terminator /= Wide_Character'First and then Outbuf(K) = Terminator then exit outer; end if; end loop; @@ -367,17 +375,15 @@ package body File is procedure Read (File: in out File_Record; Buffer: out Wide_String; Length: out System_Length) is - Terminator: Wide_String(1..0); begin - Read_Wide (File, Buffer, Length, Terminator); + Read_Wide (File, Buffer, Length, Wide_Character'First); end Read; procedure Read_Line (File: in out File_Record; Buffer: out Wide_String; Length: out System_Length) is - Terminator: constant Wide_String(1..1) := (1 => Wide_Ascii.LF); begin - Read_Wide (File, Buffer, Length, Terminator); + Read_Wide (File, Buffer, Length, Wide_Character'Val(File.Option.LF)); end Read_Line; procedure Get_Line (File: in out File_Record; @@ -390,50 +396,70 @@ package body File is begin Read_Line (File, Buffer, Length); - if Length >= 1 then - Last := Buffer'First + Length - 1; - if Buffer(Last) = Wide_Ascii.LF then - if Last > Buffer'First and then Buffer(Last - 1) = Wide_Ascii.CR then - -- Switch CR/LF to LF - 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 Length <= 0 or else (File.Option.Bits and OPTION_CRLF_IN) = 0 then + return; + end if; + + Last := Buffer'First + Length - 1; - if not Is_Empty(File.Rbuf) then - 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 - J := File.Rbuf.Pos + L3; - begin - W := Slim_To_Wide(Inbuf(I .. J)); - exception - when others => - W(1) := Wide_Ascii.NUL; - end; - if W(1) = Wide_Ascii.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_Ascii.LF; - end if; - end if; - end; + if Buffer(Last) = Wide_Character'Val(File.Option.LF) then + -- if the last character in the output bufer is LF. + -- inspect the previous character to check if it's CR. + + if Last > Buffer'First and then + Buffer(Last - 1) = Wide_Character'Val(File.Option.CR) then + -- Switch CR/LF to LF + Length := Length - 1; + Buffer(Last - 1) := Wide_Character'Val(File.Option.LF); + end if; + + elsif Buffer(Last) = Wide_Character'Val(File.Option.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); + + if Is_Empty(File.Rbuf) then + -- no more data available. + return; 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 Get_Line; --|----------------------------------------------------------------------- @@ -521,7 +547,7 @@ package body File is I := I + 1; File.Wbuf.Last := File.Wbuf.Last + 1; 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 LF := File.Wbuf.Last; end if; @@ -560,9 +586,9 @@ package body File is I := Inbuf'First - 1; while I < Inbuf'Last loop - if (File.Option.Bits and OPTION_CRLF) /= 0 and then - not Injected and then Inbuf(I + 1) = Slim_Ascii.Pos.LF then - X := Slim_Ascii.Pos.CR; + if (File.Option.Bits and OPTION_CRLF_OUT) /= 0 and then + not Injected and then Inbuf(I + 1) = File.Option.LF then + X := File.Option.CR; Injected := Standard.True; else I := I + 1; @@ -578,7 +604,7 @@ package body File is File.Wbuf.Last := File.Wbuf.Last + 1; 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 LF := File.Wbuf.Last; end if; @@ -667,7 +693,7 @@ package body File is LF := File.Wbuf.Data'First - 1; 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; end if; @@ -696,7 +722,7 @@ package body File is pragma Assert (Is_Open(File)); 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 LF := File.Wbuf.Data'First - 1; @@ -705,8 +731,8 @@ package body File is I := I + 1; X(2) := Buffer(I); - if (File.Option.Bits and OPTION_CRLF) /= 0 and then - Buffer(I) = Wide_Ascii.LF then + if (File.Option.Bits and OPTION_CRLF_OUT) /= 0 and then + Buffer(I) = Wide_Character'Val(File.Option.LF) then F := 1; else F := 2; @@ -729,7 +755,7 @@ package body File is LF := File.Wbuf.Data'First - 1; end if; - if Buffer(I) = Wide_Ascii.LF then + if Buffer(I) = Wide_Character'Val(File.Option.LF) then LF := L; end if; diff --git a/lib/h2-io.adb b/lib/h2-io.adb index 878dead..cb9414b 100644 --- a/lib/h2-io.adb +++ b/lib/h2-io.adb @@ -4,8 +4,4 @@ package body H2.IO is 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; diff --git a/lib/h2-io.ads b/lib/h2-io.ads index d91d5dd..4804f08 100644 --- a/lib/h2-io.ads +++ b/lib/h2-io.ads @@ -13,11 +13,7 @@ generic 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 Slim_Ascii is new H2.Ascii (Slim_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 Ascii is new H2.Ascii (Slim_Character, Wide_Character); package File is @@ -37,10 +33,13 @@ package H2.IO is type Option_Bits is new System_Word; type Option_Record is record Bits: Option_Bits := 0; + LF: System_Byte := Ascii.Code.LF; + CR: System_Byte := Ascii.Code.CR; end record; -- 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_Record is limited private; @@ -52,7 +51,7 @@ package H2.IO is Bits: in Flag_Bits) renames OS.File.Clear_Flag_Bits; 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; Bits: in Option_Bits); @@ -155,10 +154,10 @@ package H2.IO is type File_Record is limited record File: OS.File.File_Pointer := null; + Option: Option_Record; Rbuf: File_Buffer; Wbuf: File_Buffer; EOF: Standard.Boolean := false; - Option: Option_Record; end record; end File; diff --git a/lib/h2-scheme-bigint.adb b/lib/h2-scheme-bigint.adb index 72ec0c8..664821d 100644 --- a/lib/h2-scheme-bigint.adb +++ b/lib/h2-scheme-bigint.adb @@ -121,9 +121,9 @@ package body Bigint is V := W rem Object_Word(Radix); 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 - 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; Len := Len + 1; @@ -1009,7 +1009,7 @@ package body Bigint is Convert_Word_To_Text (W, Radix, Buf, Len); if Sign = Negative_Sign then Len := Len + 1; - Buf(Len) := Ch.Minus_Sign; + Buf(Len) := Ch_Val.Minus_Sign; end if; return Make_String(Interp, Source => Buf(1 .. Len), Invert => Standard.True); end; @@ -1102,7 +1102,7 @@ package body Bigint is --for I in Seglen + 1 .. Block_Divisors(Radix).Length loop for I in Seglen + 1 .. BD.Length loop 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; @@ -1110,7 +1110,7 @@ package body Bigint is if Sign = Negative_Sign then Totlen := Totlen + 1; - Buf(Totlen) := Ch.Minus_Sign; + Buf(Totlen) := Ch_Val.Minus_Sign; end if; Z := Make_String(Interp.Self, Source => Buf(1 .. Totlen), Invert => Standard.True); @@ -1142,14 +1142,14 @@ package body Bigint is begin Pos := Object_Character'Pos(C); case Pos is - when Ch.Pos.Zero .. Ch.Pos.Nine => - Pos := Pos - Ch.Pos.Zero; + when Ch_Code.Zero .. Ch_Code.Nine => + Pos := Pos - Ch_Code.Zero; - when Ch.Pos.LC_A .. Ch.Pos.LC_Z => - Pos := Pos - Ch.Pos.LC_A + 10; + when Ch_Code.LC_A .. Ch_Code.LC_Z => + Pos := Pos - Ch_Code.LC_A + 10; - when Ch.Pos.UC_A .. Ch.Pos.UC_Z => - Pos := Pos - Ch.Pos.UC_A + 10; + when Ch_Code.UC_A .. Ch_Code.UC_Z => + Pos := Pos - Ch_Code.UC_A + 10; when others => Pos := -1; @@ -1173,9 +1173,9 @@ package body Bigint is Sign := Positive_Sign; Idx := X'First; if Idx <= X'Last then - if X(Idx) = Ch.Plus_Sign then + if X(Idx) = Ch_Val.Plus_Sign then Idx := Idx + 1; - elsif X(Idx) = Ch.Minus_Sign then + elsif X(Idx) = Ch_Val.Minus_Sign then Idx := Idx + 1; Sign := Negative_Sign; end if; @@ -1190,7 +1190,7 @@ package body Bigint is -- Find the first non-zero digit while Idx <= X'Last loop - exit when X(Idx) /= Ch.Zero; + exit when X(Idx) /= Ch_Val.Zero; Idx := Idx + 1; end loop; if Idx > X'Last then diff --git a/lib/h2-scheme-execute.adb b/lib/h2-scheme-execute.adb index 5dcf932..c51f9ea 100644 --- a/lib/h2-scheme-execute.adb +++ b/lib/h2-scheme-execute.adb @@ -583,14 +583,14 @@ procedure Execute (Interp: in out Interpreter_Record) is function Is_White_Space (X: in Object_Character) return Standard.Boolean is begin - return X = Ch.Space or else X = Ch.HT or else X = Ch.VT or else - X = Ch.CR or else X = Ch.LF or else X = Ch.FF; + return X = Ch_Val.Space or else X = Ch_Val.HT or else X = Ch_Val.VT or else + X = Ch_Val.CR or else X = Ch_Val.LF or else X = Ch_Val.FF; end Is_White_Space; function Is_Delimiter (X: in Object_Character) return Standard.Boolean is begin - return X = Ch.Left_Parenthesis or else X = Ch.Right_Parenthesis or else - X = Ch.Quotation or else X = Ch.Semicolon or else + return X = Ch_Val.Left_Parenthesis or else X = Ch_Val.Right_Parenthesis or else + X = Ch_Val.Quotation or else X = Ch_Val.Semicolon or else Is_White_Space(X); end Is_Delimiter; @@ -602,13 +602,13 @@ procedure Execute (Interp: in out Interpreter_Record) is -- Normal character if Is_White_Space(LC.Value) then Fetch_Character; - elsif LC.Value = Ch.Semicolon then + elsif LC.Value = Ch_Val.Semicolon then -- Comment. loop Fetch_Character; 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 exit; end if; @@ -636,24 +636,24 @@ procedure Execute (Interp: in out Interpreter_Record) is -- TODO: Pass Token Location when calling Token.Set - -- Use Ch.Pos.XXX values instead of Ch.XXX values as gnat complained that - -- Ch.XXX values are not static. For this reason, "case LC.Value is ..." + -- Use Ch_Code.XXX values instead of Ch_Val.XXX values as gnat complained that + -- Ch_Val.XXX values are not static. For this reason, "case LC.Value is ..." -- changed to use Object_Character'Pos(LC.Value). 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); - when Ch.Pos.Right_Parenthesis => + when Ch_Code.Right_Parenthesis => Token.Set (Interp, Right_Parenthesis_Token, LC.Value); - when Ch.Pos.Period => + when Ch_Code.Period => Token.Set (Interp, Period_Token, LC.Value); - when Ch.Pos.Apostrophe => + when Ch_Code.Apostrophe => Token.Set (Interp, Single_Quote_Token, LC.Value); - when Ch.Pos.Number_Sign => + when Ch_Code.Number_Sign => Fetch_Character; if LC.Kind /= Normal_Character then -- ended prematurely. @@ -672,15 +672,15 @@ procedure Execute (Interp: in out Interpreter_Record) is -- #< > -- xxx case Object_Character'Pos(LC.Value) is - when Ch.Pos.LC_T => -- #t - Token.Set (Interp, True_Token, Ch.Number_Sign); + when Ch_Code.LC_T => -- #t + Token.Set (Interp, True_Token, Ch_Val.Number_Sign); Token.Append_Character (Interp, LC.Value); - when Ch.Pos.LC_F => -- #f - Token.Set (Interp, False_Token, Ch.Number_Sign); + when Ch_Code.LC_F => -- #f + Token.Set (Interp, False_Token, Ch_Val.Number_Sign); Token.Append_Character (Interp, LC.Value); - when Ch.Pos.Backslash => -- #\C, #\space, #\newline + when Ch_Code.Backslash => -- #\C, #\space, #\newline Fetch_Character; if LC.Kind /= Normal_Character then 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: #\xHHHH.... 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 - 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 -- 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; - --when Ch.Pos.Left_Parenthesis => -- #( - -- Token.Set (Interp, Vector_Token, Ch.Number_Sign); + --when Ch_Code.Left_Parenthesis => -- #( + -- Token.Set (Interp, Vector_Token, Ch_Val.Number_Sign); -- Token.Append_Character (Interp, LC.Value); - --when Ch.Pos.Left_Bracket => -- $[ - -- Token.Set (Interp, List_Token, Ch.Number_Sign); + --when Ch_Code.Left_Bracket => -- $[ + -- Token.Set (Interp, List_Token, Ch_Val.Number_Sign); -- Token.Append_Character (Interp, LC.Value); - --when Ch.Pos.Left_Bracket => -- ${ - -- Token.Set (Interp, Table_Token, Ch.Number_Sign); + --when Ch_Code.Left_Bracket => -- ${ + -- Token.Set (Interp, Table_Token, Ch_Val.Number_Sign); -- Token.Append_Character (Interp, LC.Value); when others => @@ -736,7 +736,7 @@ procedure Execute (Interp: in out Interpreter_Record) is end case; - when Ch.Pos.Quotation => + when Ch_Code.Quotation => Fetch_Character; Token.Set (Interp, String_Token); loop @@ -746,7 +746,7 @@ procedure Execute (Interp: in out Interpreter_Record) is raise Syntax_Error; end if; - if LC.Value = Ch.Backslash then + if LC.Value = Ch_Val.Backslash then Fetch_Character; if LC.Kind /= Normal_Character then -- String ended prematurely. @@ -755,7 +755,7 @@ procedure Execute (Interp: in out Interpreter_Record) is end if; -- TODO: escape letters??? \n \r \\ etc.... Token.Append_Character (Interp, LC.Value); - elsif LC.Value = Ch.Quotation then + elsif LC.Value = Ch_Val.Quotation then exit; else Token.Append_Character (Interp, LC.Value); @@ -764,33 +764,33 @@ procedure Execute (Interp: in out Interpreter_Record) is 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 Token.Set (Interp, Integer_Token); loop Token.Append_Character (Interp, LC.Value); Fetch_Character; 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_Character; exit; end if; end loop; - when Ch.Pos.Plus_Sign | Ch.Pos.Minus_Sign => + when Ch_Code.Plus_Sign | Ch_Code.Minus_Sign => Tmp(1) := LC.Value; Fetch_Character; 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)); loop Token.Append_Character (Interp, LC.Value); Fetch_Character; 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; exit; end if; diff --git a/lib/h2-scheme.adb b/lib/h2-scheme.adb index 3d99cc6..4cb52a7 100644 --- a/lib/h2-scheme.adb +++ b/lib/h2-scheme.adb @@ -60,64 +60,64 @@ package body H2.Scheme is -- Why doesn't ada include a formal type support for different character -- and string types? This limitation is caused because the generic -- 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_Begin: constant Object_Character_Array := (Ch.LC_B, Ch.LC_E, Ch.LC_G, Ch.LC_I, Ch.LC_N); -- "begin" - Label_Case: constant Object_Character_Array := (Ch.LC_C, Ch.LC_A, Ch.LC_S, Ch.LC_E); -- "case" - Label_Cond: constant Object_Character_Array := (Ch.LC_C, Ch.LC_O, Ch.LC_N, Ch.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_Do: constant Object_Character_Array := (Ch.LC_D, Ch.LC_O); -- "do" - Label_If: constant Object_Character_Array := (Ch.LC_I, Ch.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_Let: constant Object_Character_Array := (Ch.LC_L, Ch.LC_E, Ch.LC_T); -- "let" - Label_Letast: constant Object_Character_Array := (Ch.LC_L, Ch.LC_E, Ch.LC_T, Ch.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_Or: constant Object_Character_Array := (Ch.LC_O, Ch.LC_R); -- "or" - Label_Quasiquote: constant Object_Character_Array := (Ch.LC_Q, Ch.LC_U, Ch.LC_A, Ch.LC_S, Ch.LC_I, - Ch.LC_Q, Ch.LC_U, Ch.LC_O, Ch.LC_T, Ch.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_Set: constant Object_Character_Array := (Ch.LC_S, Ch.LC_E, Ch.LC_T, Ch.Exclamation); -- "set!" + 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_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_Val.LC_C, Ch_Val.LC_A, Ch_Val.LC_S, Ch_Val.LC_E); -- "case" + 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_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_Val.LC_D, Ch_Val.LC_O); -- "do" + Label_If: constant Object_Character_Array := (Ch_Val.LC_I, Ch_Val.LC_F); -- "if" + 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_Val.LC_L, Ch_Val.LC_E, Ch_Val.LC_T); -- "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_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_Val.LC_O, Ch_Val.LC_R); -- "or" + 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_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_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_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, - Ch.LC_W, Ch.LC_I, Ch.LC_T, Ch.LC_H, Ch.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.LC_C, Ch.LC_O, Ch.LC_N, Ch.LC_T, Ch.LC_I, Ch.LC_N, Ch.LC_U, Ch.LC_A, - Ch.LC_T, Ch.LC_I, Ch.LC_O, Ch.LC_N); -- "call-with-current-continuation" - Label_Car: constant Object_Character_Array := (Ch.LC_C, Ch.LC_A, Ch.LC_R); -- "car" - Label_Cdr: constant Object_Character_Array := (Ch.LC_C, Ch.LC_D, Ch.LC_R); -- "cdr" - Label_Cons: constant Object_Character_Array := (Ch.LC_C, Ch.LC_O, Ch.LC_N, Ch.LC_S); -- "cons" - Label_Not: constant Object_Character_Array := (Ch.LC_N, Ch.LC_O, Ch.LC_T); -- "not" + 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_Val.LC_W, Ch_Val.LC_I, Ch_Val.LC_T, Ch_Val.LC_H, Ch_Val.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_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_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_Val.LC_C, Ch_Val.LC_A, Ch_Val.LC_R); -- "car" + 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_Val.LC_C, Ch_Val.LC_O, Ch_Val.LC_N, Ch_Val.LC_S); -- "cons" + 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_EQ: constant Object_Character_Array := (1 => Ch.Equal_Sign); -- "=" - Label_N_GE: constant Object_Character_Array := (Ch.Greater_Than_Sign, Ch.Equal_Sign); -- ">=" - Label_N_GT: constant Object_Character_Array := (1 => Ch.Greater_Than_Sign); -- ">" - Label_N_LE: constant Object_Character_Array := (Ch.Less_Than_Sign, Ch.Equal_Sign); -- "<=" - Label_N_LT: constant Object_Character_Array := (1 => Ch.Less_Than_Sign); -- "<" - Label_N_Multiply: constant Object_Character_Array := (1 => Ch.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_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_Subtract: constant Object_Character_Array := (1 => Ch.Minus_Sign); -- "-" + Label_N_Add: constant Object_Character_Array := (1 => Ch_Val.Plus_Sign); -- "+" + Label_N_EQ: constant Object_Character_Array := (1 => Ch_Val.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_Val.Greater_Than_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_Val.Less_Than_Sign); -- "<" + Label_N_Multiply: constant Object_Character_Array := (1 => Ch_Val.Asterisk); -- "*" + 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_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_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_Eq: constant Object_Character_Array := (Ch.LC_E, Ch.LC_Q, Ch.Question); -- "eq?" - Label_Q_Eqv: constant Object_Character_Array := (Ch.LC_E, Ch.LC_Q, Ch.LC_V, Ch.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_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_Pair: constant Object_Character_Array := (Ch.LC_P, Ch.LC_A, Ch.LC_I, Ch.LC_R, Ch.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_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_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_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_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_Val.LC_E, Ch_Val.LC_Q, Ch_Val.Question); -- "eq?" + 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_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_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_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_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_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_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_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_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_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_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_Space: constant Object_Character_Array := (Ch.LC_S, Ch.LC_P, Ch.LC_A, Ch.LC_C, Ch.LC_E); -- "space" + 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_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_Else: constant Object_Character_Array := (Ch.LC_E, Ch.LC_L, Ch.LC_S, Ch.LC_E); -- "else" + Label_Arrow: constant Object_Character_Array := (Ch_Val.Equal_Sign, Ch_Val.Greater_Than_Sign); -- "=>" + 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 @@ -393,14 +393,14 @@ package body H2.Scheme is pragma Assert (Source'Length > 0); First := Source'First; - if Source(First) = Ch.Minus_Sign then + if Source(First) = Ch_Val.Minus_Sign then First := First + 1; Negative := Standard.True; - elsif Source(First) = Ch.Plus_Sign then + elsif Source(First) = Ch_Val.Plus_Sign then First := First + 1; end if; 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; if Negative then @@ -1071,8 +1071,8 @@ end if; Tag => Unknown_Object, Scode => Syntax_Code'Val(0), Sign => Positive_Sign, - Character_Slot => (others => Ch.NUL), - Character_Terminator => Ch.NUL + Character_Slot => (others => Ch_Val.NUL), + Character_Terminator => Ch_Val.NUL ); return Result; diff --git a/lib/h2-scheme.ads b/lib/h2-scheme.ads index e5f36c6..be4c713 100644 --- a/lib/h2-scheme.ads +++ b/lib/h2-scheme.ads @@ -54,7 +54,6 @@ package H2.Scheme is Divide_By_Zero_Error: exception; Numeric_String_Error: exception; - type Interpreter_Record is limited private; type Interpreter_Pointer is access all Interpreter_Record; @@ -494,8 +493,10 @@ package H2.Scheme is -- ----------------------------------------------------------------------------- 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_Record(Size: Heap_Size) is record diff --git a/lib/h2.ads b/lib/h2.ads index d1814e1..461f479 100644 --- a/lib/h2.ads +++ b/lib/h2.ads @@ -25,11 +25,7 @@ package H2 is access all System.Storage_Pools.Root_Storage_Pool'Class; type System_Byte_Array is array(System_Index range<>) of System_Byte; - - - - - - + + --package Chpos renames H2.Ascii.Code; end H2; diff --git a/lib/lib.gpr.in b/lib/lib.gpr.in index 7a68aa2..372aae1 100644 --- a/lib/lib.gpr.in +++ b/lib/lib.gpr.in @@ -27,7 +27,7 @@ project Lib is "h2-io.ads", "h2-io.adb", "h2-io-file.adb", - "h2-io-get_line_terminator.adb", + "h2-io-file-get_default_option.adb", "h2-scheme.adb", "h2-scheme.ads", "h2-scheme-bigint.adb", diff --git a/lib/posix/h2-os-file.adb b/lib/posix/h2-os-file.adb index 597a8cd..9da2854 100644 --- a/lib/posix/h2-os-file.adb +++ b/lib/posix/h2-os-file.adb @@ -169,5 +169,4 @@ package body File is end if; end Write; - end File; diff --git a/lib/win32/h2-io-file-get_default_option.adb b/lib/win32/h2-io-file-get_default_option.adb new file mode 100644 index 0000000..ef95cda --- /dev/null +++ b/lib/win32/h2-io-file-get_default_option.adb @@ -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; diff --git a/lib/win32/h2-os-file.adb b/lib/win32/h2-os-file.adb new file mode 100644 index 0000000..3deffbf --- /dev/null +++ b/lib/win32/h2-os-file.adb @@ -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; diff --git a/lib/win32/h2-sysdef.ads b/lib/win32/h2-sysdef.ads new file mode 100644 index 0000000..af20484 --- /dev/null +++ b/lib/win32/h2-sysdef.ads @@ -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;