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

Merge branch 'master' of git:plt

Browse Source
This commit is contained in:
Matthias Felleisen 2010-05-27 18:57:20 -04:00
commit b8dce21f22
146 changed files with 1385 additions and 718 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

4
collects/compiler/distribute.rkt
View File

@ -234,13 +234,13 @@
(build-path exe-dir dll)))))
(define (copy-framework name 3m? lib-dir)
(let* ([fw-name (format "PLT_~a.framework" name)]
(let* ([fw-name (format "~a.framework" name)]
[sub-dir (build-path fw-name "Versions"
(if 3m?
(format "~a_3m" (version))
(version)))])
(make-directory* (build-path lib-dir sub-dir))
(let* ([fw-name (build-path sub-dir (format "PLT_~a" name))]
(let* ([fw-name (build-path sub-dir (format "~a" name))]
[dll-dir (find-framework fw-name)])
(copy-file* (build-path dll-dir fw-name)
(build-path lib-dir fw-name))

49
collects/compiler/embed-unit.rkt
View File

@ -621,7 +621,10 @@
;; Have a relative mapping?
(let-values ([(a) (if rel-to
(assq (resolved-module-path-name rel-to) mapping-table)
#f)])
#f)]
[(ss->rkt)
(lambda (s)
(regexp-replace #rx"[.]ss$" s ".rkt"))])
(if a
(let-values ([(a2) (assoc name (cadr a))])
(if a2
@ -639,20 +642,20 @@
(if (null? (cddr name))
(if (regexp-match #rx"^[^/]*[.]" (cadr name))
;; mzlib
(string-append "mzlib/" (cadr name))
(string-append "mzlib/" (ss->rkt (cadr name)))
;; new-style
(if (regexp-match #rx"^[^/.]*$" (cadr name))
(string-append (cadr name) "/main.ss")
(string-append (cadr name) "/main.rkt")
(if (regexp-match #rx"^[^.]*$" (cadr name))
;; need a suffix:
(string-append (cadr name) ".ss")
(cadr name))))
(string-append (cadr name) ".rkt")
(ss->rkt (cadr name)))))
;; old-style multi-string
(string-append (apply string-append
(map (lambda (s)
(string-append s "/"))
(cddr name)))
(cadr name)))
(ss->rkt (cadr name))))
(if (eq? 'planet (car name))
(if (null? (cddr name))
;; need to normalize:
@ -673,7 +676,7 @@
(if (suffix-after . <= . 0)
(if (regexp-match? #rx"[.]" s)
s
(string-append s ".ss"))
(string-append s ".rkt"))
s)))))]
[(last-of)
(lambda (l)
@ -689,8 +692,8 @@
(let-values ([(vparts) (split (cadr parts) #rx":" +inf.0)])
(cons 'planet
(cons (if (null? (cddr parts))
"main.ss"
(last-of parts))
"main.rkt"
(ss->rkt (last-of parts)))
(cons
(cons
(car parts)
@ -743,6 +746,19 @@
;; Let default handler try:
(orig name rel-to stx load?))))))))))])])
(current-module-name-resolver embedded-resolver))))))
(define (ss<->rkt path)
(cond
[(regexp-match? #rx#"[.]ss$" path)
(ss<->rkt (path-replace-suffix path #".rkt"))]
[(regexp-match? #rx#"[.]rkt$" path)
(if (file-exists? path)
path
(let ([p2 (path-replace-suffix path #".ss")])
(if (file-exists? path)
p2
path)))]
[else path]))
;; Write a module bundle that can be loaded with 'load' (do not embed it
;; into an executable). The bundle is written to the current output port.
@ -757,7 +773,7 @@
(normalize f)))]
[files (map resolve-one-path module-paths)]
[collapse-one (lambda (mp)
(collapse-module-path mp (build-path (current-directory) "dummy.ss")))]
(collapse-module-path mp (build-path (current-directory) "dummy.rkt")))]
[collapsed-mps (map collapse-one module-paths)]
[prefix-mapping (map (lambda (f m)
(cons f (let ([p (car m)])
@ -811,7 +827,7 @@
(if (null? runtimes)
#f
(let* ([table-sym (module-path-index-resolve
(module-path-index-join '(lib "runtime-path-table.ss" "mzlib" "private")
(module-path-index-join '(lib "runtime-path-table.rkt" "mzlib" "private")
#f))]
[table-path (resolved-module-path-name table-sym)])
(assoc (normalize table-path) l)))])
@ -887,14 +903,15 @@
p
(let ([s (regexp-split #rx"/" (cadr p))])
(if (null? (cdr s))
`(lib "main.ss" ,(cadr p))
`(lib "main.rkt" ,(cadr p))
(let ([s (reverse s)])
`(lib ,(car s) ,@(reverse (cdr s)))))))
p)])
(build-path (if (null? (cddr p))
(collection-path "mzlib")
(apply collection-path (cddr p)))
(cadr p)))]
(ss<->rkt
(build-path (if (null? (cddr p))
(collection-path "mzlib")
(apply collection-path (cddr p)))
(cadr p))))]
[else p])])
(and p
(path->bytes

27
collects/compiler/zo-marshal.rkt
View File

@ -228,6 +228,11 @@
(traverse-stx expr visit)]
[(wrapped? expr)
(traverse-wrapped expr visit)]
[(hash? expr)
(when (visit expr)
(for ([(k v) (in-hash expr)])
(traverse-data k visit)
(traverse-data v visit)))]
[else
(void)]))
@ -987,16 +992,18 @@
(for ([v (in-vector expr)])
(out-data v out))]
[(hash? expr)
(out-byte CPT_HASH_TABLE out)
(out-number (cond
[(hash-eqv? expr) 2]
[(hash-eq? expr) 0]
[else 1])
out)
(out-number (hash-count expr) out)
(for ([(k v) (in-hash expr)])
(out-data k out)
(out-data v out))]
(out-shared expr out
(lambda ()
(out-byte CPT_HASH_TABLE out)
(out-number (cond
[(hash-eqv? expr) 2]
[(hash-eq? expr) 0]
[else 1])
out)
(out-number (hash-count expr) out)
(for ([(k v) (in-hash expr)])
(out-data k out)
(out-data v out))))]
[(svector? expr)
(let* ([vec (svector-vec expr)]
[len (vector-length vec)])

115
collects/compiler/zo-parse.rkt
View File

@ -15,8 +15,6 @@
Lines 628, 630 seem to be only for debugging and should probably throw errors
unmarshal-stx-get also seems to be for debugging and should probably throw an error
vector and pair cases of decode-wraps seem to do different things from the corresponding C code
Line 816: This should be an eqv placeholder (but they don't exist)
@ -29,8 +27,6 @@
collects/browser/compiled/browser_scrbl.zo (eg) contains a all-from-module that looks like: (#<module-path-index> 0 (1363072) . #f) --- that doesn't seem to match the spec
We seem to leave placeholders for hash-tables in the structs
|#
;; ----------------------------------------
;; Bytecode unmarshalers for various forms
@ -501,15 +497,9 @@
;; ----------------------------------------
;; Syntax unmarshaling
(define (decode-stx cp v)
(if (integer? v)
(let-values ([(v2 decoded?) (unmarshal-stx-get cp v)])
(if decoded?
v2
(let ([v2 (decode-stx cp v2)])
(unmarshal-stx-set! cp v v2)
v2)))
(unmarshal-stx-get/decode cp v decode-stx)
(let loop ([v v])
(let-values ([(cert-marks v encoded-wraps)
(match v
@ -564,29 +554,17 @@
(map loop (cdr (vector->list (struct->vector v)))))))]
[else (add-wrap v)]))))))
(define (decode-wraps cp w)
; A wraps is either a indirect reference or a list of wrap-elems (from stxobj.c:252)
(if (integer? w)
(let-values ([(w2 decoded?) (unmarshal-stx-get cp w)])
(if decoded?
w2
(let ([w2 (decode-wraps cp w2)])
(unmarshal-stx-set! cp w w2)
w2)))
(unmarshal-stx-get/decode cp w decode-wraps)
(map (lambda (a)
(let aloop ([a a])
; A wrap-elem is either
(cond
; A reference
[(integer? a)
(let-values ([(a2 decoded?) (unmarshal-stx-get cp a)])
(if decoded?
a2
(let ([a2 (aloop a2)])
(unmarshal-stx-set! cp a a2)
a2)))]
(unmarshal-stx-get/decode cp a (lambda (cp v) (aloop v)))]
; A mark (not actually a number as the C says, but a (list <num>)
[(and (pair? a) (null? (cdr a)) (number? (car a)))
(make-wrap-mark (car a))]
@ -704,23 +682,6 @@
[module-path-index
(make-simple-module-binding module-path-index)]))))
(define (unmarshal-stx-get cp pos)
(if (pos . >= . (vector-length (cport-symtab cp)))
(values `(#%bad-index ,pos) #t)
(let ([v (vector-ref (cport-symtab cp) pos)])
(if (not-ready? v)
(let ([save-pos (cport-pos cp)])
(set-cport-pos! cp (vector-ref (cport-shared-offsets cp) (sub1 pos)))
(let ([v (read-compact cp)])
(vector-set! (cport-symtab cp) pos v)
(set-cport-pos! cp save-pos)
(values v #f)))
(values v (vector-ref (cport-decoded cp) pos))))))
(define (unmarshal-stx-set! cp pos v)
(vector-set! (cport-symtab cp) pos v)
(vector-set! (cport-decoded cp) pos #t))
(define (parse-module-path-index cp s)
s)
;; ----------------------------------------
@ -738,15 +699,7 @@
(case cpt-tag
[(delayed)
(let ([pos (read-compact-number cp)])
(let ([v (vector-ref (cport-symtab cp) pos)])
(if (not-ready? v)
(let ([save-pos (cport-pos cp)])
(set-cport-pos! cp (vector-ref (cport-shared-offsets cp) (sub1 pos)))
(let ([v (read-compact cp)])
(vector-set! (cport-symtab cp) pos v)
(set-cport-pos! cp save-pos)
v))
v)))]
(read-sym cp pos))]
[(escape)
(let* ([len (read-compact-number cp)]
[s (cport-get-bytes cp len)])
@ -841,9 +794,8 @@
[len (read-compact-number cp)])
((case eq
[(0) make-hasheq-placeholder]
; XXX One of these should be eqv
[(1) make-hash-placeholder]
[(2) make-hash-placeholder])
[(2) make-hasheqv-placeholder])
(for/list ([i (in-range len)])
(cons (read-compact cp)
(read-compact cp)))))]
@ -894,16 +846,8 @@
(read-compact cp))))])
(read (open-input-bytes #"x")))))]
[(symref)
(let* ([l (read-compact-number cp)]
[v (vector-ref (cport-symtab cp) l)])
(if (not-ready? v)
(let ([pos (cport-pos cp)])
(set-cport-pos! cp (vector-ref (cport-shared-offsets cp) (sub1 l)))
(let ([v (read-compact cp)])
(set-cport-pos! cp pos)
(vector-set! (cport-symtab cp) l v)
v))
v))]
(let* ([l (read-compact-number cp)])
(read-sym cp l))]
[(weird-symbol)
(let ([uninterned (read-compact-number cp)]
[str (read-compact-chars cp (read-compact-number cp))])
@ -934,7 +878,7 @@
[(closure)
(let* ([l (read-compact-number cp)]
[ind (make-indirect #f)])
(vector-set! (cport-symtab cp) l ind)
(placeholder-set! (vector-ref (cport-symtab cp) l) ind)
(let* ([v (read-compact cp)]
[cl (make-closure v (gensym
(let ([s (lam-name v)])
@ -956,6 +900,36 @@
[else
(cons v (loop (sub1 need-car) proper))]))))
(define (unmarshal-stx-get/decode cp pos decode-stx)
(define v2 (read-sym cp pos))
(define decoded? (vector-ref (cport-decoded cp) pos))
(if decoded?
v2
(let ([dv2 (decode-stx cp v2)])
(placeholder-set! (vector-ref (cport-symtab cp) pos) dv2)
(vector-set! (cport-decoded cp) pos #t)
dv2)))
(require unstable/markparam)
(define read-sym-mark (mark-parameter))
(define (read-sym cp i)
(define symtab (cport-symtab cp))
(define ph (vector-ref symtab i))
; We are reading this already, so return the placeholder
(if (memq i (mark-parameter-all read-sym-mark))
ph
; Otherwise, try to read it and return the real thing
(local [(define vv (placeholder-get ph))]
(when (not-ready? vv)
(local [(define save-pos (cport-pos cp))]
(set-cport-pos! cp (vector-ref (cport-shared-offsets cp) (sub1 i)))
(mark-parameterize
([read-sym-mark i])
(let ([v (read-compact cp)])
(placeholder-set! ph v)))
(set-cport-pos! cp save-pos)))
(placeholder-get ph))))
;; path -> bytes
;; implementes read.c:read_compiled
(define (zo-parse port)
@ -990,18 +964,17 @@
(unless (eof-object? (read-byte port))
(error 'zo-parse "File too big"))
(define symtab (make-vector symtabsize (make-not-ready)))
(define nr (make-not-ready))
(define symtab
(build-vector symtabsize (λ (i) (make-placeholder nr))))
(define cp (make-cport 0 shared-size port size* rst-start symtab so* (make-vector symtabsize #f) (make-hash) (make-hash)))
(for/list ([i (in-range 1 symtabsize)])
(define vv (vector-ref symtab i))
(when (not-ready? vv)
(set-cport-pos! cp (vector-ref so* (sub1 i)))
(let ([v (read-compact cp)])
(vector-set! symtab i v))))
(read-sym cp i))
(set-cport-pos! cp shared-size)
(read-marshalled 'compilation-top-type cp)))
(make-reader-graph
(read-marshalled 'compilation-top-type cp))))
;; ----------------------------------------

4
collects/compiler/zo-structs.rkt
View File

@ -22,7 +22,7 @@
(define-syntax-rule (define-form-struct* id id+par ([field-id field-contract] ...))
(begin
(define-struct id+par (field-id ...) #:transparent)
(define-struct id+par (field-id ...) #:prefab)
(provide/contract
[struct id ([field-id field-contract] ...)])))
@ -57,7 +57,7 @@
(define-form-struct (expr form) ())
;; A static closure can refer directly to itself, creating a cycle
(define-struct indirect ([v #:mutable]) #:transparent)
(define-struct indirect ([v #:mutable]) #:prefab)
(define-form-struct compilation-top ([max-let-depth exact-nonnegative-integer?] [prefix prefix?] [code (or/c form? indirect? any/c)])) ; compiled code always wrapped with this

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

@ -140,7 +140,7 @@
(format "-bE:~a/ext.exp" (include-dir))
"-bnoentry")]
[(parisc-hpux) (list "-b")]
[(ppc-macosx ppc-darwin x86_64-macosx x86_86-darwin) mac-link-flags]
[(ppc-macosx ppc-darwin x86_64-macosx x86_64-darwin) mac-link-flags]
[(i386-macosx i386-darwin) (append mac-link-flags '("-m32"))]
[(i386-cygwin) win-gcc-linker-flags]
[else (list "-fPIC" "-shared")]))

2
collects/ffi/unsafe/objc.rkt
View File

@ -83,7 +83,7 @@
(case (string->symbol (path->string (system-library-subpath #f)))
[(i386-macosx i386-darwin) '(1 2 4 8)]
[(ppc-macosx ppc-darwin) '(1 2 3 4)]
[(x86_64-macosx x86_86-darwin)
[(x86_64-macosx x86_64-darwin)
;; Do we need more analysis for unaligned fields?
'(1 2 3 4 5 6 7 8)]))

5
collects/lang/private/imageeq.rkt
View File

@ -1,6 +1,7 @@
#lang scheme/base
(require scheme/gui/base
mrlib/cache-image-snip
(prefix-in 2htdp/image: mrlib/image-core)
mzlib/class)
(provide scene? image? image=?
@ -13,8 +14,8 @@
(is-a? a cache-image-snip%)))
(define (image=? a-raw b-raw)
(unless (image? a-raw) (raise-type-error 'image=? "image" 0 a-raw b-raw))
(unless (image? b-raw) (raise-type-error 'image=? "image" 1 a-raw b-raw))
(unless (or (2htdp/image:image? a-raw) (image? a-raw)) (raise-type-error 'image=? "image" 0 a-raw b-raw))
(unless (or (2htdp/image:image? b-raw) (image? b-raw)) (raise-type-error 'image=? "image" 1 a-raw b-raw))
;; Rely on image-snip% implementing equal<%>:
(equal? a-raw b-raw))

83
collects/meta/build/build
View File

@ -41,7 +41,7 @@ buildnotifyemail=""
init_repo_vars() {
# use this function to initialize these on remote builds too
gitbranch="${RKTBRANCH:-master}"
svnipath="${PLTSVNIPATH:-trunk}"
svnipath="${RKTSVNIPATH:-trunk}"
}
init_repo_vars
@ -55,7 +55,7 @@ dmgmachine="kauai"
nsismachine="pitcairn"
# list of environment variables that should be carried over to ssh jobs
ssh_vars=(RKTBRANCH PLTSVNIPATH)
ssh_vars=(RKTBRANCH RKTSVNIPATH)
# Add stuff to be msetted later (when we have the `mset' function)
declare -a initial_msets machines
@ -115,8 +115,8 @@ hostname="${hostname%%.*}"
# web directory for pre-prelease stuff on $workmachine (relative to $maindir)
prewebdir="html"
# directory for installation (relative to $maindir)
installdir="plt"
# directory in plt for build-related scripts (includes this script)
installdir="racket"
# directory in racket for build-related scripts (includes this script)
scriptdir="collects/meta/build"
# directory for internal stuff (relative to $maindir)
internaldir="iplt"
@ -148,7 +148,7 @@ htmlpatchscript="$scriptdir/patch-html"
# sitemap materials
sitemapdir="$scriptdir/sitemap"
# platform-installer stuff, all relative the the plt tree
# platform-installer stuff, all relative the the racket tree
nsisdir="$scriptdir/nsis"
unixinstallerdir="$scriptdir/unix-installer"
unixpathcheckscript="$unixinstallerdir/check-install-paths"
@ -166,15 +166,15 @@ stampfile="stamp"
# directory for temporary stuff (absolute path) -- on all machines
tmpdir="/tmp"
# lockfile for this script
lockfile="/tmp/plt-build-lock"
lockfile="/tmp/racket-build-lock"
# name for running this script remotely
remotebuildscript="$tmpdir/build-plt"
remotebuildscript="$tmpdir/build-racket"
# full name for clean repository tgz file to transfer for distributed builds
repotgz="$tmpdir/$cleantgz"
# full name for full tgz file (with binaries etc)
fulltgz="$tmpdir/$installdir-full.tgz"
# log file name prefix for background jobs
bglogfile="$tmpdir/plt-bg-log"
bglogfile="$tmpdir/racket-bg-log"
last_part() {
echo "$*" | sed 's/.*[ -]//'
@ -241,9 +241,9 @@ extra_description_of_platform() {
}
name_of_dist_package() {
case "$1" in
( "mz" ) echo "MzScheme" ;;
( "plt" ) echo "PLT Scheme" ;;
( "full" ) echo "PLT Scheme Full" ;;
( "mz" ) echo "Racket Textual" ;;
( "plt" ) echo "Racket" ;;
( "full" ) echo "Racket Full" ;;
( * ) exit_error "Unknown package name for name_of_dist_package: \"$1\"" ;;
esac
}
@ -305,12 +305,12 @@ explanation_of_installer_type() {
case "$1" in
( "tgz" ) echo "Unpack this file using" \
"\"gunzip <file> | tar xvf -\"." ;;
( "dmg" ) echo "Mount this disk image and copy the PLT folder to your" \
"disk." ;;
( "dmg" ) echo "Mount this disk image and copy the Racket folder to" \
"your disk." ;;
( "idmg" ) echo "Some browsers will automatically mount & copy the" \
"\"PLT Scheme\" folder to your desktop; if yours" \
"does not, mount the disk and copy it yourself." ;;
( "zip" ) echo "Use unzip to extract the PLT folder to your disk." ;;
"\"Racket\" folder to your desktop; if yours does not," \
"mount the disk and copy it yourself." ;;
( "zip" ) echo "Use unzip to extract the Racket folder to your disk." ;;
( "sh" ) echo "Execute this file with \"sh <file>\"," \
"and follow the instructions." ;;
( "exe" ) echo "This is a standard Windows installer." ;;
@ -319,10 +319,10 @@ explanation_of_installer_type() {
esac
}
# This is for running mzscheme scripts, unrelated to the build itself
# This is for running racket scripts, unrelated to the build itself
export PLTHOME="$maindir/$installdir" \
PLT_EXTENSION_LIB_PATHS="" \
PLTPLANETDIR="/tmp/plt-build-planet"
PLTPLANETDIR="/tmp/racket-build-planet"
export PATH="$PLTHOME/bin:$PATH"
unset PLTCOLLECTS; export PLTCOLLECTS
@ -801,7 +801,7 @@ _timeout_run() { # first input is the timeout
Xvncpid=""
Xwmpid=""
_start_xvnc() {
local xvnclog="$tmpdir/plt-xvnc-log"
local xvnclog="$tmpdir/racket-xvnc-log"
show "Starting Xvnc (logfile at \"$xvnclog\")"
# Create Xauth cookie
cookie="`mcookie`"
@ -811,7 +811,7 @@ _start_xvnc() {
Xvnc "$DISPLAY" \
-rfbport 6565 \
-localhost \
-desktop "PLT-Session" \
-desktop "Racket-Session" \
-geometry 1024x768 \
-depth 16 \
-httpPort=0 \
@ -1046,7 +1046,7 @@ MAIN_BUILD() {
show "Creating archive"
git archive --format=tar "$gitbranch" | gzip > "$repotgz" \
|| exit_error "Could not create archive"
git archive --format=tar --prefix=plt/ "$gitbranch" \
git archive --format=tar --prefix=racket/ "$gitbranch" \
| gzip > "$maindir/$cleantgz" \
|| exit_error "Could not create archive"
_cd "$maindir"
@ -1238,7 +1238,7 @@ DO_BUILD() { # inputs -- releasing
elif [[ "$(( $RANDOM % 2 ))" = "0" ]]; then test_mode="rnd";
fi;
separator "${machine}(${platform}) testing Racket ($test_mode)"
local testdir="$tmpdir/mztests"
local testdir="$tmpdir/racket-tests"
_rmcd "$testdir"
local _exe _jit exe flags
@ -1300,7 +1300,7 @@ DO_BUILD() { # inputs -- releasing
# copy the installation to a backup directory, leaving one
# backup of the old backup tree if it was there (this is used on
# the build machine, so there's an updated copy of the tree at
# ~scheme/plt); the main work directory is kept the same.
# ~scheme/racket); the main work directory is kept the same.
if [[ -e "$installdir-backup" ]]; then _rm "$installdir-backup"; fi
if [[ -e "$installdir" ]]; then _mv "$installdir" "$installdir-backup"; fi
_mv "$installdir-new" "$installdir"
@ -1328,9 +1328,9 @@ build_w32step() { # inputs: type, name, [args...]
;;
( "NMAKE" ) _run "$NMAKE" "$@"
;;
( "MZCGC" ) _run "$PLTHOME/RacketCGC.exe" "$@"
( "RKTCGC" ) _run "$PLTHOME/RacketCGC.exe" "$@"
;;
( "MZ" ) # prefer using no-suffix, then 3m, and then cgc
( "RKT" ) # prefer using no-suffix, then 3m, and then cgc
# (needed because cgc is used to build 3m)
local E="$PLTHOME/Racket"
if [[ -x "${E}.exe" ]]; then _run "${E}.exe" "$@"
@ -1387,21 +1387,22 @@ DO_WIN32_BUILD() {
separator "win32: Full build"
build_w32step VSNET "racket"
build_w32step VSNET "gracket"
_cd "$PLTHOME/src/worksp/gc2"; build_w32step MZ "3M" make.ss
_cd "$PLTHOME/src/worksp/gc2"; build_w32step RKT "3M" make.ss
_cd "$PLTHOME"
build_w32step VSNET "mzstart"
build_w32step VSNET "mrstart"
separator "win32: Building libraries"
_cd "$PLTHOME"; build_w32step MZ "mzc" -l- setup -Dl compiler
_cd "$PLTHOME"
build_w32step RKT "compiler" -N raco -l- raco setup -Dl compiler
build_w32step VSNET3M "mzcom"
build_w32step VSNET3M "libmysterx"
# _cd "$PLTHOME/src/srpersist"
# build_w32step NMAKE "srpersist" /f srpersist.mak "install"
_cd "$PLTHOME"; build_w32step MZ "raco setup" $SETUP_ARGS
_cd "$PLTHOME"; build_w32step RKT "raco setup" $SETUP_ARGS
separator "win32: Building Cygwin libreries"
_mcd "$PLTHOME/src/build"
@ -1420,7 +1421,7 @@ DO_WIN32_BUILD() {
# _cp "mzdynb.obj" "mzdynb.def" "$PLTHOME/lib/bcc"
_cd "$PLTHOME"
build_w32step MZ "winvers" -l setup/winvers; sleep 240
build_w32step RKT "winvers" -l setup/winvers; sleep 240
}
@ -1436,7 +1437,7 @@ BUILD_DOCS_AND_PDFS() {
html_table_begin
{
html_file_row "html" \
"html files for on-line browsing (same as plt/collecs/doc)"
"html files for on-line browsing (same as racket/collecs/doc)"
_rm "html"
_cp -r "$workdir/$installdir/doc" "html"
}
@ -1539,7 +1540,7 @@ BUILD_BUNDLES() {
# platform-specific installer makers:
# $1 is input file, $2 is the output (without suffix)
# $3 is the package name (mz/plt), $4 is the type (bin/src)
# $3 is the package name (textual/racket), $4 is the type (bin/src)
# $5 is the platform name (unix/mac/win for src distributions)
#----------------------------------------
@ -1729,9 +1730,9 @@ tgz_to_exe() {
fi
local dname
case "$pname" in
( "plt" ) dname="PLT" ;;
( "mz" ) dname="MzScheme" ;;
( "full" ) dname="PLT-FULL" ;;
( "mz" ) dname="Racket-Textual" ;;
( "plt" ) dname="Racket" ;;
( "full" ) dname="Racket-Full" ;;
( * ) exit_error "Unknown package name for exe installer: \"$pname\"" ;;
esac
if [[ "$releasing" != "yes" ]]; then
@ -1786,7 +1787,7 @@ do_installers_page_body() { # input: selector-html table-html
# another case that matches full-...-src and uses the clean tgz
file="../$cleantgz"
fsize="`get_first du -h \"$file\"`"
expl="This is a gzipped-tarball of the full PLT sources,"
expl="This is a gzipped-tarball of the full Racket sources,"
expl="$expl for all platforms."
echo " else if (/^full-.*-src-*/.test(d))" \
"{ t = '$file'; c = '$file ($fsize)\n$expl' }"
@ -1913,20 +1914,20 @@ BUILD_INSTALLERS() {
_cd "$maindir/$instdir"
show "Making the distributions page"
_rm "$tmpdir/plt-tmp-selector" "$tmpdir/plt-tmp-table"
do_installers_page_body "$tmpdir/plt-tmp-selector" "$tmpdir/plt-tmp-table"
_rm "$tmpdir/rkt-tmp-selector" "$tmpdir/rkt-tmp-table"
do_installers_page_body "$tmpdir/rkt-tmp-selector" "$tmpdir/rkt-tmp-table"
# selector page
html_begin "Installers"
html_content_begin
html_show -f "$tmpdir/plt-tmp-selector"
html_show -f "$tmpdir/rkt-tmp-selector"
html_content_end
html_end
# static table page
html_begin "Installers (static)" "table.html"
html_content_begin
html_table_begin "all"
html_show -f "$tmpdir/plt-tmp-table"
_rm "$tmpdir/plt-tmp-selector" "$tmpdir/plt-tmp-table"
html_show -f "$tmpdir/rkt-tmp-table"
_rm "$tmpdir/rkt-tmp-selector" "$tmpdir/rkt-tmp-table"
html_table_end
html_content_end
html_end
@ -1986,7 +1987,7 @@ BUILD_WEB() {
_mcd "$maindir/$w"
html_begin "PLT Nightly Builds"
html_begin "Racket Nightly Builds"
html_content_begin
html_table_begin
#----

53
collects/meta/build/bundle
View File

@ -13,18 +13,18 @@
(define home/ (/-ify (expand-user-path "~scheme")))
(define binaries/ (/-ify (build-path home/ "binaries")))
(define target/ (/-ify (build-path home/ "pre-installers")))
(define plt/ (/-ify (or (getenv "PLTHOME")
(define racket/ (/-ify (or (getenv "PLTHOME")
(error 'bundle "PLTHOME is not defined"))))
(define plt-base/ (/-ify (simplify-path (build-path plt/ 'up) #f)))
(define plt/-name (let-values ([(base name dir?) (split-path plt/)])
(path-element->string name)))
(define racket-base/ (/-ify (simplify-path (build-path racket/ 'up) #f)))
(define racket/-name (let-values ([(base name dir?) (split-path racket/)])
(path-element->string name)))
(define cd current-directory)
(define *readme-file*
(build-path plt/ "README"))
(build-path racket/ "README"))
(define *info-domain-file*
(build-path plt/ "collects" "info-domain" "compiled" "cache.rktd"))
(build-path racket/ "collects" "info-domain" "compiled" "cache.rktd"))
(define *readme-cache* #f)
(define *info-domain-cache* #f)
@ -177,7 +177,7 @@
(set! /dev/null-in (open-input-file "/dev/null"))
(unless (directory-exists? target/) (make-directory target/))
(let ([d (ormap (lambda (x) (and (not (directory-exists? x)) x))
(list home/ plt/ binaries/ target/))])
(list home/ racket/ binaries/ target/))])
(when d (error 'bundle "directory not found: ~a" d)))
(set! *platforms*
(parameterize ([cd binaries/])
@ -203,10 +203,10 @@
(map (lambda (platform)
(dprintf ".")
(parameterize ([cd platform])
;; if no btgz *and* "plt" already created then use get-tree
;; (useful when debugging stuff so re-use pre made ones)
;; should work the same with an old tree
(if (and (directory-exists? "plt") (not *btgz?*))
;; if no btgz *and* "racket" already created then use
;; get-tree (useful when debugging stuff so re-use pre made
;; ones) should work the same with an old tree
(if (and (directory-exists? "racket") (not *btgz?*))
(filtered-map
(lambda (x) ; only directories contain stuff we need
(and (directory-exists? x) (get-tree x)))
@ -225,8 +225,8 @@
(when (null? trees)
(error 'binaries "no binaries found for ~s" platform)))
*platforms* *platform-tree-lists*)
;; Get the plt tree, remove junk and binary stuff
(set-plt-tree! plt-base/ plt/-name *platform-tree-lists*)
;; Get the racket tree, remove junk and binary stuff
(set-racket-tree! racket-base/ racket/-name *platform-tree-lists*)
(set-bin-files-delayed-lists!
(delay (map (lambda (trees)
(sort* (mappend tree-flatten (add-trees trees))))
@ -235,11 +235,11 @@
(define (make-info-domain trees)
(unless (= 1 (length trees))
(error 'make-info-domain "got zero or multiple trees: ~e" trees))
(let* ([collects (or (tree-filter "/plt/collects/" (car trees))
(let* ([collects (or (tree-filter "/racket/collects/" (car trees))
(error 'make-info-domain "got no collects in tree"))]
[info (filter (lambda (x)
(let ([x (path->string (bytes->path (car x)))])
(pair? (tree-filter (concat "/plt/collects/" x)
(pair? (tree-filter (concat "/racket/collects/" x)
collects))))
*info-domain-cache*)])
(lambda () (write info) (newline))))
@ -267,13 +267,14 @@
(define (create-binaries platform trees)
(parameterize ([cd (build-path binaries/ platform)])
(let ([full-tgz (concat "plt-"platform"-full.tgz")]
[bin-tgz (concat "plt-"platform"-binaries.tgz")]
(let ([full-tgz (concat "racket-"platform"-full.tgz")]
[bin-tgz (concat "racket-"platform"-binaries.tgz")]
[all-tgzs (filter input-tgz-name?
(map path->string (directory-list)))])
(unless (and (directory-exists? "plt") (not *btgz?*))
(unless (and (directory-exists? "racket") (not *btgz?*))
(dprintf "Unpacking binaries in ~s ~a\n" platform all-tgzs)
;; even if a "plt" directory exists, we just overwrite the same stuff
;; even if a "racket" directory exists, we just overwrite the same
;; stuff
(unless (member full-tgz all-tgzs)
(error 'create-binaries "~a/~a not found" (cd) full-tgz))
(for ([tgz all-tgzs]) (unpack tgz trees)))
@ -285,9 +286,9 @@
(current-output-port) /dev/null-in (current-error-port)
;; see below for flag explanations
/pax "-w" "-x" "ustar" "-z" "-f" bin-tgz
;; only pack the plt dir (only exception is Libraries on
;; OSX, but that has its own dir)
"plt")])
;; only pack the racket dir (only exception is Libraries
;; on OSX, but that has its own dir)
"racket")])
(subprocess-wait p))))))
(define (pack archive trees prefix)
@ -472,7 +473,7 @@
(let ([name (format "~a-~a.tgz" name type)])
(dprintf "Creating ~s: filtering..." name)
(let ([trees (add-trees
(cons (distribute (get-plt-tree))
(cons (distribute (get-racket-tree))
(if bin?
(tag 'in-binary-tree
(map (if full?
@ -489,8 +490,8 @@
(chown 'root *readme-file* *info-domain-file*)
(pack (concat target/ name) trees
(if bin?
(format "\\(~a\\|~a~a/\\)" plt-base/ binaries/ type)
plt-base/)))
(format "\\(~a\\|~a~a/\\)" racket-base/ binaries/ type)
racket-base/)))
(dprintf " done.\n")))))
'())
(register-spec! 'distribute!
@ -529,7 +530,7 @@
(define (chown-dirs-to who)
(when (and *root?* *pack?*)
(dprintf "Changing owner to ~a..." who)
(for ([dir (list plt/ binaries/)])
(for ([dir (list racket/ binaries/)])
(parameterize ([cd dir]) (chown #:rec #t who ".")))
(dprintf " done.\n")))

2
collects/meta/build/nsis/installer.nsi
View File

@ -177,7 +177,7 @@ Section ""
DetailPrint "Installing Racket..."
SetDetailsPrint listonly
SetOutPath "$INSTDIR"
File /a /r "plt\*.*"
File /a /r "racket\*.*"
!ifndef SimpleInstaller
WriteUninstaller "${UNINSTEXE}" ; Create uninstaller
!endif

17
collects/meta/check-dists.rkt
View File

@ -7,10 +7,13 @@
[current-namespace (namespace-anchor->namespace checker-namespace-anchor)])
(define (/-ify x)
(regexp-replace #rx"/?$" (if (path? x) (path->string x) x) "/"))
(define plt/ (/-ify (simplify-path (build-path (collection-path "scheme") 'up 'up))))
(define plt-base/ (/-ify (simplify-path (build-path plt/ 'up) #f)))
(define plt/-name (let-values ([(base name dir?) (split-path plt/)])
(path-element->string name)))
(define racket/
(/-ify (simplify-path (build-path (collection-path "scheme") 'up 'up))))
(define racket-base/
(/-ify (simplify-path (build-path racket/ 'up) #f)))
(define racket/-name
(let-values ([(base name dir?) (split-path racket/)])
(path-element->string name)))
(register-macros!)
@ -19,11 +22,11 @@
(register-spec! 'verify! verify!)
(register-spec! 'distribute! void)
(set-plt-tree! plt-base/ plt/-name null)
(set-racket-tree! racket-base/ racket/-name null)
(set-bin-files-delayed-lists!
(set-bin-files-delayed-lists!
;; FIXME: hard-wired list of binary-specific files
'(("plt/collects/sgl/compiled/gl-info_ss.zo")))
'(("racket/collects/sgl/compiled/gl-info_ss.zo")))
(expand-spec 'distributions)

33
collects/meta/checker.rkt
View File

@ -449,23 +449,23 @@
file v version))))))
(define (add-dependency-contents!)
(define (pltpath path)
(define (racketpath path)
(bytes->string/utf-8
(apply bytes-append (cdr (mappend (lambda (p) (list #"/" p))
(list* #"plt" #"collects" path))))))
(list* #"racket" #"collects" path))))))
(define (read-depfile file)
(let ([x (with-input-from-file file read)])
(unless (and (pair? x) (check-version (car x) file))
(error 'dependencies "bad contents in ~s: ~s" file x))
(map (lambda (x)
(match x
[`(collects ,(and (? bytes?) s) ...) (pltpath s)]
[`(ext collects ,(and (? bytes?) s) ...) (pltpath s)]
[`(collects ,(and (? bytes?) s) ...) (racketpath s)]
[`(ext collects ,(and (? bytes?) s) ...) (racketpath s)]
[_ (error 'dependencies "bad dependency item in ~s: ~s"
file x)]))
(cddr x))))
(dprintf "Reading dependencies...")
(let loop ([tree (tree-filter "*.dep" *plt-tree*)])
(let loop ([tree (tree-filter "*.dep" *racket-tree*)])
(if (pair? tree)
(for-each loop (cdr tree))
(parameterize ([cd (prop-get tree 'base)])
@ -490,12 +490,13 @@
(define (check-dependencies spec distname)
(add-dependency-contents!)
(dprintf "Verifying dependencies for ~s..." distname)
(let* ([all-files (sort* (add-alts (tree-flatten (tree-filter spec *plt-tree*))))]
[deps0 (or (tree-filter `(and ,spec "*.dep") *plt-tree*)
(let* ([all-files
(sort* (add-alts (tree-flatten (tree-filter spec *racket-tree*))))]
[deps0 (or (tree-filter `(and ,spec "*.dep") *racket-tree*)
(error 'check-dependencies
"got no .dep files for ~s" distname))]
[deps0 (tree-flatten deps0 #t)])
(let* ([missing (tree-filter 'must-be-empty *plt-tree*)]
(let* ([missing (tree-filter 'must-be-empty *racket-tree*)]
[missing (and (pair? missing) (tree-flatten missing #t))])
(when (pair? missing)
(dprintf "files missing from distribution:\n")
@ -538,11 +539,10 @@
;;; Start working
(define *platform-tree-lists* null)
(define *plt-tree* #f)
(define *racket-tree* #f)
(provide get-plt-tree)
(define (get-plt-tree)
*plt-tree*)
(provide get-racket-tree)
(define (get-racket-tree) *racket-tree*)
(provide verify!)
(define (verify!)
@ -556,12 +556,13 @@
(provide checker-namespace-anchor)
(define-namespace-anchor checker-namespace-anchor)
(provide set-plt-tree!)
(define (set-plt-tree! plt-base/ plt/-name tree-lists)
(provide set-racket-tree!)
(define (set-racket-tree! racket-base/ racket/-name tree-lists)
(set! *platform-tree-lists* tree-lists)
(dprintf "Scanning main tree...")
(set! *plt-tree*
(let loop ([tree (parameterize ([cd plt-base/]) (get-tree plt/-name))]
(set! *racket-tree*
(let loop ([tree (parameterize ([cd racket-base/])
(get-tree racket/-name))]
[trees (apply append *platform-tree-lists*)])
(if (null? trees)
(tree-filter '(not junk) tree)

62
collects/meta/dist-specs.rkt
View File

@ -3,7 +3,7 @@
;; -*- scheme -*-
;; ============================================================================
;; This file holds the specifications for creating PLT distributions. These
;; This file holds the specifications for creating Racket distributions. These
;; specifications are defined by a sequence of <sym> := <spec>... definitions
;; (note: no parens), which binds the symbol to a tree specification. In
;; addition, a definition can use `:=tag' which will go into a special space of
@ -141,11 +141,11 @@ distribution-filters :=
;; (note: this rule means that we could avoid specifying docs and just include
;; the whole thing -- but this way we make sure that all doc sources are
;; included too (since they're specified together).)
must-be-empty := (cond docs => (- "/plt/doc/" distribution) else => none)
must-be-empty := (cond docs => (- "/racket/doc/" distribution) else => none)
compiled-filter := (- (collects: "**/compiled/")
(cond verifying => "*.dep"))
"/plt/bin/" "/plt/lib/"
"/racket/bin/" "/racket/lib/"
src-filter := (src: "")
docs-filter := (- (doc: "") ; all docs,
(notes: "") ; excluding basic stuff
@ -173,7 +173,7 @@ std-docs := (doc: "doc-license.txt" "*-std/")
;; (the first line shouldn't be necessary, but be safe)
junk := (+ ".git*" "/.mailmap" ".svn" "CVS/" "[.#]*" "*~"
;; binary stuff should come from the platform directories
"/plt/bin/" "/plt/lib/" "/plt/src/*build*/")
"/racket/bin/" "/racket/lib/" "/racket/src/*build*/")
;; These are handled in a special way by the bundle script: the binary trees
;; are scanned for paths that have "<pfx>{3m|cgc}<sfx>" where a "<pfx><sfx>"
@ -201,13 +201,13 @@ junk := (+ ".git*" "/.mailmap" ".svn" "CVS/" "[.#]*" "*~"
;; covered by these templates.
binary-keep/throw-templates :=
"/plt/{lib|include}/**/*<!>.*"
"/plt/bin/*<!>"
(cond win => "/plt/*<!>.exe"
"/plt/lib/**/lib*<!>???????.{dll|lib|exp}"
mac => "/plt/*<!>.app/"
"/plt/lib/*Racket*.framework/Versions/*<_!>/")
"/plt/collects/**/compiled/**/<!/>*.*"
"/racket/{lib|include}/**/*<!>.*"
"/racket/bin/*<!>"
(cond win => "/racket/*<!>.exe"
"/racket/lib/**/lib*<!>???????.{dll|lib|exp}"
mac => "/racket/*<!>.app/"
"/racket/lib/*Racket*.framework/Versions/*<_!>/")
"/racket/collects/**/compiled/**/<!/>*.*"
binary-keep := "3[mM]"
binary-throw := "{cgc|CGC}"
@ -216,7 +216,7 @@ binary-throw := "{cgc|CGC}"
;; don't follow the above (have no 3m or cgc in the name, and no keep version
;; of the same name that will make them disappear)
binary-throw-more :=
"/plt/lib/**/libmzgc???????.{dll|lib}"
"/racket/lib/**/libmzgc???????.{dll|lib}"
;; ============================================================================
;; Convenient macros
@ -229,7 +229,7 @@ plt-path: := (lambda (prefix . paths)
(when (and (pair? paths) (eq? ': (car paths)))
(set! suffix (cadr paths)) (set! paths (cddr paths)))
`(+ ,@(map (lambda (path)
(concat "/plt/" prefix
(concat "/racket/" prefix
(regexp-replace #rx"^/" path "")
suffix))
paths))))
@ -282,12 +282,12 @@ srcfile: :=
dll: := (lambda fs
`(+ ,@(map (lambda (f)
(concat "/plt/lib/" (regexp-replace
#rx"^/" (expand-spec-1 f) "")
(concat "/racket/lib/"
(regexp-replace #rx"^/" (expand-spec-1 f) "")
"{|3[mM]|cgc|CGC}{|???????}.dll"))
fs)
,@(map (lambda (f)
(concat "/plt/lib/**/"
(concat "/racket/lib/**/"
(regexp-replace #rx"^.*/" (expand-spec-1 f) "")
"{|3[mM]|cgc|CGC}{|???????}.lib"))
fs)))
@ -327,9 +327,9 @@ plt := (+ dr plt-extras)
;; ============================================================================
;; Packages etc
mz-base := "/plt/README"
mz-base := "/racket/README"
(package: "racket") (package: "mzscheme")
"/plt/include/"
"/racket/include/"
;; configuration stuff
(cond (not src) => (collects: "info-domain/")) ; filtered
(package: "config")
@ -411,19 +411,19 @@ extra-dynlibs := (cond win => (dll: "{ssl|lib}eay32"))
;; This filter is used on the full compiled trees to get the binary
;; (platform-dependent) portion out.
binaries := (+ "/plt/bin/"
"/plt/lib/"
"/plt/include/"
"/plt/collects/**/compiled/native/"
(cond unix => "/plt/bin/{|g}racket*"
"/plt/bin/{mzscheme|mred}*"
win => "/plt/*.exe"
"/plt/*.dll"
"/plt/collects/launcher/*.exe"
mac => "/plt/bin/racket*"
"/plt/bin/mzscheme*"
"/plt/*.app"
"/plt/collects/launcher/*.app")
binaries := (+ "/racket/bin/"
"/racket/lib/"
"/racket/include/"
"/racket/collects/**/compiled/native/"
(cond unix => "/racket/bin/{|g}racket*"
"/racket/bin/{mzscheme|mred}*"
win => "/racket/*.exe"
"/racket/*.dll"
"/racket/collects/launcher/*.exe"
mac => "/racket/bin/racket*"
"/racket/bin/mzscheme*"
"/racket/*.app"
"/racket/collects/launcher/*.app")
platform-dependent)
platform-dependent := ; hook for package rules

2
collects/meta/drdr/config.ss
View File

@ -9,7 +9,7 @@
(drdr-directory "/opt/svn/drdr")
(git-path "/usr/bin/git")
(Xvfb-path "/usr/bin/Xvfb")
(fluxbox-path "/usr/bin/fluxbox"))
(fluxbox-path "/usr/bin/fluxbox")
(current-make-install-timeout-seconds (* 90 60))
(current-make-timeout-seconds (* 90 60))
(current-subprocess-timeout-seconds 90)

29
collects/meta/drdr/render.ss
View File

@ -203,7 +203,7 @@
path))])
changes)))))]
[else
'nbsp]))
'" "]))
(define (footer)
`(div ([id "footer"])
@ -264,7 +264,7 @@
(tr (td "Duration:") (td ,(format-duration-ms dur)))
(tr (td "Timeout:") (td ,(if (timeout? log) checkmark-entity "")))
(tr (td "Exit Code:") (td ,(if (exit? log) (number->string (exit-code log)) "")))
(tr (td nbsp) (td (a ([href ,scm-url]) "View File"))))
(tr (td " ") (td (a ([href ,scm-url]) "View File"))))
,(if (lc-zero? changed)
""
`(div ([class "error"])
@ -287,14 +287,18 @@
(img ([src ,png-path])))))])
(make-cdata
#f #f
(file->string
(path-timing-html (substring (path->string* the-base-path) 1)))))
(local [(define content
(file->string
(path-timing-html (substring (path->string* the-base-path) 1))))]
#;(regexp-replace* #rx"&(?![a-z]+;)" content "\\&amp;\\1")
(regexp-replace* #rx"&gt;" content ">"))
))
,(footer))))])]))
(define (number->string/zero v)
(cond
[(zero? v)
'nbsp]
'" "]
[else
(number->string v)]))
@ -421,7 +425,7 @@
,(if directory?
(number->string/zero v)
(if (zero? v)
'nbsp
'" "
checkmark-entity))))
(list timeout unclean stderr changes))
(td ,responsible-party))])
@ -444,7 +448,7 @@
(td ,(number->string/zero (lc->number tot-unclean)))
(td ,(number->string/zero (lc->number tot-stderr)))
(td ,(number->string/zero (lc->number tot-changes)))
(td nbsp))))
(td " "))))
,(footer))))]))
(define (show-help req)
@ -476,7 +480,7 @@
@h1{How is the push "tested"?}
@p{Each file's @code{@,PROP:command-line} property is consulted. If it is the empty string, the file is ignored. If it is a string, then a single @code{~s} is replaced with the file's path, @code{racket} and @code{mzc} with their path (for the current push), and @code{gracket} and @code{gracket-text} with @code{gracket-text}'s path (for the current push); then the resulting command-line is executed.
(Currently no other executables are allowed, so you can't @code{rm -fr /}.)
If there is no property value, the default (@code{mzscheme -t ~s}) is used if the file's suffix is @code{.ss}, @code{.scm}, or @code{.scrbl}.}
If there is no property value, the default @code{racket -qt ~s} is used if the file's suffix is @code{.rkt}, @code{.ss}, @code{.scm}, or @code{.scrbl} and @code{racket -f ~s} is used if the file's suffix is @code{.rktl}.}
@p{The command-line is always executed with a fresh empty current directory which is removed after the run. But all the files share the same home directory and X server, which are both removed after each push's testing is complete.}
@ -837,6 +841,15 @@
[((integer-arg) "") show-revision]
[((integer-arg) (string-arg) ...) show-file]))
#;(define (xml-dispatch req)
(define xe (top-dispatch req))
(define full
(make-xexpr-response xe #:mime-type #"application/xhtml+xml"))
(struct-copy response/full full
[body (list*
#"<!DOCTYPE html PUBLIC \"-//W3C//DTD XHTML 1.0 Strict//EN\" \"http://www.w3.org/TR/xhtml1/DTD/xhtml1-strict.dtd\">\n"
(response/full-body full))]))
(date-display-format 'iso-8601)
(cache/file-mode 'no-cache)
(serve/servlet top-dispatch

121
collects/meta/props
View File

@ -6,7 +6,7 @@ exec racket -um "$0" "$@"
#|
This file contains "properties" of various files and directories in the PLT
This file contains "properties" of various files and directories in the Racket
tree. Its format is briefly described below, but it is mainly intended to be
used as a command-line script -- run it with `-h' to find out how to use it.
In addition, you can make it work as a git command -- put this in a file
@ -31,7 +31,7 @@ sequence of path and properties for it:
<path> <prop> <val> <prop> <val> ...
where <path> is a "/"-delimited string (relative to the plt tree root), <prop>
where <path> is a "/"-delimited string (relative to the racket root), <prop>
is one of a few known property symbols, and <val> is the assigned value. The
value is should follow the predicate specification for the property, which is
defined as `known-props' before the properties data block; note that it is
@ -46,7 +46,7 @@ are set by running this file as a script).
Requiring this file builds the data table and provides an interface for
properties, intended to be used by meta tools. In these functions, `path' is a
path argument that is given as a "/"-delimited and normalized path
string (no ".", "..", "//", or a "/" suffix) relative to the plt tree root, and
string (no ".", "..", "//", or a "/" suffix) relative to the racket root, and
path/s is either such a string or a list of them.
* (get-prop path/s prop [default]
@ -349,14 +349,14 @@ path/s is either such a string or a list of them.
"This is a utility for manipulating properties in the PLT repository."
"Each of the following subcommands expects a property name from a set of"
"known properties. The given paths are normalized to be relative to the"
"plt root for the tree holding this script *if* it is in such a tree"
"racket root for the tree holding this script *if* it is in such a tree"
"(determined by inspecting a few known directories), otherwise an error"
"is raised."
""
"Note: this script holds the data that it changes, so you need to commit"
"it after changes are made."
""
"Note: it does not depend on the plt installation that runs it -- you"
"Note: it does not depend on the racket installation that runs it -- you"
"just need to use the script from the work directory that you want to"
"deal with; if you add a git alias like:"
" prop = \"!$(git rev-parse --show-toplevel)/collects/meta/props\""
@ -388,7 +388,7 @@ path/s is either such a string or a list of them.
p)
(if (> n 0)
(loop base (sub1 n))
(error* #f "could not find the plt root from ~a"
(error* #f "could not find the racket root from ~a"
(path-only this-file))))))))
(define check-existing-paths? #t)
(define (paths->list path paths)
@ -405,7 +405,7 @@ path/s is either such a string or a list of them.
""
(let ([n (path->string n)])
(if (regexp-match #rx"^\\.\\.(?:/|$)" n)
(error* #f "path is not in the plt tree: ~s" p)
(error* #f "path is not in the racket tree: ~s" p)
n)))))
(if (null? paths) (norm path) (map norm (cons path paths))))))
(define (get prop path . paths)
@ -1469,94 +1469,72 @@ path/s is either such a string or a list of them.
"collects/tests/racket/beginner-abbr.rktl" drdr:command-line (racket "-f" *)
"collects/tests/racket/beginner.rktl" drdr:command-line (racket "-f" *)
"collects/tests/racket/benchmarks/common/auto.rkt" drdr:command-line (racket * "--" "racket" "ctak")
"collects/tests/racket/benchmarks/common/conform.rkt" drdr:command-line #f
"collects/tests/racket/benchmarks/common/cpstack-typed-non-optimizing.rkt" responsible (stamourv) drdr:command-line #f
"collects/tests/racket/benchmarks/common/cpstack-typed-optimizing.rkt" responsible (stamourv) drdr:command-line #f
"collects/tests/racket/benchmarks/common/cpstack-typed-non-optimizing.rkt" responsible (stamourv)
"collects/tests/racket/benchmarks/common/cpstack-typed-optimizing.rkt" responsible (stamourv)
"collects/tests/racket/benchmarks/common/cpstack-typed.rktl" responsible (stamourv) drdr:command-line #f
"collects/tests/racket/benchmarks/common/ctak-typed-non-optimizing.rkt" responsible (stamourv) drdr:command-line #f
"collects/tests/racket/benchmarks/common/ctak-typed-optimizing.rkt" responsible (stamourv) drdr:command-line #f
"collects/tests/racket/benchmarks/common/ctak-typed-non-optimizing.rkt" responsible (stamourv)
"collects/tests/racket/benchmarks/common/ctak-typed-optimizing.rkt" responsible (stamourv)
"collects/tests/racket/benchmarks/common/ctak-typed.rktl" responsible (stamourv) drdr:command-line #f
"collects/tests/racket/benchmarks/common/ctak.rkt" drdr:command-line #f
"collects/tests/racket/benchmarks/common/dderiv-typed-non-optimizing.rkt" responsible (stamourv) drdr:command-line #f
"collects/tests/racket/benchmarks/common/dderiv-typed-optimizing.rkt" responsible (stamourv) drdr:command-line #f
"collects/tests/racket/benchmarks/common/dderiv-typed-non-optimizing.rkt" responsible (stamourv)
"collects/tests/racket/benchmarks/common/dderiv-typed-optimizing.rkt" responsible (stamourv)
"collects/tests/racket/benchmarks/common/dderiv-typed.rktl" responsible (stamourv) drdr:command-line #f
"collects/tests/racket/benchmarks/common/deriv-typed-non-optimizing.rkt" responsible (stamourv) drdr:command-line #f
"collects/tests/racket/benchmarks/common/deriv-typed-optimizing.rkt" responsible (stamourv) drdr:command-line #f
"collects/tests/racket/benchmarks/common/deriv-typed-non-optimizing.rkt" responsible (stamourv)
"collects/tests/racket/benchmarks/common/deriv-typed-optimizing.rkt" responsible (stamourv)
"collects/tests/racket/benchmarks/common/deriv-typed.rktl" responsible (stamourv) drdr:command-line #f
"collects/tests/racket/benchmarks/common/destruct.rkt" drdr:command-line #f
"collects/tests/racket/benchmarks/common/div-typed-non-optimizing.rkt" responsible (stamourv) drdr:command-line #f
"collects/tests/racket/benchmarks/common/div-typed-optimizing.rkt" responsible (stamourv) drdr:command-line #f
"collects/tests/racket/benchmarks/common/div-typed-non-optimizing.rkt" responsible (stamourv)
"collects/tests/racket/benchmarks/common/div-typed-optimizing.rkt" responsible (stamourv)
"collects/tests/racket/benchmarks/common/div-typed.rktl" responsible (stamourv) drdr:command-line #f
"collects/tests/racket/benchmarks/common/div.rkt" drdr:command-line (mzc *)
"collects/tests/racket/benchmarks/common/dynamic.rkt" drdr:command-line #f
"collects/tests/racket/benchmarks/common/dynamic2.rkt" drdr:command-line (mzc *)
"collects/tests/racket/benchmarks/common/fft-typed-non-optimizing.rkt" responsible (stamourv) drdr:command-line #f
"collects/tests/racket/benchmarks/common/fft-typed-optimizing.rkt" responsible (stamourv) drdr:command-line #f
"collects/tests/racket/benchmarks/common/fft-typed-non-optimizing.rkt" responsible (stamourv)
"collects/tests/racket/benchmarks/common/fft-typed-optimizing.rkt" responsible (stamourv)
"collects/tests/racket/benchmarks/common/fft-typed.rktl" responsible (stamourv) drdr:command-line #f
"collects/tests/racket/benchmarks/common/graphs-typed-non-optimizing.rkt" responsible (stamourv) drdr:command-line #f
"collects/tests/racket/benchmarks/common/graphs-typed-optimizing.rkt" responsible (stamourv) drdr:command-line #f
"collects/tests/racket/benchmarks/common/graphs-typed-non-optimizing.rkt" responsible (stamourv)
"collects/tests/racket/benchmarks/common/graphs-typed-optimizing.rkt" responsible (stamourv)
"collects/tests/racket/benchmarks/common/graphs-typed.rktl" responsible (stamourv) drdr:command-line #f
"collects/tests/racket/benchmarks/common/graphs.rkt" drdr:command-line (mzc *)
"collects/tests/racket/benchmarks/common/lattice.rkt" drdr:command-line #f
"collects/tests/racket/benchmarks/common/lattice2-typed-non-optimizing.rkt" responsible (stamourv) drdr:command-line #f
"collects/tests/racket/benchmarks/common/lattice2-typed-optimizing.rkt" responsible (stamourv) drdr:command-line #f
"collects/tests/racket/benchmarks/common/lattice2-typed-non-optimizing.rkt" responsible (stamourv)
"collects/tests/racket/benchmarks/common/lattice2-typed-optimizing.rkt" responsible (stamourv)
"collects/tests/racket/benchmarks/common/lattice2-typed.rktl" responsible (stamourv) drdr:command-line #f
"collects/tests/racket/benchmarks/common/maze.rkt" drdr:command-line #f
"collects/tests/racket/benchmarks/common/maze2.rkt" drdr:command-line (mzc *)
"collects/tests/racket/benchmarks/common/mazefun-typed-non-optimizing.rkt" responsible (stamourv) drdr:command-line #f
"collects/tests/racket/benchmarks/common/mazefun-typed-optimizing.rkt" responsible (stamourv) drdr:command-line #f
"collects/tests/racket/benchmarks/common/mazefun-typed-non-optimizing.rkt" responsible (stamourv)
"collects/tests/racket/benchmarks/common/mazefun-typed-optimizing.rkt" responsible (stamourv)
"collects/tests/racket/benchmarks/common/mazefun-typed.rktl" responsible (stamourv) drdr:command-line #f
"collects/tests/racket/benchmarks/common/mazefun.rkt" drdr:command-line (mzc *)
"collects/tests/racket/benchmarks/common/mk-bigloo.rktl" drdr:command-line #f
"collects/tests/racket/benchmarks/common/mk-chicken.rktl" drdr:command-line #f
"collects/tests/racket/benchmarks/common/mk-gambit.rktl" drdr:command-line #f
"collects/tests/racket/benchmarks/common/nestedloop-typed-non-optimizing.rkt" responsible (stamourv) drdr:command-line #f
"collects/tests/racket/benchmarks/common/nestedloop-typed-optimizing.rkt" responsible (stamourv) drdr:command-line #f
"collects/tests/racket/benchmarks/common/nestedloop-typed-non-optimizing.rkt" responsible (stamourv)
"collects/tests/racket/benchmarks/common/nestedloop-typed-optimizing.rkt" responsible (stamourv)
"collects/tests/racket/benchmarks/common/nestedloop-typed.rktl" responsible (stamourv) drdr:command-line #f
"collects/tests/racket/benchmarks/common/nestedloop.rkt" drdr:command-line (mzc *)
"collects/tests/racket/benchmarks/common/nfa-typed-non-optimizing.rkt" responsible (stamourv) drdr:command-line #f
"collects/tests/racket/benchmarks/common/nfa-typed-optimizing.rkt" responsible (stamourv) drdr:command-line #f
"collects/tests/racket/benchmarks/common/nfa-typed-non-optimizing.rkt" responsible (stamourv)
"collects/tests/racket/benchmarks/common/nfa-typed-optimizing.rkt" responsible (stamourv)
"collects/tests/racket/benchmarks/common/nfa-typed.rktl" responsible (stamourv) drdr:command-line #f
"collects/tests/racket/benchmarks/common/nothing-typed-non-optimizing.rkt" responsible (stamourv) drdr:command-line #f
"collects/tests/racket/benchmarks/common/nothing-typed-optimizing.rkt" responsible (stamourv) drdr:command-line #f
"collects/tests/racket/benchmarks/common/nothing-typed-non-optimizing.rkt" responsible (stamourv)
"collects/tests/racket/benchmarks/common/nothing-typed-optimizing.rkt" responsible (stamourv)
"collects/tests/racket/benchmarks/common/nothing-typed.rktl" responsible (stamourv) drdr:command-line #f
"collects/tests/racket/benchmarks/common/nqueens-typed-non-optimizing.rkt" responsible (stamourv) drdr:command-line #f
"collects/tests/racket/benchmarks/common/nqueens-typed-optimizing.rkt" responsible (stamourv) drdr:command-line #f
"collects/tests/racket/benchmarks/common/nqueens-typed-non-optimizing.rkt" responsible (stamourv)
"collects/tests/racket/benchmarks/common/nqueens-typed-optimizing.rkt" responsible (stamourv)
"collects/tests/racket/benchmarks/common/nqueens-typed.rktl" responsible (stamourv) drdr:command-line #f
"collects/tests/racket/benchmarks/common/nqueens.rkt" drdr:command-line (mzc *)
"collects/tests/racket/benchmarks/common/paraffins-typed-non-optimizing.rkt" responsible (stamourv) drdr:command-line #f
"collects/tests/racket/benchmarks/common/paraffins-typed-optimizing.rkt" responsible (stamourv) drdr:command-line #f
"collects/tests/racket/benchmarks/common/paraffins-typed-non-optimizing.rkt" responsible (stamourv)
"collects/tests/racket/benchmarks/common/paraffins-typed-optimizing.rkt" responsible (stamourv)
"collects/tests/racket/benchmarks/common/paraffins-typed.rktl" responsible (stamourv) drdr:command-line #f
"collects/tests/racket/benchmarks/common/paraffins.rkt" drdr:command-line (mzc *)
"collects/tests/racket/benchmarks/common/peval.rkt" drdr:command-line #f
"collects/tests/racket/benchmarks/common/puzzle-typed-non-optimizing.rkt" responsible (stamourv) drdr:command-line #f
"collects/tests/racket/benchmarks/common/puzzle-typed-optimizing.rkt" responsible (stamourv) drdr:command-line #f
"collects/tests/racket/benchmarks/common/puzzle-typed-non-optimizing.rkt" responsible (stamourv)
"collects/tests/racket/benchmarks/common/puzzle-typed-optimizing.rkt" responsible (stamourv)
"collects/tests/racket/benchmarks/common/puzzle-typed.rktl" responsible (stamourv) drdr:command-line #f
"collects/tests/racket/benchmarks/common/r5rs-wrap.rktl" drdr:command-line (racket "-f" *)
"collects/tests/racket/benchmarks/common/scheme.rkt" drdr:command-line #f
"collects/tests/racket/benchmarks/common/scheme2.rkt" drdr:command-line (mzc *)
"collects/tests/racket/benchmarks/common/sort1.rkt" drdr:command-line #f
"collects/tests/racket/benchmarks/common/tak-typed-non-optimizing.rkt" responsible (stamourv) drdr:command-line #f
"collects/tests/racket/benchmarks/common/tak-typed-optimizing.rkt" responsible (stamourv) drdr:command-line #f
"collects/tests/racket/benchmarks/common/tak-typed-non-optimizing.rkt" responsible (stamourv)
"collects/tests/racket/benchmarks/common/tak-typed-optimizing.rkt" responsible (stamourv)
"collects/tests/racket/benchmarks/common/tak-typed.rktl" responsible (stamourv) drdr:command-line #f
"collects/tests/racket/benchmarks/common/tak.rkt" drdr:command-line (mzc *)
"collects/tests/racket/benchmarks/common/takl-typed-non-optimizing.rkt" responsible (stamourv) drdr:command-line #f
"collects/tests/racket/benchmarks/common/takl-typed-optimizing.rkt" responsible (stamourv) drdr:command-line #f
"collects/tests/racket/benchmarks/common/takl-typed-non-optimizing.rkt" responsible (stamourv)
"collects/tests/racket/benchmarks/common/takl-typed-optimizing.rkt" responsible (stamourv)
"collects/tests/racket/benchmarks/common/takl-typed.rktl" responsible (stamourv) drdr:command-line #f
"collects/tests/racket/benchmarks/common/takl.rkt" drdr:command-line (mzc *)
"collects/tests/racket/benchmarks/common/takr-typed-non-optimizing.rkt" responsible (stamourv) drdr:command-line #f
"collects/tests/racket/benchmarks/common/takr-typed-optimizing.rkt" responsible (stamourv) drdr:command-line #f
"collects/tests/racket/benchmarks/common/takr-typed-non-optimizing.rkt" responsible (stamourv)
"collects/tests/racket/benchmarks/common/takr-typed-optimizing.rkt" responsible (stamourv)
"collects/tests/racket/benchmarks/common/takr-typed.rktl" responsible (stamourv) drdr:command-line #f
"collects/tests/racket/benchmarks/common/takr.rkt" drdr:command-line (mzc *)
"collects/tests/racket/benchmarks/common/takr2-typed-non-optimizing.rkt" responsible (stamourv) drdr:command-line #f
"collects/tests/racket/benchmarks/common/takr2-typed-optimizing.rkt" responsible (stamourv) drdr:command-line #f
"collects/tests/racket/benchmarks/common/takr2-typed-non-optimizing.rkt" responsible (stamourv)
"collects/tests/racket/benchmarks/common/takr2-typed-optimizing.rkt" responsible (stamourv)
"collects/tests/racket/benchmarks/common/takr2-typed.rktl" responsible (stamourv) drdr:command-line #f
"collects/tests/racket/benchmarks/common/takr2.rkt" drdr:command-line (mzc *)
"collects/tests/racket/benchmarks/common/triangle-typed-non-optimizing.rkt" responsible (stamourv) drdr:command-line #f
"collects/tests/racket/benchmarks/common/triangle-typed-optimizing.rkt" responsible (stamourv) drdr:command-line #f
"collects/tests/racket/benchmarks/common/triangle-typed-non-optimizing.rkt" responsible (stamourv)
"collects/tests/racket/benchmarks/common/triangle-typed-optimizing.rkt" responsible (stamourv)
"collects/tests/racket/benchmarks/common/triangle-typed.rktl" responsible (stamourv) drdr:command-line #f
"collects/tests/racket/benchmarks/common/wrap-typed-non-optimizing.rkt" responsible (stamourv) drdr:command-line #f
"collects/tests/racket/benchmarks/common/wrap-typed-optimizing.rkt" responsible (stamourv) drdr:command-line #f
"collects/tests/racket/benchmarks/common/wrap-typed-non-optimizing.rkt" responsible (stamourv)
"collects/tests/racket/benchmarks/common/wrap-typed-optimizing.rkt" responsible (stamourv)
"collects/tests/racket/benchmarks/mz/expand-class.rktl" drdr:command-line (racket "-f" *)
"collects/tests/racket/benchmarks/mz/parsing.rktl" drdr:command-line (gracket "-f" *)
"collects/tests/racket/benchmarks/mz/redsem.rktl" drdr:command-line (racket "-f" * "--" "--skip-struct-test")
@ -1802,6 +1780,7 @@ path/s is either such a string or a list of them.
"collects/tests/units/test-unit.rktl" drdr:command-line (racket "-f" *)
"collects/tests/unstable/byte-counting-port.rkt" responsible (jay)
"collects/tests/unstable/generics.rkt" responsible (jay)
"collects/tests/unstable/list.rkt" responsible (jay)
"collects/tests/unstable/srcloc.rktl" responsible (cce) drdr:command-line (racket "-f" *)
"collects/tests/utils" responsible (unknown)
"collects/tests/utils/gui.rkt" drdr:command-line (gracket-text "-t" *)

2
collects/meta/readme.txt
View File

@ -1 +1 @@
This directory contains code that is used to manage PLT infrastructure.
This directory contains code that is used to manage Racket infrastructure.

2
collects/meta/spec-lang.rkt
View File

@ -4,7 +4,7 @@
(provide (rename-out [module-begin #%module-begin]))
(define-syntax-rule (module-begin . rest)
(#%module-begin
(#%module-begin
(provide register-specs!)
(define (register-specs! [param *specs*])
(process-specs 'rest param))))

6
collects/rackunit/info.rkt
View File

@ -1,13 +1,13 @@
#lang setup/infotab
(define name "RacUnit")
(define name "RackUnit")
(define blurb '((p "RacUnit is a unit testing framework based on the "
(define blurb '((p "RackUnit is a unit testing framework based on the "
" Extreme Programming unit test frameworks")))
(define scribblings '(("scribblings/rackunit.scrbl" (multi-page) (tool))))
(define tools '[("tool.rkt")])
(define tool-names '["RacUnit DrRacket integration"])
(define tool-names '["RackUnit DrRacket integration"])
(define homepage "http://schematics.sourceforge.net/")
(define url "http://schematics.sourceforge.net/")

4
collects/rackunit/private/gui/config.rkt
View File

@ -14,11 +14,11 @@
;; Some of these are obsolete, given the preferences above.
(define DETAILS-CANVAS-INIT-WIDTH 400)
(define FRAME-LABEL "RacUnit")
(define FRAME-LABEL "RackUnit")
(define FRAME-INIT-HEIGHT 400)
(define TREE-INIT-WIDTH 240)
(define TREE-COLORIZE-CASES #t)
(define DIALOG-ERROR-TITLE "RacUnit: Error")
(define DIALOG-ERROR-TITLE "RackUnit: Error")
(define STATUS-SUCCESS 'success)
(define STATUS-FAILURE 'failure)
(define STATUS-ERROR 'error)

4
collects/rackunit/private/gui/controller.rkt
View File

@ -25,9 +25,9 @@
;; check-ready : -> void
(define/private (check-ready)
(unless view
(error 'racunit "The RacUnit GUI is no longer running."))
(error 'rackunit "The RackUnit GUI is no longer running."))
(when (get-locked?)
(error 'racunit "The RacUnit GUI is locked and not accepting tests.")))
(error 'rackunit "The RackUnit GUI is locked and not accepting tests.")))
;; create-model : test suite<%>/#f -> result<%>
(define/public (create-model test parent)

6
collects/rackunit/private/gui/view.rkt
View File

@ -308,11 +308,11 @@ still be there, just not visible?
(super-new (width width) (height height))
(send (get-help-menu) delete)
(let ([racunit-menu
(let ([rackunit-menu
(new menu%
(label "RacUnit")
(label "RackUnit")
(parent (get-menu-bar)))])
(menu-option/notify-box racunit-menu
(menu-option/notify-box rackunit-menu
"Lock"
(get-field locked? controller)))

6
collects/rackunit/scribblings/acknowledgements.scrbl
View File

@ -3,7 +3,7 @@
@title{Acknowlegements}
The following people have contributed to RacUnit:
The following people have contributed to RackUnit:
@itemize[
@item{Robby Findler pushed me to release version 3}
@ -12,7 +12,7 @@ The following people have contributed to RacUnit:
suggested renaming @racket[test/text-ui]}
@item{Dave Gurnell reported a bug in check-not-exn and
suggested improvements to RacUnit}
suggested improvements to RackUnit}
@item{Danny Yoo reported a bug in and provided a fix for
trim-current-directory}
@ -30,7 +30,7 @@ The following people have contributed to RacUnit:
@item{Jose A. Ortega Ruiz alerted me a problem in the
packaging system and helped fix it.}
@item{Sebastian H. Seidel provided help packaging RacUnit
@item{Sebastian H. Seidel provided help packaging RackUnit
into a .plt}
@item{Don Blaheta provided the method for grabbing line number

2
collects/rackunit/scribblings/api.scrbl
View File

@ -1,7 +1,7 @@
#lang scribble/doc
@(require "base.rkt")
@title[#:tag "api"]{RacUnit API}
@title[#:tag "api"]{RackUnit API}
@defmodule[rackunit
#:use-sources (rackunit)]

4
collects/rackunit/scribblings/check.scrbl
View File

@ -3,7 +3,7 @@
@title{Checks}
Checks are the basic building block of RacUnit. A check
Checks are the basic building block of RackUnit. A check
checks some condition. If the condition holds the check
evaluates to @racket[#t]. If the condition doesn't hold the
check raises an instance of @racket[exn:test:check] with
@ -16,7 +16,7 @@ their arguments. You can use check as first class
functions, though you will lose precision in the reported
source locations if you do so.
The following are the basic checks RacUnit provides. You
The following are the basic checks RackUnit provides. You
can create your own checks using @racket[define-check].
@defproc[(check (op (-> any any any))

2
collects/rackunit/scribblings/compound-testing.scrbl
View File

@ -147,7 +147,7 @@ creates test cases within the suite, with the given names and
body expressions.
As far I know no-one uses this macro, so it might disappear
in future versions of RacUnit.}
in future versions of RackUnit.}
}

2
collects/rackunit/scribblings/control-flow.scrbl
View File

@ -48,5 +48,5 @@ file. The after action deletes it.
This somewhat curious macro evaluates the given tests in a
context where @racket[current-test-case-around] is
parameterized to @racket[test-suite-test-case-around]. This
has been useful in testing RacUnit. It might be useful
has been useful in testing RackUnit. It might be useful
for you if you create test cases that create test cases.}

2
collects/rackunit/scribblings/misc.scrbl
View File

@ -14,7 +14,7 @@ Note that @racket[require/expose] can be a bit fragile,
especially when mixed with compiled code. Use at your own risk!
}
This example gets @racket[make-failure-test], which is defined in a RacUnit test:
This example gets @racket[make-failure-test], which is defined in a RackUnit test:
@racketblock[
(require/expose rackunit/private/check-test (make-failure-test))

4
collects/rackunit/scribblings/overview.scrbl
View File

@ -1,9 +1,9 @@
#lang scribble/doc
@(require "base.rkt")
@title{Overview of RacUnit}
@title{Overview of RackUnit}
There are three basic data types in RacUnit:
There are three basic data types in RackUnit:
@itemize[

24
collects/rackunit/scribblings/philosophy.scrbl
View File

@ -1,10 +1,10 @@
#lang scribble/doc
@(require "base.rkt")
@title[#:tag "philosophy"]{The Philosophy of RacUnit}
@title[#:tag "philosophy"]{The Philosophy of RackUnit}
RacUnit is designed to allow tests to evolve in step with
the evolution of the program under testing. RacUnit
RackUnit is designed to allow tests to evolve in step with
the evolution of the program under testing. RackUnit
scales from the unstructed checks suitable for simple
programs to the complex structure necessary for large
projects.
@ -25,9 +25,9 @@ checking are of the form:
(equal? (length '(a b)) 2)
]
RacUnit directly supports this style of testing. A check
RackUnit directly supports this style of testing. A check
on its own is a valid test. So the above examples may be
written in RacUnit as:
written in RackUnit as:
@racketblock[
(check-equal? (length null) 0)
@ -35,7 +35,7 @@ written in RacUnit as:
(check-equal? (length '(a b)) 2)
]
Simple programs now get all the benefits of RacUnit with
Simple programs now get all the benefits of RackUnit with
very little overhead.
There are limitations to this style of testing that more
@ -45,7 +45,7 @@ it does not make sense to evaluate some expressions if
earlier ones have failed. This type of program needs a way
to group expressions so that a failure in one group causes
evaluation of that group to stop and immediately proceed to
the next group. In RacUnit all that is required is to
the next group. In RackUnit all that is required is to
wrap a @racket[test-begin] expression around a group of
expressions:
@ -62,7 +62,7 @@ be evaluated.
Notice that all the previous tests written in the simple
style are still valid. Introducing grouping is a local
change only. This is a key feature of RacUnit's support
change only. This is a key feature of RackUnit's support
for the evolution of the program.
The programmer may wish to name a group of tests. This is
@ -79,7 +79,7 @@ Most programs will stick with this style. However,
programmers writing very complex programs may wish to
maintain separate groups of tests for different parts of the
program, or run their tests in different ways to the normal
RacUnit manner (for example, test results may be logged
RackUnit manner (for example, test results may be logged
for the purpose of improving software quality, or they may
be displayed on a website to indicate service quality). For
these programmers it is necessary to delay the execution of
@ -104,15 +104,15 @@ outside the suite continue to evaluate as before.
@section{Historical Context}
Most testing frameworks, including earlier versions of
RacUnit, support only the final form of testing. This is
RackUnit, support only the final form of testing. This is
likely due to the influence of the SUnit testing framework,
which is the ancestor of RacUnit and the most widely used
which is the ancestor of RackUnit and the most widely used
frameworks in Java, .Net, Python, and Ruby, and many other
languages. That this is insufficient for all users is
apparent if one considers the proliferation of ``simpler''
testing frameworks in Racket such as SRFI-78, or the
practice of beginner programmers. Unfortunately these
simpler methods are inadequate for testing larger
systems. To the best of my knowledge RacUnit is the only
systems. To the best of my knowledge RackUnit is the only
testing framework that makes a conscious effort to support
the testing style of all levels of programmer.

16
collects/rackunit/scribblings/quick-start.scrbl
View File

@ -1,7 +1,7 @@
#lang scribble/doc
@(require "base.rkt")
@title[#:tag "quick-start"]{Quick Start Guide for RacUnit}
@title[#:tag "quick-start"]{Quick Start Guide for RackUnit}
Suppose we have code contained in @tt{file.rkt}, which
implements buggy versions of @racket[+] and @racket[-]
@ -24,10 +24,10 @@ racket/base
my-*)
]
We want to test this code with RacUnit. We start by
We want to test this code with RackUnit. We start by
creating a file called @tt{file-test.rkt} to contain our
tests. At the top of @tt{file-test.rkt} we import
RacUnit and @tt{file.rkt}:
RackUnit and @tt{file.rkt}:
@racketmod[
racket/base
@ -43,7 +43,7 @@ Now we add some tests to check our library:
(check-equal? (my-* 1 2) 2 "Simple multiplication")
]
This is all it takes to define tests in RacUnit. Now
This is all it takes to define tests in RackUnit. Now
evaluate this file and see if the library is correct.
Here's the result I get:
@ -63,13 +63,13 @@ expected: 2
The first @racket[#t] indicates the first test passed. The
second test failed, as shown by the message.
Requiring RacUnit and writing checks is all you need to
Requiring RackUnit and writing checks is all you need to
get started testing, but let's take a little bit more time
to look at some features beyond the essentials.
Let's say we want to check that a number of properties hold.
How do we do this? So far we've only seen checks of a
single expression. In RacUnit a check is always a single
single expression. In RackUnit a check is always a single
expression, but we can group checks into units called test
cases. Here's a simple test case written using the
@racket[test-begin] form:
@ -147,7 +147,7 @@ tests, allowing you to choose how you run your tests. You
might, for example, print the results to the screen or log
them to a file.
Let's run our tests, using RacUnit's simple textual user
Let's run our tests, using RackUnit's simple textual user
interface (there are fancier interfaces available but this
will do for our example). In @tt{file-test.rkt} add the
following lines:
@ -161,6 +161,6 @@ following lines:
Now evaluate the file and you should see similar output
again.
These are the basics of RacUnit. Refer to the
These are the basics of RackUnit. Refer to the
documentation below for more advanced topics, such as
defining your own checks. Have fun!

4
collects/rackunit/scribblings/rackunit.scrbl
View File

@ -1,12 +1,12 @@
#lang scribble/doc
@(require "base.rkt")
@title{@bold{RacUnit}: Unit Testing for Racket}
@title{@bold{RackUnit}: Unit Testing for Racket}
@author[(author+email "Noel Welsh" "noelwelsh@gmail.com")
(author+email "Ryan Culpepper" "ryan_sml@yahoo.com")]
RacUnit is a unit-testing framework for Racket. It
RackUnit is a unit-testing framework for Racket. It
is designed to handle the needs of all Racket programmers,
from novices to experts.

2
collects/rackunit/scribblings/release-notes.scrbl
View File

@ -12,7 +12,7 @@ There are also miscellaneous Scribble fixes.
@section{Version 3}
This version of RacUnit is largely backwards compatible
This version of RackUnit is largely backwards compatible
with version 2 but there are significant changes to the
underlying model, justifying incrementing the major version
number. These changes are best explained in

6
collects/rackunit/scribblings/running-tests.scrbl
View File

@ -3,14 +3,14 @@
@title[#:tag "running"]{Programmatically Running Tests and Inspecting Results}
RacUnit provides an API for running tests, from which
RackUnit provides an API for running tests, from which
custom UIs can be created.
@section{Result Types}
@defstruct[(exn:test exn) ()]{
The base structure for RacUnit exceptions. You should
The base structure for RackUnit exceptions. You should
never catch instances of this type, only the subtypes
documented below.}
@ -187,7 +187,7 @@ recorded, and so on. To do so the functions that run the
test cases need to know what type the test case has, and
hence is is necessary to provide this information.
If you've made it this far you truly are a master RacUnit
If you've made it this far you truly are a master RackUnit
hacker. As a bonus prize we'll just mention that the code
in hash-monad.rkt and monad.rkt might be of interest for
constructing user interfaces. The API is still in flux, so

8
collects/rackunit/scribblings/ui.scrbl
View File

@ -3,7 +3,7 @@
@title[#:tag "ui"]{User Interfaces}
RacUnit provides a textual and a graphical user interface
RackUnit provides a textual and a graphical user interface
@section{Textual User Interface}
@ -35,13 +35,13 @@ information.
@defmodule[rackunit/gui]
RacUnit also provides a GUI test runner, available from the
RackUnit also provides a GUI test runner, available from the
@racketmodname[rackunit/gui] module.
@defproc[(test/gui [test (or/c test-case? test-suite?)] ...)
any]{
Creates a new RacUnit GUI window and runs each @racket[test]. The
Creates a new RackUnit GUI window and runs each @racket[test]. The
GUI is updated as tests complete.
}
@ -49,7 +49,7 @@ GUI is updated as tests complete.
@defproc[(make-gui-runner)
(-> (or/c test-case? test-suite?) ... any)]{
Creates a new RacUnit GUI window and returns a procedure that, when
Creates a new RackUnit GUI window and returns a procedure that, when
applied, runs the given tests and displays the results in the GUI.
}

2
collects/scribblings/raco/zo-parse.scrbl
View File

@ -5,7 +5,7 @@
compiler/zo-parse))
@(define-syntax-rule (defstruct+ id fields . rest)
(defstruct id fields #:transparent . rest))
(defstruct id fields #:prefab . rest))
@title{API for Parsing Bytecode}

6
collects/scribblings/reference/pairs.scrbl
View File

@ -1051,3 +1051,9 @@ for use with @scheme[make-reader-graph].}
Like @scheme[make-immutable-hasheq], but produces a table placeholder
for use with @scheme[make-reader-graph].}
@defproc[(make-hasheqv-placeholder [assocs (listof pair?)])
hash-placeholder?]{
Like @scheme[make-immutable-hasheqv], but produces a table placeholder
for use with @scheme[make-reader-graph].}

2
collects/setup/dirs.rkt
View File

@ -180,7 +180,7 @@
(build-path dir r)
r)))
p)))]
[rel (get/set-dylib-path exe "PLT_M[rz]" #f)])
[rel (get/set-dylib-path exe "Racket" #f)])
(cond
[(not rel) #f] ; no framework reference found!?
[(regexp-match

84
collects/setup/unixstyle-install.rkt
View File

@ -1,27 +1,27 @@
;; This file is used to move the PLT tree as part of a Unix sh-installer (when
;; it works in unix-style mode) and similar situations. When possible (`move'
;; mode), this is done carefully (undoing changes if there is an error), and a
;; plt-uninstall script is generated. It is also used to change an already
;; existing tree (eg, when DESTDIR is used) and to copy a tree (possibly part
;; of `make install'). There is no good cmdline interface, since it is
;; internal, and should be as independent as possible (it moves the collection
;; tree). Expects these arguments:
;; This file is used to move the Racket tree as part of a Unix sh-installer
;; (when it works in unix-style mode) and similar situations. When possible
;; (`move' mode), this is done carefully (undoing changes if there is an
;; error), and a racket-uninstall script is generated. It is also used to
;; change an already existing tree (eg, when DESTDIR is used) and to copy a
;; tree (possibly part of `make install'). There is no good cmdline interface,
;; since it is internal, and should be as independent as possible (it moves the
;; collection tree). Expects these arguments:
;; * An operation name:
;; - `move': move a relative installation from `pltdir' to an absolute
;; - `move': move a relative installation from `rktdir' to an absolute
;; installation in the given paths (used by the shell installers)
;; (interactive, undo-on-error, create-uninstaller)
;; - `copy': similar to `move', but copies instead of moving
;; - `make-install-copytree': copies some toplevel directories, skips ".*"
;; and compiled subdirs, and rewrites "config.ss", but no uninstaller (used
;; by `make install') (requires an additional `origtree' argument)
;; and "compiled" subdirs, and rewrites "config.rkt", but no uninstaller
;; (used by `make install') (requires an additional `origtree' argument)
;; - `make-install-destdir-fix': fixes paths in binaries, laucnhers, and
;; config.ss (used by `make install' to fix a DESTDIR) (requires exactly
;; config.rkt (used by `make install' to fix a DESTDIR) (requires exactly
;; the same args as `make-install-copytree' (prefixed) and requires a
;; DESTDIR setting)
;; * pltdir: The source plt directory
;; * rktdir: The source racket directory
;; * Path names that should be moved/copied (bin, collects, doc, lib, ...)
#lang scheme/base
#lang racket/base
(define args (vector->list (current-command-line-arguments)))
@ -30,9 +30,9 @@
(begin0 (car args) (set! args (cdr args))))
(define op (string->symbol (get-arg)))
(define pltdir (get-arg))
(define rktdir (get-arg))
(define dirs (map (lambda (name) (list name (get-arg)))
'(bin collects doc lib includeplt libplt man #|src|#)))
'(bin collects doc lib includerkt librkt man #|src|#)))
(define (dir: name)
(cadr (or (assq name dirs) (error 'getdir "unknown dir name: ~e" name))))
@ -101,7 +101,7 @@
(define skip-filter (lambda (p) #f))
;; copy a file or a directory (recursively), preserving time stamps
;; (mzscheme's copy-file preservs permission bits)
;; (racket's copy-file preservs permission bits)
(define (cp src dst)
(let loop ([src src] [dst dst])
(let ([time! (lambda ()
@ -179,8 +179,9 @@
(regexp-replace* #rx"[\"`'$\\]" (dir: 'bin) "\\\\&"))
(write-bytes buf (current-output-port) (cdadr m))))))
(let ([magic (with-input-from-file file (lambda () (read-bytes 10)))])
(cond [(or (regexp-match #rx#"^\177ELF" magic)
(regexp-match #rx#"^\316\372\355\376" magic))
(cond [(or (regexp-match #rx#"^\177ELF" magic)
(regexp-match #rx#"^\316\372\355\376" magic)
(regexp-match #rx#"^\317\372\355\376" magic))
(let ([temp (format "~a-temp-for-install"
(regexp-replace* #rx"/" file "_"))])
(with-handlers ([exn? (lambda (e) (delete-file temp) (raise e))])
@ -194,11 +195,13 @@
(fix-script file)]
[else (error (format "unknown executable: ~a" file))])))
(define (fix-executables bindir . binfiles)
(define (fix-executables bindir librktdir [binfiles #f])
(parameterize ([current-directory bindir])
(let ([binfiles (if (pair? binfiles) (car binfiles) (ls))])
(for-each (lambda (f) (when (file-exists? f) (fix-executable f)))
binfiles))))
(for ([f (in-list (or binfiles (ls)))] #:when (file-exists? f))
(fix-executable f)))
;; fix the starter executable too
(parameterize ([current-directory librktdir])
(when (file-exists? "starter") (fix-executable "starter"))))
;; remove and record all empty dirs
(define (remove-empty-dirs dir)
@ -237,7 +240,7 @@
path-changes))
(define (write-uninstaller)
(define uninstaller (make-path (dir: 'bin) "plt-uninstall"))
(define uninstaller (make-path (dir: 'bin) "racket-uninstall"))
(printf "Writing uninstaller at: ~a...\n" uninstaller)
(register-change! 'file uninstaller)
(with-output-to-file uninstaller #:exists 'replace
@ -276,14 +279,14 @@
(apply make-path collectsdir "config" xs))
(define (ftime file)
(and (file-exists? file) (file-or-directory-modify-seconds file)))
(let* ([src (cpath "config.ss")]
[zo (cpath "compiled" "config_ss.zo")]
;; [dep (cpath "compiled" "config_ss.dep")] ; not needed
(let* ([src (cpath "config.rkt")]
[zo (cpath "compiled" "config_rkt.zo")]
;; [dep (cpath "compiled" "config_rkt.dep")] ; not needed
[src-time (ftime src)]
[zo-time (ftime zo)])
(printf "Rewriting configuration file at: ~a...\n" src)
(parameterize ([current-namespace base-ns] ; to compile (see above)
[current-library-collection-paths ; for configtab.ss
[current-library-collection-paths ; for configtab.rkt
(list collectsdir)])
(with-output-to-file src #:exists 'truncate/replace
(lambda ()
@ -292,13 +295,13 @@
(printf " (define doc-dir ~s)\n" (dir: 'doc))
(when (eq? 'shared (system-type 'link)) ; never true for now
(printf " (define dll-dir ~s)\n" (dir: 'lib)))
(printf " (define lib-dir ~s)\n" (dir: 'libplt))
(printf " (define include-dir ~s)\n" (dir: 'includeplt))
(printf " (define lib-dir ~s)\n" (dir: 'librkt))
(printf " (define include-dir ~s)\n" (dir: 'includerkt))
(printf " (define bin-dir ~s)\n" (dir: 'bin))
(printf " (define absolute-installation? #t))\n")))
;; recompile & set times as if nothing happened (don't remove .dep)
;; this requires the file to look the same on all compilations, and
;; configtab.ss generates bindings unhygienically for that reason.
;; configtab.rkt generates bindings unhygienically for that reason.
(when compile?
(when src-time (file-or-directory-modify-seconds src src-time))
(if (not zo-time)
@ -379,17 +382,17 @@
(define (move/copy-distribution move?)
(define do-tree (move/copy-tree move?))
(current-directory pltdir)
(current-directory rktdir)
(when (ormap (lambda (p) (regexp-match #rx"[.]so" p)) (ls "lib"))
(error "Cannot handle distribution of shared-libraries (yet)"))
(with-handlers ([exn? (lambda (e) (undo-changes) (raise e))])
(define binfiles (ls "bin")) ; see below
(do-tree "bin" 'bin)
(do-tree "collects" 'collects)
(do-tree "doc" 'doc #:missing 'skip) ; not included in mz distros
(do-tree "doc" 'doc #:missing 'skip) ; not included in text distros
;; (do-tree ??? 'lib) ; shared stuff goes here
(do-tree "include" 'includeplt)
(do-tree "lib" 'libplt)
(do-tree "include" 'includerkt)
(do-tree "lib" 'librkt)
(do-tree "man" 'man)
;; (when (and (not (equal? (dir: 'src) "")) (directory-exists? "src"))
;; (do-tree "src" 'src))
@ -403,17 +406,17 @@
(when (and move? (not (null? (ls))))
(error (format "leftovers in source tree: ~s" (ls))))
;; we need to know which files need fixing
(fix-executables (dir: 'bin) binfiles)
(fix-executables (dir: 'bin) (dir: 'librkt) binfiles)
(write-uninstaller)
(write-config))
(when move?
(current-directory (dirname pltdir))
(delete-directory pltdir)))
(current-directory (dirname rktdir))
(delete-directory rktdir)))
(define (make-install-copytree)
(define copytree (move/copy-tree #f))
(define origtree? (equal? "yes" (get-arg)))
(current-directory pltdir)
(current-directory rktdir)
(set! skip-filter ; skip all dot-names and compiled subdirs
(lambda (p) (regexp-match? #rx"^(?:[.].*|compiled)$" (basename p))))
(with-handlers ([exn? (lambda (e) (undo-changes) (raise e))])
@ -431,6 +434,7 @@
(define origtree? (equal? "yes" (get-arg)))
;; grab paths before we change them
(define bindir (dir: 'bin))
(define librktdir (dir: 'librkt))
(define collectsdir (dir: 'collects))
(define (remove-dest p)
(let ([pfx (and (< destdirlen (string-length p))
@ -442,7 +446,7 @@
;; no need to send an explicit binfiles argument -- this function is used
;; only when DESTDIR is present, so we're installing to a directory that
;; has only our binaries
(fix-executables bindir)
(fix-executables bindir librktdir)
(unless origtree? (write-config collectsdir)))
;; --------------------------------------------------------------------------

2
collects/teachpack/2htdp/scribblings/image.scrbl
View File

@ -868,7 +868,7 @@ the parts that fit onto @racket[scene].
(image-height (rectangle 10 0 "solid" "purple"))]
}
@defproc[(image-baseline [i image?]) (and/c integer? positive? exact?)]{
@defproc[(image-baseline [i image?]) (and/c integer? (not/c negative?) exact?)]{
Returns the distance from the top of the image to its baseline.
Unless the image was constructed with @racket[text] or @racket[text/font],
this will be the same as its height.

22
collects/tests/compiler/zo-exs.rkt Normal file
View File

@ -0,0 +1,22 @@
#lang racket
(require compiler/zo-parse
compiler/zo-marshal
tests/eli-tester)
(define (roundtrip ct)
(define bs (zo-marshal ct))
(test bs
(zo-parse (open-input-bytes bs)) => ct))
(test
(local [(define (hash-test make-hash-placeholder)
(roundtrip
(compilation-top 0
(prefix 0 empty empty)
(local [(define ht-ph (make-placeholder #f))
(define ht (make-hash-placeholder (list (cons 'g ht-ph))))]
(placeholder-set! ht-ph ht)
(make-reader-graph ht)))))]
(hash-test make-hash-placeholder)
(hash-test make-hasheq-placeholder)
(hash-test make-hasheqv-placeholder)))

2
collects/tests/eli-tester.rkt
View File

@ -216,7 +216,7 @@
=> '(#"1 test passed\n" #"2 tests passed\n")
)
;; RacUnit stuff
;; RackUnit stuff
;; (examples that should fail modified to ones that shouldn't)
#|

6
collects/tests/jpr/README.TXT Normal file
View File

@ -0,0 +1,6 @@
Some files to be checked for compatibility with new releases
of PLT-Scheme, from 4.2.5.1
Book : "Premiers Cours de Programmation avec (PLT) Scheme"
Jean-Paul Roy, Sept. 2010, 410 pages, to be published.

48
collects/tests/jpr/balle-grav-frot.ss Normal file
View File

@ -0,0 +1,48 @@
;; The first three lines of this file were inserted by DrScheme. They record metadata
;; about the language level of this file in a form that our tools can easily process.
#reader(lib "htdp-advanced-reader.ss" "lang")((modname balle-grav-frot) (read-case-sensitive #t) (teachpacks ()) (htdp-settings #(#t write mixed-fraction #t #t none #f ())))
;;; Language : advanced student
(require "valrose.ss")
(define (balle-avec-gravitation-et-frottement x0 y0 dx0 dy0)
(local [(define BALLE (bitmap "ballon.png"))
(define R (/ (image-width BALLE) 2))
(define SIZE 400)
(define FOND (place-image (text "Mouse or Space !" 18 "Blue") 200 80 (rectangle SIZE SIZE 'solid "yellow")))
(define-struct monde (x y dx dy))
(define INIT (make-monde x0 y0 dx0 dy0))
(define G #i1)
(define F #i0.95)
(define (suivant m)
(local [(define x (monde-x m))
(define y (monde-y m))
(define dx (monde-dx m))
(define dy (monde-dy m))
(define xs (+ x dx))
(define ys (+ y dy))]
(cond ((> ys (- SIZE R)) (make-monde xs (- SIZE R) (* F dx) (+ (* F (- dy)) G)))
((< xs R) (make-monde R ys (* F (- dx)) (* F (+ dy G))))
((> (+ xs R) SIZE) (make-monde (- SIZE R) ys (* F (- dx)) (* F (+ dy G))))
((< ys R) (make-monde xs R dx (+ (* F (- dy)) G)))
(else (make-monde xs ys dx (+ dy G))))))
(define (souris m x y evt)
(if (mouse=? evt "button-down")
(make-monde x y (monde-dx m) (monde-dy m))
m))
(define (clavier m key)
(if (key=? key " ")
(make-monde (+ R (random (- SIZE (* 2 R)))) (+ R (random (- SIZE (* 2 R)))) (monde-dx m) (monde-dy m))
m))
(define (dessiner m)
(place-image BALLE (monde-x m) (monde-y m) FOND))
(define (final? m)
(and (< (abs (- SIZE (monde-y m) R)) 1) (< (abs (monde-dx m)) 1) (< (abs (monde-dy m)) 1)))]
(big-bang INIT
(on-tick suivant)
(on-draw dessiner SIZE SIZE)
(on-mouse souris)
(on-key clavier)
(stop-when final?))))
(balle-avec-gravitation-et-frottement 200 200 5 15)

BIN
collects/tests/jpr/ballon.png Normal file
View File

Binary file not shown.
Side by Side

After

Width:  |  Height:  |  Size: 4.1 KiB

34
collects/tests/jpr/dessine-arbre.ss Normal file
View File

@ -0,0 +1,34 @@
;; The first three lines of this file were inserted by DrScheme. They record metadata
;; about the language level of this file in a form that our tools can easily process.
#reader(lib "htdp-advanced-reader.ss" "lang")((modname dessine-arbre) (read-case-sensitive #t) (teachpacks ()) (htdp-settings #(#t write mixed-fraction #t #t none #f ())))
;;; dessine-arbre.ss
(require "valrose.ss")
(define (objet->image x) ; x est un operateur ou une feuille
(text (if (number? x) (number->string x) (symbol->string x))
18 "black"))
(define (vert h) (rectangle 1 h 'solid "white"))
(define (horiz w) (rectangle w 1 'solid "white"))
(define (arbre->image A) ; Arbre --> Image au niveau n
(if (feuille? A)
(objet->image A)
(local [(define ig (arbre->image (fg A)))
(define wg/2 (/ (image-width ig) 2))
(define id (arbre->image (fd A)))
(define wd/2 (/ (image-width id) 2))
(define igd (beside/align 'top ig (horiz 20) id))
(define wgd/2 (/ (image-width igd) 2))]
(above (objet->image (racine A))
(beside (horiz wg/2)
(line (- wg/2 wgd/2) 20 "black")
(line (- wgd/2 wd/2) 20 "black")
(horiz wd/2))
(vert 5)
igd))))
(arbre->image '(+ (* (+ (* x (- x y)) 2) (* (- a b) longueur)) (/ (* x 2) y)))

18
collects/tests/jpr/foo.ss Normal file
View File

@ -0,0 +1,18 @@
#lang scheme
(read-accept-reader #t)
(define (chercher-definition fonc f)
(define (good-def? expr)
(and (pair? expr)
(equal? (car expr) 'define)
(or (equal? (cadr expr) fonc) ; (define fonc ...)
(and (pair? (cadr expr)) (equal? (caadr expr) fonc))))) ; (define (fonc ...) ...)
(call-with-input-file f
(lambda (p-in)
(car (filter good-def? (list-ref (read p-in) 3)))))) ; (module foo scheme (#%module-begin ...))
(define (foo x y) ; comment
(+ x y))
(printf "The definition of the function foo in this file foo.ss is :\n")
(chercher-definition 'foo "foo.ss")

40
collects/tests/jpr/jeu-du-chaos.ss Normal file
View File

@ -0,0 +1,40 @@
#lang scheme
(require graphics/graphics)
(open-graphics)
(define VIEW (open-viewport "Essai Graphics" 300 100))
(define tr-segment (draw-line VIEW)) ; un traceur de segment
(define tr-pixel (draw-pixel VIEW)) ; un traceur de pixel
(define A (make-posn 150 10))
(define B (make-posn 10 90))
(define C (make-posn 290 90))
(tr-segment A B "red")
(tr-segment B C "red")
(tr-segment C A "red")
(define M-INIT (make-posn (random 300) (random 100)))
(define (jeu-du-chaos)
(define (moyenne x y)
(/ (+ x y) 2))
(define (milieu A B)
(make-posn (moyenne (posn-x A) (posn-x B))
(moyenne (posn-y A) (posn-y B))))
(define (iter nb-fois M) ; M est le dernier point courant affiche
(if (= nb-fois 0)
(void)
(let* ((S (case (random 3) ((0) A) ((1) B) ((2) C)))
(Msuiv (milieu M S)))
(tr-pixel Msuiv "blue")
(iter (- nb-fois 1) Msuiv))))
(tr-pixel M-INIT "blue")
(iter 4000 M-INIT))
(jeu-du-chaos)

30
collects/tests/jpr/mon-script.ss Executable file
View File

@ -0,0 +1,30 @@
#!/usr/bin/env mzscheme
#lang scheme
;;; a Unix script but also a plain Scheme file...
(define (get-scheme-files) ; la A-liste ((fichier nb-defs) ...)
(map (lambda (f) (list f (nb-defs f)))
(filter (lambda (f)
(and (file-exists? f) (regexp-match ".ss$" f)))
(map path->string (directory-list)))))
(define (nb-defs f) ; number of definitions in f
(define (is-def? x) ; x is a definition ?
(and (pair? x) (equal? (car x) 'define)))
(call-with-input-file f
(lambda (p-in)
(let ((x (read p-in))) ; is f a module ?
;(printf "x=~s\n\n" x)
(if (and (pair? x) (equal? (car x) 'module)) ; yes
(length (filter is-def? (list-ref x 3))) ; one only read is enough !
(do ((e (read p-in) (read p-in)) ; non
(acc (if (is-def? x) 1 0) (if (is-def? e) (+ acc 1) acc)))
((eof-object? e) acc)))))))
(read-accept-reader #t) ; for the #lang line
(printf "Current directory is :\n ~a\n" (current-directory))
(define FILES (get-scheme-files))
(printf "It contains ~a Scheme files. " (length FILES))
(printf "Here they are, sorted by the number of definitions :\n")
(printf "~s\n" (sort FILES (lambda (L1 L2)
(<= (second L1) (second L2)))))

51
collects/tests/jpr/monte-carlo.ss Normal file
View File

@ -0,0 +1,51 @@
;;; Simulation graphique a la Monte Carlo
;;; ----> Some red points are outside the circle on the bottom right ???
#lang scheme/gui
(define RED-PEN (make-object pen% "red" 2 'solid))
(define BLACK-PEN (make-object pen% "black" 2 'solid))
(define BLUE-PEN (make-object pen% "blue" 2 'solid))
(define YELLOW-BRUSH (make-object brush% "yellow" 'solid))
(define FRAME
(new frame% (label "Monte-Carlo") (stretchable-width #f) (stretchable-height #f)))
(define VPANEL
(new vertical-panel% (parent FRAME)))
(define TEXT-FIELD
(new text-field% (parent VPANEL)
(label "Nombre de points N =")
(init-value "5000")
(callback (lambda (t e)
(when (eq? (send e get-event-type) 'text-field-enter)
(send CANVAS refresh))))))
(define MSG (new message% (parent VPANEL) (label "?") (min-width 50)))
(define CANVAS
(new canvas% (parent VPANEL)
(min-width 300) (min-height 300) (style '(border))
(paint-callback
(lambda (obj evt) ; c est le canvas et e est l'evenement
(let ((dc (send obj get-dc)))
(send dc clear)
(send dc set-pen BLUE-PEN) ; le bord du disque
(send dc set-brush YELLOW-BRUSH) ; l'interieur du disque
(send dc draw-ellipse 0 0 299 299)
(let ((s 0) (N (string->number (send TEXT-FIELD get-value))))
(do ((i 0 (+ i 1)))
((= i N) (send MSG set-label (number->string (* 4.0 (/ s N)))))
(let ((x (random 300)) (y (random 300)))
(if (< (+ (sqr (- x 150)) (sqr (- y 150))) (sqr 150))
(begin (send dc set-pen RED-PEN) (set! s (+ s 1)))
(send dc set-pen BLACK-PEN))
(send dc draw-point x y)))))))))
(define BUTTON
(new button% (parent VPANEL) (label "Go !")
(callback (lambda (obj evt)
(send CANVAS on-paint)))))
(send FRAME show #t)

52
collects/tests/jpr/streams.ss Normal file
View File

@ -0,0 +1,52 @@
#lang scheme
#|
(define-syntax scons ; SICP ==> ERROR (see Rationale of SRFI-41)
(syntax-rules ()
((scons obj s) (cons obj (delay s)))))
(define (scar s) (car s))
(define (scdr s) (force (cdr s)))
|#
(define-syntax scons
(syntax-rules ()
((scons obj s) (delay (cons obj (delay s)))))) ; from my book
(define (scar s) (car (force s)))
(define (scdr s) (force (cdr (force s))))
; -------------------------------------------------------------------
(define (element s k) ; k-th element of s
(if (= k 1)
(scar s)
(element (scdr s) (- k 1))))
(define (smerge s1 s2) ; s1 et s2 infinite ascending streams
(let ((x1 (scar s1)) (x2 (scar s2)))
(cond ((< x1 x2) (scons x1 (smerge (scdr s1) s2)))
((> x1 x2) (scons x2 (smerge s1 (scdr s2))))
(else (scons x1 (smerge (scdr s1) (scdr s2)))))))
(define (szoom x S)
(scons (* x (scar S)) (szoom x (scdr S))))
(define H (scons 1 (smerge (szoom 2 H) (smerge (szoom 3 H) (szoom 5 H))))) ; Hamming
(time (element H 20000))
;;; SRFI-41 bug
(define (sfrom n step)
(scons n (sfrom (+ n step) step)))
(define (smap f s)
(scons (f (scar s)) (smap f (scdr s))))
(define (s->list n s)
(if (= n 0)
'()
(cons (scar s) (s->list (- n 1) (scdr s)))))
(s->list 4 (smap / (sfrom 4 -1))) ; error ou (1/4 1/3 1/2 1) ?

110
collects/tests/jpr/valrose.ss Normal file
View File

@ -0,0 +1,110 @@
;;; teachpack valrose.ss - jpr, Mars 2010
#lang scheme
(require 2htdp/image 2htdp/universe) ; images et animations, version 2
(provide
(all-from-out 2htdp/image 2htdp/universe)
show match ; quelques utilitaires manquants
arbre racine fg fd fdd feuille? operateur? ; les arbres (2-3) d'expressions arithmetiques
pile-vide pile-vide? empiler depiler sommet ; les piles fonctionnelles
atome? make-neg make-fbf2 connecteur arg1 arg2) ; les FBF de la Logique d'ordre 0
; petit utilitaire pour avoir les tests dans l'editeur avec echo au toplevel
(define-syntax show
(syntax-rules ()
((show e) (begin (printf "? ~s\n" 'e) (printf "--> ~s\n" e)))))
; le type abstrait "arbre 2-3 d'expression algebrique". Toutes les operations sont O(1)
(define (arbre r Ag . Lfils) ; au moins un fils !
(cons r (cons Ag Lfils)))
(define (racine A)
(if (feuille? A)
(error (format "pas de racine pour une feuille : ~a" A))
(first A)))
(define (fg A)
(if (feuille? A)
(error (format "pas de fg pour une feuille : ~a" A))
(second A)))
(define (fd A)
(if (feuille? A)
(error (format "pas de fd pour une feuille : ~a" A))
(third A)))
(define (fdd A)
(if (or (feuille? A) (empty? (rest (rest (rest A)))))
(error (format "le fdd n'existe pas : ~a" A))
(fourth A)))
(define (feuille? obj)
(or (number? obj)
(boolean? obj)
(and (symbol? obj) (not (operateur? obj)))))
(define (operateur? obj)
(if (member obj '(+ * - / < > <= >= =)) #t #f))
; le type abstrait "pile fonctionnelle". Toutes les operations sont O(1)
(define (pile-vide)
empty)
(define (pile-vide? pile)
(empty? pile))
(define (empiler x pile)
(cons x pile))
(define (sommet pile)
(if (empty? pile)
(error "Pile vide !")
(first pile)))
(define (depiler pile)
(if (empty? pile)
(error "Pile vide !")
(rest pile)))
; le type abstrait "fbf en logique d'ordre 0"
; un parametre F denote une fbf
(define (atome? F) ; le reconnaisseur d'atomes [symboles p, q, r...]
(symbol? F))
(define (make-neg F) ; le constructeur de molecule unaire (negation)
(cond ((atome? F) (list 'non F))
((equal? (connecteur F) 'non) (arg1 F)) ; petite simplification au passage...
(else (list 'non F))))
(define (make-fbf2 r Fg Fd) ; le constructeur de molecule binaire (et, ou, =>)
(if (not (member r '(et ou =>)))
(error "Mauvais connecteur" r)
(list Fg r Fd))) ; representation interne infixee
(define (connecteur mol) ; on suppose que mol est une molecule
(if (= (length mol) 2)
(first mol) ; non
(second mol))) ; et, ou, =>
(define (arg1 mol) ; mol est une molecule
(if (= (length mol) 2)
(second mol)
(first mol)))
(define (arg2 mol) ; mol est une molecule
(if (= (length mol) 2)
(error "Molecule unaire" mol)
(third mol)))
;(printf "Module valrose : (show expr), (assoc x AL), (sleep n), (current-milliseconds), (gensym symb),
(printf "Module valrose :
(show expr), (match expr clauses ...),
(arbre r Ag Ad), (racine A), (fg A), (fd A), (fdd A), (feuille? A), (operateur? obj),
(pile-vide? P), (pile-vide), (empiler x P), (sommet P), (depiler P),
(atome? F), (make-neg F), (make-fbf2 r Fg Fd), (connecteur mol), (arg1 mol), (arg2 mol)\n")

9
collects/tests/racket/benchmarks/common/README.txt
View File

@ -22,17 +22,13 @@ run (as reported by --show). Similarly, if the first named
implementation/benchmak starts with "no-", the default set is used
minus the "no-"-specified implementation/benchmark.
The output is a comment line
; <date and time>
and then a series of lines of the form
The output is a series of lines of the form
[<impl> <benchmark> (<cpu-msec> <real-msec> <gc-msec>) <compile-msec>]
where #f means that the information is unavailable, or that the
benchmark wasn't run due to an implementation limitation. The
<cpu-msec> and <compile-msec> parts are #f only when the benchmark
wasn't run.
All benchmarks must be run from the directory containing this file.
Most bechmarks were obtained from
http://www.cs.cmu.edu/afs/cs/project/ai-repository/ai/lang/scheme/code/bench/gabriel/
http://www.ccs.neu.edu/home/will/GC/sourcecode.html
@ -40,6 +36,9 @@ Most bechmarks were obtained from
Files that end in ".sch" are supposed to be standard Scheme plus `time'.
Files that end in ".rkt" are Racket wrapper modules or helper scripts.
Files that end in "-typed.rktl" are Typed Scheme versions of the benchmarks.
Files that end in "-[non-]optimizing.rkt" are Typed Scheme wrappers
that turn Typed Scheme's optimizer on or off.
To build <benchmark>.sch directly with Gambit, Bigloo, or Chicken:
racket -f mk-gambit.rktl <benchmark> ; gsi -:m10000 <benchmark>.o1

2
collects/tests/racket/benchmarks/common/auto.rkt
View File

@ -574,7 +574,7 @@ exec racket -qu "$0" ${1+"$@"}
;; Run benchmarks -------------------------------
(rprintf "; ~a\n" (date->string (seconds->date (current-seconds)) #t))
#;(rprintf "; ~a\n" (date->string (seconds->date (current-seconds)) #t))
(parameterize ([current-directory bm-directory])
(for-each (lambda (impl)

2
collects/tests/racket/benchmarks/common/conform.rkt
View File

@ -1,2 +1,2 @@
(module conform "wrap.ss")
(module conform "wrap.ss" r5rs)

8
collects/tests/racket/benchmarks/common/cpstack-typed.rktl
View File

@ -34,4 +34,10 @@
;;; call: (cpstak 18 12 6)
(time (cpstak 18 12 2))
(let ((input (with-input-from-file "input.txt" read)))
(time (let: loop : Integer
((n : Integer 20) (v : Integer 0))
(if (zero? n)
v
(loop (- n 1)
(cpstak 18 12 (if input 2 0)))))))

7
collects/tests/racket/benchmarks/common/cpstack.sch
View File

@ -31,4 +31,9 @@
;;; call: (cpstak 18 12 6)
(time (cpstak 18 12 2))
(let ((input (with-input-from-file "input.txt" read)))
(time (let loop ((n 20) (v 0))
(if (zero? n)
v
(loop (- n 1)
(cpstak 18 12 (if input 2 0)))))))

50
collects/tests/racket/benchmarks/common/ctak-typed.rktl
View File

@ -23,42 +23,42 @@
(: ctak (Integer Integer Integer -> Integer))
(define (ctak x y z)
((inst call-with-current-continuation Integer Integer)
(lambda (k)
(call-with-current-continuation
(lambda: ((k : (Integer -> Nothing)))
(ctak-aux k x y z))))
(: ctak-aux ((Integer -> Integer) Integer Integer Integer -> Integer))
(define (ctak-aux k x y z)
(cond ((not (< y x)) ;xy
(k z))
(else ((inst call-with-current-continuation Integer Integer)
(lambda (dummy)
(ctak-aux
k
((inst call-with-current-continuation Integer Integer)
(lambda (k)
(ctak-aux k
(- x 1)
y
z)))
((inst call-with-current-continuation Integer Integer)
(lambda (k)
(ctak-aux k
(- y 1)
z
x)))
((inst call-with-current-continuation Integer Integer)
(lambda (k)
(ctak-aux k
(- z 1)
x
y)))))))))
(else (call-with-current-continuation
(let ([v (ctak-aux
k
(call-with-current-continuation
(lambda: ((k : (Integer -> Nothing)))
(ctak-aux k
(- x 1)
y
z)))
(call-with-current-continuation
(lambda: ((k : (Integer -> Nothing)))
(ctak-aux k
(- y 1)
z
x)))
(call-with-current-continuation
(lambda: ((k : (Integer -> Nothing)))
(ctak-aux k
(- z 1)
x
y))))])
(lambda (dummy) v))))))
;;; call: (ctak 18 12 6)
(let ((input (with-input-from-file "input.txt" read)))
(time (let: loop : Integer
((n : Integer 8) (v : Integer 0))
((n : Integer 25) (v : Integer 0))
(if (zero? n)
v
(loop (- n 1)

2
collects/tests/racket/benchmarks/common/ctak.sch
View File

@ -53,7 +53,7 @@
;;; call: (ctak 18 12 6)
(let ((input (with-input-from-file "input.txt" read)))
(time (let loop ((n 8) (v 0))
(time (let loop ((n 25) (v 0))
(if (zero? n)
v
(loop (- n 1)

2
collects/tests/racket/benchmarks/common/dderiv-typed.rktl
View File

@ -95,7 +95,7 @@
(: run ( -> Void))
(define (run)
(do ((i 0 (+ i 1)))
((= i 50000))
((= i 1000000))
(dderiv '(+ (* 3 x x) (* a x x) (* b x) 5))
(dderiv '(+ (* 3 x x) (* a x x) (* b x) 5))
(dderiv '(+ (* 3 x x) (* a x x) (* b x) 5))

2
collects/tests/racket/benchmarks/common/dderiv.sch
View File

@ -75,7 +75,7 @@
(define (run)
(do ((i 0 (+ i 1)))
((= i 50000))
((= i 1000000))
(dderiv '(+ (* 3 x x) (* a x x) (* b x) 5))
(dderiv '(+ (* 3 x x) (* a x x) (* b x) 5))
(dderiv '(+ (* 3 x x) (* a x x) (* b x) 5))

2
collects/tests/racket/benchmarks/common/deriv-typed.rktl
View File

@ -56,7 +56,7 @@
(: run ( -> Void))
(define (run)
(do ((i 0 (+ i 1)))
((= i 50000))
((= i 1000000))
(deriv '(+ (* 3 x x) (* a x x) (* b x) 5))
(deriv '(+ (* 3 x x) (* a x x) (* b x) 5))
(deriv '(+ (* 3 x x) (* a x x) (* b x) 5))

2
collects/tests/racket/benchmarks/common/deriv.sch
View File

@ -46,7 +46,7 @@
(define (run)
(do ((i 0 (+ i 1)))
((= i 50000))
((= i 1000000))
(deriv '(+ (* 3 x x) (* a x x) (* b x) 5))
(deriv '(+ (* 3 x x) (* a x x) (* b x) 5))
(deriv '(+ (* 3 x x) (* a x x) (* b x) 5))

2
collects/tests/racket/benchmarks/common/destruct.rkt
View File

@ -1,2 +1,2 @@
(module destruct "wrap.ss")
(module destruct "wrap.ss" r5rs)

16
collects/tests/racket/benchmarks/common/div-typed.rktl
View File

@ -33,21 +33,21 @@
(cond ((null? l) '())
(else (cons (car l) (recursive-div2 (cddr l))))))
(: test-1 ((Listof Any) -> (Listof Any)))
(: test-1 ((Listof Any) -> Void))
(define (test-1 l)
(do: : (Listof Any)
(do: : Void
((i : Integer 3000 (- i 1)))
((= i 0) '())
((= i 0))
(iterative-div2 l)
(iterative-div2 l)
(iterative-div2 l)
(iterative-div2 l)))
(: test-2 ((Listof Any) -> (Listof Any)))
(: test-2 ((Listof Any) -> Void))
(define (test-2 l)
(do: : (Listof Any)
(do: : Void
((i : Integer 3000 (- i 1)))
((= i 0) '())
((= i 0))
(recursive-div2 l)
(recursive-div2 l)
(recursive-div2 l)
@ -57,8 +57,8 @@
;;; for the recursive test call: (test-2 *ll*)
(let ((input (with-input-from-file "input.txt" read)))
(time (let: loop : (U Integer (Listof Any))
((n : Integer 10) (v : (U Integer (Listof Any)) 0))
(time (let: loop : (Pair Void Void)
((n : Integer 200) (v : (Pair Void Void) (cons (void) (void))))
(if (zero? n)
v
(loop (- n 1)

2
collects/tests/racket/benchmarks/common/div.sch
View File

@ -48,7 +48,7 @@
;;; for the recursive test call: (test-2 *ll*)
(let ((input (with-input-from-file "input.txt" read)))
(time (let loop ((n 10) (v 0))
(time (let loop ((n 200) (v 0))
(if (zero? n)
v
(loop (- n 1)

2
collects/tests/racket/benchmarks/common/dynamic.rkt
View File

@ -1,2 +1,2 @@
(module dynamic "wrap.ss")
(module dynamic "wrap.ss" r5rs)

18
collects/tests/racket/benchmarks/common/fft-typed.rktl
View File

@ -81,9 +81,9 @@
(set! i (+ i 1))
(cond ((< i n)
(l3))))
(do: : Null
(do: : Void
((l : Integer 1 (+ l 1))) ;loop thru stages (syntax converted
((> l m) '()) ; from old MACLISP style \bs)
((> l m)) ; from old MACLISP style \bs)
(set! le (expt 2 l))
(set! le1 (quotient le 2))
(set! ur 1.0)
@ -91,13 +91,13 @@
(set! wr (cos (/ pi le1)))
(set! wi (sin (/ pi le1)))
;; loop thru butterflies
(do: : Null
(do: : Void
((j : Integer 1 (+ j 1)))
((> j le1) '())
((> j le1))
;; do a butterfly
(do: : Null
(do: : Void
((i : Integer j (+ i le)))
((> i n) '())
((> i n))
(set! ip (+ i le1))
(set! tr (- (* (vector-ref ar ip) ur)
(* (vector-ref ai ip) ui)))
@ -115,11 +115,11 @@
;;; the timer which does 10 calls on fft
(: fft-bench ( -> Null))
(: fft-bench ( -> Void))
(define (fft-bench)
(do: : Null
(do: : Void
((ntimes : Integer 0 (+ ntimes 1)))
((= ntimes 1000) '())
((= ntimes 5000))
(fft *re* *im*)))
;;; call: (fft-bench)

4
collects/tests/racket/benchmarks/common/fft.sch
View File

@ -71,7 +71,7 @@
(let l6 ()
(cond ((< k j)
(set! j (- j k))
(set! k (/ k 2))
(set! k (quotient k 2))
(l6))))
(set! j (+ j k))
(set! i (+ i 1))
@ -110,7 +110,7 @@
(define (fft-bench)
(do ((ntimes 0 (+ ntimes 1)))
((= ntimes 1000))
((= ntimes 5000))
(fft *re* *im*)))
;;; call: (fft-bench)

14
collects/tests/racket/benchmarks/common/graphs-typed.rktl
View File

@ -141,7 +141,7 @@
state))))
; Iterate over the integers [0, limit).
(: gnatural-for-each (Integer (Integer -> Any) -> Null))
(: gnatural-for-each (Integer (Integer -> Any) -> Void))
(define gnatural-for-each
(lambda (limit proc!)
'(assert (and (integer? limit)
@ -150,10 +150,10 @@
limit)
'(assert (procedure? proc!)
proc!)
(do: : Null
(do: : Void
((i : Integer 0
(+ i 1)))
((= i limit) '())
((= i limit))
(proc! i))))
(: natural-for-all? (Integer (Integer -> Boolean) -> Boolean))
@ -686,10 +686,8 @@
(lambda: ((t : Integer))
(if (vector-ref from-m t)
(begin ; [wdc - was when]
(vector-set! from-f t #t)
#t)
#t)))
#t)
(vector-set! from-f t #t))
#t))))
#t)))))))
res)))
@ -709,7 +707,7 @@
(let ((input (with-input-from-file "input.txt" read)))
(time
(let: loop : (Listof RDG)
((n : Integer 3) (v : (Listof RDG) '()))
((n : Integer 45) (v : (Listof RDG) '()))
(if (zero? n)
v
(loop (- n 1)

2
collects/tests/racket/benchmarks/common/graphs.sch
View File

@ -638,7 +638,7 @@
(let ((input (with-input-from-file "input.txt" read)))
(time
(let loop ((n 3) (v 0))
(let loop ((n 45) (v 0))
(if (zero? n)
v
(loop (- n 1)

2
collects/tests/racket/benchmarks/common/lattice.rkt
View File

@ -1,2 +1,2 @@
(module lattice "wrap.ss")
(module lattice "wrap.ss" r5rs)

6
collects/tests/racket/benchmarks/common/lattice2-typed.rktl
View File

@ -231,4 +231,8 @@
(count-maps l3 l2)
(count-maps l4 l4)))
(time (run))
(time (let: loop : Integer ((n : Integer 3) (v : Integer 0))
(if (zero? n)
v
(loop (- n 1)
(run)))))

6
collects/tests/racket/benchmarks/common/lattice2.sch
View File

@ -202,4 +202,8 @@
(count-maps l3 l2)
(count-maps l4 l4)))
(time (run))
(time (let loop ((n 3) (v 0))
(if (zero? n)
v
(loop (- n 1)
(run)))))

2
collects/tests/racket/benchmarks/common/maze.rkt
View File

@ -1,2 +1,2 @@
(module maze "wrap.ss")
(module maze "wrap.ss" r5rs)

2
collects/tests/racket/benchmarks/common/maze2.rkt
View File

@ -1,2 +1,2 @@
(module maze2 "wrap.ss")
(module maze2 "wrap.ss" r5rs)

20
collects/tests/racket/benchmarks/common/mazefun-typed.rktl
View File

@ -150,7 +150,7 @@
(make-matrix n m (lambda: ((i : Integer) (j : Integer))
(if (and (even? i) (even? j))
(cons i j)
'(0 . 0)))))
#f))))
(possible-holes
(concat
(for 0 n (lambda: ((i : Integer))
@ -166,13 +166,14 @@
(lambda (cave)
(matrix-map (lambda (x) (if x '_ '*)) cave)))
(: pierce (Pos (Matrix Pos) -> (Matrix Pos)))
(: pierce (Pos (Matrix (Option Pos)) -> (Matrix (Option Pos))))
(define pierce
(lambda (pos cave)
(let: ((i : Integer (car pos)) (j : Integer (cdr pos)))
(matrix-write cave i j pos))))
(: pierce-randomly ((Listof Pos) (Matrix Pos) -> (Matrix Pos)))
(: pierce-randomly ((Listof Pos) (Matrix (Option Pos))
-> (Matrix (Option Pos))))
(define pierce-randomly
(lambda (possible-holes cave)
(if (null? possible-holes)
@ -181,7 +182,7 @@
(pierce-randomly (cdr possible-holes)
(try-to-pierce hole cave))))))
(: try-to-pierce (Pos (Matrix Pos) -> (Matrix Pos)))
(: try-to-pierce (Pos (Matrix (Option Pos)) -> (Matrix (Option Pos))))
(define try-to-pierce
(lambda (pos cave)
(let ((i (car pos)) (j (cdr pos)))
@ -192,24 +193,25 @@
ncs))
cave
(pierce pos
(foldl (lambda: ((c : (Matrix Pos)) (nc : Pos))
(foldl (lambda: ((c : (Matrix (Option Pos))) (nc : Pos))
(change-cavity c nc pos))
cave
ncs)))))))
(: change-cavity ((Matrix Pos) Pos Pos -> (Matrix Pos)))
(: change-cavity ((Matrix (Option Pos)) Pos Pos -> (Matrix (Option Pos))))
(define change-cavity
(lambda (cave pos new-cavity-id)
(let ((i (car pos)) (j (cdr pos)))
(change-cavity-aux cave pos new-cavity-id (matrix-read cave i j)))))
(: change-cavity-aux ((Matrix Pos) Pos Pos Pos -> (Matrix Pos)))
(: change-cavity-aux ((Matrix (Option Pos)) Pos Pos (Option Pos)
-> (Matrix (Option Pos))))
(define change-cavity-aux
(lambda (cave pos new-cavity-id old-cavity-id)
(let ((i (car pos)) (j (cdr pos)))
(let ((cavity-id (matrix-read cave i j)))
(if (equal? cavity-id old-cavity-id)
(foldl (lambda: ((c : (Matrix Pos)) (nc : Pos))
(foldl (lambda: ((c : (Matrix (Option Pos))) (nc : Pos))
(change-cavity-aux c nc new-cavity-id old-cavity-id))
(matrix-write cave i j new-cavity-id)
(neighboring-cavities pos cave))
@ -237,7 +239,7 @@
(let ((input (with-input-from-file "input.txt" read)))
(time (let: loop : (U (Matrix (U '_ '*)) 'error)
((n : Integer 500) (v : (U (Matrix (U '_ '*)) 'error) '()))
((n : Integer 10000) (v : (U (Matrix (U '_ '*)) 'error) '()))
(if (zero? n)
v
(loop (- n 1)

2
collects/tests/racket/benchmarks/common/mazefun.sch
View File

@ -199,7 +199,7 @@
(let ((input (with-input-from-file "input.txt" read)))
(time (let loop ((n 500) (v 0))
(time (let loop ((n 10000) (v 0))
(if (zero? n)
v
(loop (- n 1)

10
collects/tests/racket/benchmarks/common/nestedloop-typed.rktl
View File

@ -59,6 +59,10 @@
(loop6 (+ i6 1) (+ result 1)))))))))))))))
(let ((cnt (if (with-input-from-file "input.txt" read) 18 1)))
(time (list
(loops cnt)
(func-loops cnt))))
(time (let: loop : (Listof Integer) ((n : Integer 20) (v : (Listof Integer) '()))
(if (zero? n)
v
(loop (- n 1)
(list
(loops cnt)
(func-loops cnt)))))))

11
collects/tests/racket/benchmarks/common/nestedloop.sch
View File

@ -58,7 +58,10 @@
(loop6 (+ i6 1) (+ result 1)))))))))))))))
(let ((cnt (if (with-input-from-file "input.txt" read) 18 1)))
(time (list
(loops cnt)
(func-loops cnt))))
(time (let loop ((n 20) (v 0))
(if (zero? n)
v
(loop (- n 1)
(list
(loops cnt)
(func-loops cnt)))))))

2
collects/tests/racket/benchmarks/common/nfa-typed.rktl
View File

@ -50,7 +50,7 @@
'fail))
(time (let ((input (string->list (string-append (make-string 133 #\a) "bc"))))
(let: loop : 'done ((n : Integer 150000))
(let: loop : 'done ((n : Integer 2000000))
(if (zero? n)
'done
(begin

2
collects/tests/racket/benchmarks/common/nfa.sch
View File

@ -42,7 +42,7 @@
'fail))
(time (let ((input (string->list (string-append (make-string 133 #\a) "bc"))))
(let loop ((n 150000))
(let loop ((n 2000000))
(if (zero? n)
'done
(begin

2
collects/tests/racket/benchmarks/common/nqueens-typed.rktl
View File

@ -37,7 +37,7 @@
(let ((input (with-input-from-file "input.txt" read)))
(time
(let: loop : Integer ((n : Integer 500) (v : Integer 0))
(let: loop : Integer ((n : Integer 10000) (v : Integer 0))
(if (zero? n)
v
(loop (- n 1) (nqueens (if input 8 0)))))))

2
collects/tests/racket/benchmarks/common/nqueens.sch
View File

@ -31,7 +31,7 @@
(let ((input (with-input-from-file "input.txt" read)))
(time
(let loop ((n 500) (v 0))
(let loop ((n 10000) (v 0))
(if (zero? n)
v
(loop (- n 1) (nqueens (if input 8 0)))))))

4
collects/tests/racket/benchmarks/common/paraffins-typed.rktl
View File

@ -1,7 +1,5 @@
;;; PARAFFINS -- Compute how many paraffins exist with N carbon atoms.
(require/typed scheme/base (collect-garbage ( -> Void)))
(define-type Radical (Rec Radical (U 'C 'H 'BCP 'CCP (Vectorof Radical))))
(: gen (Integer -> (Vectorof (Listof Radical))))
@ -189,7 +187,7 @@
(let ((input (with-input-from-file "input.txt" read)))
(time
(let: loop : Integer
((n : Integer 100) (v : Integer 0))
((n : Integer 4000) (v : Integer 0))
(if (zero? n)
v
(loop (- n 1) (nb (if input 17 0)))))))

2
collects/tests/racket/benchmarks/common/paraffins.sch
View File

@ -169,7 +169,7 @@
(let ((input (with-input-from-file "input.txt" read)))
(time
(let loop ((n 100) (v 0))
(let loop ((n 4000) (v 0))
(if (zero? n)
v
(loop (- n 1) (nb (if input 17 0)))))))

2
collects/tests/racket/benchmarks/common/peval.rkt
View File

@ -1,2 +1,2 @@
(module peval "wrap.ss")
(module peval "wrap.ss" r5rs)

26
collects/tests/racket/benchmarks/common/puzzle-typed.rktl
View File

@ -89,14 +89,14 @@
(+ (vector-ref *piececount* (vector-ref *class* i)) 1))))
(: trial (Integer -> Boolean))
(: trial (Integer -> Any))
(define (trial j)
(let: ((k : Integer 0))
(call-with-current-continuation
(lambda: ((return : (Boolean -> Nothing)))
(do: : Boolean
(do: : Any
((i : Integer 0 (+ i 1)))
((> i typemax) (set! *kount* (+ *kount* 1)) #f)
((> i typemax) (set! *kount* (+ *kount* 1)) '())
(cond
((not
(zero?
@ -123,15 +123,15 @@
(: definePiece (Integer Integer Integer Integer -> Void))
(define (definePiece iclass ii jj kk)
(let: ((index : Integer 0))
(do: : Null
(do: : Void
((i : Integer 0 (+ i 1)))
((> i ii) '())
(do: : Null
((> i ii))
(do: : Void
((j : Integer 0 (+ j 1)))
((> j jj) '())
(do: : Null
((> j jj))
(do: : Void
((k : Integer 0 (+ k 1)))
((> k kk) '())
((> k kk))
(set! index (+ i (* *d* (+ j (* *d* k)))))
(vector-set! (vector-ref *p* *iii*) index #t))))
(vector-set! *class* *iii* iclass)
@ -192,6 +192,8 @@
;;; call: (start)
(time (start))
(time (let: loop : Void ((n : Integer 50) (v : Void (void)))
(if (zero? n)
v
(loop (- n 1)
(start)))))

8
collects/tests/racket/benchmarks/common/puzzle.sch
View File

@ -165,6 +165,8 @@
;;; call: (start)
(time (start))
(time (let loop ((n 50) (v 0))
(if (zero? n)
v
(loop (- n 1)
(start)))))

2
collects/tests/racket/benchmarks/common/scheme.rkt
View File

@ -1,2 +1,2 @@
(module scheme "wrap.ss")
(module scheme "wrap.ss" r5rs)

2
collects/tests/racket/benchmarks/common/sort1.rkt
View File

@ -1,2 +1,2 @@
(module sort1 "wrap.ss")
(module sort1 "wrap.ss" r5rs)

2
collects/tests/racket/benchmarks/common/tak-typed.rktl
View File

@ -24,7 +24,7 @@
(let ((input (with-input-from-file "input.txt" read)))
(time
(let: loop : Integer ((n : Integer 500) (v : Integer 0))
(let: loop : Integer ((n : Integer 15000) (v : Integer 0))
(if (zero? n)
v
(loop (- n 1) (tak 18 12 (if input 6 0)))))))

2
collects/tests/racket/benchmarks/common/tak.sch
View File

@ -22,7 +22,7 @@
(let ((input (with-input-from-file "input.txt" read)))
(time
(let loop ((n 500) (v 0))
(let loop ((n 15000) (v 0))
(if (zero? n)
v
(loop (- n 1) (tak 18 12 (if input 6 0)))))))

9
collects/tests/racket/benchmarks/common/takl-typed.rktl
View File

@ -43,5 +43,10 @@
;;; call: (mas 18l 12l 6l)
(let ((v (if (with-input-from-file "input.txt" read) l6l '())))
(time (mas l18l l12l v)))
(let ((x (if (with-input-from-file "input.txt" read) l6l '())))
(time (let: loop : (Listof Integer)
((n : Integer 20) (v : (Listof Integer) '()))
(if (zero? n)
v
(loop (- n 1)
(mas l18l l12l x))))))

8
collects/tests/racket/benchmarks/common/takl.sch
View File

@ -39,5 +39,9 @@
;;; call: (mas 18l 12l 6l)
(let ((v (if (with-input-from-file "input.txt" read) l6l '())))
(time (mas l18l l12l v)))
(let ((x (if (with-input-from-file "input.txt" read) l6l '())))
(time (let loop ((n 20) (v 0))
(if (zero? n)
v
(loop (- n 1)
(mas l18l l12l x))))))

2
collects/tests/racket/benchmarks/common/takr-typed.rktl
View File

@ -619,7 +619,7 @@
(let ((input (with-input-from-file "input.txt" read)))
(time
(let: loop : Integer ((n : Integer 500) (v : Integer 0))
(let: loop : Integer ((n : Integer 1500) (v : Integer 0))
(if (zero? n)
v
(loop (- n 1) (tak0 18 12 (if input 6 0)))))))

2
collects/tests/racket/benchmarks/common/takr.sch
View File

@ -519,7 +519,7 @@
(let ((input (with-input-from-file "input.txt" read)))
(time
(let loop ((n 500) (v 0))
(let loop ((n 1500) (v 0))
(if (zero? n)
v
(loop (- n 1) (tak0 18 12 (if input 6 0)))))))

2
collects/tests/racket/benchmarks/common/takr2-typed.rktl
View File

@ -623,7 +623,7 @@
(let ((input (with-input-from-file "input.txt" read)))
(time
(let: loop : Integer ((n : Integer 500) (v : Integer 0))
(let: loop : Integer ((n : Integer 1500) (v : Integer 0))
(if (zero? n)
v
(loop (- n 1) (tak 18 12 (if input 6 0)))))))

2
collects/tests/racket/benchmarks/common/takr2.sch
View File

@ -522,7 +522,7 @@
(let ((input (with-input-from-file "input.txt" read)))
(time
(let loop ((n 500) (v 0))
(let loop ((n 1500) (v 0))
(if (zero? n)
v
(loop (- n 1) (tak 18 12 (if input 6 0)))))))

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