source: project/release/4/s11n/trunk/chicken-dump.scm @ 15282

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

imported r4 version

File size: 4.4 KB
Line 
1;;;; chicken-dump.scm
2
3
4(use srfi-4 srfi-69 lolevel matchable)
5
6(include "constants.scm")
7
8#>
9#include "s11n-c.c"
10<#
11
12
13(define bytes_to_block (##core#primitive "bytes_to_block"))
14
15(define (dump port)
16  (let ((indent 0)
17        (items 0)
18        (header "")
19        (backref-count 0) )
20    (define (getb)
21      (char->integer (read-char port)) )
22    (define (getw)
23      (##core#inline "bytes_to_word" (read-string +sizeof-ulong+ port)) )
24    (define (fetchslots x i)
25      (fluid-let ((indent (add1 indent)))
26        (let ((len (##sys#size x)))
27          (do ((i i (add1 i)))
28              ((>= i len) x)
29            (fetchh (sprintf "[~a]" i))) ) ) )
30    (define (out i? fstr . args)
31      (display (make-string indent))
32      (when i? (printf "#~a:" (sub1 items)))
33      (printf "~a ~?~%" header fstr args) )
34    (define (outh fstr . args)
35      (printf "~a[~?]~%" (make-string indent) fstr args) )
36    (define (fetchh hd)
37      (fluid-let ((header hd))
38        (fetch)))
39    (define (fetch)
40      (let ((tag (getb)))
41        (select tag
42          ((sixtyfour-bit-tag) (out #f "64-bit mark") (fetch))
43          ((thirtytwo-bit-tag) (out #f "32-bit mark") (fetch))
44          ((big-endian-tag) (out #f "big endian mark") (fetch))
45          ((little-endian-tag) (out #f "little endian mark") (fetch))
46          ((void-tag) (out #f "void"))
47          ((null-tag) (out #f "()"))
48          ((eof-tag) (out #f "#!eof"))
49          ((true-tag) (out #f "#t"))
50          ((false-tag) (out #f "#f"))
51          ((backref-tag) 
52           (let ((w (getw)))
53             (out #f "back reference -> #~a" w) ) )
54          ((fixnum-tag)
55           (out #f "fixnum ~a" (##core#inline "bytes_to_fixnum" (read-string +sizeof-word+ port)) ))
56          ((char-tag)
57           (out #f "char ~s" (integer->char (getw)) ))
58          ((gensym-tag)
59           (set! items (add1 items))
60           (out #t "uninterned symbol:")
61           (fetchh "(name)") )
62          ((symbol-tag)
63           (set! items (add1 items))
64           (out #t "symbol:")
65           (fetchh "(name)"))
66          ((stdport-tag)
67           (set! items (add1 items))
68           (let* ((n (getb))
69                  (r (sub1 backref-count)))
70             (case n
71               ((0) (out #t "stdin port"))
72               ((1) (out #t "stdout port"))
73               ((2) (out #t "stderr port"))
74               (else (out #t "invalid standard port - file possibly corrupt") ) ) ) )
75          ((hash-table-tag)
76           (set! items (add1 items))
77           (out #t "hash table:")
78           (fluid-let ((indent (+ 2 indent)))
79             (fetchh "(items)") )
80           (fluid-let ((indent (+ 2 indent)))
81             (fetchh "(comparison procedure)") )
82           (fluid-let ((indent (+ 2 indent)))
83             (fetchh "(hash function)") ))
84          (else
85           (call/cc
86            (lambda (return)
87              (set! items (add1 items))
88              (let* ((h (read-string +sizeof-header+ port))
89                     (x (bytes_to_block h)))
90                (##core#inline "set_header" x h)
91                (select tag
92                  ((bytevector-tag)
93                   (##core#inline "insert_bytes" x (read-string (##sys#size x) port))
94                   (cond ((string? x) (out #t "string ~s" x))
95                         ((number? x) (out #t "float ~s" x))
96                         ((##core#inline "C_lambdainfop" x)
97                          (out #t "lambda info ~a" x) )
98                         (else
99                          (out #t "byte-vector ~s" (byte-vector->u8vector x)) ) ) )
100                  ((vector-tag)
101                   (let ((off 0))
102                     (cond ((vector? x) (out #t "vector"))
103                           ((pair? x)
104                            (out #t "pair:")
105                            (fluid-let ((indent (add1 indent)))
106                              (fetchh "(car)")
107                              (fetchh "(cdr)")  )
108                            (return #f) )
109                           ((##sys#generic-structure? x) 
110                            (out #t "structure:")
111                            (fetchh "(tag)")
112                            (set! off 1) )
113                           (else (out #t "unknown vector-like object:")) )
114                     (fetchslots x off)))
115                  ((special-tag)
116                   (out #t "(invalid) special vector-like object:")
117                   (##core#inline "insert_bytes" x (read-string +sizeof-word+ port))
118                   (fetchslots x 1) )
119                  ((procedure-tag)
120                   (out #t "procedure:")
121                   (fluid-let ((indent (add1 indent)))
122                     (fetchh "(id)")
123                     (fetchslots x 1) ) )
124                  (else (out #t "invalid tag ~a - file possibly corrupt" tag)) ) ) ) ) ) ) ) )
125    (fetch) ) )
126
127(define (version)
128  (printf "chicken-dump ~a~%" +version+)
129  (exit 0) )
130
131(define (usage)
132  (printf "usage: chicken-dump [FILE | OPTION ...]
133
134  -v  -version                   show version and exit
135  -h  -help                      show this message and exit~%")
136  (exit 0) )
137
138(define *dumped* #f)
139
140(define (dump-file fn)
141  (printf "~%File: ~a~%" fn)
142  (set! *dumped* #t)
143  (call-with-input-file fn dump) )
144
145(let loop ((args (command-line-arguments)))
146  (match args
147    (() (unless *dumped* (usage)))
148    (((or "-v" "-version") . _) (version))
149    (((or "-h" "-help" "--help") . _) (usage))
150    ((file . more)
151     (dump-file file)
152     (loop more)) ) )
Note: See TracBrowser for help on using the repository browser.