Merge branch 'master' into samth/new-logic2

This commit is contained in:
Sam Tobin-Hochstadt 2010-04-21 15:19:36 -04:00
commit c50cb0ff18
1000 changed files with 6769 additions and 7083 deletions

3
.mailmap Normal file
View File

@ -0,0 +1,3 @@
Eli Barzilay <eli@racket-lang.org> <eli@barzilay.org>
Kevin Tew <tewk@racket-lang.org> <tewk@tan.tewk.com>
Sam Tobin-Hochstadt <samth@racket-lang.org> <samth@punge.ccs.neu.edu>

View File

@ -53,6 +53,8 @@
transform the clauses into the initial arguments specification
for a new expression that instantiates the appropriate class
ensure that the initial state (state0) is not in the shape of a clause
ensure that all clauses mention only keywords specified in AllSpec or PartSpec
move the contracts from AppSpecl and PartSpec to the clauses
@ -60,12 +62,13 @@
if anything fails, use the legal keyword to specialize the error message
|#
(define (->args tag stx clauses AllSpec PartSpec ->rec? legal)
(define (->args tag stx state0 clauses AllSpec PartSpec ->rec? legal)
(define msg (format "not a legal clause in a ~a description" legal))
(define Spec (append AllSpec PartSpec))
(define kwds (map (compose (curry datum->syntax stx) car) Spec))
(define spec (clauses-use-kwd (syntax->list clauses) ->rec? msg kwds))
(duplicates? tag spec)
(not-a-clause tag stx state0 kwds)
(map (lambda (x)
(define kw (car x))
(define-values (key coercion)
@ -78,6 +81,15 @@
(list key (coercion (cdr x))))
spec))
;; Symbol Syntax Syntax [Listof Kw] -> true
;; effect: if state0 looks like a clause, raise special error
(define (not-a-clause tag stx state0 kwds)
(syntax-case state0 ()
[(kw . E)
((->kwds-in kwds) #'kw)
(raise-syntax-error tag "missing initial state" stx)]
[_ #t]))
;; Symbol [Listof kw] -> true
;; effect: raise syntax error about duplicated clause
(define (duplicates? tag lox)

View File

@ -37,4 +37,23 @@
(raise e)))))
(eval '(module a scheme
(require 2htdp/universe)
(big-bang 0 (on-tick add1) stop-when))))
(big-bang 0 (on-tick add1) stop-when))))
;; -----------------------------------------------------------------------------
;; purpose: catch illegal big-bang use w/o world expression
(with-handlers ((exn:fail:syntax?
(lambda (x)
(unless (string=? (exn-message x) "big-bang: missing initial state")
(raise x)))))
(eval '(module a scheme
(require 2htdp/universe)
(big-bang (on-key add1)))))
(with-handlers ((exn:fail:syntax?
(lambda (x)
(unless (string=? (exn-message x) "universe: missing initial state")
(raise x)))))
(eval '(module a scheme
(require 2htdp/universe)
(universe (on-msg sub1) (on-new add1)))))

View File

