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 (require racket/file
(only racket/base lambda) (only-in racket/base lambda)
racket/path racket/path
racket/system racket/system
file/zip file/zip
@ -80,8 +80,8 @@
"-mode" "555" "-mode" "555"
"-volname" (path->string "-volname" (path->string
(path-replace-suffix (file-name-from-path target) #"")) (path-replace-suffix (file-name-from-path target) #""))
"-srcfolder" (path->string (expand-path (path->complete-path dir))) "-srcfolder" (path->string (cleanse-path (path->complete-path dir)))
(path->string (expand-path (path->complete-path target))))]) (path->string (cleanse-path (path->complete-path target))))])
((list-ref p 4) 'wait) ((list-ref p 4) 'wait)
(unless (eq? ((list-ref p 4) 'status) 'done-ok) (unless (eq? ((list-ref p 4) 'status) 'done-ok)
(error 'bundle-directory (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 racket/unit)
(require "sig.rkt") (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) (require racket/unit)
(provide compiler:embed^) (provide compiler:embed^)

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

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

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

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

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

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

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

@ -1,19 +1,19 @@
(module compile-sig mzscheme #lang racket/base
(require racket/unit) (require racket/unit)
(provide dynext:compile^) (provide dynext:compile^)
(define-signature dynext:compile^ (define-signature dynext:compile^
(compile-extension (compile-extension
preprocess-extension preprocess-extension
current-extension-compiler current-extension-compiler
current-extension-compiler-flags current-extension-compiler-flags
current-extension-preprocess-flags current-extension-preprocess-flags
current-make-compile-include-strings current-make-compile-include-strings
current-make-compile-input-strings current-make-compile-input-strings
current-make-compile-output-strings current-make-compile-output-strings
use-standard-compiler use-standard-compiler
get-standard-compilers get-standard-compilers
compile-variant 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 (require racket/unit
racket/system racket/system
"private/dirs.rkt" "private/dirs.rkt"

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

@ -1,9 +1,9 @@
(module compile mzscheme #lang racket/base
(require racket/unit) (require racket/unit)
(require "compile-sig.rkt" (require "compile-sig.rkt"
"compile-unit.rkt") "compile-unit.rkt")
(define-values/invoke-unit/infer dynext:compile@) (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") (require "compile-sig.rkt" "link-sig.rkt" "file-sig.rkt")
(provide (all-from "compile-sig.rkt") (provide (all-from-out "compile-sig.rkt")
(all-from "link-sig.rkt") (all-from-out "link-sig.rkt")
(all-from "file-sig.rkt"))) (all-from-out "file-sig.rkt")))

10
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") (require "compile-unit.rkt" "link-unit.rkt" "file-unit.rkt")
(provide (all-from "compile-unit.rkt") (provide (all-from-out "compile-unit.rkt")
(all-from "link-unit.rkt") (all-from-out "link-unit.rkt")
(all-from "file-unit.rkt"))) (all-from-out "file-unit.rkt"))

10
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") (require "compile.rkt" "link.rkt" "file.rkt")
(provide (all-from "compile.rkt") (provide (all-from-out "compile.rkt")
(all-from "link.rkt") (all-from-out "link.rkt")
(all-from "file.rkt"))) (all-from-out "file.rkt"))

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

@ -1,18 +1,17 @@
#lang racket/base
(require racket/unit)
(module file-sig mzscheme (provide dynext:file^)
(require racket/unit)
(provide dynext:file^) (define-signature dynext:file^
(append-zo-suffix
append-c-suffix
append-constant-pool-suffix
append-object-suffix
append-extension-suffix
(define-signature dynext:file^ extract-base-filename/ss
(append-zo-suffix extract-base-filename/c
append-c-suffix extract-base-filename/kp
append-constant-pool-suffix extract-base-filename/o
append-object-suffix extract-base-filename/ext))
append-extension-suffix
extract-base-filename/ss
extract-base-filename/c
extract-base-filename/kp
extract-base-filename/o
extract-base-filename/ext)))

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

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

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

@ -1,16 +1,16 @@
(module link-sig mzscheme #lang racket/base
(require racket/unit) (require racket/unit)
(provide dynext:link^) (provide dynext:link^)
(define-signature dynext:link^ (define-signature dynext:link^
(link-extension (link-extension
current-extension-linker current-extension-linker
current-extension-linker-flags current-extension-linker-flags
current-make-link-input-strings current-make-link-input-strings
current-make-link-output-strings current-make-link-output-strings
current-standard-link-libraries current-standard-link-libraries
current-use-mzdyn current-use-mzdyn
use-standard-linker use-standard-linker
link-variant 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 (require racket/unit
racket/system racket/system
"private/dirs.rkt" "private/dirs.rkt"

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

@ -1,9 +1,9 @@
(module link mzscheme #lang racket/base
(require racket/unit) (require racket/unit)
(require "link-sig.rkt" (require "link-sig.rkt"
"link-unit.rkt") "link-unit.rkt")
(define-values/invoke-unit/infer dynext:link@) (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 scheme/base
(module cmdargs mzscheme
(provide split-command-line-args) (provide split-command-line-args)

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

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

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

@ -251,7 +251,7 @@
;; (MagickAnimateImages morph) ;; (MagickAnimateImages morph)
;; (let ([x (test (MagickWriteImageBlob w))]) ;; (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)]) ;; (let ([ww (NewMagickWand)])
;; (test (MagickReadImageBlob ww x)) ;; (test (MagickReadImageBlob ww x))
;; (MagickDisplayImage ww))) ;; (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 ;; LGPL-compatible license. I (Eli Barzilay) have tried to contact the
;; author, but no reply yet. ;; author, but no reply yet.
(module deflate mzscheme (module deflate racket/base
(provide deflate gzip-through-ports gzip) (provide deflate gzip-through-ports gzip)
(require mzlib/unit200) (require mzlib/unit200 (for-syntax racket/base))
(define (vector-ref* v i) (define (vector-ref* v i)
(let ([r (vector-ref v i)]) (let ([r (vector-ref v i)])
@ -880,7 +880,7 @@
;; */ ;; */
;; /* Data structure describing a single value and its code string. */ ;; /* 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 { ;; union {
;; ush freq; ;; /* frequency count */ ;; ush freq; ;; /* frequency count */
;; ush code; ;; /* bit string */ ;; ush code; ;; /* bit string */
@ -930,7 +930,8 @@
extra_base; ;; /* base index for extra_bits */ extra_base; ;; /* base index for extra_bits */
elems; ;; /* max number of elements in the tree */ elems; ;; /* max number of elements in the tree */
max_length; ;; /* max bit length for the codes */ 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 (define l_desc (make-tree_desc
dyn_ltree static_ltree extra_lbits dyn_ltree static_ltree extra_lbits
@ -2213,7 +2214,7 @@
(dynamic-wind (dynamic-wind
void void
(lambda () (lambda ()
(let ([o (open-output-file outfile 'truncate/replace)]) (let ([o (open-output-file outfile #:exists 'truncate/replace)])
(dynamic-wind (dynamic-wind
void void
(lambda () (lambda ()

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

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

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

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

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

@ -1,3 +1,111 @@
;;----------------------------------------------------------------------
;; mzscheme: provide everything
(module main scheme/mzscheme (module mzscheme '#%kernel
(provide (all-from scheme/mzscheme))) (#%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 (module old-ds '#%kernel
(#%require "define-struct.rkt" (#%require racket/private/define-struct
(for-syntax '#%kernel (for-syntax '#%kernel
"stxcase-scheme.rkt")) racket/private/stxcase-scheme))
(#%provide define-struct let-struct old-datum) (#%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 (module old-procs '#%kernel
(#%require "small-scheme.rkt" (#%require racket/private/small-scheme
"more-scheme.rkt" racket/private/more-scheme
"define.rkt" racket/private/define
"member.rkt") racket/private/member
(only racket/private/misc collection-path collection-file-path))
(#%provide make-namespace (#%provide make-namespace
free-identifier=?* free-identifier=?*
namespace-transformer-require namespace-transformer-require
transcript-on transcript-on
transcript-off transcript-off
(rename new:collection-path collection-path)
(rename new:collection-file-path collection-file-path)
make-hash-table make-hash-table
make-immutable-hash-table make-immutable-hash-table
hash-table?) hash-table?)
(define reflect-var #f) (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 (define make-namespace
(case-lambda (case-lambda
[() (make-namespace 'initial)] [() (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 (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 require require-for-syntax require-for-template require-for-label
provide provide-for-syntax provide-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' ;; mzscheme's `#%module-begin'
(module stxmz-body '#%kernel (module stxmz-body '#%kernel
(#%require "define.rkt" ;; These could probably change to just be `(require racket/base)`.
(for-syntax '#%kernel "stx.rkt")) (#%require racket/private/define
(for-syntax '#%kernel racket/private/stx))
;; So that expansions print the way the Racket programmer expects: ;; So that expansions print the way the Racket programmer expects:
(#%require (rename '#%kernel #%plain-module-begin #%module-begin)) (#%require (rename '#%kernel #%plain-module-begin #%module-begin))
@ -16,7 +17,7 @@
(list* (quote-syntax #%plain-module-begin) (list* (quote-syntax #%plain-module-begin)
(datum->syntax (datum->syntax
stx stx
(list (quote-syntax #%require) '(for-syntax scheme/mzscheme))) (list (quote-syntax #%require) '(for-syntax mzscheme)))
(stx-cdr stx)) (stx-cdr stx))
stx) stx)
(raise-syntax-error #f "bad syntax" stx)))) (raise-syntax-error #f "bad syntax" stx))))

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

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

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

@ -1,5 +1,4 @@
(module option-sig scheme/base
(module option-sig mzscheme
(require racket/unit) (require racket/unit)
(provide setup-option^) (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" (require "setup-cmdline.rkt"
racket/unit racket/unit

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

@ -7,8 +7,7 @@
racket/bool racket/bool
net/base64 net/base64
setup/getinfo setup/getinfo
"dirs.rkt" "dirs.rkt")
(only-in mzscheme make-namespace))
(provide unpack (provide unpack
fold-plt-archive) fold-plt-archive)
@ -276,7 +275,7 @@
(eq? #\L (read-char p)) (eq? #\L (read-char p))
(eq? #\T (read-char p))) (eq? #\T (read-char p)))
(error "not an unpackable distribution archive")) (error "not an unpackable distribution archive"))
(let* ([n (make-namespace)] (let* ([n (make-base-namespace)]
[info (let ([orig (current-namespace)]) [info (let ([orig (current-namespace)])
(parameterize ([current-namespace n]) (parameterize ([current-namespace n])
(namespace-require '(lib "mzlib/unit200.ss")) (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: ;;; Are you still here? Cool, keep reading it gets better:
#lang mzscheme #lang s-exp racket/base
(require srfi/optional (require srfi/optional
(only racket/base lambda)
srfi/8/receive srfi/8/receive
srfi/14/char-set) srfi/14/char-set)
(provide (provide
@ -174,7 +173,7 @@
;; Returns three values: rest start end ;; Returns three values: rest start end
(define (string-parse-start+end proc s args) (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))) (let ((slen (string-length s)))
(if (pair? args) (if (pair? args)
@ -433,7 +432,7 @@
(let ((j (- j i))) (let ((j (- j i)))
(%string-copy! ans j chunk 0 i) ; Install CHUNK[0,I). (%string-copy! ans j chunk 0 i) ; Install CHUNK[0,I).
(let lp ((j j) (chunks chunks)) ; Install CHUNKS. (let lp ((j j) (chunks chunks)) ; Install CHUNKS.
(if (pair? chunks) (when (pair? chunks)
(let* ((chunk (car chunks)) (let* ((chunk (car chunks))
(chunks (cdr chunks)) (chunks (cdr chunks))
(chunk-len (string-length chunk)) (chunk-len (string-length chunk))
@ -1393,21 +1392,21 @@
pattern args)))) pattern args))))
(let* ((rvlen (- end start)) (let* ((rvlen (- end start))
(rv (make-vector rvlen -1))) (rv (make-vector rvlen -1)))
(if (> rvlen 0) (when (> rvlen 0)
(let ((rvlen-1 (- rvlen 1)) (let ((rvlen-1 (- rvlen 1))
(c0 (string-ref pattern start))) (c0 (string-ref pattern start)))
;; Here's the main loop. We have set rv[0] ... rv[i]. ;; Here's the main loop. We have set rv[0] ... rv[i].
;; K = I + START -- it is the corresponding index into PATTERN. ;; K = I + START -- it is the corresponding index into PATTERN.
(let lp1 ((i 0) (j -1) (k start)) (let lp1 ((i 0) (j -1) (k start))
(if (< i rvlen-1) (when (< i rvlen-1)
;; lp2 invariant: ;; lp2 invariant:
;; pat[(k-j) .. k-1] matches pat[start .. start+j-1] ;; pat[(k-j) .. k-1] matches pat[start .. start+j-1]
;; or j = -1. ;; or j = -1.
(let lp2 ((j j)) (let lp2 ((j j))
(cond ((= j -1) (cond ((= j -1)
(let ((i1 (+ 1 i))) (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)) (vector-set! rv i1 0))
(lp1 i1 0 (+ k 1)))) (lp1 i1 0 (+ k 1))))
;; pat[(k-j) .. k] matches pat[start..start+j]. ;; pat[(k-j) .. k] matches pat[start..start+j].
@ -1569,7 +1568,7 @@
(else (let ((ans (make-string nchars))) (else (let ((ans (make-string nchars)))
(let lp ((strings first) (i 0)) (let lp ((strings first) (i 0))
(if (pair? strings) (when (pair? strings)
(let* ((s (car strings)) (let* ((s (car strings))
(slen (string-length s))) (slen (string-length s)))
(%string-copy! ans i s 0 slen) (%string-copy! ans i s 0 slen)
@ -1588,7 +1587,7 @@
((not (pair? strings)) i))) ((not (pair? strings)) i)))
(ans (make-string total))) (ans (make-string total)))
(let lp ((i 0) (strings strings)) (let lp ((i 0) (strings strings))
(if (pair? strings) (when (pair? strings)
(let* ((s (car strings)) (let* ((s (car strings))
(slen (string-length s))) (slen (string-length s)))
(%string-copy! ans i s 0 slen) (%string-copy! ans i s 0 slen)
@ -1649,7 +1648,7 @@
(let ((ans (make-string (+ end len)))) (let ((ans (make-string (+ end len))))
(%string-copy! ans len final 0 end) (%string-copy! ans len final 0 end)
(let lp ((i len) (lis string-list)) (let lp ((i len) (lis string-list))
(if (pair? lis) (when (pair? lis)
(let* ((s (car lis)) (let* ((s (car lis))
(lis (cdr lis)) (lis (cdr lis))
(slen (string-length s)) (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, ;; Since Mike Sperber looked carefully at this module,
;; the code and tests are a lot better than they would be. ;; 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 (require data/integer-set
racket/contract) racket/contract)
;; Data defn ---------------------------------------- ;; Data defn ----------------------------------------
(define-struct char-set (set/thunk)) (define-struct char-set (set/thunk) #:mutable)
(define (fold-set op init l) (define (fold-set op init l)
(if (null? 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 (require racket/contract/base
racket/file racket/file
(only racket/runtime-path define-runtime-path) (only-in racket/runtime-path define-runtime-path)
racket/string racket/format racket/string racket/format
syntax/modread) syntax/modread
(for-syntax racket/base))
(provide/contract (current-language (parameter/c symbol?)) (provide/contract (current-language (parameter/c symbol?))
(current-country (parameter/c symbol?)) (current-country (parameter/c symbol?))
@ -41,7 +42,7 @@
;; The association list in which bundles will be stored ;; The association list in which bundles will be stored
(define *localization-bundles* (define *localization-bundles*
(make-hash-table 'equal)) (make-hash))
(define current-language (define current-language
(make-parameter (get-from-locale 'language))) (make-parameter (get-from-locale 'language)))
@ -58,11 +59,11 @@
(~v bundle-specifier)))) (~v bundle-specifier))))
(define (declare-bundle! bundle-specifier bundle-assoc-list) (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) (define (store-bundle! bundle-specifier)
(put-preferences (list (make-name 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) #t)
(define (load-bundle-from-preference! bundle-specifier) (define (load-bundle-from-preference! bundle-specifier)
@ -123,7 +124,7 @@
(current-language) (current-language)
(current-country)))) (current-country))))
(and (not (null? specifier)) (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) (cond ((and bundle (assq template-name bundle)) => cdr)
((null? (cdr specifier)) #f) ((null? (cdr specifier)) #f)
(else (loop (rdc specifier)))))))) (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 (require racket/contract/base
(for-syntax racket/base)
"private/boundmap.rkt") "private/boundmap.rkt")
(define-syntax provide/contract* (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" (require "modread.rkt"
"modcode.rkt" "modcode.rkt"
"modcollapse.rkt" "modcollapse.rkt"
"modresolve.rkt") "modresolve.rkt")
(provide (all-from "modread.rkt") (provide (all-from-out "modread.rkt")
(all-from "modcode.rkt") (all-from-out "modcode.rkt")
(all-from "modcollapse.rkt") (all-from-out "modcollapse.rkt")
(all-from "modresolve.rkt") (all-from-out "modresolve.rkt")
show-import-tree) show-import-tree)
(define (show-import-tree module-path) (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) (require racket/contract/base)
(provide with-module-reading-parameterization) (provide with-module-reading-parameterization)
@ -53,7 +53,7 @@
(unless (eq? (syntax-e #'nm) expected-module) (unless (eq? (syntax-e #'nm) expected-module)
(raise-wrong-module-name filename expected-module (raise-wrong-module-name filename expected-module
(syntax-e #'nm)))) (syntax-e #'nm))))
(datum->syntax-object exp (datum->syntax exp
(cons (namespace-module-identifier) (cons (namespace-module-identifier)
(cdr (syntax-e exp))) (cdr (syntax-e exp)))
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 ;; The following primitives either invoke functions, or
;; install functions that can be used later. ;; install functions that can be used later.

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

@ -1,6 +1,5 @@
(module doctable racket/base
(module doctable mzscheme (define ht (make-hasheq))
(define ht (make-hash-table))
(define (register-documentation src-stx label v) (define (register-documentation src-stx label v)
(let ([mod (let ([s (syntax-source-module src-stx)]) (let ([mod (let ([s (syntax-source-module src-stx)])
@ -8,18 +7,18 @@
(if (module-path-index? s) (if (module-path-index? s)
(module-path-index-resolve s) (module-path-index-resolve s)
s)))]) s)))])
(let ([mht (hash-table-get ht mod (let ([mht (hash-ref ht mod
(lambda () (lambda ()
(let ([mht (make-hash-table)]) (let ([mht (make-hasheq)])
(hash-table-put! ht mod mht) (hash-set! ht mod mht)
mht)))]) mht)))])
(hash-table-put! mht label v)))) (hash-set! mht label v))))
(define (lookup-documentation mod label) (define (lookup-documentation mod label)
(let ([mod (resolved-module-path-name mod)]) (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 (and mht
(hash-table-get mht label (lambda () #f)))))) (hash-ref mht label (lambda () #f))))))
(provide register-documentation (provide register-documentation
lookup-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 (require racket/contract/base
syntax/stx) 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)) (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") (require (lib "plist.rkt" "xml")
racket/system racket/system

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

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

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

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

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

@ -13,12 +13,12 @@
consistently.) consistently.)
*/ */
#define MZSCHEME_VERSION "5.3.900.2" #define MZSCHEME_VERSION "5.3.900.3"
#define MZSCHEME_VERSION_X 5 #define MZSCHEME_VERSION_X 5
#define MZSCHEME_VERSION_Y 3 #define MZSCHEME_VERSION_Y 3
#define MZSCHEME_VERSION_Z 900 #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_MAJOR ((MZSCHEME_VERSION_X * 100) + MZSCHEME_VERSION_Y)
#define MZSCHEME_VERSION_MINOR ((MZSCHEME_VERSION_Z * 1000) + MZSCHEME_VERSION_W) #define MZSCHEME_VERSION_MINOR ((MZSCHEME_VERSION_Z * 1000) + MZSCHEME_VERSION_W)