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

2
collects/2htdp/universe.ss
View File

@ -309,4 +309,4 @@
(on-new nu)
(on-msg process)
#;
(on-tick (lambda (u x) (printf "hello!\n") (list u)) 1)))
(on-tick (lambda (u x) (printf "hello!\n") (list u)) 1)))

2
collects/drscheme/private/insert-large-letters.ss
View File

@ -195,4 +195,4 @@
(send bdc set-bitmap #f)
bitmap)
;(make-large-letters-dialog ";" #\; #f)
;(make-large-letters-dialog ";" #\; #f)

2
collects/framework/private/comment-box.ss
View File

@ -122,4 +122,4 @@
(make-special-comment "comment"))
(super-instantiate ())
(inherit set-snipclass)
(set-snipclass snipclass))))
(set-snipclass snipclass))))

2
collects/framework/private/search.ss
View File

@ -96,4 +96,4 @@
(if (not embedded-pos)
(next-loop)
(values embedded embedded-pos)))]
[else (next-loop)])))))))
[else (next-loop)])))))))

2
collects/framework/private/sig.ss
View File

@ -465,4 +465,4 @@
(open (prefix frame: frame^))
(open (prefix handler: handler^))
(open (prefix scheme: scheme^))
(open (prefix main: main^))))
(open (prefix main: main^))))

2
collects/games/chat-noir/info.ss
View File

@ -3,4 +3,4 @@
(define game "chat-noir-unit.ss")
(define game-set "Puzzle Games")
(define compile-omit-files '("chat-noir.ss"))
(define name "Chat Noir")
(define name "Chat Noir")

2
collects/htdp/Test/hangman-error.ss
View File

@ -11,4 +11,4 @@
(start 200 200)
(check-error (hangman-list reveal-list draw-next-part)
"draw-next-part: result of type <boolean> expected, given: #<void>")
"draw-next-part: result of type <boolean> expected, given: #<void>")

2
collects/macro-debugger/model/hiding-policies.ss
View File

@ -437,4 +437,4 @@
(define (lib-module-path? mp)
(or (symbol? mp)
(and (pair? mp) (memq (car mp) '(lib planet)))))
|#
|#

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

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

57
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<%>
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=?))
(define-interface controller<%> (displays-manager<%>
selection-manager<%>
mark-manager<%>
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)

14
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 ...))
#'(define-interface/dynamic name
(let ([name (interface () mname ...)]) name)
(mname ...))]))
[(_ 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 (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

25
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
(lambda (stx)
(enable/disable-hide/show (identifier? stx))))))
(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)))))

36
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,23 +136,24 @@
(parent id-menu)
(callback
(lambda _
(send controller set-identifier=? p))))])
(send controller listen-identifier=?
(lambda (name+func)
(send this-choice check
(eq? (car name+func) (car p)))))))
(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)))))))
(sb:identifier=-choices)))
(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?
))
(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
))
;; 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 director<%> ()
(add-deriv
new-stepper))

