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

Merge branch 'master' of pltgit:plt

Browse Source
This commit is contained in:
Stephen Bloch 2011-04-28 21:58:21 -04:00
commit 8fb0f8840d
47 changed files with 742 additions and 414 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

15
collects/framework/private/main.rkt
View File

@ -221,11 +221,13 @@
'(struct
local
define-type
struct: define-struct: define-struct/exec:
define:
define-type define-predicate
match-define))
(for-each (λ (x)
(hash-set! hash-table x 'begin))
'(case-lambda
'(case-lambda case-lambda: pcase-lambda:
match-lambda match-lambda*
cond
delay
@ -250,10 +252,19 @@
let/cc let/ec letcc catch
let-syntax letrec-syntax fluid-let-syntax letrec-syntaxes+values
let: letrec: let*:
let-values: letrec-values: let*-values:
let/cc: let/ec:
lambda: λ:
plambda: opt-lambda: popt-lambda:
for for/list for/hash for/hasheq for/and for/or
for/lists for/first for/last for/fold
for* for*/list for*/hash for*/hasheq for*/and for*/or
for*/lists for*/first for*/last for*/fold
for: for/list: for/or: for/lists: for/fold:
for*: for*/lists: for*/fold: do:
kernel-syntax-case
syntax-case syntax-case* syntax-rules syntax-id-rules

6
collects/redex/examples/stlc.rkt
View File

@ -154,10 +154,16 @@
(test-equal (term (tc x)) (term #f))
(test-equal (term (tc x (x num) (x (-> num num)))) (term num))
(test-equal (term (tc ((λ ((x num)) x) 1))) (term num))
(test-equal (term (tc ((λ ((x num)) x) 1 2))) (term #f))
(test-equal (term (tc ((λ ((f (-> num num)) (x num)) (f x)) (λ ((x num)) x) 1))) (term num))
(test-equal (term (tc (+ (+ 1 2) 3))) (term num))
(test-equal (term (tc (if0 1 (λ ((x num)) x) 3))) (term #f))
(test-equal (term (tc (if0 1 2 3))) (term num))
(test-equal (term (tc (λ ((x num)) (x)))) (term #f))
(test-equal (term (tc (1 2)))
(term #f))
(test-equal (term (tc (λ ((x num)) (1 2))))
(term #f))
(test-results)

2
collects/scribblings/reference/futures.scrbl
View File

@ -23,7 +23,7 @@ The @racket[future] and @racket[touch] functions from
by the hardware and operating system. In contrast to @racket[thread],
which provides concurrency for arbitrary computations without
parallelism, @racket[future] provides parallelism for limited
computations. A future executes its work in parallel (assuming that
computations. A @deftech{future} executes its work in parallel (assuming that
support for parallelism is available) until it detects an attempt to
perform an operation that is too complex for the system to run safely in
parallel. Similarly, work in a future is suspended if it depends in some

25
collects/stepper/break.rkt
View File

@ -1,25 +0,0 @@
(module break mzscheme
(require mzlib/contract)
(provide current-breakpoint-handler)
(define (default-current-breakpoint-handler)
(error 'default-current-breakpoint-handler
"The current-breakpoint-handler parameter has not yet been set in this thread."))
(define current-breakpoint-handler
(make-parameter
default-current-breakpoint-handler
(lambda (new-handler)
(if (and (procedure? new-handler)
(procedure-arity-includes? new-handler 0))
new-handler
(error 'current-breakpoint-handler
"Bad value for current-breakpoint-handler: ~e"
new-handler)))))
(provide/contract [break (-> any)])
(define (break)
((current-breakpoint-handler))))

14
collects/stepper/info.rkt
View File

@ -1,15 +1,11 @@
#lang setup/infotab
(define tools '(("stepper+xml-tool.ss")
;; ("debugger-tool.ss")
))
(define drracket-tools '(("stepper+xml-tool.ss")))
(define tool-names (list "The Stepper"
;; "The Debugger"
))
(define drracket-tool-names (list "The Stepper"))
(define tool-icons (list '("foot-up.png" "icons")
;; #f
))
(define drracket-tool-icons (list '("foot-up.png" "icons")))
(define compile-omit-paths '("debugger-tool.ss"))
(define scribblings '(("scribblings/stepper.scrbl")))

24
collects/stepper/view-controller.rkt → collects/stepper/private/view-controller.rkt
View File

@ -6,21 +6,21 @@
(require racket/class
racket/match
racket/list
drscheme/tool
drracket/tool
mred
string-constants
racket/async-channel
(prefix-in model: "private/model.ss")
(prefix-in x: "private/mred-extensions.ss")
"private/shared.ss"
"private/model-settings.ss"
(prefix-in model: "model.ss")
(prefix-in x: "mred-extensions.ss")
"shared.ss"
"model-settings.ss"
"xml-sig.ss")
(import drscheme:tool^ xml^ stepper-frame^)
(import drracket:tool^ xml^ stepper-frame^)
(export view-controller^)
(define drscheme-eventspace (current-eventspace))
(define drracket-eventspace (current-eventspace))
(define (definitions-text->settings definitions-text)
(send definitions-text get-next-settings))
@ -28,12 +28,12 @@
;; the stored representation of a step
(define-struct step (text kind posns) #:transparent)
(define (go drscheme-frame program-expander selection-start selection-end)
(define (go drracket-tab program-expander selection-start selection-end)
;; get the language-level:
(define language-settings (definitions-text->settings (send drscheme-frame get-definitions-text)))
(define language-level (drscheme:language-configuration:language-settings-language language-settings))
(define simple-settings (drscheme:language-configuration:language-settings-settings language-settings))
(define language-settings (definitions-text->settings (send drracket-tab get-defs)))
(define language-level (drracket:language-configuration:language-settings-language language-settings))
(define simple-settings (drracket:language-configuration:language-settings-settings language-settings))
;; VALUE CONVERSION CODE:
@ -211,7 +211,7 @@
;; GUI ELEMENTS:
(define s-frame
(make-object stepper-frame% drscheme-frame))
(make-object stepper-frame% drracket-tab))
(define button-panel
(make-object horizontal-panel% (send s-frame get-area-container)))
(define (add-button name fun)

0
collects/stepper/xml-sig.rkt → collects/stepper/private/xml-sig.rkt
View File

177
collects/stepper/scribblings/stepper.scrbl Normal file
View File

@ -0,0 +1,177 @@
#lang scribble/doc
@(require scribble/manual)
@title{The Stepper}
@section{What is the Stepper?}
DrRacket includes an "algebraic stepper," a tool which proceeds
through the evaluation of a set of definitions and expressions,
one step at a time. This evaluation shows the user how DrRacket
evaluates expressions and definitions, and can help in debugging
programs. Currently, the Stepper is available in the "Beginning
Student" and "Intermediate Student" language levels.
@section{How do I use the Stepper?}
The Stepper operates on the contents of the frontmost DrRacket
window. A click on the "Step" button brings up the stepper
window. The stepper window has two panes, arranged as follows:
@verbatim{
------------------
| | |
| before -> after|
| | |
------------------
}
The first, "before," box, shows the current expression. The
region highlighted in green is known as the "redex". You may
pronounce this word in any way you want. It is short for
"reducible expression," and it is the expression which is the
next to be simplified.
The second, "after," box shows the result of the reduction. The
region highlighted in purple is the new expression which is
substituted for the green one as a result of the reduction. For
most reductions, the only difference between the left- and right-hand
sides should be the contents of the green and purple boxes.
Please note that the stepper only steps through the expressions
in the definitions window, and does not allow the user to enter
additional expressions. So, for instance, a definitions buffer
which contains only procedure definitions will not result in
any reductions.
@section{How Does the Stepper work?}
In order to discover all of the steps that occur during the evaluation
of your code, the Stepper rewrites (or "instruments") your code.
The inserted code uses a mechanism called "continuation marks" to
store information about the program's execution as it is running,
and makes calls to the Stepper before, after and during the evaluation
of each expression, indicating the current shape of the program.
What does this instrumented code look like? For the curious, here's the
expanded version of @racket[(define (f x) (+ 3 x))] in the beginner
language [*]:
@racketblock[
(module #%htdp (lib "lang/htdp-beginner.ss")
(#%plain-module-begin
(define-syntaxes (f)
(#%app make-first-order-function
(quote procedure)
(quote 1)
(quote-syntax f)
(quote-syntax #%app)))
(define-values (test~object) (#%app namespace-variable-value (quote test~object)))
(begin
(define-values (f)
(with-continuation-mark "#<debug-key-struct>"
(#%plain-lambda () (#%plain-app "#<procedure:...rivate/marks.rkt:70:2>"))
(#%plain-app
call-with-values
(#%plain-lambda ()
(with-continuation-mark "#<debug-key-struct>"
(#%plain-lambda () (#%plain-app
"#<procedure:...rivate/marks.rkt:70:2>"
(#%plain-lambda () beginner:+)))
(#%plain-app
"#<procedure:closure-storing-proc>"
(#%plain-lambda (x)
(begin
(let-values (((arg0-1643 arg1-1644 arg2-1645)
(#%plain-app
values
"#<*unevaluated-struct*>"
"#<*unevaluated-struct*>"
"#<*unevaluated-struct*>")))
(with-continuation-mark "#<debug-key-struct>"
(#%plain-lambda ()
(#%plain-app
"#<procedure:...rivate/marks.rkt:70:2>"
(#%plain-lambda () beginner:+)
(#%plain-lambda () x)
(#%plain-lambda () arg0-1643)
(#%plain-lambda () arg1-1644)
(#%plain-lambda () arg2-1645)))
(begin
(#%plain-app "#<procedure:result-exp-break>")
(begin
(set! arg0-1643
(with-continuation-mark "#<debug-key-struct>"
(#%plain-lambda ()
(#%plain-app
"#<procedure:...rivate/marks.rkt:70:2>"))
beginner:+))
(set! arg1-1644
(with-continuation-mark "#<debug-key-struct>"
(#%plain-lambda ()
(#%plain-app
"#<procedure:...rivate/marks.rkt:70:2>"))
(quote 3)))
(set! arg2-1645
(with-continuation-mark "#<debug-key-struct>"
(#%plain-lambda ()
(#%plain-app
"#<procedure:...rivate/marks.rkt:70:2>")) x))
(begin
(#%plain-app "#<procedure:normal-break>")
(with-continuation-mark "#<debug-key-struct>"
(#%plain-lambda ()
(#%plain-app
"#<procedure:...rivate/marks.rkt:70:2>"
(#%plain-lambda () arg0-1643)
(#%plain-lambda () arg1-1644)
(#%plain-lambda () arg2-1645)))
(if (#%plain-app
"#<procedure:annotated-proc?>"
arg0-1643)
(#%plain-app
arg0-1643
arg1-1644
arg2-1645)
(#%plain-app
call-with-values
(#%plain-lambda ()
(#%plain-app arg0-1643 arg1-1644 arg2-1645))
(#%plain-lambda args
(#%plain-app
"#<procedure:result-value-break>"
args)
(#%plain-app
"#<procedure:apply>"
values
args))))))))))))
(#%plain-lambda ()
(#%plain-app
"#<procedure:...rivate/marks.rkt:70:2>"
(#%plain-lambda () beginner:+))) #f)))
(#%plain-lambda args
(#%plain-app "#<procedure:apply>" values args)))))
(#%plain-app "#<procedure:exp-finished-break>"
(#%plain-app
list
(#%plain-app
list
"#<procedure:...ate/annotate.rkt:1256:93>"
#f
(#%plain-lambda () (#%plain-app list f))))))))
(let-values (((done-already?) (quote #f)))
(#%app dynamic-wind void
(lambda () (#%app dynamic-require (quote (quote #%htdp)) (quote #f)))
(lambda () (if done-already?
(#%app void)
(let-values ()
(set! done-already? (quote #t))
(#%app test*)
(#%app current-namespace
(#%app module->namespace
(quote (quote #%htdp)))))))))]
[*] : In order to allow things like @verbatim{#<procedure:apply>} in scribble, I've taken the cheap solution of wrapping them in quotes. These are not actually strings, they're opaque 3D syntax elements.

38
collects/stepper/stepper+xml-tool.rkt
View File

@ -1,25 +1,19 @@
(module stepper+xml-tool mzscheme
(require mzlib/unit
drscheme/tool
"stepper-tool.ss"
"xml-tool.ss"
"view-controller.ss"
"private/shared.ss")
#lang racket
(provide tool@)
(require drracket/tool
"stepper-tool.rkt"
"xml-tool.rkt"
"private/view-controller.rkt")
;; the xml and stepper tools are combined, so that the stepper can create XML
;; snips. note that both of these tools provide 'void' for phase1 and phase2
;; (which together make up the tool-exports^), so we can provide either one
;; of these for the compound unit. Doesn't matter.
;; NNNURRRG! This is not true any more. But that should be okay, because the
;; stepper-tool phase1 is the non-void one. -- JBC, 2006-09-28
(provide tool@)
(define tool@
(compound-unit/infer
(import drscheme:tool^)
(export STEPPER-TOOL)
(link xml-tool@
view-controller@
[((STEPPER-TOOL : drscheme:tool-exports^)) stepper-tool@]))))
;; the xml and stepper tools are combined, so that the stepper can create XML
;; snips.
(define tool@
(compound-unit/infer
(import drracket:tool^)
(export STEPPER-TOOL)
(link xml-tool@
view-controller@
[((STEPPER-TOOL : drracket:tool-exports^)) stepper-tool@])))

272
collects/stepper/stepper-tool.rkt
View File

@ -1,27 +1,26 @@
#lang racket/unit
(require scheme/class
drscheme/tool
(require racket/class
drracket/tool
mred
mzlib/pconvert
string-constants
(prefix-in frame: framework)
mrlib/switchable-button
(file "private/my-macros.ss")
(prefix-in x: "private/mred-extensions.ss")
"private/shared.ss"
mzlib/pconvert
racket/pretty
string-constants
lang/stepper-language-interface
scheme/pretty
"xml-sig.ss"
(prefix-in x: "private/mred-extensions.rkt")
"private/shared.rkt"
"private/xml-sig.rkt"
"drracket-button.ss") ;; get the stepper-button-callback private-member-name
(import drscheme:tool^ xml^ view-controller^)
(export drscheme:tool-exports^ stepper-frame^)
(import drracket:tool^ xml^ view-controller^)
(export drracket:tool-exports^ stepper-frame^)
;; tool magic here:
(define (phase1)
;; experiment with extending the language... parameter-like fields for stepper parameters
(drscheme:language:extend-language-interface
(drracket:language:extend-language-interface
stepper-language<%>
(lambda (superclass)
(class* superclass (stepper-language<%>)
@ -67,7 +66,7 @@
(send definitions-text get-next-settings))
(define (settings->language-level settings)
(drscheme:language-configuration:language-settings-language settings))
(drracket:language-configuration:language-settings-language settings))
(define (stepper-works-for? language-level)
(or (send language-level stepper:supported?)
@ -76,10 +75,10 @@
;; the stepper's frame:
(define stepper-frame%
(class (drscheme:frame:basics-mixin
(class (drracket:frame:basics-mixin
(frame:frame:standard-menus-mixin frame:frame:basic%))
(init-field drscheme-frame)
(init-field drracket-tab)
;; PRINTING-PROC
;; I frankly don't think that printing (i.e., to a printer) works
@ -114,7 +113,7 @@
(define/augment (on-close)
(when custodian
(custodian-shutdown-all custodian))
(send drscheme-frame on-stepper-close)
(send drracket-tab on-stepper-close)
(inner (void) on-close))
;; WARNING BOXES:
@ -153,20 +152,91 @@
[height stepper-initial-height])))
;; stepper-unit-frame<%> : the interface that the extended drscheme frame
;; stepper-unit-frame<%> : the interface that the extended drracket frame
;; fulfils
(define stepper-unit-frame<%>
(define stepper-tab<%>
(interface ()
get-stepper-frame
on-stepper-close))
;; stepper-unit-frame-mixin : the mixin that is applied to the drscheme
;; frame to interact with a possible stepper window
;; stepper-unit-frame-mixin : the mixin that is applied to the drracket
;; frame to interact with a possible stepper window. Specifically, this
;; mixin needs to manage the creation and visibility of the stepper button.
(define (stepper-unit-frame-mixin super%)
(class* super% (stepper-unit-frame<%>)
(class* super% ()
(inherit get-button-panel register-toolbar-button get-current-tab get-tabs)
(inherit get-button-panel register-toolbar-button get-interactions-text get-definitions-text)
(super-new)
;; STEPPER BUTTON
(define/public (get-stepper-button) stepper-button)
(define stepper-button-parent-panel
(new horizontal-panel%
[parent (get-button-panel)]
[stretchable-width #f]
[stretchable-height #f]))
(define stepper-button
(new switchable-button%
[parent stepper-button-parent-panel]
[label (string-constant stepper-button-label)]
[bitmap x:foot-img/horizontal]
[alternate-bitmap x:foot-img/vertical]
[callback (lambda (dont-care) (send (get-current-tab)
stepper-button-callback))]))
(register-toolbar-button stepper-button)
(define (stepper-button-show)
(unless (send stepper-button is-shown?)
(send (send stepper-button get-parent)
add-child stepper-button)))
(define (stepper-button-hide)
(when (send stepper-button is-shown?)
(send (send stepper-button get-parent)
delete-child stepper-button)))
;; when the window closes, notify all of the stepper frames.
(define/augment (on-close)
(for ([tab (in-list (get-tabs))])
(define possible-stepper-frame (send tab get-stepper-frame))
(when possible-stepper-frame
(send possible-stepper-frame original-program-gone)))
(inner (void) on-close))
;; when we change tabs, show or hide the stepper button.
(define/augment (on-tab-change old new)
(show/hide-stepper-button)
(inner (void) on-tab-change old new))
;; add the stepper button to the button panel:
(send (get-button-panel) change-children
(lambda (x)
(cons stepper-button-parent-panel
(remq stepper-button-parent-panel x))))
;; show or hide the stepper button depending
;; on the language level
(define/public (show/hide-stepper-button)
(cond [(send (get-current-tab) current-lang-supports-stepper?)
(stepper-button-show)]
[else
(stepper-button-hide)]))
;; hide stepper button if it's not supported for the initial language:
(show/hide-stepper-button)))
;; stepper-tab-mixin : the mixin that is applied to drracket tabs, to
;; interact with a possible stepper window.
(define (stepper-tab-mixin super%)
(class* super% (stepper-tab<%>)
(inherit get-ints get-defs get-frame)
;; a reference to a possible stepper frame.
(define stepper-frame #f)
(define/public (on-stepper-close)
(set! stepper-frame #f))
@ -178,14 +248,14 @@
;; definitions window one at a time and calls 'iter' on each one
(define (program-expander init iter)
(let* ([lang-settings
(send (get-definitions-text) get-next-settings)]
[lang (drscheme:language-configuration:language-settings-language lang-settings)]
[settings (drscheme:language-configuration:language-settings-settings lang-settings)])
(drscheme:eval:expand-program
(drscheme:language:make-text/pos
(get-definitions-text)
(send (get-defs) get-next-settings)]
[lang (drracket:language-configuration:language-settings-language lang-settings)]
[settings (drracket:language-configuration:language-settings-settings lang-settings)])
(drracket:eval:expand-program
(drracket:language:make-text/pos
(get-defs)
0
(send (get-definitions-text) last-position))
(send (get-defs) last-position))
lang-settings
#f
(lambda ()
@ -203,108 +273,75 @@
void ; kill
iter)))
;; STEPPER BUTTON
(define/public (get-stepper-button) stepper-button)
(define stepper-button-parent-panel
(new horizontal-panel%
[parent (get-button-panel)]
[stretchable-width #f]
[stretchable-height #f]))
;; called from drracket-button.rkt, installed via the #lang htdp/bsl (& co) reader into drscheme
;; called from drracket-button.rkt, installed via the #lang htdp/bsl (& co) reader into drracket
(define/public (stepper-button-callback)
(if stepper-frame
(send stepper-frame show #t)
(let* ([language-level
(extract-language-level (get-definitions-text))]
[language-level-name (language-level->name language-level)])
(if (or (stepper-works-for? language-level)
(is-a? language-level drscheme:module-language:module-language<%>))
(set! stepper-frame
(go this
program-expander
(+ 1 (send (get-definitions-text) get-start-position))
(+ 1 (send (get-definitions-text) get-end-position))))
(message-box
(string-constant stepper-name)
(format (string-constant stepper-language-level-message)
language-level-name))))))
(cond
[stepper-frame (send stepper-frame show #t)]
[else (create-new-stepper)]))
(define stepper-button
(new switchable-button%
[parent stepper-button-parent-panel]
[label (string-constant stepper-button-label)]
[bitmap x:foot-img/horizontal]
[alternate-bitmap x:foot-img/vertical]
[callback (lambda (dont-care) (stepper-button-callback))]))
;; open a new stepper window, start it running
(define (create-new-stepper)
(let* ([language-level
(extract-language-level (get-defs))]
[language-level-name (language-level->name language-level)])
(if (or (stepper-works-for? language-level)
(is-a? language-level drracket:module-language:module-language<%>))
(set! stepper-frame
(go this
program-expander
(+ 1 (send (get-defs) get-start-position))
(+ 1 (send (get-defs) get-end-position))))
(message-box
(string-constant stepper-name)
(format (string-constant stepper-language-level-message)
language-level-name)))))
(register-toolbar-button stepper-button)
(define/override (enable-evaluation)
(super enable-evaluation)
(send (send (get-frame) get-stepper-button) enable #t))
(define/augment (enable-evaluation)
(send stepper-button enable #t)
(inner (void) enable-evaluation))
(define/override (disable-evaluation)
(super enable-evaluation)
(send (send (get-frame) get-stepper-button) enable #f))
(define/augment (disable-evaluation)
(send stepper-button enable #f)
(inner (void) disable-evaluation))
(define/public (current-lang-supports-stepper?)
(stepper-works-for? (extract-language-level (get-defs))))
(define/public (notify-stepper-frame-of-change)
(when stepper-frame
(send stepper-frame original-program-changed)))
(define/augment (on-close)
(when stepper-frame
(send stepper-frame original-program-gone))
(send stepper-frame original-program-gone))
(inner (void) on-close))
(define/augment (on-tab-change old new)
(check-current-language-for-stepper)
(inner (void) on-tab-change old new))
(define/public (check-current-language-for-stepper)
(if (stepper-works-for?
(extract-language-level (get-definitions-text)))
(unless (send stepper-button is-shown?)
(send (send stepper-button get-parent)
add-child stepper-button))
(when (send stepper-button is-shown?)
(send (send stepper-button get-parent)
delete-child stepper-button))))
;; add the stepper button to the button panel:
(send (get-button-panel) change-children
(lx (cons stepper-button-parent-panel
(remq stepper-button-parent-panel _))))
;; hide stepper button if it's not supported for the initial language:
(check-current-language-for-stepper)))
))
;; stepper-definitions-text-mixin : a mixin for the definitions text that
;; alerts thet stepper when the definitions text is altered or destroyed
(define (stepper-definitions-text-mixin %)
(class %
(inherit get-top-level-window)
(define/private (notify-stepper-frame-of-change)
(let ([win (get-top-level-window)])
;; should only be #f when win is #f
(when (is-a? win stepper-unit-frame<%>)
(let ([stepper-window (send win get-stepper-frame)])
(when stepper-window
(send stepper-window original-program-changed))))))
(inherit get-tab get-top-level-window)
(define/augment (on-insert x y)
(unless metadata-changing-now?
(notify-stepper-frame-of-change))
(send (get-tab) notify-stepper-frame-of-change))
(inner (void) on-insert x y))
(define/augment (on-delete x y)
(unless metadata-changing-now?
(notify-stepper-frame-of-change))
(send (get-tab) notify-stepper-frame-of-change))
(inner (void) on-delete x y))
(define/augment (after-set-next-settings s)
(let ([tlw (get-top-level-window)])
(when tlw
(send tlw check-current-language-for-stepper)))
(send tlw show/hide-stepper-button)))
(inner (void) after-set-next-settings s))
(define metadata-changing-now? #f)
@ -321,28 +358,29 @@
(super-new)))
;; apply the mixins dynamically to the drscheme unit frame and
;; apply the mixins dynamically to the drracket unit frame and
;; definitions text:
(drscheme:get/extend:extend-unit-frame stepper-unit-frame-mixin)
(drscheme:get/extend:extend-definitions-text stepper-definitions-text-mixin)
(drracket:get/extend:extend-unit-frame stepper-unit-frame-mixin)
(drracket:get/extend:extend-definitions-text stepper-definitions-text-mixin)
(drracket:get/extend:extend-tab stepper-tab-mixin)
;; COPIED FROM drscheme/private/language.ss
;; COPIED FROM drracket/private/language.ss
;; simple-module-based-language-convert-value : TST STYLE boolean -> TST
(define (simple-module-based-language-convert-value value settings)
(case (drscheme:language:simple-settings-printing-style settings)
(case (drracket:language:simple-settings-printing-style settings)
[(print) value]
[(write trad-write) value]
[(constructor)
(parameterize
([constructor-style-printing #t]
[show-sharing (drscheme:language:simple-settings-show-sharing settings)]
[show-sharing (drracket:language:simple-settings-show-sharing settings)]
[current-print-convert-hook
(leave-snips-alone-hook (current-print-convert-hook))])
(stepper-print-convert value))]
[(quasiquote)
(parameterize
([constructor-style-printing #f]
[show-sharing (drscheme:language:simple-settings-show-sharing settings)]
[show-sharing (drracket:language:simple-settings-show-sharing settings)]
[current-print-convert-hook
(leave-snips-alone-hook (current-print-convert-hook))])
(stepper-print-convert value))]
@ -381,19 +419,19 @@
[(is-a? exp snip%)
(send exp copy)]
#;
[((drscheme:rep:use-number-snip) exp)
[((drracket:rep:use-number-snip) exp)
(let ([number-snip-type
(drscheme:language:simple-settings-fraction-style
(drracket:language:simple-settings-fraction-style
simple-settings)])
(cond
[(eq? number-snip-type 'repeating-decimal)
(drscheme:number-snip:make-repeating-decimal-snip exp #f)]
(drracket:number-snip:make-repeating-decimal-snip exp #f)]
[(eq? number-snip-type 'repeating-decimal-e)
(drscheme:number-snip:make-repeating-decimal-snip exp #t)]
(drracket:number-snip:make-repeating-decimal-snip exp #t)]
[(eq? number-snip-type 'mixed-fraction)
(drscheme:number-snip:make-fraction-snip exp #f)]
(drracket:number-snip:make-fraction-snip exp #f)]
[(eq? number-snip-type 'mixed-fraction-e)
(drscheme:number-snip:make-fraction-snip exp #t)]
(drracket:number-snip:make-fraction-snip exp #t)]
[else
(error 'which-number-snip
"expected either 'repeating-decimal, 'repeating-decimal-e, 'mixed-fraction, or 'mixed-fraction-e got : ~e"

4
collects/stepper/tests/test-docs-complete.rkt
View File

@ -1,6 +1,2 @@
#lang racket/base
(require tests/utils/docs-complete)
(check-docs (quote stepper/xml-sig))
(check-docs (quote stepper/view-controller))
(check-docs (quote stepper/drracket-button))
(check-docs (quote stepper/break))

53
collects/stepper/xml-tool.rkt
View File

@ -1,27 +1,26 @@
#lang racket
(module xml-tool mzscheme
(require "private/xml-snip-helpers.rkt"
"private/find-tag.rkt"
"xml-sig.ss"
mzlib/unit
mzlib/contract
mzlib/class
mred
framework
drscheme/tool
xml/xml
string-constants)
(require "private/xml-snip-helpers.rkt"
"private/find-tag.rkt"
"private/xml-sig.ss"
mred
framework
drracket/tool
xml/xml
string-constants)
(provide xml-tool@)
(define orig (current-output-port))
(define-unit xml-tool@
(import drscheme:tool^)
(import drracket:tool^)
(export xml^)
(define (phase1) (void))
(define (phase2) (void))
(preferences:set-default 'drscheme:xml-eliminate-whitespace #t boolean?)
;; these were necessary when this was a stand-alone tool:
#;(define (phase1) (void))
#;(define (phase2) (void))
(preferences:set-default 'drracket:xml-eliminate-whitespace #t boolean?)
(define xml-box-color "forest green")
(define scheme-splice-box-color "blue")
@ -74,7 +73,7 @@
(define/private (set-eliminate-whitespace-in-empty-tags? new)
(unless (eq? eliminate-whitespace-in-empty-tags? new)
(set! eliminate-whitespace-in-empty-tags? new)
(preferences:set 'drscheme:xml-eliminate-whitespace new)
(preferences:set 'drracket:xml-eliminate-whitespace new)
(reset-min-sizes)
(let ([admin (get-admin)])
(when admin
@ -109,7 +108,7 @@
(define/override (make-snip stream-in)
(instantiate xml-snip% ()
[eliminate-whitespace-in-empty-tags?
(preferences:get 'drscheme:xml-eliminate-whitespace)]))
(preferences:get 'drracket:xml-eliminate-whitespace)]))
(super-instantiate ())))
;; this snipclass is for old, saved files (no snip has it set)
@ -196,7 +195,7 @@
(define (get-scheme-box-text%)
(unless scheme-box-text%
(set! scheme-box-text%
(class ((drscheme:unit:get-program-editor-mixin)
(class ((drracket:unit:get-program-editor-mixin)
(add-file-keymap-mixin
scheme:text%))
(inherit copy-self-to)
@ -306,7 +305,7 @@
(let ([xml-text% #f])
(lambda ()
(unless xml-text%
(set! xml-text% (class ((drscheme:unit:get-program-editor-mixin)
(set! xml-text% (class ((drracket:unit:get-program-editor-mixin)
(xml-text-mixin
plain-text%))
(inherit copy-self-to)
@ -375,8 +374,8 @@
(lambda ()
(instantiate xml-snip% ()
[eliminate-whitespace-in-empty-tags?
(preferences:get 'drscheme:xml-eliminate-whitespace)]))))))
(register-capability-menu-item 'drscheme:special:xml-menus (get-insert-menu))
(preferences:get 'drracket:xml-eliminate-whitespace)]))))))
(register-capability-menu-item 'drracket:special:xml-menus (get-insert-menu))
(instantiate menu:can-restore-menu-item% ()
(label (string-constant xml-tool-insert-scheme-box))
(parent menu)
@ -385,7 +384,7 @@
(lambda (menu evt)
(insert-snip
(lambda () (instantiate scheme-snip% () (splice? #f)))))))
(register-capability-menu-item 'drscheme:special:xml-menus (get-insert-menu))
(register-capability-menu-item 'drracket:special:xml-menus (get-insert-menu))
(instantiate menu:can-restore-menu-item% ()
(label (string-constant xml-tool-insert-scheme-splice-box))
(parent menu)
@ -394,10 +393,10 @@
(lambda (menu evt)
(insert-snip
(lambda () (instantiate scheme-snip% () (splice? #t)))))))
(register-capability-menu-item 'drscheme:special:xml-menus (get-insert-menu)))
(register-capability-menu-item 'drracket:special:xml-menus (get-insert-menu)))
(frame:reorder-menus this)))
(drscheme:language:register-capability 'drscheme:special:xml-menus (flat-contract boolean?) #t)
(drracket:language:register-capability 'drracket:special:xml-menus (flat-contract boolean?) #t)
(drscheme:get/extend:extend-unit-frame xml-box-frame-extension)))
(drracket:get/extend:extend-unit-frame xml-box-frame-extension))

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

@ -300,7 +300,7 @@ exec racket -qu "$0" ${1+"$@"}
#f
(if (caddr m) ; if the GC doesn't kick in, chicken doesn't print anything for GC time
(* 1000 (string->number (format "#e~a" (cadddr m))))
#f))))
0))))
(define (extract-time-times bm str)
(let ([m (regexp-match #rx#"real[ \t]+([0-9m.]+)s.*user[ \t]+([0-9m.]+)s.sys[ \t]+([0-9m.]+)s." str)]
@ -441,7 +441,7 @@ exec racket -qu "$0" ${1+"$@"}
run-exe
extract-chicken-times
clean-up-bin
(append '(scheme2 takr2)
(append '(takr2)
racket-specific-progs))
(make-impl 'bigloo
void

3
collects/tests/racket/benchmarks/common/tabulate.rkt
View File

@ -99,7 +99,8 @@ exec racket -qu "$0" ${1+"$@"}
#f)])
(if a
;; compute cpu, real and gc average time for the nothing benchmark
(let ([nothing-runs (map car a)])
(let ([nothing-runs (map (lambda (x) (map (lambda (y) (or y 0)) x))
(map car a))])
(map (lambda (x) (exact->inexact (/ x (length nothing-runs))))
(foldl (lambda (x y) (map + x y))
'(0 0 0)

2
collects/tests/typed-scheme/run
View File

@ -1,2 +0,0 @@
#!/bin/sh
gracket -e '(begin (require "main.ss") (go tests))'

40
collects/tests/typed-scheme/succeed/set.rkt Normal file
View File

@ -0,0 +1,40 @@
#lang typed/racket
(define s (set 0 1 2 3))
(define q (seteq 0 1 2 3))
(define v (seteqv 0 1 2 3))
(define s0 (ann (set) (Setof Byte)))
(set-empty? s)
(set-empty? q)
(set-empty? v)
(set-empty? s0)
(set-count s)
(set-count q)
(set-count v)
(set-count s0)
(set-member? s 0)
(set-member? q 0)
(set-member? v 0)
(set-member? s0 0)
(set-add s 4)
(set-add q 4)
(set-add v 4)
(set-add s0 4)
(set-remove s 4)
(set-remove q 4)
(set-remove v 4)
(set-remove s0 4)
(subset? s s0)
(set-map v add1)
(set-for-each s0 display)
(set-equal? s)
(set-eqv? v)
(set-eq? q)
(set? s0)

2
collects/typed-scheme/infer/infer-unit.rkt
View File

@ -497,6 +497,8 @@
(cset-meet (cg e e*) (cg e* e))]
[((Ephemeron: e) (Ephemeron: e*))
(cg e e*)]
[((Set: a) (Set: a*))
(cg a a*)]
;; we assume all HTs are mutable at the moment
[((Hashtable: s1 s2) (Hashtable: t1 t2))
;; for mutable hash tables, both are invariant

20
collects/typed-scheme/private/base-env.rkt
View File

@ -18,6 +18,7 @@
racket/function
racket/mpair
racket/base
racket/set
(only-in string-constants/private/only-once maybe-print-message)
(only-in mzscheme make-namespace)
(only-in racket/match/runtime match:error matchable? match-equality-test))
@ -599,6 +600,25 @@
[hash-iterate-value (-poly (a b)
((-HT a b) -Integer . -> . b))]
;Set operations
[set (-poly (e) (->* (list) e (-set e)))]
[seteqv (-poly (e) (->* (list) e (-set e)))]
[seteq (-poly (e) (->* (list) e (-set e)))]
[set-empty? (-poly (e) (-> (-set e) B))]
[set-count (-poly (e) (-> (-set e) -Index))]
[set-member? (-poly (e) (-> (-set e) e B))]
[set-add (-poly (e) (-> (-set e) e (-set e)))]
[set-remove (-poly (e) (-> (-set e) e (-set e)))]
[subset? (-poly (e) (-> (-set e) (-set e) B))]
[set-map (-poly (e b) (-> (-set e) (-> e b) (-lst b)))]
[set-for-each (-poly (e b) (-> (-set e) (-> e b) -Void))]
[set? (make-pred-ty (-poly (e) (-set e)))]
[set-equal? (-poly (e) (-> (-set e) B))]
[set-eqv? (-poly (e) (-> (-set e) B))]
[set-eq? (-poly (e) (-> (-set e) B))]
[bytes (->* (list) -Integer -Bytes)]
[bytes? (make-pred-ty -Bytes)]
[make-bytes (cl-> [(-Integer -Integer) -Bytes]

1
collects/typed-scheme/private/base-types.rkt
View File

@ -112,6 +112,7 @@
[Boxof (-poly (a) (make-Box a))]
[Channelof (-poly (a) (make-Channel a))]
[Ephemeronof (-poly (a) (make-Ephemeron a))]
[Setof (-poly (e) (make-Set e))]
[Continuation-Mark-Set -Cont-Mark-Set]
[False (-val #f)]
[True (-val #t)]

2
collects/typed-scheme/private/prims.rkt
View File

@ -19,7 +19,7 @@ This file defines two sorts of primitives. All of them are provided into any mod
|#
(provide (all-defined-out)
(provide (except-out (all-defined-out) dtsi* let-internal: define-for-variants define-for*-variants)
:
(rename-out [define-typed-struct define-struct:]
[lambda: λ:]

4
collects/typed-scheme/rep/type-rep.rkt
View File

@ -135,6 +135,10 @@
[#:key 'ephemeron])
;; elem is a Type
(dt Set ([elem Type/c]) [#:key 'set])
;; name is a Symbol (not a Name)
;; contract is used when generating contracts from types
;; predicate is used to check (at compile-time) whether a value belongs

140
collects/typed-scheme/scribblings/ts-reference.scrbl
View File

@ -78,16 +78,24 @@ default in Racket.
@defidform[Void]
@defidform[Input-Port]
@defidform[Output-Port]
@defidform[Port]
@defidform[Path]
@defidform[Path-String]
@defidform[Regexp]
@defidform[PRegexp]
@defidform[Byte-Regexp]
@defidform[Byte-PRegexp]
@defidform[Bytes]
@defidform[Namespace]
@defidform[Null]
@defidform[EOF]
@defidform[Continuation-Mark-Set]
@defidform[Char]
@defidform[Undefined]
@defidform[Module-Path]
@defidform[Module-Path-Index]
@defidform[Compiled-Module-Expression]
@defidform[Resolved-Module-Path]
@defidform[Thread])]{
These types represent primitive Racket data.
@ -110,11 +118,12 @@ These types represent primitive Racket data.
@subsection{Singleton Types}
Some kinds of data are given singleton types by default. In
particular, @rtech{symbols} and @rtech{keywords} have types which
consist only of the particular symbol or keyword. These types are
subtypes of @racket[Symbol] and @racket[Keyword], respectively.
particular, @rtech{booleans}, @rtech{symbols}, and @rtech{keywords} have types which
consist only of the particular boolean, symbol, or keyword. These types are
subtypes of @racket[Boolean], @racket[Symbol] and @racket[Keyword], respectively.
@ex[
#t
'#:foo
'bar
]
@ -124,7 +133,7 @@ subtypes of @racket[Symbol] and @racket[Keyword], respectively.
The following base types are parameteric in their type arguments.
@defform[(Pair s t)]{is the @rtech{pair} containing @racket[s] as the @racket[car]
@defform[(Pairof s t)]{is the @rtech{pair} containing @racket[s] as the @racket[car]
and @racket[t] as the @racket[cdr]}
@ex[
@ -140,12 +149,16 @@ The following base types are parameteric in their type arguments.
one element for each of the @racket[t]s, plus a sequence of elements
corresponding to @racket[trest], where @racket[bound]
must be an identifier denoting a type variable bound with @racket[...].}
@defform[(List* t t1 ... s)]{is equivalent to @racket[(Pairof t (List* t1 ... s))].}
@ex[
(list 'a 'b 'c)
(map symbol->string (list 'a 'b 'c))
]
@defform[(MListof t)]{Homogenous @rtech{mutable lists} of @racket[t].}
@defform[(MPairof t u)]{@rtech{Mutable pairs} of @racket[t] and @racket[u].}
@defform[(Boxof t)]{A @rtech{box} of @racket[t]}
@ex[(box "hello world")]
@ -153,6 +166,7 @@ corresponding to @racket[trest], where @racket[bound]
@defform[(Vectorof t)]{Homogenous @rtech{vectors} of @racket[t]}
@defform[(Vector t ...)]{is the type of the list with one element, in order,
for each type provided to the @racket[Vector] type constructor.}
@defidform[FlVector]{An @rtech{flvector}.}
@ex[(vector 1 2 3)
#(a b c)]
@ -163,6 +177,10 @@ corresponding to @racket[trest], where @racket[bound]
@ex[#hash((a . 1) (b . 2))]
}
@defform[(Setof t)]{is the type of a @rtech{set} of @racket[t].
@ex[(set 0 1 2 3)]
}
@defform[(Channelof t)]{A @rtech{channel} on which only @racket[t]s can be sent.
@ex[
(ann (make-channel) (Channelof Symbol))
@ -179,6 +197,11 @@ corresponding to @racket[trest], where @racket[bound]
@defform[(Promise t)]{A @rtech{promise} of @racket[t].
@ex[(delay 3)]}
@defform[(Futureof t)]{A @rtech{future} which produce a value of type @racket[t] when touched.}
@defform[(Sequenceof t ...)]{A @rtech{sequence} that produces values of the
types @racket[_t ...] on each iteration.}
@subsection{Syntax Objects}
The following types represent @rtech{syntax object}s and their content.
@ -213,7 +236,9 @@ of type @racket[Syntax-E].}
@racket[Datum] produces a value of type @racket[Syntax]. Equivalent to
@racket[(Sexpof Syntax)].}
@subsection{Other Type Constructors}
@defform[(Ephemeronof t)]{An @rtech{ephemeron} whose value is of type @racket[t].}
@subsection{Other Type Constructors}
@defform*[#:id -> #:literals (* ...)
[(dom ... -> rng)
@ -233,12 +258,16 @@ of type @racket[Syntax-E].}
(λ: ([x : Number] . [y : String *]) (length y))
ormap
string?]}
@defidform[Procedure]{is the supertype of all function types.}
@defform[(U t ...)]{is the union of the types @racket[t ...].
@ex[(λ: ([x : Real])(if (> 0 x) "yes" 'no))]}
@defform[(case-lambda fun-ty ...)]{is a function that behaves like all of
@defform[(case-> fun-ty ...)]{is a function that behaves like all of
the @racket[fun-ty]s, considered in order from first to last. The @racket[fun-ty]s must all be function
types constructed with @racket[->].
@ex[(: add-map : (case-lambda
@ex[(: add-map : (case->
[(Listof Integer) -> (Listof Integer)]
[(Listof Integer) (Listof Integer) -> (Listof Integer)]))]
For the definition of @racket[add-map] look into @racket[case-lambda:].}
@ -255,7 +284,7 @@ of type @racket[Syntax-E].}
0
(add1 (list-lenght (cdr lst)))))]}
@defform[(values t ...)]{is the type of a sequence of multiple values, with
@defform[(Values t ...)]{is the type of a sequence of multiple values, with
types @racket[t ...]. This can only appear as the return type of a
function.
@ex[(values 1 2 3)]}
@ -269,11 +298,16 @@ recursive type in the body @racket[t]
(define-type (List A) (Rec List (Pair A (U List Null))))]}
@(define-syntax-rule (defalias id1 id2)
@defidform[id1]{An alias for @racket[id2].})
@defalias[→ ->]
@defalias[∀ All]
@subsection{Other Types}
@defform[(Option t)]{Either @racket[t] or @racket[#f]}
@defform[(Opaque t)]{A type constructed using @racket[require-opaque-type].}
@section[#:tag "special-forms"]{Special Form Reference}
Typed Racket provides a variety of special forms above and beyond
@ -389,15 +423,25 @@ variants.
@deftogether[[
@defform[(for/list: : u (for:-clause ...) expr ...+)]
@;@defform[(for/hash: : u (for:-clause ...) expr ...+)] @; the ones that are commented out don't currently work
@;@defform[(for/hasheq: : u (for:-clause ...) expr ...+)]
@;@defform[(for/hasheqv: : u (for:-clause ...) expr ...+)]
@;@defform[(for/vector: : u (for:-clause ...) expr ...+)]
@;@defform[(for/flvector: : u (for:-clause ...) expr ...+)]
@;@defform[(for/and: : u (for:-clause ...) expr ...+)]
@defform[(for/hash: : u (for:-clause ...) expr ...+)]
@defform[(for/hasheq: : u (for:-clause ...) expr ...+)]
@defform[(for/hasheqv: : u (for:-clause ...) expr ...+)]
@defform[(for/vector: : u (for:-clause ...) expr ...+)]
@defform[(for/flvector: : u (for:-clause ...) expr ...+)]
@defform[(for/and: : u (for:-clause ...) expr ...+)]
@defform[(for/or: : u (for:-clause ...) expr ...+)]
@;@defform[(for/first: : u (for:-clause ...) expr ...+)]
@;@defform[(for/last: : u (for:-clause ...) expr ...+)]
@defform[(for/first: : u (for:-clause ...) expr ...+)]
@defform[(for/last: : u (for:-clause ...) expr ...+)]
@defform[(for*/list: : u (for:-clause ...) expr ...+)]
@defform[(for*/hash: : u (for:-clause ...) expr ...+)]
@defform[(for*/hasheq: : u (for:-clause ...) expr ...+)]
@defform[(for*/hasheqv: : u (for:-clause ...) expr ...+)]
@defform[(for*/vector: : u (for:-clause ...) expr ...+)]
@defform[(for*/flvector: : u (for:-clause ...) expr ...+)]
@defform[(for*/and: : u (for:-clause ...) expr ...+)]
@defform[(for*/or: : u (for:-clause ...) expr ...+)]
@defform[(for*/first: : u (for:-clause ...) expr ...+)]
@defform[(for*/last: : u (for:-clause ...) expr ...+)]
]]{
These behave like their non-annotated counterparts, with the exception
that @racket[#:when] clauses can only appear as the last
@ -521,14 +565,13 @@ can be used anywhere a definition form may be used.
@defform[(provide: [v t] ...)]{This declares that the @racket[v]s have
the types @racket[t], and also provides all of the @racket[v]s.}
@litchar{#{v : t}} This declares that the variable @racket[v] has type
@racket[t]. This is legal only for binding occurrences of @racket[_v].
@defform/none[@litchar|{ #{v : t} }|]{ This declares that the variable @racket[v] has type
@racket[t]. This is legal only for binding occurrences of @racket[_v].}
@defform[(ann e t)]{Ensure that @racket[e] has type @racket[t], or
some subtype. The entire expression has type @racket[t].
This is legal only in expression contexts.}
@litchar{#{e :: t}} This is identical to @racket[(ann e t)].
This is legal only in expression contexts. The syntax @litchar{#{e :: t}} may
also be used.}
@defform[(inst e t ...)]{Instantiate the type of @racket[e] with types
@racket[t ...]. @racket[e] must have a polymorphic type with the
@ -540,9 +583,10 @@ contexts.
(define (fold-list lst)
(foldl (inst cons A A) null lst))
(fold-list (list "1" "2" "3" "4"))]}
(fold-list (list "1" "2" "3" "4"))]
@litchar|{#{e @ t ...}}| This is identical to @racket[(inst e t ...)].
The syntax @litchar|{#{e @ t ...}}| may also be used.
}
@subsection{Require}
@ -599,12 +643,12 @@ enforce the specified types. If this contract fails, the module
Some types, notably polymorphic types constructed with @racket[All],
cannot be converted to contracts and raise a static error when used in
a @racket[require/typed] form. Here is an example of using
@racket[case-lambda] in @racket[require/typed].
@racket[case->] in @racket[require/typed].
@(racketblock
(require/typed racket/base
[file-or-directory-modify-seconds
(case-lambda
(case->
[String -> Exact-Nonnegative-Integer]
[String (Option Exact-Nonnegative-Integer)
->
@ -613,8 +657,8 @@ a @racket[require/typed] form. Here is an example of using
->
Any])]))
@racket[file-or-directory-modify-seconds] has some arguments which are optional.
So we need to use @racket[case-lambda].}
@racket[file-or-directory-modify-seconds] has some arguments which are optional,
so we need to use @racket[case->].}
@section{Libraries Provided With Typed Racket}
@ -745,7 +789,7 @@ have the types ascribed to them; these types are converted to contracts and chec
(define (fun x) x)
(define val 17))
(fun val)]
(fun val)]}
@section{Optimization in Typed Racket}
@ -772,14 +816,44 @@ The following forms are provided by Typed Racket for backwards
compatibility.
@defidform[define-type-alias]{Equivalent to @racket[define-type].}
@defidform[define-typed-struct]{Equivalent to @racket[define-struct:]}
@defidform[require/opaque-type]{Similar to using the @racket[opaque]
keyword with @racket[require/typed].}
@defidform[require-typed-struct]{Similar to using the @racket[struct]
keyword with @racket[require/typed].}
@defidform[pdefine:]{Defines a polymorphic function.}
@defform[(pred t)]{Equivalent to @racket[(Any -> Boolean : t)].}
@(defmodulelang* (typed-scheme)
@defalias[Un U]
@defalias[mu Rec]
@defalias[Tuple List]
@defalias[Parameter Parameterof]
@defalias[Pair Pairof]
@section{Compatibility Languages}
@(defmodulelang* (typed/scheme typed/scheme/base typed-scheme)
#:use-sources (typed-scheme/typed-scheme
typed-scheme/private/prims))
Equivalent to the @racketmod[typed/racket/base] language.
typed-scheme/private/prims typed-scheme/private/base-types))
Typed versions of the @racketmod[scheme] and @racketmod[scheme/base]
languages. The @racketmod[typed-scheme] language is equivalent to the
@racketmod[typed/scheme/base] language.
}
@section{Experimental Features}
These features are currently experimental and subject to change.
@defform[(Class args ...)]{A type constructor for typing classes created using @racketmodname[racket/class].}
@defform[(Instance c)]{A type constructor for typing objects created using @racketmodname[racket/class].}
@defform[(:type t)]{Prints the type @racket[_t].}
@defform[(declare-refinement id)]{Declares @racket[id] to be usable in
refinement types.}
@defform[(Refinement id)]{Includes values that have been tested with the
predicate @racket[id], which must have been specified with
@racket[declare-refinement].}
@defform[(define-typed-struct/exec forms ...)]{Defines an executable structure.}

1
collects/typed-scheme/types/abbrev.rkt
View File

@ -29,6 +29,7 @@
(define -Param make-Param)
(define -box make-Box)
(define -channel make-Channel)
(define -set make-Set)
(define -vec make-Vector)
(define -future make-Future)
(define (-seq . args) (make-Sequence args))

1
collects/typed-scheme/types/printer.rkt
View File

@ -172,6 +172,7 @@
[(Future: e) (fp "(Futureof ~a)" e)]
[(Channel: e) (fp "(Channelof ~a)" e)]
[(Ephemeron: e) (fp "(Ephemeronof ~a)" e)]
[(Set: e) (fp "(Setof ~a)" e)]
[(Union: elems) (fp "~a" (cons 'U elems))]
[(Pair: l r) (fp "(Pairof ~a ~a)" l r)]
[(ListDots: dty dbound)

1
collects/typed-scheme/types/subtype.rkt
View File

@ -361,6 +361,7 @@
[((Ephemeron: s) (Ephemeron: t))
(subtype* A0 s t)]
[((Box: _) (BoxTop:)) A0]
[((Set: t) (Set: t*)) (subtype* A0 t t*)]
[((Channel: _) (ChannelTop:)) A0]
[((Vector: _) (VectorTop:)) A0]
[((HeterogenousVector: _) (VectorTop:)) A0]

18
collects/typed/racket/base.rkt
View File

@ -1,18 +1,18 @@
#lang s-exp typed-scheme/minimal
(providing (libs (except racket/base #%module-begin #%top-interaction with-handlers lambda #%app define-struct for for*))
(basics #%module-begin #%top-interaction lambda #%app))
(providing (libs (except racket/base #%module-begin #%top-interaction with-handlers lambda #%app define-struct for for*)
(except typed-scheme/private/prims)
(except typed-scheme/private/base-types)
(except typed-scheme/private/base-types-extra))
(basics #%module-begin
#%top-interaction
lambda
#%app))
(require typed-scheme/private/extra-procs
typed-scheme/private/prims
typed-scheme/private/base-types
typed-scheme/private/base-types-extra
(for-syntax typed-scheme/private/base-types-extra))
(provide (rename-out [with-handlers: with-handlers]
[define-type-alias define-type])
(except-out (all-from-out typed-scheme/private/prims)
with-handlers: for/annotation for*/annotation)
(all-from-out typed-scheme/private/base-types)
(all-from-out typed-scheme/private/base-types-extra)
assert defined? with-type for for*
(for-syntax (all-from-out typed-scheme/private/base-types-extra)))

18
collects/typed/scheme/base.rkt
View File

@ -1,18 +1,18 @@
#lang s-exp typed-scheme/minimal
(providing (libs (except scheme/base #%module-begin #%top-interaction with-handlers lambda #%app define-struct for for*))
(basics #%module-begin #%top-interaction lambda #%app))
(providing (libs (except scheme/base #%module-begin #%top-interaction with-handlers lambda #%app define-struct for for*)
(except typed-scheme/private/prims)
(except typed-scheme/private/base-types)
(except typed-scheme/private/base-types-extra))
(basics #%module-begin
#%top-interaction
lambda
#%app))
(require typed-scheme/private/extra-procs
typed-scheme/private/prims
typed-scheme/private/base-types
typed-scheme/private/base-types-extra
(for-syntax typed-scheme/private/base-types-extra))
(provide (rename-out [with-handlers: with-handlers]
[define-type-alias define-type])
(except-out (all-from-out typed-scheme/private/prims)
with-handlers: for/annotation for*/annotation)
(all-from-out typed-scheme/private/base-types)
(all-from-out typed-scheme/private/base-types-extra)
assert defined? with-type for for*
(for-syntax (all-from-out typed-scheme/private/base-types-extra)))

3
collects/typed/tests/test-docs-complete.rkt
View File

@ -1,5 +1,6 @@
#lang racket/base
(require tests/utils/docs-complete)
(check-docs (quote typed/scheme))
(check-docs (quote typed/rackunit))
(check-docs (quote typed/scheme/base))
(check-docs (quote typed/racket))
(check-docs (quote typed/racket/base))

23
src/racket/gc2/alloc_cache.c
View File

@ -1,6 +1,6 @@
/*
Provides:
static ssize_t alloc_cache_free_page(AllocCacheBlock *blockfree, char *p, size_t len, int dirty)
static ssize_t alloc_cache_free_page(AllocCacheBlock *blockfree, char *p, size_t len, int dirty, int originated_here)
static ssize_t void alloc_cache_flush_freed_pages(AllocCacheBlock *blockfree)
static void *alloc_cache_alloc_page(AllocCacheBlock *blockfree, size_t len, size_t alignment, int dirty_ok, ssize_t *size_diff)
Requires (defined earlier):
@ -112,7 +112,7 @@ inline static void *alloc_cache_find_pages(AllocCacheBlock *blockfree, size_t le
return NULL;
}
static ssize_t alloc_cache_free_page(AllocCacheBlock *blockfree, char *p, size_t len, int dirty)
static ssize_t alloc_cache_free_page(AllocCacheBlock *blockfree, char *p, size_t len, int dirty, int originated_here)
{
int i;
@ -124,14 +124,14 @@ static ssize_t alloc_cache_free_page(AllocCacheBlock *blockfree, char *p, size_t
blockfree[i].len += len;
if (dirty)
blockfree[i].zeroed = 0;
return 0;
return (originated_here ? 0 : len);
}
if (p + len == blockfree[i].start) {
blockfree[i].start = p;
blockfree[i].len += len;
if (dirty)
blockfree[i].zeroed = 0;
return 0;
return (originated_here ? 0 : len);
}
}
@ -141,7 +141,7 @@ static ssize_t alloc_cache_free_page(AllocCacheBlock *blockfree, char *p, size_t
blockfree[i].len = len;
blockfree[i].age = 0;
blockfree[i].zeroed = !dirty;
return 0;
return (originated_here ? 0 : len);
}
}
@ -149,7 +149,7 @@ static ssize_t alloc_cache_free_page(AllocCacheBlock *blockfree, char *p, size_t
alloc_cache_collapse_pages(blockfree);
os_free_pages(p, len);
return -len;
return (originated_here ? -len : 0);
}
static ssize_t alloc_cache_flush_freed_pages(AllocCacheBlock *blockfree)
@ -207,7 +207,7 @@ static void *alloc_cache_alloc_page(AllocCacheBlock *blockfree, size_t len, siz
r = alloc_cache_find_pages(blockfree, len, alignment, dirty_ok);
if(!r) {
/* attempt to allocate from OS */
size_t extra = alignment + CACHE_SEED_PAGES * APAGE_SIZE;
size_t extra = (alignment ? (alignment + CACHE_SEED_PAGES * APAGE_SIZE) : 0);
r = os_alloc_pages(len + extra);
if(r == (void *)-1) { return NULL; }
@ -226,14 +226,15 @@ static void *alloc_cache_alloc_page(AllocCacheBlock *blockfree, size_t len, siz
/* Instead of actually unmapping, put it in the cache, and there's
a good chance we can use it next time: */
(*size_diff) += extra;
(*size_diff) += alloc_cache_free_page(blockfree, real_r + len, extra, 1);
}
else { os_free_pages(real_r + len, extra - pre_extra); }
(*size_diff) += alloc_cache_free_page(blockfree, real_r + len, extra, 1, 1);
} else {
os_free_pages(real_r + len, extra - pre_extra);
}
}
r = real_r;
}
(*size_diff) += extra;
(*size_diff) += len;
}
return r;

9
src/racket/gc2/block_cache.c
View File

@ -12,7 +12,7 @@ static void os_protect_pages(void *p, size_t len, int writable);
struct block_desc;
static AllocCacheBlock *alloc_cache_create();
static ssize_t alloc_cache_free(AllocCacheBlock *);
static ssize_t alloc_cache_free_page(AllocCacheBlock *blockfree, char *p, size_t len, int dirty);
static ssize_t alloc_cache_free_page(AllocCacheBlock *blockfree, char *p, size_t len, int dirty, int originated_here);
static ssize_t alloc_cache_flush_freed_pages(AllocCacheBlock *blockfree);
static void *alloc_cache_alloc_page(AllocCacheBlock *blockfree, size_t len, size_t alignment, int dirty_ok, ssize_t *size_diff);
@ -222,7 +222,8 @@ static int find_addr_in_bd(GCList *head, void *p, char* msg) {
}
#endif
static ssize_t block_cache_free_page(BlockCache* bc, void *p, size_t len, int type, int expect_mprotect, void **src_block) {
static ssize_t block_cache_free_page(BlockCache* bc, void *p, size_t len, int type, int expect_mprotect, void **src_block,
int originated_here) {
switch(type) {
case MMU_SMALL_GEN1:
{
@ -252,7 +253,7 @@ static ssize_t block_cache_free_page(BlockCache* bc, void *p, size_t len, int ty
printf("FREE PAGE %i %p %p-%p %03i %03i %04i %04i : %03i %03i %03i %03i %09i\n", expect_mprotect, bg, p, p + APAGE_SIZE, afu, afr, nafu, nafr, afub, afrb, nafub, nafrb, mmu_memory_allocated(bc->mmu));
}
#endif
return 0;
return (originated_here ? 0 : len);
}
break;
default:
@ -263,7 +264,7 @@ static ssize_t block_cache_free_page(BlockCache* bc, void *p, size_t len, int ty
find_addr_in_bd(&bc->non_atomic.free, p, "non_atomic freeblock")));
assert(*src_block == (char*)~0x0);
#endif
return alloc_cache_free_page(bc->bigBlockCache, p, len, MMU_DIRTY);
return alloc_cache_free_page(bc->bigBlockCache, p, len, MMU_DIRTY, originated_here);
break;
}
}

38
src/racket/gc2/newgc.c
View File

@ -378,17 +378,18 @@ static void *malloc_pages(NewGC *gc, size_t len, size_t alignment, int dirty, in
static void free_pages(NewGC *gc, void *p, size_t len, int type, int expect_mprotect, void **src_block)
{
gc->used_pages -= size_to_apage_count(len);
mmu_free_page(gc->mmu, p, len, type, expect_mprotect, src_block);
mmu_free_page(gc->mmu, p, len, type, expect_mprotect, src_block, 1);
}
static void free_orphaned_page(NewGC *gc, mpage *tmp) {
/* free_pages decrements gc->used_pages which is incorrect, since this is an orphaned page
/* free_pages decrements gc->used_pages which is incorrect, since this is an orphaned page,
* so we use mmu_free_page directly */
mmu_free_page(gc->mmu, tmp->addr, round_to_apage_size(tmp->size),
page_mmu_type(tmp),
page_mmu_protectable(tmp),
&tmp->mmu_src_block);
page_mmu_type(tmp),
page_mmu_protectable(tmp),
&tmp->mmu_src_block,
0); /* don't adjust count, since we're failing to adopt it */
free_mpage(tmp);
}
@ -899,16 +900,14 @@ static void *allocate_big(const size_t request_size_bytes, int type)
gc->gen0.big_pages = bpage;
/* orphan this page from the current GC */
/* this page is going to be sent to a different place, don't account for it here */
/* message memory pages shouldn't go into the page_map, they are getting sent to another place */
if (gc->saved_allocator) {
/* MESSAGE ALLOCATION: orphan this page from the current GC; this
page is going to be sent to a different place, so don't account
for it here, and don't put it in the page_map */
orphan_page_accounting(gc, allocate_size);
}
else {
} else
pagemap_add(gc->page_maps, bpage);
}
{
void * objptr = BIG_PAGE_TO_OBJECT(bpage);
ASSERT_VALID_OBJPTR(objptr);
@ -942,7 +941,11 @@ inline static mpage *create_new_medium_page(NewGC *gc, const int sz, const int p
gc->med_pages[pos] = page;
gc->med_freelist_pages[pos] = page;
pagemap_add(gc->page_maps, page);
if (gc->saved_allocator) /* see MESSAGE ALLOCATION above */
orphan_page_accounting(gc, APAGE_SIZE);
else
pagemap_add(gc->page_maps, page);
return page;
}
@ -1049,15 +1052,10 @@ inline static mpage *gen0_create_new_nursery_mpage(NewGC *gc, const size_t page_
page->size = PREFIX_SIZE;
GEN0_ALLOC_SIZE(page) = page_size;
/* orphan this page from the current GC */
/* this page is going to be sent to a different place, don't account for it here */
/* message memory pages shouldn't go into the page_map, they are getting sent to another place */
if (gc->saved_allocator) {
if (gc->saved_allocator) /* see MESSAGE ALLOCATION above */
orphan_page_accounting(gc, page_size);
}
else {
else
pagemap_add_with_size(gc->page_maps, page, page_size);
}
GCVERBOSEPAGE(gc, "NEW gen0", page);

2
src/racket/gc2/sighand.c
View File

@ -125,7 +125,7 @@ void fault_handler(int sn, struct siginfo *si, void *ctx)
/* ========== FreeBSD/NetBSD/OpenBSD signal handler ========== */
/* As of 2007/06/29, this is a guess for NetBSD! */
#if defined(__FreeBSD__) || defined(__NetBSD__) || defined(__OpenBSD__)
#if defined(__FreeBSD__) || defined(__FreeBSD_kernel__) || defined(__NetBSD__) || defined(__OpenBSD__)
# include <signal.h>
# include <sys/param.h>
void fault_handler(int sn, siginfo_t *si, void *ctx)

10
src/racket/gc2/vm.c
View File

@ -135,22 +135,26 @@ static void *mmu_alloc_page(MMU* mmu, size_t len, size_t alignment, int dirty, i
return alloc_cache_alloc_page(alloc_cache, len, alignment, dirty, &mmu->memory_allocated);
}
#else
mmu->memory_allocated += len;
return os_alloc_pages(mmu, len, alignment, dirty);
#endif
}
static void mmu_free_page(MMU* mmu, void *p, size_t len, int type, int expect_mprotect, void **src_block) {
static void mmu_free_page(MMU* mmu, void *p, size_t len, int type, int expect_mprotect, void **src_block,
int originated_here) {
mmu_assert_os_page_aligned(mmu, (size_t)p);
mmu_assert_os_page_aligned(mmu, len);
#ifdef USE_BLOCK_CACHE
mmu->memory_allocated += block_cache_free_page(mmu->block_cache, p, len, type, expect_mprotect, src_block);
mmu->memory_allocated += block_cache_free_page(mmu->block_cache, p, len, type, expect_mprotect, src_block,
originated_here);
#elif !( defined(_WIN32) || defined(OSKIT) )
//len = mmu_round_up_to_os_page_size(mmu, len);
{
AllocCacheBlock *alloc_cache = mmu->alloc_caches[!!expect_mprotect];
mmu->memory_allocated += alloc_cache_free_page(alloc_cache, p, len, MMU_DIRTY);
mmu->memory_allocated += alloc_cache_free_page(alloc_cache, p, len, MMU_DIRTY, originated_here);
}
#else
if (originated_here) mmu->memory_allocated -= len;
os_free_pages(mmu, p, len);
#endif
}

1
src/racket/include/mzwin.def
View File

@ -185,6 +185,7 @@ EXPORTS
scheme_eval_compiled_sized_string_with_magic
scheme_detach_multple_array
scheme_malloc_code
scheme_malloc_permanent_code
scheme_free_code
scheme_malloc_gcable_code
scheme_malloc_eternal

1
src/racket/include/mzwin3m.def
View File

@ -194,6 +194,7 @@ EXPORTS
GC_malloc_atomic_allow_interior
GC_malloc_tagged_allow_interior
scheme_malloc_code
scheme_malloc_permanent_code
scheme_free_code
scheme_malloc_gcable_code
scheme_malloc_eternal

1
src/racket/include/racket.exp
View File

@ -197,6 +197,7 @@ GC_malloc_atomic
GC_malloc_stubborn
GC_malloc_uncollectable
scheme_malloc_code
scheme_malloc_permanent_code
scheme_free_code
scheme_malloc_gcable_code
scheme_malloc_eternal

1
src/racket/include/racket3m.exp
View File

@ -202,6 +202,7 @@ GC_malloc_allow_interior
GC_malloc_atomic_allow_interior
GC_malloc_tagged_allow_interior
scheme_malloc_code
scheme_malloc_permanent_code
scheme_free_code
scheme_malloc_gcable_code
scheme_malloc_eternal

2
src/racket/src/jitstate.c
View File

@ -136,7 +136,7 @@ void *scheme_generate_one(mz_jit_state *old_jitter,
buffer = scheme_malloc_gcable_code(size);
#endif
} else {
buffer = scheme_malloc_code(size);
buffer = scheme_malloc_permanent_code(size);
}
RECORD_CODE_SIZE(size);
} else if (old_jitter) {

8
src/racket/src/number.c
View File

@ -187,13 +187,13 @@ READ_ONLY Scheme_Object *scheme_single_inf_object, *scheme_single_minus_inf_obje
#ifdef FREEBSD_CONTROL_387
#include <machine/floatingpoint.h>
# include <ieeefp.h>
#endif
#ifdef LINUX_CONTROL_387
#include <fpu_control.h>
# include <fpu_control.h>
#endif
#ifdef ALPHA_CONTROL_FP
#include <machine/fpu.h>
# include <machine/fpu.h>
#endif
#ifdef ASM_DBLPREC_CONTROL_87
@ -243,7 +243,7 @@ scheme_init_number (Scheme_Env *env)
MZ_SIGSET(SIGFPE, SIG_IGN);
#endif
#ifdef FREEBSD_CONTROL_387
fpsetmask(0);
(void)fpsetmask(0);
#endif
#ifdef LINUX_CONTROL_387
__setfpucw(_FPU_EXTENDED + _FPU_RC_NEAREST + 0x3F);

13
src/racket/src/places.c
View File

@ -1054,7 +1054,7 @@ Scheme_Object *scheme_places_deep_copy_worker(Scheme_Object *so, Scheme_Hash_Tab
}
}
nprefab_key = scheme_places_deep_copy_worker(stype->prefab_key, ht, copy);
nprefab_key = scheme_places_deep_copy_worker(SCHEME_CDR(stype->prefab_key), ht, copy);
if (copy) {
new_so = scheme_make_serialized_struct_instance(nprefab_key, size);
@ -1080,13 +1080,16 @@ Scheme_Object *scheme_places_deep_copy_worker(Scheme_Object *so, Scheme_Hash_Tab
Scheme_Serialized_Structure *st = (Scheme_Serialized_Structure*)so;
Scheme_Struct_Type *stype;
Scheme_Structure *nst;
Scheme_Object *key;
intptr_t size;
int i = 0;
size = st->num_slots;
stype = scheme_lookup_prefab_type(SCHEME_CDR(st->prefab_key), size);
key = scheme_places_deep_copy_worker(st->prefab_key, ht, copy);
if (copy) {
stype = scheme_lookup_prefab_type(key, size);
new_so = scheme_make_blank_prefab_struct_instance(stype);
nst = (Scheme_Structure*)new_so;
} else
@ -1384,11 +1387,13 @@ Scheme_Object *scheme_places_deserialize_worker(Scheme_Object *so)
Scheme_Serialized_Structure *st = (Scheme_Serialized_Structure*)so;
Scheme_Struct_Type *stype;
Scheme_Structure *nst;
Scheme_Object *key;
intptr_t size;
int i = 0;
size = st->num_slots;
stype = scheme_lookup_prefab_type(SCHEME_CDR(st->prefab_key), size);
key = scheme_places_deserialize_worker(st->prefab_key);
stype = scheme_lookup_prefab_type(key, size);
nst = (Scheme_Structure*) scheme_make_blank_prefab_struct_instance(stype);
for (i = 0; i <size ; i++) {
Scheme_Object *tmp;

47
src/racket/src/salloc.c
View File

@ -839,6 +839,12 @@ struct free_list_entry {
THREAD_LOCAL_DECL(static struct free_list_entry *free_list;)
THREAD_LOCAL_DECL(static int free_list_bucket_count;)
#ifdef MZ_USE_PLACES
static mzrt_mutex *permanent_code_mutex = NULL;
static void *permanent_code_page = NULL;
static intptr_t available_code_page_amount = 0;
#endif
static intptr_t get_page_size()
{
# ifdef PAGESIZE
@ -1095,6 +1101,47 @@ void *scheme_malloc_code(intptr_t size)
#endif
}
void *scheme_malloc_permanent_code(intptr_t size)
/* allocate code that will never be freed and that can be used
in multiple places */
{
#if defined(MZ_USE_PLACES) && (defined(MZ_JIT_USE_MPROTECT) || defined(MZ_JIT_USE_WINDOWS_VIRTUAL_ALLOC))
void *p;
intptr_t page_size;
if (!permanent_code_mutex) {
/* This function will be called at least once before any other place
is created, so it's ok to create the mutex here. */
mzrt_mutex_create(&permanent_code_mutex);
}
/* 16-byte alignment: */
if (size & 0xF) size += 16 - (size & 0xF);
mzrt_mutex_lock(permanent_code_mutex);
if (available_code_page_amount < size) {
page_size = get_page_size();
page_size *= 4;
while (page_size < size) page_size *= 2;
permanent_code_page = malloc_page(page_size);
available_code_page_amount = page_size;
}
p = permanent_code_page;
permanent_code_page = ((char *)permanent_code_page) + size;
available_code_page_amount -= size;
mzrt_mutex_unlock(permanent_code_mutex);
return p;
#else
return scheme_malloc_code(size);
#endif
}
void scheme_free_code(void *p)
{
#if defined(MZ_JIT_USE_MPROTECT) || defined(MZ_JIT_USE_WINDOWS_VIRTUAL_ALLOC)

1
src/racket/src/schemef.h
View File

@ -399,6 +399,7 @@ MZ_EXTERN void *GC_malloc_uncollectable(size_t size_in_bytes);
#endif
MZ_EXTERN void *scheme_malloc_code(intptr_t size);
MZ_EXTERN void *scheme_malloc_permanent_code(intptr_t size);
MZ_EXTERN void scheme_free_code(void *p);
#ifndef MZ_PRECISE_GC
MZ_EXTERN void *scheme_malloc_gcable_code(intptr_t size);

1
src/racket/src/schemex.h
View File

@ -308,6 +308,7 @@ void *(*GC_malloc_uncollectable)(size_t size_in_bytes);
# endif
#endif
void *(*scheme_malloc_code)(intptr_t size);
void *(*scheme_malloc_permanent_code)(intptr_t size);
void (*scheme_free_code)(void *p);
#ifndef MZ_PRECISE_GC
void *(*scheme_malloc_gcable_code)(intptr_t size);

1
src/racket/src/schemex.inc
View File

@ -219,6 +219,7 @@
# endif
#endif
scheme_extension_table->scheme_malloc_code = scheme_malloc_code;
scheme_extension_table->scheme_malloc_permanent_code = scheme_malloc_permanent_code;
scheme_extension_table->scheme_free_code = scheme_free_code;
#ifndef MZ_PRECISE_GC
scheme_extension_table->scheme_malloc_gcable_code = scheme_malloc_gcable_code;

1
src/racket/src/schemexm.h
View File

@ -219,6 +219,7 @@
# endif
#endif
#define scheme_malloc_code (scheme_extension_table->scheme_malloc_code)
#define scheme_malloc_permanent_code (scheme_extension_table->scheme_malloc_permanent_code)
#define scheme_free_code (scheme_extension_table->scheme_free_code)
#ifndef MZ_PRECISE_GC
#define scheme_malloc_gcable_code (scheme_extension_table->scheme_malloc_gcable_code)

98
src/racket/src/struct.c
View File

@ -120,9 +120,6 @@ static Scheme_Object *struct_to_vector(int argc, Scheme_Object *argv[]);
static Scheme_Object *prefab_struct_key(int argc, Scheme_Object *argv[]);
static Scheme_Object *make_prefab_struct(int argc, Scheme_Object *argv[]);
static Scheme_Object *prefab_key_struct_type(int argc, Scheme_Object *argv[]);
#ifdef MZ_USE_PLACES
static Scheme_Object *convert_prefab_key_to_external_form(Scheme_Object *key);
#endif
static Scheme_Object *struct_setter_p(int argc, Scheme_Object *argv[]);
static Scheme_Object *struct_getter_p(int argc, Scheme_Object *argv[]);
@ -2801,13 +2798,7 @@ Scheme_Object *scheme_prefab_struct_key(Scheme_Object *so)
s = (Scheme_Structure *)SCHEME_CHAPERONE_VAL((Scheme_Object *)s);
if (SCHEME_STRUCTP(((Scheme_Object *)s)) && s->stype->prefab_key) {
Scheme_Object *prefab_key;
prefab_key = SCHEME_CDR(s->stype->prefab_key);
#ifdef MZ_USE_PLACES
return convert_prefab_key_to_external_form(prefab_key);
#else
return prefab_key;
#endif
return SCHEME_CDR(s->stype->prefab_key);
}
return scheme_false;
@ -3966,8 +3957,6 @@ Scheme_Struct_Type *scheme_make_prefab_struct_type_raw(Scheme_Object *base,
struct_type->num_islots = num_fields + (parent_type ? parent_type->num_islots : 0);
struct_type->name_pos = depth;
struct_type->inspector = scheme_false;
//Scheme_Object *accessor *mutator;
//Scheme_Object *prefab_key;
struct_type->uninit_val = uninit_val;
struct_type->props = NULL;
struct_type->num_props = 0;
@ -3988,19 +3977,12 @@ static Scheme_Struct_Type *scheme_make_prefab_struct_type(Scheme_Object *base,
Scheme_Object *uninit_val,
char *immutable_array)
{
#ifdef MZ_USE_PLACES
/*
return scheme_make_prefab_struct_type_in_master
*/
#else
#endif
return scheme_make_prefab_struct_type_raw
(base,
parent,
num_fields,
num_uninit_fields,
uninit_val,
immutable_array);
return scheme_make_prefab_struct_type_raw(base,
parent,
num_fields,
num_uninit_fields,
uninit_val,
immutable_array);
}
static Scheme_Object *_make_struct_type(Scheme_Object *base,
@ -4638,19 +4620,7 @@ static Scheme_Object *make_prefab_key(Scheme_Struct_Type *type)
if (!SCHEME_NULLP(stack))
key = scheme_make_pair(scheme_make_integer(icnt), key);
/*symbols aren't equal? across places now*/
#if defined(MZ_USE_PLACES)
if (SCHEME_SYMBOLP(type->name)) {
Scheme_Object *newname;
newname = scheme_make_sized_offset_byte_string((char *)type->name, SCHEME_SYMSTR_OFFSET(type->name), SCHEME_SYM_LEN(type->name), 1);
key = scheme_make_pair(newname, key);
}
else {
scheme_arg_mismatch("make_prefab_key", "unknown type of struct name", type->name);
}
#else
key = scheme_make_pair(type->name, key);
#endif
if (SCHEME_PAIRP(stack)) {
type = (Scheme_Struct_Type *)SCHEME_CAR(stack);
@ -4703,29 +4673,6 @@ static char *mutability_data_to_immutability_data(int icnt, Scheme_Object *mutab
return immutable_array;
}
#ifdef MZ_USE_PLACES
static Scheme_Object *convert_prefab_key_to_external_form(Scheme_Object *key)
{
Scheme_Object *l;
Scheme_Object *nl;
if (SCHEME_SYMBOLP(key)) return key;
if (SCHEME_BYTE_STRINGP(key))
return scheme_intern_exact_symbol(SCHEME_BYTE_STR_VAL(key), SCHEME_BYTE_STRLEN_VAL(key));
nl = scheme_null;
for (l = key; SCHEME_PAIRP(l); l = SCHEME_CDR(l)) {
Scheme_Object *a;
a = SCHEME_CAR(l);
if (SCHEME_BYTE_STRINGP(a))
a = scheme_intern_exact_symbol(SCHEME_BYTE_STR_VAL(a), SCHEME_BYTE_STRLEN_VAL(a));
nl = scheme_make_pair(a, nl);
}
return scheme_reverse(nl);
}
#endif
Scheme_Struct_Type *scheme_lookup_prefab_type(Scheme_Object *key, int field_count)
{
Scheme_Struct_Type *parent = NULL;
@ -4733,19 +4680,8 @@ Scheme_Struct_Type *scheme_lookup_prefab_type(Scheme_Object *key, int field_coun
int ucnt, icnt;
char *immutable_array = NULL;
/*symbols aren't equal? across places now*/
#if defined(MZ_USE_PLACES)
if (SCHEME_SYMBOLP(key)) {
Scheme_Object *newname;
newname = scheme_make_sized_offset_byte_string((char*)key, SCHEME_SYMSTR_OFFSET(key), SCHEME_SYM_LEN(key), 1);
key = scheme_make_pair(newname, scheme_null);
}
if (SCHEME_BYTE_STRINGP(key))
key = scheme_make_pair(key, scheme_null);
#else
if (SCHEME_SYMBOLP(key))
key = scheme_make_pair(key, scheme_null);
#endif
if (scheme_proper_list_length(key) < 0)
return NULL;
@ -4819,21 +4755,9 @@ Scheme_Struct_Type *scheme_lookup_prefab_type(Scheme_Object *key, int field_coun
a = SCHEME_CAR(key);
key = SCHEME_CDR(key);
/*symbols aren't equal? across places now*/
#if defined(MZ_USE_PLACES)
if (SCHEME_SYMBOLP(a)) {
name = a;
}
else if (SCHEME_BYTE_STRINGP(a))
name = scheme_intern_exact_symbol(SCHEME_BYTE_STR_VAL(a), SCHEME_BYTE_STRLEN_VAL(a));
else
return NULL;
#else
if (!SCHEME_SYMBOLP(a))
return NULL;
name = a;
#endif
immutable_array = mutability_data_to_immutability_data(icnt + ucnt, mutables);
@ -4841,10 +4765,10 @@ Scheme_Struct_Type *scheme_lookup_prefab_type(Scheme_Object *key, int field_coun
return NULL;
parent = scheme_make_prefab_struct_type(name,
(Scheme_Object *)parent,
icnt, ucnt,
uninit_val,
immutable_array);
(Scheme_Object *)parent,
icnt, ucnt,
uninit_val,
immutable_array);
}

8
src/racket/src/thread.c
View File

@ -122,6 +122,7 @@ static void check_ready_break();
THREAD_LOCAL_DECL(extern int scheme_num_read_syntax_objects);
THREAD_LOCAL_DECL(extern intptr_t scheme_hash_request_count);
THREAD_LOCAL_DECL(extern intptr_t scheme_hash_iteration_count);
THREAD_LOCAL_DECL(extern intptr_t scheme_code_page_total);
#ifdef MZ_USE_JIT
extern int scheme_jit_malloced;
#else
@ -7624,6 +7625,8 @@ static char *gc_num(char *nums, int v)
}
i++;
v /= 1024; /* bytes => kbytes */
sprintf(nums+i, "%d", v);
for (len = 0; nums[i+len]; len++) { }
clen = len + ((len + ((nums[i] == '-') ? -2 : -1)) / 3);
@ -7667,13 +7670,14 @@ static void inform_GC(int master_gc, int major_gc,
delta = pre_used - post_used;
admin_delta = (pre_admin - post_admin) - delta;
sprintf(buf,
"GC [" PLACE_ID_FORMAT "%s] at %s(+%s) bytes;"
" %s(%s%s) collected in %" PRIdPTR " msec",
"GC [" PLACE_ID_FORMAT "%s] at %sK(+%sK)[+%sK];"
" freed %sK(%s%sK) in %" PRIdPTR " msec",
#ifdef MZ_USE_PLACES
scheme_current_place_id,
#endif
(master_gc ? "MASTER" : (major_gc ? "MAJOR" : "minor")),
gc_num(nums, pre_used), gc_num(nums, pre_admin - pre_used),
gc_num(nums, scheme_code_page_total),
gc_num(nums, delta), ((admin_delta < 0) ? "" : "+"), gc_num(nums, admin_delta),
(master_gc ? 0 : (end_this_gc_time - start_this_gc_time)));
buflen = strlen(buf);