From ingvar at cathouse.bofh.se  Fri Jul  9 12:01:38 2004
From: ingvar at cathouse.bofh.se (Ingvar)
Date: Fri, 09 Jul 2004 13:01:38 +0100
Subject: [Small-cl-src] Small, occasionally handy piece of code
Message-ID: <E1Biu4Q-0008Fn-00@head.cathouse.bofh.se>

;;; Haven't we all felt the need of generating combinations from a collection
;;; and calling a function for every combination?
;;;
;;; It's about as easy as this:
;;; <list> is the initial set
;;; <num> is the number of elements in the resulting combination
;;; <func> is the callback function
(defun call-with-combination (list num func &optional acc)
  (declare (list list acc)
	   (fixnum num)
	   (function func))
  (if (zerop num)
      (apply func acc)
    (loop for elt in list
	  do (call-with-combination
	      (remove elt list) (1- num) func (cons elt acc)))))





From seharris at raytheon.com  Fri Jul  9 16:18:39 2004
From: seharris at raytheon.com (Steven E. Harris)
Date: Fri, 09 Jul 2004 09:18:39 -0700
Subject: [Small-cl-src] Re: Small, occasionally handy piece of code
References: <E1Biu4Q-0008Fn-00@head.cathouse.bofh.se>
Message-ID: <q674qohgnmo.fsf@L75001820.us.ray.com>

Ingvar <ingvar at cathouse.bofh.se> writes:

> Haven't we all felt the need of generating combinations from a
> collection and calling a function for every combination?

I wrote one a while ago that may cons less because it requires use of
vectors to represent the sequences. The interface to
call-with-combinations is similar to yours, with the argument order
mixed up.

There's a lower-level function call-with-n-combo-slots that is useful
when one has both the source and working "target" vectors in hand. The
target vector is used to present the caller-provided function with the
current combination, similar to your "acc" argument.

-------------- next part --------------
An embedded and charset-unspecified text was scrubbed...
Name: combinations.lisp
URL: <https://mailman.common-lisp.net/pipermail/small-cl-src/attachments/20040709/ee0d66ab/attachment.ksh>
-------------- next part --------------

-- 
Steven E. Harris        :: seharris at raytheon.com
Raytheon                :: http://www.raytheon.com

From xach at xach.com  Fri Jul  9 16:47:59 2004
From: xach at xach.com (Zach Beane)
Date: Fri, 9 Jul 2004 12:47:59 -0400
Subject: [Small-cl-src] bit I/O
Message-ID: <20040709164759.GY29619@xach.com>

;;;; The following stuff is taken, verbatim and somewhat unpolished,
;;;; from something I'm currently working on.

;;;;
;;;; Bit-level I/O. The Flash spec has various structures packed into
;;;; bit fields.
;;;;
;;;; $Id: bitio.lisp,v 1.5 2004/07/08 02:47:20 xach Exp $

(in-package :flash)


(defclass bitstream ()
  ((current-byte :initarg :current-byte :accessor current-byte)
   (bits-left :initarg :bits-left :accessor bits-left)
   (stream :initarg :stream :reader stream))
  (:documentation
   "A class for writing or reading bits to or from an (UNSIGNED-BYTE 8) stream."))



;;; Input