161
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
(if part
(format "Macro stepper error (~a)" part)
"Macro stepper error"))
(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]"
(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 " ")
(send: sbview sb:syntax-browser<%> add-clickback "[details]"
(lambda _ (show-internal-error-details exn events))))
(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,21 +96,22 @@
#:binders [binders #f]
#:shift-table [shift-table #f]
#:definites [definites null])
(send sbview add-syntax stx
#:binder-table binders
#:shift-table shift-table
#:definites definites))
(send: sbview sb:syntax-browser<%> add-syntax stx
#:binder-table binders
#:shift-table shift-table
#:definites definites))
(define/public (add-final stx error
#:binders binders
#:shift-table [shift-table #f]
#:definites definites)
(when stx
(send sbview add-text "Expansion finished\n")
(send sbview add-syntax stx
#:binder-table binders
#:shift-table shift-table
#:definites definites))
(send*: sbview sb:syntax-browser<%>
(add-text "Expansion finished\n")
(add-syntax stx
#:binder-table binders
#:shift-table shift-table
#: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
"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))))
(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)))))
;; 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
#:binder-table binders
#:shift-table shift-table
#:definites (or (state-uses state) null)))
(exn:fail:syntax-exprs (misstep-exn step))))
(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))))
(show-lctx step binders shift-table))
;; insert-syntax/color
@ -210,14 +196,14 @@
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
#:definites (or definites null)
#:binder-table binders
#:shift-table shift-table
#:hi-colors (list hi-color
"WhiteSmoke")
#:hi-stxss (list (if highlight-foci? foci null)
(if highlight-frontier? frontier null))))
(send: sbview sb:syntax-browser<%> add-syntax stx
#:definites (or definites null)
#:binder-table binders
#:shift-table shift-table
#:hi-colors (list hi-color
"WhiteSmoke")
#:hi-stxss (list (if highlight-foci? foci null)
(if highlight-frontier? frontier null))))
;; insert-syntax/redex
(define/private (insert-syntax/redex stx foci binders 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
(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"))
(send*: sbview sb:syntax-browser<%>
(add-text "\n ")
(add-text
(make-object image-snip%
(build-path (collection-path "icons")
"red-arrow.bmp")))
(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
(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"))
(send*: sbview sb:syntax-browser<%>
(add-text " ")
(add-text
(make-object image-snip%
(build-path (collection-path "icons")
"red-arrow.bmp")))
(add-text " ")
(add-text text)
(add-text "\n\n")))
))

130
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%
(parent area)
(macro-stepper this)))
(define step-displayer (new step-display%
(config config)
(syntax-widget sbview)))
(define sbc (send sbview get-controller))
(define: sbview sb:syntax-browser<%>
(new stepper-syntax-widget%
(parent area)
(macro-stepper this)))
(define: step-displayer step-display<%>
(new step-display%
(config config)
(syntax-widget sbview)))
(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

51
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
#:binders binders
#:shift-table shift-table
#:definites raw-steps-definites)]
(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,25 +295,25 @@
(cond [steps
(let ([step (cursor:next steps)])
(if step
(send displayer add-step step
#:binders binders
#:shift-table shift-table)
(send displayer add-final raw-steps-estx raw-steps-exn
#:binders binders
#:shift-table shift-table
#:definites raw-steps-definites)))]
(send: displayer step-display<%> add-step step
#:binders binders
#:shift-table shift-table)
(send: displayer step-display<%> add-final raw-steps-estx raw-steps-exn
#:binders binders
#:shift-table shift-table
#:definites raw-steps-definites)))]
[else (display-oops #t)]))
;; display-oops : boolean -> void
(define/private (display-oops show-syntax?)
(cond [raw-steps-oops
(send displayer add-internal-error
"steps" raw-steps-oops
(and show-syntax? (wderiv-e1 deriv))
events)]
(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
"derivation" raw-deriv-oops #f events)]
(send: displayer step-display<%> add-internal-error
"derivation" raw-deriv-oops #f events)]
[else
(error 'term-record::display-oops "internal error")]))
))

44
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)
add-trace events)))))
(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)
add-deriv deriv)))))
(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))
|#

2
collects/mrlib/close-icon.ss
View File

@ -118,4 +118,4 @@
(define f (new frame% [label "test"]))
(define c (new close-icon% [parent f] [callback (λ () (printf "hi\n"))]))
(define gb (new grow-box-spacer-pane% [parent f]))
(send f show #t))
(send f show #t))

2
collects/mzlib/contract.ss
View File

@ -85,4 +85,4 @@
(define (flat-contract/predicate? pred)
(or (flat-contract? pred)
(and (procedure? pred)
(procedure-arity-includes? pred 1))))
(procedure-arity-includes? pred 1))))

2
collects/mzlib/scribblings/trace.scrbl
View File

@ -78,4 +78,4 @@ traced call. It receives the name of the function, the function's
ordinary arguments, its keywords, the values of the keywords, and a
number indicating the depth of the call.
}
}

2
collects/net/scribblings/ssl-tcp-unit.scrbl
View File

@ -53,4 +53,4 @@ connections:
trusted root certificates; @scheme[#f] disables verification of
peer server certificates}
]}
]}

2
collects/plot/plot.scrbl
View File

@ -668,4 +668,4 @@ Returns the altitude (in degrees) from which the 3-D box is viewed.}
Returns the azimuthal angle.}
}
}

2
collects/profj/scribblings/advanced.scrbl
View File

