Eli's repaired and specialized sort, fix in 'for/fold' binding, generalized integers-bytes functions, and some r6rs work
svn: r8798
This commit is contained in:
Matthew Flatt
parent
871bb0bac5
commit
8311c8f9e4
|
|
@ -22,7 +22,7 @@
|
|||
-1
|
||||
(let loop ([b b][pos 0])
|
||||
(if (zero? (bitwise-and b 1))
|
||||
(loop (arithmetic-shift b) (add1 pos))
|
||||
(loop (arithmetic-shift b -1) (add1 pos))
|
||||
pos))))
|
||||
|
||||
|
||||
|
|
|
|||
405
collects/rnrs/bytevectors-6.ss
Normal file
405
collects/rnrs/bytevectors-6.ss
Normal file
|
|
@ -0,0 +1,405 @@
|
|||
#lang scheme/base
|
||||
|
||||
(require rnrs/enums-6)
|
||||
|
||||
(provide endianness
|
||||
native-endianness
|
||||
(rename-out [bytes? bytevector?]
|
||||
[bytes-length bytevector-length]
|
||||
[bytes=? bytevector=?]
|
||||
[bytes-copy! bytevector-copy!]
|
||||
[bytes-copy bytevector-copy]
|
||||
[bytes-ref bytevector-u8-ref]
|
||||
[bytes-set! bytevector-u8-set!]
|
||||
[bytes->list bytevector->u8-list]
|
||||
[list->bytes u8-list->bytevector])
|
||||
make-bytevector
|
||||
bytevector-fill!
|
||||
bytevector-s8-ref
|
||||
bytevector-s8-set!
|
||||
|
||||
bytevector-u16-ref
|
||||
bytevector-s16-ref
|
||||
bytevector-u16-native-ref
|
||||
bytevector-s16-native-ref
|
||||
bytevector-u16-set!
|
||||
bytevector-s16-set!
|
||||
bytevector-u16-native-set!
|
||||
bytevector-s16-native-set!
|
||||
|
||||
bytevector-u32-ref
|
||||
bytevector-s32-ref
|
||||
bytevector-u32-native-ref
|
||||
bytevector-s32-native-ref
|
||||
bytevector-u32-set!
|
||||
bytevector-s32-set!
|
||||
bytevector-u32-native-set!
|
||||
bytevector-s32-native-set!
|
||||
|
||||
bytevector-u64-ref
|
||||
bytevector-s64-ref
|
||||
bytevector-u64-native-ref
|
||||
bytevector-s64-native-ref
|
||||
bytevector-u64-set!
|
||||
bytevector-s64-set!
|
||||
bytevector-u64-native-set!
|
||||
bytevector-s64-native-set!
|
||||
|
||||
bytevector-uint-ref
|
||||
bytevector-sint-ref
|
||||
bytevector-uint-set!
|
||||
bytevector-sint-set!
|
||||
|
||||
string->utf8
|
||||
string->utf16
|
||||
string->utf32
|
||||
utf8->string
|
||||
utf16->string
|
||||
utf32->string)
|
||||
|
||||
(define-enumeration endianness (big little) endianness-set)
|
||||
|
||||
(define (native-endianness)
|
||||
(if (system-big-endian?)
|
||||
(endianness big)
|
||||
(endianness little)))
|
||||
|
||||
(define (make-bytevector k [fill 0])
|
||||
(make-bytes k (convert-fill 'make-bytevector fill)))
|
||||
|
||||
(define (convert-fill who fill)
|
||||
(cond
|
||||
[(byte? fill) fill]
|
||||
[(and (exact-integer? fill)
|
||||
(<= -128 fill -1))
|
||||
(+ fill 256)]
|
||||
[else (raise-type-error who
|
||||
"exact integer in [128, 255]"
|
||||
fill)]))
|
||||
|
||||
|
||||
(define (bytevector-fill! bytes [fill 0])
|
||||
(bytes-fill! bytes (convert-fill 'bytevector-fill! fill)))
|
||||
|
||||
;; ----------------------------------------
|
||||
|
||||
(define (bytevector-s8-ref bytes k)
|
||||
(let ([v (bytes-ref bytes k)])
|
||||
(if (v . > . 127)
|
||||
(- v 256)
|
||||
v)))
|
||||
|
||||
(define (bytevector-s8-set! bytes k)
|
||||
(bytes-set! bytes (convert-fill 'bytevector-s8-set! k)))
|
||||
|
||||
(define (check-endian endianness)
|
||||
(unless (or (eq? endianness 'little)
|
||||
(eq? endianness 'big))
|
||||
(raise-type-error 'bytevector-operation "'big or 'little" endianness)))
|
||||
|
||||
(define (make-integer-ops size)
|
||||
(values
|
||||
;; uXX-ref
|
||||
(lambda (bytes k endianness)
|
||||
(check-endian endianness)
|
||||
(integer-bytes->integer bytes #f (eq? endianness 'big) k (+ k size)))
|
||||
;; sXX-ref
|
||||
(lambda (bytes k endianness)
|
||||
(check-endian endianness)
|
||||
(integer-bytes->integer bytes #t (eq? endianness 'big) k (+ k size)))
|
||||
;; uXX-native-ref
|
||||
(lambda (bytes k)
|
||||
(integer-bytes->integer bytes #f (system-big-endian?) k (+ k size)))
|
||||
;; sXX-native-ref
|
||||
(lambda (bytes k)
|
||||
(integer-bytes->integer bytes #t (system-big-endian?) k (+ k size)))
|
||||
;; uXX-set!
|
||||
(lambda (bytes k n endianness)
|
||||
(check-endian endianness)
|
||||
(integer->integer-bytes n size #f (eq? endianness 'big) bytes k)
|
||||
(void))
|
||||
;; sXX-set!
|
||||
(lambda (bytes k n endianness)
|
||||
(check-endian endianness)
|
||||
(integer->integer-bytes n size #t (eq? endianness 'big) bytes k)
|
||||
(void))
|
||||
;; uXX-native-set!
|
||||
(lambda (bytes k n)
|
||||
(integer->integer-bytes n size #f (system-big-endian?) bytes k)
|
||||
(void))
|
||||
;; sXX-native-set!
|
||||
(lambda (bytes k n)
|
||||
(integer->integer-bytes n size #t (system-big-endian?) bytes k)
|
||||
(void))))
|
||||
|
||||
(define-values (bytevector-u16-ref
|
||||
bytevector-s16-ref
|
||||
bytevector-u16-native-ref
|
||||
bytevector-s16-native-ref
|
||||
bytevector-u16-set!
|
||||
bytevector-s16-set!
|
||||
bytevector-u16-native-set!
|
||||
bytevector-s16-native-set!)
|
||||
(make-integer-ops 2))
|
||||
|
||||
(define-values (bytevector-u32-ref
|
||||
bytevector-s32-ref
|
||||
bytevector-u32-native-ref
|
||||
bytevector-s32-native-ref
|
||||
bytevector-u32-set!
|
||||
bytevector-s32-set!
|
||||
bytevector-u32-native-set!
|
||||
bytevector-s32-native-set!)
|
||||
(make-integer-ops 4))
|
||||
|
||||
(define-values (bytevector-u64-ref
|
||||
bytevector-s64-ref
|
||||
bytevector-u64-native-ref
|
||||
bytevector-s64-native-ref
|
||||
bytevector-u64-set!
|
||||
bytevector-s64-set!
|
||||
bytevector-u64-native-set!
|
||||
bytevector-s64-native-set!)
|
||||
(make-integer-ops 8))
|
||||
|
||||
;; ----------------------------------------
|
||||
|
||||
(define (bytevector-int-ref who bstr k endianness size)
|
||||
(unless (bytes? bstr)
|
||||
(raise-type-error who "bytevector" bstr))
|
||||
(unless (exact-nonnegative-integer? k)
|
||||
(raise-type-error who "exact nonnegative integer" k))
|
||||
(check-endian endianness)
|
||||
(unless (exact-positive-integer? size)
|
||||
(raise-type-error who "exact positive integer" size))
|
||||
(unless (<= (+ k size) (bytes-length bstr))
|
||||
(error who "specified range [~a, ~a) beyond string range [0, ~a)"
|
||||
k (+ k size) (bytes-length bstr)))
|
||||
(for/fold ([r 0])
|
||||
([i (in-range size)])
|
||||
(+ (arithmetic-shift r 8)
|
||||
(bytes-ref bstr (+ (if (eq? endianness 'big)
|
||||
i
|
||||
(- size i 1))
|
||||
k)))))
|
||||
|
||||
(define (bytevector-uint-ref bstr k endianness size)
|
||||
(bytevector-int-ref 'bytevector-uint-ref bstr k endianness size))
|
||||
|
||||
(define (bytevector-sint-ref bstr k endianness size)
|
||||
(let ([v (bytevector-int-ref 'bytevector-sint-ref bstr k endianness size)]
|
||||
[max (sub1 (arithmetic-shift 1 (sub1 (* size 8))))])
|
||||
(if (v . > . max)
|
||||
(- v (* 2 (add1 max)))
|
||||
v)))
|
||||
|
||||
|
||||
(define (bytevector-int-set! who bstr k n orig-n endianness size bit-size)
|
||||
(unless (bytes? bstr)
|
||||
(raise-type-error who "bytevector" bstr))
|
||||
(unless (exact-nonnegative-integer? k)
|
||||
(raise-type-error who "exact nonnegative integer" k))
|
||||
(check-endian endianness)
|
||||
(unless (exact-positive-integer? size)
|
||||
(raise-type-error who "exact positive integer" size))
|
||||
(unless (<= (+ k size) (bytes-length bstr))
|
||||
(error who "specified target range [~a, ~a) beyond string range [0, ~a)"
|
||||
k (+ k size) (bytes-length bstr)))
|
||||
(unless ((integer-length orig-n) . <= . bit-size)
|
||||
(error who "integer does not fit into ~a bytes: ~e"
|
||||
size orig-n))
|
||||
(for/fold ([n n])
|
||||
([i (in-range size)])
|
||||
(bytes-set! bstr (+ (if (eq? endianness 'little)
|
||||
i
|
||||
(- size i 1))
|
||||
k)
|
||||
(bitwise-and n 255))
|
||||
(arithmetic-shift n -8))
|
||||
(void))
|
||||
|
||||
(define (bytevector-uint-set! bstr k n endianness size)
|
||||
(unless (exact-nonnegative-integer? n)
|
||||
(raise-type-error 'bytevector-uint-set! "exact nonnegative integer" n))
|
||||
(bytevector-int-set! 'bytevector-uint-set! bstr k n n endianness size (* size 8)))
|
||||
|
||||
(define (bytevector-sint-set! bstr k n endianness size)
|
||||
(let ([pos-n (if (negative? n)
|
||||
(+ n (arithmetic-shift 1 (* 8 size)))
|
||||
n)])
|
||||
(bytevector-int-set! 'bytevector-uint-set! bstr k pos-n n endianness size (* size (sub1 8)))))
|
||||
|
||||
;; ----------------------------------------
|
||||
|
||||
(define (string->utf8 str)
|
||||
(string->bytes/utf-8 str))
|
||||
|
||||
(define (string->utf16 str [endianness 'big])
|
||||
(check-endian endianness)
|
||||
(let ([big? (eq? endianness 'big)])
|
||||
(let loop ([pos (string-length str)]
|
||||
[accum null])
|
||||
(if (zero? pos)
|
||||
(list->bytes accum)
|
||||
(let* ([pos (sub1 pos)]
|
||||
[c (string-ref str pos)]
|
||||
[v (char->integer c)])
|
||||
(if (v . >= . #x10000)
|
||||
(let ([v2 (- v #x10000)])
|
||||
(let-values ([(a b c d)
|
||||
(values (bitwise-ior #xD8
|
||||
(arithmetic-shift v2 -18))
|
||||
(bitwise-and #xFF
|
||||
(arithmetic-shift v2 -10))
|
||||
(bitwise-ior #xDC
|
||||
(bitwise-and #x3
|
||||
(arithmetic-shift v2 -8)))
|
||||
(bitwise-and v2 #xFF))])
|
||||
(if big?
|
||||
(loop pos (list* a b c d accum))
|
||||
(loop pos (list* b a d c accum)))))
|
||||
(let-values ([(hi lo)
|
||||
(values (arithmetic-shift v -8)
|
||||
(bitwise-and v 255))])
|
||||
(if big?
|
||||
(loop pos (list* hi lo accum))
|
||||
(loop pos (list* lo hi accum))))))))))
|
||||
|
||||
(define (string->utf32 str [endianness 'big])
|
||||
(check-endian endianness)
|
||||
(let ([bstr (make-bytes (* 4 (string-length str)))]
|
||||
[big? (eq? endianness 'big)])
|
||||
(for ([c (in-string str)]
|
||||
[i (in-naturals)])
|
||||
(let* ([v (char->integer c)]
|
||||
[a (arithmetic-shift v -24)]
|
||||
[b (bitwise-and #xFF (arithmetic-shift v -16))]
|
||||
[c (bitwise-and #xFF (arithmetic-shift v -8))]
|
||||
[d (bitwise-and #xFF v)]
|
||||
[pos (* i 4)])
|
||||
(if big?
|
||||
(begin
|
||||
(bytes-set! bstr pos a)
|
||||
(bytes-set! bstr (+ 1 pos) b)
|
||||
(bytes-set! bstr (+ 2 pos) c)
|
||||
(bytes-set! bstr (+ 3 pos) d))
|
||||
(begin
|
||||
(bytes-set! bstr pos d)
|
||||
(bytes-set! bstr (+ 1 pos) c)
|
||||
(bytes-set! bstr (+ 2 pos) b)
|
||||
(bytes-set! bstr (+ 3 pos) a)))))
|
||||
bstr))
|
||||
|
||||
(define (utf8->string bstr)
|
||||
(bytes->string/utf-8 bstr #\uFFFD))
|
||||
|
||||
(define (utf16->string bstr endianness [skip-bom? #f])
|
||||
;; This version skips a two bytes for decoding errors,
|
||||
;; except those that correspond to a trailing single byte.
|
||||
(check-endian endianness)
|
||||
(let ([len (bytes-length bstr)])
|
||||
(let-values ([(big? offset)
|
||||
(cond
|
||||
[skip-bom?
|
||||
(values (eq? endianness 'big) 0)]
|
||||
[(len . >= . 2)
|
||||
(cond
|
||||
[(and (eq? #xFE (bytes-ref bstr 0))
|
||||
(eq? #xFF (bytes-ref bstr 1)))
|
||||
(values #t 2)]
|
||||
[(and (eq? #xFF (bytes-ref bstr 0))
|
||||
(eq? #xFE (bytes-ref bstr 1)))
|
||||
(values #t 1)]
|
||||
[else (values (eq? endianness 'big) 0)])]
|
||||
[else (values (eq? endianness 'big) 0)])])
|
||||
(list->string
|
||||
(let loop ([pos offset])
|
||||
(cond
|
||||
[(= pos len) null]
|
||||
[(= (add1 pos) len)
|
||||
;; decoding error
|
||||
'(#\uFFFD)]
|
||||
[else
|
||||
(let ([a (bytes-ref bstr pos)]
|
||||
[b (bytes-ref bstr (add1 pos))])
|
||||
(let ([a (if big? a b)]
|
||||
[b (if big? b a)])
|
||||
(cond
|
||||
[(= (bitwise-and a #xD8) #xD8)
|
||||
(if (len . < . (+ pos 4))
|
||||
;; decoding error
|
||||
(cons #\uFFFD (loop (+ pos 2)))
|
||||
;; Surrogate...
|
||||
(let ([c (bytes-ref bstr (+ pos 2))]
|
||||
[d (bytes-ref bstr (+ pos 3))])
|
||||
(let ([c (if big? c d)]
|
||||
[d (if big? d c)])
|
||||
(cond
|
||||
[(= (bitwise-and c #xDC) #xDC)
|
||||
;; A valid surrogate
|
||||
(let ([v (+ #x10000
|
||||
(bitwise-ior
|
||||
(arithmetic-shift (bitwise-and #x3 a) 18)
|
||||
(arithmetic-shift b 10)
|
||||
(arithmetic-shift (bitwise-and #x3 c) 8)
|
||||
d))])
|
||||
(cons (integer->char v) (loop (+ pos 4))))]
|
||||
[else
|
||||
;; Invalid surrogate.
|
||||
(cons #\uFFFD (loop (+ pos 2)))]))))]
|
||||
[(= (bitwise-and a #xDC) #xDC)
|
||||
;; invalid surrogate code
|
||||
(cons #\uFFFD (loop (+ pos 2)))]
|
||||
[else
|
||||
(let ([v (bitwise-ior (arithmetic-shift a 8)
|
||||
b)])
|
||||
(cons (integer->char v)
|
||||
(loop (+ pos 2))))])))]))))))
|
||||
|
||||
(define (utf32->string bstr endianness [skip-bom? #f])
|
||||
;; Skips 4 bytes for each dcoding error (except too-few-bytes-at-end
|
||||
;; errors, obviously).
|
||||
(check-endian endianness)
|
||||
(let ([len (bytes-length bstr)])
|
||||
(let-values ([(big? offset)
|
||||
(cond
|
||||
[skip-bom?
|
||||
(values (eq? endianness 'big) 0)]
|
||||
[(and (len . >= . 4)
|
||||
(eq? #x00 (bytes-ref bstr 0))
|
||||
(eq? #x00 (bytes-ref bstr 1)))
|
||||
(cond
|
||||
[(and (eq? #xFE (bytes-ref bstr 2))
|
||||
(eq? #xFF (bytes-ref bstr 3)))
|
||||
(values #t 2)]
|
||||
[(and (eq? #xFF (bytes-ref bstr 2))
|
||||
(eq? #xFE (bytes-ref bstr 3)))
|
||||
(values #t 1)]
|
||||
[else (values (eq? endianness 'big) 0)])]
|
||||
[else (values (eq? endianness 'big) 0)])])
|
||||
(list->string
|
||||
(let loop ([pos offset])
|
||||
(cond
|
||||
[(= pos len) null]
|
||||
[((+ pos 4) . > . len)
|
||||
;; decoding error
|
||||
'(#\uFFFD)]
|
||||
[else
|
||||
(let ([a (bytes-ref bstr pos)]
|
||||
[b (bytes-ref bstr (+ pos 1))]
|
||||
[c (bytes-ref bstr (+ pos 2))]
|
||||
[d (bytes-ref bstr (+ pos 3))])
|
||||
(let ([a (if big? a d)]
|
||||
[b (if big? b c)]
|
||||
[c (if big? c b)]
|
||||
[d (if big? d a)])
|
||||
(let ([v (bitwise-ior
|
||||
(arithmetic-shift a 24)
|
||||
(arithmetic-shift b 16)
|
||||
(arithmetic-shift c 8)
|
||||
d)])
|
||||
(if (or (and (v . >= . #xD800)
|
||||
(v . <= . #xDFFF))
|
||||
(v . > . #x10FFFF))
|
||||
(cons #\uFFFD (loop (+ pos 4)))
|
||||
(cons (integer->char v) (loop (+ pos 4)))))))]))))))
|
||||
240
collects/rnrs/enums-6.ss
Normal file
240
collects/rnrs/enums-6.ss
Normal file
|
|
@ -0,0 +1,240 @@
|
|||
#lang scheme/base
|
||||
|
||||
(require scheme/mpair
|
||||
rnrs/arithmetic/bitwise-6
|
||||
(for-syntax scheme/base))
|
||||
|
||||
(provide make-enumeration
|
||||
enum-set-universe
|
||||
enum-set-indexer
|
||||
enum-set-constructor
|
||||
enum-set-member?
|
||||
enum-set-subset?
|
||||
enum-set=?
|
||||
enum-set-union
|
||||
enum-set-intersection
|
||||
enum-set-difference
|
||||
enum-set-complement
|
||||
enum-set-projection
|
||||
define-enumeration)
|
||||
|
||||
(define-struct enum-set (val ht))
|
||||
|
||||
(define (make-enumeration-universe enum)
|
||||
(let ([bad (lambda ()
|
||||
(raise-type-error
|
||||
'make-enumeration
|
||||
"list of symbols"
|
||||
enum))])
|
||||
(unless (mlist? enum) (bad))
|
||||
(let ([enum (mlist->list enum)])
|
||||
(unless (andmap symbol? enum) (bad))
|
||||
(let ([ht (make-hash-table)])
|
||||
(for ([s (in-list enum)])
|
||||
(unless (hash-table-get ht s #f)
|
||||
(hash-table-put! ht s (arithmetic-shift 1 (hash-table-count ht)))))
|
||||
ht))))
|
||||
|
||||
(define (make-enumeration enum)
|
||||
(let ([ht (make-enumeration-universe enum)])
|
||||
(make-enum-set (sub1 (arithmetic-shift 1 (hash-table-count ht)))
|
||||
ht)))
|
||||
|
||||
(define (enum-set-universe enum)
|
||||
(unless (enum-set? enum)
|
||||
(raise-type-error 'enum-set-universe
|
||||
"enumeration set"
|
||||
enum))
|
||||
(let ([ht (enum-set-ht enum)])
|
||||
(make-enum-set (sub1 (arithmetic-shift 1 (hash-table-count ht))) ht)))
|
||||
|
||||
(define (enum-set-indexer enum)
|
||||
(unless (enum-set? enum)
|
||||
(raise-type-error 'enum-set-indexer
|
||||
"enumeration set"
|
||||
enum))
|
||||
(let ([ht (enum-set-ht enum)])
|
||||
(lambda (sym)
|
||||
(let ([v (hash-table-get ht sym #f)])
|
||||
(if v
|
||||
(bitwise-first-bit-set v)
|
||||
(error 'generated-enum-set-indexer
|
||||
(if (symbol? sym)
|
||||
"symbol not in universe: ~e"
|
||||
"not a symbol: ~e")
|
||||
sym))))))
|
||||
|
||||
(define (enum-set-constructor enum)
|
||||
(unless (enum-set? enum)
|
||||
(raise-type-error 'enum-set-constructor
|
||||
"enumeration set"
|
||||
enum))
|
||||
(let ([ht (enum-set-ht enum)])
|
||||
(lambda (orig-syms)
|
||||
(let loop ([syms orig-syms][val 0])
|
||||
(cond
|
||||
[(null? syms) (make-enum-set val ht)]
|
||||
[(not (mpair? syms))
|
||||
(raise-type-error 'make-enum-set
|
||||
"list of symbols"
|
||||
orig-syms)]
|
||||
[(hash-table-get ht (mcar syms) #f)
|
||||
=> (lambda (n)
|
||||
(loop (mcdr syms) (bitwise-ior val n)))]
|
||||
[else
|
||||
(error 'make-enum-set
|
||||
(if (symbol? (mcar syms))
|
||||
"symbol not in universe: ~e"
|
||||
"not a symbol: ~e")
|
||||
(mcar syms))])))))
|
||||
|
||||
(define (enum-set-member? sym enum)
|
||||
(unless (symbol? sym)
|
||||
(raise-type-error 'enum-set-member?
|
||||
"symbol"
|
||||
sym))
|
||||
(unless (enum-set? enum)
|
||||
(raise-type-error 'enum-set-member?
|
||||
"enumeration set"
|
||||
enum))
|
||||
(let ([v (hash-table-get (enum-set-ht enum) sym #f)])
|
||||
(and v
|
||||
(not (zero? (bitwise-and v (enum-set-val enum)))))))
|
||||
|
||||
(define (check-2-enums who enum1 enum2)
|
||||
(unless (and (enum-set? enum1)
|
||||
(enum-set? enum2))
|
||||
(raise-type-error who
|
||||
"enumeration set"
|
||||
(if (enum-set? enum1)
|
||||
enum2
|
||||
enum1))))
|
||||
|
||||
(define (enum-set-subset? enum1 enum2)
|
||||
(check-2-enums 'enum-set-subset? enum1 enum2)
|
||||
(if (eq? (enum-set-ht enum1) (enum-set-ht enum2))
|
||||
(= (enum-set-val enum1)
|
||||
(bitwise-and (enum-set-val enum1) (enum-set-val enum2)))
|
||||
(let ([ht2 (enum-set-ht enum2)]
|
||||
[v1 (enum-set-val enum1)]
|
||||
[v2 (enum-set-val enum2)])
|
||||
(for/fold ([sub? #t])
|
||||
(#:when sub?
|
||||
[(key1 val1) (in-hash-table (enum-set-ht enum1))])
|
||||
(or (zero? (bitwise-and v1 val1))
|
||||
(let ([val2 (hash-table-get ht2 key1 #f)])
|
||||
(and val2
|
||||
(not (zero? (bitwise-and v2 val2))))))))))
|
||||
|
||||
(define (enum-set=? enum1 enum2)
|
||||
(check-2-enums 'enum-set=? enum1 enum2)
|
||||
(if (eq? (enum-set-ht enum1) (enum-set-ht enum2))
|
||||
(= (enum-set-val enum1) (enum-set-val enum2))
|
||||
(and (enum-set-subset? enum1 enum2)
|
||||
(enum-set-subset? enum2 enum1))))
|
||||
|
||||
(define (check-2-enums/same who enum1 enum2)
|
||||
(check-2-enums who enum1 enum2)
|
||||
(unless (eq? (enum-set-ht enum1)
|
||||
(enum-set-ht enum2))
|
||||
(error who
|
||||
"enumeration sets are not the same enumeration type: ~e ~e"
|
||||
enum1 enum2)))
|
||||
|
||||
(define (enum-set-union enum1 enum2)
|
||||
(check-2-enums/same 'enum-set-union enum1 enum2)
|
||||
(make-enum-set (bitwise-ior (enum-set-val enum1)
|
||||
(enum-set-val enum2))
|
||||
(enum-set-ht enum1)))
|
||||
|
||||
(define (enum-set-intersection enum1 enum2)
|
||||
(check-2-enums/same 'enum-set-intersection enum1 enum2)
|
||||
(make-enum-set (bitwise-and (enum-set-val enum1)
|
||||
(enum-set-val enum2))
|
||||
(enum-set-ht enum1)))
|
||||
|
||||
(define (enum-set-difference enum1 enum2)
|
||||
(check-2-enums/same 'enum-set-intersection enum1 enum2)
|
||||
(make-enum-set (- (enum-set-val enum1)
|
||||
(bitwise-and (enum-set-val enum1)
|
||||
(enum-set-val enum2)))
|
||||
(enum-set-ht enum1)))
|
||||
|
||||
(define (enum-set-complement enum1)
|
||||
(unless (enum-set? enum1)
|
||||
(raise-type-error 'enum-set-complement
|
||||
"enumeration set"
|
||||
enum1))
|
||||
(make-enum-set (bitwise-xor (sub1 (arithmetic-shift
|
||||
1
|
||||
(hash-table-count (enum-set-ht enum1))))
|
||||
(enum-set-val enum1))
|
||||
(enum-set-ht enum1)))
|
||||
|
||||
(define (enum-set-projection enum1 enum2)
|
||||
(check-2-enums 'enum-set-projection enum1 enum2)
|
||||
(let ([ht2 (enum-set-ht enum2)]
|
||||
[v1 (enum-set-val enum1)]
|
||||
[v2 (enum-set-val enum2)])
|
||||
(make-enum-set
|
||||
(for/fold ([val 0])
|
||||
([(key1 val1) (in-hash-table (enum-set-ht enum1))])
|
||||
(if (zero? (bitwise-and v1 val1))
|
||||
val
|
||||
(let ([val2 (hash-table-get ht2 key1 #f)])
|
||||
(if val2
|
||||
(bitwise-ior val val2)
|
||||
val))))
|
||||
ht2)))
|
||||
|
||||
(define-syntax (define-enumeration stx)
|
||||
(syntax-case stx ()
|
||||
[(_ type-name (sym ...) constructor)
|
||||
(let ([syms (syntax->list #'(sym ...))]
|
||||
[ht (make-hash-table)])
|
||||
(unless (identifier? #'type-name)
|
||||
(raise-syntax-error #f
|
||||
"not an identifier for type name"
|
||||
stx
|
||||
#'type-name))
|
||||
(for-each (lambda (sym)
|
||||
(unless (identifier? sym)
|
||||
(raise-syntax-error #f
|
||||
"not an identifier (to be used as a symbol)"
|
||||
stx
|
||||
sym)))
|
||||
syms)
|
||||
(unless (identifier? #'constructor)
|
||||
(raise-syntax-error #f
|
||||
"not an identifier for type name"
|
||||
stx
|
||||
#'constructor))
|
||||
(for ([s (in-list syms)])
|
||||
(unless (hash-table-get ht (syntax-e s) #f)
|
||||
(hash-table-put! ht (syntax-e s)
|
||||
(arithmetic-shift 1 (hash-table-count ht)))))
|
||||
(with-syntax ([(val ...)
|
||||
(map (lambda (s) (hash-table-get ht (syntax-e s))) syms)])
|
||||
#'(begin
|
||||
(define enum-universe (make-enumeration-universe (mlist 'sym ...)))
|
||||
(define-syntax (type-name stx)
|
||||
(syntax-case stx (sym ...)
|
||||
[(_ sym) #''sym]
|
||||
...
|
||||
[(_ other)
|
||||
(identifier? #'other)
|
||||
(raise-syntax-error #f "not in enumeration" stx #'other)]))
|
||||
(define-syntax (bit-value stx)
|
||||
(syntax-case stx (sym ...)
|
||||
[(_ orig sym) #'val]
|
||||
...
|
||||
[(_ orig s)
|
||||
(raise-syntax-error #f "not in enumeration" #'orig #'s)]))
|
||||
(...
|
||||
(define-syntax (constructor stx)
|
||||
(syntax-case stx ()
|
||||
[(_ s ...)
|
||||
(andmap identifier? (syntax->list #'(s ...)))
|
||||
(with-syntax ([orig stx])
|
||||
#'(make-enum-set (bitwise-ior (bit-value orig s) ...)
|
||||
enum-universe))]))))))]))
|
||||
|
|
@ -643,9 +643,10 @@
|
|||
#'orig-stx)]
|
||||
;; Guard case, no pending emits:
|
||||
[(_ [orig-stx nested? #f ()] ([fold-var fold-init] ...) (#:when expr . rest) . body)
|
||||
#'(if expr
|
||||
(for/foldX/derived [orig-stx nested? #f ()] ([fold-var fold-init] ...) rest . body)
|
||||
(values* fold-init ...))]
|
||||
#'(let ([fold-var fold-init] ...)
|
||||
(if expr
|
||||
(for/foldX/derived [orig-stx nested? #f ()] ([fold-var fold-var] ...) rest . body)
|
||||
(values* fold-var ...)))]
|
||||
;; Guard case, pending emits need to be flushed first
|
||||
[(frm [orig-stx nested? #f binds] ([fold-var fold-init] ...) (#:when expr . rest) . body)
|
||||
#'(frm [orig-stx nested? #t binds] ([fold-var fold-init] ...) (#:when expr . rest) . body)]
|
||||
|
|
|
|||
|
|
@ -25,71 +25,101 @@
|
|||
|
||||
compose)
|
||||
|
||||
(#%require (for-syntax "stxcase-scheme.ss"))
|
||||
|
||||
;; This is a destructive stable merge-sort, adapted from slib and improved by
|
||||
;; Eli Barzilay
|
||||
;; The original source said:
|
||||
;; It uses a version of merge-sort invented, to the best of my knowledge,
|
||||
;; by David H. D. Warren, and first used in the DEC-10 Prolog system.
|
||||
;; R. A. O'Keefe adapted it to work destructively in Scheme.
|
||||
;; but it's a plain destructive merge sort.
|
||||
(define (sort-internal lst less? n)
|
||||
(define (merge-sorted! a b)
|
||||
(define (loop r a b r-a?) ; r-a? for optimization -- is r connected to a?
|
||||
(if (less? (mcar b) (mcar a))
|
||||
(begin (when r-a? (set-mcdr! r b))
|
||||
(if (null? (mcdr b)) (set-mcdr! b a) (loop b a (mcdr b) #f)))
|
||||
;; (car a) <= (car b)
|
||||
(begin (unless r-a? (set-mcdr! r a))
|
||||
(if (null? (mcdr a)) (set-mcdr! a b) (loop a (mcdr a) b #t)))))
|
||||
(cond [(null? a) b]
|
||||
[(null? b) a]
|
||||
[(less? (mcar b) (mcar a))
|
||||
(if (null? (mcdr b)) (set-mcdr! b a) (loop b a (mcdr b) #f))
|
||||
b]
|
||||
[else ; (car a) <= (car b)
|
||||
(if (null? (mcdr a)) (set-mcdr! a b) (loop a (mcdr a) b #t))
|
||||
a]))
|
||||
(let step ([n n])
|
||||
(cond [(> n 3) (let* (; let* not really needed with mzscheme's l->r eval
|
||||
[j (quotient n 2)] [a (step j)] [b (step (- n j))])
|
||||
(merge-sorted! a b))]
|
||||
;; the following two cases are just explicit treatment of sublists
|
||||
;; of length 2 and 3, could remove both (and use the above case for
|
||||
;; n>1) and it would still work, except a little slower
|
||||
[(= n 3) (let ([p lst] [p1 (mcdr lst)] [p2 (mcdr (mcdr lst))])
|
||||
(let ([x (mcar p)] [y (mcar p1)] [z (mcar p2)])
|
||||
(set! lst (mcdr p2))
|
||||
(cond [(less? y x) ; y x
|
||||
(cond [(less? z y) ; z y x
|
||||
(set-mcar! p z)
|
||||
(set-mcar! p1 y)
|
||||
(set-mcar! p2 x)]
|
||||
[(less? z x) ; y z x
|
||||
(set-mcar! p y)
|
||||
(set-mcar! p1 z)
|
||||
(set-mcar! p2 x)]
|
||||
[else ; y x z
|
||||
(set-mcar! p y)
|
||||
(set-mcar! p1 x)])]
|
||||
[(less? z x) ; z x y
|
||||
(set-mcar! p z)
|
||||
(set-mcar! p1 x)
|
||||
(set-mcar! p2 y)]
|
||||
[(less? z y) ; x z y
|
||||
(set-mcar! p1 z)
|
||||
(set-mcar! p2 y)])
|
||||
(set-mcdr! p2 '())
|
||||
p))]
|
||||
[(= n 2) (let ([x (mcar lst)] [y (mcar (mcdr lst))] [p lst])
|
||||
(set! lst (mcdr (mcdr lst)))
|
||||
(when (less? y x) (set-mcar! p y) (set-mcar! (mcdr p) x))
|
||||
(set-mcdr! (mcdr p) '())
|
||||
p)]
|
||||
[(= n 1) (let ([p lst])
|
||||
(set! lst (mcdr lst))
|
||||
(set-mcdr! p '())
|
||||
p)]
|
||||
[else '()])))
|
||||
;; but it's a plain destructive merge sort, which I optimized further.
|
||||
(define sort-internal
|
||||
(let ()
|
||||
(define-syntax sort-internal-body
|
||||
(syntax-rules ()
|
||||
[(_ lst less? n)
|
||||
(begin
|
||||
(define (merge-sorted! a b)
|
||||
;; r-a? for optimization -- is r connected to a?
|
||||
(define (loop r a b r-a?)
|
||||
(if (less? (mcar b) (mcar a))
|
||||
(begin
|
||||
(when r-a? (set-mcdr! r b))
|
||||
(if (null? (mcdr b)) (set-mcdr! b a) (loop b a (mcdr b) #f)))
|
||||
;; (car a) <= (car b)
|
||||
(begin
|
||||
(unless r-a? (set-mcdr! r a))
|
||||
(if (null? (mcdr a)) (set-mcdr! a b) (loop a (mcdr a) b #t)))))
|
||||
(cond [(null? a) b]
|
||||
[(null? b) a]
|
||||
[(less? (mcar b) (mcar a))
|
||||
(if (null? (mcdr b)) (set-mcdr! b a) (loop b a (mcdr b) #f))
|
||||
b]
|
||||
[else ; (car a) <= (car b)
|
||||
(if (null? (mcdr a)) (set-mcdr! a b) (loop a (mcdr a) b #t))
|
||||
a]))
|
||||
(let step ([n n])
|
||||
(cond [(> n 3)
|
||||
(let* (; let* not really needed with mzscheme's l->r eval
|
||||
[j (quotient n 2)] [a (step j)] [b (step (- n j))])
|
||||
(merge-sorted! a b))]
|
||||
;; the following two cases are just explicit treatment of
|
||||
;; sublists of length 2 and 3, could remove both (and use the
|
||||
;; above case for n>1) and it would still work, except a
|
||||
;; little slower
|
||||
[(= n 3) (let ([p lst] [p1 (mcdr lst)] [p2 (mcdr (mcdr lst))])
|
||||
(let ([x (mcar p)] [y (mcar p1)] [z (mcar p2)])
|
||||
(set! lst (mcdr p2))
|
||||
(cond [(less? y x) ; y x
|
||||
(cond [(less? z y) ; z y x
|
||||
(set-mcar! p z)
|
||||
(set-mcar! p1 y)
|
||||
(set-mcar! p2 x)]
|
||||
[(less? z x) ; y z x
|
||||
(set-mcar! p y)
|
||||
(set-mcar! p1 z)
|
||||
(set-mcar! p2 x)]
|
||||
[else ; y x z
|
||||
(set-mcar! p y)
|
||||
(set-mcar! p1 x)])]
|
||||
[(less? z x) ; z x y
|
||||
(set-mcar! p z)
|
||||
(set-mcar! p1 x)
|
||||
(set-mcar! p2 y)]
|
||||
[(less? z y) ; x z y
|
||||
(set-mcar! p1 z)
|
||||
(set-mcar! p2 y)])
|
||||
(set-mcdr! p2 '())
|
||||
p))]
|
||||
[(= n 2) (let ([x (mcar lst)] [y (mcar (mcdr lst))] [p lst])
|
||||
(set! lst (mcdr (mcdr lst)))
|
||||
(when (less? y x)
|
||||
(set-mcar! p y)
|
||||
(set-mcar! (mcdr p) x))
|
||||
(set-mcdr! (mcdr p) '())
|
||||
p)]
|
||||
[(= n 1) (let ([p lst])
|
||||
(set! lst (mcdr lst))
|
||||
(set-mcdr! p '())
|
||||
p)]
|
||||
[else '()])))]))
|
||||
(define sort-internals (make-hash-table))
|
||||
(define-syntax make-precompiled-sort
|
||||
(syntax-rules ()
|
||||
[(_ less?) (hash-table-put! sort-internals less?
|
||||
(lambda (lst n) (sort-internal-body lst less? n)))]))
|
||||
(define ((sort-internal* less?) lst n)
|
||||
(sort-internal-body lst less? n))
|
||||
(make-precompiled-sort <)
|
||||
(make-precompiled-sort string<?)
|
||||
(make-precompiled-sort string-ci<?)
|
||||
(make-precompiled-sort keyword<?)
|
||||
(lambda (less? lst n)
|
||||
((or (hash-table-get sort-internals less? #f)
|
||||
(sort-internal* less?))
|
||||
lst n))))
|
||||
|
||||
(define (sort lst less?)
|
||||
(unless (list? lst)
|
||||
(raise-type-error 'sort "proper list" lst))
|
||||
|
|
@ -140,7 +170,7 @@
|
|||
(set-mcdr! last new)
|
||||
(loop new (cdr lst))))))])
|
||||
;; mlist->list
|
||||
(let loop ([r (sort-internal mlst less? n)])
|
||||
(let loop ([r (sort-internal less? mlst n)])
|
||||
(if (null? r)
|
||||
r
|
||||
(cons (mcar r) (loop (mcdr r))))))])))
|
||||
|
|
|
|||
|
|
@ -1,128 +1,130 @@
|
|||
#lang scheme/base
|
||||
(module promise '#%kernel
|
||||
|
||||
;;
|
||||
;; This module implements "lazy promises" and a `force' that is iterated
|
||||
;; through them.
|
||||
;; This is similar to the *new* version of srfi-45 -- see the post-finalization
|
||||
;; discussion at http://srfi.schemers.org/srfi-45/ for more details;
|
||||
;; specifically, this version is the `lazy2' version from
|
||||
;; http://srfi.schemers.org/srfi-45/post-mail-archive/msg00013.html and (a
|
||||
;; `lazy3' variant of `force' that deals with multiple values is included and
|
||||
;; commented). Note: if you use only `force'+`delay' it behaves as in Scheme
|
||||
;; (except that `force' is identity for non promise values), and `force'+`lazy'
|
||||
;; are sufficient for implementing the lazy language.
|
||||
|
||||
;; This module implements "lazy promises" and a `force' that is iterated
|
||||
;; through them.
|
||||
;; This is similar to the *new* version of srfi-45 -- see the post-finalization
|
||||
;; discussion at http://srfi.schemers.org/srfi-45/ for more details;
|
||||
;; specifically, this version is the `lazy2' version from
|
||||
;; http://srfi.schemers.org/srfi-45/post-mail-archive/msg00013.html and (a
|
||||
;; `lazy3' variant of `force' that deals with multiple values is included and
|
||||
;; commented). Note: if you use only `force'+`delay' it behaves as in Scheme
|
||||
;; (except that `force' is identity for non promise values), and `force'+`lazy'
|
||||
;; are sufficient for implementing the lazy language.
|
||||
(#%require "private/more-scheme.ss" "private/small-scheme.ss"
|
||||
"private/define.ss"
|
||||
(rename "private/define-struct.ss" define-struct define-struct*)
|
||||
(for-syntax '#%kernel
|
||||
"private/stxcase-scheme.ss" "private/small-scheme.ss"))
|
||||
|
||||
(require (for-syntax scheme/base))
|
||||
(#%provide lazy delay force promise?)
|
||||
|
||||
(provide lazy delay force promise?)
|
||||
(define running
|
||||
(lambda () (error 'force "reentrant promise")))
|
||||
|
||||
(define running
|
||||
(lambda () (error 'force "reentrant promise")))
|
||||
|
||||
(define (promise-printer promise port write?)
|
||||
(let loop ([p (promise-val promise)])
|
||||
(cond
|
||||
[(procedure? p)
|
||||
(cond [(object-name p)
|
||||
=> (lambda (n) (fprintf port "#<promise:~a>" n))]
|
||||
[else (display "#<promise>" port)])]
|
||||
;; no values
|
||||
[(null? p) (fprintf port "#<promise!(values)>")]
|
||||
[(pair? p)
|
||||
;; single or multiple values
|
||||
(fprintf port
|
||||
(if write? "#<promise!~a~s" "#<promise!~a~a")
|
||||
(if (null? (cdr p)) "" "(values ")
|
||||
(car p))
|
||||
(when (pair? (cdr p))
|
||||
(let ([fmt (if write? " ~s" " ~a")])
|
||||
(for-each (lambda (x) (fprintf port fmt x)) (cdr p))))
|
||||
(unless (null? (cdr p)) (display ")" port))
|
||||
(display ">" port)]
|
||||
[(promise? p) (loop (promise-val p))] ; hide sharing
|
||||
[else (loop (list p))])))
|
||||
|
||||
(define-struct promise (val)
|
||||
#:mutable
|
||||
#:property prop:custom-write promise-printer)
|
||||
|
||||
;; <promise> ::=
|
||||
;; | (promise <thunk>) delayed promise, maybe currently running, maybe an exn promise
|
||||
;; | (promise (list <object>)) forced promise (possibly multi-valued)
|
||||
;; | (promise <promise>) shared promise
|
||||
;; | (promise <object>) forced promise, since values
|
||||
|
||||
;; Creates a `composable' promise
|
||||
;; X = (force (lazy X)) = (force (lazy (lazy X))) = (force (lazy^n X))
|
||||
(define-syntax (lazy stx)
|
||||
(syntax-case stx ()
|
||||
[(lazy expr) (with-syntax ([proc (syntax-property
|
||||
(syntax/loc stx (lambda () expr))
|
||||
'inferred-name (syntax-local-name))])
|
||||
(syntax/loc stx (make-promise proc)))]))
|
||||
|
||||
;; Creates a promise that does not compose
|
||||
;; X = (force (delay X)) = (force (lazy (delay X)))
|
||||
;; = (force (lazy^n (delay X)))
|
||||
;; X = (force (force (delay (delay X)))) =/= (force (delay (delay X)))
|
||||
;; so each sequence of `(lazy^n o delay)^m' requires m `force's and a
|
||||
;; sequence of `(lazy^n o delay)^m o lazy^k' requires m+1 `force's (for k>0)
|
||||
;; (This is not needed with a lazy language (see the above URL for details),
|
||||
;; but provided for completeness.)
|
||||
(define-syntax (delay stx)
|
||||
(syntax-case stx ()
|
||||
[(delay expr)
|
||||
(with-syntax ([proc (syntax-property
|
||||
(syntax/loc stx (lambda () expr))
|
||||
'inferred-name (syntax-local-name))])
|
||||
(syntax/loc stx
|
||||
(lazy (make-promise (call-with-values proc list)))))]))
|
||||
|
||||
;; force iterates on lazy promises (forbid dependency cycles)
|
||||
;; * (force X) = X for non promises
|
||||
;; * does not deal with multiple values, since they're not used by the lazy
|
||||
;; language (but see below)
|
||||
|
||||
(define handle-results
|
||||
(case-lambda
|
||||
[(single) (values #f single)]
|
||||
[multi (values #t multi)]))
|
||||
|
||||
(define (force-proc p root)
|
||||
(define (return-vals vals)
|
||||
;; error here for "library approach" (see above URL)
|
||||
(set-promise-val! root vals)
|
||||
(apply values vals))
|
||||
(let loop1 ([p p])
|
||||
(let-values ([(multi? v) (call-with-values p handle-results)])
|
||||
(if multi?
|
||||
(return-vals v)
|
||||
(if (promise? v)
|
||||
(let loop2 ([promise* v])
|
||||
(let ([p* (promise-val promise*)])
|
||||
(set-promise-val! promise* root) ; share with root
|
||||
(cond [(procedure? p*) (loop1 p*)]
|
||||
[(or (pair? p*) (null? p*)) (return-vals p*)]
|
||||
[(promise? p*) (loop2 p*)]
|
||||
[else p*])))
|
||||
(return-vals
|
||||
(if (or (null? v) (pair? v) (procedure? v)) (list v) v)))))))
|
||||
|
||||
(define (force promise)
|
||||
(if (promise? promise)
|
||||
(define (promise-printer promise port write?)
|
||||
(let loop ([p (promise-val promise)])
|
||||
(cond
|
||||
[(procedure? p)
|
||||
;; mark root for cycle detection:
|
||||
(set-promise-val! promise running)
|
||||
(with-handlers*
|
||||
([void (lambda (e)
|
||||
(set-promise-val! promise (lambda () (raise e)))
|
||||
(raise e))])
|
||||
(force-proc p promise))]
|
||||
[(or (pair? p) (null? p)) (apply values p)]
|
||||
[(promise? p) (loop (promise-val p))]
|
||||
[else p]))
|
||||
;; different from srfi-45: identity for non-promises
|
||||
promise))
|
||||
[(procedure? p)
|
||||
(cond [(object-name p)
|
||||
=> (lambda (n) (fprintf port "#<promise:~a>" n))]
|
||||
[else (display "#<promise>" port)])]
|
||||
;; no values
|
||||
[(null? p) (fprintf port "#<promise!(values)>")]
|
||||
[(pair? p)
|
||||
;; single or multiple values
|
||||
(fprintf port
|
||||
(if write? "#<promise!~a~s" "#<promise!~a~a")
|
||||
(if (null? (cdr p)) "" "(values ")
|
||||
(car p))
|
||||
(when (pair? (cdr p))
|
||||
(let ([fmt (if write? " ~s" " ~a")])
|
||||
(for-each (lambda (x) (fprintf port fmt x)) (cdr p))))
|
||||
(unless (null? (cdr p)) (display ")" port))
|
||||
(display ">" port)]
|
||||
[(promise? p) (loop (promise-val p))] ; hide sharing
|
||||
[else (loop (list p))])))
|
||||
|
||||
(define-struct promise (val)
|
||||
#:mutable
|
||||
#:property prop:custom-write promise-printer)
|
||||
|
||||
;; <promise> ::=
|
||||
;; | (promise <thunk>) delayed promise, maybe currently running, maybe an exn promise
|
||||
;; | (promise (list <object>)) forced promise (possibly multi-valued)
|
||||
;; | (promise <promise>) shared promise
|
||||
;; | (promise <object>) forced promise, since values
|
||||
|
||||
;; Creates a `composable' promise
|
||||
;; X = (force (lazy X)) = (force (lazy (lazy X))) = (force (lazy^n X))
|
||||
(define-syntax (lazy stx)
|
||||
(syntax-case stx ()
|
||||
[(lazy expr) (with-syntax ([proc (syntax-property
|
||||
(syntax/loc stx (lambda () expr))
|
||||
'inferred-name (syntax-local-name))])
|
||||
(syntax/loc stx (make-promise proc)))]))
|
||||
|
||||
;; Creates a promise that does not compose
|
||||
;; X = (force (delay X)) = (force (lazy (delay X)))
|
||||
;; = (force (lazy^n (delay X)))
|
||||
;; X = (force (force (delay (delay X)))) =/= (force (delay (delay X)))
|
||||
;; so each sequence of `(lazy^n o delay)^m' requires m `force's and a
|
||||
;; sequence of `(lazy^n o delay)^m o lazy^k' requires m+1 `force's (for k>0)
|
||||
;; (This is not needed with a lazy language (see the above URL for details),
|
||||
;; but provided for completeness.)
|
||||
(define-syntax (delay stx)
|
||||
(syntax-case stx ()
|
||||
[(delay expr)
|
||||
(with-syntax ([proc (syntax-property
|
||||
(syntax/loc stx (lambda () expr))
|
||||
'inferred-name (syntax-local-name))])
|
||||
(syntax/loc stx
|
||||
(lazy (make-promise (call-with-values proc list)))))]))
|
||||
|
||||
;; force iterates on lazy promises (forbid dependency cycles)
|
||||
;; * (force X) = X for non promises
|
||||
;; * does not deal with multiple values, since they're not used by the lazy
|
||||
;; language (but see below)
|
||||
|
||||
(define handle-results
|
||||
(case-lambda
|
||||
[(single) (values #f single)]
|
||||
[multi (values #t multi)]))
|
||||
|
||||
(define (force-proc p root)
|
||||
(define (return-vals vals)
|
||||
;; error here for "library approach" (see above URL)
|
||||
(set-promise-val! root vals)
|
||||
(apply values vals))
|
||||
(let loop1 ([p p])
|
||||
(let-values ([(multi? v) (call-with-values p handle-results)])
|
||||
(if multi?
|
||||
(return-vals v)
|
||||
(if (promise? v)
|
||||
(let loop2 ([promise* v])
|
||||
(let ([p* (promise-val promise*)])
|
||||
(set-promise-val! promise* root) ; share with root
|
||||
(cond [(procedure? p*) (loop1 p*)]
|
||||
[(or (pair? p*) (null? p*)) (return-vals p*)]
|
||||
[(promise? p*) (loop2 p*)]
|
||||
[else p*])))
|
||||
(return-vals
|
||||
(if (or (null? v) (pair? v) (procedure? v)) (list v) v)))))))
|
||||
|
||||
(define (force promise)
|
||||
(if (promise? promise)
|
||||
(let loop ([p (promise-val promise)])
|
||||
(cond
|
||||
[(procedure? p)
|
||||
;; mark root for cycle detection:
|
||||
(set-promise-val! promise running)
|
||||
(with-handlers*
|
||||
([void (lambda (e)
|
||||
(set-promise-val! promise (lambda () (raise e)))
|
||||
(raise e))])
|
||||
(force-proc p promise))]
|
||||
[(or (pair? p) (null? p)) (apply values p)]
|
||||
[(promise? p) (loop (promise-val p))]
|
||||
[else p]))
|
||||
;; different from srfi-45: identity for non-promises
|
||||
promise)))
|
||||
|
|
|
|||
|
|
@ -708,17 +708,20 @@ padded with trailing zeros if necessary).
|
|||
|
||||
@defproc[(integer-bytes->integer [bstr bytes?]
|
||||
[signed? any/c]
|
||||
[big-endian? any/c (system-big-endian?)])
|
||||
[big-endian? any/c (system-big-endian?)]
|
||||
[start exact-nonnegative-integer? 0]
|
||||
[end exact-nonnegative-integer? (bytes-length bstr)])
|
||||
exact-integer?]{
|
||||
|
||||
Converts the machine-format number encoded in @scheme[bstr] to an
|
||||
exact integer. The @scheme[bstr] must contain either 2, 4, or 8
|
||||
bytes. If @scheme[signed?] is true, then the bytes are decoded as a
|
||||
two's-complement number, otherwise it is decoded as an unsigned
|
||||
integer. If @scheme[big-endian?] is true, then the first character's
|
||||
ASCII value provides the most significant eight bits of the number,
|
||||
otherwise the first character provides the least-significant eight
|
||||
bits, and so on..}
|
||||
exact integer. The @scheme[start] and @scheme[end] arguments specify
|
||||
the substring to decode, where @scheme[(- end start)] must be
|
||||
@scheme[2], @scheme[4], or @scheme[8]. If @scheme[signed?] is true,
|
||||
then the bytes are decoded as a two's-complement number, otherwise it
|
||||
is decoded as an unsigned integer. If @scheme[big-endian?] is true,
|
||||
then the first character's ASCII value provides the most significant
|
||||
eight bits of the number, otherwise the first character provides the
|
||||
least-significant eight bits, and so on.}
|
||||
|
||||
|
||||
@defproc[(integer->integer-bytes [n exact-integer?]
|
||||
|
|
@ -727,21 +730,23 @@ bits, and so on..}
|
|||
[big-endian? any/c (system-big-endian?)]
|
||||
[dest-bstr (and/c bytes?
|
||||
(not/c immutable?))
|
||||
(make-bytes size-n)])
|
||||
(make-bytes size-n)]
|
||||
[start exact-nonnegative-integer? 0])
|
||||
bytes?]{
|
||||
|
||||
Converts the exact integer @scheme[n] to a machine-format number
|
||||
encoded in a byte string of length @scheme[size-n], which must be 2,
|
||||
4, or 8. If @scheme[signed?] is true, then the number is encoded as
|
||||
two's complement, otherwise it is encoded as an unsigned bit
|
||||
stream. If @scheme[big-endian?] is true, then the most significant
|
||||
eight bits of the number are encoded in the first character of the
|
||||
resulting byte string, otherwise the least-significant bits are
|
||||
encoded in the first byte, and so on.
|
||||
encoded in a byte string of length @scheme[size-n], which must be
|
||||
@scheme[2], @scheme[4], or @scheme[8]. If @scheme[signed?] is true,
|
||||
then the number is encoded as two's complement, otherwise it is
|
||||
encoded as an unsigned bit stream. If @scheme[big-endian?] is true,
|
||||
then the most significant eight bits of the number are encoded in the
|
||||
first character of the resulting byte string, otherwise the
|
||||
least-significant bits are encoded in the first byte, and so on.
|
||||
|
||||
The @scheme[dest-bstr] argument must be a mutable byte string of
|
||||
length @scheme[size-n]. The encoding of @scheme[n] is written into
|
||||
@scheme[dest-bstr], and @scheme[dest-bstr] is returned as the result.
|
||||
@scheme[dest-bstr] starting at offset @scheme[start], and
|
||||
@scheme[dest-bstr] is returned as the result.
|
||||
|
||||
If @scheme[n] cannot be encoded in a string of the requested size and
|
||||
format, the @exnraise[exn:fail:contract]. If @scheme[dest-bstr] is not
|
||||
|
|
|
|||
|
|
@ -2360,128 +2360,153 @@
|
|||
|
||||
(test (integer-bytes->integer #"\1\2" #f) integer-bytes->integer #"\1\2" #f (system-big-endian?))
|
||||
|
||||
(test 0 integer-bytes->integer #"\0\0" #t)
|
||||
(test -1 integer-bytes->integer #"\377\377" #t)
|
||||
(test 65535 integer-bytes->integer #"\377\377" #f)
|
||||
;;
|
||||
(test 0 integer-bytes->integer #"\0\0" #t #t)
|
||||
(test -1 integer-bytes->integer #"\377\377" #t #t)
|
||||
(test 65535 integer-bytes->integer #"\377\377" #f #t)
|
||||
(test -256 integer-bytes->integer #"\377\0" #t #t)
|
||||
(test -255 integer-bytes->integer #"\377\1" #t #t)
|
||||
(test 511 integer-bytes->integer #"\1\377" #t #t)
|
||||
(test 513 integer-bytes->integer #"\1\2" #f #f)
|
||||
;;
|
||||
(test 0 integer-bytes->integer #"\0\0" #t #f)
|
||||
(test -1 integer-bytes->integer #"\377\377" #t #f)
|
||||
(test 65535 integer-bytes->integer #"\377\377" #f #f)
|
||||
(test 511 integer-bytes->integer #"\377\1" #t #f)
|
||||
(test -255 integer-bytes->integer #"\1\377" #t #f)
|
||||
(test 258 integer-bytes->integer #"\1\2" #f #t)
|
||||
(define (test-integer-bytes->integer integer-bytes->integer)
|
||||
(test 0 integer-bytes->integer #"\0\0" #t)
|
||||
(test -1 integer-bytes->integer #"\377\377" #t)
|
||||
(test 65535 integer-bytes->integer #"\377\377" #f)
|
||||
;;
|
||||
(test 0 integer-bytes->integer #"\0\0" #t #t)
|
||||
(test -1 integer-bytes->integer #"\377\377" #t #t)
|
||||
(test 65535 integer-bytes->integer #"\377\377" #f #t)
|
||||
(test -256 integer-bytes->integer #"\377\0" #t #t)
|
||||
(test -255 integer-bytes->integer #"\377\1" #t #t)
|
||||
(test 511 integer-bytes->integer #"\1\377" #t #t)
|
||||
(test 513 integer-bytes->integer #"\1\2" #f #f)
|
||||
;;
|
||||
(test 0 integer-bytes->integer #"\0\0" #t #f)
|
||||
(test -1 integer-bytes->integer #"\377\377" #t #f)
|
||||
(test 65535 integer-bytes->integer #"\377\377" #f #f)
|
||||
(test 511 integer-bytes->integer #"\377\1" #t #f)
|
||||
(test -255 integer-bytes->integer #"\1\377" #t #f)
|
||||
(test 258 integer-bytes->integer #"\1\2" #f #t)
|
||||
|
||||
(test 0 integer-bytes->integer #"\0\0\0\0" #t)
|
||||
(test -1 integer-bytes->integer #"\377\377\377\377" #t)
|
||||
(test 4294967295 integer-bytes->integer #"\377\377\377\377" #f)
|
||||
;;
|
||||
(test 0 integer-bytes->integer #"\0\0\0\0" #t #t)
|
||||
(test -1 integer-bytes->integer #"\377\377\377\377" #t #t)
|
||||
(test 4294967295 integer-bytes->integer #"\377\377\377\377" #f #t)
|
||||
(test -16777216 integer-bytes->integer #"\377\0\0\0" #t #t)
|
||||
(test 255 integer-bytes->integer #"\0\0\0\377" #t #t)
|
||||
;;
|
||||
(test 0 integer-bytes->integer #"\0\0\0\0" #t #f)
|
||||
(test -1 integer-bytes->integer #"\377\377\377\377" #t #f)
|
||||
(test 4294967295 integer-bytes->integer #"\377\377\377\377" #f #f)
|
||||
(test 16777471 integer-bytes->integer #"\377\0\0\1" #t #f)
|
||||
(test -16777216 integer-bytes->integer #"\0\0\0\377" #t #f)
|
||||
(test -16777215 integer-bytes->integer #"\1\0\0\377" #t #f)
|
||||
(test 0 integer-bytes->integer #"\0\0\0\0" #t)
|
||||
(test -1 integer-bytes->integer #"\377\377\377\377" #t)
|
||||
(test 4294967295 integer-bytes->integer #"\377\377\377\377" #f)
|
||||
;;
|
||||
(test 0 integer-bytes->integer #"\0\0\0\0" #t #t)
|
||||
(test -1 integer-bytes->integer #"\377\377\377\377" #t #t)
|
||||
(test 4294967295 integer-bytes->integer #"\377\377\377\377" #f #t)
|
||||
(test -16777216 integer-bytes->integer #"\377\0\0\0" #t #t)
|
||||
(test 255 integer-bytes->integer #"\0\0\0\377" #t #t)
|
||||
;;
|
||||
(test 0 integer-bytes->integer #"\0\0\0\0" #t #f)
|
||||
(test -1 integer-bytes->integer #"\377\377\377\377" #t #f)
|
||||
(test 4294967295 integer-bytes->integer #"\377\377\377\377" #f #f)
|
||||
(test 16777471 integer-bytes->integer #"\377\0\0\1" #t #f)
|
||||
(test -16777216 integer-bytes->integer #"\0\0\0\377" #t #f)
|
||||
(test -16777215 integer-bytes->integer #"\1\0\0\377" #t #f)
|
||||
|
||||
(test 1835103348 integer-bytes->integer #"matt" #t #t)
|
||||
(test 1953784173 integer-bytes->integer #"matt" #t #f)
|
||||
(test 1835103348 integer-bytes->integer #"matt" #t #t)
|
||||
(test 1953784173 integer-bytes->integer #"matt" #t #f)
|
||||
|
||||
(test 0 integer-bytes->integer #"\0\0\0\0\0\0\0\0" #t #t)
|
||||
(test -1 integer-bytes->integer #"\377\377\377\377\377\377\377\377" #t #f)
|
||||
(test 18446744073709551615 integer-bytes->integer #"\377\377\377\377\377\377\377\377" #f #f)
|
||||
(test 4294967295 integer-bytes->integer #"\377\377\377\377\0\0\0\0" #t #f)
|
||||
(test -4294967296 integer-bytes->integer #"\0\0\0\0\377\377\377\377" #t #f)
|
||||
(test 8589934591 integer-bytes->integer #"\377\377\377\377\1\0\0\0" #t #f)
|
||||
(test -4294967295 integer-bytes->integer #"\1\0\0\0\377\377\377\377" #t #f)
|
||||
;;
|
||||
(test 0 integer-bytes->integer #"\0\0\0\0\0\0\0\0" #t #f)
|
||||
(test -1 integer-bytes->integer #"\377\377\377\377\377\377\377\377" #t #f)
|
||||
(test 18446744073709551615 integer-bytes->integer #"\377\377\377\377\377\377\377\377" #f #f)
|
||||
(test -4294967296 integer-bytes->integer #"\377\377\377\377\0\0\0\0" #t #t)
|
||||
(test 4294967295 integer-bytes->integer #"\0\0\0\0\377\377\377\377" #t #t)
|
||||
(test -4294967295 integer-bytes->integer #"\377\377\377\377\0\0\0\1" #t #t)
|
||||
(test 8589934591 integer-bytes->integer #"\0\0\0\1\377\377\377\377" #t #t)
|
||||
(test 0 integer-bytes->integer #"\0\0\0\0\0\0\0\0" #t #t)
|
||||
(test -1 integer-bytes->integer #"\377\377\377\377\377\377\377\377" #t #f)
|
||||
(test 18446744073709551615 integer-bytes->integer #"\377\377\377\377\377\377\377\377" #f #f)
|
||||
(test 4294967295 integer-bytes->integer #"\377\377\377\377\0\0\0\0" #t #f)
|
||||
(test -4294967296 integer-bytes->integer #"\0\0\0\0\377\377\377\377" #t #f)
|
||||
(test 8589934591 integer-bytes->integer #"\377\377\377\377\1\0\0\0" #t #f)
|
||||
(test -4294967295 integer-bytes->integer #"\1\0\0\0\377\377\377\377" #t #f)
|
||||
;;
|
||||
(test 0 integer-bytes->integer #"\0\0\0\0\0\0\0\0" #t #f)
|
||||
(test -1 integer-bytes->integer #"\377\377\377\377\377\377\377\377" #t #f)
|
||||
(test 18446744073709551615 integer-bytes->integer #"\377\377\377\377\377\377\377\377" #f #f)
|
||||
(test -4294967296 integer-bytes->integer #"\377\377\377\377\0\0\0\0" #t #t)
|
||||
(test 4294967295 integer-bytes->integer #"\0\0\0\0\377\377\377\377" #t #t)
|
||||
(test -4294967295 integer-bytes->integer #"\377\377\377\377\0\0\0\1" #t #t)
|
||||
(test 8589934591 integer-bytes->integer #"\0\0\0\1\377\377\377\377" #t #t))
|
||||
|
||||
(arity-test integer-bytes->integer 2 3)
|
||||
(test-integer-bytes->integer integer-bytes->integer)
|
||||
(test-integer-bytes->integer (lambda (bstr signed? [big-endian? (system-big-endian?)])
|
||||
(integer-bytes->integer (bytes-append #"xxx" bstr)
|
||||
signed?
|
||||
big-endian?
|
||||
3)))
|
||||
(test-integer-bytes->integer (lambda (bstr signed? [big-endian? (system-big-endian?)])
|
||||
(integer-bytes->integer (bytes-append #"xxx" bstr #"x")
|
||||
signed?
|
||||
big-endian?
|
||||
3
|
||||
(+ 3 (bytes-length bstr)))))
|
||||
|
||||
(arity-test integer-bytes->integer 2 5)
|
||||
(err/rt-test (integer-bytes->integer 'ok #t))
|
||||
(err/rt-test (integer-bytes->integer #"" #t))
|
||||
(err/rt-test (integer-bytes->integer #"a" #t))
|
||||
(err/rt-test (integer-bytes->integer #"abc" #t))
|
||||
(err/rt-test (integer-bytes->integer #"abcdefghi" #t))
|
||||
(err/rt-test (integer-bytes->integer #"abcdefghi" #t #f 0 3))
|
||||
(err/rt-test (integer-bytes->integer #"abcd" #t #f 1))
|
||||
|
||||
;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
||||
|
||||
(test (integer->integer-bytes 42 2 #f) integer->integer-bytes 42 2 #f (system-big-endian?))
|
||||
|
||||
(test #"\0\0" integer->integer-bytes 0 2 #t)
|
||||
(test #"\377\377" integer->integer-bytes -1 2 #t)
|
||||
(test #"\377\377" integer->integer-bytes 65535 2 #f)
|
||||
;;
|
||||
(test #"\0\0" integer->integer-bytes 0 2 #t #t)
|
||||
(test #"\377\377" integer->integer-bytes -1 2 #t #t)
|
||||
(test #"\377\377" integer->integer-bytes 65535 2 #f #t)
|
||||
(test #"\377\0" integer->integer-bytes -256 2 #t #t)
|
||||
(test #"\377\1" integer->integer-bytes -255 2 #t #t)
|
||||
(test #"\1\377" integer->integer-bytes 511 2 #t #t)
|
||||
(test #"\1\2" integer->integer-bytes 513 2 #f #f)
|
||||
;;
|
||||
(test #"\0\0" integer->integer-bytes 0 2 #t #f)
|
||||
(test #"\377\377" integer->integer-bytes -1 2 #t #f)
|
||||
(test #"\377\377" integer->integer-bytes 65535 2 #f #f)
|
||||
(test #"\377\1" integer->integer-bytes 511 2 #t #f)
|
||||
(test #"\1\377" integer->integer-bytes -255 2 #t #f)
|
||||
(test #"\1\2" integer->integer-bytes 258 2 #f #t)
|
||||
(define (test-integer->integer-bytes integer->integer-bytes)
|
||||
(test #"\0\0" integer->integer-bytes 0 2 #t)
|
||||
(test #"\377\377" integer->integer-bytes -1 2 #t)
|
||||
(test #"\377\377" integer->integer-bytes 65535 2 #f)
|
||||
;;
|
||||
(test #"\0\0" integer->integer-bytes 0 2 #t #t)
|
||||
(test #"\377\377" integer->integer-bytes -1 2 #t #t)
|
||||
(test #"\377\377" integer->integer-bytes 65535 2 #f #t)
|
||||
(test #"\377\0" integer->integer-bytes -256 2 #t #t)
|
||||
(test #"\377\1" integer->integer-bytes -255 2 #t #t)
|
||||
(test #"\1\377" integer->integer-bytes 511 2 #t #t)
|
||||
(test #"\1\2" integer->integer-bytes 513 2 #f #f)
|
||||
;;
|
||||
(test #"\0\0" integer->integer-bytes 0 2 #t #f)
|
||||
(test #"\377\377" integer->integer-bytes -1 2 #t #f)
|
||||
(test #"\377\377" integer->integer-bytes 65535 2 #f #f)
|
||||
(test #"\377\1" integer->integer-bytes 511 2 #t #f)
|
||||
(test #"\1\377" integer->integer-bytes -255 2 #t #f)
|
||||
(test #"\1\2" integer->integer-bytes 258 2 #f #t)
|
||||
|
||||
(test #"\0\0\0\0" integer->integer-bytes 0 4 #t)
|
||||
(test #"\377\377\377\377" integer->integer-bytes -1 4 #t)
|
||||
(test #"\377\377\377\377" integer->integer-bytes 4294967295 4 #f)
|
||||
;;
|
||||
(test #"\0\0\0\0" integer->integer-bytes 0 4 #t #t)
|
||||
(test #"\377\377\377\377" integer->integer-bytes -1 4 #t #t)
|
||||
(test #"\377\377\377\377" integer->integer-bytes 4294967295 4 #f #t)
|
||||
(test #"\377\0\0\0" integer->integer-bytes -16777216 4 #t #t)
|
||||
(test #"\0\0\0\377" integer->integer-bytes 255 4 #t #t)
|
||||
;;
|
||||
(test #"\0\0\0\0" integer->integer-bytes 0 4 #t #f)
|
||||
(test #"\377\377\377\377" integer->integer-bytes -1 4 #t #f)
|
||||
(test #"\377\377\377\377" integer->integer-bytes 4294967295 4 #f #f)
|
||||
(test #"\377\0\0\1" integer->integer-bytes 16777471 4 #t #f)
|
||||
(test #"\0\0\0\377" integer->integer-bytes -16777216 4 #t #f)
|
||||
(test #"\1\0\0\377" integer->integer-bytes -16777215 4 #t #f)
|
||||
(test #"\0\0\0\0" integer->integer-bytes 0 4 #t)
|
||||
(test #"\377\377\377\377" integer->integer-bytes -1 4 #t)
|
||||
(test #"\377\377\377\377" integer->integer-bytes 4294967295 4 #f)
|
||||
;;
|
||||
(test #"\0\0\0\0" integer->integer-bytes 0 4 #t #t)
|
||||
(test #"\377\377\377\377" integer->integer-bytes -1 4 #t #t)
|
||||
(test #"\377\377\377\377" integer->integer-bytes 4294967295 4 #f #t)
|
||||
(test #"\377\0\0\0" integer->integer-bytes -16777216 4 #t #t)
|
||||
(test #"\0\0\0\377" integer->integer-bytes 255 4 #t #t)
|
||||
;;
|
||||
(test #"\0\0\0\0" integer->integer-bytes 0 4 #t #f)
|
||||
(test #"\377\377\377\377" integer->integer-bytes -1 4 #t #f)
|
||||
(test #"\377\377\377\377" integer->integer-bytes 4294967295 4 #f #f)
|
||||
(test #"\377\0\0\1" integer->integer-bytes 16777471 4 #t #f)
|
||||
(test #"\0\0\0\377" integer->integer-bytes -16777216 4 #t #f)
|
||||
(test #"\1\0\0\377" integer->integer-bytes -16777215 4 #t #f)
|
||||
|
||||
(test #"matt" integer->integer-bytes 1835103348 4 #t #t)
|
||||
(test #"matt" integer->integer-bytes 1953784173 4 #t #f)
|
||||
(test #"matt" integer->integer-bytes 1835103348 4 #t #t)
|
||||
(test #"matt" integer->integer-bytes 1953784173 4 #t #f)
|
||||
|
||||
(test #"\0\0\0\0\0\0\0\0" integer->integer-bytes 0 8 #t #t)
|
||||
(test #"\377\377\377\377\377\377\377\377" integer->integer-bytes -1 8 #t #f)
|
||||
(test #"\377\377\377\377\377\377\377\377" integer->integer-bytes 18446744073709551615 8 #f #f)
|
||||
(test #"\377\377\377\377\0\0\0\0" integer->integer-bytes 4294967295 8 #t #f)
|
||||
(test #"\0\0\0\0\377\377\377\377" integer->integer-bytes -4294967296 8 #t #f)
|
||||
(test #"\377\377\377\377\1\0\0\0" integer->integer-bytes 8589934591 8 #t #f)
|
||||
(test #"\1\0\0\0\377\377\377\377" integer->integer-bytes -4294967295 8 #t #f)
|
||||
;;
|
||||
(test #"\0\0\0\0\0\0\0\0" integer->integer-bytes 0 8 #t #f)
|
||||
(test #"\377\377\377\377\377\377\377\377" integer->integer-bytes -1 8 #t #f)
|
||||
(test #"\377\377\377\377\377\377\377\377" integer->integer-bytes 18446744073709551615 8 #f #f)
|
||||
(test #"\377\377\377\377\0\0\0\0" integer->integer-bytes -4294967296 8 #t #t)
|
||||
(test #"\0\0\0\0\377\377\377\377" integer->integer-bytes 4294967295 8 #t #t)
|
||||
(test #"\377\377\377\377\0\0\0\1" integer->integer-bytes -4294967295 8 #t #t)
|
||||
(test #"\0\0\0\1\377\377\377\377" integer->integer-bytes 8589934591 8 #t #t)
|
||||
(test #"\0\0\0\0\0\0\0\0" integer->integer-bytes 0 8 #t #t)
|
||||
(test #"\377\377\377\377\377\377\377\377" integer->integer-bytes -1 8 #t #f)
|
||||
(test #"\377\377\377\377\377\377\377\377" integer->integer-bytes 18446744073709551615 8 #f #f)
|
||||
(test #"\377\377\377\377\0\0\0\0" integer->integer-bytes 4294967295 8 #t #f)
|
||||
(test #"\0\0\0\0\377\377\377\377" integer->integer-bytes -4294967296 8 #t #f)
|
||||
(test #"\377\377\377\377\1\0\0\0" integer->integer-bytes 8589934591 8 #t #f)
|
||||
(test #"\1\0\0\0\377\377\377\377" integer->integer-bytes -4294967295 8 #t #f)
|
||||
;;
|
||||
(test #"\0\0\0\0\0\0\0\0" integer->integer-bytes 0 8 #t #f)
|
||||
(test #"\377\377\377\377\377\377\377\377" integer->integer-bytes -1 8 #t #f)
|
||||
(test #"\377\377\377\377\377\377\377\377" integer->integer-bytes 18446744073709551615 8 #f #f)
|
||||
(test #"\377\377\377\377\0\0\0\0" integer->integer-bytes -4294967296 8 #t #t)
|
||||
(test #"\0\0\0\0\377\377\377\377" integer->integer-bytes 4294967295 8 #t #t)
|
||||
(test #"\377\377\377\377\0\0\0\1" integer->integer-bytes -4294967295 8 #t #t)
|
||||
(test #"\0\0\0\1\377\377\377\377" integer->integer-bytes 8589934591 8 #t #t))
|
||||
|
||||
(arity-test integer->integer-bytes 3 5)
|
||||
(test-integer->integer-bytes integer->integer-bytes)
|
||||
(test-integer->integer-bytes (lambda (num sz signed? [bigend? (system-big-endian?)])
|
||||
(let ([bstr (make-bytes 11 (char->integer #\x))])
|
||||
(integer->integer-bytes num sz signed? bigend? bstr 3)
|
||||
(test #"xxx" subbytes bstr 0 3)
|
||||
(test (make-bytes (- 11 3 sz) (char->integer #\x)) subbytes bstr (+ 3 sz))
|
||||
(subbytes bstr 3 (+ 3 sz)))))
|
||||
|
||||
(arity-test integer->integer-bytes 3 6)
|
||||
(err/rt-test (integer->integer-bytes 'ack 2 #t))
|
||||
(err/rt-test (integer->integer-bytes 10 'ack #t))
|
||||
(err/rt-test (integer->integer-bytes 10 20 #t))
|
||||
|
|
@ -2497,8 +2522,8 @@
|
|||
(err/rt-test (integer->integer-bytes (expt 2 64) 8 #f) exn:application:mismatch?)
|
||||
(err/rt-test (integer->integer-bytes (expt 2 63) 4 #t) exn:application:mismatch?)
|
||||
(err/rt-test (integer->integer-bytes (sub1 (- (expt 2 63))) 8 #t) exn:application:mismatch?)
|
||||
(err/rt-test (integer->integer-bytes 100 2 #t #t (make-bytes 3)) exn:application:mismatch?)
|
||||
(err/rt-test (integer->integer-bytes 100 4 #t #t (make-bytes 3)) exn:application:mismatch?)
|
||||
(err/rt-test (integer->integer-bytes 100 2 #t #t (make-bytes 3) 2) exn:application:mismatch?)
|
||||
|
||||
(map (lambda (v)
|
||||
(let-values ([(n size signed?) (apply values v)])
|
||||
|
|
|
|||
|
|
@ -87,14 +87,14 @@ void scheme_init_numstr(Scheme_Env *env)
|
|||
env);
|
||||
|
||||
scheme_add_global_constant("integer-bytes->integer",
|
||||
scheme_make_folding_prim(bytes_to_integer,
|
||||
scheme_make_prim_w_arity(bytes_to_integer,
|
||||
"integer-bytes->integer",
|
||||
2, 3, 1),
|
||||
2, 5),
|
||||
env);
|
||||
scheme_add_global_constant("integer->integer-bytes",
|
||||
scheme_make_prim_w_arity(integer_to_bytes,
|
||||
"integer->integer-bytes",
|
||||
3, 5),
|
||||
3, 6),
|
||||
env);
|
||||
scheme_add_global_constant("floating-point-bytes->real",
|
||||
scheme_make_folding_prim(bytes_to_real,
|
||||
|
|
@ -1599,18 +1599,16 @@ int scheme_check_double(const char *where, double d, const char *dest)
|
|||
|
||||
static Scheme_Object *bytes_to_integer (int argc, Scheme_Object *argv[])
|
||||
{
|
||||
int slen, sgned;
|
||||
long strlen, slen;
|
||||
int sgned;
|
||||
char *str;
|
||||
int buf[2], i;
|
||||
int bigend = MZ_IS_BIG_ENDIAN;
|
||||
int bigend = MZ_IS_BIG_ENDIAN, offset = 0;
|
||||
|
||||
if (!SCHEME_BYTE_STRINGP(argv[0]))
|
||||
slen = 0;
|
||||
scheme_wrong_type("integer-bytes->integer", "byte string", 0, argc, argv);
|
||||
else
|
||||
slen = SCHEME_BYTE_STRLEN_VAL(argv[0]);
|
||||
|
||||
if ((slen != 2) && (slen != 4) && (slen != 8))
|
||||
scheme_wrong_type("integer-bytes->integer", "byte string (2, 4, or 8 bytes)", 0, argc, argv);
|
||||
strlen = SCHEME_BYTE_STRLEN_VAL(argv[0]);
|
||||
|
||||
str = SCHEME_BYTE_STR_VAL(argv[0]);
|
||||
|
||||
|
|
@ -1618,11 +1616,42 @@ static Scheme_Object *bytes_to_integer (int argc, Scheme_Object *argv[])
|
|||
if (argc > 2)
|
||||
bigend = SCHEME_TRUEP(argv[2]);
|
||||
|
||||
if (argc > 3) {
|
||||
long start, finish;
|
||||
|
||||
scheme_get_substring_indices("integer-bytes->integer", argv[0],
|
||||
argc, argv,
|
||||
3, 4, &start, &finish);
|
||||
|
||||
offset = start;
|
||||
slen = finish - start;
|
||||
} else {
|
||||
offset = 0;
|
||||
slen = strlen;
|
||||
}
|
||||
|
||||
if ((slen != 2) && (slen != 4) && (slen != 8)) {
|
||||
scheme_raise_exn(MZEXN_FAIL_CONTRACT,
|
||||
"integer-bytes->integer: length is not 2, 4, or 8 bytes: %ld",
|
||||
slen);
|
||||
return NULL;
|
||||
}
|
||||
|
||||
if (offset + slen > strlen) {
|
||||
scheme_raise_exn(MZEXN_FAIL_CONTRACT,
|
||||
|
||||
slen);
|
||||
return NULL;
|
||||
}
|
||||
|
||||
if (bigend != MZ_IS_BIG_ENDIAN) {
|
||||
for (i = 0; i < slen; i++) {
|
||||
((char *)buf)[slen - i - 1] = str[i];
|
||||
((char *)buf)[slen - i - 1] = str[i + offset];
|
||||
}
|
||||
str = (char *)buf;
|
||||
} else {
|
||||
memcpy(&buf, str + offset, slen);
|
||||
str = (char *)buf;
|
||||
}
|
||||
|
||||
switch(slen) {
|
||||
|
|
@ -1696,7 +1725,7 @@ static Scheme_Object *integer_to_bytes(int argc, Scheme_Object *argv[])
|
|||
Scheme_Object *n, *s;
|
||||
char *str;
|
||||
int size, sgned;
|
||||
long val;
|
||||
long val, offset, buf[2];
|
||||
#if !defined(NO_LONG_LONG_TYPE) && !defined(SIXTY_FOUR_BIT_INTEGERS)
|
||||
mzlonglong llval;
|
||||
#endif
|
||||
|
|
@ -1725,6 +1754,25 @@ static Scheme_Object *integer_to_bytes(int argc, Scheme_Object *argv[])
|
|||
if (!SCHEME_MUTABLE_BYTE_STRINGP(s))
|
||||
scheme_wrong_type("integer->integer-bytes", "mutable byte string", 4, argc, argv);
|
||||
|
||||
if (argc > 5) {
|
||||
long start, finish;
|
||||
|
||||
scheme_get_substring_indices("integer-bytes->integer", s,
|
||||
argc, argv,
|
||||
5, 6, &start, &finish);
|
||||
|
||||
offset = start;
|
||||
} else
|
||||
offset = 0;
|
||||
|
||||
if (offset + size > SCHEME_BYTE_STRLEN_VAL(s)) {
|
||||
scheme_raise_exn(MZEXN_FAIL_CONTRACT,
|
||||
"integer-bytes->integer: byte string is %ld bytes,"
|
||||
" which is shorter than starting position %ld plus size %ld",
|
||||
SCHEME_BYTE_STRLEN_VAL(s), offset, size);
|
||||
return NULL;
|
||||
}
|
||||
|
||||
/* Check for mismatch: number doesn't fit */
|
||||
if (size == 2) {
|
||||
if (SCHEME_BIGNUMP(n))
|
||||
|
|
@ -1799,17 +1847,8 @@ static Scheme_Object *integer_to_bytes(int argc, Scheme_Object *argv[])
|
|||
return NULL;
|
||||
}
|
||||
|
||||
/* Check for mismatch: string wrong size */
|
||||
|
||||
if (size != SCHEME_BYTE_STRLEN_VAL(s)) {
|
||||
scheme_raise_exn(MZEXN_FAIL_CONTRACT,
|
||||
"integer->integer-bytes: string size %d does not match indicated %d-byte length: %V",
|
||||
SCHEME_BYTE_STRLEN_VAL(s), size, s);
|
||||
return NULL;
|
||||
}
|
||||
|
||||
/* Finally, do the work */
|
||||
str = SCHEME_BYTE_STR_VAL(s);
|
||||
str = (char *)buf;
|
||||
switch (size) {
|
||||
case 2:
|
||||
{
|
||||
|
|
@ -1872,15 +1911,16 @@ static Scheme_Object *integer_to_bytes(int argc, Scheme_Object *argv[])
|
|||
break;
|
||||
}
|
||||
|
||||
str = SCHEME_BYTE_STR_VAL(s);
|
||||
if (bigend != MZ_IS_BIG_ENDIAN) {
|
||||
int i;
|
||||
char buf[8];
|
||||
|
||||
for (i = 0; i < size; i++) {
|
||||
buf[size - i - 1] = str[i];
|
||||
str[i + offset] = ((char *)buf)[size - i - 1];
|
||||
}
|
||||
} else {
|
||||
int i;
|
||||
for (i = 0; i < size; i++) {
|
||||
str[i] = buf[i];
|
||||
str[i + offset] = ((char *)buf)[i];
|
||||
}
|
||||
}
|
||||
|
||||
|
|
|
|||
Loading…
Reference in New Issue
Block a user