Make uses of 'set%!' less verbose.

* gnu/gnunet/utils/cut-syntax.scm: New module.
* Makefile.am: Add it.
* gnu/gnunet/dht/client.scm: Use it.
* tests/mq.scm: Likewise.
* tests/network-size.scm: Likewise.

5 files changed, 96 insertions, 56 deletions

diff --git a/Makefile.am b/Makefile.am
index b42b6cc..dc4b207 100644
--- a/Makefile.am
+++ b/Makefile.am
@@ -60,6 +60,7 @@ modules = \
   \
   gnu/gnunet/utils/bv-slice.scm \
   gnu/gnunet/utils/hat-let.scm \
+  gnu/gnunet/utils/cut-syntax.scm \
   gnu/gnunet/utils/netstruct.scm \
   gnu/gnunet/utils/platform-enum.scm \
   gnu/gnunet/utils/tokeniser.scm \
diff --git a/gnu/gnunet/dht/client.scm b/gnu/gnunet/dht/client.scm
index 95aedc8..12bd9d7 100644
--- a/gnu/gnunet/dht/client.scm
+++ b/gnu/gnunet/dht/client.scm
@@ -103,11 +103,13 @@
                 slice-length slice/read-only make-slice/read-write slice-copy!
                 slice-slice verify-slice-readable)
           (gnu gnunet utils hat-let)
