commit 8494b88b25a130a108075fac8ae24109b510124d
parent c8063ea4b3b94cd7947da06815a1a27b94ca1b79
Author: Tomas Hlavaty <tom@logand.com>
Date: Sun, 21 Sep 2014 17:54:00 +0200
load tls as part of cl-rw
Diffstat:
| M | cl-rw.asd | | | 4 | +++- |
| A | tls-macros.lisp | | | 186 | +++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++ |
| M | tls.lisp | | | 160 | ------------------------------------------------------------------------------- |
3 files changed, 189 insertions(+), 161 deletions(-)
diff --git a/cl-rw.asd b/cl-rw.asd
@@ -52,4 +52,6 @@
(:file "ui")
(:file "cas")
(:file "zip")
- (:file "der")))
+ (:file "der")
+ (:file "tls-macros")
+ (:file "tls")))
diff --git a/tls-macros.lisp b/tls-macros.lisp
@@ -0,0 +1,186 @@
+;;; Copyright (C) 2014 Tomas Hlavaty <tom@logand.com>
+;;;
+;;; Permission is hereby granted, free of charge, to any person
+;;; obtaining a copy of this software and associated documentation
+;;; files (the "Software"), to deal in the Software without
+;;; restriction, including without limitation the rights to use, copy,
+;;; modify, merge, publish, distribute, sublicense, and/or sell copies
+;;; of the Software, and to permit persons to whom the Software is
+;;; furnished to do so, subject to the following conditions:
+;;;
+;;; The above copyright notice and this permission notice shall be
+;;; included in all copies or substantial portions of the Software.
+;;;
+;;; THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND,
+;;; EXPRESS OR IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF
+;;; MERCHANTABILITY, FITNESS FOR A PARTICULAR PURPOSE AND
+;;; NONINFRINGEMENT. IN NO EVENT SHALL THE AUTHORS OR COPYRIGHT
+;;; HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER LIABILITY,
+;;; WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM,
+;;; OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER
+;;; DEALINGS IN THE SOFTWARE.
+
+(defpackage :rw.tls
+ (:use :cl))
+
+(in-package :rw.tls)
+
+(defun fname (x)
+ (intern (format nil "~a" x)))
+
+(defun mname (x)
+ (intern (format nil "MAKE-~a" x)))
+
+(defun rname (x)
+ (intern (format nil "NEXT-~a" x)))
+
+(defun wname (x)
+ (intern (format nil "WRITE-~a" x)))
+
+(defmacro defenum (name (&key nbits) &body alist)
+ (let ((fname (fname name))
+ (sname (intern (format nil "~a-SYMBOLS" name)))
+ (cname (intern (format nil "~a-CODES" name)))
+ (rname (rname name))
+ (wname (wname name)))
+ `(let* ((alist ',alist)
+ (symbols (mapcar #'car alist))
+ (codes (mapcar #'cdr alist)))
+ (defun ,fname (x)
+ (etypecase x
+ (symbol (cdr (assoc x alist)))
+ (integer (car (rassoc x alist)))))
+ (defun ,sname () symbols)
+ (defun ,cname () codes)
+ (defun ,rname (reader)
+ (let ((z (,fname (, (ecase nbits
+ (8 'rw:next-u8)
+ (16 'rw:next-u16))
+ reader))))
+ (assert z)
+ z))
+ (defun ,wname (writer x)
+ (, (ecase nbits
+ (8 'rw:write-u8)
+ (16 'rw:write-u16))
+ writer
+ (etypecase x
+ (symbol (,fname x))
+ (integer (when (member x codes) x))))))))
+
+(defun aname (struc &optional slot)
+ (intern (format nil "~a-~a" struc slot)))
+
+(defun defun-rname-slot (slot)
+ (destructuring-bind (ty na &key length size min max compute next) slot
+ `(,na
+ , (flet ((r1 ()
+ (if (listp ty)
+ `(ecase ,(cadr ty)
+ ,@(loop
+ for (nm ty) in (cddr ty)
+ collect (if ty
+ `(,nm (,(rname ty) r))
+ `(,nm))))
+ `(,(rname ty) r))))
+ (cond
+ ((or compute next)
+ (assert (eq 'computed ty))
+ (assert (not (or length size min max)))
+ (or compute next))
+ (length
+ `(let ((l (,(rname length) r))
+ (b (make-octet-buffer 100)))
+ ,@(when min `((assert (<= ,min l))))
+ ,@(when max `((assert (<= l ,max))))
+ ,@(when (integerp size) `((assert (= l ,size))))
+ (dotimes (i l)
+ (vector-push-extend (next-u8 r) b))
+ ,(if (eq 'u8 ty)
+ 'b
+ (if size
+ `(let ((r (rw:peek-reader (rw:reader b))))
+ (loop
+ while (rw:peek r)
+ collect ,(r1)))
+ `(let ((r (rw:reader b)))
+ ,(r1))))))
+ (size
+ (assert (eq 'u8 ty))
+ `(loop for i from 0 below ,size collect ,(r1)))
+ (t
+ `(let ((v ,(r1)))
+ ,@(when min `((assert (<= ,min v))))
+ ,@(when max `((assert (<= v ,max))))
+ v)))))))
+
+(defun defun-rname (name slots)
+ `(defun ,(rname name) (r)
+ (let* (,@(mapcar 'defun-rname-slot slots))
+ (,(mname name)
+ ,@(loop
+ for slot in slots
+ appending (let ((na (cadr slot)))
+ (list (intern (symbol-name na) :keyword) na)))))))
+
+(defun defun-wname (name slots)
+ `(defun ,(wname name) (w x)
+ ,@(loop
+ for slot in slots
+ collect
+ (destructuring-bind (ty na &key length size min max compute next) slot
+ (flet ((w1 ()
+ (if (listp ty)
+ (ecase (car ty)
+ (ecase `(ecase (,(aname name (cadr ty)) x)
+ ,@(loop
+ for (nm ty) in (cddr ty)
+ collect
+ (if ty
+ `(,nm (,(wname ty) w v))
+ `(,nm))))))
+ `(,(wname ty) w v))))
+ (cond
+ ((or compute next)
+ (assert (eq 'computed ty))
+ (assert (not (or length size min max)))
+ (when compute
+ `(setf (,(aname name na) x) ,compute)))
+ (length
+ `(let ((v (,(aname name na) x))
+ (b (make-octet-buffer 100)))
+ (let ((w (rw:writer b)))
+ ,(cond
+ (size
+ `(if (listp v)
+ (loop for v in v do ,(w1))
+ (loop for v across v do ,(w1))))
+ (t (w1))))
+ (let ((l (length b)))
+ ,@(when min `((assert (<= ,min l))))
+ ,@(when max `((assert (<= l ,max))))
+ ,@(when (integerp size) `((assert (= l ,size))))
+ (,(wname length) w l))
+ (loop for e across b do (write-u8 w e))))
+ (size
+ (assert (eq 'u8 ty))
+ `(let ((v (,(aname name na) x)))
+ ,@ (when (or min max (integerp size))
+ `((let ((l (length v)))
+ ,@(when min `((assert (<= ,min l))))
+ ,@(when max `((assert (<= l ,max))))
+ ,@(when (integerp size) `((assert (= l ,size)))))))
+ (if (listp v)
+ (loop for v in v do ,(w1))
+ (loop for v across v do ,(w1)))))
+ (t
+ `(let ((v (,(aname name na) x)))
+ ,@(when min `((assert (<= ,min v))))
+ ,@(when max `((assert (<= v ,max))))
+ ,(w1)))))))))
+
+(defmacro defstruc (name () &body slots)
+ `(progn
+ (defstruct ,(fname name) ,@(mapcar #'cadr slots))
+ ,(defun-rname name slots)
+ ,(defun-wname name slots)))
diff --git a/tls.lisp b/tls.lisp
@@ -61,49 +61,6 @@
(defun write-u32 (writer x)
(rw:write-u32 writer x))
-(defun fname (x)
- (intern (format nil "~a" x)))
-
-(defun mname (x)
- (intern (format nil "MAKE-~a" x)))
-
-(defun rname (x)
- (intern (format nil "NEXT-~a" x)))
-
-(defun wname (x)
- (intern (format nil "WRITE-~a" x)))
-
-(defmacro defenum (name (&key nbits) &body alist)
- (let ((fname (fname name))
- (sname (intern (format nil "~a-SYMBOLS" name)))
- (cname (intern (format nil "~a-CODES" name)))
- (rname (rname name))
- (wname (wname name)))
- `(let* ((alist ',alist)
- (symbols (mapcar #'car alist))
- (codes (mapcar #'cdr alist)))
- (defun ,fname (x)
- (etypecase x
- (symbol (cdr (assoc x alist)))
- (integer (car (rassoc x alist)))))
- (defun ,sname () symbols)
- (defun ,cname () codes)
- (defun ,rname (reader)
- (let ((z (,fname (, (ecase nbits
- (8 'rw:next-u8)
- (16 'rw:next-u16))
- reader))))
- (assert z)
- z))
- (defun ,wname (writer x)
- (, (ecase nbits
- (8 'rw:write-u8)
- (16 'rw:write-u16))
- writer
- (etypecase x
- (symbol (,fname x))
- (integer (when (member x codes) x))))))))
-
(defenum $AlertLevel (:nbits 8)
(WARNING . 1)
(FATAL . 2))
@@ -349,9 +306,6 @@
;;'dsa
'ecdsa)
-(defun aname (struc &optional slot)
- (intern (format nil "~a-~a" struc slot)))
-
(defun make-octet-buffer (length)
(make-array length
:element-type '(unsigned-byte 8)
@@ -359,120 +313,6 @@
:adjustable t
:fill-pointer 0))
-(defun defun-rname-slot (slot)
- (destructuring-bind (ty na &key length size min max compute next) slot
- `(,na
- , (flet ((r1 ()
- (if (listp ty)
- `(ecase ,(cadr ty)
- ,@(loop
- for (nm ty) in (cddr ty)
- collect (if ty
- `(,nm (,(rname ty) r))
- `(,nm))))
- `(,(rname ty) r))))
- (cond
- ((or compute next)
- (assert (eq 'computed ty))
- (assert (not (or length size min max)))
- (or compute next))
- (length
- `(let ((l (,(rname length) r))
- (b (make-octet-buffer 100)))
- ,@(when min `((assert (<= ,min l))))
- ,@(when max `((assert (<= l ,max))))
- ,@(when (integerp size) `((assert (= l ,size))))
- (dotimes (i l)
- (vector-push-extend (next-u8 r) b))
- ,(if (eq 'u8 ty)
- 'b
- (if size
- `(let ((r (rw:peek-reader (rw:reader b))))
- (loop
- while (rw:peek r)
- collect ,(r1)))
- `(let ((r (rw:reader b)))
- ,(r1))))))
- (size
- (assert (eq 'u8 ty))
- `(loop for i from 0 below ,size collect ,(r1)))
- (t
- `(let ((v ,(r1)))
- ,@(when min `((assert (<= ,min v))))
- ,@(when max `((assert (<= v ,max))))
- v)))))))
-
-(defun defun-rname (name slots)
- `(defun ,(rname name) (r)
- (let* (,@(mapcar 'defun-rname-slot slots))
- (,(mname name)
- ,@(loop
- for slot in slots
- appending (let ((na (cadr slot)))
- (list (intern (symbol-name na) :keyword) na)))))))
-
-(defun defun-wname (name slots)
- `(defun ,(wname name) (w x)
- ,@(loop
- for slot in slots
- collect
- (destructuring-bind (ty na &key length size min max compute next) slot
- (flet ((w1 ()
- (if (listp ty)
- (ecase (car ty)
- (ecase `(ecase (,(aname name (cadr ty)) x)
- ,@(loop
- for (nm ty) in (cddr ty)
- collect
- (if ty
- `(,nm (,(wname ty) w v))
- `(,nm))))))
- `(,(wname ty) w v))))
- (cond
- ((or compute next)
- (assert (eq 'computed ty))
- (assert (not (or length size min max)))
- (when compute
- `(setf (,(aname name na) x) ,compute)))
- (length
- `(let ((v (,(aname name na) x))
- (b (make-octet-buffer 100)))
- (let ((w (rw:writer b)))
- ,(cond
- (size
- `(if (listp v)
- (loop for v in v do ,(w1))
- (loop for v across v do ,(w1))))
- (t (w1))))
- (let ((l (length b)))
- ,@(when min `((assert (<= ,min l))))
- ,@(when max `((assert (<= l ,max))))
- ,@(when (integerp size) `((assert (= l ,size))))
- (,(wname length) w l))
- (loop for e across b do (write-u8 w e))))
- (size
- (assert (eq 'u8 ty))
- `(let ((v (,(aname name na) x)))
- ,@ (when (or min max (integerp size))
- `((let ((l (length v)))
- ,@(when min `((assert (<= ,min l))))
- ,@(when max `((assert (<= l ,max))))
- ,@(when (integerp size) `((assert (= l ,size)))))))
- (if (listp v)
- (loop for v in v do ,(w1))
- (loop for v across v do ,(w1)))))
- (t
- `(let ((v (,(aname name na) x)))
- ,@(when min `((assert (<= ,min v))))
- ,@(when max `((assert (<= v ,max))))
- ,(w1)))))))))
-
-(defmacro defstruc (name () &body slots)
- `(progn
- (defstruct ,(fname name) ,@(mapcar #'cadr slots))
- ,(defun-rname name slots)
- ,(defun-wname name slots)))
-
(defstruc $Alert ()
($AlertLevel level)
($AlertDescription description))
