added initial files

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;