-
Notifications
You must be signed in to change notification settings - Fork 0
/
alien-util.lisp
124 lines (104 loc) · 4.52 KB
/
alien-util.lisp
1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
(in-package :traceroute)
(defun unsigned-type-spec-p (type)
(and (listp type)
(eq (car type) 'unsigned)
(integerp (second type))))
(defmacro alien-coerce (obj new-type)
`(deref (cast (addr ,obj) (* ,new-type))))
(defun eval-alien-size (type &optional (units :bits))
(eval `(sb-alien:alien-size ,type ,units)))
(defun gen-struct-fields (specs)
(loop WITH bit-align = 0
FOR (name type) IN specs
COLLECT
(if (/= bit-align 0)
`(,name ,type :alignment ,bit-align)
`(,name ,type))
WHEN (unsigned-type-spec-p type)
DO
(setf bit-align (mod (+ bit-align (second type)) 8))))
(defun make-getter (struct-name endian base bit-align name type)
(let ((val `(slot ,struct-name ',base))
(size (eval-alien-size type))
(aligned-size (and (unsigned-type-spec-p type)
(* 8 (ceiling (second type) 8)))) )
(when (unsigned-type-spec-p type)
(unless (and (eq base name)
(= size aligned-size))
(setf val `(alien-coerce ,val (unsigned ,aligned-size))))
(unless (or (eq endian *native-endian*)
(<= aligned-size 8))
(setf val `(reverse-order ,val ,(/ aligned-size 8))))
(unless (= size aligned-size)
(setf val
`(ldb (byte ,size
,(case endian
(:big (- aligned-size size bit-align))
(:little bit-align)))
,val))))
`(defun ,(mksym struct-name"."name) (,struct-name)
,val)))
(defun make-setter (struct-name endian base bit-align name type)
(let* ((pos `(slot ,struct-name ',base))
(valname (gensym))
(val valname)
(size (eval-alien-size type))
(aligned-size (and (unsigned-type-spec-p type)
(* 8 (ceiling (second type) 8)))))
(when (unsigned-type-spec-p type)
(unless (and (eq base name)
(= size aligned-size))
(setf pos `(alien-coerce ,pos (unsigned ,aligned-size))))
(unless (or (eq endian *native-endian*)
(<= aligned-size 8))
(setf val `(reverse-order ,val ,(/ aligned-size 8))))
(unless (= size aligned-size)
(let ((offset (case endian
(:big (- aligned-size size bit-align))
(:little bit-align))))
(setf pos `(ldb (byte ,size ,offset) ,pos)))))
`(progn
(defun ,(mksym "%set-"struct-name"."name) (,struct-name ,valname)
(setf ,pos ,val)
,valname)
(defsetf ,(mksym struct-name"."name) ,(mksym "%set-"struct-name"."name)))))
(defun make-accessor (struct-name endian base bit-align name type)
(list (make-getter struct-name endian base bit-align name type)
(make-setter struct-name endian base bit-align name type)))
(defun make-accessors (struct-name endian specs)
(loop WITH bit-align = 0
WITH base = nil
FOR (name type) IN specs
APPEND
(prog2
(when (= bit-align 0)
(setf base name))
(make-accessor struct-name endian base bit-align name type)
(when (unsigned-type-spec-p type)
(setf bit-align (mod (+ bit-align (second type)) 8))))))
(defun gen-alien-struct-printer (struct-name specs)
(let ((stream (gensym))
(object (gensym)))
`(lambda (,stream ,object)
(print-unreadable-object (,object ,stream)
(format ,stream "~a ~s ~s #X~x"
'(alien ,struct-name)
(list ,@(loop FOR (field _ . keys) IN specs
FOR getter = (mksym struct-name"."field)
FOR name = (intern (symbol-name field) :keyword)
COLLECT
(destructuring-bind (&key (show 'identity)) keys
`(list ,name (,show (,getter ,object))))))
:sap
(sb-sys:sap-int (sb-alien:alien-sap ,object)))))))
(defmacro define-alien-struct (name (&key (endian *native-endian*)) &rest field-specs)
`(progn
(sb-alien:define-alien-type ,name
(struct nil ,@(gen-struct-fields field-specs)))
,@(make-accessors name endian field-specs)
(set-pprint-dispatch '(sb-alien:alien ,name)
,(gen-alien-struct-printer name field-specs)
0)
(define-symbol-macro ,(mksym name ".size") (sb-alien:alien-size ,name :bytes))
(define-symbol-macro ,(mksym name ".bit-size") (sb-alien:alien-size ,name))
',name))