;;;
;;; fileutils.lisp
;;;
;;; File parsing utilities.
;;;

(cl:defpackage :file-utils
  (:use :cl)
  (:export
   "U8@" "S8@"
   "U16LE@" "U32LE@" "U64LE@" "S16LE@" "S32LE@" "S64LE@"
   "U16BE@" "U32BE@" "U64BE@" "S16BE@" "S32BE@" "S64BE@"
   "LOAD-FILE-DATA" "DATA-SECTION"
   "SIGN-EXTEND"
   "DEFINE-FILE-STRUCTURE" "BITFIELD" "FIELD-VALUE" "WITH-FIELDS"))
(cl:in-package :file-utils)


;;; Bitfield utilities

;; FIXME: Make a compiler-macro for this.
(declaim (inline sign-extend))
(defun sign-extend (value width)
  "Return VALUE sign extended as if it were a WIDTH-bit signed integer."
  (if (logbitp (1- width) value)
      (logior (ash -1 width) value)
      value))


;;; Accessors

(declaim (inline u8@ s8@
		 u16le@ u16be@ s16le@ s16be@
		 u32le@ u32be@ s32le@ s32be@
		 u64le@ u64be@ s64le@ s64be@))

(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)))

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

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

(defun u64le@ (buffer offset)
  "Return the little-endian (unsigned-byte 64) value OFFSET octets into BUFFER."
  (let ((hi (u32le@ buffer (+ offset 4)))
        (lo (u32le@ buffer offset)))
    (dpb hi (byte 32 32) lo)))

(defun u64be@ (buffer offset)
  "Return the big-endian (unsigned-byte 64) value OFFSET octets into BUFFER."
  (let ((lo (u32be@ buffer (+ offset 4)))
        (hi (u32be@ buffer offset)))
    (dpb hi (byte 32 32) lo)))

(defun s8@ (buffer offset)
  "Return the (signed-byte 8) value OFFSET octets into BUFFER."
  (sign-extend (u8@ buffer offset) 8))

(defun s16le@ (buffer offset)
  "Return the little-endian (signed-byte 16) value OFFSET octets into BUFFER."
  (sign-extend (u16le@ buffer offset) 16))

(defun s16be@ (buffer offset)
  "Return the big-endian (signed-byte 16) value OFFSET octets into BUFFER."
  (sign-extend (u16be@ buffer offset) 16))

(defun s32le@ (buffer offset)
  "Return the little-endian (signed-byte 32) value OFFSET octets into BUFFER."
  (sign-extend (u32le@ buffer offset) 32))

(defun s32be@ (buffer offset)
  "Return the big-endian (signed-byte 32) value OFFSET octets into BUFFER."
  (sign-extend (u32be@ buffer offset) 32))

(defun s64le@ (buffer offset)
  "Return the little-endian (signed-byte 64) value OFFSET octets into BUFFER."
  (sign-extend (u64le@ buffer offset) 64))

(defun s64be@ (buffer offset)
  "Return the big-endian (signed-byte 64) value OFFSET octets into BUFFER."
  (sign-extend (u64be@ buffer offset) 64))


;;; File data sections

(defun load-file-data (pathname)
  (with-open-file (infile pathname :direction :input
                          :element-type '(unsigned-byte 8))
    (let ((data (make-array (file-length infile)
                            :element-type '(unsigned-byte 8))))
      (read-sequence data infile)
      data)))

(defun data-section (buffer offset length)
  (assert (<= (+ offset length) (length buffer)))
  (multiple-value-bind
        (master master-offset)
      (array-displacement buffer)
    (make-array length :element-type (array-element-type buffer)
                :displaced-to (or master buffer)
                :displaced-index-offset (+ master-offset offset))))


;;; 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))


;;; EOF