+          (only (gnu gnunet utils cut-syntax)
+                cut-syntax)
           (only (rnrs base)
                 and >= = quote * / + - define begin ... let*
                 quote case else values apply let cond if >
                 <= expt assert exact? integer? lambda for-each
-                not expt min max div-and-mod positive?)
+                not expt min max div-and-mod positive? define-syntax)
           (only (rnrs control)
                 unless when)
           (only (rnrs records syntactic)
@@ -399,15 +401,16 @@ slices in @var{old} do not impact the new search result."
       "Create a new @code{/:msg:dht:client:get} message for the query object
  @var{query}, with @var{unique-id} as ‘unique id’ and @var{options} as options."
       (define s (make-slice/read-write (sizeof /:msg:dht:client:get '())))
-      (set%! /:msg:dht:client:get '(header size) s (slice-length s))
-      (set%! /:msg:dht:client:get '(header type) s
-             (value->index (symbol-value message-type msg:dht:client:get)))
-      (set%! /:msg:dht:client:get '(options) s options)
-      (set%! /:msg:dht:client:get '(desired-replication-level) s
-             (query-desired-replication-level query))
-      (set%! /:msg:dht:client:get '(type) s (query-type query))
+      (define-syntax set%!/get (cut-syntax set%! /:msg:dht:client:get <> s <>))
+      (set%!/get '(header size) (slice-length s))
+      (set%!/get '(header type)
+                 (value->index (symbol-value message-type msg:dht:client:get)))
+      (set%!/get '(options) options)
+      (set%!/get '(desired-replication-level)
+                 (query-desired-replication-level query))
+      (set%!/get '(type) (query-type query))
       (slice-copy! (query-key query) (select /:msg:dht:client:get '(key) s))
-      (set%! /:msg:dht:client:get '(unique-id) s unique-id)
+      (set%!/get '(unique-id) unique-id)
       s)
 
     (define* (construct-client-put insertion #:optional (options 0))
@@ -421,17 +424,17 @@ object insertion with @var{options} as options."
          (+ size/header (slice-length (datum-value datum)))))
       (define header (slice-slice message 0 size/header))
       (define rest (slice-slice message size/header))
-      (set%! /:msg:dht:client:put '(header type) header
-             (value->index (symbol-value message-type msg:dht:client:put)))
-      (set%! /:msg:dht:client:put '(header size) header size)
-      (set%! /:msg:dht:client:put '(type) header (datum-type datum))
-      (set%! /:msg:dht:client:put '(option) header options)
-      (set%! /:msg:dht:client:put '(desired-replication-level) header
-             (insertion-desired-replication-level insertion))
-      (set%! /:msg:dht:client:put '(expiration) header (datum-expiration datum))
+      (define-syntax set%!/put (cut-syntax set%! /:msg:dht:client:put <> header <>))
+      (set%!/put '(header type)
+                 (value->index (symbol-value message-type msg:dht:client:put)))
+      (set%!/put '(header size) size)
+      (set%!/put '(type) (datum-type datum))
+      (set%!/put '(option) options)
+      (set%!/put '(desired-replication-level)
+                 (insertion-desired-replication-level insertion))
+      (set%!/put '(expiration) (datum-expiration datum))
       ;; Copy key-data pair to insert into the DHT.
-      (slice-copy! (datum-key datum)
-                   (select /:msg:dht:client:put '(key) header))
+      (slice-copy! (datum-key datum) (select /:msg:dht:client:put '(key) header))
       (slice-copy! (datum-value datum) rest)
       message)
 
@@ -459,20 +462,17 @@ result object @var{search-result}, with @var{unique-id} as ‘unique id’"
              (! message (make-slice/read-write size))
              (! header (slice-slice message 0 size/header))
              (! rest (slice-slice message size/header)))
-            (set%! /:msg:dht:client:result '(header type)
-                   header
-                   (value->index
-                    (symbol-value message-type msg:dht:client:result)))
-            (set%! /:msg:dht:client:result '(header size)
-                   header
-                   size)
-            (set%! /:msg:dht:client:result '(type) header type)
-            (set%! /:msg:dht:client:result '(get-path-length)
-                   header get-path-length)
-            (set%! /:msg:dht:client:result '(put-path-length)
-                   header put-path-length)
-            (set%! /:msg:dht:client:result '(unique-id) header unique-id)
-            (set%! /:msg:dht:client:result '(expiration) header expiration)
+            (define-syntax set%!/result
+              (cut-syntax set%! /:msg:dht:client:result <> header <>))
+            (set%!/result '(header type)
+                          (value->index
+                           (symbol-value message-type msg:dht:client:result)))
+            (set%!/result '(header size) size)
+            (set%!/result '(type) type)
+            (set%!/result '(get-path-length) get-path-length)
+            (set%!/result '(put-path-length) put-path-length)
+            (set%!/result '(unique-id) unique-id)
+            (set%!/result '(expiration) expiration)
             (slice-copy! key (select /:msg:dht:client:result '(key) header))
             ;; TODO: get-path and put path!
             (slice-copy! value rest)
diff --git a/gnu/gnunet/utils/cut-syntax.scm b/gnu/gnunet/utils/cut-syntax.scm
new file mode 100644
index 0000000..bc4ee9d
--- /dev/null
+++ b/gnu/gnunet/utils/cut-syntax.scm
@@ -0,0 +1,38 @@
+;; This file is part of Scheme-GNUnet
+;; Copyright © 2022 GNUnet e.V.
+;;
+;; Scheme-GNUnet is free software: you can redistribute it and/or modify it
+;; under the terms of the GNU Affero General Public License as published
+;; by the Free Software Foundation, either version 3 of the License,
+;; or (at your option) any later version.
+;;
+;; Scheme-GNUnet is distributed in the hope that it will be useful, but
+;; WITHOUT ANY WARRANTY; without even the implied warranty of
+;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the GNU
+;; Affero General Public License for more details.
+;;
+;; You should have received a copy of the GNU Affero General Public License
+;; along with this program.  If not, see <http://www.gnu.org/licenses/>.
+;;
+;; SPDX-License-Identifier: AGPL-3.0-or-later
+
+;; TODO: eliminate (gnu gnunet netstruct syntactic), use a compiler pass instead
+;; for inlining, then ‘cut-syntax’ can be deprecated in favour of a ‘cut’.
+(define-library (gnu gnunet utils cut-syntax)
+  (export cut-syntax)
+  (import (only (rnrs base) ... begin define-syntax syntax-rules))
+  (begin
+    (define-syntax substitute
+      (syntax-rules (<>)
+        ((_ (substituted ...) (<> . foos) (bar . bars))
+         (substitute (substituted ... bar) foos bars))
+        ((_ (substituted ...) (foo . foos) bars)
+         (substitute (substituted ... foo) foos bars))
+        ((_ (substituted ...) () ())
+         (substituted ...))))
+
+    (define-syntax cut-syntax
+      (syntax-rules ()
+        ((_ . foos)
+         (syntax-rules ()
+           ((_ . bars) (substitute () foos bars))))))))
diff --git a/tests/mq.scm b/tests/mq.scm
index 14d2a27..8d456ac 100644
--- a/tests/mq.scm
+++ b/tests/mq.scm
@@ -1,5 +1,5 @@
 ;; This file is part of GNUnet.
-;; Copyright (C) 2012, 2018, 2021 GNUnet e.V.
+;; Copyright (C) 2012, 2018, 2021, 2022 GNUnet e.V.
 ;;
 ;; GNUnet is free software: you can redistribute it and/or modify it
 ;; under the terms of the GNU Affero General Public License as published
@@ -46,6 +46,7 @@
              (gnu gnunet util struct)
              (gnu gnunet utils bv-slice)
              (gnu gnunet utils hat-let)
+             (gnu gnunet utils cut-syntax)
              ((gnu extractor enum)
               #:select (symbol-value value->index))
              (gnu gnunet message protocols)
@@ -82,11 +83,11 @@ Then each time the index is increased.")
 (define (index->dummy i)
   (let ((s (make-slice/read-write
             (sizeof /:msg:our-test:dummy '()))))
-    (set%! /:msg:our-test:dummy '(header type) s
-           (value->index (symbol-value message-type msg:util:dummy)))
-    (set%! /:msg:our-test:dummy '(header size) s
-           (sizeof /:msg:our-test:dummy '()))
-    (set%! /:msg:our-test:dummy '(index) s i)
+    (define-syntax set%!/dummy (cut-syntax set%! /:msg:our-test:dummy <> s <>))
+    (set%!/dummy '(header type)
+                 (value->index (symbol-value message-type msg:util:dummy)))
+    (set%!/dummy '(header size) (sizeof /:msg:our-test:dummy '()))
+    (set%!/dummy '(index) i)
     s))
 
 (define (dummy->index s)
@@ -341,12 +342,13 @@ Then each time the index is increased.")
 (define (make-thread-message thread-index i)
   (let ((s (make-slice/read-write
             (sizeof /:msg:our-test:concurrency '()))))
-    (set%! /:msg:our-test:concurrency '(header type) s
-           (value->index (symbol-value message-type msg:util:dummy)))
-    (set%! /:msg:our-test:concurrency '(header size) s
-           (sizeof /:msg:our-test:concurrency '()))
-    (set%! /:msg:our-test:concurrency '(index) s i)
-    (set%! /:msg:our-test:concurrency '(thread) s thread-index)
+    (define-syntax set%!/concurrency
+      (cut-syntax set%! /:msg:our-test:concurrency <> s <>))
+    (set%!/concurrency
+     '(header type) (value->index (symbol-value message-type msg:util:dummy)))
+    (set%!/concurrency '(header size) (sizeof /:msg:our-test:concurrency '()))
+    (set%!/concurrency '(index) i)
+    (set%!/concurrency '(thread) thread-index)
     s))
 
 (define (decode-thread-message s)
diff --git a/tests/network-size.scm b/tests/network-size.scm
index 0b27d29..8f8e6bb 100644
--- a/tests/network-size.scm
+++ b/tests/network-size.scm
@@ -23,6 +23,7 @@
         (gnu extractor enum)
         (gnu gnunet message protocols)
         (gnu gnunet config db)
+        (gnu gnunet utils cut-syntax)
         (only (rnrs base)
               assert)
         (prefix (gnu gnunet nse client) #{nse:}#)
@@ -103,19 +104,17 @@
   (define (send! estimate)
     (define s (make-slice/read-write
                (sizeof /:msg:nse:estimate '())))
+    (define-syntax set%!/estimate
+      (cut-syntax set%! /:msg:nse:estimate <> s <>))
     ;; Set the headers
-    (set%! /:msg:nse:estimate '(header size) s
-           (sizeof /:msg:nse:estimate '()))
-    (set%! /:msg:nse:estimate '(header type) s
-           (value->index
-            (symbol-value message-type msg:nse:estimate)))
+    (set%!/estimate '(header size) (sizeof /:msg:nse:estimate '()))
+    (set%!/estimate '(header type)
+                    (value->index
+                     (symbol-value message-type msg:nse:estimate)))
     ;; Set the data
-    (set%! /:msg:nse:estimate '(timestamp) s
-           (list-ref estimate 3))
-    (set%! /:msg:nse:estimate '(size-estimate) s
-           (list-ref estimate 0))
-    (set%! /:msg:nse:estimate '(std-deviation) s
-           (list-ref estimate 2))
+    (set%!/estimate '(timestamp) (list-ref estimate 3))
+    (set%!/estimate '(size-estimate) (list-ref estimate 0))
+    (set%!/estimate '(std-deviation) (list-ref estimate 2))
     ;; Send the estimate
     (send-message! mq s))
   (for-each send! %estimates))