mirror of
git://git.savannah.gnu.org/guix.git
synced 2023-12-14 03:33:07 +01:00
syscalls: 'readdir*' chooses between the Linux and Hurd code at run time.
Partly fixes <https://bugs.gnu.org/40574>.
Reported by Jan Nieuwenhuizen <janneke@gnu.org>.
Previously, we'd choose at expansion time whether to use the Hurd or the
Linux variant, taking the cross-compilation target into account. This
would lead to the wrong decision when (guix build syscalls) is evaluated
while we're cross-compiling to GNU/Hurd.
This is a followup to 1ab9e48339
.
* guix/build/syscalls.scm (define-generic-identifier)
(read-dirent-header, %struct-dirent-header, sizeof-dirent-header):
Remove.
(readdir*): Rename to...
(readdir-procedure): ... this, and add parameters.
(readdir*): Define as a call to 'readdir-procedure' as a function of
%HOST-TYPE.
This commit is contained in:
parent
33f3fef383
commit
82d8959e5d
1 changed files with 15 additions and 35 deletions
|
@ -22,7 +22,6 @@
|
||||||
|
|
||||||
(define-module (guix build syscalls)
|
(define-module (guix build syscalls)
|
||||||
#:use-module (system foreign)
|
#:use-module (system foreign)
|
||||||
#:use-module (system base target) ;for cross-compilation support
|
|
||||||
#:use-module (rnrs bytevectors)
|
#:use-module (rnrs bytevectors)
|
||||||
#:autoload (ice-9 binary-ports) (get-bytevector-n)
|
#:autoload (ice-9 binary-ports) (get-bytevector-n)
|
||||||
#:use-module (srfi srfi-1)
|
#:use-module (srfi srfi-1)
|
||||||
|
@ -892,36 +891,6 @@ system to PUT-OLD."
|
||||||
(namelen uint8)
|
(namelen uint8)
|
||||||
(name uint8))
|
(name uint8))
|
||||||
|
|
||||||
(define-syntax define-generic-identifier
|
|
||||||
(syntax-rules (gnu/linux gnu/hurd =>)
|
|
||||||
"Define a generic identifier that adjust to the current GNU variant."
|
|
||||||
((_ id (gnu/linux => linux) (gnu/hurd => hurd))
|
|
||||||
(define-syntax id
|
|
||||||
(lambda (s)
|
|
||||||
(syntax-case s ()
|
|
||||||
((_ args (... ...))
|
|
||||||
(if (string-contains (or (target-type) %host-type)
|
|
||||||
"linux")
|
|
||||||
#'(linux args (... ...))
|
|
||||||
#'(hurd args (... ...))))
|
|
||||||
(_
|
|
||||||
(if (string-contains (or (target-type) %host-type)
|
|
||||||
"linux")
|
|
||||||
#'linux
|
|
||||||
#'hurd))))))))
|
|
||||||
|
|
||||||
(define-generic-identifier read-dirent-header
|
|
||||||
(gnu/linux => read-dirent-header/linux)
|
|
||||||
(gnu/hurd => read-dirent-header/hurd))
|
|
||||||
|
|
||||||
(define-generic-identifier %struct-dirent-header
|
|
||||||
(gnu/linux => %struct-dirent-header/linux)
|
|
||||||
(gnu/hurd => %struct-dirent-header/hurd))
|
|
||||||
|
|
||||||
(define-generic-identifier sizeof-dirent-header
|
|
||||||
(gnu/linux => sizeof-dirent-header/linux)
|
|
||||||
(gnu/hurd => sizeof-dirent-header/hurd))
|
|
||||||
|
|
||||||
;; Constants for the 'type' field, from <dirent.h>.
|
;; Constants for the 'type' field, from <dirent.h>.
|
||||||
(define DT_UNKNOWN 0)
|
(define DT_UNKNOWN 0)
|
||||||
(define DT_FIFO 1)
|
(define DT_FIFO 1)
|
||||||
|
@ -960,19 +929,30 @@ system to PUT-OLD."
|
||||||
"closedir: ~A" (list (strerror err))
|
"closedir: ~A" (list (strerror err))
|
||||||
(list err)))))))
|
(list err)))))))
|
||||||
|
|
||||||
(define readdir*
|
(define (readdir-procedure name-field-offset sizeof-dirent-header
|
||||||
|
read-dirent-header)
|
||||||
(let ((proc (syscall->procedure '* "readdir64" '(*))))
|
(let ((proc (syscall->procedure '* "readdir64" '(*))))
|
||||||
(lambda* (directory #:optional (pointer->string pointer->string/utf-8))
|
(lambda* (directory #:optional (pointer->string pointer->string/utf-8))
|
||||||
(let ((ptr (proc directory)))
|
(let ((ptr (proc directory)))
|
||||||
(and (not (null-pointer? ptr))
|
(and (not (null-pointer? ptr))
|
||||||
(cons (pointer->string
|
(cons (pointer->string
|
||||||
(make-pointer (+ (pointer-address ptr)
|
(make-pointer (+ (pointer-address ptr) name-field-offset))
|
||||||
(c-struct-field-offset
|
|
||||||
%struct-dirent-header name)))
|
|
||||||
-1)
|
-1)
|
||||||
(read-dirent-header
|
(read-dirent-header
|
||||||
(pointer->bytevector ptr sizeof-dirent-header))))))))
|
(pointer->bytevector ptr sizeof-dirent-header))))))))
|
||||||
|
|
||||||
|
(define readdir*
|
||||||
|
;; Decide at run time which one must be used.
|
||||||
|
(if (string-suffix? "linux-gnu" %host-type)
|
||||||
|
(readdir-procedure (c-struct-field-offset %struct-dirent-header/linux
|
||||||
|
name)
|
||||||
|
sizeof-dirent-header/linux
|
||||||
|
read-dirent-header/linux)
|
||||||
|
(readdir-procedure (c-struct-field-offset %struct-dirent-header/hurd
|
||||||
|
name)
|
||||||
|
sizeof-dirent-header/hurd
|
||||||
|
read-dirent-header/hurd)))
|
||||||
|
|
||||||
(define* (scandir* name #:optional
|
(define* (scandir* name #:optional
|
||||||
(select? (const #t))
|
(select? (const #t))
|
||||||
(entry<? (lambda (entry1 entry2)
|
(entry<? (lambda (entry1 entry2)
|
||||||
|
|
Loading…
Reference in a new issue