[Date Prev][Date Next][Thread Prev][Thread Next][Date Index][Thread Index]
[gnunet] 01/01: Replaces the crappy “union handling” functions with bet
|
From: |
Rmi Birot-Delrue |
|
Subject: |
[gnunet] 01/01: Replaces the crappy “union handling” functions with better ones (inside “system/foreign/”); has the stub gnunet-search working. |
|
Date: |
Wed, 24 Jun 2015 11:24:41 +0000 |
remibd pushed a commit to branch master
in repository gnunet.
commit c40fcacfbce96d698d49927c22b280e6590db2f4
Author: Rémi Birot-Delrue <address@hidden>
Date: Wed Jun 24 13:20:18 2015 +0200
Replaces the crappy “union handling” functions with better ones (inside
“system/foreign/”); has the stub gnunet-search working.
---
README | 24 ++---
examples/search.scm | 44 ++++++++-
gnu/gnunet/binding-utils.scm | 12 ---
gnu/gnunet/common.scm | 16 ++-
gnu/gnunet/configuration.scm | 1 -
gnu/gnunet/fs.scm | 6 +-
gnu/gnunet/fs/progress-info.scm | 30 ++-----
gnu/gnunet/fs/uri.scm | 4 +-
gnu/gnunet/scheduler.scm | 2 +-
run-tests.scm | 27 +++++
system/foreign-padded.scm | 100 -------------------
system/foreign/unions-read-write.scm | 70 ++++++++++++++
system/foreign/unions.scm | 154 ++++++++++++++++++++++++++++++
tests/binding-utils.scm | 5 -
tests/foreign-padded.scm | 75 ---------------
tests/progress-info.scm | 18 ----
tests/system-foreign-unions.scm | 174 ++++++++++++++++++++++++++++++++++
17 files changed, 497 insertions(+), 265 deletions(-)
diff --git a/README b/README
index 51cf637..91ca55e 100644
--- a/README
+++ b/README
@@ -8,25 +8,19 @@ configuration. Edit the file `examples/search.scm` and modify
the line
(define config-file "~/.gnunet/gnunet.conf")
-to match your configuration file.
+to match your current GnuNet configuration file.
-Run Guile in the bindings directory:
+Then, go inside the bindings directory and run `search.scm` as a
+script. For instance, to run a search on the keywords "foo" and "bar":
$ cd guix/gnunet/
- $ guile
+ $ examples/search.scm "foo" "bar"
-Then in Guile’s prompt:
-
- > (add-to-load-path ".")
- > (load "examples/search.scm")
- > ,m (gnunet-search)
- > (main "foo")
-
-This will start a 5 seconds search on the keyword “foo”. Here’s the
+This will start a 5 seconds search on the given keywords. Here’s the
output when exactly one find matches the keyword “foo”:
- > (main "foo")
- Search service opened (#<pointer 0x2414dd8>)
- Starting search on gnunet://fs/ksk/foo
- RESULT! #<pointer 0x7ffcd822ee50>
+ gnunet-download -o "foo.txt" gnunet://fs/chk/M976V69FDSQDH74AORDDLB…
+
+You can also check your bindings with the command:
+ $ ./run-tests.scm
diff --git a/examples/search.scm b/examples/search.scm
old mode 100644
new mode 100755
index 9e84649..d0369b2
--- a/examples/search.scm
+++ b/examples/search.scm
@@ -1,5 +1,5 @@
#!/usr/bin/guile \
--e main -s
+-e (@\ (gnunet-search)\ main) -L . -s
!#
;;;; Copyright © 2015 Rémi Delrue <address@hidden>
;;;;
@@ -24,22 +24,54 @@
#:use-module (gnu gnunet fs uri)
#:use-module (gnu gnunet fs progress-info)
#:use-module (gnu gnunet configuration)
- #:use-module (gnu gnunet scheduler))
+ #:use-module (gnu gnunet scheduler)
+ #:export (main))
+
+;; (use-modules (ice-9 match))
+;; (use-modules (system foreign))
+;; (use-modules (gnu gnunet container metadata))
+;; (use-modules (gnu gnunet fs))
+;; (use-modules (gnu gnunet fs uri))
+;; (use-modules (gnu gnunet fs progress-info))
+;; (use-modules (gnu gnunet configuration))
+;; (use-modules (gnu gnunet scheduler))
(define config-file "~/.gnunet/gnunet.conf")
(define count-limit 10)
-(define (result-cb info)
- (simple-format #t "RESULT! ~a\n" info))
+(define (result-cb %info)
+ (match (parse-c-progress-info %info)
+ (((context cctx pctx query duration anonymity
+ (metadata uri result applicability-rank)) status handle)
+ (match (parse-c-struct result '(* * * *)) ; incomplete parse of result
+ ((_ _ %uri %metadata)
+ (let* ((uri (uri->string (wrap-uri %uri)))
+ (meta (wrap-metadata %metadata))
+ (result-directory? (is-directory? meta))
+ (result-filename (metadata-ref meta #:original-filename)))
+ (cond ((and result-directory?
+ (string-null? result-filename))
+ (simple-format #t
+ "gnunet-download -o \"collection.gnd\" -R ~a\n"
+ uri))
+ (result-directory?
+ (simple-format #t
+ "gnunet-download -o \"~a.gnd\" -R ~a\n"
+ result-filename uri))
+ ((string-null? result-filename)
+ (simple-format #t "gnunet-download ~a\n"
+ uri))
+ (else
+ (simple-format #t "gnunet-download -o \"~a\" ~a\n"
+ result-filename uri)))))))))
(define (main args)
(let ((config (load-configuration config-file)))
(define (first-task _)
(let ((search-service
(search-service-open config #:result result-cb)))
- (simple-format #t "Search service opened (~a)\n" search-service)
- (let ((current-search (start-ksk-search search-service args)))
+ (let ((current-search (start-ksk-search search-service (cdr args))))
;; adds a timeout in 5 seconds
(add-task! (lambda (_)
(stop-search current-search))
diff --git a/gnu/gnunet/binding-utils.scm b/gnu/gnunet/binding-utils.scm
index c17d84e..4f33306 100644
--- a/gnu/gnunet/binding-utils.scm
+++ b/gnu/gnunet/binding-utils.scm
@@ -74,15 +74,3 @@
if STRING is empty (\"\")."
(if (string=? "" string) %null-pointer (string->pointer string)))
-(define (make-c-struct* types)
- "Create a foreign pointer to a zeroed C struct from TYPES."
- (assert (not (null? types)))
- (letrec ((spec->zeros (lambda (spec)
- (match spec
- ('* %null-pointer)
- ((? number?) 0)
- ((? list? lst) (map spec->zeros lst))
- (_ (scm-error 'wrong-type-arg "make-c-struct*"
- "Wrong argument in position 1: (… ~a
…)"
- (list spec) #f))))))
- (make-c-struct types (map spec->zeros types))))
diff --git a/gnu/gnunet/common.scm b/gnu/gnunet/common.scm
index a57eeed..74fcfd0 100644
--- a/gnu/gnunet/common.scm
+++ b/gnu/gnunet/common.scm
@@ -17,7 +17,6 @@
(define-module (gnu gnunet common)
#:use-module (system foreign)
- #:use-module (system foreign-padded)
#:use-module (rnrs base)
#:use-module (rnrs bytevectors)
#:use-module (gnu gnunet binding-utils)
@@ -45,13 +44,20 @@
%free))
+(define (generate n x)
+ "Generates a list of length N which elements are X."
+ (if (zero? n)
+ '()
+ (cons x (generate (1- n) x))))
+
+
(define time-relative uint64)
(define time-absolute uint64)
-(define ecdsa-public-key (list (padding (/ 256 8))))
+(define ecdsa-public-key (generate (/ 256 8 4) uint32))
(define eddsa-public-key ecdsa-public-key)
-(define eddsa-signature (list (padding (/ 256 8))
- (padding (/ 256 8))))
-(define hashcode (list (padding 16 uint32)))
+(define eddsa-signature (list eddsa-public-key
+ eddsa-public-key))
+(define hashcode (list (generate 16 uint32)))
(define gnunet-ok 1)
(define gnunet-system-error -1)
diff --git a/gnu/gnunet/configuration.scm b/gnu/gnunet/configuration.scm
index 4c7b59b..263c237 100644
--- a/gnu/gnunet/configuration.scm
+++ b/gnu/gnunet/configuration.scm
@@ -18,7 +18,6 @@
(define-module (gnu gnunet configuration)
#:use-module (srfi srfi-9)
#:use-module (system foreign)
- #:use-module (system foreign-padded)
#:use-module (rnrs bytevectors)
#:use-module (gnu gnunet common)
#:use-module (gnu gnunet binding-utils)
diff --git a/gnu/gnunet/fs.scm b/gnu/gnunet/fs.scm
index be8adc0..69aa8c9 100644
--- a/gnu/gnunet/fs.scm
+++ b/gnu/gnunet/fs.scm
@@ -20,6 +20,7 @@
#:use-module (gnu gnunet binding-utils)
#:use-module (gnu gnunet common)
#:use-module (gnu gnunet configuration)
+ #:use-module (gnu gnunet container metadata)
#:use-module (gnu gnunet fs uri)
#:use-module (gnu gnunet fs progress-info)
#:export (search-service-open
@@ -99,8 +100,7 @@
(%gnunet-fs-start config "gnunet-search" progress-cb))
(define (start-ksk-search handle keywords)
- (let ((uri (make-ksk-uri keywords)))
- (simple-format #t "Starting search on ~a\n" (uri->string uri))
+ (let ((uri (apply make-ksk-uri keywords)))
(%search-start handle (unwrap-uri uri) 0 0 %null-pointer)))
(define (stop-search handle)
@@ -111,4 +111,4 @@
(define (is-directory? metadata)
"Checks some search result’s METADATA if its mime-type matches
GNUNET_FS_DIRECTORY_MIME."
- (= gnunet-yes (%test-for-directory metadata)))
+ (= gnunet-yes (%test-for-directory (unwrap-metadata metadata))))
diff --git a/gnu/gnunet/fs/progress-info.scm b/gnu/gnunet/fs/progress-info.scm
index 10c6686..7ffafec 100644
--- a/gnu/gnunet/fs/progress-info.scm
+++ b/gnu/gnunet/fs/progress-info.scm
@@ -19,7 +19,7 @@
#:use-module (ice-9 match)
#:use-module (srfi srfi-9)
#:use-module (system foreign)
- #:use-module (system foreign-padded)
+ #:use-module (system foreign unions)
#:use-module (rnrs bytevectors)
#:use-module (gnu gnunet binding-utils)
#:use-module (gnu gnunet common)
@@ -31,7 +31,7 @@
(define %progress-info-type
(list ; struct GNUNET_FS_ProgressInfo
- (make-union ; union {…} value
+ (union ; union {…} value
(list #:publish ; struct {…} publish
'* ; GNUNET_FS_PublishContext *pc;
'* ; GNUNET_FS_FileInformation *fi;
@@ -43,7 +43,7 @@
time-relative ; GNUNET_TIME_Relative duration;
uint64 ; uint64_t completed;
uint32 ; uint32_t anonymity;
- (make-union ; union {…} specifics
+ (union ; union {…} specifics
(list #:progress ; struct {…} progress
'* ; void *data;
uint64 ; uint64_t offset;
@@ -73,7 +73,7 @@
uint64 ; uint64_t completed;
uint32 ; uint32_t anonymity;
int ; int is_active;
- (make-union ; union {…} specifics
+ (union ; union {…} specifics
(list #:progress ; struct {…} progress
'* ; void *data;
uint64 ; uint64_t offset;
@@ -96,7 +96,7 @@
'* ; GNUNET_FS_Uri *query;
time-relative ; GNUNET_TIME_RELATIVE duration;
uint32 ; uint32_t anonymity;
- (make-union ; union {…} specifics
+ (union ; union {…} specifics
(list #:result ; struct {…} result
'* ; GNUNET_CONTAINER_MetaData *m…;
'* ; GNUNET_FS_Uri *uri;
@@ -143,7 +143,7 @@
time-relative ; GNUNET_TIME_Relative eta;
time-relative ; GNUNET_TIME_Relative duration;
uint64 ; uint64_t completed;
- (make-union ; union {…} specifics
+ (union ; union {…} specifics
(list #:progress ; struct {…} progress
'* ; void *data;
uint64 ; uint64_t offset;
@@ -210,20 +210,6 @@
(or (rassoc-ref progress-info-status-alist status)
(throw 'invalid-arg "progress-info-status->integer" status)))
-(define (progress-info-get-type value specifics)
- "Returns the type specification of struct GNUNET_FS_ProgressInfo
-when its union `value` is VALUE and its union `specifics` is
-SPECIFICS."
- (define (replace-specifics-union type)
- (match type
- ((? union?) (union-ref specifics type))
- (_ type)))
- (define (replace-value-union type)
- (match type
- ((? union?) (map replace-specifics-union (union-ref value type)))
- (_ type)))
- (map replace-value-union %progress-info-type))
-
(define (progress-info-status pointer)
"Returns the status of a struct GNUNET_FS_ProgressInfo as a list of
two keywords. If status is unknown, raises an error."
@@ -234,8 +220,8 @@ two keywords. If status is unknown, raises an error."
(integer->progress-info-status code)))
(define (parse-c-progress-info pointer)
- (parse-c-struct pointer (apply progress-info-get-type
- (progress-info-status pointer))))
+ (apply parse-c-struct* pointer %progress-info-type
+ (progress-info-status pointer)))
;;; incomplete mapping of GNUNET_FS_SearchResult
diff --git a/gnu/gnunet/fs/uri.scm b/gnu/gnunet/fs/uri.scm
index ba84cd3..1a610d7 100644
--- a/gnu/gnunet/fs/uri.scm
+++ b/gnu/gnunet/fs/uri.scm
@@ -21,7 +21,6 @@
(define-module (gnu gnunet fs uri)
#:use-module (srfi srfi-1)
#:use-module (srfi srfi-9)
- #:use-module ((rnrs base) #:select (assert))
#:use-module (rnrs bytevectors)
#:use-module (system foreign)
#:use-module (gnu gnunet common)
@@ -85,7 +84,8 @@
(define (make-ksk-uri-pointer . keywords)
"Create a foreign pointer to a KSK URI from a list of strings KEYWORDS."
- (assert (not (null? keywords)))
+ (when (null? keywords)
+ (throw 'invalid-arg "make-ksk-uri-pointer" keywords))
(let* ((%error-msg-ptr (%make-blob-pointer))
(%keywords-str (string->pointer (keyword-list->string keywords)))
(%uri (%uri-ksk-create %keywords-str %error-msg-ptr))
diff --git a/gnu/gnunet/scheduler.scm b/gnu/gnunet/scheduler.scm
index 198005c..10ef6a8 100644
--- a/gnu/gnunet/scheduler.scm
+++ b/gnu/gnunet/scheduler.scm
@@ -114,7 +114,7 @@ THUNK should be a function of one argument: a list of
reasons (as keywords)."
'(* *)))
(define (default-error-handler key . args)
- (simple-format #t "GNUNET SHUTDOWN: ~a ~a\n" key args)
+ (simple-format #t "GNUNET SHUTDOWN: ~s ~s\n" key args)
(schedule-shutdown!))
(define* (call-with-scheduler config thunk
diff --git a/run-tests.scm b/run-tests.scm
new file mode 100755
index 0000000..10ac4c6
--- /dev/null
+++ b/run-tests.scm
@@ -0,0 +1,27 @@
+#!/usr/bin/guile \
+-L . -s
+!#
+;;;; Copyright © 2015 Rémi Delrue <address@hidden>
+;;;;
+;;;; This program is free software: you can redistribute it and/or modify
+;;;; it under the terms of the GNU General Public License as published by
+;;;; the Free Software Foundation, either version 3 of the License, or
+;;;; (at your option) any later version.
+;;;;
+;;;; This program is distributed in the hope that it will be useful,
+;;;; but WITHOUT ANY WARRANTY; without even the implied warranty of
+;;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
+;;;; GNU General Public License for more details.
+;;;;
+;;;; You should have received a copy of the GNU General Public License
+;;;; along with this program. If not, see <http://www.gnu.org/licenses/>.
+
+(define scandir (@ (ice-9 ftw) scandir))
+(define (scm-file? f) (string-suffix? ".scm" f))
+
+(define %test-directory "tests/")
+(define %test-source-files (scandir %test-directory scm-file?))
+
+(map load
+ (map (lambda (f) (string-append %test-directory f))
+ %test-source-files))
diff --git a/system/foreign-padded.scm b/system/foreign-padded.scm
deleted file mode 100644
index e01f9b3..0000000
--- a/system/foreign-padded.scm
+++ /dev/null
@@ -1,100 +0,0 @@
-;;;; -*- mode: Scheme; indent-tabs-mode: nil; fill-column: 80; -*-
-;;;;
-;;;; Copyright © 2015 Rémi Delrue <address@hidden>
-;;;;
-;;;; This program is free software: you can redistribute it and/or modify
-;;;; it under the terms of the GNU General Public License as published by
-;;;; the Free Software Foundation, either version 3 of the License, or
-;;;; (at your option) any later version.
-;;;;
-;;;; This program is distributed in the hope that it will be useful,
-;;;; but WITHOUT ANY WARRANTY; without even the implied warranty of
-;;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
-;;;; GNU General Public License for more details.
-;;;;
-;;;; You should have received a copy of the GNU General Public License
-;;;; along with this program. If not, see <http://www.gnu.org/licenses/>.
-
-(define-module (system foreign-padded)
- #:use-module ((srfi srfi-1) #:select (fold))
- #:use-module (ice-9 match)
- #:use-module (system foreign)
- #:export (union?
- union-size
- union-ref
- alignof*
- sizeof*
- padding
- pad
- make-union))
-
-
-(define (union? type)
- (match type
- (('union (? integer? size) (? integer? align) (members ...)) #t)
- (_ #f)))
-
-(define union-size cadr)
-(define union-align caddr)
-
-(define (union-ref key union)
- (match union
- (('union size align (members ...)) (assq-ref members key))
- (_ (scm-error 'wrong-type-arg "union-ref"
- "Wrong type argument in position 2: ~a"
- (list union) (list union)))))
-
-(define (alignof* type)
- "A variant of alignof that accepts unions."
- (cond ((union? type) (union-align type))
- ((list? type) (fold max 1 (map alignof* type)))
- (else (alignof type))))
-
-(define (next-multiple numerator divisor)
- "Raise up NUMERATOR to the most little multiple M of DIVISOR such that
-NUMERATOR <= M."
- (let ((prev-multiple (* divisor (quotient numerator divisor))))
- (if (= prev-multiple numerator)
- numerator
- (+ prev-multiple divisor))))
-
-(define (sizeof* type)
- "A variant of sizeof that accepts unions and returns pads the structures in
-relation to their alignment before returning their size."
- (cond ((union? type) (union-size type))
- ((list? type) (next-multiple (fold + 0 (map sizeof* type))
- (alignof* type)))
- (#t (sizeof type))))
-
-(define* (padding n #:optional (type uint8))
- "Generate a list of N times TYPE."
- (match n
- (0 '())
- (_ (cons type (padding (- n 1))))))
-
-(define (pad type size)
- "Pad TYPE upto SIZE."
- (let ((size* (sizeof* type)))
- (cond ((> size* size)
- (scm-error 'wrong-type-arg "pad"
- "Wrong argument in position 2: (sizeof ~a) < ~a"
- (list type size) (list type size)))
- ((or (not (list? type)) (union? type))
- (scm-error 'wrong-type-arg "pad"
- "Wrong argument in position 1: ~a"
- (list type) (list type)))
- (else
- (append type (padding (- size size*)))))))
-
-(define (make-union . members)
- "Create a union. MEMBERS should be an assoc. list of lists of C types, where
-keys are only used to identify each union member in calls to `union-ref`."
- (let* ((size (fold max 0 (map (compose sizeof* cdr) members)))
- (align (fold max 1 (map (compose alignof* cdr) members)))
- (padded-size (next-multiple size align))
- (padded-members (map (match-lambda
- ((key . type) (cons key (pad type
- padded-size))))
- members)))
- (list 'union padded-size align padded-members)))
-
diff --git a/system/foreign/unions-read-write.scm
b/system/foreign/unions-read-write.scm
new file mode 100644
index 0000000..aad3c8b
--- /dev/null
+++ b/system/foreign/unions-read-write.scm
@@ -0,0 +1,70 @@
+;;;; -*- mode: Scheme; indent-tabs-mode: nil; fill-column: 80; -*-
+;;;;
+;;;; Copyright (C) 2010, 2011, 2013, 2015 Free Software Foundation, Inc.
+;;;;
+;;;; This program is free software: you can redistribute it and/or modify
+;;;; it under the terms of the GNU General Public License as published by
+;;;; the Free Software Foundation, either version 3 of the License, or
+;;;; (at your option) any later version.
+;;;;
+;;;; This program is distributed in the hope that it will be useful,
+;;;; but WITHOUT ANY WARRANTY; without even the implied warranty of
+;;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
+;;;; GNU General Public License for more details.
+;;;;
+;;;; You should have received a copy of the GNU General Public License
+;;;; along with this program. If not, see <http://www.gnu.org/licenses/>.
+
+(define *writers* (@@ (system foreign) *writers*))
+(define *readers* (@@ (system foreign) *readers*))
+
+(define (write-c-struct* bv offset types vals)
+ (let lp ((offset offset) (types types) (vals vals))
+ (cond
+ ((not (pair? types))
+ (or (null? vals)
+ (throw 'invalid-arg "write-c-struct*" vals)))
+ ((not (pair? vals))
+ (or (padding? vals)
+ (throw 'invalid-arg "write-c-struct*" types)))
+ (else
+ ;; alignof will error-check
+ (let* ((type (car types))
+ (offset (align offset (alignof* type))))
+ (cond ((pair? type)
+ (write-c-struct* bv offset (car types) (car vals)))
+ ((not (pad? type))
+ ((assv-ref *writers* type) bv offset (car vals))))
+ (lp (+ offset (sizeof* type)) (cdr types)
+ (if (pad? type) vals (cdr vals))))))))
+
+(define (read-c-struct* bv offset types)
+ (let lp ((offset offset) (types types) (vals '()))
+ (cond
+ ((not (pair? types))
+ (reverse vals))
+ (else
+ ;; alignof will error-check
+ (let* ((type (car types))
+ (offset (align offset (alignof* type))))
+ (lp (+ offset (sizeof* type)) (cdr types)
+ (cond ((pair? type)
+ (cons (read-c-struct* bv offset (car types)) vals))
+ ((pad? type) vals)
+ (else
+ (cons ((assv-ref *readers* type) bv offset) vals)))))))))
+
+(define* (make-c-struct* types vals #:rest union-references)
+ (let* ((types (replace-unions types union-references))
+ (bv (make-bytevector (sizeof* types) 0)))
+ (write-c-struct* bv 0 types vals)
+ (bytevector->pointer bv)))
+
+(define* (parse-c-struct* foreign types #:rest union-references)
+ (let* ((types (replace-unions types union-references))
+ (size (fold (lambda (type total)
+ (+ (sizeof* type)
+ (align total (alignof* type))))
+ 0
+ types)))
+ (read-c-struct* (pointer->bytevector foreign size) 0 types)))
diff --git a/system/foreign/unions.scm b/system/foreign/unions.scm
new file mode 100644
index 0000000..480cf26
--- /dev/null
+++ b/system/foreign/unions.scm
@@ -0,0 +1,154 @@
+;;;; -*- mode: Scheme; indent-tabs-mode: nil; fill-column: 80; -*-
+;;;;
+;;;; Copyright © 2015 Rémi Delrue <address@hidden>
+;;;;
+;;;; This program is free software: you can redistribute it and/or modify
+;;;; it under the terms of the GNU General Public License as published by
+;;;; the Free Software Foundation, either version 3 of the License, or
+;;;; (at your option) any later version.
+;;;;
+;;;; This program is distributed in the hope that it will be useful,
+;;;; but WITHOUT ANY WARRANTY; without even the implied warranty of
+;;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
+;;;; GNU General Public License for more details.
+;;;;
+;;;; You should have received a copy of the GNU General Public License
+;;;; along with this program. If not, see <http://www.gnu.org/licenses/>.
+
+(define-module (system foreign unions)
+ #:use-module (ice-9 match)
+ #:use-module (srfi srfi-9)
+ #:use-module (srfi srfi-9 gnu)
+ #:use-module ((srfi srfi-1) #:select (fold every))
+ #:use-module ((rnrs base) #:select (assert))
+ #:use-module (system foreign)
+ #:use-module (rnrs bytevectors)
+ #:export (<union>
+ union
+ union-ref
+ alignof*
+ sizeof*
+ make-c-struct*
+ parse-c-struct*))
+
+
+(define (tree-map f tree . trees)
+ (cond ((null? tree) '())
+ ((list? (car tree)) (cons (tree-map f (car tree))
+ (tree-map f (cdr tree))))
+ (else (cons (f (car tree))
+ (tree-map f (cdr tree))))))
+
+
+;;+TODO: memoize alignof and sizeof
+(define-record-type <union>
+ (%make-union members)
+ union?
+ (members %union-members))
+
+(set-record-type-printer! <union>
+ (lambda (union port)
+ (display "(union " port)
+ (map (lambda (x)
+ (display x port)
+ (write-char #\Space port))
+ (%union-members union))
+ (write-char #\) port)))
+
+(define (union . members)
+ "Used to build a union type specifier. MEMBERS should be an
+assoc. list, where keys are used to access each union member in
+`union-ref`."
+ (assert (every list? members))
+ (%make-union members))
+
+(define (union-ref union key)
+ (or (assq-ref (%union-members union) key)
+ (error 'invalid-arg "union-ref" key)))
+
+(define (union-members union)
+ "Returns a list of all the variants of a union (the MEMBERS
+assoc. list that was given to `union` without its keys)."
+ (map cdr (%union-members union)))
+
+;; represents a padding (a space) in a C struct
+(define-record-type <pad>
+ (pad offset)
+ pad?
+ (offset pad-offset))
+
+(set-record-type-printer! <pad>
+ (lambda (pad port)
+ (simple-format port "(pad ~a)" (pad-offset pad))))
+
+
+(define (padding? types)
+ "Returns #t if the only primitive types in TYPES are paddings."
+ (cond ((null? types) #t)
+ ((list? (car types)) (and (padding? (car types))
+ (padding? (cdr types))))
+ (else (and (pad? (car types))
+ (padding? (cdr types))))))
+;; (align offset alignment) → smallest multiple of alignment that is
+;; greater than or equal to offset.
+;; alignment must be a power of 2.
+(define align (@@ (system foreign) align))
+
+(define (alignof* type)
+ "A variant of alignof that accepts unions (and paddings)."
+ (define (maxalign l)
+ (fold (lambda (x m) (max m (alignof* x))) 1 l))
+ (cond ((union? type) (maxalign (union-members type)))
+ ((pad? type) 1)
+ ((list? type) (maxalign type))
+ (else (alignof type))))
+
+;;; note: until Guile 2.1.0, sizeof does not consider structures
+;;; trailing padding (this is corrected in commit
+;;; cff1d39b2003470b5dcdab988e279587ae2eed8c). Therefore, the
+;;; following version of sizeof reimplements the computation of a
+;;; structure’s size.
+
+(define (sizeof* type)
+ "A variant of sizeof that accepts unions (and paddings)."
+ (define (maxsize l)
+ (fold (lambda (x m) (max m (sizeof* x))) 0 l))
+ (define (sumsize l)
+ (fold (lambda (x s) (+ s (sizeof* x))) 0 l))
+ (cond ((union? type) (maxsize (union-members type)))
+ ((pad? type) (pad-offset type))
+ ((list? type) (let ((struct-alignment (alignof* type)))
+ (align
+ (fold (lambda (type offset)
+ (+ (align offset (alignof* type))
+ (sizeof* type)))
+ 0
+ type)
+ struct-alignment)))
+ (else (sizeof type))))
+
+(define (union-ref-padded union key)
+ (let* ((type (union-ref union key))
+ (offset (- (sizeof* union) (sizeof* type))))
+ (append type (if (> offset 0)
+ (list (pad offset))
+ '()))))
+
+(define (replace-unions types union-refs)
+ (let* ((stack (list-copy union-refs)))
+ (let lp ((types types))
+ (cond ((null? types) '())
+ ((list? (car types)) (cons (lp (car types))
+ (lp (cdr types))))
+ ((union? (car types))
+ (when (null? stack)
+ (throw 'invalid-arg "replace-unions" union-refs))
+ (let ((key (car stack)))
+ (set! stack (cdr stack))
+ (cons (lp (union-ref-padded (car types) key))
+ (lp (cdr types)))))
+ (else (cons (car types)
+ (lp (cdr types))))))))
+
+;; file separed for copyright reasons
+(include "unions-read-write.scm")
diff --git a/tests/binding-utils.scm b/tests/binding-utils.scm
index 9ba8688..257cb65 100644
--- a/tests/binding-utils.scm
+++ b/tests/binding-utils.scm
@@ -35,11 +35,6 @@
(test-equal #:bar (rassq-ref foo-alist 2))
(test-equal #f (rassq-ref foo-alist 5))
-;; make-c-struct*
-(test-equal '(0 0 0)
- (parse-c-struct (make-c-struct* (list int unsigned-int int8))
- (list int unsigned-int int8)))
-
;; string->pointer*
(test-equal %null-pointer (string->pointer* ""))
(test-equal "foo" (pointer->string (string->pointer* "foo")))
diff --git a/tests/foreign-padded.scm b/tests/foreign-padded.scm
deleted file mode 100644
index 0a3eda9..0000000
--- a/tests/foreign-padded.scm
+++ /dev/null
@@ -1,75 +0,0 @@
-;;;; -*- mode: Scheme; indent-tabs-mode: nil; fill-column: 80; -*-
-;;;;
-;;;; Copyright © 2015 Rémi Delrue <address@hidden>
-;;;;
-;;;; This program is free software: you can redistribute it and/or modify
-;;;; it under the terms of the GNU General Public License as published by
-;;;; the Free Software Foundation, either version 3 of the License, or
-;;;; (at your option) any later version.
-;;;;
-;;;; This program is distributed in the hope that it will be useful,
-;;;; but WITHOUT ANY WARRANTY; without even the implied warranty of
-;;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
-;;;; GNU General Public License for more details.
-;;;;
-;;;; You should have received a copy of the GNU General Public License
-;;;; along with this program. If not, see <http://www.gnu.org/licenses/>.
-
-(define-module (test-foreign-padded)
- #:use-module (srfi srfi-64)
- #:use-module (system foreign)
- #:use-module (system foreign-padded))
-
-;; union?
-(test-equal #t (union? (make-union)))
-(test-equal #t (union? (make-union '(#:foo *) '(#:bar * *))))
-(test-equal #f (union? '(union 0)))
-
-;; %next-multiple
-(define next-multiple (@@ (system foreign-padded) next-multiple))
-(test-equal 10 (next-multiple 7 5))
-(test-equal 2 (next-multiple 1 2))
-(test-equal 0 (next-multiple 0 1))
-(test-equal 10 (next-multiple 10 5))
-(test-error 'numerical-overflow (next-multiple 10 0))
-
-;; alignof*
-(test-equal (alignof '*)
- (alignof* (make-union (list #:foo '*)
- (list #:bar unsigned-int))))
-(test-equal (alignof '*)
- (alignof* (list (make-union (list #:foo '*)
- (list #:bar unsigned-int)))))
-
-;; sizeof* — unions
-(let ((size (sizeof (list int64 int16)))
- (align (alignof (list int64 int16))))
- (test-equal (next-multiple size align)
- (sizeof* (make-union (list #:foo int8)
- (list #:bar int64 int16)))))
-(test-equal 0 (sizeof* (make-union)))
-(test-equal 1 (sizeof* uint8))
-
-;; sizeof* — alignment padding
-(let ((%type (list '* unsigned-int)))
- (test-assert (zero? (remainder (sizeof* %type) (alignof %type)))))
-
-;; padding
-(test-equal 5 (length (padding 5)))
-(test-equal 0 (length (padding 0)))
-
-;; make-union
-;; (let* ((longuest (list int32 int32))
-;; (size (sizeof longuest))
-;; (pad-size (sizeof* longuest))
-;; (pad-rem (- pad-size size))
-;; (align (alignof* longuest)))
-;; (test-equal
-;; `(union ,pad-size ,align
-;; ((#:foo ,int32 ,int32 ,@(if (> pad-rem 0)
-;; (padding pad-rem)
-;; '()))
-;; (#:bar ,(pad (list uint8) (sizeof int32))
-;; ,(pad (list uint8) pad-size))))
-;; (make-union `(#:foo ,int32 ,int32)
-;; `(#:bar ,uint8))))
diff --git a/tests/progress-info.scm b/tests/progress-info.scm
index f387797..f001baa 100644
--- a/tests/progress-info.scm
+++ b/tests/progress-info.scm
@@ -20,7 +20,6 @@
#:use-module (srfi srfi-64)
#:use-module (rnrs bytevectors)
#:use-module (system foreign)
- #:use-module (system foreign-padded)
#:use-module (gnu gnunet common)
#:use-module (gnu gnunet container metadata)
#:use-module (gnu gnunet fs progress-info))
@@ -32,7 +31,6 @@
(pi-import integer->progress-info-status
progress-info-status->integer
- progress-info-get-type
bytevector-u8-fold
u8-bitmap->list)
@@ -47,22 +45,6 @@
(test-error 'invalid-arg (progress-info-status->integer
'(#:beam-me-up #:scotty)))
-;; progress-info-get-type
-(define progress-info-download-progress-signature
- (list
- (list '* '* '* '* '* '*
- uint64
- time-relative time-relative
- uint64 uint32 int
- (list '* uint64 uint64
- time-relative
- unsigned-int uint32 uint32))
- unsigned-int
- '*))
-(test-equal progress-info-download-progress-signature
- (progress-info-get-type #:download #:progress))
-(test-error 'invalid-arg (progress-info-get-type #:maximum #:warp))
-
;; bytevector-u8-fold
(let ((bv (make-bytevector 1)))
diff --git a/tests/system-foreign-unions.scm b/tests/system-foreign-unions.scm
new file mode 100644
index 0000000..513e359
--- /dev/null
+++ b/tests/system-foreign-unions.scm
@@ -0,0 +1,174 @@
+;;;; -*- mode: Scheme; indent-tabs-mode: nil; fill-column: 80; -*-
+;;;;
+;;;; Copyright © 2015 Rémi Delrue <address@hidden>
+;;;;
+;;;; This program is free software: you can redistribute it and/or modify
+;;;; it under the terms of the GNU General Public License as published by
+;;;; the Free Software Foundation, either version 3 of the License, or
+;;;; (at your option) any later version.
+;;;;
+;;;; This program is distributed in the hope that it will be useful,
+;;;; but WITHOUT ANY WARRANTY; without even the implied warranty of
+;;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
+;;;; GNU General Public License for more details.
+;;;;
+;;;; You should have received a copy of the GNU General Public License
+;;;; along with this program. If not, see <http://www.gnu.org/licenses/>.
+
+(define-module (test-system-foreign-unions)
+ #:use-module (srfi srfi-64)
+ #:use-module (system foreign)
+ #:use-module (system foreign unions))
+
+(define-syntax-rule (unions-import name ...)
+ (begin (define name (@@ (system foreign unions) name)) ...))
+
+(unions-import align
+ pad
+ padding?
+ union-ref-padded
+ replace-unions)
+
+(test-begin "test-system-foreign-unions")
+
+;; padding?
+(test-assert (padding? (list (pad 1))))
+(test-assert (padding? (list (pad 1) (list (pad 2)) (pad 3))))
+
+;; alignof*
+(test-equal (alignof '*)
+ (alignof* (union (list #:foo '*)
+ (list #:bar unsigned-int))))
+(test-equal (alignof '*)
+ (alignof* (list (union (list #:foo '*)
+ (list #:bar unsigned-int)))))
+
+;; sizeof* — unions
+(let ((alignment (alignof (list int64 int16))))
+ (test-equal (align (+ 8 2) alignment)
+ (sizeof* (union (list #:foo int8)
+ (list #:bar int64 int16)))))
+(test-equal 0 (sizeof* (union)))
+(test-equal 1 (sizeof* uint8))
+
+;; sizeof* — trailing padding
+(let ((%type (list '* unsigned-int)))
+ (test-assert (zero? (remainder (sizeof* %type) (alignof* %type)))))
+
+;; union-ref-padded
+(let ((simple-case (union (list #:foo uint16)
+ (list #:bar uint8)))
+ (complex-case (union (list #:foo uint32 uint16)
+ (list #:bar uint8))))
+ (test-equal (list uint8 (pad 1))
+ (union-ref-padded simple-case #:bar))
+ ;; test for null padding
+ (test-equal (list uint16)
+ (union-ref-padded simple-case #:foo))
+ ;; test for structures trailing padding
+ (test-equal (list uint8 (pad (+ 3 2 2)))
+ (union-ref-padded complex-case #:bar)))
+
+
+;; replace-unions
+;;+TODO: replace ad-hoc alignment values with (sizeof* _) and
+;; (alignof*) forms
+(let ((simple-case (list int16
+ (union (list #:foo int16 int8)
+ (list #:bar int8))
+ int16))
+ (nested-case (list int16
+ (union (list #:foo int32
+ (union (list #:alice int16 int16)
+ (list #:bob int8))
+ int8)
+ (list #:bar int8))
+ int16)))
+ (test-equal (list int16 (list int16 int8) int16)
+ (replace-unions simple-case '(#:foo)))
+ (test-equal (list int16 (list int8 (pad (+ 1 1 1))) int16)
+ (replace-unions simple-case '(#:bar)))
+ (test-equal (list int16 (list int32 (list int16 int16) int8) int16)
+ (replace-unions nested-case '(#:foo #:alice)))
+ (test-equal (list int16 (list int32 (list int8 (pad (+ 1 2))) int8) int16)
+ (replace-unions nested-case '(#:foo #:bob)))
+ (test-equal (list int16 (list int8 (pad (+ 3 (+ 2 2) 1 3))) int16)
+ (replace-unions nested-case '(#:bar))))
+
+;;+TODO: write-c-struct*
+;;+TODO: read-c-struct*
+
+;; make-c-struct*
+;;
+;; simple-case:
+;; struct {
+;; union {
+;; uint32_t bird_of_prey;
+;; uint8_t uss_defiant;
+;; } foo;
+;; uint16 type;
+;; } ship;
+;;
+;; complex-case:
+;; struct {
+;; union {
+;; struct {
+;; uint32_t code;
+;; union {
+;; struct {
+;; uint64_t uhura;
+;; uint32_t kirk;
+;; uint8_t scotty;
+;; } tos;
+;; struct {
+;; uint32_t picard;
+;; uint8_t weasley;
+;; } nextgen;
+;; } crew;
+;; } enterprise;
+;; struct {
+;; uint16_t class;
+;; union {
+;; uint64_t sphere;
+;; uint8_t cube;
+;; } shape;
+;; uint8 queen_is_here;
+;; } borg;
+;; } ship;
+;; uint16 whatizit;
+;; }
+(let ((simple-case (list (union (list #:bird-of-prey uint32)
+ (list #:defiant uint8))
+ uint16))
+ (complex-case (list (union (list #:enterprise
+ uint32
+ (union (list #:tos uint64 uint32 uint8)
+ (list #:nextgen uint32 uint8)))
+ (list #:borg
+ uint16
+ (union (list #:sphere uint64)
+ (list #:cube uint8))
+ uint8))
+ uint16))
+ (klingon (list (list 1) 2))
+ (defiant (list (list 3) 4))
+ (tos (list (list 5 (list 6 7 8)) 9))
+ (cube (list (list 10 (list 11) 12) 13)))
+ (test-equal klingon
+ (parse-c-struct*
+ (make-c-struct* simple-case klingon #:bird-of-prey)
+ simple-case #:bird-of-prey))
+ (test-equal defiant
+ (parse-c-struct*
+ (make-c-struct* simple-case defiant #:defiant)
+ simple-case #:defiant))
+ (test-equal tos
+ (parse-c-struct*
+ (make-c-struct* complex-case tos #:enterprise #:tos)
+ complex-case #:enterprise #:tos))
+ (test-equal cube
+ (parse-c-struct*
+ (make-c-struct* complex-case cube #:borg #:cube) ; brr
+ complex-case #:borg #:cube)))
+
+(test-end)