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

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

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

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

@ -1,8 +1,10 @@
#lang scheme/base #lang scheme/base
(require scheme/class (require scheme/class
macro-debugger/util/class-iop
scheme/gui scheme/gui
framework/framework framework/framework
scheme/list scheme/list
"interfaces.ss"
"partition.ss" "partition.ss"
"prefs.ss" "prefs.ss"
"widget.ss") "widget.ss")
@ -20,8 +22,9 @@
(define (browse-syntaxes stxs) (define (browse-syntaxes stxs)
(let ((w (make-syntax-browser))) (let ((w (make-syntax-browser)))
(for ([stx stxs]) (for ([stx stxs])
(send w add-syntax stx) (send*: w syntax-browser<%>
(send w add-separator)))) (add-syntax stx)
(add-separator)))))
;; make-syntax-browser : -> syntax-browser<%> ;; make-syntax-browser : -> syntax-browser<%>
(define (make-syntax-browser) (define (make-syntax-browser)
@ -32,21 +35,23 @@
;; syntax-browser-frame% ;; syntax-browser-frame%
(define syntax-browser-frame% (define syntax-browser-frame%
(class* 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") (super-new (label "Syntax Browser")
(width (send config pref:width)) (width (send: config config<%> get-width))
(height (send config pref:height))) (height (send: config config<%> get-height)))
(define widget (define: widget syntax-browser<%>
(new syntax-widget/controls% (new syntax-widget/controls%
(parent this) (parent this)
(config config))) (config config)))
(define/public (get-widget) widget) (define/public (get-widget) widget)
(define/augment (on-close) (define/augment (on-close)
(send config pref:width (send this get-width)) (send*: config config<%>
(send config pref:height (send this get-height)) (set-width (get-width))
(set-height (get-height)))
(send widget shutdown) (send widget shutdown)
(inner (void) on-close)) (inner (void) on-close))))
))
;; syntax-widget/controls% ;; syntax-widget/controls%
(define syntax-widget/controls% (define syntax-widget/controls%
@ -72,23 +77,23 @@
(choices (map car -identifier=-choices)) (choices (map car -identifier=-choices))
(callback (callback
(lambda (c e) (lambda (c e)
(send (get-controller) set-identifier=? (send: (get-controller) controller<%> set-identifier=?
(assoc (send c get-string-selection) (assoc (send c get-string-selection)
-identifier=-choices)))))) -identifier=-choices))))))
(new button% (new button%
(label "Clear") (label "Clear")
(parent -control-panel) (parent -control-panel)
(callback (lambda _ (send (get-controller) select-syntax #f)))) (callback (lambda _ (send: (get-controller) controller<%> set-selected-syntax #f))))
(new button% (new button%
(label "Properties") (label "Properties")
(parent -control-panel) (parent -control-panel)
(callback (callback
(lambda _ (lambda _
(send config set-props-shown? (send: config config<%> set-props-shown?
(not (send config get-props-shown?)))))) (not (send: config config<%> get-props-shown?))))))
(send (get-controller) listen-identifier=? (send: (get-controller) controller<%> listen-identifier=?
(lambda (name+func) (lambda (name+func)
(send -choice set-selection (send -choice set-selection
(or (send -choice find-string (car name+func)) 0)))) (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 #lang scheme/base
(require scheme/class (require scheme/class
macro-debugger/util/class-iop) macro-debugger/util/class-iop
"../util/notify.ss")
(provide (all-defined-out)) (provide (all-defined-out))
;; config<%>
(define-interface config<%> ()
((methods:notify suffix-option
syntax-font-size
colors
width
height
props-percentage
props-shown?)))
;; displays-manager<%> ;; displays-manager<%>
(define-interface displays-manager<%> () (define-interface displays-manager<%> ()
(;; add-syntax-display : display<%> -> void (;; add-syntax-display : display<%> -> void
@ -13,10 +24,8 @@
;; selection-manager<%> ;; selection-manager<%>
(define-interface selection-manager<%> () (define-interface selection-manager<%> ()
(;; selected-syntax : syntax/#f (;; selected-syntax : notify-box of syntax/#f
set-selected-syntax (methods:notify selected-syntax)))
get-selected-syntax
listen-selected-syntax))
;; mark-manager<%> ;; mark-manager<%>
;; Manages marks, mappings from marks to colors ;; Manages marks, mappings from marks to colors
@ -29,23 +38,10 @@
;; secondary-partition<%> ;; secondary-partition<%>
(define-interface secondary-partition<%> () (define-interface secondary-partition<%> ()
(;; get-secondary-partition : -> partition<%> (;; secondary-partition : notify-box of partition<%>
get-secondary-partition ;; identifier=? : notify-box of (cons string procedure)
(methods:notify secondary-partition
;; set-secondary-partition : partition<%> -> void identifier=?)))
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=?))
;; controller<%> ;; controller<%>
(define-interface controller<%> (displays-manager<%> (define-interface controller<%> (displays-manager<%>
@ -143,6 +139,7 @@
add-clickback add-clickback
add-separator add-separator
erase-all erase-all
get-controller
get-text)) get-text))
(define-interface partition<%> () (define-interface partition<%> ()

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

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

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

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

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

@ -1,6 +1,7 @@
#lang scheme/base #lang scheme/base
(require scheme/class (require scheme/class
macro-debugger/util/class-iop
scheme/match scheme/match
scheme/list scheme/list
mzlib/string mzlib/string
@ -205,8 +206,8 @@
(define/public (read-special src line col pos) (define/public (read-special src line col pos)
(send the-syntax-snip 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))) (lambda (?) (refresh-contents)))
(super-new) (super-new)
(set-snipclass snip-class) (set-snipclass snip-class)

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

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

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

@ -14,7 +14,15 @@
checked-binding-iface checked-binding-iface
checked-binding checked-binding
static-interface) static-interface
interface-expander?
make-interface-expander
interface-expander-proc
interface-expander
method-entry)
(define-struct static-interface (dynamic members) (define-struct static-interface (dynamic members)
#:omit-define-syntaxes #:omit-define-syntaxes
@ -60,6 +68,11 @@
(define (checked-binding-iface x) (define (checked-binding-iface x)
(raw-checked-binding-iface (set!-transformer-procedure x))) (raw-checked-binding-iface (set!-transformer-procedure x)))
(define-struct interface-expander (proc)
#:omit-define-syntaxes)
;; Syntax ;; Syntax
(define-syntax-class static-interface (define-syntax-class static-interface
@ -71,3 +84,20 @@
(pattern x (pattern x
#:declare x (static-of 'checked-binding checked-binding?) #:declare x (static-of 'checked-binding checked-binding?)
#:with value #'x.value)) #: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")) "class-ct.ss"))
(provide define-interface (provide define-interface
define-interface/dynamic define-interface/dynamic
define-interface-expander
send: send:
send*: send*:
@ -26,13 +27,14 @@
;; Defines NAME as an interface. ;; Defines NAME as an interface.
(define-syntax (define-interface stx) (define-syntax (define-interface stx)
(syntax-parse stx (syntax-parse stx
[(_ name:id (super:static-interface ...) (mname:id ...)) [(_ name:id (super:static-interface ...) (m:method-entry ...))
(with-syntax ([((super-method ...) ...) (with-syntax ([((super-method ...) ...)
(map static-interface-members (map static-interface-members
(syntax->datum #'(super.value ...)))]) (syntax->datum #'(super.value ...)))]
[((mname ...) ...) #'(m.methods ...)])
#'(define-interface/dynamic name #'(define-interface/dynamic name
(let ([name (interface (super ...) mname ...)]) name) (let ([name (interface (super ...) mname ... ...)]) name)
(super-method ... ... mname ...)))])) (super-method ... ... mname ... ...)))]))
;; define-interface/dynamic SYNTAX ;; define-interface/dynamic SYNTAX
;; (define-interface/dynamic NAME EXPR (IDENTIFIER ...)) ;; (define-interface/dynamic NAME EXPR (IDENTIFIER ...))
@ -54,6 +56,11 @@
(define-syntax name (define-syntax name
(make-static-interface #'dynamic-name '(mname ...)))))])) (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 ;; Helper
(begin-for-syntax (begin-for-syntax
@ -173,19 +180,19 @@
;; FIXME: unsafe due to mutation ;; FIXME: unsafe due to mutation
(define-syntax (init-field: stx) (define-syntax (init-field: stx)
(syntax-parse stx (syntax-parse stx
[(_ (name:id iface:static-interface) ...) [(_ (name:id iface:static-interface . default) ...)
#'(begin (init1: init-field name iface) ...)])) #'(begin (init1: init-field name iface . default) ...)]))
(define-syntax (init: stx) (define-syntax (init: stx)
(syntax-parse stx (syntax-parse stx
[(_ (name:id iface:static-interface) ...) [(_ (name:id iface:static-interface . default) ...)
#'(begin (init1: init name iface) ...)])) #'(begin (init1: init name iface . default) ...)]))
(define-syntax (init1: stx) (define-syntax (init1: stx)
(syntax-parse stx (syntax-parse stx
[(_ init name:id iface:static-interface) [(_ init name:id iface:static-interface . default)
(with-syntax ([(name-internal) (generate-temporaries #'(name))]) (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)) (void (check-object<:interface init: name-internal iface))
(define-syntax name (define-syntax name
(make-checked-binding (make-checked-binding

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

@ -3,6 +3,7 @@
(require (for-syntax scheme/base) (require (for-syntax scheme/base)
scheme/list scheme/list
scheme/class scheme/class
macro-debugger/util/class-iop
scheme/gui) scheme/gui)
(provide define/listen (provide define/listen
field/notify field/notify
@ -15,7 +16,9 @@
menu-option/notify-box menu-option/notify-box
menu-group/notify-box menu-group/notify-box
check-box/notify-box check-box/notify-box
choice/notify-box) choice/notify-box
methods:notify)
(define-for-syntax (join . args) (define-for-syntax (join . args)
(define (->string x) (define (->string x)
@ -71,6 +74,19 @@
(define/public-final (listen-name listener) (define/public-final (listen-name listener)
(send name listen 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) (define-syntax (connect-to-pref stx)
(syntax-case stx () (syntax-case stx ()
[(connect-to-pref name pref) [(connect-to-pref name pref)

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

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

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

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

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

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

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

@ -1,8 +1,23 @@
#lang scheme/base #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)) (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<%> () (define-interface widget<%> ()
(get-config (get-config
get-controller get-controller

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

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

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

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

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

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

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

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

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

@ -240,6 +240,7 @@
can-save-file? can-save-file?
on-new-box on-new-box
on-new-image-snip on-new-image-snip
size-cache-invalid
invalidate-bitmap-cache invalidate-bitmap-cache
on-paint on-paint
write-footers-to-file write-footers-to-file
@ -921,6 +922,7 @@
can-save-file? can-save-file?
on-new-box on-new-box
on-new-image-snip on-new-image-snip
size-cache-invalid
invalidate-bitmap-cache invalidate-bitmap-cache
on-paint on-paint
write-footers-to-file write-footers-to-file
@ -1133,6 +1135,7 @@
can-save-file? can-save-file?
on-new-box on-new-box
on-new-image-snip on-new-image-snip
size-cache-invalid
invalidate-bitmap-cache invalidate-bitmap-cache
on-paint on-paint
write-footers-to-file 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)) [(--> (in-hole e-ctxt_1 a) (in-hole e-ctxt_1 b))
(c--> a 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) (λ (ed)
(let ([yb (box 0)] (let ([yb (box 0)]
[snip (term-node-snip term-node)]) [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) (unbox yb)
0))))) 0)))))
@ -132,7 +132,7 @@
#:scheme-colors? [scheme-colors? #t] #:scheme-colors? [scheme-colors? #t]
#:colors [colors '()] #:colors [colors '()]
#:layout [layout void]) #:layout [layout void])
(let-values ([(graph-pb frame) (let-values ([(graph-pb canvas)
(traces reductions pre-exprs (traces reductions pre-exprs
#:no-show-frame? #t #:no-show-frame? #t
#:multiple? multiple? #:multiple? multiple?
@ -141,21 +141,18 @@
#:scheme-colors? scheme-colors? #:scheme-colors? scheme-colors?
#:colors colors #:colors colors
#:layout layout)]) #: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)] (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) (send graph-pb set-admin printing-admin)
(dynamic-wind (dynamic-wind
void void
(λ () (λ ()
(let loop ([snip (send graph-pb find-first-snip)]) (send graph-pb size-cache-invalid)
(when snip
(send snip size-cache-invalid)
(loop (send snip next))))
(send graph-pb invalidate-bitmap-cache)
(send graph-pb re-run-layout) (send graph-pb re-run-layout)
@ -168,17 +165,20 @@
(λ () (λ ()
(send graph-pb set-admin admin) (send graph-pb set-admin admin)
(send canvas set-editor graph-pb)
(send printing-admin shutdown) ;; do this early (send printing-admin shutdown) ;; do this early
(let loop ([snip (send graph-pb find-first-snip)]) (let loop ([snip (send graph-pb find-first-snip)])
(when snip (when snip
(send snip size-cache-invalid) (send snip size-cache-invalid)
(loop (send snip next)))) (loop (send snip next))))
(send graph-pb invalidate-bitmap-cache) (send graph-pb size-cache-invalid)
(send graph-pb re-run-layout))))) (send graph-pb re-run-layout)))))
(define printing-editor-admin% (define printing-editor-admin%
(class editor-admin% (class editor-admin%
(init-field ed)
(define temp-file (make-temporary-file "redex-size-snip-~a")) (define temp-file (make-temporary-file "redex-size-snip-~a"))
(define ps-dc (define ps-dc
@ -204,7 +204,8 @@
(define/override (get-max-view x y w h [full? #f]) (define/override (get-max-view x y w h [full? #f])
(get-view x y w h full?)) (get-view x y w h full?))
(define/override (get-view x y w h [full? #f]) (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? w) (set-box! w 500))
(when (box? h) (set-box! h 500))) (when (box? h) (set-box! h 500)))
@ -270,7 +271,7 @@
"Reducing..." "Reducing..."
lower-panel lower-panel
(lambda (x y) (lambda (x y)
(reduce-button-callback)))) (reduce-button-callback #f))))
(define status-message (instantiate message% () (define status-message (instantiate message% ()
(label "") (label "")
(parent lower-panel) (parent lower-panel)
@ -411,7 +412,6 @@
(set! col (+ x-spacing (find-rightmost-x graph-pb)))) (set! col (+ x-spacing (find-rightmost-x graph-pb))))
(begin0 (begin0
(insert-into col y graph-pb new-snips) (insert-into col y graph-pb new-snips)
(send graph-pb re-run-layout)
(send graph-pb end-edit-sequence) (send graph-pb end-edit-sequence)
(send status-message set-label (send status-message set-label
(string-append (term-count (count-snips)) "...")))))]) (string-append (term-count (count-snips)) "...")))))])
@ -455,9 +455,10 @@
(send reduce-button enable #t) (send reduce-button enable #t)
(send font-size enable #t)) (send font-size enable #t))
;; reduce-button-callback : -> void ;; reduce-button-callback : boolean -> void
;; =eventspace main thread= ;; =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 enable #f)
(send reduce-button set-label "Reducing...") (send reduce-button set-label "Reducing...")
(thread (thread
@ -465,6 +466,10 @@
(do-some-reductions) (do-some-reductions)
(queue-callback (queue-callback
(lambda () ;; =eventspace main thread= (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) (scroll-to-rightmost-snip)
(send reduce-button set-label "Reduce") (send reduce-button set-label "Reduce")
(cond (cond
@ -541,9 +546,8 @@
(list bottom-panel) (list bottom-panel)
null))) null)))
(out-of-dot-state) ;; make sure the state is initialized right (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) (insert-into init-rightmost-x 0 graph-pb frontier)
(send graph-pb re-run-layout)
(set-font-size (initial-font-size))
(cond (cond
[no-show-frame? [no-show-frame?
(let ([s (make-semaphore)]) (let ([s (make-semaphore)])
@ -551,9 +555,9 @@
(do-some-reductions) (do-some-reductions)
(semaphore-post s))) (semaphore-post s)))
(yield s)) (yield s))
(values graph-pb f)] (values graph-pb ec)]
[else [else
(reduce-button-callback) (reduce-button-callback #t)
(send f show #t)])) (send f show #t)]))
(define red-sem-frame% (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], to DrScheme's Scheme mode color Scheme. If it is @scheme[#f],
@scheme[traces] just uses black for the color scheme. @scheme[traces] just uses black for the color scheme.
The @scheme[layout] argument is called (with all of the terms) each The @scheme[layout] argument is called (with all of the terms) when
time a new term is inserted into the window. See also new terms is inserted into the window. In general, it is called when
@scheme[term-node-set-position!]. 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 You can save the contents of the window as a postscript file
from the menus. from the menus.

23
collects/scheme/help.ss
View File

@ -14,13 +14,17 @@
(identifier? #'id) (identifier? #'id)
#'(find-help (quote-syntax id))] #'(find-help (quote-syntax id))]
[(help id #:from lib) [(help id #:from lib)
(if (identifier? #'id) (cond [(not (identifier? #'id))
(if (module-path? (syntax->datum #'lib)) (raise-syntax-error
#'(find-help/lib (quote id) (quote lib)) #f "expected an identifier before #:from" stx #'id)]
(raise-syntax-error [(not (module-path? (syntax->datum #'lib)))
#f "expected a module path after #:from" stx #'lib)) (raise-syntax-error
(raise-syntax-error #f "expected a module path after #:from" stx #'lib)]
#f "expected an identifier before #:from" stx #'id))] [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 ...) [(help #:search str ...)
(with-syntax ([(str ...) (with-syntax ([(str ...)
(map (lambda (e) (map (lambda (e)
@ -32,8 +36,9 @@
[_ [_
(raise-syntax-error (raise-syntax-error
#f #f
(string-append "expects a single identifer, a #:from clause, or a" (string-append "expects a single identifer, any number of literal"
" #:search clause; try `(help help)' for more information") " strings, or #:search clauses;"
" try `(help help)' for more information")
stx)]))) stx)])))
(define (open-help-start) (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) immediately or at the end of the current edit sequence (if any)
started by @method[editor<%> begin-edit-sequence]. started by @method[editor<%> begin-edit-sequence].
} See also @method[editor<%> size-cache-invalid].}
@defmethod[(is-locked?) @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)]) @defmethod[(style-has-changed [style (or/c (is-a?/c style<%>) false/c)])
void?]{ void?]{

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

@ -19,6 +19,7 @@
@deftogether[( @deftogether[(
@defidform[help] @defidform[help]
@defform/none[#:literals (help) (help string ...)]
@defform/none[#:literals (help) (help id)] @defform/none[#:literals (help) (help id)]
@defform/none[#:literals (help) (help id #:from module-path)] @defform/none[#:literals (help) (help id #:from module-path)]
@defform/none[#:literals (help) (help #:search datum ...)] @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 A simple @scheme[help] or @scheme[(help)] form opens the main
documentation page. 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 A @scheme[(help id)] form looks for documentation specific to the
current binding of @scheme[id]. For example, 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}) (help frame% #:from scheme/gui) (code:comment #, @t{equivalent to the above})
] ]
The @scheme[(help #:search datum ...)] form performs a general The @scheme[(help #:search datum ...)] form is similar to
search. Searching uses strings; each string @scheme[datum] is used @scheme[(help string ...)], where any non-string form of
as-is, and any other form of @scheme[datum] is converted to a string @scheme[datum] is converted to a string using @scheme[display]. No
using @scheme[display]. No @scheme[datum] is evaluated as an @scheme[datum] is evaluated as an expression.
expression.
For example, For example,
@ -82,7 +93,7 @@ For example,
(help #:search "web browser" firefox) (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.'' phrase ``web browser'' or ``firefox.''
} }

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

@ -57,7 +57,7 @@
(schememodname lib) (schememodname lib)
" and " " and "
(schememodname scheme/init) (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." (exec "mzscheme") " is started with no command-line arguments."
" They are not provided by " (schememodname scheme/base) " They are not provided by " (schememodname scheme/base)
" or " (schememodname scheme) "." " 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 @emph{handler} functions. Specifically, the teachpack provides for the
installation of three event handlers: @scheme[on-tick], @scheme[on-key], installation of three event handlers: @scheme[on-tick], @scheme[on-key],
and @scheme[on-mouse]. In addition, a @tech{world} program may specify a 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 visualize the current world, and a @scheme[_stop?] predicate, which is used
to determine when the @tech{world} program should shut down. 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) (sleep 1)
(parameterize ((current-eventspace (make-eventspace))) (parameterize ((current-eventspace (make-eventspace)))
(let ([frame (new macro-stepper-frame% (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) (send frame show #t)
frame))) frame)))
@ -270,4 +271,4 @@
(send frame get-eventspace)))))))))) (send frame get-eventspace))))))))))
(define (test-stepper expr) (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")] @ 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 "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-image-snip" : wxImageSnip! OnNewImageSnip(nxpathname,SYM[bitmapType],bool,bool);
@ Z "on-new-box" : wxSnip! OnNewBox(SYM[bufferType]); @ 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); Bool CanSaveFile(epathname x0, int x1);
class wxSnip* OnNewBox(int x0); class wxSnip* OnNewBox(int x0);
class wxImageSnip* OnNewImageSnip(nxpathname x0, int x1, Bool x2, Bool x3); 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 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); 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); 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[]); static Scheme_Object *os_wxMediaEditInvalidateBitmapCache(int n, Scheme_Object *p[]);
void os_wxMediaEdit::InvalidateBitmapCache(double x0, double x1, double x2, double x3) 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)); 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[]) static Scheme_Object *os_wxMediaEditInvalidateBitmapCache(int n, Scheme_Object *p[])
{ {
WXS_USE_ARGUMENT(n) WXS_USE_ARGUMENT(p) WXS_USE_ARGUMENT(n) WXS_USE_ARGUMENT(p)
@ -8778,7 +8836,7 @@ void objscheme_setup_wxMediaEdit(Scheme_Env *env)
wxREGGLOB(os_wxMediaEdit_class); 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, "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)); 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, "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-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, "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, "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, "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)); 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); Bool CanSaveFile(epathname x0, int x1);
class wxSnip* OnNewBox(int x0); class wxSnip* OnNewBox(int x0);
class wxImageSnip* OnNewImageSnip(nxpathname x0, int x1, Bool x2, Bool x3); 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 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); 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); 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[]); static Scheme_Object *os_wxMediaPasteboardInvalidateBitmapCache(int n, Scheme_Object *p[]);
void os_wxMediaPasteboard::InvalidateBitmapCache(double x0, double x1, double x2, double x3) 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)); 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[]) static Scheme_Object *os_wxMediaPasteboardInvalidateBitmapCache(int n, Scheme_Object *p[])
{ {
WXS_USE_ARGUMENT(n) WXS_USE_ARGUMENT(p) WXS_USE_ARGUMENT(n) WXS_USE_ARGUMENT(p)
@ -6999,7 +7057,7 @@ void objscheme_setup_wxMediaPasteboard(Scheme_Env *env)
wxREGGLOB(os_wxMediaPasteboard_class); 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, "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)); 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, "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-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, "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, "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, "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)); WITH_VAR_STACK(scheme_add_method_w_arity(os_wxMediaPasteboard_class, "write-footers-to-file" " method", (Scheme_Method_Prim *)os_wxMediaPasteboardWriteFootersToFile, 1, 1));