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

Merge branch 'master' of git.racket-lang.org:plt

Browse Source
This commit is contained in:
Jay McCarthy 2010-04-26 13:42:54 -06:00
commit a8027280b5
275 changed files with 6339 additions and 4942 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

5
.gitignore vendored
View File

@ -9,3 +9,8 @@
# a common convenient place to set the PLTADDON directory to # a common convenient place to set the PLTADDON directory to
/add-on/ /add-on/
# common backups, autosaves, and lock files
*~
\#*
.#*

24
collects/2htdp/private/img-err.ss
View File

@ -20,6 +20,7 @@
lang/posn lang/posn
scheme/gui/base scheme/gui/base
"../../mrlib/image-core.ss" "../../mrlib/image-core.ss"
(prefix-in cis: "../../mrlib/cache-image-snip.ss")
(for-syntax scheme/base (for-syntax scheme/base
scheme/list)) scheme/list))
@ -270,9 +271,26 @@
[else arg])) [else arg]))
(define (image-snip->image is) (define (image-snip->image is)
(bitmap->image (send is get-bitmap) (let ([bm (send is get-bitmap)])
(or (send is get-bitmap-mask) (cond
(send (send is get-bitmap) get-loaded-mask)))) [(not bm)
;; this might mean we have a cache-image-snip%
;; or it might mean we have a useless snip.
(let-values ([(w h) (if (is-a? is cis:cache-image-snip%)
(send is get-size)
(values 0 0))])
(make-image (make-polygon
(list (make-point 0 0)
(make-point w 0)
(make-point w h)
(make-point 0 h))
'solid "black")
(make-bb w h h)
#f))]
[else
(bitmap->image bm
(or (send is get-bitmap-mask)
(send bm get-loaded-mask)))])))
(define (bitmap->image bm [mask-bm (send bm get-loaded-mask)]) (define (bitmap->image bm [mask-bm (send bm get-loaded-mask)])
(let ([w (send bm get-width)] (let ([w (send bm get-width)]

9
collects/2htdp/tests/test-image.ss
View File

@ -46,6 +46,7 @@
scheme/class scheme/class
scheme/gui/base scheme/gui/base
schemeunit schemeunit
(prefix-in 1: htdp/image)
(only-in lang/htdp-advanced equal~?)) (only-in lang/htdp-advanced equal~?))
(require (for-syntax scheme/base)) (require (for-syntax scheme/base))
@ -202,6 +203,14 @@
(check-close (image-height (rotate 30 (ellipse 0 100 'solid 'blue))) (check-close (image-height (rotate 30 (ellipse 0 100 'solid 'blue)))
(ceiling (* (cos (* pi 1/6)) 100))) (ceiling (* (cos (* pi 1/6)) 100)))
;; zero-sized htdp/image images should also work
(test (image-width (1:text "" 18 "blue"))
=>
0)
(test (image-height (1:rectangle 10 0 'solid "red"))
=>
0)
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;; ;;
;; polygon equality ;; polygon equality

77
collects/2htdp/universe-request.txt Normal file
View File

@ -0,0 +1,77 @@
From: Robby Findler <robby@eecs.northwestern.edu>
Date: June 16, 2009 5:16:50 PM EDT
To: Matthias Felleisen <matthias@ccs.neu.edu>
Subject: Fwd: Universe key handler request
I was cleaning out my inbox and found this. Probably too late, but I
thought I'd still pass it on in case you'd forgotten.
Robby
Forwarded conversation
Subject: Universe key handler request
------------------------
From: Robby Findler <robby@eecs.northwestern.edu>
Date: Tue, Feb 24, 2009 at 9:22 AM
To: matthias@ccs.neu.edu
Can you make the key handlers in universe take 3 arguments instead of
2? That is, it takes a world, a key-event and a boolean where the key
event does not include 'release and the Boolean indicates if the key
was pressed down or not.
Robby
----------
From: Matthias Felleisen <matthias@ccs.neu.edu>
Date: Tue, Feb 24, 2009 at 9:24 AM
To: Robby Findler <robby@eecs.northwestern.edu>
I guess. Why is this useful?
----------
From: Matthias Felleisen <matthias@ccs.neu.edu>
Date: Tue, Feb 24, 2009 at 9:25 AM
To: Robby Findler <robby@eecs.northwestern.edu>
P.S. and how would you signal the release of a key?
----------
From: Robby Findler <robby@eecs.northwestern.edu>
Date: Tue, Feb 24, 2009 at 9:29 AM
To: Matthias Felleisen <matthias@ccs.neu.edu>
the Boolean!
It is useful for multiple key presses that overlap but it is also
useful that it matches what you think when you look at a keyboard.
Robby
----------
From: Matthias Felleisen <matthias@ccs.neu.edu>
Date: Tue, Feb 24, 2009 at 10:19 AM
To: Robby Findler <robby@eecs.northwestern.edu>
Wait. Say I press a key
Ê*------------------------------||-------------------------------------*
Êkey-press Ê Êholding it down Êthe event handler is called with #t Ê more key presses, no release?
when does the program find out that I have released the key?

117
collects/2htdp/universe-syntax-parse.ss Normal file
View File

@ -0,0 +1,117 @@
#lang scheme/load
(module auxs scheme
(define (world->world> proc0)
(printf "a world to world function\n")
proc0)
(define (positive-number> rate0)
(printf "a positive number")
rate0)
;; String String Syntax[id] -> Syntax
(define (pre-post-name pre post name)
(datum->syntax
name (string->symbol (string-append pre (symbol->string (syntax-e name)) post))))
(provide (all-defined-out)))
(module clauses scheme
(require syntax/parse (for-syntax scheme 'auxs unstable/syntax)
(for-template scheme/base 'auxs))
(define-syntax (define-clause stx)
(syntax-case stx ()
[(_ name (proc p-ctc) (rate r-ctc) ...)
(with-syntax ([name-clause (pre-post-name "" "-clause" #'name)]
[(rate0 ...) (generate-temporaries #'(rate ...))])
(with-syntax ([((thing ...) ...) #'((#:with rate #'(r-ctc rate0)) ...)])
#`
(begin
(provide name name-clause)
(define-syntax (name . x)
(raise-syntax-error 'name "used out of context" x))
(define-syntax-class name-clause
#:description (format "~a" 'name)
#:literals (name)
#:attributes (proc rate ...)
(pattern (name proc0:expr)
#:with (rate0 ...) (map (lambda (x) #'0) '(rate0 ...))
#:with proc #'(world->world proc0)
thing ... ...)
(pattern (on-tick proc0:expr (~var rate0 expr) ...)
#:with proc #'(world->world> proc0)
thing ... ...))
)))]))
(define-clause on-mouse (proc world-nat-nat-mouse->world))
(define-clause on-tick (proc world->world) (rate (lambda (x) 1/28)))
;; --- on-tick ---
#|
(define-syntax (on-tick . x)
(raise-syntax-error 'on-tick "used out of context" x))
(define-syntax-class on-tick-clause
#:description "on tick"
#:literals (on-tick)
#:attributes (proc rate)
(pattern (on-tick proc0:expr)
#:with proc #'(world->world proc0)
#:with rate #'1/28)
(pattern (on-tick proc0:expr rate0:expr)
#:with proc #'(world->world> proc0)
#:with rate #'(positive-number> rate0)))
(provide on-tick on-tick-clause)
|#
;; --- on-draw ---
(define-syntax (on-draw . x)
(raise-syntax-error 'on-draw "used out of context" x))
(define-syntax-class on-draw-clause
#:description "on draw"
#:literals (on-draw)
#:attributes (proc width height)
(pattern (on-draw proc0:expr)
#:with proc #'(wrap worldxkey->world proc0)
#:with width #'#f
#:with height #'#f)
(pattern (on-draw proc0:expr width0:expr height0:expr)
#:with proc #'(worldxkey->world> proc0)
#:with width #'(natural-number> width0)
#:with height #'(natural-number> height0)))
(provide on-draw on-draw-clause))
(module utest scheme
(require (for-syntax syntax/parse 'clauses))
(define-syntax (big-bang stx)
(syntax-parse stx
[(big-bang world0:expr
(~or (~optional otc:on-tick-clause)
; (~optional omc:on-mouse-clause)
(~optional odc:on-draw-clause))
...)
#`(printf "~s\n"
'(bb world0
#,(if (attribute otc)
#'otc.rate
#'1/28)
#,(if (attribute odc)
#'odc.proc
#''not-draw)))]))
(big-bang 0)
(big-bang 1 (on-tick add1))
(big-bang 2 (on-tick add1 1/2))
(big-bang 3 (on-draw add1 1/2 1/3))
; (big-bang 4 (on-mouse add1 1 2))
)
(require 'utest)

2
collects/2htdp/universe.ss
View File

@ -7,8 +7,6 @@
-- take out counting; replace by 0.25 delay -- take out counting; replace by 0.25 delay
-- make window resizable :: why -- make window resizable :: why
-- what if clauses are repeated in world and/or universe descriptions?
-- what if the initial world or universe state is omitted? the error message is bad then.
|# |#
(require (for-syntax "private/syn-aux.ss" scheme/function) (require (for-syntax "private/syn-aux.ss" scheme/function)

2
collects/compiler/commands/c-ext.ss
View File

@ -7,7 +7,7 @@
(require (prefix-in compiler:option: "../option.ss") (require (prefix-in compiler:option: "../option.ss")
"../compiler.ss" "../compiler.ss"
tool/command-name raco/command-name
mzlib/cmdline mzlib/cmdline
dynext/file dynext/file
dynext/compile dynext/compile

2
collects/compiler/commands/decompile.ss
View File

@ -1,6 +1,6 @@
#lang scheme/base #lang scheme/base
(require scheme/cmdline (require scheme/cmdline
tool/command-name raco/command-name
compiler/zo-parse compiler/zo-parse
compiler/decompile compiler/decompile
scheme/pretty) scheme/pretty)

2
collects/compiler/commands/exe-dir.ss
View File

@ -1,6 +1,6 @@
#lang scheme/base #lang scheme/base
(require scheme/cmdline (require scheme/cmdline
tool/command-name raco/command-name
compiler/distribute) compiler/distribute)
(define verbose (make-parameter #f)) (define verbose (make-parameter #f))

2
collects/compiler/commands/exe.ss
View File

@ -1,6 +1,6 @@
#lang scheme/base #lang scheme/base
(require scheme/cmdline (require scheme/cmdline
tool/command-name raco/command-name
compiler/private/embed compiler/private/embed
dynext/file) dynext/file)

2
collects/compiler/commands/expand.ss
View File

@ -1,6 +1,6 @@
#lang scheme/base #lang scheme/base
(require scheme/cmdline (require scheme/cmdline
tool/command-name raco/command-name
scheme/pretty) scheme/pretty)
(define source-files (define source-files

2
collects/compiler/commands/info.ss
View File

@ -1,6 +1,6 @@
#lang setup/infotab #lang setup/infotab
(define racket-tools (define raco-commands
'(("make" compiler/commands/make "compile source to bytecode" 100) '(("make" compiler/commands/make "compile source to bytecode" 100)
("exe" compiler/commands/exe "create executable" 20) ("exe" compiler/commands/exe "create executable" 20)
("pack" compiler/commands/pack "pack files/collections into a .plt archive" 10) ("pack" compiler/commands/pack "pack files/collections into a .plt archive" 10)

2
collects/compiler/commands/make.ss
View File

@ -1,6 +1,6 @@
#lang scheme/base #lang scheme/base
(require scheme/cmdline (require scheme/cmdline
tool/command-name raco/command-name
compiler/cm compiler/cm
"../compiler.ss" "../compiler.ss"
dynext/file) dynext/file)

2
collects/compiler/commands/pack.ss
View File

@ -1,6 +1,6 @@
#lang scheme/base #lang scheme/base
(require scheme/cmdline (require scheme/cmdline
tool/command-name raco/command-name
setup/pack setup/pack
setup/getinfo setup/getinfo
compiler/distribute) compiler/distribute)

2
collects/drscheme/acks.ss
View File

@ -1,4 +1,4 @@
#lang scheme/base #lang racket/base
(provide get-general-acks (provide get-general-acks
get-translating-acks get-translating-acks

2
collects/drscheme/arrow.ss
View File

@ -1,4 +1,4 @@
#lang scheme/base #lang racket/base
(require scheme/class (require scheme/class
scheme/math scheme/math

4
collects/drscheme/default-code-style.ss
View File

@ -1,4 +1,4 @@
(module default-code-style mzscheme #lang racket/base
(provide color-default-code-styles (provide color-default-code-styles
bw-default-code-styles bw-default-code-styles
code-style-color code-style-color
@ -24,4 +24,4 @@
(list 'unbound-variable (make-code-style "red" #f #f #f)) (list 'unbound-variable (make-code-style "red" #f #f #f))
(list 'bound-variable (make-code-style "navy" #f #f #f)) (list 'bound-variable (make-code-style "navy" #f #f #f))
(list 'primitive (make-code-style "navy" #f #f #f)) (list 'primitive (make-code-style "navy" #f #f #f))
(list 'constant (make-code-style '(51 135 39) #f #f #f))))) (list 'constant (make-code-style '(51 135 39) #f #f #f))))

2
collects/drscheme/drscheme.ss
View File

@ -1,4 +1,4 @@
#lang scheme/base #lang racket/base
(require scheme/gui/base "private/key.ss") (require scheme/gui/base "private/key.ss")
(define debugging? (getenv "PLTDRDEBUG")) (define debugging? (getenv "PLTDRDEBUG"))

4
collects/drscheme/installer.ss
View File

@ -1,4 +1,4 @@
(module installer mzscheme #lang racket/base
(require mzlib/file (require mzlib/file
mzlib/etc mzlib/etc
launcher) launcher)
@ -18,4 +18,4 @@
(mred-program-launcher-path "DrScheme") (mred-program-launcher-path "DrScheme")
(cons (cons
`(exe-name . "DrScheme") `(exe-name . "DrScheme")
(build-aux-from-path (build-path (collection-path "drscheme") "drscheme"))))))) (build-aux-from-path (build-path (collection-path "drscheme") "drscheme"))))))

4
collects/drscheme/main.ss
View File

@ -1,2 +1,2 @@
(module main scheme/base #lang racket/base
(require "drscheme.ss")) (require "drscheme.ss")

6
collects/drscheme/private/app.ss
View File

@ -1,10 +1,8 @@
#lang scheme/unit #lang scheme/unit
(require mzlib/class (require racket/class
mzlib/list
scheme/file
string-constants string-constants
mred racket/gui/base
framework framework
browser/external browser/external
setup/getinfo setup/getinfo

17
collects/drscheme/private/bindings-browser.ss
View File

@ -1,4 +1,4 @@
#lang mzscheme #lang racket/base
#| #|
CODE COPIED (with permission ...) from syntax-browser.ss CODE COPIED (with permission ...) from syntax-browser.ss
@ -9,13 +9,10 @@ Marshalling (and hence the 'read' method of the snipclass omitted for fast proto
|# |#
(require mzlib/pretty (require racket/pretty
mzlib/list racket/class
mzlib/class racket/gui/base
mred racket/contract)
mzlib/match
mzlib/string
mzlib/contract)
(provide render-bindings/snip) (provide render-bindings/snip)
@ -64,7 +61,7 @@ Marshalling (and hence the 'read' method of the snipclass omitted for fast proto
; how to enrich the notion of an output-port to get 'bold'ing to ; how to enrich the notion of an output-port to get 'bold'ing to
; work otherwise... ; work otherwise...
(let* ([before (send output-text last-position)]) (let* ([before (send output-text last-position)])
(pretty-print (syntax-object->datum stx)) (pretty-print (syntax->datum stx))
(let* ([post-newline (send output-text last-position)]) (let* ([post-newline (send output-text last-position)])
(send output-text delete post-newline) ; delete the trailing \n. yuck! (send output-text delete post-newline) ; delete the trailing \n. yuck!
(send output-text insert " ") (send output-text insert " ")
@ -164,7 +161,7 @@ Marshalling (and hence the 'read' method of the snipclass omitted for fast proto
(define black-style-delta (make-object style-delta% 'change-normal-color)) (define black-style-delta (make-object style-delta% 'change-normal-color))
(define green-style-delta (make-object style-delta%)) (define green-style-delta (make-object style-delta%))
(send green-style-delta set-delta-foreground "forest green") (void (send green-style-delta set-delta-foreground "forest green"))
(define turn-snip% (define turn-snip%
(class snip% (class snip%

4
collects/drscheme/private/bitmap-message.ss
View File

@ -1,6 +1,6 @@
#lang scheme #lang racket/base
(require mred/mred) (require racket/gui/base racket/class)
(provide bitmap-message%) (provide bitmap-message%)
(define bitmap-message% (define bitmap-message%

14
collects/drscheme/private/debug.ss
View File

@ -1,4 +1,4 @@
#lang scheme/base #lang racket/base
#| #|
@ -10,11 +10,11 @@ profile todo:
(require errortrace/errortrace-key (require errortrace/errortrace-key
scheme/unit scheme/unit
scheme/contract racket/contract
errortrace/stacktrace errortrace/stacktrace
scheme/class racket/class
scheme/path racket/path
scheme/gui/base racket/gui/base
string-constants string-constants
framework framework
framework/private/bday framework/private/bday
@ -23,9 +23,9 @@ profile todo:
"bindings-browser.ss" "bindings-browser.ss"
net/sendurl net/sendurl
net/url net/url
scheme/match racket/match
mrlib/include-bitmap mrlib/include-bitmap
(for-syntax scheme/base)) (for-syntax racket/base))
(define orig (current-output-port)) (define orig (current-output-port))

10
collects/drscheme/private/drscheme-normal.ss
View File

@ -1,12 +1,12 @@
#lang scheme/base #lang racket/base
(require mred (require mred
scheme/class racket/class
scheme/cmdline racket/cmdline
scheme/list racket/list
framework/private/bday framework/private/bday
framework/splash framework/splash
scheme/file racket/file
"eb.ss") "eb.ss")
(define files-to-open (command-line #:args filenames filenames)) (define files-to-open (command-line #:args filenames filenames))

2
collects/drscheme/private/drsig.ss
View File

@ -1,4 +1,4 @@
#lang scheme/base #lang racket/base
(require scheme/unit) (require scheme/unit)
(provide drscheme:eval^ (provide drscheme:eval^

6
collects/drscheme/private/eb.ss
View File

@ -1,7 +1,7 @@
#lang scheme/base #lang racket/base
(require scheme/class (require racket/class
framework/splash framework/splash
scheme/gui/base) racket/gui/base)
(provide install-eb) (provide install-eb)
(define (install-eb) (define (install-eb)

6
collects/drscheme/private/embedded-snip-utils.ss
View File

@ -1,6 +1,6 @@
#lang scheme/base #lang racket/base
(require scheme/class (require racket/class
scheme/gui/base) racket/gui/base)
(provide get-enclosing-editor-frame) (provide get-enclosing-editor-frame)

12
collects/drscheme/private/eval.ss
View File

@ -1,9 +1,9 @@
#lang mzscheme #lang racket/base
(require mred (require mred
mzlib/unit scheme/unit
mzlib/port racket/port
mzlib/class racket/class
syntax/toplevel syntax/toplevel
framework framework
"drsig.ss") "drsig.ss")
@ -11,7 +11,7 @@
;; to ensure this guy is loaded (and the snipclass installed) in the drscheme namespace & eventspace ;; to ensure this guy is loaded (and the snipclass installed) in the drscheme namespace & eventspace
;; these things are for effect only! ;; these things are for effect only!
(require mrlib/cache-image-snip (require mrlib/cache-image-snip
(prefix image-core: mrlib/image-core)) (prefix-in image-core: mrlib/image-core))
(define op (current-output-port)) (define op (current-output-port))
(define (oprintf . args) (apply fprintf op args)) (define (oprintf . args) (apply fprintf op args))
@ -173,7 +173,7 @@
(error-print-width 250) (error-print-width 250)
(current-ps-setup (make-object ps-setup%)) (current-ps-setup (make-object ps-setup%))
(current-namespace (make-namespace 'empty)) (current-namespace (make-empty-namespace))
(for-each (λ (x) (namespace-attach-module drscheme:init:system-namespace x)) (for-each (λ (x) (namespace-attach-module drscheme:init:system-namespace x))
to-be-copied-module-names)) to-be-copied-module-names))

8
collects/drscheme/private/font.ss
View File

@ -1,8 +1,8 @@
#lang mzscheme #lang racket/base
(require mzlib/unit (require scheme/unit
mzlib/class racket/class
racket/gui/base
"drsig.ss" "drsig.ss"
mred
framework framework
string-constants) string-constants)

9
collects/drscheme/private/frame.ss
View File

@ -1,9 +1,8 @@
#lang scheme/unit #lang scheme/unit
(require string-constants (require string-constants
mzlib/match racket/match
mzlib/class racket/class
mzlib/string racket/string
mzlib/list
"drsig.ss" "drsig.ss"
mred mred
framework framework
@ -11,7 +10,7 @@
net/head net/head
setup/plt-installer setup/plt-installer
help/bug-report help/bug-report
scheme/file) racket/file)
(import [prefix drscheme:unit: drscheme:unit^] (import [prefix drscheme:unit: drscheme:unit^]
[prefix drscheme:app: drscheme:app^] [prefix drscheme:app: drscheme:app^]

2
collects/drscheme/private/get-extend.ss
View File

@ -1,6 +1,6 @@
#lang scheme/unit #lang scheme/unit
(require scheme/class (require racket/class
"drsig.ss") "drsig.ss")
(import [prefix drscheme:unit: drscheme:unit^] (import [prefix drscheme:unit: drscheme:unit^]

4
collects/drscheme/private/help-desk.ss
View File

@ -1,9 +1,9 @@
#lang scheme/unit #lang scheme/unit
(require scheme/gui/base (require racket/gui/base
browser/external browser/external
framework framework
scheme/class racket/class
net/url net/url
setup/dirs setup/dirs
help/search help/search

6
collects/drscheme/private/honu-logo.ss
View File

@ -1,8 +1,8 @@
#lang scheme/base #lang racket/base
(provide draw-honu) (provide draw-honu)
(require scheme/class (require racket/class
scheme/gui/base racket/gui/base
"palaka.ss") "palaka.ss")
(define pi (atan 0 -1)) (define pi (atan 0 -1))

3
collects/drscheme/private/init.ss
View File

@ -1,8 +1,7 @@
#lang scheme/unit #lang scheme/unit
(require string-constants (require string-constants
"drsig.ss" "drsig.ss"
mzlib/list racket/gui/base)
mred)
(import) (import)

2
collects/drscheme/private/insert-large-letters.ss
View File

@ -2,7 +2,7 @@
(require typed/mred/mred (require typed/mred/mred
typed/framework/framework typed/framework/framework
scheme/class racket/class
string-constants/string-constant) string-constants/string-constant)

2
collects/drscheme/private/key.ss
View File

@ -1,4 +1,4 @@
#lang mzscheme #lang racket/base
(provide break-threads) (provide break-threads)
(define super-cust (current-custodian)) (define super-cust (current-custodian))
(define first-child (make-custodian)) (define first-child (make-custodian))

18
collects/drscheme/private/label-frame-mred.ss
View File

@ -1,28 +1,28 @@
#lang mzscheme #lang racket/base
(require mred (require racket/gui/base
mzlib/class) racket/class)
(provide (all-from-except mred frame%) (provide (except-out (all-from-out racket/gui/base) frame%)
(rename registering-frame% frame%) (rename-out [registering-frame% frame%])
lookup-frame-name) lookup-frame-name)
(define (lookup-frame-name frame) (define (lookup-frame-name frame)
(semaphore-wait label-sema) (semaphore-wait label-sema)
(begin0 (begin0
(hash-table-get label-ht frame (λ () #f)) (hash-ref label-ht frame (λ () #f))
(semaphore-post label-sema))) (semaphore-post label-sema)))
(define label-sema (make-semaphore 1)) (define label-sema (make-semaphore 1))
(define label-ht (make-hash-table 'weak)) (define label-ht (make-weak-hasheq))
(define registering-frame% (define registering-frame%
(class frame% (class frame%
(define/override (set-label x) (define/override (set-label x)
(semaphore-wait label-sema) (semaphore-wait label-sema)
(hash-table-put! label-ht this x) (hash-set! label-ht this x)
(semaphore-post label-sema) (semaphore-post label-sema)
(super set-label x)) (super set-label x))
(inherit get-label) (inherit get-label)
(super-instantiate ()) (super-instantiate ())
(semaphore-wait label-sema) (semaphore-wait label-sema)
(hash-table-put! label-ht this (get-label)) (hash-set! label-ht this (get-label))
(semaphore-post label-sema))) (semaphore-post label-sema)))

21
collects/drscheme/private/language-configuration.ss
View File

@ -1,13 +1,13 @@
#lang scheme/base #lang racket/base
(require scheme/unit (require scheme/unit
mrlib/hierlist mrlib/hierlist
scheme/class racket/class
scheme/contract racket/contract
scheme/string racket/string
scheme/list racket/list
racket/gui/base
"drsig.ss" "drsig.ss"
string-constants string-constants
mred
framework framework
setup/getinfo setup/getinfo
syntax/toplevel syntax/toplevel
@ -1252,7 +1252,12 @@
(message-box (message-box
(string-constant drscheme) (string-constant drscheme)
(format (format
"The drscheme-language-position, drscheme-language-modules, drscheme-language-numbers, and drscheme-language-readers specifications aren't correct. Expected (listof (cons string (listof string))), (listof (listof string)), (listof (listof number)), (listof string), (listof string), and (listof module-spec) respectively, where the lengths of the outer lists are the same. Got ~e, ~e, ~e, ~e, ~e, and ~e" (string-append
"The drscheme-language-position, drscheme-language-modules, drscheme-language-numbers,"
" and drscheme-language-readers specifications aren't correct. Expected"
" (listof (cons string (listof string))), (listof (listof string)), (listof (listof number)), (listof string),"
" (listof string), and (listof module-spec) respectively, where the lengths of the outer lists are the same."
" Got ~e, ~e, ~e, ~e, ~e, and ~e")
lang-positions lang-positions
lang-modules lang-modules
numberss numberss
@ -1431,7 +1436,7 @@
(let ([words #f]) (let ([words #f])
(λ () (λ ()
(unless words (unless words
(set! words (text:get-completions/manuals '(scheme/base scheme/contract)))) (set! words (text:get-completions/manuals '(racket/base racket/contract))))
words))) words)))
(define get-all-manual-keywords (define get-all-manual-keywords

14
collects/drscheme/private/language-object-contract.ss
View File

@ -1,14 +1,14 @@
#reader scribble/reader #reader scribble/reader
#lang scheme/base #lang racket/base
(require (for-syntax scheme/base) (require (for-syntax racket/base)
scribble/srcdoc scribble/srcdoc
scheme/class racket/class
scheme/gui/base racket/gui/base
scheme/contract racket/contract
"recon.ss") "recon.ss")
(require/doc scheme/base scribble/manual) (require/doc racket/base scribble/manual)
(require (for-meta 2 scheme/base)) (require (for-meta 2 racket/base))
(provide language-object-abstraction) (provide language-object-abstraction)

10
collects/drscheme/private/language.ss
View File

@ -9,17 +9,17 @@
;; NOTE: this module instantiates stacktrace itself, so we have ;; NOTE: this module instantiates stacktrace itself, so we have
;; to be careful to not mix that instantiation with the one ;; to be careful to not mix that instantiation with the one
;; drscheme/private/debug.ss does. errortrace-lib's is for the ;; drracket/private/debug.ss does. errortrace-lib's is for the
;; compilation handling, DrScheme's is for profiling and test coverage ;; compilation handling, DrScheme's is for profiling and test coverage
;; (which do not do compilation) ;; (which do not do compilation)
(prefix-in el: errortrace/errortrace-lib) (prefix-in el: errortrace/errortrace-lib)
mzlib/pconvert mzlib/pconvert
scheme/pretty racket/pretty
mzlib/struct mzlib/struct
scheme/class racket/class
scheme/file racket/file
scheme/list racket/list
compiler/embed compiler/embed
launcher launcher
mred mred

4
collects/drscheme/private/launcher-bootstrap.ss
View File

@ -1,8 +1,8 @@
#lang scheme/base #lang racket/base
(provide startup) (provide startup)
(require scheme/file) (require racket/file)
(define (read-from-string s) (read (open-input-string s))) (define (read-from-string s) (read (open-input-string s)))

8
collects/drscheme/private/launcher-mred-bootstrap.ss
View File

@ -1,9 +1,9 @@
#lang scheme/base #lang racket/base
(require scheme/gui/base "launcher-bootstrap.ss") (require racket/gui/base "launcher-bootstrap.ss")
(current-namespace (make-gui-empty-namespace)) (current-namespace (make-gui-empty-namespace))
(namespace-require 'scheme/gui/base) (namespace-require 'racket/gui/base)
(namespace-require 'scheme/class) (namespace-require 'racket/class)
(startup) (startup)

4
collects/drscheme/private/launcher-mz-bootstrap.ss
View File

@ -1,8 +1,8 @@
#lang scheme/base #lang racket/base
(require "launcher-bootstrap.ss") (require "launcher-bootstrap.ss")
(current-namespace (make-base-empty-namespace)) (current-namespace (make-base-empty-namespace))
(namespace-require 'scheme/base) (namespace-require 'racket/base)
(startup) (startup)

2
collects/drscheme/private/link.ss
View File

@ -1,4 +1,4 @@
#lang scheme/base #lang racket/base
(require scheme/unit (require scheme/unit
"modes.ss" "modes.ss"
"font.ss" "font.ss"

2
collects/drscheme/private/main.ss
View File

@ -7,7 +7,7 @@
framework framework
mzlib/class mzlib/class
mzlib/list mzlib/list
scheme/path racket/path
browser/external browser/external
setup/plt-installer) setup/plt-installer)

6
collects/drscheme/private/modes.ss
View File

@ -1,7 +1,7 @@
#lang scheme/unit #lang scheme/unit
(require string-constants (require string-constants
mzlib/class racket/class
mzlib/list racket/list
framework framework
"drsig.ss") "drsig.ss")
@ -23,7 +23,7 @@
(define (not-a-language-language? l) (define (not-a-language-language? l)
(and (not (null? l)) (and (not (null? l))
(equal? (car (last-pair l)) (equal? (last l)
(string-constant no-language-chosen)))) (string-constant no-language-chosen))))
(define (add-initial-modes) (define (add-initial-modes)

6
collects/drscheme/private/module-browser.ss
View File

@ -1,7 +1,7 @@
#lang scheme/base #lang racket/base
(require mred (require mred
scheme/class racket/class
syntax/moddep syntax/moddep
syntax/toplevel syntax/toplevel
framework/framework framework/framework
@ -9,7 +9,7 @@
mrlib/graph mrlib/graph
"drsig.ss" "drsig.ss"
scheme/unit scheme/unit
scheme/async-channel racket/async-channel
setup/private/lib-roots) setup/private/lib-roots)
(define-struct req (filename key)) (define-struct req (filename key))

8
collects/drscheme/private/module-language-tools.ss
View File

@ -1,12 +1,12 @@
#lang scheme/base #lang racket/base
(provide module-language-tools@) (provide module-language-tools@)
(require mrlib/switchable-button (require mrlib/switchable-button
mrlib/bitmap-label mrlib/bitmap-label
scheme/contract racket/contract
framework framework
scheme/unit scheme/unit
scheme/class racket/class
scheme/gui/base racket/gui/base
"drsig.ss") "drsig.ss")
(define op (current-output-port)) (define op (current-output-port))

14
collects/drscheme/private/module-language.ss
View File

@ -1,11 +1,11 @@
#lang scheme/base #lang racket/base
(provide module-language@) (provide module-language@)
(require scheme/unit (require scheme/unit
scheme/class racket/class
scheme/list racket/list
scheme/path racket/path
scheme/contract racket/contract
mred mred
compiler/embed compiler/embed
compiler/cm compiler/cm
@ -382,7 +382,7 @@
#:literal-expression #:literal-expression
(begin (begin
(parameterize ([current-namespace (make-base-empty-namespace)]) (parameterize ([current-namespace (make-base-empty-namespace)])
(namespace-require 'scheme/base) (namespace-require 'racket/base)
(compile (compile
`(namespace-require '',(string->symbol (path->string short-program-name)))))) `(namespace-require '',(string->symbol (path->string short-program-name))))))
#:cmdline '("-U" "--"))))) #:cmdline '("-U" "--")))))
@ -672,7 +672,7 @@
(raise-hopeless-syntax-error "bad syntax in name position of module" (raise-hopeless-syntax-error "bad syntax in name position of module"
stx name)) stx name))
(when filename (check-filename-matches filename name* stx)) (when filename (check-filename-matches filename name* stx))
(let* (;; rewrite the module to use the scheme/base version of `module' (let* (;; rewrite the module to use the racket/base version of `module'
[mod (datum->syntax #'here 'module mod)] [mod (datum->syntax #'here 'module mod)]
[expr (datum->syntax stx `(,mod ,name ,lang . ,body) stx stx)]) [expr (datum->syntax stx `(,mod ,name ,lang . ,body) stx stx)])
(values name lang expr))) (values name lang expr)))

4
collects/drscheme/private/multi-file-search.ss
View File

@ -2,8 +2,8 @@
(require framework (require framework
mzlib/class mzlib/class
mred mred
scheme/file racket/file
scheme/path racket/path
mzlib/thread mzlib/thread
mzlib/async-channel mzlib/async-channel
string-constants string-constants

4
collects/drscheme/private/number-snip.ss
View File

@ -1,6 +1,6 @@
#lang mzscheme #lang racket/base
(require mred (require mred
mzlib/class racket/class
framework) framework)
(provide snip-class) (provide snip-class)

4
collects/drscheme/private/palaka.ss
View File

@ -1,5 +1,5 @@
#lang scheme/base #lang racket/base
(require scheme/class scheme/gui/base) (require racket/class racket/gui/base)
(provide draw-palaka palaka-pattern-size) (provide draw-palaka palaka-pattern-size)
(define scale 1) (define scale 1)

4
collects/drscheme/private/prefs-contract.ss
View File

@ -1,6 +1,6 @@
#lang scheme/base #lang racket/base
(require (for-syntax scheme/base) (require (for-syntax racket/base)
framework/framework) framework/framework)
(provide (rename-out [-preferences:get preferences:get]) (provide (rename-out [-preferences:get preferences:get])

6
collects/drscheme/private/profile-drs.ss
View File

@ -1,6 +1,6 @@
#lang scheme/base #lang racket/base
(require scheme/gui/base (require racket/gui/base
scheme/class racket/class
profile/sampler profile/sampler
profile/render-text profile/render-text
profile/analyzer profile/analyzer

4
collects/drscheme/private/recon.ss
View File

@ -1,5 +1,5 @@
#lang scheme/base #lang racket/base
(require (for-syntax scheme/base)) (require (for-syntax racket/base))
(provide reconstitute) (provide reconstitute)
(begin-for-syntax (begin-for-syntax

12
collects/drscheme/private/rep.ss
View File

@ -1,4 +1,4 @@
#lang scheme/base #lang racket/base
#| #|
@ -20,15 +20,15 @@ TODO
;; user's io ports, to aid any debugging printouts. ;; user's io ports, to aid any debugging printouts.
;; (esp. useful when debugging the users's io) ;; (esp. useful when debugging the users's io)
(require scheme/class (require racket/class
scheme/path racket/path
scheme/pretty racket/pretty
scheme/unit scheme/unit
scheme/list racket/list
string-constants string-constants
setup/xref setup/xref
scheme/gui/base racket/gui/base
framework framework
browser/external browser/external
"drsig.ss" "drsig.ss"

8
collects/drscheme/private/stick-figures.ss
View File

@ -1,7 +1,7 @@
#lang mzscheme #lang racket/base
(require mzlib/class (require racket/class
mzlib/pretty racket/pretty
mred) racket/gui/base)
(define head-size 40) (define head-size 40)
(define small-bitmap-factor 1/2) (define small-bitmap-factor 1/2)

10
collects/drscheme/private/tools.ss
View File

@ -1,9 +1,9 @@
#lang scheme/unit #lang scheme/unit
(require scheme/class (require racket/class
scheme/list racket/list
scheme/runtime-path racket/runtime-path
scheme/contract racket/contract
setup/getinfo setup/getinfo
mred mred
framework framework
@ -13,7 +13,7 @@
mrlib/switchable-button mrlib/switchable-button
string-constants) string-constants)
(require (for-syntax scheme/base scheme/match)) (require (for-syntax racket/base racket/match))
(import [prefix drscheme:frame: drscheme:frame^] (import [prefix drscheme:frame: drscheme:frame^]
[prefix drscheme:unit: drscheme:unit^] [prefix drscheme:unit: drscheme:unit^]

14
collects/drscheme/private/tracing.ss
View File

@ -1,12 +1,12 @@
#lang scheme/base #lang racket/base
(require scheme/contract (require racket/contract
scheme/unit scheme/unit
scheme/class racket/class
scheme/path racket/path
scheme/port racket/port
scheme/list racket/list
scheme/gui/base racket/gui/base
string-constants string-constants
framework framework
(prefix-in tr: trace/stacktrace) (prefix-in tr: trace/stacktrace)

3
collects/drscheme/private/ts.ss
View File

@ -1,5 +1,4 @@
#reader scribble/reader #lang at-exp racket/base
#lang scheme/base
(require scribble/decode (require scribble/decode
scribble/manual) scribble/manual)

12
collects/drscheme/private/unit.ss
View File

@ -1,4 +1,4 @@
#lang scheme/base #lang racket/base
#| #|
closing: closing:
@ -11,12 +11,12 @@ module browser threading seems wrong.
|# |#
(require scheme/contract (require racket/contract
scheme/unit scheme/unit
scheme/class racket/class
scheme/path racket/path
scheme/port racket/port
scheme/list racket/list
string-constants string-constants
framework framework
mrlib/name-message mrlib/name-message

2
collects/drscheme/sprof.ss
View File

@ -1,4 +1,4 @@
#lang scheme/base #lang racket/base
(require scheme/gui/base (require scheme/gui/base
framework framework
scheme/class) scheme/class)

2
collects/drscheme/syncheck-drscheme-button.ss
View File

@ -1,4 +1,4 @@
#lang scheme/base #lang racket/base
(require scheme/class (require scheme/class
scheme/gui/base scheme/gui/base
string-constants/string-constant) string-constants/string-constant)

34
collects/drscheme/syncheck.ss
View File

@ -1,4 +1,4 @@
#lang scheme/base #lang racket/base
#| #|
Check Syntax separates two classes of identifiers, Check Syntax separates two classes of identifiers,
@ -2276,16 +2276,28 @@ If the namespace does not, they are colored the unbound color.
(parameterize ([current-namespace user-namespace] (parameterize ([current-namespace user-namespace]
[current-directory user-directory] [current-directory user-directory]
[current-load-relative-directory user-directory]) [current-load-relative-directory user-directory])
(let ([ans (with-handlers ([exn:fail? (λ (x) #f)]) (let* ([rkt-path/mod-path
(cond (with-handlers ([exn:fail? (λ (x) #f)])
[(module-path-index? datum) (cond
(resolved-module-path-name [(module-path-index? datum)
(module-path-index-resolve datum))] (resolved-module-path-name
[else (module-path-index-resolve datum))]
(resolved-module-path-name [else
((current-module-name-resolver) datum #f #f))]))]) (resolved-module-path-name
(and (path? ans) ((current-module-name-resolver) datum #f #f))]))]
ans)))) [rkt-path/f (and (path? rkt-path/mod-path) rkt-path/mod-path)])
(let/ec k
(unless (path? rkt-path/f) (k rkt-path/f))
(when (file-exists? rkt-path/f) (k rkt-path/f))
(let* ([bts (path->bytes rkt-path/f)]
[len (bytes-length bts)])
(unless (and (len . >= . 4)
(bytes=? #".rkt" (subbytes bts (- len 4))))
(k rkt-path/f))
(let ([ss-path (bytes->path (bytes-append (subbytes bts 0 (- len 4)) #".ss"))])
(unless (file-exists? ss-path)
(k rkt-path/f))
ss-path))))))
;; make-require-open-menu : path -> menu -> void ;; make-require-open-menu : path -> menu -> void
(define (make-require-open-menu file) (define (make-require-open-menu file)

4
collects/drscheme/tool-lib.ss
View File

@ -1,4 +1,4 @@
#lang at-exp scheme/base #lang at-exp racket/base
#| #|
@ -9,7 +9,7 @@ all of the names in the tools library, for use defining keybindings
|# |#
(require scheme/class (require scheme/class
scheme/gui/base scheme/gui/base
scheme/unit (except-in scheme/unit struct)
scheme/contract scheme/contract
scheme/class scheme/class

9
collects/drscheme/tool.ss
View File

@ -1,4 +1,5 @@
(module tool mzscheme #lang racket/base
(require "private/drsig.ss") (require "private/drsig.ss")
(provide drscheme:tool^ (provide drscheme:tool^
drscheme:tool-exports^)) drscheme:tool-exports^)

4
collects/help/help.ss
View File

@ -1,10 +1,12 @@
#lang scheme/base #lang scheme/base
(require "search.ss" scheme/cmdline scheme/list scheme/string) (require "search.ss" scheme/cmdline scheme/list scheme/string
raco/command-name)
;; Minimal command-line arguments, the query string can contain all ;; Minimal command-line arguments, the query string can contain all
;; kinds of magic. ;; kinds of magic.
(command-line (command-line
#:program (short-program+command-name)
#:handlers #:handlers
(lambda (_ . ts) (lambda (_ . ts)
(if (null? ts) (if (null? ts)

2
collects/help/info.ss
View File

@ -1,4 +1,4 @@
#lang setup/infotab #lang setup/infotab
(define post-install-collection "installer.ss") (define post-install-collection "installer.ss")
(define racket-tools '(("docs" help/help "search and view documentation" 100))) (define raco-commands '(("docs" help/help "search and view documentation" 100)))

2
collects/help/installer.ss
View File

@ -27,7 +27,7 @@
(parameterize ([current-launcher-variant variant]) (parameterize ([current-launcher-variant variant])
(mk-launcher '("-l-" "help/help") (mk-launcher '("-l-" "help/help")
(mk-path "plt-help") ;; change to "Racket Docs" (mk-path "plt-help") ;; change to "Racket Docs"
`([exe-name . "plt-help"] ;; get rid of this (in favor of 'racket-tool docs') `([exe-name . "plt-help"] ;; get rid of this (in favor of 'raco docs')
[relative? . #t] [relative? . #t]
[framework-root . #f] [framework-root . #f]
[dll-dir . #f] [dll-dir . #f]

16
collects/lang/private/teach.ss
View File

@ -38,7 +38,8 @@
mzlib/list mzlib/list
mzlib/math mzlib/math
scheme/match scheme/match
"set-result.ss") "set-result.ss"
(only racket/base define-struct))
(require-for-syntax "teachhelp.ss" (require-for-syntax "teachhelp.ss"
"teach-shared.ss" "teach-shared.ss"
syntax/kerncase syntax/kerncase
@ -753,12 +754,13 @@
(lambda (def-proc-names) (lambda (def-proc-names)
(with-syntax ([(def-proc-name ...) def-proc-names] (with-syntax ([(def-proc-name ...) def-proc-names]
[(proc-name ...) proc-names]) [(proc-name ...) proc-names])
(stepper-syntax-property #`(define-values (def-proc-name ...) (stepper-syntax-property
(let () #`(define-values (def-proc-name ...)
(define-struct name_ (field_ ...) (make-inspector)) (let ()
(values proc-name ...))) (define-struct name_ (field_ ...) #:transparent #:constructor-name #,(car proc-names))
'stepper-define-struct-hint (values proc-name ...)))
stx))))]) 'stepper-define-struct-hint
stx))))])
(let ([defn (let ([defn
(quasisyntax/loc stx (quasisyntax/loc stx
(begin (begin

17
collects/meta/contrib/completion/racket-completion.bash
View File

@ -82,14 +82,14 @@ complete -F _racket $filenames racket
complete -F _racket $filenames gracket complete -F _racket $filenames gracket
complete -F _racket $filenames gracket-text complete -F _racket $filenames gracket-text
_rico_planet() _raco_planet()
{ {
local cur="${COMP_WORDS[COMP_CWORD]}" local cur="${COMP_WORDS[COMP_CWORD]}"
local planetcmds=$( echo '' '--help' ; for x in `rico planet --help 2>&1 | sed -n -e 's/^ \(.[^ ]*\).*/\1/p'` ; do echo ${x} ; done ) local planetcmds=$( echo '' '--help' ; for x in `raco planet --help 2>&1 | sed -n -e 's/^ \(.[^ ]*\).*/\1/p'` ; do echo ${x} ; done )
COMPREPLY=( $(compgen -W "${planetcmds}" -- ${cur}) ) COMPREPLY=( $(compgen -W "${planetcmds}" -- ${cur}) )
} }
_rico() _raco()
{ {
COMPREPLY=() COMPREPLY=()
local cur="${COMP_WORDS[COMP_CWORD]}" local cur="${COMP_WORDS[COMP_CWORD]}"
@ -101,10 +101,10 @@ _rico()
if [ $COMP_CWORD -eq 1 ]; then if [ $COMP_CWORD -eq 1 ]; then
# removing the empty string on the next line breaks things. such as my brain. # removing the empty string on the next line breaks things. such as my brain.
local cmds=$( echo '' '--help' ; for x in `racket -e '(begin (require rico/all-tools) (for ([(k v) (all-tools)]) (printf "~a\n" k)))'` ; do echo ${x} ; done ) local cmds=$( echo '' '--help' ; for x in `racket -e '(begin (require raco/all-tools) (for ([(k v) (all-tools)]) (printf "~a\n" k)))'` ; do echo ${x} ; done )
COMPREPLY=($(compgen -W "${cmds}" -- ${cur})) COMPREPLY=($(compgen -W "${cmds}" -- ${cur}))
elif [ $COMP_CWORD -eq 2 ]; then elif [ $COMP_CWORD -eq 2 ]; then
# Here we'll handle the main rico commands # Here we'll handle the main raco commands
local prev="${COMP_WORDS[1]}" local prev="${COMP_WORDS[1]}"
case "${prev}" in case "${prev}" in
make) make)
@ -118,7 +118,7 @@ _rico()
esac esac
;; ;;
planet) planet)
_rico_planet _raco_planet
;; ;;
--help) --help)
;; ;;
@ -132,5 +132,6 @@ _rico()
return 0 return 0
} }
complete -F _rico rico complete -F _raco rico
complete -F _rico racket-tool complete -F _raco racket-tool
complete -F _raco raco

152
collects/meta/contrib/rubber/slatex.py Normal file
View File

@ -0,0 +1,152 @@
"""
sLaTeX support for Rubber.
"""
from os import unlink
from os.path import exists, getmtime, join
import rubber
from rubber import _, msg, Depend, DependLeaf
def run(doc, env, base):
msg.progress(_("running slatex on %s") % doc.src_base)
if env.execute(["slatex", "-n", base], {}):
msg.error(_("Error executing slatex"))
return 1
doc.must_compile = 1
return 0
def slatex_needed(target, srcs):
if not exists(target):
msg.log(_("File %s does not exist") % target, pkg="slatex")
return 1
for src in srcs:
if getmtime(target) < getmtime(src):
msg.log(_("File %s older than %s") % (target, src), pkg="slatex")
return 1
return 0
class RubberDep (Depend):
# Base is the slatex module
# Target is the autogenerated file (i.e. .Z# + doc.src_base + ".tex")
# Sources is a list of sources on which this file depends
def __init__ (self, mod, target, srcs):
self.mod = mod
self.doc = mod.doc
self.env = mod.doc.env
self.target = target
self.srcs = srcs
sources = {}
for src in srcs:
sources[src] = DependLeaf(self.env, src)
Depend.__init__(self, self.env,
prods=[target],
sources=sources)
self.urvater = join(self.doc.src_path, self.doc.src_base + ".tex")
def run(self):
# We may have been out of date before any dependency was run,
# but by this point we may be up to date since slatex builds
# all the files at once. Otherwise we'll run once per out of
# date generated file.
if slatex_needed(self.target, self.srcs):
run(self.doc, self.env, self.urvater)
class Module (rubber.rules.latex.Module):
def __init__ (self, doc, dict):
self.base = doc.src_base
self.base_file = join(doc.src_path, doc.src_base + ".tex")
self.final = join(doc.env.path[0], doc.env.final.prods[0])
self.count = 0
self.doc = doc
self.env = doc.env
self.file_deps = {}
self.path = doc.src_path
self.preamble = False
def add_scheme_file(dict, others=[]):
filename = ".Z" + str(self.count) + self.base + ".tex"
path = join(self.path, filename)
deps = [dict["pos"]["file"]]
if others:
deps.extend(others)
self.doc.sources[path] = RubberDep(self, path, deps)
msg.log(_("Marking %s as dependent on %s") % (path, deps), pkg = "slatex")
self.count += 1
scheme_macros = ["scheme", "schemeresult"]
scheme_envs = ["schemedisplay",
"schemeresponse",
"schemebox",
"schemeresponsebox"]
preamble_macros = ["setspecialsymbol",
"setkeyword",
"defschememathescape"]
def add_preamble_hook(name):
def h_preamb(dict):
if not self.preamble and slatex_needed(self.final, [self.base_file]):
run(self.doc, self.env, self.base_file)
self.preamble = True
doc.add_hook(name, h_preamb)
def add_macro_hook(name):
def h_macro(dict):
add_scheme_file(dict)
doc.add_hook(name, h_macro)
def add_env_hook(name):
beg_env = "begin{%s}" % name
end_env = "end{%s}" % name
def begin_env_hook(dict):
def end_env_hook(dict, self=doc, hooks=doc.hooks):
self.hooks = hooks
self.update_seq()
doc.hooks = { end_env : end_env_hook }
# \scheme, \schemeresult allowed in these.
for macro in scheme_macros:
add_macro_hook(macro)
doc.update_seq()
add_scheme_file(dict)
doc.add_hook(beg_env, begin_env_hook)
for macro in preamble_macros:
add_preamble_hook(macro)
for macro in scheme_macros:
add_macro_hook(macro)
for environ in scheme_envs:
add_env_hook(environ)
# handled specially so that we get dependence on the
# file being included as well.
def h_schemeinput(dict):
arg_path = join(self.path, dict["arg"])
add_scheme_file(dict, others=[arg_path])
doc.add_hook("schemeinput", h_schemeinput)
# schemeregions should generate one file for the entire
# thing, so we shouldn't allow the separate scheme
# hooks like above.
def h_schemeregion(dict, end = "end{schemeregion}"):
def end_env_hook(dict, self=doc, hooks=doc.hooks):
self.hooks = hooks
self.update_seq()
doc.hooks = doc.hooks.copy()
doc.hooks[end] = end_env_hook
for macro in scheme_macros:
if macro in doc.hooks:
del doc.hooks[macro]
for env in scheme_envs:
if ("begin{%s}" % env) in doc.hooks:
del doc.hooks["begin{%s}" % env]
doc.update_seq()
add_scheme_file(dict)
doc.add_hook("begin{schemeregion}", h_schemeregion)

6
collects/meta/dist-specs.ss
View File

@ -344,7 +344,7 @@ mz-manuals := (scribblings: "main/") ; generates main pages (next line)
(notes: "COPYING.LIB" "COPYING-libscheme.txt") (notes: "COPYING.LIB" "COPYING-libscheme.txt")
(doc: "doc-license.txt") ; needed (when docs are included) (doc: "doc-license.txt") ; needed (when docs are included)
(doc+src: "reference/" "guide/" "quick/" "more/" (doc+src: "reference/" "guide/" "quick/" "more/"
"foreign/" "inside/" "places/" "foreign/" "inside/" ;; "places/" <- not ready yet
"honu/") "honu/")
(doc: "*.{html|css|js|sxref}") (doc: "*.{html|css|js|sxref}")
(scribblings: "{{info|icons}.ss|*.png}" "compiled") (scribblings: "{{info|icons}.ss|*.png}" "compiled")
@ -431,8 +431,8 @@ platform-dependent := ; hook for package rules
mz-extras :+= (- (package: "setup-plt" #:collection "setup/") mz-extras :+= (- (package: "setup-plt" #:collection "setup/")
(cond (not dr) => (srcfile: "plt-installer{|-sig|-unit}.ss"))) (cond (not dr) => (srcfile: "plt-installer{|-sig|-unit}.ss")))
;; -------------------- racket-tool ;; -------------------- raco
mz-extras :+= (package: "tool") mz-extras :+= (package: "raco")
;; -------------------- launcher ;; -------------------- launcher
mz-extras :+= (- (collects: "launcher") mz-extras :+= (- (collects: "launcher")

24
collects/meta/props Executable file → Normal file
View File

@ -140,7 +140,7 @@ path/s is either such a string or a list of them.
;; need updating if more characters are allowed in the future. ;; need updating if more characters are allowed in the future.
#rx"[^/.a-zA-Z0-9%_+-]") #rx"[^/.a-zA-Z0-9%_+-]")
(define (validate-path-string path-string who) (define (validate-path-string path-string who [only-warn? #f])
(define (bad why) (define (bad why)
(error* who "invalid path argument, expecting a ~a, got: ~e" (error* who "invalid path argument, expecting a ~a, got: ~e"
why path-string)) why path-string))
@ -149,10 +149,12 @@ path/s is either such a string or a list of them.
(regexp-match? rx:bad-path path-string)) (regexp-match? rx:bad-path path-string))
(bad "relative `/'-delimited string, no `/' suffix, `//', `.', or `..'")) (bad "relative `/'-delimited string, no `/' suffix, `//', `.', or `..'"))
(when (regexp-match? rx:bad-pathchar path-string) (when (regexp-match? rx:bad-pathchar path-string)
(error* who "invalid path argument, ~s is not allowed, got: ~e\n~a~a" (if only-warn?
(regexp-match rx:bad-pathchar path-string) path-string (warn "~s is a bad path argument" path-string)
"(note: if paths with this character are needed, then this" (error* who "invalid path argument, ~s is not allowed, got: ~e\n~a~a"
" script needs to be exteded to allow them)"))) (regexp-match rx:bad-pathchar path-string) path-string
"(note: if paths with this character are needed, then this"
" script needs to be exteded to allow them)"))))
(define (parse-prop-string prop str who) (define (parse-prop-string prop str who)
(with-handlers ([exn? (lambda (e) (with-handlers ([exn? (lambda (e)
@ -162,7 +164,7 @@ path/s is either such a string or a list of them.
(define (get-prop path-string prop-name [default get-prop] (define (get-prop path-string prop-name [default get-prop]
#:strict? [strict? #f] #:as-string? [as-string? #f]) #:strict? [strict? #f] #:as-string? [as-string? #f])
(validate-path-string path-string 'get-prop) (validate-path-string path-string 'get-prop #t) ; no errors
(let ([upchain (let ([upchain
;; take the chain going up from the most specific node, so that ;; take the chain going up from the most specific node, so that
;; properties of a directory apply to subpaths ;; properties of a directory apply to subpaths
@ -314,8 +316,9 @@ path/s is either such a string or a list of them.
sub)))) sub))))
(and (or (pair? (tree-subs tree)) (pair? (tree-props tree))) tree)) (and (or (pair? (tree-subs tree)) (pair? (tree-props tree))) tree))
(let (;; temp file in the same directory => fail early if cannot write to it (let (;; temp file in the same directory => fail early if cannot write to it
;; and make a rename possible ;; and make a rename possible; copy from this file to preserve being
[temp (make-temporary-file (format "~a~~a" this-file))]) ;; executable
[temp (make-temporary-file (format "~a~~a" this-file) this-file)])
(dynamic-wind (dynamic-wind
void void
(lambda () (lambda ()
@ -812,6 +815,7 @@ path/s is either such a string or a list of them.
"collects/handin-server/web-status-server.ss" drdr:command-line "mzc ~s" "collects/handin-server/web-status-server.ss" drdr:command-line "mzc ~s"
"collects/help" responsible (robby) "collects/help" responsible (robby)
"collects/help/bug-report.ss" drdr:command-line "mred-text -t ~s" "collects/help/bug-report.ss" drdr:command-line "mred-text -t ~s"
"collects/help/help.ss" drdr:command-line "mzc ~s"
"collects/hierlist/hierlist.ss" drdr:command-line "mred-text -t ~s" "collects/hierlist/hierlist.ss" drdr:command-line "mred-text -t ~s"
"collects/honu" responsible (mflatt rafkind) "collects/honu" responsible (mflatt rafkind)
"collects/htdp" responsible (matthias) "collects/htdp" responsible (matthias)
@ -897,8 +901,8 @@ path/s is either such a string or a list of them.
"collects/make" responsible (mflatt) "collects/make" responsible (mflatt)
"collects/meta" responsible (eli) "collects/meta" responsible (eli)
"collects/meta/check-dists.ss" drdr:command-line "" "collects/meta/check-dists.ss" drdr:command-line ""
"collects/meta/drdr" responsible (jay) drdr:command-line ""
"collects/meta/contrib/completion/racket-completion.bash" responsible (samth sstrickl) drdr:command-line "" "collects/meta/contrib/completion/racket-completion.bash" responsible (samth sstrickl) drdr:command-line ""
"collects/meta/drdr" responsible (jay) drdr:command-line ""
"collects/mred/edit-main.ss" drdr:command-line "mzc ~s" "collects/mred/edit-main.ss" drdr:command-line "mzc ~s"
"collects/mred/edit.ss" drdr:command-line "mred-text -t ~s" "collects/mred/edit.ss" drdr:command-line "mred-text -t ~s"
"collects/mred/lang/main.ss" drdr:command-line "mred-text -t ~s" "collects/mred/lang/main.ss" drdr:command-line "mred-text -t ~s"
@ -1093,7 +1097,7 @@ path/s is either such a string or a list of them.
"collects/redex/tests/matcher-test.ss" drdr:command-line "mzc ~s" "collects/redex/tests/matcher-test.ss" drdr:command-line "mzc ~s"
"collects/redex/tests/pict-test.ss" drdr:command-line "mzc ~s" "collects/redex/tests/pict-test.ss" drdr:command-line "mzc ~s"
"collects/redex/tests/rg-test.ss" drdr:command-line "mzc ~s" "collects/redex/tests/rg-test.ss" drdr:command-line "mzc ~s"
"collects/redex/tests/run-tests.ss" drdr:command-line "mred-text ~s --examples --no-bitmaps" drdr:timeout 180 "collects/redex/tests/run-tests.ss" drdr:command-line "mred-text ~s --examples --no-bitmaps" drdr:timeout 240
"collects/redex/tests/term-test.ss" drdr:command-line "mzc ~s" "collects/redex/tests/term-test.ss" drdr:command-line "mzc ~s"
"collects/redex/tests/tl-test.ss" drdr:command-line "mzc ~s" "collects/redex/tests/tl-test.ss" drdr:command-line "mzc ~s"
"collects/repos-time-stamp" responsible (eli) "collects/repos-time-stamp" responsible (eli)

312
collects/mzlib/unit.ss
View File

@ -142,19 +142,22 @@
(syntax-case stx () (syntax-case stx ()
[(_ arg ...) (datum->syntax [(_ arg ...) (datum->syntax
stx stx
(cons (self-name-struct-info-id me) (cons ((self-name-struct-info-id me))
#'(arg ...)) #'(arg ...))
stx stx
stx)] stx)]
[_ (let ([id (self-name-struct-info-id me)]) [_ (let ([id ((self-name-struct-info-id me))])
(datum->syntax id (datum->syntax id
(syntax-e id) (syntax-e id)
stx stx
stx))])) stx))]))
#:omit-define-syntaxes)) #:omit-define-syntaxes))
(define-for-syntax option-keywords
"#:mutable, #:constructor-name, #:extra-constructor-name, #:omit-constructor, #:omit-define-syntaxes, or #:omit-define-values")
;; Replacement `struct' signature form for `scheme/unit': ;; Replacement `struct' signature form for `scheme/unit':
(define-for-syntax (do-struct~ stx type-as-ctr?) (define-for-syntax (do-struct~ stx extra-make?)
(syntax-case stx () (syntax-case stx ()
((_ name (field ...) opt ...) ((_ name (field ...) opt ...)
(begin (begin
@ -175,53 +178,85 @@
stx stx
field)]))) field)])))
(syntax->list #'(field ...))) (syntax->list #'(field ...)))
(let-values ([(no-ctr? mutable? no-stx? no-rt?) (let*-values ([(no-ctr? mutable? no-stx? no-rt? opt-cname)
(let loop ([opts (syntax->list #'(opt ...))] (let loop ([opts (syntax->list #'(opt ...))]
[no-ctr? #f] [no-ctr? #f]
[mutable? #f] [mutable? #f]
[no-stx? #f] [no-stx? #f]
[no-rt? #f]) [no-rt? #f]
(if (null? opts) [cname #f])
(values no-ctr? mutable? no-stx? no-rt?) (if (null? opts)
(let ([opt (car opts)]) (values no-ctr? mutable? no-stx? no-rt? cname)
(case (syntax-e opt) (let ([opt (car opts)])
[(#:omit-constructor) (case (syntax-e opt)
(if no-ctr? [(#:constructor-name #:extra-constructor-name)
(raise-syntax-error #f (if cname
"redundant option" (raise-syntax-error #f
stx "redundant option"
opt) stx
(loop (cdr opts) #t mutable? no-stx? no-rt?))] opt)
[(#:mutable) (if (null? (cdr opts))
(if mutable? (raise-syntax-error #f
(raise-syntax-error #f "missing identifier after option"
"redundant option" stx
stx opt)
opt) (if (identifier? (cadr opts))
(loop (cdr opts) no-ctr? #t no-stx? no-rt?))] (loop (cddr opts) #f mutable? no-stx? no-rt?
[(#:omit-define-syntaxes) (if (eq? (syntax-e opt) '#:extra-constructor-name)
(if no-stx? (list (cadr opts))
(raise-syntax-error #f (cadr opts)))
"redundant option" (raise-syntax-error #f
stx "not an identifier for a constructor name"
opt) stx
(loop (cdr opts) no-ctr? mutable? #t no-rt?))] (cadr opts)))))]
[(#:omit-define-values) [(#:omit-constructor)
(if no-rt? (if no-ctr?
(raise-syntax-error #f (raise-syntax-error #f
"redundant option" "redundant option"
stx stx
opt) opt)
(loop (cdr opts) no-ctr? mutable? no-stx? #t))] (loop (cdr opts) #t mutable? no-stx? no-rt? cname))]
[else [(#:mutable)
(raise-syntax-error #f (if mutable?
(string-append (raise-syntax-error #f
"expected a keyword to specify option: " "redundant option"
"#:mutable, #:omit-constructor, #:omit-define-syntaxes, or #:omit-define-values") stx
stx opt)
opt)]))))] (loop (cdr opts) no-ctr? #t no-stx? no-rt? cname))]
[(tmp-name) (and type-as-ctr? [(#:omit-define-syntaxes)
(car (generate-temporaries #'(name))))]) (if no-stx?
(raise-syntax-error #f
"redundant option"
stx
opt)
(loop (cdr opts) no-ctr? mutable? #t no-rt? cname))]
[(#:omit-define-values)
(if no-rt?
(raise-syntax-error #f
"redundant option"
stx
opt)
(loop (cdr opts) no-ctr? mutable? no-stx? #t cname))]
[else
(raise-syntax-error #f
(string-append
"expected a keyword to specify option: "
option-keywords)
stx
opt)]))))]
[(def-cname) (cond
[opt-cname (if (pair? opt-cname)
(car opt-cname)
opt-cname)]
[extra-make? #f]
[else (car (generate-temporaries #'(name)))])]
[(cname) (cond
[opt-cname (if (pair? opt-cname)
(cons def-cname #'name)
(cons opt-cname opt-cname))]
[extra-make? #f]
[else (cons def-cname #'name)])]
[(self-ctr?) (and cname (bound-identifier=? #'name (cdr cname)))])
(cons (cons
#`(define-syntaxes (name) #`(define-syntaxes (name)
#,(let ([e (build-struct-expand-info #,(let ([e (build-struct-expand-info
@ -229,19 +264,19 @@
#f (not mutable?) #f (not mutable?)
#f '(#f) '(#f) #f '(#f) '(#f)
#:omit-constructor? no-ctr? #:omit-constructor? no-ctr?
#:constructor-name (and type-as-ctr? (cons #'name tmp-name)))]) #:constructor-name def-cname)])
(if type-as-ctr? (if self-ctr?
#`(make-self-name-struct-info #`(make-self-name-struct-info
(lambda () #,e) (lambda () #,e)
(quote-syntax #,tmp-name)) (lambda () (quote-syntax #,def-cname)))
e))) e)))
(let ([names (build-struct-names #'name (syntax->list #'(field ...)) (let ([names (build-struct-names #'name (syntax->list #'(field ...))
#f (not mutable?) #f (not mutable?)
#:constructor-name (and type-as-ctr? #:constructor-name def-cname)])
(cons #'name tmp-name)))])
(cond (cond
[no-ctr? (cons (car names) (cddr names))] [no-ctr? (cons (car names) (cddr names))]
[tmp-name (cons #`(define-values-for-export (#,tmp-name) name) names)] [self-ctr? (cons #`(define-values-for-export (#,def-cname) name)
names)]
[else names])))))) [else names]))))))
((_ name fields opt ...) ((_ name fields opt ...)
(raise-syntax-error #f (raise-syntax-error #f
@ -258,9 +293,9 @@
stx)))) stx))))
(define-signature-form (struct~s stx) (define-signature-form (struct~s stx)
(do-struct~ stx #f))
(define-signature-form (struct~r stx)
(do-struct~ stx #t)) (do-struct~ stx #t))
(define-signature-form (struct~r stx)
(do-struct~ stx #f))
(define-signature-form (struct/ctc stx) (define-signature-form (struct/ctc stx)
(parameterize ((error-syntax stx)) (parameterize ((error-syntax stx))
@ -347,7 +382,7 @@
(raise-stx-err "missing name and fields"))))) (raise-stx-err "missing name and fields")))))
;; Replacement struct/ctc form for `scheme/unit': ;; Replacement struct/ctc form for `scheme/unit':
(define-for-syntax (do-struct~/ctc stx type-as-ctr?) (define-for-syntax (do-struct~/ctc stx extra-make?)
(syntax-case stx () (syntax-case stx ()
((_ name ([field ctc] ...) opt ...) ((_ name ([field ctc] ...) opt ...)
(begin (begin
@ -368,53 +403,85 @@
stx stx
field)]))) field)])))
(syntax->list #'(field ...))) (syntax->list #'(field ...)))
(let-values ([(no-ctr? mutable? no-stx? no-rt?) (let*-values ([(no-ctr? mutable? no-stx? no-rt? opt-cname)
(let loop ([opts (syntax->list #'(opt ...))] (let loop ([opts (syntax->list #'(opt ...))]
[no-ctr? #f] [no-ctr? #f]
[mutable? #f] [mutable? #f]
[no-stx? #f] [no-stx? #f]
[no-rt? #f]) [no-rt? #f]
(if (null? opts) [cname #f])
(values no-ctr? mutable? no-stx? no-rt?) (if (null? opts)
(let ([opt (car opts)]) (values no-ctr? mutable? no-stx? no-rt? cname)
(case (syntax-e opt) (let ([opt (car opts)])
[(#:omit-constructor) (case (syntax-e opt)
(if no-ctr? [(#:constructor-name #:extra-constructor-name)
(raise-syntax-error #f (if cname
"redundant option" (raise-syntax-error #f
stx "redundant option"
opt) stx
(loop (cdr opts) #t mutable? no-stx? no-rt?))] opt)
[(#:mutable) (if (null? (cdr opts))
(if mutable? (raise-syntax-error #f
(raise-syntax-error #f "missing identifier after option"
"redundant option" stx
stx opt)
opt) (if (identifier? (cadr opts))
(loop (cdr opts) no-ctr? #t no-stx? no-rt?))] (loop (cddr opts) #f mutable? no-stx? no-rt?
[(#:omit-define-syntaxes) (if (eq? (syntax-e opt) '#:extra-constructor-name)
(if no-stx? (list (cadr opts))
(raise-syntax-error #f (cadr opts)))
"redundant option" (raise-syntax-error #f
stx "not an identifier for a constructor name"
opt) stx
(loop (cdr opts) no-ctr? mutable? #t no-rt?))] (cadr opts)))))]
[(#:omit-define-values) [(#:omit-constructor)
(if no-rt? (if no-ctr?
(raise-syntax-error #f (raise-syntax-error #f
"redundant option" "redundant option"
stx stx
opt) opt)
(loop (cdr opts) no-ctr? mutable? no-stx? #t))] (loop (cdr opts) #t mutable? no-stx? no-rt? cname))]
[else [(#:mutable)
(raise-syntax-error #f (if mutable?
(string-append (raise-syntax-error #f
"expected a keyword to specify option: " "redundant option"
"#:mutable, #:omit-constructor, #:omit-define-syntaxes, or #:omit-define-values") stx
stx opt)
opt)]))))] (loop (cdr opts) no-ctr? #t no-stx? no-rt? cname))]
[(tmp-name) (and type-as-ctr? [(#:omit-define-syntaxes)
(car (generate-temporaries #'(name))))]) (if no-stx?
(raise-syntax-error #f
"redundant option"
stx
opt)
(loop (cdr opts) no-ctr? mutable? #t no-rt? cname))]
[(#:omit-define-values)
(if no-rt?
(raise-syntax-error #f
"redundant option"
stx
opt)
(loop (cdr opts) no-ctr? mutable? no-stx? #t cname))]
[else
(raise-syntax-error #f
(string-append
"expected a keyword to specify option: "
option-keywords)
stx
opt)]))))]
[(def-cname) (cond
[opt-cname (if (pair? opt-cname)
(car opt-cname)
opt-cname)]
[extra-make? #f]
[else (car (generate-temporaries #'(name)))])]
[(cname) (cond
[opt-cname (if (pair? opt-cname)
(cons def-cname #'name)
(cons def-cname def-cname))]
[extra-make? #f]
[else (cons def-cname #'name)])]
[(self-ctr?) (and cname (bound-identifier=? #'name (cdr cname)))])
(define (add-contracts l) (define (add-contracts l)
(let* ([pred (caddr l)] (let* ([pred (caddr l)]
[ctor-ctc #`(-> ctc ... #,pred)] [ctor-ctc #`(-> ctc ... #,pred)]
@ -435,20 +502,29 @@
(map list (cdddr l) field-ctcs)))) (map list (cdddr l) field-ctcs))))
(cons (cons
#`(define-syntaxes (name) #`(define-syntaxes (name)
#,(build-struct-expand-info #,(let ([e (build-struct-expand-info
#'name (syntax->list #'(field ...)) #'name (syntax->list #'(field ...))
#f (not mutable?) #f (not mutable?)
#f '(#f) '(#f) #f '(#f) '(#f)
#:omit-constructor? no-ctr? #:omit-constructor? no-ctr?
#:constructor-name (and type-as-ctr? (cons #'name tmp-name)))) #:constructor-name def-cname)])
(if self-ctr?
#`(make-self-name-struct-info
(lambda () #,e)
(lambda () (quote-syntax #,def-cname)))
e)))
(let* ([names (add-contracts (let* ([names (add-contracts
(build-struct-names #'name (syntax->list #'(field ...)) (build-struct-names #'name (syntax->list #'(field ...))
#f (not mutable?) #f (not mutable?)
#:constructor-name (and type-as-ctr? #:constructor-name def-cname))]
(cons #'name tmp-name))))]
[cpairs (cons 'contracted [cpairs (cons 'contracted
(if no-ctr? (cddr names) (cdr names)))]) (cond
(list (car names) cpairs)))))) [no-ctr? (cddr names)]
[else (cdr names)]))]
[l (list (car names) cpairs)])
(if self-ctr?
(cons #`(define-values-for-export (#,def-cname) name) l)
l))))))
((_ name fields opt ...) ((_ name fields opt ...)
(raise-syntax-error #f (raise-syntax-error #f
"bad syntax; expected a parenthesized sequence of fields" "bad syntax; expected a parenthesized sequence of fields"
@ -464,9 +540,9 @@
stx)))) stx))))
(define-signature-form (struct~s/ctc stx) (define-signature-form (struct~s/ctc stx)
(do-struct~/ctc stx #f))
(define-signature-form (struct~r/ctc stx)
(do-struct~/ctc stx #t)) (do-struct~/ctc stx #t))
(define-signature-form (struct~r/ctc stx)
(do-struct~/ctc stx #f))
;; build-val+macro-defs : sig -> (list syntax-object^3) ;; build-val+macro-defs : sig -> (list syntax-object^3)
(define-for-syntax (build-val+macro-defs sig) (define-for-syntax (build-val+macro-defs sig)

2
collects/planet/info.ss
View File

@ -5,4 +5,4 @@
(define mzscheme-launcher-libraries '("planet.ss")) (define mzscheme-launcher-libraries '("planet.ss"))
(define scribblings '(("planet.scrbl" (multi-page) (tool)))) (define scribblings '(("planet.scrbl" (multi-page) (tool))))
(define racket-tools '(("planet" planet/planet "manage Planet package installations" 80))) (define raco-commands '(("planet" planet/planet "manage Planet package installations" 80)))

2
collects/planet/planet.ss
View File

@ -11,7 +11,7 @@ PLANNED FEATURES:
(only mzlib/list sort) (only mzlib/list sort)
net/url net/url
mzlib/match mzlib/match
tool/command-name raco/command-name
"config.ss" "config.ss"
"private/planet-shared.ss" "private/planet-shared.ss"

7
collects/racket/contract/private/blame.ss
View File

@ -87,8 +87,13 @@
(pretty-display v port) (pretty-display v port)
(get-output-string port))) (get-output-string port)))
(define (pretty-format/write v [columns (pretty-print-columns)])
(let ([port (open-output-string)])
(pretty-write v port)
(get-output-string port)))
(define show/display (show pretty-format/display)) (define show/display (show pretty-format/display))
(define show/write (show pretty-format)) (define show/write (show pretty-format/write))
(define (show-line-break line port len cols) (define (show-line-break line port len cols)
(newline port) (newline port)

12
collects/racket/contract/private/provide.ss
View File

@ -533,7 +533,7 @@
(loop (cdr l1) (loop (cdr l1)
(+ i 1)))]))) (+ i 1)))])))
;; get-field-counts/struct-names : syntax syntax -> (listof (cons symbol number)) ;; get-field-counts/struct-names : syntax syntax -> (listof (cons number symbol))
;; returns a list of numbers corresponding to the numbers of fields for each of the parent structs ;; returns a list of numbers corresponding to the numbers of fields for each of the parent structs
(define (get-field-counts/struct-names struct-name provide-stx) (define (get-field-counts/struct-names struct-name provide-stx)
(let loop ([parent-info-id struct-name]) (let loop ([parent-info-id struct-name])
@ -544,7 +544,7 @@
[(boolean? parent-info) null] [(boolean? parent-info) null]
[else [else
(let ([fields (list-ref parent-info 3)] (let ([fields (list-ref parent-info 3)]
[constructor (list-ref parent-info 1)]) [predicate (list-ref parent-info 2)])
(cond (cond
[(and (not (null? fields)) [(and (not (null? fields))
(not (last fields))) (not (last fields)))
@ -554,16 +554,16 @@
provide-stx provide-stx
struct-name)] struct-name)]
[else [else
(cons (cons (length fields) (constructor->struct-name provide-stx constructor)) (cons (cons (length fields) (predicate->struct-name provide-stx predicate))
(loop (list-ref parent-info 5)))]))])))) (loop (list-ref parent-info 5)))]))]))))
(define (constructor->struct-name orig-stx stx) (define (predicate->struct-name orig-stx stx)
(and stx (and stx
(let ([m (regexp-match #rx"^make-(.*)$" (format "~a" (syntax-e stx)))]) (let ([m (regexp-match #rx"^(.*)[?]$" (format "~a" (syntax-e stx)))])
(cond (cond
[m (cadr m)] [m (cadr m)]
[else (raise-syntax-error 'contract-base.ss [else (raise-syntax-error 'contract-base.ss
"unable to cope with a struct maker whose name doesn't begin with `make-'" "unable to cope with a struct supertype whose predicate doesn't end with `?'"
orig-stx)])))) orig-stx)]))))
;; build-constructor-contract : syntax (listof syntax) syntax -> syntax ;; build-constructor-contract : syntax (listof syntax) syntax -> syntax

6
collects/racket/gui/init.ss
View File

@ -1,6 +0,0 @@
#lang racket
(require racket/init
scheme/gui/base)
(provide (all-from-out racket/init
scheme/gui/base))

2
collects/racket/gui/lang/reader.ss
View File

@ -1,2 +1,4 @@
#lang s-exp syntax/module-reader #lang s-exp syntax/module-reader
racket/gui racket/gui
#:language-info '#(racket/language-info get-info #f)

3
collects/racket/match/parse.ss
View File

@ -153,6 +153,9 @@
[(mcons e1 e2) (make-MPair (parse #'e1) (parse #'e2))] [(mcons e1 e2) (make-MPair (parse #'e1) (parse #'e2))]
[(struct s pats) [(struct s pats)
(parse-struct stx cert parse #'s #'pats)] (parse-struct stx cert parse #'s #'pats)]
[(s . pats)
(struct-info? (syntax-local-value #'s (lambda () #f)))
(parse-struct stx cert parse #'s #'pats)]
[(? p q1 qs ...) [(? p q1 qs ...)
(make-And (cons (make-Pred (cert #'p)) (make-And (cons (make-Pred (cert #'p))
(map parse (syntax->list #'(q1 qs ...)))))] (map parse (syntax->list #'(q1 qs ...)))))]

34
collects/racket/private/define-struct.rkt
View File

@ -54,7 +54,7 @@
1 0 #f 1 0 #f
(list (cons prop:procedure (list (cons prop:procedure
(lambda (v stx) (lambda (v stx)
(self-ctor-transformer (ref v 0) stx)))) (self-ctor-transformer ((ref v 0)) stx))))
(current-inspector) #f '(0))]) (current-inspector) #f '(0))])
make-)) make-))
(define-values-for-syntax (make-self-ctor-checked-struct-info) (define-values-for-syntax (make-self-ctor-checked-struct-info)
@ -63,7 +63,7 @@
1 0 #f 1 0 #f
(list (cons prop:procedure (list (cons prop:procedure
(lambda (v stx) (lambda (v stx)
(self-ctor-transformer (ref v 0) stx)))) (self-ctor-transformer ((ref v 0)) stx))))
(current-inspector) #f '(0))]) (current-inspector) #f '(0))])
make-)) make-))
@ -203,6 +203,7 @@
(#:mutable . #f) (#:mutable . #f)
(#:guard . #f) (#:guard . #f)
(#:constructor-name . #f) (#:constructor-name . #f)
(#:only-constructor? . #f)
(#:omit-define-values . #f) (#:omit-define-values . #f)
(#:omit-define-syntaxes . #f))] (#:omit-define-syntaxes . #f))]
[nongen? #f]) [nongen? #f])
@ -259,14 +260,17 @@
(loop (cdr p) (loop (cdr p)
(extend-config config '#:inspector #'#f) (extend-config config '#:inspector #'#f)
nongen?)] nongen?)]
[(eq? '#:constructor-name (syntax-e (car p))) [(or (eq? '#:constructor-name (syntax-e (car p)))
(eq? '#:extra-constructor-name (syntax-e (car p))))
(check-exprs 1 p "identifier") (check-exprs 1 p "identifier")
(when (lookup config '#:constructor-name) (when (lookup config '#:constructor-name)
(bad "multiple #:constructor-name keys" (car p))) (bad "multiple #:constructor-name or #:extra-constructor-name keys" (car p)))
(unless (identifier? (cadr p)) (unless (identifier? (cadr p))
(bad "need an identifier after #:constructor-name" (cadr p))) (bad "need an identifier after #:constructor-name" (cadr p)))
(loop (cddr p) (loop (cddr p)
(extend-config config '#:constructor-name (cadr p)) (extend-config (extend-config config '#:constructor-name (cadr p))
'#:only-constructor?
(eq? '#:constructor-name (syntax-e (car p))))
nongen?)] nongen?)]
[(eq? '#:prefab (syntax-e (car p))) [(eq? '#:prefab (syntax-e (car p)))
(when (lookup config '#:inspector) (when (lookup config '#:inspector)
@ -360,7 +364,7 @@
(car field-stxes))] (car field-stxes))]
[else [else
(loop (cdr fields) (cdr field-stxes) #f)]))]) (loop (cdr fields) (cdr field-stxes) #f)]))])
(let*-values ([(inspector super-expr props auto-val guard ctor-name mutable? (let*-values ([(inspector super-expr props auto-val guard ctor-name ctor-only? mutable?
omit-define-values? omit-define-syntaxes?) omit-define-values? omit-define-syntaxes?)
(let ([config (parse-props #'fm (syntax->list #'(prop ...)) super-id)]) (let ([config (parse-props #'fm (syntax->list #'(prop ...)) super-id)])
(values (lookup config '#:inspector) (values (lookup config '#:inspector)
@ -369,11 +373,13 @@
(lookup config '#:auto-value) (lookup config '#:auto-value)
(lookup config '#:guard) (lookup config '#:guard)
(lookup config '#:constructor-name) (lookup config '#:constructor-name)
(lookup config '#:only-constructor?)
(lookup config '#:mutable) (lookup config '#:mutable)
(lookup config '#:omit-define-values) (lookup config '#:omit-define-values)
(lookup config '#:omit-define-syntaxes)))] (lookup config '#:omit-define-syntaxes)))]
[(self-ctor?) [(self-ctor?)
(and ctor-name (bound-identifier=? id ctor-name))]) (and ctor-name (bound-identifier=? id ctor-name))]
[(name-as-ctor?) (or self-ctor? (not ctor-only?))])
(when mutable? (when mutable?
(for-each (lambda (f f-stx) (for-each (lambda (f f-stx)
(when (field-mutable? f) (when (field-mutable? f)
@ -454,7 +460,7 @@
(cons i (loop (add1 i) (cdr fields)))] (cons i (loop (add1 i) (cdr fields)))]
[else (loop (add1 i) (cdr fields))])) [else (loop (add1 i) (cdr fields))]))
#,guard #,guard
'#,ctor-name))]) '#,(if ctor-only? ctor-name id)))])
(values struct: make- ? (values struct: make- ?
#,@(let loop ([i 0][fields fields]) #,@(let loop ([i 0][fields fields])
(if (null? fields) (if (null? fields)
@ -476,10 +482,10 @@
#`(quote-syntax #,(prune sel)) #`(quote-syntax #,(prune sel))
sel)))] sel)))]
[mk-info (if super-info-checked? [mk-info (if super-info-checked?
(if self-ctor? (if name-as-ctor?
#'make-self-ctor-checked-struct-info #'make-self-ctor-checked-struct-info
#'make-checked-struct-info) #'make-checked-struct-info)
(if self-ctor? (if name-as-ctor?
#'make-self-ctor-struct-info #'make-self-ctor-struct-info
#'make-struct-info))]) #'make-struct-info))])
(quasisyntax/loc stx (quasisyntax/loc stx
@ -488,7 +494,9 @@
(lambda () (lambda ()
(list (list
(quote-syntax #,(prune struct:)) (quote-syntax #,(prune struct:))
(quote-syntax #,(prune make-)) (quote-syntax #,(prune (if (and ctor-name self-ctor?)
id
make-)))
(quote-syntax #,(prune ?)) (quote-syntax #,(prune ?))
(list (list
#,@(map protect (reverse sels)) #,@(map protect (reverse sels))
@ -517,8 +525,8 @@
(if super-expr (if super-expr
#f #f
#t)))) #t))))
#,@(if self-ctor? #,@(if name-as-ctor?
(list #`(quote-syntax #,make-)) (list #`(lambda () (quote-syntax #,make-)))
null))))))]) null))))))])
(let ([result (let ([result
(cond (cond

11
collects/racket/private/for.rkt
View File

@ -22,6 +22,7 @@
for/last for*/last for/last for*/last
for/hash for*/hash for/hash for*/hash
for/hasheq for*/hasheq for/hasheq for*/hasheq
for/hasheqv for*/hasheqv
for/fold/derived for*/fold/derived for/fold/derived for*/fold/derived
@ -328,7 +329,7 @@
[(hash? v) (:hash-key+val-gen v)] [(hash? v) (:hash-key+val-gen v)]
[(:sequence? v) (make-sequence who ((:sequence-ref v) v))] [(:sequence? v) (make-sequence who ((:sequence-ref v) v))]
[else (raise [else (raise
(make-exn:fail:contract (exn:fail:contract
(format "for: expected a sequence for ~a, got something else: ~v" (format "for: expected a sequence for ~a, got something else: ~v"
(if (= 1 (length who)) (if (= 1 (length who))
(car who) (car who)
@ -952,6 +953,14 @@
#`(let-values ([(key val) #,x]) #`(let-values ([(key val) #,x])
(hash-set table key val)))) (hash-set table key val))))
(define-for-variants (for/hasheqv for*/hasheqv)
([table #hasheqv()])
(lambda (x) x)
(lambda (rhs) rhs)
(lambda (x)
#`(let-values ([(key val) #,x])
(hash-set table key val))))
;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;; specific sequences ;; specific sequences

698
collects/racket/private/kernstruct.rkt
View File

@ -6,266 +6,438 @@
(#%require "define.rkt") (#%require "define.rkt")
(#%require (for-syntax "struct-info.rkt")) (#%require (for-syntax "struct-info.rkt"))
(#%provide (all-defined)) (#%provide (all-defined))
(define-syntax exn (define-values-for-syntax
(make-struct-info (make-self-ctr-struct-info)
(λ () (letrec-values (((struct: make- ? ref set!)
(list (make-struct-type
(quote-syntax struct:exn) 'self-ctor-struct-info
(quote-syntax make-exn) struct:struct-info
(quote-syntax exn?) 1
(list (quote-syntax exn-continuation-marks) (quote-syntax exn-message)) 0
'(#f #f) #f
#t)))) (list
(define-syntax exn:fail (cons
(make-struct-info prop:procedure
(λ () (lambda (v stx)
(list (let-values (((id) ((ref v 0))))
(quote-syntax struct:exn:fail) (if (symbol? (syntax-e stx))
(quote-syntax make-exn:fail) id
(quote-syntax exn:fail?) (datum->syntax
(list (quote-syntax exn-continuation-marks) (quote-syntax exn-message)) stx
'(#f #f) (cons id (cdr (syntax-e stx)))
(quote-syntax exn))))) stx
(define-syntax exn:fail:contract stx))))))
(make-struct-info (current-inspector)
(λ () #f
(list '(0))))
(quote-syntax struct:exn:fail:contract) make-))
(quote-syntax make-exn:fail:contract) (begin
(quote-syntax exn:fail:contract?) (#%require (rename '#%kernel kernel:exn exn))
(list (quote-syntax exn-continuation-marks) (quote-syntax exn-message)) (define make-exn kernel:exn)
'(#f #f) (define-syntax exn
(quote-syntax exn:fail))))) (make-self-ctr-struct-info
(define-syntax exn:fail:contract:arity (λ ()
(make-struct-info (list
(λ () (quote-syntax struct:exn)
(list (quote-syntax make-exn)
(quote-syntax struct:exn:fail:contract:arity) (quote-syntax exn?)
(quote-syntax make-exn:fail:contract:arity) (list
(quote-syntax exn:fail:contract:arity?) (quote-syntax exn-continuation-marks)
(list (quote-syntax exn-continuation-marks) (quote-syntax exn-message)) (quote-syntax exn-message))
'(#f #f) '(#f #f)
(quote-syntax exn:fail:contract))))) #t))
(define-syntax exn:fail:contract:divide-by-zero (λ () (quote-syntax kernel:exn)))))
(make-struct-info (begin
(λ () (#%require (rename '#%kernel kernel:exn:fail exn:fail))
(list (define make-exn:fail kernel:exn:fail)
(quote-syntax struct:exn:fail:contract:divide-by-zero) (define-syntax exn:fail
(quote-syntax make-exn:fail:contract:divide-by-zero) (make-self-ctr-struct-info
(quote-syntax exn:fail:contract:divide-by-zero?) (λ ()
(list (quote-syntax exn-continuation-marks) (quote-syntax exn-message)) (list
'(#f #f) (quote-syntax struct:exn:fail)
(quote-syntax exn:fail:contract))))) (quote-syntax make-exn:fail)
(define-syntax exn:fail:contract:non-fixnum-result (quote-syntax exn:fail?)
(make-struct-info (list
(λ () (quote-syntax exn-continuation-marks)
(list (quote-syntax exn-message))
(quote-syntax struct:exn:fail:contract:non-fixnum-result) '(#f #f)
(quote-syntax make-exn:fail:contract:non-fixnum-result) (quote-syntax exn)))
(quote-syntax exn:fail:contract:non-fixnum-result?) (λ () (quote-syntax kernel:exn:fail)))))
(list (quote-syntax exn-continuation-marks) (quote-syntax exn-message)) (begin
'(#f #f) (#%require (rename '#%kernel kernel:exn:fail:contract exn:fail:contract))
(quote-syntax exn:fail:contract))))) (define make-exn:fail:contract kernel:exn:fail:contract)
(define-syntax exn:fail:contract:continuation (define-syntax exn:fail:contract
(make-struct-info (make-self-ctr-struct-info
(λ () (λ ()
(list (list
(quote-syntax struct:exn:fail:contract:continuation) (quote-syntax struct:exn:fail:contract)
(quote-syntax make-exn:fail:contract:continuation) (quote-syntax make-exn:fail:contract)
(quote-syntax exn:fail:contract:continuation?) (quote-syntax exn:fail:contract?)
(list (quote-syntax exn-continuation-marks) (quote-syntax exn-message)) (list
'(#f #f) (quote-syntax exn-continuation-marks)
(quote-syntax exn:fail:contract))))) (quote-syntax exn-message))
(define-syntax exn:fail:contract:variable '(#f #f)
(make-struct-info (quote-syntax exn:fail)))
(λ () (λ () (quote-syntax kernel:exn:fail:contract)))))
(list (begin
(quote-syntax struct:exn:fail:contract:variable) (#%require
(quote-syntax make-exn:fail:contract:variable) (rename '#%kernel kernel:exn:fail:contract:arity exn:fail:contract:arity))
(quote-syntax exn:fail:contract:variable?) (define make-exn:fail:contract:arity kernel:exn:fail:contract:arity)
(list (define-syntax exn:fail:contract:arity
(quote-syntax exn:fail:contract:variable-id) (make-self-ctr-struct-info
(quote-syntax exn-continuation-marks) (λ ()
(quote-syntax exn-message)) (list
'(#f #f #f) (quote-syntax struct:exn:fail:contract:arity)
(quote-syntax exn:fail:contract))))) (quote-syntax make-exn:fail:contract:arity)
(define-syntax exn:fail:syntax (quote-syntax exn:fail:contract:arity?)
(make-struct-info (list
(λ () (quote-syntax exn-continuation-marks)
(list (quote-syntax exn-message))
(quote-syntax struct:exn:fail:syntax) '(#f #f)
(quote-syntax make-exn:fail:syntax) (quote-syntax exn:fail:contract)))
(quote-syntax exn:fail:syntax?) (λ () (quote-syntax kernel:exn:fail:contract:arity)))))
(list (begin
(quote-syntax exn:fail:syntax-exprs) (#%require
(quote-syntax exn-continuation-marks) (rename '#%kernel
(quote-syntax exn-message)) kernel:exn:fail:contract:divide-by-zero
'(#f #f #f) exn:fail:contract:divide-by-zero))
(quote-syntax exn:fail))))) (define make-exn:fail:contract:divide-by-zero
(define-syntax exn:fail:read kernel:exn:fail:contract:divide-by-zero)
(make-struct-info (define-syntax exn:fail:contract:divide-by-zero
(λ () (make-self-ctr-struct-info
(list (λ ()
(quote-syntax struct:exn:fail:read) (list
(quote-syntax make-exn:fail:read) (quote-syntax struct:exn:fail:contract:divide-by-zero)
(quote-syntax exn:fail:read?) (quote-syntax make-exn:fail:contract:divide-by-zero)
(list (quote-syntax exn:fail:contract:divide-by-zero?)
(quote-syntax exn:fail:read-srclocs) (list
(quote-syntax exn-continuation-marks) (quote-syntax exn-continuation-marks)
(quote-syntax exn-message)) (quote-syntax exn-message))
'(#f #f #f) '(#f #f)
(quote-syntax exn:fail))))) (quote-syntax exn:fail:contract)))
(define-syntax exn:fail:read:eof (λ () (quote-syntax kernel:exn:fail:contract:divide-by-zero)))))
(make-struct-info (begin
(λ () (#%require
(list (rename '#%kernel
(quote-syntax struct:exn:fail:read:eof) kernel:exn:fail:contract:non-fixnum-result
(quote-syntax make-exn:fail:read:eof) exn:fail:contract:non-fixnum-result))
(quote-syntax exn:fail:read:eof?) (define make-exn:fail:contract:non-fixnum-result
(list kernel:exn:fail:contract:non-fixnum-result)
(quote-syntax exn:fail:read-srclocs) (define-syntax exn:fail:contract:non-fixnum-result
(quote-syntax exn-continuation-marks) (make-self-ctr-struct-info
(quote-syntax exn-message)) (λ ()
'(#f #f #f) (list
(quote-syntax exn:fail:read))))) (quote-syntax struct:exn:fail:contract:non-fixnum-result)
(define-syntax exn:fail:read:non-char (quote-syntax make-exn:fail:contract:non-fixnum-result)
(make-struct-info (quote-syntax exn:fail:contract:non-fixnum-result?)
(λ () (list
(list (quote-syntax exn-continuation-marks)
(quote-syntax struct:exn:fail:read:non-char) (quote-syntax exn-message))
(quote-syntax make-exn:fail:read:non-char) '(#f #f)
(quote-syntax exn:fail:read:non-char?) (quote-syntax exn:fail:contract)))
(list (λ () (quote-syntax kernel:exn:fail:contract:non-fixnum-result)))))
(quote-syntax exn:fail:read-srclocs) (begin
(quote-syntax exn-continuation-marks) (#%require
(quote-syntax exn-message)) (rename '#%kernel
'(#f #f #f) kernel:exn:fail:contract:continuation
(quote-syntax exn:fail:read))))) exn:fail:contract:continuation))
(define-syntax exn:fail:filesystem (define make-exn:fail:contract:continuation
(make-struct-info kernel:exn:fail:contract:continuation)
(λ () (define-syntax exn:fail:contract:continuation
(list (make-self-ctr-struct-info
(quote-syntax struct:exn:fail:filesystem) (λ ()
(quote-syntax make-exn:fail:filesystem) (list
(quote-syntax exn:fail:filesystem?) (quote-syntax struct:exn:fail:contract:continuation)
(list (quote-syntax exn-continuation-marks) (quote-syntax exn-message)) (quote-syntax make-exn:fail:contract:continuation)
'(#f #f) (quote-syntax exn:fail:contract:continuation?)
(quote-syntax exn:fail))))) (list
(define-syntax exn:fail:filesystem:exists (quote-syntax exn-continuation-marks)
(make-struct-info (quote-syntax exn-message))
(λ () '(#f #f)
(list (quote-syntax exn:fail:contract)))
(quote-syntax struct:exn:fail:filesystem:exists) (λ () (quote-syntax kernel:exn:fail:contract:continuation)))))
(quote-syntax make-exn:fail:filesystem:exists) (begin
(quote-syntax exn:fail:filesystem:exists?) (#%require
(list (quote-syntax exn-continuation-marks) (quote-syntax exn-message)) (rename '#%kernel
'(#f #f) kernel:exn:fail:contract:variable
(quote-syntax exn:fail:filesystem))))) exn:fail:contract:variable))
(define-syntax exn:fail:filesystem:version (define make-exn:fail:contract:variable kernel:exn:fail:contract:variable)
(make-struct-info (define-syntax exn:fail:contract:variable
(λ () (make-self-ctr-struct-info
(list (λ ()
(quote-syntax struct:exn:fail:filesystem:version) (list
(quote-syntax make-exn:fail:filesystem:version) (quote-syntax struct:exn:fail:contract:variable)
(quote-syntax exn:fail:filesystem:version?) (quote-syntax make-exn:fail:contract:variable)
(list (quote-syntax exn-continuation-marks) (quote-syntax exn-message)) (quote-syntax exn:fail:contract:variable?)
'(#f #f) (list
(quote-syntax exn:fail:filesystem))))) (quote-syntax exn:fail:contract:variable-id)
(define-syntax exn:fail:network (quote-syntax exn-continuation-marks)
(make-struct-info (quote-syntax exn-message))
(λ () '(#f #f #f)
(list (quote-syntax exn:fail:contract)))
(quote-syntax struct:exn:fail:network) (λ () (quote-syntax kernel:exn:fail:contract:variable)))))
(quote-syntax make-exn:fail:network) (begin
(quote-syntax exn:fail:network?) (#%require (rename '#%kernel kernel:exn:fail:syntax exn:fail:syntax))
(list (quote-syntax exn-continuation-marks) (quote-syntax exn-message)) (define make-exn:fail:syntax kernel:exn:fail:syntax)
'(#f #f) (define-syntax exn:fail:syntax
(quote-syntax exn:fail))))) (make-self-ctr-struct-info
(define-syntax exn:fail:out-of-memory (λ ()
(make-struct-info (list
(λ () (quote-syntax struct:exn:fail:syntax)
(list (quote-syntax make-exn:fail:syntax)
(quote-syntax struct:exn:fail:out-of-memory) (quote-syntax exn:fail:syntax?)
(quote-syntax make-exn:fail:out-of-memory) (list
(quote-syntax exn:fail:out-of-memory?) (quote-syntax exn:fail:syntax-exprs)
(list (quote-syntax exn-continuation-marks) (quote-syntax exn-message)) (quote-syntax exn-continuation-marks)
'(#f #f) (quote-syntax exn-message))
(quote-syntax exn:fail))))) '(#f #f #f)
(define-syntax exn:fail:unsupported (quote-syntax exn:fail)))
(make-struct-info (λ () (quote-syntax kernel:exn:fail:syntax)))))
(λ () (begin
(list (#%require (rename '#%kernel kernel:exn:fail:read exn:fail:read))
(quote-syntax struct:exn:fail:unsupported) (define make-exn:fail:read kernel:exn:fail:read)
(quote-syntax make-exn:fail:unsupported) (define-syntax exn:fail:read
(quote-syntax exn:fail:unsupported?) (make-self-ctr-struct-info
(list (quote-syntax exn-continuation-marks) (quote-syntax exn-message)) (λ ()
'(#f #f) (list
(quote-syntax exn:fail))))) (quote-syntax struct:exn:fail:read)
(define-syntax exn:fail:user (quote-syntax make-exn:fail:read)
(make-struct-info (quote-syntax exn:fail:read?)
(λ () (list
(list (quote-syntax exn:fail:read-srclocs)
(quote-syntax struct:exn:fail:user) (quote-syntax exn-continuation-marks)
(quote-syntax make-exn:fail:user) (quote-syntax exn-message))
(quote-syntax exn:fail:user?) '(#f #f #f)
(list (quote-syntax exn-continuation-marks) (quote-syntax exn-message)) (quote-syntax exn:fail)))
'(#f #f) (λ () (quote-syntax kernel:exn:fail:read)))))
(quote-syntax exn:fail))))) (begin
(define-syntax exn:break (#%require (rename '#%kernel kernel:exn:fail:read:eof exn:fail:read:eof))
(make-struct-info (define make-exn:fail:read:eof kernel:exn:fail:read:eof)
(λ () (define-syntax exn:fail:read:eof
(list (make-self-ctr-struct-info
(quote-syntax struct:exn:break) (λ ()
(quote-syntax make-exn:break) (list
(quote-syntax exn:break?) (quote-syntax struct:exn:fail:read:eof)
(list (quote-syntax make-exn:fail:read:eof)
(quote-syntax exn:break-continuation) (quote-syntax exn:fail:read:eof?)
(quote-syntax exn-continuation-marks) (list
(quote-syntax exn-message)) (quote-syntax exn:fail:read-srclocs)
'(#f #f #f) (quote-syntax exn-continuation-marks)
(quote-syntax exn))))) (quote-syntax exn-message))
(define-syntax arity-at-least '(#f #f #f)
(make-struct-info (quote-syntax exn:fail:read)))
(λ () (λ () (quote-syntax kernel:exn:fail:read:eof)))))
(list (begin
(quote-syntax struct:arity-at-least) (#%require
(quote-syntax make-arity-at-least) (rename '#%kernel kernel:exn:fail:read:non-char exn:fail:read:non-char))
(quote-syntax arity-at-least?) (define make-exn:fail:read:non-char kernel:exn:fail:read:non-char)
(list (quote-syntax arity-at-least-value)) (define-syntax exn:fail:read:non-char
'(#f) (make-self-ctr-struct-info
#t)))) (λ ()
(define-syntax date (list
(make-struct-info (quote-syntax struct:exn:fail:read:non-char)
(λ () (quote-syntax make-exn:fail:read:non-char)
(list (quote-syntax exn:fail:read:non-char?)
(quote-syntax struct:date) (list
(quote-syntax make-date) (quote-syntax exn:fail:read-srclocs)
(quote-syntax date?) (quote-syntax exn-continuation-marks)
(list (quote-syntax exn-message))
(quote-syntax date-time-zone-offset) '(#f #f #f)
(quote-syntax date-dst?) (quote-syntax exn:fail:read)))
(quote-syntax date-year-day) (λ () (quote-syntax kernel:exn:fail:read:non-char)))))
(quote-syntax date-week-day) (begin
(quote-syntax date-year) (#%require
(quote-syntax date-month) (rename '#%kernel kernel:exn:fail:filesystem exn:fail:filesystem))
(quote-syntax date-day) (define make-exn:fail:filesystem kernel:exn:fail:filesystem)
(quote-syntax date-hour) (define-syntax exn:fail:filesystem
(quote-syntax date-minute) (make-self-ctr-struct-info
(quote-syntax date-second)) (λ ()
'(#f #f #f #f #f #f #f #f #f #f) (list
#t)))) (quote-syntax struct:exn:fail:filesystem)
(define-syntax srcloc (quote-syntax make-exn:fail:filesystem)
(make-struct-info (quote-syntax exn:fail:filesystem?)
(λ () (list
(list (quote-syntax exn-continuation-marks)
(quote-syntax struct:srcloc) (quote-syntax exn-message))
(quote-syntax make-srcloc) '(#f #f)
(quote-syntax srcloc?) (quote-syntax exn:fail)))
(list (λ () (quote-syntax kernel:exn:fail:filesystem)))))
(quote-syntax srcloc-span) (begin
(quote-syntax srcloc-position) (#%require
(quote-syntax srcloc-column) (rename '#%kernel
(quote-syntax srcloc-line) kernel:exn:fail:filesystem:exists
(quote-syntax srcloc-source)) exn:fail:filesystem:exists))
'(#f #f #f #f #f) (define make-exn:fail:filesystem:exists kernel:exn:fail:filesystem:exists)
#t))))) (define-syntax exn:fail:filesystem:exists
(make-self-ctr-struct-info
(λ ()
(list
(quote-syntax struct:exn:fail:filesystem:exists)
(quote-syntax make-exn:fail:filesystem:exists)
(quote-syntax exn:fail:filesystem:exists?)
(list
(quote-syntax exn-continuation-marks)
(quote-syntax exn-message))
'(#f #f)
(quote-syntax exn:fail:filesystem)))
(λ () (quote-syntax kernel:exn:fail:filesystem:exists)))))
(begin
(#%require
(rename '#%kernel
kernel:exn:fail:filesystem:version
exn:fail:filesystem:version))
(define make-exn:fail:filesystem:version
kernel:exn:fail:filesystem:version)
(define-syntax exn:fail:filesystem:version
(make-self-ctr-struct-info
(λ ()
(list
(quote-syntax struct:exn:fail:filesystem:version)
(quote-syntax make-exn:fail:filesystem:version)
(quote-syntax exn:fail:filesystem:version?)
(list
(quote-syntax exn-continuation-marks)
(quote-syntax exn-message))
'(#f #f)
(quote-syntax exn:fail:filesystem)))
(λ () (quote-syntax kernel:exn:fail:filesystem:version)))))
(begin
(#%require (rename '#%kernel kernel:exn:fail:network exn:fail:network))
(define make-exn:fail:network kernel:exn:fail:network)
(define-syntax exn:fail:network
(make-self-ctr-struct-info
(λ ()
(list
(quote-syntax struct:exn:fail:network)
(quote-syntax make-exn:fail:network)
(quote-syntax exn:fail:network?)
(list
(quote-syntax exn-continuation-marks)
(quote-syntax exn-message))
'(#f #f)
(quote-syntax exn:fail)))
(λ () (quote-syntax kernel:exn:fail:network)))))
(begin
(#%require
(rename '#%kernel kernel:exn:fail:out-of-memory exn:fail:out-of-memory))
(define make-exn:fail:out-of-memory kernel:exn:fail:out-of-memory)
(define-syntax exn:fail:out-of-memory
(make-self-ctr-struct-info
(λ ()
(list
(quote-syntax struct:exn:fail:out-of-memory)
(quote-syntax make-exn:fail:out-of-memory)
(quote-syntax exn:fail:out-of-memory?)
(list
(quote-syntax exn-continuation-marks)
(quote-syntax exn-message))
'(#f #f)
(quote-syntax exn:fail)))
(λ () (quote-syntax kernel:exn:fail:out-of-memory)))))
(begin
(#%require
(rename '#%kernel kernel:exn:fail:unsupported exn:fail:unsupported))
(define make-exn:fail:unsupported kernel:exn:fail:unsupported)
(define-syntax exn:fail:unsupported
(make-self-ctr-struct-info
(λ ()
(list
(quote-syntax struct:exn:fail:unsupported)
(quote-syntax make-exn:fail:unsupported)
(quote-syntax exn:fail:unsupported?)
(list
(quote-syntax exn-continuation-marks)
(quote-syntax exn-message))
'(#f #f)
(quote-syntax exn:fail)))
(λ () (quote-syntax kernel:exn:fail:unsupported)))))
(begin
(#%require (rename '#%kernel kernel:exn:fail:user exn:fail:user))
(define make-exn:fail:user kernel:exn:fail:user)
(define-syntax exn:fail:user
(make-self-ctr-struct-info
(λ ()
(list
(quote-syntax struct:exn:fail:user)
(quote-syntax make-exn:fail:user)
(quote-syntax exn:fail:user?)
(list
(quote-syntax exn-continuation-marks)
(quote-syntax exn-message))
'(#f #f)
(quote-syntax exn:fail)))
(λ () (quote-syntax kernel:exn:fail:user)))))
(begin
(#%require (rename '#%kernel kernel:exn:break exn:break))
(define make-exn:break kernel:exn:break)
(define-syntax exn:break
(make-self-ctr-struct-info
(λ ()
(list
(quote-syntax struct:exn:break)
(quote-syntax make-exn:break)
(quote-syntax exn:break?)
(list
(quote-syntax exn:break-continuation)
(quote-syntax exn-continuation-marks)
(quote-syntax exn-message))
'(#f #f #f)
(quote-syntax exn)))
(λ () (quote-syntax kernel:exn:break)))))
(begin
(#%require (rename '#%kernel kernel:arity-at-least arity-at-least))
(define make-arity-at-least kernel:arity-at-least)
(define-syntax arity-at-least
(make-self-ctr-struct-info
(λ ()
(list
(quote-syntax struct:arity-at-least)
(quote-syntax make-arity-at-least)
(quote-syntax arity-at-least?)
(list (quote-syntax arity-at-least-value))
'(#f)
#t))
(λ () (quote-syntax kernel:arity-at-least)))))
(begin
(#%require (rename '#%kernel kernel:date date))
(define make-date kernel:date)
(define-syntax date
(make-self-ctr-struct-info
(λ ()
(list
(quote-syntax struct:date)
(quote-syntax make-date)
(quote-syntax date?)
(list
(quote-syntax date-time-zone-offset)
(quote-syntax date-dst?)
(quote-syntax date-year-day)
(quote-syntax date-week-day)
(quote-syntax date-year)
(quote-syntax date-month)
(quote-syntax date-day)
(quote-syntax date-hour)
(quote-syntax date-minute)
(quote-syntax date-second))
'(#f #f #f #f #f #f #f #f #f #f)
#t))
(λ () (quote-syntax kernel:date)))))
(begin
(#%require (rename '#%kernel kernel:srcloc srcloc))
(define make-srcloc kernel:srcloc)
(define-syntax srcloc
(make-self-ctr-struct-info
(λ ()
(list
(quote-syntax struct:srcloc)
(quote-syntax make-srcloc)
(quote-syntax srcloc?)
(list
(quote-syntax srcloc-span)
(quote-syntax srcloc-position)
(quote-syntax srcloc-column)
(quote-syntax srcloc-line)
(quote-syntax srcloc-source))
'(#f #f #f #f #f)
#t))
(λ () (quote-syntax kernel:srcloc))))))

4
collects/racket/private/kw.rkt
View File

@ -948,7 +948,7 @@
(object-name p) (object-name p)
p))]) p))])
(raise (raise
(make-exn:fail:contract (exn:fail:contract
(if extra-kw (if extra-kw
(if (keyword-procedure? p) (if (keyword-procedure? p)
(format (format
@ -1028,7 +1028,7 @@
(cond (cond
[(integer? a) (+ a delta)] [(integer? a) (+ a delta)]
[(arity-at-least? a) [(arity-at-least? a)
(make-arity-at-least (+ (arity-at-least-value a) delta))] (arity-at-least (+ (arity-at-least-value a) delta))]
[else [else
(map loop a)])))] (map loop a)])))]
[new-arity (inc-arity arity 2)] [new-arity (inc-arity arity 2)]

4
collects/racket/private/misc.rkt
View File

@ -99,7 +99,7 @@
(let-values ([(base name dir?) (split-path n)]) (let-values ([(base name dir?) (split-path n)])
(if dir? (if dir?
(raise (raise
(make-exn:fail:filesystem (exn:fail:filesystem
(string->immutable-string (string->immutable-string
(format "load/cd: cannot open a directory: ~s" n)) (format "load/cd: cannot open a directory: ~s" n))
(current-continuation-marks))) (current-continuation-marks)))
@ -108,7 +108,7 @@
(begin (begin
(if (not (directory-exists? base)) (if (not (directory-exists? base))
(raise (raise
(make-exn:fail:filesystem (exn:fail:filesystem
(string->immutable-string (string->immutable-string
(format (format
"load/cd: directory of ~s does not exist (current directory is ~s)" "load/cd: directory of ~s does not exist (current directory is ~s)"

12
collects/racket/private/more-scheme.rkt
View File

@ -367,9 +367,10 @@
(let* ([not-there (gensym)] (let* ([not-there (gensym)]
[up (lambda (who mut? set ht key xform default) [up (lambda (who mut? set ht key xform default)
(unless (and (hash? ht) (unless (and (hash? ht)
(or (not mut?) (if mut?
(not (immutable? ht)))) (not (immutable? ht))
(raise-type-error who (if mut? "mutable hash" "hash") ht)) (immutable? ht)))
(raise-type-error who (if mut? "mutable hash table" "immutable hash table") ht))
(unless (and (procedure? xform) (unless (and (procedure? xform)
(procedure-arity-includes? xform 1)) (procedure-arity-includes? xform 1))
(raise-type-error who "procedure (arity 1)" xform)) (raise-type-error who "procedure (arity 1)" xform))
@ -391,9 +392,14 @@
(hash-update! ht key xform not-there)])] (hash-update! ht key xform not-there)])]
[hash-has-key? [hash-has-key?
(lambda (ht key) (lambda (ht key)
(unless (hash? ht)
(raise-type-error 'hash-has-key? "hash table" 0 ht key))
(not (eq? not-there (hash-ref ht key not-there))))] (not (eq? not-there (hash-ref ht key not-there))))]
[hash-ref! [hash-ref!
(lambda (ht key new) (lambda (ht key new)
(unless (and (hash? ht)
(not (immutable? ht)))
(raise-type-error 'hash-ref! "mutable hash table" 0 ht key new))
(let ([v (hash-ref ht key not-there)]) (let ([v (hash-ref ht key not-there)])
(if (eq? not-there v) (if (eq? not-there v)
(let ([n (if (procedure? new) (new) new)]) (let ([n (if (procedure? new) (new) new)])

4
collects/racket/private/namespace.rkt
View File

@ -19,14 +19,14 @@
[ns (parameterize ([current-namespace this-ns]) ; ensures correct phase [ns (parameterize ([current-namespace this-ns]) ; ensures correct phase
(make-empty-namespace))]) (make-empty-namespace))])
(namespace-attach-module this-ns (namespace-attach-module this-ns
'scheme/base 'racket/base
ns) ns)
ns)) ns))
(define (make-base-namespace) (define (make-base-namespace)
(let ([ns (make-base-empty-namespace)]) (let ([ns (make-base-empty-namespace)])
(parameterize ([current-namespace ns]) (parameterize ([current-namespace ns])
(namespace-require 'scheme/base)) (namespace-require 'racket/base))
ns)) ns))
;; ---------------------------------------- ;; ----------------------------------------

1
collects/racket/private/struct.rkt
View File

@ -14,6 +14,7 @@
(cond (cond
[(syntax? config) (config-has-name? (syntax-e config))] [(syntax? config) (config-has-name? (syntax-e config))]
[(pair? config) (or (eq? (syntax-e (car config)) '#:constructor-name) [(pair? config) (or (eq? (syntax-e (car config)) '#:constructor-name)
(eq? (syntax-e (car config)) '#:extra-constructor-name)
(config-has-name? (cdr config)))] (config-has-name? (cdr config)))]
[else #f])) [else #f]))
(with-syntax ([orig stx]) (with-syntax ([orig stx])

3
collects/racket/runtime-config.rkt
View File

@ -4,7 +4,4 @@
(define-values (configure) (define-values (configure)
(lambda (config) (lambda (config)
(current-prompt-read (lambda ()
(printf "> ")
(read)))
(print-as-quasiquote #t)))) (print-as-quasiquote #t))))

22
collects/racket/sandbox.rkt
View File

@ -1,11 +1,11 @@
#lang scheme/base #lang racket/base
(require scheme/port (require racket/port
scheme/path racket/path
scheme/list racket/list
scheme/string racket/string
syntax/moddep syntax/moddep
scheme/gui/dynamic racket/gui/dynamic
planet/config) planet/config)
(provide gui? (provide gui?
@ -53,7 +53,7 @@
(define gui? (gui-available?)) (define gui? (gui-available?))
(define-syntax mz/mr ; use a value for mzscheme, or pull a mred binding (define-syntax mz/mr ; use a value for mzracket, or pull a mred binding
(syntax-rules () (syntax-rules ()
[(mz/mr mzval mrsym) [(mz/mr mzval mrsym)
(if gui? (gui-dynamic-require 'mrsym) mzval)])) (if gui? (gui-dynamic-require 'mrsym) mzval)]))
@ -479,8 +479,8 @@
;; needed to make the test-engine work ;; needed to make the test-engine work
(let ([orig-ns (namespace-anchor->empty-namespace anchor)]) (let ([orig-ns (namespace-anchor->empty-namespace anchor)])
(parameterize ([current-namespace orig-ns]) (parameterize ([current-namespace orig-ns])
(dynamic-require 'scheme/class #f)) (dynamic-require 'racket/class #f))
(namespace-attach-module orig-ns 'scheme/class))])) (namespace-attach-module orig-ns 'racket/class))]))
;; Returns a single (module ...) or (begin ...) expression (a `begin' list ;; Returns a single (module ...) or (begin ...) expression (a `begin' list
;; will be evaluated one by one -- the language might not have a `begin'). ;; will be evaluated one by one -- the language might not have a `begin').
@ -490,7 +490,7 @@
;; A more general solution would be to create a new module that exports ;; A more general solution would be to create a new module that exports
;; the given language plus all of the given extra requires. ;; the given language plus all of the given extra requires.
;; ;;
;; We use `#%requre' because, unlike the `require' of scheme/base, ;; We use `#%requre' because, unlike the `require' of racket/base,
;; it comes from `#%kernel', so it's always present through ;; it comes from `#%kernel', so it's always present through
;; transitive requires. ;; transitive requires.
(define (build-program language requires input-program) (define (build-program language requires input-program)
@ -882,7 +882,7 @@
(if (eq? h default-sandbox-exit-handler) (if (eq? h default-sandbox-exit-handler)
(lambda _ (terminate+kill! 'exited #f)) (lambda _ (terminate+kill! 'exited #f))
h))] h))]
;; Note the above definition of `current-eventspace': in MzScheme, it ;; Note the above definition of `current-eventspace': in Racket, it
;; is an unused parameter. Also note that creating an eventspace ;; is an unused parameter. Also note that creating an eventspace
;; starts a thread that will eventually run the callback code (which ;; starts a thread that will eventually run the callback code (which
;; evaluates the program in `run-in-bg') -- so this parameterization ;; evaluates the program in `run-in-bg') -- so this parameterization

31
collects/racket/set.rkt
View File

@ -6,8 +6,11 @@
set-empty? set-count set-empty? set-count
set-member? set-add set-remove set-member? set-add set-remove
set-union set-intersect set-subtract set-union set-intersect set-subtract
subset?
set-map set-for-each set-map set-for-each
(rename-out [*in-set in-set])) (rename-out [*in-set in-set])
for/set for/seteq for/seteqv
for*/set for*/seteq for*/seteqv)
(define-struct set (ht) (define-struct set (ht)
#:omit-define-syntaxes #:omit-define-syntaxes
@ -161,6 +164,18 @@
(for/fold ([set set]) ([set2 (in-list sets)]) (for/fold ([set set]) ([set2 (in-list sets)])
(set-subtract set set2))])) (set-subtract set set2))]))
(define (subset? set2 set1)
(unless (set? set2) (raise-type-error 'subset? "set" 0 set2 set1))
(unless (set? set1) (raise-type-error 'subset? "set" 0 set2 set1))
(let ([ht1 (set-ht set1)]
[ht2 (set-ht set2)])
(unless (and (eq? (hash-eq? ht1) (hash-eq? ht2))
(eq? (hash-eqv? ht1) (hash-eqv? ht2)))
(raise-mismatch-error 'set-subset? "second set's equivalence predicate is not the same as the first set: "
set2))
(for/and ([v (in-hash-keys ht2)])
(hash-ref ht1 v #f))))
(define (set-map set proc) (define (set-map set proc)
(unless (set? set) (raise-type-error 'set-map "set" 0 set proc)) (unless (set? set) (raise-type-error 'set-map "set" 0 set proc))
(unless (and (procedure? proc) (unless (and (procedure? proc)
@ -206,3 +221,17 @@
#t #t
;; loop args ;; loop args
((hash-iterate-next ht pos)))]]))) ((hash-iterate-next ht pos)))]])))
(define-syntax-rule (define-for for/fold/derived for/set set)
(define-syntax (for/set stx)
(syntax-case stx ()
[(_ bindings . body)
(quasisyntax/loc stx
(for/fold/derived #,stx ([s (set)]) bindings (set-add s (let () . body))))])))
(define-for for/fold/derived for/set set)
(define-for for*/fold/derived for*/set set)
(define-for for/fold/derived for/seteq seteq)
(define-for for*/fold/derived for*/seteq seteq)
(define-for for/fold/derived for/seteqv seteqv)
(define-for for*/fold/derived for*/seteqv seteqv)

0
collects/scheme/signature/lang.ss → collects/racket/signature/lang.rkt
View File

2
collects/racket/signature/lang/reader.ss Normal file
View File

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

7
collects/racket/unit.rkt
View File

@ -5,6 +5,7 @@
(for-syntax racket/base (for-syntax racket/base
syntax/struct)) syntax/struct))
(provide (except-out (all-from-out mzlib/unit) (provide (except-out (all-from-out mzlib/unit)
struct struct/ctc struct struct/ctc
struct~r struct~r/ctc struct~r struct~r/ctc
struct~s struct~s/ctc))) struct~s struct~s/ctc)
(rename-out [struct~r/ctc struct/ctc])))

0
collects/scheme/unit/lang.ss → collects/racket/unit/lang.rkt
View File

2
collects/racket/unit/lang/reader.ss Normal file
View File

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

6
collects/tool/all-tools.ss → collects/raco/all-tools.ss
View File

@ -4,11 +4,11 @@
(provide all-tools) (provide all-tools)
(define (all-tools) (define (all-tools)
(let* ([dirs (find-relevant-directories '(racket-tools))] (let* ([dirs (find-relevant-directories '(raco-commands))]
[tools (make-hash)]) [tools (make-hash)])
(for ([i (in-list (map get-info/full dirs))] (for ([i (in-list (map get-info/full dirs))]
[d (in-list dirs)]) [d (in-list dirs)])
(let ([entries (let ([l (i 'racket-tools (lambda () null))]) (let ([entries (let ([l (i 'raco-commands (lambda () null))])
(if (list? l) (if (list? l)
l l
(list l)))]) (list l)))])
@ -33,7 +33,7 @@
[else [else
(fprintf (fprintf
(current-error-port) (current-error-port)
"warning: ~s provided bad `racket-tools' spec: ~e" "warning: ~s provided bad `raco-commands' spec: ~e"
d d
entry)])))) entry)]))))
tools)) tools))

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