Hello
I have always been annoyed by some C idioms when it comes to unions
and arrays. A typical example is the following
union {
struct {
char a[3];
char b[5];
} slice;
char raw[8];
} the_packet;
So I embarked in making a nice CL facility that would do pretty much
the same thing (although in an obviously more bloated way :) ).
So... here it is for you to enjoy. I'd appreaciate any feedback. In
particular I am not very happy with the name of the main macro
"DEFINE-ARRAY-WITH-VIEWS", but I couldn't find anything better.
Cheers
Marco
Here it is
displaced-arrays-pkg.lisp ==============================
;;; -*- Mode: CLtL -*-
;;; displaced-arrays-pkg.lisp --
;;;==============================================================================
;;; COPYRIGHT Notice
;;;
;;; Copyright (C) 1999 Marco Antoniotti, all rights reserved.
;;;
;;; ****************************************************************
;;; General License Agreement and Lack of Warranty *****************
;;; ****************************************************************
;;;
;;; This software is distributed in the hope that it will be useful (both
;;; in and of itself and as an example of lisp programming), but WITHOUT
;;; ANY WARRANTY. The author(s) do not accept responsibility to anyone for
;;; the consequences of using it or for whether it serves any particular
;;; purpose or works at all. No warranty is made about the software or its
;;; performance.
;;;
;;; This software is made available AS IS, and is distributed in the
;;; public domain without warranty of any kind, either expressed or
;;; implied.
;;;
;;; In no event will the author(s) or her/his/their institution(s) be
;;; liable to you for damages, including lost profits, lost monies, or
;;; other special, incidental or consequential damages arising out of
;;; or in connection with the use or inability to use (including but
;;; not limited to loss of data or data being rendered inaccurate or
;;; losses sustained by third parties or a failure of the program to
;;; operate as documented) the program, even if you have been advised
;;; of the possibility of such damanges, or for any claim by any other
;;; party, whether in an action of contract, negligence, or other
;;; tortious action.
(defpackage "CL.EXT.DISPLACED-ARRAYS" (:use "COMMON-LISP")
(:nicknames "DV-ARRAYS")
(:documentation
"This package contains the definition of the DEFINE-ARRAY-WITH-VIEWS macro.
Please refer to the documentation string of the macro itself for a
description of its capabilities.")
(:export "DEFINE-ARRAY-WITH-VIEWS"))
;;; end of file -- displaced-arrays-pkg.lisp --
end of displaced-arrays-pkg.lisp =======================
displaced-arrays.lisp ==================================
;;; -*- Mode: CLtL -*-
;;; displaced-arrays.lisp -- An extension to quickly define in a
;;; single place arrays with slices. I.e. how to simulate the C idiom
;;;
;;; typedef union _packet_ {
;;; struct {
;;; int a[3];
;;; int b[3];
;;; } slices;
;;; int raw[6];
;;; } packet;
;;;
;;; Author: Marco Antoniotti
;;; Date: 19990115
;;; Version: 0.99 alfa.
;;;
;;; Commentary:
;;;
;;; We use displaced arrays and the automatic definition of several
;;; accessors in order to achieve the same effect in a more controlled
;;; way.
;;;
;;; (define-array-with-views (packet 6 :initial-element 0
;;; :element-type '(unsigned-byte 8))
;;; (:view slice-a 3)
;;; (:view slice-b 3 :displaced-index-offset 3))
;;;
;;; This form defines a constructor for the whole array and accessors
;;; for each 'view'. In the above example you would get
;;;
;;; MAKE-PACKET to create an 'array' of length 6 with two displaced
;;; arrays.
;;; PACKET-P to check whether an object is a packet.
;;; PACKET to access the whole array.
;;; SLICE-A to access the first view (or slice).
;;; SLICE-B to access the second view.
;;;
;;; To do:
;;;
;;; - more error checking on the definition form.
;;;==============================================================================
;;; COPYRIGHT Notice
;;;
;;; Copyright (C) 1999 Marco Antoniotti, all rights reserved.
;;;
;;; ****************************************************************
;;; General License Agreement and Lack of Warranty *****************
;;; ****************************************************************
;;;
;;; This software is distributed in the hope that it will be useful (both
;;; in and of itself and as an example of lisp programming), but WITHOUT
;;; ANY WARRANTY. The author(s) do not accept responsibility to anyone for
;;; the consequences of using it or for whether it serves any particular
;;; purpose or works at all. No warranty is made about the software or its
;;; performance.
;;;
;;; This software is made available AS IS, and is distributed in the
;;; public domain without warranty of any kind, either expressed or
;;; implied.
;;;
;;; In no event will the author(s) or her/his/their institution(s) be
;;; liable to you for damages, including lost profits, lost monies, or
;;; other special, incidental or consequential damages arising out of
;;; or in connection with the use or inability to use (including but
;;; not limited to loss of data or data being rendered inaccurate or
;;; losses sustained by third parties or a failure of the program to
;;; operate as documented) the program, even if you have been advised
;;; of the possibility of such damanges, or for any claim by any other
;;; party, whether in an action of contract, negligence, or other
;;; tortious action.
;;;==============================================================================
;;; Prologue
(eval-when (load compile eval)
(unless (find-package "CL.EXT.DISPLACED-ARRAYS")
(load "displaced-arrays-pkg")))
(in-package "CL.EXT.DISPLACED-ARRAYS")
;;;==============================================================================
;;; Implementation
;;; define-array-with-views -- The main (and only) entry point.
;;;
;;; NOTE: The handling of :initial-contents and of :initial-element is
;;; rather fuzzy. The solution I chose, may not signal a condition at
;;; 'definition' time, but only when the actual constructor is
;;; called. This happens also in standard CL practice. The example is
;;; supplying an :initial-content which is too short. In order to
;;; catch this error at definition time, you would have to evaluate
;;; the forms at definition time and re-evaluate them at construction
;;; time. Not a pretty thing.
;;; Therefore I do exactly as standard CL practice. An error in either
;;; keyword argument is signalled only at construction time (cfr. a
;;; DEFSTRUCT with a MAKE-ARRAY init form).
(defmacro define-array-with-views ((name dimension
&key
(initial-element nil ie-supplied-p)
(initial-contents nil ic-supplied-p)
(element-type t))
&rest options
)
"Defines a set of 'shared' array structures.
This form defines a centralized way to construct and manipulate an
array with 'views' or 'slices' (i.e. displaced sub-arrays). Its main
benefit is in the unique definition of what it is usually achieved
with a complex set of displaced arrays.
The definition form has the following syntax:
(DEFINE-ARRAY-WITH-VIEWS (<name> <dimension>
:element-type <element-type>
:initial-element <initial-element>
:initial-contents <initial-contents>)
<view-form>*)
where <element-type>, <initial-element>, and <initial-contents> have
the same meaning and relative restrictions as per MAKE-ARRAY.
Each <view-form> has the following syntax.
(<view-name> <dimension> &key displaced-index-offset <offset>)
where <offset> defaults to 0.
A typical example of the use of DEFINE-ARRAYS-WITH-VIEWS is in the
definition of network packet structures.
The definition form expands into a DEFSTRUCT named <name> which holds
in its slots the real (or 'raw') array and its displaced forms and a
constructor MAKE-<name> which takes care to create all the necessary
displacements. I.e. a DEFINE-ARRAY-WITH-VIEWS form with N views will
expand into a DEFSTRUCT with N+1 slots and a constructor."
(when (and ie-supplied-p ic-supplied-p)
(error 'simple-error
:format-control "Cannot supply both :initial-element and ·@
:initial-contents to DEFINE-ARRAY-WITH-VIEWS."))
(let ((constructor-visible-name
(intern (concatenate 'string "MAKE-" (symbol-name name))))
(constructor-internal-name
(intern (format nil "ARRAY-WITH-VIEWS ~A CONSTRUCTOR"
name)
;; *package*
(find-package "CL.EXT.DISPLACED-ARRAYS")
))
(array-views (process-view-options options 'raw-array))
)
`(progn
;; The DEFSTRUCT wrapper.
;; Should add some more structure to the slot type. ARRAY could
;; be made into a better type specifier
(defstruct (,name (:conc-name nil)
(:constructor ,constructor-internal-name
(,name ,@(mapcar #'first array-views))))
(,name nil :type (array * (*)) :read-only t)
,@(make-view-slots array-views)
) ; DEFSTRUCT
;; The defined interface MAKE-<name>.
(defun ,constructor-visible-name (&key (initial-element
,initial-element ie-supplied-p)
(initial-contents
,initial-contents ic-supplied-p)
;; no :element-type
)
;; Some error checking
(when (and ic-supplied-p ie-supplied-p)
(error "Cannot sypply both :initial-element and ·@
:initial-contents to ~S."
',constructor-visible-name))
(when (and ic-supplied-p
(/= (length initial-contents) ,dimension))
(error 'simple-error
:format-control "~D elements in the initial-contents, ·@
but the vector length is ~D."
:format-arguments (list (length initial-contents)
,dimension)))
;; The real body
(handler-case
(let* ((make-array-actual-args
(list* :element-type ,element-type
(if ie-supplied-p
(list :initial-element initial-element)
(list :initial-contents initial-contents))))
(raw-array (apply #'make-array
',dimension
make-array-actual-args))
,@array-views
)
(,constructor-internal-name raw-array
,@(mapcar #'first array-views))
)
(simple-error (e)
;; Resignal the error in the proper context.
;; Note: SIMPLE-ERROR is what CMUCL signals in
;; most cases. The handler may need tuning for
;; other CL implementations.
(error 'simple-error
:format-control
(simple-condition-format-control e)
:format-arguments
(simple-condition-format-arguments e)))
)) ; DEFUN
',name ; Return the NAME from the macro.
)))
;;; process-view-option -- An auxiliary function.
(defun process-view-options (array-view-options displaced-array-ref)
(let ((view-options (loop for opt in array-view-options
if (and (listp opt) (eq (first opt) :view))
collect (rest opt)
else do (error 'simple-error
:format-control
"Malformed :view option ~S."
:format-arguments (list opt))))
)
(loop for vopt in view-options
;; do (print vopt) ; debugging
collect
(destructuring-bind (name dims &key (displaced-index-offset 0)) vopt
;; Some more error checking should be inserted right here
;; on the content of the SPECS variable.
;;
;; E.g. null NAME or DIMS should be properly checked.
`(,name (make-array ,dims
:displaced-to ,displaced-array-ref
:displaced-index-offset ,displaced-index-offset)))
)))
;;; make-view-option -- An auxiliary function.
(defun make-view-slots (array-views)
(loop for view in array-views
collect `(,(first view) () :type array :read-only t)))
;;;==============================================================================
;;; Testing
#|
* (use-package "V-ARRAY")
T
* (define-array-with-views (packet 6 :initial-element 0)
(:view slice-a 3)
(:view slice-b 3 :displaced-index-offset 3))
PACKET
* (defvar p (make-packet))
P
* p
#S(PACKET :PACKET #(0 0 0 0 0 0) :SLICE-A #(0 0 0) :SLICE-B #(0 0 0))
* (packet-p p)
T
* (packet p)
#(0 0 0 0 0 0)
* (slice-a p)
#(0 0 0)
* (setf (aref (slice-b p) 2) 33)
33
* p
#S(PACKET :PACKET #(0 0 0 0 0 33) :SLICE-A #(0 0 0) :SLICE-B #(0 0 33))
* (packet p)
#(0 0 0 0 0 33)
* (slice-b p)
#(0 0 33)
*
|#
;;; end of file -- displaced-arrays.lisp --
end of displaced-arrays.lisp ===========================