cdef.lisp (4197B)
1 ;;; Copyright (C) 2011, 2012, 2013 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 (in-package :olefs) 24 25 (deftype achar () '(unsigned-byte 8)) 26 (deftype ubyte () '(unsigned-byte 8)) 27 (deftype ushort () '(unsigned-byte 16)) 28 (deftype wchar () '(unsigned-byte 16)) 29 (deftype dword () '(unsigned-byte 32)) 30 (deftype ulonglong () '(unsigned-byte 64)) 31 (deftype filetime () '(unsigned-byte 64)) 32 (deftype guid () '(vector ubyte 16)) 33 34 (defun slot-type-definition (type) 35 (if (atom type) 36 type 37 (destructuring-bind (type1 size) type 38 (list 'vector type1 (if (numberp size) size '*))))) 39 40 (defun slot-type-read (type) 41 (cond 42 ((eq 'ubyte type) 43 `(read-octet stream)) 44 ((atom type) 45 `(,(intern (format nil "READ-~a" type)) stream)) 46 ((eq 'ubyte (car type)) 47 `(read-octets stream ,(cadr type))) 48 (t 49 `(read-vector stream ,(cadr type) ',(car type) 50 ',(intern (format nil "READ-~a" (car type))))))) 51 52 ;;(slot-type-read #+nil 'dword #+nil '(byte 6) '(wchar 6)) 53 54 (defun slot-reader-let-definition (name type &key compute always member when default) 55 (list 56 name 57 (flet ((value () 58 (cond 59 (compute compute) 60 (when `(if ,when ,(slot-type-read type) ,default)) 61 (t (slot-type-read type))))) 62 (cond 63 (always `(let ((x ,(value))) (assert (equal x ,always)) x)) 64 (member `(let ((x ,(value))) (assert (member x ,member)) x)) 65 (t (value)))))) 66 67 (defmacro define-structure (name options &rest slots) 68 (declare (ignore options)) 69 `(progn 70 (defstruct (,name (:conc-name ,(intern (format nil "~a." name)))) 71 %physical-stream-position 72 ,@(loop 73 for slot in slots 74 collect (list (car slot) 75 nil 76 :type (slot-type-definition (cadr slot))))) 77 (defun ,(intern (format nil "READ-~a" name)) (stream) 78 (let* ((%physical-stream-position (physical-stream-position stream)) 79 ,@(loop 80 for slot in slots 81 collect (apply 'slot-reader-let-definition slot))) 82 (,(intern (format nil "MAKE-~a" name)) 83 :%physical-stream-position %physical-stream-position 84 ,@(loop 85 for slot in slots 86 appending (list 87 (intern (symbol-name (car slot)) :keyword) 88 (car slot)))))))) 89 90 (defgeneric enum-by-key (name key)) 91 (defgeneric enum-by-value (name value)) 92 93 (defmacro defenum (name args &rest values) 94 (declare (ignore args)) 95 `(progn 96 (defmethod enum-by-key ((name (eql ',name)) key) 97 (cdr (assoc key ',(loop 98 for (k v) in values 99 collect (cons k v))))) 100 (defmethod enum-by-value ((name (eql ',name)) value) 101 (cdr (assoc value ',(loop 102 for (k v) in values 103 collect (cons v k))))) 104 ,@(loop 105 for (k v) in values 106 collect `(defconstant ,k ,v)))) 107 108 ;;(enum-by-key 'RecordType 'RT_DocumentAtom) 109 ;;(enum-by-value 'RecordType #x03E9)