cl-rw

Layered streams for Common Lisp
git clone https://logand.com/git/cl-rw.git/
Log | Files | Refs

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:
Mcl-rw.asd | 4+++-
Atls-macros.lisp | 186+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
Mtls.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))