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

Fixing these back up to how they were before.

Browse Source 
svn: r13123

original commit: d3f703b04368b74d5435fcb81d8de8521c4976e1
This commit is contained in:
Stevie Strickland 2009-01-14 21:31:46 +00:00
commit 242e3f0266
6 changed files with 125 additions and 91 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

2
collects/mzlib/contract.ss
View File

@ -94,4 +94,4 @@
(define (flat-contract/predicate? pred)
(or (flat-contract? pred)
(and (procedure? pred)
(procedure-arity-includes? pred 1))))
(procedure-arity-includes? pred 1))))

75
collects/mzlib/foreign.ss
View File

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

2
collects/mzlib/md5.ss
View File

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

58
collects/mzlib/trace.ss
View File

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

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

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

18
collects/tests/mzscheme/contract-mzlib-test.ss
View File

@ -103,8 +103,8 @@ of the contract library does not change over time.
(and (exn? exn)
(,has-proper-blame? (exn-message exn))))))))))
(define (test/pos-blame name expression) (test/spec-failed name expression "module pos"))
(define (test/neg-blame name expression) (test/spec-failed name expression "module neg"))
(define (test/pos-blame name expression) (test/spec-failed name expression "pos"))
(define (test/neg-blame name expression) (test/spec-failed name expression "neg"))
(define (test/well-formed stx)
(contract-eval
@ -126,7 +126,7 @@ of the contract library does not change over time.
(contract-eval `(,test #t flat-contract? ,contract))
(test/spec-failed (format "~a fail" name)
`(contract ,contract ',fail 'pos 'neg)
"module pos")
"pos")
(test/spec-passed/result
(format "~a pass" name)
`(contract ,contract ',pass 'pos 'neg)
@ -1577,14 +1577,14 @@ of the contract library does not change over time.
'(let ()
(define/contract i integer? #t)
i)
"definition i")
"i")
(test/spec-failed
'define/contract3
'(let ()
(define/contract i (-> integer? integer?) (lambda (x) #t))
(i 1))
"definition i")
"i")
(test/spec-failed
'define/contract4
@ -4643,7 +4643,7 @@ so that propagation occurs.
(provide/contract (x integer?))))
(eval '(require 'contract-test-suite3))
(eval 'x))
"module 'contract-test-suite3")
"'contract-test-suite3")
(test/spec-passed
'provide/contract4
@ -4820,7 +4820,7 @@ so that propagation occurs.
(make-s 1 2)
[s-a #f])))
(eval '(require 'pc11b-n)))
"module 'n")
"'n")
|#
(test/spec-passed
@ -4888,7 +4888,7 @@ so that propagation occurs.
(define i #f)
(provide/contract [i integer?])))
(eval '(require 'pos)))
"module 'pos")
"'pos")
;; this is really a positive violation, but name the module `neg' just for an addl test
(test/spec-failed
@ -4899,7 +4899,7 @@ so that propagation occurs.
(define i #f)
(provide/contract [i integer?])))
(eval '(require 'neg)))
"module 'neg")
"'neg")
;; this test doesn't pass yet ... waiting for support from define-struct