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

fix some tests and docs after racket move

Browse Source
This commit is contained in:
Matthew Flatt 2010-04-20 17:28:07 -06:00
parent 88820fc4a4
commit d7e4db3efd
10 changed files with 138 additions and 104 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

2
collects/compiler/compiler-unit.ss
View File

@ -173,7 +173,7 @@
(bytes=? (subbytes b 0 len) skip-path)))
-inf.0))])
(let* ([sses (append
;; Find all .ss/.scm files:
;; Find all .rkt/.ss/.scm files:
(filter extract-base-filename/ss (directory-list))
;; Add specified doc sources:
(if skip-docs?

2
collects/dynext/file-unit.ss
View File

@ -48,7 +48,7 @@
[else #f]))
extract-base-filename)])
(values
(mk 'extract-base-filename/ss #"ss|scm" "Scheme" #f)
(mk 'extract-base-filename/ss #"rkt|ss|scm" "Racket" #f)
(mk 'extract-base-filename/c
#"c|cc|cxx|cpp|c[+][+]|m" "C" ".c, .cc, .cxx, .cpp, .c++, or .m")
(mk 'extract-base-filename/kp #"kp" "constant pool" ".kp")

2
collects/macro-debugger/model/deriv-util.ss
View File

@ -1,7 +1,7 @@
#lang scheme/base
(require (for-syntax scheme/base)
(for-syntax scheme/private/struct-info)
(for-syntax racket/private/struct-info)
scheme/list
scheme/match
unstable/struct

5
collects/meta/dist-specs.ss
View File

@ -156,9 +156,10 @@ docsrc-filter := (+ (collects: "setup/scribble.ss") ; only with doc sources
std-docs)
man-filter := (man: "*")
tests-filter := (+ (collects: "**/tests/") (srcfile: "tests.ss"))
gui-filter := (- (+ (collects: "**/gui/") (srcfile: "gui.ss"))
gui-filter := (- (+ (collects: "**/gui/") (srcfile: "gui.rkt"))
;; for use in mz code that works in mr too
(srcfile: "scheme/gui/dynamic.ss"))
(srcfile: "scheme/gui/dynamic.rkt")
(srcfile: "racket/gui/dynamic.rkt"))
tools-filter := (+ (collects: "**/tools/") (srcfile: "tools.ss"))
;; these are in the doc directory, but are comitted in svn and should be

2
collects/mzlib/list.ss
View File

@ -1,4 +1,4 @@
#lang racket/base
#lang scheme/base
;; The `first', etc. operations in this library
;; work on pairs, not lists.

4
collects/r6rs/private/find-version.ss
View File

@ -18,7 +18,7 @@
(and
(and (len . < . (bytes-length s))
(bytes=? p (subbytes s 0 len)))
(let ([ext (let ([m (regexp-match #rx#"([.][a-z]+)?[.](ss|sls)$"
(let ([ext (let ([m (regexp-match #rx#"([.][a-z]+)?[.](rkt|ss|sls)$"
(subbytes s len))])
(and m
(or (not (cadr m))
@ -37,7 +37,7 @@
ext)))))))))
files))]
[versions
(let* ([eo '(#".mzscheme.ss" #".mzscheme.sls" #".ss" #".sls")]
(let* ([eo '(#".mzscheme.ss" #".mzscheme.sls" #".ss" #".sls" #".rkt")]
[ext< (lambda (a b)
(> (length (member a eo)) (length (member b eo))))])
(sort candidate-versions

109
collects/racket/foreign.rkt → collects/racket/unsafe/ffi.rkt
View File

@ -5,74 +5,18 @@
(for-syntax racket/base racket/list syntax/stx
racket/struct-info))
;; 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 (syntax-property
(syntax-property
#'from
'not-provide-all-defined
#t)
'nominal-id
'to)))
...))]))))])))))
(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!) (unsafe cast)
ptr-offset ptr-add! offset-ptr? set-ptr-offset!
vector->cpointer flvector->cpointer saved-errno lookup-errno
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 _gcpointer _scheme (rename-out [_scheme _racket]) _fpointer function-ptr
(unsafe memcpy) (unsafe memmove) (unsafe memset)
(unsafe malloc-immobile-cell) (unsafe free-immobile-cell))
(provide ctype-sizeof ctype-alignof compiler-sizeof
malloc free end-stubborn-change
cpointer? ptr-equal? ptr-add ptr-ref ptr-set! (protect-out cast)
ptr-offset ptr-add! offset-ptr? set-ptr-offset!
vector->cpointer flvector->cpointer saved-errno lookup-errno
ctype? make-ctype make-cstruct-type make-sized-byte-string ctype->layout
_void _int8 _uint8 _int16 _uint16 _int32 _uint32 _int64 _uint64
_fixint _ufixint _fixnum _ufixnum
_float _double _double*
_bool _pointer _gcpointer _scheme (rename-out [_scheme _racket]) _fpointer function-ptr
memcpy memmove memset
malloc-immobile-cell free-immobile-cell)
(define-syntax define*
(syntax-rules ()
@ -145,8 +89,8 @@
(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)
(provide (protect-out (rename-out [get-ffi-lib ffi-lib]))
ffi-lib? ffi-lib-name)
(define get-ffi-lib
(case-lambda
[(name) (get-ffi-lib name "")]
@ -214,7 +158,7 @@
(ptr-set! ffi-obj type new)))
;; This is better handled with `make-c-parameter'
(provide* (unsafe ffi-obj-ref))
(provide (protect-out ffi-obj-ref))
(define ffi-obj-ref
(case-lambda
[(name lib) (ffi-obj-ref name lib #f)]
@ -228,7 +172,7 @@
;; 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))
(provide (protect-out get-ffi-obj))
(define get-ffi-obj*
(case-lambda
[(name lib type) (get-ffi-obj* name lib type #f)]
@ -254,7 +198,7 @@
;; 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!))
(provide (protect-out 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))
@ -262,7 +206,7 @@
;; 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))
(provide (protect-out 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))])
@ -270,7 +214,7 @@
[(new) (ffi-set! obj type new)])))
;; Then the fake binding syntax, uses the defined identifier to name the
;; object:
(provide* (unsafe define-c))
(provide (protect-out define-c))
(define-syntax (define-c stx)
(syntax-case stx ()
[(_ var-name lib-name type-expr)
@ -1035,9 +979,9 @@
(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*])))
(provide cvector? cvector-length cvector-type cvector-ptr
;; make-cvector* is a dangerous operation
(protect-out (rename-out [make-cvector make-cvector*])))
(define _cvector* ; used only as input types
(make-ctype _pointer cvector-ptr
@ -1230,8 +1174,8 @@
;; 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!))
(provide cpointer-tag set-cpointer-tag!
cpointer-has-tag? cpointer-push-tag!)
;; Defined as syntax for efficiency, but can be used as procedures too.
(define-syntax (cpointer-has-tag? stx)
@ -1661,7 +1605,7 @@
(ptr-set! cblock type i (car l))
(loop (cdr l) (add1 i))))
cblock)))
(provide* (unsafe cblock->list))
(provide (protect-out cblock->list))
(define (cblock->list cblock type len)
(cond [(zero? len) '()]
[(cpointer? cblock)
@ -1683,7 +1627,7 @@
(ptr-set! cblock type i (vector-ref v i))
(loop (add1 i))))
cblock))))
(provide* (unsafe cblock->vector))
(provide (protect-out cblock->vector))
(define (cblock->vector cblock type len)
(cond [(zero? len) '#()]
[(cpointer? cblock)
@ -1725,4 +1669,3 @@
(let loop () (will-execute killer-executor) (loop))))))))
(will-register killer-executor obj finalizer))
(define-unsafer unsafe!)

