diff --git a/collects/mzlib/foreign.ss b/collects/mzlib/foreign.ss index 8c7ccf7..34065bd 100644 --- a/collects/mzlib/foreign.ss +++ b/collects/mzlib/foreign.ss @@ -58,11 +58,11 @@ (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* - _bool _pointer _scheme _fpointer + _bool _pointer _scheme _fpointer function-ptr (unsafe memcpy) (unsafe memmove) (unsafe memset) (unsafe malloc-immobile-cell) (unsafe free-immobile-cell)) @@ -468,24 +468,28 @@ ;; 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) - (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 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: @@ -513,6 +517,7 @@ (define xs #f) (define abi #f) (define keep #f) + (define atomic? #f) (define inputs #f) (define output #f) (define bind '()) @@ -577,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])) @@ -670,17 +676,26 @@ (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))])) +(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 (note: these do not use #f as NULL). +;; utf-16 type (provide _string/ucs-4 _string/utf-16) ;; 8-bit string encodings, #f is NULL @@ -1477,7 +1492,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 ...)))])) @@ -1494,13 +1509,33 @@ (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 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)))) 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 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. diff --git a/collects/mzlib/unit.ss b/collects/mzlib/unit.ss index 8912813..7843950 100644 --- a/collects/mzlib/unit.ss +++ b/collects/mzlib/unit.ss @@ -558,12 +558,7 @@ (syntax->list #'((int-ivar ...) ...)) (syntax->list #'((ext-ivar ...) ...)) (syntax->list #'((iloc ...) ...)) - (map cadddr import-sigs)) - [(int-evar ...) - (make-id-mappers - (quote-syntax (unbox eloc)) - ...)] - ...) + (map cadddr import-sigs))) (letrec-syntaxes+values (renames ... mac ... ...) (val ... ...) @@ -703,83 +698,65 @@ (var-info-id defid))))) local-ivars) - (with-syntax ([(intname ...) - (foldr - (lambda (var res) - (cond - ((not (or (var-info-syntax? (cdr var)) - (var-info-exported? (cdr var)))) - (cons (car var) res)) - (else res))) - null - (bound-identifier-mapping-map defined-names-table cons))] - [(evar ...) #'evars] - [(l-evar ...) local-evars] - [(defn&expr ...) - (filter - values + (with-syntax ([(defn&expr ...) + (apply + append (map (lambda (defn-or-expr) (syntax-case defn-or-expr (define-values define-syntaxes) [(define-values () expr) - (syntax/loc defn-or-expr (set!-values () expr))] + defn-or-expr] [(define-values ids expr) - (let ([ids (syntax->list #'ids)] - [do-one - (lambda (id tmp name) - (let ([unit-name - (syntax-local-infer-name (error-syntax))] - [export-loc - (var-info-exported? - (bound-identifier-mapping-get - defined-names-table - id))] - [add-ctc - (var-info-add-ctc - (bound-identifier-mapping-get - defined-names-table - id))]) - (cond - (export-loc - ;; set! exported id: - (quasisyntax/loc defn-or-expr - (set-box! #,export-loc - #,(if name - #`(let ([#,name #,(if add-ctc (add-ctc tmp) tmp)]) - #,name) - tmp)))) - (else - ;; not an exported id - (quasisyntax/loc defn-or-expr - (set! #,id #,tmp))))))]) + (let* ([ids (syntax->list #'ids)] + [tmps (generate-temporaries ids)] + [new-defn (quasisyntax/loc defn-or-expr + (define-values #,(map (lambda (id tmp) + (if (var-info-exported? + (bound-identifier-mapping-get + defined-names-table + id)) + tmp + id)) + ids tmps) expr))] + [do-one + (lambda (id tmp name) + (let ([unit-name + (syntax-local-infer-name (error-syntax))] + [export-loc + (var-info-exported? + (bound-identifier-mapping-get + defined-names-table + id))] + [add-ctc + (var-info-add-ctc + (bound-identifier-mapping-get + defined-names-table + id))]) + (cond + (export-loc + ;; set! exported id: + (list + (quasisyntax/loc defn-or-expr + (set-box! #,export-loc + #,(if name + #`(let ([#,name #,(if add-ctc (add-ctc tmp) tmp)]) + #,name) + tmp))) + (quasisyntax/loc defn-or-expr + (define-syntax #,id (make-id-mapper (quote-syntax #,tmp)))))) + (else + ;; not an exported id + null))))]) (if (null? (cdr ids)) - (do-one (car ids) (syntax expr) (car ids)) - (let ([tmps (generate-temporaries ids)]) - (with-syntax ([(tmp ...) tmps] - [(set ...) - (map (lambda (id tmp) - (do-one id tmp #f)) - ids tmps)]) - (syntax/loc defn-or-expr - (let-values ([(tmp ...) expr]) - set ...))))))] - [(define-syntaxes . l) #f] - [else defn-or-expr])) - expanded-body))] - [(stx-defn ...) - (filter - values - (map (lambda (defn-or-expr) - (syntax-case defn-or-expr (define-syntaxes) - [(define-syntaxes . l) #'l] - [else #f])) + (cons new-defn (do-one (car ids) (car tmps) (car ids))) + (cons new-defn (apply append + (map (lambda (id tmp) + (do-one id tmp #f)) + ids tmps)))))] + [else (list defn-or-expr)])) expanded-body))]) - #'(letrec-syntaxes+values (stx-defn - ... - ((l-evar) (make-rename-transformer (quote-syntax evar))) - ...) - ([(intname) undefined] ...) - (void) ; in case the body would be empty - defn&expr ...))))))) + #'(begin-with-definitions + defn&expr ... + (void)))))))) (define-for-syntax (redirect-imports/exports import?) (lambda (table-stx 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))]