mirror of
https://github.com/ashinn/chibi-scheme.git
synced 2025-05-19 05:39:18 +02:00
Add tests and documentation for define-binary-record-type.
This commit is contained in:
parent
8e3fd8f00c
commit
3558c0f4a6
5 changed files with 132 additions and 27 deletions
7
Makefile
7
Makefile
|
@ -46,9 +46,10 @@ COMPILED_LIBS = $(CHIBI_COMPILED_LIBS) $(CHIBI_IO_COMPILED_LIBS) \
|
||||||
BASE_INCLUDES = include/chibi/sexp.h include/chibi/features.h include/chibi/install.h include/chibi/bignum.h
|
BASE_INCLUDES = include/chibi/sexp.h include/chibi/features.h include/chibi/install.h include/chibi/bignum.h
|
||||||
INCLUDES = $(BASE_INCLUDES) include/chibi/eval.h include/chibi/gc_heap.h
|
INCLUDES = $(BASE_INCLUDES) include/chibi/eval.h include/chibi/gc_heap.h
|
||||||
|
|
||||||
MODULE_DOCS := app assert ast base64 bytevector config crypto/md5 crypto/rsa \
|
MODULE_DOCS := app assert ast base64 binary-record bytevector config \
|
||||||
crypto/sha2 diff disasm doc edit-distance equiv filesystem generic \
|
crypto/md5 crypto/rsa crypto/sha2 diff disasm doc edit-distance \
|
||||||
heap-stats io iset/base iset/constructors iset/iterators json loop \
|
equiv filesystem generic heap-stats io \
|
||||||
|
iset/base iset/constructors iset/iterators json loop \
|
||||||
match math/prime memoize mime modules net net/http-server net/servlet \
|
match math/prime memoize mime modules net net/http-server net/servlet \
|
||||||
optional parse pathname process repl scribble string stty sxml system \
|
optional parse pathname process repl scribble string stty sxml system \
|
||||||
temp-file test time trace type-inference uri weak monad/environment \
|
temp-file test time trace type-inference uri weak monad/environment \
|
||||||
|
|
31
lib/chibi/binary-record-test.sld
Normal file
31
lib/chibi/binary-record-test.sld
Normal file
|
@ -0,0 +1,31 @@
|
||||||
|
|
||||||
|
(define-library (chibi binary-record-test)
|
||||||
|
(export run-tests)
|
||||||
|
(import (scheme base) (chibi binary-record) (chibi test))
|
||||||
|
(begin
|
||||||
|
(define-binary-record-type gif-header
|
||||||
|
(make: make-gif-header)
|
||||||
|
(pred: gif-header?)
|
||||||
|
(read: read-gif-header)
|
||||||
|
(write: write-gif-header)
|
||||||
|
(block:
|
||||||
|
"GIF89a"
|
||||||
|
(width (u16/le) gif-header-width)
|
||||||
|
(height (u16/le) gif-header-height)
|
||||||
|
(gct (u8) gif-header-gct)
|
||||||
|
(bgcolor (u8) gif-header-gbcolor)
|
||||||
|
(aspect-ratio (u8) gif-header-aspect-ratio)
|
||||||
|
))
|
||||||
|
(define (gif->bytevector gif)
|
||||||
|
(let ((out (open-output-bytevector)))
|
||||||
|
(write-gif-header gif out)
|
||||||
|
(get-output-bytevector out)))
|
||||||
|
(define (bytevector->gif bv)
|
||||||
|
(read-gif-header (open-input-bytevector bv)))
|
||||||
|
(define (run-tests)
|
||||||
|
(test-begin "(chibi binary-record)")
|
||||||
|
(let ((gif (make-gif-header 4096 2160 #xF7 1 2)))
|
||||||
|
(test #u8(#x47 #x49 #x46 #x38 #x39 #x61 0 #x10 #x70 #x08 #xF7 #x01 #x02)
|
||||||
|
(gif->bytevector gif))
|
||||||
|
(test gif (bytevector->gif (gif->bytevector gif))))
|
||||||
|
(test-end))))
|
|
@ -1,6 +1,80 @@
|
||||||
|
|
||||||
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
||||||
;; binary records
|
;; Binary Records
|
||||||
|
|
||||||
|
;;> \macro{(define-binary-record-type <name> [<bindings> ...] (block: <fields> ...))}
|
||||||
|
;;>
|
||||||
|
;;> Defines a new record type that supports serializing to and from
|
||||||
|
;;> binary ports. The generated procedures accept keyword-style
|
||||||
|
;;> arguments:
|
||||||
|
;;>
|
||||||
|
;;> \itemlist[
|
||||||
|
;;> \item{\scheme{(make: <constructor-name>)}}
|
||||||
|
;;> \item{\scheme{(pred: <predicate-name>)}}
|
||||||
|
;;> \item{\scheme{(read: <reader-name>)}}
|
||||||
|
;;> \item{\scheme{(write: <writer-name>)}}
|
||||||
|
;;> \item{\scheme{(block: <fields> ...)}}
|
||||||
|
;;> ]
|
||||||
|
;;>
|
||||||
|
;;> The fields are also similar to \scheme{define-record-type} but
|
||||||
|
;;> with an additional type:
|
||||||
|
;;>
|
||||||
|
;;> \scheme{(field (type args ...) getter setter)}
|
||||||
|
;;>
|
||||||
|
;;> Built-in types include:
|
||||||
|
;;>
|
||||||
|
;;> \itemlist[
|
||||||
|
;;> \item{\scheme{(u8)} - a single byte in [0, 255]}
|
||||||
|
;;> \item{\scheme{(u16/le)} - a little-endian short integer}
|
||||||
|
;;> \item{\scheme{(u16/be)} - a big-endian short integer}
|
||||||
|
;;> \item{\scheme{(fixed-string <length>)} - a fixed-length utf-8 string}
|
||||||
|
;;> \item{\scheme{(padded-string <length> (pad <pad-char>))} - a utf-8 string padded to a given length}
|
||||||
|
;;> \item{\scheme{(octal <length>)} - an integer in octal string format}
|
||||||
|
;;> \item{\scheme{(decimal <length>)} - an integer in decimal string format}
|
||||||
|
;;> \item{\scheme{(hexadecimal <length>)} - an integer in hexadecimal string format}
|
||||||
|
;;> ]
|
||||||
|
;;>
|
||||||
|
;;> In addition, the field can be a literal (char, string or
|
||||||
|
;;> bytevector), for instance as a file magic sequence or fixed
|
||||||
|
;;> separator. The fields (and any constants) are serialized in the
|
||||||
|
;;> order they appear in the block. For example, the header of a GIF
|
||||||
|
;;> file could be defined as:
|
||||||
|
;;>
|
||||||
|
;;> \example{
|
||||||
|
;;> (define-binary-record-type gif-header
|
||||||
|
;;> (make: make-gif-header)
|
||||||
|
;;> (pred: gif-header?)
|
||||||
|
;;> (read: read-gif-header)
|
||||||
|
;;> (write: write-gif-header)
|
||||||
|
;;> (block:
|
||||||
|
;;> "GIF89a"
|
||||||
|
;;> (width (u16/le) gif-header-width)
|
||||||
|
;;> (height (u16/le) gif-header-height)
|
||||||
|
;;> (gct (u8) gif-header-gct)
|
||||||
|
;;> (bgcolor (u8) gif-header-gbcolor)
|
||||||
|
;;> (aspect-ratio (u8) gif-header-aspect-ratio)
|
||||||
|
;;> ))
|
||||||
|
;;> }
|
||||||
|
;;>
|
||||||
|
;;> For a more complex example see the \scheme{(chibi tar)}
|
||||||
|
;;> implementation.
|
||||||
|
;;>
|
||||||
|
;;> The binary type itself is a macro used to expand to a predicate
|
||||||
|
;;> and reader/writer procedures, which can be defined with
|
||||||
|
;;> \scheme{define-binary-type}. For example,
|
||||||
|
;;>
|
||||||
|
;;> \example{
|
||||||
|
;;> (define-binary-type (u8)
|
||||||
|
;;> (lambda (x) (and (exact-integer? x) (<= 0 x 255)))
|
||||||
|
;;> read-u8
|
||||||
|
;;> write-u8)
|
||||||
|
;;> }
|
||||||
|
|
||||||
|
(define-syntax define-binary-record-type
|
||||||
|
(syntax-rules ()
|
||||||
|
((define-binary-record-type name x ...)
|
||||||
|
(defrec (x ...) name hidden-make hidden-pred hidden-read hidden-write
|
||||||
|
() () ()))))
|
||||||
|
|
||||||
(define-syntax defrec
|
(define-syntax defrec
|
||||||
(syntax-rules (make: pred: read: write: block:)
|
(syntax-rules (make: pred: read: write: block:)
|
||||||
|
@ -84,9 +158,3 @@
|
||||||
((defrec ((block:) . rest) n m p r w b f s)
|
((defrec ((block:) . rest) n m p r w b f s)
|
||||||
(defrec rest n m p r w b f s))
|
(defrec rest n m p r w b f s))
|
||||||
))
|
))
|
||||||
|
|
||||||
(define-syntax define-binary-record-type
|
|
||||||
(syntax-rules ()
|
|
||||||
((define-binary-record-type name x ...)
|
|
||||||
(defrec (x ...) name hidden-make hidden-pred hidden-read hidden-write
|
|
||||||
() () ()))))
|
|
||||||
|
|
|
@ -8,6 +8,26 @@
|
||||||
(cond-expand
|
(cond-expand
|
||||||
((library (srfi 130)) (import (srfi 130)))
|
((library (srfi 130)) (import (srfi 130)))
|
||||||
(else (import (srfi 13))))
|
(else (import (srfi 13))))
|
||||||
|
(cond-expand
|
||||||
|
;; ((library (auto))
|
||||||
|
;; (import (only (auto) make: pred: read: write: block:)))
|
||||||
|
(else
|
||||||
|
;; indirect exports for chicken
|
||||||
|
(export defrec define-auxiliary-syntax syntax-let-optionals*)
|
||||||
|
(begin
|
||||||
|
(define-syntax define-auxiliary-syntax
|
||||||
|
(syntax-rules ()
|
||||||
|
((define-auxiliary-syntax name)
|
||||||
|
(define-syntax name
|
||||||
|
(syntax-rules ()
|
||||||
|
((name . x)
|
||||||
|
(syntax-error "invalid use of auxiliary syntax"
|
||||||
|
(name . x))))))))
|
||||||
|
(define-auxiliary-syntax make:)
|
||||||
|
(define-auxiliary-syntax pred:)
|
||||||
|
(define-auxiliary-syntax read:)
|
||||||
|
(define-auxiliary-syntax write:)
|
||||||
|
(define-auxiliary-syntax block:))))
|
||||||
(export
|
(export
|
||||||
;; interface
|
;; interface
|
||||||
define-binary-record-type
|
define-binary-record-type
|
||||||
|
@ -16,9 +36,8 @@
|
||||||
octal decimal hexadecimal
|
octal decimal hexadecimal
|
||||||
;; auxiliary syntax
|
;; auxiliary syntax
|
||||||
make: pred: read: write: block:
|
make: pred: read: write: block:
|
||||||
;; indirect exports
|
;; new types
|
||||||
define-binary-type defrec define-auxiliary-syntax
|
define-binary-type)
|
||||||
syntax-let-optionals*)
|
|
||||||
(include "binary-types.scm")
|
(include "binary-types.scm")
|
||||||
(cond-expand
|
(cond-expand
|
||||||
(chicken
|
(chicken
|
||||||
|
|
|
@ -85,20 +85,6 @@
|
||||||
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
||||||
;; syntax
|
;; syntax
|
||||||
|
|
||||||
(define-syntax define-auxiliary-syntax
|
|
||||||
(syntax-rules ()
|
|
||||||
((define-auxiliary-syntax name)
|
|
||||||
(define-syntax name
|
|
||||||
(syntax-rules ()
|
|
||||||
((name . x)
|
|
||||||
(syntax-error "invalid use of auxiliary syntax" (name . x))))))))
|
|
||||||
|
|
||||||
(define-auxiliary-syntax make:)
|
|
||||||
(define-auxiliary-syntax pred:)
|
|
||||||
(define-auxiliary-syntax read:)
|
|
||||||
(define-auxiliary-syntax write:)
|
|
||||||
(define-auxiliary-syntax block:)
|
|
||||||
|
|
||||||
(define-syntax syntax-let-optionals*
|
(define-syntax syntax-let-optionals*
|
||||||
(syntax-rules ()
|
(syntax-rules ()
|
||||||
((syntax-let-optionals* () type-args expr)
|
((syntax-let-optionals* () type-args expr)
|
||||||
|
|
Loading…
Add table
Reference in a new issue