wire.lisp (8006B)
1 ;;; Copyright (C) 2014 Tomas Hlavaty <tom@logand.com> 2 ;;; 3 ;;; Permission is hereby granted, free of charge, to any person 4 ;;; obtaining a copy of this software and associated documentation 5 ;;; files (the "Software"), to deal in the Software without 6 ;;; restriction, including without limitation the rights to use, copy, 7 ;;; modify, merge, publish, distribute, sublicense, and/or sell copies 8 ;;; of the Software, and to permit persons to whom the Software is 9 ;;; furnished to do so, subject to the following conditions: 10 ;;; 11 ;;; The above copyright notice and this permission notice shall be 12 ;;; included in all copies or substantial portions of the Software. 13 ;;; 14 ;;; THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, 15 ;;; EXPRESS OR IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF 16 ;;; MERCHANTABILITY, FITNESS FOR A PARTICULAR PURPOSE AND 17 ;;; NONINFRINGEMENT. IN NO EVENT SHALL THE AUTHORS OR COPYRIGHT 18 ;;; HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER LIABILITY, 19 ;;; WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM, 20 ;;; OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER 21 ;;; DEALINGS IN THE SOFTWARE. 22 23 (defpackage :rw.wire 24 (:use :cl) 25 (:export :defenum 26 :defstruc 27 :flush 28 :make-octet-buffer 29 :packet-writer)) 30 31 (in-package :rw.wire) 32 33 ;; TODO lots of cut&paste from tls 34 35 (defun make-octet-buffer (length) 36 (make-array length 37 :element-type '(unsigned-byte 8) 38 :initial-element 0 39 :adjustable t 40 :fill-pointer 0)) 41 42 (defun %intern (pre x post) 43 (intern (format nil "~a~a~a" pre x post) (symbol-package x))) 44 45 (defun fname (x) 46 (%intern "" x "")) 47 48 (defun mname (x) 49 (%intern "MAKE-" x "")) 50 51 (defun rname (x) 52 (%intern "NEXT-" x "")) 53 54 (defun wname (x) 55 (%intern "WRITE-" x "")) 56 57 (defmacro defenum (name (&key type) &body alist) 58 (let ((fname (fname name)) 59 (sname (%intern "" name "-SYMBOLS")) 60 (cname (%intern "" name "-CODES")) 61 (rname (rname name)) 62 (wname (wname name))) 63 `(let* ((alist ',alist) 64 (symbols (mapcar #'car alist)) 65 (codes (mapcar #'cdr alist))) 66 (defun ,fname (x) 67 (etypecase x 68 (symbol (cdr (assoc x alist))) 69 (integer (car (rassoc x alist))))) 70 (defun ,sname () symbols) 71 (defun ,cname () codes) 72 (defun ,rname (reader) 73 (let ((z (,fname (,(rname type) reader)))) 74 (assert z) 75 z)) 76 (defun ,wname (writer x) 77 (,(wname type) 78 writer 79 (etypecase x 80 (symbol (,fname x)) 81 (integer (when (member x codes) x)))))))) 82 83 (defun aname (struc &optional slot) 84 (intern (format nil "~a-~a" struc slot) (symbol-package struc))) 85 86 (defun defun-rname-slot (slot) 87 (destructuring-bind (ty na &key length size min max compute next) slot 88 `(,na 89 , (flet ((r1 () 90 (if (listp ty) 91 `(ecase ,(cadr ty) 92 ,@(loop 93 for (nm ty) in (cddr ty) 94 collect (if ty 95 `(,nm (,(rname ty) r)) 96 `(,nm)))) 97 `(,(rname ty) r)))) 98 (cond 99 ((or compute next) 100 (assert (eq 'computed ty)) 101 (assert (not (or length size min max))) 102 (or compute next)) 103 (length 104 `(let ((l (,(rname length) r)) 105 (b (make-octet-buffer 100))) 106 ,@(when min `((assert (<= ,min l)))) 107 ,@(when max `((assert (<= l ,max)))) 108 ,@(when (integerp size) `((assert (= l ,size)))) 109 (dotimes (i l) 110 (vector-push-extend (rw:next-u8 r) b)) 111 ,(if (eq 'rw:u8 ty) 112 'b 113 (if size 114 `(let ((r (rw:peek-reader (rw:reader b)))) 115 (loop 116 while (rw:peek r) 117 collect ,(r1))) 118 `(let ((r (rw:reader b))) 119 ,(r1)))))) 120 (size 121 ;;(assert (eq 'rw:u8 ty)) ;; TODO how? 122 `(loop for i from 0 below ,size collect ,(r1))) 123 (t 124 `(let ((v ,(r1))) 125 ,@(when min `((assert (<= ,min v)))) 126 ,@(when max `((assert (<= v ,max)))) 127 v))))))) 128 129 (defun defun-rname (name slots) 130 `(defun ,(rname name) (r) 131 (let* (,@(mapcar 'defun-rname-slot slots)) 132 (,(mname name) 133 ,@(loop 134 for slot in slots 135 appending (let ((na (cadr slot))) 136 (list (intern (symbol-name na) :keyword) na))))))) 137 138 (defun defun-wname (name slots) 139 `(defun ,(wname name) (w x) 140 ,@(loop 141 for slot in slots 142 collect 143 (destructuring-bind (ty na &key length size min max compute next) slot 144 (flet ((w1 () 145 (if (listp ty) 146 (ecase (car ty) 147 (ecase `(ecase (,(aname name (cadr ty)) x) 148 ,@(loop 149 for (nm ty) in (cddr ty) 150 collect 151 (if ty 152 `(,nm (,(wname ty) w v)) 153 `(,nm)))))) 154 `(,(wname ty) w v)))) 155 (cond 156 ((or compute next) 157 (assert (eq 'computed ty)) 158 (assert (not (or length size min max))) 159 (when compute 160 `(setf (,(aname name na) x) ,compute))) 161 (length 162 `(let ((v (,(aname name na) x)) 163 (b (make-octet-buffer 100))) 164 (let ((w (rw:writer b))) 165 ,(cond 166 (size 167 `(if (listp v) 168 (loop for v in v do ,(w1)) 169 (loop for v across v do ,(w1)))) 170 (t (w1)))) 171 (let ((l (length b))) 172 ,@(when min `((assert (<= ,min l)))) 173 ,@(when max `((assert (<= l ,max)))) 174 ,@(when (integerp size) `((assert (= l ,size)))) 175 (,(wname length) w l)) 176 (loop for e across b do (rw:write-u8 w e)))) 177 (size 178 ;;(assert (eq 'rw:u8 ty)) ;; TODO how? 179 `(let ((v (,(aname name na) x))) 180 ,@ (when (or min max (integerp size)) 181 `((let ((l (length v))) 182 ,@(when min `((assert (<= ,min l)))) 183 ,@(when max `((assert (<= l ,max)))) 184 ,@(when (integerp size) `((assert (= l ,size))))))) 185 (if (listp v) 186 (loop for v in v do ,(w1)) 187 (loop for v across v do ,(w1))))) 188 (t 189 `(let ((v (,(aname name na) x))) 190 ,@(when min `((assert (<= ,min v)))) 191 ,@(when max `((assert (<= v ,max)))) 192 ,(w1))))))))) 193 194 (defmacro defstruc (name () &body slots) 195 `(progn 196 (defstruct ,(fname name) ,@(mapcar #'cadr slots)) 197 ,(defun-rname name slots) 198 ,(defun-wname name slots))) 199 200 (defun packet-writer (stream) 201 (let ((b (make-octet-buffer 42))) 202 (lambda (x) 203 (case x 204 (flush 205 (print b) 206 (write-sequence b stream) 207 (finish-output stream) 208 (setf (fill-pointer b) 0)) 209 (t 210 (vector-push-extend x b))) 211 x))) 212 213 (defun flush (writer) 214 (funcall writer 'flush))