;;
;; A macro to perform conversion between Scheme records and their
;; representation as byte blobs.
;;
;;  Copyright 2009 Ivan Raikov.
;;
;;   Copyright 2009 Ivan Raikov and the Okinawa Institute of Science
;;   and Technology.
;;
;;
;;   This program is free software: you can redistribute it and/or
;;   modify it under the terms of the GNU General Public License as
;;   published by the Free Software Foundation, either version 3 of
;;   the License, or (at your option) any later version.
;;
;;   This program is distributed in the hope that it will be useful,
;;   but WITHOUT ANY WARRANTY; without even the implied warranty of
;;   MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the GNU
;;   General Public License for more details.
;;
;;   A full copy of the GPL license can be found at
;;   <http://www.gnu.org/licenses/>.

(module blob-record

	((define-blob-record
	   byte-blob-append byte-blob-span)
	 )

	(import scheme chicken foreign posix)

	(require-extension byte-blob)


(define-syntax define-blob-record
  (lambda (x r c)
    (let ((typename (cadr x))
	  (pred     (car   (caddr x)))
	  (kons     (cadr  (caddr x)))
	  (size     (caddr (caddr x)))
	  (from-byte-blob  (car (cadddr x)))
	  (to-byte-blob    (cadr (cadddr x)))
	  (rest     (cddddr x))
	  (%define (r 'define))
	  (%define-record-type (r 'define-record-type))
	  (%begin (r 'begin)))
      (let ((fieldnames (map car rest))
	    (fieldsizes (map cadr rest))
	    (fieldaccs  (map caddr rest))
	    (toblobs    (map cadddr rest))
	    (fromblobs  (map (compose cadr cdddr) rest))
	    )
	`(,%begin
	  (,%define-record-type
	   ,typename 
	   (,kons . ,fieldnames)
	   ,pred .
	   ,(map (lambda (name accessor) (list name accessor))
		 fieldnames fieldaccs))
	  (,%define ,size (+ . ,fieldsizes))
	  (,%define (,to-byte-blob x)
		    (byte-blob-append .
		     ,(map (lambda (to acc) `(,to (,acc x))) toblobs fieldaccs)))
	  (,%define (,from-byte-blob x)
		    (,kons .
		     ,(let loop ((from fromblobs) (size fieldsizes) (offset 0) (r '()))
			(if (null? from) (reverse r)
			    (loop (cdr from) (cdr size) (+ offset (car size))
				  (cons `(,(car from) (byte-blob-span x ,offset ,(+ offset (car size)))) r))))
		     ))
	  )))
    ))
	
)