#|-------------------- 1.1 |# "./blob-record.meta" 566
;; -*- Hen -*-

((egg "blob-record.egg") ; This should never change

 ; List here all the files that should be bundled as part of your egg.  

 (files "blob-record.setup" "blob-record.meta" "tests/run.scm" "blob-record.scm")

 ; Your egg's license:

 (license "GPL-3")

 ; Pick one from the list of categories (see below) for your egg and
 ; enter it here.

 (category data)

 ; A list of eggs blob-record depends on.

 (needs byte-blob)

 (test-depends test)

 (doc-from-wiki)

 (author "Ivan Raikov")

 (synopsis "A facility for representing records as blobs."))


#|-------------------- 1.1 |# "./blob-record.scm" 2260
;;
;; 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))))
		     ))
	  )))
    ))
	
)	      
		      
		


#|-------------------- 1.1 |# "./blob-record.setup" 482
;;  -*- Hen -*-

(define (dynld-name fn)		
  (make-pathname #f fn ##sys#load-dynamic-extension))	

(compile -O -d2 -s blob-record.scm -j blob-record)
(compile -s blob-record.import.scm)

(install-extension

 ;; Name of your extension:
  'blob-record

  ;; Files to install for your extension:
  `(,(dynld-name "blob-record") ,(dynld-name "blob-record.import") )
  

  ;; Assoc list with properties for your extension:
  '((version 1.1)
    (documentation "blob-record.html")
    ))