unofficial mirror of guix-patches@gnu.org 
 help / color / mirror / code / Atom feed
From: Mathieu Othacehe <m.othacehe@gmail.com>
To: 26341@debbugs.gnu.org
Subject: bug#26341: [PATCH 3/5] build: syscalls: Add mount and umount to #:replace list.
Date: Sat,  8 Apr 2017 18:03:27 +0200	[thread overview]
Message-ID: <20170408160329.4068-4-m.othacehe@gmail.com> (raw)
In-Reply-To: <20170408160329.4068-1-m.othacehe@gmail.com>

* guix/build/syscalls.scm (mount): Use static-or-ffi macro
  and move from #:export list to #:replace list.
(umount): Ditto.
---
 guix/build/syscalls.scm | 86 +++++++++++++++++++++++--------------------------
 1 file changed, 41 insertions(+), 45 deletions(-)

diff --git a/guix/build/syscalls.scm b/guix/build/syscalls.scm
index 6afbfb86e..42071e7b1 100644
--- a/guix/build/syscalls.scm
+++ b/guix/build/syscalls.scm
@@ -45,8 +45,6 @@
             MNT_EXPIRE
             UMOUNT_NOFOLLOW
             restart-on-EINTR
-            mount
-            umount
             mount-points
             swapon
             swapoff
@@ -140,7 +138,9 @@
             login-type
             utmpx-entries
             (read-utmpx-from-port . read-utmpx))
-  #:replace (RB_AUTOBOOT
+  #:replace (mount
+             umount
+             RB_AUTOBOOT
              RB_HALT_SYSTEM
              RB_ENABLED_CAD
              RB_DISABLE_CAD
