diff --git a/collects/framework/private/main.rkt b/collects/framework/private/main.rkt index a1e5c93942..18572e0428 100644 --- a/collects/framework/private/main.rkt +++ b/collects/framework/private/main.rkt @@ -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 diff --git a/collects/redex/examples/stlc.rkt b/collects/redex/examples/stlc.rkt index 4e740cfed2..5e248cc4b2 100644 --- a/collects/redex/examples/stlc.rkt +++ b/collects/redex/examples/stlc.rkt @@ -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) diff --git a/collects/scribblings/reference/futures.scrbl b/collects/scribblings/reference/futures.scrbl index f40ae6a6da..ee631c2050 100644 --- a/collects/scribblings/reference/futures.scrbl +++ b/collects/scribblings/reference/futures.scrbl @@ -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 diff --git a/collects/stepper/break.rkt b/collects/stepper/break.rkt deleted file mode 100644 index 8800aff026..0000000000 --- a/collects/stepper/break.rkt +++ /dev/null @@ -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)))) diff --git a/collects/stepper/info.rkt b/collects/stepper/info.rkt index 202ca1181d..ae2a7d8351 100644 --- a/collects/stepper/info.rkt +++ b/collects/stepper/info.rkt @@ -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"))) diff --git a/collects/stepper/view-controller.rkt b/collects/stepper/private/view-controller.rkt similarity index 96% rename from collects/stepper/view-controller.rkt rename to collects/stepper/private/view-controller.rkt index 155d527802..e604a5a50e 100644 --- a/collects/stepper/view-controller.rkt +++ b/collects/stepper/private/view-controller.rkt @@ -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) diff --git a/collects/stepper/xml-sig.rkt b/collects/stepper/private/xml-sig.rkt similarity index 100% rename from collects/stepper/xml-sig.rkt rename to collects/stepper/private/xml-sig.rkt diff --git a/collects/stepper/scribblings/stepper.scrbl b/collects/stepper/scribblings/stepper.scrbl new file mode 100644 index 0000000000..5b6db19954 --- /dev/null +++ b/collects/stepper/scribblings/stepper.scrbl @@ -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 "#" + (#%plain-lambda () (#%plain-app "#")) + (#%plain-app + call-with-values + (#%plain-lambda () + (with-continuation-mark "#" + (#%plain-lambda () (#%plain-app + "#" + (#%plain-lambda () beginner:+))) + (#%plain-app + "#" + (#%plain-lambda (x) + (begin + (let-values (((arg0-1643 arg1-1644 arg2-1645) + (#%plain-app + values + "#<*unevaluated-struct*>" + "#<*unevaluated-struct*>" + "#<*unevaluated-struct*>"))) + (with-continuation-mark "#" + (#%plain-lambda () + (#%plain-app + "#" + (#%plain-lambda () beginner:+) + (#%plain-lambda () x) + (#%plain-lambda () arg0-1643) + (#%plain-lambda () arg1-1644) + (#%plain-lambda () arg2-1645))) + (begin + (#%plain-app "#") + (begin + (set! arg0-1643 + (with-continuation-mark "#" + (#%plain-lambda () + (#%plain-app + "#")) + beginner:+)) + (set! arg1-1644 + (with-continuation-mark "#" + (#%plain-lambda () + (#%plain-app + "#")) + (quote 3))) + (set! arg2-1645 + (with-continuation-mark "#" + (#%plain-lambda () + (#%plain-app + "#")) x)) + (begin + (#%plain-app "#") + (with-continuation-mark "#" + (#%plain-lambda () + (#%plain-app + "#" + (#%plain-lambda () arg0-1643) + (#%plain-lambda () arg1-1644) + (#%plain-lambda () arg2-1645))) + (if (#%plain-app + "#" + 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 + "#" + args) + (#%plain-app + "#" + values + args)))))))))))) + (#%plain-lambda () + (#%plain-app + "#" + (#%plain-lambda () beginner:+))) #f))) + (#%plain-lambda args + (#%plain-app "#" values args))))) + (#%plain-app "#" + (#%plain-app + list + (#%plain-app + list + "#" + #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{#} in scribble, I've taken the cheap solution of wrapping them in quotes. These are not actually strings, they're opaque 3D syntax elements. \ No newline at end of file diff --git a/collects/stepper/stepper+xml-tool.rkt b/collects/stepper/stepper+xml-tool.rkt index 6a13023fc2..e071d73ea8 100644 --- a/collects/stepper/stepper+xml-tool.rkt +++ b/collects/stepper/stepper+xml-tool.rkt @@ -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@]))) \ No newline at end of file diff --git a/collects/stepper/stepper-tool.rkt b/collects/stepper/stepper-tool.rkt index 3b142e312c..a9c7acd19f 100644 --- a/collects/stepper/stepper-tool.rkt +++ b/collects/stepper/stepper-tool.rkt @@ -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" diff --git a/collects/stepper/tests/test-docs-complete.rkt b/collects/stepper/tests/test-docs-complete.rkt index ed14222480..5c7f0c3dd5 100644 --- a/collects/stepper/tests/test-docs-complete.rkt +++ b/collects/stepper/tests/test-docs-complete.rkt @@ -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)) diff --git a/collects/stepper/xml-tool.rkt b/collects/stepper/xml-tool.rkt index c29fe32f90..ca30f8f4e2 100644 --- a/collects/stepper/xml-tool.rkt +++ b/collects/stepper/xml-tool.rkt @@ -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)) diff --git a/collects/tests/racket/benchmarks/common/auto.rkt b/collects/tests/racket/benchmarks/common/auto.rkt index d03a2d59af..3ca0e7a4a1 100755 --- a/collects/tests/racket/benchmarks/common/auto.rkt +++ b/collects/tests/racket/benchmarks/common/auto.rkt @@ -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 diff --git a/collects/tests/racket/benchmarks/common/tabulate.rkt b/collects/tests/racket/benchmarks/common/tabulate.rkt index d284938008..5db0bae47e 100755 --- a/collects/tests/racket/benchmarks/common/tabulate.rkt +++ b/collects/tests/racket/benchmarks/common/tabulate.rkt @@ -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) diff --git a/collects/tests/typed-scheme/run b/collects/tests/typed-scheme/run deleted file mode 100755 index 63ee58cc4f..0000000000 --- a/collects/tests/typed-scheme/run +++ /dev/null @@ -1,2 +0,0 @@ -#!/bin/sh -gracket -e '(begin (require "main.ss") (go tests))' diff --git a/collects/tests/typed-scheme/succeed/set.rkt b/collects/tests/typed-scheme/succeed/set.rkt new file mode 100644 index 0000000000..de9d5cb179 --- /dev/null +++ b/collects/tests/typed-scheme/succeed/set.rkt @@ -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) diff --git a/collects/typed-scheme/infer/infer-unit.rkt b/collects/typed-scheme/infer/infer-unit.rkt index 51c3ce685f..c58d490bed 100644 --- a/collects/typed-scheme/infer/infer-unit.rkt +++ b/collects/typed-scheme/infer/infer-unit.rkt @@ -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 diff --git a/collects/typed-scheme/private/base-env.rkt b/collects/typed-scheme/private/base-env.rkt index 05313abf6d..24b2bf2c13 100644 --- a/collects/typed-scheme/private/base-env.rkt +++ b/collects/typed-scheme/private/base-env.rkt @@ -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] diff --git a/collects/typed-scheme/private/base-types.rkt b/collects/typed-scheme/private/base-types.rkt index 6f81bf6698..1f63fe699b 100644 --- a/collects/typed-scheme/private/base-types.rkt +++ b/collects/typed-scheme/private/base-types.rkt @@ -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)] diff --git a/collects/typed-scheme/private/prims.rkt b/collects/typed-scheme/private/prims.rkt index 50efd86404..255c576111 100644 --- a/collects/typed-scheme/private/prims.rkt +++ b/collects/typed-scheme/private/prims.rkt @@ -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: λ:] diff --git a/collects/typed-scheme/rep/type-rep.rkt b/collects/typed-scheme/rep/type-rep.rkt index 2c013717f5..1c70bb5fd2 100644 --- a/collects/typed-scheme/rep/type-rep.rkt +++ b/collects/typed-scheme/rep/type-rep.rkt @@ -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 diff --git a/collects/typed-scheme/scribblings/ts-reference.scrbl b/collects/typed-scheme/scribblings/ts-reference.scrbl index 759d4a281f..8c1fa423c0 100644 --- a/collects/typed-scheme/scribblings/ts-reference.scrbl +++ b/collects/typed-scheme/scribblings/ts-reference.scrbl @@ -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.} diff --git a/collects/typed-scheme/types/abbrev.rkt b/collects/typed-scheme/types/abbrev.rkt index 397f56c471..460818bef4 100644 --- a/collects/typed-scheme/types/abbrev.rkt +++ b/collects/typed-scheme/types/abbrev.rkt @@ -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)) diff --git a/collects/typed-scheme/types/printer.rkt b/collects/typed-scheme/types/printer.rkt index 29995c352c..8509d0cac8 100644 --- a/collects/typed-scheme/types/printer.rkt +++ b/collects/typed-scheme/types/printer.rkt @@ -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) diff --git a/collects/typed-scheme/types/subtype.rkt b/collects/typed-scheme/types/subtype.rkt index 199b268a4b..548a6bf8c8 100644 --- a/collects/typed-scheme/types/subtype.rkt +++ b/collects/typed-scheme/types/subtype.rkt @@ -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] diff --git a/collects/typed/racket/base.rkt b/collects/typed/racket/base.rkt index 65d5432443..64952f4ac7 100644 --- a/collects/typed/racket/base.rkt +++ b/collects/typed/racket/base.rkt @@ -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))) diff --git a/collects/typed/scheme/base.rkt b/collects/typed/scheme/base.rkt index 4c184c2146..302f1c162c 100644 --- a/collects/typed/scheme/base.rkt +++ b/collects/typed/scheme/base.rkt @@ -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))) diff --git a/collects/typed/tests/test-docs-complete.rkt b/collects/typed/tests/test-docs-complete.rkt index 642d5aa81c..9a53a76e15 100644 --- a/collects/typed/tests/test-docs-complete.rkt +++ b/collects/typed/tests/test-docs-complete.rkt @@ -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)) diff --git a/src/racket/gc2/alloc_cache.c b/src/racket/gc2/alloc_cache.c index 44895afa90..a15c107bde 100644 --- a/src/racket/gc2/alloc_cache.c +++ b/src/racket/gc2/alloc_cache.c @@ -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; diff --git a/src/racket/gc2/block_cache.c b/src/racket/gc2/block_cache.c index 9f83ac6b0b..d3b30be95b 100644 --- a/src/racket/gc2/block_cache.c +++ b/src/racket/gc2/block_cache.c @@ -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; } } diff --git a/src/racket/gc2/newgc.c b/src/racket/gc2/newgc.c index 26b145160c..e285f2f0ef 100644 --- a/src/racket/gc2/newgc.c +++ b/src/racket/gc2/newgc.c @@ -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); diff --git a/src/racket/gc2/sighand.c b/src/racket/gc2/sighand.c index 5e79bbbba1..7b137fa5f4 100644 --- a/src/racket/gc2/sighand.c +++ b/src/racket/gc2/sighand.c @@ -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 # include void fault_handler(int sn, siginfo_t *si, void *ctx) diff --git a/src/racket/gc2/vm.c b/src/racket/gc2/vm.c index 648948bb54..43fe58575c 100644 --- a/src/racket/gc2/vm.c +++ b/src/racket/gc2/vm.c @@ -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 } diff --git a/src/racket/include/mzwin.def b/src/racket/include/mzwin.def index 4064ca015c..007b1aadb5 100644 --- a/src/racket/include/mzwin.def +++ b/src/racket/include/mzwin.def @@ -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 diff --git a/src/racket/include/mzwin3m.def b/src/racket/include/mzwin3m.def index 4cdbe20d4b..eba516240e 100644 --- a/src/racket/include/mzwin3m.def +++ b/src/racket/include/mzwin3m.def @@ -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 diff --git a/src/racket/include/racket.exp b/src/racket/include/racket.exp index 0a8dd3a8e1..07ca3c6666 100644 --- a/src/racket/include/racket.exp +++ b/src/racket/include/racket.exp @@ -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 diff --git a/src/racket/include/racket3m.exp b/src/racket/include/racket3m.exp index 79adea4d10..fe920d3ce1 100644 --- a/src/racket/include/racket3m.exp +++ b/src/racket/include/racket3m.exp @@ -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 diff --git a/src/racket/src/jitstate.c b/src/racket/src/jitstate.c index 5d07da058c..6c61c1a6bb 100644 --- a/src/racket/src/jitstate.c +++ b/src/racket/src/jitstate.c @@ -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) { diff --git a/src/racket/src/number.c b/src/racket/src/number.c index a4cb69b725..fea2871bc9 100644 --- a/src/racket/src/number.c +++ b/src/racket/src/number.c @@ -187,13 +187,13 @@ READ_ONLY Scheme_Object *scheme_single_inf_object, *scheme_single_minus_inf_obje #ifdef FREEBSD_CONTROL_387 -#include +# include #endif #ifdef LINUX_CONTROL_387 -#include +# include #endif #ifdef ALPHA_CONTROL_FP -#include +# include #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); diff --git a/src/racket/src/places.c b/src/racket/src/places.c index 08eea0c62e..de5cff031e 100644 --- a/src/racket/src/places.c +++ b/src/racket/src/places.c @@ -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 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; diff --git a/src/racket/src/schemexm.h b/src/racket/src/schemexm.h index 505e2e2085..40feea2bfb 100644 --- a/src/racket/src/schemexm.h +++ b/src/racket/src/schemexm.h @@ -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) diff --git a/src/racket/src/struct.c b/src/racket/src/struct.c index 9676944783..ea34402299 100644 --- a/src/racket/src/struct.c +++ b/src/racket/src/struct.c @@ -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); } diff --git a/src/racket/src/thread.c b/src/racket/src/thread.c index 3c3371d4dd..ff56eecb73 100644 --- a/src/racket/src/thread.c +++ b/src/racket/src/thread.c @@ -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);