From 44e1ec3cd350355d3b1adba715e96f756b081e2b Mon Sep 17 00:00:00 2001 From: Philipp Date: Tue, 26 Jul 2022 21:45:40 +0200 Subject: [PATCH] Added zlib API interfaces. --- COVERAGE.md | 8 +-- Makefile | 22 +++--- README.md | 27 +++----- src/tcl.f90 | 126 +++++++++++++++++++++++++++++++++-- src/{macro.c => tcl_macro.c} | 0 5 files changed, 142 insertions(+), 41 deletions(-) rename src/{macro.c => tcl_macro.c} (100%) diff --git a/COVERAGE.md b/COVERAGE.md index b058494..71c38c1 100644 --- a/COVERAGE.md +++ b/COVERAGE.md @@ -241,7 +241,7 @@ | `Tcl_GetBlocksFromStat` | ✓ | | `Tcl_GetBoolean` | ✓ | | `Tcl_GetBooleanFromObj` | ✓ | -| `Tcl_GetByteArrayFromObj` | – | +| `Tcl_GetByteArrayFromObj` | ✓ | | `Tcl_GetChangeTimeFromStat` | ✓ | | `Tcl_GetChannel` | – | | `Tcl_GetChannelBufferSize` | – | @@ -418,7 +418,7 @@ | `Tcl_NRExprObj` | – | | `Tcl_NewBignumObj` | – | | `Tcl_NewBooleanObj` | – | -| `Tcl_NewByteArrayObj` | – | +| `Tcl_NewByteArrayObj` | ✓ | | `Tcl_NewDictObj` | ✓ | | `Tcl_NewDoubleObj` | ✓ | | `Tcl_NewInstanceMethod` | – | @@ -507,8 +507,8 @@ | `Tcl_SetAssocData` | – | | `Tcl_SetBignumObj` | – | | `Tcl_SetBooleanObj` | ✓ | -| `Tcl_SetByteArrayLength` | – | -| `Tcl_SetByteArrayObj` | – | +| `Tcl_SetByteArrayLength` | ✓ | +| `Tcl_SetByteArrayObj` | ✓ | | `Tcl_SetChannelBufferSize` | – | | `Tcl_SetChannelError` | – | | `Tcl_SetChannelErrorInterp` | – | diff --git a/Makefile b/Makefile index 4e179b7..28d9806 100644 --- a/Makefile +++ b/Makefile @@ -10,18 +10,16 @@ AR = ar # ============================================================================== # COMPILER, LINKER, AND ARCHIVER FLAGS # ============================================================================== -CFLAGS = -Wall -FFLAGS = -Wall -Wno-unused-dummy-argument -std=f2018 -fmax-errors=1 +CFLAGS = -Wall `pkg-config --cflags tk86` +FFLAGS = -Wall -Wno-unused-dummy-argument `pkg-config --cflags tk86` ARFLAGS = rcs -LDFLAGS = -I/usr/local/include/tcl8.6/ -I/usr/local/include/tk8.6/ \ - -L/usr/local/lib/tcl8.6/ -L/usr/local/lib/tk8.6/ +LDFLAGS = `pkg-config --libs-only-L tk86` # ============================================================================== # TCL AND TK LIBRARIES TO LINK # ============================================================================== -LIBTCL86 = -ltcl86 -LIBTCLSTUB86 = -ltclstub86 -LIBTK86 = -ltk86 +LIBTCL86 = `pkg-config --libs-only-l tcl86` +LIBTK86 = `pkg-config --libs-only-l tk86` # ============================================================================== # FORTRAN LIBRARIES @@ -53,9 +51,9 @@ examples: $(CONFIG) $(DICT) $(EVAL) $(FS) $(LIBRARY) $(LINK) $(NAMESPACE) $(RE2C # INTERFACE LIBRARIES # ============================================================================== $(LIBFTCL86): - $(CC) -fPIC $(CFLAGS) $(LDFLAGS) -c src/macro.c + $(CC) -fPIC $(CFLAGS) $(LDFLAGS) -c src/tcl_macro.c $(FC) -fPIC $(FFLAGS) -c src/tcl.f90 - $(AR) $(ARFLAGS) $(LIBFTCL86) macro.o tcl.o + $(AR) $(ARFLAGS) $(LIBFTCL86) tcl_macro.o tcl.o $(LIBFTCLSTUB86): $(FC) -fPIC $(FFLAGS) -c src/tcl_stub.f90 @@ -81,16 +79,16 @@ $(FS): $(LIBFTCL86) $(FC) $(FFLAGS) $(LDFLAGS) -o $(FS) examples/fs/fs.f90 $(LIBFTCL86) $(LIBTCL86) $(LIBRARY): $(LIBFTCL86) $(LIBFTCLSTUB86) - $(FC) -DUSE_TCL_STUBS -shared -fPIC $(FFLAGS) $(LDFLAGS) -o $(LIBRARY) examples/library/hello.f90 $(LIBFTCL86) $(LIBFTCLSTUB86) $(LIBTCLSTUB86) + $(FC) -DUSE_TCL_STUBS -shared -fPIC $(FFLAGS) $(LDFLAGS) -o $(LIBRARY) examples/library/hello.f90 $(LIBFTCL86) $(LIBFTCLSTUB86) $(LINK): $(LIBFTCL86) $(FC) $(FFLAGS) $(LDFLAGS) -o $(LINK) examples/link/link.f90 $(LIBFTCL86) $(LIBTCL86) $(NAMESPACE): $(LIBFTCL86) $(LIBFTCLSTUB86) - $(FC) -DUSE_TCL_STUBS -shared -fPIC $(FFLAGS) $(LDFLAGS) -o $(NAMESPACE) examples/namespace/fortran.f90 $(LIBFTCL86) $(LIBFTCLSTUB86) $(LIBTCLSTUB86) + $(FC) -DUSE_TCL_STUBS -shared -fPIC $(FFLAGS) $(LDFLAGS) -o $(NAMESPACE) examples/namespace/fortran.f90 $(LIBFTCL86) $(LIBFTCLSTUB86) $(RE2C): $(LIBFTCL86) $(LIBFTK86) - $(FC) -DUSE_TK_STUBS $(FFLAGS) $(LDFLAGS) -o $(RE2C) examples/re2c/re2c.f90 $(LIBFTCL86) $(LIBFTK86) $(LIBTCL86) $(LIBTK86) + $(FC) -DUSE_TK_STUBS $(FFLAGS) $(LDFLAGS) -o $(RE2C) examples/re2c/re2c.f90 $(LIBFTCL86) $(LIBFTK86) $(LIBTK86) # ============================================================================== # CLEAN-UP diff --git a/README.md b/README.md index c7b7f25..4820014 100644 --- a/README.md +++ b/README.md @@ -59,7 +59,7 @@ Furthermore, it is possible to build a single static library `libfortran-tcl86.a with [fpm](https://github.com/fortran-lang/fpm): ``` -$ fpm build --profile=release --c-flag="-I/usr/local/include/tcl8.6/ -L/usr/local/lib/tcl8.6/" +$ fpm build --profile=release --c-flag="`pkg-config --cflags tcl86`" ``` The include and library search paths have to point to the correct directories. @@ -83,28 +83,22 @@ instead of `-ltcl86` on Linux). Tcl/Tk can either be linked statically (`libtcl86.a`, `libtk86.a`) or dynamically (`-ltcl86`, `-ltk86`). To create a shared library `libexample.so` with Tcl extensions written in -Fortran, link against `libftcl86.a libftclstub86.a -ltclstub86`: +Fortran, run: ``` -$ gfortran -DUSE_TCL_STUBS -fPIC -shared -o libexample.so \ - -I/usr/local/include/tcl8.6/ -L/usr/local/lib/tcl8.6/ \ - example.f90 libftcl86.a libftclstub86.a -ltclstub86 +$ gfortran -DUSE_TCL_STUBS -fPIC -shared -o libexample.so `pkg-config --cflags tcl86` \ + example.f90 libftcl86.a libftclstub86.a `pkg-config --libs tcl86` ``` To access the Tk toolkit from Fortran, link against `libftk86.a libftcl86.a --ltk86 -ltcl86`: +-ltk86 -ltcl86` (or, use `pkg-config`): ``` -$ gfortran -DUSE_TK_STUBS -I/usr/local/include/tcl8.6/ -I/usr/local/include/tk8.6/ \ - -L/usr/local/lib/tcl8.6/ -L/usr/local/lib/tk8.6/ \ - -o example example.f90 libftk86.a libftcl86.a -ltk86 -ltcl86 +$ gfortran -DUSE_TK_STUBS `pkg-config --cflags tk86` \ + -o example example.f90 libftk86.a libftcl86.a `pkg-config --libs tk86` $ ./example ``` -Again, the include and library search paths for Tcl 8.6 and Tk 8.6, as well as -the names of the libraries depend on the operating system and may differ (for -instance, `-ltk8.6 -ltcl8.6` on Linux). - ## Example The following basic example just invokes the Tcl interpreter from Fortran to evaluate a character string: @@ -135,16 +129,11 @@ end program main Compile and link the example with: ``` -$ gfortran -I/usr/local/include/tcl8.6/ -L/usr/local/lib/tcl8.6/ \ - -o example.f90 libftcl86.a -ltcl86 +$ gfortran `pkg-config --cflags tcl86` -o example.f90 libftcl86.a `pkg-config --libs tcl86` $ ./example Hello, from Tcl! ``` -On Linux, point `-I` to the directory of the Tcl header files, `-L` to the -directory of the library files, and change `-ltcl86` to `-ltcl8.6`. On Microsoft -Windows, link against `tcl86.dll` instead. - ## Further Examples The following example programs are provided: diff --git a/src/tcl.f90 b/src/tcl.f90 index 3499479..58b88cd 100644 --- a/src/tcl.f90 +++ b/src/tcl.f90 @@ -129,6 +129,7 @@ module tcl public :: tcl_fs_unregister public :: tcl_fs_utime public :: tcl_get_access_time_from_stat + public :: tcl_get_byte_array_from_obj public :: tcl_get_block_size_from_stat public :: tcl_get_blocks_from_stat public :: tcl_get_boolean @@ -201,11 +202,13 @@ module tcl public :: tcl_list_obj_length public :: tcl_list_obj_replace public :: tcl_make_safe + public :: tcl_new_byte_array_obj public :: tcl_new_dict_obj public :: tcl_new_double_obj public :: tcl_new_int_obj public :: tcl_new_list_obj public :: tcl_new_long_obj + public :: tcl_new_obj public :: tcl_new_string_obj public :: tcl_new_string_obj_ public :: tcl_new_wide_int_obj @@ -218,6 +221,8 @@ module tcl public :: tcl_scan_counted_element public :: tcl_scan_element public :: tcl_scan_element_ + public :: tcl_set_byte_array_obj + public :: tcl_set_byte_array_length public :: tcl_set_boolean_obj public :: tcl_set_boolean_obj_ public :: tcl_set_double_obj @@ -251,6 +256,12 @@ module tcl public :: tcl_up_var2_ public :: tcl_wrong_num_args public :: tcl_wrong_num_args_ + public :: tcl_zlib_adler32 + public :: tcl_zlib_crc32 + public :: tcl_zlib_deflate + public :: tcl_zlib_inflate + public :: tcl_zlib_stream_get + public :: tcl_zlib_stream_init private :: copy private :: c_f_str_ptr @@ -1243,6 +1254,15 @@ function tcl_get_access_time_from_stat(stat_ptr) bind(c, name='Tcl_GetAccessTime integer(kind=tcl_wide_int) :: tcl_get_access_time_from_stat end function tcl_get_access_time_from_stat + ! unsigned char *Tcl_GetByteArrayFromObj(Tcl_Obj *objPtr, int *lengthPtr) + function tcl_get_byte_array_from_obj(obj_ptr, length_ptr) bind(c, name='Tcl_GetByteArrayFromObj') + import :: c_int, c_ptr + implicit none + type(c_ptr), intent(in), value :: obj_ptr + integer(kind=c_int), intent(out) :: length_ptr + type(c_ptr) :: tcl_get_byte_array_from_obj + end function tcl_get_byte_array_from_obj + ! unsigned Tcl_GetBlockSizeFromStat(Tcl_StatBuf *statPtr) function tcl_get_block_size_from_stat(stat_ptr) bind(c, name='Tcl_GetBlockSizeFromStat') import :: c_ptr, c_unsigned_int @@ -1676,6 +1696,15 @@ function tcl_new_dict_obj() bind(c, name='Tcl_NewDictObj') type(c_ptr) :: tcl_new_dict_obj end function tcl_new_dict_obj + ! Tcl_Obj *Tcl_NewByteArrayObj(const unsigned char *bytes, int length) + function tcl_new_byte_array_obj(bytes, length) bind(c, name='Tcl_NewByteArrayObj') + import :: c_char, c_int, c_ptr + implicit none + character(kind=c_char), intent(in) :: bytes + integer(kind=c_int), intent(in), value :: length + type(c_ptr) :: tcl_new_byte_array_obj + end function tcl_new_byte_array_obj + ! Tcl_Obj *Tcl_NewDoubleObj(double *doubleValue) function tcl_new_double_obj(double_value) bind(c, name='Tcl_NewDoubleObj') import :: c_double, c_ptr @@ -1709,6 +1738,13 @@ function tcl_new_long_obj(long_value) bind(c, name='Tcl_NewLongObj') type(c_ptr) :: tcl_new_long_obj end function tcl_new_long_obj + ! Tcl_Obj *Tcl_NewObj() + function tcl_new_obj() bind(c, name='Tcl_NewObj') + import :: c_ptr + implicit none + type(c_ptr) :: tcl_new_obj + end function tcl_new_obj + ! Tcl_Obj *Tcl_NewStringObj(const char *bytes, int length) function tcl_new_string_obj_(bytes, length) bind(c, name='Tcl_NewStringObj') import :: c_char, c_int, c_ptr @@ -1765,6 +1801,15 @@ function tcl_scan_element_(src, flags_ptr) bind(c, name='Tcl_ScanElement') integer(kind=c_int) :: tcl_scan_element_ end function tcl_scan_element_ + ! unsigned char *Tcl_SetByteArrayLength(Tcl_Obj *objPtr, int length) + function tcl_set_byte_array_length(obj_ptr, length) bind(c, name='Tcl_SetByteArrayLength') + import :: c_int, c_ptr + implicit none + type(c_ptr), intent(in), value :: obj_ptr + integer(kind=c_int), intent(in), value :: length + type(c_ptr) :: tcl_set_byte_array_length + end function tcl_set_byte_array_length + ! const char *Tcl_SetVar(Tcl_Interp *interp, const char *varName, const char *newValue, int flags) function tcl_set_var_(interp, var_name, new_value, flags) bind(c, name='Tcl_SetVar') import :: c_char, c_int, c_ptr @@ -1865,16 +1910,78 @@ function tcl_up_var2_(interp, frame_name, name1, name2, dest_name, flags) bind(c integer(kind=c_int) :: tcl_up_var2_ end function tcl_up_var2_ - ! unsigned int Tcl_ZlibAdler32(unsigned int adler, const unsigned char *buf, int len) - ! unsigned int Tcl_ZlibCRC32(unsigned int crc, const unsigned char *buf, int len) - ! int Tcl_ZlibDeflate(Tcl_Interp *interp, int format, Tcl_Obj *data, int level, Tcl_Obj *gzipHeaderDictObj) - ! int Tcl_ZlibInflate(Tcl_Interp *interp, int format, Tcl_Obj *data, int buffersize, Tcl_Obj *gzipHeaderDictObj) + ! unsigned int Tcl_ZlibAdler32(int initValue, unsigned char *bytes, int length) + function tcl_zlib_adler32(init_value, bytes, length) bind(c, name='Tcl_ZlibAdler32') + import :: c_int, c_ptr + implicit none + integer(kind=c_int), intent(in), value :: init_value + type(c_ptr), intent(in), value :: bytes + integer(kind=c_int), intent(in), value :: length + integer(kind=c_int) :: tcl_zlib_adler32 + end function tcl_zlib_adler32 + + ! unsigned int Tcl_ZlibCRC32(int initValue, unsigned char *bytes, int length) + function tcl_zlib_crc32(init_value, bytes, length) bind(c, name='Tcl_ZlibCRC32') + import :: c_int, c_ptr + implicit none + integer(kind=c_int), intent(in), value :: init_value + type(c_ptr), intent(in), value :: bytes + integer(kind=c_int), intent(in), value :: length + integer(kind=c_int) :: tcl_zlib_crc32 + end function tcl_zlib_crc32 + + ! int Tcl_ZlibDeflate(Tcl_Interp *interp, int format, Tcl_Obj *dataObj, int level, Tcl_Obj *dictObj) + function tcl_zlib_deflate(interp, format, data_obj, level, dict_obj) bind(c, name='Tcl_ZlibDeflate') + import :: c_int, c_ptr + implicit none + type(c_ptr), intent(in), value :: interp + integer(kind=c_int), intent(in), value :: format + type(c_ptr), intent(in), value :: data_obj + integer(kind=c_int), intent(in), value :: level + type(c_ptr), intent(in), value :: dict_obj + integer(kind=c_int) :: tcl_zlib_deflate + end function tcl_zlib_deflate + + ! int Tcl_ZlibInflate(Tcl_Interp *interp, int format, Tcl_Obj *dataObj, Tcl_Obj *dictObj) + function tcl_zlib_inflate(interp, format, data_obj, dict_obj) bind(c, name='Tcl_ZlibInflate') + import :: c_int, c_ptr + implicit none + type(c_ptr), intent(in), value :: interp + integer(kind=c_int), intent(in), value :: format + type(c_ptr), intent(in), value :: data_obj + type(c_ptr), intent(in), value :: dict_obj + integer(kind=c_int) :: tcl_zlib_inflate + end function tcl_zlib_inflate + ! int Tcl_ZlibStreamChecksum(Tcl_ZlibStream zshandle) ! int Tcl_ZlibStreamClose(Tcl_ZlibStream zshandle) ! int Tcl_ZlibStreamEof(Tcl_ZlibStream zshandle) + ! int Tcl_ZlibStreamGet(Tcl_ZlibStream zshandle, Tcl_Obj *data, int count) + function tcl_zlib_stream_get(zhandle, data, count) bind(c, name='Tcl_ZlibStreamGet') + import :: c_int, c_ptr + implicit none + type(c_ptr), intent(in), value :: zhandle + type(c_ptr), intent(in), value :: data + integer(kind=c_int), intent(in), value :: count + integer(kind=c_int) :: tcl_zlib_stream_get + end function tcl_zlib_stream_get + ! Tcl_Obj *Tcl_ZlibStreamGetCommandName(Tcl_ZlibStream zshandle) + ! int Tcl_ZlibStreamInit(Tcl_Interp *interp, int mode, int format, int level, Tcl_Obj *dictObj, Tcl_ZlibStream *zshandle) + function tcl_zlib_stream_init(interp, mode, format, level, dict_obj, zhandle) bind(c, name='Tcl_ZlibStreamInit') + import :: c_int, c_ptr + implicit none + type(c_ptr), intent(in), value :: interp + integer(kind=c_int), intent(in), value :: mode + integer(kind=c_int), intent(in), value :: format + integer(kind=c_int), intent(in), value :: level + type(c_ptr), intent(in), value :: dict_obj + type(c_ptr), intent(in), value :: zhandle + integer(kind=c_int) :: tcl_zlib_stream_init + end function tcl_zlib_stream_init + ! int Tcl_ZlibStreamPut(Tcl_ZlibStream zshandle, Tcl_Obj *data, int flush) ! int Tcl_ZlibStreamReset(Tcl_ZlibStream zshandle) @@ -2013,6 +2120,15 @@ subroutine tcl_release(client_data) bind(c, name='Tcl_Release') type(c_ptr), intent(in), value :: client_data end subroutine tcl_release + ! void Tcl_SetByteArrayObj(Tcl_Obj *objPtr, const unsigned char *bytes, int length) + subroutine tcl_set_byte_array_obj(obj_ptr, bytes, length) bind(c, name='Tcl_SetByteArrayObj') + import :: c_char, c_int, c_ptr + implicit none + type(c_ptr), intent(in), value :: obj_ptr + character(kind=c_char), intent(in) :: bytes + integer(kind=c_int), intent(in), value :: length + end subroutine tcl_set_byte_array_obj + ! void *Tcl_SetBooleanObj(Tcl_Obj *objPtr, int boolValue) subroutine tcl_set_boolean_obj_(obj_ptr, bool_value) bind(c, name='Tcl_SetBooleanObj') import :: c_int, c_ptr @@ -2103,8 +2219,6 @@ subroutine tcl_wrong_num_args_(interp, objc, objv, message) bind(c, name='Tcl_Wr type(c_ptr), intent(in) :: objv(*) character(kind=c_char), intent(in) :: message end subroutine tcl_wrong_num_args_ - - ! void Tcl_ZlibStreamSetCompressionDictionary(Tcl_ZlibStream zhandle, Tcl_Obj *compressionDictionaryObj) end interface interface diff --git a/src/macro.c b/src/tcl_macro.c similarity index 100% rename from src/macro.c rename to src/tcl_macro.c