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

Syncing here also.

Browse Source 
svn: r13137
This commit is contained in:
Stevie Strickland 2009-01-15 02:38:49 +00:00
commit f739d7a8d3
32 changed files with 421 additions and 183 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

6
collects/macro-debugger/syntax-browser/controller.ss
View File

@ -38,7 +38,7 @@
;; mark-manager-mixin
(define mark-manager-mixin
(mixin () (mark-manager<%>)
(init-field [primary-partition (new-bound-partition)])
(init-field: [primary-partition partition<%> (new-bound-partition)])
(super-new)
;; get-primary-partition : -> partition
@ -63,8 +63,8 @@
(new partition% (relation (cdr name+proc)))))))
(listen-secondary-partition
(lambda (p)
(for-each (lambda (d) (send: d display<%> refresh))
displays)))
(for ([d displays])
(send: d display<%> refresh))))
(super-new)))
(define controller%

30
collects/macro-debugger/syntax-browser/display.ss
View File

@ -1,4 +1,3 @@
#lang scheme/base
(require scheme/class
scheme/gui
@ -19,8 +18,8 @@
(define range
(pretty-print-syntax stx output-port
(send: controller controller<%> get-primary-partition)
(send config get-colors)
(send config get-suffix-option)
(send: config config<%> get-colors)
(send: config config<%> get-suffix-option)
columns))
(define output-string (get-output-string output-port))
(define output-length (sub1 (string-length output-string))) ;; skip final newline
@ -55,18 +54,18 @@
;; set-standard-font : text% config number number -> void
(define (set-standard-font text config start end)
(send text change-style
(code-style text (send config get-syntax-font-size))
(code-style text (send: config config<%> get-syntax-font-size))
start end))
;; display%
(define display%
(class* object% (display<%>)
(init-field text)
(init-field controller)
(init-field config)
(init-field range)
(init-field start-position)
(init-field end-position)
(init-field: [controller controller<%>]
[config config<%>]
[range range<%>])
(init-field text
start-position
end-position)
(define extra-styles (make-hasheq))
@ -131,7 +130,7 @@
(send delta set-delta-foreground color)
delta))
(define color-styles
(list->vector (map color-style (send config get-colors))))
(list->vector (map color-style (send: config config<%> get-colors))))
(define overflow-style (color-style "darkgray"))
(define color-partition
(send: controller mark-manager<%> get-primary-partition))
@ -189,7 +188,7 @@
;; draw-secondary-connection : syntax -> void
(define/private (draw-secondary-connection stx2)
(for ([r (send range get-ranges stx2)])
(for ([r (send: range range<%> get-ranges stx2)])
(restyle-range r select-sub-highlight-d)))
;; restyle-range : (cons num num) style-delta% -> void
@ -204,11 +203,11 @@
;; Initialize
(super-new)
(send controller add-syntax-display this)))
(send: controller controller<%> add-syntax-display this)))
;; fixup-parentheses : string range -> void
(define (fixup-parentheses string range)
(define (fixup r)
(for ([r (send: range range<%> all-ranges)])
(let ([stx (range-obj r)]
[start (range-start r)]
[end (range-end r)])
@ -219,8 +218,7 @@
(string-set! string (sub1 end) #\]))
((#\{)
(string-set! string start #\{)
(string-set! string (sub1 end) #\}))))))
(for-each fixup (send range all-ranges)))
(string-set! string (sub1 end) #\})))))))
(define (open-output-string/count-lines)
(let ([os (open-output-string)])

35
collects/macro-debugger/syntax-browser/frame.ss
View File

@ -1,8 +1,10 @@
#lang scheme/base
(require scheme/class
macro-debugger/util/class-iop
scheme/gui
framework/framework
scheme/list
"interfaces.ss"
"partition.ss"
"prefs.ss"
"widget.ss")
@ -20,8 +22,9 @@
(define (browse-syntaxes stxs)
(let ((w (make-syntax-browser)))
(for ([stx stxs])
(send w add-syntax stx)
(send w add-separator))))
(send*: w syntax-browser<%>
(add-syntax stx)
(add-separator)))))
;; make-syntax-browser : -> syntax-browser<%>
(define (make-syntax-browser)
@ -32,21 +35,23 @@
;; syntax-browser-frame%
(define syntax-browser-frame%
(class* frame% ()
(init-field [config (new syntax-prefs%)])
(inherit get-width
get-height)
(init-field: [config config<%> (new syntax-prefs%)])
(super-new (label "Syntax Browser")
(width (send config pref:width))
(height (send config pref:height)))
(define widget
(width (send: config config<%> get-width))
(height (send: config config<%> get-height)))
(define: widget syntax-browser<%>
(new syntax-widget/controls%
(parent this)
(config config)))
(define/public (get-widget) widget)
(define/augment (on-close)
(send config pref:width (send this get-width))
(send config pref:height (send this get-height))
(send*: config config<%>
(set-width (get-width))
(set-height (get-height)))
(send widget shutdown)
(inner (void) on-close))
))
(inner (void) on-close))))
;; syntax-widget/controls%
(define syntax-widget/controls%
@ -72,22 +77,22 @@
(choices (map car -identifier=-choices))
(callback
(lambda (c e)
(send (get-controller) set-identifier=?
(send: (get-controller) controller<%> set-identifier=?
(assoc (send c get-string-selection)
-identifier=-choices))))))
(new button%
(label "Clear")
(parent -control-panel)
(callback (lambda _ (send (get-controller) select-syntax #f))))
(callback (lambda _ (send: (get-controller) controller<%> set-selected-syntax #f))))
(new button%
(label "Properties")
(parent -control-panel)
(callback
(lambda _
(send config set-props-shown?
(not (send config get-props-shown?))))))
(send: config config<%> set-props-shown?
(not (send: config config<%> get-props-shown?))))))
(send (get-controller) listen-identifier=?
(send: (get-controller) controller<%> listen-identifier=?
(lambda (name+func)
(send -choice set-selection
(or (send -choice find-string (car name+func)) 0))))

41
collects/macro-debugger/syntax-browser/interfaces.ss
View File

@ -1,8 +1,19 @@
#lang scheme/base
(require scheme/class
macro-debugger/util/class-iop)
macro-debugger/util/class-iop
"../util/notify.ss")
(provide (all-defined-out))
;; config<%>
(define-interface config<%> ()
((methods:notify suffix-option
syntax-font-size
colors
width
height
props-percentage
props-shown?)))
;; displays-manager<%>
(define-interface displays-manager<%> ()
(;; add-syntax-display : display<%> -> void
@ -13,10 +24,8 @@
;; selection-manager<%>
(define-interface selection-manager<%> ()
(;; selected-syntax : syntax/#f
set-selected-syntax
get-selected-syntax
listen-selected-syntax))
(;; selected-syntax : notify-box of syntax/#f
(methods:notify selected-syntax)))
;; mark-manager<%>
;; Manages marks, mappings from marks to colors
@ -29,23 +38,10 @@
;; secondary-partition<%>
(define-interface secondary-partition<%> ()
(;; get-secondary-partition : -> partition<%>
get-secondary-partition
;; set-secondary-partition : partition<%> -> void
set-secondary-partition
;; listen-secondary-partition : (partition<%> -> void) -> void
listen-secondary-partition
;; get-identifier=? : -> (cons string procedure)
get-identifier=?
;; set-identifier=? : (cons string procedure) -> void
set-identifier=?
;; listen-identifier=? : ((cons string procedure) -> void) -> void
listen-identifier=?))
(;; secondary-partition : notify-box of partition<%>
;; identifier=? : notify-box of (cons string procedure)
(methods:notify secondary-partition
identifier=?)))
;; controller<%>
(define-interface controller<%> (displays-manager<%>
@ -143,6 +139,7 @@
add-clickback
add-separator
erase-all
get-controller
get-text))
(define-interface partition<%> ()

2
collects/macro-debugger/syntax-browser/prefs.ss
View File

@ -42,7 +42,7 @@
(super-new)))
(define syntax-prefs-base%
(class prefs-base%
(class* prefs-base% (config<%>)
;; width, height : number
(notify-methods width)
(notify-methods height)

14
collects/macro-debugger/syntax-browser/pretty-helper.ss
View File

@ -1,7 +1,9 @@
#lang scheme/base
(require scheme/class
syntax/stx)
macro-debugger/util/class-iop
syntax/stx
"interfaces.ss")
(provide (all-defined-out))
;; Problem: If stx1 and stx2 are two distinguishable syntax objects, it
@ -45,10 +47,10 @@
(case suffixopt
((never) (unintern (syntax-e id)))
((always)
(let ([n (send partition get-partition id)])
(let ([n (send: partition partition<%> get-partition id)])
(if (zero? n) (unintern (syntax-e id)) (suffix (syntax-e id) n))))
((over-limit)
(let ([n (send partition get-partition id)])
(let ([n (send: partition partition<%> get-partition id)])
(if (<= n limit)
(unintern (syntax-e id))
(suffix (syntax-e id) n))))))
@ -61,7 +63,7 @@
=> (lambda (datum) datum)]
[(and partition (identifier? obj))
(when (and (eq? suffixopt 'all-if-over-limit)
(> (send partition count) limit))
(> (send: partition partition<%> count) limit))
(call-with-values (lambda () (table stx partition #f 'always))
escape))
(let ([lp-datum (make-identifier-proxy obj)])
@ -70,7 +72,7 @@
lp-datum)]
[(and (syntax? obj) (check+convert-special-expression obj))
=> (lambda (newobj)
(when partition (send partition get-partition obj))
(when partition (send: partition partition<%> get-partition obj))
(let* ([inner (cadr newobj)]
[lp-inner-datum (loop inner)]
[lp-datum (list (car newobj) lp-inner-datum)])
@ -80,7 +82,7 @@
(hash-set! stx=>flat obj lp-datum)
lp-datum))]
[(syntax? obj)
(when partition (send partition get-partition obj))
(when partition (send: partition partition<%> get-partition obj))
(let ([lp-datum (loop (syntax-e obj))])
(hash-set! flat=>stx lp-datum obj)
(hash-set! stx=>flat obj lp-datum)

3
collects/macro-debugger/syntax-browser/syntax-snip.ss
View File

@ -1,6 +1,7 @@
#lang scheme/base
(require scheme/class
macro-debugger/util/class-iop
scheme/match
scheme/list
mzlib/string
@ -205,7 +206,7 @@
(define/public (read-special src line col pos)
(send the-syntax-snip read-special src line col pos))
(send config listen-props-shown?
(send: config config<%> listen-props-shown?
(lambda (?) (refresh-contents)))
(super-new)

13
collects/macro-debugger/syntax-browser/widget.ss
View File

@ -43,6 +43,7 @@
(define/public (setup-keymap)
(new syntax-keymap%
(editor -text)
(controller controller)
(config config)))
(send -text set-styles-sticky #f)
@ -54,7 +55,7 @@
(define/private (internal-show-props show?)
(if show?
(unless (send -props-panel is-shown?)
(let ([p (send config get-props-percentage)])
(let ([p (send: config config<%> get-props-percentage)])
(send -split-panel add-child -props-panel)
(update-props-percentage p))
(send -props-panel show #t))
@ -81,7 +82,7 @@
(define/public (shutdown)
(when (props-panel-shown?)
(send config set-props-percentage
(send: config config<%> set-props-percentage
(cadr (send -split-panel get-percentages)))))
;; syntax-browser<%> Methods
@ -202,7 +203,7 @@
display)))
(define/private (calculate-columns)
(define style (code-style -text (send config get-syntax-font-size)))
(define style (code-style -text (send: config 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)))))
@ -211,13 +212,13 @@
(super-new)
(setup-keymap)
(send config listen-props-shown?
(send: config config<%> listen-props-shown?
(lambda (show?)
(show-props show?)))
(send config listen-props-percentage
(send: config config<%> listen-props-percentage
(lambda (p)
(update-props-percentage p)))
(internal-show-props (send config get-props-shown?))))
(internal-show-props (send: config config<%> get-props-shown?))))
(define clickback-style

32
collects/macro-debugger/util/class-ct.ss
View File

@ -14,7 +14,15 @@
checked-binding-iface
checked-binding
static-interface)
static-interface
interface-expander?
make-interface-expander
interface-expander-proc
interface-expander
method-entry)
(define-struct static-interface (dynamic members)
#:omit-define-syntaxes
@ -60,6 +68,11 @@
(define (checked-binding-iface x)
(raw-checked-binding-iface (set!-transformer-procedure x)))
(define-struct interface-expander (proc)
#:omit-define-syntaxes)
;; Syntax
(define-syntax-class static-interface
@ -71,3 +84,20 @@
(pattern x
#:declare x (static-of 'checked-binding checked-binding?)
#:with value #'x.value))
(define-syntax-class interface-expander
(pattern x
#:declare x (static-of 'interface-expander interface-expander?)
#:with value #'x.value))
(define-syntax-class method-entry
(pattern method:id
#:with methods (list #'method))
(pattern (macro:interface-expander . args)
#:with methods
(apply append
(for/list ([m ((interface-expander-proc #'macro.value)
#'(macro . args))])
(syntax-parse m
[m:method-entry #'m.methods])))))

27
collects/macro-debugger/util/class-iop.ss
View File

@ -5,6 +5,7 @@
"class-ct.ss"))
(provide define-interface
define-interface/dynamic
define-interface-expander
send:
send*:
@ -26,13 +27,14 @@
;; Defines NAME as an interface.
(define-syntax (define-interface stx)
(syntax-parse stx
[(_ name:id (super:static-interface ...) (mname:id ...))
[(_ name:id (super:static-interface ...) (m:method-entry ...))
(with-syntax ([((super-method ...) ...)
(map static-interface-members
(syntax->datum #'(super.value ...)))])
(syntax->datum #'(super.value ...)))]
[((mname ...) ...) #'(m.methods ...)])
#'(define-interface/dynamic name
(let ([name (interface (super ...) mname ...)]) name)
(super-method ... ... mname ...)))]))
(let ([name (interface (super ...) mname ... ...)]) name)
(super-method ... ... mname ... ...)))]))
;; define-interface/dynamic SYNTAX
;; (define-interface/dynamic NAME EXPR (IDENTIFIER ...))
@ -54,6 +56,11 @@
(define-syntax name
(make-static-interface #'dynamic-name '(mname ...)))))]))
(define-syntax (define-interface-expander stx)
(syntax-parse stx
[(_ name:id rhs:expr)
#'(define-syntax name (make-interface-expander rhs))]))
;; Helper
(begin-for-syntax
@ -173,19 +180,19 @@
;; FIXME: unsafe due to mutation
(define-syntax (init-field: stx)
(syntax-parse stx
[(_ (name:id iface:static-interface) ...)
#'(begin (init1: init-field name iface) ...)]))
[(_ (name:id iface:static-interface . default) ...)
#'(begin (init1: init-field name iface . default) ...)]))
(define-syntax (init: stx)
(syntax-parse stx
[(_ (name:id iface:static-interface) ...)
#'(begin (init1: init name iface) ...)]))
[(_ (name:id iface:static-interface . default) ...)
#'(begin (init1: init name iface . default) ...)]))
(define-syntax (init1: stx)
(syntax-parse stx
[(_ init name:id iface:static-interface)
[(_ init name:id iface:static-interface . default)
(with-syntax ([(name-internal) (generate-temporaries #'(name))])
#'(begin (init ((name-internal name)))
#'(begin (init ((name-internal name) . default))
(void (check-object<:interface init: name-internal iface))
(define-syntax name
(make-checked-binding

18
collects/macro-debugger/util/notify.ss
View File

@ -3,6 +3,7 @@
(require (for-syntax scheme/base)
scheme/list
scheme/class
macro-debugger/util/class-iop
scheme/gui)
(provide define/listen
field/notify
@ -15,7 +16,9 @@
menu-option/notify-box
menu-group/notify-box
check-box/notify-box
choice/notify-box)
choice/notify-box
methods:notify)
(define-for-syntax (join . args)
(define (->string x)
@ -71,6 +74,19 @@
(define/public-final (listen-name listener)
(send name listen listener))))]))
(define-interface-expander methods:notify
(lambda (stx)
(syntax-case stx ()
[(_ name ...)
(apply append
(for/list ([name (syntax->list #'(name ...))])
(list ;; (join "init-" #'name)
(join "get-" name)
(join "set-" name)
(join "listen-" name))))])))
(define-syntax (connect-to-pref stx)
(syntax-case stx ()
[(connect-to-pref name pref)

4
collects/macro-debugger/view/debug.ss
View File

@ -2,6 +2,8 @@
#lang scheme/base
(require scheme/pretty
scheme/class
macro-debugger/util/class-iop
"interfaces.ss"
"debug-format.ss"
"prefs.ss"
"view.ss")
@ -30,5 +32,5 @@
(pretty-print msg)
(pretty-print ctx)
(let* ([w (make-stepper)])
(send w add-trace events)
(send: w widget<%> add-trace events)
w)))

12
collects/macro-debugger/view/frame.ss
View File

@ -42,8 +42,8 @@
get-help-menu)
(super-new (label (make-label))
(width (send config get-width))
(height (send config get-height)))
(width (send: config config<%> get-width))
(height (send: config config<%> get-height)))
(define/private (make-label)
(if filename
@ -54,8 +54,8 @@
"Macro stepper"))
(define/override (on-size w h)
(send config set-width w)
(send config set-height h)
(send: config config<%> set-width w)
(send: config config<%> set-height h)
(send: widget widget<%> update/preserve-view))
(define warning-panel
@ -143,7 +143,7 @@
(eq? (car name+func) (car p)))))))
(sb:identifier=-choices)))
(let ([identifier=? (send config get-identifier=?)])
(let ([identifier=? (send: config config<%> get-identifier=?)])
(when identifier=?
(let ([p (assoc identifier=? (sb:identifier=-choices))])
(send: controller sb:controller<%> set-identifier=? p))))
@ -178,7 +178,7 @@
(parent extras-menu)
(callback
(lambda (i e)
(send config set-suffix-option
(send: config config<%> set-suffix-option
(if (send i is-checked?)
'always
'over-limit))

6
collects/macro-debugger/view/hiding-panel.ss
View File

@ -79,7 +79,7 @@
(style '(deleted))))
(define/private (get-mode)
(send config get-macro-hiding-mode))
(send: config config<%> get-macro-hiding-mode))
(define/private (macro-hiding-enabled?)
(let ([mode (get-mode)])
@ -89,7 +89,7 @@
(define/private (ensure-custom-mode)
(unless (equal? (get-mode) mode:custom)
(send config set-macro-hiding-mode mode:custom)))
(send: config config<%> set-macro-hiding-mode mode:custom)))
(define/private (update-visibility)
(let ([customizing (equal? (get-mode) mode:custom)])
@ -104,7 +104,7 @@
(list customize-panel)
null))))))
(send config listen-macro-hiding-mode
(send: config config<%> listen-macro-hiding-mode
(lambda (value)
(update-visibility)
(force-refresh)))

17
collects/macro-debugger/view/interfaces.ss
View File

@ -1,8 +1,23 @@
#lang scheme/base
(require macro-debugger/util/class-iop)
(require macro-debugger/util/class-iop
"../util/notify.ss"
(prefix-in sb: "../syntax-browser/interfaces.ss"))
(provide (all-defined-out))
(define-interface config<%> (sb:config<%>)
((methods:notify macro-hiding-mode
show-hiding-panel?
identifier=?
highlight-foci?
highlight-frontier?
show-rename-steps?
suppress-warnings?
one-by-one?
extra-navigation?
debug-catch-errors?
force-letrec-transformation?)))
(define-interface widget<%> ()
(get-config
get-controller

3
collects/macro-debugger/view/prefs.ss
View File

@ -2,6 +2,7 @@
#lang scheme/base
(require scheme/class
framework/framework
"interfaces.ss"
"../syntax-browser/prefs.ss"
"../util/notify.ss"
"../util/misc.ss")
@ -43,7 +44,7 @@
(pref:get/set pref:force-letrec-transformation? MacroStepper:ForceLetrecTransformation?)
(define macro-stepper-config-base%
(class syntax-prefs-base%
(class* syntax-prefs-base% (config<%>)
(notify-methods macro-hiding-mode)
(notify-methods show-hiding-panel?)
(notify-methods identifier=?)

6
collects/macro-debugger/view/step-display.ss
View File

@ -41,7 +41,7 @@
(define step-display%
(class* object% (step-display<%>)
(init-field config)
(init-field: (config config<%>))
(init-field ((sbview syntax-widget)))
(super-new)
@ -194,8 +194,8 @@
;; insert-syntax/color
(define/private (insert-syntax/color stx foci binders shift-table
definites frontier hi-color)
(define highlight-foci? (send config get-highlight-foci?))
(define highlight-frontier? (send config get-highlight-frontier?))
(define highlight-foci? (send: config config<%> get-highlight-foci?))
(define highlight-frontier? (send: config config<%> get-highlight-frontier?))
(send: sbview sb:syntax-browser<%> add-syntax stx
#:definites (or definites null)
#:binder-table binders

30
collects/macro-debugger/view/stepper.ss
View File

@ -86,7 +86,7 @@
(let ([term (focused-term)])
(when term
(let ([new-stepper (send: director director<%> new-stepper '(no-new-traces))])
(send: new-stepper widget<%> add-deriv (send term get-raw-deriv))
(send: new-stepper widget<%> add-deriv (send: term term-record<%> get-raw-deriv))
(void)))))
;; duplicate-stepper : -> void
@ -138,7 +138,7 @@
(config config)
(syntax-widget sbview)))
(define: sbc sb:controller<%>
(send sbview get-controller))
(send: sbview sb:syntax-browser<%> get-controller))
(define control-pane
(new vertical-panel% (parent area) (stretchable-height #f)))
(define: macro-hiding-prefs hiding-prefs<%>
@ -147,22 +147,24 @@
(stepper this)
(config config)))
(send config listen-show-hiding-panel?
(lambda (show?) (show-macro-hiding-panel show?)))
(send sbc listen-selected-syntax
(send: sbc sb:controller<%>
listen-selected-syntax
(lambda (stx) (send: macro-hiding-prefs hiding-prefs<%> set-syntax stx)))
(send config listen-highlight-foci?
(send*: config config<%>
(listen-show-hiding-panel?
(lambda (show?) (show-macro-hiding-panel show?)))
(listen-highlight-foci?
(lambda (_) (update/preserve-view)))
(send config listen-highlight-frontier?
(listen-highlight-frontier?
(lambda (_) (update/preserve-view)))
(send config listen-show-rename-steps?
(listen-show-rename-steps?
(lambda (_) (refresh/re-reduce)))
(send config listen-one-by-one?
(listen-one-by-one?
(lambda (_) (refresh/re-reduce)))
(send config listen-force-letrec-transformation?
(listen-force-letrec-transformation?
(lambda (_) (refresh/resynth)))
(send config listen-extra-navigation?
(lambda (show?) (show-extra-navigation show?)))
(listen-extra-navigation?
(lambda (show?) (show-extra-navigation show?))))
(define nav:up
(new button% (label "Previous term") (parent navigator)
@ -400,8 +402,8 @@
;; Initialization
(super-new)
(show-macro-hiding-panel (send config get-show-hiding-panel?))
(show-extra-navigation (send config get-extra-navigation?))
(show-macro-hiding-panel (send: config config<%> get-show-hiding-panel?))
(show-extra-navigation (send: config config<%> get-extra-navigation?))
(refresh/move)
))

7
collects/macro-debugger/view/term-record.ss
View File

@ -33,7 +33,8 @@
(class* object% (term-record<%>)
(init-field: (stepper widget<%>))
(define config (send stepper get-config))
(define: config config<%>
(send: stepper widget<%> get-config))
(define: displayer step-display<%>
(send: stepper widget<%> get-step-displayer))
@ -173,12 +174,12 @@
(set! steps
(and raw-steps
(let* ([filtered-steps
(if (send config get-show-rename-steps?)
(if (send: config config<%> get-show-rename-steps?)
raw-steps
(filter (lambda (x) (not (rename-step? x)))
raw-steps))]
[processed-steps
(if (send config get-one-by-one?)
(if (send: config config<%> get-one-by-one?)
(reduce:one-by-one filtered-steps)
filtered-steps)])
(cursor:new processed-steps))))

3
collects/mred/private/kernel.ss
View File

@ -240,6 +240,7 @@
can-save-file?
on-new-box
on-new-image-snip
size-cache-invalid
invalidate-bitmap-cache
on-paint
write-footers-to-file
@ -921,6 +922,7 @@
can-save-file?
on-new-box
on-new-image-snip
size-cache-invalid
invalidate-bitmap-cache
on-paint
write-footers-to-file
@ -1133,6 +1135,7 @@
can-save-file?
on-new-box
on-new-image-snip
size-cache-invalid
invalidate-bitmap-cache
on-paint
write-footers-to-file

3
collects/redex/examples/arithmetic.ss
View File

@ -38,4 +38,5 @@
[(--> (in-hole e-ctxt_1 a) (in-hole e-ctxt_1 b))
(c--> a b)]))
(traces reductions (term (- (* (sqrt 36) (/ 1 2)) (+ 1 2))))
(traces/ps reductions (term (- (* (sqrt 36) (/ 1 2)) (+ 1 2)))
"/home/mflatt/Desktop/p.ps")

44
collects/redex/private/traces.ss
View File

@ -86,7 +86,7 @@
(λ (ed)
(let ([yb (box 0)]
[snip (term-node-snip term-node)])
(if (send ed get-snip-location snip yb #f #f)
(if (send ed get-snip-location snip #f yb #f)
(unbox yb)
0)))))
@ -132,7 +132,7 @@
#:scheme-colors? [scheme-colors? #t]
#:colors [colors '()]
#:layout [layout void])
(let-values ([(graph-pb frame)
(let-values ([(graph-pb canvas)
(traces reductions pre-exprs
#:no-show-frame? #t
#:multiple? multiple?
@ -141,21 +141,18 @@
#:scheme-colors? scheme-colors?
#:colors colors
#:layout layout)])
(print-to-ps graph-pb filename)))
(print-to-ps graph-pb canvas filename)))
(define (print-to-ps graph-pb filename)
(define (print-to-ps graph-pb canvas filename)
(let ([admin (send graph-pb get-admin)]
[printing-admin (new printing-editor-admin%)])
[printing-admin (new printing-editor-admin% [ed graph-pb])])
(send canvas set-editor #f)
(send graph-pb set-admin printing-admin)
(dynamic-wind
void
(λ ()
(let loop ([snip (send graph-pb find-first-snip)])
(when snip
(send snip size-cache-invalid)
(loop (send snip next))))
(send graph-pb invalidate-bitmap-cache)
(send graph-pb size-cache-invalid)
(send graph-pb re-run-layout)
@ -168,17 +165,20 @@
(λ ()
(send graph-pb set-admin admin)
(send canvas set-editor graph-pb)
(send printing-admin shutdown) ;; do this early
(let loop ([snip (send graph-pb find-first-snip)])
(when snip
(send snip size-cache-invalid)
(loop (send snip next))))
(send graph-pb invalidate-bitmap-cache)
(send graph-pb size-cache-invalid)
(send graph-pb re-run-layout)))))
(define printing-editor-admin%
(class editor-admin%
(init-field ed)
(define temp-file (make-temporary-file "redex-size-snip-~a"))
(define ps-dc
@ -204,7 +204,8 @@
(define/override (get-max-view x y w h [full? #f])
(get-view x y w h full?))
(define/override (get-view x y w h [full? #f])
(super get-view x y w h full?)
(when x (set-box! x 0.0))
(when y (set-box! x 0.0))
(when (box? w) (set-box! w 500))
(when (box? h) (set-box! h 500)))
@ -270,7 +271,7 @@
"Reducing..."
lower-panel
(lambda (x y)
(reduce-button-callback))))
(reduce-button-callback #f))))
(define status-message (instantiate message% ()
(label "")
(parent lower-panel)
@ -411,7 +412,6 @@
(set! col (+ x-spacing (find-rightmost-x graph-pb))))
(begin0
(insert-into col y graph-pb new-snips)
(send graph-pb re-run-layout)
(send graph-pb end-edit-sequence)
(send status-message set-label
(string-append (term-count (count-snips)) "...")))))])
@ -455,9 +455,10 @@
(send reduce-button enable #t)
(send font-size enable #t))
;; reduce-button-callback : -> void
;; reduce-button-callback : boolean -> void
;; =eventspace main thread=
(define (reduce-button-callback)
(define (reduce-button-callback show-all-at-once?)
(when show-all-at-once? (send graph-pb begin-edit-sequence))
(send reduce-button enable #f)
(send reduce-button set-label "Reducing...")
(thread
@ -465,6 +466,10 @@
(do-some-reductions)
(queue-callback
(lambda () ;; =eventspace main thread=
(send graph-pb begin-edit-sequence)
(send graph-pb re-run-layout)
(send graph-pb end-edit-sequence)
(when show-all-at-once? (send graph-pb end-edit-sequence))
(scroll-to-rightmost-snip)
(send reduce-button set-label "Reduce")
(cond
@ -541,9 +546,8 @@
(list bottom-panel)
null)))
(out-of-dot-state) ;; make sure the state is initialized right
(set-font-size (initial-font-size)) ;; have to call this before 'insert-into' or else it triggers resizing
(insert-into init-rightmost-x 0 graph-pb frontier)
(send graph-pb re-run-layout)
(set-font-size (initial-font-size))
(cond
[no-show-frame?
(let ([s (make-semaphore)])
@ -551,9 +555,9 @@
(do-some-reductions)
(semaphore-post s)))
(yield s))
(values graph-pb f)]
(values graph-pb ec)]
[else
(reduce-button-callback)
(reduce-button-callback #t)
(send f show #t)]))
(define red-sem-frame%

8
collects/redex/redex.scrbl
View File

@ -1218,9 +1218,11 @@ The @scheme[scheme-colors?] argument, if @scheme[#t] causes
to DrScheme's Scheme mode color Scheme. If it is @scheme[#f],
@scheme[traces] just uses black for the color scheme.
The @scheme[layout] argument is called (with all of the terms) each
time a new term is inserted into the window. See also
@scheme[term-node-set-position!].
The @scheme[layout] argument is called (with all of the terms) when
new terms is inserted into the window. In general, it is called when
after new terms are inserted in response to the user clicking on the
reduce button, and after the initial set of terms is inserted.
See also @scheme[term-node-set-position!].
You can save the contents of the window as a postscript file
from the menus.

19
collects/scheme/help.ss
View File

@ -14,13 +14,17 @@
(identifier? #'id)
#'(find-help (quote-syntax id))]
[(help id #:from lib)
(if (identifier? #'id)
(if (module-path? (syntax->datum #'lib))
#'(find-help/lib (quote id) (quote lib))
(cond [(not (identifier? #'id))
(raise-syntax-error
#f "expected a module path after #:from" stx #'lib))
#f "expected an identifier before #:from" stx #'id)]
[(not (module-path? (syntax->datum #'lib)))
(raise-syntax-error
#f "expected an identifier before #:from" stx #'id))]
#f "expected a module path after #:from" stx #'lib)]
[else #'(find-help/lib (quote id) (quote lib))])]
[(help str0 str ...)
(andmap (lambda (s) (string? (syntax-e s)))
(syntax->list #'(str0 str ...)))
#'(search-for (list str0 str ...))]
[(help #:search str ...)
(with-syntax ([(str ...)
(map (lambda (e)
@ -32,8 +36,9 @@
[_
(raise-syntax-error
#f
(string-append "expects a single identifer, a #:from clause, or a"
" #:search clause; try `(help help)' for more information")
(string-append "expects a single identifer, any number of literal"
" strings, or #:search clauses;"
" try `(help help)' for more information")
stx)])))
(define (open-help-start)

16
collects/scribblings/gui/editor-intf.scrbl
View File

@ -1015,7 +1015,7 @@ The default implementation triggers a redraw of the editor, either
immediately or at the end of the current edit sequence (if any)
started by @method[editor<%> begin-edit-sequence].
}
See also @method[editor<%> size-cache-invalid].}
@defmethod[(is-locked?)
@ -2322,6 +2322,20 @@ Setting the style list is disallowed when the editor is internally
}
@defmethod[(size-cache-invalid)
void?]{
This method is called when the drawing context given to the editor by
its administrator changes in a way that makes cached size information
(such as the width of a string) invalid.
The default implementation eventually propagates the message to snips,
and, more generally, causes @tech{location} information to be
recalculated on demand.
See also @method[editor<%> invalidate-bitmap-cache].}
@defmethod[(style-has-changed [style (or/c (is-a?/c style<%>) false/c)])
void?]{

23
collects/scribblings/reference/help.scrbl
View File

@ -19,6 +19,7 @@
@deftogether[(
@defidform[help]
@defform/none[#:literals (help) (help string ...)]
@defform/none[#:literals (help) (help id)]
@defform/none[#:literals (help) (help id #:from module-path)]
@defform/none[#:literals (help) (help #:search datum ...)]
@ -35,6 +36,17 @@ the user's browser is launched to display help information.}
A simple @scheme[help] or @scheme[(help)] form opens the main
documentation page.
The @scheme[(help string ...)] form---using literal strings, as
opposed to expressions that produce strings---performs a
string-matching search. For example,
@schemeblock[
(help "web browser" "firefox")
]
searches the documentation index for references that include the
phrase ``web browser'' or ``firefox.''
A @scheme[(help id)] form looks for documentation specific to the
current binding of @scheme[id]. For example,
@ -70,11 +82,10 @@ The @scheme[(help id #:from module-path)] variant is similar to
(help frame% #:from scheme/gui) (code:comment #, @t{equivalent to the above})
]
The @scheme[(help #:search datum ...)] form performs a general
search. Searching uses strings; each string @scheme[datum] is used
as-is, and any other form of @scheme[datum] is converted to a string
using @scheme[display]. No @scheme[datum] is evaluated as an
expression.
The @scheme[(help #:search datum ...)] form is similar to
@scheme[(help string ...)], where any non-string form of
@scheme[datum] is converted to a string using @scheme[display]. No
@scheme[datum] is evaluated as an expression.
For example,
@ -82,7 +93,7 @@ For example,
(help #:search "web browser" firefox)
]
searches the documentation index for references that include the
also searches the documentation index for references that include the
phrase ``web browser'' or ``firefox.''
}

2
collects/scribblings/reference/mz.ss
View File

@ -57,7 +57,7 @@
(schememodname lib)
" and "
(schememodname scheme/init)
" libraries, which means that they ara available when "
" libraries, which means that they are available when "
(exec "mzscheme") " is started with no command-line arguments."
" They are not provided by " (schememodname scheme/base)
" or " (schememodname scheme) "."

2
collects/teachpack/2htdp/scribblings/universe.scrbl
View File

@ -125,7 +125,7 @@ Your program may deal with such events via the @emph{designation} of
@emph{handler} functions. Specifically, the teachpack provides for the
installation of three event handlers: @scheme[on-tick], @scheme[on-key],
and @scheme[on-mouse]. In addition, a @tech{world} program may specify a
@scheme[_dra]} function, which is called every time your program should
@scheme[draw] function, which is called every time your program should
visualize the current world, and a @scheme[_stop?] predicate, which is used
to determine when the @tech{world} program should shut down.

5
collects/tests/macro-debugger/gui-tests.ss
View File

@ -207,7 +207,8 @@
(sleep 1)
(parameterize ((current-eventspace (make-eventspace)))
(let ([frame (new macro-stepper-frame%
(config (new macro-stepper-config/prefs/readonly%)))])
(config (new macro-stepper-config/prefs/readonly%))
(director (new macro-stepper-director%)))])
(send frame show #t)
frame)))
@ -270,4 +271,4 @@
(send frame get-eventspace))))))))))
(define (test-stepper expr)
(test-stepper* (list expr) '(none basic normal))))
(test-stepper* (list expr) '(none basic normal)))

1
src/mred/wxs/wxs_mbuf.xci
View File

@ -73,6 +73,7 @@
@ Z "on-paint" : void OnPaint(bool,wxDC!,double,double,double,double,double,double,SYM[caret]); : : /CHECKDCOK[1.METHODNAME("editor<%>","on-paint")]
@ Y "invalidate-bitmap-cache" : void InvalidateBitmapCache(double=0.0,double=0.0,nnfs[end]=-1.0,nnfs[end]=-1.0);
@ Y "size-cache-invalid" : void SizeCacheInvalid();
@ Z "on-new-image-snip" : wxImageSnip! OnNewImageSnip(nxpathname,SYM[bitmapType],bool,bool);
@ Z "on-new-box" : wxSnip! OnNewBox(SYM[bufferType]);

61
src/mred/wxs/wxs_mede.cxx
View File

@ -1015,6 +1015,7 @@ class os_wxMediaEdit : public wxMediaEdit {
Bool CanSaveFile(epathname x0, int x1);
class wxSnip* OnNewBox(int x0);
class wxImageSnip* OnNewImageSnip(nxpathname x0, int x1, Bool x2, Bool x3);
void SizeCacheInvalid();
void InvalidateBitmapCache(double x0 = 0.0, double x1 = 0.0, double x2 = -1.0, double x3 = -1.0);
void OnPaint(Bool x0, class wxDC* x1, double x2, double x3, double x4, double x5, double x6, double x7, int x8);
Bool WriteFootersToFile(class wxMediaStreamOut* x0);
@ -2469,6 +2470,40 @@ class wxImageSnip* os_wxMediaEdit::OnNewImageSnip(nxpathname x0, int x1, Bool x2
}
}
static Scheme_Object *os_wxMediaEditSizeCacheInvalid(int n, Scheme_Object *p[]);
void os_wxMediaEdit::SizeCacheInvalid()
{
Scheme_Object *p[POFFSET+0] INIT_NULLED_ARRAY({ NULLED_OUT });
Scheme_Object *v;
Scheme_Object *method INIT_NULLED_OUT;
#ifdef MZ_PRECISE_GC
os_wxMediaEdit *sElF = this;
#endif
static void *mcache = 0;
SETUP_VAR_STACK(5);
VAR_STACK_PUSH(0, method);
VAR_STACK_PUSH(1, sElF);
VAR_STACK_PUSH_ARRAY(2, p, POFFSET+0);
SET_VAR_STACK();
method = objscheme_find_method((Scheme_Object *) ASSELF __gc_external, os_wxMediaEdit_class, "size-cache-invalid", &mcache);
if (!method || OBJSCHEME_PRIM_METHOD(method, os_wxMediaEditSizeCacheInvalid)) {
SET_VAR_STACK();
READY_TO_RETURN; ASSELF wxMediaEdit::SizeCacheInvalid();
} else {
p[0] = (Scheme_Object *) ASSELF __gc_external;
v = WITH_VAR_STACK(scheme_apply(method, POFFSET+0, p));
READY_TO_RETURN;
}
}
static Scheme_Object *os_wxMediaEditInvalidateBitmapCache(int n, Scheme_Object *p[]);
void os_wxMediaEdit::InvalidateBitmapCache(double x0, double x1, double x2, double x3)
@ -7673,6 +7708,29 @@ static Scheme_Object *os_wxMediaEditOnNewImageSnip(int n, Scheme_Object *p[])
return WITH_REMEMBERED_STACK(objscheme_bundle_wxImageSnip(r));
}
static Scheme_Object *os_wxMediaEditSizeCacheInvalid(int n, Scheme_Object *p[])
{
WXS_USE_ARGUMENT(n) WXS_USE_ARGUMENT(p)
REMEMBER_VAR_STACK();
objscheme_check_valid(os_wxMediaEdit_class, "size-cache-invalid in text%", n, p);
SETUP_VAR_STACK_REMEMBERED(1);
VAR_STACK_PUSH(0, p);
if (((Scheme_Class_Object *)p[0])->primflag)
WITH_VAR_STACK(((os_wxMediaEdit *)((Scheme_Class_Object *)p[0])->primdata)->wxMediaEdit::SizeCacheInvalid());
else
WITH_VAR_STACK(((wxMediaEdit *)((Scheme_Class_Object *)p[0])->primdata)->SizeCacheInvalid());
READY_TO_RETURN;
return scheme_void;
}
static Scheme_Object *os_wxMediaEditInvalidateBitmapCache(int n, Scheme_Object *p[])
{
WXS_USE_ARGUMENT(n) WXS_USE_ARGUMENT(p)
@ -8778,7 +8836,7 @@ void objscheme_setup_wxMediaEdit(Scheme_Env *env)
wxREGGLOB(os_wxMediaEdit_class);
os_wxMediaEdit_class = WITH_VAR_STACK(objscheme_def_prim_class(env, "text%", "editor%", (Scheme_Method_Prim *)os_wxMediaEdit_ConstructScheme, 153));
os_wxMediaEdit_class = WITH_VAR_STACK(objscheme_def_prim_class(env, "text%", "editor%", (Scheme_Method_Prim *)os_wxMediaEdit_ConstructScheme, 154));
WITH_VAR_STACK(scheme_add_method_w_arity(os_wxMediaEdit_class, "call-clickback" " method", (Scheme_Method_Prim *)os_wxMediaEditCallClickback, 2, 2));
WITH_VAR_STACK(scheme_add_method_w_arity(os_wxMediaEdit_class, "remove-clickback" " method", (Scheme_Method_Prim *)os_wxMediaEditRemoveClickback, 2, 2));
@ -8896,6 +8954,7 @@ void objscheme_setup_wxMediaEdit(Scheme_Env *env)
WITH_VAR_STACK(scheme_add_method_w_arity(os_wxMediaEdit_class, "can-save-file?" " method", (Scheme_Method_Prim *)os_wxMediaEditCanSaveFile, 2, 2));
WITH_VAR_STACK(scheme_add_method_w_arity(os_wxMediaEdit_class, "on-new-box" " method", (Scheme_Method_Prim *)os_wxMediaEditOnNewBox, 1, 1));
WITH_VAR_STACK(scheme_add_method_w_arity(os_wxMediaEdit_class, "on-new-image-snip" " method", (Scheme_Method_Prim *)os_wxMediaEditOnNewImageSnip, 4, 4));
WITH_VAR_STACK(scheme_add_method_w_arity(os_wxMediaEdit_class, "size-cache-invalid" " method", (Scheme_Method_Prim *)os_wxMediaEditSizeCacheInvalid, 0, 0));
WITH_VAR_STACK(scheme_add_method_w_arity(os_wxMediaEdit_class, "invalidate-bitmap-cache" " method", (Scheme_Method_Prim *)os_wxMediaEditInvalidateBitmapCache, 0, 4));
WITH_VAR_STACK(scheme_add_method_w_arity(os_wxMediaEdit_class, "on-paint" " method", (Scheme_Method_Prim *)os_wxMediaEditOnPaint, 9, 9));
WITH_VAR_STACK(scheme_add_method_w_arity(os_wxMediaEdit_class, "write-footers-to-file" " method", (Scheme_Method_Prim *)os_wxMediaEditWriteFootersToFile, 1, 1));

61
src/mred/wxs/wxs_mpb.cxx
View File

@ -436,6 +436,7 @@ class os_wxMediaPasteboard : public wxMediaPasteboard {
Bool CanSaveFile(epathname x0, int x1);
class wxSnip* OnNewBox(int x0);
class wxImageSnip* OnNewImageSnip(nxpathname x0, int x1, Bool x2, Bool x3);
void SizeCacheInvalid();
void InvalidateBitmapCache(double x0 = 0.0, double x1 = 0.0, double x2 = -1.0, double x3 = -1.0);
void OnPaint(Bool x0, class wxDC* x1, double x2, double x3, double x4, double x5, double x6, double x7, int x8);
Bool WriteFootersToFile(class wxMediaStreamOut* x0);
@ -2217,6 +2218,40 @@ class wxImageSnip* os_wxMediaPasteboard::OnNewImageSnip(nxpathname x0, int x1, B
}
}
static Scheme_Object *os_wxMediaPasteboardSizeCacheInvalid(int n, Scheme_Object *p[]);
void os_wxMediaPasteboard::SizeCacheInvalid()
{
Scheme_Object *p[POFFSET+0] INIT_NULLED_ARRAY({ NULLED_OUT });
Scheme_Object *v;
Scheme_Object *method INIT_NULLED_OUT;
#ifdef MZ_PRECISE_GC
os_wxMediaPasteboard *sElF = this;
#endif
static void *mcache = 0;
SETUP_VAR_STACK(5);
VAR_STACK_PUSH(0, method);
VAR_STACK_PUSH(1, sElF);
VAR_STACK_PUSH_ARRAY(2, p, POFFSET+0);
SET_VAR_STACK();
method = objscheme_find_method((Scheme_Object *) ASSELF __gc_external, os_wxMediaPasteboard_class, "size-cache-invalid", &mcache);
if (!method || OBJSCHEME_PRIM_METHOD(method, os_wxMediaPasteboardSizeCacheInvalid)) {
SET_VAR_STACK();
READY_TO_RETURN; ASSELF wxMediaPasteboard::SizeCacheInvalid();
} else {
p[0] = (Scheme_Object *) ASSELF __gc_external;
v = WITH_VAR_STACK(scheme_apply(method, POFFSET+0, p));
READY_TO_RETURN;
}
}
static Scheme_Object *os_wxMediaPasteboardInvalidateBitmapCache(int n, Scheme_Object *p[]);
void os_wxMediaPasteboard::InvalidateBitmapCache(double x0, double x1, double x2, double x3)
@ -5718,6 +5753,29 @@ static Scheme_Object *os_wxMediaPasteboardOnNewImageSnip(int n, Scheme_Object *
return WITH_REMEMBERED_STACK(objscheme_bundle_wxImageSnip(r));
}
static Scheme_Object *os_wxMediaPasteboardSizeCacheInvalid(int n, Scheme_Object *p[])
{
WXS_USE_ARGUMENT(n) WXS_USE_ARGUMENT(p)
REMEMBER_VAR_STACK();
objscheme_check_valid(os_wxMediaPasteboard_class, "size-cache-invalid in pasteboard%", n, p);
SETUP_VAR_STACK_REMEMBERED(1);
VAR_STACK_PUSH(0, p);
if (((Scheme_Class_Object *)p[0])->primflag)
WITH_VAR_STACK(((os_wxMediaPasteboard *)((Scheme_Class_Object *)p[0])->primdata)->wxMediaPasteboard::SizeCacheInvalid());
else
WITH_VAR_STACK(((wxMediaPasteboard *)((Scheme_Class_Object *)p[0])->primdata)->SizeCacheInvalid());
READY_TO_RETURN;
return scheme_void;
}
static Scheme_Object *os_wxMediaPasteboardInvalidateBitmapCache(int n, Scheme_Object *p[])
{
WXS_USE_ARGUMENT(n) WXS_USE_ARGUMENT(p)
@ -6999,7 +7057,7 @@ void objscheme_setup_wxMediaPasteboard(Scheme_Env *env)
wxREGGLOB(os_wxMediaPasteboard_class);
os_wxMediaPasteboard_class = WITH_VAR_STACK(objscheme_def_prim_class(env, "pasteboard%", "editor%", (Scheme_Method_Prim *)os_wxMediaPasteboard_ConstructScheme, 115));
os_wxMediaPasteboard_class = WITH_VAR_STACK(objscheme_def_prim_class(env, "pasteboard%", "editor%", (Scheme_Method_Prim *)os_wxMediaPasteboard_ConstructScheme, 116));
WITH_VAR_STACK(scheme_add_method_w_arity(os_wxMediaPasteboard_class, "set-scroll-step" " method", (Scheme_Method_Prim *)os_wxMediaPasteboardSetScrollStep, 1, 1));
WITH_VAR_STACK(scheme_add_method_w_arity(os_wxMediaPasteboard_class, "get-scroll-step" " method", (Scheme_Method_Prim *)os_wxMediaPasteboardGetScrollStep, 0, 0));
@ -7072,6 +7130,7 @@ void objscheme_setup_wxMediaPasteboard(Scheme_Env *env)
WITH_VAR_STACK(scheme_add_method_w_arity(os_wxMediaPasteboard_class, "can-save-file?" " method", (Scheme_Method_Prim *)os_wxMediaPasteboardCanSaveFile, 2, 2));
WITH_VAR_STACK(scheme_add_method_w_arity(os_wxMediaPasteboard_class, "on-new-box" " method", (Scheme_Method_Prim *)os_wxMediaPasteboardOnNewBox, 1, 1));
WITH_VAR_STACK(scheme_add_method_w_arity(os_wxMediaPasteboard_class, "on-new-image-snip" " method", (Scheme_Method_Prim *)os_wxMediaPasteboardOnNewImageSnip, 4, 4));
WITH_VAR_STACK(scheme_add_method_w_arity(os_wxMediaPasteboard_class, "size-cache-invalid" " method", (Scheme_Method_Prim *)os_wxMediaPasteboardSizeCacheInvalid, 0, 0));
WITH_VAR_STACK(scheme_add_method_w_arity(os_wxMediaPasteboard_class, "invalidate-bitmap-cache" " method", (Scheme_Method_Prim *)os_wxMediaPasteboardInvalidateBitmapCache, 0, 4));
WITH_VAR_STACK(scheme_add_method_w_arity(os_wxMediaPasteboard_class, "on-paint" " method", (Scheme_Method_Prim *)os_wxMediaPasteboardOnPaint, 9, 9));
WITH_VAR_STACK(scheme_add_method_w_arity(os_wxMediaPasteboard_class, "write-footers-to-file" " method", (Scheme_Method_Prim *)os_wxMediaPasteboardWriteFootersToFile, 1, 1));