foreign-object.scm 3.5 KB

123456789101112131415161718192021222324252627282930313233343536373839404142434445464748495051525354555657585960616263646566676869707172737475767778798081828384858687888990919293
  1. ;;; Wrapping foreign objects in Scheme
  2. ;;; Copyright (C) 2014, 2015, 2024 Free Software Foundation, Inc.
  3. ;;;
  4. ;;; This library is free software; you can redistribute it and/or
  5. ;;; modify it under the terms of the GNU Lesser General Public
  6. ;;; License as published by the Free Software Foundation; either
  7. ;;; version 3 of the License, or (at your option) any later version.
  8. ;;;
  9. ;;; This library is distributed in the hope that it will be useful,
  10. ;;; but WITHOUT ANY WARRANTY; without even the implied warranty of
  11. ;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU
  12. ;;; Lesser General Public License for more details.
  13. ;;;
  14. ;;; You should have received a copy of the GNU Lesser General Public
  15. ;;; License along with this library; if not, write to the Free Software
  16. ;;; Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA
  17. ;;;
  18. ;;; Commentary:
  19. ;;
  20. ;;
  21. ;;; Code:
  22. (define-module (system foreign-object)
  23. #:use-module (oop goops)
  24. #:export (make-foreign-object-type
  25. define-foreign-object-type))
  26. (eval-when (eval load expand)
  27. (load-extension (string-append "libguile-" (effective-version))
  28. "scm_init_foreign_object"))
  29. (define-class <foreign-class> (<class>))
  30. (define-class <foreign-class-with-finalizer> (<foreign-class>)
  31. (finalizer #:init-keyword #:finalizer #:init-value #f
  32. #:getter finalizer))
  33. (define-method (allocate-instance (class <foreign-class-with-finalizer>)
  34. initargs)
  35. (let ((instance (next-method))
  36. (finalizer (finalizer class)))
  37. (when finalizer
  38. (%add-finalizer! instance finalizer))
  39. instance))
  40. (define* (make-foreign-object-type name slots #:key finalizer
  41. (getters (map (const #f) slots))
  42. (supers '()))
  43. (unless (symbol? name)
  44. (error "type name should be a symbol" name))
  45. (unless (or (not finalizer) (procedure? finalizer))
  46. (error "finalizer should be a procedure" finalizer))
  47. (let ((dslots (map (lambda (slot getter)
  48. (unless (symbol? slot)
  49. (error "slot name should be a symbol" slot))
  50. (cons* slot #:class <foreign-slot>
  51. #:init-keyword (symbol->keyword slot)
  52. #:init-value 0
  53. (if getter (list #:getter getter) '())))
  54. slots
  55. getters)))
  56. (if finalizer
  57. (make-class supers dslots #:name name
  58. #:finalizer finalizer
  59. #:static-slot-allocation? #t
  60. #:metaclass <foreign-class-with-finalizer>)
  61. (make-class supers dslots #:name name
  62. #:static-slot-allocation? #t
  63. #:metaclass <foreign-class>))))
  64. (define-syntax define-foreign-object-type
  65. (lambda (x)
  66. (define (kw-apply slots)
  67. (syntax-case slots ()
  68. (() #'())
  69. ((slot . slots)
  70. (let ((kw (symbol->keyword (syntax->datum #'slot))))
  71. #`(#,kw slot . #,(kw-apply #'slots))))))
  72. (syntax-case x ()
  73. ((_ name constructor (slot ...) kwarg ...)
  74. #`(begin
  75. (define slot (ensure-generic 'slot (and (defined? 'slot) slot)))
  76. ...
  77. (define name
  78. (make-foreign-object-type 'name '(slot ...) kwarg ...
  79. #:getters (list slot ...)))
  80. (define constructor
  81. (lambda (slot ...)
  82. (make name #,@(kw-apply #'(slot ...))))))))))