@ -611,4 +611,4 @@ with their values specified by the ArrayInit.
@item{@(scheme false)}
}
}

2
collects/profj/scribblings/beginner.scrbl
View File

@ -252,4 +252,4 @@ The initialization statements pass the value provided to the constructor to the
}
@item{@(scheme true)}
@item{@(scheme false)}
}
}

2
collects/profj/scribblings/intermediate-access.scrbl
View File

@ -421,4 +421,4 @@ us unique. Each constructor may set its own @elemref['(inta "mods")]{access}. A
@item{@(scheme false)}
}
}

2
collects/profj/scribblings/intermediate.scrbl
View File

@ -400,4 +400,4 @@ parameters, then the first statement in the constructor must be a @elemref['(int
@item{@(scheme false)}
}
}

2
collects/redex/examples/beginner.ss
View File

@ -920,4 +920,4 @@ reflects the (broken) spec).
;; timing test
#;
(time (run-tests)
(run-big-test))
(run-big-test))

2
collects/redex/examples/semaphores.ss
View File

@ -163,4 +163,4 @@ semaphores make things much more predictable...
(semaphore-post (semaphore x)))
(begin (semaphore-wait (semaphore x))
(set! y (cons 2 y))
(semaphore-post (semaphore x))))))
(semaphore-post (semaphore x))))))

2
collects/redex/examples/subject-reduction.ss
View File

@ -105,4 +105,4 @@
(define (show term)
(traces reductions term #:pred (pred term)))
(show '((lambda (x (num -> num)) 1) ((lambda (x (num -> num)) x) (lambda (x num) x))))
(show '((lambda (x (num -> num)) 1) ((lambda (x (num -> num)) x) (lambda (x num) x))))

2
collects/redex/examples/subst.ss
View File

@ -68,4 +68,4 @@
(term (λ (z1 x1) (λ (x) z))))
(test-equal (term (subst (x 1 (λ (x x) x))))
(term (λ (x x) x)))
(test-results))
(test-results))

2
collects/redex/gui.ss
View File

@ -85,4 +85,4 @@
[initial-char-width (parameter/c number?)])
(provide reduction-steps-cutoff
default-pretty-printer)
default-pretty-printer)

2
collects/redex/main.ss
View File

@ -5,4 +5,4 @@
(provide (all-from-out "reduction-semantics.ss"
"gui.ss"
"pict.ss"))
(provide render-language)
(provide render-language)

2
collects/redex/pict.ss
View File

@ -102,4 +102,4 @@
[lw->pict
(-> (or/c (listof symbol?) compiled-lang?) lw? pict?)]
[render-lw
(-> (or/c (listof symbol?) compiled-lang?) lw? pict?)])
(-> (or/c (listof symbol?) compiled-lang?) lw? pict?)])

2
collects/redex/private/color-test.ss
View File

@ -66,4 +66,4 @@ In the other window, you expect to see the currently unreducted terms in green a
(,(* (term number_1) 2) word)
dup))
'(1 word)
#:pred last-color-pred))
#:pred last-color-pred))

2
collects/redex/private/core-layout.ss
View File

@ -762,4 +762,4 @@
[else (for-each find/lw e)]))
(find/e in-lws)
lws)
lws)

2
collects/redex/private/lw-test-util.ss
View File

@ -40,4 +40,4 @@
[(string? e) (void)]
[else (for-each find-min/lw e)]))
(find-min/lw lw)
(values min-line min-col)))
(values min-line min-col)))

2
collects/redex/private/pict-test.ss
View File

@ -50,4 +50,4 @@
(render-language x0-10)
(printf "pict-test.ss passed\n"))
(printf "pict-test.ss passed\n"))

2
collects/redex/private/reduction-semantics.ss
View File

@ -1847,4 +1847,4 @@
(provide relation-coverage
covered-cases
(rename-out [fresh-coverage make-coverage])
coverage?)
coverage?)

2
collects/redex/private/rewrite-side-conditions.ss
View File

@ -177,4 +177,4 @@
(current-continuation-marks)
(list (id/depth-id x) (id/depth-id (car dups)))))))
(not same-id?)))
(loop (cdr dups))))]))))
(loop (cdr dups))))]))))

2
collects/redex/private/rg.ss
View File

