Added zlib API interfaces.

interkosmos · Jul 26, 2022 · 44e1ec3 · 44e1ec3
1 parent ad8ffbd
commit 44e1ec3
Show file tree

Hide file tree

Showing 5 changed files with 142 additions and 41 deletions.
diff --git 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
@@ -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
@@ -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
@@ -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 → src/tcl_macro.c b/src/macro.c → src/tcl_macro.c