From ac1f721985f5f123bde21838a36b9f3b54742220 Mon Sep 17 00:00:00 2001 From: Eli Barzilay Date: Tue, 9 Dec 2008 02:39:45 +0000 Subject: [PATCH 01/14] if the path is empty, use / svn: r12750 original commit: 169c69a0bc6d0faff5473b75ff6ee17bef45ae84 --- collects/net/url-unit.ss | 51 +++++++++++++++++++++------------------- 1 file changed, 27 insertions(+), 24 deletions(-) diff --git a/collects/net/url-unit.ss b/collects/net/url-unit.ss index 986012c..b7773be 100644 --- a/collects/net/url-unit.ss +++ b/collects/net/url-unit.ss @@ -103,30 +103,33 @@ ;; http://getpost-impure-port : bool x url x union (str, #f) x list (str) -> in-port (define (http://getpost-impure-port get? url post-data strings) - (let*-values - ([(proxy) (assoc (url-scheme url) (current-proxy-servers))] - [(server->client client->server) (make-ports url proxy)] - [(access-string) (url->string - (if proxy - url - (make-url #f #f #f #f - (url-path-absolute? url) - (url-path url) - (url-query url) - (url-fragment url))))]) - (define (println . xs) - (for-each (lambda (x) (display x client->server)) xs) - (display "\r\n" client->server)) - (println (if get? "GET " "POST ") access-string " HTTP/1.0") - (println "Host: " (url-host url) - (let ([p (url-port url)]) (if p (format ":~a" p) ""))) - (when post-data (println "Content-Length: " (bytes-length post-data))) - (for-each println strings) - (println) - (when post-data (display post-data client->server)) - (flush-output client->server) - (tcp-abandon-port client->server) - server->client)) + (define proxy (assoc (url-scheme url) (current-proxy-servers))) + (define-values (server->client client->server) (make-ports url proxy)) + (define access-string + (url->string + (if proxy + url + ;; RFCs 1945 and 2616 say: + ;; Note that the absolute path cannot be empty; if none is present in + ;; the original URI, it must be given as "/" (the server root). + (let-values ([(abs? path) + (if (null? (url-path url)) + (values #t (list (make-path/param "" '()))) + (values (url-path-absolute? url) (url-path url)))]) + (make-url #f #f #f #f abs? path (url-query url) (url-fragment url)))))) + (define (println . xs) + (for-each (lambda (x) (display x client->server)) xs) + (display "\r\n" client->server)) + (println (if get? "GET " "POST ") access-string " HTTP/1.0") + (println "Host: " (url-host url) + (let ([p (url-port url)]) (if p (format ":~a" p) ""))) + (when post-data (println "Content-Length: " (bytes-length post-data))) + (for-each println strings) + (println) + (when post-data (display post-data client->server)) + (flush-output client->server) + (tcp-abandon-port client->server) + server->client) (define (file://->path url [kind (system-path-convention-type)]) (let ([strs (map path/param-path (url-path url))] From ad2792fb85af7110ec9f7c2bee9219afd1cd8f77 Mon Sep 17 00:00:00 2001 From: Eli Barzilay Date: Thu, 18 Dec 2008 06:48:10 +0000 Subject: [PATCH 02/14] ctype-basetype now holds: * a symbol naming the type for primitive types * a list of ctypes for cstruct types * another ctype for user-defined ctypes svn: r12882 original commit: 6283205982477aec904affbffa8eab57d239dd31 --- collects/mzlib/foreign.ss | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/collects/mzlib/foreign.ss b/collects/mzlib/foreign.ss index 8c7ccf7..8737faa 100644 --- a/collects/mzlib/foreign.ss +++ b/collects/mzlib/foreign.ss @@ -1500,7 +1500,7 @@ ;; 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 basetype + (if (ctype? basetype) (let ([s->c (ctype-scheme->c type)]) (get-lowlevel-object (if s->c (s->c x) x) basetype)) (values x type)))) From 588e3b23a565317c39ca9f33a8659a517f5e028f Mon Sep 17 00:00:00 2001 From: Matthew Flatt Date: Thu, 18 Dec 2008 20:05:21 +0000 Subject: [PATCH 03/14] ctype->layout in scheme/foreign; prototype Objective-C binding in ffi collection svn: r12890 original commit: 2c95f77c3141a0827bd094d8d93b3e3fa39ef8b5 --- collects/mzlib/foreign.ss | 22 +++++++++++++++++++++- 1 file changed, 21 insertions(+), 1 deletion(-) diff --git a/collects/mzlib/foreign.ss b/collects/mzlib/foreign.ss index 8737faa..fa2520d 100644 --- a/collects/mzlib/foreign.ss +++ b/collects/mzlib/foreign.ss @@ -58,7 +58,7 @@ (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? 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* @@ -1494,6 +1494,26 @@ (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 From e73dd4b4af2e8689ccc4a0469702a11785fa9f26 Mon Sep 17 00:00:00 2001 From: Matthew Flatt Date: Fri, 19 Dec 2008 23:59:33 +0000 Subject: [PATCH 04/14] add FFI types _string/utf-16/null and _string/ucs-4/null svn: r12911 original commit: 7dc56df9499127695e4fc09d754bdd4cdd411fa5 --- collects/mzlib/foreign.ss | 5 +++-- 1 file changed, 3 insertions(+), 2 deletions(-) diff --git a/collects/mzlib/foreign.ss b/collects/mzlib/foreign.ss index fa2520d..a945f09 100644 --- a/collects/mzlib/foreign.ss +++ b/collects/mzlib/foreign.ss @@ -680,8 +680,9 @@ ;; String types ;; The internal _string type uses the native ucs-4 encoding, also providing a -;; utf-16 type (note: these do not use #f as NULL). -(provide _string/ucs-4 _string/utf-16) +;; utf-16 type (note: the non-/null variants do not use #f as NULL). +(provide _string/ucs-4 _string/utf-16 + _string/ucs-4/null _string/utf-16/null) ;; 8-bit string encodings, #f is NULL (define ((false-or-op op) x) (and x (op x))) From 0a87e4bd264bcada60fa66dde7683abd606e7a03 Mon Sep 17 00:00:00 2001 From: Eli Barzilay Date: Sat, 20 Dec 2008 03:06:59 +0000 Subject: [PATCH 05/14] fix _-identifier? typo svn: r12912 original commit: a62b6a312809f2cc9b10a8cc9b92b73f4b9ef69f --- collects/mzlib/foreign.ss | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/collects/mzlib/foreign.ss b/collects/mzlib/foreign.ss index a945f09..a01579b 100644 --- a/collects/mzlib/foreign.ss +++ b/collects/mzlib/foreign.ss @@ -1478,7 +1478,7 @@ (identifiers? #'(slot ...))) (make-syntax #'_TYPE #f #'(slot ...) #'(slot-type ...))] [(_ (_TYPE _SUPER) ([slot slot-type] ...)) - (and (_-identifier? #'_TYPE) (identifiers? #'(slot ...))) + (and (_-identifier? #'_TYPE stx) (identifiers? #'(slot ...))) (with-syntax ([super (datum->syntax #'_TYPE 'super #'_TYPE)]) (make-syntax #'_TYPE #t #'(super slot ...) #'(_SUPER slot-type ...)))])) From 90abe67ff6b3d66b6936358c217467046becd2b3 Mon Sep 17 00:00:00 2001 From: Matthew Flatt Date: Sat, 20 Dec 2008 05:09:35 +0000 Subject: [PATCH 06/14] change _fpointer handling to work with function pointers in structs and other such uses; add 'function-ptr' casting operation svn: r12913 original commit: 82ead03b92f7288fede1aaf6679312fc5d2093f2 --- collects/mzlib/foreign.ss | 9 ++++++++- 1 file changed, 8 insertions(+), 1 deletion(-) diff --git a/collects/mzlib/foreign.ss b/collects/mzlib/foreign.ss index a01579b..42a9103 100644 --- a/collects/mzlib/foreign.ss +++ b/collects/mzlib/foreign.ss @@ -62,7 +62,7 @@ _void _int8 _uint8 _int16 _uint16 _int32 _uint32 _int64 _uint64 _fixint _ufixint _fixnum _ufixnum _float _double _double* - _bool _pointer _scheme _fpointer + _bool _pointer _scheme _fpointer function-ptr (unsafe memcpy) (unsafe memmove) (unsafe memset) (unsafe malloc-immobile-cell) (unsafe free-immobile-cell)) @@ -676,6 +676,13 @@ (syntax-case stx () [(_ x ...) (begin (set! xs (syntax->list #'(x ...))) (do-fun))])) +(define (function-ptr p fun-ctype) + (if (cpointer? p) + (if (eq? (ctype->layout fun-ctype) 'fpointer) + ((ctype-c->scheme fun-ctype) p) + (raise-type-error 'function-ptr "function ctype" fun-ctype)) + (raise-type-error 'function-ptr "cpointer" p))) + ;; ---------------------------------------------------------------------------- ;; String types From 000fe5277f19c8b018ada685fe25248b8e81d2e9 Mon Sep 17 00:00:00 2001 From: Matthew Flatt Date: Sun, 21 Dec 2008 13:57:46 +0000 Subject: [PATCH 07/14] fine-tune typechecking index entry svn: r12920 original commit: ec600c59bb9caa15f10fb68844677e56a4ce86dc --- collects/mzlib/foreign.ss | 6 ++++-- 1 file changed, 4 insertions(+), 2 deletions(-) diff --git a/collects/mzlib/foreign.ss b/collects/mzlib/foreign.ss index 42a9103..5c04be9 100644 --- a/collects/mzlib/foreign.ss +++ b/collects/mzlib/foreign.ss @@ -677,9 +677,11 @@ [(_ x ...) (begin (set! xs (syntax->list #'(x ...))) (do-fun))])) (define (function-ptr p fun-ctype) - (if (cpointer? p) + (if (or (cpointer? p) (procedure? p)) (if (eq? (ctype->layout fun-ctype) 'fpointer) - ((ctype-c->scheme fun-ctype) p) + (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))) From 0dc78139249f9f3966928e9c9cae3b73da26a898 Mon Sep 17 00:00:00 2001 From: Eli Barzilay Date: Tue, 23 Dec 2008 09:02:44 +0000 Subject: [PATCH 08/14] minor improvement svn: r12931 original commit: c11196839be2150d8741248e10eda3453af405b4 --- collects/net/url-unit.ss | 10 +++------- 1 file changed, 3 insertions(+), 7 deletions(-) diff --git a/collects/net/url-unit.ss b/collects/net/url-unit.ss index b7773be..0185515 100644 --- a/collects/net/url-unit.ss +++ b/collects/net/url-unit.ss @@ -378,13 +378,9 @@ (eq? 'windows (file-url-path-convention-type)) (not (equal? host "")))]) (when win-file? - (if (equal? "" port) - (set! path (string-append host ":" path)) - (set! path (if path - (if host - (string-append host "/" path) - path) - host))) + (set! path (cond [(equal? "" port) (string-append host ":" path)] + [(and path host) (string-append host "/" path)] + [else (or path host)])) (set! port #f) (set! host "")) (let* ([scheme (and scheme (string-downcase scheme))] From 2e250514c6cf473e09a27aaf3f5802722d0dffda Mon Sep 17 00:00:00 2001 From: Matthew Flatt Date: Sat, 3 Jan 2009 18:51:15 +0000 Subject: [PATCH 09/14] scheme/foreign: allow #f as NULL function pointer, allow callback as cpointer svn: r12992 original commit: d596401804242ca39007e56d798e12f3852810f0 --- collects/mzlib/foreign.ss | 19 ++++++++++--------- 1 file changed, 10 insertions(+), 9 deletions(-) diff --git a/collects/mzlib/foreign.ss b/collects/mzlib/foreign.ss index 5c04be9..4d999ce 100644 --- a/collects/mzlib/foreign.ss +++ b/collects/mzlib/foreign.ss @@ -477,15 +477,16 @@ (define-syntax-rule (make-it wrap) (make-ctype _fpointer (lambda (x) - (let ([cb (ffi-callback (wrap x) itypes otype abi)]) - (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) (wrap (ffi-call x itypes otype abi))))) + (and x + (let ([cb (ffi-callback (wrap x) itypes otype abi)]) + (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: From 87927edac413aca8242a64bd0b34e2779807960f Mon Sep 17 00:00:00 2001 From: Eli Barzilay Date: Sun, 4 Jan 2009 15:34:50 +0000 Subject: [PATCH 10/14] 2008 -> 2009 svn: r13001 original commit: 8a2753efb8fb4df490feec8d52c570cba17d2bdd --- collects/mzlib/md5.ss | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/collects/mzlib/md5.ss b/collects/mzlib/md5.ss index 0cfc071..973d358 100644 --- a/collects/mzlib/md5.ss +++ b/collects/mzlib/md5.ss @@ -2,7 +2,7 @@ (provide md5) - ;;; Copyright (c) 2005-2008, PLT Scheme Inc. + ;;; Copyright (c) 2005-2009, PLT Scheme Inc. ;;; Copyright (c) 2002, Jens Axel Soegaard ;;; ;;; Permission to copy this software, in whole or in part, to use this From 3fd92992eece73fd4240c8e7c762b630da5267ac Mon Sep 17 00:00:00 2001 From: Matthew Flatt Date: Tue, 6 Jan 2009 13:07:45 +0000 Subject: [PATCH 11/14] revised Mac OS X sleeping; optional atomic mode for FFI callbacks svn: r13016 original commit: 61685c72f9f4dc9c759011c02c013ee92ea185be --- collects/mzlib/foreign.ss | 19 ++++++++++++------- 1 file changed, 12 insertions(+), 7 deletions(-) diff --git a/collects/mzlib/foreign.ss b/collects/mzlib/foreign.ss index 4d999ce..87c1b45 100644 --- a/collects/mzlib/foreign.ss +++ b/collects/mzlib/foreign.ss @@ -468,17 +468,20 @@ ;; 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]) - (_cprocedure* itypes otype abi wrapper keep)) + #: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) +(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)]) + (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)]) @@ -514,6 +517,7 @@ (define xs #f) (define abi #f) (define keep #f) + (define atomic? #f) (define inputs #f) (define output #f) (define bind '()) @@ -578,9 +582,10 @@ (begin (set! var (cadr xs)) (set! xs (cddr xs)) (loop)))] ... [else (err "unknown keyword" (car xs))])) - (when (keyword? k) (kwds [#:abi abi] [#:keep keep])))) + (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])) @@ -671,9 +676,9 @@ (string->symbol (string-append "ffi-wrapper:" n))) body))]) #`(_cprocedure* (list #,@(filter-map car inputs)) #,(car output) - #,abi (lambda (ffi) #,body) #,keep)) + #,abi (lambda (ffi) #,body) #,keep #,atomic?)) #`(_cprocedure* (list #,@(filter-map car inputs)) #,(car output) - #,abi #f #,keep))) + #,abi #f #,keep #,atomic?))) (syntax-case stx () [(_ x ...) (begin (set! xs (syntax->list #'(x ...))) (do-fun))])) From 42e6044cd4d6a19516e4d91cc0bc1ef47a506c8e Mon Sep 17 00:00:00 2001 From: Robby Findler Date: Wed, 7 Jan 2009 15:44:07 +0000 Subject: [PATCH 12/14] opened up the trace library a little more to make it more useable for Redex svn: r13027 original commit: cda64e40da21ef9e639faa82f741bfd736edf245 --- collects/mzlib/trace.ss | 58 ++++++++++++++++++++--------------------- 1 file changed, 29 insertions(+), 29 deletions(-) diff --git a/collects/mzlib/trace.ss b/collects/mzlib/trace.ss index e04c657..21c47e0 100644 --- a/collects/mzlib/trace.ss +++ b/collects/mzlib/trace.ss @@ -4,19 +4,16 @@ (for-syntax scheme/base)) (provide trace untrace + current-trace-print-args trace-apply current-trace-notify) (define max-dash-space-depth 10) (define number-nesting-depth 6) - (define as-spaces - (lambda (s) - (let ((n (string-length s))) - (apply string-append - (let loop ((k n)) - (if (zero? k) '("") - (cons " " (loop (sub1 k))))))))) - + (define (as-spaces s) + (build-string (string-length s) + (lambda (i) #\space))) + (define-struct prefix-entry (for-first for-rest)) (define prefixes (make-vector 20 #f)) @@ -101,28 +98,29 @@ (lambda (name args kws kw-vals level) (as-trace-notify (lambda () - (trace-print-args name args kws kw-vals level))))) - - (define trace-print-args - (lambda (name args kws kw-vals level) - (let-values (((first rest) - (build-prefixes level))) - (parameterize ((pretty-print-print-line - (lambda (n port offset width) - (display - (if n - (if (zero? n) first - (format "~n~a" rest)) - (format "~n")) - port) - (if n - (if (zero? n) - (string-length first) - (string-length rest)) - 0)))) - (pretty-print (append (cons name args) - (apply append (map list kws kw-vals)))))))) + ((current-trace-print-args) name args kws kw-vals level))))) + (define current-trace-print-args + (make-parameter + (lambda (name args kws kw-vals level) + (let-values (((first rest) + (build-prefixes level))) + (parameterize ((pretty-print-print-line + (lambda (n port offset width) + (display + (if n + (if (zero? n) first + (format "~n~a" rest)) + (format "~n")) + port) + (if n + (if (zero? n) + (string-length first) + (string-length rest)) + 0)))) + (pretty-print (append (cons name args) + (apply append (map list kws kw-vals))))))))) + (define -:trace-print-results (lambda (name results level) (as-trace-notify @@ -197,6 +195,8 @@ ;; the nesting depth: (define -:trace-level-key (gensym)) + (define (trace-apply id f kws kw-vals . args) (do-traced id args kws kw-vals f)) + ;; Apply a traced procedure to arguments, printing arguments ;; and results. We set and inspect the -:trace-level-key continuation ;; mark a few times to detect tail calls. From 365bc53e44137e4be18628208d81395ec3224938 Mon Sep 17 00:00:00 2001 From: Matthew Flatt Date: Wed, 7 Jan 2009 17:49:14 +0000 Subject: [PATCH 13/14] change _string/utf-16 and _string/ucs-4 so that #f = NULL (for consistency with other pointer types), and drop the /null variants svn: r13031 original commit: 0663588ee1f03c92ad6d4d0956a293d43e6f266d --- collects/mzlib/foreign.ss | 5 ++--- 1 file changed, 2 insertions(+), 3 deletions(-) diff --git a/collects/mzlib/foreign.ss b/collects/mzlib/foreign.ss index 87c1b45..34065bd 100644 --- a/collects/mzlib/foreign.ss +++ b/collects/mzlib/foreign.ss @@ -695,9 +695,8 @@ ;; String types ;; The internal _string type uses the native ucs-4 encoding, also providing a -;; utf-16 type (note: the non-/null variants do not use #f as NULL). -(provide _string/ucs-4 _string/utf-16 - _string/ucs-4/null _string/utf-16/null) +;; 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))) From 8f600ef6f7d30f2294a33575748425281bd22152 Mon Sep 17 00:00:00 2001 From: Eli Barzilay Date: Wed, 14 Jan 2009 03:10:47 +0000 Subject: [PATCH 14/14] newlines at EOFs svn: r13105 original commit: d1a0086471bf5e9553a9b056b26286c427831d38 --- collects/mzlib/contract.ss | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/collects/mzlib/contract.ss b/collects/mzlib/contract.ss index bf96a1c..30abf6d 100644 --- a/collects/mzlib/contract.ss +++ b/collects/mzlib/contract.ss @@ -85,4 +85,4 @@ (define (flat-contract/predicate? pred) (or (flat-contract? pred) (and (procedure? pred) - (procedure-arity-includes? pred 1)))) \ No newline at end of file + (procedure-arity-includes? pred 1))))