diff --git a/collects/unstable/byte-counting-port.rkt b/collects/unstable/byte-counting-port.rkt index 17949a9d2d..1902aa91cb 100644 --- a/collects/unstable/byte-counting-port.rkt +++ b/collects/unstable/byte-counting-port.rkt @@ -12,6 +12,10 @@ (make-output-port name always-evt write-out close #f #f #f get-location)) +;; Ryan: Isn't this just a reimplementation of 'open-output-nowhere'? +;; Actually, the 'get-location' method isn't called unless 'port-count-lines!' +;; is called first, and on a fresh port (no writes), it errors because it returns +;; 0 and a positive number is required. (provide/contract - [make-byte-counting-port (() (any/c) . ->* . output-port?)]) \ No newline at end of file + [make-byte-counting-port (() (any/c) . ->* . output-port?)]) diff --git a/collects/unstable/contract.rkt b/collects/unstable/contract.rkt index 71f66530a4..2b8b9af8b7 100644 --- a/collects/unstable/contract.rkt +++ b/collects/unstable/contract.rkt @@ -13,6 +13,18 @@ (lambda (s) (not (zero? (string-length s)))))) ;; Eli: If this gets in, there should also be versions for bytes, lists, and ;; vectors. +;; Ryan: How about just making these predicates? Predicates are more broadly applicable, +;; and when used as a contract we get the descriptive name for free. +(define (non-empty-string? x) + (and (string? x) (not (zero? (string-length x))))) +(define (non-empty-bytes? x) + (and (bytes? x) (not (zero? (bytes-length x))))) +(define (non-empty-vector? x) + (and (vector? x) (not (zero? (vector-length x))))) +(define (non-empty-list? x) + (and (list? x) (pair? x))) +(define (singleton-list? x) + (and (pair? x) (null? (cdr x)))) ;; ryanc added: @@ -52,6 +64,15 @@ #:first-order (lambda (x) (if (predicate x) (then-fo x) (else-fo x)))))))) +;; failure-result/c : contract +;; Describes the optional failure argument passed to hash-ref, for example. +;; If the argument is a procedure, it must be a thunk, and it is applied. Otherwise +;; the argument is simply the value to return. +(define failure-result/c + (if/c procedure? (-> any) any/c)) + +;; rename-contract : contract any/c -> contract +;; If the argument is a flat contract, so is the result. (define (rename-contract ctc name) (let ([ctc (coerce-contract 'rename-contract ctc)]) (if (flat-contract? ctc) @@ -343,7 +364,15 @@ [non-empty-string/c contract?] [path-element? contract?] [port-number? contract?] + + [non-empty-string? predicate/c] + [non-empty-bytes? predicate/c] + [non-empty-vector? predicate/c] + [non-empty-list? predicate/c] + [singleton-list? predicate/c] + [if/c (-> procedure? contract? contract? contract?)] + [failure-result/c contract?] [rename-contract (-> contract? any/c contract?)] [nat/c flat-contract?] diff --git a/collects/unstable/dict.rkt b/collects/unstable/dict.rkt index 0b15dd44b1..0bc4fb047a 100644 --- a/collects/unstable/dict.rkt +++ b/collects/unstable/dict.rkt @@ -18,6 +18,7 @@ (dict-ref dict key (lambda () (return #f))) #t))) dict-has-key?)) +;; Ryan: Why the with-contract region? Why not provide/contract? (define dict-ref! (let () diff --git a/collects/unstable/find.rkt b/collects/unstable/find.rkt index 86fdbb2afd..0ca5a2366b 100644 --- a/collects/unstable/find.rkt +++ b/collects/unstable/find.rkt @@ -70,4 +70,3 @@ (if (procedure? default) (default) default))) -;; Eli: Note that this is documented "Like `find-first'". diff --git a/collects/unstable/generics.rkt b/collects/unstable/generics.rkt index ccc38511cb..b166e3b371 100644 --- a/collects/unstable/generics.rkt +++ b/collects/unstable/generics.rkt @@ -157,10 +157,10 @@ [(mthd-generic ...) (map (λ (g) (datum->syntax #'mthds (syntax->datum g))) specs)]) + (syntax-property (syntax/loc stx - (let ([fake #'generics] ; This is to get the arrow to show up in DrRacket. It is ? arrow, so it isn't that nice. - ; XXX this could be a signal to the guard to error early, but is seems okay to allow - ; missing methods + (let (; XXX this could be a signal to the guard to error early, + ; but is seems okay to allow missing methods [mthd-generic #f] ...) (syntax-parameterize @@ -179,4 +179,6 @@ stx #'method-name)]))]) (local mthds - (vector mthd-generic ...)))))))])) \ No newline at end of file + (vector mthd-generic ...))))) + 'disappeared-use + (list #'generics))))])) diff --git a/collects/unstable/list.rkt b/collects/unstable/list.rkt index f8b964d713..4bd6d12212 100644 --- a/collects/unstable/list.rkt +++ b/collects/unstable/list.rkt @@ -3,7 +3,7 @@ racket/dict (for-syntax racket/base)) -; list-prefix : list? list? -> boolean? +; list-prefix? : list? list? -> boolean? ; Is l a prefix or r? (define (list-prefix? ls rs) (or (null? ls) @@ -24,8 +24,33 @@ ;; lists, and return a matching number of values. ;; ryanc: changed to use Eli's version +(define (internal-split-common-prefix as bs same? keep-prefix?) + (let loop ([as as] [bs bs]) + (if (and (pair? as) (pair? bs) (same? (car as) (car bs))) + (let-values ([(prefix atail btail) (loop (cdr as) (cdr bs))]) + (values (and keep-prefix? (cons (car as) prefix)) atail btail)) + (values null as bs)))) + +(define (split-common-prefix as bs #:same? [same? equal?]) + (internal-split-common-prefix as bs same? #t)) + +(define (take-common-prefix as bs #:same? [same? equal?]) + (let-values ([(prefix atail btail) (internal-split-common-prefix as bs same? #t)]) + prefix)) + +(define (drop-common-prefix as bs #:same? [same? equal?]) + (let-values ([(atail btail) (internal-split-common-prefix as bs same? #f)]) + (values atail btail))) + (provide/contract - [list-prefix? (list? list? . -> . boolean?)]) + [list-prefix? (list? list? . -> . boolean?)] + [split-common-prefix + (->* (any/c any/c) (#:same? procedure?) (values list? any/c any/c))] + [take-common-prefix + (->* (any/c any/c) (#:same? procedure?) list?)] + [drop-common-prefix + (->* (any/c any/c) (#:same? procedure?) (values any/c any/c))]) + (define (filter-multiple l . fs) (apply values diff --git a/collects/unstable/port.rkt b/collects/unstable/port.rkt index c0f4b9c787..89710d8a57 100644 --- a/collects/unstable/port.rkt +++ b/collects/unstable/port.rkt @@ -1,20 +1,22 @@ #lang racket - (require unstable/srcloc) -(define buffer (make-bytes 1024)) - +#| +Ryan: + Shouldn't this be called read-bytes/avail instead? (parallel existing names) + Changed to eliminate thread-unsafe buffer. +|# (define (read-available-bytes [port (current-input-port)]) - (read-available-bytes/offset port 0)) + (read-available-bytes/offset port (make-bytes 1024) 0)) -(define (read-available-bytes/offset port offset) +(define (read-available-bytes/offset port buffer offset) (let* ([result (read-bytes-avail!* buffer port offset)]) (if (eof-object? result) (if (zero? offset) result (subbytes buffer 0 offset)) - (let* ([new-offset (+ offset result)]) + (let ([new-offset (+ offset result)]) (if (= new-offset (bytes-length buffer)) - (begin (set! buffer (bytes-append buffer buffer)) - (read-available-bytes/offset port new-offset)) + (let ([new-buffer (bytes-append buffer buffer)]) + (read-available-bytes/offset port new-buffer new-offset)) (subbytes buffer 0 new-offset)))))) (define (port->srcloc port [source (object-name port)] [span 0]) diff --git a/collects/unstable/regexp.rkt b/collects/unstable/regexp.rkt index 44bf254cc2..deeb58a826 100644 --- a/collects/unstable/regexp.rkt +++ b/collects/unstable/regexp.rkt @@ -2,6 +2,9 @@ (require racket/list racket/contract) +;; Ryan: These functions should also allow regexp objects, use object-name to get strings. +;; And use string-join instead of add-between. + ;; regexp-or : String ... -> String ;; Produces the regexp disjunction of several regexp-strings. (define (regexp-or . strings) diff --git a/collects/unstable/scribblings/contract.scrbl b/collects/unstable/scribblings/contract.scrbl index 157b1a2563..cf21eca5b5 100644 --- a/collects/unstable/scribblings/contract.scrbl +++ b/collects/unstable/scribblings/contract.scrbl @@ -43,6 +43,14 @@ The last contract is the same as @racket[any/c] because @racket[or/c] tries flat contracts before higher-order contracts. } +@defthing[failure-result/c contract?]{ + +A contract that describes the failure result arguments of procedures +such as @racket[hash-ref]. + +Equivalent to @racket[(if/c procedure? (-> any) any/c)]. +} + @defproc[(rename-contract [contract contract?] [name any/c]) contract?]{