From d7e4db3efd8454d4f114fb28e8a136608f47b776 Mon Sep 17 00:00:00 2001 From: Matthew Flatt Date: Tue, 20 Apr 2010 17:28:07 -0600 Subject: [PATCH] fix some tests and docs after racket move --- collects/compiler/compiler-unit.ss | 2 +- collects/dynext/file-unit.ss | 2 +- collects/macro-debugger/model/deriv-util.ss | 2 +- collects/meta/dist-specs.ss | 5 +- collects/mzlib/list.ss | 2 +- collects/r6rs/private/find-version.ss | 4 +- .../racket/{foreign.rkt => unsafe/ffi.rkt} | 109 +++++------------- collects/scheme/foreign.rkt | 93 ++++++++++++++- collects/scribblings/foreign/foreign.scrbl | 3 +- collects/tests/mzscheme/sandbox.ss | 20 ++-- 10 files changed, 138 insertions(+), 104 deletions(-) rename collects/racket/{foreign.rkt => unsafe/ffi.rkt} (94%) diff --git a/collects/compiler/compiler-unit.ss b/collects/compiler/compiler-unit.ss index 473974c5a9..9ff5b08921 100644 --- a/collects/compiler/compiler-unit.ss +++ b/collects/compiler/compiler-unit.ss @@ -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? diff --git a/collects/dynext/file-unit.ss b/collects/dynext/file-unit.ss index f790473347..2385df0047 100644 --- a/collects/dynext/file-unit.ss +++ b/collects/dynext/file-unit.ss @@ -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") diff --git a/collects/macro-debugger/model/deriv-util.ss b/collects/macro-debugger/model/deriv-util.ss index ee8afd2c60..0a3c2a3049 100644 --- a/collects/macro-debugger/model/deriv-util.ss +++ b/collects/macro-debugger/model/deriv-util.ss @@ -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 diff --git a/collects/meta/dist-specs.ss b/collects/meta/dist-specs.ss index 8eba91b2f9..fbc0f2adbb 100644 --- a/collects/meta/dist-specs.ss +++ b/collects/meta/dist-specs.ss @@ -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 diff --git a/collects/mzlib/list.ss b/collects/mzlib/list.ss index 445733821f..ed658ee04e 100644 --- a/collects/mzlib/list.ss +++ b/collects/mzlib/list.ss @@ -1,4 +1,4 @@ -#lang racket/base +#lang scheme/base ;; The `first', etc. operations in this library ;; work on pairs, not lists. diff --git a/collects/r6rs/private/find-version.ss b/collects/r6rs/private/find-version.ss index e26cdafcdb..da2cead888 100644 --- a/collects/r6rs/private/find-version.ss +++ b/collects/r6rs/private/find-version.ss @@ -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 diff --git a/collects/racket/foreign.rkt b/collects/racket/unsafe/ffi.rkt similarity index 94% rename from collects/racket/foreign.rkt rename to collects/racket/unsafe/ffi.rkt index 6fc02d0f7d..2ad92a982a 100644 --- a/collects/racket/foreign.rkt +++ b/collects/racket/unsafe/ffi.rkt @@ -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!) diff --git a/collects/scheme/foreign.rkt b/collects/scheme/foreign.rkt index d3c95b5cba..a3e1b5bd78 100644 --- a/collects/scheme/foreign.rkt +++ b/collects/scheme/foreign.rkt @@ -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))) + ...))]))))]))))) diff --git a/collects/scribblings/foreign/foreign.scrbl b/collects/scribblings/foreign/foreign.scrbl index bdc92ff4d8..52b73ab995 100644 --- a/collects/scribblings/foreign/foreign.scrbl +++ b/collects/scribblings/foreign/foreign.scrbl @@ -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 diff --git a/collects/tests/mzscheme/sandbox.ss b/collects/tests/mzscheme/sandbox.ss index 31ed64392f..b691da7de5 100644 --- a/collects/tests/mzscheme/sandbox.ss +++ b/collects/tests/mzscheme/sandbox.ss @@ -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"