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

sync to trunk

Browse Source 
svn: r14750

original commit: 0ddf7338cbc9c3d01c8a24820a04cac82deed6b7
This commit is contained in:
Sam Tobin-Hochstadt 2009-05-08 20:11:09 +00:00
commit ffb4f75f4a
12 changed files with 2081 additions and 3653 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

3
collects/mzlib/contract.ss
View File

@ -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

143
collects/mzlib/deflate.ss
View File

@ -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<vec v1 v2)
(< (gzvector-offset v1) (gzvector-offset v2)))
(define (gzvector-vec v1 v2)
(- (gzvector-offset v1) (gzvector-offset v2)))
(define (gzvector-copy v1 v2 n)
(let ([v1 (gzvector-vector v1)] [o1 (gzvector-offset v1)]
[v2 (gzvector-vector v2)] [o2 (gzvector-offset v2)])
(for m := 0 < n do
(vector-set! v1 (+ o1 m) (vector-ref v2 (+ o2 m))))))
(define (gzvector-zero! v n)
(let ([v (gzvector-vector v)] [o (gzvector-offset v)])
(for m := o < (+ n o) do (vector-set! v m 0))))
(define-struct gzbytes (bytes offset))
(define (gzbytes-ref v o)
(bytes-ref (gzbytes-bytes v) (+ (gzbytes-offset v) o)))
(define (gzbytes-set! v o x)
(bytes-set! (gzbytes-bytes v) (+ (gzbytes-offset v) o) x))
(define (gzbytes+ v o)
(make-gzbytes (gzbytes-bytes v) (+ (gzbytes-offset v) o)))
(define (Trace stderr str . args)
(apply fprintf (current-error-port) str args))
@ -214,9 +206,7 @@
(define real-table (make-vector (<< 1 BITS) 0))
(define prev-vec real-table)
(define prev (make-gzvector prev-vec 0))
(define head-vec real-table)
(define head (make-gzvector head-vec head-vec-delta))
;; /* DECLARE(uch, window, 2L*WSIZE); */
;; /* Sliding window. Input bytes are read into the second half of the window,
@ -241,8 +231,8 @@
(define window_size (* 2 WSIZE))
;; /* window size, 2*WSIZE
;; */
(define window-vec (make-vector window_size 0))
(define window (make-gzvector window-vec 0))
(define window-vec (make-bytes window_size 0))
(define window (make-gzbytes window-vec 0))
(define block_start 0)
;; /* window position at the beginning of the current output block. Gets
@ -354,7 +344,8 @@
(error "bad pack level"))
;; /* Initialize the hash table. */
(gzvector-zero! head HASH_SIZE)
(for i := head-vec-delta < (+ head-vec-delta HASH_SIZE) do
(vector-set! head-vec i 0))
;; /* prev will be initialized on the fly */
@ -391,7 +382,7 @@
(fill_window)))
(set! ins_h 0)
(for j := 0 < MIN_MATCH-1 do (UPDATE_HASH (vector-ref window-vec j)))
(for j := 0 < MIN_MATCH-1 do (UPDATE_HASH (bytes-ref window-vec j)))
(DEBUG (Trace stderr "hash init: ~a\n" ins_h))
;; /* If lookahead < MIN_MATCH, ins_h is garbage, but this is
;; * not important since only literal bytes will be emitted.
@ -450,8 +441,8 @@
;; #endif
(set! strendpos (+ strstart MAX_MATCH))
(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)))
;; /* Do not waste too much time if we already have a good match: */
(when (>= 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)

1622
collects/mzlib/foreign.ss
View File

File diff suppressed because it is too large Load Diff

12
collects/mzlib/inflate.ss
View File

@ -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))))]))
)

3500
collects/mzlib/port.ss
View File

File diff suppressed because it is too large Load Diff

11
collects/mzlib/pretty.ss
View File

@ -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)

6
collects/mzlib/process.ss
View File

@ -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))

266
collects/mzlib/unit.ss
View File

@ -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 <define-unit-identifier>)"
(syntax-e (stx-car stx)))))))
(format "expected syntax matching (~a [(export <define-signature-identifier>)] <define-unit-identifier>) or (~a [(export <define-signature-identifier>)] (link <define-unit-identifier> ...))"
(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 <define-unit-identifier>)"
(syntax-e (stx-car stx)))))))
(format "expected syntax matching (~a <define-unit-identifier>) or (~a (link <define-unit-identifier> ...))"
(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")

25
collects/net/cgi-unit.ss
View File

@ -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?))])))

8
collects/net/head-unit.ss
View File

@ -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)])

120
collects/scheme/package.ss
View File

@ -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)

18
collects/tests/mzscheme/pconvert.ss
View File

@ -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)