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

Syncing up to trunk.

Browse Source 
svn: r13115
This commit is contained in:
Stevie Strickland 2009-01-14 16:45:50 +00:00
commit 4ca79e31ff
168 changed files with 773 additions and 715 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

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

@ -68,9 +68,10 @@
(super-new)))
(define controller%
(class (secondary-partition-mixin
(class* (secondary-partition-mixin
(selection-manager-mixin
(mark-manager-mixin
(displays-manager-mixin
object%))))
(controller<%>)
(super-new)))

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

@ -1,11 +1,10 @@
#lang scheme/base
(require scheme/class
macro-debugger/util/class-iop)
(provide (all-defined-out))
;; displays-manager<%>
(define-interface displays-manager<%>
(define-interface displays-manager<%> ()
(;; add-syntax-display : display<%> -> void
add-syntax-display
@ -13,7 +12,7 @@
remove-all-syntax-displays))
;; selection-manager<%>
(define-interface selection-manager<%>
(define-interface selection-manager<%> ()
(;; selected-syntax : syntax/#f
set-selected-syntax
get-selected-syntax
@ -21,12 +20,15 @@
;; mark-manager<%>
;; Manages marks, mappings from marks to colors
(define-interface mark-manager<%>
(define-interface mark-manager<%> ()
(;; get-primary-partition : -> partition
get-primary-partition))
get-primary-partition
;; reset-primary-partition : -> void
reset-primary-partition))
;; secondary-partition<%>
(define-interface secondary-partition<%>
(define-interface secondary-partition<%> ()
(;; get-secondary-partition : -> partition<%>
get-secondary-partition
@ -46,27 +48,15 @@
listen-identifier=?))
;; controller<%>
(define-interface/dynamic controller<%>
(interface (displays-manager<%>
(define-interface controller<%> (displays-manager<%>
selection-manager<%>
mark-manager<%>
secondary-partition<%>))
(add-syntax-display
remove-all-syntax-displays
set-selected-syntax
get-selected-syntax
listen-selected-syntax
get-primary-partition
get-secondary-partition
set-secondary-partition
listen-secondary-partition
get-identifier=?
set-identifier=?
listen-identifier=?))
secondary-partition<%>)
())
;; host<%>
(define-interface host<%>
(define-interface host<%> ()
(;; get-controller : -> controller<%>
get-controller
@ -74,7 +64,7 @@
add-keymap))
;; display<%>
(define-interface display<%>
(define-interface display<%> ()
(;; refresh : -> void
refresh
@ -94,7 +84,7 @@
get-range))
;; range<%>
(define-interface range<%>
(define-interface range<%> ()
(;; get-ranges : datum -> (list-of (cons number number))
get-ranges
@ -111,14 +101,14 @@
;; syntax-prefs<%>
(define-interface syntax-prefs<%>
(define-interface syntax-prefs<%> ()
(pref:width
pref:height
pref:props-percentage
pref:props-shown?))
;; widget-hooks<%>
(define-interface widget-hooks<%>
(define-interface widget-hooks<%> ()
(;; setup-keymap : -> void
setup-keymap
@ -126,7 +116,7 @@
shutdown))
;; keymap-hooks<%>
(define-interface keymap-hooks<%>
(define-interface keymap-hooks<%> ()
(;; make-context-menu : -> context-menu<%>
make-context-menu
@ -134,7 +124,7 @@
get-context-menu%))
;; context-menu-hooks<%>
(define-interface context-menu-hooks<%>
(define-interface context-menu-hooks<%> ()
(add-edit-items
after-edit-items
add-selection-items
@ -146,15 +136,16 @@
;;----------
;; Convenience widget, specialized for displaying stx and not much else
(define-interface syntax-browser<%>
(define-interface syntax-browser<%> ()
(add-syntax
add-text
add-error-text
add-clickback
add-separator
erase-all
select-syntax
get-text))
(define-interface partition<%>
(define-interface partition<%> ()
(;; get-partition : any -> number
get-partition

1
collects/macro-debugger/syntax-browser/keymap.ss
View File

@ -1,4 +1,3 @@
#lang scheme/base
(require scheme/class
scheme/gui

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

@ -21,7 +21,7 @@
;; widget%
;; A syntax widget creates its own syntax-controller.
(define widget%
(class* object% (widget-hooks<%>)
(class* object% (syntax-browser<%> widget-hooks<%>)
(init parent)
(init-field config)

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

@ -13,6 +13,7 @@
define:
lambda:
init:
init-field:
init-private:)
;; Configuration
@ -25,10 +26,13 @@
;; Defines NAME as an interface.
(define-syntax (define-interface stx)
(syntax-parse stx
[(_ name:id (mname:id ...))
[(_ name:id (super:static-interface ...) (mname:id ...))
(with-syntax ([((super-method ...) ...)
(map static-interface-members
(syntax->datum #'(super.value ...)))])
#'(define-interface/dynamic name
(let ([name (interface () mname ...)]) name)
(mname ...))]))
(let ([name (interface (super ...) mname ...)]) name)
(super-method ... ... mname ...)))]))
;; define-interface/dynamic SYNTAX
;; (define-interface/dynamic NAME EXPR (IDENTIFIER ...))
@ -181,7 +185,7 @@
(syntax-parse stx
[(_ init name:id iface:static-interface)
(with-syntax ([(name-internal) (generate-temporaries #'(name))])
#'(begin (init (name name-internal))
#'(begin (init ((name-internal name)))
(void (check-object<:interface init: name-internal iface))
(define-syntax name
(make-checked-binding

21
collects/macro-debugger/view/extensions.ss
View File

@ -1,6 +1,7 @@
#lang scheme/base
(require scheme/class
macro-debugger/util/class-iop
scheme/unit
scheme/list
scheme/match
@ -13,6 +14,7 @@
"hiding-panel.ss"
(prefix-in s: "../syntax-browser/widget.ss")
(prefix-in s: "../syntax-browser/keymap.ss")
(prefix-in s: "../syntax-browser/interfaces.ss")
"../model/deriv.ss"
"../model/deriv-util.ss"
"../model/trace.ss"
@ -26,7 +28,7 @@
(define stepper-keymap%
(class s:syntax-keymap%
(init-field macro-stepper)
(init-field: (macro-stepper widget<%>))
(inherit-field config
controller
the-context-menu)
@ -39,17 +41,17 @@
(super-new)
(define/public (get-hiding-panel)
(send macro-stepper get-macro-hiding-prefs))
(send: macro-stepper widget<%> get-macro-hiding-prefs))
(add-function "hiding:show-macro"
(lambda (i e)
(send* (get-hiding-panel)
(send*: (get-hiding-panel) hiding-prefs<%>
(add-show-identifier)
(refresh))))
(add-function "hiding:hide-macro"
(lambda (i e)
(send* (get-hiding-panel)
(send*: (get-hiding-panel) hiding-prefs<%>
(add-hide-identifier)
(refresh))))
@ -75,26 +77,27 @@
(send show-macro enable ?)
(send hide-macro enable ?))
(send controller listen-selected-syntax
(send: controller s:controller<%> listen-selected-syntax
(lambda (stx)
(enable/disable-hide/show (identifier? stx))))))
(define stepper-syntax-widget%
(class s:widget%
(init-field macro-stepper)
(init-field: (macro-stepper widget<%>))
(inherit get-text)
(inherit-field controller)
(define/override (setup-keymap)
(new stepper-keymap%
(editor (get-text))
(config (send macro-stepper get-config))
(config (send: macro-stepper widget<%> get-config))
(controller controller)
(macro-stepper macro-stepper)))
(define/override (show-props show?)
(super show-props show?)
(send macro-stepper update/preserve-view))
(send: macro-stepper widget<%> update/preserve-view))
(super-new
(config (send macro-stepper get-config)))))
(config (send: macro-stepper widget<%> get-config)))))

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

@ -1,6 +1,7 @@
#lang scheme/base
(require scheme/class
macro-debugger/util/class-iop
scheme/unit
scheme/list
scheme/file
@ -14,6 +15,7 @@
"warning.ss"
"hiding-panel.ss"
(prefix-in sb: "../syntax-browser/embed.ss")
(prefix-in sb: "../syntax-browser/interfaces.ss")
"../model/deriv.ss"
"../model/deriv-util.ss"
"../model/trace.ss"
@ -23,7 +25,7 @@
(provide macro-stepper-frame-mixin)
(define (macro-stepper-frame-mixin base-frame%)
(class base-frame%
(class* base-frame% (stepper-frame<%>)
(init-field config)
(init-field director)
(init-field (filename #f))
@ -54,7 +56,7 @@
(define/override (on-size w h)
(send config set-width w)
(send config set-height h)
(send widget update/preserve-view))
(send: widget widget<%> update/preserve-view))
(define warning-panel
(new horizontal-panel%
@ -65,12 +67,13 @@
(define/public (get-macro-stepper-widget%)
macro-stepper-widget%)
(define widget
(define: widget widget<%>
(new (get-macro-stepper-widget%)
(parent (get-area-container))
(director director)
(config config)))
(define controller (send widget get-controller))
(define: controller sb:controller<%>
(send: widget widget<%> get-controller))
(define/public (get-widget) widget)
(define/public (get-controller) controller)
@ -112,11 +115,11 @@
(new (get-menu-item%)
(label "Duplicate stepper")
(parent file-menu)
(callback (lambda _ (send widget duplicate-stepper))))
(callback (lambda _ (send: widget widget<%> duplicate-stepper))))
(new (get-menu-item%)
(label "Duplicate stepper (current term only)")
(parent file-menu)
(callback (lambda _ (send widget show-in-new-frame)))))
(callback (lambda _ (send: widget widget<%> show-in-new-frame)))))
(menu-option/notify-box stepper-menu
"View syntax properties"
@ -133,8 +136,8 @@
(parent id-menu)
(callback
(lambda _
(send controller set-identifier=? p))))])
(send controller listen-identifier=?
(send: controller sb:controller<%> set-identifier=? p))))])
(send: controller sb:controller<%> listen-identifier=?
(lambda (name+func)
(send this-choice check
(eq? (car name+func) (car p)))))))
@ -143,13 +146,14 @@
(let ([identifier=? (send config get-identifier=?)])
(when identifier=?
(let ([p (assoc identifier=? (sb:identifier=-choices))])
(send controller set-identifier=? p))))
(send: controller sb:controller<%> set-identifier=? p))))
(new (get-menu-item%)
(label "Clear selection")
(parent stepper-menu)
(callback
(lambda _ (send controller set-selected-syntax #f))))
(lambda _ (send: controller sb:controller<%>
set-selected-syntax #f))))
(new separator-menu-item% (parent stepper-menu))
@ -160,11 +164,11 @@
(new (get-menu-item%)
(label "Remove selected term")
(parent stepper-menu)
(callback (lambda _ (send widget remove-current-term))))
(callback (lambda _ (send: widget widget<%> remove-current-term))))
(new (get-menu-item%)
(label "Reset mark numbering")
(parent stepper-menu)
(callback (lambda _ (send widget reset-primary-partition))))
(callback (lambda _ (send: widget widget<%> reset-primary-partition))))
(let ([extras-menu
(new (get-menu%)
(label "Extra options")
@ -178,7 +182,7 @@
(if (send i is-checked?)
'always
'over-limit))
(send widget update/preserve-view))))
(send: widget widget<%> update/preserve-view))))
(menu-option/notify-box extras-menu
"Highlight redex/contractum"
(get-field highlight-foci? config))

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

@ -1,9 +1,11 @@
#lang scheme/base
(require scheme/class
macro-debugger/util/class-iop
scheme/gui
scheme/list
syntax/boundmap
"interfaces.ss"
"../model/hiding-policies.ss"
"../util/mpi.ss"
"../util/notify.ss")
@ -16,9 +18,9 @@
;; macro-hiding-prefs-widget%
(define macro-hiding-prefs-widget%
(class object%
(class* object% (hiding-prefs<%>)
(init parent)
(init-field stepper)
(init-field: (stepper widget<%>))
(init-field config)
(define/public (get-policy)
@ -173,11 +175,11 @@
;; refresh : -> void
(define/public (refresh)
(when (macro-hiding-enabled?)
(send stepper refresh/resynth)))
(send: stepper widget<%> refresh/resynth)))
;; force-refresh : -> void
(define/private (force-refresh)
(send stepper refresh/resynth))
(send: stepper widget<%> refresh/resynth))
;; set-syntax : syntax/#f -> void
(define/public (set-syntax lstx)

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

@ -1,50 +1,77 @@
#lang scheme/base
(require scheme/unit)
(require macro-debugger/util/class-iop)
(provide (all-defined-out))
;; Signatures
(define-interface widget<%> ()
(get-config
get-controller
get-macro-hiding-prefs
get-step-displayer
#;
(define-signature view^
(macro-stepper-frame%
macro-stepper-widget%
make-macro-stepper
go
go/deriv))
add-trace
add-deriv
#;
(define-signature view-base^
(base-frame%))
update/preserve-view
refresh/resynth
#;
(define-signature prefs^
(pref:width
pref:height
pref:props-shown?
pref:props-percentage
pref:macro-hiding-mode
pref:show-syntax-properties?
pref:show-hiding-panel?
pref:identifier=?
pref:show-rename-steps?
pref:highlight-foci?
pref:highlight-frontier?
pref:suppress-warnings?
pref:one-by-one?
pref:extra-navigation?
pref:debug-catch-errors?
pref:force-letrec-transformation?
reset-primary-partition
remove-current-term
duplicate-stepper
show-in-new-frame
get-preprocess-deriv
get-show-macro?
))
;; macro-stepper-config%
;; all fields are notify-box% objects
;; width
;; height
;; macro-hiding?
;; hide-primitives?
;; hide-libs?
;; show-syntax-properties?
;; show-hiding-panel?
;; show-rename-steps?
;; highlight-foci?
(define-interface stepper-frame<%> ()
(get-widget
get-controller
add-obsoleted-warning))
(define-interface hiding-prefs<%> ()
(add-show-identifier
add-hide-identifier
set-syntax
get-policy
refresh))
(define-interface step-display<%> ()
(add-syntax
add-step
add-error
add-final
add-internal-error))
(define-interface term-record<%> ()
(get-raw-deriv
get-deriv-hidden?
get-step-index
invalidate-synth!
invalidate-steps!
has-prev?
has-next?
#|
at-start?
at-end?
|#
navigate-to-start
navigate-to-end
navigate-previous
navigate-next
navigate-to
on-get-focus
on-lose-focus
display-initial-term
display-final-term
display-step
))
(define-interface director<%> ()
(add-deriv
new-stepper))

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

@ -1,6 +1,7 @@
#lang scheme/base
(require scheme/class
macro-debugger/util/class-iop
scheme/unit
scheme/list
scheme/match
@ -21,8 +22,10 @@
"../model/reductions.ss"
"../model/steps.ss"
"../util/notify.ss"
(prefix-in sb: "../syntax-browser/interfaces.ss")
"cursor.ss"
"debug-format.ss")
#;
(provide step-display%
step-display<%>)
@ -35,24 +38,6 @@
(define (prestep-term1 s) (state-term (protostep-s1 s)))
(define (poststep-term2 s) (state-term (protostep-s1 s)))
(define step-display<%>
(interface ()
;; add-syntax
add-syntax
;; add-step
add-step
;; add-error
add-error
;; add-final
add-final
;; add-internal-error
add-internal-error))
(define step-display%
(class* object% (step-display<%>)
@ -61,18 +46,18 @@
(super-new)
(define/public (add-internal-error part exn stx events)
(send sbview add-text
(send: sbview sb:syntax-browser<%> add-text
(if part
(format "Macro stepper error (~a)" part)
"Macro stepper error"))
(when (exn? exn)
(send sbview add-text " ")
(send sbview add-clickback "[details]"
(send: sbview sb:syntax-browser<%> add-text " ")
(send: sbview sb:syntax-browser<%> add-clickback "[details]"
(lambda _ (show-internal-error-details exn events))))
(send sbview add-text ". ")
(when stx (send sbview add-text "Original syntax:"))
(send sbview add-text "\n")
(when stx (send sbview add-syntax stx)))
(send: sbview sb:syntax-browser<%> add-text ". ")
(when stx (send: sbview sb:syntax-browser<%> add-text "Original syntax:"))
(send: sbview sb:syntax-browser<%> add-text "\n")
(when stx (send: sbview sb:syntax-browser<%> add-syntax stx)))
(define/private (show-internal-error-details exn events)
(case (message-box/custom "Macro stepper internal error"
@ -91,8 +76,9 @@
((3 #f) (void))))
(define/public (add-error exn)
(send sbview add-error-text (exn-message exn))
(send sbview add-text "\n"))
(send*: sbview sb:syntax-browser<%>
(add-error-text (exn-message exn))
(add-text "\n")))
(define/public (add-step step
#:binders binders
@ -110,7 +96,7 @@
#:binders [binders #f]
#:shift-table [shift-table #f]
#:definites [definites null])
(send sbview add-syntax stx
(send: sbview sb:syntax-browser<%> add-syntax stx
#:binder-table binders
#:shift-table shift-table
#:definites definites))
@ -120,11 +106,12 @@
#:shift-table [shift-table #f]
#:definites definites)
(when stx
(send sbview add-text "Expansion finished\n")
(send sbview add-syntax stx
(send*: sbview sb:syntax-browser<%>
(add-text "Expansion finished\n")
(add-syntax stx
#:binder-table binders
#:shift-table shift-table
#:definites definites))
#:definites definites)))
(when error
(add-error error)))
@ -133,17 +120,16 @@
(define state (protostep-s1 step))
(define lctx (state-lctx state))
(when (pair? lctx)
(send sbview add-text "\n")
(for-each (lambda (bf)
(send sbview add-text
(send: sbview sb:syntax-browser<%> add-text "\n")
(for ([bf (reverse lctx)])
(send: sbview sb:syntax-browser<%> add-text
"while executing macro transformer in:\n")
(insert-syntax/redex (bigframe-term bf)
(bigframe-foci bf)
binders
shift-table
(state-uses state)
(state-frontier state)))
(reverse lctx))))
(state-frontier state)))))
;; separator : Step -> void
(define/private (separator step)
@ -194,15 +180,15 @@
(define state (protostep-s1 step))
(show-state/redex state binders shift-table)
(separator step)
(send sbview add-error-text (exn-message (misstep-exn step)))
(send sbview add-text "\n")
(send*: sbview sb:syntax-browser<%>
(add-error-text (exn-message (misstep-exn step)))
(add-text "\n"))
(when (exn:fail:syntax? (misstep-exn step))
(for-each (lambda (e)
(send sbview add-syntax e
(for ([e (exn:fail:syntax-exprs (misstep-exn step))])
(send: sbview sb:syntax-browser<%> add-syntax e
#:binder-table binders
#:shift-table shift-table
#:definites (or (state-uses state) null)))
(exn:fail:syntax-exprs (misstep-exn step))))
#:definites (or (state-uses state) null))))
(show-lctx step binders shift-table))
;; insert-syntax/color
@ -210,7 +196,7 @@
definites frontier hi-color)
(define highlight-foci? (send config get-highlight-foci?))
(define highlight-frontier? (send config get-highlight-frontier?))
(send sbview add-syntax stx
(send: sbview sb:syntax-browser<%> add-syntax stx
#:definites (or definites null)
#:binder-table binders
#:shift-table shift-table
@ -233,29 +219,32 @@
;; insert-step-separator : string -> void
(define/private (insert-step-separator text)
(send sbview add-text "\n ")
(send sbview add-text
(send*: sbview sb:syntax-browser<%>
(add-text "\n ")
(add-text
(make-object image-snip%
(build-path (collection-path "icons")
"red-arrow.bmp")))
(send sbview add-text " ")
(send sbview add-text text)
(send sbview add-text "\n\n"))
(add-text " ")
(add-text text)
(add-text "\n\n")))
;; insert-as-separator : string -> void
(define/private (insert-as-separator text)
(send sbview add-text "\n ")
(send sbview add-text text)
(send sbview add-text "\n\n"))
(send*: sbview sb:syntax-browser<%>
(add-text "\n ")
(add-text text)
(add-text "\n\n")))
;; insert-step-separator/small : string -> void
(define/private (insert-step-separator/small text)
(send sbview add-text " ")
(send sbview add-text
(send*: sbview sb:syntax-browser<%>
(add-text " ")
(add-text
(make-object image-snip%
(build-path (collection-path "icons")
"red-arrow.bmp")))
(send sbview add-text " ")
(send sbview add-text text)
(send sbview add-text "\n\n"))
(add-text " ")
(add-text text)
(add-text "\n\n")))
))

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

@ -1,6 +1,7 @@
#lang scheme/base
(require scheme/class
macro-debugger/util/class-iop
scheme/unit
scheme/list
scheme/match
@ -14,6 +15,7 @@
"hiding-panel.ss"
"term-record.ss"
"step-display.ss"
(prefix-in sb: "../syntax-browser/interfaces.ss")
"../model/deriv.ss"
"../model/deriv-util.ss"
"../model/deriv-find.ss"
@ -29,10 +31,10 @@
;; macro-stepper-widget%
(define macro-stepper-widget%
(class* object% ()
(class* object% (widget<%>)
(init-field parent)
(init-field config)
(init-field director)
(init-field: (director director<%>))
;; Terms
@ -65,7 +67,7 @@
(define/public (add trec)
(set! all-terms (cons trec all-terms))
(let ([display-new-term? (cursor:at-end? terms)]
[invisible? (send trec get-deriv-hidden?)])
[invisible? (send: trec term-record<%> get-deriv-hidden?)])
(unless invisible?
(cursor:add-to-end! terms (list trec))
(trim-navigator)
@ -83,15 +85,16 @@
(define/public (show-in-new-frame)
(let ([term (focused-term)])
(when term
(let ([new-stepper (send director new-stepper '(no-new-traces))])
(send new-stepper add-deriv (send term get-raw-deriv))
(let ([new-stepper (send: director director<%> new-stepper '(no-new-traces))])
(send: new-stepper widget<%> add-deriv (send term get-raw-deriv))
(void)))))
;; duplicate-stepper : -> void
(define/public (duplicate-stepper)
(let ([new-stepper (send director new-stepper)])
(let ([new-stepper (send: director director<%> new-stepper)])
(for ([term (cursor->list terms)])
(send new-stepper add-deriv (send term get-raw-deriv)))))
(send: new-stepper widget<%> add-deriv
(send: term term-record<%> get-raw-deriv)))))
(define/public (get-config) config)
(define/public (get-controller) sbc)
@ -101,7 +104,7 @@
(define/public (get-macro-hiding-prefs) macro-hiding-prefs)
(define/public (reset-primary-partition)
(send sbc reset-primary-partition)
(send: sbc sb:controller<%> reset-primary-partition)
(update/preserve-view))
(define area (new vertical-panel% (parent parent)))
@ -126,16 +129,19 @@
(define warnings-area (new stepper-warnings% (parent area)))
(define sbview (new stepper-syntax-widget%
(define: sbview sb:syntax-browser<%>
(new stepper-syntax-widget%
(parent area)
(macro-stepper this)))
(define step-displayer (new step-display%
(define: step-displayer step-display<%>
(new step-display%
(config config)
(syntax-widget sbview)))
(define sbc (send sbview get-controller))
(define: sbc sb:controller<%>
(send sbview get-controller))
(define control-pane
(new vertical-panel% (parent area) (stretchable-height #f)))
(define macro-hiding-prefs
(define: macro-hiding-prefs hiding-prefs<%>
(new macro-hiding-prefs-widget%
(parent control-pane)
(stepper this)
@ -144,7 +150,7 @@
(send config listen-show-hiding-panel?
(lambda (show?) (show-macro-hiding-panel show?)))
(send sbc listen-selected-syntax
(lambda (stx) (send macro-hiding-prefs set-syntax stx)))
(lambda (stx) (send: macro-hiding-prefs hiding-prefs<%> set-syntax stx)))
(send config listen-highlight-foci?
(lambda (_) (update/preserve-view)))
(send config listen-highlight-frontier?
@ -231,36 +237,36 @@
(list navigator)))))
;; Navigation
#|
(define/public-final (at-start?)
(send (focused-term) at-start?))
(send: (focused-term) term-record<%> at-start?))
(define/public-final (at-end?)
(send (focused-term) at-end?))
(send: (focused-term) term-record<%> at-end?))
|#
(define/public-final (navigate-to-start)
(send (focused-term) navigate-to-start)
(send: (focused-term) term-record<%> navigate-to-start)
(update/save-position))
(define/public-final (navigate-to-end)
(send (focused-term) navigate-to-end)
(send: (focused-term) term-record<%> navigate-to-end)
(update/save-position))
(define/public-final (navigate-previous)
(send (focused-term) navigate-previous)
(send: (focused-term) term-record<%> navigate-previous)
(update/save-position))
(define/public-final (navigate-next)
(send (focused-term) navigate-next)
(send: (focused-term) term-record<%> navigate-next)
(update/save-position))
(define/public-final (navigate-to n)
(send (focused-term) navigate-to n)
(send: (focused-term) term-record<%> navigate-to n)
(update/save-position))
(define/public-final (navigate-up)
(when (focused-term)
(send (focused-term) on-lose-focus))
(send: (focused-term) term-record<%> on-lose-focus))
(cursor:move-prev terms)
(refresh/move))
(define/public-final (navigate-down)
(when (focused-term)
(send (focused-term) on-lose-focus))
(send: (focused-term) term-record<%> on-lose-focus))
(cursor:move-next terms)
(refresh/move))
@ -272,7 +278,7 @@
;; update/preserve-lines-view : -> void
(define/public (update/preserve-lines-view)
(define text (send sbview get-text))
(define text (send: sbview sb:syntax-browser<%> get-text))
(define start-box (box 0))
(define end-box (box 0))
(send text get-visible-line-range start-box end-box)
@ -285,7 +291,7 @@
;; update/preserve-view : -> void
(define/public (update/preserve-view)
(define text (send sbview get-text))
(define text (send: sbview sb:syntax-browser<%> get-text))
(define start-box (box 0))
(define end-box (box 0))
(send text get-visible-position-range start-box end-box)
@ -295,17 +301,17 @@
;; update : -> void
;; Updates the terms in the syntax browser to the current step
(define/private (update)
(define text (send sbview get-text))
(define text (send: sbview sb:syntax-browser<%> get-text))
(define position-of-interest 0)
(define multiple-terms? (> (length (cursor->list terms)) 1))
(send text begin-edit-sequence)
(send sbview erase-all)
(send: sbview sb:syntax-browser<%> erase-all)
(update:show-prefix)
(when multiple-terms? (send sbview add-separator))
(when multiple-terms? (send: sbview sb:syntax-browser<%> add-separator))
(set! position-of-interest (send text last-position))
(update:show-current-step)
(when multiple-terms? (send sbview add-separator))
(when multiple-terms? (send: sbview sb:syntax-browser<%> add-separator))
(update:show-suffix)
(send text end-edit-sequence)
(send text scroll-to-position
@ -319,35 +325,35 @@
;; update:show-prefix : -> void
(define/private (update:show-prefix)
;; Show the final terms from the cached synth'd derivs
(for-each (lambda (trec) (send trec display-final-term))
(for-each (lambda (trec) (send: trec term-record<%> display-final-term))
(cursor:prefix->list terms)))
;; update:show-current-step : -> void
(define/private (update:show-current-step)
(when (focused-term)
(send (focused-term) display-step)))
(send: (focused-term) term-record<%> display-step)))
;; update:show-suffix : -> void
(define/private (update:show-suffix)
(let ([suffix0 (cursor:suffix->list terms)])
(when (pair? suffix0)
(for-each (lambda (trec)
(send trec display-initial-term))
(send: trec term-record<%> display-initial-term))
(cdr suffix0)))))
;; update-nav-index : -> void
(define/private (update-nav-index)
(define term (focused-term))
(set-current-step-index
(and term (send term get-step-index))))
(and term (send: term term-record<%> get-step-index))))
;; enable/disable-buttons : -> void
(define/private (enable/disable-buttons)
(define term (focused-term))
(send nav:start enable (and term (send term has-prev?)))
(send nav:previous enable (and term (send term has-prev?)))
(send nav:next enable (and term (send term has-next?)))
(send nav:end enable (and term (send term has-next?)))
(send nav:start enable (and term (send: term term-record<%> has-prev?)))
(send nav:previous enable (and term (send: term term-record<%> has-prev?)))
(send nav:next enable (and term (send: term term-record<%> has-next?)))
(send nav:end enable (and term (send: term term-record<%> has-next?)))
(send nav:text enable (and term #t))
(send nav:up enable (cursor:has-prev? terms))
(send nav:down enable (cursor:has-next? terms)))
@ -357,14 +363,14 @@
;; refresh/resynth : -> void
;; Macro hiding policy has changed; invalidate cached parts of trec
(define/public (refresh/resynth)
(for-each (lambda (trec) (send trec invalidate-synth!))
(for-each (lambda (trec) (send: trec term-record<%> invalidate-synth!))
(cursor->list terms))
(refresh))
;; refresh/re-reduce : -> void
;; Reduction config has changed; invalidate cached parts of trec
(define/private (refresh/re-reduce)
(for-each (lambda (trec) (send trec invalidate-steps!))
(for-each (lambda (trec) (send: trec term-record<%> invalidate-steps!))
(cursor->list terms))
(refresh))
@ -377,47 +383,15 @@
(define/public (refresh)
(send warnings-area clear)
(when (focused-term)
(send (focused-term) on-get-focus))
(send: (focused-term) term-record<%> on-get-focus))
(update))
#|
;; delayed-recache-errors : (list-of (cons exn string))
(define delayed-recache-errors null)
;; handle-recache-error : exception string -> void
(define/private (handle-recache-error exn part)
(if (send config get-debug-catch-errors?)
(begin
(set! delayed-recache-errors
(cons (cons exn part) delayed-recache-errors))
(queue-callback
(lambda ()
(when (pair? delayed-recache-errors)
(message-box
"Error"
(string-append
"Internal errors in macro stepper:\n"
(if (memq 'macro-hiding (map cdr delayed-recache-errors))
(string-append
"Macro hiding failed on one or more terms. "
"The macro stepper is showing the terms "
"with macro hiding disabled.\n")
"")
(if (memq 'reductions (map cdr delayed-recache-errors))
(string-append
"The macro stepper failed to compute the reduction sequence "
"for one or more terms.\n")
"")))
(set! delayed-recache-errors null)))))
(raise exn)))
|#
(define/private (foci x) (if (list? x) x (list x)))
;; Hiding policy
(define/public (get-show-macro?)
(send macro-hiding-prefs get-policy))
(send: macro-hiding-prefs hiding-prefs<%> get-policy))
;; Derivation pre-processing

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

@ -1,6 +1,6 @@
#lang scheme/base
(require scheme/class
macro-debugger/util/class-iop
scheme/unit
scheme/list
scheme/match
@ -30,11 +30,12 @@
;; TermRecords
(define term-record%
(class object%
(init-field stepper)
(class* object% (term-record<%>)
(init-field: (stepper widget<%>))
(define config (send stepper get-config))
(define displayer (send stepper get-step-displayer))
(define: displayer step-display<%>
(send: stepper widget<%> get-step-displayer))
;; Data
@ -128,7 +129,7 @@
(unless (or deriv deriv-hidden?)
(recache-raw-deriv!)
(when raw-deriv
(let ([process (send stepper get-preprocess-deriv)])
(let ([process (send: stepper widget<%> get-preprocess-deriv)])
(let ([d (process raw-deriv)])
(when (not d)
(set! deriv-hidden? #t))
@ -151,7 +152,7 @@
(unless (or raw-steps raw-steps-oops)
(recache-synth!)
(when deriv
(let ([show-macro? (or (send stepper get-show-macro?)
(let ([show-macro? (or (send: stepper widget<%> get-show-macro?)
(lambda (id) #t))])
(with-handlers ([(lambda (e) #t)
(lambda (e)
@ -274,18 +275,18 @@
;; display-initial-term : -> void
(define/public (display-initial-term)
(send displayer add-syntax (wderiv-e1 deriv)))
(send: displayer step-display<%> add-syntax (wderiv-e1 deriv)))
;; display-final-term : -> void
(define/public (display-final-term)
(recache-steps!)
(cond [(syntax? raw-steps-estx)
(send displayer add-syntax raw-steps-estx
(send: displayer step-display<%> add-syntax raw-steps-estx
#:binders binders
#:shift-table shift-table
#:definites raw-steps-definites)]
[(exn? raw-steps-exn)
(send displayer add-error raw-steps-exn)]
(send: displayer step-display<%> add-error raw-steps-exn)]
[else (display-oops #f)]))
;; display-step : -> void
@ -294,10 +295,10 @@
(cond [steps
(let ([step (cursor:next steps)])
(if step
(send displayer add-step step
(send: displayer step-display<%> add-step step
#:binders binders
#:shift-table shift-table)
(send displayer add-final raw-steps-estx raw-steps-exn
(send: displayer step-display<%> add-final raw-steps-estx raw-steps-exn
#:binders binders
#:shift-table shift-table
#:definites raw-steps-definites)))]
@ -306,12 +307,12 @@
;; display-oops : boolean -> void
(define/private (display-oops show-syntax?)
(cond [raw-steps-oops
(send displayer add-internal-error
(send: displayer step-display<%> add-internal-error
"steps" raw-steps-oops
(and show-syntax? (wderiv-e1 deriv))
events)]
[raw-deriv-oops
(send displayer add-internal-error
(send: displayer step-display<%> add-internal-error
"derivation" raw-deriv-oops #f events)]
[else
(error 'term-record::display-oops "internal error")]))

40
collects/macro-debugger/view/view.ss
View File

@ -1,6 +1,7 @@
#lang scheme/base
(require scheme/class
macro-debugger/util/class-iop
scheme/pretty
scheme/gui
framework/framework
@ -13,7 +14,7 @@
go)
(define macro-stepper-director%
(class object%
(class* object% (director<%>)
(define stepper-frames (make-hasheq))
;; Flags is a subset(list) of '(no-obsolete no-new-traces)
@ -27,23 +28,23 @@
(hash-for-each stepper-frames
(lambda (stepper-frame flags)
(unless (memq 'no-obsolete flags)
(send stepper-frame add-obsoleted-warning)))))
(send: stepper-frame stepper-frame<%> add-obsoleted-warning)))))
(define/public (add-trace events)
(hash-for-each stepper-frames
(lambda (stepper-frame flags)
(unless (memq 'no-new-traces flags)
(send (send stepper-frame get-widget)
(send: (send: stepper-frame stepper-frame<%> get-widget) widget<%>
add-trace events)))))
(define/public (add-deriv deriv)
(hash-for-each stepper-frames
(lambda (stepper-frame flags)
(unless (memq 'no-new-traces flags)
(send (send stepper-frame get-widget)
(send: (send: stepper-frame stepper-frame<%> get-widget) widget<%>
add-deriv deriv)))))
(define/public (new-stepper [flags '()])
(define stepper-frame (new-stepper-frame))
(define stepper (send stepper-frame get-widget))
(define stepper (send: stepper-frame stepper-frame<%> get-widget))
(send stepper-frame show #t)
(add-stepper! stepper-frame flags)
stepper)
@ -64,31 +65,6 @@
(define (go stx)
(define director (new macro-stepper-director%))
(define stepper (send director new-stepper))
(send director add-deriv (trace stx))
(define stepper (send: director director<%> new-stepper))
(send: director director<%> add-deriv (trace stx))
(void))
#|
(define (make-macro-stepper)
(let ([f (new macro-stepper-frame%
(config (new macro-stepper-config/prefs%)))])
(send f show #t)
(send f get-widget)))
(define (go stx)
(let ([stepper (make-macro-stepper)])
(send stepper add-deriv (trace stx))
stepper))
(define (go/deriv deriv)
(let* ([f (new macro-stepper-frame%)]
[w (send f get-widget)])
(send w add-deriv deriv)
(send f show #t)
w))
(define (go/trace events)
(let* ([w (make-macro-stepper)])
(send w add-trace events)
w))
|#

79
collects/redex/private/size-snip.ss
View File

@ -1,12 +1,13 @@
(module size-snip mzscheme
(require (lib "mred.ss" "mred")
(lib "class.ss")
(lib "pretty.ss")
(lib "framework.ss" "framework")
#lang scheme/base
(require scheme/gui/base
scheme/class
framework
scheme/pretty
"matcher.ss")
(provide reflowing-snip<%>
size-editor-snip%
size-text%
default-pretty-printer
initial-char-width
resizing-pasteboard-mixin)
@ -36,7 +37,6 @@
(define (resizing-pasteboard-mixin pb%)
(class pb%
(init-field shrink-down?)
(define/augment (on-interactive-resize snip)
(when (is-a? snip reflowing-snip<%>)
@ -55,26 +55,10 @@
(inherit get-snip-location
begin-edit-sequence
end-edit-sequence)
end-edit-sequence
find-first-snip
get-dc)
(define/augment (on-insert snip before x y)
(begin-edit-sequence)
(inner (void) on-insert snip before x y))
(define/augment (after-insert snip before x y)
(inner (void) after-insert snip before x y)
(when (is-a? snip size-editor-snip%)
(let ([cw (send snip get-char-width)]
[woc (send snip get-width-of-char)]
[bt (box 0)]
[bb (box 0)])
(get-snip-location snip #f bt #f)
(get-snip-location snip #f bb #t)
(send snip resize
(* cw woc)
(- (unbox bb) (unbox bt)))
(when shrink-down?
(send snip shrink-down))))
(end-edit-sequence))
(super-new)))
(define size-editor-snip%
@ -86,6 +70,7 @@
(if (procedure-arity-includes? pp 4)
pp
(lambda (v port w spec) (display (pp v) port))))
(inherit get-admin)
(define/public (get-expr) expr)
(define/public (get-char-width) char-width)
@ -106,29 +91,6 @@
(format-expr)
(on-width-changed char-width))))))
;; final
(define/pubment (shrink-down)
(let ([ed (get-editor)]
[bx (box 0)]
[by (box 0)])
(let ([max-line-width
(let loop ([p 0]
[max-w 0])
(cond
[(<= p (send ed last-paragraph))
(send ed position-location
(send ed paragraph-end-position p)
bx by #t)
(let ([this-w (unbox bx)])
(loop (+ p 1)
(max this-w max-w)))]
[else max-w]))])
(send ed position-location (send ed last-position) bx by #f)
(let-values ([(hms vms) (get-margin-space)])
(super resize
(+ max-line-width hms)
(+ (unbox by) vms))))))
(inherit get-margin)
(define/public (get-snip-width)
(let ([admin (get-admin)])
@ -148,20 +110,23 @@
[bt (box 0)]
[bb (box 0)])
(get-margin bl bt br bb)
(values (+ (unbox bl) (unbox br) 2) ;; not sure what the 2 is for. Maybe caret space?
(values (+ (unbox bl) (unbox br) 6) ;; not sure what the 2 is for. Maybe caret space?
(+ (unbox bt) (unbox bb)))))
;; get-width-of-char : -> number or false
;; depends on `dc' field
(define/public (get-width-of-char)
(let ([ed (get-editor)])
(and ed
(let ([dc (send ed get-dc)]
[std-style (send (editor:get-standard-style-list) find-named-style "Standard")])
(let ([std-style (send (editor:get-standard-style-list) find-named-style "Standard")]
[dc (send ed get-dc)])
(and dc
(let-values ([(tw th _2 _3) (send dc get-text-extent "w"
(and std-style
(send std-style get-font)))])
tw))))))
;; depends on `dc' field
(define/public (get-height-of-char)
(let ([ed (get-editor)])
(and ed
@ -193,4 +158,14 @@
(super-new)
(inherit use-style-background)
(use-style-background #t))))
(use-style-background #t)))
(define size-text%
(scheme:set-mode-mixin
(scheme:text-mixin
(color:text-mixin
(text:autocomplete-mixin
(mode:host-text-mixin
(editor:standard-style-list-mixin
text:basic%)))))))

34
collects/redex/private/stepper.ss
View File

@ -77,7 +77,6 @@ todo:
(define upper-hp (new horizontal-panel% [parent dp]))
(define lower-hp (new horizontal-panel% [alignment '(center center)] [parent f] [stretchable-height #f]))
(define pb (new columnar-pasteboard%
[shrink-down? #f]
[moved (λ (a b c d)
(when (procedure? moved)
(moved a b c d)))]))
@ -801,7 +800,7 @@ todo:
flat-to-remove)
(for-each (λ (x) (insert x)) flat-to-insert)))
(inherit get-admin move-to resize)
(inherit get-admin move-to)
(define/public (update-heights)
(let ([admin (get-admin)])
(let-values ([(w h) (get-view-size)])
@ -816,9 +815,11 @@ todo:
;; if there is only a single snip in the column, we let it be as long as it wants to be.
(let* ([snip (car column)]
[sw (get-snip-width snip)]
[sh (get-snip-max-height snip)])
[sh (get-snip-max-height snip)]
[new-height (- (max h sh) (get-border-height snip))])
(move-to snip x 0)
(resize snip sw (max h sh))
(send snip set-min-height new-height)
(send snip set-max-height new-height)
(loop (cdr columns) (+ x sw)))]
[else
;; otherwise, we make all of the snips fit into the visible area
@ -838,16 +839,39 @@ todo:
0
1))])
(move-to snip x y)
(resize snip sw h)
(let ([border-height (get-border-height snip)])
(send snip set-min-height (- h border-height))
(send snip set-max-height (- h border-height)))
(loop (cdr snips)
(if (zero? extra-space)
0
(- extra-space 1))
(+ y h)
(max widest sw)))]))])
(for-each (λ (snip)
(let ([border-width (get-border-width snip)])
(send snip set-min-width (- widest border-width))
(send snip set-max-width (- widest border-width))))
column)
(loop (cdr columns)
(+ x widest)))]))])))))
(define/private (get-border-height snip)
(let ([lb (box 0)]
[tb (box 0)]
[rb (box 0)]
[bb (box 0)])
(send snip get-margin lb tb bb rb)
(+ (unbox bb) (unbox tb))))
(define/private (get-border-width snip)
(let ([lb (box 0)]
[tb (box 0)]
[rb (box 0)]
[bb (box 0)])
(send snip get-margin lb tb bb rb)
(+ (unbox lb) (unbox rb))))
(inherit get-snip-location)
(define/public (get-snip-width snip)
(let ([lb (box 0)]

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

@ -1,15 +1,17 @@
#lang scheme/base
;; should cache the count of new snips -- dont
;; use `count-snips'; use something associated with the
;; equal hash-table
#lang scheme
(require mrlib/graph
"reduction-semantics.ss"
"matcher.ss"
"size-snip.ss"
"dot.ss"
scheme/gui/base
scheme/class
scheme/file
framework)
(preferences:set-default 'plt-reducer:show-bottom #t boolean?)
@ -139,12 +141,83 @@
#:scheme-colors? scheme-colors?
#:colors colors
#:layout layout)])
(print-to-ps graph-pb filename)))
(define (print-to-ps graph-pb filename)
(let ([admin (send graph-pb get-admin)]
[printing-admin (new printing-editor-admin%)])
(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 re-run-layout)
(let ([ps-setup (make-object ps-setup%)])
(send ps-setup copy-from (current-ps-setup))
(send ps-setup set-file filename)
(send ps-setup set-mode 'file)
(parameterize ([current-ps-setup ps-setup])
(send graph-pb print #f #f 'postscript #f #f #t)))))
(send graph-pb print #f #f 'postscript #f #f #t))))
(λ ()
(send graph-pb set-admin admin)
(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 re-run-layout)))))
(define printing-editor-admin%
(class editor-admin%
(define temp-file (make-temporary-file "redex-size-snip-~a"))
(define ps-dc
(let ([ps-setup (make-object ps-setup%)])
(send ps-setup copy-from (current-ps-setup))
(send ps-setup set-file temp-file)
(parameterize ([current-ps-setup ps-setup])
(make-object post-script-dc% #f #f #f #t))))
(send ps-dc start-doc "fake dc")
(send ps-dc start-page)
(super-new)
(define/public (shutdown)
(send ps-dc end-page)
(send ps-dc end-doc)
(delete-file temp-file))
(define/override (get-dc [x #f] [y #f])
(super get-dc x y)
ps-dc)
(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 (box? w) (set-box! w 500))
(when (box? h) (set-box! h 500)))
;; the following methods are not overridden; they all default to doing nothing.
;; grab-caret
;; modified
;; needs-update
;; popup-menu
;; refresh-delayed?
;; resized
;; scroll-to
;; update-cursor
))
(define (traces reductions pre-exprs
#:multiple? [multiple? #f]
@ -157,7 +230,7 @@
(define exprs (if multiple? pre-exprs (list pre-exprs)))
(define main-eventspace (current-eventspace))
(define saved-parameterization (current-parameterization))
(define graph-pb (new graph-pasteboard% [shrink-down? #t]))
(define graph-pb (new graph-pasteboard% [layout layout]))
(define f (instantiate red-sem-frame% ()
(label "PLT Redex Reduction Graph")
(style '(toolbar-button))
@ -275,7 +348,7 @@
(let loop ([snip (send graph-pb find-first-snip)])
(when snip
(when (is-a? snip reflowing-snip<%>)
(send snip shrink-down))
(send snip reflow-program))
(loop (send snip next))))))
;; fill-out : (listof X) (listof X) -> (listof X)
@ -338,7 +411,7 @@
(set! col (+ x-spacing (find-rightmost-x graph-pb))))
(begin0
(insert-into col y graph-pb new-snips)
(layout (hash-map snip-cache (lambda (x y) (send y get-term-node))))
(send graph-pb re-run-layout)
(send graph-pb end-edit-sequence)
(send status-message set-label
(string-append (term-count (count-snips)) "...")))))])
@ -469,7 +542,7 @@
null)))
(out-of-dot-state) ;; make sure the state is initialized right
(insert-into init-rightmost-x 0 graph-pb frontier)
(layout (map (lambda (y) (send y get-term-node)) frontier))
(send graph-pb re-run-layout)
(set-font-size (initial-font-size))
(cond
[no-show-frame?
@ -507,6 +580,10 @@
(define graph-pasteboard%
(class (resizing-pasteboard-mixin
(graph-pasteboard-mixin pasteboard%))
(init-field layout) ;; (-> (listof term-node) void)
;; this is the function supplied by the :#layout argument to traces or traces/ps
(define dot-callback #f)
(define/public (set-dot-callback cb) (set! dot-callback cb))
(define/override (draw-edges dc left top right bottom dx dy)
@ -521,6 +598,17 @@
(define/augment (can-interactive-move? evt) mobile?)
(define/augment (can-interactive-resize? evt) mobile?)
(inherit find-first-snip)
(define/public (re-run-layout)
(layout
(let loop ([snip (find-first-snip)])
(cond
[(not snip) '()]
[(is-a? snip reflowing-snip<%>)
(cons (send snip get-term-node)
(loop (send snip next)))]
[else (loop (send snip next))]))))
(super-new)))
(define graph-editor-snip%
@ -578,7 +666,7 @@
(super-new)))
(define program-text%
(class scheme:text%
(class size-text%
(define bad-color #f)
(define/public (set-bad color) (set! bad-color color))
@ -688,6 +776,7 @@
(pp pp)
(expr expr))])
(send text set-autowrap-bitmap #f)
(send text set-max-width 'none)
(send text freeze-colorer)
(send text stop-colorer (not scheme-colors?))
(send es format-expr)

28
collects/redex/redex.scrbl
View File

@ -213,12 +213,13 @@ looking for a decomposition, it ignores any holes found in
that @|pattern|.
}
@item{The @tt{(@defpattech[side-condition] @ttpattern guard)} @pattern matches
what the embedded @pattern matches, and then the guard expression is
evaluated. If it returns @scheme[#f], the @pattern fails to match, and if it
returns anything else, the @pattern matches. In addition, any
occurrences of `name' in the @pattern are bound using @scheme[term-let]
in the guard.
@item{The @tt{(@defpattech[side-condition] @ttpattern guard)} @pattern
matches what the embedded @pattern matches, and then the guard
expression is evaluated. If it returns @scheme[#f], the @pattern fails
to match, and if it returns anything else, the @pattern matches. Any
occurrences of `name' in the @pattern (including those implicitly
there via @tt{_} pattersn) are bound using @scheme[term-let] in the
guard.
}
@item{The @tt{(@defpattech[cross] symbol)} @pattern is used for the compatible
@ -1095,7 +1096,7 @@ pattern does not match the @scheme[pattern].}
[relation reduction-relation?]
[property (-> any/c any/c)]
[#:attempts attempts natural-number/c 100])
(or/c true/c void?)]{
void?]{
Tests a @scheme[relation] as follows: for each case of @scheme[relation],
@scheme[check-reduction-relation] generates @scheme[attempts] random
terms that match that case's left-hand side and applies @scheme[property]
@ -1367,9 +1368,18 @@ the stepper and traces.
@defparam[dark-pen-color color (or/c string? (is-a?/c color<%>))]{}
@defparam[dark-brush-color color (or/c string? (is-a?/c color<%>))]{}
@defparam[light-pen-color color (or/c string? (is-a?/c color<%>))]{}
@defparam[light-brush-color color (or/c string? (is-a?/c color<%>))]{}]]{
@defparam[light-brush-color color (or/c string? (is-a?/c color<%>))]{}
@defparam[dark-text-color color (or/c string? (is-a?/c color<%>))]{}
@defparam[light-text-color color (or/c string? (is-a?/c color<%>))]{}]]{
These four parameters control the color of the edges in the graph.
These six parameters control the color of the edges in the graph.
The dark colors are used when the mouse is over one of the nodes that
is connected to this edge. The light colors are used when it isn't.
The pen colors control the color of the line. The brush colors control
the color used to fill the arrowhead and the text colors control the
color used to draw the label on the edge.
}
@defproc[(default-pretty-printer [v any] [port output-port] [width number] [text (is-a?/c text%)]) void?]{

2
collects/repos-time-stamp/stamp.ss
View File

@ -1 +1 @@
#lang scheme/base (provide stamp) (define stamp "13jan2009")
#lang scheme/base (provide stamp) (define stamp "14jan2009")

1
collects/scheme/private/map.ss
View File

@ -127,4 +127,3 @@
(ormap f l1 l2))]
[(f . args) (apply ormap f args)])])
ormap)))

4
collects/scribblings/gui/blurbs.ss
View File

@ -267,8 +267,8 @@ information@|details|, even if the editor currently has delayed refreshing (see
(define (edsnipsize a b c)
@elem{An @scheme[editor-snip%] normally stretches to wrap around the size
of the editor it contains. This method #1 of the snip
(and if the editor is #2, #3).})
of the editor it contains. This method @|a| of the snip
(and if the editor is @|b|, @|c|).})
(define (edsnipmax n)
(edsnipsize @elem{limits the @|n|}
@elem{larger}

1
collects/tests/typed-scheme/succeed/hw01.scm
View File

@ -108,4 +108,3 @@
(= 0 (list-length '()))
(= 2 (list-length '(1 2)))
(= 3 (list-length '(1 2 (1 2 3 4))))

1
collects/typed/net/base64.ss
View File

@ -10,4 +10,3 @@
[base64-decode (Bytes -> Bytes)])
(provide base64-encode-stream base64-decode-stream base64-encode base64-decode)

2
collects/typed/net/pop3.ss
View File

@ -40,5 +40,3 @@
(require-typed-struct/provide (malformed-server-response pop3)
([communicator : communicator]) net/pop3)

1
collects/typed/net/qp.ss
View File

@ -7,4 +7,3 @@
[qp-decode ( String -> String )]
[qp-encode-stream (case-lambda (Input-Port Output-Port -> Void) (Input-Port Output-Port String -> Void) )]
[qp-decode-stream ( Input-Port Output-Port -> Void )])

1
collects/typed/net/sendmail.ss
View File

@ -9,4 +9,3 @@
(String String (Listof String) (Listof String) (Listof String) (Listof String) String * -> Output-Port)])
(provide send-mail-message/port send-mail-message #;no-mail-recipients)

1
collects/typed/net/sendurl.ss
View File

@ -6,4 +6,3 @@
[external-browser (-> (U Symbol #f (Pair String String)))])
(provide send-url unix-browser-list browser-preference? external-browser)

2
collects/typed/net/smtp.ss
View File

@ -7,5 +7,3 @@
[smtp-sending-end-of-message (Parameter (-> Any))])
(provide smtp-send-message smtp-sending-end-of-message)

1
collects/typed/net/uri-codec.ss
View File

@ -12,4 +12,3 @@
[alist->form-urlencoded ( (Listof (cons Symbol String)) -> String )]
[form-urlencoded->alist ( String -> (Listof (cons Symbol String)) )]
[current-alist-separator-mode (Parameter Symbol)])

2
src/mzscheme/src/string.c
View File

@ -968,7 +968,7 @@ void scheme_get_substring_indices(const char *name, Scheme_Object *str,
if (SCHEME_VECTORP(str))
len = SCHEME_VEC_SIZE(str);
if (SCHEME_CHAR_STRINGP(str))
else if (SCHEME_CHAR_STRINGP(str))
len = SCHEME_CHAR_STRTAG_VAL(str);
else
len = SCHEME_BYTE_STRTAG_VAL(str);