diff --git a/collects/handin-server/checker.ss b/collects/handin-server/checker.ss
index a80d3ff831..8d5d1fc9f2 100644
--- a/collects/handin-server/checker.ss
+++ b/collects/handin-server/checker.ss
@@ -651,6 +651,9 @@
(define (procedure/arity? proc arity)
(and (procedure? proc) (procedure-arity-includes? proc arity)))
+(define (get-namespace evaluator)
+ (call-in-sandbox-context evaluator (lambda () (current-namespace))))
+
(provide !defined)
(define-syntax-rule (!defined id ...)
;; expected to be used only with identifiers
diff --git a/collects/macro-debugger/model/deriv-c.ss b/collects/macro-debugger/model/deriv-c.ss
index 7260748cc5..3efb19f094 100644
--- a/collects/macro-debugger/model/deriv-c.ss
+++ b/collects/macro-debugger/model/deriv-c.ss
@@ -89,6 +89,9 @@
(srenames sbindrhss vrenames vrhss body tag)
#:transparent)
+;; (make-p:provide (listof Deriv) ?exn)
+(define-struct (p:provide prule) (inners ?2) #:transparent)
+
;; (make-p:stop )
;; (make-p:unknown )
;; (make-p:#%top Stx)
@@ -98,7 +101,6 @@
;; (make-p:require )
;; (make-p:require-for-syntax )
;; (make-p:require-for-template )
-;; (make-p:provide )
;; (make-p:#%variable-reference )
(define-struct (p::STOP prule) () #:transparent)
(define-struct (p:stop p::STOP) () #:transparent)
@@ -110,7 +112,6 @@
(define-struct (p:require p::STOP) () #:transparent)
(define-struct (p:require-for-syntax p::STOP) () #:transparent)
(define-struct (p:require-for-template p::STOP) () #:transparent)
-(define-struct (p:provide p::STOP) () #:transparent)
(define-struct (p:#%variable-reference p::STOP) () #:transparent)
;; A LDeriv is
diff --git a/collects/macro-debugger/model/deriv-find.ss b/collects/macro-debugger/model/deriv-find.ss
index 99ed54f14c..5de9f5c07a 100644
--- a/collects/macro-debugger/model/deriv-find.ss
+++ b/collects/macro-debugger/model/deriv-find.ss
@@ -75,6 +75,8 @@
(join (loops rhss) (loop body))]
[(Wrap p:letrec-syntaxes+values (_ _ _ _ _ srhss _ vrhss body _))
(join (loops srhss) (loops vrhss) (loop body))]
+ [(Wrap p:provide (_ _ _ _ inners _))
+ (loops inners)]
[(Wrap p:module (_ _ _ _ _ _ _ check _ _ body _))
(join (loop check) (loop body))]
[(Wrap p:#%module-begin (_ _ _ _ _ pass1 pass2 _))
diff --git a/collects/macro-debugger/model/deriv-parser.ss b/collects/macro-debugger/model/deriv-parser.ss
index e3c312377e..029041ccc4 100644
--- a/collects/macro-debugger/model/deriv-parser.ss
+++ b/collects/macro-debugger/model/deriv-parser.ss
@@ -288,8 +288,8 @@
[()
(make mod:skip)]
;; provide: special
- [(enter-prim prim-provide (? ModuleProvide/Inner) exit-prim)
- (make mod:cons (make p:provide $1 $4 null $3))]
+ [(enter-prim prim-provide (? ModuleProvide/Inner) ! exit-prim)
+ (make mod:cons (make p:provide $1 $5 null #f $3 $4))]
;; normal: expand completely
[((? EE))
(make mod:cons $1)]
@@ -298,10 +298,10 @@
(make mod:lift $1 #f $2)])
(ModuleProvide/Inner
- [() #f]
- [(!!) $1]
- [(EE/Interrupted) $1]
- [(EE (? ModuleProvide/Inner)) $2])
+ (#:skipped null)
+ [() null]
+ [((? EE) (? ModuleProvide/Inner))
+ (cons $1 $2)])
;; Definitions
(PrimDefineSyntaxes
@@ -442,7 +442,7 @@
(PrimProvide
(#:args e1 e2 rs)
- [(prim-provide !) (make p:provide e1 e2 rs $2)])
+ [(prim-provide !) (make p:provide e1 e2 rs $2 null #f)])
(PrimVarRef
(#:args e1 e2 rs)
diff --git a/collects/macro-debugger/model/reductions.ss b/collects/macro-debugger/model/reductions.ss
index 67671a7595..8ded0fb8f8 100644
--- a/collects/macro-debugger/model/reductions.ss
+++ b/collects/macro-debugger/model/reductions.ss
@@ -194,9 +194,23 @@
[#:pattern (?top . ?var)]
[#:learn (list #'?var)])]
- [(Wrap p:provide (e1 e2 rs ?1))
- (R [! ?1]
- [#:walk e2 'provide])]
+ [(Wrap p:provide (e1 e2 rs ?1 inners ?2))
+ (let ([wrapped-inners
+ (for/list ([inner inners])
+ (match inner
+ [(Wrap deriv (e1 e2))
+ (make local-expansion e1 e2
+ #f e1 inner #f e2 #f)]))])
+ (R [! ?1]
+ [#:pattern ?form]
+ [#:pass1]
+ [#:left-foot]
+ [LocalActions ?form wrapped-inners]
+ [! ?2]
+ [#:pass2]
+ [#:set-syntax e2]
+ [#:step 'provide]
+ [#:set-syntax e2]))]
[(Wrap p:stop (e1 e2 rs ?1))
(R [! ?1])]
diff --git a/collects/macro-debugger/syntax-browser/display.ss b/collects/macro-debugger/syntax-browser/display.ss
index 626af874e0..e61b9efcff 100644
--- a/collects/macro-debugger/syntax-browser/display.ss
+++ b/collects/macro-debugger/syntax-browser/display.ss
@@ -3,7 +3,6 @@
(require scheme/class
scheme/gui
scheme/match
- "params.ss"
"pretty-printer.ss"
"interfaces.ss"
"util.ss")
@@ -11,8 +10,8 @@
code-style)
;; print-syntax-to-editor : syntax text controller<%> -> display<%>
-(define (print-syntax-to-editor stx text controller)
- (new display% (syntax stx) (text text) (controller controller)))
+(define (print-syntax-to-editor stx text controller config)
+ (new display% (syntax stx) (text text) (controller controller) (config config)))
;; FIXME: assumes text never moves
@@ -22,6 +21,7 @@
(init ((stx syntax)))
(init-field text)
(init-field controller)
+ (init-field config)
(define start-anchor (new anchor-snip%))
(define end-anchor (new anchor-snip%))
@@ -33,7 +33,7 @@
(with-unlock text
(send text delete (get-start-position) (get-end-position))
(set! range
- (print-syntax stx text controller
+ (print-syntax stx text controller config
(lambda () (get-start-position))
(lambda () (get-end-position))))
(apply-primary-partition-styles))
@@ -131,7 +131,7 @@
(let ([delta (new style-delta%)])
(send delta set-delta-foreground color)
delta))
- (define color-styles (list->vector (map color-style (current-colors))))
+ (define color-styles (list->vector (map color-style (send config get-colors))))
(define overflow-style (color-style "darkgray"))
(define color-partition (send controller get-primary-partition))
(define offset (get-start-position))
@@ -162,16 +162,20 @@
(render-syntax stx)
(send controller add-syntax-display this)))
-;; print-syntax : syntax controller (-> number) (-> number)
+;; print-syntax : syntax text% controller config (-> number) (-> number)
;; -> range%
-(define (print-syntax stx text controller
+(define (print-syntax stx text controller config
get-start-position get-end-position)
(define primary-partition (send controller get-primary-partition))
(define real-output-port (make-text-port text get-end-position))
(define output-port (open-output-string))
+ (define colors (send config get-colors))
+ (define suffix-option (send config get-suffix-option))
+ (define columns (send config get-columns))
(port-count-lines! output-port)
- (let ([range (pretty-print-syntax stx output-port primary-partition)])
+ (let ([range (pretty-print-syntax stx output-port primary-partition
+ colors suffix-option columns)])
(write-string (get-output-string output-port) real-output-port)
(let ([end (get-end-position)])
;; Pretty printer always inserts final newline; we remove it here.
@@ -189,7 +193,7 @@
(send range all-ranges)))
;; Set font to standard
(send text change-style
- (code-style text)
+ (code-style text (send config get-syntax-font-size))
(get-start-position)
(get-end-position))
range))
@@ -212,11 +216,10 @@
(send text insert char pos (add1 pos)))
(for-each fixup (send range all-ranges)))
-;; code-style : text<%> -> style<%>
-(define (code-style text)
+;; code-style : text<%> number/#f -> style<%>
+(define (code-style text font-size)
(let* ([style-list (send text get-style-list)]
- [style (send style-list find-named-style "Standard")]
- [font-size (current-syntax-font-size)])
+ [style (send style-list find-named-style "Standard")])
(if font-size
(send style-list find-or-create-style
style
diff --git a/collects/macro-debugger/syntax-browser/embed.ss b/collects/macro-debugger/syntax-browser/embed.ss
index 7c46e857ee..2edc5e6df5 100644
--- a/collects/macro-debugger/syntax-browser/embed.ss
+++ b/collects/macro-debugger/syntax-browser/embed.ss
@@ -3,11 +3,9 @@
(require "interfaces.ss"
"widget.ss"
"keymap.ss"
- "params.ss"
"partition.ss")
(provide (all-from-out "interfaces.ss")
(all-from-out "widget.ss")
(all-from-out "keymap.ss")
- (all-from-out "params.ss")
identifier=-choices)
diff --git a/collects/macro-debugger/syntax-browser/frame.ss b/collects/macro-debugger/syntax-browser/frame.ss
index 1abce48832..87519bccc6 100644
--- a/collects/macro-debugger/syntax-browser/frame.ss
+++ b/collects/macro-debugger/syntax-browser/frame.ss
@@ -54,8 +54,7 @@
(define syntax-widget/controls%
(class* widget% ()
(inherit get-main-panel
- get-controller
- toggle-props)
+ get-controller)
(super-new)
(inherit-field config)
@@ -85,7 +84,10 @@
(new button%
(label "Properties")
(parent -control-panel)
- (callback (lambda _ (toggle-props))))
+ (callback
+ (lambda _
+ (send config set-props-shown?
+ (not (send config get-props-shown?))))))
(send (get-controller) listen-identifier=?
(lambda (name+func)
diff --git a/collects/macro-debugger/syntax-browser/keymap.ss b/collects/macro-debugger/syntax-browser/keymap.ss
index dab85ada3c..40c29d4056 100644
--- a/collects/macro-debugger/syntax-browser/keymap.ss
+++ b/collects/macro-debugger/syntax-browser/keymap.ss
@@ -2,6 +2,7 @@
#lang scheme/base
(require scheme/class
scheme/gui
+ "../util/notify.ss"
"interfaces.ss"
"partition.ss")
(provide smart-keymap%
@@ -48,6 +49,7 @@
(set! on-demand-actions (cons p on-demand-actions)))
(define/override (on-demand)
+ (super on-demand)
(for-each (lambda (p) (p)) on-demand-actions))
(super-new)))
@@ -92,28 +94,42 @@
(lambda (i e)
(send config set-props-shown? #f)))
- (define/public (add-edit-items)
+ (define/private (selected-syntax)
+ (send controller get-selected-syntax))
+
+ (define/public (add-menu-items)
(set! copy-menu
(new menu-item% (label "Copy") (parent the-context-menu)
- (callback (lambda (i e)
- (call-function "copy-text" i e)))))
- (void))
-
- (define/public (after-edit-items)
- (void))
-
- (define/public (add-selection-items)
+ (demand-callback
+ (lambda (i)
+ (send i enable (and (selected-syntax) #t))))
+ (callback
+ (lambda (i e)
+ (call-function "copy-text" i e)))))
+ (add-separator)
(set! clear-menu
(new menu-item%
(label "Clear selection")
(parent the-context-menu)
+ (demand-callback
+ (lambda (i)
+ (send i enable (and (selected-syntax) #t))))
(callback
(lambda (i e)
(call-function "clear-syntax-selection" i e)))))
(set! props-menu
+ (menu-option/notify-box the-context-menu
+ "View syntax properties"
+ (get-field props-shown? config))
+ #;
(new menu-item%
(label "Show syntax properties")
(parent the-context-menu)
+ (demand-callback
+ (lambda (i)
+ (if (send config get-props-shown?)
+ (send i set-label "Hide syntax properties")
+ (send i set-label "Show syntax properties"))))
(callback
(lambda (i e)
(if (send config get-props-shown?)
@@ -121,55 +137,10 @@
(call-function "show-syntax-properties" i e))))))
(void))
- (define/public (after-selection-items)
- (void))
-
- (define/public (add-partition-items)
- (let ([secondary (new menu% (label "identifier=?") (parent the-context-menu))])
- (for-each
- (lambda (name func)
- (let ([this-choice
- (new checkable-menu-item%
- (label name)
- (parent secondary)
- (callback
- (lambda (i e)
- (send controller set-identifier=?
- (cons name func)))))])
- (send controller listen-identifier=?
- (lambda (name+proc)
- (send this-choice check (eq? name (car name+proc)))))))
- (map car (identifier=-choices))
- (map cdr (identifier=-choices))))
- (void))
-
- (define/public (after-partition-items)
- (void))
-
(define/public (add-separator)
(new separator-menu-item% (parent the-context-menu)))
;; Initialize menu
- (add-edit-items)
- (after-edit-items)
-
- (add-separator)
- (add-selection-items)
- (after-selection-items)
-
- (add-separator)
- (add-partition-items)
- (after-partition-items)
-
- (send the-context-menu add-on-demand
- (lambda ()
- (define stx (send controller get-selected-syntax))
- (send copy-menu enable (and stx #t))
- (send clear-menu enable (and stx #t))))
- (send config listen-props-shown?
- (lambda (shown?)
- (send props-menu set-label
- (if shown?
- "Hide syntax properties"
- "Show syntax properties"))))))
+ (add-menu-items)
+ ))
diff --git a/collects/macro-debugger/syntax-browser/params.ss b/collects/macro-debugger/syntax-browser/params.ss
deleted file mode 100644
index f8753b7d40..0000000000
--- a/collects/macro-debugger/syntax-browser/params.ss
+++ /dev/null
@@ -1,25 +0,0 @@
-
-#lang scheme/base
-(provide current-syntax-font-size
- current-default-columns
- current-colors
- current-suffix-option)
-
-;; current-syntax-font-size : parameter of number/#f
-;; When non-false, overrides the default font size
-(define current-syntax-font-size (make-parameter #f))
-
-;; current-default-columns : parameter of number
-(define current-default-columns (make-parameter 60))
-
-;; current-suffix-option : parameter of SuffixOption
-(define current-suffix-option (make-parameter 'over-limit))
-
-(define current-colors
- (make-parameter
- (list "black" "red" "blue"
- "mediumforestgreen" "darkgreen"
- "darkred"
- "cornflowerblue" "royalblue" "steelblue" "darkslategray" "darkblue"
- "indigo" "purple"
- "orange" "salmon" "darkgoldenrod" "olive")))
diff --git a/collects/macro-debugger/syntax-browser/prefs.ss b/collects/macro-debugger/syntax-browser/prefs.ss
index 95754653a9..99cc06765d 100644
--- a/collects/macro-debugger/syntax-browser/prefs.ss
+++ b/collects/macro-debugger/syntax-browser/prefs.ss
@@ -5,13 +5,9 @@
"interfaces.ss"
"../util/notify.ss"
"../util/misc.ss")
-(provide syntax-prefs%
- syntax-prefs/readonly%
-
- #;pref:tabify
- #;pref:height
- #;pref:width
- #;pref:props-percentage)
+(provide syntax-prefs-base%
+ syntax-prefs%
+ syntax-prefs/readonly%)
(preferences:set-default 'SyntaxBrowser:Width 700 number?)
(preferences:set-default 'SyntaxBrowser:Height 600 number?)
@@ -22,13 +18,37 @@
(pref:get/set pref:height SyntaxBrowser:Height)
(pref:get/set pref:props-percentage SyntaxBrowser:PropertiesPanelPercentage)
(pref:get/set pref:props-shown? SyntaxBrowser:PropertiesPanelShown)
-(pref:get/set pref:tabify framework:tabify)
(define syntax-prefs-base%
(class object%
+ ;; columns : number
+ (field/notify columns (new notify-box% (value 60)))
+
+ ;; suffix-option : SuffixOption
+ (field/notify suffix-option (new notify-box% (value 'over-limit)))
+
+ ;; syntax-font-size : number/#f
+ ;; When non-false, overrides the default font size
+ (field/notify syntax-font-size (new notify-box% (value #f)))
+
+ ;; colors : (listof string)
+ (field/notify colors
+ (new notify-box%
+ (value '("black" "red" "blue"
+ "mediumforestgreen" "darkgreen"
+ "darkred"
+ "cornflowerblue" "royalblue" "steelblue" "darkslategray" "darkblue"
+ "indigo" "purple"
+ "orange" "salmon" "darkgoldenrod" "olive"))))
+
+ ;; width, height : number
(notify-methods width)
(notify-methods height)
+
+ ;; props-percentage : ...
(notify-methods props-percentage)
+
+ ;; props-shown? : boolean
(notify-methods props-shown?)
(super-new)))
diff --git a/collects/macro-debugger/syntax-browser/pretty-helper.ss b/collects/macro-debugger/syntax-browser/pretty-helper.ss
index c672a9a797..0eadf413b1 100644
--- a/collects/macro-debugger/syntax-browser/pretty-helper.ss
+++ b/collects/macro-debugger/syntax-browser/pretty-helper.ss
@@ -1,8 +1,7 @@
#lang scheme/base
(require scheme/class
- syntax/stx
- "partition.ss")
+ syntax/stx)
(provide (all-defined-out))
;; Problem: If stx1 and stx2 are two distinguishable syntax objects, it
@@ -27,7 +26,7 @@
;; - 'over-limit -- suffix > limit
;; - 'all-if-over-limit -- suffix > 0 if any over limit
-;; syntax->datum/tables : stx [partition% num SuffixOption]
+;; syntax->datum/tables : stx partition% num SuffixOption
;; -> (values s-expr hashtable hashtable)
;; When partition is not false, tracks the partititions that subterms belong to
;; When limit is a number, restarts processing with numbering? set to true
@@ -37,10 +36,8 @@
;; - a hashtable mapping S-expressions to syntax objects
;; - a hashtable mapping syntax objects to S-expressions
;; Syntax objects which are eq? will map to same flat values
-(define syntax->datum/tables
- (case-lambda
- [(stx) (table stx #f #f 'never)]
- [(stx partition limit suffixopt) (table stx partition limit suffixopt)]))
+(define (syntax->datum/tables stx partition limit suffixopt)
+ (table stx partition limit suffixopt))
;; table : syntax maybe-partition% maybe-num SuffixOption -> (values s-expr hashtable hashtable)
(define (table stx partition limit suffixopt)
diff --git a/collects/macro-debugger/syntax-browser/pretty-printer.ss b/collects/macro-debugger/syntax-browser/pretty-printer.ss
index bc47431c61..417e52b711 100644
--- a/collects/macro-debugger/syntax-browser/pretty-printer.ss
+++ b/collects/macro-debugger/syntax-browser/pretty-printer.ss
@@ -7,19 +7,18 @@
scheme/pretty
scheme/gui
"pretty-helper.ss"
- "interfaces.ss"
- "params.ss"
- "prefs.ss")
-
+ "interfaces.ss")
(provide pretty-print-syntax)
-;; pretty-print-syntax : syntax port partition -> range%
-(define (pretty-print-syntax stx port primary-partition)
+;; pretty-print-syntax :
+;; syntax port partition (listof string) SuffixOption number
+;; -> range%
+(define (pretty-print-syntax stx port primary-partition colors suffix-option columns)
(define range-builder (new range-builder%))
(define-values (datum ht:flat=>stx ht:stx=>flat)
(syntax->datum/tables stx primary-partition
- (length (current-colors))
- (current-suffix-option)))
+ (length colors)
+ suffix-option))
(define identifier-list
(filter identifier? (hash-map ht:stx=>flat (lambda (k v) k))))
(define (flat=>stx obj)
@@ -53,7 +52,7 @@
[pretty-print-size-hook pp-size-hook]
[pretty-print-print-hook pp-print-hook]
[pretty-print-current-style-table (pp-extend-style-table identifier-list)]
- [pretty-print-columns (current-default-columns)]
+ [pretty-print-columns columns]
;; Printing parameters (mzscheme manual 7.9.1.4)
[print-unreadable #t]
[print-graph #f]
diff --git a/collects/macro-debugger/syntax-browser/syntax-snip.ss b/collects/macro-debugger/syntax-browser/syntax-snip.ss
index 4ab5b17863..538d4e7675 100644
--- a/collects/macro-debugger/syntax-browser/syntax-snip.ss
+++ b/collects/macro-debugger/syntax-browser/syntax-snip.ss
@@ -60,7 +60,9 @@
(send text begin-edit-sequence)
(send text change-style (make-object style-delta% 'change-alignment 'top))
(define display
- (print-syntax-to-editor stx text (send host get-controller)))
+ (print-syntax-to-editor stx text
+ (send host get-controller)
+ (send host get-config)))
(send text lock #t)
(send text end-edit-sequence)
(send text hide-caret #t)
diff --git a/collects/macro-debugger/syntax-browser/widget.ss b/collects/macro-debugger/syntax-browser/widget.ss
index a8303f0606..3d0966cbdf 100644
--- a/collects/macro-debugger/syntax-browser/widget.ss
+++ b/collects/macro-debugger/syntax-browser/widget.ss
@@ -8,7 +8,6 @@
mzlib/kw
syntax/boundmap
"interfaces.ss"
- "params.ss"
"controller.ss"
"display.ss"
"keymap.ss"
@@ -48,15 +47,10 @@
(send -text set-styles-sticky #f)
(send -text lock #t)
- ;; syntax-properties-controller<%> methods
-
- (define/public (props-shown?)
- (send -props-panel is-shown?))
-
- (define/public (toggle-props)
- (show-props (not (send -props-panel is-shown?))))
-
(define/public (show-props show?)
+ (internal-show-props show?))
+
+ (define/private (internal-show-props show?)
(if show?
(unless (send -props-panel is-shown?)
(let ([p (send config get-props-percentage)])
@@ -67,27 +61,25 @@
(send -split-panel delete-child -props-panel)
(send -props-panel show #f))))
- (send config listen-props-percentage
- (lambda (p)
- (update-props-percentage p)))
- (send config listen-props-shown?
- (lambda (show?)
- (show-props show?)))
-
(define/private (update-props-percentage p)
(send -split-panel set-percentages
(list (- 1 p) p)))
- ;;
-
- (define/public (get-controller) controller)
+ (define/private (props-panel-shown?)
+ (send -props-panel is-shown?))
;;
- (define/public (get-main-panel) -main-panel)
+ (define/public (get-controller)
+ controller)
+
+ ;;
+
+ (define/public (get-main-panel)
+ -main-panel)
(define/public (shutdown)
- (when (props-shown?)
+ (when (props-panel-shown?)
(send config set-props-percentage
(cadr (send -split-panel get-percentages)))))
@@ -187,23 +179,31 @@
;; internal-add-syntax : syntax -> display
(define/private (internal-add-syntax stx)
(with-unlock -text
- (parameterize ((current-default-columns (calculate-columns)))
- (let ([display (print-syntax-to-editor stx -text controller)])
- (send* -text
- (insert "\n")
- ;(scroll-to-position current-position)
- )
- display))))
+ (let ([display (print-syntax-to-editor stx -text controller config)])
+ (send* -text
+ (insert "\n")
+ ;;(scroll-to-position current-position)
+ )
+ display)))
(define/private (calculate-columns)
- (define style (code-style -text))
+ (define style (code-style -text (send config get-syntax-font-size)))
(define char-width (send style get-text-width (send -ecanvas get-dc)))
(define-values (canvas-w canvas-h) (send -ecanvas get-client-size))
(sub1 (inexact->exact (floor (/ canvas-w char-width)))))
;; Initialize
(super-new)
- (setup-keymap)))
+ (setup-keymap)
+
+ (send config listen-props-shown?
+ (lambda (show?)
+ (show-props show?)))
+ (send config listen-props-percentage
+ (lambda (p)
+ (update-props-percentage p)))
+ (internal-show-props (send config get-props-shown?))))
+
(define clickback-style
(let ([sd (new style-delta%)])
diff --git a/collects/macro-debugger/tool.ss b/collects/macro-debugger/tool.ss
index 53cf67f2e9..af578c1620 100644
--- a/collects/macro-debugger/tool.ss
+++ b/collects/macro-debugger/tool.ss
@@ -201,36 +201,44 @@
(define/private (make-stepper filename)
(new drscheme-macro-stepper-director% (filename filename)))
+ (define/private (inner-eval original-eval-handler e-expr)
+ (original-eval-handler e-expr))
+
(define/private (make-handlers original-eval-handler
original-module-name-resolver)
- (let* ([filename (send (send (get-top-level-window)
- get-definitions-text)
- get-filename/untitled-name)]
- [director (make-stepper filename)]
- [debugging? debugging?])
- (set! current-stepper-director director)
- (values
- (lambda (expr)
- (if (and debugging? (syntax? expr))
- (let-values ([(e-expr events derivp) (trace* expr expand)])
- (show-deriv director events)
- (if (syntax? e-expr)
- (parameterize ((current-eval original-eval-handler))
- (original-eval-handler e-expr))
- (raise e-expr)))
- (original-eval-handler expr)))
- (lambda args
- (let ([eo (current-expand-observe)]
- [saved-debugging? debugging?])
- (dynamic-wind
- (lambda ()
- (set! debugging? #f)
- (when eo (current-expand-observe void)))
- (lambda ()
- (apply original-module-name-resolver args))
- (lambda ()
- (set! debugging? saved-debugging?)
- (when eo (current-expand-observe eo)))))))))
+ (define filename (send (send (get-top-level-window) get-definitions-text)
+ get-filename/untitled-name))
+ (define director (make-stepper filename))
+ (define local-debugging? debugging?)
+ (define (call-without-debugging thunk)
+ (let ([eo (current-expand-observe)]
+ [saved-debugging? local-debugging?])
+ (dynamic-wind
+ (lambda ()
+ (set! local-debugging? #f)
+ (when eo (current-expand-observe void)))
+ thunk
+ (lambda ()
+ (set! local-debugging? saved-debugging?)
+ (when eo (current-expand-observe eo))))))
+ (define (the-eval expr)
+ (if (and local-debugging? (syntax? expr))
+ (let-values ([(e-expr events derivp) (trace* expr expand)])
+ (show-deriv director events)
+ (if (syntax? e-expr)
+ (inner-eval e-expr)
+ (raise e-expr)))
+ (original-eval-handler expr)))
+ (define (inner-eval e-expr)
+ (if #f ;; fixme: turn into parameter/preference???
+ (call-without-debugging (lambda () (original-eval-handler e-expr)))
+ (original-eval-handler e-expr)))
+ (define (the-module-resolver . args)
+ (call-without-debugging
+ (lambda () (apply original-module-name-resolver args))))
+ (set! current-stepper-director director)
+ (values the-eval
+ the-module-resolver))
(define/private (show-deriv director events)
(parameterize ([current-eventspace drscheme-eventspace])
diff --git a/collects/macro-debugger/util/notify.ss b/collects/macro-debugger/util/notify.ss
index 316358a8f8..33267dd89a 100644
--- a/collects/macro-debugger/util/notify.ss
+++ b/collects/macro-debugger/util/notify.ss
@@ -151,10 +151,13 @@
(new checkable-menu-item%
(label label)
(parent parent)
- (checked (send nb get))
+ (demand-callback
+ (lambda (i)
+ (send i check (send nb get))))
(callback
- (lambda _ (send nb set (send menu-item is-checked?))))))
- (send nb listen (lambda (value) (send menu-item check value)))
+ (lambda _
+ #;(send nb set (send menu-item is-checked?))
+ (send nb set (not (send nb get)))))))
menu-item)
(define (check-box/notify-box parent label nb)
diff --git a/collects/macro-debugger/view/extensions.ss b/collects/macro-debugger/view/extensions.ss
index 311386c960..d28ed5794a 100644
--- a/collects/macro-debugger/view/extensions.ss
+++ b/collects/macro-debugger/view/extensions.ss
@@ -57,8 +57,8 @@
(inherit add-separator)
- (define/override (after-selection-items)
- (super after-selection-items)
+ (define/override (add-menu-items)
+ (super add-menu-items)
(add-separator)
(set! show-macro
(new menu-item% (label "Show selected identifier") (parent the-context-menu)
diff --git a/collects/macro-debugger/view/frame.ss b/collects/macro-debugger/view/frame.ss
index c921f78e63..29688ba4f2 100644
--- a/collects/macro-debugger/view/frame.ss
+++ b/collects/macro-debugger/view/frame.ss
@@ -14,7 +14,6 @@
"warning.ss"
"hiding-panel.ss"
(prefix-in sb: "../syntax-browser/embed.ss")
- (prefix-in sb: "../syntax-browser/params.ss")
"../model/deriv.ss"
"../model/deriv-util.ss"
"../model/trace.ss"
@@ -120,8 +119,8 @@
(callback (lambda _ (send widget show-in-new-frame)))))
(menu-option/notify-box stepper-menu
- "Show syntax properties"
- (get-field show-syntax-properties? config))
+ "View syntax properties"
+ (get-field props-shown? config))
(let ([id-menu
(new (get-menu%)
@@ -175,10 +174,10 @@
(parent extras-menu)
(callback
(lambda (i e)
- (sb:current-suffix-option
- (if (send i is-checked?)
- 'always
- 'over-limit))
+ (send config set-suffix-option
+ (if (send i is-checked?)
+ 'always
+ 'over-limit))
(send widget update/preserve-view))))
(menu-option/notify-box extras-menu
"Highlight redex/contractum"
diff --git a/collects/macro-debugger/view/interfaces.ss b/collects/macro-debugger/view/interfaces.ss
index c0a9adee1f..e374aaa9f9 100644
--- a/collects/macro-debugger/view/interfaces.ss
+++ b/collects/macro-debugger/view/interfaces.ss
@@ -5,6 +5,7 @@
;; Signatures
+#;
(define-signature view^
(macro-stepper-frame%
macro-stepper-widget%
@@ -12,12 +13,15 @@
go
go/deriv))
+#;
(define-signature view-base^
(base-frame%))
+#;
(define-signature prefs^
(pref:width
pref:height
+ pref:props-shown?
pref:props-percentage
pref:macro-hiding-mode
pref:show-syntax-properties?
diff --git a/collects/macro-debugger/view/prefs.ss b/collects/macro-debugger/view/prefs.ss
index e21cd97aa9..cdeeee8be6 100644
--- a/collects/macro-debugger/view/prefs.ss
+++ b/collects/macro-debugger/view/prefs.ss
@@ -2,6 +2,7 @@
#lang scheme/base
(require scheme/class
framework/framework
+ "../syntax-browser/prefs.ss"
"../util/notify.ss"
"../util/misc.ss")
(provide macro-stepper-config-base%
@@ -30,7 +31,6 @@
(pref:get/set pref:props-shown? MacroStepper:PropertiesShown?)
(pref:get/set pref:props-percentage MacroStepper:PropertiesPanelPercentage)
(pref:get/set pref:macro-hiding-mode MacroStepper:MacroHidingMode)
-(pref:get/set pref:show-syntax-properties? MacroStepper:ShowSyntaxProperties?)
(pref:get/set pref:show-hiding-panel? MacroStepper:ShowHidingPanel?)
(pref:get/set pref:identifier=? MacroStepper:IdentifierComparison)
(pref:get/set pref:highlight-foci? MacroStepper:HighlightFoci?)
@@ -43,13 +43,8 @@
(pref:get/set pref:force-letrec-transformation? MacroStepper:ForceLetrecTransformation?)
(define macro-stepper-config-base%
- (class object%
- (notify-methods width)
- (notify-methods height)
- (notify-methods props-shown?)
- (notify-methods props-percentage)
+ (class syntax-prefs-base%
(notify-methods macro-hiding-mode)
- (notify-methods show-syntax-properties?)
(notify-methods show-hiding-panel?)
(notify-methods identifier=?)
(notify-methods highlight-foci?)
@@ -66,10 +61,9 @@
(class macro-stepper-config-base%
(connect-to-pref width pref:width)
(connect-to-pref height pref:height)
- (connect-to-pref props-shown? pref:props-shown?)
(connect-to-pref props-percentage pref:props-percentage)
+ (connect-to-pref props-shown? pref:props-shown?)
(connect-to-pref macro-hiding-mode pref:macro-hiding-mode)
- (connect-to-pref show-syntax-properties? pref:show-syntax-properties?)
(connect-to-pref show-hiding-panel? pref:show-hiding-panel?)
(connect-to-pref identifier=? pref:identifier=?)
(connect-to-pref highlight-foci? pref:highlight-foci?)
@@ -88,7 +82,6 @@
(connect-to-pref/readonly height pref:height)
(connect-to-pref/readonly macro-hiding-mode pref:macro-hiding-mode)
(connect-to-pref/readonly props-percentage pref:props-percentage)
- (connect-to-pref/readonly show-syntax-properties? pref:show-syntax-properties?)
(connect-to-pref/readonly show-hiding-panel? pref:show-hiding-panel?)
(connect-to-pref/readonly identifier=? pref:identifier=?)
(connect-to-pref/readonly highlight-foci? pref:highlight-foci?)
diff --git a/collects/macro-debugger/view/stepper.ss b/collects/macro-debugger/view/stepper.ss
index 3d12e06aa8..830a1c72e1 100644
--- a/collects/macro-debugger/view/stepper.ss
+++ b/collects/macro-debugger/view/stepper.ss
@@ -13,8 +13,6 @@
"warning.ss"
"hiding-panel.ss"
"term-record.ss"
- (prefix-in s: "../syntax-browser/widget.ss")
- (prefix-in s: "../syntax-browser/params.ss")
"../model/deriv.ss"
"../model/deriv-util.ss"
"../model/deriv-find.ss"
@@ -138,10 +136,8 @@
(stepper this)
(config config)))
- (send config listen-show-syntax-properties?
- (lambda (show?) (send sbview show-props show?)))
(send config listen-show-hiding-panel?
- (lambda (show?) (show-macro-hiding-prefs show?)))
+ (lambda (show?) (show-macro-hiding-panel show?)))
(send sbc listen-selected-syntax
(lambda (stx) (send macro-hiding-prefs set-syntax stx)))
(send config listen-highlight-foci?
@@ -215,7 +211,7 @@
nav:next
nav:end)))))
- (define/public (show-macro-hiding-prefs show?)
+ (define/public (show-macro-hiding-panel show?)
(send area change-children
(lambda (children)
(if show?
@@ -379,6 +375,7 @@
(send (focused-term) on-get-focus))
(update))
+#|
;; delayed-recache-errors : (list-of (cons exn string))
(define delayed-recache-errors null)
@@ -408,6 +405,7 @@
"")))
(set! delayed-recache-errors null)))))
(raise exn)))
+|#
(define/private (foci x) (if (list? x) x (list x)))
@@ -423,8 +421,7 @@
;; Initialization
(super-new)
- (send sbview show-props (send config get-show-syntax-properties?))
- (show-macro-hiding-prefs (send config get-show-hiding-panel?))
+ (show-macro-hiding-panel (send config get-show-hiding-panel?))
(show-extra-navigation (send config get-extra-navigation?))
(refresh/move)
))
diff --git a/collects/macro-debugger/view/term-record.ss b/collects/macro-debugger/view/term-record.ss
index c6e5d1a8a4..6e08c02ea0 100644
--- a/collects/macro-debugger/view/term-record.ss
+++ b/collects/macro-debugger/view/term-record.ss
@@ -12,8 +12,6 @@
"extensions.ss"
"warning.ss"
"hiding-panel.ss"
- (prefix-in s: "../syntax-browser/widget.ss")
- (prefix-in s: "../syntax-browser/params.ss")
"../model/deriv.ss"
"../model/deriv-util.ss"
"../model/deriv-find.ss"
@@ -277,13 +275,16 @@
;; display-final-term : -> void
(define/public (display-final-term)
- (recache-synth!)
+ (recache-steps!)
(cond [(syntax? raw-steps-estx)
(add-syntax raw-steps-estx binders definites)]
[(exn? error)
(add-error error)]
[raw-steps-oops
- (add-internal-error "steps" raw-steps-oops #f)]))
+ (add-internal-error "steps" raw-steps-oops #f)]
+ [else
+ (error 'term-record::display-final-term
+ "internal error")]))
;; display-step : -> void
(define/public (display-step)
diff --git a/collects/repos-time-stamp/stamp.ss b/collects/repos-time-stamp/stamp.ss
index 19669ca910..8a8883f6f5 100644
--- a/collects/repos-time-stamp/stamp.ss
+++ b/collects/repos-time-stamp/stamp.ss
@@ -1 +1 @@
-#lang scheme/base (provide stamp) (define stamp "30nov2008")
+#lang scheme/base (provide stamp) (define stamp "3dec2008")
diff --git a/collects/scheme/sandbox.ss b/collects/scheme/sandbox.ss
index c1199582be..71bceafb46 100644
--- a/collects/scheme/sandbox.ss
+++ b/collects/scheme/sandbox.ss
@@ -29,9 +29,10 @@
get-output
get-error-output
get-uncovered-expressions
- get-namespace
+ call-in-sandbox-context
make-evaluator
make-module-evaluator
+ call-in-nested-thread*
call-with-limits
with-limits
exn:fail:resource?
@@ -212,45 +213,61 @@
(define memory-accounting? (custodian-memory-accounting-available?))
+;; similar to `call-in-nested-thread', but propagates killing the thread,
+;; shutting down the custodian or setting parameters and thread cells;
+;; optionally with thunks to call for kill/shutdown.
+(define (call-in-nested-thread*
+ thunk
+ [kill (lambda () (kill-thread (current-thread)))]
+ [shutdown (lambda () (custodian-shutdown-all (current-custodian)))])
+ (let* ([p #f]
+ [c (make-custodian)]
+ [b (make-custodian-box c #t)])
+ (with-handlers ([(lambda (_) (not p))
+ ;; if the after thunk was not called, then this error is
+ ;; about the thread dying unnaturally, so propagate
+ ;; whatever it did
+ (lambda (_) ((if (custodian-box-value b) kill shutdown)))])
+ (dynamic-wind void
+ (lambda ()
+ (parameterize ([current-custodian c])
+ (call-in-nested-thread
+ (lambda ()
+ (dynamic-wind void thunk
+ ;; this should always be called unless the thread is killed or
+ ;; the custodian is shutdown, distinguish the two cases
+ ;; through the above box
+ (lambda ()
+ (set! p (current-preserved-thread-cell-values))))))))
+ (lambda () (when p (current-preserved-thread-cell-values p)))))))
+
(define (call-with-limits sec mb thunk)
- (let ([r #f]
- [c (make-custodian)]
- ;; used to copy parameter changes from the nested thread
- [p current-preserved-thread-cell-values])
- (when (and mb memory-accounting?)
- (custodian-limit-memory c (* mb 1024 1024) c))
- (parameterize ([current-custodian c])
- ;; The nested-thread can die on a time-out or memory-limit,
- ;; and never throws an exception, so we never throw an error,
- ;; just assume the a death means the custodian was shut down
- ;; due to memory limit. Note: cannot copy the
- ;; parameterization in this case.
- (with-handlers ([exn:fail? (lambda (e)
- (unless r (set! r (cons #f 'memory))))])
- (call-in-nested-thread
- (lambda ()
- (define this (current-thread))
- (define timer
- (and sec
- (thread (lambda ()
- (sleep sec)
- ;; even in this case there are no parameters
- ;; to copy, since it is on a different thread
- (set! r (cons #f 'time))
- (kill-thread this)))))
- (set! r
- (with-handlers ([void (lambda (e) (list (p) raise e))])
- (call-with-values thunk (lambda vs (list* (p) values vs)))))
- (when timer (kill-thread timer)))))
- (custodian-shutdown-all c)
- (unless r (error 'call-with-limits "internal error"))
- ;; apply parameter changes first
- (when (car r) (p (car r)))
- (if (pair? (cdr r))
- (apply (cadr r) (cddr r))
- (raise (make-exn:fail:resource (format "with-limit: out of ~a" (cdr r))
- (current-continuation-marks)
- (cdr r)))))))
+ ;; note that when the thread is killed after using too much memory or time,
+ ;; then all thread-local changes (parameters and thread cells) are discarded
+ (let ([r #f])
+ (call-in-nested-thread*
+ (lambda ()
+ ;; memory limit
+ (when (and mb memory-accounting?)
+ (custodian-limit-memory (current-custodian) (* mb 1024 1024)))
+ ;; time limit
+ (when sec
+ (let ([t (current-thread)])
+ (thread (lambda () (sleep sec) (set! r 'time) (kill-thread t)))))
+ (set! r (with-handlers ([void (lambda (e) (list raise e))])
+ (call-with-values thunk (lambda vs (list* values vs))))))
+ (lambda () (unless r (set! r 'kill)))
+ (lambda () (unless r (set! r 'shut))))
+ (case r
+ [(kill) (kill-thread (current-thread))]
+ [(shut) (custodian-shutdown-all (current-custodian))]
+ [(memory time)
+ (raise (make-exn:fail:resource (format "with-limit: out of ~a" r)
+ (current-continuation-marks)
+ r))]
+ [else (if (pair? r)
+ (apply (car r) (cdr r))
+ (error 'call-with-limits "internal error in nested: ~e" r))])))
(define-syntax with-limits
(syntax-rules ()
@@ -382,16 +399,14 @@
(lambda (x) (abort-current-continuation deftag x)))
(loop (car exprs) (cdr exprs))))))))))
-(define (evaluate-program program limits uncovered!)
+(define (evaluate-program program limit-thunk uncovered!)
(when uncovered!
(eval `(,#'#%require scheme/private/sandbox-coverage)))
- ;; the actual evaluation happens under specified limits, if given
- (let ([run (if (and (pair? program) (eq? 'begin (car program)))
- (lambda () (eval* (cdr program)))
- (lambda () (eval program)))]
- [sec (and limits (car limits))]
- [mb (and limits (cadr limits))])
- (if (or sec mb) (call-with-limits sec mb run) (run)))
+ ;; the actual evaluation happens under the specified limits
+ ((limit-thunk (lambda ()
+ (if (and (pair? program) (eq? 'begin (car program)))
+ (eval* (cdr program))
+ (eval program)))))
(let ([ns (syntax-case* program (module) literal-identifier=?
[(module mod . body)
(identifier? #'mod)
@@ -435,15 +450,15 @@
(define-evaluator-messenger kill-evaluator 'kill)
(define-evaluator-messenger break-evaluator 'break)
-(define-evaluator-messenger (set-eval-limits . xs) 'limits)
+(define-evaluator-messenger (set-eval-limits secs mb) 'limits)
(define-evaluator-messenger (put-input . xs) 'input)
(define-evaluator-messenger get-output 'output)
(define-evaluator-messenger get-error-output 'error-output)
(define-evaluator-messenger (get-uncovered-expressions . xs) 'uncovered)
-(define-evaluator-messenger get-namespace 'namespace)
+(define-evaluator-messenger (call-in-sandbox-context thunk) 'thunk)
(define (make-evaluator* init-hook require-perms program-maker)
- (define cust (make-custodian))
+ (define user-cust (make-custodian))
(define coverage? (sandbox-coverage-enabled))
(define uncovered #f)
(define input-ch (make-channel))
@@ -453,12 +468,17 @@
(define error-output #f)
(define limits (sandbox-eval-limits))
(define user-thread #t) ; set later to the thread
- (define orig-cust (current-custodian))
+ (define user-done-evt #t) ; set in the same place
+ (define orig-cust (current-custodian))
+ (define (limit-thunk thunk)
+ (let* ([sec (and limits (car limits))]
+ [mb (and limits (cadr limits))])
+ (if (or sec mb) (lambda () (call-with-limits sec mb thunk)) thunk)))
(define (user-kill)
(when user-thread
(let ([t user-thread])
(set! user-thread #f)
- (custodian-shutdown-all cust)
+ (custodian-shutdown-all user-cust)
(kill-thread t))) ; just in case
(void))
(define (user-break)
@@ -471,7 +491,7 @@
;; now read and evaluate the input program
(evaluate-program
(if (procedure? program-maker) (program-maker) program-maker)
- limits
+ limit-thunk
(and coverage? (lambda (es+get) (set! uncovered es+get))))
(channel-put result-ch 'ok))
;; finally wait for interaction expressions
@@ -481,20 +501,15 @@
(when (eof-object? expr) (channel-put result-ch expr) (user-kill))
(with-handlers ([void (lambda (exn)
(channel-put result-ch (cons 'exn exn)))])
- (let* ([run (if (evaluator-message? expr)
- (lambda ()
- (apply (evaluator-message-msg expr)
- (evaluator-message-args expr)))
- (lambda ()
- (set! n (add1 n))
- (eval* (input->code (list expr) 'eval n))))]
- [sec (and limits (car limits))]
- [mb (and limits (cadr limits))]
- [run (if (or sec mb)
- (lambda () (with-limits sec mb (run)))
- run)])
- (channel-put result-ch
- (cons 'vals (call-with-values run list)))))
+ (define run
+ (limit-thunk (if (evaluator-message? expr)
+ (lambda ()
+ (apply (evaluator-message-msg expr)
+ (evaluator-message-args expr)))
+ (lambda ()
+ (set! n (add1 n))
+ (eval* (input->code (list expr) 'eval n))))))
+ (channel-put result-ch (cons 'vals (call-with-values run list))))
(loop)))))
(define (user-eval expr)
(let ([r (if user-thread
@@ -506,7 +521,7 @@
(lambda (e)
(user-break)
(loop))])
- (channel-get result-ch))))
+ (sync user-done-evt result-ch))))
eof)])
(cond [(eof-object? r) (error 'evaluator "terminated")]
[(eq? (car r) 'exn) (raise (cdr r))]
@@ -544,30 +559,32 @@
[(output) (output-getter output)]
[(error-output) (output-getter error-output)]
[(uncovered) (apply get-uncovered (evaluator-message-args expr))]
- [(namespace) (user-eval (make-evaluator-message
- current-namespace '()))]
+ [(thunk) (user-eval (make-evaluator-message
+ (car (evaluator-message-args expr)) '()))]
[else (error 'evaluator "internal error, bad message: ~e" msg)]))
(user-eval expr)))
- (define linked-outputs? #f)
(define (make-output what out set-out! allow-link?)
(cond [(not out) (open-output-nowhere)]
[(and (procedure? out) (procedure-arity-includes? out 0)) (out)]
[(output-port? out) out]
[(eq? out 'pipe) (let-values ([(i o) (make-pipe)]) (set-out! i) o)]
[(memq out '(bytes string))
- (let* ([bytes? (eq? 'bytes out)]
- ;; the following doesn't really matter: they're the same
- [out ((if bytes? open-output-bytes open-output-string))])
+ (let* ([bytes? (eq? out 'bytes)]
+ ;; create the port under the user's custodian
+ [out (parameterize ([current-custodian user-cust])
+ (call-in-nested-thread
+ ;; this doesn't really matter: they're the same anyway
+ (if bytes? open-output-bytes open-output-string)))])
(set-out!
(lambda ()
- (parameterize ([current-custodian orig-cust])
- (let ([buf (get-output-bytes out #t)])
- (if bytes? buf (bytes->string/utf-8 buf #\?))))))
+ ;; this will run in the user context
+ (let ([buf (get-output-bytes out #t)])
+ (if bytes? buf (bytes->string/utf-8 buf #\?)))))
out)]
[else (error 'make-evaluator "bad sandox-~a spec: ~e" what out)]))
(parameterize* ; the order in these matters
(;; create a sandbox context first
- [current-custodian cust]
+ [current-custodian user-cust]
[current-thread-group (make-thread-group)]
[current-namespace (make-evaluation-namespace)]
;; set up the IO context
@@ -613,6 +630,7 @@
;; it will not use the new namespace.
[current-eventspace (make-eventspace)])
(set! user-thread (bg-run->thread (run-in-bg user-process)))
+ (set! user-done-evt (handle-evt user-thread (lambda (_) (user-kill) eof)))
(let ([r (channel-get result-ch)])
(if (eq? r 'ok)
;; initial program executed ok, so return an evaluator
diff --git a/collects/scribblings/reference/bytes.scrbl b/collects/scribblings/reference/bytes.scrbl
index b1343663f6..a8273f9e88 100644
--- a/collects/scribblings/reference/bytes.scrbl
+++ b/collects/scribblings/reference/bytes.scrbl
@@ -335,7 +335,7 @@ string.
@defproc[(bytes-open-converter [from-name string?][to-name string?])
bytes-converter?]{
-Produces a string converter to go from the encoding named by
+Produces a @deftech{byte converter} to go from the encoding named by
@scheme[from-name] to the encoding named by @scheme[to-name]. If the
requested conversion pair is not available, @scheme[#f] is returned
instead of a converter.
@@ -534,8 +534,8 @@ The result of @scheme[bytes-convert-end] is two values:
@defproc[(bytes-converter? [v any/c]) boolean?]{
-Returns @scheme[#t] if @scheme[v] is a byte converter produced by
-@scheme[bytes-open-converter], @scheme[#f] otherwise.}
+Returns @scheme[#t] if @scheme[v] is a @tech{byte converter} produced
+by @scheme[bytes-open-converter], @scheme[#f] otherwise.}
@defproc[(locale-string-encoding) any]{
diff --git a/collects/scribblings/reference/custodians.scrbl b/collects/scribblings/reference/custodians.scrbl
index 459e5bb270..69e5a66a76 100644
--- a/collects/scribblings/reference/custodians.scrbl
+++ b/collects/scribblings/reference/custodians.scrbl
@@ -1,6 +1,8 @@
#lang scribble/doc
@(require "mz.ss")
+@(define eventspaces @tech[#:doc '(lib "scribblings/gui/gui.scrbl")]{eventspaces})
+
@title[#:tag "custodians"]{Custodians}
See @secref["custodian-model"] for basic information on the PLT
@@ -22,8 +24,13 @@ automatically directed to shut down its managed values as well.}
@defproc[(custodian-shutdown-all [cust custodian?]) void?]{
-Closes all open ports and closes all active TCP listeners and UDP
-sockets that are managed by @scheme[cust]. It also removes
+@margin-note{In MrEd, @|eventspaces| managed by @scheme[cust] are also
+ shut down.}
+
+Closes all @tech{file-stream ports}, @tech{TCP ports}, @tech{TCP
+listeners}, and @tech{UDP sockets} that are managed by @scheme[cust]
+(and its subordinates), and empties all @tech{custodian box}es
+associated with @scheme[cust] (and its subordinates). It also removes
@scheme[cust] (and its subordinates) as managers of all threads; when
a thread has no managers, it is killed (or suspended; see
@scheme[thread/suspend-to-kill]) If the current thread is to be
@@ -33,18 +40,20 @@ thread.}
@defparam[current-custodian cust custodian?]{
+@margin-note{In MrEd, custodians also manage @|eventspaces|.}
+
A parameter that determines a custodian that assumes responsibility
-for newly created threads, ports, TCP listeners, UDP sockets, and
-byte converters.}
+for newly created threads, @tech{file-stream ports}, TCP ports,
+@tech{TCP listeners}, @tech{UDP sockets}, and @tech{byte converters}.}
@defproc[(custodian-managed-list [cust custodian?][super custodian?]) list?]{
-Returns a list of immediately managed objects and subordinate
-custodians for @scheme[cust], where @scheme[cust] is itself
-subordinate to @scheme[super] (directly or indirectly). If
-@scheme[cust] is not strictly subordinate to @scheme[super], the
-@exnraise[exn:fail:contract].}
+Returns a list of immediately managed objects (not including
+@tech{custodian box}es) and subordinate custodians for @scheme[cust],
+where @scheme[cust] is itself subordinate to @scheme[super] (directly
+or indirectly). If @scheme[cust] is not strictly subordinate to
+@scheme[super], the @exnraise[exn:fail:contract].}
@defproc[(custodian-memory-accounting-available?) boolean?]{
@@ -66,7 +75,7 @@ per-custodian memory accounting, otherwise the
If a check is registered, and if PLT Scheme later reaches a state after
garbage collection (see @secref["gc-model"]) where allocating
@scheme[need-amt] bytes charged to @scheme[limit-cust] would fail or
-tigger some shutdown, then @scheme[stop-cust] is shut down.}
+trigger some shutdown, then @scheme[stop-cust] is shut down.}
@defproc[(custodian-limit-memory [limit-cust custodian?]
[limit-amt exact-nonnegative-integer?]
@@ -81,11 +90,16 @@ after garbage collection (see @secref["gc-model"]) where
@scheme[limit-cust] owns more than @scheme[limit-amt] bytes, then
@scheme[stop-cust] is shut down.
+@margin-note{A custodian's limit is checked only after a garbage
+ collection, except that it may also be checked during
+ certain large allocations that are individually larger
+ than the custodian's limit.}
+
For reliable shutdown, @scheme[limit-amt] for
@scheme[custodian-limit-memory] must be much lower than the total
amount of memory available (minus the size of memory that is
potentially used and not charged to @scheme[limit-cust]). Moreover, if
-indvidual allocations that are initially charged to
+individual allocations that are initially charged to
@scheme[limit-cust] can be arbitrarily large, then @scheme[stop-cust]
must be the same as @scheme[limit-cust], so that excessively large
immediate allocations can be rejected with an
@@ -93,13 +107,13 @@ immediate allocations can be rejected with an
@defproc[(make-custodian-box [cust custodian?][v any/c]) custodian-box?]{
-Returns a @deftech{custodian box} that contains @scheme[v] as long as
+Returns a @tech{custodian box} that contains @scheme[v] as long as
@scheme[cust] has not been shut down.}
@defproc[(custodian-box? [v any/c]) boolean?]{Returns @scheme[#t] if
@scheme[v] is a @tech{custodian box} produced by
@scheme[make-custodian-box], @scheme[#f] otherwise.}
-@defproc[(custodian-box-value [cb custodian-box?]) any]{Rturns the
+@defproc[(custodian-box-value [cb custodian-box?]) any]{Returns the
value in the given @tech{custodian box}, or @scheme[#f] if the value
has been removed.}
diff --git a/collects/scribblings/reference/eval-model.scrbl b/collects/scribblings/reference/eval-model.scrbl
index 2c75b4300c..4cd934cbe6 100644
--- a/collects/scribblings/reference/eval-model.scrbl
+++ b/collects/scribblings/reference/eval-model.scrbl
@@ -744,12 +744,12 @@ outermost frame of the continuation for any new thread.
@margin-note/ref{See @secref["custodians"] for custodian functions.}
-A @deftech{custodian} manages a collection of threads, file-stream
-ports, TCP ports, TCP listeners, UDP sockets, and byte converters.
-Whenever a thread, file-stream port, TCP port, TCP listener, or UDP
-socket is created, it is placed under the management of the
-@deftech{current custodian} as determined by the
-@scheme[current-custodian] @tech{parameter}.
+A @deftech{custodian} manages a collection of threads,
+@tech{file-stream ports}, TCP ports, @tech{TCP listeners}, @tech{UDP
+sockets}, and @tech{byte converters}. Whenever a thread, etc. is
+created, it is placed under the management of the @deftech{current
+custodian} as determined by the @scheme[current-custodian]
+@tech{parameter}.
@margin-note{In MrEd, custodians also manage eventspaces.}
@@ -785,7 +785,7 @@ collected, at which point its subordinates become immediately
subordinate to the collected custodian's superordinate custodian.
In addition to the other entities managed by a custodian, a
-@defterm{custodian box} created with @scheme[make-custodian-box]
+@deftech{custodian box} created with @scheme[make-custodian-box]
strongly holds onto a value placed in the box until the box's
custodian is shut down. The custodian only weakly retains the box
itself, however (so the box and its content can be collected if there
diff --git a/collects/scribblings/reference/networking.scrbl b/collects/scribblings/reference/networking.scrbl
index 71f30d3a66..64e918e35a 100644
--- a/collects/scribblings/reference/networking.scrbl
+++ b/collects/scribblings/reference/networking.scrbl
@@ -51,11 +51,11 @@ supported or IPv6 sockets are not configurable, then the IPv6
addresses are ignored; otherwise, each IPv6 listener accepts only IPv6
connections.)
-The return value of @scheme[tcp-listen] is a TCP listener value. This
-value can be used in future calls to @scheme[tcp-accept],
-@scheme[tcp-accept-ready?], and @scheme[tcp-close]. Each new TCP
-listener value is placed into the management of the current custodian
-(see @secref["custodians"]).
+The return value of @scheme[tcp-listen] is a @deftech{TCP
+listener}. This value can be used in future calls to
+@scheme[tcp-accept], @scheme[tcp-accept-ready?], and
+@scheme[tcp-close]. Each new TCP listener value is placed into the
+management of the current custodian (see @secref["custodians"]).
If the server cannot be started by @scheme[tcp-listen], the
@exnraise[exn:fail:network].}
@@ -137,8 +137,7 @@ not both.}
(values input-port? output-port?)]{
Accepts a client connection for the server associated with
-@scheme[listener], which is a TCP listener value returned by
-@scheme[tcp-listen]. If no client connection is waiting on the
+@scheme[listener]. If no client connection is waiting on the
listening port, the call to @scheme[tcp-accept] will block. (See also
@scheme[tcp-accept-ready?].)
@@ -168,8 +167,7 @@ raised, but not both.}
@defproc[(tcp-accept-ready? [listener tcp-listener?]) boolean?]{
Tests whether an unaccepted client has connected to the server
-associated with @scheme[listener]. The @scheme[listener] argument is a
-TCP listener value returned by @scheme[tcp-listen]. If a client is
+associated with @scheme[listener]. If a client is
waiting, the return value is @scheme[#t], otherwise it is
@scheme[#f]. A client is accepted with the @scheme[tcp-accept]
procedure, which returns ports for communicating with the client and
@@ -180,10 +178,9 @@ If the listener has been closed, the @exnraise[exn:fail:network].}
@defproc[(tcp-close [listener tcp-listener?]) void?]{
-Shuts down the server associated with @scheme[listener]. The
-@scheme[listener] argument is a TCP listener value returned by
-@scheme[tcp-listen]. All unaccepted clients receive an end-of-file
-from the server; connections to accepted clients are unaffected.
+Shuts down the server associated with @scheme[listener]. All
+unaccepted clients receive an end-of-file from the server; connections
+to accepted clients are unaffected.
If the listener has already been closed, the @exnraise[exn:fail:network].
@@ -195,7 +192,7 @@ explanation of the @tt{TIME_WAIT} TCP state.}
@defproc[(tcp-listener? [v any/c]) boolean?]{
-Returns @scheme[#t] if @scheme[v] is a TCP listener value created by
+Returns @scheme[#t] if @scheme[v] is a @tech{TCP listener} created by
@scheme[tcp-listen], @scheme[#f] otherwise.}
@@ -220,7 +217,7 @@ closed.
The TCP protocol does not include a ``no longer reading'' state on
connections, so @scheme[tcp-abandon-port] is equivalent to
-@scheme[close-input-port] on input TCP ports.}
+@scheme[close-input-port] on input @tech{TCP ports}.}
@defproc[(tcp-addresses [tcp-port tcp-port?]
@@ -231,7 +228,7 @@ connections, so @scheme[tcp-abandon-port] is equivalent to
Returns two strings when @scheme[port-numbers?] is @scheme[#f] (the
default). The first string is the Internet address for the local
-machine a viewed by the given TCP port's connection. (For most
+machine a viewed by the given @tech{TCP port}'s connection. (For most
machines, the answer corresponds to the current machine's only
Internet address, but when a machine serves multiple addresses, the
result is connection-specific.) The second string is the Internet
@@ -248,10 +245,10 @@ If the given port has been closed, the @exnraise[exn:fail:network].}
@defproc[(tcp-port? [v any/c]) boolean?]{
-Returns @scheme[#t] if @scheme[v] is a port returned by
-@scheme[tcp-accept], @scheme[tcp-connect],
+Returns @scheme[#t] if @scheme[v] is a @deftech{TCP port}---which is a
+port returned by @scheme[tcp-accept], @scheme[tcp-connect],
@scheme[tcp-accept/enable-break], or
-@scheme[tcp-connect/enable-break], @scheme[#f] otherwise.}
+@scheme[tcp-connect/enable-break]---@scheme[#f] otherwise.}
@;------------------------------------------------------------------------
@section[#:tag "udp"]{UDP}
@@ -265,7 +262,7 @@ Volume 1} by W. Richard Stevens.
[family-port-no (or/c string? #f) #f])
udp?]{
-Creates and returns a UDP socket to send and receive
+Creates and returns a @deftech{UDP socket} to send and receive
datagrams (broadcasting is allowed). Initially, the socket is not
bound or connected to any address or port.
diff --git a/collects/scribblings/reference/sandbox.scrbl b/collects/scribblings/reference/sandbox.scrbl
index 3db9ae43ee..0e69330221 100644
--- a/collects/scribblings/reference/sandbox.scrbl
+++ b/collects/scribblings/reference/sandbox.scrbl
@@ -477,19 +477,14 @@ of the input program. Its value should be a list of two numbers, the
first is a timeout value in seconds, and the second is a memory limit
in megabytes. Either one can be @scheme[#f] for disabling the
corresponding limit; alternately, the parameter can be set to
-@scheme[#f] to disable all limits (in case more are available in
-future versions). The default is @scheme[(list 30 20)].
+@scheme[#f] to disable all limits (useful in case more limit kinds are
+available in future versions). The default is @scheme[(list 30 20)].
Note that these limits apply to the creation of the sandbox
environment too --- even @scheme[(make-evaluator 'scheme/base)] can
fail if the limits are strict enough. Therefore, to avoid surprises
you need to catch errors that happen when the sandbox is created.
-so, for example, if the memory that is required to
-create the sandbox is higher than the limit, then
-@scheme[make-evaluator] will fail with a memory limit exception.
-
-
When limits are set, @scheme[call-with-limits] (see below) is wrapped
around each use of the evaluator, so consuming too much time or memory
results in an exception. Change the limits of a running evaluator
@@ -571,9 +566,10 @@ in a way that depends on the setting of @scheme[(sandbox-output)] or
input port end of the created pipe;}
@item{if it was @scheme['bytes] or @scheme['string], then the result
- is the accumulated output, and the output is directed to a new
- output string or byte string (so each call returns a different
- piece of the evaluator's output);}
+ is the accumulated output, and the output port is reset so each
+ call returns a different piece of the evaluator's output (note
+ that any allocations of such output are still subject to the
+ sandbox memory limit);}
@item{otherwise, it returns @scheme[#f].}
]}
@@ -622,10 +618,18 @@ the @scheme[src] argument. Using a sequence of S-expressions (not
coverage results, since each expression may be assigned a single
source location.}
-@defproc[(get-namespace [evaluator (any/c . -> . any)])
- namespace?]{
+@defproc[(call-in-sandbox-context [evaluator (any/c . -> . any)]
+ [thunk (-> any)])
+ any]{
-Retrieves the namespace that is used in an evaluator.}
+Calls the given @scheme[thunk] in the context of a sandboxed
+evaluator. The call is performed under the resource limits that are
+used for evaluating expressions.
+
+This is usually similar to @scheme[(evaluator (list thunk))], except
+that this relies on the common meaning of list expressions as function
+application (which is not true in all languages), and it relies on
+MzScheme's @scheme[eval] forgiving a non-S-expression input.}
@; ----------------------------------------------------------------------
diff --git a/collects/teachpack/htdp/scribblings/world.scrbl b/collects/teachpack/htdp/scribblings/world.scrbl
index f31a6d9557..641bbd64f0 100644
--- a/collects/teachpack/htdp/scribblings/world.scrbl
+++ b/collects/teachpack/htdp/scribblings/world.scrbl
@@ -64,21 +64,13 @@ pinholes are at position @scheme[(0,0)].
[w natural-number/c]
[h natural-number/c]
[r number?]
- [create-image (-> natural-number/c scene)]
- [gifs? boolean? #f])
+ [create-image (-> natural-number/c scene)])
true]{
creates and shows a canvas of width @scheme[w] and height @scheme[h] ,
starts a clock, making it tick every @scheme[r] (usually fractional)
seconds. Every time the clock ticks, drscheme applies @scheme[create-image] to
the number of ticks passed since this function call. The results of
these applications are displayed in the canvas.
-
- The fifth (and last) argument is optional. Providing @scheme[true] as
- the fifth argument causes drscheme to collect the scenes that the
- animation generates and to create an animated GIF from the results. Both
- the intermediate images as well as the final animated GIF are saved in a
- user-specified directory. This is useful for writing documentation and
- for describing students work.
}
Example:
diff --git a/collects/tests/mzscheme/sandbox.ss b/collects/tests/mzscheme/sandbox.ss
index cacbb51478..bb23038bdc 100644
--- a/collects/tests/mzscheme/sandbox.ss
+++ b/collects/tests/mzscheme/sandbox.ss
@@ -5,6 +5,28 @@
(require scheme/sandbox)
+;; test call-in-nested-thread*
+(let ()
+ (define-syntax-rule (nested body ...)
+ (call-in-nested-thread* (lambda () body ...)))
+ (test 1 values (nested 1))
+ ;; propagates parameters
+ (let ([p (make-parameter #f)])
+ (nested (p 1))
+ (test 1 p)
+ (with-handlers ([void void]) (nested (p 2) (error "foo") (p 3)))
+ (test 2 p))
+ ;; propagates kill-thread
+ (test (void) thread-wait
+ (thread (lambda ()
+ (nested (kill-thread (current-thread)))
+ ;; never reach here
+ (semaphore-wait (make-semaphore 0)))))
+ ;; propagates custodian-shutdown-all
+ (test (void) values
+ (parameterize ([current-custodian (make-custodian)])
+ (nested (custodian-shutdown-all (current-custodian))))))
+
(let ([ev void])
(define (run thunk)
(with-handlers ([void (lambda (e) (list 'exn: e))])
@@ -336,6 +358,74 @@
(set! y 789) ; would be an error without the `set!' parameter
y => 789
+ ;; test that output is also collected under the limit
+ --top--
+ (set! ev (parameterize ([sandbox-output 'bytes]
+ [sandbox-error-output current-output-port]
+ [sandbox-eval-limits '(0.25 1/2)])
+ (make-evaluator 'scheme/base)))
+ ;; GCing is needed to allow these to happen
+ --eval-- (display (make-bytes 400000 65))
+ --top-- (bytes-length (get-output ev)) => 400000
+ --eval-- (display (make-bytes 400000 65))
+ --top-- (bytes-length (get-output ev)) => 400000
+ --eval-- (display (make-bytes 400000 65))
+ --top-- (bytes-length (get-output ev)) => 400000
+ --eval-- (display (make-bytes 400000 65))
+ --top-- (bytes-length (get-output ev)) => 400000
+ --eval-- (display (make-bytes 400000 65))
+ --top-- (bytes-length (get-output ev)) => 400000
+ ;; EB: for some reason, the first thing doesn't throw an error, and I think
+ ;; that the second should break much sooner than 100 iterations
+ ;; --eval-- (let ([400k (make-bytes 400000 65)])
+ ;; (for ([i (in-range 2)]) (display 400k)))
+ ;; --top-- (bytes-length (get-output ev))
+ ;; =err> "out of memory"
+ ;; --eval-- (let ([400k (make-bytes 400000 65)])
+ ;; (for ([i (in-range 100)]) (display 400k)))
+ ;; =err> "out of memory"
+
+ ;; test that killing the custodian works fine
+ ;; first try it without limits (which imply a nester thread/custodian)
+ --top--
+ (set! ev (parameterize ([sandbox-eval-limits #f])
+ (make-evaluator 'scheme/base)))
+ --eval--
+ (kill-thread (current-thread)) =err> "terminated"
+ --top--
+ (set! ev (parameterize ([sandbox-eval-limits #f])
+ (make-evaluator 'scheme/base)))
+ --eval--
+ (custodian-shutdown-all (current-custodian)) =err> "terminated"
+ --top--
+ ;; also happens when it's done directly
+ (set! ev (parameterize ([sandbox-eval-limits #f])
+ (make-evaluator 'scheme/base)))
+ (call-in-sandbox-context ev (lambda () (kill-thread (current-thread))))
+ =err> "terminated"
+ (set! ev (parameterize ([sandbox-eval-limits #f])
+ (make-evaluator 'scheme/base)))
+ (call-in-sandbox-context ev
+ (lambda () (custodian-shutdown-all (current-custodian))))
+ =err> "terminated"
+ --top--
+ ;; now make sure it works with per-expression limits too
+ (set! ev (make-evaluator 'scheme/base))
+ --eval--
+ (kill-thread (current-thread)) =err> "terminated"
+ --top--
+ (set! ev (make-evaluator 'scheme/base))
+ --eval--
+ (custodian-shutdown-all (current-custodian)) =err> "terminated"
+ --top--
+ (set! ev (make-evaluator 'scheme/base))
+ (call-in-sandbox-context ev (lambda () (kill-thread (current-thread))))
+ =err> "terminated"
+ (set! ev (make-evaluator 'scheme/base))
+ (call-in-sandbox-context ev
+ (lambda () (custodian-shutdown-all (current-custodian))))
+ =err> "terminated"
+
))
(report-errs)
diff --git a/collects/tests/mzscheme/will.ss b/collects/tests/mzscheme/will.ss
index e3ebb4d8be..a047468886 100644
--- a/collects/tests/mzscheme/will.ss
+++ b/collects/tests/mzscheme/will.ss
@@ -116,6 +116,15 @@
((current-memory-use c) . >= . 100000))
c)))
+(let ()
+ (define c1 (make-custodian (current-custodian)))
+ (define b1 (make-custodian-box c1 #t))
+ (define c2 (make-custodian c1))
+ (define b2 (make-custodian-box c2 #t))
+ (test '(#t #t) map custodian-box-value (list b1 b2))
+ (custodian-shutdown-all c1)
+ (test '(#f #f) map custodian-box-value (list b1 b2)))
+
;; ----------------------------------------
(report-errs)
diff --git a/collects/tests/r6rs/base.sls b/collects/tests/r6rs/base.sls
index 50bcf669e6..39525229fb 100644
--- a/collects/tests/r6rs/base.sls
+++ b/collects/tests/r6rs/base.sls
@@ -62,11 +62,11 @@
(syntax-rules ()
[(_ op)
(begin
- (test/exn (op 1 0) &assertion)
- (test/exn (op 1 0.0) &assertion)
- (test/exn (op +inf.0 1) &assertion)
- (test/exn (op -inf.0 1) &assertion)
- (test/exn (op +nan.0 1) &assertion))]))
+ (test/unspec-flonum-or-exn (op 1 0) &assertion)
+ (test/unspec-flonum-or-exn (op 1 0.0) &assertion)
+ (test/unspec-flonum-or-exn (op +inf.0 1) &assertion)
+ (test/unspec-flonum-or-exn (op -inf.0 1) &assertion)
+ (test/unspec-flonum-or-exn (op +nan.0 1) &assertion))]))
(define-syntax test-string-to-number
(syntax-rules ()
@@ -924,7 +924,7 @@
(for-each
(lambda (n)
(test (string->number (number->string n)) n)
- (test (string->number (number->string n 10 5)) n)
+ (test (string->number (number->string (inexact n) 10 5)) (inexact n))
(when (exact? n)
(test (string->number (number->string n 16) 16) n)
(test (string->number (string-append "#x" (number->string n 16))) n)
diff --git a/collects/tests/r6rs/io/ports.sls b/collects/tests/r6rs/io/ports.sls
index e49a3c8e12..5a0ea2ce3b 100644
--- a/collects/tests/r6rs/io/ports.sls
+++ b/collects/tests/r6rs/io/ports.sls
@@ -342,16 +342,19 @@
(close-port p))
(let ([p (open-file-input-port "io-tmp1")])
(let ([b1 (get-u8 p)])
- (if (= b1 #xFE)
- (begin
- (test (get-u8 p) #xFF)
- (test (get-u8 p) 0)
- (test (get-u8 p) 97))
- (begin
- (test b1 #xFF)
- (test (get-u8 p) #xFE)
- (test (get-u8 p) 97)
- (test (get-u8 p) 0))))
+ (cond
+ [(equal? b1 #xFE)
+ (test (get-u8 p) #xFF)
+ (test (get-u8 p) 0)
+ (test (get-u8 p) 97)]
+ [(equal? b1 #xFF)
+ (test (get-u8 p) #xFE)
+ (test (get-u8 p) 97)
+ (test (get-u8 p) 0)]
+ [else
+ ;; Must be big-endian
+ (test b1 0)
+ (test (get-u8 p) 97)]))
(test/unspec (close-port p)))
(let ([bytevector->string-via-file
@@ -566,22 +569,19 @@
(lambda () pos)
(lambda (p) (set! pos p))
(lambda () 'ok))])
- (test (port-position p) 0)
+ (test/unspec (port-position p))
(test (get-string-n p 3) "abc")
- (test (port-position p) 3)
(test (lookahead-char p) #\d)
(test (lookahead-char p) #\d)
- (test (port-position p) 3)
- (test/unspec (set-port-position! p 10))
+ (test (get-string-n p 7) "defghij")
(get-string-n p 2)
(test (get-string-n p 2) "mn")
(test (get-string-n p 2) "op")
(test (get-string-n p 2) (eof-object))
- (test/unspec (set-port-position! p 2))
- (test (get-string-n p 3) "cde")
(test/unspec (close-port p)))
- (test-positions make-custom-textual-input-port)
+ ;; textual port positions are hopelessly broken in R6RS
+ #;(test-positions make-custom-textual-input-port)
(let* ([accum '()]
[p (make-custom-binary-output-port
@@ -640,7 +640,8 @@
(test accum '(#\z #\b #\a))
(test/unspec (close-port p)))
- (test-positions make-custom-textual-output-port)
+ ;; textual port positions are hopelessly broken in R6RS
+ #;(test-positions make-custom-textual-output-port)
(let* ([save #f]
[p (make-custom-binary-input/output-port
@@ -678,9 +679,10 @@
(test (get-char p) #\!)
(close-port p))
- (test-positions (lambda (id r/w get set close)
- (make-custom-textual-input/output-port
- id r/w r/w get set close)))
+ ;; textual port positions are hopelessly broken in R6RS
+ #;(test-positions (lambda (id r/w get set close)
+ (make-custom-textual-input/output-port
+ id r/w r/w get set close)))
;; ----------------------------------------
;; stdin, stderr, stdout
diff --git a/collects/tests/r6rs/lists.sls b/collects/tests/r6rs/lists.sls
index 87218cc0e3..91a3b602d5 100644
--- a/collects/tests/r6rs/lists.sls
+++ b/collects/tests/r6rs/lists.sls
@@ -15,7 +15,7 @@
(test (for-all even? '()) #t)
(test (for-all even? '(3 1 4 1 5 9)) #f)
- (test (for-all even? '(3 1 4 1 5 9 . 2)) #f)
+ ;; (test (for-all even? '(3 1 4 1 5 9 . 2)) #f) ; removed from R6RS
(test (for-all even? '(2 4 14)) #t)
(test/exn (for-all even? '(2 4 14 . 9)) &assertion)
(test (for-all (lambda (n) (and (even? n) n))
@@ -121,7 +121,7 @@
(test (for-all (lambda (x) x) '(12 14)) 14)
(test (for-all (lambda (x) x) '(12)) 12)
(test (for-all (lambda (x) x) '()) #t)
- (test (for-all even? '(13 . 14)) #f)
+ ;; (test (for-all even? '(13 . 14)) #f) ; removed from R6RS
(test (for-all cons '(1 2 3) '(a b c)) '(3 . c))
(test (for-all (lambda (a b) (= a 1)) '(1 2 3) '(a b c)) #f)
;; R6RS merely says that this *should* work, but not must:
diff --git a/collects/tests/r6rs/test.sls b/collects/tests/r6rs/test.sls
index cb9bf479db..19dae25955 100644
--- a/collects/tests/r6rs/test.sls
+++ b/collects/tests/r6rs/test.sls
@@ -9,6 +9,7 @@
test/output
test/unspec
test/unspec-or-exn
+ test/unspec-flonum-or-exn
test/output/unspec
run-test
report-test-results)
@@ -123,6 +124,19 @@
(begin expr 'unspec))
'unspec)]))
+ (define-syntax test/unspec-flonum-or-exn
+ (syntax-rules ()
+ [(_ expr condition)
+ (test (guard (c [((condition-predicate (record-type-descriptor condition)) c)
+ 'unspec-or-flonum])
+ (let ([v expr])
+ (if (flonum? v)
+ 'unspec-or-flonum
+ (if (eq? v 'unspec-or-flonum)
+ (list v)
+ v))))
+ 'unspec-or-flonum)]))
+
(define-syntax test/output/unspec
(syntax-rules ()
[(_ expr str)
diff --git a/collects/web-server/dispatchers/dispatch-servlets.ss b/collects/web-server/dispatchers/dispatch-servlets.ss
index a28932d4db..fdb1b831d0 100644
--- a/collects/web-server/dispatchers/dispatch-servlets.ss
+++ b/collects/web-server/dispatchers/dispatch-servlets.ss
@@ -66,6 +66,7 @@
(define response
(with-handlers ([exn:fail:filesystem:exists?
(lambda (the-exn) (next-dispatcher))]
+ [exn:dispatcher? raise]
[(lambda (x) #t)
(lambda (the-exn) (responders-servlet-loading uri the-exn))])
(define the-servlet (url->servlet uri))
@@ -73,7 +74,8 @@
[current-custodian (servlet-custodian the-servlet)]
[current-directory (servlet-directory the-servlet)]
[current-namespace (servlet-namespace the-servlet)])
- (with-handlers ([(lambda (x) #t)
+ (with-handlers ([exn:dispatcher? raise]
+ [(lambda (x) #t)
(lambda (exn) (responders-servlet uri exn))])
(call-with-continuation-barrier
(lambda ()
diff --git a/collects/web-server/insta/insta.ss b/collects/web-server/insta/insta.ss
index 49ac1ca2cd..5b1b335efa 100644
--- a/collects/web-server/insta/insta.ss
+++ b/collects/web-server/insta/insta.ss
@@ -61,7 +61,7 @@
(provide/contract (#,start (request? . -> . response?)))
(if extra-files-path
(serve/servlet #,start
- #:extra-files-path extra-files-path
+ #:extra-files-paths (list extra-files-path)
#:launch-browser? launch-browser?)
(serve/servlet #,start
#:launch-browser? launch-browser?)))))]))
\ No newline at end of file
diff --git a/collects/web-server/scribblings/dispatchers.scrbl b/collects/web-server/scribblings/dispatchers.scrbl
index 7c95ea93be..1622cee48c 100644
--- a/collects/web-server/scribblings/dispatchers.scrbl
+++ b/collects/web-server/scribblings/dispatchers.scrbl
@@ -368,7 +368,7 @@ a URL that refreshes the password file, servlet cache, etc.}
dispatcher/c]{
This dispatcher runs Scheme servlets, using @scheme[url->servlet] to resolve URLs to the underlying servlets.
If servlets have errors loading, then @scheme[responders-servlet-loading] is used. Other errors are handled with
- @scheme[responders-servlet].
+ @scheme[responders-servlet]. If a servlet raises calls @scheme[next-dispatcher], then the signal is propagated by this dispatcher.
}
}
diff --git a/src/mred/mrmain.cxx b/src/mred/mrmain.cxx
index 1dec62ac1a..878609876c 100644
--- a/src/mred/mrmain.cxx
+++ b/src/mred/mrmain.cxx
@@ -345,7 +345,7 @@ static BOOL CALLBACK CheckWindow(HWND wnd, LPARAM param)
argv = (char **)param;
len = gl = strlen(MRED_GUID);
- len += 4 + sizeof(WORD);
+ len += 4 + sizeof(DWORD);
for (i = 1; argv[i]; i++) {
len += sizeof(DWORD) + strlen(argv[i]);
}
diff --git a/src/mzscheme/gc2/blame_the_child.c b/src/mzscheme/gc2/blame_the_child.c
index ca40591282..21fb5c08bf 100644
--- a/src/mzscheme/gc2/blame_the_child.c
+++ b/src/mzscheme/gc2/blame_the_child.c
@@ -264,10 +264,11 @@ inline static void mark_cust_boxes(NewGC *gc, Scheme_Custodian *cur)
SCHEME_CDR(prev) = next;
else
cur->cust_boxes = next;
+ --cur->num_cust_boxes;
}
pr = next;
}
- cur->cust_boxes = NULL;
+ cur->checked_cust_boxes = cur->num_cust_boxes;
}
int BTC_thread_mark(void *p)
diff --git a/src/mzscheme/gc2/newgc.c b/src/mzscheme/gc2/newgc.c
index 985f2e6bd7..83f6feb5b8 100644
--- a/src/mzscheme/gc2/newgc.c
+++ b/src/mzscheme/gc2/newgc.c
@@ -15,7 +15,7 @@
The following page map invariants are required:
Outside of collection, only pages in the older generation should
- be in the global poitner -> page map.
+ be in the gc->page_maps.
During the mark phase of collection, only pages which contain
objects which may be marked should be in the page map. This means
@@ -1953,49 +1953,48 @@ void *GC_next_tagged_start(void *p)
/* garbage collection */
/*****************************************************************************/
-static void prepare_pages_for_collection(NewGC *gc)
+static void reset_gen1_pages_live_and_previous_sizes(NewGC *gc)
{
Page_Range *protect_range = gc->protect_range;
- struct mpage *work;
+ mpage *work;
int i;
- GCDEBUG((DEBUGOUTF, "PREPPING PAGES.\n"));
- if(gc->gc_full) {
- /* we need to make sure that previous_size for every page is reset, so
- we don't accidentally screw up the mark routine */
- if (gc->generations_available) {
- for(i = 0; i < PAGE_TYPES; i++)
- for(work = gc->gen1_pages[i]; work; work = work->next) {
- if (work->mprotected) {
- work->mprotected = 0;
- add_protect_page_range(protect_range, work->addr, work->big_page ? round_to_apage_size(work->size) : APAGE_SIZE, APAGE_SIZE, 1);
- }
- }
- flush_protect_page_ranges(protect_range, 1);
+ GCDEBUG((DEBUGOUTF, "MAJOR COLLECTION - PREPPING PAGES - reset live_size, reset previous_size, unprotect.\n"));
+ /* we need to make sure that previous_size for every page is reset, so
+ we don't accidentally screw up the mark routine */
+ for(i = 0; i < PAGE_TYPES; i++) {
+ for(work = gc->gen1_pages[i]; work; work = work->next) {
+ if (gc->generations_available && work->mprotected) {
+ work->mprotected = 0;
+ add_protect_page_range(protect_range, work->addr, work->big_page ? round_to_apage_size(work->size) : APAGE_SIZE, APAGE_SIZE, 1);
+ }
+ work->live_size = 0;
+ work->previous_size = PREFIX_SIZE;
}
- for(i = 0; i < PAGE_TYPES; i++)
- for(work = gc->gen1_pages[i]; work; work = work->next) {
- work->live_size = 0;
- work->previous_size = PREFIX_SIZE;
- }
- } else {
- /* if we're not doing a major collection, then we need to remove all the
- pages in gc->gen1_pages[] from the page map */
- PageMap pagemap = gc->page_maps;
- for(i = 0; i < PAGE_TYPES; i++)
- for(work = gc->gen1_pages[i]; work; work = work->next) {
- if (gc->generations_available) {
- if (work->back_pointers) {
- if (work->mprotected) {
- work->mprotected = 0;
- add_protect_page_range(protect_range, work->addr, work->big_page ? round_to_apage_size(work->size) : APAGE_SIZE, APAGE_SIZE, 1);
- }
- }
- }
- pagemap_remove(pagemap, work);
- }
- flush_protect_page_ranges(protect_range, 1);
}
+ flush_protect_page_ranges(protect_range, 1);
+}
+
+static void remove_all_gen1_pages_from_pagemap(NewGC *gc)
+{
+ Page_Range *protect_range = gc->protect_range;
+ PageMap pagemap = gc->page_maps;
+ mpage *work;
+ int i;
+
+ GCDEBUG((DEBUGOUTF, "MINOR COLLECTION - PREPPING PAGES - remove all gen1 pages from pagemap.\n"));
+ /* if we're not doing a major collection, then we need to remove all the
+ pages in gc->gen1_pages[] from the page map */
+ for(i = 0; i < PAGE_TYPES; i++) {
+ for(work = gc->gen1_pages[i]; work; work = work->next) {
+ if (gc->generations_available && work->back_pointers && work->mprotected) {
+ work->mprotected = 0;
+ add_protect_page_range(protect_range, work->addr, work->big_page ? round_to_apage_size(work->size) : APAGE_SIZE, APAGE_SIZE, 1);
+ }
+ pagemap_remove(pagemap, work);
+ }
+ }
+ flush_protect_page_ranges(protect_range, 1);
}
static void mark_backpointers(NewGC *gc)
@@ -2435,7 +2434,11 @@ static void garbage_collect(NewGC *gc, int force_full)
gc->no_further_modifications = 1;
- prepare_pages_for_collection(gc);
+ if (gc->gc_full)
+ reset_gen1_pages_live_and_previous_sizes(gc);
+ else /* minor collection */
+ remove_all_gen1_pages_from_pagemap(gc);
+
init_weak_boxes(gc);
init_weak_arrays(gc);
init_ephemerons(gc);
diff --git a/src/mzscheme/gc2/sighand.c b/src/mzscheme/gc2/sighand.c
index 9110a10bf5..db9145ea54 100644
--- a/src/mzscheme/gc2/sighand.c
+++ b/src/mzscheme/gc2/sighand.c
@@ -118,16 +118,14 @@ static void initialize_signal_handler(GCTYPE *gc)
# ifdef NEED_SIGWIN
{
HMODULE hm;
- PVOID (WINAPI*aveh)(ULONG, gcPVECTORED_EXCEPTION_HANDLER);
hm = LoadLibrary("kernel32.dll");
- if (hm)
+ if (hm) {
+ PVOID (WINAPI*aveh)(ULONG, gcPVECTORED_EXCEPTION_HANDLER);
aveh = (PVOID (WINAPI*)(ULONG, gcPVECTORED_EXCEPTION_HANDLER))GetProcAddress(hm, "AddVectoredExceptionHandler");
- else
- aveh = NULL;
- if (aveh)
aveh(TRUE, fault_handler);
- else
+ }
+ else /* WINDOWS 95 */
gc->generations_available = 0;
}
# endif
@@ -150,15 +148,13 @@ static void remove_signal_handler(GCTYPE *gc)
# ifdef NEED_SIGWIN
if (gc->generations_available) {
HMODULE hm;
- ULONG (WINAPI*rveh)(gcPVECTORED_EXCEPTION_HANDLER);
hm = LoadLibrary("kernel32.dll");
- if (hm)
+ if (hm) {
+ ULONG (WINAPI*rveh)(gcPVECTORED_EXCEPTION_HANDLER);
rveh = (ULONG (WINAPI*)(gcPVECTORED_EXCEPTION_HANDLER))GetProcAddress(hm, "RemoveVectoredExceptionHandler");
- else
- rveh = NULL;
- if (rveh)
rveh(fault_handler);
+ }
}
# endif
}
diff --git a/src/mzscheme/src/schpriv.h b/src/mzscheme/src/schpriv.h
index 7d28bfc77d..9bd90960ec 100644
--- a/src/mzscheme/src/schpriv.h
+++ b/src/mzscheme/src/schpriv.h
@@ -438,6 +438,7 @@ struct Scheme_Custodian {
#ifdef MZ_PRECISE_GC
int gc_owner_set;
Scheme_Object *cust_boxes;
+ int num_cust_boxes, checked_cust_boxes;
#endif
};
diff --git a/src/mzscheme/src/thread.c b/src/mzscheme/src/thread.c
index adbc13f86d..acef8eda8f 100644
--- a/src/mzscheme/src/thread.c
+++ b/src/mzscheme/src/thread.c
@@ -1467,12 +1467,27 @@ Scheme_Thread *scheme_do_close_managed(Scheme_Custodian *m, Scheme_Exit_Closer_F
}
}
+#ifdef MZ_PRECISE_GC
+ {
+ Scheme_Object *pr = m->cust_boxes, *wb;
+ Scheme_Custodian_Box *cb;
+ while (pr) {
+ wb = SCHEME_CAR(pr);
+ cb = (Scheme_Custodian_Box *)SCHEME_BOX_VAL(wb);
+ if (cb) cb->v = NULL;
+ pr = SCHEME_CDR(pr);
+ }
+ m->cust_boxes = NULL;
+ }
+#endif
+
m->count = 0;
m->alloc = 0;
m->boxes = NULL;
m->closers = NULL;
m->data = NULL;
m->mrefs = NULL;
+ m->shut_down = 1;
if (SAME_OBJ(m, start))
break;
@@ -1715,10 +1730,29 @@ static Scheme_Object *make_custodian_box(int argc, Scheme_Object *argv[])
#ifdef MZ_PRECISE_GC
/* 3m */
{
- Scheme_Object *wb, *pr;
+ Scheme_Object *wb, *pr, *prev;
wb = GC_malloc_weak_box(cb, NULL, 0);
pr = scheme_make_raw_pair(wb, cb->cust->cust_boxes);
cb->cust->cust_boxes = pr;
+ cb->cust->num_cust_boxes++;
+
+ /* The GC prunes the list of custodian boxes in accounting mode,
+ but prune here in case accounting is never triggered. */
+ if (cb->cust->num_cust_boxes > 2 * cb->cust->checked_cust_boxes) {
+ prev = pr;
+ pr = SCHEME_CDR(pr);
+ while (pr) {
+ wb = SCHEME_CAR(pr);
+ if (!SCHEME_BOX_VAL(pr)) {
+ SCHEME_CDR(prev) = SCHEME_CDR(pr);
+ --cb->cust->num_cust_boxes;
+ } else {
+ prev = pr;
+ }
+ pr = SCHEME_CDR(pr);
+ }
+ cb->cust->checked_cust_boxes = cb->cust->num_cust_boxes;
+ }
}
#else
/* CGC */