[Date Prev][Date Next][Thread Prev][Thread Next][Date Index][Thread Index]
[gnunet-scheme] branch master updated: Define 'construct' macro for maki
|
From: |
gnunet |
|
Subject: |
[gnunet-scheme] branch master updated: Define 'construct' macro for making bytevector slices. |
|
Date: |
Thu, 29 Dec 2022 22:50:20 +0100 |
This is an automated email from the git hooks/post-receive script.
maxime-devos pushed a commit to branch master
in repository gnunet-scheme.
The following commit(s) were added to refs/heads/master by this push:
new 44061e6 Define 'construct' macro for making bytevector slices.
44061e6 is described below
commit 44061e6dc2b15b6f6cb036d00a8adb0e3d1a474a
Author: Maxime Devos <maximedevos@telenet.be>
AuthorDate: Thu Dec 29 22:44:32 2022 +0100
Define 'construct' macro for making bytevector slices.
* doc/network-structures.tm: Document new macros.
* NEWS: Likewise.
* gnu/gnunet/cadet/client.tm
(construct-local-channel-create): Use it.
(construct-local-channel-destroy): Likewise.
(construct-local-data): Likewise.
(construct-local-acknowledgement): Likewise.
* gnu/gnunet/dht/client.scm
(construct-client-get): Likewise.
(construct-client-get-stop): Likewise.
(construct-client-result): Likewise.
* gnu/gnunet/fs/network.scm
(construct-request-loc-signature): Likewise.
* gnu/gnunet/fs/uri.scm
(make-content-hash-key/share): Use 'define-analyser'.
* gnu/gnunet/netstruct/syntactic.scm
(%sizeof,=>slice!,=>!,construct): Implement new macros.
---
NEWS | 7 +-
doc/network-structures.tm | 57 ++++++++++++++++
gnu/gnunet/cadet/client.scm | 81 +++++++++-------------
gnu/gnunet/dht/client.scm | 133 +++++++++++++++----------------------
gnu/gnunet/fs/network.scm | 44 +++++-------
gnu/gnunet/fs/uri.scm | 11 ++-
gnu/gnunet/netstruct/syntactic.scm | 41 +++++++++++-
7 files changed, 206 insertions(+), 168 deletions(-)
diff --git a/NEWS b/NEWS
index 4e2a667..550d859 100644
--- a/NEWS
+++ b/NEWS
@@ -12,9 +12,10 @@
in the manual. These tools have been used to reduce duplication between
client code of different services, so tests targeting a single service
automatically also test the other services a bit.
- - New macro 'analyse' and 'define-analyser', to make using read% and select%
- less tedious when the type and slice remains the same. Also, by using the
- new macros, the code base should now be a bit more readible.
+ - New macro 'analyse', 'construct' and 'define-analyser', to make using
+ read%, select% and 'set%', less tedious when the type and slice remains
+ the same. Also, by using the new macros, the code base should now be a
+ bit more readible.
** Bugfixes
- A potential (but unverified) bug with automatic collection is fixed --
previously, if DHT garbage was found multiple times within a single
diff --git a/doc/network-structures.tm b/doc/network-structures.tm
index ebda27a..3f65c93 100644
--- a/doc/network-structures.tm
+++ b/doc/network-structures.tm
@@ -157,6 +157,8 @@
...) slice value)>.<space|1em>The following code sets all the fields:
<\scm-code>
+ ;; This example will be simplified later!
+
(set%! /:msg:nse:estimate/example '(header size) message
\ \ \ \ \ \ \ (sizeof /:msg:nse:estimate/example '()))
@@ -166,6 +168,61 @@
(set%! /:msg:nse:estimate/example '(size-estimate) message 19.2)
</scm-code>
+ Repeating the message type and slice can be repetitive, so <scm|(gnu gnunet
+ netstruct syntactic)> has a macro <scm|construct> to avoid this:
+
+ <\explain>
+ <scm|(construct <var|type> #:tail (<var|tail> <var|space>) <var|clause>
+ ...)><index|construct>
+ <|explain>
+ The keyword argument <scm|#:tail (<var|tail> <var|space>)> is optional \U
+ <var|space> defaults to <scm|0>.
+
+ Return a fresh read-write bytevector slice holding a <var|type> and
+ <var|space> additional bytes. The slice is initialised by sequentally
+ running <var|clause> <text-dots>. In the syntactic environment of the
+ clauses, when present, <var|tail> is bound to a read-write bytevector
+ slice for the <var|space> additional bytes, and in the environment the
+ following macros are available:
+
+ <\description>
+ <item*|<scm|(%sizeof)><index|%sizeof>>The total size of the bytevector
+ size, i.e. the size of the network structure <var|type> plus
+ <var|space>.
+
+ <item*|<scm|(=\<gtr\>! <var|field> <var|value>)><index|=\<gtr\>!>>Assign
+ <var|value> to the field <var|field>. This is to be understood as a
+ literal list, not as a procedure invocation \U neither the list nor
+ <var|field> <text-dots> is evaluated.
+
+ <item*|<scm|(=\<gtr\>slice! <var|field>
+ <var|slice>)><index|=\<gtr\>slice!>>Copy the slice <var|slice> into the
+ field <var|field>, where <scm|(field ...)> is interpreted the same way
+ as for <scm|=\<gtr\>!>.
+ </description>
+
+ <var|type> can currently be evaluated multiple times. These macros
+ <scm|%sizeof>, <scm|=\<gtr\>!><space|1em>and <scm|=\<gtr\>slice!> can
+ only be used inside a <scm|construct> form; in other contexts an
+ exception is raised.
+ </explain>
+
+ Using this macro, the previous example can be simplified to:
+
+ <\scm-code>
+ (import [...]) (define-type [...]) ; copy from previous example
+
+ (define message
+
+ \ \ (construct /:msg:nse:estimate/example
+
+ \ \ \ \ (=\<gtr\>! (header size) (%sizeof))
+
+ \ \ \ \ (=\<gtr\>! (header type) 165)
+
+ \ \ \ \ (=\<gtr\>! (size-estimate) 19.2)))
+ </scm-code>
+
The size of an individual field can be determined with <scm|(sizeof
netstruct '(field ...))>.<space|1em>For example, the following code
determines the size of the \<#2018\>size\<#2019\> field in the header:
diff --git a/gnu/gnunet/cadet/client.scm b/gnu/gnunet/cadet/client.scm
index 50118fe..7306cb4 100644
--- a/gnu/gnunet/cadet/client.scm
+++ b/gnu/gnunet/cadet/client.scm
@@ -77,12 +77,11 @@
(only (gnu gnunet mq)
make-message-queue inject-message!)
(only (gnu gnunet netstruct syntactic)
- sizeof select read% set%! r% s% define-analyser analyse)
+ sizeof %sizeof read% r% s% define-analyser analyse
+ construct =>! =>slice!)
(only (gnu gnunet utils bv-slice)
make-slice/read-write slice-copy/read-only slice-length
slice-copy! slice-slice)
- (only (gnu gnunet utils cut-syntax)
- cut-syntax)
(only (gnu gnunet utils hat-let)
let^)
(only (rnrs base)
@@ -391,21 +390,16 @@ do not have any impact on the cadet address."
"Create a new @code{/:msg:cadet:channel:create} message for contacting
the CADET addresss @var{cadet-address}, using the channel number
@var{channel-number} and options @var{options}."
- (define s
- (make-slice/read-write (sizeof /:msg:cadet:local:channel:create '())))
- (define-syntax set*
- (cut-syntax set%! /:msg:cadet:local:channel:create <> s <>))
- (define-syntax select*
- (cut-syntax select /:msg:cadet:local:channel:create <> s))
- (set* '(header size) (slice-length s))
- (set* '(header type)
+ (construct
+ /:msg:cadet:local:channel:create
+ (=>! (header size) (%sizeof))
+ (=>! (header type)
(value->index
(symbol-value message-type msg:cadet:local:channel:create)))
- (set* '(channel-number) channel-number)
- (slice-copy! (cadet-address-peer cadet-address) (select* '(peer)))
- (slice-copy! (cadet-address-port cadet-address) (select* '(port)))
- (set* '(options) options)
- s)
+ (=>! (channel-number) channel-number)
+ (=>slice! (peer) (cadet-address-peer cadet-address))
+ (=>slice! (port) (cadet-address-port cadet-address))
+ (=>! (options) options)))
(define (send-local-channel-create! mq channel)
(send-message!
@@ -423,16 +417,12 @@ the @code{/:msg:cadet:channel:create} message
@var{message}."
(define (construct-local-channel-destroy channel-number)
"Create a @code{/:msg:cadet:channel:destroy} message for closing the
CADET channel with channel number @var{channel-number}."
- (define s
- (make-slice/read-write (sizeof /:msg:cadet:local:channel:destroy '())))
- (define-syntax set*
- (cut-syntax set%! /:msg:cadet:local:channel:destroy <> s <>))
- (set* '(header size) (slice-length s))
- (set* '(header type)
- (value->index
- (symbol-value message-type msg:cadet:local:channel:destroy)))
- (set* '(channel-number) channel-number)
- s)
+ (construct /:msg:cadet:local:channel:destroy
+ (=>! (header size) (%sizeof))
+ (=>! (header type)
+ (value->index
+ (symbol-value message-type msg:cadet:local:channel:destroy)))
+ (=>! (channel-number) channel-number)))
(define-analyser analyse-local-channel-destroy
/:msg:cadet:local:channel:destroy
@@ -448,20 +438,15 @@ CADET channel with channel number @var{channel-number}."
;; TODO: direction (service->client, client->service?)
(define (construct-local-data channel-number priority-preference data)
"Create a @code{/:msg:cadet:local:data} message ???"
- (define header-size (sizeof /:msg:cadet:local:data '()))
- (define s (make-slice/read-write (+ header-size (slice-length data))))
- (define header (slice-slice s 0 header-size))
- (define rest (slice-slice s header-size))
- (define-syntax set*
- (cut-syntax set%! /:msg:cadet:local:data <> header <>))
- (set* '(header size) (slice-length s))
- (set* '(header type)
- (value->index
- (symbol-value message-type msg:cadet:local:data)))
- (set* '(channel-number) channel-number)
- (set* '(priority-preference) priority-preference)
- (slice-copy! data rest)
- s)
+ (construct /:msg:cadet:local:data
+ #:tail (rest (slice-length data))
+ (=>! (header size) (%sizeof))
+ (=>! (header type)
+ (value->index
+ (symbol-value message-type msg:cadet:local:data)))
+ (=>! (channel-number) channel-number)
+ (=>! (priority-preference) priority-preference)
+ (slice-copy! data rest)))
(define (analyse-local-data message)
"Return the channel number, the numeric priority-preference value and
data
@@ -478,16 +463,12 @@ in the @code{/:msg:cadet:local:data} message
@var{message}."
"Create a @code{/:msg:cadet:local:acknowledgement} message,
to inform the client that more data can be sent across the channel
identified by @var{channel-number}."
- (define s
- (make-slice/read-write (sizeof /:msg:cadet:local:acknowledgement '())))
- (define-syntax set*
- (cut-syntax set%! /:msg:cadet:local:acknowledgement <> s <>))
- (set* '(header size) (slice-length s))
- (set* '(header type)
- (value->index
- (symbol-value message-type msg:cadet:local:acknowledgement)))
- (set* '(client-channel-number) channel-number)
- s)
+ (construct /:msg:cadet:local:acknowledgement
+ (=>! (header size) (%sizeof))
+ (=>! (header type)
+ (value->index
+ (symbol-value message-type msg:cadet:local:acknowledgement)))
+ (=>! (client-channel-number) channel-number)))
(define-analyser analyse-local-acknowledgement
/:msg:cadet:local:acknowledgement
diff --git a/gnu/gnunet/dht/client.scm b/gnu/gnunet/dht/client.scm
index 047ca6d..a09f355 100644
--- a/gnu/gnunet/dht/client.scm
+++ b/gnu/gnunet/dht/client.scm
@@ -87,9 +87,8 @@
loop:terminal-condition loop:control-channel
run-loop spawn-server-loop)
(only (guile)
- pk define-syntax-rule define* lambda* error
- ->bool and=> define-syntax-parameter syntax
- syntax-parameterize)
+ define-syntax-rule define* lambda* error
+ ->bool and=>)
(only (ice-9 atomic)
make-atomic-box)
(only (ice-9 match)
@@ -107,19 +106,18 @@
(only (gnu gnunet message protocols)
message-type)
(only (gnu gnunet netstruct syntactic)
- read% sizeof set%! select r% s% analyse define-analyser)
+ read% sizeof r% s% analyse define-analyser
+ construct =>! =>slice! %sizeof)
(only (gnu gnunet utils bv-slice)
slice-length slice/read-only make-slice/read-write slice-copy!
slice-slice verify-slice-readable slice-copy/read-write
slice-copy/read-only)
(gnu gnunet utils hat-let)
- (only (gnu gnunet utils cut-syntax)
- cut-syntax)
(only (rnrs base)
and < >= = quote * / + - define begin ... let*
quote case else values apply let cond if > eq?
<= expt assert exact? integer? lambda for-each
- not expt min max div-and-mod positive? define-syntax
+ not expt min max div-and-mod positive?
vector cons append list)
(only (rnrs control)
unless when)
@@ -405,61 +403,45 @@ slices in @var{old} do not impact the new search result."
(define* (construct-client-get query unique-id #:optional (options 0))
"Create a new @code{/:msg:dht:client:get} message for the query object
@var{query}, with @var{unique-id} as ‘unique id’ and @var{options} as
options."
- (define s (make-slice/read-write (sizeof /:msg:dht:client:get '())))
- (define-syntax set%!/get (cut-syntax set%! /:msg:dht:client:get <> s <>))
- (set%!/get '(header size) (slice-length s))
- (set%!/get '(header type)
- (value->index (symbol-value message-type msg:dht:client:get)))
- (set%!/get '(options) options)
- (set%!/get '(desired-replication-level)
- (query-desired-replication-level query))
- (set%!/get '(type) (query-type query))
- (slice-copy! (hashcode:512->slice (query-key query))
- (select /:msg:dht:client:get '(key) s))
- (set%!/get '(unique-id) unique-id)
- s)
+ (construct /:msg:dht:client:get
+ (=>! (header size) (%sizeof))
+ (=>! (header type)
+ (value->index (symbol-value message-type msg:dht:client:get)))
+ (=>! (options) options)
+ (=>! (desired-replication-level)
+ (query-desired-replication-level query))
+ (=>! (type) (query-type query))
+ (=>slice! (key) (hashcode:512->slice (query-key query)))
+ (=>! (unique-id) unique-id)))
(define* (construct-client-get-stop key unique-id)
"Create a new @code{/:msg:dht:client:get:stop} message for cancelling a
get request with @var{unique-id} as unique id and @var{key} as key."
- (define s (make-slice/read-write (sizeof /:msg:dht:client:get:stop '())))
- (define-syntax set%!/stop
- (cut-syntax set%! /:msg:dht:client:get:stop <> s <>))
- (set%!/stop '(header size) (slice-length s))
- (set%!/stop '(header type)
- (value->index
- (symbol-value message-type msg:dht:client:get:stop)))
- (set%!/stop '(reserved) 0)
- (set%!/stop '(unique-id) unique-id)
- (slice-copy! (hashcode:512->slice key)
- (select /:msg:dht:client:get:stop '(key) s))
- s)
+ (construct /:msg:dht:client:get:stop
+ (=>! (header size) (%sizeof))
+ (=>! (header type)
+ (value->index (symbol-value message-type msg:dht:client:get:stop)))
+ (=>! (reserved) 0)
+ (=>! (unique-id) unique-id)
+ (=>slice! (key) (hashcode:512->slice key))))
(define* (construct-client-put insertion #:optional (options 0))
"Create a new @code{/:msg:dht:client:put} message for the insertion
object insertion with @var{options} as options."
(define datum (insertion->datum insertion))
- (define size/header (sizeof /:msg:dht:client:put '()))
- (define size (+ size/header (slice-length (datum-value datum))))
- (define message
- (make-slice/read-write
- (+ size/header (slice-length (datum-value datum)))))
- (define header (slice-slice message 0 size/header))
- (define rest (slice-slice message size/header))
- (define-syntax set%!/put (cut-syntax set%! /:msg:dht:client:put <>
header <>))
- (set%!/put '(header type)
- (value->index (symbol-value message-type msg:dht:client:put)))
- (set%!/put '(header size) size)
- (set%!/put '(type) (datum-type datum))
- (set%!/put '(option) options)
- (set%!/put '(desired-replication-level)
- (insertion-desired-replication-level insertion))
- (set%!/put '(expiration) (datum-expiration datum))
- ;; Copy key-data pair to insert into the DHT.
- (slice-copy! (hashcode:512->slice (datum-key datum))
- (select /:msg:dht:client:put '(key) header))
- (slice-copy! (datum-value datum) rest)
- message)
+ (construct /:msg:dht:client:put
+ #:tail (rest (slice-length (datum-value datum)))
+ (=>! (header size) (%sizeof))
+ (=>! (header type)
+ (value->index (symbol-value message-type msg:dht:client:put)))
+ (=>! (type) (datum-type datum))
+ (=>! (option) options)
+ (=>! (desired-replication-level)
+ (insertion-desired-replication-level insertion))
+ (=>! (expiration) (datum-expiration datum))
+ ;; Copy key-data pair to insert into the DHT.
+ (=>slice! (key) (hashcode:512->slice (datum-key datum)))
+ (slice-copy! (datum-value datum) rest)))
(define (construct-client-result search-result unique-id)
"Create a new @code{/:msg:dht:client:result} message for the search
@@ -467,40 +449,29 @@ result object @var{search-result}, with @var{unique-id}
as ‘unique id’"
(let^ ((! datum (search-result->datum search-result))
(! get-path (search-result-get-path search-result))
(! put-path (search-result-put-path search-result))
- (! type (datum-type datum))
- (! key (datum-key datum))
(! value (datum-value datum))
- (! expiration (datum-expiration datum))
- (! size/header (sizeof /:msg:dht:client:result '()))
(! (path-length path)
(if path
(/ (slice-length path) (sizeof /dht:path-element '()))
0))
(! get-path-length (path-length get-path))
- (! put-path-length (path-length put-path))
- (! size (+ size/header
- (slice-length value)
- get-path-length
- put-path-length))
- (! message (make-slice/read-write size))
- (! header (slice-slice message 0 size/header))
- (! rest (slice-slice message size/header)))
- (define-syntax set%!/result
- (cut-syntax set%! /:msg:dht:client:result <> header <>))
- (set%!/result '(header type)
- (value->index
- (symbol-value message-type msg:dht:client:result)))
- (set%!/result '(header size) size)
- (set%!/result '(type) type)
- (set%!/result '(get-path-length) get-path-length)
- (set%!/result '(put-path-length) put-path-length)
- (set%!/result '(unique-id) unique-id)
- (set%!/result '(expiration) expiration)
- (slice-copy! (hashcode:512->slice key)
- (select /:msg:dht:client:result '(key) header))
- ;; TODO: get-path and put path!
- (slice-copy! value rest)
- message))
+ (! put-path-length (path-length put-path)))
+ (construct /:msg:dht:client:result
+ #:tail (rest (+ (slice-length value)
+ get-path-length
+ put-path-length))
+ (=>! (header type)
+ (value->index
+ (symbol-value message-type msg:dht:client:result)))
+ (=>! (header size) (%sizeof))
+ (=>! (type) (datum-type datum))
+ (=>! (get-path-length) get-path-length)
+ (=>! (put-path-length) put-path-length)
+ (=>! (unique-id) unique-id)
+ (=>! (expiration) (datum-expiration datum))
+ (=>slice! (key) (hashcode:512->slice (datum-key datum)))
+ ;; TODO: get-path and put path!
+ (slice-copy! value rest))))
(define-analyser analyse-client-get /:msg:dht:client:get
"Return the query object, the unique id and the options corresponding to
diff --git a/gnu/gnunet/fs/network.scm b/gnu/gnunet/fs/network.scm
index 3519aae..8de63c0 100644
--- a/gnu/gnunet/fs/network.scm
+++ b/gnu/gnunet/fs/network.scm
@@ -20,10 +20,8 @@
;; TODO: untested
(define-library (gnu gnunet fs network)
(export construct-request-loc-signature analyse-request-loc-signature)
- (import (only (rnrs base) define define-syntax quote values)
+ (import (only (rnrs base) define values)
(only (guile) begin define*)
- (only (gnu gnunet utils bv-slice)
- make-slice/read-write slice-copy! slice-length )
(only (gnu extractor enum) value->index symbol-value)
(only (gnu gnunet message protocols) message-type)
(only (gnu gnunet fs struct)
@@ -34,15 +32,15 @@
make-content-hash-key/share)
(only (gnu gnunet hashcode)
hashcode:512->slice)
- (only (gnu gnunet utils cut-syntax) cut-syntax)
(only (gnu gnunet netstruct syntactic)
- set%! sizeof select r% s% define-analyser))
+ r% s% define-analyser construct %sizeof
+ =>! =>slice!))
(begin
;; GNUNET_SIGNATURE_PURPOSE_PEER_PLACEMENT,
;; (see gnunet-signatures/gnunet_signatures.rst)
(define %purpose-peer-placement 5)
- (define* (construct-request-loc-signature file-length
+ (define* (construct-request-loc-signature file-length*
content-hash-key
expiration-time
#:key
@@ -51,26 +49,20 @@
length @var{file-length} with @var{content-hash-key} as content hash key,
expiring at @var{expiration-time} (TODO type), for @var{purpose}
(currently always %purpose-peer-placement). TODO bounds."
- (define s (make-slice/read-write
- (sizeof /:msg:fs:request-loc-signature '())))
- (define-syntax set%!* (cut-syntax set%!
- /:msg:fs:request-loc-signature <> s <>))
- (define-syntax select* (cut-syntax select
- /:msg:fs:request-loc-signature <> s))
- (set%!* '(header size) (slice-length s))
- (set%!* '(header type)
- (value->index
- (symbol-value message-type msg:fs:request-loc-signature)))
- (set%!* '(purpose) purpose)
- (set%!* '(expiration-time) expiration-time)
- (slice-copy!
- (hashcode:512->slice (content-hash-key-key content-hash-key))
- (select* '(content-hash-key key)))
- (slice-copy!
- (hashcode:512->slice (content-hash-key-query content-hash-key))
- (select* '(content-hash-key query)))
- (set%!* '(file-length) file-length)
- s)
+ (construct
+ /:msg:fs:request-loc-signature
+ (=>! (header size) (%sizeof))
+ (=>! (header type)
+ (value->index
+ (symbol-value message-type msg:fs:request-loc-signature)))
+ (=>! (purpose) purpose)
+ (=>! (expiration-time) expiration-time)
+ (=>slice! (content-hash-key key)
+ (hashcode:512->slice (content-hash-key-key content-hash-key)))
+ (=>slice!
+ (content-hash-key query)
+ (hashcode:512->slice (content-hash-key-query content-hash-key)))
+ (=>! (file-length) file-length*)))
(define-analyser analyse-request-loc-signature
/:msg:fs:request-loc-signature
diff --git a/gnu/gnunet/fs/uri.scm b/gnu/gnunet/fs/uri.scm
index ce3b5dd..88cdb56 100644
--- a/gnu/gnunet/fs/uri.scm
+++ b/gnu/gnunet/fs/uri.scm
@@ -93,7 +93,7 @@
(only (ice-9 regex) match:substring)
(only (srfi srfi-2) and-let*)
(only (gnu gnunet netstruct syntactic)
- select))
+ define-analyser s%))
;; Size of the individual blocks used for file-sharing.
;; TODO: what is the proper place to define this constant
@@ -115,14 +115,13 @@
(assert (hashcode:512? query))
(%make-content-hash-key key query))
- (define (make-content-hash-key/share slice)
+ (define-analyser make-content-hash-key/share /content-hash-key
"Construct a <content-hash-key> corresponding to the
-@code{/content-hash-key} @var{slice}. @var{slice} may not be modified
+@code{/content-hash-key} slice. The slice may not be modified
while the content hash key is in use."
(make-content-hash-key
- (make-hashcode:512/share (select /content-hash-key '(key) slice))
- (make-hashcode:512/share
- (select /content-hash-key '(query) slice))))
+ (make-hashcode:512/share (s% key))
+ (make-hashcode:512/share (s% query))))
;; Information needed to retrieve a file (content-hash-key
;; plus file size)
diff --git a/gnu/gnunet/netstruct/syntactic.scm
b/gnu/gnunet/netstruct/syntactic.scm
index fe54165..5e923e2 100644
--- a/gnu/gnunet/netstruct/syntactic.scm
+++ b/gnu/gnunet/netstruct/syntactic.scm
@@ -22,7 +22,7 @@
(define-library (gnu gnunet netstruct syntactic)
(export sizeof offsetof select read% set%!
structure/packed define-type
- r% s% analyse define-analyser)
+ r% s% analyse define-analyser =>! =>slice! construct %sizeof)
(import (rnrs base)
(rnrs control)
(only (rnrs exceptions)
@@ -444,6 +444,21 @@ with some inlining where possible."
(syntax-violation 's%
"s% used outside of a 'analyzer' construct"
stx)))
+ (define-syntax-parameter %sizeof ; size of field
+ (lambda (s)
+ (syntax-violation '%sizeof
+ "%sizeof used outside a 'construct' form"
+ s)))
+ (define-syntax-parameter =>slice! ; copy a slice into a field
+ (lambda (s)
+ (syntax-violation '=>slice!
+ "=>slice! used outside a 'construct' form"
+ s)))
+ (define-syntax-parameter =>! ; assign a field
+ (lambda (s)
+ (syntax-violation '=>!
+ "=>! used outside a 'construct' form"
+ s)))
(define-syntax analyse
(syntax-rules ()
((_ type message body ...)
@@ -458,4 +473,26 @@ with some inlining where possible."
((_ name type docstring body ...)
(define (name message)
docstring
- (analyse type message body ...)))))))
+ (analyse type message body ...)))))
+ (define-syntax construct
+ (syntax-rules ()
+ ((_ type #:tail (tail space) clause ...)
+ (let* ((type-size (sizeof type '()))
+ (tail-size space)
+ (total-size (+ type-size tail-size))
+ (message (make-slice/read-write total-size))
+ (header (slice-slice message 0 type-size))
+ (tail (slice-slice message type-size)))
+ (syntax-parameterize
+ ((%sizeof (syntax-rules ()
+ ((_) total-size)
+ ((_ . fields) (sizeof type 'fields))))
+ (=>! (syntax-rules ()
+ ((_ field value) (set%! type 'field header value))))
+ (=>slice! (syntax-rules ()
+ ((_ field slice)
+ (slice-copy! slice (select type 'field header))))))
+ clause ...
+ message)))
+ ((_ type clause ...)
+ (construct type #:tail (unused 0) clause ...))))))
--
To stop receiving notification emails like this one, please contact
gnunet@gnunet.org.
| [Prev in Thread] |
Current Thread |
[Next in Thread] |
- [gnunet-scheme] branch master updated: Define 'construct' macro for making bytevector slices.,
gnunet <=