summaryrefslogtreecommitdiffstats
path: root/guile/modules/gnutls/build/smobs.scm
diff options
context:
space:
mode:
Diffstat (limited to 'guile/modules/gnutls/build/smobs.scm')
-rw-r--r--guile/modules/gnutls/build/smobs.scm231
1 files changed, 231 insertions, 0 deletions
diff --git a/guile/modules/gnutls/build/smobs.scm b/guile/modules/gnutls/build/smobs.scm
new file mode 100644
index 0000000..9612922
--- /dev/null
+++ b/guile/modules/gnutls/build/smobs.scm
@@ -0,0 +1,231 @@
+;;; Help produce Guile wrappers for GnuTLS types.
+;;;
+;;; GnuTLS --- Guile bindings for GnuTLS.
+;;; Copyright (C) 2007-2012, 2014 Free Software Foundation, Inc.
+;;;
+;;; GnuTLS is free software; you can redistribute it and/or
+;;; modify it under the terms of the GNU Lesser General Public
+;;; License as published by the Free Software Foundation; either
+;;; version 2.1 of the License, or (at your option) any later version.
+;;;
+;;; GnuTLS is distributed in the hope that it will be useful,
+;;; but WITHOUT ANY WARRANTY; without even the implied warranty of
+;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU
+;;; Lesser General Public License for more details.
+;;;
+;;; You should have received a copy of the GNU Lesser General Public
+;;; License along with GnuTLS; if not, write to the Free Software
+;;; Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA
+
+;;; Written by Ludovic Courtès <ludo@chbouib.org>
+
+(define-module (gnutls build smobs)
+ :use-module (srfi srfi-9)
+ :use-module (srfi srfi-13)
+ :use-module (gnutls build utils)
+ :export (make-smob-type smob-type-tag smob-free-function
+ smob-type-predicate-scheme-name
+ smob-type-from-c-function smob-type-to-c-function
+
+ output-smob-type-definition output-smob-type-declaration
+ output-smob-type-predicate
+ output-c->smob-converter output-smob->c-converter
+
+ %gnutls-smobs))
+
+
+;;;
+;;; SMOB types.
+;;;
+
+(define-record-type <smob-type>
+ (%make-smob-type c-name scm-name free-function)
+ smob-type?
+ (c-name smob-type-c-name)
+ (scm-name smob-type-scheme-name)
+ (free-function smob-type-free-function))
+
+(define (make-smob-type c-name scm-name . free-function)
+ (%make-smob-type c-name scm-name
+ (if (null? free-function)
+ (string-append "gnutls_"
+ (scheme-symbol->c-name scm-name)
+ "_deinit")
+ (car free-function))))
+
+(define (smob-type-tag type)
+ ;; Return the name of the C variable holding the type tag for TYPE.
+ (string-append "scm_tc16_gnutls_"
+ (scheme-symbol->c-name (smob-type-scheme-name type))))
+
+(define (smob-type-predicate-scheme-name type)
+ ;; Return a string denoting the Scheme name of TYPE's type predicate.
+ (string-append (symbol->string (smob-type-scheme-name type)) "?"))
+
+(define (smob-type-to-c-function type)
+ ;; Return the name of the C `scm_to_' function for SMOB.
+ (string-append "scm_to_gnutls_"
+ (scheme-symbol->c-name (smob-type-scheme-name type))))
+
+(define (smob-type-from-c-function type)
+ ;; Return the name of the C `scm_from_' function for SMOB.
+ (string-append "scm_from_gnutls_"
+ (scheme-symbol->c-name (smob-type-scheme-name type))))
+
+
+;;;
+;;; C code generation.
+;;;
+
+(define (output-smob-type-definition type port)
+ (format port "SCM_GLOBAL_SMOB (~a, \"~a\", 0);~%"
+ (smob-type-tag type)
+ (smob-type-scheme-name type))
+
+ (format port "SCM_SMOB_FREE (~a, ~a_free, obj)~%{~%"
+ (smob-type-tag type)
+ (scheme-symbol->c-name (smob-type-scheme-name type)))
+ (format port " ~a c_obj;~%"
+ (smob-type-c-name type))
+ (format port " c_obj = (~a) SCM_SMOB_DATA (obj);~%"
+ (smob-type-c-name type))
+ (format port " ~a (c_obj);~%"
+ (smob-type-free-function type))
+ (format port " return 0;~%")
+ (format port "}~%"))
+
+(define (output-smob-type-declaration type port)
+ ;; Issue a header file declaration for the SMOB type tag of TYPE.
+ (format port "SCM_API scm_t_bits ~a;~%"
+ (smob-type-tag type)))
+
+(define (output-smob-type-predicate type port)
+ (define (texi-doc-string)
+ (string-append "Return true if @var{obj} is of type @code{"
+ (symbol->string (smob-type-scheme-name type))
+ "}."))
+
+ (let ((c-name (string-append "scm_gnutls_"
+ (string-map (lambda (chr)
+ (if (char=? chr #\-)
+ #\_
+ chr))
+ (symbol->string
+ (smob-type-scheme-name type)))
+ "_p")))
+ (format port "SCM_DEFINE (~a, \"~a\", 1, 0, 0,~%"
+ c-name (smob-type-predicate-scheme-name type))
+ (format port " (SCM obj),~%")
+ (format port " \"~a\")~%"
+ (texi-doc-string))
+ (format port "#define FUNC_NAME s_~a~%"
+ c-name)
+ (format port "{~%")
+ (format port " return (scm_from_bool (SCM_SMOB_PREDICATE (~a, obj)));~%"
+ (smob-type-tag type))
+ (format port "}~%#undef FUNC_NAME~%")))
+
+(define (output-c->smob-converter type port)
+ (format port "static inline SCM~%~a (~a c_obj)~%{~%"
+ (smob-type-from-c-function type)
+ (smob-type-c-name type))
+ (format port " SCM_RETURN_NEWSMOB (~a, (scm_t_bits) c_obj);~%"
+ (smob-type-tag type))
+ (format port "}~%"))
+
+(define (output-smob->c-converter type port)
+ (format port "static inline ~a~%~a (SCM obj, "
+ (smob-type-c-name type)
+ (smob-type-to-c-function type))
+ (format port "unsigned pos, const char *func)~%")
+ (format port "#define FUNC_NAME func~%")
+ (format port "{~%")
+ (format port " SCM_VALIDATE_SMOB (pos, obj, ~a);~%"
+ (string-append "gnutls_"
+ (scheme-symbol->c-name (smob-type-scheme-name type))))
+ (format port " return ((~a) SCM_SMOB_DATA (obj));~%"
+ (smob-type-c-name type))
+ (format port "}~%")
+ (format port "#undef FUNC_NAME~%"))
+
+
+;;;
+;;; Actual SMOB types.
+;;;
+
+(define %session-smob
+ (make-smob-type "gnutls_session_t" 'session
+ "gnutls_deinit"))
+
+(define %anonymous-client-credentials-smob
+ (make-smob-type "gnutls_anon_client_credentials_t" 'anonymous-client-credentials
+ "gnutls_anon_free_client_credentials"))
+
+(define %anonymous-server-credentials-smob
+ (make-smob-type "gnutls_anon_server_credentials_t" 'anonymous-server-credentials
+ "gnutls_anon_free_server_credentials"))
+
+(define %dh-parameters-smob
+ (make-smob-type "gnutls_dh_params_t" 'dh-parameters
+ "gnutls_dh_params_deinit"))
+
+(define %certificate-credentials-smob
+ (make-smob-type "gnutls_certificate_credentials_t" 'certificate-credentials
+ "gnutls_certificate_free_credentials"))
+
+(define %srp-server-credentials-smob
+ (make-smob-type "gnutls_srp_server_credentials_t" 'srp-server-credentials
+ "gnutls_srp_free_server_credentials"))
+
+(define %srp-client-credentials-smob
+ (make-smob-type "gnutls_srp_client_credentials_t" 'srp-client-credentials
+ "gnutls_srp_free_client_credentials"))
+
+(define %psk-server-credentials-smob
+ (make-smob-type "gnutls_psk_server_credentials_t" 'psk-server-credentials
+ "gnutls_psk_free_server_credentials"))
+
+(define %psk-client-credentials-smob
+ (make-smob-type "gnutls_psk_client_credentials_t" 'psk-client-credentials
+ "gnutls_psk_free_client_credentials"))
+
+(define %x509-certificate-smob
+ (make-smob-type "gnutls_x509_crt_t" 'x509-certificate
+ "gnutls_x509_crt_deinit"))
+
+(define %x509-private-key-smob
+ (make-smob-type "gnutls_x509_privkey_t" 'x509-private-key
+ "gnutls_x509_privkey_deinit"))
+
+(define %openpgp-certificate-smob
+ (make-smob-type "gnutls_openpgp_crt_t" 'openpgp-certificate
+ "gnutls_openpgp_crt_deinit"))
+
+(define %openpgp-private-key-smob
+ (make-smob-type "gnutls_openpgp_privkey_t" 'openpgp-private-key
+ "gnutls_openpgp_privkey_deinit"))
+
+(define %openpgp-keyring-smob
+ (make-smob-type "gnutls_openpgp_keyring_t" 'openpgp-keyring
+ "gnutls_openpgp_keyring_deinit"))
+
+
+(define %gnutls-smobs
+ ;; All SMOB types.
+ (list %session-smob %anonymous-client-credentials-smob
+ %anonymous-server-credentials-smob %dh-parameters-smob
+ %certificate-credentials-smob
+ %srp-server-credentials-smob %srp-client-credentials-smob
+ %psk-server-credentials-smob %psk-client-credentials-smob
+ %x509-certificate-smob %x509-private-key-smob
+
+ %openpgp-certificate-smob %openpgp-private-key-smob
+ %openpgp-keyring-smob))
+
+
+;;; Local Variables:
+;;; mode: scheme
+;;; coding: latin-1
+;;; End:
+
+;;; arch-tag: 26bf79ef-6dee-45f2-9e9d-2d209c518278
generated by cgit v1.2.3 (git 2.39.1) at 2025-02-12 16:46:23 +0000