@ -859,4 +859,4 @@ To do a better job of not generating programs with free variables,
generation-decisions)
(provide/contract
[find-base-cases (-> compiled-lang? hash?)])
[find-base-cases (-> compiled-lang? hash?)])

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

@ -1,196 +1,171 @@
(module size-snip mzscheme
(require (lib "mred.ss" "mred")
(lib "class.ss")
(lib "pretty.ss")
(lib "framework.ss" "framework")
"matcher.ss")
(provide reflowing-snip<%>
size-editor-snip%
default-pretty-printer
initial-char-width
resizing-pasteboard-mixin)
(define initial-char-width (make-parameter 30))
(define (default-pretty-printer v port w spec)
(parameterize ([pretty-print-columns w]
[pretty-print-size-hook
(λ (val display? op)
(cond
[(hole? val) 4]
[(eq? val 'hole) 6]
[else #f]))]
[pretty-print-print-hook
(λ (val display? op)
(cond
[(hole? val)
(display "hole" op)]
[(eq? val 'hole)
(display ",'hole" op)]))])
(pretty-print v port)))
(define reflowing-snip<%>
(interface ()
reflow-program))
(define (resizing-pasteboard-mixin pb%)
(class pb%
(init-field shrink-down?)
(define/augment (on-interactive-resize snip)
(when (is-a? snip reflowing-snip<%>)
(send snip reflow-program))
(inner (void) on-interactive-resize snip))
(define/augment (after-interactive-resize snip)
(when (is-a? snip reflowing-snip<%>)
(send snip reflow-program))
(inner (void) after-interactive-resize snip))
(define/override (interactive-adjust-resize snip w h)
(super interactive-adjust-resize snip w h)
(when (is-a? snip reflowing-snip<%>)
(send snip reflow-program)))
(inherit get-snip-location
begin-edit-sequence
end-edit-sequence)
(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%
(class* editor-snip% (reflowing-snip<%>)
(init-field expr)
(init pp)
(init-field char-width)
(define real-pp
(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)
(define/override (resize w h)
(super resize w h)
(reflow-program))
(inherit get-editor)
;; final
(define/pubment (reflow-program)
(let* ([tw (get-width-of-char)]
[sw (get-snip-width)])
(when (and tw sw)
(let ([new-width (max 1 (inexact->exact (floor (/ sw tw))))])
(unless (equal? new-width char-width)
(set! char-width new-width)
(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)])
(and admin
(let ([containing-editor (send admin get-editor)]
[bl (box 0)]
[br (box 0)])
(send containing-editor get-snip-location this bl #f #f)
(send containing-editor get-snip-location this br #f #t)
(let ([outer-w (- (unbox br) (unbox bl))])
(let-values ([(hms vms) (get-margin-space)])
(- outer-w hms)))))))
(define/private (get-margin-space)
(let ([bl (box 0)]
[br (box 0)]
[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?
(+ (unbox bt) (unbox bb)))))
(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")])
(and dc
(let-values ([(tw th _2 _3) (send dc get-text-extent "w"
(and std-style
(send std-style get-font)))])
tw))))))
(define/public (get-height-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")])
(and dc
(let-values ([(tw th _2 _3) (send dc get-text-extent "w"
(and std-style
(send std-style get-font)))])
th))))))
#lang scheme/base
(require scheme/gui/base
scheme/class
framework
scheme/pretty
"matcher.ss")
(define/pubment (on-width-changed w) (inner (void) on-width-changed w))
(define/public (format-expr)
(let* ([text (get-editor)]
[port (open-output-text-editor text)])
(send text begin-edit-sequence)
(when (is-a? text color:text<%>)
(send text thaw-colorer))
(send text set-styles-sticky #f)
(send text erase)
(real-pp expr port char-width text)
(unless (zero? (send text last-position))
(when (char=? #\newline (send text get-character (- (send text last-position) 1)))
(send text delete (- (send text last-position) 1) (send text last-position))))
(when (is-a? text color:text<%>)
(send text freeze-colorer))
(send text end-edit-sequence)))
(provide reflowing-snip<%>
size-editor-snip%
size-text%
default-pretty-printer
initial-char-width
resizing-pasteboard-mixin)
(define initial-char-width (make-parameter 30))
(define (default-pretty-printer v port w spec)
(parameterize ([pretty-print-columns w]
[pretty-print-size-hook
(λ (val display? op)
(cond
[(hole? val) 4]
[(eq? val 'hole) 6]
[else #f]))]
[pretty-print-print-hook
(λ (val display? op)
(cond
[(hole? val)
(display "hole" op)]
[(eq? val 'hole)
(display ",'hole" op)]))])
(pretty-print v port)))
(define reflowing-snip<%>
(interface ()
reflow-program))
(define (resizing-pasteboard-mixin pb%)
(class pb%
(define/augment (on-interactive-resize snip)
(when (is-a? snip reflowing-snip<%>)
(send snip reflow-program))
(inner (void) on-interactive-resize snip))
(define/augment (after-interactive-resize snip)
(when (is-a? snip reflowing-snip<%>)
(send snip reflow-program))
(inner (void) after-interactive-resize snip))
(define/override (interactive-adjust-resize snip w h)
(super interactive-adjust-resize snip w h)
(when (is-a? snip reflowing-snip<%>)
(send snip reflow-program)))
(inherit get-snip-location
begin-edit-sequence
end-edit-sequence
find-first-snip
get-dc)
(super-new)))
(define size-editor-snip%
(class* editor-snip% (reflowing-snip<%>)
(init-field expr)
(init pp)
(init-field char-width)
(define real-pp
(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)
(define/override (resize w h)
(super resize w h)
(reflow-program))
(inherit get-editor)
;; final
(define/pubment (reflow-program)
(let* ([tw (get-width-of-char)]
[sw (get-snip-width)])
(when (and tw sw)
(let ([new-width (max 1 (inexact->exact (floor (/ sw tw))))])
(unless (equal? new-width char-width)
(set! char-width new-width)
(format-expr)
(on-width-changed char-width))))))
(inherit get-margin)
(define/public (get-snip-width)
(let ([admin (get-admin)])
(and admin
(let ([containing-editor (send admin get-editor)]
[bl (box 0)]
[br (box 0)])
(send containing-editor get-snip-location this bl #f #f)
(send containing-editor get-snip-location this br #f #t)
(let ([outer-w (- (unbox br) (unbox bl))])
(let-values ([(hms vms) (get-margin-space)])
(- outer-w hms)))))))
(define/private (get-margin-space)
(let ([bl (box 0)]
[br (box 0)]
[bt (box 0)]
[bb (box 0)])
(get-margin bl bt br bb)
(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 ([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
(let ([dc (send ed get-dc)]
[std-style (send (editor:get-standard-style-list) find-named-style "Standard")])
(and dc
(let-values ([(tw th _2 _3) (send dc get-text-extent "w"
(and std-style
(send std-style get-font)))])
th))))))
(define/pubment (on-width-changed w) (inner (void) on-width-changed w))
(define/public (format-expr)
(let* ([text (get-editor)]
[port (open-output-text-editor text)])
(send text begin-edit-sequence)
(when (is-a? text color:text<%>)
(send text thaw-colorer))
(send text set-styles-sticky #f)
(send text erase)
(real-pp expr port char-width text)
(unless (zero? (send text last-position))
(when (char=? #\newline (send text get-character (- (send text last-position) 1)))
(send text delete (- (send text last-position) 1) (send text last-position))))
(when (is-a? text color:text<%>)
(send text freeze-colorer))
(send text end-edit-sequence)))
(super-new)
(inherit use-style-background)
(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%)))))))
(super-new)
(inherit use-style-background)
(use-style-background #t))))

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)]

2
collects/redex/private/term-test.ss
View File

@ -76,4 +76,4 @@
(term (((metafun x) y) ...))))
'((whatever 4) (whatever 5) (whatever 6)))
(print-tests-passed 'term-test.ss))
(print-tests-passed 'term-test.ss))

2
collects/redex/private/term.ss
View File

@ -127,4 +127,4 @@
(with-syntax ([x rhs] ...)
(begin body1 body2 ...)))]
[(_ x)
(raise-syntax-error 'term-let "expected at least one body" stx)])))
(raise-syntax-error 'term-let "expected at least one body" stx)])))

115
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)])
(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)))))
(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 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)

2
collects/redex/private/underscore-allowed.ss
View File

@ -1,3 +1,3 @@
(module underscore-allowed mzscheme
(provide underscore-allowed)
(define underscore-allowed '(any number string variable)))
(define underscore-allowed '(any number string variable)))

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/redex/reduction-semantics.ss
View File

@ -70,4 +70,4 @@
(one-of/c #t (void)))]
[relation-coverage (parameter/c (or/c false/c coverage?))]
[make-coverage (-> reduction-relation? coverage?)]
[covered-cases (-> coverage? (listof (cons/c string? natural-number/c)))])
[covered-cases (-> coverage? (listof (cons/c string? natural-number/c)))])

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")

2
collects/scheme/private/contract-guts.ss
View File

@ -515,4 +515,4 @@
#:property name-prop (λ (ctc) (predicate-contract-name ctc))
#:property flat-prop (λ (ctc) (predicate-contract-pred ctc)))
(define (build-flat-contract name pred) (make-predicate-contract name pred))
(define (build-flat-contract name pred) (make-predicate-contract name pred))

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

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

2
collects/scribble/private/manual-style.ss
View File

@ -240,4 +240,4 @@
(list (make-element 'italic (list i)))])]
[(eq? i 'rsquo) (list 'prime)]
[else (list i)])))
c))))
c))))

2
collects/scribblings/framework/standard-menus.scrbl
View File

@ -349,4 +349,4 @@
@(defmethod (help-menu:after-about (menu (is-a?/c menu-item%))) void? "This method is called " "after" " the addition of the" "\n" (tt "about") " menu-item. Override it to add additional" "\n" "menu items at that point. ")
}
}

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}

2
collects/scribblings/tools/tool-lib-extracts.ss
View File

@ -2,4 +2,4 @@
(require scribble/extract)
(provide-extracted (lib "tool-lib.ss" "drscheme"))
(provide-extracted (lib "tool-lib.ss" "drscheme"))

2
collects/srfi/42/comprehensions.scm
View File

@ -401,4 +401,4 @@
(qualifier)
(first-ec #t qualifier (if (not expression)) #f) ))
)
)

2
collects/srfi/42/generator-definitions.scm
View File

@ -35,4 +35,4 @@
(raise-syntax-error
'define-generator
"expected either (define-generator <id> <proc>) or (define-generator (<id1> <id2>) <body> ... , got: "
stx)])))
stx)])))

