data.scm
1 | ;;;; Copyright (C) 2020 Julien Lepiller <julien@lepiller.eu> |
2 | ;;;; |
3 | ;;;; This library is free software; you can redistribute it and/or |
4 | ;;;; modify it under the terms of the GNU Lesser General Public |
5 | ;;;; License as published by the Free Software Foundation; either |
6 | ;;;; version 3 of the License, or (at your option) any later version. |
7 | ;;;; |
8 | ;;;; This library is distributed in the hope that it will be useful, |
9 | ;;;; but WITHOUT ANY WARRANTY; without even the implied warranty of |
10 | ;;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU |
11 | ;;;; Lesser General Public License for more details. |
12 | ;;;; |
13 | ;;;; You should have received a copy of the GNU Lesser General Public |
14 | ;;;; License along with this library; if not, write to the Free Software |
15 | ;;;; Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA |
16 | ;;;; |
17 | |
18 | (define-module (netlink data) |
19 | #:use-module (ice-9 match) |
20 | #:use-module (srfi srfi-9) |
21 | #:export (make-nl-data |
22 | nl-data-data nl-data-size-proc nl-data-serialize-proc |
23 | data-size |
24 | serialize deserialize |
25 | get-current-deserialize get-next-deserialize |
26 | define-data-type)) |
27 | |
28 | (define-record-type nl-data |
29 | (make-nl-data data size-proc serialize-proc) |
30 | nl-data? |
31 | (data nl-data-data) |
32 | (size-proc nl-data-size-proc) |
33 | (serialize-proc nl-data-serialize-proc)) |
34 | |
35 | (define (data-size data) |
36 | ((nl-data-size-proc data) (nl-data-data data))) |
37 | |
38 | (define (serialize data pos bv) |
39 | ((nl-data-serialize-proc data) (nl-data-data data) pos bv)) |
40 | |
41 | (define (get-next-deserialize decoder current-type target-type) |
42 | (match (assoc-ref decoder current-type) |
43 | ((_ . type-alist) |
44 | (or (assoc-ref type-alist target-type) |
45 | (assoc-ref type-alist 'default))) |
46 | (#f (throw 'no-decoder current-type)))) |
47 | |
48 | (define (get-current-deserialize decoder current-type) |
49 | (match (assoc-ref decoder current-type) |
50 | ((current-deserialize . _) current-deserialize) |
51 | (#f (throw 'no-decoder current-type)))) |
52 | |
53 | (define (deserialize type decoder bv pos) |
54 | (let ((deserialize (get-current-deserialize decoder type))) |
55 | (deserialize decoder bv pos))) |
56 | |
57 | (define* (syntax-append x . s) |
58 | (define (->symbol s) |
59 | (if (symbol? s) s (syntax->datum s))) |
60 | (datum->syntax x (apply symbol-append (map ->symbol s)))) |
61 | |
62 | (define-syntax define-data-type |
63 | (lambda (x) |
64 | (syntax-case x () |
65 | ((_ name size-proc serialize-proc (field accessor internal-accessor) ...) |
66 | #`(begin |
67 | (define-record-type #,(syntax-append x #'name '-type) |
68 | (#,(syntax-append x 'make- #'name '-type) field ...) |
69 | #,(syntax-append x #'name '-type?) |
70 | (field internal-accessor) ...) |
71 | |
72 | (define (accessor data) |
73 | (internal-accessor (nl-data-data data))) |
74 | ... |
75 | |
76 | (define (#,(syntax-append x 'make- #'name) field ...) |
77 | (make-nl-data |
78 | (#,(syntax-append x 'make- #'name '-type) field ...) |
79 | size-proc |
80 | serialize-proc)) |
81 | |
82 | (define (#,(syntax-append x #'name '?) data) |
83 | (#,(syntax-append x #'name '-type?) |
84 | (nl-data-data data)))))))) |
85 |