@@ -478,57 +478,53 @@ procedure, otherwise return FFI-PROCEDURE."
 (define UMOUNT_NOFOLLOW 8)
 
 (define mount
-  ;; If called from the statically linked Guile, use Guile core 'mount'.
-  ;; Otherwise, use an FFI binding to define 'mount'.
   ;; XXX: '#:update-mtab?' is not implemented by core 'mount'.
-  (if (module-defined? the-scm-module 'mount)
-      (module-ref the-scm-module 'mount)
-      (let ((proc (syscall->procedure int "mount" `(* * * ,unsigned-long *))))
-        (lambda* (source target type #:optional (flags 0) options
-                         #:key (update-mtab? #f))
-          "Mount device SOURCE on TARGET as a file system TYPE.
+  (static-or-ffi
+   'mount
+   (let ((proc (syscall->procedure int "mount" `(* * * ,unsigned-long *))))
+     (lambda* (source target type #:optional (flags 0) options
+                      #:key (update-mtab? #f))
+       "Mount device SOURCE on TARGET as a file system TYPE.
 Optionally, FLAGS may be a bitwise-or of the MS_* <sys/mount.h>
 constants, and OPTIONS may be a string.  When FLAGS contains
 MS_REMOUNT, SOURCE and TYPE are ignored.  When UPDATE-MTAB? is true,
 update /etc/mtab.  Raise a 'system-error' exception on error."
-          (let-values (((ret err)
-                        (proc (if source
-                                  (string->pointer source)
-                                  %null-pointer)
-                              (string->pointer target)
-                              (if type
-                                  (string->pointer type)
-                                  %null-pointer)
-                              flags
-                              (if options
-                                  (string->pointer options)
-                                  %null-pointer))))
-            (unless (zero? ret)
-              (throw 'system-error "mount" "mount ~S on ~S: ~A"
-                     (list source target (strerror err))
-                     (list err)))
-            (when update-mtab?
-              (augment-mtab source target type options)))))))
+       (let-values (((ret err)
+                     (proc (if source
+                               (string->pointer source)
+                               %null-pointer)
+                           (string->pointer target)
+                           (if type
+                               (string->pointer type)
+                               %null-pointer)
+                           flags
+                           (if options
+                               (string->pointer options)
+                               %null-pointer))))
+         (unless (zero? ret)
+           (throw 'system-error "mount" "mount ~S on ~S: ~A"
+                  (list source target (strerror err))
+                  (list err)))
+         (when update-mtab?
+           (augment-mtab source target type options)))))))
 
 (define umount
-  ;; If called from the statically linked Guile, use Guile core 'umount'.
-  ;; Otherwise, use an FFI binding to define 'umount'.
   ;; XXX: '#:update-mtab?' is not implemented by core 'umount'.
-  (if (module-defined? the-scm-module 'umount)
-      (module-ref the-scm-module 'umount)
-      (let ((proc (syscall->procedure int "umount2" `(* ,int))))
-        (lambda* (target #:optional (flags 0)
-                         #:key (update-mtab? #f))
-          "Unmount TARGET.  Optionally FLAGS may be one of the MNT_* or UMOUNT_*
+  (static-or-ffi
+   'umount
+   (let ((proc (syscall->procedure int "umount2" `(* ,int))))
+     (lambda* (target #:optional (flags 0)
+                      #:key (update-mtab? #f))
+       "Unmount TARGET.  Optionally FLAGS may be one of the MNT_* or UMOUNT_*
 constants from <sys/mount.h>."
-          (let-values (((ret err)
-                        (proc (string->pointer target) flags)))
-            (unless (zero? ret)
-              (throw 'system-error "umount" "~S: ~A"
-                     (list target (strerror err))
-                     (list err)))
-            (when update-mtab?
-              (remove-from-mtab target)))))))
+       (let-values (((ret err)
+                     (proc (string->pointer target) flags)))
+         (unless (zero? ret)
+           (throw 'system-error "umount" "~S: ~A"
+                  (list target (strerror err))
+                  (list err)))
+         (when update-mtab?
+           (remove-from-mtab target)))))))
 
 (define (mount-points)
   "Return the mounts points for currently mounted file systems."
-- 
2.12.2

  parent reply	other threads:[~2017-04-08 16:04 UTC|newest]

Thread overview: 30+ messages / expand[flat|nested]  mbox.gz  Atom feed  top
2017-04-02 15:01 bug#26341: [PATCH] build: vm: Add missing module Mathieu Othacehe
2017-04-04 12:41 ` Ludovic Courtès
2017-04-05 10:30   ` Mathieu Othacehe
2017-04-05 10:32     ` Mathieu Othacehe
2017-04-05 21:39       ` Ludovic Courtès
2017-04-06  6:55         ` Mathieu Othacehe
2017-04-06  8:10           ` Ludovic Courtès
2017-04-07 21:36             ` Ludovic Courtès
2017-04-08  9:24               ` Mathieu Othacehe
2017-04-05 21:35     ` Ludovic Courtès
2017-04-06  6:55 ` bug#26341: [PATCH 1/2] build: syscalls: Allow mount and umount use from static Guile Mathieu Othacehe
2017-04-06  6:55   ` bug#26341: [PATCH 2/2] build: vm: Add missing module Mathieu Othacehe
2017-04-08 16:03 ` bug#26341: [PATCH 0/5] Fix warnings related to syscalls in static Guile Mathieu Othacehe
2017-04-08 16:03   ` bug#26341: [PATCH 1/5] build: syscalls: Add reboot Mathieu Othacehe
2017-04-10  9:42     ` Ludovic Courtès
2017-04-10 13:18       ` Mathieu Othacehe
2017-04-10 13:41         ` Ludovic Courtès
2017-04-10 17:18           ` Mathieu Othacehe
2017-04-08 16:03   ` bug#26341: [PATCH 2/5] build: syscalls: Allow use to network-interface syscalls independently of calling context Mathieu Othacehe
2017-04-08 16:03   ` Mathieu Othacehe [this message]
2017-04-08 16:03   ` bug#26341: [PATCH 4/5] build: syscalls: Add load-linux-module Mathieu Othacehe
2017-04-08 16:03   ` bug#26341: [PATCH 5/5] build: Fix compilation warnings Mathieu Othacehe
2017-04-10 17:18 ` bug#26341: [PATCH 1/5] build: syscalls: Add reboot Mathieu Othacehe
2017-04-10 17:18   ` bug#26341: [PATCH 2/5] build: syscalls: Use define-as-needed for mount and umount Mathieu Othacehe
2017-04-10 17:18   ` bug#26341: [PATCH 3/5] build: syscalls: Use define-as-needed for network-interface syscalls Mathieu Othacehe
2017-04-10 17:18   ` bug#26341: [PATCH 4/5] build: syscalls: Add load-linux-module Mathieu Othacehe
2017-04-10 17:18   ` bug#26341: [PATCH 5/5] build: Fix compilation warnings Mathieu Othacehe
2017-04-11  9:15   ` bug#26341: [PATCH 1/5] build: syscalls: Add reboot Ludovic Courtès
2017-04-11 11:39     ` Mathieu Othacehe
2017-04-11 12:20       ` Ludovic Courtès

Reply instructions:

You may reply publicly to this message via plain-text email
using any one of the following methods:

* Save the following mbox file, import it into your mail client,
  and reply-to-all from there: mbox

  Avoid top-posting and favor interleaved quoting:
  https://en.wikipedia.org/wiki/Posting_style#Interleaved_style

  List information: https://guix.gnu.org/

* Reply using the --to, --cc, and --in-reply-to
  switches of git-send-email(1):

  git send-email \
    --in-reply-to=20170408160329.4068-4-m.othacehe@gmail.com \
    --to=m.othacehe@gmail.com \
    --cc=26341@debbugs.gnu.org \
    /path/to/YOUR_REPLY

  https://kernel.org/pub/software/scm/git/docs/git-send-email.html

* If your mail client supports setting the In-Reply-To header
  via mailto: links, try the mailto: link
Be sure your reply has a Subject: header at the top and a blank line before the message body.
Code repositories for project(s) associated with this public inbox

	https://git.savannah.gnu.org/cgit/guix.git

This is a public inbox, see mirroring instructions
for how to clone and mirror all data and code used for this inbox;
as well as URLs for read-only IMAP folder(s) and NNTP newsgroup(s).