diff --git a/racket/src/io/common/object.rkt b/racket/src/io/common/object.rkt deleted file mode 100644 index c343f27f8e..0000000000 --- a/racket/src/io/common/object.rkt +++ /dev/null @@ -1,267 +0,0 @@ -#lang racket/base -(require (for-syntax racket/base - racket/pretty) - racket/stxparam - "fixnum.rkt") - -;; The `define-constructor` form implements a basic object system -;; where any `(define (id ....) ....)` or `(define id (case-lambda -;; ....)` in the constructor body is treated as a method that is -;; converted to accept a vector of free variables. -;; -;; A `lambda` or `case-lambda` is any other position can be wrapped in -;; `method` to convert it, too. Note that the caller of such methods -;; must know to pass along the self vector somehow. The `self` -;; identifier is bound to the self vector. -;; -;; Constraints: -;; -;; Macros are not expanded to recognize definitions; use only -;; `define` or `define-fixnum` for definitions. -;; -;; Only `set!` any variables within a method. -;; -;; A named method cannot be used as a value unless it is wrapped -;; with `method`; calls are automatcally converted to pass along the -;; self vector, while the `method` escape obliges a called of the -;; result to pass along the self vector. - -(provide define-constructor - method - self) - -(define-syntax-parameter self - (lambda (stx) - (raise-syntax-error #f "misuse outside of a constructor" stx))) - -(define-syntax-parameter current-constructor-fields #f) -(define-syntax-parameter current-constructor-methods #f) - -(define-for-syntax (get-current-constructor-fields) - (syntax-parameter-value #'current-constructor-fields)) -(define-for-syntax (get-current-constructor-methods) - (syntax-parameter-value #'current-constructor-methods)) - -(define-for-syntax (maybe-lift mode e) - (syntax-case mode () - [#:lift (syntax-local-lift-expression e)] - [#:no-lift e])) - -(define-syntax (method stx) - (syntax-case stx (lambda case-lambda) - [(_ id) - (identifier? #'id) - #'(id #:method)] - [(_ rhs) - #'(method #:lift rhs)] - [(_ lift-mode (lambda (arg ...) body ...)) - (with-syntax ([fields (get-current-constructor-fields)] - [methods (get-current-constructor-methods)] - [(_ _ inside) stx]) - (maybe-lift - #'lift-mode - #`(lambda (this arg ...) - (let-methods - this methods inside - (let-fields - this 0 fields inside - body ...)))))] - [(_ lift-mode (case-lambda [(arg ...) body ...] ...)) - (with-syntax ([fields (get-current-constructor-fields)] - [methods (get-current-constructor-methods)] - [(_ _ inside) stx]) - (maybe-lift - #'lift-mode - #`(case-lambda - [(this arg ...) - (let-methods - this methods inside - (let-fields - this 0 fields inside - body ...))] - ...)))])) - -(define-for-syntax (make-method-transformer self-id id) - (lambda (stx) - (syntax-case stx () - [(_ #:method) id] - [(_ arg ...) (quasisyntax/loc stx - (#,id #,self-id arg ...))]))) - -(define-syntax (define-constructor stx) - (syntax-case stx () - [(_ (name arg ...) body ... last-body) - (andmap identifier? (syntax->list #'(arg ...))) - (let () - (define fields - (apply append - (syntax->list #'(arg ...)) - (for/list ([body (in-list (syntax->list #'(body ...)))]) - (syntax-case body (define case-lambda define-values define-fixnum) - [(define (id . _) . _) - null] - [(define id (case-lambda . _)) - null] - [(define id _) - (list #'id)] - [(define-values (id ...) _) - (syntax->list #'(id ...))] - [(define-fixnum id _) - (list #'(capture-fixnum id))] - [else - null])))) - (define methods - (apply - append - (for/list ([body (in-list (syntax->list #'(body ...)))]) - (syntax-case body (define define-values define-fixnum case-lambda) - [(define (id . args) . bodys) - (list (cons #'id (generate-temporaries #'(id))))] - [(define id (case-lambda . clauses)) - (list (cons #'id (generate-temporaries #'(id))))] - [_ null])))) - (define (find-method-name id) - (for/or ([pr (in-list methods)]) - (and (free-identifier=? id (car pr)) - (cadr pr)))) - (define num-args (length (syntax->list #'(arg ...)))) - (define-values (method-defns other-bodys count) - (for/fold ([method-defns null] [other-bodys null] [n num-args]) ([body (in-list (syntax->list #'(body ...)))]) - (syntax-case body (define define-values define-fixnum case-lambda) - [(define (id . args) . bodys) - (let ([re (lambda (s) (datum->syntax body (syntax-e s) body body))] - [tmp-id (find-method-name #'id)]) - (values (cons #`(define #,tmp-id - (syntax-parameterize ([current-constructor-fields (quote-syntax #,fields)] - [current-constructor-methods (quote-syntax #,methods)]) - (method #:no-lift #,(re #'(lambda args . bodys))))) - method-defns) - other-bodys - n))] - [(define id (case-lambda . clauses)) - (let ([re (lambda (s) (datum->syntax body (syntax-e s) body body))] - [tmp-id (find-method-name #'id)]) - (values (cons #`(define #,tmp-id - (syntax-parameterize ([current-constructor-fields (quote-syntax #,fields)] - [current-constructor-methods (quote-syntax #,methods)]) - (method #:no-lift #,(re #'(case-lambda clauses))))) - method-defns) - other-bodys - n))] - [(define id _) - (values method-defns - (list* #`(vector*-set! self-vec #,n id) - body - other-bodys) - (add1 n))] - [(define-values (id ...) _) - (values method-defns - (list* #`(begin #,@(for/list ([id (in-list (syntax->list #'(id ...)))] - [n (in-naturals n)]) - #`(vector*-set! self-vec #,n #,id))) - body - other-bodys) - (+ n (length (syntax->list #'(id ...)))))] - [(define-fixnum id _) - (values method-defns - (list* #`(vector*-set! self-vec #,n (capture-fixnum id)) - body - other-bodys) - (add1 n))] - [else - (values method-defns - (cons body other-bodys) - n)]))) - (with-syntax ([inside stx] - [count #`#,count] - [fields fields] - [methods methods] - [(init-arg ...) (for/list ([arg (in-list (syntax->list #'(arg ...)))] - [i (in-naturals)]) - #`(vector*-set! self-vec #,i #,arg))] - [(other-body ...) (reverse other-bodys)] - [(method-defn ...) (reverse method-defns)]) - #'(begin - method-defn ... - (define (name arg ...) - (define self-vec (make-vector count)) - init-arg ... - (syntax-parameterize ([current-constructor-fields (quote-syntax fields)] - [current-constructor-methods (quote-syntax methods)] - [self (lambda (stx) #'self-vec)]) - (let-methods - self-vec methods inside - (let () - other-body ... - last-body)))))))] - [(_ (name . formals) body ... last-body) - (with-syntax ([(arg ...) (let loop ([formals #'formals]) - (syntax-case formals () - [() null] - [id - (identifier? #'id) - (list #'id)] - [(kw . formals) - (keyword? (syntax-e #'kw)) - (loop #'formals)] - [([id _] . formals) - (cons #'id (loop #'formals))] - [(id . formals) - (cons #'id (loop #'formals))]))]) - #`(begin - #,(datum->syntax - stx - (syntax-e #'(define-constructor (constructor arg ...) - body ... last-body)) - stx - stx) - (define (name . formals) - (constructor arg ...))))])) - -(define-syntax (let-fields stx) - (syntax-case stx (capture-fixnum) - [(_ self-id n () ctx body ...) - #'(let () body ...)] - [(_ self-id n ((capture-fixnum id) . captureds) ctx . bodys) - (with-syntax ([id (datum->syntax #'ctx (syntax-e #'id))] - [n+1 #`#,(+ (syntax-e #'n) 1)]) - #'(let-syntax ([id (make-fixnum-transformer #'(vector*-ref self-id n))]) - (let-fields self-id n+1 captureds ctx . bodys)))] - [(_ self-id n (id . captureds) ctx . bodys) - (with-syntax ([id (datum->syntax #'ctx (syntax-e #'id))] - [n+1 #`#,(+ (syntax-e #'n) 1)]) - #'(let-syntax ([id (make-set!-transformer - (lambda (stx) - (syntax-case stx (set!) - [(set! _ r) #'(vector*-set! self-id n r)] - [(_ arg (... ...)) #'((vector*-ref self-id n) arg (... ...))] - [_ #'(vector*-ref self-id n)])))]) - (let-fields self-id n+1 captureds ctx . bodys)))])) - -(define-syntax (let-methods stx) - (syntax-case stx () - [(_ self-id () ctx body ...) - #'(let () body ...)] - [(_ self-id ((id tmp-id) . methods) ctx . bodys) - (with-syntax ([id (datum->syntax #'ctx (syntax-e #'id))]) - #'(let-syntax ([id (make-method-transformer #'self-id #'tmp-id)]) - (let-methods self-id methods ctx . bodys)))])) - -;; ---------------------------------------- - -(module+ test - (define-constructor (c x y) - (define a 12) - (define-fixnum z 120) - (define (f) - (set! z 130) - (set! y 8) - (list a x (g))) - (define (g) - (list y z)) - (values (method f) - self)) - - (define-values (f f-self) (c 1 2)) - (f f-self)) - diff --git a/racket/src/io/port/input-port.rkt b/racket/src/io/port/input-port.rkt index 58313ffdba..13def442a1 100644 --- a/racket/src/io/port/input-port.rkt +++ b/racket/src/io/port/input-port.rkt @@ -9,9 +9,7 @@ (provide prop:input-port input-port? ->core-input-port - (struct-out core-input-port) - make-core-input-port - compat-input-port-self) + (struct-out core-input-port)) (define-values (prop:input-port input-port-via-property? input-port-ref) (make-struct-type-property 'input-port @@ -147,67 +145,3 @@ (define empty-input-port (new core-input-port [name 'empty])) - -;; ---------------------------------------- - -(class compat-input-port #:extends core-input-port - (field - [self #f])) - -(define (make-core-input-port #:name name - #:data [data #f] - #:self self - #:prepare-change [prepare-change #f] - #:read-byte [read-byte #f] - #:read-in read-in - #:peek-byte [peek-byte #f] - #:peek-in peek-in - #:byte-ready byte-ready - #:close close - #:get-progress-evt [get-progress-evt #f] - #:commit [commit #f] - #:get-location [get-location #f] - #:count-lines! [count-lines! #f] - #:init-offset [init-offset 0] - #:file-position [file-position #f] - #:buffer-mode [buffer-mode #f]) - (new compat-input-port - #:override - ([close (and #t (lambda (in) (close self)))] - [count-lines! (and count-lines! (lambda (in) (count-lines! self)))] - [get-location (and get-location (lambda (in) (get-location self)))] - [file-position (and file-position - (if (input-port? file-position) - file-position - (if (procedure-arity-includes? file-position 2) - (case-lambda - [(in) (file-position self)] - [(in pos) (file-position self pos)]) - (lambda (out) (file-position self)))))] - [buffer-mode - (and buffer-mode (case-lambda - [(in) (buffer-mode self)] - [(in mode) (buffer-mode self mode)]))] - [prepare-change (and prepare-change (lambda (in) (prepare-change self)))] - [read-in - (if (input-port? read-in) - read-in - (lambda (in bstr start end copy?) - (read-in self bstr start end copy?)))] - [peek-in - (if (input-port? peek-in) - peek-in - (lambda (in bstr start end skip progress-evt copy?) - (peek-in self bstr start end skip progress-evt copy?)))] - [byte-ready - (if (input-port? byte-ready) - byte-ready - (lambda (in work-done!) (byte-ready self work-done!)))] - [get-progress-evt (and get-progress-evt (lambda (in) (get-progress-evt self)))] - [commit (and #t (lambda (in amt-k progress-evt? evt? finish) - (commit self amt-k progress-evt? evt? finish)))]) - ;; fields - [name name] - [offset init-offset] - [data data] - [self self])) diff --git a/racket/src/io/port/max-output-port.rkt b/racket/src/io/port/max-output-port.rkt new file mode 100644 index 0000000000..a3accbf5ee --- /dev/null +++ b/racket/src/io/port/max-output-port.rkt @@ -0,0 +1,40 @@ +#lang racket/base +(require "../common/class.rkt" + "../host/thread.rkt" + "output-port.rkt" + "bytes-output.rkt") + +(provide make-max-output-port + max-output-port-max-length) + +(class max-output-port #:extends core-output-port + (field + [o #f] + [max-length 0]) + (override + [write-out + (lambda (src-bstr src-start src-end nonblock? enable-break? copy?) + (cond + [max-length + (define len (- src-end src-start)) + (unless (eq? max-length 'full) + (define write-len (min len max-length)) + (end-atomic) + (define wrote-len (write-bytes src-bstr o src-start (+ src-start write-len))) + (start-atomic) + (if (= max-length wrote-len) + (set! max-length 'full) + (set! max-length (- max-length wrote-len)))) + len] + [else + (end-atomic) + (define len (write-bytes src-bstr o src-start src-end)) + (start-atomic) + len]))])) + +(define (make-max-output-port o max-length) + (new max-output-port + [name (object-name o)] + [evt o] + [o o] + [max-length max-length])) diff --git a/racket/src/io/port/output-port.rkt b/racket/src/io/port/output-port.rkt index 7f2efab6f3..8b752b7c21 100644 --- a/racket/src/io/port/output-port.rkt +++ b/racket/src/io/port/output-port.rkt @@ -10,9 +10,7 @@ output-port? ->core-output-port (struct-out core-output-port) - get-write-evt-via-write-out - make-core-output-port - compat-output-port-self) + get-write-evt-via-write-out) (define-values (prop:output-port output-port-via-property? output-port-ref) (make-struct-type-property 'output-port @@ -120,71 +118,3 @@ (define empty-output-port (new core-output-port [name 'empty])) - -;; ---------------------------------------- - -(class compat-output-port #:extends core-output-port - (field - [self #f])) - -(define (make-core-output-port #:name name - #:data [data #f] - #:self self - #:evt evt - #:write-out write-out - #:close close - #:write-out-special [write-out-special #f] - #:get-write-evt [get-write-evt #f] - #:count-write-evt-via-write-out [count-write-evt-via-write-out #f] - #:get-write-special-evt [get-write-special-evt #f] - #:get-location [get-location #f] - #:count-lines! [count-lines! #f] - #:file-position [file-position #f] - #:init-offset [init-offset 0] - #:buffer-mode [buffer-mode #f]) - (new compat-output-port - #:override - ([close (and #t (lambda (out) (close self)))] - [count-lines! (and count-lines! (lambda (out) (count-lines! self)))] - [get-location (and get-location (lambda (out) (get-location self)))] - [file-position (and file-position - (if (output-port? file-position) - file-position - (if (procedure-arity-includes? file-position 2) - (case-lambda - [(out) (file-position self)] - [(out pos) (file-position self pos)]) - (lambda (out) (file-position self)))))] - [buffer-mode (and buffer-mode (case-lambda - [(out) (buffer-mode self)] - [(out mode) (buffer-mode self mode)]))] - [write-out - (if (output-port? write-out) - write-out - (lambda (out bstr start-k end-k no-block/buffer? enable-break? copy?) - (write-out self bstr start-k end-k no-block/buffer? enable-break? copy?)))] - [write-out-special - (and write-out-special - (if (output-port? write-out-special) - write-out-special - (lambda (out any no-block/buffer? enable-break?) - (write-out-special self any no-block/buffer? enable-break?))))] - [get-write-evt - (cond - [get-write-evt (lambda (out src-bstr src-start src-endv) - (get-write-evt self out src-bstr src-start src-endv))] - [count-write-evt-via-write-out - (get-write-evt-via-write-out - (lambda (out v src-bstr src-start) - (count-write-evt-via-write-out self out v src-bstr src-start)))] - [else #f])] - [get-write-special-evt - (and get-write-special-evt - (lambda (out v) - (get-write-special-evt self v)))]) - ;; fields - [name name] - [offset init-offset] - [evt evt] - [data data] - [self self])) diff --git a/racket/src/io/port/peek-via-read-port.rkt b/racket/src/io/port/peek-via-read-port.rkt index 24486c6a67..478edb295b 100644 --- a/racket/src/io/port/peek-via-read-port.rkt +++ b/racket/src/io/port/peek-via-read-port.rkt @@ -8,8 +8,7 @@ "pipe.rkt" "commit-port.rkt") -(provide peek-via-read-input-port - open-input-peek-via-read) +(provide peek-via-read-input-port) (class peek-via-read-input-port #:extends commit-input-port (field @@ -231,169 +230,3 @@ [close (lambda () (close-peek-buffer))])) - -;; ---------------------------------------- - -(define (open-input-peek-via-read #:name name - #:self next-self - #:data [data #f] - #:read-in read-in - #:read-is-atomic? [read-is-atomic? #f] ; => can implement progress evts - #:close close - #:get-location [get-location #f] - #:count-lines! [count-lines! #f] - #:init-offset [init-offset 0] - #:file-position [file-position #f] - #:alt-buffer-mode [alt-buffer-mode #f]) - (define-values (peek-pipe-i peek-pipe-o) (make-pipe)) - (define peeked-eof? #f) - (define buf (make-bytes 4096)) - (define buffer-mode 'block) - - ;; in atomic mode - (define (prepare-change self) - (send core-input-port peek-pipe-i prepare-change)) - - ;; in atomic mode - (define (pull-some-bytes [amt (if (eq? 'block buffer-mode) (bytes-length buf) 1)] #:keep-eof? [keep-eof? #t]) - (define v (read-in next-self buf 0 amt #f)) - (cond - [(eof-object? v) - (when keep-eof? - (set! peeked-eof? #t)) - eof] - [(evt? v) v] - [(eqv? v 0) 0] - [else - (let loop ([wrote 0]) - (define just-wrote (send core-output-port peek-pipe-o write-out buf wrote v #t #f #f)) - (define next-wrote (+ wrote just-wrote)) - (unless (= v next-wrote) - (loop next-wrote))) - v])) - - (define (retry-pull? v) - (and (integer? v) (not (eqv? v 0)))) - - ;; in atomic mode - (define (do-read-in self dest-bstr start end copy?) - (let try-again () - (cond - [(positive? (pipe-content-length peek-pipe-i)) - (send core-input-port peek-pipe-i read-in dest-bstr start end copy?)] - [peeked-eof? - (set! peeked-eof? #f) - ;; an EOF doesn't count as progress - eof] - [else - (cond - [(and (< (- end start) (bytes-length buf)) - (eq? 'block buffer-mode)) - (define v (pull-some-bytes)) - (cond - [(or (eqv? v 0) (evt? v)) v] - [else (try-again)])] - [else - (define v (read-in next-self dest-bstr start end copy?)) - (unless (eq? v 0) - (progress!)) - v])]))) - - ;; in atomic mode - (define (do-peek-in self dest-bstr start end skip progress-evt copy?) - (let try-again () - (define peeked-amt (if peek-pipe-i - (pipe-content-length peek-pipe-i) - 0)) - (cond - [(and progress-evt - (sync/timeout 0 progress-evt)) - #f] - [(and peek-pipe-i - (peeked-amt . > . skip)) - (send core-input-port peek-pipe-i peek-in dest-bstr start end skip progress-evt copy?)] - [peeked-eof? - eof] - [else - (define v (pull-some-bytes)) - (if (retry-pull? v) - (try-again) - v)]))) - - ;; in atomic mode - (define (do-byte-ready self work-done!) - (cond - [(positive? (pipe-content-length peek-pipe-i)) - #t] - [peeked-eof? - #t] - [else - (define v (pull-some-bytes)) - (work-done!) - (cond - [(retry-pull? v) - (do-byte-ready self void)] - [(evt? v) v] - [else - (not (eqv? v 0))])])) - - ;; in atomic mode - (define (purge-buffer) - (set!-values (peek-pipe-i peek-pipe-o) (make-pipe)) - (set! peeked-eof? #f)) - - ;; in atomic mode - (define (get-progress-evt self) - (send core-input-port peek-pipe-i get-progress-evt)) - - ;; in atomic mode - (define (progress!) - ;; Relies on support for `0 #f #f` arguments in pipe implementation: - (send core-input-port peek-pipe-i commit 0 #f #f void)) - - (define (commit self amt evt ext-evt finish) - (send core-input-port peek-pipe-i commit amt evt ext-evt finish)) - - (define do-buffer-mode - (case-lambda - [(self) buffer-mode] - [(self mode) (set! buffer-mode mode)])) - - (values (make-core-input-port - #:name name - #:data data - #:self #f - - #:prepare-change prepare-change - - #:read-in do-read-in - #:peek-in do-peek-in - #:byte-ready do-byte-ready - - #:get-progress-evt (and read-is-atomic? - get-progress-evt) - #:commit commit - - #:close (lambda (self) - (close next-self) - (purge-buffer)) - - #:get-location (and get-location - (lambda (self) (get-location next-self))) - #:count-lines! (and count-lines! - (lambda (self) (count-lines! next-self))) - #:init-offset init-offset - #:file-position (and file-position - (case-lambda - [(self) (file-position next-self)] - [(self pos) (file-position next-self pos)])) - #:buffer-mode (or (and alt-buffer-mode - (case-lambda - [(self) (alt-buffer-mode next-self)] - [(self mode) (alt-buffer-mode next-self mode)])) - do-buffer-mode)) - - ;; in atomic mode: - (case-lambda - [() (purge-buffer)] - [(pos) (- pos (pipe-content-length peek-pipe-i))]))) diff --git a/racket/src/io/print/write-with-max.rkt b/racket/src/io/print/write-with-max.rkt index 295e4c198f..1040126ac5 100644 --- a/racket/src/io/print/write-with-max.rkt +++ b/racket/src/io/print/write-with-max.rkt @@ -2,7 +2,7 @@ (require "../port/string-output.rkt" "../port/bytes-output.rkt" "../port/port.rkt" - "../port/output-port.rkt") + "../port/max-output-port.rkt") (provide write-string/max write-bytes/max @@ -44,27 +44,8 @@ 'full])])) (define (make-output-port/max o max-length) - (make-core-output-port - #:name (object-name o) - #:data (lambda () max-length) - #:self o - #:evt o - #:write-out - (lambda (o src-bstr src-start src-end nonblock? enable-break? copy?) - (cond - [max-length - (define len (- src-end src-start)) - (unless (eq? max-length 'full) - (define write-len (min len max-length)) - (define wrote-len (write-bytes src-bstr o src-start (+ src-start write-len))) - (if (= max-length wrote-len) - (set! max-length 'full) - (set! max-length (- max-length wrote-len)))) - len] - [else - (write-bytes src-bstr o src-start src-end)])) - #:close void)) + (make-max-output-port o max-length)) (define (output-port/max-max-length o max-length) (and max-length - ((core-port-data o)))) + (max-output-port-max-length o)))