From 10541eb0a18d033873ab22fa30ca4d480988b7df Mon Sep 17 00:00:00 2001 From: Stevie Strickland Date: Wed, 18 Feb 2009 02:25:45 +0000 Subject: [PATCH 01/28] * Add initial version of define-struct/contract * Allow uncontracted exports of syntax from a with-contract form. svn: r13717 original commit: 7e8816ce0f212c87e5a32433b869d0dc5ce14002 --- collects/mzlib/contract.ss | 3 ++- 1 file changed, 2 insertions(+), 1 deletion(-) 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 From 5074111cf3769b98b35f6f91a31542d7fab9683b Mon Sep 17 00:00:00 2001 From: Stevie Strickland Date: Mon, 23 Feb 2009 21:46:22 +0000 Subject: [PATCH 02/28] Try to set up the inferred-name property appropriately. svn: r13805 original commit: 78dbc225981e467c8399b5aca535b9e69ccb1a72 --- collects/mzlib/unit.ss | 49 +++++++++++++++++++++--------------------- 1 file changed, 25 insertions(+), 24 deletions(-) diff --git a/collects/mzlib/unit.ss b/collects/mzlib/unit.ss index 8bfd095..0b25cdc 100644 --- a/collects/mzlib/unit.ss +++ b/collects/mzlib/unit.ss @@ -790,30 +790,31 @@ [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 (or target-ctc ctc) + #`(cons + (λ () + (let ([old-v #,(if ctc + #`(let ([old-v/c ((car #,vref))]) + (contract ctc-stx (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 ctc-stx (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)))) (car target-sig) (cadddr target-sig))) target-import-sigs)) From 5d478c9aa124c430c9e0d25b505b21eec9f0491d Mon Sep 17 00:00:00 2001 From: Stevie Strickland Date: Mon, 23 Feb 2009 22:05:09 +0000 Subject: [PATCH 03/28] Fixing some more inferred-name placements. svn: r13806 original commit: e727f4fd083b3728d9531486f26d2be42e2bd882 --- collects/mzlib/unit.ss | 21 +++++++++++++-------- 1 file changed, 13 insertions(+), 8 deletions(-) diff --git a/collects/mzlib/unit.ss b/collects/mzlib/unit.ss index 0b25cdc..64eed91 100644 --- a/collects/mzlib/unit.ss +++ b/collects/mzlib/unit.ss @@ -459,11 +459,12 @@ (define-for-syntax (make-import-unboxing var loc ctc) (if ctc - (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))))) + (with-syntax ([ctc-stx (syntax-property ctc 'inferred-name var)]) + (quasisyntax/loc (error-syntax) + (quote-syntax (let ([v/c ((car #,loc))]) + (contract ctc-stx (car v/c) (cdr v/c) + (current-contract-region) + #,(id->contract-src-info var)))))) (quasisyntax/loc (error-syntax) (quote-syntax ((car #,loc)))))) @@ -1278,9 +1279,13 @@ (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)) + (with-syntax ([ctc-stx + (syntax-property + #`(letrec-syntax #,rename-bindings #,c) + 'inferred-name v)]) + #`(contract ctc-stx (car v/c) (cdr v/c) + (current-contract-region) + #,(id->contract-src-info v))) #'v/c))) tbs (iota (length (car os))) From dd8e3a30af8cbca961dde18cfca6cefa58b035eb Mon Sep 17 00:00:00 2001 From: Stevie Strickland Date: Mon, 23 Feb 2009 22:22:06 +0000 Subject: [PATCH 04/28] More name-setting fun. svn: r13807 original commit: 5a1f31668d00469284ba9712078fdd2e854df53c --- collects/mzlib/unit.ss | 1 + 1 file changed, 1 insertion(+) diff --git a/collects/mzlib/unit.ss b/collects/mzlib/unit.ss index 64eed91..b93bc54 100644 --- a/collects/mzlib/unit.ss +++ b/collects/mzlib/unit.ss @@ -1482,6 +1482,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] ...) ...))))] From 74dad6d8d4210ee9b48ad65b62332117b5acc383 Mon Sep 17 00:00:00 2001 From: Stevie Strickland Date: Thu, 26 Feb 2009 22:52:08 +0000 Subject: [PATCH 05/28] Adding unit/s and define-unit/s, which is the inferred version of unit-new-import-export etc. svn: r13860 original commit: cf005e3297f845dadedda0c6c55f86d2ec8bb661 --- collects/mzlib/unit.ss | 25 ++++++++++++++++++++++++- 1 file changed, 24 insertions(+), 1 deletion(-) diff --git a/collects/mzlib/unit.ss b/collects/mzlib/unit.ss index b93bc54..546e8a0 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) @@ -1793,5 +1793,28 @@ (format "expected syntax matching (~a )" (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") From 87b0915ce180f6d16039af900ab6026683984740 Mon Sep 17 00:00:00 2001 From: Stevie Strickland Date: Sat, 28 Feb 2009 19:46:47 +0000 Subject: [PATCH 06/28] We can't actually change how exports are set, we can only change how they're retrieved, so having each export be a cons of an accessor/mutator pair is misleading. Remove the mutator, just have the unit set-box! the box directly, and just export the accessor. svn: r13882 original commit: b58c5881c645ae2cb248252922cb13b3e5c3c7b5 --- collects/mzlib/unit.ss | 50 +++++++++++++++--------------------------- 1 file changed, 18 insertions(+), 32 deletions(-) diff --git a/collects/mzlib/unit.ss b/collects/mzlib/unit.ss index 546e8a0..fd12908 100644 --- a/collects/mzlib/unit.ss +++ b/collects/mzlib/unit.ss @@ -461,12 +461,12 @@ (if ctc (with-syntax ([ctc-stx (syntax-property ctc 'inferred-name var)]) (quasisyntax/loc (error-syntax) - (quote-syntax (let ([v/c ((car #,loc))]) + (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 ((car #,loc)))))) + (quote-syntax (#,loc))))) ;; build-unit : syntax-object -> ;; (values syntax-object (listof identifier) (listof identifier)) @@ -546,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 ...) @@ -576,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)))))) @@ -723,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)))))))] @@ -796,25 +791,16 @@ 'inferred-name var) ctc)]) (if (or target-ctc ctc) - #`(cons - (λ () - (let ([old-v #,(if ctc - #`(let ([old-v/c ((car #,vref))]) - (contract ctc-stx (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 ctc-stx (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))))) + #`(λ () + (let ([old-v #,(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))]) + #,(if target-ctc + #'(cons old-v (current-contract-region)) + #'old-v))) vref)))) (car target-sig) (cadddr target-sig))) @@ -1277,7 +1263,7 @@ (define rename-bindings (get-member-bindings def-table os #'(#%variable-reference))) (map (λ (tb i v c) - #`(let ([v/c ((car #,tb))]) + #`(let ([v/c (#,tb)]) #,(if c (with-syntax ([ctc-stx (syntax-property From 2a58f8d016d7be5cdc6070540cf1f56dfd84c497 Mon Sep 17 00:00:00 2001 From: Stevie Strickland Date: Sat, 28 Feb 2009 20:34:06 +0000 Subject: [PATCH 07/28] Cleanups. svn: r13884 original commit: 837906b7834c8b42c94db219fd04ebdba188c277 --- collects/mzlib/unit.ss | 20 ++++++++++---------- 1 file changed, 10 insertions(+), 10 deletions(-) diff --git a/collects/mzlib/unit.ss b/collects/mzlib/unit.ss index fd12908..fb4bc86 100644 --- a/collects/mzlib/unit.ss +++ b/collects/mzlib/unit.ss @@ -1263,16 +1263,16 @@ (define rename-bindings (get-member-bindings def-table os #'(#%variable-reference))) (map (λ (tb i v c) - #`(let ([v/c (#,tb)]) - #,(if c - (with-syntax ([ctc-stx - (syntax-property - #`(letrec-syntax #,rename-bindings #,c) - 'inferred-name v)]) - #`(contract ctc-stx (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)) From 5ba7ce5c730413c7656717946bf8d914b592ad8c Mon Sep 17 00:00:00 2001 From: Stevie Strickland Date: Sun, 1 Mar 2009 01:12:03 +0000 Subject: [PATCH 08/28] Just a small change, nothing big. svn: r13885 original commit: bd4c6f40ba5c854817091bf0ddf9463415987bf1 --- collects/mzlib/unit.ss | 26 +++++++++++++++----------- 1 file changed, 15 insertions(+), 11 deletions(-) diff --git a/collects/mzlib/unit.ss b/collects/mzlib/unit.ss index fb4bc86..186e534 100644 --- a/collects/mzlib/unit.ss +++ b/collects/mzlib/unit.ss @@ -790,18 +790,22 @@ #`(letrec-syntax #,rename-bindings #,ctc) 'inferred-name var) ctc)]) - (if (or target-ctc ctc) + (if target-ctc #`(λ () - (let ([old-v #,(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))]) - #,(if target-ctc - #'(cons old-v (current-contract-region)) - #'old-v))) - vref)))) + (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)) From 9c6d98812db713fbb90aa0382f007dc879c9e23e Mon Sep 17 00:00:00 2001 From: Matthew Flatt Date: Wed, 4 Mar 2009 02:54:22 +0000 Subject: [PATCH 09/28] added prop:print-converter svn: r13938 original commit: b4f6c524a13fd3a0ac20d04f54724643628ccae4 --- collects/tests/mzscheme/pconvert.ss | 18 +++++++++++++++++- 1 file changed, 17 insertions(+), 1 deletion(-) 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) From 01540ec84d87457ff07fc33a7586d24c697b51e8 Mon Sep 17 00:00:00 2001 From: Eli Barzilay Date: Thu, 5 Mar 2009 20:55:15 +0000 Subject: [PATCH 10/28] fix a really stupid bug that I introduced in r4490 svn: r13971 original commit: 4b7ec271911368349f2da9b039a84128a26cd522 --- collects/mzlib/deflate.ss | 10 +++++----- 1 file changed, 5 insertions(+), 5 deletions(-) diff --git a/collects/mzlib/deflate.ss b/collects/mzlib/deflate.ss index c3c4f99..20e805a 100644 --- a/collects/mzlib/deflate.ss +++ b/collects/mzlib/deflate.ss @@ -17,11 +17,11 @@ (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 (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))])) (define-syntax pqremove (syntax-rules () From 779bdf38e0ee0ccfa178c21db5d9b4129403aa8a Mon Sep 17 00:00:00 2001 From: Eli Barzilay Date: Thu, 5 Mar 2009 22:38:26 +0000 Subject: [PATCH 11/28] gzvector is gone, have gzbytes instead, (almost?) all input buffers are bytes svn: r13972 original commit: 3931fb7e35d4ef81518efe36f34c558d459c7816 --- collects/mzlib/deflate.ss | 131 +++++++++++++++++--------------------- 1 file changed, 58 insertions(+), 73 deletions(-) diff --git a/collects/mzlib/deflate.ss b/collects/mzlib/deflate.ss index 20e805a..125db9e 100644 --- a/collects/mzlib/deflate.ss +++ b/collects/mzlib/deflate.ss @@ -14,10 +14,17 @@ (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))) + (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)) @@ -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)))) @@ -2078,7 +2067,7 @@ (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,40 +2082,36 @@ ;; (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 (bitwise-and #xFFFF n)) (put_short (>> n 16))) (define outcnt 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) From b60ac8f412138a4d51abbbaba0232bdf48217618 Mon Sep 17 00:00:00 2001 From: Robby Findler Date: Fri, 6 Mar 2009 16:35:04 +0000 Subject: [PATCH 12/28] a bunch of improvements to the splash screen (loads less code before the splash appears, got rid of a bunch of dynamic-requires that were not necessary, fixed the lack of special screen on prince kuhio and king kamehameha days, got rid of the flicker in the tools icons) svn: r13980 original commit: 283c1819a92df7e6949ece8eebf659aac777583c --- collects/mzlib/inflate.ss | 12 ++++++------ 1 file changed, 6 insertions(+), 6 deletions(-) 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))))])) -) + From 0a32e8dd83648af27e36c62608817de5a82084c4 Mon Sep 17 00:00:00 2001 From: Matthew Flatt Date: Mon, 9 Mar 2009 13:24:34 +0000 Subject: [PATCH 13/28] fix package so that syntax-local-value works after define* svn: r14021 original commit: 44e77446467ec9d592bc95befe3d3eea146373c1 --- collects/scheme/package.ss | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/collects/scheme/package.ss b/collects/scheme/package.ss index 21fd108..7cb8720 100644 --- a/collects/scheme/package.ss +++ b/collects/scheme/package.ss @@ -291,7 +291,7 @@ (let ([star? (free-identifier=? #'def #'define*-syntaxes)] [ids (syntax->list #'(id ...))]) (let* ([def-ctx (if star? - (syntax-local-make-definition-context) + (syntax-local-make-definition-context (car def-ctxes)) (car def-ctxes))] [ids (if star? (map (add-package-context (list def-ctx)) ids) From f5e49e3128fdb852ee4a1de2b8ccf4ff593092d0 Mon Sep 17 00:00:00 2001 From: Matthew Flatt Date: Mon, 9 Mar 2009 17:19:21 +0000 Subject: [PATCH 14/28] adjust define*-{values,syntaxes} to avoid certificate problems svn: r14024 original commit: 13b2bc336337077d603050eab67ae4343beb54cc --- collects/scheme/package.ss | 34 +++++++++++++++++++++++----------- 1 file changed, 23 insertions(+), 11 deletions(-) diff --git a/collects/scheme/package.ss b/collects/scheme/package.ss index 7cb8720..8f6e0e3 100644 --- a/collects/scheme/package.ss +++ b/collects/scheme/package.ss @@ -34,10 +34,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)]) @@ -125,8 +139,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)] @@ -282,13 +296,13 @@ 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)) @@ -305,9 +319,9 @@ (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) @@ -394,9 +408,7 @@ (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) From 99331b204b2ee39b0fb97fef34387484de92f110 Mon Sep 17 00:00:00 2001 From: Ryan Culpepper Date: Fri, 13 Mar 2009 01:44:30 +0000 Subject: [PATCH 15/28] pretty-printer: changed 'module' printing svn: r14082 original commit: 3d5377d8f8a0948c4c8ae112230a7017352343ae --- collects/mzlib/pretty.ss | 11 +++++++++-- 1 file changed, 9 insertions(+), 2 deletions(-) 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) From cc43fe2ea83d80a5b2fac6f4ce6522e4a94f2eaa Mon Sep 17 00:00:00 2001 From: Jay McCarthy Date: Mon, 16 Mar 2009 18:45:16 +0000 Subject: [PATCH 16/28] pr7974 + include in release svn: r14132 original commit: f9c4e4eb542b3980d0d27e6c53e10f62399c3ae4 --- collects/net/cgi-unit.ss | 25 ++++++++++++++++++++----- 1 file changed, 20 insertions(+), 5 deletions(-) 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?))]))) From 715756c512fb781e3fe8682146ab9d851421ee8a Mon Sep 17 00:00:00 2001 From: Eli Barzilay Date: Tue, 17 Mar 2009 10:53:13 +0000 Subject: [PATCH 17/28] fixed use of string-length and error symbol svn: r14142 original commit: e616818d347b3ab5d9ec3ed8d92890f060ea9997 --- collects/net/head-unit.ss | 8 ++++---- 1 file changed, 4 insertions(+), 4 deletions(-) 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)]) From d9260c3cfdbda57d4bbfd0e81cbe90a40d03b29b Mon Sep 17 00:00:00 2001 From: Eli Barzilay Date: Wed, 18 Mar 2009 01:20:42 +0000 Subject: [PATCH 18/28] Fix bug in calling put_short with a bad value svn: r14166 original commit: 977b08c5c4de9120354f0b42af0498044b8aa61c --- collects/mzlib/deflate.ss | 4 ++-- 1 file changed, 2 insertions(+), 2 deletions(-) diff --git a/collects/mzlib/deflate.ss b/collects/mzlib/deflate.ss index 125db9e..c0f89d1 100644 --- a/collects/mzlib/deflate.ss +++ b/collects/mzlib/deflate.ss @@ -2062,7 +2062,7 @@ (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))) @@ -2112,7 +2112,7 @@ ;; /* Output a 32 bit value to the bit stream, lsb first */ (define (put_long n) (put_short (bitwise-and #xFFFF n)) - (put_short (>> n 16))) + (put_short (bitwise-and #xFFFF (>> n 16)))) (define outcnt 0) (define bytes_out 0) From f9d480a02a897dde95243c4a283db027c8cb8e29 Mon Sep 17 00:00:00 2001 From: Matthew Flatt Date: Thu, 19 Mar 2009 20:22:18 +0000 Subject: [PATCH 19/28] =?UTF-8?q?free-id=3D=3F=20propagation=20through=20m?= =?UTF-8?q?odule=20exports;=20add=20'not-free-identifier=3D=3F=20syntax=20?= =?UTF-8?q?property=20to=20disable=20free-id=3D=3F=20propagation;=20add=20?= =?UTF-8?q?prop:rename-transformer=20and=20prop:set-transformer;=20fix=20s?= =?UTF-8?q?cheme/local=20so=20that=20local=20syntax=20bindings=20are=20vis?= =?UTF-8?q?ible=20to=20later=20definitions=20(v4.1.5.3)?= svn: r14191 original commit: 2109cec2f4d89f820647ae75e81b0d7b6a70f4a1 --- collects/mzlib/foreign.ss | 1622 +------------------------------------ 1 file changed, 3 insertions(+), 1619 deletions(-) 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))) From 68cb9c1fe4e87ba6faacb71e1a10c05886af10ba Mon Sep 17 00:00:00 2001 From: Matthew Flatt Date: Wed, 25 Mar 2009 16:51:13 +0000 Subject: [PATCH 20/28] change the way that hidden package ids are generated svn: r14277 original commit: 4ce30226fe27dbee13a772e794a1a4713064bf2f --- collects/scheme/package.ss | 8 ++++++-- 1 file changed, 6 insertions(+), 2 deletions(-) diff --git a/collects/scheme/package.ss b/collects/scheme/package.ss index 8f6e0e3..8f0d471 100644 --- a/collects/scheme/package.ss +++ b/collects/scheme/package.ss @@ -70,6 +70,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) @@ -85,7 +89,7 @@ ;; 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))) @@ -172,7 +176,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) From 7a326a7ee9cfd31185f4f11c680288c627c0daa5 Mon Sep 17 00:00:00 2001 From: Stevie Strickland Date: Fri, 27 Mar 2009 13:47:12 +0000 Subject: [PATCH 21/28] Sam and I did some work to allow automatic inferred linking in (define-values/)invoke-unit/infer. svn: r14315 original commit: 99aac7d7455c3ce9189d038f781558b6bd696424 --- collects/mzlib/unit.ss | 152 ++++++++++++++++++++++++++++++++++------- 1 file changed, 126 insertions(+), 26 deletions(-) diff --git a/collects/mzlib/unit.ss b/collects/mzlib/unit.ss index 186e534..84c81fc 100644 --- a/collects/mzlib/unit.ss +++ b/collects/mzlib/unit.ss @@ -1495,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) @@ -1770,18 +1873,15 @@ (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) From 7e81aaeb655eba928a2b776e12e7c2bb9cdd5036 Mon Sep 17 00:00:00 2001 From: Matthew Flatt Date: Tue, 7 Apr 2009 20:36:08 +0000 Subject: [PATCH 22/28] scheme/package simplifications from Chongkai svn: r14448 original commit: de1e2fac233b1c1916943bb946b77224455619d5 --- collects/scheme/package.ss | 28 +++++++++++----------------- 1 file changed, 11 insertions(+), 17 deletions(-) diff --git a/collects/scheme/package.ss b/collects/scheme/package.ss index 8f0d471..2140f22 100644 --- a/collects/scheme/package.ss +++ b/collects/scheme/package.ss @@ -222,7 +222,6 @@ [(_ stx) #'stx])))))]) (let loop ([exprs init-exprs] [rev-forms null] - [defined null] [def-ctxes (list def-ctx)]) (cond [(null? exprs) @@ -296,7 +295,6 @@ [(begin . rest) (loop (append (syntax->list #'rest) (cdr exprs)) rev-forms - defined def-ctxes)] [(def (id ...) rhs) (and (or (free-identifier=? #'def #'define-syntaxes) @@ -319,7 +317,6 @@ (loop (cdr exprs) (cons #`(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) @@ -337,7 +334,6 @@ (register-bindings! ids) (loop (cdr exprs) (cons #`(define-values #,ids rhs) rev-forms) - (cons ids defined) (if star? (cons def-ctx def-ctxes) def-ctxes))))] [else (loop (cdr exprs) @@ -346,7 +342,6 @@ expr #`(define-values () (begin #,expr (values)))) rev-forms) - defined def-ctxes)]))]))))))])) (define-syntax (define-package stx) @@ -396,18 +391,17 @@ (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) - ...))))))))])) + #`(#,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) + ...)))))))])) (define-syntax (open-package stx) (do-open stx #'define-syntaxes)) From a2181635c9015258d45b9fc3f9948a5572e4a4e2 Mon Sep 17 00:00:00 2001 From: Matthew Flatt Date: Mon, 13 Apr 2009 14:52:14 +0000 Subject: [PATCH 23/28] check-syntax binding for open-package's package id svn: r14498 original commit: 0be3dca240500caf2640ad59a6e34868a89693c6 --- collects/scheme/package.ss | 25 ++++++++++++++----------- 1 file changed, 14 insertions(+), 11 deletions(-) diff --git a/collects/scheme/package.ss b/collects/scheme/package.ss index 2140f22..cf091fc 100644 --- a/collects/scheme/package.ss +++ b/collects/scheme/package.ss @@ -391,17 +391,20 @@ (syntax-local-introduce (cdr p)))) ((package-exports v)))] [(h ...) (map syntax-local-introduce ((package-hidden v)))]) - #`(#,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)) From b14a0887548a369c3f354f16ba478fa5fb29deda Mon Sep 17 00:00:00 2001 From: Matthew Flatt Date: Fri, 17 Apr 2009 12:29:04 +0000 Subject: [PATCH 24/28] fix handling of define*-values between a syntax binding and a syntax-local-value svn: r14541 original commit: 7d61c67bab33f059d7c270685b46ff57eae5511c --- collects/scheme/package.ss | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/collects/scheme/package.ss b/collects/scheme/package.ss index cf091fc..ebaeb4b 100644 --- a/collects/scheme/package.ss +++ b/collects/scheme/package.ss @@ -325,7 +325,7 @@ (let ([star? (free-identifier=? #'def #'-define*-values)] [ids (syntax->list #'(id ...))]) (let* ([def-ctx (if star? - (syntax-local-make-definition-context) + (syntax-local-make-definition-context (car def-ctxes)) (car def-ctxes))] [ids (if star? (map (add-package-context (list def-ctx)) ids) From 2b7e5a9642b4bff0d1a73c74a5d8038d464f34b0 Mon Sep 17 00:00:00 2001 From: Matthew Flatt Date: Fri, 17 Apr 2009 22:50:19 +0000 Subject: [PATCH 25/28] fix inverted argument default for editor<%> read-from-file method; better Check Sytax results on packages; added syntax/flatten-begin library svn: r14548 original commit: 4b3626c1560658fe3937019e001911c2a44aaff3 --- collects/scheme/package.ss | 15 +++++++++++---- 1 file changed, 11 insertions(+), 4 deletions(-) diff --git a/collects/scheme/package.ss b/collects/scheme/package.ss index ebaeb4b..469ce82 100644 --- a/collects/scheme/package.ss +++ b/collects/scheme/package.ss @@ -2,7 +2,8 @@ (require (for-syntax scheme/base syntax/kerncase syntax/boundmap - syntax/define)) + syntax/define + syntax/flatten-begin)) (provide define-package package-begin @@ -93,6 +94,12 @@ 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 ...) @@ -293,7 +300,7 @@ (car def-ctxes)))]) (syntax-case expr (begin) [(begin . rest) - (loop (append (syntax->list #'rest) (cdr exprs)) + (loop (append (flatten-begin expr) (cdr exprs)) rev-forms def-ctxes)] [(def (id ...) rhs) @@ -315,7 +322,7 @@ (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) (if star? (cons def-ctx def-ctxes) def-ctxes)))))] [(def (id ...) rhs) @@ -333,7 +340,7 @@ (syntax-local-bind-syntaxes ids #f def-ctx) (register-bindings! ids) (loop (cdr exprs) - (cons #`(define-values #,ids rhs) rev-forms) + (cons (move-props expr #`(define-values #,ids rhs)) rev-forms) (if star? (cons def-ctx def-ctxes) def-ctxes))))] [else (loop (cdr exprs) From 872f83b18d766a7078d94ac9f3d2359d31ca870a Mon Sep 17 00:00:00 2001 From: Matthew Flatt Date: Thu, 30 Apr 2009 23:57:45 +0000 Subject: [PATCH 26/28] fix problem with package, define*, and macro-introduced identifiers svn: r14671 original commit: 2b8b10dd400a833a0b8632411f91b01c48e61796 --- collects/scheme/package.ss | 23 ++++++++++------------- 1 file changed, 10 insertions(+), 13 deletions(-) diff --git a/collects/scheme/package.ss b/collects/scheme/package.ss index 469ce82..cf8b4d4 100644 --- a/collects/scheme/package.ss +++ b/collects/scheme/package.ss @@ -219,14 +219,12 @@ 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] [def-ctxes (list def-ctx)]) @@ -293,11 +291,10 @@ (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 (flatten-begin expr) (cdr exprs)) From 240fa9dc9838a7f903ddb1caaf7bee971ce193c5 Mon Sep 17 00:00:00 2001 From: Matthew Flatt Date: Sun, 3 May 2009 23:49:22 +0000 Subject: [PATCH 27/28] fix define after define* in package; doc repairs svn: r14701 original commit: 16e483033c9278d2bd386a3d419d4caedc4a1a77 --- collects/scheme/package.ss | 5 +++-- 1 file changed, 3 insertions(+), 2 deletions(-) diff --git a/collects/scheme/package.ss b/collects/scheme/package.ss index cf8b4d4..38bbbed 100644 --- a/collects/scheme/package.ss +++ b/collects/scheme/package.ss @@ -1,5 +1,6 @@ #lang scheme/base (require (for-syntax scheme/base + scheme/list syntax/kerncase syntax/boundmap syntax/define @@ -312,7 +313,7 @@ [ids (syntax->list #'(id ...))]) (let* ([def-ctx (if star? (syntax-local-make-definition-context (car def-ctxes)) - (car def-ctxes))] + (last def-ctxes))] [ids (if star? (map (add-package-context (list def-ctx)) ids) ids)]) @@ -330,7 +331,7 @@ [ids (syntax->list #'(id ...))]) (let* ([def-ctx (if star? (syntax-local-make-definition-context (car def-ctxes)) - (car def-ctxes))] + (last def-ctxes))] [ids (if star? (map (add-package-context (list def-ctx)) ids) ids)]) From 0aea94d8048f5e0b9d470bc34c7bc3b624427cae Mon Sep 17 00:00:00 2001 From: Matthew Flatt Date: Mon, 4 May 2009 12:22:01 +0000 Subject: [PATCH 28/28] fix file-descriptor leak in process[*]/ports (PR 10229) svn: r14710 original commit: 83cd3964f4e27c38790762dc44c00b0bf57f6fb2 --- collects/mzlib/process.ss | 6 +++++- 1 file changed, 5 insertions(+), 1 deletion(-) 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))