managed to change h2-scheme to a generic package

This commit is contained in:
hyung-hwan 2014-01-09 15:32:36 +00:00
parent de2e462814
commit d502f1ab4c
10 changed files with 656 additions and 490 deletions

View File

@ -6,7 +6,9 @@ with Ada.Text_IO;
with Ada.Unchecked_Deallocation; with Ada.Unchecked_Deallocation;
procedure scheme is procedure scheme is
package S renames H2.Scheme; --package S renames H2.Scheme;
--package S is new H2.Scheme (Wide_Character, Wide_String);
package S renames Stream.S;
Pool: aliased Storage.Global_Pool; Pool: aliased Storage.Global_Pool;
SI: S.Interpreter_Record; SI: S.Interpreter_Record;
@ -43,14 +45,6 @@ begin
--S.Set_Input_Stream (SI, String_Stream); --S.Set_Input_Stream (SI, String_Stream);
--S.Set_Output_Stream (SI, Stream); -- specify main output stream. --S.Set_Output_Stream (SI, Stream); -- specify main output stream.
--S.Read (SI, I);
S.Make_Test_Object (SI, I);
S.Evaluate (SI, I, O);
S.Print (SI, I);
Ada.Text_IO.Put_Line ("-------------------------------------------");
S.Print (SI, O);
Ada.Text_IO.Put_Line ("-------------------------------------------"); Ada.Text_IO.Put_Line ("-------------------------------------------");
S.Run_Loop (SI, I); S.Run_Loop (SI, I);
S.Print (SI, I); S.Print (SI, I);

View File

@ -3,7 +3,8 @@ with Ada.Wide_Text_IO;
package Stream is package Stream is
package S renames H2.Scheme; --package S renames H2.Scheme;
package S is new H2.Scheme (Standard.Wide_Character, Standard.Wide_String);
------------------------------------------------------------ ------------------------------------------------------------
--type Object_String_Pointer is access all S.Object_String; --type Object_String_Pointer is access all S.Object_String;

17
lib/ascii.awk Normal file
View File

@ -0,0 +1,17 @@
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");
}
{
t = sprintf ("%c", NR - 1);
if (str::isprint(t)) t = " -- " t;
else t="";
printf ("\t%-20s: constant Character_Type := Character_Type'Val(%d);%s\n", $1, NR - 1, t);
}
END {
printf ("\nend H2.Ascii;\n");
}

128
lib/ascii.txt Normal file
View File

@ -0,0 +1,128 @@
NUL
SOH
STX
ETX
EOT
ENQ
ACK
BEL
BS
HT
LF
VT
FF
CR
SO
SI
DLE
DC1
DC2
DC3
DC4
NAK
SYN
ETB
CAN
EM
SUB
ESC
FS
GS
RS
US
Space
Exclamation
Quotation
Number_Sign
Dollar_Sign
Percent_Sign
Ampersand
Apostrophe
Left_Parenthesis
Right_Parenthesis
Asterisk
Plus_Sign
Comma
Minus_Sign
Period
Slash
Zero
One
Two
Three
Four
Five
Six
Seven
Eight
Nine
Colon
Semicolon
Less_Than_Sign
Equals_Sign
Greater_Than_Sign
Question
Commercial_At
UC_A
UC_B
UC_C
UC_D
UC_E
UC_F
UC_G
UC_H
UC_I
UC_J
UC_K
UC_L
UC_M
UC_N
UC_O
UC_P
UC_Q
UC_R
UC_S
UC_T
UC_U
UC_V
UC_W
UC_X
UC_Y
UC_Z
Left_Square_Bracket
Backslash
Right_Square_Bracket
Circumflex
Low_Line
Grave
LC_A
LC_B
LC_C
LC_D
LC_E
LC_F
LC_G
LC_H
LC_I
LC_J
LC_K
LC_L
LC_M
LC_N
LC_O
LC_P
LC_Q
LC_R
LC_S
LC_T
LC_U
LC_V
LC_W
LC_X
LC_Y
LC_Z
Left_Curly_Bracket
Vertical_Line
Right_Curly_Bracket
Tilde
DEL

137
lib/h2-ascii.ads Normal file
View File

