Source

scheme-bert / src / scheme-bert.ss

  1
  2
  3
  4
  5
  6
  7
  8
  9
 10
 11
 12
 13
 14
 15
 16
 17
 18
 19
 20
 21
 22
 23
 24
 25
 26
 27
 28
 29
 30
 31
 32
 33
 34
 35
 36
 37
 38
 39
 40
 41
 42
 43
 44
 45
 46
 47
 48
 49
 50
 51
 52
 53
 54
 55
 56
 57
 58
 59
 60
 61
 62
 63
 64
 65
 66
 67
 68
 69
 70
 71
 72
 73
 74
 75
 76
 77
 78
 79
 80
 81
 82
 83
 84
 85
 86
 87
 88
 89
 90
 91
 92
 93
 94
 95
 96
 97
 98
 99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
139
140
141
142
143
144
145
146
147
148
149
150
151
152
153
154
155
156
157
158
159
160
161
162
163
164
165
166
167
168
169
170
171
172
173
174
175
176
177
178
179
180
181
182
183
184
185
186
187
188
189
190
191
192
193
194
195
196
197
198
199
200
201
202
203
204
205
206
207
208
209
210
211
212
213
214
215
216
217
218
219
220
221
222
223
224
225
226
227
228
229
230
231
232
233
234
235
236
237
238
239
240
241
242
243
244
245
246
247
248
249
250
251
252
253
254
255
256
257
258
259
260
261
262
263
264
265
266
267
268
269
270
271
272
273
274
275
276
277
278
279
280
281
282
283
284
285
286
287
288
289
290
291
292
293
294
295
296
297
298
299
300
301
302
303
304
305
306
307
308
309
310
311
312
313
314
315
316
317
318
319
320
321
322
323
324
325
326
327
328
329
330
331
332
333
334
335
336
337
338
339
340
341
342
343
344
345
346
347
348
349
350
351
352
353
354
355
356
357
358
359
360
361
362
363
364
365
366
367
368
369
370
371
372
373
374
375
376
377
378
379
380
381
382
383
384
385
386
387
388
389
390
391
392
393
394
395
396
397
398
399
400
401
402
403
404
405
406
407
408
409
410
411
412
413
414
415
416
417
418
419
420
421
422
423
424
425
426
427
428
429
430
431
432
433
434
435
#!r6rs
(library (scheme-bert)
         (export encode)
         (import (rnrs base) 
                 (rnrs bytevectors) 
                 (rnrs lists) 
                 (rnrs hashtables)
                 (rnrs mutable-pairs)
                 (rnrs io ports)
                 (rnrs io simple)
                 (rnrs control)
                 (rename 
                  (rnrs arithmetic bitwise) 
                  (bitwise-and band)
                  (bitwise-arithmetic-shift-left bsl)
                  (bitwise-arithmetic-shift-right bsr)
                  (bitwise-ior bor))
                 (rnrs arithmetic fixnums)                 
                 (rnrs arithmetic flonums)
                 (rnrs r5rs)
                 ;; see TODO
                 (mzlib pregexp)
                 (srfi :19))
         
         ;; Erlang external term format types
         (define SMALL_INT 97)
         (define INT 98)
         (define SMALL_BIGNUM 110)
         (define LARGE_BIGNUM 111)
         (define FLOAT 99)
         (define ATOM 100)
         (define SMALL_TUPLE 104)
         (define LARGE_TUPLE 105)
         (define NIL 106)
         (define STRING 107)
         (define LIST 108)
         (define BIN 109)
         (define MAGIC 131)
         (define MAX_INT (- (bsl 1 27) 1))
         (define MIN_INT (- (bsl 1 27)))         
         
         ;; take returns the first k elements of list lst.
         ;; It is not an error for k to exceed the length of the list -- 
         ;; in that case the whole list is returned. 
         #|(define (take lst k)
           (let recur ((lst lst)
                       (k k))
             (if (null? lst) '()
                 (if (zero? k) '()
                     (cons (car lst) 
                           (recur (cdr lst) (- k 1)))))))|#
         
         (define (dropwhile proc list)
           (let recur ((proc proc)
                       (list list)
                       (acc '()))
             (if (or (null? list) (not (proc (car list))))
                 (reverse acc)
                 (recur proc (cdr list) (cons (car list) acc)))))         
         
         (define (fold/and proc lst)
           (cond
             ((null? lst)
              #t)
             ((proc (car lst))
              (fold/and proc (cdr lst)))
             (else #f)))
         
         (define (write-1 outpr byte)
           (put-u8 outpr byte))
         
         (define (write-2 outpr short)
           (put-u8 outpr (bsr short 8))
           (put-u8 outpr (band short #xff)))
         
         (define (write-4 outpr long)         
           (let ((b (make-bytevector 4)))
             (bytevector-s32-set! b 0 long (endianness big))
             (put-bytevector outpr b)))         
         
         (define (write-binary outpr data)
           (write-1 outpr BIN)
           (let ((b (string->bytevector data (native-transcoder))))
             (write-4 outpr (bytevector-length b))
             (put-bytevector outpr b)))
         
         (define (write-float outpr float)
           (write-1 outpr FLOAT)
           (let* ((str (fldigits float))
                  (len (string-length str)))
             (write-str outpr str)
             (let pad ((x (- 31 len)))
               (if (zero? x) '()
                   (begin
                     (write-1 outpr 0)
                     (pad (- x 1)))))))                  
         
         (define (write-str outpr str)
           (put-bytevector 
            outpr 
            (string->bytevector str (native-transcoder))))
         
         (define (write-atom outpr symbol)
           (let* ((str (symbol->string symbol))
                  (len (string-length str)))
             (if (< len 256)
                 (if (eq? #f (pregexp-match "^[a-zA-Z]+[a-zA-Z0-9_]*$" str))
                     (error "write-symbol" 
                            "Syntax error, unexpected character.")
                     (begin
                       (write-1 outpr ATOM)
                       (write-2 outpr len)
                       (write-str outpr str)))
                 (error "write-symbol" 
                        "Length error, should be in range [0,255]"))))         
         
         (define (write-list outpr data)
           (cond
             ((null? data)
              (write-1 outpr NIL))
             ((fold/and (lambda (x) (isbyte? x)) data)
              (write-1 outpr STRING)
              (write-2 outpr (length data))
              (for-each (lambda (x) (write-1 outpr x)) data))
             (else (write-1 outpr LIST)
                   (write-4 outpr (length data))
                   (for-each (lambda (x) (write-any-raw outpr x)) data)
                   (write-1 outpr NIL))))
         
         (define (write-tuple outpr data)
           (let ((len (vector-length data)))
             (if (< len 256)
                 (begin
                   (write-1 outpr SMALL_TUPLE)
                   (write-1 outpr len))
                 (begin
                   (write-1 outpr LARGE_TUPLE)
                   (write-4 outpr len)))
             (let vector-do ((position 0))
               (unless (= position len)
                 (begin
                   (write-any-raw outpr (vector-ref data position))
                   (vector-do (+ position 1)))))))
         
         (define (isbyte? x)
           (and (integer? x) (> x 0) (< x 256)))
         
         (define (write-fixnum outpr num)
           (cond
             ((isbyte? num)
              (write-1 outpr SMALL_INT)
              (write-1 outpr num))
             ((and (>= num MIN_INT) (<= num MAX_INT))
              (write-1 outpr INT)
              (write-4 outpr num))
             (else (write-bignum outpr num))))         
         
         (define (write-bignum outpr num)
           (let ((n (ceiling (/ (bitwise-length num) 8)))) bitwise-length
             (if (< n 256)
                 (begin
                   (write-1 outpr SMALL_BIGNUM)
                   (write-1 outpr n))
                 (begin
                   (write-1 outpr LARGE_BIGNUM)
                   (write-4 outpr n)))
             (write-bignum-guts outpr num)))
         
         (define (write-bignum-guts outpr num)
           (write-1 outpr (if (< num 0) 1 0))     ; sign
           (let wr-b ((numabs (abs num)))
             (unless (zero? numabs)
               (begin
                 (write-1 outpr (mod numabs 256))
                 (wr-b (bsr numabs 8))))))         
         
         (define (write-hash outpr hash)
           (let-values (((a b) (hashtable-entries hash)))
             (write-any-raw 
              outpr
              (vector 'bert 'dict
                      (vector->list 
                       (vector-map
                        (lambda (k v) (vector (convert k) (convert v)))
                        a b))))))
         
         (define (write-any-raw outpr obj)
           (cond
             ((list? obj)
              (write-list outpr obj))
             ((hashtable? obj)
              (write-hash outpr obj))
             ((vector? obj)
              (write-tuple outpr obj))
             ((symbol? obj)
              (write-atom outpr obj))
             ((flonum? obj)  ;; should be before integer? test
              (write-float outpr obj))                 
             ((integer? obj)
              (write-fixnum outpr obj))
             ((string? obj)
              (write-binary outpr obj))
             (else (error "write-any-raw" "Not implemented."))))
         
         (define (write-any outpr obj)
           (write-1 outpr MAGIC)
           (write-any-raw outpr obj))
         
         (define (convert obj)
           (cond
             ((eq? obj #t)
              (vector 'bert 'true))
             ((eq? obj #f)
              (vector 'bert 'false))
             ((eqv? obj 'nil)
              (vector 'bert 'nil))
             ((time? obj)
              (let ((t (time-second obj)))
                (vector 'bert 
                        'time 
                        (div t 1000000) 
                        (mod t 1000000)
                        (div (time-nanosecond obj) 1000))))
             (else obj)))
         
         (define (encode obj)
           (call-with-bytevector-output-port 
            (lambda(outpr) (write-any outpr (convert obj)))))
         
         (define (encode-pretty obj)
           (bytevector->u8-list (encode obj)))         
         
         ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
         ;; Floating-point processing routines
         
         ;; funpack unpacks and returns double-precision 64 bit
         ;; IEEE-754 float's sign, exponent and fraction
         (define (funpack float)
           (let ((b (make-bytevector 8)))
             (bytevector-ieee-double-native-set! b 0 float)
             (values
              (bitwise-bit-field (bytevector-u64-native-ref b 0) 63 64)
              (bitwise-bit-field (bytevector-u64-native-ref b 0) 52 63)
              (bitwise-bit-field (bytevector-u64-native-ref b 0)  0 52))))
         
         ;; frexp is analogous to frexp(1) found in C
         (define (frexp float)
           (let ((FLOAT_BIAS 1022))
             (define (frac1 sign expon frac)
               (let ((b (make-bytevector 8)))
                 (bytevector-u64-native-set!
                  b 0 (bor (bsl (bor (bsl sign 11) FLOAT_BIAS) 52) frac))
                 (bytevector-ieee-double-native-ref b 0)))
             (let-values (((sign expon frac) (funpack float)))
               (cond
                 ((fold/and zero? (list sign expon frac))
                  (values 0 0))
                 ((zero? expon)
                  (cons (frac1 sign exp (- frac 1))
                        (+ (- (- FLOAT_BIAS) 52) (bitwise-length frac))))
                 (else 
                  (cons (frac1 sign expon frac) 
                        (- expon FLOAT_BIAS)))))))
         
         (define (insert-decimal-exp place s)
           (let* ((s0 (if (= (string-length s) 1) "0"
                          (substring s 1)))
                  (e  (if (< place 1) "e-" "e+"))
                  (t (- 20 (string-length s0)))
                  (s1 (if (not (zero? t))
                          (string-append s0 (make-string t #\0))
                          s0)))
             (string-append (substring s 0 1) "." s1 e 
                            (number->string (abs (- place 1))))))
         
         (define (fldigits float)
           (if (zero? float)
               "0.0"
               (let* ((frexpres (frexp float))
                      (f (car frexpres))
                      (e (cdr frexpres))
                      (e1 (- e 53))
                      (f1 (exact (truncate (* (abs f) (bsl 1 53)))))
                      (fdig (flonum->digits float f1 e1))
                      (place (car fdig))
                      (digits (cdr fdig))
                      (r (map (lambda(x)(integer->char (+ x #x30))) digits))
                      (strdigits (list->string r)))
                 (string-append (if (< float 0) "-" "")                                
                                (insert-decimal-exp place strdigits)))))
         
         ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
         ;; These are routines from
         ;;  "Printing Floating-Point Numbers Quickly and Accurately"
         ;; by Robert G. Burger and R. Kent Dybvig.
         ;; Refer to http://www.cs.indiana.edu/~burger/fp/index.html
         
         (define flonum->digits
           (let ([min-e -1074]
                 [bp-1 (expt 2 52)])
             (lambda (v f e)
               (let ([round? (even? f)])
                 (if (>= e 0)
                     (if (not (= f bp-1))
                         (let ([be (expt 2 e)])
                           (scale (* f be 2) 2 be be 0 round? round? v))
                         (let ([be (expt 2 e)])
                           (scale (* f be 4) 4 (* be 2) be 0 round? round? v)))
                     (if (or (= e min-e) (not (= f bp-1)))
                         (scale (* f 2) (expt 2 (- 1 e)) 1 1 0 round? round? v)
                         (scale (* f 4) (expt 2 (- 2 e)) 2 1 0 
                                round? round? v)))))))
         
         (define scale
           (lambda (r s m+ m- k low-ok? high-ok? v)
             (newline)
             (let ([est (exact (ceiling (- (log10 (abs v)) 1e-10)))])
               (if (>= est 0)
                   (fixup r (* s (expt10 est)) m+ m- est low-ok? high-ok?)
                   (let ([scale (expt10 (- est))])
                     (fixup (* r scale) s (* m+ scale) (* m- scale)
                            est low-ok? high-ok?))))))
         
         (define fixup
           (lambda (r s m+ m- k low-ok? high-ok?)
             (if ((if high-ok? >= >) (+ r m+) s) ; too low?
                 (cons (+ k 1) (generate r s m+ m- low-ok? high-ok?))
                 (cons k
                       (generate (* r 10) s (* m+ 10) 
                                 (* m- 10) low-ok? high-ok?)))))
         
         (define generate
           (lambda (r s m+ m- low-ok? high-ok?)
             (let ([d (quotient r s)]
                   [r (remainder r s)])
               (let ([tc1 ((if low-ok? <= <) r m-)]
                     [tc2 ((if high-ok? >= >) (+ r m+) s)])
                 (if (not tc1)
                     (if (not tc2)
                         (cons d (generate (* r 10) s (* m+ 10) (* m- 10)
                                           low-ok? high-ok?))
                         (list (+ d 1)))
                     (if (not tc2)
                         (list d)
                         (if (< (* r 2) s) (list d) (list (+ d 1)))))))))
         
         (define expt10
           (let ([table (make-vector 326)])
             (do ([k 0 (+ k 1)] [v 1 (* v 10)])
               ((= k 326))
               (vector-set! table k v))
             (lambda (k)
               (vector-ref table k))))
         
         (define log10
           (let ([f (/ (log 10))])
             (lambda (x)
               (* (log x) f))))
         
         ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
         ;; Decoder part
         
         (define (decode bytes)
           (read-any (open-bytevector-input-port bytes)))
         
         (define (read-any inp)
           (if (eq? (read-small-int inp) MAGIC)
               (read-any-raw inp)
               (error "read-any" "Bad Magic")))
         
         (define (read-any-raw inp)
           (let ((tag (read-small-int inp)))
             (cond
               ((eq? tag ATOM) (read-atom inp))
               ((eq? tag SMALL_INT) (read-small-int inp))
               ((eq? tag INT) (read-int inp))
               ((eq? tag SMALL_BIGNUM) (read-bignum-t inp 'small))               
               ((eq? tag LARGE_BIGNUM) (read-bignum-t inp 'large))
               ((eq? tag FLOAT) (read-float inp))               
               (else
                (error "read-any-raw"
                       (string-append 
                        "Unknown term tag: "
                        (number->string tag)))))))
         
         (define (read-n inp len)
           (get-bytevector-n inp len))
         
         (define (read-1 inp)
           (read-n inp 1))
         
         (define (read-2 inp)
           (read-n inp 2))
         
         (define (read-4 inp)
           (read-n inp 4))
         
         (define (read-short inp)
           (bytevector-u16-ref (read-2 inp) 0 (endianness big)))
         
         (define (read-str inp length)
           (bytevector->string (read-n inp length) 
                               (native-transcoder)))
         
         (define (read-atom inp)
           (let ((len (read-short inp)))
             (string->symbol (read-str inp len))))
         
         (define (read-small-int inp)
           (bytevector-u8-ref (read-1 inp) 0))
         
         (define (read-int inp)
           (bytevector-s32-ref (read-4 inp) 0 (endianness big)))
         
         (define (read-bignum-t inp type)
           (let* ((size (if (eq? type 'small) 
                            (read-small-int inp)
                            (read-int inp)))
                  (sign (read-small-int inp))
                  (bytes (bytevector->u8-list (read-n inp size))))
             (let recur ((i 0)
                         (bytes bytes)
                         (sum 0))
               (if (null? bytes)
                   (if (zero? sign) sum (- sum))
                   (recur (+ i 1) (cdr bytes)
                     (+ sum (* (car bytes) (expt 256 i))))))))        
         
         (define (read-float inp)      
           (string->number 
            (bytevector->string 
             (u8-list->bytevector                    
              (dropwhile (lambda(x) (> x 0)) 
                         (bytevector->u8-list (read-n inp 31))))
             (native-transcoder)))))