93
collects/scheme/foreign.rkt
View File

@ -1,2 +1,91 @@
#lang scheme/private/provider
racket/foreign
#lang racket/base
(require (for-syntax scheme/base))
(define-syntax-rule (provide-except-unsafe lib u! id ...)
(begin
(require lib)
(provide (except-out (all-from-out lib) id ...))
(define-syntax (u! stx)
(syntax-case stx ()
[(_) (with-syntax ([lib+ids (datum->syntax stx '(lib id ...))])
#'(require (only-in . lib+ids)))]))))
(provide-except-unsafe racket/unsafe/ffi unsafe!
free end-stubborn-change
ptr-ref ptr-set! cast
make-sized-byte-string
memcpy memmove memset
malloc-immobile-cell free-immobile-cell
malloc
ffi-lib
ffi-obj-ref
get-ffi-obj
set-ffi-obj!
make-c-parameter
define-c
define-fun-syntax
make-cvector*
cpointer-tag set-cpointer-tag!
cpointer-has-tag? cpointer-push-tag!
cblock->list
cblock->vector)
(provide provide* define-unsafer
unsafe!)
;; 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 (syntax-property
(syntax-property
#'from
'not-provide-all-defined
#t)
'nominal-id
'to)))
...))]))))])))))

3
collects/scribblings/foreign/foreign.scrbl
View File