@ -0,0 +1,137 @@
-- Generated with ascii.txt and ascii.awk
-- Run qseawk -f ascii.awk ascii.txt > h2-ascii.ads for regeneration
generic
type Character_Type is (<>);
package H2.Ascii is
NUL : constant Character_Type := Character_Type'Val(0);
SOH : constant Character_Type := Character_Type'Val(1);
STX : constant Character_Type := Character_Type'Val(2);
ETX : constant Character_Type := Character_Type'Val(3);
EOT : constant Character_Type := Character_Type'Val(4);
ENQ : constant Character_Type := Character_Type'Val(5);
ACK : constant Character_Type := Character_Type'Val(6);
BEL : constant Character_Type := Character_Type'Val(7);
BS : constant Character_Type := Character_Type'Val(8);
HT : constant Character_Type := Character_Type'Val(9);
LF : constant Character_Type := Character_Type'Val(10);
VT : constant Character_Type := Character_Type'Val(11);
FF : constant Character_Type := Character_Type'Val(12);
CR : constant Character_Type := Character_Type'Val(13);
SO : constant Character_Type := Character_Type'Val(14);
SI : constant Character_Type := Character_Type'Val(15);
DLE : constant Character_Type := Character_Type'Val(16);
DC1 : constant Character_Type := Character_Type'Val(17);
DC2 : constant Character_Type := Character_Type'Val(18);
DC3 : constant Character_Type := Character_Type'Val(19);
DC4 : constant Character_Type := Character_Type'Val(20);
NAK : constant Character_Type := Character_Type'Val(21);
SYN : constant Character_Type := Character_Type'Val(22);
ETB : constant Character_Type := Character_Type'Val(23);
CAN : constant Character_Type := Character_Type'Val(24);
EM : constant Character_Type := Character_Type'Val(25);
SUB : constant Character_Type := Character_Type'Val(26);
ESC : constant Character_Type := Character_Type'Val(27);
FS : constant Character_Type := Character_Type'Val(28);
GS : constant Character_Type := Character_Type'Val(29);
RS : constant Character_Type := Character_Type'Val(30);
US : constant Character_Type := Character_Type'Val(31);
Space : constant Character_Type := Character_Type'Val(32); --
Exclamation : constant Character_Type := Character_Type'Val(33); -- !
Quotation : constant Character_Type := Character_Type'Val(34); -- "
Number_Sign : constant Character_Type := Character_Type'Val(35); -- #
Dollar_Sign : constant Character_Type := Character_Type'Val(36); -- $
Percent_Sign : constant Character_Type := Character_Type'Val(37); -- %
Ampersand : constant Character_Type := Character_Type'Val(38); -- &
Apostrophe : constant Character_Type := Character_Type'Val(39); -- '
Left_Parenthesis : constant Character_Type := Character_Type'Val(40); -- (
Right_Parenthesis : constant Character_Type := Character_Type'Val(41); -- )
Asterisk : constant Character_Type := Character_Type'Val(42); -- *
Plus_Sign : constant Character_Type := Character_Type'Val(43); -- +
Comma : constant Character_Type := Character_Type'Val(44); -- ,
Minus_Sign : constant Character_Type := Character_Type'Val(45); -- -
Period : constant Character_Type := Character_Type'Val(46); -- .
Slash : constant Character_Type := Character_Type'Val(47); -- /
Zero : constant Character_Type := Character_Type'Val(48); -- 0
One : constant Character_Type := Character_Type'Val(49); -- 1
Two : constant Character_Type := Character_Type'Val(50); -- 2
Three : constant Character_Type := Character_Type'Val(51); -- 3
Four : constant Character_Type := Character_Type'Val(52); -- 4
Five : constant Character_Type := Character_Type'Val(53); -- 5
Six : constant Character_Type := Character_Type'Val(54); -- 6
Seven : constant Character_Type := Character_Type'Val(55); -- 7
Eight : constant Character_Type := Character_Type'Val(56); -- 8
Nine : constant Character_Type := Character_Type'Val(57); -- 9
Colon : constant Character_Type := Character_Type'Val(58); -- :
Semicolon : constant Character_Type := Character_Type'Val(59); -- ;
Less_Than_Sign : constant Character_Type := Character_Type'Val(60); -- <
Equals_Sign : constant Character_Type := Character_Type'Val(61); -- =
Greater_Than_Sign : constant Character_Type := Character_Type'Val(62); -- >
Question : constant Character_Type := Character_Type'Val(63); -- ?
Commercial_At : constant Character_Type := Character_Type'Val(64); -- @
UC_A : constant Character_Type := Character_Type'Val(65); -- A
UC_B : constant Character_Type := Character_Type'Val(66); -- B
UC_C : constant Character_Type := Character_Type'Val(67); -- C
UC_D : constant Character_Type := Character_Type'Val(68); -- D
UC_E : constant Character_Type := Character_Type'Val(69); -- E
UC_F : constant Character_Type := Character_Type'Val(70); -- F
UC_G : constant Character_Type := Character_Type'Val(71); -- G
UC_H : constant Character_Type := Character_Type'Val(72); -- H
UC_I : constant Character_Type := Character_Type'Val(73); -- I
UC_J : constant Character_Type := Character_Type'Val(74); -- J
UC_K : constant Character_Type := Character_Type'Val(75); -- K
UC_L : constant Character_Type := Character_Type'Val(76); -- L
UC_M : constant Character_Type := Character_Type'Val(77); -- M
UC_N : constant Character_Type := Character_Type'Val(78); -- N
UC_O : constant Character_Type := Character_Type'Val(79); -- O
UC_P : constant Character_Type := Character_Type'Val(80); -- P
UC_Q : constant Character_Type := Character_Type'Val(81); -- Q
UC_R : constant Character_Type := Character_Type'Val(82); -- R
UC_S : constant Character_Type := Character_Type'Val(83); -- S
UC_T : constant Character_Type := Character_Type'Val(84); -- T
UC_U : constant Character_Type := Character_Type'Val(85); -- U
UC_V : constant Character_Type := Character_Type'Val(86); -- V
UC_W : constant Character_Type := Character_Type'Val(87); -- W
UC_X : constant Character_Type := Character_Type'Val(88); -- X
UC_Y : constant Character_Type := Character_Type'Val(89); -- Y
UC_Z : constant Character_Type := Character_Type'Val(90); -- Z
Left_Square_Bracket : constant Character_Type := Character_Type'Val(91); -- [
Backslash : constant Character_Type := Character_Type'Val(92); -- \
Right_Square_Bracket: constant Character_Type := Character_Type'Val(93); -- ]
Circumflex : constant Character_Type := Character_Type'Val(94); -- ^
Low_Line : constant Character_Type := Character_Type'Val(95); -- _
Grave : constant Character_Type := Character_Type'Val(96); -- `
LC_A : constant Character_Type := Character_Type'Val(97); -- a
LC_B : constant Character_Type := Character_Type'Val(98); -- b
LC_C : constant Character_Type := Character_Type'Val(99); -- c
LC_D : constant Character_Type := Character_Type'Val(100); -- d
LC_E : constant Character_Type := Character_Type'Val(101); -- e
LC_F : constant Character_Type := Character_Type'Val(102); -- f
LC_G : constant Character_Type := Character_Type'Val(103); -- g
LC_H : constant Character_Type := Character_Type'Val(104); -- h
LC_I : constant Character_Type := Character_Type'Val(105); -- i
LC_J : constant Character_Type := Character_Type'Val(106); -- j
LC_K : constant Character_Type := Character_Type'Val(107); -- k
LC_L : constant Character_Type := Character_Type'Val(108); -- l
LC_M : constant Character_Type := Character_Type'Val(109); -- m
LC_N : constant Character_Type := Character_Type'Val(110); -- n
LC_O : constant Character_Type := Character_Type'Val(111); -- o
LC_P : constant Character_Type := Character_Type'Val(112); -- p
LC_Q : constant Character_Type := Character_Type'Val(113); -- q
LC_R : constant Character_Type := Character_Type'Val(114); -- r
LC_S : constant Character_Type := Character_Type'Val(115); -- s
LC_T : constant Character_Type := Character_Type'Val(116); -- t
LC_U : constant Character_Type := Character_Type'Val(117); -- u
LC_V : constant Character_Type := Character_Type'Val(118); -- v
LC_W : constant Character_Type := Character_Type'Val(119); -- w
LC_X : constant Character_Type := Character_Type'Val(120); -- x
LC_Y : constant Character_Type := Character_Type'Val(121); -- y
LC_Z : constant Character_Type := Character_Type'Val(122); -- z
Left_Curly_Bracket : constant Character_Type := Character_Type'Val(123); -- {
Vertical_Line : constant Character_Type := Character_Type'Val(124); -- |
Right_Curly_Bracket : constant Character_Type := Character_Type'Val(125); -- }
Tilde : constant Character_Type := Character_Type'Val(126); -- ~
DEL : constant Character_Type := Character_Type'Val(127);
end H2.Ascii;

