From 8311c8f9e4844331675f455e8b3163c10e92eab6 Mon Sep 17 00:00:00 2001 From: Matthew Flatt Date: Mon, 25 Feb 2008 14:42:32 +0000 Subject: [PATCH] Eli's repaired and specialized sort, fix in 'for/fold' binding, generalized integers-bytes functions, and some r6rs work svn: r8798 --- collects/rnrs/arithmetic/bitwise-6.ss | 2 +- collects/rnrs/bytevectors-6.ss | 405 +++++++++++++++++++ collects/rnrs/enums-6.ss | 240 +++++++++++ collects/scheme/private/for.ss | 7 +- collects/scheme/private/list.ss | 150 ++++--- collects/scheme/promise.ss | 244 +++++------ collects/scribblings/reference/numbers.scrbl | 39 +- collects/tests/mzscheme/number.ss | 235 ++++++----- src/mzscheme/src/numstr.c | 92 +++-- 9 files changed, 1081 insertions(+), 333 deletions(-) create mode 100644 collects/rnrs/bytevectors-6.ss create mode 100644 collects/rnrs/enums-6.ss diff --git a/collects/rnrs/arithmetic/bitwise-6.ss b/collects/rnrs/arithmetic/bitwise-6.ss index 94c8007f9d..788a2a5396 100644 --- a/collects/rnrs/arithmetic/bitwise-6.ss +++ b/collects/rnrs/arithmetic/bitwise-6.ss @@ -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)))) diff --git a/collects/rnrs/bytevectors-6.ss b/collects/rnrs/bytevectors-6.ss new file mode 100644 index 0000000000..7bfd684bfd --- /dev/null +++ b/collects/rnrs/bytevectors-6.ss @@ -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)))))))])))))) diff --git a/collects/rnrs/enums-6.ss b/collects/rnrs/enums-6.ss new file mode 100644 index 0000000000..7d91cad521 --- /dev/null +++ b/collects/rnrs/enums-6.ss @@ -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))]))))))])) diff --git a/collects/scheme/private/for.ss b/collects/scheme/private/for.ss index bf59e6890d..807bcd43b3 100644 --- a/collects/scheme/private/for.ss +++ b/collects/scheme/private/for.ss @@ -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)] diff --git a/collects/scheme/private/list.ss b/collects/scheme/private/list.ss index 8d009e5727..1b83f8b8a4 100644 --- a/collects/scheme/private/list.ss +++ b/collects/scheme/private/list.ss @@ -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 stringlist - (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))))))]))) diff --git a/collects/scheme/promise.ss b/collects/scheme/promise.ss index 489e1dd382..5acfd7dd50 100644 --- a/collects/scheme/promise.ss +++ b/collects/scheme/promise.ss @@ -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 "#" n))] - [else (display "#" port)])] - ;; no values - [(null? p) (fprintf port "#")] - [(pair? p) - ;; single or multiple values - (fprintf port - (if write? "#" 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 ) delayed promise, maybe currently running, maybe an exn promise -;; | (promise (list )) forced promise (possibly multi-valued) -;; | (promise ) shared promise -;; | (promise ) 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 "#" n))] + [else (display "#" port)])] + ;; no values + [(null? p) (fprintf port "#")] + [(pair? p) + ;; single or multiple values + (fprintf port + (if write? "#" 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 ) delayed promise, maybe currently running, maybe an exn promise + ;; | (promise (list )) forced promise (possibly multi-valued) + ;; | (promise ) shared promise + ;; | (promise ) 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))) diff --git a/collects/scribblings/reference/numbers.scrbl b/collects/scribblings/reference/numbers.scrbl index 31f9eb8edc..84d66234af 100644 --- a/collects/scribblings/reference/numbers.scrbl +++ b/collects/scribblings/reference/numbers.scrbl @@ -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 diff --git a/collects/tests/mzscheme/number.ss b/collects/tests/mzscheme/number.ss index db5d911d82..962da2dcd0 100644 --- a/collects/tests/mzscheme/number.ss +++ b/collects/tests/mzscheme/number.ss @@ -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)]) diff --git a/src/mzscheme/src/numstr.c b/src/mzscheme/src/numstr.c index 53dc2203c3..09499f8b73 100644 --- a/src/mzscheme/src/numstr.c +++ b/src/mzscheme/src/numstr.c @@ -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]; } }