internal.scm 4.6 KB

123456789101112131415161718192021222324252627282930313233343536373839404142434445464748495051525354555657585960616263646566676869707172737475767778798081828384858687888990919293949596979899100101102103104105106107108109110111112113114115116117118119120121122123
  1. ;;; guile-gcrypt --- crypto tooling for guile
  2. ;;; Copyright © 2019, 2020 Ludovic Courtès <ludo@gnu.org>
  3. ;;;
  4. ;;; This file is part of guile-gcrypt.
  5. ;;;
  6. ;;; guile-gcrypt is free software; you can redistribute it and/or
  7. ;;; modify it under the terms of the GNU Lesser General Public License
  8. ;;; as published by the Free Software Foundation; either version 3 of
  9. ;;; the License, or (at your option) any later version.
  10. ;;;
  11. ;;; guile-gcrypt is distributed in the hope that it will be useful, but
  12. ;;; WITHOUT ANY WARRANTY; without even the implied warranty of
  13. ;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU
  14. ;;; Lesser General Public License for more details.
  15. ;;;
  16. ;;; You should have received a copy of the GNU Lesser General Public License
  17. ;;; along with guile-gcrypt. If not, see <http://www.gnu.org/licenses/>.
  18. (define-module (gcrypt internal)
  19. #:use-module (gcrypt package-config)
  20. #:use-module (system foreign)
  21. #:export (libgcrypt->pointer
  22. libgcrypt->procedure
  23. define-enumerate-type
  24. define-lookup-procedure
  25. gcrypt-version))
  26. ;;; Code:
  27. ;;;
  28. ;;; This module provides tools for internal use. The API of this module may
  29. ;;; change anytime; you should not rely on it. Loading this module
  30. ;;; initializes Libgcrypt as a side effect.
  31. ;;;
  32. ;;; Comment:
  33. (define (libgcrypt->pointer name)
  34. "Return a pointer to symbol FUNC in libgcrypt."
  35. (catch #t
  36. (lambda ()
  37. (dynamic-func name (dynamic-link %libgcrypt)))
  38. (lambda args
  39. (lambda _
  40. (throw 'system-error name "~A" (list (strerror ENOSYS))
  41. (list ENOSYS))))))
  42. (define (libgcrypt->procedure return name params)
  43. "Return a pointer to symbol FUNC in libgcrypt."
  44. (catch #t
  45. (lambda ()
  46. (let ((ptr (dynamic-func name (dynamic-link %libgcrypt))))
  47. ;; The #:return-errno? facility was introduced in Guile 2.0.12.
  48. (pointer->procedure return ptr params
  49. #:return-errno? #t)))
  50. (lambda args
  51. (lambda _
  52. (throw 'system-error name "~A" (list (strerror ENOSYS))
  53. (list ENOSYS))))))
  54. (define-syntax-rule (define-enumerate-type name->integer symbol->integer
  55. integer->symbol
  56. (name id) ...)
  57. (begin
  58. (define-syntax name->integer
  59. (syntax-rules (name ...)
  60. "Return hash algorithm NAME."
  61. ((_ name) id) ...))
  62. (define symbol->integer
  63. (let ((alist '((name . id) ...)))
  64. (lambda (symbol)
  65. "Look up SYMBOL and return the corresponding integer or #f if it
  66. could not be found."
  67. (assq-ref alist symbol))))
  68. (define-lookup-procedure integer->symbol
  69. "Return the name (a symbol) corresponding to the given integer value."
  70. (id name) ...)))
  71. (define-syntax define-lookup-procedure
  72. (lambda (s)
  73. "Define LOOKUP as a procedure that maps an integer to its corresponding
  74. value in O(1)."
  75. (syntax-case s ()
  76. ((_ lookup docstring (index value) ...)
  77. (let* ((values (map cons
  78. (syntax->datum #'(index ...))
  79. #'(value ...)))
  80. (min (apply min (syntax->datum #'(index ...))))
  81. (max (apply max (syntax->datum #'(index ...))))
  82. (array (let loop ((i max)
  83. (result '()))
  84. (if (< i min)
  85. result
  86. (loop (- i 1)
  87. (cons (or (assv-ref values i) *unspecified*)
  88. result))))))
  89. #`(define lookup
  90. ;; Allocate a big sparse vector.
  91. (let ((values '#(#,@array)))
  92. (lambda (integer)
  93. docstring
  94. (and (<= integer #,max) (>= integer #,min)
  95. (let ((result (vector-ref values (- integer #,min))))
  96. (if (unspecified? result)
  97. #f
  98. result)))))))))))
  99. (define gcrypt-version
  100. ;; According to the manual, this function must be called before any other,
  101. ;; and it's not clear whether it can be called more than once. So call it
  102. ;; right here from the top level. During cross-compilation, the call to
  103. ;; PROC fails with a 'system-error exception; catch it.
  104. (let* ((proc (libgcrypt->procedure '* "gcry_check_version" '(*)))
  105. (version (catch 'system-error
  106. (lambda ()
  107. (pointer->string (proc %null-pointer)))
  108. (const ""))))
  109. (lambda ()
  110. "Return the version number of libgcrypt as a string."
  111. version)))