View File

@ -1,6 +1,8 @@
with H2.Pool; with H2.Pool;
package body H2.Scheme.Token is separate (H2.Scheme)
package body Token is
----------------------------------------------------------------------------- -----------------------------------------------------------------------------
-- BUFFER MANAGEMENT -- BUFFER MANAGEMENT
@ -84,6 +86,24 @@ package body H2.Scheme.Token is
Interp.Token := (End_Token, (null, 0, 0)); Interp.Token := (End_Token, (null, 0, 0));
end Purge; end Purge;
procedure Set (Interp: in out Interpreter_Record;
Kind: in Token_Kind) is
begin
Interp.Token.Kind := Kind;
Clear_Buffer (Interp.Token.Value);
end Set;
procedure Set (Interp: in out Interpreter_Record;
Kind: in Token_Kind;
Value: in Object_Character) is
Tmp: Object_String(1..1);
begin
Interp.Token.Kind := Kind;
Clear_Buffer (Interp.Token.Value);
Tmp(1) := Value;
Append_Buffer (Interp, Interp.Token.Value, Tmp);
end Set;
procedure Set (Interp: in out Interpreter_Record; procedure Set (Interp: in out Interpreter_Record;
Kind: in Token_Kind; Kind: in Token_Kind;
Value: in Object_String) is Value: in Object_String) is
@ -111,4 +131,4 @@ package body H2.Scheme.Token is
end Append_Character; end Append_Character;
end H2.Scheme.Token; end Token;

