added initial files

Makefile.in

@@ -0,0 +1,7 @@
+all:
+	cd @abs_builddir@/lib; make all
+	cd @abs_builddir@/cmd; make all
+
+clean:
+	cd @abs_builddir@/lib; make clean
+	cd @abs_builddir@/cmd; make clean

cmd/Makefile.in

@@ -0,0 +1,23 @@
+all: @abs_builddir@/@ADA_OBJDIR@
+	#gnatmake -x -aP@abs_builddir@ -Pscheme
+	gprbuild @abs_builddir@/scheme.gpr
+
+install: install-exec install-data
+
+install-data:
+
+install-exec:
+
+uninstall:
+
+@abs_builddir@/@ADA_OBJDIR@:
+	mkdir -p @abs_builddir@/@ADA_OBJDIR@
+
+clean:
+	rm -rf @abs_builddir@/@ADA_OBJDIR@
+	rm -f @abs_builddir@/*.ali
+	rm -f @abs_builddir@/*.so
+	rm -f @abs_builddir@/*.a
+	rm -f @abs_builddir@/*.cgpr
+
+distclean: clean

cmd/scheme.adb

@@ -0,0 +1,52 @@
+with H2.Scheme;
+with Storage;
+with Ada.Text_IO;
+
+procedure scheme is
+	package S renames H2.Scheme;
+
+	Pool: aliased Storage.Global_Pool;
+	SI: S.Interpreter_Record;
+
+begin
+	Ada.Text_Io.Put_Line (S.Object_Word'Image(S.Object_Pointer_Bytes));
+
+	S.Open (SI, 2_000_000, Pool'Unchecked_Access);
+	--S.Open (SI, null);
+	S.Evaluate (SI);
+	S.Close (SI);
+
+	declare
+		subtype x is S.Object_Record (S.Moved_Object, 0);
+		subtype y is S.Object_Record (S.Pointer_Object, 1);
+		subtype z is S.Object_Record (S.Character_Object, 1);
+		subtype q is S.Object_Record (S.Byte_Object, 1);
+		a: x;
+		b: y;
+		c: z;
+		d: q;
+          w: S.Object_Word;
+	begin
+	Ada.Text_Io.Put_Line (S.Object_Word'Image(w'Size));
+	Ada.Text_Io.Put_Line (S.Object_Word'Image(S.Object_Word'Size));
+	Ada.Text_IO.Put_Line ("------");
+	Ada.Text_Io.Put_Line (S.Object_Word'Image(x'Size));
+	Ada.Text_Io.Put_Line (S.Object_Word'Image(y'Size));
+	Ada.Text_Io.Put_Line (S.Object_Word'Image(z'Size));
+	Ada.Text_Io.Put_Line (S.Object_Word'Image(q'Size));
+	Ada.Text_Io.Put_Line (S.Object_Word'Image(x'Max_Size_In_Storage_Elements));
+	Ada.Text_Io.Put_Line (S.Object_Word'Image(y'Max_Size_In_Storage_Elements));
+	Ada.Text_Io.Put_Line (S.Object_Word'Image(z'Max_Size_In_Storage_Elements));
+	Ada.Text_Io.Put_Line (S.Object_Word'Image(q'Max_Size_In_Storage_Elements));
+	Ada.Text_Io.Put_Line (S.Object_Word'Image(a'Size));
+	Ada.Text_Io.Put_Line (S.Object_Word'Image(b'Size));
+	Ada.Text_Io.Put_Line (S.Object_Word'Image(c'Size));
+	Ada.Text_Io.Put_Line (S.Object_Word'Image(c'Size));
+	Ada.Text_Io.Put_Line (S.Object_Integer'Image(S.Object_Integer'First));
+	Ada.Text_Io.Put_Line (S.Object_Integer'Image(S.Object_Integer'Last));
+	end;
+
+	Ada.Text_IO.Put_Line ("BYE...");
+
+
+end scheme;

cmd/scheme.gpr.in

@@ -0,0 +1,35 @@
+
+with "@abs_builddir@/../lib/libh2";
+
+project H2_Scheme is
+
+	for Main use ("scheme");
+
+	for Exec_Dir use ".";
+
+	for Source_Dirs use (
+		"@abs_builddir@/../lib",
+		"@abs_builddir@",
+		"@abs_srcdir@"
+	);
+	for Source_Files use (
+		"storage.ads",
+		"storage.adb",
+		"scheme.adb"
+	);
+	for Object_Dir use "@ADA_OBJDIR@";
+
+	package Compiler is
+		for Default_Switches ("Ada") use (
+			"-gnata", "-gnato", "-gnatN",  "-gnatwl",
+			"-I@abs_srcdir@/../lib"
+		);
+	end Compiler;
+
+	package Builder is
+		for Executable ("scheme.adb") use "h2scm";
+	end Builder;
+
+end H2_Scheme;
+
+

cmd/storage.adb

@@ -0,0 +1,66 @@
+with System;
+--with System.Address_Image;
+
+
+with Ada.Text_IO;
+
+package body Storage is
+
+	type Size_T is mod 2 ** System.Word_Size;
+
+	function Sys_Malloc (Size: Size_T) return System.Address;
+	--pragma Import (C, Sys_Malloc, Link_Name => "malloc");
+	pragma Import (Convention => C, Entity => Sys_Malloc, External_Name => "malloc");
+
+	procedure Sys_Free (Ptr: System.Address);
+	--pragma Import (C, Sys_Free, Link_Name => "free");
+	pragma Import (Convention => C, Entity => Sys_Free, External_Name => "free");
+
+	procedure Allocate (Pool: in out Global_Pool; Address : out System.Address; Size: in SSE.Storage_Count; Alignment: in SSE.Storage_Count) is
+		tmp: System.Address;
+		use type SSE.Storage_Count;
+	begin
+Ada.Text_IO.Put_Line ("QSE.Global_Pool Allocating " & SSE.Storage_Count'Image (Size) & " " & SSE.Storage_Count'Image (((Size + Alignment - 1) / Alignment) * Alignment));
+		tmp := Sys_Malloc (Size_T(((Size + Alignment - 1) / Alignment) * Alignment));
+		if System."=" (tmp, System.Null_Address) then
+			raise Storage_Error;
+		else
+			Address := tmp;
+--Ada.Text_IO.Put_Line ("QSE.Global_Pool Returning " & System.Address_Image (Address));
+		end if;
+	end Allocate;
+
+	procedure Deallocate (Pool: in out Global_Pool; Address : in System.Address; Size: in SSE.Storage_Count; Alignment: in SSE.Storage_Count) is
+	begin
+Ada.Text_IO.Put_Line ("QSE.Global_Pool Deallocating ");
+--Ada.Text_IO.Put_Line ("QSE.Global_Pool Deallocating " & System.Address_Image (Address));
+		Sys_Free (Address);
+	end Deallocate;
+
+	function Storage_Size (Pool: in Global_Pool) return SSE.Storage_Count is
+	begin
+Ada.Text_IO.Put_Line ("QSE.Global_Pool Storage_Size ");
+		return SSE.Storage_Count'Last;
+	end Storage_Size;
+
+
+	-- TODO: find a better solution
+	-- gnat 3.15p somehow looks for the rountines below when H2.Pool is used.
+	-- let me put these routines here temporarily until i find a proper solution.
+	procedure Allocate_315P (Pool: in out SSP.Root_Storage_Pool'Class; Address : out System.Address; Size: in SSE.Storage_Count; Alignment: in SSE.Storage_Count);
+	pragma Export (Ada, Allocate_315P, "system__storage_pools__allocate");
+	procedure Allocate_315P (Pool: in out SSP.Root_Storage_Pool'Class; Address : out System.Address; Size: in SSE.Storage_Count; Alignment: in SSE.Storage_Count) is
+	begin
+ada.text_io.put_line ("system__storage_pools__allocate...");
+		SSP.Allocate (Pool, Address, Size, Alignment);
+	end Allocate_315P;
+
+	procedure Deallocate_315P (Pool: in out SSP.Root_Storage_Pool'Class; Address : in System.Address; Size: in SSE.Storage_Count; Alignment: in SSE.Storage_Count);
+	pragma Export (Ada, Deallocate_315P, "system__storage_pools__deallocate");
+	procedure Deallocate_315P (Pool: in out SSP.Root_Storage_Pool'Class; Address : in System.Address; Size: in SSE.Storage_Count; Alignment: in SSE.Storage_Count) is
+	begin
+ada.text_io.put_line ("system__storage_pools__deallocate...");
+		SSP.Deallocate (Pool, Address, Size, Alignment);
+	end Deallocate_315P;
+end Storage;
+

cmd/storage.ads

@@ -0,0 +1,26 @@
+with System.Storage_Pools;
+with System.Storage_Elements;
+
+package Storage is
+
+	package SSE renames System.Storage_Elements;
+	package SSP renames System.Storage_Pools;
+
+	type Global_Pool is new SSP.Root_Storage_Pool with private;
+
+	procedure Allocate (Pool:      in out Global_Pool;
+	                    Address:   out System.Address;
+	                    Size:      in SSE.Storage_Count;
+	                    Alignment: in SSE.Storage_Count);
+
+	procedure Deallocate (Pool:      in out Global_Pool;
+	                      Address:   in System.Address;
+	                      Size:      in SSE.Storage_Count;
+	                      Alignment: in SSE.Storage_Count);
+
+	function Storage_Size (Pool: in Global_Pool) return SSE.Storage_Count;
+
+private
+	type Global_Pool is new SSP.Root_Storage_Pool with null record;
+
+end Storage;

configure.ac

@@ -0,0 +1,24 @@
+AC_INIT([H2], 0.1.0)
+dnl AM_INIT_AUTOMAKE
+AC_PROG_CC
+
+AC_ARG_WITH([ada-objdir],
+	[AS_HELP_STRING(--with-ada-objdir,specify ada object directory path)],
+	[ada_objdir=$withval]
+)
+if test -n "$ada_objdir"
+then
+        AC_SUBST(ADA_OBJDIR, "$ada_objdir")
+else
+        AC_SUBST(ADA_OBJDIR, "objdir")
+fi
+
+AC_CONFIG_FILES([
+	Makefile
+	lib/Makefile
+	lib/lib.gpr
+	lib/libh2.gpr
+	cmd/Makefile
+	cmd/scheme.gpr
+])
+AC_OUTPUT

lib/Makefile.in

@@ -0,0 +1,24 @@
+all: @abs_builddir@/@ADA_OBJDIR@
+	#gnatmake -x -aP@abs_builddir@ -Plib
+	gprbuild @abs_builddir@/lib.gpr
+
+install: install-exec install-data
+
+install-data:
+
+install-exec:
+
+uninstall:
+
+@abs_builddir@/@ADA_OBJDIR@:
+	mkdir -p @abs_builddir@/@ADA_OBJDIR@
+
+clean:
+	rm -rf @abs_builddir@/@ADA_OBJDIR@
+	rm -f @abs_builddir@/*.ali
+	rm -f @abs_builddir@/*.so
+	rm -f @abs_builddir@/*.a
+	rm -f @abs_builddir@/*.cgpr
+	
+
+distclean: clean

lib/h2-pool.adb

@@ -0,0 +1,86 @@
+with Ada.Unchecked_Conversion;
+with Ada.Unchecked_Deallocation;
+
+package body H2.Pool is
+
+	function Allocate (Pool: in Storage_Pool_Pointer := null) return Pointer_Type is
+		P: Storage_Pool_Pointer;
+
+	begin
+		if Pool = null then
+			P := Storage_Pool;
+		else
+			P := Pool;
+		end if;
+
+		if P = null then
+			return new Normal_Type;
+		else
+			declare
+				type Pooled_Pointer is access Normal_Type;
+				for Pooled_Pointer'Storage_Pool use P.all;
+				function To_Pointer_Type is new Ada.Unchecked_Conversion (Pooled_Pointer, Pointer_Type);
+				Tmp: Pooled_Pointer;
+			begin
+				Tmp := new Normal_Type;
+				return To_Pointer_Type (Tmp);
+			end; 
+		end if;
+	end Allocate;
+
+	function Allocate (Source: in Normal_Type; 
+	                   Pool:   in Storage_Pool_Pointer := null) return Pointer_Type is
+		P: Storage_Pool_Pointer;
+	begin
+		if Pool = null then
+			P := Storage_Pool;
+		else
+			P := Pool;
+		end if;
+
+		if P = null then
+			return new Normal_Type'(Source);
+		else
+			declare
+				type Pooled_Pointer is access Normal_Type;
+				for Pooled_Pointer'Storage_Pool use P.all;
+				function To_Pointer_Type is new Ada.Unchecked_Conversion (Pooled_Pointer, Pointer_Type);
+				Tmp: Pooled_Pointer;
+			begin
+				Tmp := new Normal_Type'(Source);
+				return To_Pointer_Type (Tmp);
+			end; 
+		end if;
+	end Allocate;
+
+	procedure Deallocate (Target: in out Pointer_Type;
+	                      Pool:   in Storage_Pool_Pointer := null) is
+		P: Storage_Pool_Pointer;
+	begin
+		if Pool = null then
+			P := Storage_Pool;
+		else
+			P := Pool;
+		end if;
+
+		if P = null then
+			declare
+				procedure Dealloc is new Ada.Unchecked_Deallocation (Normal_Type, Pointer_Type);
+			begin
+				Dealloc (Target);
+			end;
+		else
+			declare
+				type Pooled_Pointer is access Normal_Type;
+				for Pooled_Pointer'Storage_Pool use P.all;
+				function To_Pooled_Pointer is new Ada.Unchecked_Conversion (Pointer_Type, Pooled_Pointer);
+				procedure Dealloc is new Ada.Unchecked_Deallocation (Normal_Type, Pooled_Pointer);
+				Tmp: Pooled_Pointer := To_Pooled_Pointer (Target);
+			begin
+				Dealloc (Tmp);
+				Target := null;	
+			end;
+		end if;
+	end Deallocate;
+
+end H2.Pool;

lib/h2-pool.ads

@@ -0,0 +1,25 @@
+--------------------------------------------------------------------
+-- Instantantiate this package before using. To allocate integers,
+--
+--   package Integer_Pool is new Pool (Integer, Integer_Pointer, Storage_Pool);
+--
+--   Integer_Pool.Allocate (10);
+--------------------------------------------------------------------
+
+generic
+	type Normal_Type is private;
+	type Pointer_Type is access Normal_Type;
+	Storage_Pool: in Storage_Pool_Pointer := null;
+
+package H2.Pool is
+
+	function Allocate (Pool: in Storage_Pool_Pointer := null) return Pointer_Type;
+
+	function Allocate (Source: in Normal_Type; 
+	                   Pool:   in Storage_Pool_Pointer := null) return Pointer_Type;
+
+	procedure Deallocate (Target: in out Pointer_Type;
+	                      Pool:   in     Storage_Pool_Pointer := null);
+
+end H2.Pool;
+

lib/h2-scheme.ads

@@ -0,0 +1,341 @@
+---------------------------------------------------------------------
+--  #####                                           #     #  #####  
+-- #     #  ####  #    # ###### #    # ######       #     # #     # 
+-- #       #    # #    # #      ##  ## #            #     #       # 
+--  #####  #      ###### #####  # ## # #####  ##### #######  #####  
+--       # #      #    # #      #    # #            #     # #       
+-- #     # #    # #    # #      #    # #            #     # #       
+--  #####   ####  #    # ###### #    # ######       #     # ####### 
+---------------------------------------------------------------------
+
+with System;
+with System.Storage_Pools;
+
+
+with Ada.Unchecked_Conversion;
+-- TODO: delete these after debugging
+with ada.text_io;
+with ada.wide_text_io;
+with ada.integer_text_io;
+with ada.long_integer_text_io;
+--with system.address_image;
+-- TODO: delete above after debugging
+
+package H2.Scheme is
+
+	-- An object pointer takes up as many bytes as a system word.
+	Object_Pointer_Bits: constant := System.Word_Size;
+	Object_Pointer_Bytes: constant := Object_Pointer_Bits / System.Storage_Unit;
+
+	-- I use the lower 2 bits to indicate the type of an object pointer.
+	-- A real object pointer is typically allocated on a word boundary.
+	-- As a result, the lower 2 bits should always be 0. Using this
+	-- property, I keep some other values at the lower 2 bits to indicate
+	-- some other direct values like an integer or a character.
+	Object_Pointer_Type_Bits: constant := 2;
+	type Object_Pointer_Type is mod 2 ** Object_Pointer_Type_Bits;
+	Object_Pointer_Type_Pointer:   constant Object_Pointer_Type := 2#00#;
+	Object_Pointer_Type_Integer:   constant Object_Pointer_Type := 2#01#;
+	Object_Pointer_Type_Character: constant Object_Pointer_Type := 2#10#;
+	Object_Pointer_Type_Byte:      constant Object_Pointer_Type := 2#11#;
+	Object_Pointer_Type_Mask:      constant Object_Pointer_Type := 2#11#;
+
+	type Object_Record;
+	type Object_Pointer is access all Object_Record;
+	for Object_Pointer'Size use Object_Pointer_Bits;
+
+	-- Object_Word is a numeric type as large as Object_Poinetr;
+	type Object_Word is mod 2 ** Object_Pointer_Bits;
+	for Object_Word'Size use Object_Pointer_Bits;
+
+	-- Object_Signed_Word is the signed version of Object_Word.
+	-- Note Object_Word is a modular type while this is a signed range.
+	type Object_Signed_Word is range -(2 ** (Object_Pointer_Bits - 1)) ..
+	                                 +(2 ** (Object_Pointer_Bits - 1)) - 1;
+	for Object_Signed_Word'Size use Object_Pointer_Bits;
+
+	-- The actual number of bits for an integer the number of bits excluding
+	-- the pointer type bits.
+	Object_Integer_Bits: constant := Object_Pointer_Bits - Object_Pointer_Type_Bits;
+
+	-- Object_Integer represents the range of SmallInteger.
+	-- It defines an integer that can be held in the upper Object_Integer_Bits
+	-- bits. Conversion functions betwen Object_Integer and Object_Pointer
+	-- use the highest 1 bit to represent the sign after shifting. So, the 
+	-- range is shrunk further by 1 bit, resulting in -2 in the foluma below.
+	-- -----------------------------------------------------------------------
+	--   type Object_Integer is range -(2 ** (Object_Integer_Bits - 2)) ..
+	--                                +(2 ** (Object_Integer_Bits - 2)) - 1;
+	-- -----------------------------------------------------------------------
+	-- If i don't include -(2 ** (Object_Integer_Bits - 1)) into the range, 
+	-- it can be extended to a larger range. That's because the excluded number
+	-- conflicts with the highest sign bit during the conversion process.
+	-- -----------------------------------------------------------------------
+	type Object_Integer is range -(2 ** (Object_Integer_Bits - 1)) + 1 ..
+	                             +(2 ** (Object_Integer_Bits - 1)) - 1;
+	-- -----------------------------------------------------------------------
+	-- What is a better choice? TODO: decide what to use
+	-- -----------------------------------------------------------------------
+	-- Let Object_Integer take up as large a space as Object_Pointer
+	-- despite the actual range of Object_Integer.
+	for Object_Integer'Size use Object_Pointer_Bits;
+
+	-- The Object_Size type defines the size of object payload.
+	-- It is the number of payload items for each object kind.
+	--type Object_Size is new Object_Word range 0 .. (2 ** (System.Word_Size - 1)) - 1;
+	--type Object_Size is new Object_Word range 0 .. 1000; -- TODO: remove this line and uncommect the live above
+	type Object_Size is new Object_Word;
+	for Object_Size'Size use Object_Pointer_Bits; -- for GC
+
+	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;
+	--package Text_IO renames Ada.Wide_Text_IO;
+	subtype Object_Character is Standard.Character;
+	subtype Object_String is Standard.String;
+	package Text_IO renames Ada.Text_IO;
+
+	type Object_Byte_Array is array (Object_Size range <>) of Object_Byte;
+	type Object_Character_Array is array (Object_Size range <>) of Object_Character;
+	type Object_Pointer_Array is array (Object_Size range <>) of Object_Pointer;
+	type Object_Word_Array is array (Object_Size range <>) of Object_Word;
+
+	type Object_Kind is (
+		Moved_Object, -- internal use only
+		Pointer_Object,
+		Character_Object,
+		Byte_Object,
+		Word_Object
+	);
+	for Object_Kind use (
+		Moved_Object => 0,
+		Pointer_Object => 1,
+		Character_Object => 2,
+		Byte_Object => 3,
+		Word_Object => 4
+	);
+
+	-- -----------------------------------------------------------------------
+
+	-- Object_Record contains the Flags field that can be used
+	-- freely for management purpose. The Object_Flags type
+	-- represents the value that can be stored in this field.
+	type Object_Flags is mod 2 ** 4;
+	Syntax_Object: constant Object_Flags := Object_Flags'(2#0001#);
+
+	type Syntax_Code is mod 2 ** 4;
+	AND_SYNTAX:    constant Syntax_Code := Syntax_Code'(0);
+	BEGIN_SYNTAX:  constant Syntax_Code := Syntax_Code'(0);
+	CASE_SYNTAX:   constant Syntax_Code := Syntax_Code'(0);
+	COND_SYNTAX:   constant Syntax_Code := Syntax_Code'(0);
+	DEFINE_SYNTAX: constant Syntax_Code := Syntax_Code'(0);
+	IF_SYNTAX:     constant Syntax_Code := Syntax_Code'(0);
+	LAMBDA_SYNTAX: constant Syntax_Code := Syntax_Code'(0);
+	LET_SYNTAX:    constant Syntax_Code := Syntax_Code'(0);
+	LETAST_SYNTAX: constant Syntax_Code := Syntax_Code'(0);
+	LETREC_SYNTAX: constant Syntax_Code := Syntax_Code'(0);
+	OR_SYNTAX:     constant Syntax_Code := Syntax_Code'(0);
+	QUOTE_SYNTAX:  constant Syntax_Code := Syntax_Code'(0);
+	SET_SYNTAX:    constant Syntax_Code := Syntax_Code'(0);
+
+
+	type Object_Tag is (
+		Unknown_Object, 
+		Cons_Object,
+		String_Object,
+		Symbol_Object,
+		Number_Object,
+		Array_Object,
+		Table_Object,
+		Lambda_Object,
+		Continuation_Object,
+		Frame_Object
+	);
+
+	type Object_Record (Kind: Object_Kind; Size: Object_Size) is record
+		Flags: Object_Flags := 0;
+		Scode: Syntax_Code := 0;
+		Tag: Object_Tag := Unknown_Object;
+
+		-- Object payload:
+		--  I assume that the smallest payload is able to hold an 
+		--  object pointer by specifying the alignement attribute 
+		--  to Object_Pointer_Bytes. this implementation will break
+		--  severely if this assumption is not correct.
+		case Kind is
+			when Moved_Object =>
+				New_Pointer: Object_Pointer := null;
+			when Pointer_Object =>
+				Pointer_Slot: Object_Pointer_Array (1 .. Size) := (others => null);
+			when Character_Object =>
+				Character_Slot: Object_Character_Array (0 .. Size) := (others => Object_Character'First);
+			when Byte_Object =>
+				Byte_Slot: Object_Byte_Array (1 .. Size) := (others => 0);
+			when Word_Object =>
+				Word_Slot: Object_Word_Array (1 .. Size) := (others => 0);
+		end case;
+	end record;
+	for Object_Record use record
+		Kind  at 0 range 0 .. 3; -- 4 bits (0 .. 15)
+		Flags at 0 range 4 .. 7; -- 4 bits 
+		Scode at 0 range 8 .. 11; -- 4 bits (0 .. 15)
+		Tag   at 0 range 12 .. 15; -- 4 bits (0 .. 15)
+		-- there are still some space unused in the first word. What can i do?
+	end record;
+	for Object_Record'Alignment use Object_Pointer_Bytes;
+
+	-- the following 3 size types are defined for limiting the object size range.
+	subtype Empty_Object_Record is Object_Record (Byte_Object, 0);
+
+	-- the number of bytes in an object header. this is fixed in size
+	Object_Header_Bytes: constant Object_Size := Empty_Object_Record'Max_Size_In_Storage_Elements;
+	-- the largest number of bytes that an object can hold after the header
+	Object_Payload_Max_Bytes: constant Object_Size := Object_Size'Last - Object_Header_Bytes;
+
+	-- the following types are defined to set the byte range of the object data.
+	-- the upper bound is set to the maximum that don't cause overflow in calcuating the size in bits.
+	-- the compiler doesn't seem to be able to return 'Size or 'Max_Size_In_Storage_Elements properly
+	-- when the number of bits calculated overflows.
+	subtype Byte_Object_Size is Object_Size range
+		Object_Size'First .. (Object_Payload_Max_Bytes / (Object_Byte'Max_Size_In_Storage_Elements * System.Storage_Unit));
+	subtype Character_Object_Size is Object_Size range
+		Object_Size'First .. (Object_Payload_Max_Bytes / (Object_Character'Max_Size_In_Storage_Elements * System.Storage_Unit));
+	subtype Pointer_Object_Size is Object_Size range
+		Object_Size'First .. (Object_Payload_Max_Bytes / (Object_Pointer'Max_Size_In_Storage_Elements * System.Storage_Unit));
+	subtype Word_Object_Size is Object_Size range
+		Object_Size'First .. (Object_Payload_Max_Bytes / (Object_Word'Max_Size_In_Storage_Elements * System.Storage_Unit));
+
+	-- -----------------------------------------------------------------------------
+	-- Various pointer classification and conversion procedures
+	-- -----------------------------------------------------------------------------
+	function Is_Pointer (Pointer: in Object_Pointer) return Standard.Boolean;
+	function Is_Special_Pointer (Pointer: in Object_Pointer) return Standard.Boolean;
+	function Is_Normal_Pointer (Pointer: in Object_Pointer) return Standard.Boolean;
+	function Is_Integer (Pointer: in Object_Pointer) return Standard.Boolean;
+	function Is_Character (Pointer: in Object_Pointer) return Standard.Boolean;
+	function Is_Byte (Pointer: in Object_Pointer) return Standard.Boolean;
+
+	function Integer_To_Pointer (Int: in Object_Integer) return Object_Pointer;
+	function Character_To_Pointer (Char: in Object_Character) return Object_Pointer;
+	function Byte_To_Pointer (Byte: in Object_Byte) return Object_Pointer;
+
+	function Pointer_To_Integer (Pointer: in Object_Pointer) return Object_Integer;
+	function Pointer_To_Character (Pointer: in Object_Pointer) return Object_Character;
+	function Pointer_To_Byte (Pointer: in Object_Pointer) return Object_Byte;
+
+	pragma Inline (Is_Special_Pointer);
+	pragma Inline (Is_Pointer);
+	pragma Inline (Is_Integer);
+	pragma Inline (Is_Character);
+	pragma Inline (Integer_To_Pointer);
+	pragma Inline (Character_To_Pointer);
+	pragma Inline (Byte_To_Pointer);
+	pragma Inline (Pointer_To_Integer);
+	pragma Inline (Pointer_To_Character);
+	pragma Inline (Pointer_To_Byte);
+
+	-- -----------------------------------------------------------------------------
+	-- While I could define Memory_Element and Memory_Size to be
+	-- the subtype of Object_Byte and Object_Size each, they are not
+	-- logically the same thing.
+	-- subtype Storage_Element is Object_Byte;
+	-- subtype Storage_Count is Object_Size;
+	type Memory_Element is mod 2 ** System.Storage_Unit;
+	type Memory_Size is range 0 .. (2 ** (System.Word_Size - 1)) - 1;
+
+	type Interpreter_Record is limited private;
+
+	type Trait_Mask is mod 2 ** System.Word_Size;
+	No_Garbage_Collection: constant Trait_Mask := 2 ** 0;
+
+	type Option_Kind is (Trait_Option);
+	type Option_Record (Kind: Option_Kind) is record
+		case Kind is
+			when Trait_Option =>
+				Trait_Bits: Trait_Mask := 0;
+		end case;
+	end record;  
+
+	-- -----------------------------------------------------------------------------
+
+	-- The nil/true/false object are represented by special pointer values.
+	-- The special values are defined under the assumption that actual objects
+	-- are never allocated on one of these addresses. Addresses of 0, 4, 8 are
+	-- very low, making the assumption pretty safe.
+	Nil_Word: constant Object_Word := 2#0000#; -- 0
+	--Nil_Pointer: constant Object_Pointer;
+	--for Nil_Pointer'Address use Nil_Word'Address;
+	--pragma Import (Ada, Nil_Pointer);
+
+	True_Word: constant Object_Word := 2#0100#; -- 4
+	--True_Pointer: constant Object_Pointer;
+	--for True_Pointer'Address use True_Word'Address;
+	--pragma Import (Ada, True_Pointer);
+
+	False_Word: constant Object_Word := 2#1000#; -- 8
+	--False_Pointer: constant Object_Pointer;
+	--for False_Pointer'Address use False_Word'Address;
+	--pragma Import (Ada, False_Pointer);
+
+	function Object_Word_To_Pointer is new Ada.Unchecked_Conversion (Object_Word, Object_Pointer);
+	function Object_Pointer_To_Word is new Ada.Unchecked_Conversion (Object_Pointer, Object_Word);
+	Nil_Pointer: constant Object_Pointer := Object_Word_To_Pointer (Nil_Word);
+	True_Pointer: constant Object_Pointer := Object_Word_To_Pointer (True_Word);
+	False_Pointer: constant Object_Pointer := Object_Word_To_Pointer (False_Word);
+
+	-- -----------------------------------------------------------------------------
+
+	procedure Open (Interp:           in out Interpreter_Record;
+	                Initial_Heap_Size:in     Memory_Size;
+	                Storage_Pool:     in     Storage_Pool_Pointer := null);
+
+	procedure Close (Interp: in out Interpreter_Record);
+
+	procedure Evaluate (Interp: in out Interpreter_Record);
+
+	procedure Set_Option (Interp: in out Interpreter_Record;
+	                      Option: in     Option_Record);
+
+	procedure Get_Option (Interp: in out Interpreter_Record;
+	                      Option: in out Option_Record);
+
+	-- -----------------------------------------------------------------------------
+
+private
+	type Heap_Array is array (Memory_Size range <>) of aliased Memory_Element;
+
+	type Heap_Record (Size: Memory_Size) is record
+		Space: Heap_Array (1 .. Size) := (others => 0);
+		Bound: Memory_Size := 0;
+	end record;
+	for Heap_Record'Alignment use Object_Pointer_Bytes;
+	type Heap_Pointer is access all Heap_Record;
+
+	type Heap_Number is mod 2 ** 1;
+	type Heap_Pointer_Array is Array (Heap_Number'First .. Heap_Number'Last) of Heap_Pointer;
+
+	type Register_Record is limited record
+		Code:  Object_Pointer := Nil_Pointer;
+		Envir: Object_Pointer := Nil_Pointer;
+		Args:  Object_Pointer := Nil_Pointer;
+		Next:  Object_Pointer := Nil_Pointer;
+	end record;
+
+	type Interpreter_Record is limited record
+		Storage_Pool: Storage_Pool_Pointer := null;
+		Trait: Option_Record (Trait_Option);
+
+		Heap: Heap_Pointer_Array := (others => null);
+		Current_Heap: Heap_Number := Heap_Number'First;
+
+		Root_Table: Object_Pointer := Nil_Pointer;
+		Symbol_Table: Object_Pointer := Nil_Pointer;
+		Environment: Object_Pointer := Nil_Pointer;
+		Stack: Object_Pointer := Nil_Pointer;
+
+		R: Register_Record;
+	end record;
+
+end H2.Scheme;

lib/h2.ads

@@ -0,0 +1,10 @@
+with System.Storage_Pools;
+
+package H2 is
+
+	subtype Character is Standard.Wide_Character;
+
+	type Storage_Pool_Pointer is 
+		access all System.Storage_Pools.Root_Storage_Pool'Class;
+
+end H2;

lib/lib.gpr.in

@@ -0,0 +1,33 @@
+project Lib is
+
+	for Source_Dirs use ("@abs_srcdir@");
+	for Library_Name use "h2";
+	for Library_Kind use "dynamic";
+	for Library_Dir use ".";
+	--for Library_Src_Dir use ".";
+	for Object_Dir use "@ADA_OBJDIR@";
+
+	for Source_Files use (
+		"h2.ads",
+		"h2-pool.adb",
+		"h2-pool.ads",
+		"h2-scheme.adb",
+		"h2-scheme.ads"
+	);
+	for Library_Interface use (
+		"h2",
+		"h2.pool",
+		"h2.scheme"
+	);
+
+	package Compiler is
+		for Default_Switches ("Ada") use (
+			"-gnata", "-gnato", "-gnatN",  "-gnatwl"
+		);
+	end Compiler;
+
+	--package Install is
+	--	for Prefix use "@prefix@";
+	--end Install;
+end Lib;
+

lib/libh2.gpr.in

@@ -0,0 +1,10 @@
+project LibH2 is
+
+	for Library_Name use "h2";
+	for Library_Kind use "dynamic";
+	for Library_Dir use "@abs_builddir@";
+	for Source_Files use ();
+	for Externally_Built use "true";
+
+end LibH2;
+