Replaces the crappy “union handling” functions with better ones (inside “system/foreign/”); has the stub gnunet-search working.
This commit is contained in:
Rémi Birot-Delrue
parent
04bbbcef56
commit
c40fcacfbc
24
README
24
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
|
||||
|
|
|
|||
|
|
@ -1,5 +1,5 @@
|
|||
#!/usr/bin/guile \
|
||||
-e main -s
|
||||
-e (@\ (gnunet-search)\ main) -L . -s
|
||||
!#
|
||||
;;;; Copyright © 2015 Rémi Delrue <asgeir@free.fr>
|
||||
;;;;
|
||||
|
|
@ -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))
|
||||
|
|
|
|||
|
|
@ -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))))
|
||||
|
|
|
|||
|
|
@ -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)
|
||||
|
|
@ -44,14 +43,21 @@
|
|||
%malloc
|
||||
%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)
|
||||
|
|
|
|||
|
|
@ -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)
|
||||
|
|
|
|||
|
|
@ -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))))
|
||||
|
|
|
|||
|
|
@ -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
|
||||
|
|
|
|||
|
|
@ -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))
|
||||
|
|
|
|||
|
|
@ -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
|
||||
|
|
|
|||
|
|
@ -0,0 +1,27 @@
|
|||
#!/usr/bin/guile \
|
||||
-L . -s
|
||||
!#
|
||||
;;;; Copyright © 2015 Rémi Delrue <asgeir@free.fr>
|
||||
;;;;
|
||||
;;;; 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))
|
||||
|
|
@ -1,100 +0,0 @@
|
|||
;;;; -*- mode: Scheme; indent-tabs-mode: nil; fill-column: 80; -*-
|
||||
;;;;
|
||||
;;;; Copyright © 2015 Rémi Delrue <asgeir@free.fr>
|
||||
;;;;
|
||||
;;;; 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)))
|
||||
|
||||
|
|
@ -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)))
|
||||
|
|
@ -0,0 +1,154 @@
|
|||
;;;; -*- mode: Scheme; indent-tabs-mode: nil; fill-column: 80; -*-
|
||||
;;;;
|
||||
;;;; Copyright © 2015 Rémi Delrue <asgeir@free.fr>
|
||||
;;;;
|
||||
;;;; 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")
|
||||
|
|
@ -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")))
|
||||
|
|
|
|||
|
|
@ -1,75 +0,0 @@
|
|||
;;;; -*- mode: Scheme; indent-tabs-mode: nil; fill-column: 80; -*-
|
||||
;;;;
|
||||
;;;; Copyright © 2015 Rémi Delrue <asgeir@free.fr>
|
||||
;;;;
|
||||
;;;; 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))))
|
||||
|
|
@ -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)))
|
||||
|
|
|
|||
|
|
@ -0,0 +1,174 @@
|
|||
;;;; -*- mode: Scheme; indent-tabs-mode: nil; fill-column: 80; -*-
|
||||
;;;;
|
||||
;;;; Copyright © 2015 Rémi Delrue <asgeir@free.fr>
|
||||
;;;;
|
||||
;;;; 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)
|
||||
Loading…
Reference in New Issue