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

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

imported r4 version

File size: 7.1 KB
Line 
1;;;; s11n.scm
2
3
4(declare
5  (fixnum))
6
7
8(module s11n (serialize deserialize serialization-mode)
9  (import scheme chicken foreign)
10
11(use srfi-69 extras)
12
13(include "constants.scm")
14
15#>
16#include "s11n-c.c"
17<#
18
19(define procedure_to_id
20  (foreign-lambda* c-string ((scheme-object p)) 
21    "return(C_lookup_procedure_id((void *)C_block_item(p, 0)));") )
22
23(define fixnum_to_bytes (##core#primitive "fixnum_to_bytes"))
24(define word_to_bytes (##core#primitive "word_to_bytes"))
25(define header_to_bytes (##core#primitive "header_to_bytes"))
26
27
28(define serialization-mode (make-parameter 'host))
29
30
31(define (serialize x #!optional (port (current-output-port)) serializer)
32  (let ((table (make-hash-table eq?))
33        (pos 0) )
34    (define (emitb b)
35      (write-char (integer->char b) port) )
36    (define (emit s)
37      (display s port) )
38    (define (emitw w)
39      (display (word_to_bytes w) port) )
40    (define (walkslots x i)
41      (let ((len (##sys#size x)))
42        (do ((i i (add1 i)))
43            ((>= i len))
44          (walk (##sys#slot x i)) ) ) )
45    (define (emitbytes x)
46      (let ((len (##sys#size x)))
47        (do ((i 0 (add1 i)))
48            ((>= i len))
49          (emitb (##sys#byte x i)) ) ) )
50    (define (fail msg x)
51      (if serializer
52          (walk (serializer x))
53          (error 'serialize (string-append "unable to serialize object - " msg) x)))
54    (define (walk x)
55      #+debug
56      (fprintf 
57       (current-error-port)
58       "Emitting: ~a"
59       (##sys#with-print-length-limit 
60        80
61        (lambda () (with-output-to-string (cut pp x)))))
62      (cond ((fixnum? x) 
63             (emitb fixnum-tag)
64             (emit (fixnum_to_bytes x)) )
65            ((char? x)
66             (emitb char-tag)
67             (emitw (char->integer x)) )
68            ((##sys#immediate? x)
69             (select x
70               (((##core#undefined)) (emitb void-tag))
71               ((#t) (emitb true-tag))
72               ((#f) (emitb false-tag))
73               ((#!eof) (emitb eof-tag))
74               (('()) (emitb null-tag))
75               (else (fail "can not serialize immediate value" x))) )
76            ((hash-table-ref/default table x #f) =>
77             (lambda (pos)
78               (emitb backref-tag)
79               (emitw pos) ) )
80            (else
81             (hash-table-set! table x pos)
82             (set! pos (add1 pos))
83             (cond ((procedure? x)
84                    (emitb procedure-tag)
85                    (emit (header_to_bytes x))
86                    (let ((id (procedure_to_id x)))
87                      (cond ((not id)
88                             (set! pos (sub1 pos))
89                             (fail "unable to serialize procedure (no table entry found)" x) )
90                            (else
91                             (walk id)
92                             (walkslots x 1) ) ) ) )
93                   ((##core#inline "C_specialp" x)
94                    (cond ((port? x)
95                           (let ((name (##sys#slot x 3)))
96                             (cond ((string=? "(stdin)" name)
97                                    (emitb stdport-tag)
98                                    (emitb 0) )
99                                   ((string=? "(stdout)" name)
100                                    (emitb stdport-tag)
101                                    (emitb 1) )
102                                   ((string=? "(stderr)" name)
103                                    (emitb stdport-tag)
104                                    (emitb 2) )
105                                   ((not (zero? (##sys#pointer->address x)))
106                                    (fail "can not serialize stream port" x) )
107                                   (else
108                                    (emitb vector-tag)
109                                    (emit (header_to_bytes x))
110                                    (emitw 0)
111                                    (walkslots x 1) ) ) ) )
112                          (else
113                           (fail "can not serialize pointer-like object" x)
114                           #| (emitb special-tag)
115                           (emit (header_to_bytes x))
116                           (walkslots x 1) |#) ) )
117                   ((##core#inline "C_byteblockp" x)
118                    (emitb bytevector-tag)
119                    (emit (header_to_bytes x))
120                    (emitbytes x) )
121                   ((symbol? x)
122                    (emitb
123                     (if (not (##core#inline "C_lookup_symbol" x))
124                         gensym-tag
125                         symbol-tag) )
126                    (walk (##sys#slot x 1)) )
127                   ((hash-table? x)
128                    (emitb hash-table-tag)
129                    (walk (hash-table->alist x))
130                    (walkslots x 3) )
131                   (else
132                    (emitb vector-tag)
133                    (emit (header_to_bytes x))
134                    (walkslots x 0) ) ) ) ) )
135    (when (eq? (serialization-mode) 'portable)
136      (emitb (if (##sys#fudge 3) sixtyfour-bit-tag thirtytwo-bit-tag))
137      (emitb +endianness-tag+) )
138    (walk x) ) )
139
140(define bytes_to_block (##core#primitive "bytes_to_block"))
141
142(define stdin-port ##sys#standard-input)
143(define stdout-port ##sys#standard-output)
144(define stderr-port ##sys#standard-error)
145
146(define (deserialize #!optional (port (current-input-port)) fallback (safe #t))
147  (let ((backrefs (make-vector 100))
148        (backref-count 0) )
149    (define (getb)
150      (let ((c (read-char port)))
151        (if (eof-object? c)
152            (error 'deserialize "unexpected end of input" port)
153            (char->integer c))))
154    (define (getw)
155      (##core#inline "bytes_to_word" (read-string +sizeof-ulong+ port)) )
156    (define (addref x)
157      (when (>= backref-count (vector-length backrefs))
158        (set! backrefs (vector-resize backrefs (* 2 backref-count))) )
159      (vector-set! backrefs backref-count x)
160      (set! backref-count (add1 backref-count))
161      x)
162    (define (fetchslots x i)
163      (let ((len (##sys#size x)))
164        (do ((i i (add1 i)))
165            ((>= i len) x)
166          (##sys#setslot x i (fetch)) ) ) )
167    (define (fetch)
168      (let ((tag (getb)))
169        (select tag
170          ((sixtyfour-bit-tag) (fetch))
171          ((thirtytwo-bit-tag) (fetch))
172          ((big-endian-tag) (fetch))
173          ((little-endian-tag) (fetch))
174          ((void-tag) (void))
175          ((null-tag) '())
176          ((eof-tag) #!eof)
177          ((true-tag) #t)
178          ((false-tag) #f)
179          ((backref-tag)
180           (let ((w (getw)))
181             (vector-ref backrefs w)) )
182          ((fixnum-tag)
183           (##core#inline "bytes_to_fixnum" (read-string +sizeof-word+ port)) )
184          ((char-tag)
185           (integer->char (getw)) )
186          ((gensym-tag)
187           (addref #f)
188           (let* ((r (sub1 backref-count))
189                  (x (##sys#make-symbol (fetch))) )
190             (vector-set! backrefs r x)
191             x) )
192          ((symbol-tag)
193           (addref #f)
194           (let* ((r (sub1 backref-count))
195                  (x (##sys#intern-symbol (fetch)) ))
196             (vector-set! backrefs r x)
197             x) )
198          ((stdport-tag)
199           (addref #f)
200           (let* ((n (getb))
201                  (r (sub1 backref-count))
202                  (p (case n
203                       ((0) stdin-port)
204                       ((1) stdout-port)
205                       ((2) stderr-port)
206                       (else (error 'deserialize "invalid standard-port number" n)) ) ) )
207             (vector-set! backrefs r p)
208             p) )
209          ((hash-table-tag)
210           (addref #f)
211           (let ((r (sub1 backref-count))
212                 (ht (##sys#make-structure 'hash-table #f 0 #f #f)) )
213             (vector-set! backrefs r ht)
214             (let* ((table (fetch))
215                    (test (fetch))
216                    (hashf (fetch)) 
217                    (ht2 (alist->hash-table table)) )
218               (##sys#setslot ht 1 (##sys#slot ht2 1))
219               (##sys#setslot ht 2 (##sys#slot ht2 2))
220               (##sys#setslot ht 3 test)
221               (##sys#setslot ht 4 hashf)
222               ht) ) )
223          (else
224           (let* ((h (read-string +sizeof-header+ port))
225                  (x (addref (bytes_to_block h))) 
226                  (r (sub1 backref-count)) )
227             (##core#inline "set_header" x h)
228             (select tag
229               ((bytevector-tag)
230                (##core#inline "insert_bytes" x (read-string (##sys#size x) port))
231                x)
232               ((vector-tag) (fetchslots x 0))
233               #;((special-tag)
234                (when safe
235                  (error 'deserialize "unable to deserialize pointer-like object" x) )
236                (##core#inline "insert_bytes" x (read-string +sizeof-word+ port))
237                (fetchslots x 1) )
238               ((procedure-tag)
239                (let ((id (fetch)))
240                  (cond ((##core#inline "set_procedure_ptr" x (##sys#make-c-string id))
241                         (fetchslots x 1) )
242                        (fallback 
243                         (let ((proc (fallback id (fetchslots x 1))))
244                           (vector-set! backrefs r proc)
245                           proc) )
246                        (else (error 'deserialize "unable to deserialize procedure - no table entry found" id))) ) )
247               (else (error 'deserialize "invalid tag" tag)) ) ) ) ) ) )
248    (fetch) ) )
249
250)
Note: See TracBrowser for help on using the repository browser.