2
collects/srfi/42/generator-struct.scm
View File

@ -14,4 +14,4 @@
; of a generator clause as input. For example
; #'(:list x (list 1 2 3)). The function form->loop
; returns a loop structure.
(define-struct generator (name clause->loop)))
(define-struct generator (name clause->loop)))

2
collects/srfi/42/generators.scm
View File

@ -455,4 +455,4 @@
"expected (:while <generator> <expr>) got: "
form-stx)]))
)
)

2
collects/srfi/42/loops.scm
View File

@ -107,4 +107,4 @@
(if ne2
(loop ls ...))))))))))]))
)
)

2
collects/srfi/42/simplifier.scm
View File

@ -90,4 +90,4 @@
; anything else
((ec-simplify expression)
#'expression ))))
#'expression ))))

2
collects/stepper/private/debugger-summary.txt
View File

@ -13,4 +13,4 @@
by the chosen frame
(bound) : all bound vars
(v <x>) : value of a named variable
(src) : the source code
(src) : the source code

2
collects/syntax/modcollapse.ss
View File

@ -23,4 +23,4 @@
. -> . simple-rel-to-module-path-v/c)]
[collapse-module-path-index ((or/c symbol? module-path-index?)
rel-to-module-path-v/c
. -> . simple-rel-to-module-path-v/c)])
. -> . simple-rel-to-module-path-v/c)])

