[shepherd] 03/03: system: Use #:return-errno? when it's available.

[Ludovic Courtès]

civodul pushed a commit to branch master
in repository shepherd.

commit 9ae6290f7ce2592a8745998d9cd87fb2859571cb
Author: Ludovic Courtès <address@hidden>
Date:   Thu Oct 20 22:49:41 2016 +0200

    system: Use #:return-errno? when it's available.
    
    * modules/shepherd/system.scm.in (syscall->procedure): New procedure.
    (%libc-reboot): Use it.  Adjust call to PROC accordingly.
    (sysconf): Likewise.
---
 modules/shepherd/system.scm.in |   51 ++++++++++++++++++++++++++++------------
 1 file changed, 36 insertions(+), 15 deletions(-)

diff --git a/modules/shepherd/system.scm.in b/modules/shepherd/system.scm.in
index 237dc10..a54dca7 100644
--- a/modules/shepherd/system.scm.in
+++ b/modules/shepherd/system.scm.in
@@ -1,5 +1,5 @@
 ;; system.scm -- Low-level operating system interface.
-;; Copyright (C) 2013, 2014 Ludovic Courtès <address@hidden>
+;; Copyright (C) 2013, 2014, 2016 Ludovic Courtès <address@hidden>
 ;;
 ;; This file is part of the GNU Shepherd.
 ;;
@@ -19,6 +19,7 @@
 (define-module (shepherd system)
   #:use-module (system foreign)
   #:use-module (rnrs bytevectors)
+  #:use-module (srfi srfi-11)
   #:export (reboot
             halt
             power-off
@@ -29,10 +30,35 @@
 (define RB_HALT_SYSTEM @RB_HALT_SYSTEM@)
 (define RB_POWER_OFF @RB_POWER_OFF@)
 
+(define (syscall->procedure return-type name argument-types)
+  "Return a procedure that wraps the C function NAME using the dynamic FFI,
+and that returns two values: NAME's return value, and errno.
+
+If an error occurs while creating the binding, defer the error report until
+the returned procedure is called."
+  (catch #t
+    (lambda ()
+      (let ((ptr (dynamic-func name (dynamic-link))))
+        ;; The #:return-errno? facility was introduced in Guile 2.0.12.
+        ;; Support older versions of Guile by catching 'wrong-number-of-args'.
+        (catch 'wrong-number-of-args
+          (lambda ()
+            (pointer->procedure return-type ptr argument-types
+                                #:return-errno? #t))
+          (lambda (key . rest)
+            (let ((proc (pointer->procedure return-type ptr argument-types)))
+              (lambda args
+                (let ((result (apply proc args))
+                      (err    (errno)))
+                  (values result err))))))))
+    (lambda args
+      (lambda _
+        (error (format #f "~a: syscall->procedure failed: ~s"
+                       name args))))))
+
 (define %libc-reboot
   ;; libc's 'reboot' function as declared in <sys/reboot.h>.
-  (let* ((ptr  (dynamic-func "reboot" (dynamic-link)))
-         (proc (pointer->procedure int ptr (list unsigned-int))))
+  (let ((proc (syscall->procedure int "reboot" (list unsigned-int))))
     (define (howto->symbol howto)
       (cond ((eqv? howto RB_AUTOBOOT) 'RB_AUTOBOOT)
             ((eqv? howto RB_HALT_SYSTEM) 'RB_HALT_SYSTEM)
@@ -40,14 +66,11 @@
             (else howto)))
 
     (lambda (howto)
-      ;; Block asyncs during the call so 'errno' remains unchanged.
-      (let ((err (call-with-blocked-asyncs
-                  (lambda ()
-                    (or (zero? (proc howto))
-                        (errno))))))
-        (throw 'system-error "reboot" "~A: ~S"
-               (list (strerror err) (howto->symbol howto))
-               (list err))))))
+      (let-values (((ret err) (proc howto)))
+        (unless (zero? ret)
+          (throw 'system-error "reboot" "~A: ~S"
+                 (list (strerror err) (howto->symbol howto))
+                 (list err)))))))
 
 (define %libc-errno-pointer
   ;; Glibc's 'errno' pointer.
@@ -97,12 +120,10 @@
 (define _SC_OPEN_MAX @_SC_OPEN_MAX@)
 
 (define sysconf
-  (let* ((ptr  (dynamic-func "sysconf" (dynamic-link)))
-         (proc (pointer->procedure long ptr (list int))))
+  (let ((proc (syscall->procedure long "sysconf" (list int))))
     (lambda (name)
       "Return the system configuration for NAME."
-      (let* ((result (proc name))
-             (err    (errno)))
+      (let-values (((result err) (proc name)))
         (if (= -1 result)
             (throw 'system-error "sysconf" "~A: ~S"
                    (list (strerror err) name)