reorganized h2

This commit is contained in:
2021-08-21 14:31:39 +00:00
parent 161545a648
commit f6e2146485
85 changed files with 12444 additions and 59510 deletions

22
bin/Makefile.am Normal file
View File

@ -0,0 +1,22 @@
AUTOMAKE_OPTIONS = nostdinc
EXTRA_DIST = \
slim_stream.ads storage.ads wide_stream.ads \
slim_stream.adb storage.adb wide_stream.adb \
scheme.adb
#bin_PROGRAMS = h2scm
all-local: h2scm$(EXEEXT)
h2scm$(EXEEXT): @abs_builddir@/@ADA_OBJDIR@ @abs_builddir@/../lib/libh2.so @abs_srcdir@/scheme.adb
gprbuild @abs_builddir@/scheme.gpr
@abs_builddir@/@ADA_OBJDIR@:
mkdir -p @abs_builddir@/@ADA_OBJDIR@
clean-local:
gprclean -P@abs_builddir@/scheme.gpr

505
bin/Makefile.in Normal file
View File

@ -0,0 +1,505 @@
# Makefile.in generated by automake 1.16.2 from Makefile.am.
# @configure_input@
# Copyright (C) 1994-2020 Free Software Foundation, Inc.
# This Makefile.in is free software; the Free Software Foundation
# gives unlimited permission to copy and/or distribute it,
# with or without modifications, as long as this notice is preserved.
# This program is distributed in the hope that it will be useful,
# but WITHOUT ANY WARRANTY, to the extent permitted by law; without
# even the implied warranty of MERCHANTABILITY or FITNESS FOR A
# PARTICULAR PURPOSE.
@SET_MAKE@
VPATH = @srcdir@
am__is_gnu_make = { \
if test -z '$(MAKELEVEL)'; then \
false; \
elif test -n '$(MAKE_HOST)'; then \
true; \
elif test -n '$(MAKE_VERSION)' && test -n '$(CURDIR)'; then \
true; \
else \
false; \
fi; \
}
am__make_running_with_option = \
case $${target_option-} in \
?) ;; \
*) echo "am__make_running_with_option: internal error: invalid" \
"target option '$${target_option-}' specified" >&2; \
exit 1;; \
esac; \
has_opt=no; \
sane_makeflags=$$MAKEFLAGS; \
if $(am__is_gnu_make); then \
sane_makeflags=$$MFLAGS; \
else \
case $$MAKEFLAGS in \
*\\[\ \ ]*) \
bs=\\; \
sane_makeflags=`printf '%s\n' "$$MAKEFLAGS" \
| sed "s/$$bs$$bs[$$bs $$bs ]*//g"`;; \
esac; \
fi; \
skip_next=no; \
strip_trailopt () \
{ \
flg=`printf '%s\n' "$$flg" | sed "s/$$1.*$$//"`; \
}; \
for flg in $$sane_makeflags; do \
test $$skip_next = yes && { skip_next=no; continue; }; \
case $$flg in \
*=*|--*) continue;; \
-*I) strip_trailopt 'I'; skip_next=yes;; \
-*I?*) strip_trailopt 'I';; \
-*O) strip_trailopt 'O'; skip_next=yes;; \
-*O?*) strip_trailopt 'O';; \
-*l) strip_trailopt 'l'; skip_next=yes;; \
-*l?*) strip_trailopt 'l';; \
-[dEDm]) skip_next=yes;; \
-[JT]) skip_next=yes;; \
esac; \
case $$flg in \
*$$target_option*) has_opt=yes; break;; \
esac; \
done; \
test $$has_opt = yes
am__make_dryrun = (target_option=n; $(am__make_running_with_option))
am__make_keepgoing = (target_option=k; $(am__make_running_with_option))
pkgdatadir = $(datadir)/@PACKAGE@
pkgincludedir = $(includedir)/@PACKAGE@
pkglibdir = $(libdir)/@PACKAGE@
pkglibexecdir = $(libexecdir)/@PACKAGE@
am__cd = CDPATH="$${ZSH_VERSION+.}$(PATH_SEPARATOR)" && cd
install_sh_DATA = $(install_sh) -c -m 644
install_sh_PROGRAM = $(install_sh) -c
install_sh_SCRIPT = $(install_sh) -c
INSTALL_HEADER = $(INSTALL_DATA)
transform = $(program_transform_name)
NORMAL_INSTALL = :
PRE_INSTALL = :
POST_INSTALL = :
NORMAL_UNINSTALL = :
PRE_UNINSTALL = :
POST_UNINSTALL = :
build_triplet = @build@
host_triplet = @host@
subdir = bin
ACLOCAL_M4 = $(top_srcdir)/aclocal.m4
am__aclocal_m4_deps = $(top_srcdir)/m4/ax_cxx_namespace.m4 \
$(top_srcdir)/m4/ax_numval.m4 $(top_srcdir)/m4/ax_pthread.m4 \
$(top_srcdir)/m4/libtool.m4 $(top_srcdir)/m4/ltoptions.m4 \
$(top_srcdir)/m4/ltsugar.m4 $(top_srcdir)/m4/ltversion.m4 \
$(top_srcdir)/m4/lt~obsolete.m4 \
$(top_srcdir)/m4/lx_find_mpi.m4 $(top_srcdir)/configure.ac
am__configure_deps = $(am__aclocal_m4_deps) $(CONFIGURE_DEPENDENCIES) \
$(ACLOCAL_M4)
DIST_COMMON = $(srcdir)/Makefile.am $(am__DIST_COMMON)
mkinstalldirs = $(install_sh) -d
CONFIG_HEADER = $(top_builddir)/include/h2/config.h
CONFIG_CLEAN_FILES = scheme.gpr
CONFIG_CLEAN_VPATH_FILES =
AM_V_P = $(am__v_P_@AM_V@)
am__v_P_ = $(am__v_P_@AM_DEFAULT_V@)
am__v_P_0 = false
am__v_P_1 = :
AM_V_GEN = $(am__v_GEN_@AM_V@)
am__v_GEN_ = $(am__v_GEN_@AM_DEFAULT_V@)
am__v_GEN_0 = @echo " GEN " $@;
am__v_GEN_1 =
AM_V_at = $(am__v_at_@AM_V@)
am__v_at_ = $(am__v_at_@AM_DEFAULT_V@)
am__v_at_0 = @
am__v_at_1 =
SOURCES =
DIST_SOURCES =
am__can_run_installinfo = \
case $$AM_UPDATE_INFO_DIR in \
n|no|NO) false;; \
*) (install-info --version) >/dev/null 2>&1;; \
esac
am__tagged_files = $(HEADERS) $(SOURCES) $(TAGS_FILES) $(LISP)
am__DIST_COMMON = $(srcdir)/Makefile.in $(srcdir)/scheme.gpr.in
DISTFILES = $(DIST_COMMON) $(DIST_SOURCES) $(TEXINFOS) $(EXTRA_DIST)
ACLOCAL = @ACLOCAL@
ADA_OBJDIR = @ADA_OBJDIR@
AMTAR = @AMTAR@
AM_DEFAULT_VERBOSITY = @AM_DEFAULT_VERBOSITY@
AR = @AR@
AUTOCONF = @AUTOCONF@
AUTOHEADER = @AUTOHEADER@
AUTOMAKE = @AUTOMAKE@
AWK = @AWK@
BUILD_MODE = @BUILD_MODE@
CC = @CC@
CCDEPMODE = @CCDEPMODE@
CFLAGS = @CFLAGS@
CHAR_TYPE = @CHAR_TYPE@
CPP = @CPP@
CPPFLAGS = @CPPFLAGS@
CXX = @CXX@
CXXCPP = @CXXCPP@
CXXDEPMODE = @CXXDEPMODE@
CXXFLAGS = @CXXFLAGS@
CYGPATH_W = @CYGPATH_W@
DEFS = @DEFS@
DEPDIR = @DEPDIR@
DLLTOOL = @DLLTOOL@
DSYMUTIL = @DSYMUTIL@
DUMPBIN = @DUMPBIN@
ECHO = @ECHO@
ECHO_C = @ECHO_C@
ECHO_N = @ECHO_N@
ECHO_T = @ECHO_T@
EGREP = @EGREP@
EXEEXT = @EXEEXT@
FGREP = @FGREP@
GREP = @GREP@
H2_PROJECT_AUTHOR = @H2_PROJECT_AUTHOR@
H2_PROJECT_URL = @H2_PROJECT_URL@
H2_SIZEOF_CHAR = @H2_SIZEOF_CHAR@
H2_SIZEOF_DOUBLE = @H2_SIZEOF_DOUBLE@
H2_SIZEOF_FLOAT = @H2_SIZEOF_FLOAT@
H2_SIZEOF_INT = @H2_SIZEOF_INT@
H2_SIZEOF_LONG = @H2_SIZEOF_LONG@
H2_SIZEOF_LONG_DOUBLE = @H2_SIZEOF_LONG_DOUBLE@
H2_SIZEOF_LONG_LONG = @H2_SIZEOF_LONG_LONG@
H2_SIZEOF_OFF64_T = @H2_SIZEOF_OFF64_T@
H2_SIZEOF_OFF_T = @H2_SIZEOF_OFF_T@
H2_SIZEOF_SHORT = @H2_SIZEOF_SHORT@
H2_SIZEOF_VOID_P = @H2_SIZEOF_VOID_P@
HAVE_CXX = @HAVE_CXX@
INSTALL = @INSTALL@
INSTALL_DATA = @INSTALL_DATA@
INSTALL_PROGRAM = @INSTALL_PROGRAM@
INSTALL_SCRIPT = @INSTALL_SCRIPT@
INSTALL_STRIP_PROGRAM = @INSTALL_STRIP_PROGRAM@
LD = @LD@
LDFLAGS = @LDFLAGS@
LIBM = @LIBM@
LIBOBJS = @LIBOBJS@
LIBS = @LIBS@
LIBTOOL = @LIBTOOL@
LIBTOOL_DEPS = @LIBTOOL_DEPS@
LIPO = @LIPO@
LN_S = @LN_S@
LTLIBOBJS = @LTLIBOBJS@
LT_SYS_LIBRARY_PATH = @LT_SYS_LIBRARY_PATH@
MAKEINFO = @MAKEINFO@
MANIFEST_TOOL = @MANIFEST_TOOL@
MKDIR_P = @MKDIR_P@
MPICC = @MPICC@
MPI_CFLAGS = @MPI_CFLAGS@
MPI_CLDFLAGS = @MPI_CLDFLAGS@
NM = @NM@
NMEDIT = @NMEDIT@
OBJDUMP = @OBJDUMP@
OBJEXT = @OBJEXT@
OTOOL = @OTOOL@
OTOOL64 = @OTOOL64@
PACKAGE = @PACKAGE@
PACKAGE_BUGREPORT = @PACKAGE_BUGREPORT@
PACKAGE_NAME = @PACKAGE_NAME@
PACKAGE_STRING = @PACKAGE_STRING@
PACKAGE_TARNAME = @PACKAGE_TARNAME@
PACKAGE_URL = @PACKAGE_URL@
PACKAGE_VERSION = @PACKAGE_VERSION@
PACKAGE_VERSION_MAJOR = @PACKAGE_VERSION_MAJOR@
PACKAGE_VERSION_MINOR = @PACKAGE_VERSION_MINOR@
PACKAGE_VERSION_PATCH = @PACKAGE_VERSION_PATCH@
PATH_SEPARATOR = @PATH_SEPARATOR@
PTHREAD_CC = @PTHREAD_CC@
PTHREAD_CFLAGS = @PTHREAD_CFLAGS@
PTHREAD_LIBS = @PTHREAD_LIBS@
QUADMATH_LIBS = @QUADMATH_LIBS@
RANLIB = @RANLIB@
RM = @RM@
RMDIR = @RMDIR@
SED = @SED@
SENDFILE_LIBS = @SENDFILE_LIBS@
SET_MAKE = @SET_MAKE@
SHELL = @SHELL@
SOCKET_LIBS = @SOCKET_LIBS@
SSL_LIBS = @SSL_LIBS@
STRIP = @STRIP@
TRUE = @TRUE@
UCI_LIBS = @UCI_LIBS@
UNICOWS_LIBS = @UNICOWS_LIBS@
VERSION = @VERSION@
abs_builddir = @abs_builddir@
abs_srcdir = @abs_srcdir@
abs_top_builddir = @abs_top_builddir@
abs_top_srcdir = @abs_top_srcdir@
ac_ct_AR = @ac_ct_AR@
ac_ct_CC = @ac_ct_CC@
ac_ct_CXX = @ac_ct_CXX@
ac_ct_DUMPBIN = @ac_ct_DUMPBIN@
am__include = @am__include@
am__leading_dot = @am__leading_dot@
am__quote = @am__quote@
am__tar = @am__tar@
am__untar = @am__untar@
ax_pthread_config = @ax_pthread_config@
bindir = @bindir@
build = @build@
build_alias = @build_alias@
build_cpu = @build_cpu@
build_os = @build_os@
build_vendor = @build_vendor@
builddir = @builddir@
datadir = @datadir@
datarootdir = @datarootdir@
docdir = @docdir@
dvidir = @dvidir@
exec_prefix = @exec_prefix@
host = @host@
host_alias = @host_alias@
host_cpu = @host_cpu@
host_os = @host_os@
host_vendor = @host_vendor@
htmldir = @htmldir@
includedir = @includedir@
infodir = @infodir@
install_sh = @install_sh@
libdir = @libdir@
libexecdir = @libexecdir@
localedir = @localedir@
localstatedir = @localstatedir@
mandir = @mandir@
mkdir_p = @mkdir_p@
oldincludedir = @oldincludedir@
pdfdir = @pdfdir@
prefix = @prefix@
program_transform_name = @program_transform_name@
psdir = @psdir@
sbindir = @sbindir@
sharedstatedir = @sharedstatedir@
srcdir = @srcdir@
sysconfdir = @sysconfdir@
target_alias = @target_alias@
top_build_prefix = @top_build_prefix@
top_builddir = @top_builddir@
top_srcdir = @top_srcdir@
AUTOMAKE_OPTIONS = nostdinc
EXTRA_DIST = \
slim_stream.ads storage.ads wide_stream.ads \
slim_stream.adb storage.adb wide_stream.adb \
scheme.adb
all: all-am
.SUFFIXES:
$(srcdir)/Makefile.in: $(srcdir)/Makefile.am $(am__configure_deps)
@for dep in $?; do \
case '$(am__configure_deps)' in \
*$$dep*) \
( cd $(top_builddir) && $(MAKE) $(AM_MAKEFLAGS) am--refresh ) \
&& { if test -f $@; then exit 0; else break; fi; }; \
exit 1;; \
esac; \
done; \
echo ' cd $(top_srcdir) && $(AUTOMAKE) --foreign bin/Makefile'; \
$(am__cd) $(top_srcdir) && \
$(AUTOMAKE) --foreign bin/Makefile
Makefile: $(srcdir)/Makefile.in $(top_builddir)/config.status
@case '$?' in \
*config.status*) \
cd $(top_builddir) && $(MAKE) $(AM_MAKEFLAGS) am--refresh;; \
*) \
echo ' cd $(top_builddir) && $(SHELL) ./config.status $(subdir)/$@ $(am__maybe_remake_depfiles)'; \
cd $(top_builddir) && $(SHELL) ./config.status $(subdir)/$@ $(am__maybe_remake_depfiles);; \
esac;
$(top_builddir)/config.status: $(top_srcdir)/configure $(CONFIG_STATUS_DEPENDENCIES)
cd $(top_builddir) && $(MAKE) $(AM_MAKEFLAGS) am--refresh
$(top_srcdir)/configure: $(am__configure_deps)
cd $(top_builddir) && $(MAKE) $(AM_MAKEFLAGS) am--refresh
$(ACLOCAL_M4): $(am__aclocal_m4_deps)
cd $(top_builddir) && $(MAKE) $(AM_MAKEFLAGS) am--refresh
$(am__aclocal_m4_deps):
scheme.gpr: $(top_builddir)/config.status $(srcdir)/scheme.gpr.in
cd $(top_builddir) && $(SHELL) ./config.status $(subdir)/$@
mostlyclean-libtool:
-rm -f *.lo
clean-libtool:
-rm -rf .libs _libs
tags TAGS:
ctags CTAGS:
cscope cscopelist:
distdir: $(BUILT_SOURCES)
$(MAKE) $(AM_MAKEFLAGS) distdir-am
distdir-am: $(DISTFILES)
@srcdirstrip=`echo "$(srcdir)" | sed 's/[].[^$$\\*]/\\\\&/g'`; \
topsrcdirstrip=`echo "$(top_srcdir)" | sed 's/[].[^$$\\*]/\\\\&/g'`; \
list='$(DISTFILES)'; \
dist_files=`for file in $$list; do echo $$file; done | \
sed -e "s|^$$srcdirstrip/||;t" \
-e "s|^$$topsrcdirstrip/|$(top_builddir)/|;t"`; \
case $$dist_files in \
*/*) $(MKDIR_P) `echo "$$dist_files" | \
sed '/\//!d;s|^|$(distdir)/|;s,/[^/]*$$,,' | \
sort -u` ;; \
esac; \
for file in $$dist_files; do \
if test -f $$file || test -d $$file; then d=.; else d=$(srcdir); fi; \
if test -d $$d/$$file; then \
dir=`echo "/$$file" | sed -e 's,/[^/]*$$,,'`; \
if test -d "$(distdir)/$$file"; then \
find "$(distdir)/$$file" -type d ! -perm -700 -exec chmod u+rwx {} \;; \
fi; \
if test -d $(srcdir)/$$file && test $$d != $(srcdir); then \
cp -fpR $(srcdir)/$$file "$(distdir)$$dir" || exit 1; \
find "$(distdir)/$$file" -type d ! -perm -700 -exec chmod u+rwx {} \;; \
fi; \
cp -fpR $$d/$$file "$(distdir)$$dir" || exit 1; \
else \
test -f "$(distdir)/$$file" \
|| cp -p $$d/$$file "$(distdir)/$$file" \
|| exit 1; \
fi; \
done
check-am: all-am
check: check-am
all-am: Makefile all-local
installdirs:
install: install-am
install-exec: install-exec-am
install-data: install-data-am
uninstall: uninstall-am
install-am: all-am
@$(MAKE) $(AM_MAKEFLAGS) install-exec-am install-data-am
installcheck: installcheck-am
install-strip:
if test -z '$(STRIP)'; then \
$(MAKE) $(AM_MAKEFLAGS) INSTALL_PROGRAM="$(INSTALL_STRIP_PROGRAM)" \
install_sh_PROGRAM="$(INSTALL_STRIP_PROGRAM)" INSTALL_STRIP_FLAG=-s \
install; \
else \
$(MAKE) $(AM_MAKEFLAGS) INSTALL_PROGRAM="$(INSTALL_STRIP_PROGRAM)" \
install_sh_PROGRAM="$(INSTALL_STRIP_PROGRAM)" INSTALL_STRIP_FLAG=-s \
"INSTALL_PROGRAM_ENV=STRIPPROG='$(STRIP)'" install; \
fi
mostlyclean-generic:
clean-generic:
distclean-generic:
-test -z "$(CONFIG_CLEAN_FILES)" || rm -f $(CONFIG_CLEAN_FILES)
-test . = "$(srcdir)" || test -z "$(CONFIG_CLEAN_VPATH_FILES)" || rm -f $(CONFIG_CLEAN_VPATH_FILES)
maintainer-clean-generic:
@echo "This command is intended for maintainers to use"
@echo "it deletes files that may require special tools to rebuild."
clean: clean-am
clean-am: clean-generic clean-libtool clean-local mostlyclean-am
distclean: distclean-am
-rm -f Makefile
distclean-am: clean-am distclean-generic
dvi: dvi-am
dvi-am:
html: html-am
html-am:
info: info-am
info-am:
install-data-am:
install-dvi: install-dvi-am
install-dvi-am:
install-exec-am:
install-html: install-html-am
install-html-am:
install-info: install-info-am
install-info-am:
install-man:
install-pdf: install-pdf-am
install-pdf-am:
install-ps: install-ps-am
install-ps-am:
installcheck-am:
maintainer-clean: maintainer-clean-am
-rm -f Makefile
maintainer-clean-am: distclean-am maintainer-clean-generic
mostlyclean: mostlyclean-am
mostlyclean-am: mostlyclean-generic mostlyclean-libtool
pdf: pdf-am
pdf-am:
ps: ps-am
ps-am:
uninstall-am:
.MAKE: install-am install-strip
.PHONY: all all-am all-local check check-am clean clean-generic \
clean-libtool clean-local cscopelist-am ctags-am distclean \
distclean-generic distclean-libtool distdir dvi dvi-am html \
html-am info info-am install install-am install-data \
install-data-am install-dvi install-dvi-am install-exec \
install-exec-am install-html install-html-am install-info \
install-info-am install-man install-pdf install-pdf-am \
install-ps install-ps-am install-strip installcheck \
installcheck-am installdirs maintainer-clean \
maintainer-clean-generic mostlyclean mostlyclean-generic \
mostlyclean-libtool pdf pdf-am ps ps-am tags-am uninstall \
uninstall-am
.PRECIOUS: Makefile
#bin_PROGRAMS = h2scm
all-local: h2scm$(EXEEXT)
h2scm$(EXEEXT): @abs_builddir@/@ADA_OBJDIR@ @abs_builddir@/../lib/libh2.so @abs_srcdir@/scheme.adb
gprbuild @abs_builddir@/scheme.gpr
@abs_builddir@/@ADA_OBJDIR@:
mkdir -p @abs_builddir@/@ADA_OBJDIR@
clean-local:
gprclean -P@abs_builddir@/scheme.gpr
# Tell versions [3.59,3.63) of GNU make to not export all variables.
# Otherwise a system limit (for SysV at least) may be exceeded.
.NOEXPORT:

229
bin/scheme.adb Normal file
View File

@ -0,0 +1,229 @@
with H2.Wide;
with H2.Slim;
with H2.Pool;
with Storage;
with Slim_Stream;
with Wide_Stream;
with Ada.Text_IO;
with Ada.Wide_Text_IO;
with Ada.Unchecked_Deallocation;
with Ada.Exceptions;
with H2.OS;
with H2.IO;
use type H2.System_Length;
with Interfaces.C;
procedure scheme is
package Stream renames Wide_Stream;
package Scheme renames H2.Wide.Scheme;
--package Stream renames Slim_Stream;
--package Scheme renames H2.Slim.Scheme;
Pool: aliased Storage.Global_Pool;
SI: Scheme.Interpreter_Record;
I: Scheme.Object_Pointer;
O: Scheme.Object_Pointer;
--String: aliased S.Object_String := "(car '(1 2 3))";
String: aliased constant Scheme.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 := (Len => String'Length, Str => String, Pos => 0);
File_Name: aliased Scheme.Object_Character_Array := "test.adb";
--File_Name: aliased constant Scheme.Object_Character_Array := "시험.scm";
--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;
--procedure h2init;
--pragma Import (C, h2init, "h2init");
begin
--h2init;
ada.text_io.put ("Object_Size'Last: ");
ada.text_io.put_line (Scheme.Object_Size'Image(Scheme.Object_Size'Last));
ada.text_io.put ("Object_Byte'Size: ");
ada.text_io.put_line (Scheme.Object_Size'Image(Scheme.Object_Byte'Size));
ada.text_io.put ("Object_Word'Size: ");
ada.text_io.put_line (Scheme.Object_Size'Image(Scheme.Object_Word'Size));
ada.text_io.put ("Object_Pointer'Size: ");
ada.text_io.put_line (Scheme.Object_Size'Image(Scheme.Object_Pointer'Size));
ada.text_io.put ("Object_Pointer_Bits: ");
ada.text_io.put_line (Scheme.Object_Size'Image(Scheme.Object_Pointer_Bits));
ada.text_io.put ("Object_Pointer_Bytes: ");
ada.text_io.put_line (Scheme.Object_Size'Image(Scheme.Object_Pointer_Bytes));
ada.text_io.put ("Object_Header_Bytes: ");
ada.text_io.put_line (Scheme.Object_Size'Image(Scheme.Object_Header_Bytes));
ada.text_io.put ("Object_Payload_Max_Bytes: ");
ada.text_io.put_line (Scheme.Object_Size'Image(Scheme.Object_Payload_Max_Bytes));
ada.text_io.put ("Byte_Object_Size_last: ");
ada.text_io.put_line (Scheme.Object_Size'Image(Scheme.Byte_Object_Size_Last));
ada.text_io.put ("Pointer_Object_Size_last: ");
ada.text_io.put_line (Scheme.Object_Size'Image(Scheme.Pointer_Object_Size_Last));
ada.text_io.put_line (Scheme.Object_Size'Image(Scheme.Empty_Object_Record'Size));
ada.text_io.put_line (Scheme.Object_Size'Image(Scheme.Empty_Object_Record'Max_Size_In_Storage_Elements));
declare
package OS is new H2.OS (
H2.Slim.Character,
H2.Wide.Character,
H2.Slim.String,
H2.Wide.String,
H2.Wide.Utf8.To_Unicode_String,
H2.Wide.Utf8.From_Unicode_String);
package File renames OS.File;
F: File.File_Pointer;
FL: File.Flag_Record;
Length: H2.System_Length;
Buffer: H2.System_Byte_Array (50 .. 100);
begin
--OS.File.Set_Flag_Bits (FL, OS.File.FLAG_WRITE);
File.Set_Flag_Bits (FL, File.FLAG_READ);
File.Open (F, H2.Wide.String'("/etc/passwd"), FL);
File.Read (F, Buffer, Length);
File.Close (F);
File.Write (OS.File.Get_Stdout, Buffer(Buffer'First .. Buffer'First + Length - 1), Length);
end;
declare
package IO is new H2.IO (
H2.Slim.Character,
H2.Wide.Character,
H2.Slim.String,
H2.Wide.String,
H2.Wide.Utf8.To_Unicode_String,
H2.Wide.Utf8.From_Unicode_String,
H2.Wide.Utf8.Sequence_Length);
package File renames IO.File;
F, F2: File.File_Record;
FL: File.Flag_Record;
Buffer: H2.Slim.String (1 .. 200);
BufferW: H2.Wide.String (1 .. 27);
IL, OL: H2.System_Length;
Option: File.Option_Record;
begin
--File.Open (F, H2.Slim.String'("/etc/passwd"), FL);
--File.Read (F, Buffer, Length);
--Ada.Text_IO.PUt_Line (Standard.String(Buffer(Buffer'First .. Buffer'First + Length - 1)));
--File.Read (F, Buffer, Length);
--Ada.Text_IO.PUt (Standard.String(Buffer(Buffer'First .. Buffer'First + Length - 1)));
--File.Close (F);
ada.text_io.put_line ("------------------");
--Stdout.Get_Line (..
--Stdout.Print ("-----------------");
--Stdout.Print_Line ("-------------------");
File.Set_Flag_Bits (FL, File.FLAG_READ);
File.Set_Flag_Bits (FL, File.FLAG_NONBLOCK);
File.Open (F, H2.Slim.String'("/tmp/xxx"), FL);
--Option := File.Get_Option(F2);
File.Clear_Flag_Bits (FL, FL.Bits);
File.Set_Flag_Bits (FL, File.FLAG_WRITE);
File.Set_Flag_Bits (FL, File.FLAG_CREATE);
File.Set_Flag_Bits (FL, File.FLAG_TRUNCATE);
File.Open (F2, H2.Wide.String'("/tmp/yyy"), FL);
File.Set_Option_Bits (Option, File.Option_CRLF_IN);
--File.Set_Option_Bits (Option, File.Option_CRLF_OUT);
--Option.LF := IO.Ascii.Code.Colon;
File.Set_Option (F2, Option);
File.Set_Option (F, Option);
loop
--File.Get_Line (F, Buffer, IL);
File.Get_Line (F, BufferW, IL);
--ada.text_io.put_line (standard.string(buffer(1..il)));
--ada.wide_text_io.put_line (standard.wide_string(bufferw(1..il)));
--File.Read (F, BufferW, IL);
exit when IL <= 0;
--File.Put_Line (F2, Buffer(Buffer'First .. Buffer'First + IL - 1), OL);
File.Put_Line (F2, BufferW(Buffer'First .. Buffer'First + IL - 1), OL);
pragma Assert (IL = OL);
--Ada.Text_IO.PUt (Standard.String(Buffer(Buffer'First .. Buffer'First + IL - 1)));
--Ada.Wide_Text_IO.Put_Line (Standard.Wide_String(BufferW(BufferW'First .. BufferW'First + IL - 1)));
end loop;
--File.Write (F2, H2.Wide.String'("나는 피리부는 사나이 정말로 멋있는 사나이"), OL);
--File.Write_Line (F2, H2.Wide.String'("이세상에 문디없어면 무슨재미로 너도 나도 만세."), OL);
--File.Write_Line (F2, H2.Wide.String'("이세상에 for the first time 우하."), OL);
--File.Write_Line (F2, H2.Wide.String'(""), OL);
File.Close (F2);
File.Close (F);
exception
when Error: others =>
Ada.Text_IO.Put_Line ("~~~~~~~~~~ EXCEPTION ~~~~~~~~~~" & Ada.Exceptions.Exception_Information(Error));
if File.Is_Open(F2) then
File.Close (F2);
end if;
if File.Is_Open(F) then
File.Close (F);
end if;
end;
declare
LC_ALL : constant Interfaces.C.int := 0;
procedure setlocale (
category : Interfaces.C.int;
locale : Interfaces.C.char_array);
pragma Import (C, setlocale);
Empty : aliased Interfaces.C.char_array := (0 => Interfaces.C.nul);
begin
setlocale (LC_ALL, Empty);
end;
Scheme.Open (SI, 2_000_000, Pool'Unchecked_Access);
--Scheme.Open (SI, null);
-- Specify the named stream handler
Scheme.Set_Option (SI, (Scheme.Stream_Option,
Stream.Allocate_Stream'Access,
Stream.Deallocate_Stream'Access)
);
Scheme.Set_Option (SI, (Scheme.Trait_Option, Scheme.No_Optimization));
File_Stream.Name := File_Name'Unchecked_Access;
begin
Scheme.Set_Input_Stream (SI, File_Stream); -- specify main input stream
--Schee.Set_Input_Stream (SI, String_Stream);
exception
when others =>
Ada.Text_IO.Put_Line ("Cannot open Input Stream");
end;
--Scheme.Set_Output_Stream (SI, Stream); -- specify main output stream.
Ada.Text_IO.Put_Line ("-------------------------------------------");
Scheme.Run_Loop (SI, I);
Scheme.Print (SI, I);
Scheme.Close (SI);
Ada.Text_IO.Put_Line ("BYE...");
end scheme;

41
bin/scheme.gpr.in Normal file
View File

@ -0,0 +1,41 @@
with "@abs_builddir@/../lib/libh2";
project 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",
"slim_stream.ads",
"slim_stream.adb",
"wide_stream.ads",
"wide_stream.adb",
"scheme.adb"
);
for Object_Dir use "@ADA_OBJDIR@";
package Compiler is
for Default_Switches ("Ada") use (
"-gnata", "-gnato", "-gnatN", "-gnatwl", "-gnat95", "-gnatW8", "-g",
"-I@abs_srcdir@/../lib",
"-I@abs_srcdir@/../lib/posix",
"-I@abs_builddir@/../lib/posix"
);
end Compiler;
package Builder is
for Executable ("scheme.adb") use "h2scm";
end Builder;
end Scheme;

125
bin/slim_stream.adb Normal file
View File

@ -0,0 +1,125 @@
with H2.Pool;
with Ada.Unchecked_Conversion;
package body Slim_Stream is
use type S.Object_Size;
------------------------------------------------------------------
procedure Open (Stream: in out String_Input_Stream_Record) is
begin
Ada.Text_IO.Put_Line ("****** OPEN SLIM STRING STREAM ******");
Stream.Pos := 0;
end Open;
procedure Close (Stream: in out String_Input_Stream_Record) is
begin
Ada.Text_IO.Put_Line ("****** CLOSE SLIM STRING STREAM ******");
Stream.Pos := Stream.Str'Last;
end Close;
procedure Read (Stream: in out String_Input_Stream_Record;
Data: out S.Object_Character_Array;
Last: out S.Object_Size) is
Avail: S.Object_Size;
begin
Avail := Stream.Str'Last - Stream.Pos;
if Avail <= 0 then
-- EOF
Last := Data'First - 1;
else
if Avail > Data'Length then
Avail := Data'Length;
end if;
Data(Data'First .. Avail) := Stream.Str(Stream.Pos + 1..Stream.Pos + Avail);
Stream.Pos := Stream.Pos + Avail;
Last := Data'First + Avail - 1;
end if;
end Read;
procedure Write (Stream: in out String_Input_Stream_Record;
Data: out S.Object_Character_Array;
Last: out S.Object_Size) is
begin
--raise S.Stream_Error;
Last := Data'First - 1;
end Write;
------------------------------------------------------------------
procedure Open (Stream: in out File_Stream_Record) is
begin
Ada.Text_IO.Put_Line (">>>>> OPEN SLIM FILE STREAM <<<<< " & Standard.String(Stream.Name.all));
Ada.Text_IO.Open (Stream.Handle, Ada.Text_IO.In_File, Standard.String(Stream.Name.all));
end Open;
procedure Close (Stream: in out File_Stream_Record) is
begin
Ada.Text_IO.Put_Line (">>>>> CLOSE SLIM FILE STREAM <<<<< " & Standard.String(Stream.Name.all));
Ada.Text_IO.Close (Stream.Handle);
end Close;
procedure Read (Stream: in out File_Stream_Record;
Data: out S.Object_Character_Array;
Last: out S.Object_Size) is
begin
for I in Data'First .. Data'Last loop
begin
if Ada.Text_IO.End_Of_File (Stream.Handle) then
Last := I - 1;
return;
end if;
Ada.Text_IO.Get_Immediate (Stream.Handle, Data(I));
--Ada.Text_IO.Get (Stream.Handle, Data(I));
exception
when Ada.Text_IO.End_Error =>
Last := I - 1;
return;
-- other exceptions must be just raised to indicate errors
end;
end loop;
Last := Data'Last;
end Read;
procedure Write (Stream: in out File_Stream_Record;
Data: out S.Object_Character_Array;
Last: out S.Object_Size) is
begin
--raise S.Stream_Error;
Last := Data'First - 1;
end Write;
------------------------------------------------------------------
procedure Allocate_Stream (Interp: in out S.Interpreter_Record;
Name: access S.Object_Character_Array;
Result: out S.Stream_Pointer) is
subtype FSR is File_Stream_Record;
type FSP is access all FSR;
package P is new H2.Pool (FSR, FSP);
X: FSP;
for X'Address use Result'Address;
pragma Import (Ada, X);
begin
X := P.Allocate (S.Get_Storage_Pool(Interp));
X.Name := S.Constant_Object_Character_Array_Pointer(Name);
end Allocate_Stream;
procedure Deallocate_Stream (Interp: in out S.Interpreter_Record;
Source: in out S.Stream_Pointer) is
subtype FSR is File_Stream_Record;
type FSP is access all FSR;
package P is new H2.Pool (FSR, FSP);
X: FSP;
for X'Address use Source'Address;
pragma Import (Ada, X);
begin
P.Deallocate (X, S.Get_Storage_Pool(Interp));
end Deallocate_Stream;
end Slim_Stream;

55
bin/slim_stream.ads Normal file
View File

@ -0,0 +1,55 @@
with H2.Slim;
with Ada.Text_IO;
package Slim_Stream is
package S renames H2.Slim.Scheme;
------------------------------------------------------------
--type Object_Character_Array_Pointer is access all S.Object_Character_Array;
type Object_Character_Array_Pointer is access constant S.Object_Character_Array;
type String_Input_Stream_Record(Str: Object_Character_Array_Pointer) is new S.Stream_Record with record
Pos: S.Object_Size := 0;
end record;
procedure Open (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;
Data: out S.Object_Character_Array;
Last: out S.Object_Size);
procedure Write (Stream: in out String_Input_Stream_Record;
Data: out S.Object_Character_Array;
Last: out S.Object_Size);
------------------------------------------------------------
type File_Stream_Record is new S.Stream_Record with record
Name: S.Constant_Object_Character_Array_Pointer;
Handle: Ada.Text_IO.File_Type;
end record;
procedure Open (Stream: in out File_Stream_Record);
procedure Close (Stream: in out File_Stream_Record);
procedure Read (Stream: in out File_Stream_Record;
Data: out S.Object_Character_Array;
Last: out S.Object_Size);
procedure Write (Stream: in out File_Stream_Record;
Data: out S.Object_Character_Array;
Last: out S.Object_Size);
------------------------------------------------------------
procedure Allocate_Stream (Interp: in out S.Interpreter_Record;
Name: access S.Object_Character_Array;
Result: out S.Stream_Pointer);
procedure Deallocate_Stream (Interp: in out S.Interpreter_Record;
Source: in out S.Stream_Pointer);
--private
-- type File_Stream_Record is new S.Stream_Record with record
-- Name: S.Constant_Object_Character_Array_Pointer;
-- Handle: Ada.Text_IO.File_Type;
-- end record;
end Slim_Stream;

66
bin/storage.adb Normal file
View File

@ -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;

26
bin/storage.ads Normal file
View File

@ -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;

140
bin/wide_stream.adb Normal file
View File

@ -0,0 +1,140 @@
with H2.Pool;
with Ada.Unchecked_Conversion;
with Ada.Text_IO; -- for debugging
with Ada.Exceptions;
package body Wide_Stream is
package Utf8 renames H2.Wide.Utf8;
use type S.Object_Size;
------------------------------------------------------------------
procedure Open (Stream: in out String_Input_Stream_Record) is
begin
Ada.Text_IO.Put_Line ("****** OPEN WIDE STRING STREAM ******");
Stream.Pos := 0;
end Open;
procedure Close (Stream: in out String_Input_Stream_Record) is
begin
Ada.Text_IO.Put_Line ("****** CLOSE WIDE STRING STREAM ******");
Stream.Pos := Stream.Str'Last;
end Close;
procedure Read (Stream: in out String_Input_Stream_Record;
Data: out S.Object_Character_Array;
Last: out S.Object_Size) is
Avail: S.Object_Size;
begin
Avail := Stream.Str'Last - Stream.Pos;
if Avail <= 0 then
-- EOF
Last := Data'First - 1;
else
if Avail > Data'Length then
Avail := Data'Length;
end if;
Data(Data'First .. Avail) := Stream.Str(Stream.Pos + 1..Stream.Pos + Avail);
Stream.Pos := Stream.Pos + Avail;
Last := Data'First + Avail - 1;
end if;
end Read;
procedure Write (Stream: in out String_Input_Stream_Record;
Data: out S.Object_Character_Array;
Last: out S.Object_Size) is
begin
--raise S.Stream_Error;
Last := Data'First - 1;
end Write;
------------------------------------------------------------------
procedure Open (Stream: in out File_Stream_Record) is
begin
Ada.Text_IO.Put_Line (">>>>> OPEN WIDE FILE STREAM <<<<< " & Standard.String(Utf8.From_Unicode_String(Utf8.Unicode_String(Stream.Name.all))));
--Ada.Wide_Text_IO.Open (Stream.Handle, Ada.Wide_Text_IO.In_File, Ada.Characters.Conversions.To_String(Standard.Wide_String(Stream.Name.all)));
Ada.Wide_Text_IO.Open (Stream.Handle, Ada.Wide_Text_IO.In_File, Standard.String(Utf8.From_Unicode_String(Utf8.Unicode_String(Stream.Name.all))));
end Open;
procedure Close (Stream: in out File_Stream_Record) is
subtype Wide_String is Standard.Wide_String(1 .. Standard.Natural(Stream.Name'Length));
function To_Wide_String is new Ada.Unchecked_Conversion (S.Object_Character_Array, Wide_String);
begin
--Ada.Wide_Text_IO.Put_Line (">>>>> CLOSE File STREAM <<<<< " & Standard.Wide_String(Stream.Name.all));
Ada.Text_IO.Put_Line (">>>>> CLOSE WIDE FILE STREAM <<<<< " & Standard.String(Utf8.From_Unicode_String(Utf8.Unicode_String(Stream.Name.all))));
begin
ada.wide_text_io.put_line (">> " & Standard.Wide_String(Utf8.To_Unicode_String(Utf8.From_Unicode_String(Utf8.Unicode_String(Stream.Name.all)))));
exception
when Ex: others =>
ada.text_io.put_line ("fuck - " & Ada.Exceptions.Exception_Name(Ex) & Ada.Exceptions.Exception_Information(Ex));
end;
ada.text_io.put_line (">>");
Ada.Wide_Text_IO.Close (Stream.Handle);
end Close;
procedure Read (Stream: in out File_Stream_Record;
Data: out S.Object_Character_Array;
Last: out S.Object_Size) is
begin
for I in Data'First .. Data'Last loop
begin
if Ada.Wide_Text_IO.End_Of_File (Stream.Handle) then
Last := I - 1;
return;
end if;
Ada.Wide_Text_IO.Get_Immediate (Stream.Handle, Data(I));
exception
when Ada.Wide_Text_IO.End_Error =>
Last := I - 1;
return;
-- other exceptions must be just raised to indicate errors
end;
end loop;
Last := Data'Last;
end Read;
procedure Write (Stream: in out File_Stream_Record;
Data: out S.Object_Character_Array;
Last: out S.Object_Size) is
begin
--raise S.Stream_Error;
Last := Data'First - 1;
end Write;
------------------------------------------------------------------
procedure Allocate_Stream (Interp: in out S.Interpreter_Record;
Name: access S.Object_Character_Array;
Result: out S.Stream_Pointer) is
subtype FSR is File_Stream_Record;
type FSP is access all FSR;
package P is new H2.Pool (FSR, FSP);
X: FSP;
for X'Address use Result'Address;
pragma Import (Ada, X);
begin
X := P.Allocate (S.Get_Storage_Pool(Interp));
X.Name := S.Constant_Object_Character_Array_Pointer(Name);
end Allocate_Stream;
procedure Deallocate_Stream (Interp: in out S.Interpreter_Record;
Source: in out S.Stream_Pointer) is
subtype FSR is File_Stream_Record;
type FSP is access all FSR;
package P is new H2.Pool (FSR, FSP);
X: FSP;
for X'Address use Source'Address;
pragma Import (Ada, X);
begin
P.Deallocate (X, S.Get_Storage_Pool(Interp));
end Deallocate_Stream;
end Wide_Stream;

55
bin/wide_stream.ads Normal file
View File

@ -0,0 +1,55 @@
with H2.Wide;
with Ada.Wide_Text_IO;
package Wide_Stream is
package S renames H2.Wide.Scheme;
------------------------------------------------------------
--type Object_Character_Array_Pointer is access all S.Object_Character_Array;
type Object_Character_Array_Pointer is access constant S.Object_Character_Array;
type String_Input_Stream_Record(Str: Object_Character_Array_Pointer) is new S.Stream_Record with record
Pos: S.Object_Size := 0;
end record;
procedure Open (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;
Data: out S.Object_Character_Array;
Last: out S.Object_Size);
procedure Write (Stream: in out String_Input_Stream_Record;
Data: out S.Object_Character_Array;
Last: out S.Object_Size);
------------------------------------------------------------
type File_Stream_Record is new S.Stream_Record with record
Name: S.Constant_Object_Character_Array_Pointer;
Handle: Ada.Wide_Text_IO.File_Type;
end record;
procedure Open (Stream: in out File_Stream_Record);
procedure Close (Stream: in out File_Stream_Record);
procedure Read (Stream: in out File_Stream_Record;
Data: out S.Object_Character_Array;
Last: out S.Object_Size);
procedure Write (Stream: in out File_Stream_Record;
Data: out S.Object_Character_Array;
Last: out S.Object_Size);
------------------------------------------------------------
procedure Allocate_Stream (Interp: in out S.Interpreter_Record;
Name: access S.Object_Character_Array;
Result: out S.Stream_Pointer);
procedure Deallocate_Stream (Interp: in out S.Interpreter_Record;
Source: in out S.Stream_Pointer);
--private
-- type File_Stream_Record is new S.Stream_Record with record
-- Name: S.Constant_Object_Character_Array_Pointer;
-- Handle: Ada.Wide_Text_IO.File_Type;
-- end record;
end Wide_Stream;