2
collects/syntax/private/modhelp.ss
View File

@ -17,4 +17,4 @@
(define (module-path-v? v)
(or (path? v)
(module-path? v)))
(module-path? v)))

2
collects/tests/mzscheme/benchmarks/shootout/mandelbrot.ss
View File

@ -76,4 +76,4 @@
;; -------------------------------
(command-line #:args (n)
(main (string->number n)))
(main (string->number n)))

2
collects/tests/typed-scheme/660-examples/hw02.scm
View File

@ -235,4 +235,4 @@
|#|#
)
)

2
collects/tests/typed-scheme/660-examples/hw04.scm
View File

@ -346,4 +346,4 @@
{fun main {foo} {call foo foo}}}"
1))
)
)

2
collects/tests/typed-scheme/660-examples/hw05.scm
View File

@ -219,4 +219,4 @@ Evaluation rules:
{fun {x} {fun {y} {+ x y}}}}
123}")
=> 124)
|#)
|#)

2
collects/tests/typed-scheme/fail/apply-dots.ss
View File

@ -10,4 +10,4 @@
(apply (case-lambda: (([x : Number] . [y : Number ... a]) x)
(([x : String] [y : String] . [z : String *]) 0)
([y : String *] 0))
w))
w))

2
collects/tests/typed-scheme/fail/cl-bug.ss
View File

