;;; Accessors

(defun u8@ (buffer offset)
  "Return the (unsigned-byte 8) value OFFSET octets into BUFFER."
  (aref buffer offset))

(defun u16le@ (buffer offset)
  "Return the little-endian (unsigned-byte 16) value OFFSET octets into BUFFER."
  (let ((hi (u8@ buffer (1+ offset)))
        (lo (u8@ buffer offset)))
    (dpb hi (byte 8 8) lo)))

(defun u16be@ (buffer offset)
  "Return the big-endian (unsigned-byte 16) value OFFSET octets into BUFFER."
  (let ((lo (u8@ buffer (1+ offset)))
        (hi (u8@ buffer offset)))
    (dpb hi (byte 8 8) lo)))

;; ... continue on in this vein...


;;; File structure accessors

(defvar *struct-field-mappings* nil)

(defmacro define-file-structure (name options &rest slots)
  (declare (ignore options))
  `(eval-when (:compile-toplevel :load-toplevel)
     (setf (getf *struct-field-mappings* ',name) ',slots)))

(defmacro bitfield (buffer accessor offset field)
  `(ldb ,field (,accessor ,buffer ,offset)))

(defmacro with-fields (fields (buffer struct-name) &body body)
  (let* ((mapping (getf *struct-field-mappings* struct-name))
	 (readers (loop for field in fields
		       for map = (assoc field mapping)
		       collect `(,field (,(cadr map) ,buffer ,@(cddr map))))))
    `(symbol-macrolet ,readers ,@body)))


;;; Example structure definition

(define-file-structure ecoff-file-descriptor-entry ()
  (|adr|          u64le@ #x00)
  (|cbLineOffset| u64le@ #x08)
  (|cbLine|       u64le@ #x10)
  (|cbSs|         u64le@ #x18)
  (|rss|       u32le@ #x20)
  (|issBase|   u32le@ #x24)
  (|isymBase|  u32le@ #x28)
  (|csym|      u32le@ #x2c)
  (|ilineBase| u32le@ #x30)
  (|cline|     u32le@ #x34)
  (|ioptBase|  u32le@ #x38)
  (|copt|      u32le@ #x3c)
  (|ipdFirst|  u32le@ #x40)
  (|cpd|       u32le@ #x44)
  (|iauxBase|  u32le@ #x48)
  (|caux|      u32le@ #x4c)
  (|rfdBase|   u32le@ #x50)
  (|crfd|      u32le@ #x54)
  (|lang|       bitfield u16le@ #x58 (byte 5 0))
  (|fMerge|     bitfield u16le@ #x58 (byte 1 5))
  (|fReadin|    bitfield u16le@ #x58 (byte 1 6))
  (|fBigendian| bitfield u16le@ #x58 (byte 1 7))
  (|gLevel|     bitfield u16le@ #x58 (byte 2 8))
  (|fTrim|      bitfield u16le@ #x58 (byte 1 10))
  (|reserved|   bitfield u16le@ #x58 (byte 5 11))
  (|vstamp| u16le@ #x5a)
  (|reserved2| u32le@ #x5c))


;;; Example use of with-fields

(defun build-ecoff-file-procedure-descriptors (file-descriptor)
  (with-slots (symbolic-header data-section) file-descriptor
    (with-fields (|ipdFirst| |cpd|)
	(data-section ecoff-file-descriptor-entry)
      ;;(format t "~A: ~D ~D~%" file-descriptor |ipdFirst| |cpd|)
      (unless (zerop |cpd|)
	(subseq (ecoff-procedure-descriptors symbolic-header)
		|ipdFirst| (+ |ipdFirst| |cpd|))))))

;; Same public interface, with the addition of FIELD-VALUE.

;;; File structure accessors

(defvar *struct-field-mappings* nil)

(defun find-field-mapping (struct-name field-name)
  (assoc field-name (getf *struct-field-mappings* struct-name)))

(defmacro define-file-structure (name options &rest slots)
  (declare (ignore options))
  `(eval-when (:compile-toplevel :load-toplevel)
     (setf (getf *struct-field-mappings* ',name) ',slots)))

(declaim (inline bitfield))
(defun bitfield (buffer accessor offset bytespec)
  (ldb bytespec (funcall accessor buffer offset)))

(defun field-value (buffer struct-name field)
  (let ((field-mapping (find-field-mapping struct-name field)))
    (apply (cadr field-mapping) buffer (cddr field-mapping))))

(define-compiler-macro field-value (&whole form buffer struct-name field)
  (when (and (typep struct-name '(cons (eql quote) (cons symbol null)))
	     (typep field '(cons (eql quote) (cons symbol null))))
    (let ((field-mapping (find-field-mapping (cadr struct-name) (cadr field))))
      (when field-mapping
	(return-from field-value
	  `(,(cadr field-mapping) ,buffer ,@(cddr field-mapping))))))
  form)

(defmacro with-fields (fields (buffer struct-name) &body body)
  `(symbol-macrolet
       ,(loop
	   for field in fields
	   collect `(,field (field-value ,buffer ',struct-name ',field)))
     ,@body))