;;;-*- Mode: Lisp; Package: CCL -*-

;; packed-record.lisp
;;
;; Reorganize records from a packed format to MCL record format.
;;
;; Due to common memory architectures, MCL adjusts the position
;; of fields in a record to even addresses. However, records are
;; commonly stored and/or transferred in a packed format where
;; the fields follows each other with no empty space. This module
;; faciliates translation between packed records and MCL records,
;; so that you can use MCL record functionality to build or get 
;; fields from any record with a predefined structure.
;;
;; Copyright 1997-99 Media Design in*Progress
;; You are permitted to freely distribute and use this module in any LISP software
;; provided that this copyright notice is included.
;;
;; You are encouraged to submit eventual improvements to the author so they 
;; can be included in later version. Any submitted improvement automatically
;; fall under the copyright of this module.
;;
;; Terje Norderhaug
;; Media Design in*Progress
;; terje@in-progress.com
;;
;; The most recent version of this module is available from:
;; http://www.in-progress.com/src

;; Change History (most recent first):

;; 990528 Terje  Changed order of arguments in %write-packed-record.
;; 990528 Terje  Changed order of arguments in %read-packed-record.
;; 990527 Terje  Changed read/write methods to functions.
;; 990526 Terje  Macros to define reader and writer for records.
;; 971111 Terje  Version 1.0 released.

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;

(in-package :ccl)

(export 'define-read-packed)
(export 'define-write-packed)

(defmacro define-read-packed (record-type)
  "Defines a function to read a packed record"
  `(defun ,(intern (concatenate 'string "READ-PACKED-" (string record-type)))
      (&optional stream record)
      (%read-packed-record stream
        (or record (make-record ,record-type))
        ',(%packed-record-segments record-type))))

(defmacro define-write-packed (record-type)
  "Defines a function to write a packed record"
  `(defun ,(intern (concatenate 'string "WRITE-PACKED-" (string record-type)))
      (record &optional stream)
      (%write-packed-record record stream 
        ',(%packed-record-segments record-type))))

(defun %packed-record-segments (record-type &aux result)
  "Generates an optimized list of offset and lengths for active segments of a record"
  (dolist (field (record-info record-type) (nreverse result))
    (let ((start (second field))
          (length (fourth field)))
      (cond
        ((and result (= start (+ (caar result)(cdar result)))
           (incf (cdar result) length)))
        (T
           (push (cons start length) result))))))

(defun %read-packed-record (stream record segments)  
  (with-pointers ((ptr record))
    (dolist (field segments)
      (with-pointers ((segment-ptr (%inc-ptr ptr (car field))))
        (dotimes (i (cdr field))
          (declare (fixnum i))
          (%put-byte segment-ptr (read-byte stream) i))))))

(defun %write-packed-record (record stream segments)
  (with-pointers ((ptr record))
    (dolist (field segments)
      (with-pointers ((segment-ptr (%inc-ptr ptr (car field))))
        (dotimes (i (cdr field))
          (declare (fixnum i))
          (stream-tyo stream
            (code-char
              (the unsigned-byte  
                (%get-unsigned-byte segment-ptr i) ))))))))

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;; Do not edit beyond this line

(provide :packed-record)