@ -4,4 +4,4 @@
(define (f3 x y) (+ x y))
(: f2 (case-lambda (Number * -> Number)))
(define (f2 x y) (+ x y))
(define (f2 x y) (+ x y))

2
collects/tests/typed-scheme/fail/dotted-identity.ss
View File

@ -8,4 +8,4 @@
(: g (All (b ...) ( -> (b ... b -> Integer))))
(define (g) (lambda xs 0))
(f (g))
(f (g))

2
collects/tests/typed-scheme/fail/formal-len-mismatches.ss
View File

@ -14,4 +14,4 @@
(: f3 (Integer Integer -> Integer))
(define (f3 x . z)
(apply + #\c x z))
(apply + #\c x z))

2
collects/tests/typed-scheme/fail/nested-tvars.ss
View File

@ -6,4 +6,4 @@
(define (g x y) y)
(g "foo" (list "foo")))
(f 3)
(f 3)

2
collects/tests/typed-scheme/fail/unbound-type.ss
View File

@ -6,4 +6,4 @@
(: f (Foo -> String))
(define (f x) (string-append x))
(f 1)
(f 1)

2
collects/tests/typed-scheme/succeed/cl-bug.ss
View File

@ -4,4 +4,4 @@
(define (f . x) (+ 1 2))
(: f4 (case-lambda (Integer * -> Integer) (Number * -> Number)))
(define (f4 . x) (apply + x))
(define (f4 . x) (apply + x))

2
collects/tests/typed-scheme/succeed/dot-intro.ss
View File

@ -13,4 +13,4 @@
y)
(plambda: (a ...) ([x : Number] . [y : Number ... a])
(map add1 y))
(map add1 y))

2
collects/tests/typed-scheme/succeed/fold-left-inst.ss
View File

@ -16,4 +16,4 @@
c
(apply f
(apply (inst fold-left c a b ... b) f c (cdr as) (map cdr bss))
(car as) (map car bss))))
(car as) (map car bss))))

2
collects/tests/typed-scheme/succeed/fold-left.ss
View File

@ -38,4 +38,4 @@
3 4 5)
(fold-left (lambda: ([a : (Listof Integer)] [c : Integer]) (cons c a)) null (list 3 4 5 6))
(fold-right (lambda: ([a : (Listof Integer)] [c : Integer]) (cons c a)) null (list 3 4 5 6))
(fold-right (lambda: ([a : (Listof Integer)] [c : Integer]) (cons c a)) null (list 3 4 5 6))

2
collects/tests/typed-scheme/succeed/foldo.scm
View File

@ -55,4 +55,4 @@
'()
root
))
)
)

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))))

2
collects/tests/typed-scheme/succeed/lots-o-bugs.ss
View File

@ -18,4 +18,4 @@
#;((plambda: (a ...) () (lambda: [ys : a ... a] 3)))
#;((plambda: (a ...) [xs : a ... a] (lambda: [ys : a ... a] 3))
1 2 3 "foo")
1 2 3 "foo")

2
collects/tests/typed-scheme/succeed/nested-poly.ss
View File

@ -17,4 +17,4 @@
(apply f as))
fs))))
(inst map-with-funcs Integer Integer Integer Integer)
(inst map-with-funcs Integer Integer Integer Integer)

2
collects/tests/typed-scheme/succeed/poly-subtype.ss
View File

