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

separated token handling to a separate file

Browse Source
This commit is contained in:
hyung-hwan 2014-01-04 06:31:14 +00:00
parent a81a2230d0
commit 78fb4223e9
6 changed files with 156 additions and 126 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

2
cmd/scheme.gpr.in
View File

@ -23,7 +23,7 @@ project Scheme is
package Compiler is
for Default_Switches ("Ada") use (
"-gnata", "-gnato", "-gnatN", "-gnatwl", "-gnat95"
"-gnata", "-gnato", "-gnatN", "-gnatwl", "-gnat95",
"-I@abs_srcdir@/../lib"
);
end Compiler;

114
lib/h2-scheme-token.adb Normal file
View File

@ -0,0 +1,114 @@
with H2.Pool;
package body H2.Scheme.Token is
-----------------------------------------------------------------------------
-- BUFFER MANAGEMENT
-----------------------------------------------------------------------------
procedure Clear_Buffer (Buffer: in out Buffer_Record) is
pragma Inline (Clear_Buffer);
begin
Buffer.Last := 0;
end Clear_Buffer;
procedure Purge_Buffer (Interp: in out Interpreter_Record;
Buffer: in out Buffer_Record) is
begin
if Buffer.Len > 0 then
declare
subtype New_String is Object_String (1 .. Buffer.Len);
type New_String_Pointer is access all New_String;
for New_String_Pointer'Size use Object_Pointer_Bits;
package Pool is new H2.Pool (New_String, New_String_Pointer, Interp.Storage_Pool);
Tmp: New_String_Pointer;
for Tmp'Address use Buffer.Ptr'Address;
pragma Import (Ada, Tmp);
begin
Pool.Deallocate (Tmp);
end;
Buffer := (null, 0, 0);
end if;
end Purge_Buffer;
procedure Append_Buffer (Interp: in out Interpreter_Record;
Buffer: in out Buffer_Record;
Source: in Object_String) is
Incr: Standard.Natural;
begin
if Buffer.Last >= Buffer.Len then
if Buffer.Len <= 0 then
Incr := 1; -- TODO: increase to 128
else
Incr := Buffer.Len;
end if;
if Incr < Source'Length then
Incr := Source'Length;
end if;
declare
subtype New_String is Object_String (1 .. Buffer.Len + Incr);
type New_String_Pointer is access all New_String;
for New_String_Pointer'Size use Object_Pointer_Bits;
package Pool is new H2.Pool (New_String, New_String_Pointer, Interp.Storage_Pool);
T1: New_String_Pointer;
T2: New_String_Pointer;
for T2'Address use Buffer.Ptr'Address;
pragma Import (Ada, T2);
begin
T1 := Pool.Allocate;
if Buffer.Last > 0 then
T1(1 .. Buffer.Last) := Buffer.Ptr(1 .. Buffer.Last);
end if;
Pool.Deallocate (T2);
T2 := T1;
end;
Buffer.Len := Buffer.Len + Incr;
end if;
Buffer.Ptr(Buffer.Last + 1 .. Buffer.Last + Source'Length) := Source;
Buffer.Last := Buffer.Last + Source'Length;
end Append_Buffer;
-----------------------------------------------------------------------------
-- TOKEN MANAGEMENT
-----------------------------------------------------------------------------
procedure Purge (Interp: in out Interpreter_Record) is
begin
Purge_Buffer (Interp, Interp.Token.Value);
Interp.Token := (End_Token, (null, 0, 0));
end Purge;
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);
if Value'Length > 0 then
Append_Buffer (Interp, Interp.Token.Value, Value);
end if;
end Set;
procedure Append_String (Interp: in out Interpreter_Record;
Value: in Object_String) is
begin
if Value'Length > 0 then
Append_Buffer (Interp, Interp.Token.Value, Value);
end if;
end Append_String;
procedure Append_Character (Interp: in out Interpreter_Record;
Value: in Object_Character) is
Tmp: Object_String(1..1) := (1 => Value);
begin
Append_Buffer (Interp, Interp.Token.Value, Tmp);
end Append_Character;
end H2.Scheme.Token;

