[shepherd] 02/08: shepherd: Define and use 'replace-core-bindings!'.

[Ludovic Courtès]

civodul pushed a commit to branch master
in repository shepherd.

commit c3585cc01675a210929502b2da72cd9931e20a74
Author: Ludovic Courtès <ludo@gnu.org>
AuthorDate: Fri Mar 24 23:39:04 2023 +0100

    shepherd: Define and use 'replace-core-bindings!'.
    
    * modules/shepherd.scm (replace-core-bindings!): New macro.
    (main): Use it instead of hand-crafted 'set!' sequences.
---
 modules/shepherd.scm | 46 +++++++++++++++++++++++++++-------------------
 1 file changed, 27 insertions(+), 19 deletions(-)

diff --git a/modules/shepherd.scm b/modules/shepherd.scm
index 0b4728c..1c926c4 100644
--- a/modules/shepherd.scm
+++ b/modules/shepherd.scm
@@ -224,6 +224,28 @@ already ~a threads running, disabling 'signalfd' support")
 
            (next-command))))))
 
+(define-syntax replace-core-bindings!
+  (syntax-rules (<>)
+    "Replace the given core bindings in the current process, restoring them 
upon
+fork in the child process."
+    ((_ () <> ((binding value) ...))
+     (let ((real-primitive-fork primitive-fork))
+       (set! primitive-fork
+             (lambda ()
+               (let ((result (real-primitive-fork)))
+                 (when (zero? result)
+                   (set! binding value)
+                   ...
+                   (set! primitive-fork real-primitive-fork))
+                 result)))))
+    ((_ ((binding value) rest ...) <> (saved-bindings ...))
+     (let ((real binding))
+       (set! binding value)
+       (replace-core-bindings! (rest ...) <>
+                               ((binding real) saved-bindings ...))))
+    ((_ (binding value) ...)
+     (replace-core-bindings! ((binding value) ...) <> ()))))
+
 
 ;; Main program.
 (define (main . args)
@@ -396,25 +418,11 @@ already ~a threads running, disabling 'signalfd' support")
                    ;; cooperates instead of blocking on 'waitpid'.  Replace
                    ;; 'primitive-load' (in C as of 3.0.9) with one that does
                    ;; not introduce a continuation barrier.
-                   (let ((real-system* system*)
-                         (real-system  system)
-                         (real-primitive-load primitive-load))
-                     (set! system* (lambda command
-                                     (spawn-command command)))
-                     (set! system spawn-shell-command)
-                     (set! primitive-load primitive-load*)
-
-                     ;; Restore those bindings after fork.
-                     (set! primitive-fork
-                           (let ((real-fork primitive-fork))
-                             (lambda ()
-                               (let ((result (real-fork)))
-                                 (when (zero? result)
-                                   (set! primitive-fork real-fork)
-                                   (set! system* real-system*)
-                                   (set! system real-system)
-                                   (set! primitive-load real-primitive-load))
-                                 result)))))
+                   (replace-core-bindings!
+                    (system* (lambda command
+                               (spawn-command command)))
+                    (system spawn-shell-command)
+                    (primitive-load primitive-load*))
 
                    (run-daemon #:socket-file socket-file
                                #:config-file config-file