Replaces the crappy “union handling” functions with better ones (inside “system/foreign/”); has the stub gnunet-search working.
This commit is contained in:
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")
|
(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/
|
$ cd guix/gnunet/
|
||||||
$ guile
|
$ examples/search.scm "foo" "bar"
|
||||||
|
|
||||||
Then in Guile’s prompt:
|
This will start a 5 seconds search on the given keywords. Here’s the
|
||||||
|
|
||||||
> (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
|
|
||||||
output when exactly one find matches the keyword “foo”:
|
output when exactly one find matches the keyword “foo”:
|
||||||
|
|
||||||
> (main "foo")
|
gnunet-download -o "foo.txt" gnunet://fs/chk/M976V69FDSQDH74AORDDLB…
|
||||||
Search service opened (#<pointer 0x2414dd8>)
|
|
||||||
Starting search on gnunet://fs/ksk/foo
|
|
||||||
RESULT! #<pointer 0x7ffcd822ee50>
|
|
||||||
|
|
||||||
|
You can also check your bindings with the command:
|
||||||
|
|
||||||
|
$ ./run-tests.scm
|
||||||
|
|
|
@ -1,5 +1,5 @@
|
||||||
#!/usr/bin/guile \
|
#!/usr/bin/guile \
|
||||||
-e main -s
|
-e (@\ (gnunet-search)\ main) -L . -s
|
||||||
!#
|
!#
|
||||||
;;;; Copyright © 2015 Rémi Delrue <asgeir@free.fr>
|
;;;; Copyright © 2015 Rémi Delrue <asgeir@free.fr>
|
||||||
;;;;
|
;;;;
|
||||||
|
@ -24,22 +24,54 @@
|
||||||
#:use-module (gnu gnunet fs uri)
|
#:use-module (gnu gnunet fs uri)
|
||||||
#:use-module (gnu gnunet fs progress-info)
|
#:use-module (gnu gnunet fs progress-info)
|
||||||
#:use-module (gnu gnunet configuration)
|
#: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 config-file "~/.gnunet/gnunet.conf")
|
||||||
(define count-limit 10)
|
(define count-limit 10)
|
||||||
|
|
||||||
|
|
||||||
(define (result-cb info)
|
(define (result-cb %info)
|
||||||
(simple-format #t "RESULT! ~a\n" 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)
|
(define (main args)
|
||||||
(let ((config (load-configuration config-file)))
|
(let ((config (load-configuration config-file)))
|
||||||
(define (first-task _)
|
(define (first-task _)
|
||||||
(let ((search-service
|
(let ((search-service
|
||||||
(search-service-open config #:result result-cb)))
|
(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 (cdr args))))
|
||||||
(let ((current-search (start-ksk-search search-service args)))
|
|
||||||
;; adds a timeout in 5 seconds
|
;; adds a timeout in 5 seconds
|
||||||
(add-task! (lambda (_)
|
(add-task! (lambda (_)
|
||||||
(stop-search current-search))
|
(stop-search current-search))
|
||||||
|
|
|
@ -74,15 +74,3 @@
|
||||||
if STRING is empty (\"\")."
|
if STRING is empty (\"\")."
|
||||||
(if (string=? "" string) %null-pointer (string->pointer string)))
|
(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)
|
(define-module (gnu gnunet common)
|
||||||
#:use-module (system foreign)
|
#:use-module (system foreign)
|
||||||
#:use-module (system foreign-padded)
|
|
||||||
#:use-module (rnrs base)
|
#:use-module (rnrs base)
|
||||||
#:use-module (rnrs bytevectors)
|
#:use-module (rnrs bytevectors)
|
||||||
#:use-module (gnu gnunet binding-utils)
|
#:use-module (gnu gnunet binding-utils)
|
||||||
|
@ -44,14 +43,21 @@
|
||||||
%malloc
|
%malloc
|
||||||
%free))
|
%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-relative uint64)
|
||||||
(define time-absolute 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-public-key ecdsa-public-key)
|
||||||
(define eddsa-signature (list (padding (/ 256 8))
|
(define eddsa-signature (list eddsa-public-key
|
||||||
(padding (/ 256 8))))
|
eddsa-public-key))
|
||||||
(define hashcode (list (padding 16 uint32)))
|
(define hashcode (list (generate 16 uint32)))
|
||||||
|
|
||||||
(define gnunet-ok 1)
|
(define gnunet-ok 1)
|
||||||
(define gnunet-system-error -1)
|
(define gnunet-system-error -1)
|
||||||
|
|
|
@ -18,7 +18,6 @@
|
||||||
(define-module (gnu gnunet configuration)
|
(define-module (gnu gnunet configuration)
|
||||||
#:use-module (srfi srfi-9)
|
#:use-module (srfi srfi-9)
|
||||||
#:use-module (system foreign)
|
#:use-module (system foreign)
|
||||||
#:use-module (system foreign-padded)
|
|
||||||
#:use-module (rnrs bytevectors)
|
#:use-module (rnrs bytevectors)
|
||||||
#:use-module (gnu gnunet common)
|
#:use-module (gnu gnunet common)
|
||||||
#:use-module (gnu gnunet binding-utils)
|
#:use-module (gnu gnunet binding-utils)
|
||||||
|
|
|
@ -20,6 +20,7 @@
|
||||||
#:use-module (gnu gnunet binding-utils)
|
#:use-module (gnu gnunet binding-utils)
|
||||||
#:use-module (gnu gnunet common)
|
#:use-module (gnu gnunet common)
|
||||||
#:use-module (gnu gnunet configuration)
|
#:use-module (gnu gnunet configuration)
|
||||||
|
#:use-module (gnu gnunet container metadata)
|
||||||
#:use-module (gnu gnunet fs uri)
|
#:use-module (gnu gnunet fs uri)
|
||||||
#:use-module (gnu gnunet fs progress-info)
|
#:use-module (gnu gnunet fs progress-info)
|
||||||
#:export (search-service-open
|
#:export (search-service-open
|
||||||
|
@ -99,8 +100,7 @@
|
||||||
(%gnunet-fs-start config "gnunet-search" progress-cb))
|
(%gnunet-fs-start config "gnunet-search" progress-cb))
|
||||||
|
|
||||||
(define (start-ksk-search handle keywords)
|
(define (start-ksk-search handle keywords)
|
||||||
(let ((uri (make-ksk-uri keywords)))
|
(let ((uri (apply make-ksk-uri keywords)))
|
||||||
(simple-format #t "Starting search on ~a\n" (uri->string uri))
|
|
||||||
(%search-start handle (unwrap-uri uri) 0 0 %null-pointer)))
|
(%search-start handle (unwrap-uri uri) 0 0 %null-pointer)))
|
||||||
|
|
||||||
(define (stop-search handle)
|
(define (stop-search handle)
|
||||||
|
@ -111,4 +111,4 @@
|
||||||
(define (is-directory? metadata)
|
(define (is-directory? metadata)
|
||||||
"Checks some search result’s METADATA if its mime-type matches
|
"Checks some search result’s METADATA if its mime-type matches
|
||||||
GNUNET_FS_DIRECTORY_MIME."
|
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 (ice-9 match)
|
||||||
#:use-module (srfi srfi-9)
|
#:use-module (srfi srfi-9)
|
||||||
#:use-module (system foreign)
|
#:use-module (system foreign)
|
||||||
#:use-module (system foreign-padded)
|
#:use-module (system foreign unions)
|
||||||
#:use-module (rnrs bytevectors)
|
#:use-module (rnrs bytevectors)
|
||||||
#:use-module (gnu gnunet binding-utils)
|
#:use-module (gnu gnunet binding-utils)
|
||||||
#:use-module (gnu gnunet common)
|
#:use-module (gnu gnunet common)
|
||||||
|
@ -31,7 +31,7 @@
|
||||||
|
|
||||||
(define %progress-info-type
|
(define %progress-info-type
|
||||||
(list ; struct GNUNET_FS_ProgressInfo
|
(list ; struct GNUNET_FS_ProgressInfo
|
||||||
(make-union ; union {…} value
|
(union ; union {…} value
|
||||||
(list #:publish ; struct {…} publish
|
(list #:publish ; struct {…} publish
|
||||||
'* ; GNUNET_FS_PublishContext *pc;
|
'* ; GNUNET_FS_PublishContext *pc;
|
||||||
'* ; GNUNET_FS_FileInformation *fi;
|
'* ; GNUNET_FS_FileInformation *fi;
|
||||||
|
@ -43,7 +43,7 @@
|
||||||
time-relative ; GNUNET_TIME_Relative duration;
|
time-relative ; GNUNET_TIME_Relative duration;
|
||||||
uint64 ; uint64_t completed;
|
uint64 ; uint64_t completed;
|
||||||
uint32 ; uint32_t anonymity;
|
uint32 ; uint32_t anonymity;
|
||||||
(make-union ; union {…} specifics
|
(union ; union {…} specifics
|
||||||
(list #:progress ; struct {…} progress
|
(list #:progress ; struct {…} progress
|
||||||
'* ; void *data;
|
'* ; void *data;
|
||||||
uint64 ; uint64_t offset;
|
uint64 ; uint64_t offset;
|
||||||
|
@ -73,7 +73,7 @@
|
||||||
uint64 ; uint64_t completed;
|
uint64 ; uint64_t completed;
|
||||||
uint32 ; uint32_t anonymity;
|
uint32 ; uint32_t anonymity;
|
||||||
int ; int is_active;
|
int ; int is_active;
|
||||||
(make-union ; union {…} specifics
|
(union ; union {…} specifics
|
||||||
(list #:progress ; struct {…} progress
|
(list #:progress ; struct {…} progress
|
||||||
'* ; void *data;
|
'* ; void *data;
|
||||||
uint64 ; uint64_t offset;
|
uint64 ; uint64_t offset;
|
||||||
|
@ -96,7 +96,7 @@
|
||||||
'* ; GNUNET_FS_Uri *query;
|
'* ; GNUNET_FS_Uri *query;
|
||||||
time-relative ; GNUNET_TIME_RELATIVE duration;
|
time-relative ; GNUNET_TIME_RELATIVE duration;
|
||||||
uint32 ; uint32_t anonymity;
|
uint32 ; uint32_t anonymity;
|
||||||
(make-union ; union {…} specifics
|
(union ; union {…} specifics
|
||||||
(list #:result ; struct {…} result
|
(list #:result ; struct {…} result
|
||||||
'* ; GNUNET_CONTAINER_MetaData *m…;
|
'* ; GNUNET_CONTAINER_MetaData *m…;
|
||||||
'* ; GNUNET_FS_Uri *uri;
|
'* ; GNUNET_FS_Uri *uri;
|
||||||
|
@ -143,7 +143,7 @@
|
||||||
time-relative ; GNUNET_TIME_Relative eta;
|
time-relative ; GNUNET_TIME_Relative eta;
|
||||||
time-relative ; GNUNET_TIME_Relative duration;
|
time-relative ; GNUNET_TIME_Relative duration;
|
||||||
uint64 ; uint64_t completed;
|
uint64 ; uint64_t completed;
|
||||||
(make-union ; union {…} specifics
|
(union ; union {…} specifics
|
||||||
(list #:progress ; struct {…} progress
|
(list #:progress ; struct {…} progress
|
||||||
'* ; void *data;
|
'* ; void *data;
|
||||||
uint64 ; uint64_t offset;
|
uint64 ; uint64_t offset;
|
||||||
|
@ -210,20 +210,6 @@
|
||||||
(or (rassoc-ref progress-info-status-alist status)
|
(or (rassoc-ref progress-info-status-alist status)
|
||||||
(throw 'invalid-arg "progress-info-status->integer" 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)
|
(define (progress-info-status pointer)
|
||||||
"Returns the status of a struct GNUNET_FS_ProgressInfo as a list of
|
"Returns the status of a struct GNUNET_FS_ProgressInfo as a list of
|
||||||
two keywords. If status is unknown, raises an error."
|
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)))
|
(integer->progress-info-status code)))
|
||||||
|
|
||||||
(define (parse-c-progress-info pointer)
|
(define (parse-c-progress-info pointer)
|
||||||
(parse-c-struct pointer (apply progress-info-get-type
|
(apply parse-c-struct* pointer %progress-info-type
|
||||||
(progress-info-status pointer))))
|
(progress-info-status pointer)))
|
||||||
|
|
||||||
|
|
||||||
;;; incomplete mapping of GNUNET_FS_SearchResult
|
;;; incomplete mapping of GNUNET_FS_SearchResult
|
||||||
|
|
|
@ -21,7 +21,6 @@
|
||||||
(define-module (gnu gnunet fs uri)
|
(define-module (gnu gnunet fs uri)
|
||||||
#:use-module (srfi srfi-1)
|
#:use-module (srfi srfi-1)
|
||||||
#:use-module (srfi srfi-9)
|
#:use-module (srfi srfi-9)
|
||||||
#:use-module ((rnrs base) #:select (assert))
|
|
||||||
#:use-module (rnrs bytevectors)
|
#:use-module (rnrs bytevectors)
|
||||||
#:use-module (system foreign)
|
#:use-module (system foreign)
|
||||||
#:use-module (gnu gnunet common)
|
#:use-module (gnu gnunet common)
|
||||||
|
@ -85,7 +84,8 @@
|
||||||
|
|
||||||
(define (make-ksk-uri-pointer . keywords)
|
(define (make-ksk-uri-pointer . keywords)
|
||||||
"Create a foreign pointer to a KSK URI from a list of strings 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))
|
(let* ((%error-msg-ptr (%make-blob-pointer))
|
||||||
(%keywords-str (string->pointer (keyword-list->string keywords)))
|
(%keywords-str (string->pointer (keyword-list->string keywords)))
|
||||||
(%uri (%uri-ksk-create %keywords-str %error-msg-ptr))
|
(%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)
|
(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!))
|
(schedule-shutdown!))
|
||||||
|
|
||||||
(define* (call-with-scheduler config thunk
|
(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 #:bar (rassq-ref foo-alist 2))
|
||||||
(test-equal #f (rassq-ref foo-alist 5))
|
(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*
|
;; string->pointer*
|
||||||
(test-equal %null-pointer (string->pointer* ""))
|
(test-equal %null-pointer (string->pointer* ""))
|
||||||
(test-equal "foo" (pointer->string (string->pointer* "foo")))
|
(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 (srfi srfi-64)
|
||||||
#:use-module (rnrs bytevectors)
|
#:use-module (rnrs bytevectors)
|
||||||
#:use-module (system foreign)
|
#:use-module (system foreign)
|
||||||
#:use-module (system foreign-padded)
|
|
||||||
#:use-module (gnu gnunet common)
|
#:use-module (gnu gnunet common)
|
||||||
#:use-module (gnu gnunet container metadata)
|
#:use-module (gnu gnunet container metadata)
|
||||||
#:use-module (gnu gnunet fs progress-info))
|
#:use-module (gnu gnunet fs progress-info))
|
||||||
|
@ -32,7 +31,6 @@
|
||||||
|
|
||||||
(pi-import integer->progress-info-status
|
(pi-import integer->progress-info-status
|
||||||
progress-info-status->integer
|
progress-info-status->integer
|
||||||
progress-info-get-type
|
|
||||||
bytevector-u8-fold
|
bytevector-u8-fold
|
||||||
u8-bitmap->list)
|
u8-bitmap->list)
|
||||||
|
|
||||||
|
@ -47,22 +45,6 @@
|
||||||
(test-error 'invalid-arg (progress-info-status->integer
|
(test-error 'invalid-arg (progress-info-status->integer
|
||||||
'(#:beam-me-up #:scotty)))
|
'(#: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
|
;; bytevector-u8-fold
|
||||||
(let ((bv (make-bytevector 1)))
|
(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