[Date Prev][Date Next][Thread Prev][Thread Next][Date Index][Thread Index]
[shepherd] 03/03: system: Use #:return-errno? when it's available.
From: |
Ludovic Courtès |
Subject: |
[shepherd] 03/03: system: Use #:return-errno? when it's available. |
Date: |
Thu, 20 Oct 2016 20:51:45 +0000 (UTC) |
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)