inspection.scm 2.9 KB

1234567891011121314151617181920212223242526272829303132333435363738394041424344454647484950515253545556575859606162636465666768697071727374757677787980
  1. ;;; inspection.scm --- Inspection support for R6RS records
  2. ;; Copyright (C) 2010, 2019 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. (library (rnrs records inspection (6))
  18. (export record?
  19. record-rtd
  20. record-type-name
  21. record-type-parent
  22. record-type-uid
  23. record-type-generative?
  24. record-type-sealed?
  25. record-type-opaque?
  26. record-type-field-names
  27. record-field-mutable?)
  28. (import (rnrs arithmetic bitwise (6))
  29. (rnrs base (6))
  30. (rnrs records procedural (6))
  31. (rnrs exceptions (6))
  32. (rnrs conditions (6))
  33. (rename (only (guile)
  34. unless
  35. logbit?
  36. record?
  37. record-type-name
  38. record-type-parent
  39. record-type-fields
  40. record-type-opaque?
  41. record-type-extensible?
  42. record-type-uid
  43. record-type-mutable-fields
  44. struct-vtable)
  45. (record? guile:record?)))
  46. (define (record? obj)
  47. (and (guile:record? obj)
  48. (not (record-type-opaque? (struct-vtable obj)))))
  49. (define (record-rtd record)
  50. (unless (record? record)
  51. (assertion-violation 'record-rtd "not a record" record))
  52. (struct-vtable record))
  53. (define (record-type-generative? rtd)
  54. (not (record-type-uid rtd)))
  55. (define (record-type-sealed? rtd)
  56. (not (record-type-extensible? rtd)))
  57. (define (record-type-field-names rtd)
  58. (let ((parent (record-type-parent rtd))
  59. (fields (record-type-fields rtd)))
  60. (list->vector
  61. (if parent
  62. (list-tail fields (length (record-type-fields parent)))
  63. fields))))
  64. (define (record-field-mutable? rtd k)
  65. (let* ((parent (record-type-parent rtd))
  66. (parent-nfields (if parent
  67. (length (record-type-fields parent))
  68. 0))
  69. (k (+ k parent-nfields)))
  70. (unless (and (<= parent-nfields k)
  71. (< k (length (record-type-fields rtd))))
  72. (raise (make-assertion-violation)))
  73. (logbit? k (record-type-mutable-fields rtd)))))