futurile/guix-play
1
0
Fork 0
Code Issues Pull Requests Actions Packages Projects Releases Wiki Activity

syscalls: Implement arrays in 'define-c-struct' and use it.

Browse Source 
* guix/build/syscalls.scm (sizeof*, alignof*, write-type, read-type):
Add support for (array ...) forms.
* guix/build/syscalls.scm (<file-system>)[spare0, spare1]: Remove.
[spare]: New field.
* guix/build/syscalls.scm (%statfs)[identifier]: Change to (array int 2).
[spare0, spare1]: Remove.
[spare]: New field.
This commit is contained in:
Ludovic Courtès 2016-05-01 21:38:53 +02:00 committed by 宋文武
parent d20708b6c5
commit ba369abe58
1 changed files with 27 additions and 10 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

37
guix/build/syscalls.scm
View File

@ -123,9 +123,11 @@
(define-syntax sizeof* (define-syntax sizeof*
;; XXX: This duplicates 'compile-time-value'. ;; XXX: This duplicates 'compile-time-value'.
(syntax-rules (int128) (syntax-rules (int128 array)
((_ int128) ((_ int128)
16) 16)
((_ (array type n))
(* (sizeof* type) n))
((_ type) ((_ type)
(let-syntax ((v (lambda (s) (let-syntax ((v (lambda (s)
(let ((val (sizeof type))) (let ((val (sizeof type)))
@ -135,9 +137,11 @@
(define-syntax alignof* (define-syntax alignof*
;; XXX: This duplicates 'compile-time-value'. ;; XXX: This duplicates 'compile-time-value'.
(syntax-rules (int128) (syntax-rules (int128 array)
((_ int128) ((_ int128)
16) 16)
((_ (array type n))
(alignof* type))
((_ type) ((_ type)
(let-syntax ((v (lambda (s) (let-syntax ((v (lambda (s)
(let ((val (alignof type))) (let ((val (alignof type)))
@ -182,10 +186,19 @@ result is the alignment of the \"most strictly aligned component\"."
types ...)))) types ...))))
(define-syntax write-type (define-syntax write-type
(syntax-rules (~) (syntax-rules (~ array)
((_ bv offset (type ~ order) value) ((_ bv offset (type ~ order) value)
(bytevector-uint-set! bv offset value (bytevector-uint-set! bv offset value
(endianness order) (sizeof* type))) (endianness order) (sizeof* type)))
((_ bv offset (array type n) value)
(let loop ((i 0)
(value value)
(o offset))
(unless (= i n)
(match value
((head . tail)
(write-type bv o type head)
(loop (+ 1 i) tail (+ o (sizeof* type))))))))
((_ bv offset type value) ((_ bv offset type value)
(bytevector-uint-set! bv offset value (bytevector-uint-set! bv offset value
(native-endianness) (sizeof* type))))) (native-endianness) (sizeof* type)))))
@ -202,7 +215,7 @@ result is the alignment of the \"most strictly aligned component\"."
(types ...) (fields ...)))))) (types ...) (fields ...))))))
(define-syntax read-type (define-syntax read-type
(syntax-rules (~ quote *) (syntax-rules (~ array quote *)
((_ bv offset '*) ((_ bv offset '*)
(make-pointer (bytevector-uint-ref bv offset (make-pointer (bytevector-uint-ref bv offset
(native-endianness) (native-endianness)
@ -210,6 +223,12 @@ result is the alignment of the \"most strictly aligned component\"."
((_ bv offset (type ~ order)) ((_ bv offset (type ~ order))
(bytevector-uint-ref bv offset (bytevector-uint-ref bv offset
(endianness order) (sizeof* type))) (endianness order) (sizeof* type)))
((_ bv offset (array type n))
(unfold (lambda (i) (= i n))
(lambda (i)
(read-type bv (+ offset (* i (sizeof* type))) type))
1+
0))
((_ bv offset type) ((_ bv offset type)
(bytevector-uint-ref bv offset (bytevector-uint-ref bv offset
(native-endianness) (sizeof* type))))) (native-endianness) (sizeof* type)))))
@ -476,7 +495,7 @@ string TMPL and return its file name. TMPL must end with 'XXXXXX'."
(define-record-type <file-system> (define-record-type <file-system>
(file-system type block-size blocks blocks-free (file-system type block-size blocks blocks-free
blocks-available files free-files identifier blocks-available files free-files identifier
name-length fragment-size mount-flags spare0 spare1) name-length fragment-size mount-flags spare)
file-system? file-system?
(type file-system-type) (type file-system-type)
(block-size file-system-block-size) (block-size file-system-block-size)
@ -489,8 +508,7 @@ string TMPL and return its file name. TMPL must end with 'XXXXXX'."
(name-length file-system-maximum-name-length) (name-length file-system-maximum-name-length)
(fragment-size file-system-fragment-size) (fragment-size file-system-fragment-size)
(mount-flags file-system-mount-flags) (mount-flags file-system-mount-flags)
(spare0 file-system--spare0) (spare file-system--spare))
(spare1 file-system--spare1))
(define-syntax fsword ;fsword_t (define-syntax fsword ;fsword_t
(identifier-syntax long)) (identifier-syntax long))
@ -507,12 +525,11 @@ string TMPL and return its file name. TMPL must end with 'XXXXXX'."
(blocks-available uint64) (blocks-available uint64)
(files uint64) (files uint64)
(free-files uint64) (free-files uint64)
(identifier uint64) ;really "int[2]" (identifier (array int 2))
(name-length fsword) (name-length fsword)
(fragment-size fsword) (fragment-size fsword)
(mount-flags fsword) (mount-flags fsword)
(spare0 int128) ;really "fsword[4]" (spare (array fsword 4)))
(spare1 int128))
(define statfs (define statfs
(let ((proc (syscall->procedure int "statfs64" '(* *)))) (let ((proc (syscall->procedure int "statfs64" '(* *))))