S-S-S-S-S-S-Syncing
svn: r12695
This commit is contained in:
Stevie Strickland
commit
5eab2260cc
|
|
@ -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
|
||||
|
|
|
|||
|
|
@ -89,6 +89,9 @@
|
|||
(srenames sbindrhss vrenames vrhss body tag)
|
||||
#:transparent)
|
||||
|
||||
;; (make-p:provide <Base> (listof Deriv) ?exn)
|
||||
(define-struct (p:provide prule) (inners ?2) #:transparent)
|
||||
|
||||
;; (make-p:stop <Base>)
|
||||
;; (make-p:unknown <Base>)
|
||||
;; (make-p:#%top <Base> Stx)
|
||||
|
|
@ -98,7 +101,6 @@
|
|||
;; (make-p:require <Base>)
|
||||
;; (make-p:require-for-syntax <Base>)
|
||||
;; (make-p:require-for-template <Base>)
|
||||
;; (make-p:provide <Base>)
|
||||
;; (make-p:#%variable-reference <Base>)
|
||||
(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
|
||||
|
|
|
|||
|
|
@ -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 _))
|
||||
|
|
|
|||
|
|
@ -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)
|
||||
|
|
|
|||
|
|
@ -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])]
|
||||
|
|
|
|||
|
|
@ -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
|
||||
|
|
|
|||
|
|
@ -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)
|
||||
|
|
|
|||
|
|
@ -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)
|
||||
|
|
|
|||
|
|
@ -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)
|
||||
))
|
||||
|
|
|
|||
|
|
@ -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")))
|
||||
|
|
@ -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)))
|
||||
|
||||
|
|
|
|||
|
|
@ -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)
|
||||
|
|
|
|||
|
|
@ -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]
|
||||
|
|
|
|||
|
|
@ -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)
|
||||
|
|
|
|||
|
|
@ -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%)])
|
||||
|
|
|
|||
|
|
@ -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])
|
||||
|
|
|
|||
|
|
@ -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)
|
||||
|
|
|
|||
|
|
@ -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)
|
||||
|
|
|
|||
|
|
@ -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"
|
||||
|
|
|
|||
|
|
@ -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?
|
||||
|
|
|
|||
|
|
@ -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?)
|
||||
|
|
|
|||
|
|
@ -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)
|
||||
))
|
||||
|
|
|
|||
|
|
@ -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)
|
||||
|
|
|
|||
|
|
@ -1 +1 @@
|
|||
#lang scheme/base (provide stamp) (define stamp "30nov2008")
|
||||
#lang scheme/base (provide stamp) (define stamp "3dec2008")
|
||||
|
|
|
|||
|
|
@ -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
|
||||
|
|
|
|||
|
|
@ -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]{
|
||||
|
|
|
|||
|
|
@ -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.}
|
||||
|
|
|
|||
|
|
@ -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
|
||||
|
|
|
|||
|
|
@ -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.
|
||||
|
||||
|
|
|
|||
|
|
@ -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.}
|
||||
|
||||
@; ----------------------------------------------------------------------
|
||||
|
||||
|
|
|
|||
|
|
@ -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:
|
||||
|
|
|
|||
|
|
@ -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)
|
||||
|
|
|
|||
|
|
@ -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)
|
||||
|
|
|
|||
|
|
@ -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)
|
||||
|
|
|
|||
|
|
@ -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
|
||||
|
|
|
|||
|
|
@ -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:
|
||||
|
|
|
|||
|
|
@ -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)
|
||||
|
|
|
|||
|
|
@ -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 ()
|
||||
|
|
|
|||
|
|
@ -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?)))))]))
|
||||
|
|
@ -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.
|
||||
}
|
||||
|
||||
}
|
||||
|
|
|
|||
|
|
@ -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]);
|
||||
}
|
||||
|
|
|
|||
|
|
@ -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)
|
||||
|
|
|
|||
|
|
@ -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);
|
||||
|
|
|
|||
|
|
@ -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
|
||||
}
|
||||
|
|
|
|||
|
|
@ -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
|
||||
};
|
||||
|
||||
|
|
|
|||
|
|
@ -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 */
|
||||
|
|
|
|||
Loading…
Reference in New Issue
Block a user