@ -179,7 +179,7 @@
[(V) (set! rec? #'V)]
[_ (err '#'record? stx)])))]
[args
(->args 'big-bang stx (syntax (clause ...)) AllSpec WldSpec ->rec? "world")])
(->args 'big-bang stx (syntax w) (syntax (clause ...)) AllSpec WldSpec ->rec? "world")])
#`(let* ([esp (make-eventspace)]
[thd (eventspace-handler-thread esp)])
(with-handlers ((exn:break? (lambda (x) (break-thread thd))))
@ -276,7 +276,7 @@
[(universe u) (raise-syntax-error #f "not a legal universe description" stx)]
[(universe u bind ...)
(let*
([args (->args 'universe stx (syntax (bind ...)) AllSpec UniSpec void "universe")]
([args (->args 'universe stx (syntax u) (syntax (bind ...)) AllSpec UniSpec void "universe")]
[domain (map (compose syntax-e car) args)])
(cond
[(not (memq 'on-new domain))

View File

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

View File

@ -1,4 +1,4 @@
#lang scheme/base
#lang racket/base
(provide add-plt-segment
get/set-dylib-path)

View File

@ -1,4 +1,4 @@
#lang scheme/base
#lang racket/base
(provide bytes->utf-16-bytes
utf-16-bytes->bytes)

View File

@ -1,4 +1,4 @@
#lang scheme/base
#lang racket/base
(require "config.ss")
(provide (all-from-out "config.ss"))

View File

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

View File

@ -2,7 +2,7 @@
(require syntax/moddep
mzlib/class
scheme/private/namespace
racket/private/namespace
mred)
(provide eval/annotations

View File

@ -2,6 +2,52 @@
;; 4. integrate with snips
#|
From: Mark Engelberg <mark.engelberg@gmail.com>
In a flash of inspiration, I searched on matrix, and turned up the
matrix teachpack.  I really like it!  I especially like:
* the ease of converting back and forth between "rectangles" and "matrices"
* the multiple ways of constructing matrices
* the ability to set cells non-destructively or destructively
Two questions:
1. The documentation warns that the teachpack is experimental.  Are
there any major problems I need to be aware of, or is the warning just
an indicator that the API is likely to continue to be revised?
2. Are there other similar built-in PLT Scheme libraries that I should
be aware of, or is this the main one I should be considering?
A few API comments and suggestions:
matrix-render is a nice low-level function for extracting information
from the matrix in preparation for displaying or printing, but perhaps
there could also be a higher-level matrix->string function.
For example,
(define (matrix->string m col-separator row-separator)
 (string-join (map (λ (row) (string-join row col-separator))
(matrix-render m)) row-separator))
Since matrix-ref returns an error with a bogus row,column, it would be
nice to be able to easily test for that in advance:
(define (matrix-within-bounds? m i j)
 (and (<= 0 i) (< i (matrix-rows m)) (<= 0 j) (< j (matrix-cols m))))
or alternatively adjust matrix-ref to take an optional argument to
return if the entry is invalid (like hash-ref).
Since matrix-where? returns a list of posn structures, it would be
ideal if the other matrix functions (e.g., matrix-ref, matrix-set)
could optionally consume a single posn rather than a separate i and j.
Speaking of which, shouldn't the matrix teachpack automatically
provide lang/posn so that you can call posn-x and posn-y on the
position structures returned by matrix-where?
|#
(require htdp/matrix-sig
htdp/matrix-render-sig
htdp/matrix-unit

View File

@ -297,6 +297,9 @@
" if so, it produces the suffix of the list that starts with x"
" if not, it produces false."
" (it compares values with the eqv? predicate.)")
((beginner-member member?) (any (listof any) -> boolean)
"to determine whether some value is on the list"
" (comparing values with equal?)")
((beginner-member member) (any (listof any) -> boolean)
"to determine whether some value is on the list"
" (comparing values with equal?)")

View File

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

View File

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

View File

@ -197,9 +197,7 @@
(lambda ()
(define l (pth-cmd))
(with-env (["DISPLAY" (format ":~a" (+ XSERVER-OFFSET (current-worker)))]
["HOME" (home-dir (current-worker))])
; XXX Maybe this should destroy the old home and copy in a new one
; Otherwise it is a source of randomness
["HOME" (make-fresh-home-dir)])
(with-temporary-directory
(run/collect/wait/log log-pth
#:timeout pth-timeout
@ -234,14 +232,6 @@
(build-path log-dir "src" "build" "set-browser.ss")
mzscheme-path
(list "-t" (path->string* (build-path (drdr-directory) "set-browser.ss"))))
; Make home directories
(cache/file/timestamp
(build-path rev-dir "homedir-dup")
(lambda ()
(notify! "Copying home directory for each worker")
(for ([i (in-range (number-of-cpus))])
(with-handlers ([exn:fail? void])
(copy-directory/files (hash-ref (current-env) "HOME") (home-dir i))))))
; And go
(notify! "Starting testing")
(test-directory collects-pth top-sema)
@ -250,10 +240,11 @@
(notify! "Stopping testing")
(stop-job-queue! test-workers))
(define (home-dir i)
(format "~a~a"
(hash-ref (current-env) "HOME")
i))
(define (make-fresh-home-dir)
(define new-dir (make-temporary-file "home~a" 'directory))
(with-handlers ([exn:fail? void])
(copy-directory/files (hash-ref (current-env) "HOME") new-dir))
(path->string new-dir))
(define (recur-many i r f)
(if (zero? i)

View File

@ -557,7 +557,8 @@
(define name (path->string rev-pth))
(define url (format "~a/" name))
(define rev (string->number name))
(define log (read-cache (revision-commit-msg rev)))
(define log-pth (revision-commit-msg rev))
(define log (read-cache log-pth))
(define committer (svn-rev-log-author log))
(define commit-msg (string-first-line (svn-rev-log-msg log)))
(define title
@ -566,7 +567,7 @@
commit-msg))
(define (no-rendering-row)
(define mtime
(file-or-directory-modify-seconds (build-path builds-pth rev-pth)))
(file-or-directory-modify-seconds log-pth))
`(tr ([class "dir"]
[title ,title])

View File

@ -1,30 +1,31 @@
#lang scheme
(require "dirstruct.ss"
"status.ss")
(require "status.ss")
(define (rewrite-status s)
(if (current-rev)
(local [(define from (number->string (current-rev)))]
(match s
[(struct exit (start end command-line output-log code))
(make-exit start end (rewrite-strings from command-line) (rewrite-events from output-log) code)]
[(struct timeout (start end command-line output-log))
(make-timeout start end (rewrite-strings from command-line) (rewrite-events from output-log))]))
s))
(define (rewrite-status #:rewrite rewrite-string s)
(match s
[(struct exit (start end command-line output-log code))
(make-exit start end
(rewrite-strings #:rewrite rewrite-string command-line)
(rewrite-events #:rewrite rewrite-string output-log)
code)]
[(struct timeout (start end command-line output-log))
(make-timeout start end
(rewrite-strings #:rewrite rewrite-string command-line)
(rewrite-events #:rewrite rewrite-string output-log))]))
(define (rewrite-strings from los)
(map (curry rewrite-string from) los))
(define (rewrite-events from loe)
(map (rewrite-event from) loe))
(define (rewrite-event from)
(define (rewrite-strings #:rewrite rewrite-string los)
(map rewrite-string los))
(define (rewrite-events #:rewrite rewrite-string loe)
(map (rewrite-event #:rewrite rewrite-string) loe))
(define (rewrite-event #:rewrite rewrite-bytes)
(match-lambda
[(struct stdout (b)) (make-stdout (rewrite-bytes from b))]
[(struct stderr (b)) (make-stderr (rewrite-bytes from b))]))
[(struct stdout (b)) (make-stdout (rewrite-bytes b))]
[(struct stderr (b)) (make-stderr (rewrite-bytes b))]))
(define (rewrite-string from s)
(regexp-replace* from s "<current-rev>"))
(define rewrite-bytes rewrite-string)
(define rewrite-string/c
((or/c string? bytes?) . -> . (or/c string? bytes?)))
(provide/contract
[rewrite-status (status? . -> . status?)])
[rewrite-string/c contract?]
[rewrite-status (#:rewrite rewrite-string/c status? . -> . status?)])

View File

@ -2,6 +2,7 @@
(require "status.ss"
"notify.ss"
"rewriting.ss"
"dirstruct.ss"
"cache.ss")
(define (command+args+env->command+args
@ -97,6 +98,17 @@
final-status))
(define-syntax regexp-replace**
(syntax-rules ()
[(_ () s) s]
[(_ ([pat0 subst0]
[pat subst]
...)
s)
(regexp-replace* pat0
(regexp-replace** ([pat subst] ...) s)
subst0)]))
(define (run/collect/wait/log log-path command
#:timeout timeout
#:env env
@ -105,8 +117,20 @@
(cache/file
log-path
(lambda ()
(define rev (number->string (current-rev)))
(define home (hash-ref env "HOME"))
(define tmp (hash-ref env "TMPDIR"))
(define cwd (path->string (current-directory)))
(define (rewrite s)
(regexp-replace** ([rev "<current-rev>"]
[home "<home>"]
[tmp "<tmp>"]
[cwd "<cwd>"])
s))
(set! ran? #t)
(rewrite-status
#:rewrite rewrite
(run/collect/wait
#:timeout timeout
#:env env

View File

@ -2,7 +2,7 @@
;; All of the implementation is actually in private/class-internal.ss,
;; which provides extra (private) functionality to contract.ss.
(require scheme/private/class-internal)
(require racket/private/class-internal)
(provide (rename class-traced class)
(rename class*-traced class*)

View File

@ -1,3 +1,3 @@
(module class mzscheme
(require scheme/private/class-internal)
(require racket/private/class-internal)
(provide-public-names))

View File

@ -1,4 +1,4 @@
#lang scheme/base
#lang racket/base
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;
@ -25,37 +25,37 @@
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;
;; provide everything from the scheme/ implementation
;; provide everything from the racket/ implementation
;; except the arrow contracts
;;
(require scheme/contract/private/base
scheme/contract/private/misc
scheme/contract/private/provide
scheme/contract/private/guts
scheme/contract/private/ds
scheme/contract/private/opt
scheme/contract/private/basic-opters)
(require racket/contract/private/base
racket/contract/private/misc
racket/contract/private/provide
racket/contract/private/guts
racket/contract/private/ds
racket/contract/private/opt
racket/contract/private/basic-opters)
(provide
opt/c define-opt/c ;(all-from "private/contract-opt.ss")
(except-out (all-from-out scheme/contract/private/ds)
(except-out (all-from-out racket/contract/private/ds)
lazy-depth-to-look)
(all-from-out scheme/contract/private/base)
(all-from-out scheme/contract/private/provide)
(except-out (all-from-out scheme/contract/private/misc)
(all-from-out racket/contract/private/base)
(all-from-out racket/contract/private/provide)
(except-out (all-from-out racket/contract/private/misc)
check-between/c
string-len/c
check-unary-between/c)
(rename-out [or/c union])
(rename-out [string-len/c string/len])
(except-out (all-from-out scheme/contract/private/guts)
(except-out (all-from-out racket/contract/private/guts)
check-flat-contract
check-flat-named-contract))
;; copied here because not provided by scheme/contract anymore
;; copied here because not provided by racket/contract anymore
(define (flat-contract/predicate? pred)
(or (flat-contract? pred)
(and (procedure? pred)

View File

@ -1,8 +1,8 @@
#lang mzscheme
(require setup/main-collects
scheme/local
scheme/bool
racket/local
racket/bool
(only scheme/base
build-string
build-list

View File

@ -1,31 +1,13 @@
#lang mzscheme
#lang scheme/base
;; The `first', etc. operations in this library
;; work on pairs, not lists.
(require (only scheme/base
foldl
foldr
remv
remq
remove
remv*
remq*
remove*
findf
memf
assf
filter
sort)
(only scheme/list
cons?
empty?
empty
last-pair))
(require (only-in scheme/list
cons?
empty?
empty
last-pair))
(provide first
second

View File

@ -1,4 +1,4 @@
#lang scheme/base
#lang racket/base
(require scheme/match/legacy-match)
(provide (all-from-out scheme/match/legacy-match))
(require racket/match/legacy-match)
(provide (all-from-out racket/match/legacy-match))

View File

@ -1,4 +1,4 @@
#lang scheme/base
(require scheme/match/match)
(provide (all-from-out scheme/match/match))
(require racket/match/match)
(provide (all-from-out racket/match/match))

View File

@ -1,8 +1,7 @@
#lang scheme/base
#lang racket/base
(require (for-syntax scheme/base)
mzlib/etc
scheme/contract/base
(require (for-syntax racket/base)
racket/contract/base
mzlib/list
"private/port.ss")
@ -118,13 +117,13 @@
;; 0 always (which implies that the `read' proc must not return
;; a pipe input port).
(define make-input-port/read-to-peek
(opt-lambda (name read fast-peek close
[location-proc #f]
[count-lines!-proc void]
[init-position 1]
[buffer-mode-proc #f]
[buffering? #f]
[on-consumed #f])
(lambda (name read fast-peek close
[location-proc #f]
[count-lines!-proc void]
[init-position 1]
[buffer-mode-proc #f]
[buffering? #f]
[on-consumed #f])
(define lock-semaphore (make-semaphore 1))
(define commit-semaphore (make-semaphore 1))
(define-values (peeked-r peeked-w) (make-pipe))
@ -440,7 +439,7 @@
(buffer-mode-proc mode)])))))
(define peeking-input-port
(opt-lambda (orig-in [name (object-name orig-in)] [delta 0])
(lambda (orig-in [name (object-name orig-in)] [delta 0])
(make-input-port/read-to-peek
name
(lambda (s)
@ -452,11 +451,11 @@
void)))
(define relocate-input-port
(opt-lambda (p line col pos [close? #t])
(lambda (p line col pos [close? #t])
(transplant-to-relocate transplant-input-port p line col pos close?)))
(define transplant-input-port
(opt-lambda (p location-proc pos [close? #t] [count-lines!-proc void])
(lambda (p location-proc pos [close? #t] [count-lines!-proc void])
(make-input-port
(object-name p)
(lambda (s)
@ -486,7 +485,7 @@
;; thread when write evts are active; otherwise, we use a lock semaphore.
;; (Actually, the lock semaphore has to be used all the time, to guard
;; the flag indicating whether the manager thread is running.)
(opt-lambda ([limit (expt 2 64)] [in-name 'pipe] [out-name 'pipe])
(lambda ([limit (expt 2 64)] [in-name 'pipe] [out-name 'pipe])
(let-values ([(r w) (make-pipe limit)]
[(more) null]
[(more-last) #f]
@ -724,7 +723,7 @@
(values in out))))
(define input-port-append
(opt-lambda (close-orig? . ports)
(lambda (close-orig? . ports)
(make-input-port
(map object-name ports)
(lambda (str)
@ -815,7 +814,7 @@
(loop half skip)))))))
(define make-limited-input-port
(opt-lambda (port limit [close-orig? #t])
(lambda (port limit [close-orig? #t])
(let ([got 0])
(make-input-port
(object-name port)
@ -1208,13 +1207,13 @@
(loop (add1 i) (add1 j))]))))]))
(define reencode-input-port
(opt-lambda (port encoding [error-bytes #f] [close? #f]
[name (object-name port)]
[newline-convert? #f]
[decode-error (lambda (msg port)
(error 'reencode-input-port
(format "~a: ~e" msg)
port))])
(lambda (port encoding [error-bytes #f] [close? #f]
[name (object-name port)]
[newline-convert? #f]
[decode-error (lambda (msg port)
(error 'reencode-input-port
(format "~a: ~e" msg)
port))])
(let ([c (let ([c (bytes-open-converter encoding "UTF-8")])
(if newline-convert? (mcons c #f) c))]
[ready-bytes (make-bytes 1024)]
@ -1345,13 +1344,13 @@
;; --------------------------------------------------
(define reencode-output-port
(opt-lambda (port encoding [error-bytes #f] [close? #f]
[name (object-name port)]
[convert-newlines-to #f]
[decode-error (lambda (msg port)
(error 'reencode-input-port
(format "~a: ~e" msg)
port))])
(lambda (port encoding [error-bytes #f] [close? #f]
[name (object-name port)]
[convert-newlines-to #f]
[decode-error (lambda (msg port)
(error 'reencode-input-port
(format "~a: ~e" msg)
port))])
(let ([c (bytes-open-converter "UTF-8" encoding)]
[ready-bytes (make-bytes 1024)]
[ready-start 0]
@ -1664,7 +1663,7 @@
;; ----------------------------------------
(define dup-output-port
(opt-lambda (p [close? #f])
(lambda (p [close? #f])
(let ([new (transplant-output-port
p
(lambda () (port-next-location p))
@ -1677,7 +1676,7 @@
new)))
(define dup-input-port
(opt-lambda (p [close? #f])
(lambda (p [close? #f])
(let ([new (transplant-input-port
p
(lambda () (port-next-location p))

View File

@ -1,7 +1,7 @@
#lang scheme/base
#lang racket/base
(provide (all-defined-out))
(require scheme/contract/private/guts)
(require racket/contract/private/guts)
(define empty-case-lambda/c
(flat-named-contract '(case->)

View File

@ -4,7 +4,7 @@
(require (for-syntax scheme/base))
(require (for-template scheme/base)
(for-template scheme/contract/private/guts)
(for-template racket/contract/private/guts)
(for-template "contract-arr-checks.ss"))
(provide make-/proc ->/h ->*/h ->d/h ->d*/h ->r/h

View File

@ -1,11 +1,11 @@
#lang scheme/base
#lang racket/base
(require scheme/contract/private/guts
scheme/contract/private/opt
(require racket/contract/private/guts
racket/contract/private/opt
"contract-arr-checks.ss")
(require (for-syntax scheme/base)
(for-syntax scheme/contract/private/opt-guts)
(for-syntax scheme/contract/private/helpers)
(require (for-syntax racket/base)
(for-syntax racket/contract/private/opt-guts)
(for-syntax racket/contract/private/helpers)
(for-syntax "contract-arr-obj-helpers.ss")
(for-syntax syntax/stx)
(for-syntax syntax/name))

View File

@ -1,11 +1,11 @@
#lang scheme/base
#lang racket/base
(provide define/contract)
(require (for-syntax scheme/base
(require (for-syntax racket/base
unstable/srcloc
(prefix-in a: scheme/contract/private/helpers))
(only-in scheme/contract/private/base contract))
(prefix-in a: racket/contract/private/helpers))
(only-in racket/contract/private/base contract))
;; First, we have the old define/contract implementation, which
;; is still used in mzlib/contract.

View File

@ -1,11 +1,11 @@
#lang scheme/base
#lang racket/base
(require "contract-arrow.ss"
scheme/contract/private/guts
scheme/private/class-internal
racket/contract/private/guts
racket/private/class-internal
"contract-arr-checks.ss")
(require (for-syntax scheme/base
scheme/contract/private/helpers
(require (for-syntax racket/base
racket/contract/private/helpers
"contract-arr-obj-helpers.ss"))
(provide mixin-contract

View File

@ -3,15 +3,14 @@
;; used by contract.ss, which is used by port.ss --- so we
;; break the cycle with this module.
(module port mzscheme
(require "../etc.ss")
(module port racket/base
(provide open-output-nowhere
relocate-output-port
transplant-output-port
transplant-to-relocate)
(define open-output-nowhere
(opt-lambda ([name 'nowhere] [specials-ok? #t])
(lambda ([name 'nowhere] [specials-ok? #t])
(make-output-port
name
always-evt
@ -42,13 +41,13 @@
close?)))
(define relocate-output-port
(opt-lambda (p line col pos [close? #t])
(lambda (p line col pos [close? #t])
(transplant-to-relocate
transplant-output-port
p line col pos close?)))
(define transplant-output-port
(opt-lambda (p location-proc pos [close? #t] [count-lines!-proc void])
(lambda (p location-proc pos [close? #t] [count-lines!-proc void])
(make-output-port
(object-name p)
p

View File

@ -7,7 +7,7 @@
(require (for-template scheme/base
"unit-keywords.ss"
"unit-runtime.ss"))
(require scheme/private/define-struct)
(require racket/private/define-struct)
(provide (struct-out var-info)
(struct-out signature)

View File

@ -1,14 +1,14 @@
#lang scheme/base
#lang racket/base
(require (for-syntax scheme/base
(require (for-syntax racket/base
syntax/boundmap
syntax/name
syntax/parse
"unit-compiletime.ss"
"unit-contract-syntax.ss"
"unit-syntax.ss")
(for-meta 2 scheme/base)
scheme/contract/base
(for-meta 2 racket/base)
racket/contract/base
"unit-utils.ss"
"unit-runtime.ss")

View File

@ -4,7 +4,7 @@
syntax/boundmap
"unit-compiletime.ss"
"unit-syntax.ss")
scheme/contract/base)
racket/contract/base)
(provide (for-syntax build-key
check-duplicate-sigs

View File

@ -4,13 +4,13 @@
mzlib/etc
mzlib/list
;; core [de]serializer:
scheme/private/serialize)
racket/private/serialize)
(provide define-serializable-struct
define-serializable-struct/versions
;; core [de]serializer:
(all-from scheme/private/serialize))
(all-from racket/private/serialize))
;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;; define-serializable-struct

View File

@ -16,7 +16,7 @@
"private/unit-syntax.ss"))
(require mzlib/etc
scheme/contract/base
racket/contract/base
scheme/stxparam
unstable/location
"private/unit-contract.ss"

View File

@ -1,4 +1,4 @@
(module config mzscheme
(module config racket/base
(require "private/define-config.ss")
(define-parameters
(PLANET-SERVER-NAME "planet.plt-scheme.org")

View File

@ -1,4 +1,5 @@
(module define-config mzscheme
(module define-config racket/base
(require (for-syntax racket/base))
(provide define-parameters)

View File

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

4
collects/racket/base.rkt Normal file
View File

@ -0,0 +1,4 @@
#lang racket/private
(require "private/base.rkt")
(provide (all-from-out "private/base.rkt"))

View File

@ -1,5 +0,0 @@
#lang racket/private
(require "private/struct.rkt")
(provide (all-from-out scheme/base)
struct)

11
collects/racket/class.rkt Normal file
View File

@ -0,0 +1,11 @@
#lang racket/base
(require "contract/private/object.rkt")
(provide (all-from-out "contract/private/object.rkt"))
;; All of the implementation is actually in private/class-internal.rkt,
;; which provides extra (private) functionality to contract.rkt.
(require "private/class-internal.rkt")
(provide-public-names)
(provide generic?)

View File

@ -9,14 +9,15 @@ differences from v3:
|#
(require scheme/contract/exists
scheme/contract/regions
"contract/private/basic-opters.ss"
"contract/base.ss")
(require racket/contract/exists
racket/contract/regions
"contract/private/basic-opters.rkt"
"contract/base.rkt"
"private/define-struct.rkt")
(provide (all-from-out "contract/base.ss")
(except-out (all-from-out scheme/contract/exists) ∃?)
(all-from-out scheme/contract/regions))
(provide (all-from-out "contract/base.rkt")
(except-out (all-from-out racket/contract/exists) ∃?)
(all-from-out racket/contract/regions))
;; ======================================================================
;; The alternate implementation disables contracts. Its useful mainly to

View File

@ -1,4 +1,4 @@
#lang scheme/base
#lang racket/base
;; A stripped down version of scheme/contract for use in
;; the PLT code base where appropriate.

View File

@ -1,4 +1,4 @@
#lang scheme/base
#lang racket/base
(require "private/guts.ss")

View File

@ -1,4 +1,4 @@
#lang scheme/base
#lang racket/base
#|
@ -20,8 +20,8 @@ v4 todo:
(require "guts.ss"
"opt.ss"
scheme/stxparam)
(require (for-syntax scheme/base)
racket/stxparam)
(require (for-syntax racket/base)
(for-syntax "opt-guts.ss")
(for-syntax "helpers.ss")
(for-syntax syntax/stx)

View File

@ -1,4 +1,4 @@
#lang scheme/base
#lang racket/base
#|
@ -13,8 +13,8 @@ improve method arity mismatch contract violation error messages?
recursive-contract
current-contract-region)
(require (for-syntax scheme/base)
scheme/stxparam
(require (for-syntax racket/base)
racket/stxparam
unstable/srcloc
unstable/location
"guts.ss"

View File

@ -1,9 +1,9 @@
#lang scheme/base
#lang racket/base
(require "guts.ss"
"opt.ss"
"base.ss")
(require (for-syntax scheme/base
(require (for-syntax racket/base
"opt-guts.ss"))
;;

View File

@ -1,6 +1,6 @@
#lang scheme/base
#lang racket/base
(require unstable/srcloc scheme/pretty)
(require unstable/srcloc racket/pretty)
(provide blame?
make-blame

View File

@ -1,4 +1,4 @@
#lang scheme/base
#lang racket/base
(provide ensure-well-formed
build-func-params
build-clauses
@ -6,8 +6,7 @@
generate-arglists)
(require "opt-guts.ss")
(require (for-template scheme/base)
(for-syntax scheme/base))
(require (for-template racket/base))
#|

View File

@ -1,4 +1,4 @@
#lang scheme/base
#lang racket/base
#|
@ -18,13 +18,11 @@ it around flattened out.
|#
(require "guts.ss"
"opt.ss"
mzlib/etc)
"opt.ss")
(require (for-syntax scheme/base)
(for-syntax "ds-helpers.ss")
(for-syntax "helpers.ss")
(for-syntax "opt-guts.ss")
(for-syntax mzlib/etc))
(for-syntax "opt-guts.ss"))
(provide define-contract-struct

View File

@ -1,11 +1,11 @@
#lang scheme/base
#lang racket/base
(require "helpers.ss"
"blame.ss"
"prop.ss"
scheme/pretty)
racket/pretty)
(require (for-syntax scheme/base
(require (for-syntax racket/base
"helpers.ss"))
(provide (except-out (all-from-out "blame.ss") make-blame)

View File

@ -1,4 +1,4 @@
#lang scheme/base
#lang racket/base
(provide mangle-id mangle-id-for-maker
build-struct-names
@ -9,8 +9,8 @@
known-good-contract?)
(require setup/main-collects
scheme/struct-info
(for-template scheme/base))
racket/struct-info
(for-template racket/base))
;; lookup-struct-info : syntax -> (union #f (list syntax syntax (listof syntax) ...))
(define (lookup-struct-info stx provide-stx)

View File

@ -1,4 +1,4 @@
#lang scheme/base
#lang racket/base
(require "guts.ss" "blame.ss" unstable/srcloc)

View File

@ -1,10 +1,10 @@
#lang scheme/base
#lang racket/base
(require (for-syntax scheme/base
scheme/struct-info
(require (for-syntax racket/base
racket/struct-info
"helpers.ss"
"opt-guts.ss")
scheme/promise
racket/promise
"opt.ss"
"guts.ss")

View File

@ -1,7 +1,7 @@
#lang scheme/base
(require "arrow.ss"
"guts.ss"
scheme/private/class-internal
racket/private/class-internal
scheme/stxparam)
(require (for-syntax scheme/base))

View File

@ -1,8 +1,8 @@
#lang scheme/base
#lang racket/base
(require syntax/private/boundmap ;; needs to be the private one, since the public one has contracts
(for-template scheme/base)
(for-template racket/base)
(for-template "guts.ss")
(for-syntax scheme/base))
(for-syntax racket/base))
(provide get-opter reg-opter! opter
interleave-lifts

View File

@ -1,13 +1,12 @@
#lang scheme/base
#lang racket/base
(require "guts.ss"
scheme/stxparam
mzlib/etc)
(require (for-syntax scheme/base)
racket/stxparam)
(require (for-syntax racket/base)
(for-syntax "opt-guts.ss")
(for-syntax mzlib/etc)
(for-syntax scheme/stxparam))
(for-syntax racket/stxparam))
(provide opt/c define-opt/c define/opter opt-stronger-vars-ref)
(provide opt/c define-opt/c define/opter opt-stronger-vars-ref
begin-lifted)
;; define/opter : id -> syntax
;;
@ -151,6 +150,11 @@
(vector)
(begin-lifted (box #f)))))))]))
(define-syntax (begin-lifted stx)
(syntax-case stx ()
[(_ expr)
(syntax-local-lift-expression #'expr)]))
(define-syntax-parameter define/opt-recursive-fn #f)
(define-syntax (define-opt/c stx)

View File

@ -1,4 +1,4 @@
#lang scheme/base
#lang racket/base
(require "blame.ss")

View File

@ -1,14 +1,14 @@
#lang scheme/base
#lang racket/base
(provide provide/contract
(for-syntax make-provide/contract-transformer))
(require (for-syntax scheme/base
scheme/list
(require (for-syntax racket/base
racket/list
(prefix-in a: "helpers.ss"))
"arrow.ss"
"base.ss"
scheme/contract/exists
racket/contract/exists
"guts.ss"
unstable/location
unstable/srcloc)

View File

@ -1,19 +1,19 @@
#lang scheme/base
#lang racket/base
(provide define-struct/contract
define/contract
with-contract)
(require (for-syntax scheme/base
scheme/list
scheme/struct-info
(require (for-syntax racket/base
racket/list
racket/struct-info
syntax/define
syntax/kerncase
syntax/parse
unstable/syntax
(prefix-in a: "private/helpers.ss"))
scheme/splicing
scheme/stxparam
racket/splicing
racket/stxparam
unstable/location
"private/arrow.ss"
"private/base.ss"

View File

@ -1,4 +1,4 @@
(module control scheme/base
(module control racket/base
(require mzlib/control)
(provide (all-from-out mzlib/control)))

View File

@ -1,6 +1,6 @@
#lang scheme/base
#lang racket/base
(require (for-syntax scheme/base))
(require (for-syntax racket/base))
(provide prop:dict
dict?
@ -268,7 +268,7 @@
[else
(raise-type-error 'dict-count "dict" d)]))
(define-struct assoc-iter (head pos))
(struct assoc-iter (head pos))
(define (dict-iterate-first d)
(cond
@ -276,7 +276,7 @@
[(vector? d) (if (zero? (vector-length d))
#f
0)]
[(assoc? d) (if (null? d) #f (make-assoc-iter d d))]
[(assoc? d) (if (null? d) #f (assoc-iter d d))]
[(dict-struct? d) ((get-dict-iterate-first (dict-struct-ref d)) d)]
[else
(raise-type-error 'dict-iterate-first "dict" d)]))
@ -302,7 +302,7 @@
(let ([pos (cdr (assoc-iter-pos i))])
(if (null? pos)
#f
(make-assoc-iter d pos)))]
(assoc-iter d pos)))]
[(dict-struct? d) ((get-dict-iterate-next (dict-struct-ref d)) d i)]
[(assoc? d)
(raise-mismatch-error
@ -409,7 +409,7 @@
;; ----------------------------------------
(define-struct hash-box (key))
(struct hash-box (key))
(define custom-hash-ref
(case-lambda
@ -433,8 +433,8 @@
(let ([table (hash-set (custom-hash-table d)
((custom-hash-make-box d) k)
v)])
(make-immutable-custom-hash table
(custom-hash-make-box d))))
(immutable-custom-hash table
(custom-hash-make-box d))))
(define (custom-hash-remove! d k)
(hash-remove! (custom-hash-table d)
@ -443,8 +443,8 @@
(define (custom-hash-remove d k)
(let ([table (hash-remove (custom-hash-table d)
((custom-hash-make-box d) k))])
(make-immutable-custom-hash table
(custom-hash-make-box d))))
(immutable-custom-hash table
(custom-hash-make-box d))))
(define (custom-hash-count d)
(hash-count (custom-hash-table d)))
@ -461,7 +461,7 @@
(define (custom-hash-iterate-value d i)
(hash-iterate-value (custom-hash-table d) i))
(define-struct custom-hash (table make-box)
(struct custom-hash (table make-box)
#:property prop:dict
(vector custom-hash-ref
custom-hash-set!
@ -482,7 +482,7 @@
(lambda (a recur) (recur (custom-hash-table a)))
(lambda (a recur) (recur (custom-hash-table a)))))
(define-struct (immutable-custom-hash custom-hash) ()
(struct immutable-custom-hash custom-hash ()
#:property prop:dict
(vector custom-hash-ref
#f
@ -510,7 +510,7 @@
(procedure-arity-includes? hash2 1))
(raise-type-error who "procedure (arity 1)" hash2))
(let ()
(define-struct (box hash-box) ()
(struct box hash-box ()
#:property prop:equal+hash (list
(lambda (a b recur)
(=? (hash-box-key a) (hash-box-key b)))
@ -518,16 +518,16 @@
(hash (hash-box-key v)))
(lambda (v recur)
(hash2 (hash-box-key v)))))
(make-custom-hash table (wrap-make-box make-box))))])
(make-custom-hash table (wrap-make-box box))))])
(let ([make-custom-hash
(lambda (=? hash [hash2 (lambda (v) 10001)])
(mk hash hash2 =? 'make-custom-hash make-custom-hash (make-hash) values))]
(mk hash hash2 =? 'make-custom-hash custom-hash (make-hash) values))]
[make-immutable-custom-hash
(lambda (=? hash [hash2 (lambda (v) 10001)])
(mk hash hash2 =? 'make-immutable-custom-hash make-immutable-custom-hash #hash() values))]
(mk hash hash2 =? 'make-immutable-custom-hash immutable-custom-hash #hash() values))]
[make-weak-custom-hash
(lambda (=? hash [hash2 (lambda (v) 10001)])
(mk hash hash2 =? 'make-weak-custom-hash make-custom-hash (make-weak-hash)
(mk hash hash2 =? 'make-weak-custom-hash custom-hash (make-weak-hash)
(lambda (make-box)
(let ([ht (make-weak-hasheq)])
(lambda (v)

View File

@ -1,7 +1,7 @@
#lang scheme/base
#lang racket/base
(require syntax/modcode
(for-syntax scheme/base))
(for-syntax racket/base))
(provide enter!)
@ -29,10 +29,10 @@
(enter-require mod)
(let ([ns (module->namespace mod)])
(current-namespace ns)
(namespace-require 'scheme/enter)))
(namespace-require 'racket/enter)))
(current-namespace orig-namespace)))
(define-struct mod (name timestamp depends))
(struct mod (name timestamp depends))
(define loaded (make-hash))
@ -66,13 +66,13 @@
(or (current-load-relative-directory)
(current-directory)))))])
;; Record module timestamp and dependencies:
(let ([mod (make-mod name
(get-timestamp path)
(if code
(apply append
(map cdr (module-compiled-imports code)))
null))])
(hash-set! loaded path mod))
(let ([a-mod (mod name
(get-timestamp path)
(if code
(apply append
(map cdr (module-compiled-imports code)))
null))])
(hash-set! loaded path a-mod))
;; Evaluate the module:
(eval code))
;; Not a module:

View File

@ -1,4 +1,4 @@
#lang scheme/base
#lang racket/base
(provide s-exp->fasl
fasl->s-exp)

View File

@ -1,4 +1,4 @@
#lang scheme/base
#lang racket/base
(provide delete-directory/files
copy-directory/files
@ -22,7 +22,7 @@
write-to-file
display-lines-to-file)
(require "private/portlines.ss")
(require "private/portlines.rkt")
;; utility: sorted dirlist so functions are deterministic
(define (sorted-dirlist [dir (current-directory)])

View File

@ -1,4 +1,4 @@
#lang scheme/base
#lang racket/base
(require '#%futures)
(provide future?

View File

@ -1,8 +1,8 @@
#lang scheme/base
#lang racket/base
(require (for-syntax scheme/base)
scheme/control
scheme/stxparam scheme/splicing)
(require (for-syntax racket/base)
racket/control
racket/stxparam racket/splicing)
(provide yield generator generator-state in-generator infinite-generator
sequence->generator sequence->repeated-generator)

4
collects/racket/gui.rkt Normal file
View File

@ -0,0 +1,4 @@
(module gui racket
(require racket/gui/base)
(provide (all-from-out racket)
(all-from-out racket/gui/base)))

View File

@ -0,0 +1,2 @@
#lang s-exp syntax/module-reader
racket/gui

View File

@ -1,6 +1,6 @@
#lang scheme/base
#lang racket/base
(require (for-syntax scheme/base) scheme/promise)
(require (for-syntax racket/base) racket/promise)
(provide help)

View File

@ -1,6 +1,6 @@
#lang scheme/base
#lang racket/base
(require (for-syntax scheme/base
(require (for-syntax racket/base
syntax/stx
syntax/path-spec
mzlib/private/increader

View File

@ -1,7 +1,6 @@
#lang racket
(require scheme/enter
scheme/help
"private/runtime.ss")
(require racket/enter
racket/help)
;; Set the printer:
(current-print (let ([pretty-printer
@ -11,5 +10,5 @@
pretty-printer))
(provide (all-from-out racket
scheme/enter
scheme/help))
racket/enter
racket/help))

55
collects/racket/main.rkt Normal file
View File

@ -0,0 +1,55 @@
#lang racket/private
(require racket/base
racket/contract
racket/class
racket/unit
racket/dict
racket/include
racket/pretty
racket/math
racket/match
racket/shared
racket/set
racket/tcp
racket/udp
racket/list
racket/vector
racket/string
racket/function
racket/path
racket/file
racket/port
racket/cmdline
racket/promise
racket/bool
racket/local
racket/nest
(for-syntax racket/base))
(provide (all-from-out racket/contract
racket/class
racket/unit
racket/dict
racket/include
racket/pretty
racket/math
racket/match
racket/shared
racket/base
racket/set
racket/tcp
racket/udp
racket/list
racket/vector
racket/string
racket/function
racket/path
racket/file
racket/port
racket/cmdline
racket/promise
racket/bool
racket/local
racket/nest)
(for-syntax (all-from-out racket/base)))

View File

@ -1,8 +0,0 @@
#lang racket/private
(require (except-in scheme struct struct/ctc)
(only-in mzlib/unit struct~r/ctc)
"private/struct.rkt")
(provide (all-from-out scheme)
(rename-out [struct~r/ctc struct/ctc])
struct)

View File

@ -1,7 +1,7 @@
#lang scheme/base
(require scheme/match/match
(for-syntax scheme/base))
(provide (except-out (all-from-out scheme/match/match)
#lang racket/base
(require racket/match/match
(for-syntax racket/base))
(provide (except-out (all-from-out racket/match/match)
define-match-expander)
(rename-out [define-match-expander* define-match-expander]))

View File

@ -1,4 +1,4 @@
#lang scheme/base
#lang racket/base
(require (only-in "runtime.ss"
match-equality-test

View File

@ -1,4 +1,4 @@
#lang scheme/base
#lang racket/base
(require (only-in "runtime.ss"
match-equality-test

View File

@ -1,9 +1,9 @@
#lang scheme/base
#lang racket/base
(require (for-template scheme/base)
(require (for-template racket/base)
syntax/boundmap
syntax/stx
scheme/struct-info
racket/struct-info
"patterns.ss"
"compiler.ss"
"parse-helper.ss"

Some files were not shown because too many files have changed in this diff Show More