@ -5,7 +5,8 @@
@author["Eli Barzilay"]
@defmodule[scheme/foreign #:use-sources ('#%foreign)]
@defmodule[scheme/foreign #:use-sources ('#%foreign
racket/unsafe/ffi)]
The @schememodname[scheme/foreign] library enables the direct use of
C-based APIs within Scheme programs---without writing any new C

20
collects/tests/mzscheme/sandbox.ss
View File

@ -285,9 +285,9 @@
--top--
(let* ([tmp (make-temporary-file "sandboxtest~a" 'directory)]
[strpath (lambda xs (path->string (apply build-path xs)))]
[schemelib (strpath (collection-path "scheme"))]
[list-lib (strpath schemelib "list.rkt")]
[list-zo (strpath schemelib "compiled" "list_rkt.zo")]
[racketlib (strpath (collection-path "racket"))]
[list-lib (strpath racketlib "list.rkt")]
[list-zo (strpath racketlib "compiled" "list_rkt.zo")]
[test-lib (strpath tmp "sandbox-test.ss")]
[test-zo (strpath tmp "compiled" "sandbox-test_ss.zo")]
[test2-lib (strpath tmp "sandbox-test2.ss")]
@ -296,7 +296,7 @@
(make-base-evaluator!)
--eval--
;; reading from collects is allowed
(list? (directory-list ,schemelib))
(list? (directory-list ,racketlib))
(file-exists? ,list-lib) => #t
(input-port? (open-input-file ,list-lib)) => #t
;; writing is forbidden
@ -304,13 +304,13 @@
;; reading from other places is forbidden
(directory-list ,tmp) =err> "`read' access denied"
;; no network too
(require scheme/tcp)
(require racket/tcp)
(tcp-listen 12345) =err> "network access denied"
--top--
;; reading from a specified require is fine
(with-output-to-file test-lib
(lambda ()
(printf "~s\n" '(module sandbox-test scheme/base
(printf "~s\n" '(module sandbox-test racket/base
(define x 123) (provide x)))))
(make-base-evaluator/reqs! `(,test-lib))
--eval--
@ -322,7 +322,7 @@
;; should work also for module evaluators
;; --> NO! Shouldn't make user code require whatever it wants
;; (make-module-evaluator!
;; `(module foo scheme/base (require (file ,test-lib))))
;; `(module foo racket/base (require (file ,test-lib))))
;; --eval--
;; x => 123
;; (length (with-input-from-file ,test-lib read)) => 5
@ -340,7 +340,7 @@
(list? (directory-list ,tmp))
(open-output-file ,(build-path tmp "blah")) =err> "access denied"
(delete-directory ,(build-path tmp "blah")) =err> "access denied"
(list? (directory-list ,schemelib))
(list? (directory-list ,racketlib))
;; we can read/write/delete list-zo, but we can't load bytecode from
;; it due to the code inspector
(copy-file ,list-zo ,test-zo) => (void)
@ -368,7 +368,7 @@
;; bytecode from test2-lib is explicitly allowed
(load/use-compiled ,test2-lib)
(require 'list) => (void))
((dynamic-require 'scheme/file 'delete-directory/files) tmp))
((dynamic-require 'racket/file 'delete-directory/files) tmp))
;; languages and requires
--top--
@ -389,7 +389,7 @@
(eq? (ev "6") (ev "(sub1 (* 2 3.5))"))
(eq? (ev "6") (ev "(sub1 (* 2 x))"))
--top--
(make-base-evaluator/reqs! '(scheme/list))
(make-base-evaluator/reqs! '(racket/list))
--eval--
(last-pair '(1 2 3)) => '(3)
(last-pair null) =err> "expected argument of type"