source: project/release/4/s11n/trunk/tests/run.scm @ 15282

Last change on this file since 15282 was 15282, checked in by felix winkelmann, 11 years ago

imported r4 version

File size: 2.5 KB
Line 
1(use s11n)
2
3(define dump
4  (lambda (x . len-out)
5    (let-optionals len-out
6        ([len #f]
7         [out ##sys#standard-output] )
8      (define (bestlen n) (if len (min len n) n))
9      (cond [(##sys#immediate? x) (print "can not dump immediate object" x)]
10            [(##sys#bytevector? x) (hexdump x (bestlen (##sys#size x)) ##sys#byte out)]
11            [(string? x) (hexdump x (bestlen (##sys#size x)) ##sys#byte out)]
12            [(and (not (##sys#immediate? x)) (##sys#pointer? x))
13             (hexdump x 32 ##sys#peek-byte out) ]
14            [(and (##sys#generic-structure? x) (assq (##sys#slot x 0) bytevector-data))
15             (let ([bv (##sys#slot x 1)])
16               (hexdump bv (bestlen (##sys#size bv)) ##sys#byte out) ) ]
17            [else (print "can not dump object" x)] ) ) ) )
18
19(define hexdump
20  (let ([display display]
21        [string-append string-append]
22        [make-string make-string]
23        [write-char write-char] )
24    (lambda (bv len ref out)
25
26      (define (justify n m base lead)
27        (let* ([s (number->string n base)]
28               [len (##sys#size s)] )
29          (if (fx< len m)
30              (string-append (make-string (fx- m len) lead) s)
31              s) ) )
32
33      (do ([a 0 (fx+ a 16)])
34          ((fx>= a len))
35        (display (justify a 4 10 #\space) out)
36        (write-char #\: out)
37        (do ([j 0 (fx+ j 1)]
38             [a a (fx+ a 1)] )
39            ((or (fx>= j 16) (fx>= a len))
40             (and-let* ([(fx>= a len)]
41                        [o (fxmod len 16)]
42                        [(not (fx= o 0))] )
43               (do ([k (fx- 16 o) (fx- k 1)])
44                   ((fx= k 0))
45                 (display "   " out) ) ) )
46          (write-char #\space out)
47          (display (justify (ref bv a) 2 16 #\0) out) )
48        (write-char #\space out)
49        (do ([j 0 (fx+ j 1)]
50             [a a (fx+ a 1)] )
51            ((or (fx>= j 16) (fx>= a len)))
52          (let ([c (ref bv a)])
53            (if (and (fx>= c 32) (fx< c 128))
54                (write-char (integer->char c) out)
55                (write-char #\. out) ) ) ) 
56        (##sys#write-char-0 #\newline out) ) ) ) )
57
58(define (pipe x #!optional pred (check #t))
59  (let ((str (with-output-to-string (cut serialize x))))
60    (##sys#with-print-length-limit 80 (cut print* x))
61    (newline)
62    (dump str)
63    (let ((y (deserialize (open-input-string str))))
64      (when pred (assert (pred y)))
65      (when check (assert (equal? x y)))
66      y) ) )
67
68(pp (pipe 123))
69(pp (pipe #\A))
70(pp (pipe 'abc ##sys#interned-symbol?))
71(pp (pipe (gensym) (complement ##sys#interned-symbol?) #f))
72(pp (pipe abc: keyword?))
73(pp (pipe "a test"))
74(pp (pipe '#(this is "a test")))
75(define p '(1))
76(set-cdr! p p)
77(pipe p (lambda (x) (eq? x (cdr x))) #f)
78;(pp (pipe serialize))
79;(pp (pipe (let ((x serialize)) (lambda () (print x))) (lambda (x) (x))))
Note: See TracBrowser for help on using the repository browser.