From 9ec42042a50403961c08179a892ae3de725b1d7a Mon Sep 17 00:00:00 2001 From: Frode Date: Fri, 2 Jul 2010 12:26:18 +0200 Subject: [PATCH] Copied to github --- COPYING | 26 ++ ChangeLog | 411 +++++++++++++++++++ Makefile | 41 ++ README | 174 ++++++++ README-bitfield | 52 +++ binary-types.asd | 30 ++ binary-types.lisp | 1180 +++++++++++++++++++++++++++++++++++++++++++++++++++++ example.lisp | 146 +++++++ 8 files changed, 2060 insertions(+) create mode 100644 COPYING create mode 100644 ChangeLog create mode 100644 Makefile create mode 100644 README create mode 100644 README-bitfield create mode 100644 binary-types.asd create mode 100644 binary-types.lisp create mode 100644 example.lisp diff --git a/COPYING b/COPYING new file mode 100644 index 0000000..497dbe4 --- /dev/null +++ b/COPYING @@ -0,0 +1,26 @@ +###################################################################### +## +## Copyright (C) 1999, +## Department of Computer Science, University of Tromsø, Norway +## +## Filename: COPYING +## Description: Defines the terms under which this software may be copied. +## Author: Frode Vatvedt Fjeld +## Created at: Mon Nov 8 20:32:12 1999 +## Distribution: See the accompanying file COPYING. +## +## $Id: COPYING,v 1.1.1.1 2004/01/13 11:13:13 ffjeld Exp $ +## +###################################################################### + +Redistribution and use in source and binary forms, with or without +modification, are permitted provided that the following conditions +are met: + 1. Redistributions of source code must retain the above copyright + notice, this list of conditions and the following disclaimer. + 2. Redistributions in binary form must reproduce the above copyright + notice, this list of conditions and the following disclaimer in the + documentation and/or other materials provided with the distribution. + 3. Neither the name of the University nor the names of its contributors + may be used to endorse or promote products derived from this software + without specific prior written permission. \ No newline at end of file diff --git a/ChangeLog b/ChangeLog new file mode 100644 index 0000000..87df894 --- /dev/null +++ b/ChangeLog @@ -0,0 +1,411 @@ +2003-12-11 Frode Vatvedt Fjeld + + * RELEASE: 0.90 + + * API CHANGE! Map-binary-write functions now receive two + arguments: The object (as before), and the name of the binary-type + the object is supposed to be mapped to. + + * Imroved README a bit. Documented :map-binary-read and + :map-binary-read-delayed. + + * Fixed bug as reported by Simon Leinen. Various minor + bug-fixes. Changed the defpackage form to use gensym names. + +2001-08-28 Frode Vatvedt Fjeld + + * binary-types.lisp: + Added utility functions SPLIT-BYTES and MERGE-BYTES that deals with + converting lists of bytes to new byte-sizes. + +2001-08-27 Frode Vatvedt Fjeld + + * binary-types.lisp: Added generic function READ-BINARY-RECORD so + that it may be specialized. + +2001-08-27 Frode Vatvedt Fjeld + + * binary-types.lisp: + Added function ENUM-SYMBOLIC-VALUE, the inverse of ENUM-VALUE. + +2001-08-27 Frode Vatvedt Fjeld + + * binary-types.lisp: Added :binary-tags slot-option. The argument + specifies a list of "tags" (intended to be symbols, but any lisp + objects will do) that will be associated with the slot. The + function BINARY-SLOT-TAGS will retrieve the set of tags for a + slot. The function BINARY-RECORD-SLOT-NAMES has been modified to + take the keyword argument :MATCH-TAGS so that only slots with at + least one of those tags are returned. + + The idea is that sometimes you need to iterate over a sub-set of + the slots, in which case a tag can be used to name and reference + such sub-sets. + +2001-08-24 Frode Vatvedt Fjeld + + * binary-types.lisp: Changed they expansion function of + DEFINE-BINARY-CLASS not to generate literal structure + objects. Expansions should be much "nicer" for the compiler to + handle now. + +2001-08-17 Frode Vatvedt Fjeld + + * binary-types.lisp: Added slot-options :MAP-ON-READ and + :MAP-ON-READ-DELAYED. The former is analogous to :MAP-ON-WRITE, + i.e. at BINARY-READ-time the function named is applied to the + (binary) value read, and the result is placed in the + slot. + + :MAP-ON-READ-DELAYED is a variation that delays the mapping + operation until the slot is read. Until that time, the slot is + unbound and the binary value kept in a "hidden" slot. [This is + implemented more or less seamlessly by specializing the + SLOT-UNBOUND method.] However, the "hidden" binary value can be + read using BINARY-SLOT-VALUE; this will not cause the mapping to + occur. The idea is that if you have slots that represent pointers + to other records, you probalby don't want the READ-BINARY + operation to automatically follow and recursively read such + pointers. Using this mechanism, objects referenced by pointers + will magically be loaded "on demand". + +2001-07-27 Frode Vatvedt Fjeld + + * binary-types.lisp: + Removed LET from DEFINE-BINARY-STRUCT expansion, making it a proper top-level-form. + +2001-07-27 Frode Vatvedt Fjeld + + * RELEASE: 0.84 + + * binary-types.lisp: Removed (superfluous) LET* from + DEFINE-BINARY-STRUCT's expansion, so as not to hinder such forms + from being proper top-level forms. + +2001-07-12 Frode Vatvedt Fjeld + + * RELEASE: 0.83 + + * binary-types.lisp: Fixed READ-BINARY-STRING to work correctly + for :SIZE 0. It will now return "" and 0, rather than entering + an infinite loop. + +2001-06-29 Frode Vatvedt Fjeld + + * RELEASE: 0.82 + + * binary-types.lisp: Added macro WITH-BINARY-OUTPUT-TO-VECTOR. + Supposed to resemble CL:WITH-OUTPUT-TO-STRING. + +2001-06-26 Frode Vatvedt Fjeld + + * binary-types.lisp: Fixed buggy function READ-BINARY-STRING. + +2001-06-22 Frode Vatvedt Fjeld + + * binary-types.lisp: Renamed many identifiers from xx-COMPUND-xx + to xx-RECORD-xx. Of the exported symbols, only two are changed: + WRITE-BINARY-RECORD, and BINARY-RECORD-SLOT-NAMES. A (binary) + record is either a lisp struct or class. + + * RELEASE: 0.81 + + * binary-types.lisp: Minor fixups to make BT work with CLISP. + +2001-06-20 Frode Vatvedt Fjeld + + * RELEASE: 0.80 + + * binary-types.lisp: Rewrote and renamed some the binary string + types. Macros DEFINE-BINARY-STRING and + DEFINE-NULL-TERMINATED-STRING should now be used to define string + types. + + * binary-types.lisp: Added function READ-BINARY-STRING that should + be general enough to read most kinds of strings. It still doesn't + do character sets, though. + + * binary-types.lisp: Removed traces of variable-sized binary + types. Everything is now constant-sized. Removed functions + SIZEOF-MIN and SIZEOF-MAX. + +2001-06-09 Frode Vatvedt Fjeld + + * binary-types.lisp: Removed one more instance of upcased symbols + in the code, in order to facilitate those using case-sensitive + readers. + +2001-06-06 Frode Vatvedt Fjeld + + * RELEASE: 0.76 + + * binary-types.lisp: Added macro WITH-BINARY-INPUT-FROM-VECTOR. + + * binary-types.lisp: Added check for end-of-list in + WITH-BINARY-INPUT-FROM-LIST macro. + + * Makefile: Forgot to include recently added file + type-hierarchy.ps in the distribution tarball. + +2001-05-03 Frode Vatvedt Fjeld + + * binary-types.lisp: Renamed the slot-options (the old ones still + work though). + :bt => :binary-type + :btt => :binary-lisp-type + :bt-on-write => :map-binary-write. + + * binary-types.lisp: Added a pseudo-type :LABEL available only + inside DEFINE-BINARY-CLASS and which is a void type intended for + "slots" that don't hold any data but are used as labels in the + struct in order to determine offsets etc. If this type is declared + with the :btt (or :binary-lisp-type) slot-option, the lisp :type + NIL is declared (the empty type). + +2001-04-24 Frode Vatvedt Fjeld + + * RELEASE: 0.75 + +2001-04-23 Frode Vatvedt Fjeld + + * type-hierarchy.ps: Added. This is a postscript file displaying + the type (meta-) hierarchy, for reference. + +2001-04-22 Frode Vatvedt Fjeld + + * binary-types.lisp: Added macro WITH-BINARY-INPUT-FROM-LIST that + sets up a "stream" variable suitable for READ-BINARY that provides + 8-bit bytes from a list of integers. + +2001-04-12 Frode Vatvedt Fjeld + + * RELEASE: 0.74 + + * binary-types.lisp: The previous fix for DEFINE-BINARY-STRUCT's + lambda list was wrong. Hopefully this actually fixes it. + +2001-04-11 Frode Vatvedt Fjeld + + * RELEASE: 0.73 + + * binary-types.lisp: Changed in DEFINE-BINARY-STRUCT a (format + "MAKE-~A" name) to (format "~A-~A" '#:make name), which should + allow for lower-case lisps to work. + + * binary-types.lisp: Modified DEFINE-BINARY-STRUCT's macro + lambda-list slightly to accommodate a bug in clisp. (This + shouldn't affect other systems at all.) + +2001-03-29 Frode Vatvedt Fjeld + + * RELEASE: 0.72. + +2001-03-28 Frode Vatvedt Fjeld + + * binary-types.lisp: Added macro WITH-BINARY-OUTPUT-TO-LIST that, + given a stream variable S, evaluates its body such that calls to + WRITE-BINARY to stream S collects in a list the individual bytes + as integers. This list is returned by the macro form. + + * binary-types.lisp: Added two dynamic variables that allows you + to override the low-level IO functions binary-types use to read + and write single octets: *BINARY-READ-BYTE* and + *BINARY-WRITE-BYTE*, respectively. They default to the standard CL + functions READ-BYTE and WRITE-BYTE, and you may rebind them to any + function with the same signature. + + * binary-types.lisp: Fixed bug in the expansion of + DEFINE-BINARY-STRUCT that caused nested declarations not to + work. This bug even made example.lisp not work. Sigh. + +2001-02-19 Frode Vatvedt Fjeld + + * RELEASE: 0.71. + + * README: Revamped the documentation somewhat. Fixed up some + inconsistencies etc. + +2001-02-13 Frode Vatvedt Fjeld + + * binary-types.lisp: Changed some more syntax (slightly) in order + to be more consistent with CL syntax. Specifically, + DEFINE-BITFIELD now requires parens around the storage-type (as + does DEFINE-ENUM). + + * example.lisp: Changed to reflext new syntax. + +2001-02-12 Frode Vatvedt Fjeld + + * binary-types.lisp: Changed syntax of DEFINE-ENUM. The + storage-type must be put in braces, and you may optionally specify + the :byte. + + * binary-types.lisp: Added function ENUM-VALUE. + +2000-11-01 Frode Vatvedt Fjeld + + * binary-types.lisp: Changed COMPOUND-SLOT-NAMES to not include + padding slots, unless explicity requested. + + * binary-types.lisp: Added method WRITE-BINARY-COMPOUND that is + like WRITE-BINARY only it will automatically look up the correct + binary-type from the object, and it only works on compounds (that + is, binary-classes and binary-structs). + +2000-10-31 Frode Vatvedt Fjeld + + * binary-types.lisp: Added slot-option :on-write, that provides a + function that will be called (at binary-writing time) on the + slot's value to obtain the actual value that is written. + +2000-10-26 Frode Vatvedt Fjeld + + * RELEASE: 0.70. + + * binary-types.lisp: Renamed DEF-BINCLASS to DEFINE-BINARY-CLASS, + and DEF-BINSTRUCT to DEFINE-BINARY-STRUCT, and DEF-* to DEFINE-*. + + * binary-types.lisp: Added a variation of the :BT slot-option. It + is named :BTT, and will have the extra effect of adding a :TYPE + slot-option to the class or struct slot. Be careful when using + this in DEF-BINSTRUCT to provide an slot-initform that is of the + correct type! + + * binary-types.lisp: Changed the way nested declarations are + expanded. Now, even nested declarations will (in the expansion) + become top-level forms, I believe. This means that the + type-specifiers (the place after :BT in e.g. DEF-BINCLASS) is no + longer really evaluated, rather it is parsed by the + macro-expander. This means you no longer have to quote the + type-names (See "example.lisp"). Bitfield types are represented + symbolically by lists, so they are all of the lisp-type + "list". Fixed-size-nt-strings are equivalent to lisp strings (they + should really be strings of a maximum size, but lisp can't easily + express that concept). Also note that padding binary types which + are named by integer objects don't translate to lisp types at + all. This is just fine, I think, since padding "slots" are not + supposed to hold any lisp data. + + * binary-types.lisp: Added DEFTYPE declarations so that all + binary-types also become lisp-types. For example, if you declare + (def-unsigned raw-number 1), you implicitly declare a lisp + type-specifier RAW-NUMBER that is equivalent to (integer 0 255). + +2000-10-25 Frode Vatvedt Fjeld + + * RELEASE: 0.61 + + * binary-types.lisp: Fixed bug in READ-BINARY for signed integers. + + * binary-types.lisp: Added a WRITE-BINARY for binary-type + fixed-size-nt-string. Hopefully, read/write symmetry is complete + now. At least it should be possible to write the elf-header from + example.lisp. + + * binary-types.lisp: Added DEF-BINSTRUCT macro, which is (supposed + to be) to DEFSTRUCT what DEF-BINCLASS is to DEFCLASS. If nothing + else, structs prints and reads more easily than classes. See the + definition of E-IDENT in the updated example.lisp. + +2000-10-24 Frode Vatvedt Fjeld + + * binary-types.lisp: Added class-option for DEF-BINCLASS + :class-slot-align that allows you to adjust the offsets by + declaring the offset of one slot. Like this + (:class-slot-align slot-name offset) + + * binary-types.lisp: Added a class-option for DEF-BINCLASS, + :class-slot-offset , that specifies an offset to add to + any slot-offset as returned by SLOT-OFFSET. + + * README-bitfield: This is my response to a query about how + DEF-BITFIELD works, included here to provide some documentation. + +2000-10-23 Frode Vatvedt Fjeld + + * RELEASE: 0.50 + + * binary-types.lisp: Added a macro WITH-BINARY-FILE that is a thin + wrapper around WITH-OPEN-FILE that tries to force the stream to + have the correct element-type. + +2000-10-22 Frode Vatvedt Fjeld + + * binary-types.lisp: Changed syntax of DEF-BINCLASS again, so that + it now completely matches the DEFCLASS syntax, only you have one + extra slot-option, :BT, which declares the slot's + binary-type. This slot-option is evaluated, so you may still have + nested declarations. What is new is that you may have slots that + don't have a binary-type. Such slots are simply ignored by + READ-BINARY and WRITE-BINARY. + +2000-10-21 Frode Vatvedt Fjeld + + * binary-types.lisp: Added COMPOUND-SLOT-NAMES, to replace + COMPOUND-ALIST and COMPOUND-MERGE which are now deprecated (the + functions are still there, but their symbols are no longer + exported..). + + * binary-types.lisp: Changed the two BITFIELD-COMPUTE-XX-VALUE + from generic to regular functions (no reason for these to be + generic functions). + +2000-10-20 Frode Vatvedt Fjeld + + * example.lisp: Changed the example ELF header declaration to work + with the slightly changed syntax. Basically, all slots' type-field + is evaluated, so type-names (symbols) must be quoted. + + * binary-types.lisp: Renamed DEF-COMPOUND to DEF-BINCLASS, and + changed the syntax so it looks more like DEFCLASS. + + * binary-types.lisp: Added the capability of binary-integers to be + declared a certain endianess. So an integer is either :BIG-ENDIAN + or :LITTLE-ENDIAN (regardless of *ENDIAN*), or it depends + dynamically on the value of *ENDIAN*. The DEF-INTEGER macros now + takes and optional endianess argument. + + * binary-types.lisp: Changed the (previously very ugly) + implementation of the binary-types name-space. Now use the new + accessor FIND-BINARY-TYPE which is implemented with a simple + hash-table. This means that BINARY TYPES MUST NOW BE NAMED BY + SYMBOLS (binary-types no longer touches the symbol-value of + symbols). + + * binary-types.lisp: Removed generic function BIT-SIZEOF, since we + only deal with octets anyway. + + * binary-types.lisp: Changed *ENDIAN* to take keyword symbols + :BIG-ENDIAN or :LITTLE-ENDIAN (old BT-interned symbols still + work). + +2000-08-25 Frode Vatvedt Fjeld + + * binary-types.lisp: Fixed reading of signed integers. + +2000-06-13 Frode Vatvedt Fjeld + + * README: Added a little more documentation. + + * example.lisp: Cleaned up some small things. + +2000-03-30 Frode Vatvedt Fjeld + + * binary-types.lisp: Added write support for bitfield. + + * binary-types.lisp: Changed the bitfield type to use proper CL + "bytes" for subfields. + +1999-12-08 Frode Vatvedt Fjeld + + * test.lisp: Added this file for tests of the BINARY-TYPES + package. Not much in it so far. + + * binary-types.lisp: Fixed READ-BINARY for signed integers so it + actually works. + + * binary-types.lisp: Added WRITE-BINARY for integers, char8, + padding, and compound. + + * ChangeLog: Started + diff --git a/Makefile b/Makefile new file mode 100644 index 0000000..d6e1cbe --- /dev/null +++ b/Makefile @@ -0,0 +1,41 @@ +###################################################################### +## +## Copyright (C) 2001,2000,1999, 2003 +## Department of Computer Science, University of Tromsø, Norway +## +## Filename: Makefile +## Author: Frode Vatvedt Fjeld +## Created at: Wed Sep 29 19:28:52 1999 +## +## $Id: Makefile,v 1.1.1.1 2004/01/13 11:13:13 ffjeld Exp $ +## +###################################################################### + +SCP = scp -oProtocol=1 +SSH = ssh -1 +DIST_EXTRAS = README README-bitfield ChangeLog COPYING type-hierarchy.ps type-hierarchy.png + +dist: binary-types.lisp $(DIST_EXTRAS) + @ if [ ! "${VER}" ]; then echo 'You must set $$VER!'; exit 5; fi + mkdir binary-types-$(VER) + cp *.lisp $(DIST_EXTRAS) binary-types-$(VER) + tar czf binary-types-$(VER).tar.gz binary-types-$(VER) + rm -rf binary-types-$(VER) + +updist: dist + - $(SSH) www.stud "mv www/sw/binary-types/*.tar.gz www/sw/binary-types/old" + $(SCP) binary-types-$(VER).tar.gz www.stud:www/sw/binary-types/ + $(SCP) $(DIST_EXTRAS) www.stud:www/sw/binary-types/ + @ echo "Remember cvs TAG REL_x_xx" + +repdist: dist + - $(SSH) www.stud "rm www/sw/binary-types/*.tar.gz" + $(SCP) binary-types-$(VER).tar.gz www.stud:www/sw/binary-types/ + $(SCP) $(DIST_EXTRAS) www.stud:www/sw/binary-types/ + @ echo "Remember cvs TAG REL_x_xx" + +clean: + rm -f *.fasl memdump *~ + +force: + diff --git a/README b/README new file mode 100644 index 0000000..a9dd259 --- /dev/null +++ b/README @@ -0,0 +1,174 @@ +###################################################################### +## +## Copyright (C) 2001,2000, 2003 +## Department of Computer Science, University of Tromsø, Norway +## +## Filename: README +## Author: Frode Vatvedt Fjeld +## Created at: Wed Dec 8 15:35:53 1999 +## Distribution: See the accompanying file COPYING. +## +## $Id: README,v 1.1.1.1 2004/01/13 11:13:13 ffjeld Exp $ +## +###################################################################### + +Binary-types is a Common Lisp package for reading and writing binary +files. Binary-types provides macros that are used to declare the +mapping between lisp objects and some binary (i.e. octet-based) +representation. + +Supported kinds of binary types include: + + * Signed and unsigned integers of any octet-size, big-endian or + little-endian. Maps to lisp integers. + + * Enumerated types based on any integer type. Maps to lisp symbols. + + * Complex bit-field types based on any integer type. Sub-fields can + be numeric, enumerated, or bit-flags. Maps to lisp lists of symbols + and integers. + + * Fixed-length and null-terminated strings. Maps to lisp strings. + + * Compound records of other binary types. Maps to lisp DEFCLASS + classes or, when you prefer, DEFSTRUCT structs. + +Typically, a complete binary record format/type can be specified in a +single (nested) declaration statement. Such compound records may then +be read and written with READ-BINARY and WRITE-BINARY. + +Binary-types is *not* helpful in reading files with variable +bit-length code-words, such as most compressed file formats. It will +basically only work with file-formats based on 8-bit bytes +(octets). Also, at this time no floating-point types are supported out +of the box. + +Binary types may now be declared with the DEFINE-BINARY-CLASS macro, +which has the same syntax (and semantics) as DEFCLASS, only there is +an additional slot-option (named :BINARY-TYPE) that declares that +slot's binary type. Note that the binary aspects of slots are *not* +inherited (the semantics of inheriting binary slots is unclear to me). + +Another slot-option added by binary-types is :MAP-BINARY-WRITE, which +names a function (of two arguments) that is applied to the slot's +value and the name of the slot's binary-type in order to obtain the +value that is actually passed to WRITE-BINARY. Similarly, +:MAP-BINARY-READ takes a function that is to be applied to the binary +data and type-name when a record of that type is being read. A +slightly modified version of :map-binary-read is +:MAP-BINARY-READ-DELAYED, which will do essentially the same thing as +:map-binary-read, only the mapping will be "on-demand": A slot-unbound +method will be created for this purpose. + +A variation of the :BINARY-TYPE slot-option is :BINARY-LISP-TYPE, +which does everything :BINARY-TYPE does, but also passes on a :TYPE +slot-option to DEFCLASS (or DEFSTRUCT). The type-spec is inferred +from the binary-type declaration. When using this mechanism, you +should be careful to always provide a legal value in the slot (as you +must always do when declaring slots' types). If you find this +confusing, just use :BINARY-TYPE. + +Performance has not really been a concern for me while designing this +package. There's no obvious performance bottlenecks that I know of, +but keep in mind that all "binary" reads and writes are reduced to +individual 8-bit READ-BYTEs and WRITE-BYTEs. If you do identify +particular performance bottlenecks, let me know. + +The included file "example.lisp" demonstrates how to use this +package. To give you a taste of what it looks like, the following +declarations are enough to read the header of an ELF executable file +with the form + + (let ((*endian* :big-endian)) + (read-binary 'elf-header stream) + + +;;; ELF basic type declarations +(define-unsigned word 4) +(define-signed sword 4) +(define-unsigned addr 4) +(define-unsigned off 4) +(define-unsigned half 2) + +;;; ELF file header structure +(define-binary-class elf-header () + ((e-ident + :binary-type (define-binary-struct e-ident () + (ei-magic nil :binary-type + (define-binary-struct ei-magic () + (ei-mag0 0 :binary-type u8) + (ei-mag1 #\null :binary-type char8) + (ei-mag2 #\null :binary-type char8) + (ei-mag3 #\null :binary-type char8))) + (ei-class nil :binary-type + (define-enum ei-class (u8) + elf-class-none 0 + elf-class-32 1 + elf-class-64 2)) + (ei-data nil :binary-type + (define-enum ei-data (u8) + elf-data-none 0 + elf-data-2lsb 1 + elf-data-2msb 2)) + (ei-version 0 :binary-type u8) + (padding nil :binary-type 1) + (ei-name "" :binary-type + (define-null-terminated-string ei-name 8)))) + (e-type + :binary-type (define-enum e-type (half) + et-none 0 + et-rel 1 + et-exec 2 + et-dyn 3 + et-core 4 + et-loproc #xff00 + et-hiproc #xffff)) + (e-machine + :binary-type (define-enum e-machine (half) + em-none 0 + em-m32 1 + em-sparc 2 + em-386 3 + em-68k 4 + em-88k 5 + em-860 7 + em-mips 8)) + (e-version :binary-type word) + (e-entry :binary-type addr) + (e-phoff :binary-type off) + (e-shoff :binary-type off) + (e-flags :binary-type word) + (e-ehsize :binary-type half) + (e-phentsize :binary-type half) + (e-phnum :binary-type half) + (e-shentsize :binary-type half) + (e-shnum :binary-type half) + (e-shstrndx :binary-type half))) + + +For a second example, here's an approach to supporting floats: + + (define-bitfield ieee754-single-float (u32) + (((:enum :byte (1 31)) + positive 0 + negative 1) + ((:numeric exponent 8 23)) + ((:numeric significand 23 0)))) + + + + +The postscript file "type-hierarchy.ps" shows the binary types +hierarchy. It is generated using psgraph from the CMU lisp +repository: + + (with-open-file (*standard-output* "type-hierarchy.ps" + :direction :output + :if-exists :supersede) + (psgraph:psgraph 'binary-type + #'(lambda (p) + (mapcar #'class-name + (aclmop:class-direct-subclasses + (find-class p)))) + #'(lambda (s) (list (symbol-name s))) + t)) diff --git a/README-bitfield b/README-bitfield new file mode 100644 index 0000000..420cb86 --- /dev/null +++ b/README-bitfield @@ -0,0 +1,52 @@ + +> My only problem is with DEF-BITFIELD. All other BINARY-TYPES +> features are intuitive and easy to use. + +Hi, you are right that DEF-BITFIELD is poorly documented. I think +that's because it's a bit complex and I'm not quite confident it is +the way it should be. Anyways, here are a couple of examples: + +(define-bitfield r-info (u32) + (((:enum :byte (8 0)) + r-386-none 0 + r-386-32 1 + r-386-pc32 2 + r-386-got32 3 + r-386-plt32 4 + r-386-copy 5 + r-386-glob-dat 6 + r-386-jmp-slot 7 + r-386-relative 8 + r-386-gotoff 9 + r-386-gotpc 10) + ((:numeric r-sym 24 8)))) + +This declares R-INFO to be an unsigned 32-bit number, divided into two +fields. The first field resides in bits 0-7, and is one of the values +r-386-xx. The second field is a numeric value that resides in bits +8-23. So this type R-INFO may for example have symbolic value +(r-386-pc32 (r-sym . 1)), which translates to a numeric value of + (logior 2 1<<8)) = 258. + +Another example: + +(define-bitfield p-flags (u8) + (((:bits) + pf-x 0 + pf-w 1 + pf-r 2))) + +Here P-FLAGS has just one bit-field, where bit 0 is named PF-X, bit 1 +is named PF-W etc. So the value (PF-X PF-R) maps to 5. + +As you may see by now, DEF-BITFIELD divides a numeric base-type +(typically an unsigned integer) into a number of fields, where each +field is one of :BITS for bitmaps, :ENUM for an enumerated field +(takes an optional :BYTE ), and finally :NUMERIC + for a subfield that is a number. + +Hope this helps. + +-- +Frode Vatvedt Fjeld + diff --git a/binary-types.asd b/binary-types.asd new file mode 100644 index 0000000..53b12a0 --- /dev/null +++ b/binary-types.asd @@ -0,0 +1,30 @@ +;;;; -*- Mode: Lisp; Syntax: ANSI-Common-Lisp; Base: 10 -*- +;;;;------------------------------------------------------------------ +;;;; +;;;; Copyright (C) 2008, Frode V. Fjeld +;;;; +;;;; For distribution policy, see the accompanying file COPYING. +;;;; +;;;; Filename: movitz.asd +;;;; Description: Movitz ASDF system definition. +;;;; Author: Frode Vatvedt Fjeld +;;;; Created at: Thu Jan 15 18:40:58 2004 +;;;; +;;;; $Id: binary-types.asd,v 1.2 2008/02/25 23:43:24 ffjeld Exp $ +;;;; +;;;;------------------------------------------------------------------ + +(defpackage binary-types-asd + (:use :cl :asdf)) + +(in-package binary-types-asd) + +(defsystem binary-types + :name "Binary-types" + :maintainer "ffjeld@common-lisp.net" + :author "Frode V. Fjeld" + :license "BSD-like, see accopanying file COPYING." + :description "A library for reading and writing binary records." + :perform (load-op :after (op c) + (provide 'binary-types)) + :components ((:file "binary-types"))) diff --git a/binary-types.lisp b/binary-types.lisp new file mode 100644 index 0000000..b5bf6f4 --- /dev/null +++ b/binary-types.lisp @@ -0,0 +1,1180 @@ +;;;;------------------------------------------------------------------ +;;;; +;;;; Copyright (C) 1999-2004, +;;;; Department of Computer Science, University of Tromsoe, Norway +;;;; +;;;; Filename: binary-types.lisp +;;;; Description: Reading and writing of binary data in streams. +;;;; Author: Frode Vatvedt Fjeld +;;;; Created at: Fri Nov 19 18:53:57 1999 +;;;; Distribution: See the accompanying file COPYING. +;;;; +;;;; $Id: binary-types.lisp,v 1.3 2004/04/20 08:32:50 ffjeld Exp $ +;;;; +;;;;------------------------------------------------------------------ + +(defpackage #:binary-types + (:nicknames #:bt) + (:use #:common-lisp) + (:export #:*endian* ; [dynamic-var] must be bound when reading integers + #:endianess ; [deftype] The set of endian names + ;; built-in types + #:char8 ; [type-name] 8-bit character + #:u8 ; [type-name] 8-bit unsigned integer + #:u16 ; [type-name] 16-bit unsigned integer + #:u32 ; [type-name] 32-bit unsigned integer + #:s8 ; [type-name] 8-bit signed integer + #:s16 ; [type-name] 16-bit signed integer + #:s32 ; [type-name] 32-bit signed integer + ; (you may define additional integer types + ; of any size yourself.) + ;; type defining macros + #:define-unsigned ; [macro] declare an unsigned-int type + #:define-signed ; [macro] declare a signed-int type + #:define-binary-struct ; [macro] declare a binary defstruct type + #:define-binary-class ; [macro] declare a binary defclass type + #:define-bitfield ; [macro] declare a bitfield (symbolic integer) type + #:define-enum ; [macro] declare an enumerated type + #:define-binary-string ; [macro] declare a string type + #:define-null-terminated-string ; [macro] declare a null-terminated string + ;; readers and writers + #:read-binary ; [func] reads a binary-type from a stream + #:read-binary-record ; [method] + #:write-binary ; [func] writes an binary object to a stream + #:write-binary-record ; [method] + #:read-binary-string + ;; record handling + #:binary-record-slot-names ; [func] list names of binary slots. + #:binary-slot-value ; [func] get "binary" version of slot's value + #:binary-slot-type ; [func] get binary slot's binary type + #:binary-slot-tags ; [func] get the tags of a binary slot + #:slot-offset ; [func] determine offset of slot. + ;; misc + #:find-binary-type ; [func] accessor to binary-types namespace + #:sizeof ; [func] The size in octets of a binary type + #:enum-value ; [func] Calculate numeric version of enum value + #:enum-symbolic-value ; [func] Inverse of enum-value. + #:with-binary-file ; [macro] variant of with-open-file + #:with-binary-output-to-list ; [macro] + #:with-binary-output-to-vector ; [macro] + #:with-binary-input-from-list ; [macro] + #:with-binary-input-from-vector ; [macro] + #:*binary-write-byte* ; [dynamic-var] + #:*binary-read-byte* ; [dynamic-var] + #:*padding-byte* ; [dynamic-var] The value filled in when writing paddings + #:split-bytes ; [func] utility + #:merge-bytes ; [func] utility + )) + +(in-package binary-types) + +(defvar *ignore-hidden-slots-for-pcl* nil + "Really ugly hack to allow older PCL-infested lisps to work in the +precense of :map-binary-read-delayed.") + +(defvar *binary-write-byte* #'common-lisp:write-byte + "The low-level WRITE-BYTE function used by binary-types.") +(defvar *binary-read-byte* #'common-lisp:read-byte + "The low-level READ-BYTE function used by binary-types.") + +;;; ---------------------------------------------------------------- +;;; Utilities +;;; ---------------------------------------------------------------- + +(defun make-pairs (list) + "(make-pairs '(1 2 3 4)) => ((1 . 2) (3 . 4))" + (loop for x on list by #'cddr collect (cons (first x) (second x)))) + +;;; ---------------------------------------------------------------- +;;; +;;; ---------------------------------------------------------------- + +(eval-when (:compile-toplevel :load-toplevel :execute) + (deftype endianess () + "These are the legal declarations of endianess. The value NIL +means that the endianess is determined by the dynamic value of *endian*." + '(member nil :big-endian :little-endian))) + +(defvar *endian* nil + "*endian* must be (dynamically) bound to either :big-endian or +:little-endian while reading endian-sensitive types.") + +;;; ---------------------------------------------------------------- +;;; Binary Types Namespace +;;; ---------------------------------------------------------------- + +(defvar *binary-type-namespace* (make-hash-table :test #'eq) + "Maps binary type's names (which are symbols) to their binary-type class object.") + +(defun find-binary-type (name &optional (errorp t)) + (or (gethash name *binary-type-namespace*) + (if errorp + (error "Unable to find binary type named ~S." name) + nil))) + +(defun (setf find-binary-type) (value name) + (check-type value binary-type) + (let ((old-value (find-binary-type name nil))) + (when (and old-value (not (eq (class-of value) (class-of old-value)))) + (warn "Redefining binary-type ~A from ~A to ~A." + name (type-of old-value) (type-of value)))) + (setf (gethash name *binary-type-namespace*) value)) + +(defun find-binary-type-name (type) + (maphash #'(lambda (key val) + (when (eq type val) + (return-from find-binary-type-name key))) + *binary-type-namespace*)) + +;;; ---------------------------------------------------------------- +;;; Base Binary Type (Abstract) +;;; ---------------------------------------------------------------- + +(defgeneric sizeof (type) + (:documentation "Return the size in octets of the single argument TYPE, +or nil if TYPE is not constant-sized.")) + +(defmethod sizeof (obj) + (sizeof (find-binary-type (type-of obj)))) + +(defmethod sizeof ((type symbol)) + (sizeof (find-binary-type type))) + +(defgeneric read-binary (type stream &key &allow-other-keys) + (:documentation "Read an object of binary TYPE from STREAM.")) + +(defmethod read-binary ((type symbol) stream &rest key-args) + (apply #'read-binary (find-binary-type type) stream key-args)) + +(defgeneric write-binary (type stream object &key &allow-other-keys) + (:documentation "Write an OBJECT of TYPE to STREAM.")) + +(defmethod write-binary ((type symbol) stream object &rest key-args) + (apply #'write-binary (find-binary-type type) stream object key-args)) + +(defclass binary-type () + ((name + :initarg name + :initform '#:anonymous-binary-type + :reader binary-type-name) + (sizeof + :initarg sizeof + :reader sizeof)) + (:documentation "BINARY-TYPE is the base class for binary types meta-classes.")) + +(defmethod print-object ((object binary-type) stream) + (print-unreadable-object (object stream :type 'binary-type) + (format stream "~A" (binary-type-name object)))) + +;;; ---------------------------------------------------------------- +;;; Integer Type (Abstract) +;;; ---------------------------------------------------------------- + +(defclass binary-integer (binary-type) + ((endian :type endianess + :reader binary-integer-endian + :initarg endian + :initform nil))) + +(defmethod print-object ((type binary-integer) stream) + (if (not *print-readably*) + (print-unreadable-object (type stream :type t) + (format stream "~D-BIT~@[ ~A~] INTEGER TYPE: ~A" + (* 8 (slot-value type 'sizeof)) + (slot-value type 'endian) + (binary-type-name type))) + (call-next-method type stream))) + +;;; WRITE-BINARY is identical for SIGNED and UNSIGNED, but READ-BINARY +;;; is not. + +(defmethod write-binary ((type binary-integer) stream object &key &allow-other-keys) + (check-type object integer) + (if (= 1 (sizeof type)) + (progn (funcall *binary-write-byte* object stream) 1) + (ecase (or (binary-integer-endian type) + *endian*) + ((:big-endian big-endian) + (do ((i (* 8 (1- (sizeof type))) (- i 8))) + ((minusp i) (sizeof type)) + (funcall *binary-write-byte* (ldb (byte 8 i) object) stream))) + ((:little-endian little-endian) + (dotimes (i (sizeof type)) + (funcall *binary-write-byte* (ldb (byte 8 (* 8 i)) object) stream)) + (sizeof type))))) + +;;; ---------------------------------------------------------------- +;;; Unsigned Integer Types +;;; ---------------------------------------------------------------- + +(defclass binary-unsigned (binary-integer) ()) + +(defmacro define-unsigned (name size &optional endian) + (check-type size (integer 1 *)) + (check-type endian endianess) + `(progn + (deftype ,name () '(unsigned-byte ,(* 8 size))) + (setf (find-binary-type ',name) + (make-instance 'binary-unsigned + 'name ',name + 'sizeof ,size + 'endian ,endian)) + ',name)) + +(define-unsigned u8 1) +(define-unsigned u16 2) +(define-unsigned u32 4) + +(defmethod read-binary ((type binary-unsigned) stream &key &allow-other-keys) + (if (= 1 (sizeof type)) + (values (funcall *binary-read-byte* stream) + 1) + (let ((unsigned-value 0)) + (ecase (or (binary-integer-endian type) + *endian*) + ((:big-endian big-endian) + (dotimes (i (sizeof type)) + (setf unsigned-value (+ (* unsigned-value #x100) + (funcall *binary-read-byte* stream) + )))) + ((:little-endian little-endian) + (dotimes (i (sizeof type)) + (setf unsigned-value (+ unsigned-value + (ash (funcall *binary-read-byte* stream) + (* 8 i))))))) + (values unsigned-value + (sizeof type))))) + +;;; ---------------------------------------------------------------- +;;; Twos Complement Signed Integer Types +;;; ---------------------------------------------------------------- + +(defclass binary-signed (binary-integer) ()) + +(defmacro define-signed (name size &optional (endian nil)) + (check-type size (integer 1 *)) + (check-type endian endianess) + `(progn + (deftype ,name () '(signed-byte ,(* 8 size))) + (setf (find-binary-type ',name) + (make-instance 'binary-signed + 'name ',name + 'sizeof ,size + 'endian ,endian)) + ',name)) + +(define-signed s8 1) +(define-signed s16 2) +(define-signed s32 4) + +(defmethod read-binary ((type binary-signed) stream &key &allow-other-keys) + (let ((unsigned-value 0)) + (if (= 1 (sizeof type)) + (setf unsigned-value (funcall *binary-read-byte* stream)) + (ecase (or (binary-integer-endian type) + *endian*) + ((:big-endian big-endian) + (dotimes (i (sizeof type)) + (setf unsigned-value (+ (* unsigned-value #x100) + (funcall *binary-read-byte* stream) + )))) + ((:little-endian little-endian) + (dotimes (i (sizeof type)) + (setf unsigned-value (+ unsigned-value + (ash (funcall *binary-read-byte* stream) + (* 8 i)))))))) + (values (if (>= unsigned-value (ash 1 (1- (* 8 (sizeof type))))) + (- unsigned-value (ash 1 (* 8 (sizeof type)))) + unsigned-value) + (sizeof type)))) + +;;; ---------------------------------------------------------------- +;;; Character Types +;;; ---------------------------------------------------------------- + +;;; There are probably lots of things one _could_ do with character +;;; sets etc.. + +(defclass binary-char8 (binary-type) ()) + +(setf (find-binary-type 'char8) + (make-instance 'binary-char8 + 'name 'char8 + 'sizeof 1)) + +(deftype char8 () 'character) + +(defmethod read-binary ((type binary-char8) stream &key &allow-other-keys) + (values (code-char (read-binary 'u8 stream)) + 1)) + +(defmethod write-binary ((type binary-char8) stream object &key &allow-other-keys) + (write-binary 'u8 stream (char-code object))) + +;;; ---------------------------------------------------------------- +;;; Padding Type (Implicitly defined and named by integers) +;;; ---------------------------------------------------------------- + +;;; The padding type of size 3 octets is named by the integer 3, and +;;; so on. + +(defmethod sizeof ((type integer)) type) + +(defmethod read-binary ((type integer) stream &key &allow-other-keys) + (dotimes (i type) + (read-binary 'u8 stream)) + (values nil type)) + +(defvar *padding-byte* #x00 + "The value written to padding octets.") + +(defmethod write-binary ((type integer) stream object &key &allow-other-keys) + (declare (ignore object)) + (check-type *padding-byte* (unsigned-byte 8)) + (dotimes (i type) + (write-binary 'u8 stream *padding-byte*)) + type) + +;;; ---------------------------------------------------------------- +;;; String library functions +;;; ---------------------------------------------------------------- + +(defun read-binary-string (stream &key size terminators) + "Read a string from STREAM, terminated by any member of the list TERMINATORS. +If SIZE is provided and non-nil, exactly SIZE octets are read, but the returned +string is still terminated by TERMINATORS. The string and the number of octets +read are returned." + (check-type size (or null (integer 0 *))) + (check-type terminators list) + (assert (or size terminators) (size terminators) + "Can't read a binary-string without a size limitation nor terminating bytes.") + (let (bytes-read) + (values (with-output-to-string (string) + (loop with string-terminated = nil + for count upfrom 0 + until (if size (= count size) string-terminated) + do (let ((byte (funcall *binary-read-byte* stream))) + (cond + ((member byte terminators :test #'=) + (setf string-terminated t)) + ((not string-terminated) + (write-char (code-char byte) string)))) + finally (setf bytes-read count))) + bytes-read))) + +;;; ---------------------------------------------------------------- +;;; String Types +;;; ---------------------------------------------------------------- + +(defclass binary-string (binary-type) + ((terminators + :initarg terminators + :reader binary-string-terminators))) + +(defmacro define-binary-string (type-name size &key terminators) + (check-type size (integer 1 *)) + `(progn + (deftype ,type-name () 'string) + (setf (find-binary-type ',type-name) + (make-instance 'binary-string + 'name ',type-name + 'sizeof ,size + 'terminators ,terminators)) + ',type-name)) + +(defmacro define-null-terminated-string (type-name size) + `(define-binary-string ,type-name ,size :terminators '(0))) + +(defmacro define-fixed-size-nt-string (type-name size) + ;; compatibility.. + `(define-null-terminated-string ,type-name ,size)) + +(defmethod read-binary ((type binary-string) stream &key &allow-other-keys) + (read-binary-string stream + :size (sizeof type) + :terminators (binary-string-terminators type))) + +(defmethod write-binary ((type binary-string) stream obj &key &allow-other-keys) + (check-type obj string) + (dotimes (i (sizeof type)) + (if (< i (length obj)) + (funcall *binary-write-byte* (char-code (aref obj i)) stream) + (funcall *binary-write-byte* + ;; use the first member of TERMINATORS as writing terminator. + (or (first (binary-string-terminators type)) 0) + stream))) + (sizeof type)) + +;;; ---------------------------------------------------------------- +;;; Record Types ("structs") +;;; ---------------------------------------------------------------- + +;;;(defstruct compound-slot +;;; name +;;; type +;;; on-write) + +;;;(defun make-record-slot (&key name type map-write) +;;; (list name type map-write map-read)) +;;; +;;;(defun record-slot-name (s) (first s)) +;;;(defun record-slot-type (s) (second s)) +;;;(defun record-slot-on-write (s) (third s)) + +(eval-when (:load-toplevel :compile-toplevel) + (defstruct record-slot + name + type + map-write + map-read + map-read-delayed + hidden-read-slot + tags)) ; for map-read-delayed, the binary value is stored here. + +(defmethod make-load-form ((object record-slot) &optional environment) + (declare (ignore environment)) + (with-slots (name type map-write map-read map-read-delayed hidden-read-slot) + object + `(make-record-slot :name ',name + :type ',type + :map-write ,map-write + :map-read ,map-read + :map-read-delayed ,map-read-delayed + :hidden-read-slot ',hidden-read-slot))) + +(defclass binary-record (binary-type) + ((slots + :initarg slots + :accessor binary-record-slots) + (offset + :initarg offset + :reader binary-record-slot-offset))) + +(defclass binary-class (binary-record) + ;; a DEFCLASS class with binary properties + ((instance-class + :type standard-class + :initarg instance-class))) + +(defmethod binary-record-make-instance ((type binary-class)) + (make-instance (slot-value type 'instance-class))) + +(defclass binary-struct (binary-record) + ;; A DEFSTRUCT type with binary properties + ((constructor :initarg constructor))) + +(defmethod binary-record-make-instance ((type binary-struct)) + (funcall (slot-value type 'constructor))) + +(defun slot-offset (type slot-name) + "Return the offset (in number of octets) of SLOT-NAME in TYPE." + (unless (typep type 'binary-record) + (setf type (find-binary-type type))) + (check-type type binary-record) + (unless (find-if #'(lambda (slot) + (eq slot-name (record-slot-name slot))) + (binary-record-slots type)) + (error "Slot ~S doesn't exist in type ~S." + slot-name type)) + (+ (binary-record-slot-offset type) + (loop for slot in (binary-record-slots type) + until (eq slot-name (record-slot-name slot)) + summing (sizeof (record-slot-type slot))))) + +(defun binary-slot-tags (type slot-name) + (when (symbolp type) + (setf type (find-binary-type type))) + (let ((slot (find slot-name (binary-record-slots type) :key #'record-slot-name))) + (assert slot (slot-name) + "No slot named ~S in binary-type ~S." slot-name type) + (record-slot-tags slot))) + +(defun binary-record-slot-names (type &key (padding-slots-p nil) + (match-tags nil)) + "Returns a list of the slot-names of TYPE, in sequence." + (when (symbolp type) + (setf type (find-binary-type type))) + (when (and match-tags (atom match-tags)) + (setf match-tags (list match-tags))) + (let ((slot-names (if padding-slots-p + (mapcar #'record-slot-name (binary-record-slots type)) + (mapcan #'(lambda (slot) + (if (integerp (record-slot-type slot)) + nil + (list (record-slot-name slot)))) + (binary-record-slots type))))) + (if (null match-tags) + slot-names + (loop for slot-name in slot-names + when (intersection (binary-slot-tags type slot-name) + match-tags) + collect slot-name)))) + +(defun binary-slot-type (type slot-name) + (when (symbolp type) + (setf type (find-binary-type type))) + (let ((slot (find slot-name (binary-record-slots type) :key #'record-slot-name))) + (assert slot (slot-name) + "No slot named ~S in binary-type ~S." slot-name type) + (record-slot-type slot))) + +(defun quoted-name-p (form) + (and (listp form) + (= 2 (length form)) + (eq 'cl:quote (first form)) + (symbolp (second form)) + (second form))) + +(defun parse-bt-spec (expr) + "Takes a binary-type specifier (a symbol, integer, or define-xx form), + and returns three values: the binary-type's name, the equivalent lisp type, + and any nested declaration that must be expanded separately." + (cond + ((eq :label expr) (values 0 nil)) ; a label + ((symbolp expr) (values expr expr)) ; a name + ((integerp expr) (values expr nil)) ; a padding type + ((quoted-name-p expr) + (values (second expr) (second expr))) ; a quoted name + ((and (listp expr) ; a nested declaration + (symbolp (first expr)) + (eq (find-package 'binary-types) + (symbol-package (first expr)))) + (values (second expr) (second expr) expr)) + (t (error "Unknown nested binary-type specifier: ~S" expr)))) + +(defmacro define-binary-class (type-name supers slots &rest class-options) + (let (embedded-declarations) + (flet ((parse-slot-specifier (slot-specifier) + "For a class slot-specifier, return the slot-specifier to forward + (sans binary-type options), the binary-type of the slot (or nil), + and the slot's name, and map-write, map-read and map-read-delayed + functions if present." + (when (symbolp slot-specifier) + (setf slot-specifier (list slot-specifier))) + (loop for slot-options on (rest slot-specifier) by #'cddr + as slot-option = (first slot-options) + as slot-option-arg = (second slot-options) + with bintype = nil + and typetype = nil + and map-write = nil + and map-read = nil + and map-read-delayed = nil + and tags = nil + unless + (case slot-option + (:binary-tag + (prog1 t + (setf tags (if (atom slot-option-arg) + (list slot-option-arg) + slot-option-arg)))) + ((:bt-on-write :map-binary-write) + (prog1 t + (setf map-write slot-option-arg))) + (:map-binary-read + (prog1 t + (setf map-read slot-option-arg))) + (:map-binary-read-delayed + (prog1 t + (setf map-read-delayed slot-option-arg))) + ((:bt :btt :binary-type :binary-lisp-type) + (prog1 t + (multiple-value-bind (bt tt nested-form) + (parse-bt-spec slot-option-arg) + (setf bintype bt) + (when nested-form + (push nested-form embedded-declarations)) + (when (and (symbolp tt) + (member slot-option '(:btt :binary-lisp-type))) + (setf typetype tt)))))) + nconc (list slot-option + slot-option-arg) into options + finally (return (values (list* (first slot-specifier) + (if typetype + (list* :type typetype options) + options)) + bintype + (first slot-specifier) + map-write + map-read + map-read-delayed + tags))))) + (multiple-value-bind (binslot-forms binslot-types hidden-slots) + (loop for slot-specifier in slots with binslot-forms and binslot-types and hidden-slots + do (multiple-value-bind (options bintype slot-name map-write map-read map-read-delayed tags) + (parse-slot-specifier slot-specifier) + (declare (ignore options)) + (when bintype + (let ((hidden-read-slot-name (when map-read-delayed + (make-symbol (format nil "hidden-slot-~A" + slot-name))))) + (push `(make-record-slot + :name ',slot-name + :type ',bintype + :map-write ,map-write + :map-read ,map-read + :map-read-delayed ,map-read-delayed + :hidden-read-slot ',hidden-read-slot-name + :tags ',tags) + binslot-forms) + (when (and hidden-read-slot-name + (not *ignore-hidden-slots-for-pcl*)) + (push (list hidden-read-slot-name slot-name map-read-delayed bintype) + hidden-slots)) + (push bintype binslot-types)))) + finally (return (values (reverse binslot-forms) + (reverse binslot-types) + (reverse hidden-slots)))) + (let* ((forward-class-options (loop for co in class-options + unless (member (car co) + '(:slot-align :class-slot-offset)) + collect co)) + (class-slot-offset (or (second (assoc :class-slot-offset class-options)) 0)) + (slot-align-slot (second (assoc :slot-align class-options))) + (slot-align-offset (third (assoc :slot-align class-options)))) + `(progn + ,@embedded-declarations + (defclass ,type-name ,supers + ,(append (mapcar #'parse-slot-specifier slots) + (mapcar #'first hidden-slots)) + ,@forward-class-options) + (let ((record-size (loop for s in ',binslot-types summing (sizeof s)))) + (setf (find-binary-type ',type-name) + (make-instance 'binary-class + 'name ',type-name + 'sizeof record-size + 'slots (list ,@binslot-forms) + 'offset ,class-slot-offset + 'instance-class (find-class ',type-name))) + ,@(when slot-align-slot + `((setf (slot-value (find-binary-type ',type-name) 'offset) + (- ,slot-align-offset + (slot-offset ',type-name ',slot-align-slot))))) + ,@(loop for bs in hidden-slots + collect `(defmethod slot-unbound (class (instance ,type-name) + (slot-name (eql ',(second bs)))) + (if (not (slot-boundp instance ',(first bs))) + (call-next-method class instance slot-name) + (setf (slot-value instance slot-name) + (funcall ,(third bs) + (slot-value instance ',(first bs)) + ',(fourth bs)))))) + ',type-name))))))) + + +(defmacro define-binary-struct (name-and-options dummy-options &rest doc-slot-descriptions) + (declare (ignore dummy-options)) ; clisp seems to require this.. + (let (embedded-declarations) + (flet ((parse-slot-description (slot-description) + (cond + ((symbolp slot-description) + (values slot-description nil slot-description)) + ((>= 2 (list-length slot-description)) + (values slot-description nil (first slot-description))) + (t (loop for descr on (cddr slot-description) by #'cddr + with bintype = nil + and typetype = nil + if (member (first descr) + '(:bt :btt :binary-type :binary-lisp-type)) + do (multiple-value-bind (bt lisp-type nested-form) + (parse-bt-spec (second descr)) + (declare (ignore lisp-type)) + (setf bintype bt) + (when nested-form + (push nested-form embedded-declarations)) + (when (and (symbolp bt) + (member (first descr) + '(:btt :binary-lisp-type))) + (setf typetype bintype))) + else nconc + (list (first descr) (second descr)) into descriptions + finally + (return (values (list* (first slot-description) + (second slot-description) + (if typetype + (list* :type typetype descriptions) + descriptions)) + bintype + (first slot-description)))))))) + (multiple-value-bind (doc slot-descriptions) + (if (stringp (first doc-slot-descriptions)) + (values (list (first doc-slot-descriptions)) + (rest doc-slot-descriptions)) + (values nil doc-slot-descriptions)) + (let* ((type-name (if (consp name-and-options) + (first name-and-options) + name-and-options)) + (binslots (mapcan (lambda (slot-description) + (multiple-value-bind (options bintype slot-name) + (parse-slot-description slot-description) + (declare (ignore options)) + (if bintype + (list (make-record-slot :name slot-name + :type bintype)) + nil))) + slot-descriptions)) + (slot-types (mapcar #'record-slot-type binslots))) + `(progn + ,@embedded-declarations + (defstruct ,name-and-options + ,@doc + ,@(mapcar #'parse-slot-description slot-descriptions)) + (setf (find-binary-type ',type-name) + (make-instance 'binary-struct + 'name ',type-name + 'sizeof (loop for s in ',slot-types sum (sizeof s)) + 'slots ',binslots + 'offset 0 + 'constructor (find-symbol (format nil "~A-~A" '#:make ',type-name)))) + ',type-name)))))) + +(defmethod read-binary-record (type-name stream &key start stop &allow-other-keys) + (let ((type (find-binary-type type-name)) + (start-slot 0) + (stop-slot nil)) + (check-type type binary-record) + (when start + (setf start-slot (position-if #'(lambda (sp) + (eq start (record-slot-name sp))) + (binary-record-slots type))) + (unless start-slot + (error "start-slot ~S not found in type ~A" + start type))) + (when stop + (setf stop-slot (position-if #'(lambda (sp) + (eq stop (record-slot-name sp))) + (binary-record-slots type))) + (unless stop-slot + (error "stop-slot ~S not found in type ~A" + stop type))) + (let ((total-read-bytes 0) + (slot-list (subseq (binary-record-slots type) start-slot stop-slot)) + (object (binary-record-make-instance type))) + (dolist (slot slot-list) + (multiple-value-bind (read-slot-value read-slot-bytes) + (read-binary (record-slot-type slot) stream) + (cond + ((record-slot-map-read-delayed slot) + (setf (slot-value object (record-slot-hidden-read-slot slot)) + read-slot-value) + (slot-makunbound object (record-slot-name slot))) + ((record-slot-map-read slot) + (setf (slot-value object (record-slot-name slot)) + (funcall (record-slot-map-read slot) read-slot-value))) + (t (setf (slot-value object (record-slot-name slot)) read-slot-value))) + (incf total-read-bytes read-slot-bytes))) + (values object total-read-bytes)))) + +(defmethod read-binary ((type binary-record) stream &key start stop &allow-other-keys) + (read-binary-record (binary-type-name type) stream :start start :stop stop)) + +(defmethod write-binary-record (object stream) + (write-binary (find-binary-type (type-of object)) stream object)) + +(defun binary-slot-value (object slot-name) + "Return the ``binary'' value of a slot, i.e the value mapped +by any MAP-ON-WRITE slot mapper function." + (let ((slot (find slot-name (binary-record-slots (find-binary-type (type-of object))) + :key #'record-slot-name))) + (assert slot () + "Slot-name ~A not found in ~S of type ~S." + slot-name object (find-binary-type (type-of object))) +;;; (warn "slot: ~S value: ~S" slot (slot-value object slot-name)) + (cond + ((integerp (record-slot-type slot)) nil) ; padding + ((and (record-slot-map-read-delayed slot) + (not (slot-boundp object slot-name)) + (slot-boundp object (record-slot-hidden-read-slot slot))) + (slot-value object (record-slot-hidden-read-slot slot))) + ((record-slot-map-write slot) + (funcall (record-slot-map-write slot) + (slot-value object slot-name) + (record-slot-type slot))) + (t (slot-value object slot-name))))) + +(defmethod write-binary ((type binary-record) stream object + &key start stop &allow-other-keys) + (let ((start-slot 0) + (stop-slot nil)) + (when start + (setf start-slot (position-if #'(lambda (sp) + (eq start (record-slot-name sp))) + (binary-record-slots type))) + (unless start-slot + (error "start-slot ~S not found in type ~A" + start type))) + (when stop + (setf stop-slot (position-if #'(lambda (sp) + (eq stop (record-slot-name sp))) + (binary-record-slots type))) + (unless stop-slot + (error "stop-slot ~S not found in type ~A" + stop type))) + (let ((written-bytes 0) + (slot-list (subseq (binary-record-slots type) start-slot stop-slot))) + (dolist (slot slot-list) + (let* ((slot-name (record-slot-name slot)) + (slot-type (record-slot-type slot)) + (value (cond + ((integerp slot-type) nil) ; padding + ((record-slot-map-write slot) + (funcall (record-slot-map-write slot) + (slot-value object slot-name) + slot-type)) + (t (slot-value object slot-name))))) + (incf written-bytes + (write-binary slot-type stream value)))) + written-bytes))) + +(defun merge-binary-records (obj1 obj2) + "Returns a record where every non-bound slot in obj1 is replaced +with that slot's value from obj2." + (let ((class (class-of obj1))) + (unless (eq class (class-of obj2)) + (error "cannot merge incompatible records ~S and ~S" obj1 obj2)) + (let ((new-obj (make-instance class))) + (dolist (slot (binary-record-slots (find-binary-type (type-of obj1)))) + (let ((slot-name (record-slot-name slot))) + (cond + ((slot-boundp obj1 slot-name) + (setf (slot-value new-obj slot-name) + (slot-value obj1 slot-name))) + ((slot-boundp obj2 slot-name) + (setf (slot-value new-obj slot-name) + (slot-value obj2 slot-name)))))) + new-obj))) + +(defun binary-record-alist (obj) + "Returns an assoc-list representation of (the slots of) a binary +record object." + (mapcan #'(lambda (slot) + (unless (integerp (record-slot-type slot)) + (list (cons (record-slot-name slot) + (if (slot-boundp obj (record-slot-name slot)) + (slot-value obj (record-slot-name slot)) + 'unbound-slot))))) + (binary-record-slots (find-binary-type (type-of obj))))) + +;;; ---------------------------------------------------------------- +;;; Bitfield Types +;;; ---------------------------------------------------------------- + +(defclass bitfield (binary-type) + ((storage-type + :type t + :accessor storage-type + :initarg storage-type) + (hash + :type hash-table + :initform (make-hash-table :test #'eq) + :accessor bitfield-hash))) + +(defstruct bitfield-entry + value + bytespec) + +(defmacro define-bitfield (type-name (storage-type) spec) + (let ((slot-list ; (slot-name value byte-size byte-pos) + (mapcan #'(lambda (set) + (ecase (caar set) + (:bits + (mapcar #'(lambda (slot) + (list (car slot) + 1 + 1 + (cdr slot))) + (make-pairs (cdr set)))) + (:enum + (destructuring-bind (&key byte) + (rest (car set)) + (mapcar #'(lambda (slot) + (list (car slot) + (cdr slot) + (first byte) + (second byte))) + (make-pairs (cdr set))))) + (:numeric + (let ((s (car set))) + (list (list (second s) + nil + (third s) + (fourth s))))))) + spec))) + `(let ((type-obj (make-instance 'bitfield + 'name ',type-name + 'sizeof (sizeof ',storage-type) + 'storage-type (find-binary-type ',storage-type)))) + (deftype ,type-name () '(or list symbol)) + (dolist (slot ',slot-list) + (setf (gethash (first slot) (bitfield-hash type-obj)) + (make-bitfield-entry :value (second slot) + :bytespec (if (and (third slot) + (fourth slot)) + (byte (third slot) + (fourth slot)) + nil)))) + (setf (find-binary-type ',type-name) type-obj) + ',type-name))) + +(defmacro define-enum (type-name (storage-name &optional byte-spec) &rest spec) + "A simple wrapper around DEFINE-BITFIELD for simple enum types." + `(define-bitfield ,type-name (,storage-name) + (((:enum :byte ,byte-spec) + ,@spec)))) + +(defun bitfield-compute-symbolic-value (type numeric-value) + "Return the symbolic value of a numeric bitfield" + (check-type numeric-value integer) + (let (result) + (maphash #'(lambda (slot-name entry) + (let ((e-value (bitfield-entry-value entry)) + (e-bytespec (bitfield-entry-bytespec entry))) + (cond + ((and e-value e-bytespec) + (when (= e-value + (ldb e-bytespec numeric-value)) + (push slot-name + result))) + (e-value + ;; no mask => this must be the sole entry present + (when (= numeric-value e-value) + (setf result slot-name))) + (e-bytespec + ;; no value => this is a numeric sub-field + (push (cons slot-name + (ldb e-bytespec numeric-value)) + result)) + (t (error "bitfield-value type ~A has NIL value and bytespec" type))))) + (bitfield-hash type)) +;;;;; Consistency check by symmetry. Uncomment for debugging. +;;; (unless (= numeric-value +;;; (bitfield-compute-numeric-value type result)) +;;; (error "bitfield inconsitency with ~A: ~X => ~A => ~X." +;;; (type-of type) +;;; numeric-value +;;; result +;;; (bitfield-compute-numeric-value type result))) + result)) + +(defun enum-value (type symbolic-value) + "For an enum type (actually, for any bitfield-based type), ~ + look up the numeric value of a symbol." + (unless (typep type 'bitfield) + (setf type (find-binary-type type))) + (bitfield-compute-numeric-value type symbolic-value)) + +(defun enum-symbolic-value (type binary-value) + "The inverse of ENUM-VALUE." + (unless (typep type 'bitfield) + (setf type (find-binary-type type))) + (bitfield-compute-symbolic-value type binary-value)) + +(defun bitfield-compute-numeric-value (type symbolic-value) + "Returns the numeric representation of a bitfields symbolic value." + (etypecase symbolic-value + (list + (let ((result 0)) + (dolist (slot symbolic-value) + (etypecase slot + (symbol ; enum sub-field + (let ((entry (gethash slot (bitfield-hash type)))) + (assert entry (entry) "Unknown bitfield slot ~S of ~S." + slot (find-binary-type-name type)) + (setf (ldb (bitfield-entry-bytespec entry) result) + (bitfield-entry-value entry)))) + (cons ; numeric sub-field + (let ((entry (gethash (car slot) (bitfield-hash type)))) + (assert entry (entry) "Unknown bitfield slot ~S of ~S." + (car slot) (find-binary-type-name type)) + (setf (ldb (bitfield-entry-bytespec entry) result) + (cdr slot)))))) + result)) + (symbol ; enum + (let ((entry (gethash symbolic-value + (bitfield-hash type)))) + (assert entry (entry) "Unknown bitfield slot ~A:~S of ~S." + (package-name (symbol-package symbolic-value)) + symbolic-value + (find-binary-type-name type)) + (if (bitfield-entry-bytespec entry) + (dpb (bitfield-entry-value entry) + (bitfield-entry-bytespec entry) + 0) + (bitfield-entry-value entry)))))) + +(defmethod read-binary ((type bitfield) stream &key &allow-other-keys) + (multiple-value-bind (storage-obj num-octets-read) + (read-binary (storage-type type) stream) + (values (bitfield-compute-symbolic-value type storage-obj) + num-octets-read))) + +(defmethod write-binary ((type bitfield) stream symbolic-value &rest key-args) + (apply #'write-binary + (storage-type type) + stream + (bitfield-compute-numeric-value type symbolic-value) + key-args)) + +;;;; Macros: + +(defmacro with-binary-file ((stream-var path &rest key-args) &body body) + "This is a thin wrapper around WITH-OPEN-FILE, that tries to set the +stream's element-type to that required by READ-BINARY and WRITE-BINARY. +A run-time assertion on the stream's actual element type is performed, +unless you disable this feature by setting the keyword option :check-stream +to nil." + (let ((check-stream (getf key-args :check-stream t)) + (fwd-key-args (copy-list key-args))) + ;; This is manual parsing of keyword arguments. We force :element-type + ;; to (unsigned-byte 8), and remove :check-stream from the arguments + ;; passed on to WITH-OPEN-FILE. + (remf fwd-key-args :check-stream) + ;; #-(and allegro-version>= (version>= 6 0)) + (setf (getf fwd-key-args :element-type) ''(unsigned-byte 8)) + `(with-open-file (,stream-var ,path ,@fwd-key-args) + ,@(when check-stream + `((let ((stream-type (stream-element-type ,stream-var))) + (assert (and (subtypep '(unsigned-byte 8) stream-type) + (subtypep stream-type '(unsigned-byte 8))) + () + "Failed to open ~S in 8-bit binary mode, stream element-type was ~S" + ,path stream-type)))) + ,@body))) + +(defmacro with-binary-output-to-list ((stream-var) &body body) + "Inside BODY, calls to WRITE-BINARY with stream STREAM-VAR will +collect the individual 8-bit bytes in a list (of integers). +This list is returned by the form. (There is no way to get at +the return-value of BODY.) +This macro depends on the binding of *BINARY-WRITE-BYTE*, which should +not be shadowed." + (let ((save-bwt-var (make-symbol "save-bwt")) + (closure-byte-var (make-symbol "closure-byte")) + (closure-stream-var (make-symbol "closure-stream"))) + `(let* ((,save-bwt-var *binary-write-byte*) + (,stream-var (cons nil nil)) ; (head . tail) + (*binary-write-byte* + #'(lambda (,closure-byte-var ,closure-stream-var) + (if (eq ,stream-var ,closure-stream-var) + (if (endp (cdr ,stream-var)) + (setf (cdr ,stream-var) + (setf (car ,stream-var) (list ,closure-byte-var))) + (setf (cdr ,stream-var) + (setf (cddr ,stream-var) (list ,closure-byte-var)))) + (funcall ,save-bwt-var ; it's not our stream, so pass it ... + ,closure-byte-var ; along to the next function. + ,closure-stream-var))))) + ,@body + (car ,stream-var)))) + +(defmacro with-binary-input-from-list ((stream-var list-form) &body body) + "Bind STREAM-VAR to an object that, when passed to READ-BINARY, provides +8-bit bytes from LIST-FORM, which must yield a list. +Binds *BINARY-READ-BYTE* appropriately. This macro will break if this +binding is shadowed." + (let ((save-brb-var (make-symbol "save-brb"))) + `(let* ((,save-brb-var *binary-read-byte*) + (,stream-var (cons ,list-form nil)) ; use cell as stream id. + (*binary-read-byte* #'(lambda (s) + (if (eq s ,stream-var) + (if (null (car s)) + (error "WITH-BINARY-INPUT-FROM-LIST reached end of list.") + (pop (car s))) + (funcall ,save-brb-var s))))) + ,@body))) + +(defmacro with-binary-input-from-vector + ((stream-var vector-form &key (start 0)) &body body) + "Bind STREAM-VAR to an object that, when passed to READ-BINARY, provides +8-bit bytes from VECTOR-FORM, which must yield a vector. +Binds *BINARY-READ-BYTE* appropriately. This macro will break if this +binding is shadowed." + (let ((save-brb-var (make-symbol "save-brb"))) + `(let* ((,save-brb-var *binary-read-byte*) + (,stream-var (cons (1- ,start) ,vector-form)) + (*binary-read-byte* #'(lambda (s) + (if (eq s ,stream-var) + (aref (cdr s) (incf (car s))) + (funcall ,save-brb-var s))))) + ,@body))) + +(defmacro with-binary-output-to-vector + ((stream-var &optional (vector-or-size-form 0) + &key (adjustable (and (integerp vector-or-size-form) + (zerop vector-or-size-form))) + (fill-pointer 0) + (element-type ''(unsigned-byte 8)) + (on-full-array :error)) + &body body) + "Arrange for STREAM-VAR to collect octets in a vector. +VECTOR-OR-SIZE-FORM is either a form that evaluates to a vector, or an +integer in which case a new vector of that size is created. The vector's +fill-pointer is used as the write-index. If ADJUSTABLE nil (or not provided), +an error will occur if the array is too small. Otherwise, the array will +be adjusted in size, using VECTOR-PUSH-EXTEND. If ADJUSTABLE is an integer, +that value will be passed as the EXTENSION argument to VECTOR-PUSH-EXTEND. +If VECTOR-OR-SIZE-FORM is an integer, the created vector is returned, +otherwise the value of BODY." + (let ((vector-form + (if (integerp vector-or-size-form) + `(make-array ,vector-or-size-form + :element-type ,element-type + :adjustable ,(and adjustable t) + :fill-pointer ,fill-pointer) + vector-or-size-form))) + (let ((save-bwb-var (make-symbol "save-bwb"))) + `(let* ((,save-bwb-var *binary-write-byte*) + (,stream-var ,vector-form) + (*binary-write-byte* + #'(lambda (byte stream) + (if (eq stream ,stream-var) + ,(cond + (adjustable + `(vector-push-extend byte stream + ,@(when (integerp adjustable) + (list adjustable)))) + ((eq on-full-array :error) + `(assert (vector-push byte stream) (stream) + "Binary output vector is full when writing byte value ~S: ~S" + byte stream)) + ((eq on-full-array :ignore) + `(vector-push byte stream)) + (t (error "Unknown ON-FULL-ARRAY argument ~S, must be one of :ERROR, :IGNORE." + on-full-array))) + (funcall ,save-bwb-var byte stream))))) + ,@body + ,@(when (integerp vector-or-size-form) + (list stream-var)))))) + + +;;; + +(defun split-bytes (bytes from-size to-size) + "From a list of BYTES sized FROM-SIZE bits, split each byte into bytes of size TO-SIZE, + according to *ENDIAN*. TO-SIZE must divide FROM-SIZE evenly. If this is not the case, + you might want to apply MERGE-BYTES to the list of BYTES first." + (assert (zerop (rem from-size to-size)) (from-size to-size) + "TO-SIZE ~D doesn't evenly divide FROM-SIZE ~D." to-size from-size) + (ecase *endian* + (:little-endian + (loop for byte in bytes + append (loop for x from 0 below (truncate from-size to-size) + collect (ldb (byte to-size (* x to-size)) byte)))) + (:big-endian + (loop for byte in bytes + append (loop for x from (1- (truncate from-size to-size)) downto 0 + collect (ldb (byte to-size (* x to-size)) byte)))))) +(defun merge-bytes (bytes from-size to-size) + "Combine BYTES sized FROM-SIZE bits into new bytes sized TO-SIZE bits." + (assert (zerop (rem to-size from-size))) + (let ((factor (truncate to-size from-size))) + (ecase *endian* + (:little-endian + (loop for bytes on bytes by #'(lambda (x) (nthcdr factor x)) + collect (loop for n from 0 below factor + as sub-byte = (or (nth n bytes) 0) + summing (ash sub-byte (* n from-size))))) + (:big-endian + (loop for bytes on bytes by #'(lambda (x) (nthcdr factor x)) + collect (loop for n from 0 below factor + as sub-byte = (or (nth (- factor 1 n) bytes) 0) + summing (ash sub-byte (* n from-size)))))))) diff --git a/example.lisp b/example.lisp new file mode 100644 index 0000000..4664cd2 --- /dev/null +++ b/example.lisp @@ -0,0 +1,146 @@ +;;;;------------------------------------------------------------------ +;;;; +;;;; Copyright (C) 200120001999, +;;;; Department of Computer Science, University of Tromsø, Norway +;;;; +;;;; Filename: example.lisp +;;;; Description: +;;;; Author: Frode Vatvedt Fjeld +;;;; Created at: Wed Dec 8 15:15:06 1999 +;;;; Distribution: See the accompanying file COPYING. +;;;; +;;;; $Id: example.lisp,v 1.1.1.1 2004/01/13 11:13:13 ffjeld Exp $ +;;;; +;;;;------------------------------------------------------------------ + +(defpackage "EXAMPLE" + (:use "COMMON-LISP" "BINARY-TYPES") + (:export run)) + +(in-package "EXAMPLE") + +;;; ELF basic types +(define-unsigned word 4) +(define-signed sword 4) +(define-unsigned addr 4) +(define-unsigned off 4) +(define-unsigned half 2) + +;;; Mapping from ELF symbols to BT:*ENDIAN* values +(defun elf-data-to-endian (elf-data) + (ecase elf-data + ((elf-data-2lsb) :little-endian) + ((elf-data-2msb) :big-endian))) + +(defconstant +ELF-MAGIC+ '(#x7f #\E #\L #\F)) + +;;; ELF file header structure +(define-binary-class elf-header () + ((e-ident + :binary-type (define-binary-struct e-ident () + (ei-magic nil :binary-type + (define-binary-struct ei-magic () + (ei-mag0 0 :binary-type u8) + (ei-mag1 #\null :binary-type char8) + (ei-mag2 #\null :binary-type char8) + (ei-mag3 #\null :binary-type char8))) + (ei-class nil :binary-type + (define-enum ei-class (u8) + elf-class-none 0 + elf-class-32 1 + elf-class-64 2)) + (ei-data nil :binary-type + (define-enum ei-data (u8) + elf-data-none 0 + elf-data-2lsb 1 + elf-data-2msb 2)) + (ei-version 0 :binary-type u8) + (padding nil :binary-type 1) + (ei-name "" :binary-type + (define-null-terminated-string ei-name 8)))) + (e-type + :binary-type (define-enum e-type (half) + et-none 0 + et-rel 1 + et-exec 2 + et-dyn 3 + et-core 4 + et-loproc #xff00 + et-hiproc #xffff)) + (e-machine + :binary-type (define-enum e-machine (half) + em-none 0 + em-m32 1 + em-sparc 2 + em-386 3 + em-68k 4 + em-88k 5 + em-860 7 + em-mips 8)) + (e-version :binary-type word) + (e-entry :binary-type addr) + (e-phoff :binary-type off) + (e-shoff :binary-type off) + (e-flags :binary-type word) + (e-ehsize :binary-type half) + (e-phentsize :binary-type half) + (e-phnum :binary-type half) + (e-shentsize :binary-type half) + (e-shnum :binary-type half) + (e-shstrndx :binary-type half))) + +(define-condition elf32-reader-error (error) + ((stream :initarg :stream :reader elf32-parse-error-stream) + (message :initarg :message :reader elf32-parse-error-message)) + (:report (lambda (condition stream) + (princ (elf32-parse-error-message condition) + stream)))) + +(define-condition elf32-wrong-magic (elf32-reader-error) + ((magic :initarg :magic :reader elf32-wrong-magic-magic))) + +(define-condition elf32-wrong-class (elf32-reader-error) + ((class :initarg :class :reader elf32-wrong-class-class))) + +(defun read-elf-file-header (stream) + "Returns an ELF-HEADER and the file's endianess." + (let ((header (read-binary 'elf-header stream :stop 'e-type))) + (with-slots (ei-data ei-class ei-magic) + (slot-value header 'e-ident) + (let* ((binary-types:*endian* (elf-data-to-endian ei-data)) + (magic (mapcar #'(lambda (slot-name) + (slot-value ei-magic slot-name)) + (binary-record-slot-names 'ei-magic)))) + ;; Check that file is in fact 32-bit ELF + (unless (equal +ELF-MAGIC+ magic) + (error 'elf32-wrong-magic + :stream stream + :message (format nil "file doesn't match ELF-MAGIC: ~A" magic) + :magic magic)) + (unless (eq 'elf-class-32 ei-class) + (error 'elf32-wrong-class + :stream stream + :message (format nil "file is not 32-bit ELF (~A)" ei-class) + :class ei-class)) + ;; Read the rest of the file-header and merge it with what + ;; we've allready got. + (let ((rest (read-binary 'elf-header stream :start 'e-type))) + (dolist (slot-name (binary-record-slot-names 'elf-header)) + (unless (slot-boundp header slot-name) + (setf (slot-value header slot-name) + (slot-value rest slot-name)))) + (values header binary-types:*endian*)))))) + +(defun run (path) + (with-binary-file (stream path :direction :input) + (let ((elf-header (read-elf-file-header stream))) + (format t "~&ELF header for \"~A\":~:{~&~12@A: ~S~}~%" path + (mapcar #'(lambda (slot-name) + (list slot-name + (slot-value elf-header slot-name))) + (binary-record-slot-names 'elf-header))) + elf-header))) + +#+unix +(run "/bin/ls") + -- 1.7.10.4