View File

@ -1,21 +0,0 @@
private package H2.Scheme.Token is
procedure Purge (Interp: in out Interpreter_Record);
pragma Inline (Purge);
procedure Set (Interp: in out Interpreter_Record;
Kind: in Token_Kind;
Value: in Object_String);
procedure Append_String (Interp: in out Interpreter_Record;
Value: in Object_String);
pragma Inline (Append_String);
procedure Append_Character (Interp: in out Interpreter_Record;
Value: in Object_Character);
pragma Inline (Append_Character);
end H2.Scheme.Token;

File diff suppressed because it is too large Load Diff

View File

@ -39,6 +39,9 @@ with System;
with System.Storage_Pools; with System.Storage_Pools;
with Ada.Unchecked_Conversion; with Ada.Unchecked_Conversion;
generic
type Character_Type is (<>);
type String_Type is array (Standard.Positive range<>) of Character_Type;
package H2.Scheme is package H2.Scheme is
type Interpreter_Record is limited private; type Interpreter_Record is limited private;
@ -122,8 +125,10 @@ package H2.Scheme is
type Object_Byte is mod 2 ** System.Storage_Unit; type Object_Byte is mod 2 ** System.Storage_Unit;
for Object_Byte'Size use System.Storage_Unit; for Object_Byte'Size use System.Storage_Unit;
subtype Object_Character is Standard.Wide_Character; --subtype Object_Character is Standard.Wide_Character;
subtype Object_String is Standard.Wide_String; --subtype Object_String is Standard.Wide_String;
subtype Object_Character is Character_Type;
subtype Object_String is String_Type;
type Object_String_Pointer is access all Object_String; type Object_String_Pointer is access all Object_String;
type Constant_Object_String_Pointer is access constant Object_String; type Constant_Object_String_Pointer is access constant Object_String;
@ -381,8 +386,6 @@ package H2.Scheme is
-- ----------------------------------------------------------------------------- -- -----------------------------------------------------------------------------
procedure Make_Test_Object (Interp: in out Interpreter_Record; Result: out Object_Pointer);
procedure Open (Interp: in out Interpreter_Record; procedure Open (Interp: in out Interpreter_Record;
Initial_Heap_Size:in Heap_Size; Initial_Heap_Size:in Heap_Size;
Storage_Pool: in Storage_Pool_Pointer := null); Storage_Pool: in Storage_Pool_Pointer := null);
@ -437,8 +440,6 @@ private
type Heap_Number is mod 2 ** 1; type Heap_Number is mod 2 ** 1;
type Heap_Pointer_Array is Array (Heap_Number'First .. Heap_Number'Last) of Heap_Pointer; type Heap_Pointer_Array is Array (Heap_Number'First .. Heap_Number'Last) of Heap_Pointer;
type Token_Kind is (End_Token, type Token_Kind is (End_Token,
Identifier_Token, Identifier_Token,
Left_Parenthesis_Token, Left_Parenthesis_Token,
@ -479,4 +480,30 @@ private
LC_Unfetched: Standard.Boolean := Standard.False; LC_Unfetched: Standard.Boolean := Standard.False;
end record; end record;
package Token is
procedure Purge (Interp: in out Interpreter_Record);
pragma Inline (Purge);
procedure Set (Interp: in out Interpreter_Record;
Kind: in Token_Kind);
procedure Set (Interp: in out Interpreter_Record;
Kind: in Token_Kind;
Value: in Object_Character);
procedure Set (Interp: in out Interpreter_Record;
Kind: in Token_Kind;
Value: in Object_String);
procedure Append_String (Interp: in out Interpreter_Record;
Value: in Object_String);
pragma Inline (Append_String);
procedure Append_Character (Interp: in out Interpreter_Record;
Value: in Object_Character);
pragma Inline (Append_Character);
end Token;
end H2.Scheme; end H2.Scheme;

View File

@ -9,15 +9,16 @@ project Lib is
for Source_Files use ( for Source_Files use (
"h2.ads", "h2.ads",
"h2-ascii.ads",
"h2-pool.adb", "h2-pool.adb",
"h2-pool.ads", "h2-pool.ads",
"h2-scheme.adb", "h2-scheme.adb",
"h2-scheme.ads", "h2-scheme.ads",
"h2-scheme-token.adb", "h2-scheme-token.adb"
"h2-scheme-token.ads"
); );
for Library_Interface use ( for Library_Interface use (
"h2", "h2",
"h2.ascii",
"h2.pool", "h2.pool",
"h2.scheme" "h2.scheme"
); );