diff --git a/collects/mzlib/contract.ss b/collects/mzlib/contract.ss index a07bee7..ac8a793 100644 --- a/collects/mzlib/contract.ss +++ b/collects/mzlib/contract.ss @@ -31,7 +31,8 @@ (require (except-in scheme/private/contract define/contract - with-contract) + with-contract + define-struct/contract) scheme/private/contract-guts scheme/private/contract-ds scheme/private/contract-opt diff --git a/collects/mzlib/deflate.ss b/collects/mzlib/deflate.ss index c3c4f99..c0f89d1 100644 --- a/collects/mzlib/deflate.ss +++ b/collects/mzlib/deflate.ss @@ -14,14 +14,21 @@ (require "unit200.ss") + (define (vector-ref* v i) + (let ([r (vector-ref v i)]) + (if (<= 0 r 255) r (error 'vector-ref "BOOM: ~s" r)))) + + (define (vector-set!* v i n) + (if (<= 0 n 255) (vector-set! v i n) (error 'vector-ref "BOOM!: ~s" n))) + (define-syntax INSERT_STRING (syntax-rules () [(_ s match_head UPDATE_HASH window-vec head-vec prev-vec ins_h) - #'(begin (UPDATE_HASH (vector-ref window-vec (+ s MIN_MATCH-1))) - (let ([mh (vector-ref head-vec (+ ins_h head-vec-delta))]) - (set! match_head mh) - (vector-set! prev-vec (bitwise-and s WMASK) mh)) - (vector-set! head-vec (+ head-vec-delta ins_h) s))])) + (begin (UPDATE_HASH (bytes-ref window-vec (+ s MIN_MATCH-1))) + (let ([mh (vector-ref head-vec (+ ins_h head-vec-delta))]) + (set! match_head mh) + (vector-set! prev-vec (bitwise-and s WMASK) mh)) + (vector-set! head-vec (+ head-vec-delta ins_h) s))])) (define-syntax pqremove (syntax-rules () @@ -44,28 +51,13 @@ (let loop ([n start]) (when (< n endval) body ... (loop (next n)))))])) - (define-struct gzvector (vector offset)) - (define (gzvector-ref v o) - (vector-ref (gzvector-vector v) (+ (gzvector-offset v) o))) - (define (gzvector-set! v o x) - (vector-set! (gzvector-vector v) (+ (gzvector-offset v) o) x)) - (define (gzvector+ v o) - (make-gzvector (gzvector-vector v) (+ (gzvector-offset v) o))) - - (define (gzvector= prev_length good_match) @@ -474,10 +465,10 @@ (longest_match-loop))) (define (*++scan) (set! scanpos (add1 scanpos)) - (vector-ref window-vec scanpos)) + (bytes-ref window-vec scanpos)) (define (*++match) (set! matchpos (add1 matchpos)) - (vector-ref window-vec matchpos)) + (bytes-ref window-vec matchpos)) (define (match-eight) (when (and (eq? (*++scan) (*++match)) (eq? (*++scan) (*++match)) @@ -499,12 +490,12 @@ ;; * or if the match length is less than 2: ;; */ - (if (or (not (eq? (vector-ref window-vec (+ matchpos best_len)) scan_end)) - (not (eq? (vector-ref window-vec (+ matchpos best_len -1)) scan_end1)) - (not (eq? (vector-ref window-vec matchpos) (vector-ref window-vec scanpos))) + (if (or (not (eq? (bytes-ref window-vec (+ matchpos best_len)) scan_end)) + (not (eq? (bytes-ref window-vec (+ matchpos best_len -1)) scan_end1)) + (not (eq? (bytes-ref window-vec matchpos) (bytes-ref window-vec scanpos))) (not (eq? (begin (set! matchpos (add1 matchpos)) - (vector-ref window-vec matchpos)) - (vector-ref window-vec (add1 scanpos))))) + (bytes-ref window-vec matchpos)) + (bytes-ref window-vec (add1 scanpos))))) (continue) (begin @@ -534,8 +525,8 @@ (if (>= len nice_match) #f (begin - (set! scan_end1 (vector-ref window-vec (+ scanpos best_len -1))) - (set! scan_end (vector-ref window-vec (+ scanpos best_len))) + (set! scan_end1 (bytes-ref window-vec (+ scanpos best_len -1))) + (set! scan_end (bytes-ref window-vec (+ scanpos best_len))) #t))) #t)) (continue))))) @@ -564,7 +555,8 @@ ;; * move the upper half to the lower one to make room in the upper half. ;; */ (when (>= strstart (+ WSIZE MAX_DIST)) - (gzvector-copy window (gzvector+ window WSIZE) WSIZE) + (let ([bs (gzbytes-bytes window)] [ofs (gzbytes-offset window)]) + (bytes-copy! bs ofs bs (+ ofs WSIZE) (+ ofs WSIZE WSIZE))) (set! match_start (- match_start WSIZE)) (set! strstart (- strstart WSIZE)) ;; /* we now have strstart >= MAX_DIST: */ @@ -597,9 +589,7 @@ ;; * IN assertion: strstart is set to the end of the current match. ;; */ (define (FLUSH-BLOCK eof) - (flush_block (if (>= block_start 0) - (gzvector+ window block_start) - null) + (flush_block (and (>= block_start 0) (gzbytes+ window block_start)) (- strstart block_start) eof)) @@ -620,7 +610,7 @@ (when (not (zero? lookahead)) (DEBUG (Trace stderr "prep ~a ~a ~a ~a ~a ~a ~a ~a ~a ~a\n" hash_head prev_length match_length max_lazy_match strstart - ins_h (+ strstart MIN_MATCH-1) (vector-ref window-vec (+ strstart MIN_MATCH-1)) + ins_h (+ strstart MIN_MATCH-1) (bytes-ref window-vec (+ strstart MIN_MATCH-1)) H_SHIFT HASH_MASK)) ;; /* Insert the string window[strstart .. strstart+2] in the @@ -630,7 +620,7 @@ (DEBUG (Trace stderr "inh ~a ~a ~a ~a ~a ~a ~a\n" hash_head prev_length match_length max_lazy_match strstart - ins_h (vector-ref window-vec (+ strstart MIN_MATCH-1)))) + ins_h (bytes-ref window-vec (+ strstart MIN_MATCH-1)))) ;; /* Find the longest match, discarding those <= prev_length. ;; */ @@ -682,7 +672,7 @@ (INSERT_STRING strstart hash_head UPDATE_HASH window-vec head-vec prev-vec ins_h) (DEBUG (Trace stderr "inhx ~a ~a ~a ~a ~a ~a\n" hash_head prev_length max_lazy_match strstart - ins_h (vector-ref window-vec (+ strstart MIN_MATCH -1)))) + ins_h (bytes-ref window-vec (+ strstart MIN_MATCH -1)))) ;; /* strstart never exceeds WSIZE-MAX_MATCH, so there are ;; * always MIN_MATCH bytes ahead. If lookahead < MIN_MATCH ;; * these bytes are garbage, but it does not matter since the @@ -707,7 +697,7 @@ ;; * is longer, truncate the previous match to a single literal. ;; */ ;; (Tracevv stderr "~c" (integer->char (vector-ref window-vec (- strstart 1)))) - (when (ct_tally 0 (vector-ref window-vec (- strstart 1))) + (when (ct_tally 0 (bytes-ref window-vec (- strstart 1))) (FLUSH-BLOCK 0) (set! block_start strstart)) (set! strstart (add1 strstart)) @@ -742,7 +732,7 @@ (dloop))) (when match_available - (ct_tally 0 (vector-ref window-vec (- strstart 1)))) + (ct_tally 0 (bytes-ref window-vec (- strstart 1)))) (FLUSH-BLOCK 1)); /* eof */ @@ -984,7 +974,7 @@ (define base_dist (make-vector D_CODES 0)) ;; /* First normalized distance for each code (0 = distance of 1) */ -(define inbuf (make-gzvector (make-vector (+ INBUFSIZ INBUF_EXTRA) 0) 0)) +(define inbuf (make-bytes (+ INBUFSIZ INBUF_EXTRA) 0)) (define l_buf inbuf) ;; /* DECLARE(uch, l_buf, LIT_BUFSIZE); buffer for literals or lengths */ @@ -1674,8 +1664,7 @@ ;; * the whole file is transformed into a stored file: ;; */ (cond - [(and (<= (+ stored_len 4) opt_lenb) - (not (null? buf))) + [(and buf (<= (+ stored_len 4) opt_lenb)) ;; /* 4: two words for the lengths */ ;; /* The test buf != NULL is only necessary if LIT_BUFSIZE > WSIZE. @@ -1732,7 +1721,7 @@ (set! dist _dist) - (gzvector-set! l_buf last_lit lc) + (bytes-set! l_buf last_lit lc) (set! last_lit (add1 last_lit)) (if (= dist 0) ;; /* lc is the unmatched char */ @@ -1816,7 +1805,7 @@ (set! flag (vector-ref flag_buf fx)) (set! fx (add1 fx))) - (set! lc (gzvector-ref l_buf lx)) + (set! lc (bytes-ref l_buf lx)) (set! lx (add1 lx)) (cond @@ -1999,7 +1988,7 @@ (loop (bitwise-xor (vector-ref crc_32_tab (bitwise-and - (bitwise-xor c (vector-ref window-vec (+ s p))) + (bitwise-xor c (bytes-ref window-vec (+ s p))) #xff)) (arithmetic-shift c -8)) (add1 p)))) @@ -2073,12 +2062,12 @@ (when header (put_short len) - (put_short (bitwise-not len)) + (put_short (bitwise-and (bitwise-not len) #xFFFF)) (set! bits_sent (+ bits_sent (* 2 16)))) (set! bits_sent (+ bits_sent (<< len 3))) - (for pos := 0 < len do (put_byte (gzvector-ref buf pos)))) + (for pos := 0 < len do (put_byte (gzbytes-ref buf pos)))) ;; /* =========================================================================== ;; * Read a new buffer from the current input file, perform end-of-line @@ -2093,41 +2082,37 @@ ;; (unless (= insize 0) ;; (error "inbuf not empty")) - (let* ([s (read-bytes size ifd)] - [len (if (eof-object? s) - EOF-const - (bytes-length s))]) + (let* ([s (read-bytes! window-vec ifd startpos (+ size startpos))] + [len (if (eof-object? s) EOF-const s)]) (when (positive? len) - (let rloop ([p 0]) - (unless (= p len) - (vector-set! window-vec (+ p startpos) (bytes-ref s p)) - (rloop (add1 p)))) - (updcrc startpos len) (set! bytes_in (+ bytes_in len))) - len)) ;; Assumes being called with c in 0..FF -(define (put_byte c) - (bytes-set! outbuf outcnt c) - (set! outcnt (add1 outcnt)) - (when (= outcnt OUTBUFSIZ) (flush_outbuf))) +(define-syntax put_byte + (syntax-rules () + [(_ c) + (begin (bytes-set! outbuf outcnt c) + (set! outcnt (add1 outcnt)) + (when (= outcnt OUTBUFSIZ) (flush_outbuf)))])) ;; /* Output a 16 bit value, lsb first */ ;; Assumes being called with c in 0..FFFF (define (put_short w) (if (< outcnt (- OUTBUFSIZ 2)) (begin (bytes-set! outbuf outcnt (bitwise-and #xFF w)) - (bytes-set! outbuf (add1 outcnt) (bitwise-and #xFF (>> w 8))) + (bytes-set! outbuf (add1 outcnt) (>> w 8)) + ;; this is not faster... + ;; (integer->integer-bytes w 2 #f #f outbuf outcnt) (set! outcnt (+ outcnt 2))) (begin (put_byte (bitwise-and #xFF w)) (put_byte (>> w 8))))) ;; /* Output a 32 bit value to the bit stream, lsb first */ (define (put_long n) - (put_short n) - (put_short (>> n 16))) + (put_short (bitwise-and #xFFFF n)) + (put_short (bitwise-and #xFFFF (>> n 16)))) (define outcnt 0) (define bytes_out 0) @@ -2207,7 +2192,7 @@ (put_byte 3) ;; /* OS identifier */ (when origname - (for-each put_byte (bytes->list origname)) + (for-each (lambda (b) (put_byte b)) (bytes->list origname)) (put_byte 0)) (do-deflate) diff --git a/collects/mzlib/foreign.ss b/collects/mzlib/foreign.ss index 5ca2e24..00d2cce 100644 --- a/collects/mzlib/foreign.ss +++ b/collects/mzlib/foreign.ss @@ -1,1620 +1,4 @@ -#lang scheme/base -;; Foreign Scheme interface -(require '#%foreign setup/dirs - (for-syntax scheme/base scheme/list syntax/stx)) - -;; This module is full of unsafe bindings that are not provided to requiring -;; modules. Instead, an `unsafe!' binding is provided that makes these unsafe -;; bindings available. The following two syntaxes do that: `provide*' is like -;; `provide', but using `(unsafe id)' registers an unsafe binding. Then, -;; `define-unsafer' should be used with a binding that will expose the unsafe -;; bindings. This might move elsewhere at some point if it turns out to be -;; useful in other contexts. -(provide provide* define-unsafer) -(define-syntaxes (provide* define-unsafer) - (let ((unsafe-bindings '())) - (values - (lambda (stx) - (syntax-case stx () - [(_ p ...) - (let loop ([provides '()] - [unsafes '()] - [ps (syntax->list #'(p ...))]) - (if (null? ps) - (begin (set! unsafe-bindings - (append unsafe-bindings (reverse unsafes))) - (with-syntax ([(p ...) provides]) #'(provide p ...))) - (syntax-case (car ps) (unsafe) - [(unsafe u) - (syntax-case #'u (rename-out) - [(rename-out [from to]) - (loop provides (cons (cons #'from #'to) unsafes) (cdr ps))] - [id (identifier? #'id) - (loop provides (cons (cons #'id #'id) unsafes) (cdr ps))] - [_ - (raise-syntax-error 'provide* "bad unsafe usage" - (car ps) stx)])] - [_ (loop (cons (car ps) provides) unsafes (cdr ps))])))])) - (lambda (stx) - (syntax-case stx () - [(_ unsafe) - (with-syntax ([(from ...) (map car unsafe-bindings)] - [(to ...) (map cdr unsafe-bindings)] - [(id ...) (generate-temporaries unsafe-bindings)]) - (set! unsafe-bindings '()) - #'(begin - (provide (protect-out unsafe)) - (define-syntax (unsafe stx) - (syntax-case stx () - [(_) (with-syntax ([(id ...) (list (datum->syntax - stx 'to stx) - ...)]) - #'(begin (define-syntax id - (make-rename-transformer #'from)) - ...))]))))]))))) - -(provide* ctype-sizeof ctype-alignof compiler-sizeof - (unsafe malloc) (unsafe free) (unsafe end-stubborn-change) - cpointer? ptr-equal? ptr-add (unsafe ptr-ref) (unsafe ptr-set!) - ptr-offset ptr-add! offset-ptr? set-ptr-offset! - ctype? make-ctype make-cstruct-type (unsafe make-sized-byte-string) ctype->layout - _void _int8 _uint8 _int16 _uint16 _int32 _uint32 _int64 _uint64 - _fixint _ufixint _fixnum _ufixnum - _float _double _double* - _bool _pointer _scheme _fpointer function-ptr - (unsafe memcpy) (unsafe memmove) (unsafe memset) - (unsafe malloc-immobile-cell) (unsafe free-immobile-cell)) - -(define-syntax define* - (syntax-rules () - [(_ (name . args) body ...) - (begin (provide name) (define (name . args) body ...))] - [(_ name expr) - (begin (provide name) (define name expr))])) - -;; ---------------------------------------------------------------------------- -;; C integer types - -(define* _sint8 _int8) -(define* _sint16 _int16) -(define* _sint32 _int32) -(define* _sint64 _int64) - -;; _byte etc is a convenient name for _uint8 & _sint8 -;; (_byte is unsigned) -(define* _byte _uint8) -(define* _ubyte _uint8) -(define* _sbyte _int8) - -;; _word etc is a convenient name for _uint16 & _sint16 -;; (_word is unsigned) -(define* _word _uint16) -(define* _uword _uint16) -(define* _sword _int16) - -;; _short etc is a convenient name for whatever is the compiler's `short' -;; (_short is signed) -(provide _short _ushort _sshort) -(define-values (_short _ushort _sshort) - (case (compiler-sizeof 'short) - [(2) (values _int16 _uint16 _int16)] - [(4) (values _int32 _uint32 _int32)] - [else (error 'foreign "internal error: bad compiler size for `short'")])) - -;; _int etc is a convenient name for whatever is the compiler's `int' -;; (_int is signed) -(provide _int _uint _sint) -(define-values (_int _uint _sint) - (case (compiler-sizeof 'int) - [(2) (values _int16 _uint16 _int16)] - [(4) (values _int32 _uint32 _int32)] - [(8) (values _int64 _uint64 _int64)] - [else (error 'foreign "internal error: bad compiler size for `int'")])) - -;; _long etc is a convenient name for whatever is the compiler's `long' -;; (_long is signed) -(provide _long _ulong _slong) -(define-values (_long _ulong _slong) - (case (compiler-sizeof 'long) - [(4) (values _int32 _uint32 _int32)] - [(8) (values _int64 _uint64 _int64)] - [else (error 'foreign "internal error: bad compiler size for `long'")])) - -;; _llong etc is a convenient name for whatever is the compiler's `long long' -;; (_llong is signed) -(provide _llong _ullong _sllong) -(define-values (_llong _ullong _sllong) - (case (compiler-sizeof '(long long)) - [(4) (values _int32 _uint32 _int32)] - [(8) (values _int64 _uint64 _int64)] - [else (error 'foreign "internal error: bad compiler size for `llong'")])) - -;; ---------------------------------------------------------------------------- -;; Getting and setting library objects - -(define lib-suffix (bytes->string/latin-1 (subbytes (system-type 'so-suffix) 1))) -(define lib-suffix-re (regexp (string-append "\\." lib-suffix "$"))) -(define suffix-before-version? (not (equal? lib-suffix "dylib"))) - -(provide* (unsafe (rename-out [get-ffi-lib ffi-lib])) - ffi-lib? ffi-lib-name) -(define get-ffi-lib - (case-lambda - [(name) (get-ffi-lib name "")] - [(name version/s) - (cond - [(not name) (ffi-lib name)] ; #f => NULL => open this executable - [(not (or (string? name) (path? name))) - (raise-type-error 'ffi-lib "library-name" name)] - [else - ;; A possible way that this might be misleading: say that there is a - ;; "foo.so" file in the current directory, which refers to some - ;; undefined symbol, trying to use this function with "foo.so" will try - ;; a dlopen with "foo.so" which isn't found, then it tries a dlopen with - ;; "//foo.so" which fails because of the undefined symbol, and - ;; since all fails, it will use (ffi-lib "foo.so") to raise the original - ;; file-not-found error. This is because the dlopen doesn't provide a - ;; way to distinguish different errors (only dlerror, but that's - ;; unreliable). - (let* ([versions (if (list? version/s) version/s (list version/s))] - [versions (map (lambda (v) - (if (or (not v) (zero? (string-length v))) - "" (string-append "." v))) - versions)] - [fullpath (lambda (p) (path->complete-path (cleanse-path p)))] - [absolute? (absolute-path? name)] - [name0 (path->string (cleanse-path name))] ; orig name - [names (map (if (regexp-match lib-suffix-re name0) ; name+suffix - (lambda (v) (string-append name0 v)) - (lambda (v) - (if suffix-before-version? - (string-append name0 "." lib-suffix v) - (string-append name0 v "." lib-suffix)))) - versions)] - [ffi-lib* (lambda (name) (ffi-lib name #t))]) - (or ;; try to look in our library paths first - (and (not absolute?) - (ormap (lambda (dir) - ;; try good names first, then original - (or (ormap (lambda (name) - (ffi-lib* (build-path dir name))) - names) - (ffi-lib* (build-path dir name0)))) - (get-lib-search-dirs))) - ;; try a system search - (ormap ffi-lib* names) ; try good names first - (ffi-lib* name0) ; try original - (ormap (lambda (name) ; try relative paths - (and (file-exists? name) (ffi-lib* (fullpath name)))) - names) - (and (file-exists? name0) ; relative with original - (ffi-lib* (fullpath name0))) - ;; give up: call ffi-lib so it will raise an error - (ffi-lib (car names))))])])) - -(define (get-ffi-lib-internal x) - (if (ffi-lib? x) x (get-ffi-lib x))) - -;; These internal functions provide the functionality to be used by -;; get-ffi-obj, set-ffi-obj! and define-c below -(define (ffi-get ffi-obj type) - (ptr-ref ffi-obj type)) -(define (ffi-set! ffi-obj type new) - (let-values ([(new type) (get-lowlevel-object new type)]) - (hash-set! ffi-objects-ref-table ffi-obj new) - (ptr-set! ffi-obj type new))) - -;; This is better handled with `make-c-parameter' -(provide* (unsafe ffi-obj-ref)) -(define ffi-obj-ref - (case-lambda - [(name lib) (ffi-obj-ref name lib #f)] - [(name lib failure) - (let ([name (get-ffi-obj-name 'ffi-obj-ref name)] - [lib (get-ffi-lib-internal lib)]) - (with-handlers ([exn:fail:filesystem? - (lambda (e) (if failure (failure) (raise e)))]) - (ffi-obj name lib)))])) - -;; get-ffi-obj is implemented as a syntax only to be able to propagate the -;; foreign name into the type syntax, which allows generated wrappers to have a -;; proper name. -(provide* (unsafe get-ffi-obj)) -(define get-ffi-obj* - (case-lambda - [(name lib type) (get-ffi-obj* name lib type #f)] - [(name lib type failure) - (let ([name (get-ffi-obj-name 'get-ffi-obj name)] - [lib (get-ffi-lib-internal lib)]) - (let-values ([(obj error?) - (with-handlers - ([exn:fail:filesystem? - (lambda (e) - (if failure (values (failure) #t) (raise e)))]) - (values (ffi-obj name lib) #f))]) - (if error? obj (ffi-get obj type))))])) -(define-syntax (get-ffi-obj stx) - (syntax-case stx () - [(_ name lib type) - #`(get-ffi-obj* name lib #,(syntax-property #`type 'ffi-name #'name))] - [(_ name lib type failure) - #`(get-ffi-obj* name lib #,(syntax-property #`type 'ffi-name #'name) - failure)] - [x (identifier? #'x) #'get-ffi-obj*])) - -;; It is important to use the set-ffi-obj! wrapper because it takes care of -;; keeping a handle on the object -- otherwise, setting a callback hook will -;; crash when the Scheme function is gone. -(provide* (unsafe set-ffi-obj!)) -(define (set-ffi-obj! name lib type new) - (ffi-set! (ffi-obj (get-ffi-obj-name 'set-ffi-obj! name) - (get-ffi-lib-internal lib)) - type new)) - -;; Combining the above two in a `define-c' special form which makes a Scheme -;; `binding', first a `parameter'-like constructor: -(provide* (unsafe make-c-parameter)) -(define (make-c-parameter name lib type) - (let ([obj (ffi-obj (get-ffi-obj-name 'make-c-parameter name) - (get-ffi-lib-internal lib))]) - (case-lambda [() (ffi-get obj type)] - [(new) (ffi-set! obj type new)]))) -;; Then the fake binding syntax, uses the defined identifier to name the -;; object: -(provide* (unsafe define-c)) -(define-syntax (define-c stx) - (syntax-case stx () - [(_ var-name lib-name type-expr) - (with-syntax ([(p) (generate-temporaries (list #'var-name))]) - (namespace-syntax-introduce - #'(begin (define p (make-c-parameter 'var-name lib-name type-expr)) - (define-syntax var-name - (syntax-id-rules (set!) - [(set! var val) (p val)] - [(var . xs) ((p) . xs)] - [var (p)])))))])) - -;; Used to convert strings and symbols to a byte-string that names an object -(define (get-ffi-obj-name who objname) - (cond [(bytes? objname) objname] - [(symbol? objname) (get-ffi-obj-name who (symbol->string objname))] - [(string? objname) (string->bytes/utf-8 objname)] - [else (raise-type-error who "object-name" objname)])) - -;; This table keeps references to values that are set in foreign libraries, to -;; avoid them being GCed. See set-ffi-obj! above. -(define ffi-objects-ref-table (make-hasheq)) - -;; ---------------------------------------------------------------------------- -;; Compile-time support for fun-expanders - -(begin-for-syntax - - ;; The `_fun' macro tears its input apart and reassemble it using pieces from - ;; custom function types (macros). This whole deal needs some work to make - ;; it play nicely with code certificates, so Matthew wrote the following - ;; code. The idea is to create a define-fun-syntax which makes the new - ;; syntax transformer be an object that carries extra information, later used - ;; by `expand-fun-syntax/fun'. - - (define fun-cert-key (gensym)) - - ;; bug in begin-for-syntax (PR7104), see below - (define foo!!! (make-parameter #f)) - (define (expand-fun-syntax/normal fun-stx stx) - ((foo!!!) fun-stx stx)) - - (define-values (make-fun-syntax fun-syntax? - fun-syntax-proc fun-syntax-certifier fun-syntax-name) - (let-values ([(desc make pred? get set!) - (make-struct-type - 'fun-syntax #f 3 0 #f '() (current-inspector) - expand-fun-syntax/normal)]) - (values make pred? - (make-struct-field-accessor get 0 'proc) - (make-struct-field-accessor get 1 'certifier) - (make-struct-field-accessor get 2 'name)))) - - ;; This is used to expand a fun-syntax in a _fun type context. - (define (expand-fun-syntax/fun stx) - (let loop ([stx stx]) - (define (do-expand id id?) ; id? == are we expanding an identifier? - (define v (syntax-local-value id (lambda () #f))) - (define set!-trans? (set!-transformer? v)) - (define proc (if set!-trans? (set!-transformer-procedure v) v)) - (if (and (fun-syntax? proc) (or (not id?) set!-trans?)) - ;; Do essentially the same thing that `local-expand' does. - ;; First, create an "introducer" to mark introduced identifiers: - (let* ([introduce (make-syntax-introducer)] - [expanded - ;; Re-introduce mark related to expansion of `_fun': - (syntax-local-introduce - ;; Re-add mark specific to this expansion, cancelling - ;; some marks applied before expanding (leaving only - ;; introuced syntax marked) - (introduce - ;; Actually expand: - ((fun-syntax-proc proc) - ;; Add mark specific to this expansion: - (introduce - ;; Remove mark related to expansion of `_fun': - (syntax-local-introduce stx)))))]) - ;; Certify based on definition of expander, then loop - ;; to continue expanding: - (loop ((fun-syntax-certifier proc) - expanded fun-cert-key introduce))) - stx)) - (syntax-case stx () - [(id . rest) (identifier? #'id) (do-expand #'id #f)] - [id (identifier? #'id) (do-expand #'id #t)] - [_else stx]))) - - ;; Use module-or-top-identifier=? because we use keywords like `=' and want - ;; to make it possible to play with it at the toplevel. - (define id=? module-or-top-identifier=?) - - (define (split-by key args) - (let loop ([args args] [r (list '())]) - (cond [(null? args) (reverse (map reverse r))] - [(eq? key (car args)) (loop (cdr args) (cons '() r))] - [else (loop (cdr args) - (cons (cons (car args) (car r)) (cdr r)))]))) - - (define (add-renamer body from to) - (with-syntax ([body body] [from from] [to to]) - #'(let-syntax ([to (syntax-id-rules () - [(_?_ . _rest_) (from . _rest_)] [_?_ from])]) - body))) - - (define (custom-type->keys type err) - (define stops (map (lambda (s) (datum->syntax type s #f)) - '(#%app #%top #%datum))) - ;; Expand `type' using expand-fun-syntax/fun - (define orig (expand-fun-syntax/fun type)) - (define (with-arg x) - (syntax-case* x (=>) id=? - [(id => body) (identifier? #'id) - ;; Extract #'body from its context, use a key it needs certification: - (list (syntax-recertify #'id orig #f fun-cert-key) - (syntax-recertify #'body orig #f fun-cert-key))] - [_else x])) - (define (cert-id id) - (syntax-recertify id orig #f fun-cert-key)) - (let ([keys '()]) - (define (setkey! key val . id?) - (cond - [(assq key keys) - (err "bad expansion of custom type (two `~a:'s)" key type)] - [(and (pair? id?) (car id?) (not (identifier? val))) - (err "bad expansion of custom type (`~a:' expects an identifier)" - key type)] - [else (set! keys (cons (cons key val) keys))])) - (let loop ([t orig]) - (define (next rest . args) (apply setkey! args) (loop rest)) - (syntax-case* t (type: expr: bind: 1st-arg: prev-arg: pre: post:) id=? - [(type: t x ...) (next #'(x ...) 'type #'t)] - [(expr: e x ...) (next #'(x ...) 'expr #'e)] - [(bind: id x ...) (next #'(x ...) 'bind (cert-id #'id) #t)] - [(1st-arg: id x ...) (next #'(x ...) '1st (cert-id #'id) #t)] - [(prev-arg: id x ...) (next #'(x ...) 'prev (cert-id #'id) #t)] - ;; in the following two cases pass along orig for recertifying - [(pre: p x ...) (next #'(x ...) 'pre (with-arg #'p))] - [(post: p x ...) (next #'(x ...) 'post (with-arg #'p))] - [() (and (pair? keys) keys)] - [_else #f])))) - - ;; This is used for a normal expansion of fun-syntax, when not in a _fun type - ;; context. - ;; bug in begin-for-syntax (PR7104), see above - ;; should be (define (expand-fun-syntax/normal fun-stx stx) ...) - (foo!!! (lambda (fun-stx stx) - (define (err msg . sub) - (apply raise-syntax-error (fun-syntax-name fun-stx) msg stx sub)) - (let ([keys (custom-type->keys stx err)]) - (define (getkey key) (cond [(assq key keys) => cdr] [else #f])) - (define (notkey key) - (when (getkey key) - (err (format "this type must be used in a _fun expression (uses ~s)" - key)))) - (if keys - (let ([type (getkey 'type)] [pre (getkey 'pre)] [post (getkey 'post)]) - (unless type - (err "this type must be used in a _fun expression (#f type)")) - (for-each notkey '(expr bind 1st prev)) - (if (or pre post) - ;; a type with pre/post blocks - (let ([make-> (lambda (x what) - (cond [(not x) #'#f] - [(and (list? x) (= 2 (length x)) - (identifier? (car x))) - #`(lambda (#,(car x)) #,(cadr x))] - [else #`(lambda (_) - (error '#,(fun-syntax-name fun-stx) - "cannot be used to ~a" - #,what))]))]) - (with-syntax ([type type] - [scheme->c (make-> pre "send values to C")] - [c->scheme (make-> post "get values from C")]) - #'(make-ctype type scheme->c c->scheme))) - ;; simple type - type)) - ;; no keys => normal expansion - ((fun-syntax-proc fun-stx) stx)))))) - -;; Use define-fun-syntax instead of define-syntax for forms that -;; are to be expanded by `_fun': -(provide define-fun-syntax) -(define-syntax define-fun-syntax - (syntax-rules () - [(_ id trans) - (define-syntax id - (let* ([xformer trans] - [set!-trans? (set!-transformer? xformer)]) - (unless (or (and (procedure? xformer) - (procedure-arity-includes? xformer 1)) - set!-trans?) - (raise-type-error 'define-fun-syntax - "procedure (arity 1) or set!-transformer" - xformer)) - (let ([f (make-fun-syntax (if set!-trans? - (set!-transformer-procedure xformer) - xformer) - ;; Capture definition-time certificates: - (syntax-local-certifier) - 'id)]) - (if set!-trans? (make-set!-transformer f) f))))])) - -;; ---------------------------------------------------------------------------- -;; Function type - -;; Creates a simple function type that can be used for callouts and callbacks, -;; optionally applying a wrapper function to modify the result primitive -;; (callouts) or the input procedure (callbacks). -(define* (_cprocedure itypes otype - #:abi [abi #f] - #:wrapper [wrapper #f] - #:keep [keep #f] - #:atomic? [atomic? #f]) - (_cprocedure* itypes otype abi wrapper keep atomic?)) - -;; for internal use -(define held-callbacks (make-weak-hasheq)) -(define (_cprocedure* itypes otype abi wrapper keep atomic?) - (define-syntax-rule (make-it wrap) - (make-ctype _fpointer - (lambda (x) - (and x - (let ([cb (ffi-callback (wrap x) itypes otype abi atomic?)]) - (cond [(eq? keep #t) (hash-set! held-callbacks x cb)] - [(box? keep) - (let ([x (unbox keep)]) - (set-box! keep - (if (or (null? x) (pair? x)) (cons cb x) cb)))] - [(procedure? keep) (keep cb)]) - cb))) - (lambda (x) (and x (wrap (ffi-call x itypes otype abi)))))) - (if wrapper (make-it wrapper) (make-it begin))) - -;; Syntax for the special _fun type: -;; (_fun [{(name ... [. name]) | name} [-> expr] ::] -;; {type | (name : type [= expr]) | ([name :] type = expr)} ... -;; -> {type | (name : type)} -;; [-> expr]) -;; Usage: -;; `{(name ...) | ...} ::' specify explicit wrapper function formal arguments -;; `-> expr' can be used instead of the last expr -;; `type' input type (implies input, but see type macros next) -;; `(name : type = expr)' specify name and type, `= expr' means computed input -;; `-> type' output type (possibly with name) -;; `-> expr' specify different output, can use previous names -;; Also, see below for custom function types. - -(provide ->) ; to signal better errors when trying to use this with contracts -(define-syntax -> - (syntax-id-rules () - [_ (raise-syntax-error '-> "should be used only in a _fun context")])) - -(provide _fun) -(define-syntax (_fun stx) - (define (err msg . sub) (apply raise-syntax-error '_fun msg stx sub)) - (define xs #f) - (define abi #f) - (define keep #f) - (define atomic? #f) - (define inputs #f) - (define output #f) - (define bind '()) - (define pre '()) - (define post '()) - (define input-names #f) - (define output-type #f) - (define output-expr #f) - (define 1st-arg #f) - (define prev-arg #f) - (define (bind! x) (set! bind (append bind (list x)))) - (define (pre! x) (set! pre (append pre (list x)))) - (define (post! x) (set! post (append post (list x)))) - (define ((t-n-e clause) type name expr) - (let ([keys (custom-type->keys type err)]) - (define (getkey key) (cond [(assq key keys) => cdr] [else #f])) - (define (arg x . no-expr?) - (define use-expr? - (and (list? x) (= 2 (length x)) (identifier? (car x)))) - ;; when the current expr is not used with a (x => ...) form, - ;; either check that no expression is given or just make it - ;; disappear from the inputs. - (unless use-expr? - (if (and (pair? no-expr?) (car no-expr?) expr) - (err "got an expression for a custom type that do not use it" - clause) - (set! expr (void)))) - (set! x (if use-expr? (add-renamer (cadr x) name (car x)) x)) - (cond [(getkey '1st) => - (lambda (v) - (if 1st-arg - (set! x (add-renamer x 1st-arg v)) - (err "got a custom type that wants 1st arg too early" - clause)))]) - (cond [(getkey 'prev) => - (lambda (v) - (if prev-arg - (set! x (add-renamer x prev-arg v)) - (err "got a custom type that wants prev arg too early" - clause)))]) - x) - (when keys - (set! type (getkey 'type)) - (cond [(and (not expr) (getkey 'expr)) => (lambda (x) (set! expr x))]) - (cond [(getkey 'bind) => (lambda (x) (bind! #`[#,x #,name]))]) - (cond [(getkey 'pre) => (lambda (x) (pre! #`[#,name #,(arg x #t)]))]) - (cond [(getkey 'post) => (lambda (x) (post! #`[#,name #,(arg x)]))])) - ;; turn a #f syntax to #f - (set! type (and type (syntax-case type () [#f #f] [_ type]))) - (when type ; remember these for later usages - (unless 1st-arg (set! 1st-arg name)) - (set! prev-arg name)) - (list type name expr))) - (define (do-fun) - ;; parse keywords - (let loop () - (let ([k (and (pair? xs) (pair? (cdr xs)) (syntax-e (car xs)))]) - (define-syntax-rule (kwds [key var] ...) - (case k - [(key) (if var - (err (format "got a second ~s keyword") 'key (car xs)) - (begin (set! var (cadr xs)) (set! xs (cddr xs)) (loop)))] - ... - [else (err "unknown keyword" (car xs))])) - (when (keyword? k) (kwds [#:abi abi] [#:keep keep] [#:atomic? atomic?])))) - (unless abi (set! abi #'#f)) - (unless keep (set! keep #'#t)) - (unless atomic? (set! atomic? #'#f)) - ;; parse known punctuation - (set! xs (map (lambda (x) - (syntax-case* x (-> ::) id=? [:: '::] [-> '->] [_ x])) - xs)) - ;; parse "::" - (let ([s (split-by ':: xs)]) - (case (length s) - [(0) (err "something bad happened (::)")] - [(1) (void)] - [(2) (if (and (= 1 (length (car s))) (not (eq? '-> (caar s)))) - (begin (set! xs (cadr s)) (set! input-names (caar s))) - (err "bad wrapper formals"))] - [else (err "saw two or more instances of `::'")])) - ;; parse "->" - (let ([s (split-by '-> xs)]) - (case (length s) - [(0) (err "something bad happened (->)")] - [(1) (err "missing output type")] - [(2 3) (set! inputs (car s)) - (case (length (cadr s)) - [(1) (set! output-type (caadr s))] - [(0) (err "missing output type after `->'")] - [else (err "extraneous output type" (cadadr s))]) - (unless (null? (cddr s)) - (case (length (caddr s)) - [(1) (set! output-expr (caaddr s))] - [(0) (err "missing output expression after `->'")] - [else (err "extraneous output expression" - (cadr (caddr s)))]))] - [else (err "saw three or more instances of `->'")])) - (set! inputs - (map (lambda (sub temp) - (let ([t-n-e (t-n-e sub)]) - (syntax-case* sub (: =) id=? - [(name : type) (t-n-e #'type #'name #f)] - [(type = expr) (t-n-e #'type temp #'expr)] - [(name : type = expr) (t-n-e #'type #'name #'expr)] - [type (t-n-e #'type temp #f)]))) - inputs - (generate-temporaries (map (lambda (x) 'tmp) inputs)))) - ;; when processing the output type, only the post code matters - (set! pre! (lambda (x) #f)) - (set! output - (let ([temp (car (generate-temporaries #'(ret)))] - [t-n-e (t-n-e output-type)]) - (syntax-case* output-type (: =) id=? - [(name : type) (t-n-e #'type #'name output-expr)] - [(type = expr) (if output-expr - (err "extraneous output expression" #'expr) - (t-n-e #'type temp #'expr))] - [(name : type = expr) - (if output-expr - (err "extraneous output expression" #'expr) - (t-n-e #'type #'name #'expr))] - [type (t-n-e #'type temp output-expr)]))) - (if (or (caddr output) input-names (ormap caddr inputs) - (ormap (lambda (x) (not (car x))) inputs) - (pair? bind) (pair? pre) (pair? post)) - (let* ([input-names (or input-names - (filter-map (lambda (i) - (and (not (caddr i)) (cadr i))) - inputs))] - [output-expr (let ([o (caddr output)]) - (or (and (not (void? o)) o) - (cadr output)))] - [args (filter-map (lambda (i) - (and (caddr i) - (not (void? (caddr i))) - #`[#,(cadr i) #,(caddr i)])) - inputs)] - [ffi-args (filter-map (lambda (x) (and (car x) (cadr x))) inputs)] - ;; the actual wrapper body - [body (quasisyntax/loc stx - (lambda #,input-names - (let* (#,@args - #,@bind - #,@pre - [#,(cadr output) (ffi #,@ffi-args)] - #,@post) - #,output-expr)))] - ;; if there is a string 'ffi-name property, use it as a name - [body (let ([n (cond [(syntax-property stx 'ffi-name) - => syntax->datum] - [else #f])]) - (if (string? n) - (syntax-property - body 'inferred-name - (string->symbol (string-append "ffi-wrapper:" n))) - body))]) - #`(_cprocedure* (list #,@(filter-map car inputs)) #,(car output) - #,abi (lambda (ffi) #,body) #,keep #,atomic?)) - #`(_cprocedure* (list #,@(filter-map car inputs)) #,(car output) - #,abi #f #,keep #,atomic?))) - (syntax-case stx () - [(_ x ...) (begin (set! xs (syntax->list #'(x ...))) (do-fun))])) - -(define (function-ptr p fun-ctype) - (if (or (cpointer? p) (procedure? p)) - (if (eq? (ctype->layout fun-ctype) 'fpointer) - (if (procedure? p) - ((ctype-scheme->c fun-ctype) p) - ((ctype-c->scheme fun-ctype) p)) - (raise-type-error 'function-ptr "function ctype" fun-ctype)) - (raise-type-error 'function-ptr "cpointer" p))) - -;; ---------------------------------------------------------------------------- -;; String types - -;; The internal _string type uses the native ucs-4 encoding, also providing a -;; utf-16 type -(provide _string/ucs-4 _string/utf-16) - -;; 8-bit string encodings, #f is NULL -(define ((false-or-op op) x) (and x (op x))) -(define* _string/utf-8 - (make-ctype _bytes - (false-or-op string->bytes/utf-8) (false-or-op bytes->string/utf-8))) -(define* _string/locale - (make-ctype _bytes - (false-or-op string->bytes/locale) (false-or-op bytes->string/locale))) -(define* _string/latin-1 - (make-ctype _bytes - (false-or-op string->bytes/latin-1) (false-or-op bytes->string/latin-1))) - -;; 8-bit string encodings, #f is NULL, can also use bytes and paths -(define ((any-string-op op) x) - (cond [(not x) x] - [(bytes? x) x] - [(path? x) (path->bytes x)] - [else (op x)])) -(define* _string*/utf-8 - (make-ctype _bytes - (any-string-op string->bytes/utf-8) (false-or-op bytes->string/utf-8))) -(define* _string*/locale - (make-ctype _bytes - (any-string-op string->bytes/locale) (false-or-op bytes->string/locale))) -(define* _string*/latin-1 - (make-ctype _bytes - (any-string-op string->bytes/latin-1) (false-or-op bytes->string/latin-1))) - -;; A generic _string type that usually does the right thing via a parameter -(define* default-_string-type - (make-parameter _string*/utf-8 - (lambda (x) - (if (ctype? x) - x (error 'default-_string-type "expecting a C type, got ~e" x))))) -;; The type looks like an identifier, but it's actually using the parameter -(provide _string) -(define-syntax _string - (syntax-id-rules () - [(_ . xs) ((default-_string-type) . xs)] - [_ (default-_string-type)])) - -;; _symbol is defined in C, since it uses simple C strings -(provide _symbol) - -(provide _path) -;; `file' type: path-expands a path string, provide _path too. -(define* _file (make-ctype _path cleanse-path #f)) - -;; `string/eof' type: converts an output #f (NULL) to an eof-object. -(define string-type->string/eof-type - (let ([table (make-hasheq)]) - (lambda (string-type) - (hash-ref table string-type - (lambda () - (let ([new-type (make-ctype string-type - (lambda (x) (and (not (eof-object? x)) x)) - (lambda (x) (or x eof)))]) - (hash-set! table string-type new-type) - new-type)))))) -(provide _string/eof _bytes/eof) -(define _bytes/eof - (make-ctype _bytes - (lambda (x) (and (not (eof-object? x)) x)) - (lambda (x) (or x eof)))) -(define-syntax _string/eof ; make it a syntax so it depends on the _string type - (syntax-id-rules () - [(_ . xs) ((string-type->string/eof-type _string) . xs)] - [_ (string-type->string/eof-type _string)])) - -;; ---------------------------------------------------------------------------- -;; Utility types - -;; Call this with a name (symbol) and a list of symbols, where a symbol can be -;; followed by a '= and an integer to have a similar effect of C's enum. -(define (_enum* name symbols . base?) - (define basetype (if (pair? base?) (car base?) _ufixint)) - (define sym->int '()) - (define int->sym '()) - (define s->c - (if name (string->symbol (format "enum:~a->int" name)) 'enum->int)) - (let loop ([i 0] [symbols symbols]) - (unless (null? symbols) - (let-values ([(i rest) - (if (and (pair? (cdr symbols)) - (eq? '= (cadr symbols)) - (pair? (cddr symbols))) - (values (caddr symbols) - (cdddr symbols)) - (values i - (cdr symbols)))]) - (set! sym->int (cons (cons (car symbols) i) sym->int)) - (set! int->sym (cons (cons i (car symbols)) int->sym)) - (loop (add1 i) rest)))) - (make-ctype basetype - (lambda (x) - (let ([a (assq x sym->int)]) - (if a - (cdr a) - (raise-type-error s->c (format "~a" (or name "enum")) x)))) - (lambda (x) (cond [(assq x int->sym) => cdr] [else #f])))) - -;; Macro wrapper -- no need for a name -(provide _enum) -(define-syntax (_enum stx) - (syntax-case stx () - [(_ syms) - (with-syntax ([name (syntax-local-name)]) - #'(_enum* 'name syms))] - [(_ syms basetype) - (with-syntax ([name (syntax-local-name)]) - #'(_enum* 'name syms basetype))] - [id (identifier? #'id) - #'(lambda (syms . base?) (apply _enum* #f syms base?))])) - -;; Call this with a name (symbol) and a list of (symbol int) or symbols like -;; the above with '= -- but the numbers have to be specified in some way. The -;; generated type will convert a list of these symbols into the logical-or of -;; their values and back. -(define (_bitmask* name orig-symbols->integers . base?) - (define basetype (if (pair? base?) (car base?) _uint)) - (define s->c - (if name (string->symbol (format "bitmask:~a->int" name)) 'bitmask->int)) - (define symbols->integers - (let loop ([s->i orig-symbols->integers]) - (cond - [(null? s->i) - null] - [(and (pair? (cdr s->i)) (eq? '= (cadr s->i)) (pair? (cddr s->i))) - (cons (list (car s->i) (caddr s->i)) - (loop (cdddr s->i)))] - [(and (pair? (car s->i)) (pair? (cdar s->i)) (null? (cddar s->i)) - (symbol? (caar s->i)) (integer? (cadar s->i))) - (cons (car s->i) (loop (cdr s->i)))] - [else - (error '_bitmask "bad spec in ~e" orig-symbols->integers)]))) - (make-ctype basetype - (lambda (symbols) - (if (null? symbols) ; probably common - 0 - (let loop ([xs (if (pair? symbols) symbols (list symbols))] [n 0]) - (cond [(null? xs) n] - [(assq (car xs) symbols->integers) => - (lambda (x) (loop (cdr xs) (bitwise-ior (cadr x) n)))] - [else (raise-type-error s->c (format "~a" (or name "bitmask")) - symbols)])))) - (lambda (n) - (if (zero? n) ; probably common - '() - (let loop ([s->i symbols->integers] [l '()]) - (if (null? s->i) - (reverse l) - (loop (cdr s->i) - (let ([i (cadar s->i)]) - (if (and (not (= i 0)) (= i (bitwise-and i n))) - (cons (caar s->i) l) - l))))))))) - -;; Macro wrapper -- no need for a name -(provide _bitmask) -(define-syntax (_bitmask stx) - (syntax-case stx () - [(_ syms) - (with-syntax ([name (syntax-local-name)]) - #'(_bitmask* 'name syms))] - [(_ syms basetype) - (with-syntax ([name (syntax-local-name)]) - #'(_bitmask* 'name syms basetype))] - [id (identifier? #'id) - #'(lambda (syms . base?) (apply _bitmask* #f syms base?))])) - -;; ---------------------------------------------------------------------------- -;; Custom function type macros - -;; These macros get expanded by the _fun type. They can expand to a form that -;; looks like (keyword: value ...), where the keyword is one of: -;; * `type:' for the type that will be used, -;; * `expr:' an expression that will always be used for these arguments, as -;; if `= expr' is always given, when an expression is actually -;; given in an argument specification, it supersedes this. -;; * `bind:' for an additional binding that holds the initial value, -;; * `1st-arg:' is used to name an identifier that will be bound to the value -;; of the 1st foreign argument in pre/post chunks (good for -;; common cases where the first argument has a special meaning, -;; eg, for method calls), -;; * `prev-arg:' similar to 1st-arg: but for the previous argument, -;; * `pre:' for a binding that will be inserted before the ffi call, -;; * `post:' for a binding after the ffi call. -;; The pre: and post: bindings can be of the form (id => expr) to use the -;; existing value. Note that if the pre: expression is not (id => expr), then -;; it means that there is no input for this argument. Also note that if a -;; custom type is used as an output type of a function, then only the post: -;; code is used -- for example, this is useful for foreign functions that -;; allocate a memory block and return it to the user. The resulting wrapper -;; looks like: -;; (let* (...bindings for arguments... -;; ...bindings for bind: identifiers... -;; ...bindings for pre-code... -;; (ret-name ffi-call) -;; ...bindings for post-code...) -;; return-expression) -;; -;; Finally, the code in a custom-function macro needs special treatment when it -;; comes to dealing with code certificates, so instead of using -;; `define-syntax', you should use `define-fun-syntax' (used in the same way). - -;; _? -;; This is not a normal ffi type -- it is a marker for expressions that should -;; not be sent to the ffi function. Use this to bind local values in a -;; computation that is part of an ffi wrapper interface. -(provide _?) -(define-fun-syntax _? - (syntax-id-rules () [(_ . xs) ((type: #f) . xs)] [_ (type: #f)])) - -;; (_ptr ) -;; This is for pointers, where mode indicates input or output pointers (or -;; both). If the mode is `o' (output), then the wrapper will not get an -;; argument for it, instead it generates the matching argument. -(provide _ptr) -(define-fun-syntax _ptr - (syntax-rules (i o io) - [(_ i t) (type: _pointer - pre: (x => (let ([p (malloc t)]) (ptr-set! p t x) p)))] - [(_ o t) (type: _pointer - pre: (malloc t) - post: (x => (ptr-ref x t)))] - [(_ io t) (type: _pointer - pre: (x => (let ([p (malloc t)]) (ptr-set! p t x) p)) - post: (x => (ptr-ref x t)))])) - -;; (_box ) -;; This is similar to a (_ptr io ) argument, where the input is expected -;; to be a box, which is unboxed on entry and modified on exit. -(provide _box) -(define-fun-syntax _box - (syntax-rules () - [(_ t) (type: _pointer - bind: tmp ; need to save the box so we can get back to it - pre: (x => (let ([p (malloc t)]) (ptr-set! p t (unbox x)) p)) - post: (x => (begin (set-box! tmp (ptr-ref x t)) tmp)))])) - -;; (_list []) -;; Similar to _ptr, except that it is used for converting lists to/from C -;; vectors. The length is needed for output values where it is used in the -;; post code, and in the pre code of an output mode to allocate the block. In -;; any case it can refer to a previous binding for the length of the list which -;; the C function will most likely require. -(provide _list) -(define-fun-syntax _list - (syntax-rules (i o io) - [(_ i t ) (type: _pointer - pre: (x => (list->cblock x t)))] - [(_ o t n) (type: _pointer - pre: (malloc n t) - post: (x => (cblock->list x t n)))] - [(_ io t n) (type: _pointer - pre: (x => (list->cblock x t)) - post: (x => (cblock->list x t n)))])) - -;; (_vector []) -;; Same as _list, except that it uses Scheme vectors. -(provide _vector) -(define-fun-syntax _vector - (syntax-rules (i o io) - [(_ i t ) (type: _pointer - pre: (x => (vector->cblock x t)))] - [(_ o t n) (type: _pointer - pre: (malloc n t) - post: (x => (cblock->vector x t n)))] - [(_ io t n) (type: _pointer - pre: (x => (vector->cblock x t)) - post: (x => (cblock->vector x t n)))])) - -;; _bytes or (_bytes o n) is for a memory block represented as a Scheme byte -;; string. _bytes is just like a byte-string, and (_bytes o n) is for -;; pre-malloc of the string. There is no need for other modes: i or io would -;; be just like _bytes since the string carries its size information (so there -;; is no real need for the `o', but it's there for consistency with the above -;; macros). -(provide (rename-out [_bytes* _bytes])) -(define-fun-syntax _bytes* - (syntax-id-rules (o) - [(_ o n) (type: _bytes - pre: (make-sized-byte-string (malloc n) n) - ;; post is needed when this is used as a function output type - post: (x => (make-sized-byte-string x n)))] - [(_ . xs) (_bytes . xs)] - [_ _bytes])) - -;; ---------------------------------------------------------------------------- -;; Safe raw vectors - -(define-struct cvector (ptr type length)) - -(provide* cvector? cvector-length cvector-type cvector-ptr - ;; make-cvector* is a dangerous operation - (unsafe (rename-out [make-cvector make-cvector*]))) - -(define _cvector* ; used only as input types - (make-ctype _pointer cvector-ptr - (lambda (x) - (error '_cvector - "cannot automatically convert a C pointer to a cvector")))) - -;; (_cvector [ ]) | _cevector -;; Same as _list etc above, except that it uses C vectors. -(provide _cvector) -(define-fun-syntax _cvector - (syntax-id-rules (i o io) - [(_ i ) _cvector*] - [(_ o t n) (type: _pointer ; needs to be a pointer, not a cvector* - pre: (malloc n t) - post: (x => (make-cvector x t n)))] - [(_ io ) (type: _cvector* - bind: tmp - pre: (x => (cvector-ptr x)) - post: (x => tmp))] - [(_ . xs) (_cvector* . xs)] - [_ _cvector*])) - -(provide (rename-out [allocate-cvector make-cvector])) -(define (allocate-cvector type len) - (make-cvector (if (zero? len) #f ; 0 => NULL - (malloc len type)) - type len)) - -(provide (rename-out [cvector-args cvector])) -(define (cvector-args type . args) - (list->cvector args type)) - -(define* (cvector-ref v i) - (if (and (exact-nonnegative-integer? i) (< i (cvector-length v))) - (ptr-ref (cvector-ptr v) (cvector-type v) i) - (error 'cvector-ref "bad index ~e for cvector bounds of 0..~e" - i (sub1 (cvector-length v))))) - -(define* (cvector-set! v i x) - (if (and (exact-nonnegative-integer? i) (< i (cvector-length v))) - (ptr-set! (cvector-ptr v) (cvector-type v) i x) - (error 'cvector-ref "bad index ~e for cvector bounds of 0..~e" - i (sub1 (cvector-length v))))) - -(define* (cvector->list v) - (cblock->list (cvector-ptr v) (cvector-type v) (cvector-length v))) - -(define* (list->cvector l type) - (make-cvector (list->cblock l type) type (length l))) - -;; ---------------------------------------------------------------------------- -;; SRFI-4 implementation - -(define-syntax (srfi-4-define/provide stx) - (syntax-case stx () - [(_ TAG type) - (identifier? #'TAG) - (let ([name (format "~avector" (syntax->datum #'TAG))]) - (define (id prefix suffix) - (let* ([name (if prefix (string-append prefix name) name)] - [name (if suffix (string-append name suffix) name)]) - (datum->syntax #'TAG (string->symbol name) #'TAG))) - (with-syntax ([TAG? (id "" "?")] - [TAG (id "" "")] - [s:TAG (id "s:" "")] - [make-TAG (id "make-" "")] - [TAG-ptr (id "" "-ptr")] - [TAG-length (id "" "-length")] - [allocate-TAG (id "allocate-" "")] - [TAG* (id "" "*")] - [list->TAG (id "list->" "")] - [TAG->list (id "" "->list")] - [TAG-ref (id "" "-ref")] - [TAG-set! (id "" "-set!")] - [_TAG (id "_" "")] - [_TAG* (id "_" "*")] - [TAGname name]) - #'(begin - (define-struct TAG (ptr length)) - (provide TAG? TAG-length (rename-out [TAG s:TAG])) - (provide (rename-out [allocate-TAG make-TAG])) - (define (allocate-TAG n . init) - (let* ([p (if (eq? n 0) #f (malloc n type))] - [v (make-TAG p n)]) - (when (and p (pair? init)) - (let ([init (car init)]) - (let loop ([i (sub1 n)]) - (unless (< i 0) - (ptr-set! p type i init) - (loop (sub1 i)))))) - v)) - (provide (rename-out [TAG* TAG])) - (define (TAG* . vals) - (list->TAG vals)) - (define* (TAG-ref v i) - (if (TAG? v) - (if (and (exact-nonnegative-integer? i) (< i (TAG-length v))) - (ptr-ref (TAG-ptr v) type i) - (error 'TAG-ref "bad index ~e for ~a bounds of 0..~e" - i 'TAG (sub1 (TAG-length v)))) - (raise-type-error 'TAG-ref TAGname v))) - (define* (TAG-set! v i x) - (if (TAG? v) - (if (and (exact-nonnegative-integer? i) (< i (TAG-length v))) - (ptr-set! (TAG-ptr v) type i x) - (error 'TAG-set! "bad index ~e for ~a bounds of 0..~e" - i 'TAG (sub1 (TAG-length v)))) - (raise-type-error 'TAG-set! TAGname v))) - (define* (TAG->list v) - (if (TAG? v) - (cblock->list (TAG-ptr v) type (TAG-length v)) - (raise-type-error 'TAG->list TAGname v))) - (define* (list->TAG l) - (make-TAG (list->cblock l type) (length l))) - ;; same as the _cvector implementation - (provide _TAG) - (define _TAG* - (make-ctype _pointer TAG-ptr - (lambda (x) - (error - '_TAG - "cannot automatically convert a C pointer to a ~a" - TAGname)))) - (define-fun-syntax _TAG - (syntax-id-rules (i o io) - [(_ i ) _TAG*] - [(_ o n) (type: _pointer - pre: (malloc n type) - post: (x => (make-TAG x n)))] - [(_ io ) (type: _cvector* - bind: tmp - pre: (x => (TAG-ptr x)) - post: (x => tmp))] - [(_ . xs) (_TAG* . xs)] - [_ _TAG*])))))] - [(_ TAG type) - (identifier? #'TAG)])) - -;; check that the types that were used above have the proper sizes -(unless (= 4 (ctype-sizeof _float)) - (error 'foreign "internal error: float has a bad size (~s)" - (ctype-sizeof _float))) -(unless (= 8 (ctype-sizeof _double*)) - (error 'foreign "internal error: double has a bad size (~s)" - (ctype-sizeof _double*))) - -(srfi-4-define/provide s8 _int8) -(srfi-4-define/provide s16 _int16) -(srfi-4-define/provide u16 _uint16) -(srfi-4-define/provide s32 _int32) -(srfi-4-define/provide u32 _uint32) -(srfi-4-define/provide s64 _int64) -(srfi-4-define/provide u64 _uint64) -(srfi-4-define/provide f32 _float) -(srfi-4-define/provide f64 _double*) - -;; simply rename bytes* to implement the u8vector type -(provide (rename-out [bytes? u8vector? ] - [bytes-length u8vector-length] - [make-bytes make-u8vector ] - [bytes u8vector ] - [bytes-ref u8vector-ref ] - [bytes-set! u8vector-set! ] - [bytes->list u8vector->list ] - [list->bytes list->u8vector ] - [_bytes _u8vector ])) -;; additional `u8vector' bindings for srfi-66 -(provide (rename-out [bytes-copy u8vector-copy] [bytes=? u8vector=?])) -(define* (u8vector-compare v1 v2) - (cond [(bytes? v1 v2) 1] - [else 0])) -(define* (u8vector-copy! src src-start dest dest-start n) - (bytes-copy! dest dest-start src src-start (+ src-start n))) - -;; ---------------------------------------------------------------------------- -;; Tagged pointers - -;; Make these operations available for unsafe interfaces (they can be used to -;; grab a hidden tag value and break code). -(provide* (unsafe cpointer-tag) (unsafe set-cpointer-tag!) - (unsafe cpointer-has-tag?) (unsafe cpointer-push-tag!)) - -;; Defined as syntax for efficiency, but can be used as procedures too. -(define-syntax (cpointer-has-tag? stx) - (syntax-case stx () - [(_ cptr tag) - #'(let ([ptag (cpointer-tag cptr)]) - (if (pair? ptag) (memq tag ptag) (eq? tag ptag)))] - [id (identifier? #'id) - #'(lambda (cptr tag) (cpointer-has-tag? cptr tag))])) -(define-syntax (cpointer-push-tag! stx) - (syntax-case stx () - [(_ cptr tag) - #'(let ([ptag (cpointer-tag cptr)]) - (set-cpointer-tag! cptr - (cond [(not ptag) tag] - [(pair? ptag) (cons tag ptag)] - [else (list tag ptag)])))] - [id (identifier? #'id) - #'(lambda (cptr tag) (cpointer-push-tag! cptr tag))])) - -(define (cpointer-maker nullable?) - (case-lambda - [(tag) ((cpointer-maker nullable?) tag #f #f #f)] - [(tag ptr-type) ((cpointer-maker nullable?) tag ptr-type #f #f)] - [(tag ptr-type scheme->c c->scheme) - (let* ([tag->C (string->symbol (format "~a->C" tag))] - [error-str (format "~a`~a' pointer" - (if nullable? "" "non-null ") tag)] - [error* (lambda (p) (raise-type-error tag->C error-str p))]) - (define-syntax-rule (tag-or-error ptr t) - (let ([p ptr]) - (if (cpointer? p) - (if (cpointer-has-tag? p t) p (error* p)) - (error* p)))) - (define-syntax-rule (tag-or-error/null ptr t) - (let ([p ptr]) - (if (cpointer? p) - (and p (if (cpointer-has-tag? p t) p (error* p))) - (error* p)))) - (make-ctype (or ptr-type _pointer) - ;; bad hack: `if's outside the lambda for efficiency - (if nullable? - (if scheme->c - (lambda (p) (tag-or-error/null (scheme->c p) tag)) - (lambda (p) (tag-or-error/null p tag))) - (if scheme->c - (lambda (p) (tag-or-error (scheme->c p) tag)) - (lambda (p) (tag-or-error p tag)))) - (if nullable? - (if c->scheme - (lambda (p) (when p (cpointer-push-tag! p tag)) (c->scheme p)) - (lambda (p) (when p (cpointer-push-tag! p tag)) p)) - (if c->scheme - (lambda (p) - (if p (cpointer-push-tag! p tag) (error* p)) - (c->scheme p)) - (lambda (p) - (if p (cpointer-push-tag! p tag) (error* p)) - p)))))])) - -;; This is a kind of a pointer that gets a specific tag when converted to -;; Scheme, and accepts only such tagged pointers when going to C. An optional -;; `ptr-type' can be given to be used as the base pointer type, instead of -;; _pointer, `scheme->c' and `c->scheme' can be used for adding conversion -;; hooks. -(define* _cpointer (cpointer-maker #f)) - -;; Similar to the above, but can tolerate null pointers (#f). -(define* _cpointer/null (cpointer-maker #t)) - -;; A macro version of the above two functions, using the defined name for a tag -;; string, and defining a predicate too. The name should look like `_foo', the -;; predicate will be `foo?', and the tag will be "foo". In addition, `foo-tag' -;; is bound to the tag. The optional `ptr-type', `scheme->c', and `c->scheme' -;; arguments are the same as those of `_cpointer'. `_foo' will be bound to the -;; _cpointer type, and `_foo/null' to the _cpointer/null type. -(provide define-cpointer-type) -(define-syntax (define-cpointer-type stx) - (syntax-case stx () - [(_ _TYPE) #'(define-cpointer-type _TYPE #f #f #f)] - [(_ _TYPE ptr-type) #'(define-cpointer-type _TYPE ptr-type #f #f)] - [(_ _TYPE ptr-type scheme->c c->scheme) - (and (identifier? #'_TYPE) - (regexp-match #rx"^_.+" (symbol->string (syntax-e #'_TYPE)))) - (let ([name (cadr (regexp-match #rx"^_(.+)$" - (symbol->string (syntax-e #'_TYPE))))]) - (define (id . strings) - (datum->syntax - #'_TYPE (string->symbol (apply string-append strings)) #'_TYPE)) - (with-syntax ([name-string name] - [TYPE? (id name "?")] - [TYPE-tag (id name "-tag")] - [_TYPE/null (id "_" name "/null")]) - #'(define-values (_TYPE _TYPE/null TYPE? TYPE-tag) - (let ([TYPE-tag name-string]) - (values (_cpointer TYPE-tag ptr-type scheme->c c->scheme) - (_cpointer/null TYPE-tag ptr-type scheme->c c->scheme) - (lambda (x) - (and (cpointer? x) (cpointer-has-tag? x TYPE-tag))) - TYPE-tag)))))])) - -;; ---------------------------------------------------------------------------- -;; Struct wrappers - -(define (compute-offsets types) - (let loop ([ts types] [cur 0] [r '()]) - (if (null? ts) - (reverse r) - (let* ([algn (ctype-alignof (car ts))] - [pos (+ cur (modulo (- (modulo cur algn)) algn))]) - (loop (cdr ts) - (+ pos (ctype-sizeof (car ts))) - (cons pos r)))))) - -;; Simple structs: call this with a list of types, and get a type that marshals -;; C structs to/from Scheme lists. -(define* (_list-struct . types) - (let ([stype (make-cstruct-type types)] - [offsets (compute-offsets types)] - [len (length types)]) - (make-ctype stype - (lambda (vals) - (unless (and (list vals) (= len (length vals))) - (raise-type-error 'list-struct (format "list of ~a items" len) vals)) - (let ([block (malloc stype)]) - (for-each (lambda (type ofs val) (ptr-set! block type 'abs ofs val)) - types offsets vals) - block)) - (lambda (block) - (map (lambda (type ofs) (ptr-ref block type 'abs ofs)) - types offsets))))) - -;; (define-cstruct _foo ([slot type] ...)) -;; or -;; (define-cstruct (_foo _super) ([slot type] ...)) -;; defines a type called _foo for a C struct, with user-procedues: make-foo, -;; foo? foo-slot... and set-foo-slot!.... The `_' prefix is required. Objects -;; of this new type are actually cpointers, with a type tag that is "foo" and -;; (possibly more if the first type is itself a cstruct type or if a super type -;; is given,) provided as foo-tag, and tags of pointers are checked before -;; attempting to use them (see define-cpointer-type above). Note that since -;; structs are implemented as pointers, they can be used for a _pointer input -;; to a foreign function: their address will be used, to make this possible, -;; the corresponding cpointer type is defined as _foo-pointer. If a super -;; cstruct type is given, the constructor function expects values for every -;; field of the super type as well as other fields that are specified, and a -;; slot named `super' can be used to extract this initial struct -- although -;; pointers to the new struct type can be used as pointers to the super struct -;; type. -(provide define-cstruct) -(define-syntax (define-cstruct stx) - (define (make-syntax _TYPE-stx has-super? slot-names-stx slot-types-stx) - (define name - (cadr (regexp-match #rx"^_(.+)$" (symbol->string (syntax-e _TYPE-stx))))) - (define slot-names (map (lambda (x) (symbol->string (syntax-e x))) - (syntax->list slot-names-stx))) - (define 1st-type - (let ([xs (syntax->list slot-types-stx)]) (and (pair? xs) (car xs)))) - (define (id . strings) - (datum->syntax - _TYPE-stx (string->symbol (apply string-append strings)) _TYPE-stx)) - (define (ids name-func) - (map (lambda (s) - (datum->syntax - _TYPE-stx - (string->symbol (apply string-append (name-func s))) - _TYPE-stx)) - slot-names)) - (define (safe-id=? x y) - (and (identifier? x) (identifier? y) (free-identifier=? x y))) - (with-syntax - ([has-super? has-super?] - [name-string name] - [struct-string (format "struct:~a" name)] - [(slot ...) slot-names-stx] - [(slot-type ...) slot-types-stx] - [_TYPE _TYPE-stx] - [_TYPE-pointer (id "_"name"-pointer")] - [_TYPE-pointer/null (id "_"name"-pointer/null")] - [_TYPE/null (id "_"name"/null")] - [_TYPE* (id "_"name"*")] - [TYPE? (id name"?")] - [make-TYPE (id "make-"name)] - [list->TYPE (id "list->"name)] - [list*->TYPE (id "list*->"name)] - [TYPE->list (id name"->list")] - [TYPE->list* (id name"->list*")] - [TYPE-tag (id name"-tag")] - [(stype ...) (ids (lambda (s) `(,name"-",s"-type")))] - [(TYPE-SLOT ...) (ids (lambda (s) `(,name"-",s)))] - [(set-TYPE-SLOT! ...) (ids (lambda (s) `("set-",name"-",s"!")))] - [(offset ...) (generate-temporaries - (ids (lambda (s) `(,s"-offset"))))]) - (with-syntax ([get-super-info - ;; the 1st-type might be a pointer to this type - (if (or (safe-id=? 1st-type #'_TYPE-pointer/null) - (safe-id=? 1st-type #'_TYPE-pointer)) - #'(values #f '() #f #f #f #f) - #`(cstruct-info #,1st-type - (lambda () (values #f '() #f #f #f #f))))]) - #'(define-values (_TYPE _TYPE-pointer _TYPE-pointer/null TYPE? TYPE-tag - make-TYPE TYPE-SLOT ... set-TYPE-SLOT! ... - list->TYPE list*->TYPE TYPE->list TYPE->list*) - (let-values ([(super-pointer super-tags super-types super-offsets - super->list* list*->super) - get-super-info]) - (define-cpointer-type _TYPE super-pointer) - ;; these makes it possible to use recursive pointer definitions - (define _TYPE-pointer _TYPE) - (define _TYPE-pointer/null _TYPE/null) - (let*-values ([(stype ...) (values slot-type ...)] - [(types) (list stype ...)] - [(offsets) (compute-offsets types)] - [(offset ...) (apply values offsets)]) - (define all-tags (cons TYPE-tag super-tags)) - (define _TYPE* - ;; c->scheme adjusts all tags - (let* ([cst (make-cstruct-type types)] - [t (_cpointer TYPE-tag cst)] - [c->s (ctype-c->scheme t)]) - (make-ctype cst (ctype-scheme->c t) - ;; hack: modify & reuse the procedure made by _cpointer - (lambda (p) - (if p (set-cpointer-tag! p all-tags) (c->s p)) - p)))) - (define-values (all-types all-offsets) - (if (and has-super? super-types super-offsets) - (values (append super-types (cdr types)) - (append super-offsets (cdr offsets))) - (values types offsets))) - (define (TYPE-SLOT x) - (unless (TYPE? x) - (raise-type-error 'TYPE-SLOT struct-string x)) - (ptr-ref x stype 'abs offset)) - ... - (define (set-TYPE-SLOT! x slot) - (unless (TYPE? x) - (raise-type-error 'set-TYPE-SLOT! struct-string 0 x slot)) - (ptr-set! x stype 'abs offset slot)) - ... - (define make-TYPE - (if (and has-super? super-types super-offsets) - ;; init using all slots - (lambda vals - (if (= (length vals) (length all-types)) - (let ([block (malloc _TYPE*)]) - (set-cpointer-tag! block all-tags) - (for-each (lambda (type ofs value) - (ptr-set! block type 'abs ofs value)) - all-types all-offsets vals) - block) - (error '_TYPE "expecting ~s values, got ~s: ~e" - (length all-types) (length vals) vals))) - ;; normal initializer - (lambda (slot ...) - (let ([block (malloc _TYPE*)]) - (set-cpointer-tag! block all-tags) - (ptr-set! block stype 'abs offset slot) - ... - block)))) - (define (list->TYPE vals) (apply make-TYPE vals)) - (define (list*->TYPE vals) - (cond - [(TYPE? vals) vals] - [(= (length vals) (length all-types)) - (let ([block (malloc _TYPE*)]) - (set-cpointer-tag! block all-tags) - (for-each - (lambda (type ofs value) - (let-values - ([(ptr tags types offsets T->list* list*->T) - (cstruct-info - type - (lambda () (values #f '() #f #f #f #f)))]) - (ptr-set! block type 'abs ofs - (if list*->T (list*->T value) value)))) - all-types all-offsets vals) - block)] - [else (error '_TYPE "expecting ~s values, got ~s: ~e" - (length all-types) (length vals) vals)])) - (define (TYPE->list x) - (unless (TYPE? x) - (raise-type-error 'TYPE-list struct-string x)) - (map (lambda (type ofs) (ptr-ref x type 'abs ofs)) - all-types all-offsets)) - (define (TYPE->list* x) - (unless (TYPE? x) - (raise-type-error 'TYPE-list struct-string x)) - (map (lambda (type ofs) - (let-values - ([(v) (ptr-ref x type 'abs ofs)] - [(ptr tags types offsets T->list* list*->T) - (cstruct-info - type - (lambda () (values #f '() #f #f #f #f)))]) - (if T->list* (T->list* v) v))) - all-types all-offsets)) - (cstruct-info - _TYPE* 'set! - _TYPE all-tags all-types all-offsets TYPE->list* list*->TYPE) - (values _TYPE* _TYPE-pointer _TYPE-pointer/null TYPE? TYPE-tag - make-TYPE TYPE-SLOT ... set-TYPE-SLOT! ... - list->TYPE list*->TYPE TYPE->list TYPE->list*))))))) - (define (identifiers? stx) - (andmap identifier? (syntax->list stx))) - (define (_-identifier? id stx) - (and (identifier? id) - (or (regexp-match #rx"^_." (symbol->string (syntax-e id))) - (raise-syntax-error #f "cstruct name must begin with a `_'" - stx id)))) - (syntax-case stx () - [(_ _TYPE ([slot slot-type] ...)) - (and (_-identifier? #'_TYPE stx) - (identifiers? #'(slot ...))) - (make-syntax #'_TYPE #f #'(slot ...) #'(slot-type ...))] - [(_ (_TYPE _SUPER) ([slot slot-type] ...)) - (and (_-identifier? #'_TYPE stx) (identifiers? #'(slot ...))) - (with-syntax ([super (datum->syntax #'_TYPE 'super #'_TYPE)]) - (make-syntax #'_TYPE #t #'(super slot ...) #'(_SUPER slot-type ...)))])) - -;; helper for the above: keep runtime information on structs -(define cstruct-info - (let ([table (make-weak-hasheq)]) - (lambda (cstruct msg/fail-thunk . args) - (cond [(eq? 'set! msg/fail-thunk) - (hash-set! table cstruct (make-ephemeron cstruct args))] - [(and cstruct ; might get a #f if there were no slots - (hash-ref table cstruct (lambda () #f))) - => (lambda (xs) - (let ([v (ephemeron-value xs)]) - (if v (apply values v) (msg/fail-thunk))))] - [else (msg/fail-thunk)])))) - -;; ---------------------------------------------------------------------------- -;; - -(define prim-synonyms - #hasheq((double* . double) - (fixint . long) - (ufixint . ulong) - (fixnum . long) - (ufixnum . ulong) - (path . bytes) - (symbol . bytes) - (scheme . pointer))) - -(define (ctype->layout c) - (let ([b (ctype-basetype c)]) - (cond - [(ctype? b) (ctype->layout b)] - [(list? b) (map ctype->layout b)] - [else (hash-ref prim-synonyms b b)]))) - -;; ---------------------------------------------------------------------------- -;; Misc utilities - -;; Used by set-ffi-obj! to get the actual value so it can be kept around -(define (get-lowlevel-object x type) - (let ([basetype (ctype-basetype type)]) - (if (ctype? basetype) - (let ([s->c (ctype-scheme->c type)]) - (get-lowlevel-object (if s->c (s->c x) x) basetype)) - (values x type)))) - -;; Converting Scheme lists to/from C vectors (going back requires a length) -(define* (list->cblock l type) - (if (null? l) - #f ; null => NULL - (let ([cblock (malloc (length l) type)]) - (let loop ([l l] [i 0]) - (unless (null? l) - (ptr-set! cblock type i (car l)) - (loop (cdr l) (add1 i)))) - cblock))) -(provide* (unsafe cblock->list)) -(define (cblock->list cblock type len) - (cond [(zero? len) '()] - [(cpointer? cblock) - (let loop ([i (sub1 len)] [r '()]) - (if (< i 0) - r - (loop (sub1 i) (cons (ptr-ref cblock type i) r))))] - [else (error 'cblock->list - "expecting a non-void pointer, got ~s" cblock)])) - -;; Converting Scheme vectors to/from C vectors -(define* (vector->cblock v type) - (let ([len (vector-length v)]) - (if (zero? len) - #f ; #() => NULL - (let ([cblock (malloc len type)]) - (let loop ([i 0]) - (when (< i len) - (ptr-set! cblock type i (vector-ref v i)) - (loop (add1 i)))) - cblock)))) -(provide* (unsafe cblock->vector)) -(define (cblock->vector cblock type len) - (cond [(zero? len) '#()] - [(cpointer? cblock) - (let ([v (make-vector len)]) - (let loop ([i (sub1 len)]) - (unless (< i 0) - (vector-set! v i (ptr-ref cblock type i)) - (loop (sub1 i)))) - v)] - [else (error 'cblock->vector - "expecting a non-void pointer, got ~s" cblock)])) - -;; Useful for automatic definitions -;; If a provided regexp begins with a "^" or ends with a "$", then -;; `regexp-replace' is used, otherwise use `regexp-replace*'. -(define* (regexp-replaces x rs) - (let loop ([str (if (bytes? x) (bytes->string/utf-8 x) (format "~a" x))] - [rs rs]) - (if (null? rs) - str - (loop ((if (regexp-match #rx"^\\^|\\$$" - (if (regexp? (caar rs)) - (object-name (caar rs)) (caar rs))) - regexp-replace regexp-replace*) - (caar rs) str (cadar rs)) (cdr rs))))) - -;; A facility for running finalizers using executors. #%foreign has a C-based -;; version that uses finalizers, but that leads to calling Scheme from the GC -;; which is not a good idea. -(define killer-executor (make-will-executor)) -(define killer-thread #f) - -(define* (register-finalizer obj finalizer) - (unless killer-thread - (set! killer-thread - (thread (lambda () - (let loop () (will-execute killer-executor) (loop)))))) - (will-register killer-executor obj finalizer)) - -(define-unsafer unsafe!) +(module foreign scheme/base + (require scheme/foreign) + (provide (all-from-out scheme/foreign))) diff --git a/collects/mzlib/inflate.ss b/collects/mzlib/inflate.ss index cf7441d..5a8ae87 100644 --- a/collects/mzlib/inflate.ss +++ b/collects/mzlib/inflate.ss @@ -1,5 +1,5 @@ - -(module inflate mzscheme +#lang scheme/base +(require (for-syntax scheme/base)) (provide inflate gunzip-through-ports @@ -120,7 +120,7 @@ error in the data. */ |# - (define-struct huft (e b v)) + (define-struct huft (e b v) #:mutable) (define (huft-copy dest src) (set-huft-e! dest (huft-e src)) @@ -591,8 +591,8 @@ (set! t (vector-ref tl (bitwise-and bb ml))) ; (printf "t->e: ~s t->b: ~s\n" (huft-e t) (huft-b t)) (set! e (huft-e t)) - (if (> e 16) - (jump-to-next)) + (when (> e 16) + (jump-to-next)) (DUMPBITS (huft-b t)) ; (printf "e: ~s\n" e) (if (= e 16) ; /* then it's a literal */ @@ -928,4 +928,4 @@ void (lambda () (do-gunzip in #f name-filter)) (lambda () (close-input-port in))))])) -) + diff --git a/collects/mzlib/port.ss b/collects/mzlib/port.ss index f3a1657..3d7c110 100644 --- a/collects/mzlib/port.ss +++ b/collects/mzlib/port.ss @@ -1,1298 +1,1193 @@ +#lang scheme/base -(module port mzscheme - (require mzlib/etc - mzlib/contract - mzlib/list - "private/port.ss") +(require (for-syntax scheme/base) + mzlib/etc + scheme/contract + mzlib/list + "private/port.ss") - (define (input-port-with-progress-evts? ip) - (and (input-port? ip) - (port-provides-progress-evts? ip))) +(define (input-port-with-progress-evts? ip) + (and (input-port? ip) + (port-provides-progress-evts? ip))) - (define (mutable-bytes? b) - (and (bytes? b) (not (immutable? b)))) - (define (mutable-string? b) - (and (string? b) (not (immutable? b)))) +(define (mutable-bytes? b) + (and (bytes? b) (not (immutable? b)))) +(define (mutable-string? b) + (and (string? b) (not (immutable? b)))) - (define (line-mode-symbol? s) - (memq s '(linefeed return return-linefeed any any-one))) +(define (line-mode-symbol? s) + (memq s '(linefeed return return-linefeed any any-one))) - (define (evt?/false v) - (or (eq? #f v) (evt? v))) - - ;; ---------------------------------------- +(define (evt?/false v) + (or (eq? #f v) (evt? v))) - (define (strip-shell-command-start in) - (when (regexp-match-peek #rx#"^#![^\r\n]*" in) - (let loop ([s (read-line in)]) - (when (regexp-match #rx#"\\\\$" s) - (loop (read-line in)))))) +;; ---------------------------------------- - ;; ---------------------------------------- +(define (strip-shell-command-start in) + (when (regexp-match-peek #rx#"^#![^\r\n]*" in) + (let loop ([s (read-line in)]) + (when (regexp-match #rx#"\\\\$" s) + (loop (read-line in)))))) - (define (copy-port src dest . dests) - (unless (input-port? src) - (raise-type-error 'copy-port "input-port" src)) - (for-each - (lambda (dest) - (unless (output-port? dest) - (raise-type-error 'copy-port "output-port" dest))) - (cons dest dests)) - (let ([s (make-bytes 4096)] - [dests (cons dest dests)]) - (let loop () - (let ([c (read-bytes-avail! s src)]) - (cond - [(number? c) - (let loop ([dests dests]) - (unless (null? dests) - (let loop ([start 0]) - (unless (= start c) - (let ([c2 (write-bytes-avail s (car dests) start c)]) - (loop (+ start c2))))) - (loop (cdr dests)))) - (loop)] - [(procedure? c) - (let ([v (let-values ([(l col p) (port-next-location src)]) - (c (object-name src) l col p))]) - (let loop ([dests dests]) - (unless (null? dests) - (write-special v (car dests)) - (loop (cdr dests))))) - (loop)] - [else - ;; Must be EOF - (void)]))))) - - (define merge-input - (case-lambda - [(a b) (merge-input a b 4096)] - [(a b limit) - (or (input-port? a) - (raise-type-error 'merge-input "input-port" a)) - (or (input-port? b) - (raise-type-error 'merge-input "input-port" b)) - (or (not limit) - (and (number? limit) (positive? limit) (exact? limit) (integer? limit)) - (raise-type-error 'merge-input "positive exact integer or #f" limit)) - (let-values ([(rd wt) (make-pipe-with-specials limit)] - [(other-done?) #f] - [(sema) (make-semaphore 1)]) - (let ([copy - (lambda (from) - (thread - (lambda () - (copy-port from wt) - (semaphore-wait sema) - (if other-done? - (close-output-port wt) - (set! other-done? #t)) - (semaphore-post sema))))]) - (copy a) - (copy b) - rd))])) +;; ---------------------------------------- - ;; `make-input-port/read-to-peek' sometimes needs to wrap a special-value - ;; procedure so that it's only called once when the value is both - ;; peeked and read. - (define-values (struct:memoized make-memoized memoized? memoized-ref memoized-set!) - (make-struct-type 'memoized #f 1 0 #f null (current-inspector) 0)) - (define (memoize p) - (define result #f) - (make-memoized - (if (procedure-arity-includes? p 0) - ;; original p accepts 0 or 4 arguments: - (case-lambda - [() (unless result (set! result (box (p)))) (unbox result)] - [(src line col pos) - (unless result (set! result (box (p src line col pos)))) - (unbox result)]) - ;; original p accepts only 4 arguments: - (lambda (src line col pos) - (unless result (set! result (box (p src line col pos)))) - (unbox result))))) +(define (copy-port src dest . dests) + (unless (input-port? src) + (raise-type-error 'copy-port "input-port" src)) + (for-each + (lambda (dest) + (unless (output-port? dest) + (raise-type-error 'copy-port "output-port" dest))) + (cons dest dests)) + (let ([s (make-bytes 4096)] + [dests (cons dest dests)]) + (let loop () + (let ([c (read-bytes-avail! s src)]) + (cond + [(number? c) + (let loop ([dests dests]) + (unless (null? dests) + (let loop ([start 0]) + (unless (= start c) + (let ([c2 (write-bytes-avail s (car dests) start c)]) + (loop (+ start c2))))) + (loop (cdr dests)))) + (loop)] + [(procedure? c) + (let ([v (let-values ([(l col p) (port-next-location src)]) + (c (object-name src) l col p))]) + (let loop ([dests dests]) + (unless (null? dests) + (write-special v (car dests)) + (loop (cdr dests))))) + (loop)] + [else + ;; Must be EOF + (void)]))))) - ;; Not kill-safe. - ;; If the `read' proc returns an event, the event must produce - ;; 0 always (which implies that the `read' proc must not return - ;; a pipe input port). - (define make-input-port/read-to-peek - (opt-lambda (name read fast-peek close - [location-proc #f] - [count-lines!-proc void] - [init-position 1] - [buffer-mode-proc #f] - [buffering? #f] - [on-consumed #f]) - (define lock-semaphore (make-semaphore 1)) - (define commit-semaphore (make-semaphore 1)) - (define-values (peeked-r peeked-w) (make-pipe)) - (define special-peeked null) - (define special-peeked-tail #f) - (define progress-requested? #f) - (define use-manager? #f) - (define manager-th #f) - (define manager-ch (make-channel)) - (define resume-ch (make-channel)) - (define buf (make-bytes 4096)) - (define (try-again) - (wrap-evt - (semaphore-peek-evt lock-semaphore) - (lambda (x) 0))) - (define (suspend-manager) - (channel-put manager-ch 'suspend)) - (define (resume-manager) - (channel-put resume-ch 'resume)) - (define (with-manager-lock thunk) - (thread-resume manager-th (current-thread)) - (dynamic-wind suspend-manager thunk resume-manager)) - (define (make-progress) - ;; We dont worry about this byte getting picked up directly - ;; from peeked-r, because the pipe must have been empty when - ;; we grabed the lock, and since we've grabbed the lock, - ;; no other thread could have re-returned the pipe behind - ;; our back. - (write-byte 0 peeked-w) - (read-byte peeked-r)) - (define (consume-from-peeked s) - (let ([n (read-bytes-avail!* s peeked-r)]) - (when on-consumed - (on-consumed n)) - n)) - (define (read-it-with-lock s) - (if use-manager? - (with-manager-lock (lambda () (do-read-it s))) - (do-read-it s))) - (define (read-it s) - (call-with-semaphore - lock-semaphore - read-it-with-lock - try-again - s)) - (define (do-read-it s) - (if (byte-ready? peeked-r) - (if on-consumed - (consume-from-peeked s) - peeked-r) - ;; If nothing is saved from a peeking read, - ;; dispatch to `read', otherwise return - ;; previously peeked data - (cond - [(null? special-peeked) - (when progress-requested? (make-progress)) - (if (and buffering? - ((bytes-length s) . < . 10)) - ;; Buffering is enabled, so read more to move things - ;; along: - (let ([r (read buf)]) - (if (and (number? r) (positive? r)) - (begin - (write-bytes buf peeked-w 0 r) - (if on-consumed - (consume-from-peeked s) - peeked-r)) - (begin - (when on-consumed - (on-consumed r)) - r))) - ;; Just read requested amount: - (let ([v (read s)]) - (when on-consumed - (on-consumed v)) - v))] - [else (if (bytes? (mcar special-peeked)) - (let ([b (mcar special-peeked)]) - (write-bytes b peeked-w) - (set! special-peeked (mcdr special-peeked)) - (when (null? special-peeked) - (set! special-peeked-tail #f)) - (consume-from-peeked s)) - (let ([v (mcar special-peeked)]) - (make-progress) - (set! special-peeked (mcdr special-peeked)) - (when on-consumed - (on-consumed v)) - (when (null? special-peeked) - (set! special-peeked-tail #f)) - v))]))) - (define (peek-it-with-lock s skip unless-evt) - (if use-manager? - (with-manager-lock (lambda () (do-peek-it s skip unless-evt))) - (do-peek-it s skip unless-evt))) - (define (peek-it s skip unless-evt) - (let ([v (peek-bytes-avail!* s skip unless-evt peeked-r)]) - (if (eq? v 0) - (call-with-semaphore - lock-semaphore - peek-it-with-lock - try-again - s skip unless-evt) - v))) - (define (do-peek-it s skip unless-evt) - (let ([v (peek-bytes-avail!* s skip unless-evt peeked-r)]) - (if (eq? v 0) - ;; The peek may have failed because peeked-r is empty, - ;; because unless-evt is ready, or because the skip is - ;; far. Handle nicely the common case where there are no - ;; specials. - (cond - [(and unless-evt (sync/timeout 0 unless-evt)) - #f] - [(null? special-peeked) - ;; Empty special queue, so read through the original proc. - ;; We only only need - ;; (- (+ skip (bytes-length s)) (pipe-content-length peeked-w)) - ;; bytes, but if buffering is enabled, read more (up to size of - ;; buf) to help move things along. - (let* ([dest (if buffering? - buf - (make-bytes (- (+ skip (bytes-length s)) - (pipe-content-length peeked-w))))] - [r (read dest)]) - (cond - [(number? r) - ;; The nice case --- reading gave us more bytes - (write-bytes dest peeked-w 0 r) - ;; Now try again - (peek-bytes-avail!* s skip #f peeked-r)] - [(evt? r) - (if unless-evt - ;; Technically, there's a race condition here. - ;; We might choose r (and return 0) even when - ;; unless-evt becomes available first. However, - ;; this race is detectable only by the inside - ;; of `read'. - (choice-evt r (wrap-evt unless-evt (lambda (x) #f))) - r)] - [else - (set! special-peeked (mcons r null)) - (set! special-peeked-tail special-peeked) - ;; Now try again - (do-peek-it s skip unless-evt)]))] - [else - ;; Non-empty special queue, so try to use it - (let* ([avail (pipe-content-length peeked-r)] - [sk (- skip avail)]) - (let loop ([sk sk] - [l special-peeked]) - (cond - [(null? l) - ;; Not enough even in the special queue. - ;; Read once and add it. - (let* ([t (make-bytes (min 4096 (+ sk (bytes-length s))))] - [r (read t)]) - (cond - [(evt? r) - (if unless-evt - ;; See note above - (choice-evt r (wrap-evt unless-evt (lambda (x) #f))) - r)] - [(eq? r 0) - ;; Original read thinks a spin is ok, - ;; so we return 0 to skin, too. - 0] - [else (let ([v (if (number? r) - (subbytes t 0 r) - r)]) - (let ([pr (mcons v null)]) - (set-mcdr! special-peeked-tail pr) - (set! special-peeked-tail pr)) - ;; Got something; now try again - (do-peek-it s skip unless-evt))]))] - [(eof-object? (mcar l)) - ;; No peeking past an EOF - eof] - [(procedure? (mcar l)) - (if (zero? sk) - ;; We should call the procedure only once. Change - ;; (mcar l) to a memoizing function, if it isn't already: - (let ([proc (mcar l)]) - (if (memoized? proc) - proc - (let ([proc (memoize proc)]) - (set-mcar! l proc) - proc))) - ;; Skipping over special... - (loop (sub1 sk) (mcdr l)))] - [(bytes? (mcar l)) - (let ([len (bytes-length (mcar l))]) - (if (sk . < . len) - (let ([n (min (bytes-length s) - (- len sk))]) - (bytes-copy! s 0 (mcar l) sk (+ sk n)) - n) - (loop (- sk len) (mcdr l))))])))]) - v))) - (define (commit-it-with-lock amt unless-evt done-evt) - (if use-manager? - (with-manager-lock (lambda () (do-commit-it amt unless-evt done-evt))) - (do-commit-it amt unless-evt done-evt))) - (define (commit-it amt unless-evt done-evt) - (call-with-semaphore - lock-semaphore - commit-it-with-lock - #f - amt unless-evt done-evt)) - (define (do-commit-it amt unless-evt done-evt) - (if (sync/timeout 0 unless-evt) - #f - (let* ([avail (pipe-content-length peeked-r)] - [p-commit (min avail amt)]) - (let loop ([amt (- amt p-commit)] - [l special-peeked]) - (cond - [(amt . <= . 0) - ;; Enough has been peeked. Do commit... - (actual-commit p-commit l unless-evt done-evt)] - [(null? l) - ;; Requested commit was larger than previous peeks - #f] - [(bytes? (mcar l)) - (let ([bl (bytes-length (mcar l))]) - (if (bl . > . amt) - ;; Split the string - (let ([next (mcons - (subbytes (mcar l) amt) - (mcdr l))]) - (set-mcar! l (subbytes (mcar l) 0 amt)) - (set-mcdr! l next) - (when (eq? l special-peeked-tail) - (set! special-peeked-tail next)) - (loop 0 (mcdr l))) - ;; Consume this string... - (loop (- amt bl) (mcdr l))))] - [else - (loop (sub1 amt) (mcdr l))]))))) - (define (actual-commit p-commit l unless-evt done-evt) - ;; The `finish' proc finally, actually, will commit... - (define (finish) - (unless (zero? p-commit) - (peek-byte peeked-r (sub1 p-commit)) - (port-commit-peeked p-commit unless-evt always-evt peeked-r)) - (set! special-peeked l) - (when (null? special-peeked) - (set! special-peeked-tail #f)) - (when (and progress-requested? (zero? p-commit)) - (make-progress)) - #t) - ;; If we can sync done-evt immediately, then finish. - (if (sync/timeout 0 (wrap-evt done-evt (lambda (x) #t))) - (finish) - ;; We need to wait, so we'll have to release the lock. - ;; Send the work to a manager thread. - (let ([result-ch (make-channel)] - [w/manager? use-manager?]) - (if w/manager? - ;; Resume manager if it was running: - (resume-manager) - ;; Start manager if it wasn't running: - (begin - (set! manager-th (thread manage-commits)) - (set! use-manager? #t) - (thread-resume manager-th (current-thread)))) - ;; Sets use-manager? if the manager wasn't already running: - (channel-put manager-ch (list finish unless-evt done-evt result-ch)) - ;; Release locks: - (semaphore-post lock-semaphore) - (begin0 - ;; Wait for manager to complete commit: - (sync result-ch) - ;; Grab locks again, so they're released - ;; properly on exit: - (semaphore-wait lock-semaphore) - (when w/manager? - (suspend-manager)))))) - (define (manage-commits) - (let loop ([commits null]) - (apply - sync - (handle-evt manager-ch - (lambda (c) - (case c - [(suspend) - (channel-get resume-ch) - (loop commits)] - [else - ;; adding a commit - (loop (cons c commits))]))) - (map (lambda (c) - (define (send-result v) - ;; Create a new thread to send the result asynchronously: - (thread-resume - (thread (lambda () - (channel-put (list-ref c 3) v))) - (current-thread)) - (when (null? (cdr commits)) - (set! use-manager? #f)) - (loop (remq c commits))) - ;; Choose between done and unless: - (if (sync/timeout 0 (list-ref c 1)) - (handle-evt always-evt - (lambda (x) - (send-result #f))) - (choice-evt - (handle-evt (list-ref c 1) - (lambda (x) - ;; unless ready, which means that the commit must fail - (send-result #f))) - (handle-evt (list-ref c 2) - (lambda (x) - ;; done-evt ready, which means that the commit - ;; must succeed. - ;; If we get here, then commits are not - ;; suspended, so we implicitly have the - ;; lock. - ((list-ref c 0)) - (send-result #t)))))) - commits)))) - (make-input-port - name - ;; Read - read-it - ;; Peek - (if fast-peek - (let ([fast-peek-k (lambda (s skip) - (peek-it s skip #f))]) - (lambda (s skip unless-evt) - (if (or unless-evt - (byte-ready? peeked-r) - (mpair? special-peeked)) - (peek-it s skip unless-evt) - (fast-peek s skip fast-peek-k)))) - peek-it) - close - (lambda () - (set! progress-requested? #t) - (port-progress-evt peeked-r)) - commit-it - location-proc - count-lines!-proc - init-position - (and buffer-mode-proc - (case-lambda - [() (buffer-mode-proc)] - [(mode) - (set! buffering? (eq? mode 'block)) - (buffer-mode-proc mode)]))))) +(define merge-input + (case-lambda + [(a b) (merge-input a b 4096)] + [(a b limit) + (or (input-port? a) + (raise-type-error 'merge-input "input-port" a)) + (or (input-port? b) + (raise-type-error 'merge-input "input-port" b)) + (or (not limit) + (and (number? limit) (positive? limit) (exact? limit) (integer? limit)) + (raise-type-error 'merge-input "positive exact integer or #f" limit)) + (let-values ([(rd wt) (make-pipe-with-specials limit)] + [(other-done?) #f] + [(sema) (make-semaphore 1)]) + (let ([copy + (lambda (from) + (thread + (lambda () + (copy-port from wt) + (semaphore-wait sema) + (if other-done? + (close-output-port wt) + (set! other-done? #t)) + (semaphore-post sema))))]) + (copy a) + (copy b) + rd))])) - (define peeking-input-port - (opt-lambda (orig-in [name (object-name orig-in)] [delta 0]) - (make-input-port/read-to-peek - name - (lambda (s) - (let ([r (peek-bytes-avail!* s delta #f orig-in)]) - (set! delta (+ delta (cond - [(number? r) r] - [else 1]))) - (if (eq? r 0) - (handle-evt orig-in (lambda (v) 0)) - r))) - (lambda (s skip default) - (peek-bytes-avail!* s (+ delta skip) #f orig-in)) - void))) +;; `make-input-port/read-to-peek' sometimes needs to wrap a special-value +;; procedure so that it's only called once when the value is both +;; peeked and read. +(define-values (struct:memoized make-memoized memoized? memoized-ref memoized-set!) + (make-struct-type 'memoized #f 1 0 #f null (current-inspector) 0)) +(define (memoize p) + (define result #f) + (make-memoized + (if (procedure-arity-includes? p 0) + ;; original p accepts 0 or 4 arguments: + (case-lambda + [() (unless result (set! result (box (p)))) (unbox result)] + [(src line col pos) + (unless result (set! result (box (p src line col pos)))) + (unbox result)]) + ;; original p accepts only 4 arguments: + (lambda (src line col pos) + (unless result (set! result (box (p src line col pos)))) + (unbox result))))) - (define relocate-input-port - (opt-lambda (p line col pos [close? #t]) - (transplant-to-relocate - transplant-input-port - p line col pos close?))) - - (define transplant-input-port - (opt-lambda (p location-proc pos [close? #t] [count-lines!-proc void]) - (make-input-port - (object-name p) - (lambda (s) (let ([v (read-bytes-avail!* s p)]) - (if (eq? v 0) - (wrap-evt p (lambda (x) 0)) - v))) - (lambda (s skip evt) - (let ([v (peek-bytes-avail!* s skip evt p)]) - (if (eq? v 0) - (choice-evt - (wrap-evt p (lambda (x) 0)) - (if evt - (wrap-evt evt (lambda (x) #f)) - never-evt)) - v))) - (lambda () - (when close? - (close-input-port p))) - (and (port-provides-progress-evts? p) - (lambda () - (port-progress-evt p))) - (and (port-provides-progress-evts? p) - (lambda (n evt target-evt) - (port-commit-peeked n evt target-evt p))) - location-proc - count-lines!-proc - pos))) - - ;; Not kill-safe. - (define make-pipe-with-specials - ;; This implementation of pipes is almost CML-style, with a manager thread - ;; to guard access to the pipe content. But we only enable the manager - ;; thread when write evts are active; otherwise, we use a lock semaphore. - ;; (Actually, the lock semaphore has to be used all the time, to guard - ;; the flag indicating whether the manager thread is running.) - (opt-lambda ([limit (expt 2 64)] [in-name 'pipe] [out-name 'pipe]) - (let-values ([(r w) (make-pipe limit)] - [(more) null] - [(more-last) #f] - [(more-sema) #f] - [(close-w?) #f] - [(lock-semaphore) (make-semaphore 1)] - [(mgr-th) #f] - [(via-manager?) #f] - [(mgr-ch) (make-channel)]) - (define (flush-more) - (if (null? more) - (begin - (set! more-last #f) - (when close-w? - (close-output-port w))) - (when (bytes? (mcar more)) - (let ([amt (bytes-length (mcar more))]) - (let ([wrote (write-bytes-avail* (mcar more) w)]) - (if (= wrote amt) - (begin - (set! more (mcdr more)) - (flush-more)) - (begin - ;; This means that we let too many bytes - ;; get written while a special was pending. - ;; (The limit is disabled when a special - ;; is in the pipe.) - (set-mcar! more (subbytes (mcar more) wrote)) - ;; By peeking, make room for more: - (peek-byte r (sub1 (min (pipe-content-length w) - (- amt wrote)))) - (flush-more)))))))) - (define (read-one s) - (let ([v (read-bytes-avail!* s r)]) - (if (eq? v 0) - (if more-last - ;; Return a special - (let ([a (mcar more)]) - (set! more (mcdr more)) - (flush-more) - (lambda (file line col ppos) - a)) - ;; Nothing available, yet. - (begin - (unless more-sema - (set! more-sema (make-semaphore))) - (wrap-evt (semaphore-peek-evt more-sema) - (lambda (x) 0)))) - v))) - (define (close-it) - (set! close-w? #t) - (unless more-last - (close-output-port w)) - (when more-sema - (semaphore-post more-sema))) - (define (write-these-bytes str start end) - (begin0 - (if more-last - (let ([p (mcons (subbytes str start end) null)]) - (set-mcdr! more-last p) - (set! more-last p) - (- end start)) - (let ([v (write-bytes-avail* str w start end)]) - (if (zero? v) - (wrap-evt w (lambda (x) #f)) - v))) - (when more-sema - (semaphore-post more-sema) - (set! more-sema #f)))) - (define (write-spec v) - (let ([p (mcons v null)]) - (if more-last - (set-mcdr! more-last p) - (set! more p)) - (set! more-last p) - (when more-sema - (semaphore-post more-sema) - (set! more-sema #f)))) - (define (serve) - ;; A request is - ;; (list sym result-ch nack-evt . v) - ;; where `v' varies for different `sym's - ;; The possible syms are: read, reply, close, - ;; write, write-spec, write-evt, write-spec-evt - (let loop ([reqs null]) - (apply - sync - ;; Listen for a request: - (handle-evt mgr-ch - (lambda (req) - (let ([req - ;; Most requests we handle immediately and - ;; convert to a reply. The manager thread - ;; implicitly has the lock. - (let ([reply (lambda (v) - (list 'reply (cadr req) (caddr req) v))]) - (case (car req) - [(read) - (reply (read-one (cadddr req)))] - [(close) - (reply (close-it))] - [(write) - (reply (apply write-these-bytes (cdddr req)))] - [(write-spec) - (reply (write-spec (cadddr req)))] - [else req]))]) - (loop (cons req reqs))))) - (if (and (null? reqs) - via-manager?) - ;; If we can get the lock before another request - ;; turn off manager mode: - (handle-evt lock-semaphore - (lambda (x) - (set! via-manager? #f) - (semaphore-post lock-semaphore) - (loop null))) - never-evt) - (append - (map (lambda (req) - (case (car req) - [(reply) (handle-evt (channel-put-evt (cadr req) - (cadddr req)) - (lambda (x) - (loop (remq req reqs))))] - [(write-spec-evt) (if close-w? - ;; Report close error: - (handle-evt (channel-put-evt (cadr req) 'closed) - (lambda (x) - (loop (remq req reqs)))) - ;; Try to write special: - (handle-evt (channel-put-evt (cadr req) #t) - (lambda (x) - ;; We sync'd, so now we *must* write - (write-spec (cadddr req)) - (loop (remq req reqs)))))] - [(write-evt) (if close-w? - ;; Report close error: - (handle-evt (channel-put-evt (cadr req) 'closed) - (lambda (x) - (loop (remq req reqs)))) - ;; Try to write bytes: - (let* ([start (list-ref req 4)] - [end (list-ref req 5)] - [len (if more-last - (- end start) - (min (- end start) - (max 0 - (- limit (pipe-content-length w)))))]) - (if (and (zero? len) - (null? more)) - (handle-evt w (lambda (x) (loop reqs))) - (handle-evt (channel-put-evt (cadr req) len) - (lambda (x) - ;; We sync'd, so now we *must* write - (write-these-bytes (cadddr req) start (+ start len)) - (loop (remq req reqs)))))))])) - reqs) - ;; nack => remove request (could be anything) - (map (lambda (req) - (handle-evt (caddr req) - (lambda (x) - (loop (remq req reqs))))) - reqs))))) - (define (via-manager what req-sfx) - (thread-resume mgr-th (current-thread)) - (let ([ch (make-channel)]) - (sync (nack-guard-evt - (lambda (nack) - (channel-put mgr-ch (list* what ch nack req-sfx)) - ch))))) - (define (start-mgr) - (unless mgr-th - (set! mgr-th (thread serve))) - (set! via-manager? #t)) - (define (evt what req-sfx) - (nack-guard-evt - (lambda (nack) - (resume-mgr) - (let ([ch (make-channel)]) - (call-with-semaphore - lock-semaphore - (lambda () - (unless mgr-th - (set! mgr-th (thread serve))) - (set! via-manager? #t) - (thread-resume mgr-th (current-thread)) - (channel-put mgr-ch (list* what ch nack req-sfx)) - (wrap-evt ch (lambda (x) - (if (eq? x 'close) - (raise-mismatch-error 'write-evt "port is closed: " out) - x))))))))) - (define (resume-mgr) - (when mgr-th - (thread-resume mgr-th (current-thread)))) - (define in - ;; ----- Input ------ - (make-input-port/read-to-peek - in-name - (lambda (s) - (let ([v (read-bytes-avail!* s r)]) - (if (eq? v 0) - (begin - (resume-mgr) - (call-with-semaphore - lock-semaphore - (lambda () - (if via-manager? - (via-manager 'read (list s)) - (read-one s))))) - v))) - #f - void)) - (define out - ;; ----- Output ------ - (make-output-port - out-name - w - ;; write - (lambda (str start end buffer? w/break?) - (if (= start end) - #t - (begin - (resume-mgr) - (call-with-semaphore - lock-semaphore - (lambda () - (if via-manager? - (via-manager 'write (list str start end)) - (write-these-bytes str start end))))))) - ;; close - (lambda () - (resume-mgr) - (call-with-semaphore - lock-semaphore - (lambda () - (if via-manager? - (via-manager 'close null) - (close-it))))) - ;; write-special - (lambda (v buffer? w/break?) - (resume-mgr) - (call-with-semaphore - lock-semaphore - (lambda () - (if via-manager? - (via-manager 'write-spec (list v)) - (write-spec v))))) - ;; write-evt - (lambda (str start end) - (if (= start end) - (wrap-evt always-evt (lambda (x) 0)) - (evt 'write-evt (list str start end)))) - ;; write-special-evt - (lambda (v) - (evt 'write-spec-evt (list v))))) - (values in out)))) - - - (define input-port-append - (opt-lambda (close-orig? . ports) - (make-input-port - (map object-name ports) - (lambda (str) - ;; Reading is easy -- read from the first port, - ;; and get rid of it if the result is eof - (if (null? ports) - eof - (let ([n (read-bytes-avail!* str (car ports))]) - (cond - [(eq? n 0) (wrap-evt (car ports) (lambda (x) 0))] - [(eof-object? n) - (when close-orig? - (close-input-port (car ports))) - (set! ports (cdr ports)) - 0] - [else n])))) - (lambda (str skip unless-evt) - ;; Peeking is more difficult, due to skips. - (let loop ([ports ports][skip skip]) - (if (null? ports) - eof - (let ([n (peek-bytes-avail!* str skip unless-evt (car ports))]) - (cond - [(eq? n 0) - ;; Not ready, yet. - (peek-bytes-avail!-evt str skip unless-evt (car ports))] - [(eof-object? n) - ;; Port is exhausted, or we skipped past its input. - ;; If skip is not zero, we need to figure out - ;; how many chars were skipped. - (loop (cdr ports) - (- skip (compute-avail-to-skip skip (car ports))))] - [else n]))))) - (lambda () - (when close-orig? - (map close-input-port ports)))))) - - (define (convert-stream from from-port - to to-port) - (let ([c (bytes-open-converter from to)] - [in (make-bytes 4096)] - [out (make-bytes 4096)]) - (unless c - (error 'convert-stream "could not create converter from ~e to ~e" - from to)) - (dynamic-wind - void - (lambda () - (let loop ([got 0]) - (let ([n (read-bytes-avail! in from-port got)]) - (let ([got (+ got (if (number? n) - n - 0))]) - (let-values ([(wrote used status) (bytes-convert c in 0 got out)]) - (when (eq? status 'error) - (error 'convert-stream "conversion error")) - (unless (zero? wrote) - (write-bytes out to-port 0 wrote)) - (bytes-copy! in 0 in used got) - (if (not (number? n)) - (begin - (unless (= got used) - (error 'convert-stream "input stream ~a with a partial conversion" - (if (eof-object? n) "ended" "hit a special value"))) - (let-values ([(wrote status) (bytes-convert-end c out)]) - (when (eq? status 'error) - (error 'convert-stream "conversion-end error")) - (unless (zero? wrote) - (write-bytes out to-port 0 wrote)) - (if (eof-object? n) - ;; Success - (void) - (begin - (write-special n to-port) - (loop 0))))) - (loop (- got used)))))))) - (lambda () (bytes-close-converter c))))) - - ;; Helper for input-port-append; given a skip count - ;; and an input port, determine how many characters - ;; (up to upto) are left in the port. We figure this - ;; out using binary search. - (define (compute-avail-to-skip upto p) - (let ([str (make-bytes 1)]) - (let loop ([upto upto][skip 0]) - (if (zero? upto) - skip - (let* ([half (quotient upto 2)] - [n (peek-bytes-avail!* str (+ skip half) #f p)]) - (if (eq? n 1) - (loop (- upto half 1) (+ skip half 1)) - (loop half skip))))))) - - (define make-limited-input-port - (opt-lambda (port limit [close-orig? #t]) - (let ([got 0]) - (make-input-port - (object-name port) - (lambda (str) - (let ([count (min (- limit got) (bytes-length str))]) - (if (zero? count) - eof - (let ([n (read-bytes-avail!* str port 0 count)]) - (cond - [(eq? n 0) (wrap-evt port (lambda (x) 0))] - [(number? n) (set! got (+ got n)) n] - [(procedure? n) (set! got (add1 got)) n] - [else n]))))) - (lambda (str skip progress-evt) - (let ([count (max 0 (min (- limit got skip) (bytes-length str)))]) - (if (zero? count) - eof - (let ([n (peek-bytes-avail!* str skip progress-evt port 0 count)]) - (if (eq? n 0) - (wrap-evt port (lambda (x) 0)) - n))))) - (lambda () - (when close-orig? - (close-input-port port))))))) - - ;; ---------------------------------------- - - (define (poll-or-spawn go) - (poll-guard-evt - (lambda (poll?) - (if poll? - ;; In poll mode, call `go' directly: - (let ([v (go never-evt #f #t)]) - (if v - (wrap-evt always-evt (lambda (x) v)) - never-evt)) - ;; In non-poll mode, start a thread to call go - (nack-guard-evt - (lambda (nack) - (define ch (make-channel)) - (define ready (make-semaphore)) - (let ([t (thread (lambda () - (parameterize-break #t - (with-handlers ([exn:break? void]) - (semaphore-post ready) - (go nack ch #f)))))]) - (thread (lambda () - (sync nack) - (semaphore-wait ready) - (break-thread t)))) - ch)))))) - - (define (read-at-least-bytes!-evt orig-bstr input-port need-more? shrink combo - peek-offset prog-evt) - ;; go is the main reading function, either called directly for - ;; a poll, or called in a thread for a non-poll read - (define (go nack ch poll?) - (let try-again ([pos 0][bstr orig-bstr]) - (let* ([progress-evt (or prog-evt - (port-progress-evt input-port))] - [v ((if poll? - peek-bytes-avail!* - peek-bytes-avail!) - bstr (+ pos (or peek-offset 0)) progress-evt input-port pos)]) - (cond - ;; the first two cases below are shortcuts, and not - ;; strictly necessary - [(sync/timeout 0 nack) (void)] - [(sync/timeout 0 progress-evt) (if poll? - #f - (if prog-evt - (void) - (try-again pos bstr)))] - [(and poll? (equal? v 0)) #f] - [(and (number? v) (need-more? bstr (+ pos v))) - => (lambda (bstr) - (try-again (+ v pos) bstr))] - [else - (let* ([v2 (cond - [(number? v) (shrink bstr (+ v pos))] - [(positive? pos) pos] - [else v])] - [result (combo bstr v2)]) - (cond - [peek-offset - (if poll? - result - (sync (or prog-evt never-evt) - (channel-put-evt ch result)))] - [(port-commit-peeked (if (number? v2) v2 1) - progress-evt - (if poll? - always-evt - (channel-put-evt ch result)) - input-port) - result] - [(and (eof-object? eof) - (zero? pos) - (not (sync/timeout 0 progress-evt))) - ;; Must be a true end-of-file - (let ([result (combo bstr eof)]) - (if poll? - result - (channel-put ch result)))] - [poll? #f] - [else (try-again 0 orig-bstr)]))])))) - (if (zero? (bytes-length orig-bstr)) - (wrap-evt always-evt (lambda (x) 0)) - (poll-or-spawn go))) - - (define (-read-bytes-avail!-evt bstr input-port peek-offset prog-evt) - (read-at-least-bytes!-evt bstr input-port - (lambda (bstr v) (if (zero? v) - bstr - #f)) - (lambda (bstr v) v) - (lambda (bstr v) v) - peek-offset prog-evt)) - - (define (read-bytes-avail!-evt bstr input-port) - (-read-bytes-avail!-evt bstr input-port #f #f)) - - (define (peek-bytes-avail!-evt bstr peek-offset prog-evt input-port) - (-read-bytes-avail!-evt bstr input-port peek-offset prog-evt)) - - (define (-read-bytes!-evt bstr input-port peek-offset prog-evt) - (read-at-least-bytes!-evt bstr input-port - (lambda (bstr v) - (if (v . < . (bytes-length bstr)) - bstr - #f)) - (lambda (bstr v) v) - (lambda (bstr v) v) - peek-offset prog-evt)) - - (define (read-bytes!-evt bstr input-port) - (-read-bytes!-evt bstr input-port #f #f)) - - (define (peek-bytes!-evt bstr peek-offset prog-evt input-port) - (-read-bytes!-evt bstr input-port peek-offset prog-evt)) - - (define (-read-bytes-evt len input-port peek-offset prog-evt) - (let ([bstr (make-bytes len)]) +;; Not kill-safe. +;; If the `read' proc returns an event, the event must produce +;; 0 always (which implies that the `read' proc must not return +;; a pipe input port). +(define make-input-port/read-to-peek + (opt-lambda (name read fast-peek close + [location-proc #f] + [count-lines!-proc void] + [init-position 1] + [buffer-mode-proc #f] + [buffering? #f] + [on-consumed #f]) + (define lock-semaphore (make-semaphore 1)) + (define commit-semaphore (make-semaphore 1)) + (define-values (peeked-r peeked-w) (make-pipe)) + (define special-peeked null) + (define special-peeked-tail #f) + (define progress-requested? #f) + (define use-manager? #f) + (define manager-th #f) + (define manager-ch (make-channel)) + (define resume-ch (make-channel)) + (define buf (make-bytes 4096)) + (define (try-again) (wrap-evt - (-read-bytes!-evt bstr input-port peek-offset prog-evt) - (lambda (v) - (if (number? v) - (if (= v len) - bstr - (subbytes bstr 0 v)) - v))))) - - (define (read-bytes-evt len input-port) - (-read-bytes-evt len input-port #f #f)) - - (define (peek-bytes-evt len peek-offset prog-evt input-port) - (-read-bytes-evt len input-port peek-offset prog-evt)) - - (define (-read-string-evt goal input-port peek-offset prog-evt) - (if (zero? goal) - (wrap-evt always-evt (lambda (x) "")) - (let ([bstr (make-bytes goal)] - [c (bytes-open-converter "UTF-8-permissive" "UTF-8")]) - (wrap-evt - (read-at-least-bytes!-evt bstr input-port - (lambda (bstr v) - (if (= v (bytes-length bstr)) - ;; We can't easily use bytes-utf-8-length here, - ;; because we may need more bytes to figure out - ;; the true role of the last byte. The - ;; `bytes-convert' function lets us deal with - ;; the last byte properly. - (let-values ([(bstr2 used status) - (bytes-convert c bstr 0 v)]) - (let ([got (bytes-utf-8-length bstr2)]) - (if (= got goal) - ;; Done: - #f - ;; Need more bytes: - (let ([bstr2 (make-bytes (+ v (- goal got)))]) - (bytes-copy! bstr2 0 bstr) - bstr2)))) - ;; Need more bytes in bstr: - bstr)) - (lambda (bstr v) - ;; We may need one less than v, - ;; because we may have had to peek - ;; an extra byte to discover an - ;; error in the stream. - (if ((bytes-utf-8-length bstr #\? 0 v) . > . goal) - (sub1 v) - v)) - cons - peek-offset prog-evt) - (lambda (bstr+v) - (let ([bstr (car bstr+v)] - [v (cdr bstr+v)]) - (if (number? v) - (bytes->string/utf-8 bstr #\? 0 v) - v))))))) - - (define (read-string-evt goal input-port) - (-read-string-evt goal input-port #f #f)) - - (define (peek-string-evt goal peek-offset prog-evt input-port) - (-read-string-evt goal input-port peek-offset prog-evt)) - - (define (-read-string!-evt str input-port peek-offset prog-evt) - (wrap-evt - (-read-string-evt (string-length str) input-port peek-offset prog-evt) - (lambda (s) - (if (string? s) - (begin - (string-copy! str 0 s) - (string-length s)) - s)))) - - (define (read-string!-evt str input-port) - (-read-string!-evt str input-port #f #f)) - - (define (peek-string!-evt str peek-offset prog-evt input-port) - (-read-string!-evt str input-port peek-offset prog-evt)) - - (define (regexp-match-evt pattern input-port) - (define (go nack ch poll?) - (let try-again () - (let* ([progress-evt (port-progress-evt input-port)] - [m ((if poll? - regexp-match-peek-positions-immediate - regexp-match-peek-positions) - pattern input-port 0 #f progress-evt)]) - (cond - [(sync/timeout 0 nack) (void)] - [(sync/timeout 0 progress-evt) (try-again)] - [(not m) - (if poll? - #f - (sync nack - (handle-evt progress-evt - (lambda (x) (try-again)))))] - [else - (let ([m2 (map (lambda (p) - (and p - (let ([bstr (make-bytes (- (cdr p) (car p)))]) - (unless (= (car p) (cdr p)) - (let loop ([offset 0]) - (let ([v (peek-bytes-avail! bstr (car p) progress-evt input-port offset)]) - (unless (zero? v) - (when ((+ offset v) . < . (bytes-length bstr)) - (loop (+ offset v))))))) - bstr))) - m)]) - (cond - [(and (zero? (cdar m)) - (or poll? - (channel-put ch m2))) - m2] - [(port-commit-peeked (cdar m) - progress-evt - (if poll? - always-evt - (channel-put-evt ch m2)) - input-port) - m2] - [poll? #f] - [else (try-again)]))])))) - (poll-or-spawn go)) - - (define-syntax (newline-rx stx) - (syntax-case stx () - [(_ str) (datum->syntax-object #'here - (byte-regexp - (string->bytes/latin-1 - (format "^(?:(.*?)~a)|(.*?$)" - (syntax-e #'str)))))])) - - (define read-bytes-line-evt - (opt-lambda (input-port [mode 'linefeed]) - (wrap-evt - (regexp-match-evt (case mode - [(linefeed) (newline-rx "\n")] - [(return) (newline-rx "\r")] - [(return-linefeed) (newline-rx "\r\n")] - [(any) (newline-rx "(?:\r\n|\r|\n)")] - [(any-one) (newline-rx "[\r\n]")]) - input-port) - (lambda (m) - (or (cadr m) - (let ([l (caddr m)]) - (if (and l (zero? (bytes-length l))) - eof - l))))))) - - (define read-line-evt - (opt-lambda (input-port [mode 'linefeed]) - (wrap-evt - (read-bytes-line-evt input-port mode) - (lambda (s) - (if (eof-object? s) - s - (bytes->string/utf-8 s #\?)))))) - - (define (eof-evt input-port) - (wrap-evt - (regexp-match-evt #rx#"^$" input-port) - (lambda (x) - eof))) - - ;; -------------------------------------------------- - - ;; Helper for reencode-input-port: simulate the composition - ;; of a CRLF/CRNEL/NEL/LS -> LF decoding and some other - ;; decoding. - ;; The "converter" `c' is (mcons converter saved), where - ;; saved is #f if no byte is saved, otherwise it's a saved - ;; byte. It would be nicer and closer to the `bytes-convert' - ;; interface to not consume a trailing CR, but we don't - ;; know the inner encoding, and so we can't rewind it. - (define (bytes-convert/post-nl c buf buf-start buf-end dest) - (cond - [(and (mcdr c) (= buf-start buf-end)) - ;; No more bytes to convert; provide single - ;; saved byte if it's not #\return, otherwise report 'aborts - (if (eq? (mcdr c) (char->integer #\return)) - (values 0 0 'aborts) - (begin - (bytes-set! dest 0 (mcdr c)) - (set-mcdr! c #f) - (values 1 0 'complete)))] - [(and (mcdr c) (= 1 (bytes-length dest))) - ;; We have a saved byte, but the destination is only 1 byte. - ;; If the saved byte is a return, we need to try decoding more, - ;; which means we may end up saving a non-#\return byte: - (if (eq? (mcdr c) (char->integer #\return)) - (let-values ([(got-c used-c status) - (bytes-convert (mcar c) buf buf-start buf-end dest)]) - (if (positive? got-c) - (cond - [(eq? (bytes-ref dest 0) (char->integer #\newline)) - ;; Found CRLF, so just produce LF (and nothing to save) - (set-mcdr! c #f) - (values 1 used-c status)] + (semaphore-peek-evt lock-semaphore) + (lambda (x) 0))) + (define (suspend-manager) + (channel-put manager-ch 'suspend)) + (define (resume-manager) + (channel-put resume-ch 'resume)) + (define (with-manager-lock thunk) + (thread-resume manager-th (current-thread)) + (dynamic-wind suspend-manager thunk resume-manager)) + (define (make-progress) + ;; We dont worry about this byte getting picked up directly + ;; from peeked-r, because the pipe must have been empty when + ;; we grabed the lock, and since we've grabbed the lock, + ;; no other thread could have re-returned the pipe behind + ;; our back. + (write-byte 0 peeked-w) + (read-byte peeked-r)) + (define (consume-from-peeked s) + (let ([n (read-bytes-avail!* s peeked-r)]) + (when on-consumed (on-consumed n)) + n)) + (define (read-it-with-lock s) + (if use-manager? + (with-manager-lock (lambda () (do-read-it s))) + (do-read-it s))) + (define (read-it s) + (call-with-semaphore lock-semaphore read-it-with-lock try-again s)) + (define (do-read-it s) + (if (byte-ready? peeked-r) + (if on-consumed (consume-from-peeked s) peeked-r) + ;; If nothing is saved from a peeking read, dispatch to + ;; `read', otherwise return previously peeked data + (cond + [(null? special-peeked) + (when progress-requested? (make-progress)) + (if (and buffering? ((bytes-length s) . < . 10)) + ;; Buffering is enabled, so read more to move things + ;; along: + (let ([r (read buf)]) + (if (and (number? r) (positive? r)) + (begin (write-bytes buf peeked-w 0 r) + (if on-consumed (consume-from-peeked s) peeked-r)) + (begin (when on-consumed (on-consumed r)) + r))) + ;; Just read requested amount: + (let ([v (read s)]) + (when on-consumed (on-consumed v)) + v))] + [else (if (bytes? (mcar special-peeked)) + (let ([b (mcar special-peeked)]) + (write-bytes b peeked-w) + (set! special-peeked (mcdr special-peeked)) + (when (null? special-peeked) (set! special-peeked-tail #f)) + (consume-from-peeked s)) + (let ([v (mcar special-peeked)]) + (make-progress) + (set! special-peeked (mcdr special-peeked)) + (when on-consumed (on-consumed v)) + (when (null? special-peeked) (set! special-peeked-tail #f)) + v))]))) + (define (peek-it-with-lock s skip unless-evt) + (if use-manager? + (with-manager-lock (lambda () (do-peek-it s skip unless-evt))) + (do-peek-it s skip unless-evt))) + (define (peek-it s skip unless-evt) + (let ([v (peek-bytes-avail!* s skip unless-evt peeked-r)]) + (if (eq? v 0) + (call-with-semaphore lock-semaphore + peek-it-with-lock try-again s skip unless-evt) + v))) + (define (do-peek-it s skip unless-evt) + (let ([v (peek-bytes-avail!* s skip unless-evt peeked-r)]) + (if (eq? v 0) + ;; The peek may have failed because peeked-r is empty, + ;; because unless-evt is ready, or because the skip is + ;; far. Handle nicely the common case where there are no + ;; specials. + (cond + [(and unless-evt (sync/timeout 0 unless-evt)) + #f] + [(null? special-peeked) + ;; Empty special queue, so read through the original proc. + ;; We only only need + ;; (- (+ skip (bytes-length s)) (pipe-content-length peeked-w)) + ;; bytes, but if buffering is enabled, read more (up to size of + ;; buf) to help move things along. + (let* ([dest (if buffering? + buf + (make-bytes (- (+ skip (bytes-length s)) + (pipe-content-length peeked-w))))] + [r (read dest)]) + (cond + [(number? r) + ;; The nice case --- reading gave us more bytes + (write-bytes dest peeked-w 0 r) + ;; Now try again + (peek-bytes-avail!* s skip #f peeked-r)] + [(evt? r) + (if unless-evt + ;; Technically, there's a race condition here. + ;; We might choose r (and return 0) even when + ;; unless-evt becomes available first. However, + ;; this race is detectable only by the inside + ;; of `read'. + (choice-evt r (wrap-evt unless-evt (lambda (x) #f))) + r)] [else - ;; Next char fits in a byte, so it isn't NEL, etc. - ;; Save it, and for now return the #\return. - (set-mcdr! c (bytes-ref dest 0)) - (bytes-set! dest 0 (char->integer #\newline)) - (values 1 used-c 'continues)]) - ;; Didn't decode any more; ask for bigger input, etc. - (values 0 0 status))) - ;; Saved a non-#\return, so use that up now. - (begin - (bytes-set! dest 0 (mcdr c)) - (set-mcdr! c #f) - (values 1 0 'continues)))] - [else - ;; Normal convert, maybe prefixed: - (let-values ([(got-c used-c status) - (bytes-convert (mcar c) buf buf-start buf-end dest - (if (mcdr c) 1 0))]) - (let* ([got-c (if (mcdr c) - ;; Insert saved character: - (begin - (bytes-set! dest 0 (char->integer #\return)) - (set-mcdr! c #f) - (add1 got-c)) - got-c)] - [got-c (if (and (positive? got-c) - (eq? (bytes-ref dest (sub1 got-c)) (char->integer #\return)) - (not (eq? status 'error))) - ;; Save trailing carriage return: - (begin - (set-mcdr! c (char->integer #\return)) - (sub1 got-c)) - got-c)]) - ;; Iterate through the converted bytes to apply the newline conversions: - (let loop ([i 0] - [j 0]) + (set! special-peeked (mcons r null)) + (set! special-peeked-tail special-peeked) + ;; Now try again + (do-peek-it s skip unless-evt)]))] + [else + ;; Non-empty special queue, so try to use it + (let* ([avail (pipe-content-length peeked-r)] + [sk (- skip avail)]) + (let loop ([sk sk] [l special-peeked]) + (cond + [(null? l) + ;; Not enough even in the special queue. + ;; Read once and add it. + (let* ([t (make-bytes (min 4096 (+ sk (bytes-length s))))] + [r (read t)]) + (cond + [(evt? r) + (if unless-evt + ;; See note above + (choice-evt r (wrap-evt unless-evt (lambda (x) #f))) + r)] + [(eq? r 0) + ;; Original read thinks a spin is ok, + ;; so we return 0 to skin, too. + 0] + [else (let ([v (if (number? r) + (subbytes t 0 r) + r)]) + (let ([pr (mcons v null)]) + (set-mcdr! special-peeked-tail pr) + (set! special-peeked-tail pr)) + ;; Got something; now try again + (do-peek-it s skip unless-evt))]))] + [(eof-object? (mcar l)) + ;; No peeking past an EOF + eof] + [(procedure? (mcar l)) + (if (zero? sk) + ;; We should call the procedure only once. Change + ;; (mcar l) to a memoizing function, if it isn't already: + (let ([proc (mcar l)]) + (if (memoized? proc) + proc + (let ([proc (memoize proc)]) + (set-mcar! l proc) + proc))) + ;; Skipping over special... + (loop (sub1 sk) (mcdr l)))] + [(bytes? (mcar l)) + (let ([len (bytes-length (mcar l))]) + (if (sk . < . len) + (let ([n (min (bytes-length s) + (- len sk))]) + (bytes-copy! s 0 (mcar l) sk (+ sk n)) + n) + (loop (- sk len) (mcdr l))))])))]) + v))) + (define (commit-it-with-lock amt unless-evt done-evt) + (if use-manager? + (with-manager-lock (lambda () (do-commit-it amt unless-evt done-evt))) + (do-commit-it amt unless-evt done-evt))) + (define (commit-it amt unless-evt done-evt) + (call-with-semaphore lock-semaphore + commit-it-with-lock #f amt unless-evt done-evt)) + (define (do-commit-it amt unless-evt done-evt) + (if (sync/timeout 0 unless-evt) + #f + (let* ([avail (pipe-content-length peeked-r)] + [p-commit (min avail amt)]) + (let loop ([amt (- amt p-commit)] [l special-peeked]) (cond - [(= i got-c) - (values (- got-c (- i j)) used-c (if (and (eq? 'complete status) - (mcdr c)) - 'aborts - status))] + [(amt . <= . 0) + ;; Enough has been peeked. Do commit... + (actual-commit p-commit l unless-evt done-evt)] + [(null? l) + ;; Requested commit was larger than previous peeks + #f] + [(bytes? (mcar l)) + (let ([bl (bytes-length (mcar l))]) + (if (bl . > . amt) + ;; Split the string + (let ([next (mcons (subbytes (mcar l) amt) (mcdr l))]) + (set-mcar! l (subbytes (mcar l) 0 amt)) + (set-mcdr! l next) + (when (eq? l special-peeked-tail) + (set! special-peeked-tail next)) + (loop 0 (mcdr l))) + ;; Consume this string... + (loop (- amt bl) (mcdr l))))] + [else + (loop (sub1 amt) (mcdr l))]))))) + (define (actual-commit p-commit l unless-evt done-evt) + ;; The `finish' proc finally, actually, will commit... + (define (finish) + (unless (zero? p-commit) + (peek-byte peeked-r (sub1 p-commit)) + (port-commit-peeked p-commit unless-evt always-evt peeked-r)) + (set! special-peeked l) + (when (null? special-peeked) (set! special-peeked-tail #f)) + (when (and progress-requested? (zero? p-commit)) (make-progress)) + #t) + ;; If we can sync done-evt immediately, then finish. + (if (sync/timeout 0 (wrap-evt done-evt (lambda (x) #t))) + (finish) + ;; We need to wait, so we'll have to release the lock. + ;; Send the work to a manager thread. + (let ([result-ch (make-channel)] + [w/manager? use-manager?]) + (if w/manager? + ;; Resume manager if it was running: + (resume-manager) + ;; Start manager if it wasn't running: + (begin (set! manager-th (thread manage-commits)) + (set! use-manager? #t) + (thread-resume manager-th (current-thread)))) + ;; Sets use-manager? if the manager wasn't already running: + (channel-put manager-ch (list finish unless-evt done-evt result-ch)) + ;; Release locks: + (semaphore-post lock-semaphore) + (begin0 ;; Wait for manager to complete commit: + (sync result-ch) + ;; Grab locks again, so they're released + ;; properly on exit: + (semaphore-wait lock-semaphore) + (when w/manager? (suspend-manager)))))) + (define (manage-commits) + (let loop ([commits null]) + (apply + sync + (handle-evt manager-ch + (lambda (c) + (case c + [(suspend) + (channel-get resume-ch) + (loop commits)] + [else + ;; adding a commit + (loop (cons c commits))]))) + (map (lambda (c) + (define (send-result v) + ;; Create a new thread to send the result asynchronously: + (thread-resume + (thread (lambda () (channel-put (list-ref c 3) v))) + (current-thread)) + (when (null? (cdr commits)) + (set! use-manager? #f)) + (loop (remq c commits))) + ;; Choose between done and unless: + (if (sync/timeout 0 (list-ref c 1)) + (handle-evt always-evt (lambda (x) (send-result #f))) + (choice-evt + (handle-evt (list-ref c 1) + (lambda (x) + ;; unless ready, which means that the commit must fail + (send-result #f))) + (handle-evt (list-ref c 2) + (lambda (x) + ;; done-evt ready, which means that the commit + ;; must succeed. + ;; If we get here, then commits are not + ;; suspended, so we implicitly have the + ;; lock. + ((list-ref c 0)) + (send-result #t)))))) + commits)))) + (make-input-port + name + ;; Read + read-it + ;; Peek + (if fast-peek + (let ([fast-peek-k (lambda (s skip) (peek-it s skip #f))]) + (lambda (s skip unless-evt) + (if (or unless-evt + (byte-ready? peeked-r) + (mpair? special-peeked)) + (peek-it s skip unless-evt) + (fast-peek s skip fast-peek-k)))) + peek-it) + close + (lambda () + (set! progress-requested? #t) + (port-progress-evt peeked-r)) + commit-it + location-proc + count-lines!-proc + init-position + (and buffer-mode-proc + (case-lambda + [() (buffer-mode-proc)] + [(mode) + (set! buffering? (eq? mode 'block)) + (buffer-mode-proc mode)]))))) + +(define peeking-input-port + (opt-lambda (orig-in [name (object-name orig-in)] [delta 0]) + (make-input-port/read-to-peek + name + (lambda (s) + (let ([r (peek-bytes-avail!* s delta #f orig-in)]) + (set! delta (+ delta (if (number? r) r 1))) + (if (eq? r 0) (handle-evt orig-in (lambda (v) 0)) r))) + (lambda (s skip default) + (peek-bytes-avail!* s (+ delta skip) #f orig-in)) + void))) + +(define relocate-input-port + (opt-lambda (p line col pos [close? #t]) + (transplant-to-relocate transplant-input-port p line col pos close?))) + +(define transplant-input-port + (opt-lambda (p location-proc pos [close? #t] [count-lines!-proc void]) + (make-input-port + (object-name p) + (lambda (s) + (let ([v (read-bytes-avail!* s p)]) + (if (eq? v 0) (wrap-evt p (lambda (x) 0)) v))) + (lambda (s skip evt) + (let ([v (peek-bytes-avail!* s skip evt p)]) + (if (eq? v 0) + (choice-evt + (wrap-evt p (lambda (x) 0)) + (if evt (wrap-evt evt (lambda (x) #f)) never-evt)) + v))) + (lambda () + (when close? (close-input-port p))) + (and (port-provides-progress-evts? p) + (lambda () (port-progress-evt p))) + (and (port-provides-progress-evts? p) + (lambda (n evt target-evt) (port-commit-peeked n evt target-evt p))) + location-proc + count-lines!-proc + pos))) + +;; Not kill-safe. +(define make-pipe-with-specials + ;; This implementation of pipes is almost CML-style, with a manager thread + ;; to guard access to the pipe content. But we only enable the manager + ;; thread when write evts are active; otherwise, we use a lock semaphore. + ;; (Actually, the lock semaphore has to be used all the time, to guard + ;; the flag indicating whether the manager thread is running.) + (opt-lambda ([limit (expt 2 64)] [in-name 'pipe] [out-name 'pipe]) + (let-values ([(r w) (make-pipe limit)] + [(more) null] + [(more-last) #f] + [(more-sema) #f] + [(close-w?) #f] + [(lock-semaphore) (make-semaphore 1)] + [(mgr-th) #f] + [(via-manager?) #f] + [(mgr-ch) (make-channel)]) + (define (flush-more) + (if (null? more) + (begin (set! more-last #f) + (when close-w? (close-output-port w))) + (when (bytes? (mcar more)) + (let ([amt (bytes-length (mcar more))]) + (let ([wrote (write-bytes-avail* (mcar more) w)]) + (if (= wrote amt) + (begin (set! more (mcdr more)) + (flush-more)) + (begin + ;; This means that we let too many bytes + ;; get written while a special was pending. + ;; (The limit is disabled when a special + ;; is in the pipe.) + (set-mcar! more (subbytes (mcar more) wrote)) + ;; By peeking, make room for more: + (peek-byte r (sub1 (min (pipe-content-length w) + (- amt wrote)))) + (flush-more)))))))) + (define (read-one s) + (let ([v (read-bytes-avail!* s r)]) + (if (eq? v 0) + (if more-last + ;; Return a special + (let ([a (mcar more)]) + (set! more (mcdr more)) + (flush-more) + (lambda (file line col ppos) a)) + ;; Nothing available, yet. + (begin (unless more-sema (set! more-sema (make-semaphore))) + (wrap-evt (semaphore-peek-evt more-sema) + (lambda (x) 0)))) + v))) + (define (close-it) + (set! close-w? #t) + (unless more-last (close-output-port w)) + (when more-sema (semaphore-post more-sema))) + (define (write-these-bytes str start end) + (begin0 (if more-last + (let ([p (mcons (subbytes str start end) null)]) + (set-mcdr! more-last p) + (set! more-last p) + (- end start)) + (let ([v (write-bytes-avail* str w start end)]) + (if (zero? v) (wrap-evt w (lambda (x) #f)) v))) + (when more-sema + (semaphore-post more-sema) + (set! more-sema #f)))) + (define (write-spec v) + (let ([p (mcons v null)]) + (if more-last (set-mcdr! more-last p) (set! more p)) + (set! more-last p) + (when more-sema + (semaphore-post more-sema) + (set! more-sema #f)))) + (define (serve) + ;; A request is + ;; (list sym result-ch nack-evt . v) + ;; where `v' varies for different `sym's + ;; The possible syms are: read, reply, close, + ;; write, write-spec, write-evt, write-spec-evt + (let loop ([reqs null]) + (apply + sync + ;; Listen for a request: + (handle-evt + mgr-ch + (lambda (req) + (let ([req + ;; Most requests we handle immediately and + ;; convert to a reply. The manager thread + ;; implicitly has the lock. + (let ([reply (lambda (v) + (list 'reply (cadr req) (caddr req) v))]) + (case (car req) + [(read) + (reply (read-one (cadddr req)))] + [(close) + (reply (close-it))] + [(write) + (reply (apply write-these-bytes (cdddr req)))] + [(write-spec) + (reply (write-spec (cadddr req)))] + [else req]))]) + (loop (cons req reqs))))) + (if (and (null? reqs) via-manager?) + ;; If we can get the lock before another request + ;; turn off manager mode: + (handle-evt lock-semaphore + (lambda (x) + (set! via-manager? #f) + (semaphore-post lock-semaphore) + (loop null))) + never-evt) + (append + (map (lambda (req) + (case (car req) + [(reply) + (handle-evt (channel-put-evt (cadr req) (cadddr req)) + (lambda (x) (loop (remq req reqs))))] + [(write-spec-evt) + (if close-w? + ;; Report close error: + (handle-evt (channel-put-evt (cadr req) 'closed) + (lambda (x) (loop (remq req reqs)))) + ;; Try to write special: + (handle-evt (channel-put-evt (cadr req) #t) + (lambda (x) + ;; We sync'd, so now we *must* write + (write-spec (cadddr req)) + (loop (remq req reqs)))))] + [(write-evt) + (if close-w? + ;; Report close error: + (handle-evt (channel-put-evt (cadr req) 'closed) + (lambda (x) (loop (remq req reqs)))) + ;; Try to write bytes: + (let* ([start (list-ref req 4)] + [end (list-ref req 5)] + [len (if more-last + (- end start) + (min (- end start) + (max 0 + (- limit (pipe-content-length w)))))]) + (if (and (zero? len) (null? more)) + (handle-evt w (lambda (x) (loop reqs))) + (handle-evt + (channel-put-evt (cadr req) len) + (lambda (x) + ;; We sync'd, so now we *must* write + (write-these-bytes (cadddr req) start (+ start len)) + (loop (remq req reqs)))))))])) + reqs) + ;; nack => remove request (could be anything) + (map (lambda (req) + (handle-evt (caddr req) + (lambda (x) (loop (remq req reqs))))) + reqs))))) + (define (via-manager what req-sfx) + (thread-resume mgr-th (current-thread)) + (let ([ch (make-channel)]) + (sync (nack-guard-evt + (lambda (nack) + (channel-put mgr-ch (list* what ch nack req-sfx)) + ch))))) + (define (start-mgr) + (unless mgr-th (set! mgr-th (thread serve))) + (set! via-manager? #t)) + (define (evt what req-sfx) + (nack-guard-evt + (lambda (nack) + (resume-mgr) + (let ([ch (make-channel)]) + (call-with-semaphore + lock-semaphore + (lambda () + (unless mgr-th (set! mgr-th (thread serve))) + (set! via-manager? #t) + (thread-resume mgr-th (current-thread)) + (channel-put mgr-ch (list* what ch nack req-sfx)) + (wrap-evt ch (lambda (x) + (if (eq? x 'close) + (raise-mismatch-error 'write-evt "port is closed: " out) + x))))))))) + (define (resume-mgr) + (when mgr-th (thread-resume mgr-th (current-thread)))) + (define in + ;; ----- Input ------ + (make-input-port/read-to-peek + in-name + (lambda (s) + (let ([v (read-bytes-avail!* s r)]) + (if (eq? v 0) + (begin (resume-mgr) + (call-with-semaphore + lock-semaphore + (lambda () + (if via-manager? + (via-manager 'read (list s)) + (read-one s))))) + v))) + #f + void)) + (define out + ;; ----- Output ------ + (make-output-port + out-name + w + ;; write + (lambda (str start end buffer? w/break?) + (if (= start end) + #t + (begin + (resume-mgr) + (call-with-semaphore + lock-semaphore + (lambda () + (if via-manager? + (via-manager 'write (list str start end)) + (write-these-bytes str start end))))))) + ;; close + (lambda () + (resume-mgr) + (call-with-semaphore + lock-semaphore + (lambda () + (if via-manager? (via-manager 'close null) (close-it))))) + ;; write-special + (lambda (v buffer? w/break?) + (resume-mgr) + (call-with-semaphore + lock-semaphore + (lambda () + (if via-manager? + (via-manager 'write-spec (list v)) + (write-spec v))))) + ;; write-evt + (lambda (str start end) + (if (= start end) + (wrap-evt always-evt (lambda (x) 0)) + (evt 'write-evt (list str start end)))) + ;; write-special-evt + (lambda (v) + (evt 'write-spec-evt (list v))))) + (values in out)))) + +(define input-port-append + (opt-lambda (close-orig? . ports) + (make-input-port + (map object-name ports) + (lambda (str) + ;; Reading is easy -- read from the first port, + ;; and get rid of it if the result is eof + (if (null? ports) + eof + (let ([n (read-bytes-avail!* str (car ports))]) + (cond + [(eq? n 0) (wrap-evt (car ports) (lambda (x) 0))] + [(eof-object? n) + (when close-orig? (close-input-port (car ports))) + (set! ports (cdr ports)) + 0] + [else n])))) + (lambda (str skip unless-evt) + ;; Peeking is more difficult, due to skips. + (let loop ([ports ports][skip skip]) + (if (null? ports) + eof + (let ([n (peek-bytes-avail!* str skip unless-evt (car ports))]) + (cond + [(eq? n 0) + ;; Not ready, yet. + (peek-bytes-avail!-evt str skip unless-evt (car ports))] + [(eof-object? n) + ;; Port is exhausted, or we skipped past its input. + ;; If skip is not zero, we need to figure out + ;; how many chars were skipped. + (loop (cdr ports) + (- skip (compute-avail-to-skip skip (car ports))))] + [else n]))))) + (lambda () + (when close-orig? + (map close-input-port ports)))))) + +(define (convert-stream from from-port to to-port) + (let ([c (bytes-open-converter from to)] + [in (make-bytes 4096)] + [out (make-bytes 4096)]) + (unless c + (error 'convert-stream "could not create converter from ~e to ~e" + from to)) + (dynamic-wind + void + (lambda () + (let loop ([got 0]) + (let ([n (read-bytes-avail! in from-port got)]) + (let ([got (+ got (if (number? n) n 0))]) + (let-values ([(wrote used status) (bytes-convert c in 0 got out)]) + (when (eq? status 'error) + (error 'convert-stream "conversion error")) + (unless (zero? wrote) + (write-bytes out to-port 0 wrote)) + (bytes-copy! in 0 in used got) + (if (not (number? n)) + (begin + (unless (= got used) + (error 'convert-stream + "input stream ~a with a partial conversion" + (if (eof-object? n) "ended" "hit a special value"))) + (let-values ([(wrote status) (bytes-convert-end c out)]) + (when (eq? status 'error) + (error 'convert-stream "conversion-end error")) + (unless (zero? wrote) + (write-bytes out to-port 0 wrote)) + (if (eof-object? n) + ;; Success + (void) + (begin (write-special n to-port) + (loop 0))))) + (loop (- got used)))))))) + (lambda () (bytes-close-converter c))))) + +;; Helper for input-port-append; given a skip count +;; and an input port, determine how many characters +;; (up to upto) are left in the port. We figure this +;; out using binary search. +(define (compute-avail-to-skip upto p) + (let ([str (make-bytes 1)]) + (let loop ([upto upto][skip 0]) + (if (zero? upto) + skip + (let* ([half (quotient upto 2)] + [n (peek-bytes-avail!* str (+ skip half) #f p)]) + (if (eq? n 1) + (loop (- upto half 1) (+ skip half 1)) + (loop half skip))))))) + +(define make-limited-input-port + (opt-lambda (port limit [close-orig? #t]) + (let ([got 0]) + (make-input-port + (object-name port) + (lambda (str) + (let ([count (min (- limit got) (bytes-length str))]) + (if (zero? count) + eof + (let ([n (read-bytes-avail!* str port 0 count)]) + (cond [(eq? n 0) (wrap-evt port (lambda (x) 0))] + [(number? n) (set! got (+ got n)) n] + [(procedure? n) (set! got (add1 got)) n] + [else n]))))) + (lambda (str skip progress-evt) + (let ([count (max 0 (min (- limit got skip) (bytes-length str)))]) + (if (zero? count) + eof + (let ([n (peek-bytes-avail!* str skip progress-evt port 0 count)]) + (if (eq? n 0) + (wrap-evt port (lambda (x) 0)) + n))))) + (lambda () + (when close-orig? + (close-input-port port))))))) + +;; ---------------------------------------- + +(define (poll-or-spawn go) + (poll-guard-evt + (lambda (poll?) + (if poll? + ;; In poll mode, call `go' directly: + (let ([v (go never-evt #f #t)]) + (if v (wrap-evt always-evt (lambda (x) v)) never-evt)) + ;; In non-poll mode, start a thread to call go + (nack-guard-evt + (lambda (nack) + (define ch (make-channel)) + (define ready (make-semaphore)) + (let ([t (thread (lambda () + (parameterize-break #t + (with-handlers ([exn:break? void]) + (semaphore-post ready) + (go nack ch #f)))))]) + (thread (lambda () + (sync nack) + (semaphore-wait ready) + (break-thread t)))) + ch)))))) + +(define (read-at-least-bytes!-evt orig-bstr input-port need-more? shrink combo + peek-offset prog-evt) + ;; go is the main reading function, either called directly for + ;; a poll, or called in a thread for a non-poll read + (define (go nack ch poll?) + (let try-again ([pos 0][bstr orig-bstr]) + (let* ([progress-evt (or prog-evt (port-progress-evt input-port))] + [v ((if poll? peek-bytes-avail!* peek-bytes-avail!) + bstr (+ pos (or peek-offset 0)) progress-evt input-port pos)]) + (cond + ;; the first two cases below are shortcuts, and not + ;; strictly necessary + [(sync/timeout 0 nack) (void)] + [(sync/timeout 0 progress-evt) + (cond [poll? #f] + [prog-evt (void)] + [else (try-again pos bstr)])] + [(and poll? (equal? v 0)) #f] + [(and (number? v) (need-more? bstr (+ pos v))) + => (lambda (bstr) (try-again (+ v pos) bstr))] + [else + (let* ([v2 (cond [(number? v) (shrink bstr (+ v pos))] + [(positive? pos) pos] + [else v])] + [result (combo bstr v2)]) + (cond + [peek-offset + (if poll? + result + (sync (or prog-evt never-evt) + (channel-put-evt ch result)))] + [(port-commit-peeked (if (number? v2) v2 1) + progress-evt + (if poll? + always-evt + (channel-put-evt ch result)) + input-port) + result] + [(and (eof-object? eof) + (zero? pos) + (not (sync/timeout 0 progress-evt))) + ;; Must be a true end-of-file + (let ([result (combo bstr eof)]) + (if poll? result (channel-put ch result)))] + [poll? #f] + [else (try-again 0 orig-bstr)]))])))) + (if (zero? (bytes-length orig-bstr)) + (wrap-evt always-evt (lambda (x) 0)) + (poll-or-spawn go))) + +(define (-read-bytes-avail!-evt bstr input-port peek-offset prog-evt) + (read-at-least-bytes!-evt bstr input-port + (lambda (bstr v) (if (zero? v) bstr #f)) + (lambda (bstr v) v) + (lambda (bstr v) v) + peek-offset prog-evt)) + +(define (read-bytes-avail!-evt bstr input-port) + (-read-bytes-avail!-evt bstr input-port #f #f)) + +(define (peek-bytes-avail!-evt bstr peek-offset prog-evt input-port) + (-read-bytes-avail!-evt bstr input-port peek-offset prog-evt)) + +(define (-read-bytes!-evt bstr input-port peek-offset prog-evt) + (read-at-least-bytes!-evt bstr input-port + (lambda (bstr v) + (if (v . < . (bytes-length bstr)) bstr #f)) + (lambda (bstr v) v) + (lambda (bstr v) v) + peek-offset prog-evt)) + +(define (read-bytes!-evt bstr input-port) + (-read-bytes!-evt bstr input-port #f #f)) + +(define (peek-bytes!-evt bstr peek-offset prog-evt input-port) + (-read-bytes!-evt bstr input-port peek-offset prog-evt)) + +(define (-read-bytes-evt len input-port peek-offset prog-evt) + (let ([bstr (make-bytes len)]) + (wrap-evt + (-read-bytes!-evt bstr input-port peek-offset prog-evt) + (lambda (v) + (if (number? v) + (if (= v len) bstr (subbytes bstr 0 v)) + v))))) + +(define (read-bytes-evt len input-port) + (-read-bytes-evt len input-port #f #f)) + +(define (peek-bytes-evt len peek-offset prog-evt input-port) + (-read-bytes-evt len input-port peek-offset prog-evt)) + +(define (-read-string-evt goal input-port peek-offset prog-evt) + (if (zero? goal) + (wrap-evt always-evt (lambda (x) "")) + (let ([bstr (make-bytes goal)] + [c (bytes-open-converter "UTF-8-permissive" "UTF-8")]) + (wrap-evt + (read-at-least-bytes!-evt + bstr input-port + (lambda (bstr v) + (if (= v (bytes-length bstr)) + ;; We can't easily use bytes-utf-8-length here, + ;; because we may need more bytes to figure out + ;; the true role of the last byte. The + ;; `bytes-convert' function lets us deal with + ;; the last byte properly. + (let-values ([(bstr2 used status) + (bytes-convert c bstr 0 v)]) + (let ([got (bytes-utf-8-length bstr2)]) + (if (= got goal) + ;; Done: + #f + ;; Need more bytes: + (let ([bstr2 (make-bytes (+ v (- goal got)))]) + (bytes-copy! bstr2 0 bstr) + bstr2)))) + ;; Need more bytes in bstr: + bstr)) + (lambda (bstr v) + ;; We may need one less than v, + ;; because we may have had to peek + ;; an extra byte to discover an + ;; error in the stream. + (if ((bytes-utf-8-length bstr #\? 0 v) . > . goal) (sub1 v) v)) + cons + peek-offset prog-evt) + (lambda (bstr+v) + (let ([bstr (car bstr+v)] + [v (cdr bstr+v)]) + (if (number? v) + (bytes->string/utf-8 bstr #\? 0 v) + v))))))) + +(define (read-string-evt goal input-port) + (-read-string-evt goal input-port #f #f)) + +(define (peek-string-evt goal peek-offset prog-evt input-port) + (-read-string-evt goal input-port peek-offset prog-evt)) + +(define (-read-string!-evt str input-port peek-offset prog-evt) + (wrap-evt + (-read-string-evt (string-length str) input-port peek-offset prog-evt) + (lambda (s) + (if (string? s) + (begin (string-copy! str 0 s) + (string-length s)) + s)))) + +(define (read-string!-evt str input-port) + (-read-string!-evt str input-port #f #f)) + +(define (peek-string!-evt str peek-offset prog-evt input-port) + (-read-string!-evt str input-port peek-offset prog-evt)) + +(define (regexp-match-evt pattern input-port) + (define (go nack ch poll?) + (let try-again () + (let* ([progress-evt (port-progress-evt input-port)] + [m ((if poll? + regexp-match-peek-positions-immediate + regexp-match-peek-positions) + pattern input-port 0 #f progress-evt)]) + (cond + [(sync/timeout 0 nack) (void)] + [(sync/timeout 0 progress-evt) (try-again)] + [(not m) + (if poll? + #f + (sync nack + (handle-evt progress-evt + (lambda (x) (try-again)))))] + [else + (let ([m2 (map (lambda (p) + (and p + (let ([bstr (make-bytes (- (cdr p) (car p)))]) + (unless (= (car p) (cdr p)) + (let loop ([offset 0]) + (let ([v (peek-bytes-avail! bstr (car p) progress-evt input-port offset)]) + (unless (zero? v) + (when ((+ offset v) . < . (bytes-length bstr)) + (loop (+ offset v))))))) + bstr))) + m)]) + (cond + [(and (zero? (cdar m)) (or poll? (channel-put ch m2))) + m2] + [(port-commit-peeked + (cdar m) + progress-evt + (if poll? always-evt (channel-put-evt ch m2)) + input-port) + m2] + [poll? #f] + [else (try-again)]))])))) + (poll-or-spawn go)) + +(define-syntax (newline-rx stx) + (syntax-case stx () + [(_ str) + (datum->syntax + #'here + (byte-regexp (string->bytes/latin-1 + (format "^(?:(.*?)~a)|(.*?$)" (syntax-e #'str)))))])) + +(define read-bytes-line-evt + (lambda (input-port [mode 'linefeed]) + (wrap-evt + (regexp-match-evt (case mode + [(linefeed) (newline-rx "\n")] + [(return) (newline-rx "\r")] + [(return-linefeed) (newline-rx "\r\n")] + [(any) (newline-rx "(?:\r\n|\r|\n)")] + [(any-one) (newline-rx "[\r\n]")]) + input-port) + (lambda (m) + (or (cadr m) + (let ([l (caddr m)]) + (if (and l (zero? (bytes-length l))) eof l))))))) + +(define read-line-evt + (lambda (input-port [mode 'linefeed]) + (wrap-evt + (read-bytes-line-evt input-port mode) + (lambda (s) + (if (eof-object? s) s (bytes->string/utf-8 s #\?)))))) + +(define (eof-evt input-port) + (wrap-evt (regexp-match-evt #rx#"^$" input-port) + (lambda (x) eof))) + +;; -------------------------------------------------- + +;; Helper for reencode-input-port: simulate the composition +;; of a CRLF/CRNEL/NEL/LS -> LF decoding and some other +;; decoding. +;; The "converter" `c' is (mcons converter saved), where +;; saved is #f if no byte is saved, otherwise it's a saved +;; byte. It would be nicer and closer to the `bytes-convert' +;; interface to not consume a trailing CR, but we don't +;; know the inner encoding, and so we can't rewind it. +(define (bytes-convert/post-nl c buf buf-start buf-end dest) + (cond + [(and (mcdr c) (= buf-start buf-end)) + ;; No more bytes to convert; provide single + ;; saved byte if it's not #\return, otherwise report 'aborts + (if (eq? (mcdr c) (char->integer #\return)) + (values 0 0 'aborts) + (begin (bytes-set! dest 0 (mcdr c)) + (set-mcdr! c #f) + (values 1 0 'complete)))] + [(and (mcdr c) (= 1 (bytes-length dest))) + ;; We have a saved byte, but the destination is only 1 byte. + ;; If the saved byte is a return, we need to try decoding more, + ;; which means we may end up saving a non-#\return byte: + (if (eq? (mcdr c) (char->integer #\return)) + (let-values ([(got-c used-c status) + (bytes-convert (mcar c) buf buf-start buf-end dest)]) + (if (positive? got-c) + (cond + [(eq? (bytes-ref dest 0) (char->integer #\newline)) + ;; Found CRLF, so just produce LF (and nothing to save) + (set-mcdr! c #f) + (values 1 used-c status)] + [else + ;; Next char fits in a byte, so it isn't NEL, etc. + ;; Save it, and for now return the #\return. + (set-mcdr! c (bytes-ref dest 0)) + (bytes-set! dest 0 (char->integer #\newline)) + (values 1 used-c 'continues)]) + ;; Didn't decode any more; ask for bigger input, etc. + (values 0 0 status))) + ;; Saved a non-#\return, so use that up now. + (begin (bytes-set! dest 0 (mcdr c)) + (set-mcdr! c #f) + (values 1 0 'continues)))] + [else + ;; Normal convert, maybe prefixed: + (let-values ([(got-c used-c status) + (bytes-convert (mcar c) buf buf-start buf-end dest + (if (mcdr c) 1 0))]) + (let* ([got-c (if (mcdr c) + ;; Insert saved character: + (begin (bytes-set! dest 0 (char->integer #\return)) + (set-mcdr! c #f) + (add1 got-c)) + got-c)] + [got-c (if (and (positive? got-c) + (eq? (bytes-ref dest (sub1 got-c)) + (char->integer #\return)) + (not (eq? status 'error))) + ;; Save trailing carriage return: + (begin (set-mcdr! c (char->integer #\return)) + (sub1 got-c)) + got-c)]) + ;; Iterate through the converted bytes to apply the newline + ;; conversions: + (let loop ([i 0] [j 0]) + (cond + [(= i got-c) + (values (- got-c (- i j)) + used-c + (if (and (eq? 'complete status) (mcdr c)) + 'aborts + status))] [(eq? (bytes-ref dest i) (char->integer #\return)) - (cond - [(= (add1 i) got-c) - ;; Found lone CR: - (bytes-set! dest j (char->integer #\newline)) - (loop (add1 i) (add1 j))] - [(eq? (bytes-ref dest (add1 i)) (char->integer #\newline)) - ;; Found CRLF: - (bytes-set! dest j (char->integer #\newline)) - (loop (+ i 2) (add1 j))] - [(and (eq? (bytes-ref dest (add1 i)) #o302) - (eq? (bytes-ref dest (+ i 2)) #o205)) - ;; Found CRNEL: - (bytes-set! dest j (char->integer #\newline)) - (loop (+ i 3) (add1 j))] - [else - ;; Found lone CR: - (bytes-set! dest j (char->integer #\newline)) - (loop (add1 i) (add1 j))])] + (cond [(= (add1 i) got-c) + ;; Found lone CR: + (bytes-set! dest j (char->integer #\newline)) + (loop (add1 i) (add1 j))] + [(eq? (bytes-ref dest (add1 i)) (char->integer #\newline)) + ;; Found CRLF: + (bytes-set! dest j (char->integer #\newline)) + (loop (+ i 2) (add1 j))] + [(and (eq? (bytes-ref dest (add1 i)) #o302) + (eq? (bytes-ref dest (+ i 2)) #o205)) + ;; Found CRNEL: + (bytes-set! dest j (char->integer #\newline)) + (loop (+ i 3) (add1 j))] + [else + ;; Found lone CR: + (bytes-set! dest j (char->integer #\newline)) + (loop (add1 i) (add1 j))])] [(and (eq? (bytes-ref dest i) #o302) (eq? (bytes-ref dest (+ i 1)) #o205)) ;; Found NEL: @@ -1309,559 +1204,542 @@ (unless (= i j) (bytes-set! dest j (bytes-ref dest i))) (loop (add1 i) (add1 j))]))))])) - - (define reencode-input-port - (opt-lambda (port encoding [error-bytes #f] [close? #f] [name (object-name port)] - [newline-convert? #f] - [decode-error (lambda (msg port) - (error 'reencode-input-port - (format "~a: ~e" msg) - port))]) - (let ([c (let ([c (bytes-open-converter encoding "UTF-8")]) - (if newline-convert? - (mcons c #f) - c))] - [ready-bytes (make-bytes 1024)] - [ready-start 0] - [ready-end 0] - [buf (make-bytes 1024)] - [buf-start 0] - [buf-end 0] - [buf-eof? #f] - [buf-eof-result #f] - [buffer-mode (or (file-stream-buffer-mode port) - 'none)]) - ;; Main reader entry: - (define (read-it s) - (cond - [(> ready-end ready-start) - ;; We have leftover converted bytes: - (let ([cnt (min (bytes-length s) - (- ready-end ready-start))]) - (bytes-copy! s 0 ready-bytes ready-start (+ ready-start cnt)) - (set! ready-start (+ ready-start cnt)) - cnt)] - [else - ;; Try converting already-read bytes: - (let-values ([(got-c used-c status) (if (= buf-start buf-end) - (values 0 0 'aborts) - ((if newline-convert? - bytes-convert/post-nl - bytes-convert) - c buf buf-start buf-end s))]) - (when (positive? used-c) - (set! buf-start (+ used-c buf-start))) - (cond - [(positive? got-c) - ;; We converted some bytes into s. - got-c] - [(eq? status 'aborts) - (if buf-eof? - ;; Had an EOF or special in the stream. - (if (= buf-start buf-end) - (if (and newline-convert? (mcdr c)) ; should be bytes-convert-end - ;; Have leftover CR: - (begin - (bytes-set! s 0 (if (eq? (mcdr c) (char->integer #\return)) - (char->integer #\newline) - (mcdr c))) - (set-mcdr! c #f) - 1) - ;; Return EOF: - (begin0 - buf-eof-result - (set! buf-eof? #f) - (set! buf-eof-result #f))) - (handle-error s)) - ;; Need more bytes. - (begin - (when (positive? buf-start) - (bytes-copy! buf 0 buf buf-start buf-end) - (set! buf-end (- buf-end buf-start)) - (set! buf-start 0)) - (let* ([amt (bytes-length s)] - [c (read-bytes-avail!* buf port buf-end - (if (eq? buffer-mode 'block) - (bytes-length buf) - (min (bytes-length buf) - (+ buf-end amt))))]) - (cond - [(or (eof-object? c) - (procedure? c)) - ;; Got EOF/procedure - (set! buf-eof? #t) - (set! buf-eof-result c) - (read-it s)] - [(zero? c) - ;; No bytes ready --- try again later. - (wrap-evt port (lambda (v) 0))] - [else - ;; Got some bytes; loop to decode. - (set! buf-end (+ buf-end c)) - (read-it s)]))))] - [(eq? status 'error) - (handle-error s)] - [(eq? status 'continues) - ;; Need more room to make progress at all. - ;; Decode into ready-bytes. - (let-values ([(got-c used-c status) ((if newline-convert? - bytes-convert/post-nl - bytes-convert) + +(define reencode-input-port + (opt-lambda (port encoding [error-bytes #f] [close? #f] + [name (object-name port)] + [newline-convert? #f] + [decode-error (lambda (msg port) + (error 'reencode-input-port + (format "~a: ~e" msg) + port))]) + (let ([c (let ([c (bytes-open-converter encoding "UTF-8")]) + (if newline-convert? (mcons c #f) c))] + [ready-bytes (make-bytes 1024)] + [ready-start 0] + [ready-end 0] + [buf (make-bytes 1024)] + [buf-start 0] + [buf-end 0] + [buf-eof? #f] + [buf-eof-result #f] + [buffer-mode (or (file-stream-buffer-mode port) 'none)]) + ;; Main reader entry: + (define (read-it s) + (cond + [(> ready-end ready-start) + ;; We have leftover converted bytes: + (let ([cnt (min (bytes-length s) (- ready-end ready-start))]) + (bytes-copy! s 0 ready-bytes ready-start (+ ready-start cnt)) + (set! ready-start (+ ready-start cnt)) + cnt)] + [else + ;; Try converting already-read bytes: + (let-values ([(got-c used-c status) + (if (= buf-start buf-end) + (values 0 0 'aborts) + ((if newline-convert? + bytes-convert/post-nl + bytes-convert) + c buf buf-start buf-end s))]) + (when (positive? used-c) (set! buf-start (+ used-c buf-start))) + (cond + [(positive? got-c) + ;; We converted some bytes into s. + got-c] + [(eq? status 'aborts) + (if buf-eof? + ;; Had an EOF or special in the stream. + (if (= buf-start buf-end) + (if (and newline-convert? (mcdr c)) ; should be bytes-convert-end + ;; Have leftover CR: + (begin + (bytes-set! s 0 + (if (eq? (mcdr c) (char->integer #\return)) + (char->integer #\newline) + (mcdr c))) + (set-mcdr! c #f) + 1) + ;; Return EOF: + (begin0 buf-eof-result + (set! buf-eof? #f) + (set! buf-eof-result #f))) + (handle-error s)) + ;; Need more bytes. + (begin + (when (positive? buf-start) + (bytes-copy! buf 0 buf buf-start buf-end) + (set! buf-end (- buf-end buf-start)) + (set! buf-start 0)) + (let* ([amt (bytes-length s)] + [c (read-bytes-avail!* + buf port buf-end + (if (eq? buffer-mode 'block) + (bytes-length buf) + (min (bytes-length buf) (+ buf-end amt))))]) + (cond + [(or (eof-object? c) (procedure? c)) + ;; Got EOF/procedure + (set! buf-eof? #t) + (set! buf-eof-result c) + (read-it s)] + [(zero? c) + ;; No bytes ready --- try again later. + (wrap-evt port (lambda (v) 0))] + [else + ;; Got some bytes; loop to decode. + (set! buf-end (+ buf-end c)) + (read-it s)]))))] + [(eq? status 'error) + (handle-error s)] + [(eq? status 'continues) + ;; Need more room to make progress at all. + ;; Decode into ready-bytes. + (let-values ([(got-c used-c status) ((if newline-convert? + bytes-convert/post-nl + bytes-convert) c buf buf-start buf-end ready-bytes)]) (unless (memq status '(continues complete)) - (decode-error "unable to make decoding progress" + (decode-error "unable to make decoding progress" port)) - (set! ready-start 0) - (set! ready-end got-c) - (set! buf-start (+ used-c buf-start)) - (read-it s))]))])) + (set! ready-start 0) + (set! ready-end got-c) + (set! buf-start (+ used-c buf-start)) + (read-it s))]))])) - ;; Raise exception or discard first buffered byte. - ;; We assume that read-bytes is empty - (define (handle-error s) - (if error-bytes - (begin - (set! buf-start (add1 buf-start)) - (let ([cnt (min (bytes-length s) - (bytes-length error-bytes))]) - (bytes-copy! s 0 error-bytes 0 cnt) - (bytes-copy! ready-bytes 0 error-bytes cnt) - (set! ready-start 0) - (set! ready-end (- (bytes-length error-bytes) cnt)) - cnt)) - (decode-error "decoding error in input stream" - port))) - - (unless c - (error 'reencode-input-port - "could not create converter from ~e to UTF-8" - encoding)) - - (make-input-port/read-to-peek - name - read-it - #f - (lambda () - (when close? - (close-input-port port)) - (bytes-close-converter (if newline-convert? - (mcar c) - c))) - #f void 1 - (case-lambda - [() buffer-mode] - [(mode) (set! buffer-mode mode)]) - (eq? buffer-mode 'block))))) - - ;; -------------------------------------------------- - - (define reencode-output-port - (opt-lambda (port encoding [error-bytes #f] [close? #f] [name (object-name port)] - [convert-newlines-to #f] - [decode-error (lambda (msg port) - (error 'reencode-input-port - (format "~a: ~e" msg) - port))]) - (let ([c (bytes-open-converter "UTF-8" encoding)] - [ready-bytes (make-bytes 1024)] - [ready-start 0] - [ready-end 0] - [out-bytes (make-bytes 1024)] - [out-start 0] - [out-end 0] - [buffer-mode (or (file-stream-buffer-mode port) - 'block)] - [debuffer-buf #f] - [newline-buffer #f]) - (define-values (buffered-r buffered-w) (make-pipe 4096)) - - ;; The main writing entry point: - (define (write-it s start end no-buffer&block? enable-break?) - (cond - [(= start end) - ;; This is a flush request; no-buffer&block? must be #f - ;; Note: we could get stuck because only half an encoding - ;; is available in out-bytes. - (flush-buffer-pipe #f enable-break?) - (flush-some #f enable-break?) - (if (buffer-flushed?) - 0 - (write-it s start end no-buffer&block? enable-break?))] - [no-buffer&block? - (case (flush-all #t enable-break?) - [(not-done) - ;; We couldn't flush right away, so give up. - #f] - [(done) - (non-blocking-write s start end)] - [(stuck) - ;; We need more bytes to make progress. - ;; Add out-bytes and s into one string for non-blocking-write. - (let ([s2 (bytes-append (subbytes out-bytes out-start out-end) - (subbytes s start end))] - [out-len (- out-end out-start)]) - (let ([c (non-blocking-write s2 0 (bytes-length s2))]) - (and c - (begin - (set! out-start 0) - (set! out-end 0) - (- c out-len)))))])] - [(and (eq? buffer-mode 'block) - (zero? (pipe-content-length buffered-r))) - ;; The port system can buffer to a pipe faster, so give it a pipe. - buffered-w] - [else - ;; Flush/buffer from pipe, first: - (flush-buffer-pipe #f enable-break?) - ;; Flush as needed to make room in the buffer: - (make-buffer-room #f enable-break?) - ;; Buffer some bytes: - (let-values ([(s2 start2 cnt2 used) (convert-newlines s start - (- end start) - (- (bytes-length out-bytes) out-end))]) - (if (zero? used) - ;; No room --- try flushing again: - (write-it s start end #f enable-break?) - ;; Buffer and report success: - (begin - (bytes-copy! out-bytes out-end s2 start2 (+ start2 cnt2)) - (set! out-end (+ cnt2 out-end)) - (case buffer-mode - [(none) (flush-all-now enable-break?)] - [(line) (when (regexp-match-positions #rx#"[\r\n]" s start (+ start used)) - (flush-all-now enable-break?))]) - used)))])) + ;; Raise exception or discard first buffered byte. + ;; We assume that read-bytes is empty + (define (handle-error s) + (if error-bytes + (begin + (set! buf-start (add1 buf-start)) + (let ([cnt (min (bytes-length s) + (bytes-length error-bytes))]) + (bytes-copy! s 0 error-bytes 0 cnt) + (bytes-copy! ready-bytes 0 error-bytes cnt) + (set! ready-start 0) + (set! ready-end (- (bytes-length error-bytes) cnt)) + cnt)) + (decode-error "decoding error in input stream" port))) - (define (convert-newlines s start cnt avail) - ;; If newline converting is on, try convert up to cnt - ;; bytes to produce a result that fits in avail bytes. - (if convert-newlines-to - ;; Conversion: - (let ([end (+ start cnt)] - [avail (min avail 1024)]) - (unless newline-buffer - (set! newline-buffer (make-bytes 1024))) - (let loop ([i start][j 0]) - (cond - [(or (= j avail) (= i end)) (values newline-buffer 0 j i)] - [(eq? (char->integer #\newline) (bytes-ref s i)) - ;; Newline conversion - (let ([len (bytes-length convert-newlines-to)]) - (if ((+ j len) . > . avail) - ;; No room - (values newline-buffer 0 j i) - ;; Room - (begin - (bytes-copy! newline-buffer j convert-newlines-to) + (unless c + (error 'reencode-input-port + "could not create converter from ~e to UTF-8" + encoding)) + + (make-input-port/read-to-peek + name + read-it + #f + (lambda () + (when close? (close-input-port port)) + (bytes-close-converter (if newline-convert? (mcar c) c))) + #f void 1 + (case-lambda + [() buffer-mode] + [(mode) (set! buffer-mode mode)]) + (eq? buffer-mode 'block))))) + +;; -------------------------------------------------- + +(define reencode-output-port + (opt-lambda (port encoding [error-bytes #f] [close? #f] + [name (object-name port)] + [convert-newlines-to #f] + [decode-error (lambda (msg port) + (error 'reencode-input-port + (format "~a: ~e" msg) + port))]) + (let ([c (bytes-open-converter "UTF-8" encoding)] + [ready-bytes (make-bytes 1024)] + [ready-start 0] + [ready-end 0] + [out-bytes (make-bytes 1024)] + [out-start 0] + [out-end 0] + [buffer-mode (or (file-stream-buffer-mode port) 'block)] + [debuffer-buf #f] + [newline-buffer #f]) + (define-values (buffered-r buffered-w) (make-pipe 4096)) + + ;; The main writing entry point: + (define (write-it s start end no-buffer&block? enable-break?) + (cond + [(= start end) + ;; This is a flush request; no-buffer&block? must be #f + ;; Note: we could get stuck because only half an encoding + ;; is available in out-bytes. + (flush-buffer-pipe #f enable-break?) + (flush-some #f enable-break?) + (if (buffer-flushed?) + 0 + (write-it s start end no-buffer&block? enable-break?))] + [no-buffer&block? + (case (flush-all #t enable-break?) + [(not-done) + ;; We couldn't flush right away, so give up. + #f] + [(done) + (non-blocking-write s start end)] + [(stuck) + ;; We need more bytes to make progress. + ;; Add out-bytes and s into one string for non-blocking-write. + (let ([s2 (bytes-append (subbytes out-bytes out-start out-end) + (subbytes s start end))] + [out-len (- out-end out-start)]) + (let ([c (non-blocking-write s2 0 (bytes-length s2))]) + (and c (begin (set! out-start 0) + (set! out-end 0) + (- c out-len)))))])] + [(and (eq? buffer-mode 'block) + (zero? (pipe-content-length buffered-r))) + ;; The port system can buffer to a pipe faster, so give it a pipe. + buffered-w] + [else + ;; Flush/buffer from pipe, first: + (flush-buffer-pipe #f enable-break?) + ;; Flush as needed to make room in the buffer: + (make-buffer-room #f enable-break?) + ;; Buffer some bytes: + (let-values ([(s2 start2 cnt2 used) + (convert-newlines s start + (- end start) + (- (bytes-length out-bytes) out-end))]) + (if (zero? used) + ;; No room --- try flushing again: + (write-it s start end #f enable-break?) + ;; Buffer and report success: + (begin + (bytes-copy! out-bytes out-end s2 start2 (+ start2 cnt2)) + (set! out-end (+ cnt2 out-end)) + (case buffer-mode + [(none) (flush-all-now enable-break?)] + [(line) (when (regexp-match-positions #rx#"[\r\n]" s start + (+ start used)) + (flush-all-now enable-break?))]) + used)))])) + + (define (convert-newlines s start cnt avail) + ;; If newline converting is on, try convert up to cnt + ;; bytes to produce a result that fits in avail bytes. + (if convert-newlines-to + ;; Conversion: + (let ([end (+ start cnt)] + [avail (min avail 1024)]) + (unless newline-buffer + (set! newline-buffer (make-bytes 1024))) + (let loop ([i start][j 0]) + (cond + [(or (= j avail) (= i end)) (values newline-buffer 0 j i)] + [(eq? (char->integer #\newline) (bytes-ref s i)) + ;; Newline conversion + (let ([len (bytes-length convert-newlines-to)]) + (if ((+ j len) . > . avail) + ;; No room + (values newline-buffer 0 j i) + ;; Room + (begin (bytes-copy! newline-buffer j convert-newlines-to) (loop (add1 i) (+ j len)))))] - [else - (bytes-set! newline-buffer j (bytes-ref s i)) - (loop (add1 i) (add1 j))]))) - ;; No conversion: - (let ([cnt (min cnt avail)]) - (values s start cnt cnt)))) + [else + (bytes-set! newline-buffer j (bytes-ref s i)) + (loop (add1 i) (add1 j))]))) + ;; No conversion: + (let ([cnt (min cnt avail)]) + (values s start cnt cnt)))) - (define (make-buffer-room non-block? enable-break?) - (when (or (> ready-end ready-start) - (< (- (bytes-length out-bytes) out-end) 100)) - ;; Make room for conversion. - (flush-some non-block? enable-break?) ;; convert some - (flush-some non-block? enable-break?)) ;; write converted - ;; Make room in buffer - (when (positive? out-start) - (bytes-copy! out-bytes 0 out-bytes out-start out-end) - (set! out-end (- out-end out-start)) - (set! out-start 0))) + (define (make-buffer-room non-block? enable-break?) + (when (or (> ready-end ready-start) + (< (- (bytes-length out-bytes) out-end) 100)) + ;; Make room for conversion. + (flush-some non-block? enable-break?) ;; convert some + (flush-some non-block? enable-break?)) ;; write converted + ;; Make room in buffer + (when (positive? out-start) + (bytes-copy! out-bytes 0 out-bytes out-start out-end) + (set! out-end (- out-end out-start)) + (set! out-start 0))) - (define (flush-buffer-pipe non-block? enable-break?) - (let loop () - (if (zero? (pipe-content-length buffered-r)) - 'done - (begin - (unless debuffer-buf - (set! debuffer-buf (make-bytes 4096))) - (make-buffer-room non-block? enable-break?) - (let ([amt (- (bytes-length out-bytes) out-end)]) - (if (zero? amt) - 'stuck - (if convert-newlines-to - ;; Peek, convert newlines, write, then read converted amount: - (let ([cnt (peek-bytes-avail! debuffer-buf 0 #f buffered-r 0 amt)]) - (let-values ([(s2 start2 cnt2 used) - (convert-newlines debuffer-buf 0 cnt amt)]) - (bytes-copy! out-bytes out-end s2 start2 cnt2) - (set! out-end (+ cnt2 out-end)) - (read-bytes-avail! debuffer-buf buffered-r 0 used) - (loop))) - ;; Skip an indirection: read directly and write: - (let ([cnt (read-bytes-avail! debuffer-buf buffered-r 0 amt)]) - (bytes-copy! out-bytes out-end debuffer-buf 0 cnt) - (set! out-end (+ cnt out-end)) - (loop))))))))) - - (define (non-blocking-write s start end) - ;; For now, everything that we can flushed is flushed. - ;; Try to write the minimal number of bytes, and hope for the - ;; best. If none of all of the minimal bytes get written, - ;; everyone is happy enough. If some of the bytes get written, - ;; the we will have buffered bytes when we shouldn't have. - ;; That probably won't happen, but we can't guarantee it. - (if (sync/timeout 0.0 port) - ;; We should be able to write one byte... - (let loop ([len 1]) - (let*-values ([(s2 start2 len2 used) (convert-newlines s start (- end start) len)] - [(got-c used-c status) (bytes-convert c s2 start2 (+ start2 len2) ready-bytes)]) - (cond - [(positive? got-c) - (try-flush-ready got-c used-c) - ;; If used-c < len2, then we converted only partially --- which - ;; is strange, because we kept adding bytes one at a time. - ;; we will just guess is that the unused bytes were not converted - ;; bytes, and generally hope that this sort of encoding doesn't - ;; show up. - (- used (- len2 used-c))] - [(eq? status 'aborts) - (if (< len (- end start)) - ;; Try converting a bigger chunk - (loop (add1 len)) - ;; We can't flush half an encoding, so just buffer it. - (begin - (when (> len2 (bytes-length out-bytes)) + (define (flush-buffer-pipe non-block? enable-break?) + (let loop () + (if (zero? (pipe-content-length buffered-r)) + 'done + (begin + (unless debuffer-buf (set! debuffer-buf (make-bytes 4096))) + (make-buffer-room non-block? enable-break?) + (let ([amt (- (bytes-length out-bytes) out-end)]) + (if (zero? amt) + 'stuck + (if convert-newlines-to + ;; Peek, convert newlines, write, then read converted amount: + (let ([cnt (peek-bytes-avail! debuffer-buf 0 #f buffered-r + 0 amt)]) + (let-values ([(s2 start2 cnt2 used) + (convert-newlines debuffer-buf 0 cnt amt)]) + (bytes-copy! out-bytes out-end s2 start2 cnt2) + (set! out-end (+ cnt2 out-end)) + (read-bytes-avail! debuffer-buf buffered-r 0 used) + (loop))) + ;; Skip an indirection: read directly and write: + (let ([cnt (read-bytes-avail! debuffer-buf buffered-r + 0 amt)]) + (bytes-copy! out-bytes out-end debuffer-buf 0 cnt) + (set! out-end (+ cnt out-end)) + (loop))))))))) + + (define (non-blocking-write s start end) + ;; For now, everything that we can flushed is flushed. + ;; Try to write the minimal number of bytes, and hope for the + ;; best. If none of all of the minimal bytes get written, + ;; everyone is happy enough. If some of the bytes get written, + ;; the we will have buffered bytes when we shouldn't have. + ;; That probably won't happen, but we can't guarantee it. + (if (sync/timeout 0.0 port) + ;; We should be able to write one byte... + (let loop ([len 1]) + (let*-values ([(s2 start2 len2 used) + (convert-newlines s start (- end start) len)] + [(got-c used-c status) + (bytes-convert c s2 start2 (+ start2 len2) + ready-bytes)]) + (cond + [(positive? got-c) + (try-flush-ready got-c used-c) + ;; If used-c < len2, then we converted only partially + ;; --- which is strange, because we kept adding + ;; bytes one at a time. we will just guess is that + ;; the unused bytes were not converted bytes, and + ;; generally hope that this sort of encoding doesn't + ;; show up. + (- used (- len2 used-c))] + [(eq? status 'aborts) + (if (< len (- end start)) + ;; Try converting a bigger chunk + (loop (add1 len)) + ;; We can't flush half an encoding, so just buffer it. + (begin (when (> len2 (bytes-length out-bytes)) (raise-insane-decoding-length)) (bytes-copy! out-bytes 0 s2 start2 (+ start2 len2)) (set! out-start 0) (set! out-end len2) used))] - [(eq? status 'continues) - ;; Not enough room in ready-bytes!? We give up. - (raise-insane-decoding-length)] - [else - ;; Encoding error. Try to flush error bytes. - (let ([cnt (bytes-length error-bytes)]) - (bytes-copy! ready-bytes 0 error-bytes) - (try-flush-ready cnt 1) - used)]))) - ;; Port is not ready for writing: - #f)) + [(eq? status 'continues) + ;; Not enough room in ready-bytes!? We give up. + (raise-insane-decoding-length)] + [else + ;; Encoding error. Try to flush error bytes. + (let ([cnt (bytes-length error-bytes)]) + (bytes-copy! ready-bytes 0 error-bytes) + (try-flush-ready cnt 1) + used)]))) + ;; Port is not ready for writing: + #f)) - (define (write-special-it v no-buffer&block? enable-break?) - (cond - [(buffer-flushed?) - ((if no-buffer&block? - write-special-avail* - (if enable-break? - (lambda (v p) - (parameterize-break #t (write-special v p))) - write-special)) - v port)] - [else - ;; Note: we could get stuck because only half an encoding - ;; is available in out-bytes. - (flush-buffer-pipe no-buffer&block? enable-break?) - (flush-some no-buffer&block? enable-break?) - (if (or (buffer-flushed?) - (not no-buffer&block?)) - (write-special-it v no-buffer&block? enable-break?) - #f)])) - - ;; flush-all : -> 'done, 'not-done, or 'stuck - (define (flush-all non-block? enable-break?) - (if (eq? (flush-buffer-pipe non-block? enable-break?) 'done) - (let ([orig-none-ready? (= ready-start ready-end)] - [orig-out-start out-start] - [orig-out-end out-end]) - (flush-some non-block? enable-break?) - (if (buffer-flushed?) - 'done - ;; Couldn't flush everything. One possibility is that we need - ;; more bytes to convert before a flush. - (if (and orig-none-ready? - (= ready-start ready-end) - (= orig-out-start out-start) - (= orig-out-end out-end)) - 'stuck - 'not-done))) - 'stuck)) + (define (write-special-it v no-buffer&block? enable-break?) + (cond + [(buffer-flushed?) + ((if no-buffer&block? + write-special-avail* + (if enable-break? + (lambda (v p) (parameterize-break #t (write-special v p))) + write-special)) + v port)] + [else + ;; Note: we could get stuck because only half an encoding + ;; is available in out-bytes. + (flush-buffer-pipe no-buffer&block? enable-break?) + (flush-some no-buffer&block? enable-break?) + (if (or (buffer-flushed?) (not no-buffer&block?)) + (write-special-it v no-buffer&block? enable-break?) + #f)])) - (define (flush-all-now enable-break?) - (case (flush-all #f enable-break?) - [(not-done) (flush-all-now enable-break?)])) - - (define (buffer-flushed?) - (and (= ready-start ready-end) - (= out-start out-end) - (zero? (pipe-content-length buffered-r)))) - - ;; Try to flush immediately a certain number of bytes. - ;; we've already converted them, so we have to keep - ;; the bytes in any case. - (define (try-flush-ready got-c used-c) - (let ([c (write-bytes-avail* ready-bytes port 0 got-c)]) - (unless (= c got-c) - (set! ready-start c) - (set! ready-end got-c)))) + ;; flush-all : -> 'done, 'not-done, or 'stuck + (define (flush-all non-block? enable-break?) + (if (eq? (flush-buffer-pipe non-block? enable-break?) 'done) + (let ([orig-none-ready? (= ready-start ready-end)] + [orig-out-start out-start] + [orig-out-end out-end]) + (flush-some non-block? enable-break?) + (if (buffer-flushed?) + 'done + ;; Couldn't flush everything. One possibility is that we need + ;; more bytes to convert before a flush. + (if (and orig-none-ready? + (= ready-start ready-end) + (= orig-out-start out-start) + (= orig-out-end out-end)) + 'stuck + 'not-done))) + 'stuck)) - ;; Try to make progress flushing buffered bytes - (define (flush-some non-block? enable-break?) - (unless (= ready-start ready-end) - ;; Flush converted bytes: - (let ([cnt ((cond - [non-block? write-bytes-avail*] - [enable-break? write-bytes-avail/enable-break] - [else write-bytes-avail]) - ready-bytes port ready-start ready-end)]) - (set! ready-start (+ ready-start cnt)))) - (when (= ready-start ready-end) - ;; Convert more, if available: - (set! ready-start 0) - (set! ready-end 0) - (when (> out-end out-start) - (let-values ([(got-c used-c status) (bytes-convert c out-bytes out-start out-end ready-bytes)]) - (set! ready-end got-c) - (set! out-start (+ out-start used-c)) - (when (and (eq? status 'continues) - (zero? used-c)) - ;; Yikes! Size of ready-bytes isn't enough room for progress!? - (raise-insane-decoding-length)) - (when (and (eq? status 'error) - (zero? used-c)) - ;; No progress before an encoding error. - (if error-bytes - ;; Write error bytes and drop an output byte: - (begin - (set! out-start (add1 out-start)) - (bytes-copy! ready-bytes 0 error-bytes) - (set! ready-end (bytes-length error-bytes))) - ;; Raise an exception: - (begin - (set! out-start out-end) ;; flush buffer so close can work - (decode-error - "error decoding output to stream" - port)))))))) + (define (flush-all-now enable-break?) + (case (flush-all #f enable-break?) + [(not-done) (flush-all-now enable-break?)])) - ;; This error is used when decoding wants more bytes to make progress even - ;; though we've supplied hundreds of bytes - (define (raise-insane-decoding-length) - (decode-error "unable to make decoding progress" - port)) + (define (buffer-flushed?) + (and (= ready-start ready-end) + (= out-start out-end) + (zero? (pipe-content-length buffered-r)))) - ;; Check that a decoder is available: - (unless c - (error 'reencode-output-port - "could not create converter from ~e to UTF-8" - encoding)) + ;; Try to flush immediately a certain number of bytes. + ;; we've already converted them, so we have to keep + ;; the bytes in any case. + (define (try-flush-ready got-c used-c) + (let ([c (write-bytes-avail* ready-bytes port 0 got-c)]) + (unless (= c got-c) + (set! ready-start c) + (set! ready-end got-c)))) - (make-output-port - name - port - write-it - (lambda () - ;; Flush output - (write-it #"" 0 0 #f #f) - (when close? - (close-output-port port)) - (bytes-close-converter c)) - write-special-it - #f #f - #f void - 1 - (case-lambda - [() buffer-mode] - [(mode) (let ([old buffer-mode]) - (set! buffer-mode mode) - (when (or (and (eq? old 'block) - (memq mode '(none line))) - (and (eq? old 'line) - (memq mode '(none)))) - ;; Flush output - (write-it #"" 0 0 #f #f)))]))))) + ;; Try to make progress flushing buffered bytes + (define (flush-some non-block? enable-break?) + (unless (= ready-start ready-end) + ;; Flush converted bytes: + (let ([cnt ((cond [non-block? write-bytes-avail*] + [enable-break? write-bytes-avail/enable-break] + [else write-bytes-avail]) + ready-bytes port ready-start ready-end)]) + (set! ready-start (+ ready-start cnt)))) + (when (= ready-start ready-end) + ;; Convert more, if available: + (set! ready-start 0) + (set! ready-end 0) + (when (> out-end out-start) + (let-values ([(got-c used-c status) + (bytes-convert c out-bytes out-start out-end + ready-bytes)]) + (set! ready-end got-c) + (set! out-start (+ out-start used-c)) + (when (and (eq? status 'continues) (zero? used-c)) + ;; Yikes! Size of ready-bytes isn't enough room for progress!? + (raise-insane-decoding-length)) + (when (and (eq? status 'error) (zero? used-c)) + ;; No progress before an encoding error. + (if error-bytes + ;; Write error bytes and drop an output byte: + (begin (set! out-start (add1 out-start)) + (bytes-copy! ready-bytes 0 error-bytes) + (set! ready-end (bytes-length error-bytes))) + ;; Raise an exception: + (begin + (set! out-start out-end) ;; flush buffer so close can work + (decode-error + "error decoding output to stream" + port)))))))) - ;; ---------------------------------------- + ;; This error is used when decoding wants more bytes to make + ;; progress even though we've supplied hundreds of bytes + (define (raise-insane-decoding-length) + (decode-error "unable to make decoding progress" port)) - (define dup-output-port - (opt-lambda (p [close? #f]) - (let ([new (transplant-output-port p - (lambda () - (port-next-location p)) - (let-values ([(line col pos) - (port-next-location p)]) - (or pos - (file-position p))) - close? - (lambda () - (port-count-lines! p)))]) - (port-display-handler new (port-display-handler p)) - (port-write-handler new (port-write-handler p)) - new))) + ;; Check that a decoder is available: + (unless c + (error 'reencode-output-port + "could not create converter from ~e to UTF-8" + encoding)) - (define dup-input-port - (opt-lambda (p [close? #f]) - (let ([new (transplant-input-port p - (lambda () - (port-next-location p)) - (let-values ([(line col pos) - (port-next-location p)]) - (or pos - (file-position p))) - close? - (lambda () - (port-count-lines! p)))]) - (port-read-handler new (port-read-handler p)) - new))) + (make-output-port + name + port + write-it + (lambda () + ;; Flush output + (write-it #"" 0 0 #f #f) + (when close? + (close-output-port port)) + (bytes-close-converter c)) + write-special-it + #f #f + #f void + 1 + (case-lambda + [() buffer-mode] + [(mode) (let ([old buffer-mode]) + (set! buffer-mode mode) + (when (or (and (eq? old 'block) (memq mode '(none line))) + (and (eq? old 'line) (memq mode '(none)))) + ;; Flush output + (write-it #"" 0 0 #f #f)))]))))) - ;; ---------------------------------------- - - (provide open-output-nowhere - make-pipe-with-specials - make-input-port/read-to-peek - peeking-input-port - relocate-input-port - transplant-input-port - relocate-output-port - transplant-output-port - merge-input - copy-port - input-port-append - convert-stream - make-limited-input-port - reencode-input-port - reencode-output-port - dup-input-port - dup-output-port - strip-shell-command-start) - - (provide/contract (read-bytes-avail!-evt (mutable-bytes? input-port-with-progress-evts? - . -> . evt?)) - (peek-bytes-avail!-evt (mutable-bytes? exact-nonnegative-integer? evt?/false - input-port-with-progress-evts? - . -> . evt?)) - (read-bytes!-evt (mutable-bytes? input-port-with-progress-evts? . -> . evt?)) - (peek-bytes!-evt (mutable-bytes? exact-nonnegative-integer? evt?/false - input-port-with-progress-evts? - . -> . evt?)) - (read-bytes-evt (exact-nonnegative-integer? input-port-with-progress-evts? - . -> . evt?)) - (peek-bytes-evt (exact-nonnegative-integer? exact-nonnegative-integer? evt?/false - input-port-with-progress-evts? - . -> . evt?)) - (read-string!-evt (mutable-string? input-port-with-progress-evts? - . -> . evt?)) - (peek-string!-evt (mutable-string? exact-nonnegative-integer? evt?/false - input-port-with-progress-evts? - . -> . evt?)) - (read-string-evt (exact-nonnegative-integer? input-port-with-progress-evts? - . -> . evt?)) - (peek-string-evt (exact-nonnegative-integer? exact-nonnegative-integer? evt?/false - input-port-with-progress-evts? - . -> . evt?)) - (regexp-match-evt ((or/c regexp? byte-regexp? string? bytes?) - input-port-with-progress-evts? - . -> . evt?)) +;; ---------------------------------------- - (read-bytes-line-evt (case-> - (input-port-with-progress-evts? . -> . evt?) - (input-port-with-progress-evts? line-mode-symbol? . -> . evt?))) - (read-line-evt (case-> - (input-port-with-progress-evts? . -> . evt?) - (input-port-with-progress-evts? line-mode-symbol? . -> . evt?))) - (eof-evt (input-port-with-progress-evts? . -> . evt?)))) +(define dup-output-port + (opt-lambda (p [close? #f]) + (let ([new (transplant-output-port + p + (lambda () (port-next-location p)) + (let-values ([(line col pos) (port-next-location p)]) + (or pos (file-position p))) + close? + (lambda () (port-count-lines! p)))]) + (port-display-handler new (port-display-handler p)) + (port-write-handler new (port-write-handler p)) + new))) + +(define dup-input-port + (opt-lambda (p [close? #f]) + (let ([new (transplant-input-port + p + (lambda () (port-next-location p)) + (let-values ([(line col pos) (port-next-location p)]) + (or pos (file-position p))) + close? + (lambda () (port-count-lines! p)))]) + (port-read-handler new (port-read-handler p)) + new))) + +;; ---------------------------------------- + +(provide open-output-nowhere + make-pipe-with-specials + make-input-port/read-to-peek + peeking-input-port + relocate-input-port + transplant-input-port + relocate-output-port + transplant-output-port + merge-input + copy-port + input-port-append + convert-stream + make-limited-input-port + reencode-input-port + reencode-output-port + dup-input-port + dup-output-port + strip-shell-command-start) + +(provide/contract + (read-bytes-avail!-evt (mutable-bytes? input-port-with-progress-evts? + . -> . evt?)) + (peek-bytes-avail!-evt (mutable-bytes? exact-nonnegative-integer? evt?/false + input-port-with-progress-evts? + . -> . evt?)) + (read-bytes!-evt (mutable-bytes? input-port-with-progress-evts? . -> . evt?)) + (peek-bytes!-evt (mutable-bytes? exact-nonnegative-integer? evt?/false + input-port-with-progress-evts? + . -> . evt?)) + (read-bytes-evt (exact-nonnegative-integer? input-port-with-progress-evts? + . -> . evt?)) + (peek-bytes-evt (exact-nonnegative-integer? exact-nonnegative-integer? + evt?/false input-port-with-progress-evts? + . -> . evt?)) + (read-string!-evt (mutable-string? input-port-with-progress-evts? + . -> . evt?)) + (peek-string!-evt (mutable-string? exact-nonnegative-integer? evt?/false + input-port-with-progress-evts? + . -> . evt?)) + (read-string-evt (exact-nonnegative-integer? input-port-with-progress-evts? + . -> . evt?)) + (peek-string-evt (exact-nonnegative-integer? exact-nonnegative-integer? + evt?/false input-port-with-progress-evts? + . -> . evt?)) + (regexp-match-evt ((or/c regexp? byte-regexp? string? bytes?) + input-port-with-progress-evts? + . -> . evt?)) + + (read-bytes-line-evt (case-> (input-port-with-progress-evts? . -> . evt?) + (input-port-with-progress-evts? line-mode-symbol? + . -> . evt?))) + (read-line-evt (case-> (input-port-with-progress-evts? . -> . evt?) + (input-port-with-progress-evts? line-mode-symbol? + . -> . evt?))) + (eof-evt (input-port-with-progress-evts? . -> . evt?))) diff --git a/collects/mzlib/pretty.ss b/collects/mzlib/pretty.ss index 7e38db9..8c750b5 100644 --- a/collects/mzlib/pretty.ss +++ b/collects/mzlib/pretty.ss @@ -1050,6 +1050,11 @@ (pp-two-up expr extra pp-expr-list depth apair? acar acdr open close)) + (define (pp-module expr extra depth + apair? acar acdr open close) + (pp-two-up expr extra pp-expr depth + apair? acar acdr open close)) + (define (pp-make-object expr extra depth apair? acar acdr open close) (pp-one-up expr extra pp-expr-list depth @@ -1138,8 +1143,10 @@ ((do letrec-syntaxes+values) (and (no-sharing? expr 2 apair? acdr) pp-do)) - - ((send syntax-case instantiate module) + ((module) + (and (no-sharing? expr 2 apair? acdr) + pp-module)) + ((send syntax-case instantiate) (and (no-sharing? expr 2 apair? acdr) pp-syntax-case)) ((make-object) diff --git a/collects/mzlib/process.ss b/collects/mzlib/process.ss index 21d246b..24775a3 100644 --- a/collects/mzlib/process.ss +++ b/collects/mzlib/process.ss @@ -71,7 +71,11 @@ (define (streamify-out cout out get-thread?) (if (and cout (not (file-stream-port? cout))) - (let ([t (thread (lambda () (copy-port out cout)))]) + (let ([t (thread (lambda () + (dynamic-wind + void + (lambda () (copy-port out cout)) + (lambda () (close-input-port out)))))]) (and get-thread? t)) out)) diff --git a/collects/mzlib/unit.ss b/collects/mzlib/unit.ss index 8bfd095..84c81fc 100644 --- a/collects/mzlib/unit.ss +++ b/collects/mzlib/unit.ss @@ -1,6 +1,5 @@ (module unit mzscheme (require-for-syntax mzlib/list - scheme/pretty stxclass syntax/boundmap syntax/context @@ -31,6 +30,7 @@ unit-from-context define-unit-from-context define-unit-binding unit/new-import-export define-unit/new-import-export + unit/s define-unit/s unit/c define-unit/contract) (define-syntax/err-param (define-signature-form stx) @@ -459,13 +459,14 @@ (define-for-syntax (make-import-unboxing var loc ctc) (if ctc + (with-syntax ([ctc-stx (syntax-property ctc 'inferred-name var)]) + (quasisyntax/loc (error-syntax) + (quote-syntax (let ([v/c (#,loc)]) + (contract ctc-stx (car v/c) (cdr v/c) + (current-contract-region) + #,(id->contract-src-info var)))))) (quasisyntax/loc (error-syntax) - (quote-syntax (let ([v/c ((car #,loc))]) - (contract #,ctc (car v/c) (cdr v/c) - (current-contract-region) - #,(id->contract-src-info var))))) - (quasisyntax/loc (error-syntax) - (quote-syntax ((car #,loc)))))) + (quote-syntax (#,loc))))) ;; build-unit : syntax-object -> ;; (values syntax-object (listof identifier) (listof identifier)) @@ -545,10 +546,7 @@ (list (cons 'dept depr) ...) (syntax-parameterize ([current-contract-region (lambda (stx) #'(quote (unit name)))]) (lambda () - (let ([eloc (let ([loc (box undefined)]) - (cons - (λ () (unbox loc)) - (λ (v) (set-box! loc v))))] ... ...) + (let ([eloc (box undefined)] ... ...) (values (lambda (import-table) (let-values ([(iloc ...) @@ -575,7 +573,7 @@ (eloc ... ...) (ectc ... ...) . body))))) - (unit-export ((export-key ...) (vector-immutable eloc ...)) ...))))))) + (unit-export ((export-key ...) (vector-immutable (λ () (unbox eloc)) ...)) ...))))))) import-tagged-sigids export-tagged-sigids dep-tagged-sigids)))))) @@ -722,12 +720,10 @@ (current-contract-region) 'cant-happen #,(id->contract-src-info id)) - ((cdr #,export-loc) - (let ([#,id #,tmp]) - (cons #,id (current-contract-region)))))) + (set-box! #,export-loc + (cons #,tmp (current-contract-region))))) (quasisyntax/loc defn-or-expr - ((cdr #,export-loc) - (let ([#,id #,tmp]) #,id)))) + (set-box! #,export-loc #,tmp))) (quasisyntax/loc defn-or-expr (define-syntax #,id (make-id-mapper (quote-syntax #,tmp)))))))] @@ -790,30 +786,26 @@ [rename-bindings (get-member-bindings def-table (bound-identifier-mapping-get sig-table var) #'(current-contract-region))]) - (if (or target-ctc ctc) - #`(cons - (λ () - (let ([old-v #,(if ctc - #`(let ([old-v/c ((car #,vref))]) - (contract (let ([#,var (letrec-syntax #,rename-bindings #,ctc)]) #,var) - (car old-v/c) - (cdr old-v/c) (current-contract-region) - #,(id->contract-src-info var))) - #`((car #,vref)))]) - #,(if target-ctc - #'(cons old-v (current-contract-region)) - #'old-v))) - (λ (v) (let ([new-v #,(if ctc - #`(contract (let ([#,var (letrec-syntax #,rename-bindings #,ctc)]) #,var) - (car v) - (current-contract-region) - (cdr v) - #,(id->contract-src-info var)) - #'v)]) - #,(if target-ctc - #`((cdr #,vref) (cons new-v (current-contract-region))) - #`((cdr #,vref) new-v))))) - vref))) + (with-syntax ([ctc-stx (if ctc (syntax-property + #`(letrec-syntax #,rename-bindings #,ctc) + 'inferred-name var) + ctc)]) + (if target-ctc + #`(λ () + (cons #,(if ctc + #`(let ([old-v/c (#,vref)]) + (contract ctc-stx (car old-v/c) + (cdr old-v/c) (current-contract-region) + #,(id->contract-src-info var))) + #`(#,vref)) + (current-contract-region))) + (if ctc + #`(λ () + (let ([old-v/c (#,vref)]) + (contract ctc-stx (car old-v/c) + (cdr old-v/c) (current-contract-region) + #,(id->contract-src-info var)))) + vref))))) (car target-sig) (cadddr target-sig))) target-import-sigs)) @@ -1275,12 +1267,16 @@ (define rename-bindings (get-member-bindings def-table os #'(#%variable-reference))) (map (λ (tb i v c) - #`(let ([v/c ((car #,tb))]) - #,(if c - #`(contract (letrec-syntax #,rename-bindings #,c) (car v/c) (cdr v/c) - (current-contract-region) - #,(id->contract-src-info v)) - #'v/c))) + (if c + (with-syntax ([ctc-stx + (syntax-property + #`(letrec-syntax #,rename-bindings #,c) + 'inferred-name v)]) + #`(let ([v/c (#,tb)]) + (contract ctc-stx (car v/c) (cdr v/c) + (current-contract-region) + #,(id->contract-src-info v)))) + #`(#,tb))) tbs (iota (length (car os))) (map car (car os)) @@ -1476,6 +1472,7 @@ (with-syntax ([new-unit exp] [unit-contract (unit/c/core + #'name (syntax/loc stx ((import (import-tagged-sig-id [i.x i.c] ...) ...) (export (export-tagged-sig-id [e.x e.c] ...) ...))))] @@ -1498,24 +1495,127 @@ (if (car ti) #`(tag #,(car ti) #,(cdr ti)) (cdr ti))) + + ;; (syntax or listof[syntax]) boolean (boolean or listof[syntax]) -> syntax + (define-for-syntax (build-invoke-unit/infer units define? exports) + (define (imps/exps-from-unit u) + (let* ([ui (lookup-def-unit u)] + [unprocess (let ([i (make-syntax-delta-introducer u (unit-info-orig-binder ui))]) + (lambda (p) + (unprocess-tagged-id (cons (car p) (i (cdr p))))))] + [isigs (map unprocess (unit-info-import-sig-ids ui))] + [esigs (map unprocess (unit-info-export-sig-ids ui))]) + (values isigs esigs))) + (define (drop-from-other-list exp-tagged imp-tagged imp-sources) + (let loop ([ts imp-tagged] [ss imp-sources]) + (cond + [(null? ts) null] + [(ormap (lambda (tinfo2) + (and (eq? (car (car ts)) (car tinfo2)) + (siginfo-subtype (cdr tinfo2) (cdr (car ts))))) + exp-tagged) + (loop (cdr ts) (cdr ss))] + [else (cons (car ss) (loop (cdr ts) (cdr ss)))]))) + + (define (drop-duplicates tagged-siginfos sources) + (let loop ([ts tagged-siginfos] [ss sources] [res-t null] [res-s null]) + (cond + [(null? ts) (values res-t res-s)] + [(ormap (lambda (tinfo2) + (and (eq? (car (car ts)) (car tinfo2)) + (siginfo-subtype (cdr tinfo2) (cdr (car ts))))) + (cdr ts)) + (loop (cdr ts) (cdr ss) res-t res-s)] + [else (loop (cdr ts) (cdr ss) (cons (car ts) res-t) (cons (car ss) res-s))]))) + + (define (imps/exps-from-units units exports) + (define-values (isigs esigs) + (let loop ([units units] [imps null] [exps null]) + (if (null? units) + (values imps exps) + (let-values ([(i e) (imps/exps-from-unit (car units))]) + (loop (cdr units) (append i imps) (append e exps)))))) + (define-values (isig tagged-import-sigs import-tagged-infos + import-tagged-sigids import-sigs) + (process-unit-import (datum->syntax-object #f isigs))) + + (define-values (esig tagged-export-sigs export-tagged-infos + export-tagged-sigids export-sigs) + (process-unit-export (datum->syntax-object #f esigs))) + (check-duplicate-subs export-tagged-infos esig) + (let-values ([(itagged isources) (drop-duplicates import-tagged-infos isig)]) + (values (drop-from-other-list export-tagged-infos itagged isources) + (cond + [(list? exports) + (let-values ([(spec-esig spec-tagged-export-sigs spec-export-tagged-infos + spec-export-tagged-sigids spec-export-sigs) + (process-unit-export (datum->syntax-object #f exports))]) + (restrict-exports export-tagged-infos + spec-esig spec-export-tagged-infos))] + [else esig])))) + + (define (restrict-exports unit-tagged-exports spec-exports spec-tagged-exports) + (for-each (lambda (se ste) + (unless (ormap (lambda (ute) + (and (eq? (car ute) (car ste)) + (siginfo-subtype (cdr ute) (cdr ste)))) + unit-tagged-exports) + (raise-stx-err (format "no subunit exports signature ~a" + (syntax-object->datum se)) + se))) + spec-exports + spec-tagged-exports) + spec-exports) + (when (and (not define?) exports) + (error 'build-invoke-unit/infer + "internal error: exports for invoke-unit/infer")) + (when (null? units) + (raise-stx-err "no units in link clause")) + (cond [(identifier? units) + (let-values ([(isig esig) (imps/exps-from-units (list units) exports)]) + (with-syntax ([u units] + [(esig ...) esig] + [(isig ...) isig]) + (if define? + (syntax/loc (error-syntax) (define-values/invoke-unit u (import isig ...) (export esig ...))) + (syntax/loc (error-syntax) (invoke-unit u (import isig ...))))))] + [(list? units) + (let-values ([(isig esig) (imps/exps-from-units units exports)]) + (with-syntax ([(new-unit) (generate-temporaries '(new-unit))] + [(unit ...) units] + [(esig ...) esig] + [(isig ...) isig]) + (with-syntax ([cunit (syntax/loc (error-syntax) + (define-compound-unit/infer new-unit + (import isig ...) (export esig ...) (link unit ...)))]) + + (if define? + (syntax/loc (error-syntax) + (begin cunit + (define-values/invoke-unit new-unit (import isig ...) (export esig ...)))) + (syntax/loc (error-syntax) + (let () + cunit + (invoke-unit new-unit (import isig ...))))))))] + ;; just for error handling + [else (lookup-def-unit units)])) (define-syntax/err-param (define-values/invoke-unit/infer stx) - (syntax-case stx () - ((_ u) - (let* ((ui (lookup-def-unit #'u)) - (unprocess (let ([i (make-syntax-delta-introducer #'u (unit-info-orig-binder ui))]) - (lambda (p) - (unprocess-tagged-id (cons (car p) (i (cdr p)))))))) - (with-syntax (((sig ...) (map unprocess (unit-info-export-sig-ids ui))) - ((isig ...) (map unprocess (unit-info-import-sig-ids ui)))) - (quasisyntax/loc stx - (define-values/invoke-unit u (import isig ...) (export sig ...)))))) - ((_) - (raise-stx-err "missing unit" stx)) - ((_ . b) + (syntax-case stx (export link) + [(_ (link unit ...)) + (build-invoke-unit/infer (syntax->list #'(unit ...)) #t #f)] + [(_ (export e ...) (link unit ...)) + (build-invoke-unit/infer (syntax->list #'(unit ...)) #t (syntax->list #'(e ...)))] + [(_ (export e ...) u) + (build-invoke-unit/infer #'u #t (syntax->list #'(e ...)))] + [(_ u) + (build-invoke-unit/infer #'u #t #f)] + [(_) + (raise-stx-err "missing unit" stx)] + [(_ . b) (raise-stx-err - (format "expected syntax matching (~a )" - (syntax-e (stx-car stx))))))) + (format "expected syntax matching (~a [(export )] ) or (~a [(export )] (link ...))" + (syntax-e (stx-car stx)) (syntax-e (stx-car stx))))])) (define-for-syntax (temp-id-with-tags id i) (syntax-case i (tag) @@ -1773,18 +1873,38 @@ (define-syntax/err-param (invoke-unit/infer stx) (syntax-case stx () - ((_ u) - (let ((ui (lookup-def-unit #'u))) - (with-syntax (((isig ...) (map unprocess-tagged-id - (unit-info-import-sig-ids ui)))) - (quasisyntax/loc stx - (invoke-unit u (import isig ...)))))) - ((_) - (raise-stx-err "missing unit" stx)) - ((_ . b) + [(_ (link unit ...)) + (build-invoke-unit/infer (syntax->list #'(unit ...)) #f #f)] + [(_ u) (build-invoke-unit/infer #'u #f #f)] + [(_) + (raise-stx-err "missing unit" stx)] + [(_ . b) (raise-stx-err - (format "expected syntax matching (~a )" - (syntax-e (stx-car stx))))))) + (format "expected syntax matching (~a ) or (~a (link ...))" + (syntax-e (stx-car stx)) (syntax-e (stx-car stx))))])) + + (define-for-syntax (build-unit/s stx) + (syntax-case stx (import export init-depend) + [((import i ...) (export e ...) (init-depend d ...) u) + (let* ([ui (lookup-def-unit #'u)] + [unprocess (let ([i (make-syntax-delta-introducer #'u (unit-info-orig-binder ui))]) + (lambda (p) + (unprocess-tagged-id (cons (car p) (i (cdr p))))))]) + (with-syntax ([(isig ...) (map unprocess (unit-info-import-sig-ids ui))] + [(esig ...) (map unprocess (unit-info-export-sig-ids ui))]) + (build-unit/new-import-export + (syntax/loc stx + ((import i ...) (export e ...) (init-depend d ...) ((esig ...) u isig ...))))))])) + + (define-syntax/err-param (define-unit/s stx) + (build-define-unit stx (λ (stx) (build-unit/s (check-unit-syntax stx))) + "missing unit name")) + + (define-syntax/err-param (unit/s stx) + (syntax-case stx () + [(_ . stx) + (let-values ([(u x y z) (build-unit/s (check-unit-syntax #'stx))]) + u)])) ) ;(load "test-unit.ss") diff --git a/collects/net/cgi-unit.ss b/collects/net/cgi-unit.ss index ce92d4a..a42c3da 100644 --- a/collects/net/cgi-unit.ss +++ b/collects/net/cgi-unit.ss @@ -96,32 +96,47 @@ ;; -- operates on the default input port; the second value indicates whether ;; reading stopped because an EOF was hit (as opposed to the delimiter being ;; seen); the delimiter is not part of the result -(define (read-until-char ip delimiter) +(define (read-until-char ip delimiter?) (let loop ([chars '()]) (let ([c (read-char ip)]) (cond [(eof-object? c) (values (reverse chars) #t)] - [(char=? c delimiter) (values (reverse chars) #f)] + [(delimiter? c) (values (reverse chars) #f)] [else (loop (cons c chars))])))) +;; delimiter->predicate : +;; symbol -> (char -> bool) +;; returns a predicates to pass to read-until-char +(define (delimiter->predicate delimiter) + (case delimiter + [(eq) (lambda (c) (char=? c #\=))] + [(amp) (lambda (c) (char=? c #\&))] + [(semi) (lambda (c) (char=? c #\;))] + [(amp-or-semi) (lambda (c) (or (char=? c #\&) (char=? c #\;)))])) + ;; read-name+value : iport -> (symbol + bool) x (string + bool) x bool ;; -- If the first value is false, so is the second, and the third is true, ;; indicating EOF was reached without any input seen. Otherwise, the first ;; and second values contain strings and the third is either true or false ;; depending on whether the EOF has been reached. The strings are processed ;; to remove the CGI spec "escape"s. This code is _slightly_ lax: it allows -;; an input to end in `&'. It's not clear this is legal by the CGI spec, +;; an input to end in (current-alist-separator-mode). +;; It's not clear this is legal by the CGI spec, ;; which suggests that the last value binding must end in an EOF. It doesn't ;; look like this matters. It would also introduce needless modality and ;; reduce flexibility. (define (read-name+value ip) - (let-values ([(name eof?) (read-until-char ip #\=)]) + (let-values ([(name eof?) (read-until-char ip (delimiter->predicate 'eq))]) (cond [(and eof? (null? name)) (values #f #f #t)] [eof? (generate-error-output (list "Server generated malformed input for POST method:" (string-append "No binding for `" (list->string name) "' field.")))] - [else (let-values ([(value eof?) (read-until-char ip #\&)]) + [else (let-values ([(value eof?) + (read-until-char + ip + (delimiter->predicate + (current-alist-separator-mode)))]) (values (string->symbol (query-chars->string name)) (query-chars->string value) eof?))]))) diff --git a/collects/net/head-unit.ss b/collects/net/head-unit.ss index 7b42b5a..d5b82b9 100644 --- a/collects/net/head-unit.ss +++ b/collects/net/head-unit.ss @@ -33,15 +33,15 @@ [(and (= (+ offset 2) len) (bytes=? CRLF/bytes (subbytes s offset len))) (void)] ; validated - [(= offset len) (error 'validate-header/bytes "missing ending CRLF")] + [(= offset len) (error 'validate-header "missing ending CRLF")] [(or (regexp-match re:field-start/bytes s offset) (regexp-match re:continue/bytes s offset)) (let ([m (regexp-match-positions #rx#"\r\n" s offset)]) (if m (loop (cdar m)) - (error 'validate-header/bytes "missing ending CRLF")))] - [else (error 'validate-header/bytes "ill-formed header at ~s" - (subbytes s offset (string-length s)))]))) + (error 'validate-header "missing ending CRLF")))] + [else (error 'validate-header "ill-formed header at ~s" + (subbytes s offset (bytes-length s)))]))) ;; otherwise it should be a string: (begin (let ([m (regexp-match #rx"[^\000-\377]" s)]) diff --git a/collects/scheme/package.ss b/collects/scheme/package.ss index 21fd108..38bbbed 100644 --- a/collects/scheme/package.ss +++ b/collects/scheme/package.ss @@ -1,8 +1,10 @@ #lang scheme/base (require (for-syntax scheme/base + scheme/list syntax/kerncase syntax/boundmap - syntax/define)) + syntax/define + syntax/flatten-begin)) (provide define-package package-begin @@ -34,10 +36,24 @@ (with-syntax ([define-values define-values-id]) (syntax/loc stx (define-values (id ...) rhs))))])) -(define-syntax (define*-values stx) +(define-syntax (-define*-values stx) (do-define-* stx #'define-values)) -(define-syntax (define*-syntaxes stx) +(define-syntax (-define*-syntaxes stx) (do-define-* stx #'define-syntaxes)) +(define-syntax (define*-values stx) + (syntax-case stx () + [(_ (id ...) rhs) + (syntax-property + (syntax/loc stx (-define*-values (id ...) rhs)) + 'certify-mode + 'transparent-binding)])) +(define-syntax (define*-syntaxes stx) + (syntax-case stx () + [(_ (id ...) rhs) + (syntax-property + (syntax/loc stx (-define*-syntaxes (id ...) rhs)) + 'certify-mode + 'transparent-binding)])) (define-syntax (define* stx) (let-values ([(id rhs) (normalize-definition stx #'lambda)]) @@ -56,6 +72,10 @@ #f "misuse of a package name" stx))) + + (define (generate-hidden id) + ;; Like `generate-temporaries', but preserve the symbolic name + ((make-syntax-introducer) (datum->syntax #f (syntax-e id)))) (define (reverse-mapping who id exports hidden) (or (ormap (lambda (m) @@ -71,10 +91,16 @@ ;; avoid potential duplicate-definition errors ;; when the name is bound in the same context as ;; the package. - (car (generate-temporaries (list id))))) + (generate-hidden id))) hidden) id))) +(define-for-syntax (move-props orig new) + (datum->syntax new + (syntax-e new) + orig + orig)) + (define-for-syntax (do-define-package stx exp-stx) (syntax-case exp-stx () [(_ pack-id mode exports form ...) @@ -125,8 +151,8 @@ id def-ctxes))] [kernel-forms (list* - #'define*-values - #'define*-syntaxes + #'-define*-values + #'-define*-syntaxes (kernel-form-identifier-list))] [init-exprs (syntax->list #'(form ...))] [new-bindings (make-bound-identifier-mapping)] @@ -158,7 +184,7 @@ ;; It's not accessible, so just hide the name ;; to avoid re-binding errors. (Is this necessary, ;; or would `pre-package-id' take care of it?) - (car (generate-temporaries (list id))))) + (generate-hidden id))) (syntax->list #'(export ...)))]) (syntax/loc stx (define-syntaxes (pack-id) @@ -194,17 +220,14 @@ ids))] [add-package-context (lambda (def-ctxes) (lambda (stx) - (for/fold ([stx stx]) - ([def-ctx (in-list (reverse def-ctxes))]) - (let ([q (local-expand #`(quote #,stx) - ctx - (list #'quote) - def-ctx)]) - (syntax-case q () - [(_ stx) #'stx])))))]) + (let ([q (local-expand #`(quote #,stx) + ctx + (list #'quote) + def-ctxes)]) + (syntax-case q () + [(_ stx) #'stx]))))]) (let loop ([exprs init-exprs] [rev-forms null] - [defined null] [def-ctxes (list def-ctx)]) (cond [(null? exprs) @@ -269,57 +292,53 @@ (lambda () (list (quote-syntax hidden) ...)))))))))))] [else - (let ([expr ((add-package-context (cdr def-ctxes)) - (local-expand ((add-package-context (cdr def-ctxes)) (car exprs)) - ctx - kernel-forms - (car def-ctxes)))]) + (let ([expr (local-expand (car exprs) + ctx + kernel-forms + def-ctxes)]) (syntax-case expr (begin) [(begin . rest) - (loop (append (syntax->list #'rest) (cdr exprs)) + (loop (append (flatten-begin expr) (cdr exprs)) rev-forms - defined def-ctxes)] [(def (id ...) rhs) (and (or (free-identifier=? #'def #'define-syntaxes) - (free-identifier=? #'def #'define*-syntaxes)) + (free-identifier=? #'def #'-define*-syntaxes)) (andmap identifier? (syntax->list #'(id ...)))) (with-syntax ([rhs (local-transformer-expand #'rhs 'expression null)]) - (let ([star? (free-identifier=? #'def #'define*-syntaxes)] + (let ([star? (free-identifier=? #'def #'-define*-syntaxes)] [ids (syntax->list #'(id ...))]) (let* ([def-ctx (if star? - (syntax-local-make-definition-context) - (car def-ctxes))] + (syntax-local-make-definition-context (car def-ctxes)) + (last def-ctxes))] [ids (if star? (map (add-package-context (list def-ctx)) ids) ids)]) (syntax-local-bind-syntaxes ids #'rhs def-ctx) (register-bindings! ids) (loop (cdr exprs) - (cons #`(define-syntaxes #,ids rhs) + (cons (move-props expr #`(define-syntaxes #,ids rhs)) rev-forms) - (cons ids defined) (if star? (cons def-ctx def-ctxes) def-ctxes)))))] [(def (id ...) rhs) (and (or (free-identifier=? #'def #'define-values) - (free-identifier=? #'def #'define*-values)) + (free-identifier=? #'def #'-define*-values)) (andmap identifier? (syntax->list #'(id ...)))) - (let ([star? (free-identifier=? #'def #'define*-values)] + (let ([star? (free-identifier=? #'def #'-define*-values)] [ids (syntax->list #'(id ...))]) (let* ([def-ctx (if star? - (syntax-local-make-definition-context) - (car def-ctxes))] + (syntax-local-make-definition-context (car def-ctxes)) + (last def-ctxes))] [ids (if star? (map (add-package-context (list def-ctx)) ids) ids)]) (syntax-local-bind-syntaxes ids #f def-ctx) (register-bindings! ids) (loop (cdr exprs) - (cons #`(define-values #,ids rhs) rev-forms) - (cons ids defined) + (cons (move-props expr #`(define-values #,ids rhs)) rev-forms) (if star? (cons def-ctx def-ctxes) def-ctxes))))] [else (loop (cdr exprs) @@ -328,7 +347,6 @@ expr #`(define-values () (begin #,expr (values)))) rev-forms) - defined def-ctxes)]))]))))))])) (define-syntax (define-package stx) @@ -378,25 +396,25 @@ (syntax-local-introduce (cdr p)))) ((package-exports v)))] [(h ...) (map syntax-local-introduce ((package-hidden v)))]) - #`(begin - (#,define-syntaxes-id (intro ...) - (let ([rev-map (lambda (x) - (reverse-mapping - 'pack-id - x - (list (cons (quote-syntax a) - (quote-syntax b)) - ...) - (list (quote-syntax h) ...)))]) - (values (make-rename-transformer #'defined rev-map) - ...))))))))])) + (syntax-property + #`(#,define-syntaxes-id (intro ...) + (let ([rev-map (lambda (x) + (reverse-mapping + 'pack-id + x + (list (cons (quote-syntax a) + (quote-syntax b)) + ...) + (list (quote-syntax h) ...)))]) + (values (make-rename-transformer #'defined rev-map) + ...))) + 'disappeared-use + (syntax-local-introduce id))))))])) (define-syntax (open-package stx) (do-open stx #'define-syntaxes)) (define-syntax (open*-package stx) - (syntax-property (do-open stx #'define*-syntaxes) - 'certify-mode - 'transparent-binding)) + (do-open stx #'define*-syntaxes)) (define-for-syntax (package-exported-identifiers id) (let ([v (and (identifier? id) diff --git a/collects/tests/mzscheme/pconvert.ss b/collects/tests/mzscheme/pconvert.ss index ed186dc..628b6e4 100644 --- a/collects/tests/mzscheme/pconvert.ss +++ b/collects/tests/mzscheme/pconvert.ss @@ -5,7 +5,8 @@ (require mzlib/file mzlib/class - mzlib/pconvert) + mzlib/pconvert + mzlib/pconvert-prop) (constructor-style-printing #t) (quasi-read-style-printing #f) @@ -399,4 +400,19 @@ (pc #t) (let ([g (lambda (y) (let ([f (lambda (x) y)]) f))]) (list (g 1) (g 2))))) +;; ---------------------------------------- + +(let () + (define-struct pt (x [y #:mutable]) + #:property prop:print-converter (lambda (v recur) + `(PT! ,(recur (pt-y v)) + ,(recur (pt-x v))))) + (test '(PT! 2 3) print-convert (make-pt 3 2)) + (test '(PT! 2 (list 3)) print-convert (make-pt '(3) 2)) + (let ([p (make-pt 1 2)]) + (set-pt-y! p p) + (test '(shared ([-0- (PT! -0- 1)]) -0-) print-convert p))) + +;; ---------------------------------------- + (report-errs)