From 78fb4223e939d0ad44bfb6cc5fbc608d2cc05e39 Mon Sep 17 00:00:00 2001 From: hyung-hwan Date: Sat, 4 Jan 2014 06:31:14 +0000 Subject: [PATCH] separated token handling to a separate file --- cmd/scheme.gpr.in | 2 +- lib/h2-scheme-token.adb | 114 ++++++++++++++++++++++++++++++++++++ lib/h2-scheme-token.ads | 21 +++++++ lib/h2-scheme.adb | 125 +++------------------------------------- lib/h2-scheme.ads | 16 ++--- lib/lib.gpr.in | 4 +- 6 files changed, 156 insertions(+), 126 deletions(-) create mode 100644 lib/h2-scheme-token.adb create mode 100644 lib/h2-scheme-token.ads diff --git a/cmd/scheme.gpr.in b/cmd/scheme.gpr.in index e2a8a6e..728aa02 100644 --- a/cmd/scheme.gpr.in +++ b/cmd/scheme.gpr.in @@ -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; diff --git a/lib/h2-scheme-token.adb b/lib/h2-scheme-token.adb new file mode 100644 index 0000000..c878d74 --- /dev/null +++ b/lib/h2-scheme-token.adb @@ -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; diff --git a/lib/h2-scheme-token.ads b/lib/h2-scheme-token.ads new file mode 100644 index 0000000..30cf7da --- /dev/null +++ b/lib/h2-scheme-token.ads @@ -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; + diff --git a/lib/h2-scheme.adb b/lib/h2-scheme.adb index b1525ab..0b83874 100644 --- a/lib/h2-scheme.adb +++ b/lib/h2-scheme.adb @@ -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 diff --git a/lib/h2-scheme.ads b/lib/h2-scheme.ads index 82fbbc2..1550b4f 100644 --- a/lib/h2-scheme.ads +++ b/lib/h2-scheme.ads @@ -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, diff --git a/lib/lib.gpr.in b/lib/lib.gpr.in index e78063d..103f6b0 100644 --- a/lib/lib.gpr.in +++ b/lib/lib.gpr.in @@ -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",