managed to change h2-scheme to a generic package
This commit is contained in:
@ -6,7 +6,9 @@ with Ada.Text_IO;
|
||||
with Ada.Unchecked_Deallocation;
|
||||
|
||||
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;
|
||||
SI: S.Interpreter_Record;
|
||||
@ -43,14 +45,6 @@ begin
|
||||
--S.Set_Input_Stream (SI, String_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 ("-------------------------------------------");
|
||||
S.Run_Loop (SI, I);
|
||||
S.Print (SI, I);
|
||||
|
||||
@ -3,7 +3,8 @@ with Ada.Wide_Text_IO;
|
||||
|
||||
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;
|
||||
|
||||
17
h2/lib/ascii.awk
Normal file
17
h2/lib/ascii.awk
Normal 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
h2/lib/ascii.txt
Normal file
128
h2/lib/ascii.txt
Normal 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
h2/lib/h2-ascii.ads
Normal file
137
h2/lib/h2-ascii.ads
Normal 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;
|
||||
@ -1,6 +1,8 @@
|
||||
with H2.Pool;
|
||||
|
||||
package body H2.Scheme.Token is
|
||||
separate (H2.Scheme)
|
||||
|
||||
package body Token is
|
||||
|
||||
-----------------------------------------------------------------------------
|
||||
-- BUFFER MANAGEMENT
|
||||
@ -85,8 +87,26 @@ package body H2.Scheme.Token is
|
||||
end Purge;
|
||||
|
||||
procedure Set (Interp: in out Interpreter_Record;
|
||||
Kind: in Token_Kind;
|
||||
Value: in Object_String) is
|
||||
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;
|
||||
Kind: in Token_Kind;
|
||||
Value: in Object_String) is
|
||||
begin
|
||||
Interp.Token.Kind := Kind;
|
||||
Clear_Buffer (Interp.Token.Value);
|
||||
@ -111,4 +131,4 @@ package body H2.Scheme.Token is
|
||||
end Append_Character;
|
||||
|
||||
|
||||
end H2.Scheme.Token;
|
||||
end Token;
|
||||
|
||||
@ -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
@ -39,6 +39,9 @@ with System;
|
||||
with System.Storage_Pools;
|
||||
with Ada.Unchecked_Conversion;
|
||||
|
||||
generic
|
||||
type Character_Type is (<>);
|
||||
type String_Type is array (Standard.Positive range<>) of Character_Type;
|
||||
package H2.Scheme is
|
||||
|
||||
type Interpreter_Record is limited private;
|
||||
@ -122,8 +125,10 @@ package H2.Scheme is
|
||||
type Object_Byte is mod 2 ** System.Storage_Unit;
|
||||
for Object_Byte'Size use System.Storage_Unit;
|
||||
|
||||
subtype Object_Character is Standard.Wide_Character;
|
||||
subtype Object_String is Standard.Wide_String;
|
||||
--subtype Object_Character is Standard.Wide_Character;
|
||||
--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 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;
|
||||
Initial_Heap_Size:in Heap_Size;
|
||||
Storage_Pool: in Storage_Pool_Pointer := null);
|
||||
@ -437,8 +440,6 @@ private
|
||||
type Heap_Number is mod 2 ** 1;
|
||||
type Heap_Pointer_Array is Array (Heap_Number'First .. Heap_Number'Last) of Heap_Pointer;
|
||||
|
||||
|
||||
|
||||
type Token_Kind is (End_Token,
|
||||
Identifier_Token,
|
||||
Left_Parenthesis_Token,
|
||||
@ -479,4 +480,30 @@ private
|
||||
LC_Unfetched: Standard.Boolean := Standard.False;
|
||||
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;
|
||||
|
||||
@ -9,15 +9,16 @@ project Lib is
|
||||
|
||||
for Source_Files use (
|
||||
"h2.ads",
|
||||
"h2-ascii.ads",
|
||||
"h2-pool.adb",
|
||||
"h2-pool.ads",
|
||||
"h2-scheme.adb",
|
||||
"h2-scheme.ads",
|
||||
"h2-scheme-token.adb",
|
||||
"h2-scheme-token.ads"
|
||||
"h2-scheme-token.adb"
|
||||
);
|
||||
for Library_Interface use (
|
||||
"h2",
|
||||
"h2.ascii",
|
||||
"h2.pool",
|
||||
"h2.scheme"
|
||||
);
|
||||
|
||||
Reference in New Issue
Block a user