Skip to content

Commit 15b2aa2

Browse files
ktakashiktakashi
committed
Supporting SRFI-230
1 parent a1278cb commit 15b2aa2

File tree

4 files changed

+414
-1
lines changed

4 files changed

+414
-1
lines changed

‎doc/srfi.md

Lines changed: 3 additions & 1 deletion
Original file line numberDiff line numberDiff line change
@@ -9,7 +9,7 @@ functions, please look for SRFI's site. I might write it later.
99
For now, I just put pointer to [the SRFI's web site](http://srfi.schemers.org/)
1010

1111
| SRFI number | Library name |
12-
| ----------------------------------------------------------- | ----------------------------------------------------|
12+
|-------------------------------------------------------------|-----------------------------------------------------|
1313
| [SRFI-0](http://srfi.schemers.org/srfi-0/srfi-0.html) | (srfi :0 cond-expand) |
1414
| [SRFI-1](http://srfi.schemers.org/srfi-1/srfi-1.html) | (srfi :1 lists) |
1515
| [SRFI-2](http://srfi.schemers.org/srfi-2/srfi-2.html) | (srfi :2 and-let\*) |
@@ -94,6 +94,8 @@ For now, I just put pointer to [the SRFI's web site](http://srfi.schemers.org/)
9494
| [SRFI-197](http://srfi.schemers.org/srfi-197/srfi-197.html) | (srfi :197 pipeline)[^longname] |
9595
| [SRFI-210](http://srfi.schemers.org/srfi-210/srfi-210.html) | (srfi :210 multiple-values)[^longname] |
9696
| [SRFI-219](http://srfi.schemers.org/srfi-219/srfi-219.html) | (srfi :219 define)[^longname][^builtin] |
97+
| [SRFI-230](http://srfi.schemers.org/srfi-230/srfi-230.html) | (srfi :230 atomic) |
98+
9799

98100
[^SRFI-4]: This SRFI also contains reader macro described below this section.
99101

‎sitelib/srfi/%3a230.scm

Lines changed: 33 additions & 0 deletions
Original file line numberDiff line numberDiff line change
@@ -0,0 +1,33 @@
1+
;;; -*- mode:scheme; coding:utf-8; -*-
2+
;;;
3+
;;; srfi/%3a230.scm - Atomic Operations
4+
;;;
5+
;;; Copyright (c) 2025 Takashi Kato <ktakashi@ymail.com>
6+
;;;
7+
;;; Redistribution and use in source and binary forms, with or without
8+
;;; modification, are permitted provided that the following conditions
9+
;;; are met:
10+
;;;
11+
;;; 1. Redistributions of source code must retain the above copyright
12+
;;; notice, this list of conditions and the following disclaimer.
13+
;;;
14+
;;; 2. Redistributions in binary form must reproduce the above copyright
15+
;;; notice, this list of conditions and the following disclaimer in the
16+
;;; documentation and/or other materials provided with the distribution.
17+
;;;
18+
;;; THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS
19+
;;; "AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT
20+
;;; LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR
21+
;;; A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT
22+
;;; OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL,
23+
;;; SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED
24+
;;; TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR
25+
;;; PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF
26+
;;; LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING
27+
;;; NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS
28+
;;; SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
29+
30+
#!nounbound
31+
(library (srfi :230)
32+
(export :all)
33+
(import (srfi :230 atomic)))

‎sitelib/srfi/%3a230/atomic.scm

Lines changed: 167 additions & 0 deletions
Original file line numberDiff line numberDiff line change
@@ -0,0 +1,167 @@
1+
;;; -*- mode:scheme; coding:utf-8; -*-
2+
;;;
3+
;;; srfi/%3a230/atomic.scm - Atomic Operations
4+
;;;
5+
;;; Copyright (c) 2025 Takashi Kato <ktakashi@ymail.com>
6+
;;;
7+
;;; Redistribution and use in source and binary forms, with or without
8+
;;; modification, are permitted provided that the following conditions
9+
;;; are met:
10+
;;;
11+
;;; 1. Redistributions of source code must retain the above copyright
12+
;;; notice, this list of conditions and the following disclaimer.
13+
;;;
14+
;;; 2. Redistributions in binary form must reproduce the above copyright
15+
;;; notice, this list of conditions and the following disclaimer in the
16+
;;; documentation and/or other materials provided with the distribution.
17+
;;;
18+
;;; THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS
19+
;;; "AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT
20+
;;; LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR
21+
;;; A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT
22+
;;; OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL,
23+
;;; SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED
24+
;;; TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR
25+
;;; PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF
26+
;;; LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING
27+
;;; NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS
28+
;;; SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
29+
30+
#!nounbound
31+
(library (srfi :230 atomic)
32+
(export memory-order
33+
memory-order?
34+
make-atomic-flag
35+
atomic-flag?
36+
atomic-flag-test-and-set!
37+
atomic-flag-clear!
38+
make-atomic-box
39+
atomic-box?
40+
atomic-box-ref
41+
atomic-box-set!
42+
atomic-box-swap!
43+
atomic-box-compare-and-swap!
44+
make-atomic-fxbox
45+
atomic-fxbox?
46+
atomic-fxbox-ref
47+
atomic-fxbox-set!
48+
atomic-fxbox-swap!
49+
atomic-fxbox-compare-and-swap!
50+
atomic-fxbox+/fetch!
51+
atomic-fxbox-/fetch!
52+
atomic-fxbox-and/fetch!
53+
atomic-fxbox-ior/fetch!
54+
atomic-fxbox-xor/fetch!
55+
make-atomic-pair
56+
atomic-pair?
57+
atomic-pair-ref
58+
atomic-pair-set!
59+
atomic-pair-swap!
60+
atomic-pair-compare-and-swap!
61+
atomic-fence)
62+
(import (rnrs)
63+
(rename (sagittarius atomic)
64+
(memory-order? a:memory-order?)))
65+
;; memory order
66+
(define-enumeration memory-order
67+
(relaxed acquire release acquire-release sequentially-consistent)
68+
memory-orders)
69+
(define *memory-orders* (enum-set-universe (memory-orders)))
70+
(define (memory-order? sym) (enum-set-member? sym *memory-orders*))
71+
(define *default-order* (memory-order sequentially-consistent))
72+
73+
;; atomic flag
74+
(define (make-atomic-flag) (make-atomic #f))
75+
(define (atomic-flag? a) (and (atomic? a) (boolean? (atomic-load a))))
76+
(define (atomic-flag-test-and-set! (atomic atomic-flag?)
77+
:optional (order *default-order*))
78+
(atomic-exchange! atomic #t (memory-order->value order)))
79+
(define (atomic-flag-clear! (atomic atomic-flag?)
80+
:optional (order *default-order*))
81+
(atomic-exchange! atomic #f (memory-order->value order)))
82+
83+
;; atomic box
84+
(define (make-atomic-box obj) (make-atomic obj))
85+
(define atomic-box? atomic?)
86+
(define (atomic-box-ref (box atomic-box?)
87+
:optional (order *default-order*))
88+
(atomic-load box (memory-order->value order)))
89+
(define (atomic-box-set! (box atomic-box?) obj
90+
:optional (order *default-order*))
91+
(atomic-store! box obj (memory-order->value order)))
92+
(define (atomic-box-swap! (box atomic-box?) obj
93+
:optional (order *default-order*))
94+
(atomic-exchange! box obj (memory-order->value order)))
95+
(define (atomic-box-compare-and-swap! (box atomic-box?) old new
96+
:optional (order *default-order*))
97+
(if (atomic-compare-and-swap! box old new (memory-order->value order))
98+
old
99+
(atomic-box-ref box order)))
100+
101+
;; atomic fixnum
102+
(define (make-atomic-fxbox (fx fixnum?)) (make-atomic-fixnum fx))
103+
(define (atomic-fxbox? obj) (atomic-fixnum? obj))
104+
(define (atomic-fxbox-ref (afx atomic-fxbox?)
105+
:optional (order *default-order*))
106+
(atomic-fixnum-load afx (memory-order->value order)))
107+
(define (atomic-fxbox-set! (afx atomic-fxbox?) (fx fixnum?)
108+
:optional (order *default-order*))
109+
(atomic-fixnum-store! afx fx (memory-order->value order)))
110+
(define (atomic-fxbox-swap! (afx atomic-fxbox?) (fx fixnum?)
111+
:optional (order *default-order*))
112+
(atomic-fixnum-exchange! afx fx (memory-order->value order)))
113+
(define (atomic-fxbox-compare-and-swap! (afx atomic-fxbox?)
114+
(old fixnum?) (new fixnum?)
115+
:optional (order *default-order*))
116+
(if (atomic-compare-and-swap! afx old new (memory-order->value order))
117+
old
118+
(atomic-fxbox-ref afx order)))
119+
(define (atomic-fxbox+/fetch! (afx atomic-fxbox?) (fx fixnum?)
120+
:optional (order *default-order*))
121+
(atomic-fixnum-add! afx fx (memory-order->value order)))
122+
(define (atomic-fxbox-/fetch! (afx atomic-fxbox?) (fx fixnum?)
123+
:optional (order *default-order*))
124+
(atomic-fixnum-sub! afx fx (memory-order->value order)))
125+
(define (atomic-fxbox-and/fetch! (afx atomic-fxbox?) (fx fixnum?)
126+
:optional (order *default-order*))
127+
(atomic-fixnum-and! afx fx (memory-order->value order)))
128+
(define (atomic-fxbox-ior/fetch! (afx atomic-fxbox?) (fx fixnum?)
129+
:optional (order *default-order*))
130+
(atomic-fixnum-ior! afx fx (memory-order->value order)))
131+
(define (atomic-fxbox-xor/fetch! (afx atomic-fxbox?) (fx fixnum?)
132+
:optional (order *default-order*))
133+
(atomic-fixnum-xor! afx fx (memory-order->value order)))
134+
135+
;; atomic pair
136+
;; make-atomic-pair and atomic-pair? are the same
137+
(define (atomic-pair-ref (ap atomic-pair?)
138+
:optional (order *default-order*))
139+
(let ((p (atomic-load ap (memory-order->value order))))
140+
(values (car p) (cdr p))))
141+
(define (atomic-pair-set! (ap atomic-pair?) a d
142+
:optional (order *default-order*))
143+
(atomic-store! ap (cons a d) (memory-order->value order)))
144+
(define (atomic-pair-swap! (ap atomic-pair?) a d
145+
:optional (order *default-order*))
146+
(let ((p (atomic-exchange! ap (cons a d) (memory-order->value order))))
147+
(values (car p) (cdr p))))
148+
(define (atomic-pair-compare-and-swap! (ap atomic-pair?) oa od na nd
149+
:optional (order *default-order*))
150+
(define morder (memory-order->value order))
151+
(if (atomic-compare-and-swap! ap (cons oa od) (cons na nd) morder)
152+
(values oa od)
153+
(atomic-pair-ref ap order)))
154+
155+
(define (atomic-fence (order memory-order?))
156+
(atomic-thread-fence (memory-order->value order)))
157+
158+
;; utilities
159+
(define (memory-order->value (order memory-order?))
160+
(case order
161+
((relaxed) *memory-order:relaxed*)
162+
((acquire) *memory-order:acquire*)
163+
((relaxed) *memory-order:release*)
164+
((acquire-release) *memory-order:acq-rel*)
165+
((sequentially-consistent) *memory-order:seq-cst*)))
166+
167+
)

0 commit comments

Comments
 (0)