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

Remove most uses of mzscheme in the core.

Browse Source 
Remaining are:
 - parts of unit200 that Matthew plans to remove.
 - the `mzscheme` implementation itself.

The implementation of `mzscheme` has been moved
to the `mzscheme` collection (from the `racket` and
`scheme` collections). The `scheme/mzscheme`
language, which was undocumented, has been removed.

This is slightly backwards-incompatible, because
the `xform` handling of precompiled headers now
evaluates code in a `racket/base`-like namespace,
instead of in a `mzscheme`-like namespace.
This commit is contained in:
Sam Tobin-Hochstadt 2013-06-30 10:04:34 -04:00
parent d0a0e31abc
commit d54c1e4e49
58 changed files with 420 additions and 424 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

8
racket/lib/collects/compiler/bundle-dist.rkt
View File

@ -1,7 +1,7 @@
(module bundle-dist mzscheme
(module bundle-dist racket/base
(require racket/file
(only racket/base lambda)
(only-in racket/base lambda)
racket/path
racket/system
file/zip
@ -80,8 +80,8 @@
"-mode" "555"
"-volname" (path->string
(path-replace-suffix (file-name-from-path target) #""))
"-srcfolder" (path->string (expand-path (path->complete-path dir)))
(path->string (expand-path (path->complete-path target))))])
"-srcfolder" (path->string (cleanse-path (path->complete-path dir)))
(path->string (cleanse-path (path->complete-path target))))])
((list-ref p 4) 'wait)
(unless (eq? ((list-ref p 4) 'status) 'done-ok)
(error 'bundle-directory

2
racket/lib/collects/compiler/compiler.rkt
View File

@ -1,4 +1,4 @@
(module compiler mzscheme
(module compiler racket/base
(require racket/unit)
(require "sig.rkt")

2
racket/lib/collects/compiler/embed-sig.rkt
View File

@ -1,5 +1,5 @@
(module embed-sig mzscheme
(module embed-sig racket/base
(require racket/unit)
(provide compiler:embed^)

6
racket/lib/collects/compiler/embed-unit.rkt
View File

@ -446,9 +446,9 @@
(if (path? module-path)
(path->complete-path module-path)
module-path)])
(syntax-case (expand `(,#'module m mzscheme
(require (only ,module-path)
mzlib/runtime-path)
(syntax-case (expand `(,#'module m racket/base
(#%require (only ,module-path)
racket/runtime-path)
(runtime-paths ,module-path))) (quote)
[(_ m mz (#%mb rfs req (quote (spec ...))))
(syntax->datum #'(spec ...))]

2
racket/lib/collects/compiler/option-unit.rkt
View File

@ -1,4 +1,4 @@
#lang mzscheme
#lang racket/base
(require racket/unit)
(require "sig.rkt")

2
racket/lib/collects/compiler/option.rkt
View File

@ -1,4 +1,4 @@
(module option mzscheme
(module option racket/base
(require racket/unit)
(require "sig.rkt"

5
racket/lib/collects/compiler/private/collects-path.rkt
View File

@ -1,5 +1,4 @@
(module collects-path mzscheme
(module collects-path racket/base
(provide collects-path->bytes
check-collects-path
@ -54,4 +53,4 @@
(file-position out libpos)
(write-bytes collects-path-bytes out)
(write-bytes #"\0\0" out)))
'update)))))
#:exists 'update)))))

3
racket/lib/collects/compiler/private/embed.rkt
View File

@ -1,5 +1,4 @@
(module embed mzscheme
(module embed racket/base
(require compiler/embed)
(define mzc:create-embedding-executable create-embedding-executable)
(define mzc:embedding-executable-add-suffix embedding-executable-add-suffix)

4
racket/lib/collects/compiler/private/macfw.rkt
View File

@ -1,7 +1,7 @@
(module macfw mzscheme
(module macfw racket/base
(require "mach-o.rkt"
racket/string
(only racket/base regexp-quote)
(only-in racket/base regexp-quote)
racket/system)
(provide update-framework-path

2
racket/lib/collects/compiler/private/windlldir.rkt
View File

@ -1,4 +1,4 @@
(module windlldir mzscheme
(module windlldir racket/base
(require racket/port
"winutf16.rkt")

2
racket/lib/collects/compiler/private/winsubsys.rkt
View File

@ -1,4 +1,4 @@
(module winsubsys mzscheme
(module winsubsys racket/base
(provide set-subsystem)
(define DF_NewHeaderOffset #x3C)

170
racket/lib/collects/compiler/private/xform.rkt
View File

@ -1,6 +1,6 @@
(module xform mzscheme
(module xform racket/base
(require racket/list
(only racket/base sort filter remove let)
(for-syntax racket/base)
racket/system)
(provide xform)
@ -43,10 +43,10 @@
;; "AST" structures
;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
(define-struct tok (n line file) (make-inspector))
(define-struct tok (n line file) #:inspector (make-inspector))
(define-struct (sysheader-tok tok) ())
(define-struct (seq tok) (close in) (make-inspector))
(define-struct (parens seq) () (make-inspector))
(define-struct (seq tok) (close in) #:inspector (make-inspector))
(define-struct (parens seq) () #:inspector (make-inspector))
(define-struct (brackets seq) ())
(define-struct (braces seq) ())
(define-struct (callstage-parens parens) ())
@ -72,28 +72,28 @@
(define seqce vector)
;; A cheap way of getting rid of unneeded prototypes:
(define used-symbols (make-hash-table))
(hash-table-put! used-symbols (string->symbol "GC_variable_stack") 1)
(hash-table-put! used-symbols (string->symbol "GC_cpp_delete") 1)
(hash-table-put! used-symbols (string->symbol "GC_get_variable_stack") 1)
(hash-table-put! used-symbols (string->symbol "GC_set_variable_stack") 1)
(hash-table-put! used-symbols (string->symbol "memset") 1)
(hash-table-put! used-symbols (string->symbol "scheme_thread_local_key") 1)
(hash-table-put! used-symbols (string->symbol "scheme_thread_locals") 1)
(hash-table-put! used-symbols (string->symbol "pthread_getspecific") 1)
(define used-symbols (make-hasheq))
(hash-set! used-symbols (string->symbol "GC_variable_stack") 1)
(hash-set! used-symbols (string->symbol "GC_cpp_delete") 1)
(hash-set! used-symbols (string->symbol "GC_get_variable_stack") 1)
(hash-set! used-symbols (string->symbol "GC_set_variable_stack") 1)
(hash-set! used-symbols (string->symbol "memset") 1)
(hash-set! used-symbols (string->symbol "scheme_thread_local_key") 1)
(hash-set! used-symbols (string->symbol "scheme_thread_locals") 1)
(hash-set! used-symbols (string->symbol "pthread_getspecific") 1)
;; For dependency tracking:
(define depends-files (make-hash-table 'equal))
(define depends-files (make-hash))
(define (make-triple v src line sysheader?)
(when (symbol? v)
(hash-table-put! used-symbols v
(add1 (hash-table-get
(hash-set! used-symbols v
(add1 (hash-ref
used-symbols
v
(lambda () 0)))))
(when (and src output-depends-info?)
(hash-table-put! depends-files src #t))
(hash-set! depends-files src #t))
(if sysheader?
(make-sysheader-tok v line src)
(make-tok v line src)))
@ -479,7 +479,7 @@
(define recorded-cpp-out
(and precompiling-header?
(open-output-file (change-suffix file-out #".e") 'truncate)))
(open-output-file (change-suffix file-out #".e") #:exists 'truncate)))
(define recorded-cpp-in
(and precompiled-header
(open-input-file (change-suffix precompiled-header #".e"))))
@ -557,7 +557,7 @@
;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
(current-output-port (if file-out
(open-output-file file-out 'truncate)
(open-output-file file-out #:exists 'truncate)
(make-output-port 'dev/null
always-evt
(lambda (s st ed f?)
@ -585,7 +585,7 @@
(define map-port
(if palm-out
(open-output-file palm-out 'truncate)
(open-output-file palm-out #:exists 'truncate)
#f))
;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
@ -808,10 +808,10 @@
nonempty-calls?))
;; A function prototype record:
(define-struct prototype (type args static? pointer? pointer?-determined?))
(define-struct prototype (type args static? pointer? pointer?-determined?) #:mutable)
;; A C++ class record:
(define-struct c++-class (parent parent-name prototyped top-vars))
(define-struct c++-class (parent parent-name prototyped top-vars) #:mutable)
;; Symbol constants:
(define semi (string->symbol ";"))
@ -903,17 +903,17 @@
scheme_make_small_bignum scheme_make_small_rational scheme_make_small_complex))
(define non-functions-table
(let ([ht (make-hash-table)])
(let ([ht (make-hasheq)])
(for-each (lambda (s)
(hash-table-put! ht s #f))
(hash-set! ht s #f))
non-functions)
ht))
(define args-unevaled '(sizeof __typeof __builtin_object_size))
(define args-unevaled-table
(let ([ht (make-hash-table)])
(let ([ht (make-hasheq)])
(for-each (lambda (s)
(hash-table-put! ht s #t))
(hash-set! ht s #t))
args-unevaled)
ht))
@ -936,9 +936,9 @@
'("XTextExtents" "XTextExtents16"
"XDrawImageString16" "XDrawImageString"
"XDrawString16" "XDrawString"))))
(define non-gcing-functions (make-hash-table))
(define non-gcing-functions (make-hasheq))
(for-each (lambda (name)
(hash-table-put! non-gcing-functions name #t))
(hash-set! non-gcing-functions name #t))
non-gcing-builtin-functions)
(define non-returning-functions
@ -1038,49 +1038,50 @@
;; Marhsaling and unmarshaling
;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
(define makers (make-hash-table))
(hash-table-put! makers 'struct:tok (cons 'make-tok make-tok))
(hash-table-put! makers 'struct:sysheader-tok (cons 'make-sysheader-tok make-sysheader-tok))
(hash-table-put! makers 'struct:seq (cons 'make-a-seq make-a-seq))
(hash-table-put! makers 'struct:parens (cons 'make-parens make-parens))
(hash-table-put! makers 'struct:brackets (cons 'make-brackets make-brackets))
(hash-table-put! makers 'struct:braces (cons 'make-braces make-braces))
(hash-table-put! makers 'struct:callstage-parens (cons 'make-callstage-parens make-callstage-parens))
(hash-table-put! makers 'struct:creation-parens (cons 'make-creation-parens make-creation-parens))
(hash-table-put! makers 'struct:nosrc-parens (cons 'make-nosrc-parens make-nosrc-parens))
(hash-table-put! makers 'struct:call (cons 'make-call make-call))
(hash-table-put! makers 'struct:block-push (cons 'make-block-push make-block-push))
(hash-table-put! makers 'struct:note (cons 'make-note make-note))
(hash-table-put! makers 'struct:vtype (cons 'make-vtype make-vtype))
(hash-table-put! makers 'struct:pointer-type (cons 'make-pointer-type make-pointer-type))
(hash-table-put! makers 'struct:array-type (cons 'make-array-type make-array-type))
(hash-table-put! makers 'struct:struc-type (cons 'make-struc-type make-struc-type))
(hash-table-put! makers 'struct:struct-array-type (cons 'make-struct-array-type make-struct-array-type))
(hash-table-put! makers 'struct:union-type (cons 'make-union-type make-union-type))
(hash-table-put! makers 'struct:non-pointer-type (cons 'make-non-pointer-type make-non-pointer-type))
(hash-table-put! makers 'struct:live-var-info (cons 'make-live-var-info make-live-var-info))
(hash-table-put! makers 'struct:prototype (cons 'make-prototype make-prototype))
(hash-table-put! makers 'struct:c++-class (cons 'make-c++-class make-c++-class))
(define makers (make-hasheq))
(hash-set! makers 'struct:tok (cons 'make-tok make-tok))
(hash-set! makers 'struct:sysheader-tok (cons 'make-sysheader-tok make-sysheader-tok))
(hash-set! makers 'struct:seq (cons 'make-a-seq make-a-seq))
(hash-set! makers 'struct:parens (cons 'make-parens make-parens))
(hash-set! makers 'struct:brackets (cons 'make-brackets make-brackets))
(hash-set! makers 'struct:braces (cons 'make-braces make-braces))
(hash-set! makers 'struct:callstage-parens (cons 'make-callstage-parens make-callstage-parens))
(hash-set! makers 'struct:creation-parens (cons 'make-creation-parens make-creation-parens))
(hash-set! makers 'struct:nosrc-parens (cons 'make-nosrc-parens make-nosrc-parens))
(hash-set! makers 'struct:call (cons 'make-call make-call))
(hash-set! makers 'struct:block-push (cons 'make-block-push make-block-push))
(hash-set! makers 'struct:note (cons 'make-note make-note))
(hash-set! makers 'struct:vtype (cons 'make-vtype make-vtype))
(hash-set! makers 'struct:pointer-type (cons 'make-pointer-type make-pointer-type))
(hash-set! makers 'struct:array-type (cons 'make-array-type make-array-type))
(hash-set! makers 'struct:struc-type (cons 'make-struc-type make-struc-type))
(hash-set! makers 'struct:struct-array-type (cons 'make-struct-array-type make-struct-array-type))
(hash-set! makers 'struct:union-type (cons 'make-union-type make-union-type))
(hash-set! makers 'struct:non-pointer-type (cons 'make-non-pointer-type make-non-pointer-type))
(hash-set! makers 'struct:live-var-info (cons 'make-live-var-info make-live-var-info))
(hash-set! makers 'struct:prototype (cons 'make-prototype make-prototype))
(hash-set! makers 'struct:c++-class (cons 'make-c++-class make-c++-class))
(define (make-short-tok l) (make-tok l #f #f))
;; A precompiled header saves the above state variables.
(when precompiled-header
(let ([orig (current-namespace)])
(parameterize ([current-namespace (make-namespace)])
(namespace-attach-module orig 'mzscheme)
(namespace-require 'mzscheme)
(parameterize ([current-namespace (make-base-empty-namespace)])
(namespace-require/copy 'racket/base)
(namespace-attach-module orig 'racket/base)
(namespace-require 'racket/base)
;; Put constructors into the namespace:
(hash-table-for-each makers
(hash-for-each makers
(lambda (k v)
(namespace-set-variable-value! (car v) (cdr v))))
(namespace-set-variable-value! 'make-short-tok make-short-tok)
;; Load the pre-compiled-header-as-.zo:
(let ([l (load (change-suffix precompiled-header #".zo"))])
(for-each (lambda (x)
(hash-table-put! used-symbols (car x)
(hash-set! used-symbols (car x)
(+
(hash-table-get
(hash-ref
used-symbols (car x)
(lambda () 0))
(cdr x))))
@ -1094,7 +1095,7 @@
(set! non-pointer-types (list-ref l 5))
(set! struct-defs (list-ref l 6))
(set! non-gcing-functions (hash-table-copy (list-ref l 7)))
(set! non-gcing-functions (hash-copy (list-ref l 7)))
(set! gc-var-stack-mode (list-ref l 8))))))
@ -1519,11 +1520,11 @@
[(proc-prototype? e)
(let ([name (register-proto-information e)])
(when (eq? (tok-n (car e)) '__xform_nongcing__)
(hash-table-put! non-gcing-functions name #t))
(hash-set! non-gcing-functions name #t))
(when show-info?
(printf "/* PROTO ~a */\n" name))
(if (or precompiling-header?
(> (hash-table-get used-symbols name) 1)
(> (hash-ref used-symbols name) 1)
(ormap (lambda (v) (eq? (tok-n v) 'virtual)) e)) ; can't drop virtual methods!
(if palm?
(add-segment-label name e)
@ -1553,7 +1554,7 @@
[(function? e)
(let ([name (register-proto-information e)])
(when (eq? (tok-n (car e)) '__xform_nongcing__)
(hash-table-put! non-gcing-functions name #t))
(hash-set! non-gcing-functions name #t))
(if (skip-function? e)
e
(begin
@ -1698,7 +1699,7 @@
(andmap (lambda (x) (and (symbol? (tok-n x))
(not (eq? '|,| (tok-n x)))))
e)
(= 1 (hash-table-get used-symbols
(= 1 (hash-ref used-symbols
(let loop ([e e])
(if (null? (cddr e))
(tok-n (car e))
@ -1710,7 +1711,7 @@
(define (unused-struc-typedef? e)
(let ([once (lambda (s)
(and (not precompiling-header?)
(= 1 (hash-table-get used-symbols
(= 1 (hash-ref used-symbols
(tok-n s)))))]
[seps (list '|,| '* semi)])
(let ([e (if (eq? '__extension__ (car e))
@ -1920,8 +1921,10 @@
0)]
[non-ptr-base (cond
[(eq? 'unsigned (tok-n (car e)))
(if (memq (tok-n (cadr e)) '(int long char intptr_t))
(list 'unsigned (tok-n (cadr e))))]
(if (memq (tok-n (cadr e))
'(int long char intptr_t))
(list 'unsigned (tok-n (cadr e)))
(void))]
[(lookup-non-pointer-type (tok-n (car e)))
(list (tok-n (car e)))]
[else #f])])
@ -2488,7 +2491,7 @@
e
(lambda (name class-name type args static?)
type)))])
(if (hash-table-get non-gcing-functions name (lambda () #f))
(if (hash-ref non-gcing-functions name (lambda () #f))
(when saw-gcing-call
(log-error "[GCING] ~a in ~a: Function ~a declared __xform_nongcing__, but includes a function call."
(tok-line saw-gcing-call) (tok-file saw-gcing-call)
@ -2871,15 +2874,15 @@
(convert-function-calls (car el) extra-vars &-vars c++-class live-vars "decls" #f #t)])
(dloop (cdr el) live-vars))))))])
;; Calculate vars to push in this block. Make sure there are no duplicates.
(let ([newly-pushed (let ([ht (make-hash-table)])
(let ([newly-pushed (let ([ht (make-hasheq)])
(for-each (lambda (x)
(when (or (assq (car x) local-vars)
(assq (car x) pushable-vars)
(and setup-stack-return-type
(is-generated? x)))
(hash-table-put! ht (car x) x)))
(hash-set! ht (car x) x)))
(live-var-info-pushed-vars live-vars))
(hash-table-map ht (lambda (k v) v)))])
(hash-map ht (lambda (k v) v)))])
(values (apply
append
pragmas
@ -3035,7 +3038,7 @@
;; Something precedes
(not (null? (cdr e-)))
;; Not an assignment, sizeof, if, string
(or nf? (hash-table-get non-functions-table (tok-n (cadr e-)) #t))
(or nf? (hash-ref non-functions-table (tok-n (cadr e-)) #t))
(not (string? (tok-n (cadr e-))))
;; Look back one more for if, etc. if preceding is paren
(not (and (parens? (cadr e-))
@ -3433,7 +3436,7 @@
[(sub-memcpy?)
;; memcpy, etc. call?
(and (pair? (cdr e-))
(hash-table-get non-gcing-functions (tok-n (cadr e-)) #f))]
(hash-ref non-gcing-functions (tok-n (cadr e-)) #f))]
[(args live-vars)
(convert-paren-interior args vars &-vars
c++-class
@ -3507,7 +3510,7 @@
(live-var-info-nonempty-calls? live-vars)))])
(let ([non-gcing-call?
(and (null? (cdr func))
(hash-table-get non-gcing-functions (tok-n (car func)) (lambda () #f)))]
(hash-ref non-gcing-functions (tok-n (car func)) (lambda () #f)))]
[setjmp-call?
(memq (tok-n (car func)) setjmp-functions)])
(loop rest-
@ -3566,7 +3569,7 @@
(null? rest-)
(not (memq (tok-n (car rest-)) '(return else)))))))))))]
[(and (looks-like-call? e- #t)
(hash-table-get args-unevaled-table (tok-n (cadr e-)) #f))
(hash-ref args-unevaled-table (tok-n (cadr e-)) #f))
(loop (cddr e-) (cons (cadr e-) (cons (car e-) result)) live-vars converted-sub?)]
[(eq? 'goto (tok-n (car e-)))
;; Goto - assume all vars are live
@ -4027,7 +4030,7 @@
(if (eq? 'struct:tok (vector-ref vec 0))
(list 'make-short-tok (loop (vector-ref vec 1)))
(cons
(car (hash-table-get makers (vector-ref vec 0)))
(car (hash-ref makers (vector-ref vec 0)))
(map loop (cdr (vector->list vec))))))]
[(list? v) (cons 'list (map loop v))]
[(pair? v) (list 'cons (loop (car v)) (loop (cdr v)))]
@ -4043,7 +4046,7 @@
(list
'list
(list 'quote (hash-table-map used-symbols cons))
(list 'quote (hash-map used-symbols cons))
(marshall c++-classes)
(marshall (prototyped))
@ -4057,12 +4060,15 @@
(with-output-to-file (change-suffix file-out #".zo")
(lambda ()
(let ([orig (current-namespace)])
(parameterize ([current-namespace (make-namespace)])
(namespace-attach-module orig 'mzscheme)
(namespace-require 'mzscheme)
(parameterize ([current-namespace (make-base-namespace)])
(namespace-require/copy 'racket/base)
(namespace-attach-module orig 'racket/base)
(namespace-require 'racket/base)
(namespace-require '(for-syntax racket/base))
(namespace-require/copy '(for-syntax racket/base))
(eval #'(define-syntaxes (#%top-interaction) (lambda (stx) (cdr (syntax-e stx)))))
(write (compile e)))))
'truncate))))
#:exists 'truncate))))
(when precompiling-header?
(let loop ([i 1])
@ -4079,6 +4085,6 @@
(when output-depends-info?
(with-output-to-file (change-suffix file-out #".sdep")
(lambda ()
(write (hash-table-map depends-files (lambda (k v) k)))
(write (hash-map depends-files (lambda (k v) k)))
(newline))
'truncate/replace))))))
#:exists 'truncate/replace))))))

3
racket/lib/collects/compiler/sig.rkt
View File

@ -1,5 +1,4 @@
#lang mzscheme
#lang racket/base
(require racket/unit)

4
racket/lib/collects/dynext/compile-sig.rkt
View File

@ -1,4 +1,4 @@
(module compile-sig mzscheme
#lang racket/base
(require racket/unit)
(provide dynext:compile^)
@ -15,5 +15,5 @@
use-standard-compiler
get-standard-compilers
compile-variant
expand-for-compile-variant)))
expand-for-compile-variant))

2
racket/lib/collects/dynext/compile-unit.rkt
View File

@ -1,4 +1,4 @@
(module compile-unit mzscheme
(module compile-unit scheme/base
(require racket/unit
racket/system
"private/dirs.rkt"

4
racket/lib/collects/dynext/compile.rkt
View File

@ -1,4 +1,4 @@
(module compile mzscheme
#lang racket/base
(require racket/unit)
(require "compile-sig.rkt"
@ -6,4 +6,4 @@
(define-values/invoke-unit/infer dynext:compile@)
(provide-signature-elements dynext:compile^))
(provide-signature-elements dynext:compile^)

8
racket/lib/collects/dynext/dynext-sig.rkt
View File

@ -1,7 +1,7 @@
(module dynext-sig mzscheme
(module dynext-sig racket/base
(require "compile-sig.rkt" "link-sig.rkt" "file-sig.rkt")
(provide (all-from "compile-sig.rkt")
(all-from "link-sig.rkt")
(all-from "file-sig.rkt")))
(provide (all-from-out "compile-sig.rkt")
(all-from-out "link-sig.rkt")
(all-from-out "file-sig.rkt")))

8
racket/lib/collects/dynext/dynext-unit.rkt
View File

@ -1,7 +1,7 @@
(module dynext-unit mzscheme
#lang racket/base
(require "compile-unit.rkt" "link-unit.rkt" "file-unit.rkt")
(provide (all-from "compile-unit.rkt")
(all-from "link-unit.rkt")
(all-from "file-unit.rkt")))
(provide (all-from-out "compile-unit.rkt")
(all-from-out "link-unit.rkt")
(all-from-out "file-unit.rkt"))

8
racket/lib/collects/dynext/dynext.rkt
View File

@ -1,7 +1,7 @@
(module dynext mzscheme
#lang racket/base
(require "compile.rkt" "link.rkt" "file.rkt")
(provide (all-from "compile.rkt")
(all-from "link.rkt")
(all-from "file.rkt")))
(provide (all-from-out "compile.rkt")
(all-from-out "link.rkt")
(all-from-out "file.rkt"))

5
racket/lib/collects/dynext/file-sig.rkt
View File

@ -1,5 +1,4 @@
(module file-sig mzscheme
#lang racket/base
(require racket/unit)
(provide dynext:file^)
@ -15,4 +14,4 @@
extract-base-filename/c
extract-base-filename/kp
extract-base-filename/o
extract-base-filename/ext)))
extract-base-filename/ext))

4
racket/lib/collects/dynext/file.rkt
View File

@ -1,4 +1,4 @@
(module file mzscheme
#lang racket/base
(require racket/unit)
(require "file-sig.rkt"
@ -6,4 +6,4 @@
(define-values/invoke-unit/infer dynext:file@)
(provide-signature-elements dynext:file^))
(provide-signature-elements dynext:file^)

4
racket/lib/collects/dynext/link-sig.rkt
View File

@ -1,4 +1,4 @@
(module link-sig mzscheme
#lang racket/base
(require racket/unit)
(provide dynext:link^)
@ -13,4 +13,4 @@
current-use-mzdyn
use-standard-linker
link-variant
expand-for-link-variant)))
expand-for-link-variant))

2
racket/lib/collects/dynext/link-unit.rkt
View File

@ -1,4 +1,4 @@
(module link-unit mzscheme
(module link-unit scheme/base
(require racket/unit
racket/system
"private/dirs.rkt"

4
racket/lib/collects/dynext/link.rkt
View File

@ -1,4 +1,4 @@
(module link mzscheme
#lang racket/base
(require racket/unit)
(require "link-sig.rkt"
@ -6,4 +6,4 @@
(define-values/invoke-unit/infer dynext:link@)
(provide-signature-elements dynext:link^))
(provide-signature-elements dynext:link^)

3
racket/lib/collects/dynext/private/cmdargs.rkt
View File

@ -1,5 +1,4 @@
(module cmdargs mzscheme
(module cmdargs scheme/base
(provide split-command-line-args)

5
racket/lib/collects/dynext/private/dirs.rkt
View File

@ -1,8 +1,7 @@
(module dirs mzscheme
#lang racket/base
(require setup/dirs)
(define include-dir find-include-dir)
(define std-library-dir find-lib-dir)
(provide include-dir std-library-dir))
(provide include-dir std-library-dir)

2
racket/lib/collects/ffi/examples/use-magick.rkt
View File

@ -251,7 +251,7 @@
;; (MagickAnimateImages morph)
;; (let ([x (test (MagickWriteImageBlob w))])
;; (with-output-to-file "~/tmp/x" (lambda () (display x)) 'truncate)
;; (with-output-to-file "~/tmp/x" (lambda () (display x)) #:exists 'truncate)
;; (let ([ww (NewMagickWand)])
;; (test (MagickReadImageBlob ww x))
;; (MagickDisplayImage ww)))

11
racket/lib/collects/file/gzip.rkt
View File

@ -12,11 +12,11 @@
;; LGPL-compatible license. I (Eli Barzilay) have tried to contact the
;; author, but no reply yet.
(module deflate mzscheme
(module deflate racket/base
(provide deflate gzip-through-ports gzip)
(require mzlib/unit200)
(require mzlib/unit200 (for-syntax racket/base))
(define (vector-ref* v i)
(let ([r (vector-ref v i)])
@ -880,7 +880,7 @@
;; */
;; /* Data structure describing a single value and its code string. */
(define-struct ct_data (freq code dad len))
(define-struct ct_data (freq code dad len) #:mutable)
;; union {
;; ush freq; ;; /* frequency count */
;; ush code; ;; /* bit string */
@ -930,7 +930,8 @@
extra_base; ;; /* base index for extra_bits */
elems; ;; /* max number of elements in the tree */
max_length; ;; /* max bit length for the codes */
max_code)); ;; /* largest code with non zero frequency */
max_code); ;; /* largest code with non zero frequency */
#:mutable)
(define l_desc (make-tree_desc
dyn_ltree static_ltree extra_lbits
@ -2213,7 +2214,7 @@
(dynamic-wind
void
(lambda ()
(let ([o (open-output-file outfile 'truncate/replace)])
(let ([o (open-output-file outfile #:exists 'truncate/replace)])
(dynamic-wind
void
(lambda ()

5
racket/lib/collects/file/zip.rkt
View File

@ -1,8 +1,7 @@
;; A modification of Dave Herman's zip module
(module zip mzscheme
(require file/gzip racket/file
(only racket/base define))
(module zip racket/base
(require file/gzip racket/file)
;; ===========================================================================
;; DATA DEFINITIONS

1
racket/lib/collects/mzlib/private/sigutil.rkt
View File

@ -1,4 +1,3 @@
(module sigutil mzscheme
;; Used by unitsig.rkt
;; (needs an overhaul, too)

112
racket/lib/collects/mzscheme/main.rkt
View File

@ -1,3 +1,111 @@
;;----------------------------------------------------------------------
;; mzscheme: provide everything
(module main scheme/mzscheme
(provide (all-from scheme/mzscheme)))
(module mzscheme '#%kernel
(#%require racket/private/more-scheme
(all-except racket/private/misc
collection-path
collection-file-path)
racket/private/letstx-scheme
racket/private/stxcase-scheme
racket/private/stx
racket/private/qqstx
racket/private/define
mzscheme/private/stxmz-body
mzscheme/private/old-ds
mzscheme/private/old-rp
mzscheme/private/old-if
mzscheme/private/old-procs
racket/private/map ; shadows #%kernel bindings
racket/private/kernstruct
racket/private/promise
racket/private/cert
(only racket/private/cond old-cond)
;; shadows #%kernel bindings:
(only racket/private/list
assq assv assoc reverse)
racket/private/member
racket/tcp
racket/udp
'#%builtin) ; so it's attached
(#%provide require require-for-syntax require-for-template require-for-label
provide provide-for-syntax provide-for-label
(all-from-except racket/private/more-scheme case old-case
log-fatal log-error log-warning log-info log-debug
hash-update hash-update!)
(rename old-case case)
(all-from racket/private/misc)
collection-path
collection-file-path
(all-from-except racket/private/stxcase-scheme _ datum datum-case with-datum)
(all-from-except racket/private/letstx-scheme
-define -define-syntax -define-struct
cond old-cond else =>)
(rename old-cond cond)
define-struct let-struct
identifier? ;; from racket/private/stx
(all-from racket/private/cert)
(all-from-except racket/private/qqstx quasidatum undatum undatum-splicing)
(all-from racket/private/define)
(all-from racket/private/kernstruct)
force delay promise?
(all-from-except '#%kernel #%module-begin #%datum
if make-empty-namespace
syntax->datum datum->syntax
free-identifier=?
free-transformer-identifier=?
free-template-identifier=?
free-label-identifier=?
vector-copy!
thread-send
thread-receive
thread-try-receive
thread-receive-evt
make-hash make-immutable-hash make-weak-hash
make-hasheq make-immutable-hasheq make-weak-hasheq
hash? hash-eq? hash-weak?
hash-ref hash-set! hash-set
hash-remove! hash-remove
hash-copy hash-count
hash-map hash-for-each
hash-iterate-first hash-iterate-next
hash-iterate-value hash-iterate-key
log-message log-level? make-logger logger? current-logger logger-name
make-log-receiver log-receiver?
prop:incomplete-arity)
(rename syntax->datum syntax-object->datum)
(rename datum->syntax datum->syntax-object)
(rename free-identifier=? module-identifier=?)
(rename free-transformer-identifier=? module-transformer-identifier=?)
(rename free-template-identifier=? module-template-identifier=?)
(rename free-label-identifier=? module-label-identifier=?)
(rename free-identifier=?* free-identifier=?)
make-hash-table hash-table? make-immutable-hash-table
(rename hash-ref hash-table-get)
(rename hash-set! hash-table-put!)
(rename hash-remove! hash-table-remove!)
(rename hash-count hash-table-count)
(rename hash-copy hash-table-copy)
(rename hash-map hash-table-map)
(rename hash-for-each hash-table-for-each)
(rename hash-iterate-first hash-table-iterate-first)
(rename hash-iterate-next hash-table-iterate-next)
(rename hash-iterate-value hash-table-iterate-value)
(rename hash-iterate-key hash-table-iterate-key)
namespace-transformer-require
transcript-on transcript-off
(rename cleanse-path expand-path)
(rename if* if)
(rename list list-immutable)
make-namespace
#%top-interaction
map for-each andmap ormap
assq assv assoc reverse memq memv member
(rename old-datum #%datum)
(rename mzscheme-in-stx-module-begin #%module-begin)
(rename #%module-begin #%plain-module-begin)
(rename lambda #%plain-lambda)
(rename #%app #%plain-app)
(all-from racket/tcp)
(all-from racket/udp)))

4
racket/lib/collects/racket/private/old-ds.rkt → racket/lib/collects/mzscheme/private/old-ds.rkt
View File

@ -1,8 +1,8 @@
(module old-ds '#%kernel
(#%require "define-struct.rkt"
(#%require racket/private/define-struct
(for-syntax '#%kernel
"stxcase-scheme.rkt"))
racket/private/stxcase-scheme))
(#%provide define-struct let-struct old-datum)

0
racket/lib/collects/racket/private/old-if.rkt → racket/lib/collects/mzscheme/private/old-if.rkt
View File

34
racket/lib/collects/racket/private/old-procs.rkt → racket/lib/collects/mzscheme/private/old-procs.rkt
View File

@ -1,21 +1,47 @@
(module old-procs '#%kernel
(#%require "small-scheme.rkt"
"more-scheme.rkt"
"define.rkt"
"member.rkt")
(#%require racket/private/small-scheme
racket/private/more-scheme
racket/private/define
racket/private/member
(only racket/private/misc collection-path collection-file-path))
(#%provide make-namespace
free-identifier=?*
namespace-transformer-require
transcript-on
transcript-off
(rename new:collection-path collection-path)
(rename new:collection-file-path collection-file-path)
make-hash-table
make-immutable-hash-table
hash-table?)
(define reflect-var #f)
(define new:collection-path
(let ([collection-path (lambda (collection . collections)
(apply collection-path
(lambda (s)
(raise
(exn:fail:filesystem
(string-append "collection-path: " s)
(current-continuation-marks))))
collection collections))])
collection-path))
(define new:collection-file-path
(let ([collection-file-path (lambda (file-name collection . collections)
(apply collection-file-path
(lambda (s)
(raise
(exn:fail:filesystem
(string-append "collection-file-path: " s)
(current-continuation-marks))))
file-name collection collections))])
collection-file-path))
(define make-namespace
(case-lambda
[() (make-namespace 'initial)]

3
racket/lib/collects/racket/private/old-rp.rkt → racket/lib/collects/mzscheme/private/old-rp.rkt
View File

@ -1,6 +1,7 @@
(module old-rp '#%kernel
(#%require (for-syntax '#%kernel "stx.rkt" "small-scheme.rkt" "stxcase-scheme.rkt"))
(#%require (for-syntax '#%kernel racket/private/stx racket/private/small-scheme
racket/private/stxcase-scheme))
(#%provide require require-for-syntax require-for-template require-for-label
provide provide-for-syntax provide-for-label)

7
racket/lib/collects/racket/private/stxmz-body.rkt → racket/lib/collects/mzscheme/private/stxmz-body.rkt
View File

@ -2,8 +2,9 @@
;; mzscheme's `#%module-begin'
(module stxmz-body '#%kernel
(#%require "define.rkt"
(for-syntax '#%kernel "stx.rkt"))
;; These could probably change to just be `(require racket/base)`.
(#%require racket/private/define
(for-syntax '#%kernel racket/private/stx))
;; So that expansions print the way the Racket programmer expects:
(#%require (rename '#%kernel #%plain-module-begin #%module-begin))
@ -16,7 +17,7 @@
(list* (quote-syntax #%plain-module-begin)
(datum->syntax
stx
(list (quote-syntax #%require) '(for-syntax scheme/mzscheme)))
(list (quote-syntax #%require) '(for-syntax mzscheme)))
(stx-cdr stx))
stx)
(raise-syntax-error #f "bad syntax" stx))))

5
racket/lib/collects/openssl/openssl.rkt
View File

@ -1,4 +1,3 @@
(module openssl mzscheme
#lang racket/base
(require "mzssl.rkt")
(provide ssl-connect))
(provide ssl-connect)

2
racket/lib/collects/racket/private/increader.rkt
View File

@ -1,5 +1,5 @@
(module increader mzscheme
(module increader racket/base
(define-struct reader (val))
(provide reader? make-reader reader-val))

36
racket/lib/collects/racket/trait.rkt
View File

@ -1,18 +1,16 @@
(module trait mzscheme
(module trait racket/base
(require racket/class
racket/list
(only racket/base sort filter struct-copy))
(require-for-syntax racket/list
(only racket/base filter)
racket/list)
(require (for-syntax racket/list racket/base
syntax/stx
syntax/boundmap
syntax/kerncase
;; This should be part of a public expand-time API
;; exported by the class system:
(only "private/classidmap.rkt"
generate-class-expand-context))
(only-in "private/classidmap.rkt"
generate-class-expand-context)))
(provide (rename :trait trait)
(provide (rename-out [:trait trait])
trait?
trait->mixin
trait-sum
@ -172,7 +170,7 @@
"bad syntax"
e))]
[(id . rest)
(ormap (lambda (x) (module-identifier=? x #'id))
(ormap (lambda (x) (free-identifier=? x #'id))
(syntax->list
#'(public public-final pubment
override override-final augment augment-final augride overment
@ -216,13 +214,13 @@
[(null? l) (apply values results)]
[else
(let ([kw (stx-car (car l))])
(if (or (module-identifier=? kw #'define-values)
(module-identifier=? kw #'field))
(if (or (free-identifier=? kw #'define-values)
(free-identifier=? kw #'field))
(loop (cdr l) results)
(loop (cdr l)
(let iloop ([mapping keyword-mapping]
[results results])
(if (ormap (lambda (x) (module-identifier=? kw x))
(if (ormap (lambda (x) (free-identifier=? kw x))
(car mapping))
(cons (append (stx->list (stx-cdr (car l)))
(car results))
@ -518,23 +516,23 @@
(define (validate-trait who t)
;; Methods:
(let ([ht (make-hash-table)])
(let ([ht (make-hasheq)])
;; Build up table and check for duplicates:
(for-each (lambda (m)
(let* ([name (method-name m)]
[key (member-name-key-hash-code name)])
(let ([l (hash-table-get ht key null)])
(let ([l (hash-ref ht key null)])
(when (ormap (lambda (n) (member-name-key=? (car n) name))
l)
(raise-mismatch-error
who
"result would include multiple declarations of a method: "
name))
(hash-table-put! ht key (cons (cons name m) l)))))
(hash-set! ht key (cons (cons name m) l)))))
(trait-methods t))
;; Check consistency of expectations and provisions:
(let* ([find (lambda (name)
(let ([l (hash-table-get ht (member-name-key-hash-code name) null)])
(let ([l (hash-ref ht (member-name-key-hash-code name) null)])
(ormap (lambda (n)
(and (member-name-key=? (car n) name)
(cdr n)))
@ -567,19 +565,19 @@
(method-need-inner m)))
(trait-methods t))))
;; Fields:
(let ([ht (make-hash-table)])
(let ([ht (make-hasheq)])
;; Build up table and check for duplicates:
(for-each (lambda (f)
(let* ([name (feeld-name f)]
[key (member-name-key-hash-code name)])
(let ([l (hash-table-get ht key null)])
(let ([l (hash-ref ht key null)])
(when (ormap (lambda (n) (member-name-key=? (car n) name))
l)
(raise-mismatch-error
who
"result would include multiple declarations of a field: "
name))
(hash-table-put! ht key (cons (cons name f) l)))))
(hash-set! ht key (cons (cons name f) l)))))
(trait-fields t)))
;; Return validated trait:
t)

132
racket/lib/collects/scheme/mzscheme.rkt
View File

@ -1,132 +0,0 @@
;;----------------------------------------------------------------------
;; mzscheme: provide everything
(module mzscheme '#%kernel
(#%require racket/private/more-scheme
racket/private/misc
racket/private/letstx-scheme
racket/private/stxcase-scheme
racket/private/stx
racket/private/stxmz-body
racket/private/qqstx
racket/private/define
racket/private/old-ds
racket/private/old-rp
racket/private/old-if
racket/private/old-procs
racket/private/map ; shadows #%kernel bindings
racket/private/kernstruct
racket/private/promise
racket/private/cert
(only racket/private/cond old-cond)
;; shadows #%kernel bindings:
(only racket/private/list
assq assv assoc reverse)
racket/private/member
racket/tcp
racket/udp
'#%builtin) ; so it's attached
(define new:collection-path
(let ([collection-path (lambda (collection . collections)
(apply collection-path
(lambda (s)
(raise
(exn:fail:filesystem
(string-append "collection-path: " s)
(current-continuation-marks))))
collection collections))])
collection-path))
(define new:collection-file-path
(let ([collection-file-path (lambda (file-name collection . collections)
(apply collection-file-path
(lambda (s)
(raise
(exn:fail:filesystem
(string-append "collection-file-path: " s)
(current-continuation-marks))))
file-name collection collections))])
collection-file-path))
(#%provide require require-for-syntax require-for-template require-for-label
provide provide-for-syntax provide-for-label
(all-from-except racket/private/more-scheme case old-case
log-fatal log-error log-warning log-info log-debug
hash-update hash-update!)
(rename old-case case)
(all-from-except racket/private/misc collection-path collection-file-path)
(rename new:collection-path collection-path)
(rename new:collection-file-path collection-file-path)
(all-from-except racket/private/stxcase-scheme _ datum datum-case with-datum)
(all-from-except racket/private/letstx-scheme
-define -define-syntax -define-struct
cond old-cond else =>)
(rename old-cond cond)
define-struct let-struct
identifier? ;; from racket/private/stx
(all-from racket/private/cert)
(all-from-except racket/private/qqstx quasidatum undatum undatum-splicing)
(all-from racket/private/define)
(all-from racket/private/kernstruct)
force delay promise?
(all-from-except '#%kernel #%module-begin #%datum
if make-empty-namespace
syntax->datum datum->syntax
free-identifier=?
free-transformer-identifier=?
free-template-identifier=?
free-label-identifier=?
vector-copy!
thread-send
thread-receive
thread-try-receive
thread-receive-evt
make-hash make-immutable-hash make-weak-hash
make-hasheq make-immutable-hasheq make-weak-hasheq
hash? hash-eq? hash-weak?
hash-ref hash-set! hash-set
hash-remove! hash-remove
hash-copy hash-count
hash-map hash-for-each
hash-iterate-first hash-iterate-next
hash-iterate-value hash-iterate-key
log-message log-level? make-logger logger? current-logger logger-name
make-log-receiver log-receiver?
prop:incomplete-arity)
(rename syntax->datum syntax-object->datum)
(rename datum->syntax datum->syntax-object)
(rename free-identifier=? module-identifier=?)
(rename free-transformer-identifier=? module-transformer-identifier=?)
(rename free-template-identifier=? module-template-identifier=?)
(rename free-label-identifier=? module-label-identifier=?)
(rename free-identifier=?* free-identifier=?)
make-hash-table hash-table? make-immutable-hash-table
(rename hash-ref hash-table-get)
(rename hash-set! hash-table-put!)
(rename hash-remove! hash-table-remove!)
(rename hash-count hash-table-count)
(rename hash-copy hash-table-copy)
(rename hash-map hash-table-map)
(rename hash-for-each hash-table-for-each)
(rename hash-iterate-first hash-table-iterate-first)
(rename hash-iterate-next hash-table-iterate-next)
(rename hash-iterate-value hash-table-iterate-value)
(rename hash-iterate-key hash-table-iterate-key)
namespace-transformer-require
transcript-on transcript-off
(rename cleanse-path expand-path)
(rename if* if)
(rename list list-immutable)
make-namespace
#%top-interaction
map for-each andmap ormap
assq assv assoc reverse memq memv member
(rename old-datum #%datum)
(rename mzscheme-in-stx-module-begin #%module-begin)
(rename #%module-begin #%plain-module-begin)
(rename lambda #%plain-lambda)
(rename #%app #%plain-app)
(all-from racket/tcp)
(all-from racket/udp)))

2
racket/lib/collects/setup/main-doc.rkt
View File

@ -1,4 +1,4 @@
#lang mzscheme
#lang s-exp scheme/base
(require "dirs.rkt" "path-relativize.rkt")
(provide path->main-doc-relative

3
racket/lib/collects/setup/option-sig.rkt
View File

@ -1,5 +1,4 @@
(module option-sig mzscheme
(module option-sig scheme/base
(require racket/unit)
(provide setup-option^)

2
racket/lib/collects/setup/setup-go.rkt
View File

@ -1,4 +1,4 @@
(module setup-go mzscheme
(module setup-go scheme/base
(require "setup-cmdline.rkt"
racket/unit

5
racket/lib/collects/setup/unpack.rkt
View File

@ -7,8 +7,7 @@
racket/bool
net/base64
setup/getinfo
"dirs.rkt"
(only-in mzscheme make-namespace))
"dirs.rkt")
(provide unpack
fold-plt-archive)
@ -276,7 +275,7 @@
(eq? #\L (read-char p))
(eq? #\T (read-char p)))
(error "not an unpackable distribution archive"))
(let* ([n (make-namespace)]
(let* ([n (make-base-namespace)]
[info (let ([orig (current-namespace)])
(parameterize ([current-namespace n])
(namespace-require '(lib "mzlib/unit200.ss"))

19
racket/lib/collects/srfi/13/string.rkt
View File

@ -85,10 +85,9 @@
;;; Are you still here? Cool, keep reading it gets better:
#lang mzscheme
#lang s-exp racket/base
(require srfi/optional
(only racket/base lambda)
srfi/8/receive
srfi/14/char-set)
(provide
@ -174,7 +173,7 @@
;; Returns three values: rest start end
(define (string-parse-start+end proc s args)
(if (not (string? s)) (error proc "Non-string value ~a" s))
(when (not (string? s)) (error proc "Non-string value ~a" s))
(let ((slen (string-length s)))
(if (pair? args)
@ -433,7 +432,7 @@
(let ((j (- j i)))
(%string-copy! ans j chunk 0 i) ; Install CHUNK[0,I).
(let lp ((j j) (chunks chunks)) ; Install CHUNKS.
(if (pair? chunks)
(when (pair? chunks)
(let* ((chunk (car chunks))
(chunks (cdr chunks))
(chunk-len (string-length chunk))
@ -1393,21 +1392,21 @@
pattern args))))
(let* ((rvlen (- end start))
(rv (make-vector rvlen -1)))
(if (> rvlen 0)
(when (> rvlen 0)
(let ((rvlen-1 (- rvlen 1))
(c0 (string-ref pattern start)))
;; Here's the main loop. We have set rv[0] ... rv[i].
;; K = I + START -- it is the corresponding index into PATTERN.
(let lp1 ((i 0) (j -1) (k start))
(if (< i rvlen-1)
(when (< i rvlen-1)
;; lp2 invariant:
;; pat[(k-j) .. k-1] matches pat[start .. start+j-1]
;; or j = -1.
(let lp2 ((j j))
(cond ((= j -1)
(let ((i1 (+ 1 i)))
(if (not (c= (string-ref pattern (+ k 1)) c0))
(when (not (c= (string-ref pattern (+ k 1)) c0))
(vector-set! rv i1 0))
(lp1 i1 0 (+ k 1))))
;; pat[(k-j) .. k] matches pat[start..start+j].
@ -1569,7 +1568,7 @@
(else (let ((ans (make-string nchars)))
(let lp ((strings first) (i 0))
(if (pair? strings)
(when (pair? strings)
(let* ((s (car strings))
(slen (string-length s)))
(%string-copy! ans i s 0 slen)
@ -1588,7 +1587,7 @@
((not (pair? strings)) i)))
(ans (make-string total)))
(let lp ((i 0) (strings strings))
(if (pair? strings)
(when (pair? strings)
(let* ((s (car strings))
(slen (string-length s)))
(%string-copy! ans i s 0 slen)
@ -1649,7 +1648,7 @@
(let ((ans (make-string (+ end len))))
(%string-copy! ans len final 0 end)
(let lp ((i len) (lis string-list))
(if (pair? lis)
(when (pair? lis)
(let* ((s (car lis))
(lis (cdr lis))
(slen (string-length s))

4
racket/lib/collects/srfi/14/char-set.rkt
View File

@ -3,13 +3,13 @@
;; Since Mike Sperber looked carefully at this module,
;; the code and tests are a lot better than they would be.
(module char-set mzscheme
(module char-set racket/base
(require data/integer-set
racket/contract)
;; Data defn ----------------------------------------
(define-struct char-set (set/thunk))
(define-struct char-set (set/thunk) #:mutable)
(define (fold-set op init l)
(if (null? l)

15
racket/lib/collects/srfi/29/localization.rkt
View File

@ -1,10 +1,11 @@
(module localization mzscheme
(module localization racket/base
(require racket/contract/base
racket/file
(only racket/runtime-path define-runtime-path)
(only-in racket/runtime-path define-runtime-path)
racket/string racket/format
syntax/modread)
syntax/modread
(for-syntax racket/base))
(provide/contract (current-language (parameter/c symbol?))
(current-country (parameter/c symbol?))
@ -41,7 +42,7 @@
;; The association list in which bundles will be stored
(define *localization-bundles*
(make-hash-table 'equal))
(make-hash))
(define current-language
(make-parameter (get-from-locale 'language)))
@ -58,11 +59,11 @@
(~v bundle-specifier))))
(define (declare-bundle! bundle-specifier bundle-assoc-list)
(hash-table-put! *localization-bundles* bundle-specifier bundle-assoc-list))
(hash-set! *localization-bundles* bundle-specifier bundle-assoc-list))
(define (store-bundle! bundle-specifier)
(put-preferences (list (make-name bundle-specifier))
(list (hash-table-get *localization-bundles* bundle-specifier)))
(list (hash-ref *localization-bundles* bundle-specifier)))
#t)
(define (load-bundle-from-preference! bundle-specifier)
@ -123,7 +124,7 @@
(current-language)
(current-country))))
(and (not (null? specifier))
(let ((bundle (hash-table-get *localization-bundles* specifier #f)))
(let ((bundle (hash-ref *localization-bundles* specifier #f)))
(cond ((and bundle (assq template-name bundle)) => cdr)
((null? (cdr specifier)) #f)
(else (loop (rdc specifier))))))))

3
racket/lib/collects/syntax/boundmap.rkt
View File

@ -1,5 +1,6 @@
(module boundmap mzscheme
(module boundmap racket/base
(require racket/contract/base
(for-syntax racket/base)
"private/boundmap.rkt")
(define-syntax provide/contract*

10
racket/lib/collects/syntax/moddep.rkt
View File

@ -1,13 +1,13 @@
(module moddep mzscheme
(module moddep scheme/base
(require "modread.rkt"
"modcode.rkt"
"modcollapse.rkt"
"modresolve.rkt")
(provide (all-from "modread.rkt")
(all-from "modcode.rkt")
(all-from "modcollapse.rkt")
(all-from "modresolve.rkt")
(provide (all-from-out "modread.rkt")
(all-from-out "modcode.rkt")
(all-from-out "modcollapse.rkt")
(all-from-out "modresolve.rkt")
show-import-tree)
(define (show-import-tree module-path)

4
racket/lib/collects/syntax/modread.rkt
View File

@ -1,4 +1,4 @@
(module modread mzscheme
(module modread racket/base
(require racket/contract/base)
(provide with-module-reading-parameterization)
@ -53,7 +53,7 @@
(unless (eq? (syntax-e #'nm) expected-module)
(raise-wrong-module-name filename expected-module
(syntax-e #'nm))))
(datum->syntax-object exp
(datum->syntax exp
(cons (namespace-module-identifier)
(cdr (syntax-e exp)))
exp

2
racket/lib/collects/syntax/primitives.rkt
View File

@ -1,5 +1,5 @@
(module primitives mzscheme
(module primitives racket/base
;; The following primitives either invoke functions, or
;; install functions that can be used later.

17
racket/lib/collects/syntax/private/doctable.rkt
View File

@ -1,6 +1,5 @@
(module doctable mzscheme
(define ht (make-hash-table))
(module doctable racket/base
(define ht (make-hasheq))
(define (register-documentation src-stx label v)
(let ([mod (let ([s (syntax-source-module src-stx)])
@ -8,18 +7,18 @@
(if (module-path-index? s)
(module-path-index-resolve s)
s)))])
(let ([mht (hash-table-get ht mod
(let ([mht (hash-ref ht mod
(lambda ()
(let ([mht (make-hash-table)])
(hash-table-put! ht mod mht)
(let ([mht (make-hasheq)])
(hash-set! ht mod mht)
mht)))])
(hash-table-put! mht label v))))
(hash-set! mht label v))))
(define (lookup-documentation mod label)
(let ([mod (resolved-module-path-name mod)])
(let ([mht (hash-table-get ht mod (lambda () #f))])
(let ([mht (hash-ref ht mod (lambda () #f))])
(and mht
(hash-table-get mht label (lambda () #f))))))
(hash-ref mht label (lambda () #f))))))
(provide register-documentation
lookup-documentation))

2
racket/lib/collects/syntax/to-string.rkt
View File

@ -1,4 +1,4 @@
(module to-string mzscheme
(module to-string racket/base
(require racket/contract/base
syntax/stx)

2
racket/lib/collects/syntax/trusted-xforms.rkt
View File

@ -1,2 +1,2 @@
(module trusted-xforms mzscheme
(module trusted-xforms racket/base
(require racket/class))

2
racket/src/mac/osx_appl.rkt
View File

@ -8,7 +8,7 @@
|#
(module osx_appl mzscheme
(module osx_appl racket/base
(require (lib "plist.rkt" "xml")
racket/system

1
racket/src/racket/gc2/setup.rkt
View File

@ -84,7 +84,6 @@
;; Readers:
(map (lambda (r) (go r #f #f))
'(s-exp/lang/reader
mzscheme/lang/reader
scheme/base/lang/reader
scheme/private/provider/lang/reader
racket/base/lang/reader

5
racket/src/racket/gc2/xform-mod.rkt
View File

@ -1,6 +1,5 @@
(module xform-mod mzscheme
(require (lib "xform.rkt" "compiler" "private")
racket/cmdline)
(module xform-mod racket/base
(require compiler/private/xform racket/cmdline)
(define precompiling-header? (getenv "XFORM_PRECOMP"))
(define precompiled-header (getenv "XFORM_USE_PRECOMP"))

4
racket/src/racket/src/schvers.h
View File

@ -13,12 +13,12 @@
consistently.)
*/
#define MZSCHEME_VERSION "5.3.900.2"
#define MZSCHEME_VERSION "5.3.900.3"
#define MZSCHEME_VERSION_X 5
#define MZSCHEME_VERSION_Y 3
#define MZSCHEME_VERSION_Z 900
#define MZSCHEME_VERSION_W 2
#define MZSCHEME_VERSION_W 3
#define MZSCHEME_VERSION_MAJOR ((MZSCHEME_VERSION_X * 100) + MZSCHEME_VERSION_Y)
#define MZSCHEME_VERSION_MINOR ((MZSCHEME_VERSION_Z * 1000) + MZSCHEME_VERSION_W)