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

Changed to be more like what Sam and I envisioned.

Browse Source 
svn: r13039

original commit: bf0d872afdcb3b511051da314cfd476c9d6e65ef
This commit is contained in:
Stevie Strickland 2009-01-08 20:50:33 +00:00
commit 343618feec
5 changed files with 142 additions and 134 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

63
collects/mzlib/foreign.ss
View File

@ -58,11 +58,11 @@
(unsafe malloc) (unsafe free) (unsafe end-stubborn-change) (unsafe malloc) (unsafe free) (unsafe end-stubborn-change)
cpointer? ptr-equal? ptr-add (unsafe ptr-ref) (unsafe ptr-set!) cpointer? ptr-equal? ptr-add (unsafe ptr-ref) (unsafe ptr-set!)
ptr-offset ptr-add! offset-ptr? set-ptr-offset! 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 _void _int8 _uint8 _int16 _uint16 _int32 _uint32 _int64 _uint64
_fixint _ufixint _fixnum _ufixnum _fixint _ufixint _fixnum _ufixnum
_float _double _double* _float _double _double*
_bool _pointer _scheme _fpointer _bool _pointer _scheme _fpointer function-ptr
(unsafe memcpy) (unsafe memmove) (unsafe memset) (unsafe memcpy) (unsafe memmove) (unsafe memset)
(unsafe malloc-immobile-cell) (unsafe free-immobile-cell)) (unsafe malloc-immobile-cell) (unsafe free-immobile-cell))
@ -468,24 +468,28 @@
;; optionally applying a wrapper function to modify the result primitive ;; optionally applying a wrapper function to modify the result primitive
;; (callouts) or the input procedure (callbacks). ;; (callouts) or the input procedure (callbacks).
(define* (_cprocedure itypes otype (define* (_cprocedure itypes otype
#:abi [abi #f] #:wrapper [wrapper #f] #:keep [keep #f]) #:abi [abi #f]
(_cprocedure* itypes otype abi wrapper keep)) #:wrapper [wrapper #f]
#:keep [keep #f]
#:atomic? [atomic? #f])
(_cprocedure* itypes otype abi wrapper keep atomic?))
;; for internal use ;; for internal use
(define held-callbacks (make-weak-hasheq)) (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) (define-syntax-rule (make-it wrap)
(make-ctype _fpointer (make-ctype _fpointer
(lambda (x) (lambda (x)
(let ([cb (ffi-callback (wrap 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)] (cond [(eq? keep #t) (hash-set! held-callbacks x cb)]
[(box? keep) [(box? keep)
(let ([x (unbox keep)]) (let ([x (unbox keep)])
(set-box! keep (set-box! keep
(if (or (null? x) (pair? x)) (cons cb x) cb)))] (if (or (null? x) (pair? x)) (cons cb x) cb)))]
[(procedure? keep) (keep cb)]) [(procedure? keep) (keep cb)])
cb)) cb)))
(lambda (x) (wrap (ffi-call x itypes otype abi))))) (lambda (x) (and x (wrap (ffi-call x itypes otype abi))))))
(if wrapper (make-it wrapper) (make-it begin))) (if wrapper (make-it wrapper) (make-it begin)))
;; Syntax for the special _fun type: ;; Syntax for the special _fun type:
@ -513,6 +517,7 @@
(define xs #f) (define xs #f)
(define abi #f) (define abi #f)
(define keep #f) (define keep #f)
(define atomic? #f)
(define inputs #f) (define inputs #f)
(define output #f) (define output #f)
(define bind '()) (define bind '())
@ -577,9 +582,10 @@
(begin (set! var (cadr xs)) (set! xs (cddr xs)) (loop)))] (begin (set! var (cadr xs)) (set! xs (cddr xs)) (loop)))]
... ...
[else (err "unknown keyword" (car xs))])) [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 abi (set! abi #'#f))
(unless keep (set! keep #'#t)) (unless keep (set! keep #'#t))
(unless atomic? (set! atomic? #'#f))
;; parse known punctuation ;; parse known punctuation
(set! xs (map (lambda (x) (set! xs (map (lambda (x)
(syntax-case* x (-> ::) id=? [:: '::] [-> '->] [_ x])) (syntax-case* x (-> ::) id=? [:: '::] [-> '->] [_ x]))
@ -670,17 +676,26 @@
(string->symbol (string-append "ffi-wrapper:" n))) (string->symbol (string-append "ffi-wrapper:" n)))
body))]) body))])
#`(_cprocedure* (list #,@(filter-map car inputs)) #,(car output) #`(_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) #`(_cprocedure* (list #,@(filter-map car inputs)) #,(car output)
#,abi #f #,keep))) #,abi #f #,keep #,atomic?)))
(syntax-case stx () (syntax-case stx ()
[(_ x ...) (begin (set! xs (syntax->list #'(x ...))) (do-fun))])) [(_ 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 ;; String types
;; The internal _string type uses the native ucs-4 encoding, also providing a ;; 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) (provide _string/ucs-4 _string/utf-16)
;; 8-bit string encodings, #f is NULL ;; 8-bit string encodings, #f is NULL
@ -1477,7 +1492,7 @@
(identifiers? #'(slot ...))) (identifiers? #'(slot ...)))
(make-syntax #'_TYPE #f #'(slot ...) #'(slot-type ...))] (make-syntax #'_TYPE #f #'(slot ...) #'(slot-type ...))]
[(_ (_TYPE _SUPER) ([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)]) (with-syntax ([super (datum->syntax #'_TYPE 'super #'_TYPE)])
(make-syntax #'_TYPE #t #'(super slot ...) #'(_SUPER slot-type ...)))])) (make-syntax #'_TYPE #t #'(super slot ...) #'(_SUPER slot-type ...)))]))
@ -1494,13 +1509,33 @@
(if v (apply values v) (msg/fail-thunk))))] (if v (apply values v) (msg/fail-thunk))))]
[else (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 ;; Misc utilities
;; Used by set-ffi-obj! to get the actual value so it can be kept around ;; Used by set-ffi-obj! to get the actual value so it can be kept around
(define (get-lowlevel-object x type) (define (get-lowlevel-object x type)
(let ([basetype (ctype-basetype type)]) (let ([basetype (ctype-basetype type)])
(if basetype (if (ctype? basetype)
(let ([s->c (ctype-scheme->c type)]) (let ([s->c (ctype-scheme->c type)])
(get-lowlevel-object (if s->c (s->c x) x) basetype)) (get-lowlevel-object (if s->c (s->c x) x) basetype))
(values x type)))) (values x type))))

2
collects/mzlib/md5.ss
View File

@ -2,7 +2,7 @@
(provide md5) (provide md5)
;;; Copyright (c) 2005-2008, PLT Scheme Inc. ;;; Copyright (c) 2005-2009, PLT Scheme Inc.
;;; Copyright (c) 2002, Jens Axel Soegaard ;;; Copyright (c) 2002, Jens Axel Soegaard
;;; ;;;
;;; Permission to copy this software, in whole or in part, to use this ;;; Permission to copy this software, in whole or in part, to use this

20
collects/mzlib/trace.ss
View File

@ -4,18 +4,15 @@
(for-syntax scheme/base)) (for-syntax scheme/base))
(provide trace untrace (provide trace untrace
current-trace-print-args trace-apply
current-trace-notify) current-trace-notify)
(define max-dash-space-depth 10) (define max-dash-space-depth 10)
(define number-nesting-depth 6) (define number-nesting-depth 6)
(define as-spaces (define (as-spaces s)
(lambda (s) (build-string (string-length s)
(let ((n (string-length s))) (lambda (i) #\space)))
(apply string-append
(let loop ((k n))
(if (zero? k) '("")
(cons " " (loop (sub1 k)))))))))
(define-struct prefix-entry (for-first for-rest)) (define-struct prefix-entry (for-first for-rest))
@ -101,9 +98,10 @@
(lambda (name args kws kw-vals level) (lambda (name args kws kw-vals level)
(as-trace-notify (as-trace-notify
(lambda () (lambda ()
(trace-print-args name args kws kw-vals level))))) ((current-trace-print-args) name args kws kw-vals level)))))
(define trace-print-args (define current-trace-print-args
(make-parameter
(lambda (name args kws kw-vals level) (lambda (name args kws kw-vals level)
(let-values (((first rest) (let-values (((first rest)
(build-prefixes level))) (build-prefixes level)))
@ -121,7 +119,7 @@
(string-length rest)) (string-length rest))
0)))) 0))))
(pretty-print (append (cons name args) (pretty-print (append (cons name args)
(apply append (map list kws kw-vals)))))))) (apply append (map list kws kw-vals)))))))))
(define -:trace-print-results (define -:trace-print-results
(lambda (name results level) (lambda (name results level)
@ -197,6 +195,8 @@
;; the nesting depth: ;; the nesting depth:
(define -:trace-level-key (gensym)) (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 ;; Apply a traced procedure to arguments, printing arguments
;; and results. We set and inspect the -:trace-level-key continuation ;; and results. We set and inspect the -:trace-level-key continuation
;; mark a few times to detect tail calls. ;; mark a few times to detect tail calls.

79
collects/mzlib/unit.ss
View File

@ -558,12 +558,7 @@
(syntax->list #'((int-ivar ...) ...)) (syntax->list #'((int-ivar ...) ...))
(syntax->list #'((ext-ivar ...) ...)) (syntax->list #'((ext-ivar ...) ...))
(syntax->list #'((iloc ...) ...)) (syntax->list #'((iloc ...) ...))
(map cadddr import-sigs)) (map cadddr import-sigs)))
[(int-evar ...)
(make-id-mappers
(quote-syntax (unbox eloc))
...)]
...)
(letrec-syntaxes+values (renames ... (letrec-syntaxes+values (renames ...
mac ... ...) mac ... ...)
(val ... ...) (val ... ...)
@ -703,27 +698,25 @@
(var-info-id defid))))) (var-info-id defid)))))
local-ivars) local-ivars)
(with-syntax ([(intname ...) (with-syntax ([(defn&expr ...)
(foldr (apply
(lambda (var res) append
(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
(map (lambda (defn-or-expr) (map (lambda (defn-or-expr)
(syntax-case defn-or-expr (define-values define-syntaxes) (syntax-case defn-or-expr (define-values define-syntaxes)
[(define-values () expr) [(define-values () expr)
(syntax/loc defn-or-expr (set!-values () expr))] defn-or-expr]
[(define-values ids expr) [(define-values ids expr)
(let ([ids (syntax->list #'ids)] (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 [do-one
(lambda (id tmp name) (lambda (id tmp name)
(let ([unit-name (let ([unit-name
@ -741,45 +734,29 @@
(cond (cond
(export-loc (export-loc
;; set! exported id: ;; set! exported id:
(list
(quasisyntax/loc defn-or-expr (quasisyntax/loc defn-or-expr
(set-box! #,export-loc (set-box! #,export-loc
#,(if name #,(if name
#`(let ([#,name #,(if add-ctc (add-ctc tmp) tmp)]) #`(let ([#,name #,(if add-ctc (add-ctc tmp) tmp)])
#,name) #,name)
tmp)))) tmp)))
(quasisyntax/loc defn-or-expr
(define-syntax #,id (make-id-mapper (quote-syntax #,tmp))))))
(else (else
;; not an exported id ;; not an exported id
(quasisyntax/loc defn-or-expr null))))])
(set! #,id #,tmp))))))])
(if (null? (cdr ids)) (if (null? (cdr ids))
(do-one (car ids) (syntax expr) (car ids)) (cons new-defn (do-one (car ids) (car tmps) (car ids)))
(let ([tmps (generate-temporaries ids)]) (cons new-defn (apply append
(with-syntax ([(tmp ...) tmps]
[(set ...)
(map (lambda (id tmp) (map (lambda (id tmp)
(do-one id tmp #f)) (do-one id tmp #f))
ids tmps)]) ids tmps)))))]
(syntax/loc defn-or-expr [else (list 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]))
expanded-body))]) expanded-body))])
#'(letrec-syntaxes+values (stx-defn #'(begin-with-definitions
... defn&expr ...
((l-evar) (make-rename-transformer (quote-syntax evar))) (void))))))))
...)
([(intname) undefined] ...)
(void) ; in case the body would be empty
defn&expr ...)))))))
(define-for-syntax (redirect-imports/exports import?) (define-for-syntax (redirect-imports/exports import?)
(lambda (table-stx (lambda (table-stx

10
collects/net/url-unit.ss
View File

@ -378,13 +378,9 @@
(eq? 'windows (file-url-path-convention-type)) (eq? 'windows (file-url-path-convention-type))
(not (equal? host "")))]) (not (equal? host "")))])
(when win-file? (when win-file?
(if (equal? "" port) (set! path (cond [(equal? "" port) (string-append host ":" path)]
(set! path (string-append host ":" path)) [(and path host) (string-append host "/" path)]
(set! path (if path [else (or path host)]))
(if host
(string-append host "/" path)
path)
host)))
(set! port #f) (set! port #f)
(set! host "")) (set! host ""))
(let* ([scheme (and scheme (string-downcase scheme))] (let* ([scheme (and scheme (string-downcase scheme))]