(defun make-input-bitstream (stream &key (current-byte 0) (bits-left 0))
  "Return a bitstream suitable for reading. The CURRENT-BYTE and
BITS-LEFT, if specified, initialize the internal byte buffer and
count."
  (assert (input-stream-p stream))
  (assert (subtypep (stream-element-type stream) '(unsigned-byte 8)))
  (make-instance 'bitstream
                 :stream stream
                 :current-byte current-byte
                 :bits-left bits-left))

(defmethod read-bits (width (bitstream bitstream) &optional (signedp nil))
  (with-accessors ((bits-left bits-left) (input stream)
                   (current-byte current-byte))
    bitstream
    (loop with result = 0
          with bits-needed = width
          while (plusp bits-needed)
          if (> bits-needed bits-left) do
          (setf result (logior (ash result bits-left)
                               (ldb (byte bits-left 0) current-byte))
                bits-needed (- bits-needed bits-left)
                current-byte (read-byte input)
                bits-left 8)
          else do
          (setf result (logior (ash result bits-needed)
                               (ldb (byte bits-needed (- bits-left
                                                         bits-needed))
                                    current-byte))
                bits-left (- bits-left bits-needed)
                bits-needed 0)
          finally (if (and signedp
                           (logbitp (1- width) result))
                      (return (1- (- (logandc2 (1- (ash 1 width)) result))))
                      (return result)))))

(defmethod read-boolean ((bitstream bitstream))
  "Read and return a single bit from BITSTREAM as a boolean."
  (logbitp 0 (read-bits 1 bitstream)))

(defmacro with-input-bitstream ((bitstream stream
                                  &key (current-byte 0) (bits-left 0))
                                 &body body)
  "Evaluate BODY with a newly-created input bitstream bound to BITSTREAM."
  (let ((-current-byte- (gensym))
        (-bits-left- (gensym)))
    `(let* ((,-current-byte- ,current-byte)
            (,-bits-left- ,bits-left)
            (,bitstream (make-input-bitstream ,stream
                                              :current-byte ,-current-byte-
                                              :bits-left ,-bits-left-)))
      , at body)))


;;; Output

(defun make-output-bitstream (stream &key (current-byte 0) (bits-left 8))
  "Return a bitstream suitable for writing. The CURRENT-BYTE and
BITS-LEFT, if specified, initialize the internal byte buffer and
count."
  (assert (output-stream-p stream))
  (assert (subtypep (stream-element-type stream) '(unsigned-byte 8)))
  (make-instance 'bitstream
                 :stream stream
                 :current-byte current-byte
                 :bits-left bits-left))

(defmethod write-bits (integer width (bitstream bitstream))
  "Write the rightmost WIDTH bits from INTEGER to the bitstream"
  (with-accessors ((bits-left bits-left) (stream stream)
                   (current-byte current-byte))
    bitstream
    (when (minusp integer)
      (setf integer (ldb (byte width 0) integer)))
    (loop with bits-needed = width
          while (plusp bits-needed)
          if (> bits-needed bits-left) do
          (setf (ldb (byte bits-left 0) current-byte)
                (ldb (byte bits-left (- bits-needed bits-left)) integer)
                bits-needed (- bits-needed bits-left))
          (write-byte current-byte stream)
          (setf current-byte 0
                bits-left 8)
          else do
          (setf (ldb (byte bits-needed (- bits-left bits-needed)) current-byte)
                (ldb (byte bits-needed 0) integer)
                bits-left (- bits-left bits-needed)
                bits-needed 0))))

(defmethod write-bit (bit (bitstream bitstream))
  "Write a single bit to the bitstream."
  (write-bits bit 1 bitstream))

(defmethod write-boolean (boolean (bitstream bitstream))
  "Write BOOLEAN as a bit to the bitstream."
  (if boolean
      (write-bit 1 bitstream)
      (write-bit 0 bitstream)))

(defmethod finish-write ((bitstream bitstream))
  "Flush the output buffer byte of BITSTREAM. Uninitialized bits are
written as 0."
  (when (< (bits-left bitstream) 8)
    (write-byte (current-byte bitstream) (stream bitstream))
    (setf (current-byte bitstream) 0)
    (setf (bits-left bitstream) 8)))

(defmacro with-output-bitstream ((bitstream stream
                                  &key (current-byte 0) (bits-left 8))
                                 &body body)
  "Evaluate BODY with a newly-created output bitstream bound to
BITSTREAM. Pending output is flushed at the end of evaluation."
  (let ((-current-byte- (gensym))
        (-bits-left- (gensym)))
    `(let* ((,-current-byte- ,current-byte)
            (,-bits-left- ,bits-left)
            (,bitstream (make-output-bitstream ,stream
                                               :current-byte ,-current-byte-
                                               :bits-left ,-bits-left-)))
      (unwind-protect
           (progn , at body)
        (finish-write ,bitstream)))))



(defun test-bitstreams (file width integer)
  (with-open-file (output file :direction :output
                          :element-type '(unsigned-byte 8)
                          :if-exists :supersede
                          :if-does-not-exist :create)
    (with-output-bitstream (bitstream output)
      (write-bits integer width bitstream)))
  (with-open-file (input file :direction :input
                         :element-type '(unsigned-byte 8))
    (with-input-bitstream (bitstream input)
      (list (read-bits width bitstream t) integer))))


;;; Utility

(defun sufficient-bits (&rest numbers)
  "Return the number of bits necessary to represent the largest number
in NUMBERS."
  (loop for number in numbers
        maximizing (1+ (integer-length number))))



From ingvar at cathouse.bofh.se  Fri Jul  9 16:52:36 2004
From: ingvar at cathouse.bofh.se (Ingvar)
Date: Fri, 09 Jul 2004 17:52:36 +0100
Subject: [Small-cl-src] Useless piece of code,
	with Important Information in comments
Message-ID: <E1Biyc0-0001PW-00@head.cathouse.bofh.se>

;;; No More Mr Nice Listadmin...
;;; Remember, small-cl-src is "source code only" and "plain text".
;;; ALL comments on code SHOULD be sent to small-cl-src-discuss at hexapodia.net
;;; Attachments MUST NOT be used when mailing small-cl-src
;;; In theory, in a unix environment, with an mh-style mailfile 
;;; the following should result in a loadable lisp file (when called with the
;;; file name of the mh-style mail file and a suitable output stream):

(defun extract-small-cl-source (filename &optional (outstream t))
  (let ((extract nil))
    (with-open-file (infile filename)
     (do ((line (read-line infile nil infile) (read-line infile nil infile)))
	 ((or (eq line infile) (string= line "_______________________________________________") (string= line "-- ")) nil)
        (setf extract (or extract (string= line "")))
	(when extract
	  (format outstream "~a~%" line))))))





From seharris at raytheon.com  Fri Jul  9 17:46:21 2004
From: seharris at raytheon.com (Steven E. Harris)
Date: Fri, 09 Jul 2004 10:46:21 -0700
Subject: [Small-cl-src] combinations and permutations (was: Small,
	occasionally handy piece of code)
References: <E1Biu4Q-0008Fn-00@head.cathouse.bofh.se>
	<q674qohgnmo.fsf@L75001820.us.ray.com>
Message-ID: <q67n029f502.fsf@L75001820.us.ray.com>

"Steven E. Harris" <seharris at raytheon.com> writes:

> I wrote one a while ago that may cons less because it requires use
> of vectors to represent the sequences.

Following up to myself, if you're interested, I also have similar code
to produce permutations from a source vector, though the permutation
algorithm operates destructively in-place on the source sequence.

It's been about six months since I was doing the analysis for this
code, but I recall some interesting interdependencies between
combinations and permutations. Unfortunately my notes are at home
right now.

For example, one can compute /how many/ permutations exist for a full
draw from a set (n!), or how many permutations exist for a draw k from
a set (n!/(n - k)!), but computing how many combinations exist for any
draw k is dependent upon the related permutation count (P/k!).?

However, to actually come up with the /specific/ permutations and
combinations, the dependency is reversed. One can come up with
combinations in any draw k independently. One can also come up with
permutations for a full draw independently. But to come up with the
permutations for some draw k, one must first generate the combinations
of draw k, then permute each of those combinations as a full draw. The
apparent independence of the full draw permutations is due to there
being only one combination to permute for a full draw.


Footnotes: 
? http://www.themathpage.com/aPreCalc/permutations-combinations.htm

-- 
Steven E. Harris        :: seharris at raytheon.com
Raytheon                :: http://www.raytheon.com




From luke at bluetail.com  Mon Jul 12 10:11:54 2004
From: luke at bluetail.com (Luke Gorrie)
Date: Mon, 12 Jul 2004 12:11:54 +0200
Subject: [Small-cl-src] packet.lisp, version 2
Message-ID: <lhzn65k00l.fsf@dodo.bluetail.com>

;;; packet.lisp -- Decode TCP/IP packets (version 2)
;;; Written by Luke Gorrie <luke at bluetail.com> in May of 2004.
;;;
;;; A PDF version of this source file can be found at:
;;;   http://www.bluetail.com/~luke/misc/lisp/packet.pdf
;;;
;;; Revision history:
;;;
;;;   Version 2: Added support for encoding.
;;;              Dropped alist support. Now always using structures.
;;;
;;; TODO: conditions, IPv4 options, TCP.
;;;
;;;# Introduction
;;;
;;; This is a program for encoding and decoding the packet headers of
;;; some TCP/IP family protocols. It converts between packets
;;; represented as octet-vectors and structures.
;;;
;;; This program is a library; it's not very useful in itself.
;;;
;;; Written for CMUCL 19A. I've used some non-portable features:
;;; `ext:collect', `slot-value' on structures, and PCL introspection.

;; Avoid calling defpackage is the package already exists.
;; Is this correct? It does avoid a lot of irritating warnings due to
;; the programmed exports at the end of the file.
(eval-when (:compile-toplevel :load-toplevel :execute)
  (unless (find-package "PACKET")
    (defpackage :packet
      (:use :common-lisp)
      ;; Note: structures and their accessors are auto-exported down below.
      (:export #:decode #:encode
               #:buffer #:octet #:packet #:header))))

(in-package :packet)

;;;# Top-level interface
;;;
;;; The program has two main data types: buffers and packets. Buffers
;;; are octet-vectors for the encoded binary representations of
;;; packets.
;;;
(deftype buffer ()
  "A network packet represented as a vector of octets."
  '(array octet (*)))

(deftype octet ()
  "An unsigned 8-bit byte."
  '(unsigned-byte 8))

;;; A packet is a list of header structures followed by zero or more
;;; buffers of raw data. This is the representation of a decoded
;;; network packet's headers and payload. Note that the individual
;;; header types are defined down below in the protocol-specific
;;; sections.
;;;
(deftype packet ()
  "A list of headers and buffers representing a network packet."
  'cons)

(deftype header ()
  "A decoded protocol header."
  '(or ethernet-header arp-header ipv4-header udp-header))

;;; The `decode' and `encode' functions convert between the buffer and
;;; packet representations. They are inverse operations when applied
;;; to well-formed inputs.
;;;
(declaim (ftype (function (buffer) packet) decode)
         (ftype (function (packet) buffer) encode))

(defun decode (buffer)
  "Decode BUFFER as a packet."
  (decode-headers buffer))

(defun encode (packet)
  "Encode PACKET into a buffer."
  (encode-headers packet))

;;;# I/O machinery
;;;
;;; All our I/O is based on treating a `buffer' (octet-vector) as a
;;; stream of bits. For decoding we "grab" quantities of bits from the
;;; buffer as needed, and for encoding we similarly "shove" bits into
;;; an output buffer.

;;;## Input "grabbing"

(defvar *decode-buffer* nil
  "Buffer containing the packet currently being decoded.")

(defvar *decode-position* nil
  "Current bit-position in *DECODE-BUFFER*.")

(defmacro with-buffer-input (buffer &body body)
  "Execute BODY, grabbing input from the beginning of BUFFER."
  `(let ((*decode-buffer* ,buffer)
         (*decode-position* 0))
    , at body))

(defun bit-octet (bit &optional (check-alignment t))
  "Convert from bit position to octet position."
  (multiple-value-bind (quotient remainder) (truncate bit 8)
    (when (and check-alignment (plusp remainder))
      (error "Bit-position ~S is not octet-aligned." bit))
    quotient))

(defun octet-bit (octet)
  "Convert from octet position to bit position."
  (* 8 octet))

;;; "Grab" functions consume input from `*decode-buffer*' and advance
;;; `*decode-position*'.

(defun grab-octets (num)
  "Grab a vector of NUM octets."
  (let ((start (bit-octet *decode-position*)))
    (incf *decode-position* (* num 8))
    (subseq *decode-buffer* start (+ num start))))

(defun grab-ethernet-address ()
  (make-ethernet-address :octets (grab-octets 6)))

(defun grab-ipv4-address ()
  (make-ipv4-address :octets (grab-octets 4)))

(defun grab-rest ()
  "Grab the rest of the buffer into an octet vector."
  (prog1 (subseq *decode-buffer* (bit-octet *decode-position*))
    (setf *decode-position* (octet-bit (length *decode-buffer*)))))

(defmacro dpb! (value bytespec place)
  "Deposit VALUE into BYTESPEC of PLACE."
  `(setf ,place (dpb ,value ,bytespec ,place)))

;;; I've written this function countless times but it always comes out
;;; ugly. What's the right way?
(defun grab-bits (bits)
  "Grab a BITS-long unsigned integer"
  (let ((accumulator 0)
        (remaining bits))
    (flet ((accumulate-byte ()
             ;; Accumulate the relevant part of the current byte and
             ;; advance to the next one.
             (let* ((size (min remaining (- 8 (rem *decode-position* 8))))
                    (offset (rem (- 8 (rem (+ *decode-position* size) 8)) 8))
                    (value (ldb (byte size offset)
                                (aref *decode-buffer*
                                      (bit-octet *decode-position* nil)))))
               (decf remaining size)
               (dpb! value (byte size remaining) accumulator)
               (incf *decode-position* size))))
      (loop while (plusp remaining)
            do (accumulate-byte))
      accumulator)))

(defun grab-bitflag ()
  "Grab a single bit. Return T if it's 1 and NIL if it's 0."
  (= (grab-bits 1) 1))

;;;## Output "shoving"

(defvar *encode-buffer* nil
  "Buffer (adjustable and with fill-pointer) for encoding data into.")

(defvar *encode-position* nil
  "The encoding position in *ENCODE-BUFFER*.")

(defvar *encode-bit-bucket* 0 "Accumulator for smaller-than-byte output.")
(defvar *encode-bit-offset* 0 "The current accumulator bit-position.")

(defmacro with-buffer-output (() &body body)
  `(let ((*encode-buffer* (make-array '(0) :element-type 'octet
                                      :adjustable t :fill-pointer 0))
         (*encode-position* 0)
         (*encode-bit-bucket* 0)
         (*encode-bit-offset* 0))
    , at body
    (coerce *encode-buffer* 'buffer)))

(defun encoding-position ()
  (length *encode-buffer*))

(defmacro with-buffer-patch (position &body body)
  "Shove output at POSITION, overwriting any that was already there.
Used within WITH-BUFFER-OUTPUT."
  `(let ((*encode-position* ,position))
    , at body))

;;; "Shove" functions extend `*encode-buffer*' and advance
;;; `*encode-position*'.

(defun shove-octet (octet)
  (unless (zerop *encode-bit-offset*)
    (error "Attempt to shove an octet at unaligned position."))
  (cond ((= *encode-position* (length *encode-buffer*))
         (vector-push-extend octet *encode-buffer*)
         (incf *encode-position*)) 
        ((< *encode-position* (length *encode-buffer*))
         (setf (aref *encode-buffer* *encode-position*) octet)
         (incf *encode-position*))
        (t
         (error "Can't shove to position ~D with ~D-length buffer!"
                *encode-position* (length *encode-buffer*)))))

(defun shove-ethernet-address (address)
  (shove-vector (ethernet-address.octets address)))

(defun shove-ipv4-address (address)
  (shove-vector (ipv4-address.octets address)))

(defun shove-vector (vector)
  (map nil #'shove-octet vector))

(defun shove-bits (value nbits)
  "Shove NBITS of VALUE."
  (cond ((zerop nbits))
        ((< (+ *encode-bit-offset* nbits) 8)
         ;; We can fit NBITS into the accumulator without filling it.
         ;; Deposit VALUE into the most-significant accumulator bits
         ;; available.
         (let ((store-offset (- 8 nbits *encode-bit-offset*)))
           (dpb! value (byte nbits store-offset) *encode-bit-bucket*)
           (incf *encode-bit-offset* nbits)))
        (t
         ;; We have at least enough data to complete a byte. We
         ;; consume enough of VALUE's most-significant bits to fill
         ;; the accumulator, output a byte, then recurse on any
         ;; remainder.
         (let* ((take-bits (- 8 *encode-bit-offset*))
                ;; The TAKE-BITS most-significant bits of VALUE.
                (take-value (ldb (byte take-bits (- nbits take-bits)) value))
                (store-offset (- 8 take-bits *encode-bit-offset*))
                (remaining (- nbits take-bits)))
           (dpb! take-value (byte take-bits store-offset) *encode-bit-bucket*)
           (setf *encode-bit-offset* 0)
           (shove-octet *encode-bit-bucket*)
           ;; Recurse with the remainder.
           (shove-bits value remaining)))))

;;;# Protocol implementations
;;;
;;; Each protocol defines a pair of GRAB and SHOVE functions for its
;;; headers.

(defvar *resolve-protocols* t
  "When non-nil protocol numbers are resolved to symbolic names.
Unrecognised numbers are left as numbers.")

(defun lookup (key alist &key (errorp t) (reversep nil))
  "Lookup the value of KEY in ALIST.
If the key is not present and ERRORP is true then an error is
signalled; if ERRORP is nil then the key itself is returned."
  (let ((entry (funcall (if reversep #'rassoc #'assoc) key alist)))
    (cond (entry  (funcall (if reversep #'car #'cdr) entry))
          (errorp (error "Key ~S is not present in ~A." key alist))
          (t      key))))

(defun rlookup (key alist)
  "Lookup the value of KEY in CDR-position in ALIST, else return KEY."
  (lookup key alist :errorp nil :reversep t))

;;;## Ethernet

;;;### ethernet-address
;;;
;;; This big `eval-when' is needed to define the read-syntax for
;;; `ethernet-address' such that it can be used in this file.
;;;
;;; The read syntax is `#e"ff:00:1:2:3:4'.
;;;
(eval-when (:compile-toplevel :load-toplevel :execute)
  (defstruct (ethernet-address (:conc-name #:ethernet-address.)
                               (:print-function print-ethernet-address))
    "48-bit Ethernet MAC address."
    (octets (ext:required-argument) :type (array octet (6))))

  (defun read-ethernet-address (stream &optional c n)
    "Read an ethernet address in colon-separated syntax.
     Example: #e\"1:2:3:4:5:6\""
    (declare (ignore c n))
    (let ((value-stream (make-string-input-stream (read stream t nil t)))
          (*readtable* (copy-readtable))
          (*read-base* 16))
      (set-syntax-from-char #\: #\Space)
      (let ((vec (make-array '(6) :element-type 'octet)))
        (dotimes (i 6)
          (let ((octet (read value-stream t nil t)))
            (unless *read-suppress*
              (setf (elt vec i) octet))))
        (unless *read-suppress*
          (make-ethernet-address :octets vec)))))
  
  (set-dispatch-macro-character #\# #\e 'read-ethernet-address)

  (defun print-ethernet-address (address stream depth)
    "Print ethernet addresses as in #e\"0:ff:1:2:3:4\"."
    (declare (ignore depth))
    (format stream "#e\"~{~16,2,'0R~^:~}\""
            (coerce (ethernet-address.octets address) 'list)))

  (defmethod make-load-form ((s ethernet-address) &optional env)
    (make-load-form-saving-slots s :environment env)))

;;;### Decode and encode

(defstruct (ethernet-header (:conc-name #:ethernet-header.))
  (dest     nil :type (or null ethernet-address))
  (source   nil :type (or null ethernet-address))
  (protocol nil :type (or null (unsigned-byte 16) symbol)))

(defparameter *ethernet-protocol-names* '((#x0806 . :arp) (#x0800 . :ipv4))
  "Mapping from ethernet protocol numbers to symbolic names.")

(defun grab-ethernet-header ()
  "Grab an ethernet header and call FUNCTION with each part."
  (let ((struct (make-ethernet-header)))
    (flet ((header (name value) (setf (slot-value struct name) value)))
      (header 'dest     (grab-ethernet-address))
      (header 'source   (grab-ethernet-address))
      (header 'protocol (ethernet-protocol-name (grab-bits 16))))
    struct))

(defun ethernet-protocol-name (number)
  "Return the symbolic protocol name of NUMBER, if appropriate."
  (if *resolve-protocols*
      (lookup number *ethernet-protocol-names* :errorp nil)
      number))

(defun shove-ethernet-header (header)
  (declare (type ethernet-header header))
  (with-slots (dest source protocol) header
    (shove-ethernet-address dest)
    (shove-ethernet-address source)
    (shove-bits (rlookup protocol *ethernet-protocol-names*) 16))
  (constantly nil))

;;;## ARP

(defstruct (arp-header (:conc-name #:arp-header.))
  (hardware-type   nil :type (or null (unsigned-byte 16)))
  (protocol-type   nil :type (or null (unsigned-byte 16)))
  (hardware-length nil :type (or null (unsigned-byte 8)))
  (protocol-length nil :type (or null (unsigned-byte 8)))
  (operation       nil :type (or null symbol (unsigned-byte 16)))
  (sender-ha       nil :type (or null ethernet-address))
  (sender-ip       nil :type (or null ipv4-address))
  (target-ha       nil :type (or null ethernet-address))
  (target-ip       nil :type (or null ipv4-address)))

(defun grab-arp-header ()
  "Grab an ARP header and call FUNCTION with each part."
  (let ((struct (make-arp-header)))
    (flet ((header (name value) (setf (slot-value struct name) value)))
      (header 'hardware-type (grab-bits 16))
      (header 'protocol-type (grab-bits 16))
      (header 'hardware-length (grab-bits 8))
      (header 'protocol-length (grab-bits 8))
      (header 'operation (arp-operation (grab-bits 16)))
      (header 'sender-ha (grab-ethernet-address))
      (header 'sender-ip (grab-ipv4-address))
      (header 'target-ha (grab-ethernet-address))
      (header 'target-ip (grab-ipv4-address)))
    struct))

(defvar *arp-operation-names* '((1 . :request) (2 . :response))
  "Mapping between ARP operation numbers and their symbolic names.")

(defun arp-operation (operation)
  "Return the symbolic name for OPERATION, if appropriate."
  (if *resolve-protocols*
      (lookup operation *arp-operation-names* :errorp nil)
      operation))

(defun shove-arp-header (header)
  (declare (type arp-header header))
  (with-slots (hardware-type protocol-type hardware-length protocol-length
               operation sender-ha sender-ip target-ha target-ip)
      header
    (shove-bits hardware-type 16)
    (shove-bits protocol-type 16)
    (shove-octet hardware-length)
    (shove-octet protocol-length)
    (shove-bits (rlookup operation *arp-operation-names*) 16)
    (shove-ethernet-address sender-ha)
    (shove-ipv4-address sender-ip)
    (shove-ethernet-address target-ha)
    (shove-ipv4-address target-ip))
  (constantly nil))

;;;## IPv4
;;;
;;; The Internet Protocol is described in RFC791.
;;;
;;;### ipv4-address
;;;
;;; IP addresses also have a special read-syntax: `@10.0.0.1'.
;;;
(eval-when (:compile-toplevel :load-toplevel :execute)
  (defstruct (ipv4-address (:conc-name #:ipv4-address.)
                           (:print-function print-ipv4-address))
    (octets (ext:required-argument) :type (array octet (4))))

  (defun read-ipv4-address (stream &optional c n)
    "Read an IPv4 address in dotted-quad format.
     Example: @192.168.0.1"
    (declare (ignore c n))
    (let ((*readtable* (copy-readtable)))
      (set-syntax-from-char #\. #\Space)
      (let ((vec (make-array '(4) :element-type 'octet)))
        (dotimes (i 4)
          (let ((octet (read stream t nil t)))
            (unless *read-suppress*
              (setf (elt vec i) octet))))
        (unless *read-suppress*
          (make-ipv4-address :octets vec)))))
  
  (set-macro-character #\@ 'read-ipv4-address t)

  (defun print-ipv4-address (address stream depth)
    "Print IPv4 addresses as in @192.168.0.1."
    (declare (ignore depth))
    (format stream "@~{~A~^.~}" (coerce (ipv4-address.octets address) 'list)))
  
  (defmethod make-load-form ((s ipv4-address) &optional env)
    (make-load-form-saving-slots s :environment env)))

;;;### decoder

(defstruct (ipv4-header (:conc-name #:ipv4-header.))
  (version         nil :type (or null (unsigned-byte 4)))
  (hlen            nil :type (or null (unsigned-byte 4)))
  (tos             nil :type (or null (unsigned-byte 8)))
  (total-len       nil :type (or null (unsigned-byte 16)))
  (id              nil :type (or null (unsigned-byte 16)))
  (flags           nil :type (or null (unsigned-byte 3)))
  (fragment-offset nil :type (or null (unsigned-byte 13)))
  (ttl             nil :type (or null (unsigned-byte 8)))
  (protocol        nil :type (or null symbol (unsigned-byte 8)))
  (checksum        nil :type (or null (unsigned-byte 16)))
  (source          nil :type (or null ipv4-address))
  (dest            nil :type (or null ipv4-address)))

(defconstant ipv4-min-hlen 5
  "The header length (in 32-bit words) of an IPv4 packet with no options.")

(defun grab-ipv4-header ()
  (let ((struct (make-ipv4-header))
        (header-start-pos (bit-octet *decode-position*))
        hlen
        checksum)
    (flet ((header (name value) (setf (slot-value struct name) value)))
      (header 'version         (grab-bits 4))
      (header 'hlen            (setf hlen (grab-bits 4)))
      (header 'tos             (grab-bits 8))
      (header 'total-len       (grab-bits 16))
      (header 'id              (grab-bits 16))
      (header 'flags           (grab-bits 3))
      (header 'fragment-offset (grab-bits 13))
      (header 'ttl             (grab-bits 8))
      (header 'protocol        (if *resolve-protocols*
                                   (ipv4-protocol (grab-bits 8))
                                 (grab-bits 8)))
      (header 'checksum        (setf checksum (grab-bits 16)))
      (header 'source          (grab-ipv4-address))
      (header 'dest            (grab-ipv4-address))
      ;; FIXME
      (unless (= hlen ipv4-min-hlen)
        (error "Can't decode options in IPv4 packets."))
      (let* ((initial (- checksum))
             (header-octets (* hlen 4))
             (computed-checksum
              (checksum *decode-buffer*
                        :position header-start-pos
                        :length header-octets
                        :initial initial)))
        (unless (eql checksum computed-checksum)
          (error "Bad checksum: Got ~D, computed ~D."
                 checksum computed-checksum))))
    struct))

(defvar ipv4-protocol-names '((1 . :icmp) (6 . :tcp) (17 . :udp))
  "Mapping between IPv4 protocol numbers and their symbolic names.")

(defun ipv4-protocol (number)
  "Return the symbolic name for protocol NUMBER, if appropriate."
  (if *resolve-protocols*
      (lookup number ipv4-protocol-names :errorp nil)
      number))

(defconstant ipv4-no-options-hlen 5)

(defun shove-ipv4-header (header)
  "Shove an IPv4 header.
The length and checksum fields are computed automatically."
  (with-slots (version hlen tos total-len id flags fragment-offset ttl
               protocol checksum source dest)
      header
    (let (start total-len-pos checksum-pos)
      (setf start (encoding-position))
      (shove-bits version 4)
      (shove-bits ipv4-no-options-hlen 4)
      (shove-bits tos 8)
      (setf total-len-pos (encoding-position))
      (shove-bits 0 16)                 ; total-len
      (shove-bits id 16)
      (shove-bits flags 3)
      (shove-bits fragment-offset 13)
      (shove-bits ttl 8)
      (shove-bits (rlookup protocol ipv4-protocol-names) 8)
      ;; Remember where the checksum is: we have to come back and
      ;; patch it in.
      (setf checksum-pos (encoding-position))
      (shove-bits 0 16)
      (shove-ipv4-address source)
      (shove-ipv4-address dest)
      (lambda ()
        (with-buffer-patch total-len-pos
          (let ((total-len (- (length *encode-buffer*) start)))
            (shove-bits total-len 16)))
        (with-buffer-patch checksum-pos
          (shove-bits (checksum *encode-buffer*
                                :position start
                                :length (* ipv4-no-options-hlen 4))
                      16))))))

;;;## UDP

;;; RFC 768

(defstruct (udp-header (:conc-name #:udp-header.))
  (src-port      nil :type (or null (unsigned-byte 16)))
  (dest-port     nil :type (or null (unsigned-byte 16)))
  (length        nil :type (or null (unsigned-byte 16)))
  (checksum      nil :type (or null (unsigned-byte 16))))

(defun grab-udp-header (&optional src-ip dest-ip)
  "Grab a UDP header and call FUNCTION with each part.
The checksum can only be checked if the SRC-IP and DEST-IP fields from
the IPv4 header are supplied."
  (let ((struct (make-udp-header))
        (header-start (bit-octet *decode-position*))
        checksum length)
    (flet ((header (name value) (setf (slot-value struct name) value)))
      (header 'src-port  (grab-bits 16))
      (header 'dest-port (grab-bits 16))
      (header 'length    (setf length (grab-bits 16)))
      (header 'checksum  (setf checksum (grab-bits 16)))
      (when (and src-ip dest-ip)
        (unless (zerop checksum)        ; checksum is optional
          (let* ((init (- (udp-pseudo-header-checksum-acc
                           src-ip dest-ip length)
                          checksum))
                 (computed-checksum (checksum *decode-buffer*
                                              :position header-start
                                              :length length
                                              :initial init)))
            (unless (eql checksum computed-checksum)
              (error "Bad checksum: Got ~D, computed ~D."
                     checksum computed-checksum))))))
    struct))

(defun udp-pseudo-header-checksum-acc (src-ip dest-ip udp-length)
  (+ (checksum-acc-ipv4-address src-ip)
     (checksum-acc-ipv4-address dest-ip)
     (lookup :udp ipv4-protocol-names :reversep t)
     udp-length))

(defun shove-udp-header (header src-ip dest-ip)
  "Shove a UDP header.
SRC-IP and DEST-IP are from the outer IPv4 header."
  (with-slots (src-port dest-port checksum) header
    (let ((start-pos (encoding-position))
          length-pos checksum-pos)
      (shove-bits src-port 16)
      (shove-bits dest-port 16)
      (setf length-pos (encoding-position))
      (shove-bits 0 16)
      (setf checksum-pos (encoding-position))
      (shove-bits 0 16)
      (lambda ()
        (let ((length (- (length *encode-buffer*) start-pos)))
          (with-buffer-patch length-pos
            (shove-bits length 16))
          (let ((csum (checksum *encode-buffer*
                                :position start-pos
                                :initial (udp-pseudo-header-checksum-acc
                                          src-ip dest-ip length))))
            (with-buffer-patch checksum-pos
              (shove-bits csum 16))))))))

;;;# Checksum computation
;;;
;;; The TCP/IP protocols use 16-bit ones-complement checksums. See
;;; RFC1071 for details.

(defun checksum (buffer
                 &key
                 (position 0)
                 (length (- (length buffer) position))
                 (initial 0)
                 (finish t))
  "Compute a checksum using normal twos-complement arithmetic.
The buffer is treated as a sequence of 16-bit big-endian numbers."
  (declare (type buffer buffer))
  (let ((last-pos (+ position (1- length)))
        (acc initial))
    (do ((msb-pos position      (+ msb-pos 2))
         (lsb-pos (1+ position) (+ lsb-pos 2)))
        ((> msb-pos last-pos))
      (let ((msb (aref buffer msb-pos))
            (lsb (if (> lsb-pos last-pos) 0 (aref buffer lsb-pos))))
        (incf acc (dpb msb (byte 8 8) lsb))))
    (if finish (finish-checksum acc) acc)))

(defun finish-checksum (n)
  "Convert N into an unsigned 16-bit ones-complement number.
The result is a bit-pattern also represented as an integer."
  (let* ((acc (+ (ldb (byte 16 16) n)
                 (ldb (byte 16 0) n)))
         (acc (+ acc (ldb (byte 16 16) acc))))
    (logxor #xFFFF (ldb (byte 16 0) acc))))

(defun checksum-acc-ipv4-address (address)
  "Return the partial checksum accumulated from an IPv4 address."
  (checksum (ipv4-address.octets address) :finish nil))

;;;# Decoding driver

(defvar *previous-header* nil
  "Bound to the previously decoded header.
Some protocols (e.g. UDP) need to retrieve fields from their enclosing
protocol's header.")

(defun decode-headers (buffer)
  "Return a list of decoded headers from BUFFER"
  (with-buffer-input buffer
    (let* ((headers (grab-more-headers (grab-header :ethernet)))
           (rest (grab-rest)))
      (if (zerop (length rest))
          headers
          (append headers (list rest))))))

(defun grab-more-headers (header)
  "Accumulate HEADER and continue decoding the rest."
  (if (member (type-of header) '(ethernet-header ipv4-header))
      (let ((*previous-header* header)
            (inner-protocol (slot-value header 'protocol)))
        (cons header (grab-more-headers (grab-header inner-protocol))))
      ;; This is the last header we know how to decode.
      (list header)))

(defun grab-header (protocol)
  "Grab and return the header of PROTOCOL."
  (case protocol
    (:ethernet (grab-ethernet-header))
    (:arp      (grab-arp-header))
    (:ipv4     (grab-ipv4-header))
    (:udp      (let ((src-ip  (slot-value *previous-header* 'source))
                     (dest-ip (slot-value *previous-header* 'dest)))
                 (grab-udp-header src-ip dest-ip)))))

;;;# Encoding driver
;;;
;;; To encode a packet we "shove" each element into a vector and then
;;; apply the "touchup functions".

(defun encode-headers (headers)
  (let (src-ip dest-ip)
    (flet ((shove-element (e)
             ;; Shove E into the encoding vector and return a touchup.
             (etypecase e
               (buffer
                (shove-vector e)
                (constantly nil))
               (ethernet-header
                (shove-ethernet-header e))
               (arp-header
                (shove-arp-header e))
               (ipv4-header
                (setf src-ip (ipv4-header.source e))
                (setf dest-ip (ipv4-header.dest e))
                (shove-ipv4-header e))
               (udp-header
                (assert (and src-ip dest-ip))
                (shove-udp-header e src-ip dest-ip)))))
      (with-buffer-output ()
        (let ((touchups '()))
          (dolist (e headers)
            (push (shove-element e) touchups))
          (mapc #'funcall touchups))))))

;;;# Sample packets

(defparameter *arp-packet*
  (coerce
   #(255 255 255 255 255 255 0 8 116 228 110 188 8 6 0 1 8 0 6 4 0 1 0 8 116
     228 110 188 192 168 128 44 0 0 0 0 0 0 192 168 128 1)
   'buffer)
  "An ethernet frame containing an ARP request.")

(defparameter *udp-packet*
  (coerce
   #(255 255 255 255 255 255 0 8 116 228 110 188 8 0 69 0 0 124 0 0 64 0 64
     17 183 244 192 168 128 44 192 168 128 255 128 117 0 111 0 104 5 206 20
     15 249 61 0 0 0 0 0 0 0 2 0 1 134 160 0 0 0 2 0 0 0 5 0 0 0 1 0 0 0 24
     64 158 126 39 0 0 0 4 100 111 100 111 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0
     0 0 0 0 1 134 164 0 0 0 2 0 0 0 2 0 0 0 16 0 0 0 12 98 108 117 101 116
     97 105 108 46 99 111 109)
   'buffer)
  "An ethernet frame containing a UDP packet.")

(defun test ()
  (decode-test)
  (encode-test)
  'ok)

(defun decode-test ()
  "Test that the sample packets are decoded correctly."
  (let* ((arp-headers (decode *arp-packet*))
         (udp-headers (decode *udp-packet*)))
    (check-headers arp-headers
                   '((ETHERNET-HEADER
                      ((DEST            . #e"FF:FF:FF:FF:FF:FF")
                       (SOURCE          . #e"00:08:74:E4:6E:BC")
                       (PROTOCOL        . :ARP)))
                     (ARP-HEADER
                      ((HARDWARE-TYPE   . 1)
                       (PROTOCOL-TYPE   . 2048)
                       (HARDWARE-LENGTH . 6)
                       (PROTOCOL-LENGTH . 4)
                       (OPERATION       . :REQUEST)
                       (SENDER-HA       . #e"00:08:74:E4:6E:BC")
                       (SENDER-IP       . @192.168.128.44)
                       (TARGET-HA       . #e"00:00:00:00:00:00")
                       (TARGET-IP       . @192.168.128.1)))))
    (check-headers udp-headers
                   `((ETHERNET-HEADER
                      ((DEST            . #e"FF:FF:FF:FF:FF:FF")
                       (SOURCE          . #e"00:08:74:E4:6E:BC")
                       (PROTOCOL        . :IPV4)))
                     (IPV4-HEADER
                      ((VERSION         . 4)
                       (HLEN            . 5)
                       (TOS             . 0)
                       (TOTAL-LEN       . 124)
                       (ID              . 0)
                       (FLAGS           . 2)
                       (FRAGMENT-OFFSET . 0)
                       (TTL             . 64)
                       (PROTOCOL        . :UDP)
                       (CHECKSUM        . 47092)
                       (SOURCE          . @192.168.128.44)
                       (DEST            . @192.168.128.255)))
                     (UDP-HEADER
                      ((SRC-PORT        . 32885)
                       (DEST-PORT       . 111)
                       (LENGTH          . 104)
                       (CHECKSUM        . 1486)))
                     ,(coerce
                       #(20 15 249 61 0 0 0 0 0 0 0 2 0 1 134 160 0 0 0
                         2 0 0 0 5 0 0 0 1 0 0 0 24 64 158 126 39 0 0 0
                         4 100 111 100 111 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0
                         0 0 0 0 0 0 1 134 164 0 0 0 2 0 0 0 2 0 0 0 16 0
                         0 0 12 98 108 117 101 116 97 105 108 46 99 111 109)
                       'buffer)))))

(defun check-headers (headers specs)
  "Check that HEADERS agrees element-wise with SPECS.
SPECS is a list of specifications of what a header should contain."
  (flet ((check (header spec)
           ;; Raise an error if HEADER doesn't match SPEC.
           (loop for (slot . value) in (second spec)
                 do (unless (equalp (slot-value header slot) value)
                      (error "Slot ~A: Expected ~A, got ~A."
                             slot value (slot-value header slot)))
                 always t)))
    (unless (and (null headers) (null specs))
      (let ((header (first headers))
            (spec   (first specs)))
        (if (and (typep header 'buffer) (typep spec 'buffer))
            (unless (equalp header spec)
              (error "Mismatch in binary parts."))
            (progn
              (unless (eq (type-of header) (first spec))
                (error "Header type mismatch: ~A ~A"
                       (type-of header) (first spec)))
              (check header spec)
              (check-headers (rest headers) (rest specs))))))))

(defun encode-test ()
  "Check that (encode (decode PACKET)) <=> identity."
  (assert (and (equalp *udp-packet* (encode (decode *udp-packet*)))
               (equalp *arp-packet* (encode (decode *arp-packet*))))))

(defun bench (n)
  "Show how long it takes to decode and re-encode 10^N UDP packets."
  (time (dotimes (i (expt 10 n))
          (encode (decode *udp-packet*)))))

;;;# Exporting structures
;;;
;;; My pet hate is explicitly enumerating all the accessors for
;;; structures in export declarations. Instead we do a little
;;; introspection to enumerate them automatically, and jump through
;;; some hoops with `defpackage' (above) to avoid warnings.

(eval-when (:compile-toplevel :load-toplevel)

  (defun structure-exports ()
    "The list of defstruct-defined symbols that we want to export."
    (apply #'append (mapcar #'structure-symbol-names
                            '(ethernet-header ethernet-address
                              arp-header
                              ipv4-header ipv4-address
                              udp-header))))

  (defun structure-symbol-names (name)
    "Return all the interesting symbols generated by DEFSTRUCT for NAME.
     Assumes a FOO type name, MAKE-FOO constructor, and FOO-P
     predicate to avoid excessively low-level introspection."
    (list* name
           (find-symbol (format nil "~A-P" name))
           (find-symbol (format nil "MAKE-~A" name))
           (structure-accessors name)))

  (defun structure-accessors (name)
    (mapcar #'pcl::slot-definition-defstruct-accessor-symbol
            (pcl:class-direct-slots (find-class name))))

  (export (structure-exports)))




From mb at bese.it  Fri Jul 16 11:36:12 2004
From: mb at bese.it (Marco Baringer)
Date: Fri, 16 Jul 2004 13:36:12 +0200
Subject: [Small-cl-src] WITH*
Message-ID: <m2n020fakz.fsf@convey.it>


;;;; Alleviate deep nesting. Suggestions for a better name are welcome.
;;;;
;;;; An example will explain this far better than i can with words, so:
;;;;
;;;; (with*
;;;;   (let ((*special* '())) (declare (special *special*)))
;;;;   (dolist (a a-list))
;;;;   (with-slots (foo bar baz) a)
;;;;   (multiple-value-bind (c d e) (process baz))
;;;;   (progn
;;;;     body))
;;;; ==>
;;;; (let ((*special* '()))
;;;;   (declare (special *special*))
;;;;   (dolist (a a-list)
;;;;     (with-slots (foo bar baz)
;;;;         a
;;;;       (multiple-value-bind (c d e)
;;;;           (process baz)
;;;;         body))))

(defmacro with* (&body body)
  (cond
    ((cddr body)
     (append (first body) `((with* ,@(cdr body)))))
    ((cdr body)
     `(,@(first body) ,(second body)))
    (body (first body))
    (t nil)))

-- 
-Marco
Ring the bells that still can ring.
Forget your perfect offering.
There is a crack in everything.
That's how the light gets in.
     -Leonard Cohen