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

in the middle of debugging GC

Browse Source
This commit is contained in:
hyung-hwan 2014-01-16 16:52:18 +00:00
parent 2e03937883
commit a4e4c5c127
9 changed files with 1458 additions and 1242 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

6
cmd/scheme.adb
View File

@ -18,13 +18,13 @@ procedure scheme is
O: S.Object_Pointer; O: S.Object_Pointer;
--String: aliased S.Object_String := "(car '(1 2 3))"; --String: aliased S.Object_String := "(car '(1 2 3))";
String: aliased constant S.Object_String := "((lambda (x y) (+ x y)) 9 7)"; String: aliased constant S.Object_Character_Array := "((lambda (x y) (+ x y)) 9 7)";
String_Stream: Stream.String_Input_Stream_Record (String'Unchecked_Access); String_Stream: Stream.String_Input_Stream_Record (String'Unchecked_Access);
--String_Stream: Stream.String_Input_Stream_Record := (Len => String'Length, Str => String, Pos => 0); --String_Stream: Stream.String_Input_Stream_Record := (Len => String'Length, Str => String, Pos => 0);
--File_Name: aliased S.Object_String := "test.adb"; --File_Name: aliased S.Object_Character_Array := "test.adb";
File_Name: aliased constant S.Object_String := "test.scm"; File_Name: aliased constant S.Object_Character_Array := "test.scm";
--File_Stream: Stream.File_Stream_Record (File_Name'Unchecked_Access); --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 := (Name => File_Name'Unchecked_Access);
File_Stream: Stream.File_Stream_Record; File_Stream: Stream.File_Stream_Record;

2
cmd/scheme.gpr.in
View File

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

26
cmd/stream.adb
View File

