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