diff options
Diffstat (limited to 'guile/modules')
| -rw-r--r-- | guile/modules/gnutls.in | 616 | ||||
| -rw-r--r-- | guile/modules/gnutls/build/enums.scm | 730 | ||||
| -rw-r--r-- | guile/modules/gnutls/build/smobs.scm | 231 | ||||
| -rw-r--r-- | guile/modules/gnutls/build/tests.scm | 93 | ||||
| -rw-r--r-- | guile/modules/gnutls/build/utils.scm | 46 | ||||
| -rw-r--r-- | guile/modules/gnutls/extra.scm | 83 | ||||
| -rw-r--r-- | guile/modules/system/documentation/README | 15 | ||||
| -rw-r--r-- | guile/modules/system/documentation/c-snarf.scm | 210 | ||||
| -rw-r--r-- | guile/modules/system/documentation/output.scm | 176 |
9 files changed, 2200 insertions, 0 deletions
diff --git a/guile/modules/gnutls.in b/guile/modules/gnutls.in new file mode 100644 index 0000000..67f0a29 --- /dev/null +++ b/guile/modules/gnutls.in @@ -0,0 +1,616 @@ +;;; GnuTLS --- Guile bindings for GnuTLS. +;;; Copyright (C) 2007-2012, 2014, 2015, 2016, 2019, 2021-2022 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@gnu.org> + +(define-module (gnutls) + ;; Note: The export list must be manually kept in sync with the build + ;; system. + :export (;; versioning + gnutls-version + + ;; sessions + session? + make-session bye handshake rehandshake reauthenticate + alert-get alert-send + session-cipher session-kx session-mac session-protocol + session-compression-method session-certificate-type + session-authentication-type session-server-authentication-type + session-client-authentication-type + session-peer-certificate-chain session-our-certificate-chain + set-session-transport-fd! set-session-transport-port! + set-session-credentials! set-server-session-certificate-request! + set-session-server-name! + + ;; anonymous credentials + anonymous-client-credentials? anonymous-server-credentials? + make-anonymous-client-credentials make-anonymous-server-credentials + set-anonymous-server-dh-parameters! + + ;; certificate credentials + certificate-credentials? make-certificate-credentials + set-certificate-credentials-dh-parameters! + set-certificate-credentials-x509-key-files! + set-certificate-credentials-x509-trust-file! + set-certificate-credentials-x509-crl-file! + set-certificate-credentials-x509-key-data! + set-certificate-credentials-x509-trust-data! + set-certificate-credentials-x509-crl-data! + set-certificate-credentials-x509-keys! + set-certificate-credentials-verify-limits! + set-certificate-credentials-verify-flags! + peer-certificate-status + + ;; SRP credentials + srp-client-credentials? srp-server-credentials? + make-srp-client-credentials make-srp-server-credentials + set-srp-client-credentials! + set-srp-server-credentials-files! + server-session-srp-username + srp-base64-encode srp-base64-decode + + ;; PSK credentials + psk-client-credentials? psk-server-credentials? + make-psk-client-credentials make-psk-server-credentials + set-psk-client-credentials! + set-psk-server-credentials-file! + server-session-psk-username + + ;; priorities + set-session-priorities! + set-session-default-priority! + + ;; DH + set-session-dh-prime-bits! + make-dh-parameters dh-parameters? + pkcs3-import-dh-parameters pkcs3-export-dh-parameters + + ;; X.509 + x509-certificate? x509-private-key? + import-x509-certificate x509-certificate-matches-hostname? + x509-certificate-dn x509-certificate-dn-oid + x509-certificate-issuer-dn x509-certificate-issuer-dn-oid + x509-certificate-signature-algorithm x509-certificate-version + x509-certificate-key-id x509-certificate-authority-key-id + x509-certificate-subject-key-id + x509-certificate-subject-alternative-name + x509-certificate-public-key-algorithm x509-certificate-key-usage + x509-certificate-fingerprint import-x509-private-key + pkcs8-import-x509-private-key + + ;; record layer + record-send record-receive! + session-record-port + set-session-record-port-close! + + ;; debugging + set-log-procedure! set-log-level! + + ;; enum->string functions + cipher->string kx->string params->string credentials->string + mac->string digest->string compression-method->string + connection-end->string connection-flag->string + alert-level->string + alert-description->string handshake-description->string + certificate-status->string certificate-request->string + close-request->string + protocol->string certificate-type->string + x509-certificate-format->string + x509-subject-alternative-name->string pk-algorithm->string + sign-algorithm->string psk-key-format->string key-usage->string + certificate-verify->string error->string + cipher-suite->string server-name-type->string + + ;; enum values + cipher/null + cipher/arcfour cipher/arcfour-128 + cipher/3des-cbc + cipher/aes-128-cbc cipher/rijndael-cbc cipher/rijndael-128-cbc + cipher/aes-256-cbc cipher/rijndael-256-cbc + cipher/arcfour-40 + cipher/rc2-40-cbc + cipher/des-cbc + kx/rsa + kx/dhe-dss + kx/dhe-rsa + kx/anon-dh + kx/srp + kx/rsa-export + kx/srp-rsa + kx/srp-dss + kx/psk + kx/dhe-dss + params/rsa-export + params/dh + credentials/certificate + credentials/anon + credentials/anonymous + credentials/srp + credentials/psk + credentials/ia + mac/unknown + mac/null + mac/md5 + mac/sha1 + mac/rmd160 + mac/md2 + digest/null + digest/md5 + digest/sha1 + digest/rmd160 + digest/md2 + digest/sha256 + compression-method/null + compression-method/deflate + compression-method/lzo + connection-end/server + connection-end/client + connection-flag/datagram + connection-flag/nonblock + connection-flag/no-extensions + connection-flag/no-replay-protection + connection-flag/no-signal + connection-flag/allow-id-change + connection-flag/enable-false-start + connection-flag/force-client-cert + connection-flag/no-tickets + connection-flag/key-share-top + connection-flag/key-share-top2 + connection-flag/key-share-top3 + connection-flag/post-handshake-auth + connection-flag/no-auto-rekey + connection-flag/safe-padding-check + connection-flag/enable-early-start + connection-flag/enable-rawpk + connection-flag/auto-reauth + connection-flag/enable-early-data + alert-level/warning + alert-level/fatal + alert-description/close-notify + alert-description/unexpected-message + alert-description/bad-record-mac + alert-description/decryption-failed + alert-description/record-overflow + alert-description/decompression-failure + alert-description/handshake-failure + alert-description/ssl3-no-certificate + alert-description/bad-certificate + alert-description/unsupported-certificate + alert-description/certificate-revoked + alert-description/certificate-expired + alert-description/certificate-unknown + alert-description/illegal-parameter + alert-description/unknown-ca + alert-description/access-denied + alert-description/decode-error + alert-description/decrypt-error + alert-description/export-restriction + alert-description/protocol-version + alert-description/insufficient-security + alert-description/internal-error + alert-description/user-canceled + alert-description/no-renegotiation + alert-description/unsupported-extension + alert-description/certificate-unobtainable + alert-description/unrecognized-name + alert-description/unknown-psk-identity + alert-description/inner-application-failure + alert-description/inner-application-verification + handshake-description/hello-request + handshake-description/client-hello + handshake-description/server-hello + handshake-description/certificate-pkt + handshake-description/server-key-exchange + handshake-description/certificate-request + handshake-description/server-hello-done + handshake-description/certificate-verify + handshake-description/client-key-exchange + handshake-description/finished + certificate-status/invalid + certificate-status/revoked + certificate-status/signer-not-found + certificate-status/signer-not-ca + certificate-status/insecure-algorithm + certificate-status/not-activated + certificate-status/expired + certificate-status/signature-failure + certificate-status/revocation-data-superseded + certificate-status/unexpected-owner + certificate-status/revocation-data-issued-in-future + certificate-status/signer-constraints-failed + certificate-status/mismatch + certificate-status/purpose-mismatch + certificate-status/missing-ocsp-status + certificate-status/invalid-ocsp-status + certificate-status/unknown-crit-extensions + certificate-request/ignore + certificate-request/request + certificate-request/require + close-request/rdwr + close-request/wr + protocol/ssl-3 + protocol/tls-1.0 + protocol/tls-1.1 + protocol/version-unknown + certificate-type/x509 + certificate-type/openpgp + x509-certificate-format/der + x509-certificate-format/pem + x509-subject-alternative-name/dnsname + x509-subject-alternative-name/rfc822name + x509-subject-alternative-name/uri + x509-subject-alternative-name/ipaddress + pk-algorithm/rsa + pk-algorithm/dsa + pk-algorithm/unknown + sign-algorithm/unknown + sign-algorithm/rsa-sha1 + sign-algorithm/dsa-sha1 + sign-algorithm/rsa-md5 + sign-algorithm/rsa-md2 + sign-algorithm/rsa-rmd160 + psk-key-format/raw + psk-key-format/hex + key-usage/digital-signature + key-usage/non-repudiation + key-usage/key-encipherment + key-usage/data-encipherment + key-usage/key-agreement + key-usage/key-cert-sign + key-usage/crl-sign + key-usage/encipher-only + key-usage/decipher-only + certificate-verify/disable-ca-sign + certificate-verify/allow-x509-v1-ca-crt + certificate-verify/allow-x509-v1-ca-certificate + certificate-verify/do-not-allow-same + certificate-verify/allow-any-x509-v1-ca-crt + certificate-verify/allow-any-x509-v1-ca-certificate + certificate-verify/allow-sign-rsa-md2 + certificate-verify/allow-sign-rsa-md5 + server-name-type/dns + + ;; FIXME: Automate this: + ;; grep '^#define GNUTLS_E_' ../../lib/includes/gnutls/gnutls.h.in | \ + ;; sed -r -e 's|^#define GNUTLS_E_([^ ]+).*$|error/\1|' | tr A-Z_ a-z- + error/success + error/unsupported-version-packet + error/tls-packet-decoding-error + error/unexpected-packet-length + error/invalid-session + error/fatal-alert-received + error/unexpected-packet + error/warning-alert-received + error/error-in-finished-packet + error/unexpected-handshake-packet + error/decryption-failed + error/memory-error + error/decompression-failed + error/compression-failed + error/again + error/expired + error/db-error + error/srp-pwd-error + error/keyfile-error + error/insufficient-credentials + error/insuficient-credentials + error/insufficient-cred + error/insuficient-cred + error/hash-failed + error/base64-decoding-error + error/rehandshake + error/got-application-data + error/record-limit-reached + error/encryption-failed + error/pk-encryption-failed + error/pk-decryption-failed + error/pk-sign-failed + error/x509-unsupported-critical-extension + error/key-usage-violation + error/no-certificate-found + error/invalid-request + error/short-memory-buffer + error/interrupted + error/push-error + error/pull-error + error/received-illegal-parameter + error/requested-data-not-available + error/pkcs1-wrong-pad + error/received-illegal-extension + error/internal-error + error/dh-prime-unacceptable + error/file-error + error/too-many-empty-packets + error/unknown-pk-algorithm + error/too-many-handshake-packets + error/received-disallowed-name + error/certificate-required + error/no-temporary-rsa-params + error/no-compression-algorithms + error/no-cipher-suites + error/openpgp-getkey-failed + error/pk-sig-verify-failed + error/illegal-srp-username + error/srp-pwd-parsing-error + error/keyfile-parsing-error + error/no-temporary-dh-params + error/asn1-element-not-found + error/asn1-identifier-not-found + error/asn1-der-error + error/asn1-value-not-found + error/asn1-generic-error + error/asn1-value-not-valid + error/asn1-tag-error + error/asn1-tag-implicit + error/asn1-type-any-error + error/asn1-syntax-error + error/asn1-der-overflow + error/openpgp-uid-revoked + error/certificate-error + error/x509-certificate-error + error/certificate-key-mismatch + error/unsupported-certificate-type + error/x509-unknown-san + error/openpgp-fingerprint-unsupported + error/x509-unsupported-attribute + error/unknown-hash-algorithm + error/unknown-pkcs-content-type + error/unknown-pkcs-bag-type + error/invalid-password + error/mac-verify-failed + error/constraint-error + error/warning-ia-iphf-received + error/warning-ia-fphf-received + error/ia-verify-failed + error/unknown-algorithm + error/unsupported-signature-algorithm + error/safe-renegotiation-failed + error/unsafe-renegotiation-denied + error/unknown-srp-username + error/premature-termination + error/malformed-cidr + error/base64-encoding-error + error/incompatible-gcrypt-library + error/incompatible-crypto-library + error/incompatible-libtasn1-library + error/openpgp-keyring-error + error/x509-unsupported-oid + error/random-failed + error/base64-unexpected-header-error + error/openpgp-subkey-error + error/crypto-already-registered + error/already-registered + error/handshake-too-large + error/cryptodev-ioctl-error + error/cryptodev-device-error + error/channel-binding-not-available + error/bad-cookie + error/openpgp-preferred-key-error + error/incompat-dsa-key-with-tls-protocol + error/insufficient-security + error/heartbeat-pong-received + error/heartbeat-ping-received + error/unrecognized-name + error/pkcs11-error + error/pkcs11-load-error + error/parsing-error + error/pkcs11-pin-error + error/pkcs11-slot-error + error/locking-error + error/pkcs11-attribute-error + error/pkcs11-device-error + error/pkcs11-data-error + error/pkcs11-unsupported-feature-error + error/pkcs11-key-error + error/pkcs11-pin-expired + error/pkcs11-pin-locked + error/pkcs11-session-error + error/pkcs11-signature-error + error/pkcs11-token-error + error/pkcs11-user-error + error/crypto-init-failed + error/timedout + error/user-error + error/ecc-no-supported-curves + error/ecc-unsupported-curve + error/pkcs11-requested-object-not-availble + error/certificate-list-unsorted + error/illegal-parameter + error/no-priorities-were-set + error/x509-unsupported-extension + error/session-eof + error/tpm-error + error/tpm-key-password-error + error/tpm-srk-password-error + error/tpm-session-error + error/tpm-key-not-found + error/tpm-uninitialized + error/tpm-no-lib + error/no-certificate-status + error/ocsp-response-error + error/random-device-error + error/auth-error + error/no-application-protocol + error/sockets-init-error + error/key-import-failed + error/inappropriate-fallback + error/certificate-verification-error + error/privkey-verification-error + error/unexpected-extensions-length + error/asn1-embedded-null-in-string + error/self-test-error + error/no-self-test + error/lib-in-error-state + error/pk-generation-error + error/idna-error + error/need-fallback + error/session-user-id-changed + error/handshake-during-false-start + error/unavailable-during-handshake + error/pk-invalid-pubkey + error/pk-invalid-privkey + error/not-yet-activated + error/invalid-utf8-string + error/no-embedded-data + error/invalid-utf8-email + error/invalid-password-string + error/certificate-time-error + error/record-overflow + error/asn1-time-error + error/incompatible-sig-with-key + error/pk-invalid-pubkey-params + error/pk-no-validation-params + error/ocsp-mismatch-with-certs + error/no-common-key-share + error/reauth-request + error/too-many-matches + error/crl-verification-error + error/missing-extension + error/db-entry-exists + error/early-data-rejected + error/unimplemented-feature + error/int-ret-0 + error/int-check-again + error/application-error-max + error/application-error-min + + fatal-error? + + ;; OpenPGP keys (formerly in GnuTLS-extra) + openpgp-certificate? openpgp-private-key? + import-openpgp-certificate import-openpgp-private-key + openpgp-certificate-id openpgp-certificate-id! + openpgp-certificate-fingerprint openpgp-certificate-fingerprint! + openpgp-certificate-name openpgp-certificate-names + openpgp-certificate-algorithm openpgp-certificate-version + openpgp-certificate-usage + + ;; OpenPGP keyrings + openpgp-keyring? import-openpgp-keyring + openpgp-keyring-contains-key-id? + + ;; certificate credentials + set-certificate-credentials-openpgp-keys! + + ;; enum->string functions + openpgp-certificate-format->string + + ;; enum values + openpgp-certificate-format/raw + openpgp-certificate-format/base64)) + +(eval-when (expand load eval) + (define %libdir + (or (getenv "GNUTLS_GUILE_EXTENSION_DIR") + + ;; The .scm file is supposed to be architecture-independent. Thus, + ;; save 'extensiondir' only if it's different from what Guile expects. + @maybe_guileextensiondir@)) + + (unless (getenv "GNUTLS_GUILE_CROSS_COMPILING") + (load-extension (if %libdir + (string-append %libdir "/guile-gnutls-v-2") + "guile-gnutls-v-2") + "scm_init_gnutls"))) + +(define-syntax define-deprecated + (lambda (s) + "Define a deprecated variable or procedure, along these lines: + + (define-deprecated variable alias) + +This defines 'variable' as an alias for 'alias', and emits a warning when +'variable' is used." + (syntax-case s () + ((_ variable) + (with-syntax ((alias (datum->syntax + #'variable + (symbol-append + '% (syntax->datum #'variable))))) + #'(define-deprecated variable alias))) + ((_ variable alias) + (identifier? #'variable) + #`(define-syntax variable + (lambda (s) + (issue-deprecation-warning + (format #f "GnuTLS variable '~a' is deprecated" + (syntax->datum #'variable))) + (syntax-case s () + ((_ args (... ...)) + #'(alias args (... ...))) + (id + (identifier? #'id) + #'alias)))))))) + + +;; Renaming. +(define protocol/ssl-3 protocol/ssl3) +(define protocol/tls-1.0 protocol/tls1-0) +(define protocol/tls-1.1 protocol/tls1-1) + +;; Aliases. +(define credentials/anonymous credentials/anon) +(define cipher/rijndael-256-cbc cipher/aes-256-cbc) +(define cipher/rijndael-128-cbc cipher/aes-128-cbc) +(define cipher/rijndael-cbc cipher/aes-128-cbc) +(define cipher/arcfour-128 cipher/arcfour) +(define certificate-verify/allow-any-x509-v1-ca-certificate + certificate-verify/allow-any-x509-v1-ca-crt) +(define certificate-verify/allow-x509-v1-ca-certificate + certificate-verify/allow-x509-v1-ca-crt) + +;; Deprecated OpenPGP bindings. +(define-deprecated certificate-type/openpgp) +(define-deprecated error/openpgp-getkey-failed) +(define-deprecated error/openpgp-uid-revoked) +(define-deprecated error/openpgp-fingerprint-unsupported) +(define-deprecated error/openpgp-keyring-error) +(define-deprecated error/openpgp-subkey-error) +(define-deprecated error/openpgp-preferred-key-error) +(define-deprecated openpgp-private-key?) +(define-deprecated import-openpgp-certificate) +(define-deprecated import-openpgp-private-key) +(define-deprecated openpgp-certificate-id) +(define-deprecated openpgp-certificate-id!) +(define-deprecated openpgp-certificate-fingerprint) +(define-deprecated openpgp-certificate-fingerprint!) +(define-deprecated openpgp-certificate-name) +(define-deprecated openpgp-certificate-names) +(define-deprecated openpgp-certificate-algorithm) +(define-deprecated openpgp-certificate-version) +(define-deprecated openpgp-certificate-usage) +(define-deprecated openpgp-keyring?) +(define-deprecated import-openpgp-keyring) +(define-deprecated openpgp-keyring-contains-key-id?) +(define-deprecated set-certificate-credentials-openpgp-keys!) + +;; XXX: The following bindings should be marked as deprecated as well, but due +;; to the way binding names are constructed for enums and smobs, it's +;; complicated. Oh well. +;; +;; (define-deprecated openpgp-certificate?) +;; (define-deprecated openpgp-certificate-format->string) +;; (define-deprecated openpgp-certificate-format/raw) +;; (define-deprecated openpgp-certificate-format/base64) + +;;; Local Variables: +;;; mode: scheme +;;; coding: latin-1 +;;; End: + +;;; arch-tag: 3394732c-d9fa-48dd-a093-9fba3a325b8b diff --git a/guile/modules/gnutls/build/enums.scm b/guile/modules/gnutls/build/enums.scm new file mode 100644 index 0000000..4bfbb45 --- /dev/null +++ b/guile/modules/gnutls/build/enums.scm @@ -0,0 +1,730 @@ +;;; GnuTLS --- Guile bindings for GnuTLS. +;;; Copyright (C) 2007-2012, 2014, 2019 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 enums) + :use-module (srfi srfi-1) + :use-module (srfi srfi-9) + :use-module (gnutls build utils) + + :export (make-enum-type enum-type-subsystem enum-type-value-alist + enum-type-c-type enum-type-get-name-function + enum-type-automatic-get-name-function + enum-type-smob-name + enum-type-to-c-function enum-type-from-c-function + + output-enum-smob-definitions output-enum-definitions + output-enum-declarations + output-enum-definition-function output-c->enum-converter + output-enum->c-converter + + %cipher-enum %mac-enum %compression-method-enum %kx-enum + %protocol-enum %certificate-type-enum + + %gnutls-enums)) + +;;; +;;; This module helps with the creation of bindings for the C enumerate +;;; types. It aims at providing strong typing (i.e., one cannot use an +;;; enumerate value of the wrong type) along with authenticity checks (i.e., +;;; values of a given enumerate type cannot be forged---for instance, one +;;; cannot use some random integer as an enumerate value). Additionally, +;;; Scheme enums representing the same C enum value should be `eq?'. +;;; +;;; To that end, Scheme->C conversions are optimized (a simple +;;; `SCM_SMOB_DATA'), since that is the most common usage pattern. +;;; Conversely, C->Scheme conversions take time proportional to the number of +;;; value in the enum type. +;;; + + +;;; +;;; Enumeration tools. +;;; + +(define-record-type <enum-type> + (%make-enum-type subsystem c-type enum-map get-name value-prefix) + enum-type? + (subsystem enum-type-subsystem) + (enum-map enum-type-value-alist) + (c-type enum-type-c-type) + (get-name enum-type-get-name-function) + (value-prefix enum-type-value-prefix)) + + +(define (make-enum-type subsystem c-type values get-name . value-prefix) + ;; Return a new enumeration type. + (let ((value-prefix (if (null? value-prefix) + #f + (car value-prefix)))) + (%make-enum-type subsystem c-type + (make-enum-map subsystem values value-prefix) + get-name value-prefix))) + + +(define (make-enum-map subsystem values value-prefix) + ;; Return an alist mapping C enum values (strings) to Scheme symbols. + (define (value-symbol->string value) + (string-upcase (scheme-symbol->c-name value))) + + (define (make-c-name value) + (case value-prefix + ((#f) + ;; automatically derive the C value name. + (string-append "GNUTLS_" (string-upcase (symbol->string subsystem)) + "_" (value-symbol->string value))) + (else + (string-append value-prefix (value-symbol->string value))))) + + (map (lambda (value) + (cons (make-c-name value) value)) + values)) + +(define (enum-type-smob-name enum) + ;; Return the C name of the smob type for ENUM. + (string-append "scm_tc16_gnutls_" + (scheme-symbol->c-name (enum-type-subsystem enum)) + "_enum")) + +(define (enum-type-smob-list enum) + ;; Return the name of the C variable holding a list of value (SMOBs) for + ;; ENUM. This list is used when converting from C to Scheme. + (string-append "scm_gnutls_" + (scheme-symbol->c-name (enum-type-subsystem enum)) + "_enum_values")) + +(define (enum-type-to-c-function enum) + ;; Return the name of the C `scm_to_' function for ENUM. + (string-append "scm_to_gnutls_" + (scheme-symbol->c-name (enum-type-subsystem enum)))) + +(define (enum-type-from-c-function enum) + ;; Return the name of the C `scm_from_' function for ENUM. + (string-append "scm_from_gnutls_" + (scheme-symbol->c-name (enum-type-subsystem enum)))) + +(define (enum-type-automatic-get-name-function enum) + ;; Return the name of an automatically-generated C function that returns a + ;; string describing the given enum value of type ENUM. + (string-append "scm_gnutls_" + (scheme-symbol->c-name (enum-type-subsystem enum)) + "_to_c_string")) + + +;;; +;;; C code generation. +;;; + +(define (output-enum-smob-definitions enum port) + (let ((smob (enum-type-smob-name enum)) + (get-name (enum-type-get-name-function enum))) + (format port "SCM_GLOBAL_SMOB (~a, \"~a\", 0);~%" + smob (enum-type-subsystem enum)) + (format port "SCM ~a = SCM_EOL;~%" + (enum-type-smob-list enum)) + + (if (not (string? get-name)) + ;; Generate a "get name" function. + (output-enum-get-name-function enum port)) + + ;; Generate the printer and `->string' function. + (let ((get-name (or get-name + (enum-type-automatic-get-name-function enum)))) + (let ((subsystem (scheme-symbol->c-name (enum-type-subsystem enum)))) + ;; SMOB printer. + (format port "SCM_SMOB_PRINT (~a, ~a_print, obj, port, pstate)~%{~%" + smob subsystem) + (format port " scm_puts (\"#<gnutls-~a-enum \", port);~%" + (enum-type-subsystem enum)) + (format port " scm_puts (~a (~a (obj, 1, \"~a_print\")), port);~%" + get-name (enum-type-to-c-function enum) subsystem) + (format port " scm_puts (\">\", port);~%") + (format port " return 1;~%") + (format port "}~%") + + ;; Enum-to-string. + (format port "SCM_DEFINE (scm_gnutls_~a_to_string, \"~a->string\", " + subsystem (enum-type-subsystem enum)) + (format port "1, 0, 0,~%") + (format port " (SCM enumval),~%") + (format port " \"Return a string describing ") + (format port "@var{enumval}, a @code{~a} value.\")~%" + (enum-type-subsystem enum)) + (format port "#define FUNC_NAME s_scm_gnutls_~a_to_string~%" + subsystem) + (format port "{~%") + (format port " ~a c_enum;~%" + (enum-type-c-type enum)) + (format port " const char *c_string;~%") + (format port " c_enum = ~a (enumval, 1, FUNC_NAME);~%" + (enum-type-to-c-function enum)) + (format port " c_string = ~a (c_enum);~%" + get-name) + (format port " return (scm_from_locale_string (c_string));~%") + (format port "}~%") + (format port "#undef FUNC_NAME~%"))))) + +(define (output-enum-definitions enum port) + ;; Output to PORT the Guile C code that defines the values of ENUM-ALIST. + (let ((subsystem (scheme-symbol->c-name (enum-type-subsystem enum)))) + (format port " enum_values = SCM_EOL;~%") + (for-each (lambda (c+scheme) + (format port " SCM_NEWSMOB (enum_smob, ~a, " + (enum-type-smob-name enum)) + (format port "(scm_t_bits) ~a);~%" + (car c+scheme)) + (format port " enum_values = scm_cons (enum_smob, ") + (format port "enum_values);~%") + (format port " scm_c_define (\"~a\", enum_smob);~%" + (symbol-append (enum-type-subsystem enum) '/ + (cdr c+scheme)))) + (enum-type-value-alist enum)) + (format port " ~a = scm_permanent_object (enum_values);~%" + (enum-type-smob-list enum)))) + +(define (output-enum-declarations enum port) + ;; Issue header file declarations needed for the inline functions that + ;; handle ENUM values. + (format port "SCM_API scm_t_bits ~a;~%" + (enum-type-smob-name enum)) + (format port "SCM_API SCM ~a;~%" + (enum-type-smob-list enum))) + +(define (output-enum-definition-function enums port) + ;; Output a C function that does all the `scm_c_define ()' for the enums + ;; listed in ENUMS. + (format port "static inline void~%scm_gnutls_define_enums (void)~%{~%") + (format port " SCM enum_values, enum_smob;~%") + (for-each (lambda (enum) + (output-enum-definitions enum port)) + enums) + (format port "}~%")) + +(define (output-c->enum-converter enum port) + ;; Output a C->Scheme converted for ENUM. This works by walking the list + ;; of available enum values (SMOBs) for ENUM and then returning the + ;; matching SMOB, so that users can then compare enums using `eq?'. While + ;; this may look inefficient, this shouldn't be a problem since (i) + ;; conversion in that direction is rarely needed and (ii) the number of + ;; values per enum is expected to be small. + (format port "static inline SCM~%~a (~a c_obj)~%{~%" + (enum-type-from-c-function enum) + (enum-type-c-type enum)) + (format port " SCM pair, result = SCM_BOOL_F;~%") + (format port " for (pair = ~a; scm_is_pair (pair); " + (enum-type-smob-list enum)) + (format port "pair = SCM_CDR (pair))~%") + (format port " {~%") + (format port " SCM enum_smob;~%") + (format port " enum_smob = SCM_CAR (pair);~%") + (format port " if ((~a) SCM_SMOB_DATA (enum_smob) == c_obj)~%" + (enum-type-c-type enum)) + (format port " {~%") + (format port " result = enum_smob;~%") + (format port " break;~%") + (format port " }~%") + (format port " }~%") + (format port " return result;~%") + (format port "}~%")) + +(define (output-enum->c-converter enum port) + (let* ((c-type-name (enum-type-c-type enum)) + (subsystem (scheme-symbol->c-name (enum-type-subsystem enum)))) + + (format port + "static inline ~a~%~a (SCM obj, unsigned pos, const char *func)~%" + c-type-name (enum-type-to-c-function enum)) + (format port "#define FUNC_NAME func~%") + (format port "{~%") + (format port " SCM_VALIDATE_SMOB (pos, obj, ~a);~%" + (string-append "gnutls_" subsystem "_enum")) + (format port " return ((~a) SCM_SMOB_DATA (obj));~%" + c-type-name) + (format port "}~%") + (format port "#undef FUNC_NAME~%"))) + +(define (output-enum-get-name-function enum port) + ;; Output a C function that, when passed a C ENUM value, returns a C string + ;; representing that value. + (let ((function (enum-type-automatic-get-name-function enum))) + (format port + "static const char *~%~a (~a c_obj)~%" + function (enum-type-c-type enum)) + (format port "{~%") + (format port " static const struct ") + (format port "{ ~a value; const char *name; } " + (enum-type-c-type enum)) + (format port "table[] =~%") + (format port " {~%") + (for-each (lambda (c+scheme) + (format port " { ~a, \"~a\" },~%" + (car c+scheme) (cdr c+scheme))) + (enum-type-value-alist enum)) + (format port " };~%") + (format port " unsigned i;~%") + (format port " const char *name = NULL;~%") + (format port " for (i = 0; i < ~a; i++)~%" + (length (enum-type-value-alist enum))) + (format port " {~%") + (format port " if (table[i].value == c_obj)~%") + (format port " {~%") + (format port " name = table[i].name;~%") + (format port " break;~%") + (format port " }~%") + (format port " }~%") + (format port " return (name);~%") + (format port "}~%"))) + + +;;; +;;; Actual enumerations. +;;; + +(define %cipher-enum + (make-enum-type 'cipher "gnutls_cipher_algorithm_t" + '(null arcfour 3des-cbc aes-128-cbc aes-256-cbc + arcfour-40 rc2-40-cbc des-cbc) + "gnutls_cipher_get_name")) + +(define %kx-enum + (make-enum-type 'kx "gnutls_kx_algorithm_t" + '(rsa dhe-dss dhe-rsa anon-dh srp rsa-export + srp-rsa srp-dss psk dhe-dss) + "gnutls_kx_get_name")) + +(define %params-enum + (make-enum-type 'params "gnutls_params_type_t" + '(rsa-export dh) + #f)) + +(define %credentials-enum + (make-enum-type 'credentials "gnutls_credentials_type_t" + '(certificate anon srp psk ia) + #f + "GNUTLS_CRD_")) + +(define %mac-enum + (make-enum-type 'mac "gnutls_mac_algorithm_t" + '(unknown null md5 sha1 rmd160 md2) + "gnutls_mac_get_name")) + +(define %digest-enum + (make-enum-type 'digest "gnutls_digest_algorithm_t" + '(null md5 sha1 rmd160 md2 sha256) + #f + "GNUTLS_DIG_")) + +(define %compression-method-enum + (make-enum-type 'compression-method "gnutls_compression_method_t" + '(null deflate) + "gnutls_compression_get_name" + "GNUTLS_COMP_")) + +(define %connection-end-enum + (make-enum-type 'connection-end "gnutls_connection_end_t" + '(server client) + #f + "GNUTLS_")) + +(define %connection-flag-enum + (make-enum-type 'connection-flag "gnutls_init_flags_t" + '(datagram + nonblock + no-extensions + no-replay-protection + no-signal + allow-id-change + enable-false-start + force-client-cert + no-tickets + key-share-top + key-share-top2 + key-share-top3 + post-handshake-auth + no-auto-rekey + safe-padding-check + enable-early-start + enable-rawpk + auto-reauth + enable-early-data) + #f + "GNUTLS_")) + +(define %alert-level-enum + (make-enum-type 'alert-level "gnutls_alert_level_t" + '(warning fatal) + #f + "GNUTLS_AL_")) + +(define %alert-description-enum + (make-enum-type 'alert-description "gnutls_alert_description_t" + '(close-notify unexpected-message bad-record-mac +decryption-failed record-overflow decompression-failure handshake-failure +ssl3-no-certificate bad-certificate unsupported-certificate +certificate-revoked certificate-expired certificate-unknown illegal-parameter +unknown-ca access-denied decode-error decrypt-error export-restriction +protocol-version insufficient-security internal-error user-canceled +no-renegotiation unsupported-extension certificate-unobtainable +unrecognized-name unknown-psk-identity) + #f + "GNUTLS_A_")) + +(define %handshake-description-enum + (make-enum-type 'handshake-description "gnutls_handshake_description_t" + '(hello-request client-hello server-hello certificate-pkt + server-key-exchange certificate-request server-hello-done + certificate-verify client-key-exchange finished) + #f + "GNUTLS_HANDSHAKE_")) + +(define %certificate-status-enum + (make-enum-type 'certificate-status "gnutls_certificate_status_t" + '(invalid revoked signer-not-found signer-not-ca + insecure-algorithm not-activated expired + signature-failure revocation-data-superseded + unexpected-owner revocation-data-issued-in-future + signer-constraints-failure mismatch purpose-mismatch + missing-ocsp-status invalid-ocsp-status + unknown-crit-extensions) + #f + "GNUTLS_CERT_")) + +(define %certificate-request-enum + (make-enum-type 'certificate-request "gnutls_certificate_request_t" + '(ignore request require) + #f + "GNUTLS_CERT_")) + +;; XXX: Broken naming convention. +; (define %openpgp-key-status-enum +; (make-enum-type 'openpgp-key-status "gnutls_openpgp_key_status_t" +; '(key fingerprint) +; #f +; "GNUTLS_OPENPGP_")) + +(define %close-request-enum + (make-enum-type 'close-request "gnutls_close_request_t" + '(rdwr wr) ;; FIXME: Check the meaning and rename + #f + "GNUTLS_SHUT_")) + +(define %protocol-enum + (make-enum-type 'protocol "gnutls_protocol_t" + '(ssl3 tls1-0 tls1-1 version-unknown) + #f + "GNUTLS_")) + +(define %certificate-type-enum + (make-enum-type 'certificate-type "gnutls_certificate_type_t" + '(x509 openpgp) + "gnutls_certificate_type_get_name" + "GNUTLS_CRT_")) + +(define %x509-certificate-format-enum + (make-enum-type 'x509-certificate-format "gnutls_x509_crt_fmt_t" + '(der pem) + #f + "GNUTLS_X509_FMT_")) + +(define %x509-subject-alternative-name-enum + (make-enum-type 'x509-subject-alternative-name + "gnutls_x509_subject_alt_name_t" + '(dnsname rfc822name uri ipaddress) + #f + "GNUTLS_SAN_")) + +(define %pk-algorithm-enum + (make-enum-type 'pk-algorithm "gnutls_pk_algorithm_t" + '(unknown rsa dsa) + "gnutls_pk_algorithm_get_name" + "GNUTLS_PK_")) + +(define %sign-algorithm-enum + (make-enum-type 'sign-algorithm "gnutls_sign_algorithm_t" + '(unknown rsa-sha1 dsa-sha1 rsa-md5 rsa-md2 + rsa-rmd160) + "gnutls_sign_algorithm_get_name" + "GNUTLS_SIGN_")) + +(define %psk-key-format-enum + (make-enum-type 'psk-key-format "gnutls_psk_key_flags" + '(raw hex) + #f + "GNUTLS_PSK_KEY_")) + +(define %key-usage-enum + ;; Not actually an enum on the C side. + (make-enum-type 'key-usage "int" + '(digital-signature non-repudiation key-encipherment + data-encipherment key-agreement key-cert-sign + crl-sign encipher-only decipher-only) + #f + "GNUTLS_KEY_")) + +(define %certificate-verify-enum + (make-enum-type 'certificate-verify "gnutls_certificate_verify_flags" + '(disable-ca-sign allow-x509-v1-ca-crt + do-not-allow-same allow-any-x509-v1-ca-crt + allow-sign-rsa-md2 allow-sign-rsa-md5) + #f + "GNUTLS_VERIFY_")) + +(define %error-enum + (make-enum-type 'error "int" + '( +;; FIXME: Automate this: +;; grep '^#define GNUTLS_E_' ../../../lib/includes/gnutls/gnutls.h.in \ +;; | sed -r -e 's/^#define GNUTLS_E_([^ ]+).*$/\1/' | tr A-Z_ a-z- +success +unsupported-version-packet +tls-packet-decoding-error +unexpected-packet-length +invalid-session +fatal-alert-received +unexpected-packet +warning-alert-received +error-in-finished-packet +unexpected-handshake-packet +decryption-failed +memory-error +decompression-failed +compression-failed +again +expired +db-error +srp-pwd-error +keyfile-error +insufficient-credentials +insuficient-credentials +insufficient-cred +insuficient-cred +hash-failed +base64-decoding-error +rehandshake +got-application-data +record-limit-reached +encryption-failed +pk-encryption-failed +pk-decryption-failed +pk-sign-failed +x509-unsupported-critical-extension +key-usage-violation +no-certificate-found +invalid-request +short-memory-buffer +interrupted +push-error +pull-error +received-illegal-parameter +requested-data-not-available +pkcs1-wrong-pad +received-illegal-extension +internal-error +dh-prime-unacceptable +file-error +too-many-empty-packets +unknown-pk-algorithm +too-many-handshake-packets +received-disallowed-name +certificate-required +no-temporary-rsa-params +no-compression-algorithms +no-cipher-suites +openpgp-getkey-failed +pk-sig-verify-failed +illegal-srp-username +srp-pwd-parsing-error +keyfile-parsing-error +no-temporary-dh-params +asn1-element-not-found +asn1-identifier-not-found +asn1-der-error +asn1-value-not-found +asn1-generic-error +asn1-value-not-valid +asn1-tag-error +asn1-tag-implicit +asn1-type-any-error +asn1-syntax-error +asn1-der-overflow +openpgp-uid-revoked +certificate-error +x509-certificate-error +certificate-key-mismatch +unsupported-certificate-type +x509-unknown-san +openpgp-fingerprint-unsupported +x509-unsupported-attribute +unknown-hash-algorithm +unknown-pkcs-content-type +unknown-pkcs-bag-type +invalid-password +mac-verify-failed +constraint-error +warning-ia-iphf-received +warning-ia-fphf-received +ia-verify-failed +unknown-algorithm +unsupported-signature-algorithm +safe-renegotiation-failed +unsafe-renegotiation-denied +unknown-srp-username +premature-termination +malformed-cidr +base64-encoding-error +incompatible-gcrypt-library +incompatible-crypto-library +incompatible-libtasn1-library +openpgp-keyring-error +x509-unsupported-oid +random-failed +base64-unexpected-header-error +openpgp-subkey-error +crypto-already-registered +already-registered +handshake-too-large +cryptodev-ioctl-error +cryptodev-device-error +channel-binding-not-available +bad-cookie +openpgp-preferred-key-error +incompat-dsa-key-with-tls-protocol +insufficient-security +heartbeat-pong-received +heartbeat-ping-received +unrecognized-name +pkcs11-error +pkcs11-load-error +parsing-error +pkcs11-pin-error +pkcs11-slot-error +locking-error +pkcs11-attribute-error +pkcs11-device-error +pkcs11-data-error +pkcs11-unsupported-feature-error +pkcs11-key-error +pkcs11-pin-expired +pkcs11-pin-locked +pkcs11-session-error +pkcs11-signature-error +pkcs11-token-error +pkcs11-user-error +crypto-init-failed +timedout +user-error +ecc-no-supported-curves +ecc-unsupported-curve +pkcs11-requested-object-not-availble +certificate-list-unsorted +illegal-parameter +no-priorities-were-set +x509-unsupported-extension +session-eof +tpm-error +tpm-key-password-error +tpm-srk-password-error +tpm-session-error +tpm-key-not-found +tpm-uninitialized +tpm-no-lib +no-certificate-status +ocsp-response-error +random-device-error +auth-error +no-application-protocol +sockets-init-error +key-import-failed +inappropriate-fallback +certificate-verification-error +privkey-verification-error +unexpected-extensions-length +asn1-embedded-null-in-string +self-test-error +no-self-test +lib-in-error-state +pk-generation-error +idna-error +need-fallback +session-user-id-changed +handshake-during-false-start +unavailable-during-handshake +pk-invalid-pubkey +pk-invalid-privkey +not-yet-activated +invalid-utf8-string +no-embedded-data +invalid-utf8-email +invalid-password-string +certificate-time-error +record-overflow +asn1-time-error +incompatible-sig-with-key +pk-invalid-pubkey-params +pk-no-validation-params +ocsp-mismatch-with-certs +no-common-key-share +reauth-request +too-many-matches +crl-verification-error +missing-extension +db-entry-exists +early-data-rejected +unimplemented-feature +int-ret-0 +int-check-again +application-error-max +application-error-min +) + "gnutls_strerror" + "GNUTLS_E_")) + + +(define %openpgp-certificate-format-enum + (make-enum-type 'openpgp-certificate-format "gnutls_openpgp_crt_fmt_t" + '(raw base64) + #f + "GNUTLS_OPENPGP_FMT_")) + +(define %server-name-type-enum + (make-enum-type 'server-name-type "gnutls_server_name_type_t" + '(dns) + #f + "GNUTLS_NAME_")) + +(define %gnutls-enums + ;; All enums. + (list %cipher-enum %kx-enum %params-enum %credentials-enum %mac-enum + %digest-enum %compression-method-enum + %connection-end-enum %connection-flag-enum + %alert-level-enum %alert-description-enum %handshake-description-enum + %certificate-status-enum %certificate-request-enum + %close-request-enum %protocol-enum %certificate-type-enum + %x509-certificate-format-enum %x509-subject-alternative-name-enum + %pk-algorithm-enum %sign-algorithm-enum %server-name-type-enum + %psk-key-format-enum %key-usage-enum %certificate-verify-enum + %error-enum + + %openpgp-certificate-format-enum)) + +;;; Local Variables: +;;; mode: scheme +;;; coding: latin-1 +;;; End: + +;;; arch-tag: 9e3eb6bb-61a5-4e85-861f-1914ab9677b0 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 diff --git a/guile/modules/gnutls/build/tests.scm b/guile/modules/gnutls/build/tests.scm new file mode 100644 index 0000000..7dd7991 --- /dev/null +++ b/guile/modules/gnutls/build/tests.scm @@ -0,0 +1,93 @@ +;;; GnuTLS --- Guile bindings for GnuTLS. +;;; Copyright (C) 2011-2012, 2016, 2021-2022 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@gnu.org>. + +(define-module (gnutls build tests) + #:export (run-test + with-child-process)) + +(define (run-test thunk) + "Call `(exit (THUNK))'. If THUNK raises an exception, then call `(exit 1)' and +display a backtrace. Otherwise, return THUNK's return value." + (exit + (catch #t + thunk + (lambda (key . args) + ;; Never reached. + (exit 1)) + (lambda (key . args) + (dynamic-wind ;; to be on the safe side + (lambda () #t) + (lambda () + (format (current-error-port) + "~%throw to `~a' with args ~s [PID ~a]~%" + key args (getpid)) + (display-backtrace (make-stack #t) (current-output-port))) + (lambda () + (exit 1))) + (exit 1))))) + +(define (call-with-child-process child parent) + "Run thunk CHILD in a child process and invoke PARENT from the parent +process, passing it the PID of the child process. Make sure the child +process exits upon failure." + (let ((pid (primitive-fork))) + (if (zero? pid) + (dynamic-wind + (const #t) + (lambda () + (primitive-exit (if (child) 0 1))) + (lambda () + (primitive-exit 2))) + (parent pid)))) + +(use-modules (rnrs io ports) + (rnrs bytevectors) + (ice-9 match)) + +(define-syntax-rule (define-replacement (name args ...) body ...) + ;; Define a compatibility replacement for NAME, if needed. + (define-public name + (if (module-defined? the-scm-module 'name) + (module-ref the-scm-module 'name) + (lambda (args ...) + body ...)))) + +;; 'uniform-vector-read!' and 'uniform-vector-write' are deprecated in 2.0 +;; and absent in 2.2. +;; TODO: Switch to the R6RS bytevector and I/O interface. + +(define-replacement (uniform-vector-read! buf port) + (match (get-bytevector-n! port buf + 0 (bytevector-length buf)) + ((? eof-object?) 0) + ((? integer? n) n))) + +(define-replacement (uniform-vector-write buf port) + (put-bytevector port buf)) + +(define-syntax-rule (with-child-process pid parent child) + "Fork and evaluate expression PARENT in the current process, with PID bound +to the PID of its child process; the child process evaluated CHILD." + (call-with-child-process + (lambda () child) + (lambda (pid) parent))) + +;;; Local Variables: +;;; eval: (put 'define-replacement 'scheme-indent-function 1) +;;; End: diff --git a/guile/modules/gnutls/build/utils.scm b/guile/modules/gnutls/build/utils.scm new file mode 100644 index 0000000..b547aa8 --- /dev/null +++ b/guile/modules/gnutls/build/utils.scm @@ -0,0 +1,46 @@ +;;; GnuTLS --- Guile bindings for GnuTLS. +;;; Copyright (C) 2007-2012 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 utils) + :use-module (srfi srfi-13) + :export (scheme-symbol->c-name)) + +;;; +;;; Common utilities for the binding generation code. +;;; + + +;;; +;;; Utilities. +;;; + +(define (scheme-symbol->c-name sym) + ;; Turn SYM, a symbol denoting a Scheme name, into a string denoting a C + ;; name. + (string-map (lambda (chr) + (if (eq? chr #\-) #\_ chr)) + (symbol->string sym))) + + +;;; Local Variables: +;;; mode: scheme +;;; coding: latin-1 +;;; End: + +;;; arch-tag: 56919ee1-7cce-46b9-b90f-ae6fbcfe4159 diff --git a/guile/modules/gnutls/extra.scm b/guile/modules/gnutls/extra.scm new file mode 100644 index 0000000..4191c5a --- /dev/null +++ b/guile/modules/gnutls/extra.scm @@ -0,0 +1,83 @@ +;;; GnuTLS-extra --- Guile bindings for GnuTLS-EXTRA. +;;; Copyright (C) 2007-2012 Free Software Foundation, Inc. +;;; +;;; GnuTLS-extra is free software; you can redistribute it and/or modify +;;; it under the terms of the GNU General Public License as published by +;;; the Free Software Foundation; either version 3 of the License, or +;;; (at your option) any later version. +;;; +;;; GnuTLS-extra 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 General Public License for more details. +;;; +;;; You should have received a copy of the GNU General Public License +;;; along with GnuTLS-EXTRA; 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@gnu.org> + +(define-module (gnutls extra) + + :use-module (gnutls) + + :re-export (;; OpenPGP keys + openpgp-certificate? openpgp-private-key? + import-openpgp-certificate import-openpgp-private-key + openpgp-certificate-id openpgp-certificate-id! + openpgp-certificate-fingerprint openpgp-certificate-fingerprint! + openpgp-certificate-name openpgp-certificate-names + openpgp-certificate-algorithm openpgp-certificate-version + openpgp-certificate-usage + + ;; OpenPGP keyrings + openpgp-keyring? import-openpgp-keyring + openpgp-keyring-contains-key-id? + + ;; certificate credentials + set-certificate-credentials-openpgp-keys! + + ;; enum->string functions + openpgp-certificate-format->string + + ;; enum values + openpgp-certificate-format/raw + openpgp-certificate-format/base64)) + + + +;;; +;;; This module will be removed in a future version. +;;; + +(issue-deprecation-warning + "The (gnutls extra) module is deprecated; use (gnutls) instead") + + +;;; +;;; Aliases kept for backward compatibility with GnuTLS 2.0.x. These aliases +;;; are deprecated in 2.2 and should be removed in 2.4.x. +;;; + +(define-public openpgp-public-key? openpgp-certificate?) +(define-public import-openpgp-public-key import-openpgp-certificate) +(define-public openpgp-public-key-id openpgp-certificate-id) +(define-public openpgp-public-key-id! openpgp-certificate-id!) +(define-public openpgp-public-key-fingerprint openpgp-certificate-fingerprint) +(define-public openpgp-public-key-fingerprint! openpgp-certificate-fingerprint!) +(define-public openpgp-public-key-name openpgp-certificate-name) +(define-public openpgp-public-key-names openpgp-certificate-names) +(define-public openpgp-public-key-algorithm openpgp-certificate-algorithm) +(define-public openpgp-public-key-version openpgp-certificate-version) +(define-public openpgp-public-key-usage openpgp-certificate-usage) + +(define-public openpgp-key-format->string openpgp-certificate-format->string) +(define-public openpgp-key-format/raw openpgp-certificate-format/raw) +(define-public openpgp-key-format/base64 openpgp-certificate-format/base64) + + +;;; Local Variables: +;;; mode: scheme +;;; coding: latin-1 +;;; End: diff --git a/guile/modules/system/documentation/README b/guile/modules/system/documentation/README new file mode 100644 index 0000000..d8dba12 --- /dev/null +++ b/guile/modules/system/documentation/README @@ -0,0 +1,15 @@ +C Documentation Snarfing Modules +-------------------------------- + +This modules provide allow the extraction of Texinfo documentation +strings from C files---this is usually referred to as ``doc snarfing'' +in Guile terms. + +They were stolen from Guile-Reader 0.3: + + https://www.nongnu.org/guile-reader/ + +It was only slightly modified. + + +Ludovic Courtès <ludo@chbouib.org>. diff --git a/guile/modules/system/documentation/c-snarf.scm b/guile/modules/system/documentation/c-snarf.scm new file mode 100644 index 0000000..5e54da3 --- /dev/null +++ b/guile/modules/system/documentation/c-snarf.scm @@ -0,0 +1,210 @@ +;;; c-snarf.scm -- Parsing documentation "snarffed" from C files. +;;; +;;; Copyright 2006-2012 Free Software Foundation, Inc. +;;; +;;; +;;; This program is free software; you can redistribute it and/or modify +;;; it under the terms of the GNU General Public License as published by +;;; the Free Software Foundation; either version 3 of the License, or +;;; (at your option) any later version. +;;; +;;; This program 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 General Public License for more details. +;;; +;;; You should have received a copy of the GNU General Public License +;;; along with this program; if not, write to the Free Software +;;; Foundation, Inc., 51 Franklin St, Fifth Floor, Boston, MA 02110-1301 USA + +(define-module (system documentation c-snarf) + :use-module (ice-9 popen) + :use-module (ice-9 rdelim) + + :use-module (srfi srfi-13) + :use-module (srfi srfi-14) + :use-module (srfi srfi-39) + + :export (run-cpp-and-extract-snarfing + parse-snarfing + parse-snarfed-line)) + +;;; Author: Ludovic Courtès +;;; +;;; Commentary: +;;; +;;; This module provides tools to parse and otherwise manipulate +;;; documentation "snarffed" from C files, i.e., information obtained by +;;; running the C preprocessor with the @code{-DSCM_MAGIC_SNARF_DOCS} flag. +;;; +;;; Code: + + + +;;; +;;; High-level API. +;;; + +(define (run-cpp-and-extract-snarfing file cpp cpp-flags) + (let ((pipe (apply open-pipe* OPEN_READ + (cons cpp (append cpp-flags (list file)))))) + (parse-snarfing pipe))) + + +;;; +;;; Parsing magic-snarffed CPP output. +;;; + +(define (parse-c-argument-list arg-string) + "Parse @var{arg-string} (a string representing a ANSI C argument list, +e.g., @var{(const SCM first, SCM second_arg)}) and return a list of strings +denoting the argument names." + (define %c-symbol-char-set + (char-set-adjoin char-set:letter+digit #\_)) + + (let loop ((args (string-tokenize (string-trim-both arg-string #\space) + %c-symbol-char-set)) + (type? #t) + (result '())) + (if (null? args) + (reverse! result) + (let ((the-arg (car args))) + (cond ((and type? (string=? the-arg "const")) + (loop (cdr args) type? result)) + ((and type? (string=? the-arg "SCM")) + (loop (cdr args) (not type?) result)) + (type? ;; any other type, e.g., `void' + (loop (cdr args) (not type?) result)) + (else + (loop (cdr args) (not type?) (cons the-arg result)))))))) + +(define (parse-documentation-item item) + "Parse @var{item} (a string), a single function string produced by the C +preprocessor. The result is an alist whose keys represent specific aspects +of a procedure's documentation: @code{c-name}, @code{scheme-name}, + @code{documentation} (a Texinfo documentation string), etc." + + (define (read-strings) + ;; Read several subsequent strings and return their concatenation. + (let loop ((str (read)) + (result '())) + (if (or (eof-object? str) + (not (string? str))) + (string-concatenate (reverse! result)) + (loop (read) (cons str result))))) + + (let* ((item (string-trim-both item #\space)) + (space (string-index item #\space))) + (if (not space) + (error "invalid documentation item" item) + (let ((kind (substring item 0 space)) + (rest (substring item space (string-length item)))) + (cond ((string=? kind "cname") + (cons 'c-name (string-trim-both rest #\space))) + ((string=? kind "fname") + (cons 'scheme-name + (with-input-from-string rest read-strings))) + ((string=? kind "type") + (cons 'type (with-input-from-string rest read))) + ((string=? kind "location") + (cons 'location + (with-input-from-string rest + (lambda () + (let loop ((str (read)) + (result '())) + (if (eof-object? str) + (reverse! result) + (loop (read) (cons str result)))))))) + ((string=? kind "arglist") + (cons 'arguments + (parse-c-argument-list rest))) + ((string=? kind "argsig") + (cons 'signature + (with-input-from-string rest + (lambda () + (let ((req (read)) (opt (read)) (rst? (read))) + (list (cons 'required req) + (cons 'optional opt) + (cons 'rest? (= 1 rst?)))))))) + (else + ;; docstring (may consist of several C strings which we + ;; assume to be equivalent to Scheme strings) + (cons 'documentation + (with-input-from-string item read-strings)))))))) + +(define (parse-snarfed-line line) + "Parse @var{line}, a string that contains documentation returned for a +single function by the C preprocessor with the @code{-DSCM_MAGIC_SNARF_DOCS} +option. @var{line} is assumed to be a complete \"^^ { ... ^^ }\" sequence." + (define (caret-split str) + (let loop ((str str) + (result '())) + (if (string=? str "") + (reverse! result) + (let ((caret (string-index str #\^)) + (len (string-length str))) + (if caret + (if (and (> (- len caret) 0) + (eq? (string-ref str (+ caret 1)) #\^)) + (loop (substring str (+ 2 caret) len) + (cons (string-take str (- caret 1)) result)) + (error "single caret not allowed" str)) + (loop "" (cons str result))))))) + + (let ((items (caret-split (substring line 4 + (- (string-length line) 4))))) + (map parse-documentation-item items))) + + +(define (parse-snarfing port) + "Read C preprocessor (where the @code{SCM_MAGIC_SNARF_DOCS} macro is +defined) output from @var{port} a return a list of alist, each of which +contains information about a specific function described in the C +preprocessor output." + (define start-marker "^^ {") + (define end-marker "^^ }") + + (define (read-snarf-lines start) + ;; Read the snarf lines that follow START until and end marker is found. + (let loop ((line start) + (result '())) + (cond ((eof-object? line) + ;; EOF in the middle of a "^^ { ... ^^ }" sequence; shouldn't + ;; happen. + line) + ((string-contains line end-marker) + => + (lambda (end) + (let ((result (cons (string-take line (+ 3 end)) + result))) + (string-concatenate-reverse result)))) + ((string-prefix? "#" line) + ;; Presumably a "# LINENUM" directive; skip it. + (loop (read-line port) result)) + (else + (loop (read-line port) + (cons line result)))))) + + (let loop ((line (read-line port)) + (result '())) + (cond ((eof-object? line) + result) + ((string-contains line start-marker) + => + (lambda (start) + (let ((line + (read-snarf-lines (string-drop line start)))) + (loop (read-line port) + (cons (parse-snarfed-line line) result))))) + (else + (loop (read-line port) result))))) + + +;;; c-snarf.scm ends here + +;;; Local Variables: +;;; mode: scheme +;;; coding: latin-1 +;;; End: + +;;; arch-tag: dcba2446-ee43-46d8-a47e-e6e12f121988 diff --git a/guile/modules/system/documentation/output.scm b/guile/modules/system/documentation/output.scm new file mode 100644 index 0000000..d60fe44 --- /dev/null +++ b/guile/modules/system/documentation/output.scm @@ -0,0 +1,176 @@ +;;; output.scm -- Output documentation "snarffed" from C files in Texi/GDF. +;;; +;;; Copyright 2006-2012 Free Software Foundation, Inc. +;;; +;;; +;;; This program is free software; you can redistribute it and/or modify +;;; it under the terms of the GNU General Public License as published by +;;; the Free Software Foundation; either version 3 of the License, or +;;; (at your option) any later version. +;;; +;;; This program 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 General Public License for more details. +;;; +;;; You should have received a copy of the GNU General Public License +;;; along with this program; if not, write to the Free Software +;;; Foundation, Inc., 51 Franklin St, Fifth Floor, Boston, MA 02110-1301 USA + +(define-module (system documentation output) + :use-module (srfi srfi-1) + :use-module (srfi srfi-13) + :use-module (srfi srfi-39) + :autoload (system documentation c-snarf) (run-cpp-and-extract-snarfing) + + :export (schemify-name scheme-procedure-texi-line + procedure-gdf-string procedure-texi-documentation + output-procedure-texi-documentation-from-c-file + *document-c-functions?*)) + +;;; Author: Ludovic Courtès +;;; +;;; Commentary: +;;; +;;; This module provides support function to issue Texinfo or GDF (Guile +;;; Documentation Format) documentation from "snarffed" C files. +;;; +;;; Code: + + +;;; +;;; Utility. +;;; + +(define (schemify-name str) + "Turn @var{str}, a C variable or function name, into a more ``Schemey'' +form, e.g., one with dashed instead of underscores, etc." + (string-map (lambda (chr) + (if (eq? chr #\_) + #\- + chr)) + (if (string-suffix? "_p" str) + (string-append (substring str 0 + (- (string-length str) 2)) + "?") + str))) + + +;;; +;;; Issuing Texinfo and GDF-formatted doc (i.e., `guile-procedures.texi'). +;;; GDF = Guile Documentation Format +;;; + +(define *document-c-functions?* + ;; Whether to mention C function names along with Scheme procedure names. + (make-parameter #t)) + +(define (scheme-procedure-texi-line proc-name args + required-args optional-args + rest-arg?) + "Return a Texinfo string describing the Scheme procedure named +@var{proc-name}, whose arguments are listed in @var{args} (a list of strings) +and whose signature is defined by @var{required-args}, @var{optional-args} +and @var{rest-arg?}." + (string-append "@deffn {Scheme Procedure} " proc-name " " + (string-join (take args required-args) " ") + (string-join (take (drop args required-args) + (+ optional-args + (if rest-arg? 1 0))) + " [" 'prefix) + (if rest-arg? "...]" "") + (make-string optional-args #\]))) + +(define (procedure-gdf-string proc-doc) + "Issue a Texinfo/GDF docstring corresponding to @var{proc-doc}, a +documentation alist as returned by @code{parse-snarfed-line}. To produce +actual GDF-formatted doc, the resulting string must be processed by +@code{makeinfo}." + (let* ((proc-name (assq-ref proc-doc 'scheme-name)) + (args (assq-ref proc-doc 'arguments)) + (signature (assq-ref proc-doc 'signature)) + (required-args (assq-ref signature 'required)) + (optional-args (assq-ref signature 'optional)) + (rest-arg? (assq-ref signature 'rest?)) + (location (assq-ref proc-doc 'location)) + (file-name (car location)) + (line (cadr location)) + (documentation (assq-ref proc-doc 'documentation))) + (string-append " " ;; form feed + proc-name (string #\newline) + (format #f "@c snarfed from ~a:~a~%" + file-name line) + + (scheme-procedure-texi-line proc-name + (map schemify-name args) + required-args optional-args + rest-arg?) + + (string #\newline) + documentation (string #\newline) + "@end deffn" (string #\newline)))) + +(define (procedure-texi-documentation proc-doc) + "Issue a Texinfo docstring corresponding to @var{proc-doc}, a documentation +alist as returned by @var{parse-snarfed-line}. The resulting Texinfo string +is meant for use in a manual since it also documents the corresponding C +function." + (let* ((proc-name (assq-ref proc-doc 'scheme-name)) + (c-name (assq-ref proc-doc 'c-name)) + (args (assq-ref proc-doc 'arguments)) + (signature (assq-ref proc-doc 'signature)) + (required-args (assq-ref signature 'required)) + (optional-args (assq-ref signature 'optional)) + (rest-arg? (assq-ref signature 'rest?)) + (location (assq-ref proc-doc 'location)) + (file-name (car location)) + (line (cadr location)) + (documentation (assq-ref proc-doc 'documentation))) + (string-append (string #\newline) + (format #f "@c snarfed from ~a:~a~%" + file-name line) + + ;; document the Scheme procedure + (scheme-procedure-texi-line proc-name + (map schemify-name args) + required-args optional-args + rest-arg?) + (string #\newline) + + (if (*document-c-functions?*) + (string-append + ;; document the C function + "@deffnx {C Function} " c-name " (" + (if (null? args) + "void" + (string-join (map (lambda (arg) + (string-append "SCM " arg)) + args) + ", ")) + ")" (string #\newline)) + "") + + documentation (string #\newline) + "@end deffn" (string #\newline)))) + + +;;; +;;; Very high-level interface. +;;; + +(define (output-procedure-texi-documentation-from-c-file c-file cpp cflags + port) + (for-each (lambda (texi-string) + (display texi-string port)) + (map procedure-texi-documentation + (run-cpp-and-extract-snarfing c-file cpp cflags)))) + + +;;; output.scm ends here + +;;; Local Variables: +;;; mode: scheme +;;; coding: latin-1 +;;; End: + +;;; arch-tag: 20ca493a-6f1a-4d7f-9d24-ccce0d32df49 |