@ -6,7 +6,7 @@ with Ada.Text_IO; -- for debugging
package body Stream is package body Stream is
------------------------------------------------------------------ ------------------------------------------------------------------
use type S.Object_String_Size; use type S.Object_Size;
procedure Open (Stream: in out String_Input_Stream_Record) is procedure Open (Stream: in out String_Input_Stream_Record) is
begin begin
@ -21,9 +21,9 @@ Ada.Text_IO.Put_Line ("****** CLOSE STRING STREAM ******");
end Close; end Close;
procedure Read (Stream: in out String_Input_Stream_Record; procedure Read (Stream: in out String_Input_Stream_Record;
Data: out S.Object_String; Data: out S.Object_Character_Array;
Last: out S.Object_String_Size) is Last: out S.Object_Size) is
Avail: S.Object_String_Size; Avail: S.Object_Size;
begin begin
Avail := Stream.Str'Last - Stream.Pos; Avail := Stream.Str'Last - Stream.Pos;
if Avail <= 0 then if Avail <= 0 then
@ -41,8 +41,8 @@ Ada.Text_IO.Put_Line ("****** CLOSE STRING STREAM ******");
end Read; end Read;
procedure Write (Stream: in out String_Input_Stream_Record; procedure Write (Stream: in out String_Input_Stream_Record;
Data: out S.Object_String; Data: out S.Object_Character_Array;
Last: out S.Object_String_Size) is Last: out S.Object_Size) is
begin begin
--raise S.Stream_Error; --raise S.Stream_Error;
Last := Data'First - 1; Last := Data'First - 1;
@ -59,7 +59,7 @@ Ada.Text_IO.Put_Line (">>>>> OPEN File STREAM <<<<< " & Standard.String(Utf8.Uni
procedure Close (Stream: in out File_Stream_Record) is procedure Close (Stream: in out File_Stream_Record) is
subtype Wide_String is Standard.Wide_String(1 .. Standard.Natural(Stream.Name'Length)); subtype Wide_String is Standard.Wide_String(1 .. Standard.Natural(Stream.Name'Length));
function To_Wide_String is new Ada.Unchecked_Conversion (S.Object_String, Wide_String); function To_Wide_String is new Ada.Unchecked_Conversion (S.Object_Character_Array, Wide_String);
begin begin
--Ada.Wide_Text_IO.Put_Line (">>>>> CLOSE File STREAM <<<<< " & Standard.Wide_String(Stream.Name.all)); --Ada.Wide_Text_IO.Put_Line (">>>>> CLOSE File STREAM <<<<< " & Standard.Wide_String(Stream.Name.all));
Ada.Text_IO.Put_Line (">>>>> CLOSE File STREAM <<<<< " & Standard.String(Utf8.Unicode_To_Utf8(Utf8.Unicode_String(Stream.Name.all)))); Ada.Text_IO.Put_Line (">>>>> CLOSE File STREAM <<<<< " & Standard.String(Utf8.Unicode_To_Utf8(Utf8.Unicode_String(Stream.Name.all))));
@ -67,8 +67,8 @@ Ada.Text_IO.Put_Line (">>>>> CLOSE File STREAM <<<<< " & Standard.String(Utf8.Un
end Close; end Close;
procedure Read (Stream: in out File_Stream_Record; procedure Read (Stream: in out File_Stream_Record;
Data: out S.Object_String; Data: out S.Object_Character_Array;
Last: out S.Object_String_Size) is Last: out S.Object_Size) is
begin begin
for I in Data'First .. Data'Last loop for I in Data'First .. Data'Last loop
begin begin
@ -88,8 +88,8 @@ Ada.Text_IO.Put_Line (">>>>> CLOSE File STREAM <<<<< " & Standard.String(Utf8.Un
end Read; end Read;
procedure Write (Stream: in out File_Stream_Record; procedure Write (Stream: in out File_Stream_Record;
Data: out S.Object_String; Data: out S.Object_Character_Array;
Last: out S.Object_String_Size) is Last: out S.Object_Size) is
begin begin
--raise S.Stream_Error; --raise S.Stream_Error;
Last := Data'First - 1; Last := Data'First - 1;
@ -98,7 +98,7 @@ Ada.Text_IO.Put_Line (">>>>> CLOSE File STREAM <<<<< " & Standard.String(Utf8.Un
------------------------------------------------------------------ ------------------------------------------------------------------
procedure Allocate_Stream (Interp: in out S.Interpreter_Record; procedure Allocate_Stream (Interp: in out S.Interpreter_Record;
Name: in S.Constant_Object_String_Pointer; Name: access S.Object_Character_Array;
Result: out S.Stream_Pointer) is Result: out S.Stream_Pointer) is
subtype FSR is Stream.File_Stream_Record; subtype FSR is Stream.File_Stream_Record;
type FSP is access all FSR; type FSP is access all FSR;
@ -109,7 +109,7 @@ Ada.Text_IO.Put_Line (">>>>> CLOSE File STREAM <<<<< " & Standard.String(Utf8.Un
pragma Import (Ada, X); pragma Import (Ada, X);
begin begin
X := P.Allocate (S.Get_Storage_Pool(Interp)); X := P.Allocate (S.Get_Storage_Pool(Interp));
X.Name := Name; X.Name := S.Constant_Object_Character_Array_Pointer(Name);
end Allocate_Stream; end Allocate_Stream;
procedure Deallocate_Stream (Interp: in out S.Interpreter_Record; procedure Deallocate_Stream (Interp: in out S.Interpreter_Record;

30
cmd/stream.ads
View File

@ -8,40 +8,40 @@ package Stream is
package Utf8 is new H2.Utf8 (Standard.Character, Standard.Wide_Character); package Utf8 is new H2.Utf8 (Standard.Character, Standard.Wide_Character);
------------------------------------------------------------ ------------------------------------------------------------
--type Object_String_Pointer is access all S.Object_String; --type Object_Character_Array_Pointer is access all S.Object_Character_Array;
type Object_String_Pointer is access constant S.Object_String; type Object_Character_Array_Pointer is access constant S.Object_Character_Array;
type String_Input_Stream_Record(Str: Object_String_Pointer) is new S.Stream_Record with record type String_Input_Stream_Record(Str: Object_Character_Array_Pointer) is new S.Stream_Record with record
Pos: S.Object_String_Size := 0; Pos: S.Object_Size := 0;
end record; end record;
procedure Open (Stream: in out String_Input_Stream_Record); procedure Open (Stream: in out String_Input_Stream_Record);
procedure Close (Stream: in out String_Input_Stream_Record); procedure Close (Stream: in out String_Input_Stream_Record);
procedure Read (Stream: in out String_Input_Stream_Record; procedure Read (Stream: in out String_Input_Stream_Record;
Data: out S.Object_String; Data: out S.Object_Character_Array;
Last: out S.Object_String_Size); Last: out S.Object_Size);
procedure Write (Stream: in out String_Input_Stream_Record; procedure Write (Stream: in out String_Input_Stream_Record;
Data: out S.Object_String; Data: out S.Object_Character_Array;
Last: out S.Object_String_Size); Last: out S.Object_Size);
------------------------------------------------------------ ------------------------------------------------------------
type File_Stream_Record is new S.Stream_Record with record type File_Stream_Record is new S.Stream_Record with record
Name: S.Constant_Object_String_Pointer; Name: S.Constant_Object_Character_Array_Pointer;
Handle: Ada.Wide_Text_IO.File_Type; Handle: Ada.Wide_Text_IO.File_Type;
end record; end record;
procedure Open (Stream: in out File_Stream_Record); procedure Open (Stream: in out File_Stream_Record);
procedure Close (Stream: in out File_Stream_Record); procedure Close (Stream: in out File_Stream_Record);
procedure Read (Stream: in out File_Stream_Record; procedure Read (Stream: in out File_Stream_Record;
Data: out S.Object_String; Data: out S.Object_Character_Array;
Last: out S.Object_String_Size); Last: out S.Object_Size);
procedure Write (Stream: in out File_Stream_Record; procedure Write (Stream: in out File_Stream_Record;
Data: out S.Object_String; Data: out S.Object_Character_Array;
Last: out S.Object_String_Size); Last: out S.Object_Size);
------------------------------------------------------------ ------------------------------------------------------------
procedure Allocate_Stream (Interp: in out S.Interpreter_Record; procedure Allocate_Stream (Interp: in out S.Interpreter_Record;
Name: in S.Constant_Object_String_Pointer; Name: access S.Object_Character_Array;
Result: out S.Stream_Pointer); Result: out S.Stream_Pointer);
procedure Deallocate_Stream (Interp: in out S.Interpreter_Record; procedure Deallocate_Stream (Interp: in out S.Interpreter_Record;
@ -49,7 +49,7 @@ package Stream is
--private --private
-- type File_Stream_Record is new S.Stream_Record with record -- type File_Stream_Record is new S.Stream_Record with record
-- Name: S.Constant_Object_String_Pointer; -- Name: S.Constant_Object_Character_Array_Pointer;
-- Handle: Ada.Wide_Text_IO.File_Type; -- Handle: Ada.Wide_Text_IO.File_Type;
-- end record; -- end record;

1062
lib/h2-scheme-execute.adb Normal file
View File

File diff suppressed because it is too large Load Diff

18
lib/h2-scheme-token.adb
View File

@ -18,7 +18,7 @@ package body Token is
begin begin
if Buffer.Len > 0 then if Buffer.Len > 0 then
declare declare
subtype New_String is Object_String (1 .. Buffer.Len); subtype New_String is Object_Character_Array (1 .. Buffer.Len);
type New_String_Pointer is access all New_String; type New_String_Pointer is access all New_String;
for New_String_Pointer'Size use Object_Pointer_Bits; for New_String_Pointer'Size use Object_Pointer_Bits;
@ -37,8 +37,8 @@ package body Token is
procedure Append_Buffer (Interp: in out Interpreter_Record; procedure Append_Buffer (Interp: in out Interpreter_Record;
Buffer: in out Buffer_Record; Buffer: in out Buffer_Record;
Source: in Object_String) is Source: in Object_Character_Array) is
Incr: Object_String_Size; Incr: Object_Size;
begin begin
if Buffer.Last >= Buffer.Len then if Buffer.Last >= Buffer.Len then
if Buffer.Len <= 0 then if Buffer.Len <= 0 then
@ -51,7 +51,7 @@ package body Token is
end if; end if;
declare declare
subtype New_String is Object_String (1 .. Buffer.Len + Incr); subtype New_String is Object_Character_Array (1 .. Buffer.Len + Incr);
type New_String_Pointer is access all New_String; type New_String_Pointer is access all New_String;
for New_String_Pointer'Size use Object_Pointer_Bits; for New_String_Pointer'Size use Object_Pointer_Bits;
@ -96,7 +96,7 @@ package body Token is
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_Character) is Value: in Object_Character) is
Tmp: Object_String(1..1); Tmp: Object_Character_Array(1..1);
begin begin
Interp.Token.Kind := Kind; Interp.Token.Kind := Kind;
Clear_Buffer (Interp.Token.Value); Clear_Buffer (Interp.Token.Value);
@ -106,7 +106,7 @@ package body Token is
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_Character_Array) is
begin begin
Interp.Token.Kind := Kind; Interp.Token.Kind := Kind;
Clear_Buffer (Interp.Token.Value); Clear_Buffer (Interp.Token.Value);
@ -116,7 +116,7 @@ package body Token is
end Set; end Set;
procedure Append_String (Interp: in out Interpreter_Record; procedure Append_String (Interp: in out Interpreter_Record;
Value: in Object_String) is Value: in Object_Character_Array) is
begin begin
if Value'Length > 0 then if Value'Length > 0 then
Append_Buffer (Interp, Interp.Token.Value, Value); Append_Buffer (Interp, Interp.Token.Value, Value);
@ -124,8 +124,8 @@ package body Token is
end Append_String; end Append_String;
procedure Append_Character (Interp: in out Interpreter_Record; procedure Append_Character (Interp: in out Interpreter_Record;
Value: in Object_Character) is Value: in Object_Character) is
Tmp: Object_String(1..1) := (1 => Value); Tmp: Object_Character_Array(1..1) := (1 => Value);
begin begin
Append_Buffer (Interp, Interp.Token.Value, Tmp); Append_Buffer (Interp, Interp.Token.Value, Tmp);
end Append_Character; end Append_Character;

1484
lib/h2-scheme.adb
View File

File diff suppressed because it is too large Load Diff

69
lib/h2-scheme.ads
View File

@ -128,25 +128,19 @@ package H2.Scheme is
subtype Object_Character is Character_Type; subtype Object_Character is Character_Type;
subtype Object_String_Size is Object_Size;
subtype Object_String_Index is Object_Index;
type Object_String is array(Object_String_Index range <>) of Object_Character;
type Object_String_Pointer is access all Object_String;
for Object_String_Pointer'Size use Object_Pointer_Bits;
type Constant_Object_String_Pointer is access constant Object_String;
for Constant_Object_String_Pointer'Size use Object_Pointer_Bits;
-- TODO: are these Thin_XXXX necessary?
subtype Thin_Object_String is Object_String(Object_Index'Range);
type Thin_Object_String_Pointer is access all Thin_Object_String;
for Thin_Object_String_Pointer'Size use Object_Pointer_Bits;
type Object_Byte_Array is array(Object_Index range <>) of Object_Byte;
subtype Object_Character_Array is Object_String;
type Object_Pointer_Array is array(Object_Index range <>) of Object_Pointer; type Object_Pointer_Array is array(Object_Index range <>) of Object_Pointer;
type Object_Character_Array is array(Object_Index range <>) of Object_Character;
type Object_Byte_Array is array(Object_Index range <>) of Object_Byte;
type Object_Word_Array is array(Object_Index range <>) of Object_Word; type Object_Word_Array is array(Object_Index range <>) of Object_Word;
type Object_Character_Array_Pointer is access all Object_Character_Array;
for Object_Character_Array_Pointer'Size use Object_Pointer_Bits;
type Constant_Object_Character_Array_Pointer is access constant Object_Character_Array;
for Constant_Object_Character_Array_Pointer'Size use Object_Pointer_Bits;
subtype Thin_Object_Character_Array is Object_Character_Array(Object_Index'Range);
type Thin_Object_Character_Array_Pointer is access all Thin_Object_Character_Array;
for Thin_Object_Character_Array_Pointer'Size use Object_Pointer_Bits;
type Object_Kind is ( type Object_Kind is (
Moved_Object, -- internal use only Moved_Object, -- internal use only
Pointer_Object, Pointer_Object,
@ -303,18 +297,18 @@ package H2.Scheme is
procedure Close (Stream: in out Stream_Record) is abstract; procedure Close (Stream: in out Stream_Record) is abstract;
procedure Read (Stream: in out Stream_Record; procedure Read (Stream: in out Stream_Record;
Data: out Object_String; Data: out Object_Character_Array;
Last: out Object_String_Size) is abstract; Last: out Object_Size) is abstract;
procedure Write (Stream: in out Stream_Record; procedure Write (Stream: in out Stream_Record;
Data: out Object_String; Data: out Object_Character_Array;
Last: out Object_String_Size) is abstract; Last: out Object_Size) is abstract;
type Stream_Pointer is access all Stream_Record'Class; type Stream_Pointer is access all Stream_Record'Class;
type Stream_Allocator is access type Stream_Allocator is access
procedure (Interp: in out Interpreter_Record; procedure (Interp: in out Interpreter_Record;
Name: Constant_Object_String_Pointer; Name: access Object_Character_Array;
Result: out Stream_Pointer); Result: out Stream_Pointer);
type Stream_Deallocator is access type Stream_Deallocator is access
@ -339,10 +333,10 @@ package H2.Scheme is
type IO_Record is record type IO_Record is record
--type IO_Record is limited record --type IO_Record is limited record
Stream: Stream_Pointer := null; Stream: Stream_Pointer := null;
--Data: Object_String(1..2048) := (others => Object_Character'First); --Data: Object_Character_Array(1..2048) := (others => Object_Character'First);
Data: Object_String(1..5) := (others => Object_Character'First); Data: Object_Character_Array(1..5) := (others => Object_Character'First);
Last: Object_String_Size := 0; Last: Object_Size := 0;
Pos: Object_String_Size := 0; Pos: Object_Size := 0;
Flags: IO_Flags := 0; -- EOF, ERROR Flags: IO_Flags := 0; -- EOF, ERROR
Next: IO_Pointer := null; Next: IO_Pointer := null;
Iochar: IO_Character_Record; -- the last character read. Iochar: IO_Character_Record; -- the last character read.
@ -430,12 +424,6 @@ package H2.Scheme is
-- ----------------------------------------------------------------------------- -- -----------------------------------------------------------------------------
type Buffer_Record is record
Ptr: Thin_Object_String_Pointer := null;
Len: Object_String_Size := 0;
Last: Object_String_Size := 0;
end record;
private private
type Heap_Element_Array is array(Heap_Size range <>) of aliased Heap_Element; type Heap_Element_Array is array(Heap_Size range <>) of aliased Heap_Element;
@ -449,6 +437,12 @@ 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 Buffer_Record is record
Ptr: Thin_Object_Character_Array_Pointer := null;
Len: Object_Size := 0;
Last: Object_Size := 0;
end record;
type Token_Kind is (End_Token, type Token_Kind is (End_Token,
Identifier_Token, Identifier_Token,
Left_Parenthesis_Token, Left_Parenthesis_Token,
@ -474,8 +468,8 @@ private
--type Interpreter_Record is tagged limited record --type Interpreter_Record is tagged limited record
type Interpreter_Record is limited record type Interpreter_Record is limited record
--Self: Interpreter_Pointer := null;
Self: Interpreter_Pointer := Interpreter_Record'Unchecked_Access; -- Current instance's pointer Self: Interpreter_Pointer := Interpreter_Record'Unchecked_Access; -- Current instance's pointer
Storage_Pool: Storage_Pool_Pointer := null; Storage_Pool: Storage_Pool_Pointer := null;
Trait: Option_Record(Trait_Option); Trait: Option_Record(Trait_Option);
Stream: Option_Record(Stream_Option); Stream: Option_Record(Stream_Option);
@ -483,20 +477,21 @@ private
Heap: Heap_Pointer_Array := (others => null); Heap: Heap_Pointer_Array := (others => null);
Current_Heap: Heap_Number := Heap_Number'First; Current_Heap: Heap_Number := Heap_Number'First;
Root_Table: Object_Pointer := Nil_Pointer;
Symbol_Table: Object_Pointer := Nil_Pointer; Symbol_Table: Object_Pointer := Nil_Pointer;
Root_Environment: Object_Pointer := Nil_Pointer; Root_Environment: Object_Pointer := Nil_Pointer;
Environment: Object_Pointer := Nil_Pointer; Environment: Object_Pointer := Nil_Pointer;
Stack: Object_Pointer := Nil_Pointer; Stack: aliased Object_Pointer := Nil_Pointer;
Mark: Object_Pointer := Nil_Pointer; Mark: Object_Pointer := Nil_Pointer;
Top: Top_Record; -- temporary object pointers
Base_Input: aliased IO_Record; Base_Input: aliased IO_Record;
Input: IO_Pointer := null; Input: IO_Pointer := null;
Token: Token_Record; Token: Token_Record;
LC_Unfetched: Standard.Boolean := Standard.False; LC_Unfetched: Standard.Boolean := Standard.False;
Top: Top_Record; STACK_XXX: aliased Object_Pointer := Nil_Pointer;
end record; end record;
package Token is package Token is
@ -513,10 +508,10 @@ private
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); Value: in Object_Character_Array);
procedure Append_String (Interp: in out Interpreter_Record; procedure Append_String (Interp: in out Interpreter_Record;
Value: in Object_String); Value: in Object_Character_Array);
pragma Inline (Append_String); pragma Inline (Append_String);
procedure Append_Character (Interp: in out Interpreter_Record; procedure Append_Character (Interp: in out Interpreter_Record;

3
lib/lib.gpr.in
View File

@ -14,6 +14,7 @@ project Lib is
"h2-pool.ads", "h2-pool.ads",
"h2-scheme.adb", "h2-scheme.adb",
"h2-scheme.ads", "h2-scheme.ads",
"h2-scheme-execute.adb",
"h2-scheme-token.adb", "h2-scheme-token.adb",
"h2-utf8.adb", "h2-utf8.adb",
"h2-utf8.ads" "h2-utf8.ads"
@ -28,7 +29,7 @@ project Lib is
package Compiler is package Compiler is
for Default_Switches ("Ada") use ( for Default_Switches ("Ada") use (
"-gnata", "-gnato", "-gnatN", "-gnatwl", "-gnat95", "-gnatW8" "-gnata", "-gnato", "-gnatN", "-gnatwl", "-gnat95", "-gnatW8", "-g"
); );
end Compiler; end Compiler;