@ -17,4 +17,4 @@
(define (g x) 3)
|#
|#

2
collects/tests/typed-scheme/succeed/star-sizes.ss
View File

@ -3,4 +3,4 @@
(: f (All (a) ((Integer a * -> Integer) -> Integer)))
(define (f g) 0)
(f +)
(f +)

2
collects/tests/typed-scheme/succeed/unholy-terror.ss
View File

@ -62,4 +62,4 @@
(map (lambda: ([f : (a ... a -> b)])
(apply f as))
fs)))
(map-with-funcs + - * /)
(map-with-funcs + - * /)

2
collects/tests/typed-scheme/succeed/values-dots.ss
View File

@ -27,4 +27,4 @@
(((inst map-with-funcs Integer Integer)
(lambda: ([x : Integer] [y : Integer]) (+ x y))
(lambda: ([x : Integer] [y : Integer]) (- x y)))
3 4)
3 4)

2
collects/tests/typed-scheme/succeed/with-handlers.ss
View File

@ -7,4 +7,4 @@
(define: (is-happiness-a-warm-gun?) : Boolean
(with-handlers ([integer? (lambda: ([x : Any]) #t)])
(f 42)
#t))
#t))

2
collects/tests/typed-scheme/unit-tests/random-testing.ss
View File

@ -67,4 +67,4 @@
(go 0)
;(generate (base-gen 1))
;(generate (base-gen 1))

2
collects/tests/web-server/dispatchers/dispatch-servlets-test.ss
View File

@ -119,4 +119,4 @@
; Comment in to run tests
#;(require #;(planet "graphical-ui.ss" ("schematics" "schemeunit.plt" 2))
(planet "text-ui.ss" ("schematics" "schemeunit.plt" 2)))
#;(test/text-ui dispatch-servlets-tests)
#;(test/text-ui dispatch-servlets-tests)

2
collects/tests/web-server/dispatchers/filesystem-map-test.ss
View File

@ -78,4 +78,4 @@
(test-url->path test-filter-map (build-path "dispatchers/filesystem-map.html")))))
(test-case "Allows content after w/ valid"
(test-url->path test-filter-valid-map (build-path "dispatchers/filesystem-map.ss/extra/info")
#:expected (build-path "dispatchers/filesystem-map.ss"))))))
#:expected (build-path "dispatchers/filesystem-map.ss"))))))

2
collects/tests/web-server/lang-test.ss
View File

@ -565,4 +565,4 @@
(define-values (point i) (values #t 1))
i)))))))
))
))

2
collects/tests/web-server/lang/abort-resume-test.ss
View File

@ -204,4 +204,4 @@
; XXX test dispatch
))
))

2
collects/tests/web-server/servlet-env/env.ss
View File

@ -25,4 +25,4 @@
,(number->string (+ (request-number "first") (request-number "second")))))))
(serve/servlet start
#:servlet-path "/")
#:servlet-path "/")

2
collects/typed-scheme/infer/constraint-structs.ss
View File

@ -48,4 +48,4 @@
(struct dcon-exact ([fixed (listof c?)] [rest c?]))
(struct dcon-dotted ([type c?] [bound symbol?]))
(struct dmap ([map (hashof symbol? (or/c dcon? dcon-exact? dcon-dotted?))]))
(struct cset ([maps (listof (cons/c (hashof symbol? c?) dmap?))])))
(struct cset ([maps (listof (cons/c (hashof symbol? c?) dmap?))])))

2
collects/typed-scheme/infer/dmap.ss
View File

@ -63,4 +63,4 @@
(define (dmap-meet dm1 dm2)
(make-dmap
(hash-union (dmap-map dm1) (dmap-map dm2)
(lambda (k dc1 dc2) (dcon-meet dc1 dc2)))))
(lambda (k dc1 dc2) (dcon-meet dc1 dc2)))))

2
collects/typed-scheme/infer/infer-dummy.ss
View File

@ -5,4 +5,4 @@
(define infer-param (make-parameter (lambda e (int-err "infer not initialized"))))
(define (unify X S T) ((infer-param) X S T (make-Univ) null))
(provide unify infer-param)
(provide unify infer-param)

Some files were not shown because too many files have changed in this diff Show More