suzanne.soy/racket
1
0
Fork 0
Code Issues Pull Requests Actions Packages Projects Releases Wiki Activity

Some reformating. The only real change is using `write-bytes' instead

Browse Source 
of a `display' in one place.
This commit is contained in:
Eli Barzilay 2011-06-04 16:32:36 -04:00
parent 3ecdd3bc59
commit 5754312120
1 changed files with 285 additions and 281 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

156
collects/racket/private/string.rkt
View File

@ -15,14 +15,13 @@
;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
(define (real->decimal-string n [digits 2]) (define (real->decimal-string n [digits 2])
(unless (exact-nonnegative-integer? digits) (unless (exact-nonnegative-integer? digits)
(raise-type-error 'real->decimal-string "exact-nonnegative-integer" digits)) (raise-type-error 'real->decimal-string "exact-nonnegative-integer"
digits))
(let* ([e (expt 10 digits)] (let* ([e (expt 10 digits)]
[num (round (abs (* e (inexact->exact n))))]) [num (round (abs (* e (inexact->exact n))))])
(format "~a~a.~a" (format
(if (or (negative? n) "~a~a.~a"
(equal? n -0.0)) (if (or (negative? n) (equal? n -0.0)) "-" "")
"-"
"")
(quotient num e) (quotient num e)
(if (zero? digits) (if (zero? digits)
"" ""
@ -87,39 +86,38 @@
(or (hash-ref t key #f) (or (hash-ref t key #f)
(let ([rx* (run-tweak)]) (hash-set! t key rx*) rx*)))))) (let ([rx* (run-tweak)]) (hash-set! t key rx*) rx*))))))
(define (regexp-try-match pattern input-port [start-k 0] [end-k #f] [out #f] [prefix #""]) (define (regexp-try-match pattern input-port [start-k 0] [end-k #f] [out #f]
[prefix #""])
(unless (input-port? input-port) (unless (input-port? input-port)
(raise-type-error 'regexp-try-match (raise-type-error 'regexp-try-match "input port" input-port))
"input port" input-port))
(unless (or (not out) (output-port? out)) (unless (or (not out) (output-port? out))
(raise-type-error 'regexp-try-match (raise-type-error 'regexp-try-match "output port or #f" out))
"output port or #f" out)) (let ([m (regexp-match-peek-positions pattern input-port start-k end-k #f
(let ([m (regexp-match-peek-positions pattern input-port start-k end-k #f prefix)]) prefix)])
(and m (and m
;; What happens if someone swipes our bytes before we can get them? ;; What happens if someone swipes our bytes before we can get them?
(let ([drop (caar m)]) (let ([drop (caar m)])
;; drop prefix before match: ;; drop prefix before match:
(let ([s (read-bytes drop input-port)]) (let ([s (read-bytes drop input-port)])
(when out (when out (write-bytes s out)))
(display s out)))
;; Get the matching part, and shift matching indices ;; Get the matching part, and shift matching indices
(let ([s (read-bytes (- (cdar m) drop) input-port)]) (let ([s (read-bytes (- (cdar m) drop) input-port)])
(cons s (cons s
(map (lambda (p) (map (lambda (p)
(and p (subbytes s (- (car p) drop) (- (cdr p) drop)))) (and p (subbytes s (- (car p) drop)
(- (cdr p) drop))))
(cdr m)))))))) (cdr m))))))))
;; Helper macro for the regexp functions below, with some utilities. ;; Helper macro for the regexp functions below, with some utilities.
(define (bstring-length s) (define (bstring-length s)
(if (bytes? s) (bytes-length s) (string-length s))) (if (bytes? s) (bytes-length s) (string-length s)))
(define no-empty-edge-matches (define no-empty-edge-matches
(make-regexp-tweaker (lambda (rx n) (make-regexp-tweaker
(lambda (rx n)
(if (bytes? rx) (if (bytes? rx)
(bytes-append #"(?:" (bytes-append #"(?:" rx #")(?<="
rx (make-bytes n (char->integer #\.)) #")")
#")(?<=" (make-bytes n (char->integer #\.)) #")") (format "(?:~a)(?<=~a)" rx (make-bytes n (char->integer #\.)))))))
(format "(?:~a)(?<=~a)"
rx (make-bytes n (char->integer #\.)))))))
(define-syntax-rule (regexp-loop (define-syntax-rule (regexp-loop
name loop start end pattern string name loop start end pattern string
ipre ipre
@ -134,12 +132,13 @@
[len (cond [(string? string) (string-length string)] [len (cond [(string? string) (string-length string)]
[(bytes? string) (bytes-length string)] [(bytes? string) (bytes-length string)]
[else #f])] [else #f])]
[orig-rx (cond [(bytes? pattern) (byte-regexp pattern)] [orig-rx
(cond [(bytes? pattern) (byte-regexp pattern)]
[(string? pattern) (regexp pattern)] [(string? pattern) (regexp pattern)]
[(regexp? pattern) pattern] [(regexp? pattern) pattern]
[(byte-regexp? pattern) pattern] [(byte-regexp? pattern) pattern]
[else [else (raise-type-error
(raise-type-error 'name 'name
"regexp, byte regexp, string, or byte string" "regexp, byte regexp, string, or byte string"
pattern)])] pattern)])]
[max-lookbehind (regexp-max-lookbehind orig-rx)]) [max-lookbehind (regexp-max-lookbehind orig-rx)])
@ -172,9 +171,10 @@
end)) end))
(reverse (reverse
(let loop ([acc '()] [start start] [end end] [ipre ipre] [0-ok? #t]) (let loop ([acc '()] [start start] [end end] [ipre ipre] [0-ok? #t])
(let* ([rx (if 0-ok? (let ([rx (if 0-ok?
orig-rx orig-rx
(no-empty-edge-matches orig-rx (add1 (bytes-length ipre))))]) (no-empty-edge-matches orig-rx
(add1 (bytes-length ipre))))])
(if (and port-success-choose (input-port? string)) (if (and port-success-choose (input-port? string))
;; Input port match, get string ;; Input port match, get string
@ -198,8 +198,8 @@
c)) c))
void))] void))]
[end (and end (- end start))]) [end (and end (- end start))])
(let-values ([(ms ipre) (regexp-match/end rx (let-values ([(ms ipre)
string 0 end spitout ipre (regexp-match/end rx string 0 end spitout ipre
max-lookbehind)]) max-lookbehind)])
(let* ([m (and ms (car ms))] (let* ([m (and ms (car ms))]
[discarded/leftovers (if need-leftover? [discarded/leftovers (if need-leftover?
@ -209,8 +209,7 @@
(bstring-length discarded/leftovers) (bstring-length discarded/leftovers)
discarded/leftovers)] discarded/leftovers)]
[got (and m (bstring-length m))] [got (and m (bstring-length m))]
[end (and end m [end (and end m (- end skipped got))])
(- end skipped got))])
(if m (if m
(let ([0-ok? (not (zero? got))]) (let ([0-ok? (not (zero? got))])
(loop (port-success-choose m discarded/leftovers ms acc) (loop (port-success-choose m discarded/leftovers ms acc)
@ -220,11 +219,11 @@
;; String/port match, get positions ;; String/port match, get positions
(let-values ([(m ipre) (let-values ([(m ipre)
(if peek? (if peek?
(regexp-match-peek-positions/end rx (regexp-match-peek-positions/end
string start end #f ipre rx string start end #f ipre
max-lookbehind) max-lookbehind)
(regexp-match-positions/end rx (regexp-match-positions/end
string start end #f ipre rx string start end #f ipre
max-lookbehind))]) max-lookbehind))])
(if (not m) (if (not m)
(failure-k acc start end) (failure-k acc start end)
@ -241,10 +240,7 @@
;; Returns all the positions at which the pattern matched. ;; Returns all the positions at which the pattern matched.
(define (regexp-match-positions* pattern string [start 0] [end #f] [ipre #""]) (define (regexp-match-positions* pattern string [start 0] [end #f] [ipre #""])
(regexp-loop (regexp-loop regexp-match-positions* loop start end pattern string ipre
regexp-match-positions* loop start end
pattern string
ipre
;; success-choose: ;; success-choose:
(lambda (start mstart mend ms acc) (cons (cons mstart mend) acc)) (lambda (start mstart mend ms acc) (cons (cons mstart mend) acc))
;; failure-k: ;; failure-k:
@ -265,11 +261,10 @@
#f)) #f))
;; Returns all the positions at which the pattern matched. ;; Returns all the positions at which the pattern matched.
(define (regexp-match-peek-positions* pattern string [start 0] [end #f] [ipre #""]) (define (regexp-match-peek-positions* pattern string [start 0] [end #f]
(regexp-loop [ipre #""])
regexp-match-peek-positions* loop start end (regexp-loop regexp-match-peek-positions* loop start end
pattern string pattern string ipre
ipre
;; success-choose: ;; success-choose:
(lambda (start mstart mend ms acc) (cons (cons mstart mend) acc)) (lambda (start mstart mend ms acc) (cons (cons mstart mend) acc))
;; failure-k: ;; failure-k:
@ -284,13 +279,14 @@
;; Splits a string into a list by removing any piece which matches ;; Splits a string into a list by removing any piece which matches
;; the pattern. ;; the pattern.
(define (regexp-split pattern string [start 0] [end #f] [ipre #""]) (define (regexp-split pattern string [start 0] [end #f] [ipre #""])
(define buf (if (and (string? string) (or (byte-regexp? pattern) (define buf
(bytes? pattern))) (if (and (string? string) (or (byte-regexp? pattern) (bytes? pattern)))
(string->bytes/utf-8 string (char->integer #\?)) (string->bytes/utf-8 string (char->integer #\?))
string)) string))
(define sub (if (or (bytes? buf) (and (path? string) (define sub
(or (bytes? pattern) (if (or (bytes? buf)
(byte-regexp? pattern)))) (and (path? string)
(or (bytes? pattern) (byte-regexp? pattern))))
subbytes subbytes
substring)) substring))
(regexp-loop regexp-split loop start end pattern buf ipre (regexp-loop regexp-split loop start end pattern buf ipre
@ -312,32 +308,32 @@
(define -regexp-replace* (define -regexp-replace*
(let ([regexp-replace* (let ([regexp-replace*
(lambda (pattern string orig-replacement [ipre #""]) (lambda (pattern string orig-replacement [ipre #""])
(define buf (if (and (string? string) (or (byte-regexp? pattern) (define buf
(bytes? pattern))) (if (and (string? string)
(or (byte-regexp? pattern) (bytes? pattern)))
(string->bytes/utf-8 string (char->integer #\?)) (string->bytes/utf-8 string (char->integer #\?))
string)) string))
(define sub (if (bytes? buf) subbytes substring)) (define sub (if (bytes? buf) subbytes substring))
(define start 0) (define start 0)
(define end #f) (define end #f)
(define needs-string? (define needs-string?
(and (or (string? pattern) (regexp? pattern)) (and (or (string? pattern) (regexp? pattern)) (string? string)))
(string? string)))
(define replacement (define replacement
(if (and (not needs-string?) (string? orig-replacement)) (if (and (not needs-string?) (string? orig-replacement))
(string->bytes/utf-8 orig-replacement) (string->bytes/utf-8 orig-replacement)
orig-replacement)) orig-replacement))
(define (check proc args) (define (check proc args)
(let ([v (apply proc args)]) (let ([v (apply proc args)])
(unless (if needs-string? (unless (if needs-string? (string? v) (bytes? v))
(string? v) (raise-mismatch-error
(bytes? v)) '|regexp-replace* (calling given filter procedure)|
(raise-mismatch-error '|regexp-replace* (calling given filter procedure)|
(if needs-string? (if needs-string?
"expected a string result: " "expected a string result: "
"expected a byte string result: ") "expected a byte string result: ")
v)) v))
v)) v))
(define need-replac? (and (not (procedure? replacement)) (define need-replac?
(and (not (procedure? replacement))
(regexp-match? #rx#"[\\&]" replacement))) (regexp-match? #rx#"[\\&]" replacement)))
(define (replac ms str) (define (replac ms str)
(if need-replac? (if need-replac?
@ -345,22 +341,22 @@
(apply (apply
bytes-append bytes-append
(let ([str (if (string? str) (string->bytes/utf-8 str) str)] (let ([str (if (string? str) (string->bytes/utf-8 str) str)]
[get-match (lambda (n) [get-match
(lambda (n)
(if (n . < . (length ms)) (if (n . < . (length ms))
(let* ([p (list-ref ms n)] (let* ([p (list-ref ms n)]
[s (if (pair? p) [s (if (pair? p)
(sub buf (car p) (cdr p)) (sub buf (car p) (cdr p))
p)]) p)])
(if (string? s) (if (string? s) (string->bytes/utf-8 s) s))
(string->bytes/utf-8 s)
s))
#""))]) #""))])
(let loop ([pos 0]) (let loop ([pos 0])
(let ([m (regexp-match-positions #rx#"[\\&]" str pos)]) (let ([m (regexp-match-positions #rx#"[\\&]" str pos)])
(if m (if m
(cons (subbytes str pos (caar m)) (cons (subbytes str pos (caar m))
(cond (cond
[(equal? (char->integer #\&) (bytes-ref str (caar m))) [(equal? (char->integer #\&)
(bytes-ref str (caar m)))
(cons (get-match 0) (loop (cdar m)))] (cons (get-match 0) (loop (cdar m)))]
[(= (cdar m) (bytes-length str)) [(= (cdar m) (bytes-length str))
;; \ with no following character ;; \ with no following character
@ -373,10 +369,14 @@
=> (lambda (s) => (lambda (s)
(cons s (loop (add1 (cdar m)))))] (cons s (loop (add1 (cdar m)))))]
[else [else
(let ([n (regexp-match #rx#"^[0-9]+" str (cdar m))]) (let ([n (regexp-match #rx#"^[0-9]+" str
(cdar m))])
(if n (if n
(cons (get-match (string->number (bytes->string/utf-8 (car n)))) (cons (get-match (string->number
(loop (+ (cdar m) (bytes-length (car n))))) (bytes->string/utf-8
(car n))))
(loop (+ (cdar m)
(bytes-length (car n)))))
(cons (get-match 0) (cons (get-match 0)
(loop (cdar m)))))])) (loop (cdar m)))))]))
(list (subbytes str pos)))))))) (list (subbytes str pos))))))))
@ -385,22 +385,25 @@
(regexp? pattern) (byte-regexp? pattern)) (regexp? pattern) (byte-regexp? pattern))
(unless (or (string? string) (unless (or (string? string)
(bytes? string)) (bytes? string))
(raise-type-error 'regexp-replace* "string or byte string" string)) (raise-type-error 'regexp-replace* "string or byte string"
string))
(unless (or (string? replacement) (unless (or (string? replacement)
(bytes? replacement) (bytes? replacement)
(procedure? replacement)) (procedure? replacement))
(raise-type-error 'regexp-replace* "string, byte string, or procedure" (raise-type-error 'regexp-replace*
"string, byte string, or procedure"
replacement)) replacement))
(when (and needs-string? (bytes? replacement)) (when (and needs-string? (bytes? replacement))
(raise-mismatch-error 'regexp-replace* (raise-mismatch-error
'regexp-replace*
"cannot replace a string with a byte string: " "cannot replace a string with a byte string: "
replacement))) replacement)))
(apply (apply
(if (bytes? buf) bytes-append string-append) (if (bytes? buf) bytes-append string-append)
(regexp-loop (regexp-loop regexp-replace* loop start end pattern buf ipre
regexp-replace* loop start end pattern buf ipre
;; success-choose: ;; success-choose:
(lambda (start mstart mend ms acc) (list* (if (procedure? replacement) (lambda (start mstart mend ms acc)
(list* (if (procedure? replacement)
(check (check
replacement replacement
(for/list ([m ms]) (for/list ([m ms])
@ -423,13 +426,14 @@
;; Returns all the matches for the pattern in the string. ;; Returns all the matches for the pattern in the string.
(define (regexp-match* pattern string [start 0] [end #f] [ipre #""]) (define (regexp-match* pattern string [start 0] [end #f] [ipre #""])
(define buf (if (and (string? string) (or (byte-regexp? pattern) (define buf
(bytes? pattern))) (if (and (string? string) (or (byte-regexp? pattern) (bytes? pattern)))
(string->bytes/utf-8 string (char->integer #\?)) (string->bytes/utf-8 string (char->integer #\?))
string)) string))
(define sub (if (or (bytes? buf) (and (path? string) (define sub
(or (bytes? pattern) (if (or (bytes? buf)
(byte-regexp? pattern)))) (and (path? string)
(or (bytes? pattern) (byte-regexp? pattern))))
subbytes subbytes
substring)) substring))
(regexp-loop regexp-match* loop start end pattern buf ipre (regexp-loop regexp-match* loop start end pattern buf ipre