atomic.c 3.9 KB

123456789101112131415161718192021222324252627282930313233343536373839404142434445464748495051525354555657585960616263646566676869707172737475767778798081828384858687888990919293949596979899100101102103104105106107108109110111112113114115116117118119120121122123124125126127128129130131132133134135
  1. /* Copyright 2016,2018-2019
  2. Free Software Foundation, Inc.
  3. This file is part of Guile.
  4. Guile is free software: you can redistribute it and/or modify it
  5. under the terms of the GNU Lesser General Public License as published
  6. by the Free Software Foundation, either version 3 of the License, or
  7. (at your option) any later version.
  8. Guile is distributed in the hope that it will be useful, but WITHOUT
  9. ANY WARRANTY; without even the implied warranty of MERCHANTABILITY or
  10. FITNESS FOR A PARTICULAR PURPOSE. See the GNU Lesser General Public
  11. License for more details.
  12. You should have received a copy of the GNU Lesser General Public
  13. License along with Guile. If not, see
  14. <https://www.gnu.org/licenses/>. */
  15. #ifdef HAVE_CONFIG_H
  16. # include <config.h>
  17. #endif
  18. #include "atomics-internal.h"
  19. #include "boolean.h"
  20. #include "extensions.h"
  21. #include "gsubr.h"
  22. #include "ports.h"
  23. #include "version.h"
  24. #include "atomic.h"
  25. SCM_DEFINE (scm_make_atomic_box, "make-atomic-box", 1, 0, 0,
  26. (SCM init),
  27. "Return an atomic box initialized to value @var{init}.")
  28. #define FUNC_NAME s_scm_make_atomic_box
  29. {
  30. SCM ret = scm_cell (scm_tc7_atomic_box, SCM_UNPACK (SCM_UNDEFINED));
  31. scm_atomic_box_set_x (ret, init);
  32. return ret;
  33. }
  34. #undef FUNC_NAME
  35. SCM_DEFINE (scm_atomic_box_p, "atomic-box?", 1, 0, 0,
  36. (SCM obj),
  37. "Return @code{#t} if @var{obj} is an atomic-box object, else\n"
  38. "return @code{#f}.")
  39. #define FUNC_NAME s_scm_atomic_box_p
  40. {
  41. return scm_from_bool (scm_is_atomic_box (obj));
  42. }
  43. #undef FUNC_NAME
  44. SCM_DEFINE (scm_atomic_box_ref, "atomic-box-ref", 1, 0, 0,
  45. (SCM box),
  46. "Fetch the value stored in the atomic box @var{box} and\n"
  47. "return it.")
  48. #define FUNC_NAME s_scm_atomic_box_ref
  49. {
  50. SCM_VALIDATE_ATOMIC_BOX (1, box);
  51. return scm_atomic_ref_scm (scm_atomic_box_loc (box));
  52. }
  53. #undef FUNC_NAME
  54. SCM_DEFINE (scm_atomic_box_set_x, "atomic-box-set!", 2, 0, 0,
  55. (SCM box, SCM val),
  56. "Store @var{val} into the atomic box @var{box}.")
  57. #define FUNC_NAME s_scm_atomic_box_set_x
  58. {
  59. SCM_VALIDATE_ATOMIC_BOX (1, box);
  60. scm_atomic_set_scm (scm_atomic_box_loc (box), val);
  61. return SCM_UNSPECIFIED;
  62. }
  63. #undef FUNC_NAME
  64. SCM_DEFINE (scm_atomic_box_swap_x, "atomic-box-swap!", 2, 0, 0,
  65. (SCM box, SCM val),
  66. "Store @var{val} into the atomic box @var{box},\n"
  67. "and return the value that was previously stored in\n"
  68. "the box.")
  69. #define FUNC_NAME s_scm_atomic_box_swap_x
  70. {
  71. SCM_VALIDATE_ATOMIC_BOX (1, box);
  72. return scm_atomic_swap_scm (scm_atomic_box_loc (box), val);
  73. }
  74. #undef FUNC_NAME
  75. SCM_DEFINE (scm_atomic_box_compare_and_swap_x,
  76. "atomic-box-compare-and-swap!", 3, 0, 0,
  77. (SCM box, SCM expected, SCM desired),
  78. "If the value of the atomic box @var{box} is the same as,\n"
  79. "@var{expected} (in the sense of @code{eq?}), replace the\n"
  80. "contents of the box with @var{desired}. Otherwise does not\n"
  81. "update the box. Returns the previous value of the box in\n"
  82. "either case, so you can know if the swap worked by checking\n"
  83. "if the return value is @code{eq?} to @var{expected}.")
  84. #define FUNC_NAME s_scm_atomic_box_compare_and_swap_x
  85. {
  86. SCM_VALIDATE_ATOMIC_BOX (1, box);
  87. return scm_atomic_compare_and_swap_scm (scm_atomic_box_loc (box),
  88. expected, desired);
  89. }
  90. #undef FUNC_NAME
  91. void
  92. scm_i_atomic_box_print (SCM exp, SCM port, scm_print_state *pstate)
  93. {
  94. scm_puts ("#<atomic-box ", port);
  95. scm_uintprint (SCM_UNPACK (exp), 16, port);
  96. scm_puts (" value: ", port);
  97. scm_iprin1 (scm_atomic_box_ref (exp), port, pstate);
  98. scm_putc ('>', port);
  99. }
  100. static void
  101. scm_init_atomic (void)
  102. {
  103. #include "atomic.x"
  104. }
  105. void
  106. scm_register_atomic (void)
  107. {
  108. scm_c_register_extension ("libguile-" SCM_EFFECTIVE_VERSION,
  109. "scm_init_atomic",
  110. (scm_t_extension_init_func) scm_init_atomic,
  111. NULL);
  112. }