21
lib/h2-scheme-token.ads Normal file
View File

@ -0,0 +1,21 @@
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;

125
lib/h2-scheme.adb
View File

@ -1,5 +1,6 @@
with H2.Pool;
with System.Address_To_Access_Conversions;
with H2.Scheme.Token;
with Ada.Unchecked_Deallocation; -- for h2scm c interface. TOOD: move it to a separate file
@ -361,114 +362,6 @@ package body H2.Scheme is
end if;
end Print_Object_Pointer;
-----------------------------------------------------------------------------
-- BUFFER MANAGEMENT
-----------------------------------------------------------------------------
procedure Clear_Buffer (Buffer: in out Buffer_Record) is
pragma Inline (Clear_Buffer);
begin
Buffer.Last := 0;
end Clear_Buffer;
procedure Purge_Buffer (Interp: in out Interpreter_Record;
Buffer: in out Buffer_Record) is
begin
if Buffer.Len > 0 then
declare
subtype New_String is Object_String (1 .. Buffer.Len);
type New_String_Pointer is access all New_String;
for New_String_Pointer'Size use Object_Pointer_Bits;
package Pool is new H2.Pool (New_String, New_String_Pointer, Interp.Storage_Pool);
Tmp: New_String_Pointer;
for Tmp'Address use Buffer.Ptr'Address;
pragma Import (Ada, Tmp);
begin
Pool.Deallocate (Tmp);
end;
Buffer := (null, 0, 0);
end if;
end Purge_Buffer;
procedure Append_Buffer (Interp: in out Interpreter_Record;
Buffer: in out Buffer_Record;
Source: in Object_String) is
Incr: Standard.Natural;
begin
if Buffer.Last >= Buffer.Len then
if Buffer.Len <= 0 then
Incr := 1; -- TODO: increase to 128
else
Incr := Buffer.Len;
end if;
if Incr < Source'Length then
Incr := Source'Length;
end if;
declare
subtype New_String is Object_String (1 .. Buffer.Len + Incr);
type New_String_Pointer is access all New_String;
for New_String_Pointer'Size use Object_Pointer_Bits;
package Pool is new H2.Pool (New_String, New_String_Pointer, Interp.Storage_Pool);
T1: New_String_Pointer;
T2: New_String_Pointer;
for T2'Address use Buffer.Ptr'Address;
pragma Import (Ada, T2);
begin
T1 := Pool.Allocate;
if Buffer.Last > 0 then
T1(1 .. Buffer.Last) := Buffer.Ptr(1 .. Buffer.Last);
end if;
Pool.Deallocate (T2);
T2 := T1;
end;
Buffer.Len := Buffer.Len + Incr;
end if;
Buffer.Ptr(Buffer.Last + 1 .. Buffer.Last + Source'Length) := Source;
Buffer.Last := Buffer.Last + Source'Length;
end Append_Buffer;
procedure Purge_Token (Interp: in out Interpreter_Record) is
begin
Purge_Buffer (Interp, Interp.Token.Value);
Interp.Token := (End_Token, (null, 0, 0));
end Purge_Token;
procedure Set_Token (Interp: in out Interpreter_Record;
Kind: in Token_Kind;
Value: in Object_String) is
begin
Interp.Token.Kind := Kind;
Clear_Buffer (Interp.Token.Value);
if Value'Length > 0 then
Append_Buffer (Interp, Interp.Token.Value, Value);
end if;
end Set_Token;
procedure Append_Token_String (Interp: in out Interpreter_Record;
Value: in Object_String) is
pragma Inline (Append_Token_String);
begin
if Value'Length > 0 then
Append_Buffer (Interp, Interp.Token.Value, Value);
end if;
end Append_Token_String;
procedure Append_Token_Character (Interp: in out Interpreter_Record;
Value: in Object_Character) is
pragma Inline (Append_Token_Character);
Tmp: Object_String(1..1) := (1 => Value);
begin
Append_Buffer (Interp, Interp.Token.Value, Tmp);
end Append_Token_Character;
-----------------------------------------------------------------------------
-- MEMORY MANAGEMENT
-----------------------------------------------------------------------------
@ -1603,7 +1496,7 @@ Text_IO.Put_Line (To_Object_String(IO_Character_Record'Max_Size_In_Storage_Eleme
end if;
Deinitialize_Heap (Interp);
Purge_Token (Interp);
Token.Purge (Interp);
end Close;
function Get_Storage_Pool (Interp: in Interpreter_Record) return Storage_Pool_Pointer is
@ -1743,25 +1636,25 @@ Text_IO.Put_Line (To_Object_String(IO_Character_Record'Max_Size_In_Storage_Eleme
begin
Skip_Spaces;
if C.Kind /= Normal_Character then
Set_Token (Interp, End_Token, "");
Token.Set (Interp, End_Token, "");
return;
end if;
case C.Value is
when '(' =>
Set_Token (Interp, Left_Parenthesis_Token, "(");
Token.Set (Interp, Left_Parenthesis_Token, "(");
Fetch_Character;
when ')' =>
Set_Token (Interp, Right_Parenthesis_Token, ")");
Token.Set (Interp, Right_Parenthesis_Token, ")");
Fetch_Character;
when ''' =>
Set_Token (Interp, Single_Quote_Token, "'");
Token.Set (Interp, Single_Quote_Token, "'");
Fetch_Character;
when '"' =>
Set_Token (Interp, String_Token, "'");
Token.Set (Interp, String_Token, "'");
Fetch_Character;
-- TODO:
@ -1770,9 +1663,9 @@ Text_IO.Put_Line (To_Object_String(IO_Character_Record'Max_Size_In_Storage_Eleme
-- TODO: t, false, etc
when others =>
Set_Token (Interp, Identifier_Token, "");
Token.Set (Interp, Identifier_Token, "");
loop
Append_Token_Character (Interp, C.Value);
Token.Append_Character (Interp, C.Value);
Fetch_Character;
--exit when not Is_Ident_Char(C.Value);
if C.Value = '(' or else C.Value = ')' or else

16
lib/h2-scheme.ads
View File

@ -417,6 +417,14 @@ procedure Make_Test_Object (Interp: in out Interpreter_Record; Result: out Objec
-- -----------------------------------------------------------------------------
subtype Thin_String is Object_String (Standard.Positive'Range);
type Thin_String_Pointer is access all Thin_String;
for Thin_String_Pointer'Size use Object_Pointer_Bits;
type Buffer_Record is record
Ptr: Thin_String_Pointer := null;
Len: Standard.Natural := 0;
Last: Standard.Natural := 0;
end record;
private
type Heap_Element_Array is array (Heap_Size range <>) of aliased Heap_Element;
@ -430,15 +438,7 @@ private
type Heap_Number is mod 2 ** 1;
type Heap_Pointer_Array is Array (Heap_Number'First .. Heap_Number'Last) of Heap_Pointer;
subtype Thin_String is Object_String (Standard.Positive'Range);
type Thin_String_Pointer is access all Thin_String;
for Thin_String_Pointer'Size use Object_Pointer_Bits;
type Buffer_Record is record
Ptr: Thin_String_Pointer := null;
Len: Standard.Natural := 0;
Last: Standard.Natural := 0;
end record;
type Token_Kind is (End_Token,
Identifier_Token,

4
lib/lib.gpr.in
View File

@ -12,7 +12,9 @@ project Lib is
"h2-pool.adb",
"h2-pool.ads",
"h2-scheme.adb",
"h2-scheme.ads"
"h2-scheme.ads",
"h2-scheme-token.adb",
"h2-scheme-token.ads"
);
for Library_Interface use (
"h2",