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

sync to trunk

Browse Source 
svn: r14940
This commit is contained in:
Sam Tobin-Hochstadt 2009-05-22 21:42:46 +00:00
commit a8ee2dc161
115 changed files with 1641 additions and 689 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

2
collects/deinprogramm/scribblings/image.scrbl
View File

@ -20,8 +20,6 @@ Zusätzliche Prozeduren erlauben die Komposition von Bildern.
@;----------------------------------------------------------------------------- @;-----------------------------------------------------------------------------
@section{Bilder} @section{Bilder}
@declare-exporting[teachpack/deinprogramm/image]
@defthing[image contract]{ @defthing[image contract]{
Ein @deftech{Bild} (Name: @scheme[image]) ist die Repräsentation eines Bildes. Ein @deftech{Bild} (Name: @scheme[image]) ist die Repräsentation eines Bildes.
} }

12
collects/drscheme/private/rep.ss
View File

@ -46,12 +46,12 @@ TODO
(define checkpoints (make-weak-hasheq)) (define checkpoints (make-weak-hasheq))
(define (call-with-stack-checkpoint thunk) (define (call-with-stack-checkpoint thunk)
(define checkpoint (current-continuation-marks)) (define checkpoint (current-continuation-marks))
(with-handlers ([exn? (lambda (exn) (call-with-exception-handler
;; nested ones take precedence (λ (exn)
(unless (hash-has-key? checkpoints exn) (unless (hash-has-key? checkpoints exn)
(hash-set! checkpoints exn checkpoint)) (hash-set! checkpoints exn checkpoint))
(raise exn))]) exn)
(thunk))) thunk))
;; returns the stack of the input exception, cutting off any tail that was ;; returns the stack of the input exception, cutting off any tail that was
;; registered as a checkpoint ;; registered as a checkpoint
(define (cut-stack-at-checkpoint exn) (define (cut-stack-at-checkpoint exn)

4
collects/drscheme/private/text.ss
View File

@ -9,12 +9,12 @@
(interface (scheme:text<%>) (interface (scheme:text<%>)
printing-on printing-on
printing-off printing-off
is-printing?)) is-printing-on?))
(define text% (define text%
(class* scheme:text% (text<%>) (class* scheme:text% (text<%>)
(define printing? #f) (define printing? #f)
(define/public (is-printing?) printing?) (define/public (is-printing-on?) printing?)
(define/public (printing-on) (set! printing? #t)) (define/public (printing-on) (set! printing? #t))
(define/public (printing-off) (set! printing? #f)) (define/public (printing-off) (set! printing? #f))
; (rename [super-on-paint on-paint]) ; (rename [super-on-paint on-paint])

21
collects/games/chat-noir/README
View File

@ -1,21 +0,0 @@
These are the files for the literate version of Chat Noir. The files
not mentioned are actually in use for Chat Noir that you get via PLT
Games.
Problems:
- Run in the module language doesn't seem to work anymore, in that
definitions in the literate program don't show up in the REPL.
- Need to make 'a-chunk' be a real macro, I expect. (used in
scribble/private/lp.ss)
- hyperlink bound top-level identifiers to their bindings?
- do unbound chunk ids signal syntax errors? How about unused ones?
To document:
@chunk
scribble/lp (when it is added).
scribble/lp-include

22
collects/games/chat-noir/chat-noir-literate.ss
View File

@ -1129,7 +1129,7 @@ based on the state of the key event.
(world-state w) (world-state w)
(world-size w) (world-size w)
(world-mouse-posn w) (world-mouse-posn w)
(key=? ke #\h)))] (key=? ke "h")))]
The @scheme[clack] function handles mouse input. It has three tasks and each corresponds The @scheme[clack] function handles mouse input. It has three tasks and each corresponds
to a helper function: to a helper function:
@ -1156,7 +1156,7 @@ player's move (via the @scheme[player-moved?] function.
(update-world-posn (update-world-posn
moved-world moved-world
(and (eq? (world-state moved-world) 'playing) (and (eq? (world-state moved-world) 'playing)
(not (eq? evt 'leave)) (not (equal? evt "leave"))
(make-posn x y)))))] (make-posn x y)))))]
The @scheme[player-moved?] predicate returns The @scheme[player-moved?] predicate returns
@ -1170,7 +1170,7 @@ is not over, and then it just calls @scheme[circle-at-point].
(define/contract (player-moved? world x y evt) (define/contract (player-moved? world x y evt)
(-> world? integer? integer? any/c (-> world? integer? integer? any/c
(or/c posn? #f)) (or/c posn? #f))
(and (equal? evt 'button-up) (and (equal? evt "button-up")
(equal? 'playing (world-state world)) (equal? 'playing (world-state world))
(circle-at-point (world-board world) x y)))] (circle-at-point (world-board world) x y)))]
@ -2009,7 +2009,7 @@ and reports the results.
@chunk[<clack-tests> @chunk[<clack-tests>
(test (clack (test (clack
(make-world '() (make-posn 0 0) 'playing 3 #f #f) (make-world '() (make-posn 0 0) 'playing 3 #f #f)
1 1 'button-down) 1 1 "button-down")
(make-world '() (make-posn 0 0) 'playing 3 #f #f)) (make-world '() (make-posn 0 0) 'playing 3 #f #f))
(test (clack (test (clack
(make-world '() (make-posn 0 0) 'playing 3 #f #f) (make-world '() (make-posn 0 0) 'playing 3 #f #f)
@ -2059,7 +2059,7 @@ and reports the results.
'playing 3 (make-posn 0 0) #f) 'playing 3 (make-posn 0 0) #f)
10 10
10 10
'button-down) "button-down")
(make-world '() (make-posn 0 0) 'playing 3 #f #f)) (make-world '() (make-posn 0 0) 'playing 3 #f #f))
(test (clack (make-world (list (make-cell (make-posn 0 0) #f) (test (clack (make-world (list (make-cell (make-posn 0 0) #f)
@ -2071,7 +2071,7 @@ and reports the results.
#f) #f)
(cell-center-x (make-posn 0 0)) (cell-center-x (make-posn 0 0))
(cell-center-y (make-posn 0 0)) (cell-center-y (make-posn 0 0))
'button-up) "button-up")
(make-world (list (make-cell (make-posn 0 0) #t) (make-world (list (make-cell (make-posn 0 0) #t)
(make-cell (make-posn 1 1) #f)) (make-cell (make-posn 1 1) #f))
(make-posn 1 1) (make-posn 1 1)
@ -2085,7 +2085,7 @@ and reports the results.
'cat-lost 3 (make-posn 0 0) #f) 'cat-lost 3 (make-posn 0 0) #f)
10 10
10 10
'button-up) "button-up")
(make-world '() (make-posn 0 0) (make-world '() (make-posn 0 0)
'cat-lost 3 #f #f)) 'cat-lost 3 #f #f))
(test (clack (test (clack
@ -2104,7 +2104,7 @@ and reports the results.
#f) #f)
(cell-center-x (make-posn 1 0)) (cell-center-x (make-posn 1 0))
(cell-center-y (make-posn 1 0)) (cell-center-y (make-posn 1 0))
'button-up) "button-up")
(make-world (make-world
(list (make-cell (make-posn 1 0) #t) (list (make-cell (make-posn 1 0) #t)
(make-cell (make-posn 2 0) #t) (make-cell (make-posn 2 0) #t)
@ -2135,7 +2135,7 @@ and reports the results.
#f) #f)
(cell-center-x (make-posn 1 0)) (cell-center-x (make-posn 1 0))
(cell-center-y (make-posn 1 0)) (cell-center-y (make-posn 1 0))
'button-up) "button-up")
(make-world (make-world
(list (make-cell (make-posn 1 0) #t) (list (make-cell (make-posn 1 0) #t)
(make-cell (make-posn 2 0) #f) (make-cell (make-posn 2 0) #f)
@ -2246,12 +2246,12 @@ and reports the results.
@chunk[<change-tests> @chunk[<change-tests>
(test (change (make-world '() (make-posn 1 1) (test (change (make-world '() (make-posn 1 1)
'playing 3 (make-posn 0 0) #f) 'playing 3 (make-posn 0 0) #f)
#\h) "h")
(make-world '() (make-posn 1 1) (make-world '() (make-posn 1 1)
'playing 3 (make-posn 0 0) #t)) 'playing 3 (make-posn 0 0) #t))
(test (change (make-world '() (make-posn 1 1) (test (change (make-world '() (make-posn 1 1)
'playing 3 (make-posn 0 0) #t) 'playing 3 (make-posn 0 0) #t)
'release) "release")
(make-world '() (make-posn 1 1) 'playing 3 (make-posn 0 0) #f))] (make-world '() (make-posn 1 1) 'playing 3 (make-posn 0 0) #f))]

2
collects/htdp/big-draw.ss
View File

@ -14,7 +14,7 @@
(define-values/invoke-unit/infer (define-values/invoke-unit/infer
(export graphics^) (export graphics^)
(link graphics-posn-less@ standard-mred@)) (link standard-mred@ graphics-posn-less@))
(provide-signature-elements graphics^) (provide-signature-elements graphics^)

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

@ -342,99 +342,11 @@
hide-none-policy) hide-none-policy)
(define standard-policy (define standard-policy
#;(make-policy #t #t #t #t null)
(policy->predicate 'standard)) (policy->predicate 'standard))
(define base-policy (define base-policy
#;(make-policy #t #f #f #f null)
(policy->predicate (policy->predicate
'(custom #t #f #f #f ()))) '(custom #t #f #f #f ())))
(define (hide-all-policy id) #f) (define (hide-all-policy id) #f)
(define (hide-none-policy id) #t) (define (hide-none-policy id) #t)
#|
;; make-policy : bool^4 (listof (identifier bindinglist (bool -> void) -> void))
;; -> identifier -> bool
(define (make-policy hide-mzscheme?
hide-libs?
hide-contracts?
hide-transformers?
specialized-policies)
(lambda (id)
(define now (phase))
(define binding
(cond [(= now 0) (identifier-binding id)]
[(= now 1) (identifier-transformer-binding id)]
[else #f]))
(define-values (def-mod def-name nom-mod nom-name)
(if (pair? binding)
(values (car binding)
(cadr binding)
(caddr binding)
(cadddr binding))
(values #f #f #f #f)))
(let/ec return
(let loop ([policies specialized-policies])
(when (pair? policies)
((car policies) id binding return)
(loop (cdr policies))))
(cond [(and hide-mzscheme? def-mod (scheme-module? def-mod))
#f]
[(and hide-libs? def-mod (lib-module? def-mod))
#f]
[(and hide-contracts? def-name
(regexp-match #rx"^provide/contract-id-"
(symbol->string def-name)))
#f]
[(and hide-transformers? (positive? now))
#f]
[else #t]))))
;; ----
(define (scheme-module? mpi)
(let ([abs (find-absolute-module-path mpi)])
(and abs
(or (base-module-path? abs)
(scheme-lib-module-path? abs)))))
(define (lib-module? mpi)
(let ([abs (find-absolute-module-path mpi)])
(and abs (lib-module-path? abs))))
(define (find-absolute-module-path mpi)
(and (module-path-index? mpi)
(let-values ([(path rel) (module-path-index-split mpi)])
(cond [(and (pair? path) (memq (car path) '(quote lib planet)))
path]
[(symbol? path) path]
[(string? path) (find-absolute-module-path rel)]
[else #f]))))
(define (base-module-path? mp)
(and (pair? mp)
(eq? 'quote (car mp))
(regexp-match #rx"^#%" (symbol->string (cadr mp)))))
(define (scheme-lib-module-path? mp)
(cond [(symbol? mp)
(scheme-collection-name? (symbol->string mp))]
[(and (pair? mp) (eq? (car mp) 'lib))
(cond [(string? (cadr mp)) (null? (cddr mp))
(scheme-collection-name? (cadr mp))]
[(symbol? (cadr mp))
(scheme-collection-name? (symbol->string (cadr mp)))]
[else #f])]
[else #f]))
(define (scheme-collection-name? path)
(or (regexp-match? #rx"^scheme/base(/.)?" path)
(regexp-match? #rx"^mzscheme(/.)?" path)))
(define (lib-module-path? mp)
(or (symbol? mp)
(and (pair? mp) (memq (car mp) '(lib planet)))))
|#

2
collects/macro-debugger/model/reductions.ss
View File

@ -612,7 +612,7 @@
;; lift-error ;; lift-error
(define (lift-error sym . args) (define (lift-error sym . args)
(apply fprintf (current-error-port) args) (apply fprintf (current-error-port) args)
(when #t (when #f
(apply error sym args))) (apply error sym args)))
;; opaque-table ;; opaque-table

19
collects/macro-debugger/util/mpi.ss
View File

@ -41,15 +41,26 @@
;; (list #f) ;; "self" module ;; (list #f) ;; "self" module
;; null ;; null
;; An rmp-sexpr is
;; (list 'resolved path/symbol)
;; mpi->mpi-sexpr : mpi -> mpi-sexpr ;; mpi->mpi-sexpr : mpi -> mpi-sexpr
(define (mpi->mpi-sexpr mpi) (define (mpi->mpi-sexpr mpi)
(cond [(module-path-index? mpi) (cond [(module-path-index? mpi)
(let-values ([(mod next) (module-path-index-split mpi)]) (let-values ([(mod next) (module-path-index-split mpi)])
(cons mod (mpi->mpi-sexpr next)))] (cons (mp->mp-sexpr mod) (mpi->mpi-sexpr next)))]
[(resolved-module-path? mpi) [(resolved-module-path? mpi)
(list (rmp->rmp-sexpr mpi))] (list (rmp->rmp-sexpr mpi))]
[else null])) [else null]))
;; mp->mp-sexpr : mp -> mp-sexpr
(define (mp->mp-sexpr mp)
(if (path? mp)
(if (absolute-path? mp)
`(file ,(path->string mp))
(path->string mp))
mp))
;; mpi-sexpr->mpi : mpi-sexpr -> mpi ;; mpi-sexpr->mpi : mpi-sexpr -> mpi
(define (mpi-sexpr->mpi sexpr) (define (mpi-sexpr->mpi sexpr)
(match sexpr (match sexpr
@ -124,7 +135,11 @@
[else [else
`(REL (split-mods path))])] `(REL (split-mods path))])]
[(? string? path) [(? string? path)
`(REL ,(split-mods path))])) `(REL ,(split-mods path))]
[`(resolved ,(? path? path))
`(FILE ,path)]
[`(resolved ,(? symbol? symbol))
`(QUOTE ,symbol)]))
;; expanded-mpi-sexpr->mpi-sexpr ;; expanded-mpi-sexpr->mpi-sexpr
(define (expanded-mpi-sexpr->mpi-sexpr sexpr) (define (expanded-mpi-sexpr->mpi-sexpr sexpr)

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

@ -23,7 +23,8 @@
"../model/reductions.ss" "../model/reductions.ss"
"../model/steps.ss" "../model/steps.ss"
"cursor.ss" "cursor.ss"
"../util/notify.ss") "../util/notify.ss"
(only-in mzscheme [#%top-interaction mz-top-interaction]))
(provide macro-stepper-widget% (provide macro-stepper-widget%
macro-stepper-widget/process-mixin) macro-stepper-widget/process-mixin)
@ -434,7 +435,8 @@
;; adjust-deriv/top : Derivation -> Derivation ;; adjust-deriv/top : Derivation -> Derivation
(define/private (adjust-deriv/top deriv) (define/private (adjust-deriv/top deriv)
(if (or (syntax-source (wderiv-e1 deriv)) (if (or (and #| (syntax-source (wderiv-e1 deriv)) |#
(syntax-original? (wderiv-e1 deriv)))
(p:module? deriv)) (p:module? deriv))
deriv deriv
;; It's not original... ;; It's not original...
@ -454,6 +456,7 @@
#f]))) #f])))
(define/public (top-interaction-kw? x) (define/public (top-interaction-kw? x)
(free-identifier=? x #'#%top-interaction)) (or (free-identifier=? x #'#%top-interaction)
(free-identifier=? x #'mz-top-interaction)))
)) ))

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

@ -259,7 +259,8 @@ Matthew
(interactive? fit-on-page?) (interactive? fit-on-page?)
(interactive? fit-on-page? output-mode) (interactive? fit-on-page? output-mode)
(interactive? fit-on-page? output-mode parent) (interactive? fit-on-page? output-mode parent)
(interactive? fit-on-page? output-mode parent force-ps-page-bbox?)] (interactive? fit-on-page? output-mode parent force-ps-page-bbox?)
(interactive? fit-on-page? output-mode parent force-ps-page-bbox? as-eps?)]
unlocked) unlocked)
(get-text [() (x) (x y) (x y z) (x y z p)] unlocked) (get-text [() (x) (x y) (x y z) (x y z p)] unlocked)

7
collects/mred/private/syntax.ss
View File

@ -10,7 +10,8 @@
method-name init-name method-name init-name
let-boxes let-boxes
properties field-properties init-properties properties field-properties init-properties
->long) ->long
assert)
(define-syntax-parameter class-name #f) (define-syntax-parameter class-name #f)
@ -264,3 +265,7 @@
[(eqv? +inf.0 i) (expt 2 64)] [(eqv? +inf.0 i) (expt 2 64)]
[(eqv? +nan.0 i) 0] [(eqv? +nan.0 i) 0]
[else (inexact->exact (floor i))])) [else (inexact->exact (floor i))]))
(define-syntax-rule (assert e) (void))
; (define-syntax-rule (assert e) (unless e (error 'assert "failed: ~s" 'e)))

7
collects/mred/private/wxcanvas.ss
View File

@ -224,5 +224,10 @@
0 0 #t #t))) 0 0 #t #t)))
(inherit editor-canvas-on-scroll) (inherit editor-canvas-on-scroll)
(define/override (on-scroll e) (define/override (on-scroll e)
(editor-canvas-on-scroll)) (if (or (eq? 'windows (system-type))
(eq? 'macosx (system-type)))
(queue-window-callback
this
(lambda () (editor-canvas-on-scroll)))
(editor-canvas-on-scroll)))
(super-new)))) (super-new))))

17
collects/mred/private/wxme/editor-canvas.ss
View File

@ -5,6 +5,7 @@
"editor-admin.ss" "editor-admin.ss"
"private.ss" "private.ss"
(only-in "cycle.ss" popup-menu%) (only-in "cycle.ss" popup-menu%)
(only-in "../helper.ss" queue-window-callback)
"wx.ss") "wx.ss")
(provide editor-canvas%) (provide editor-canvas%)
@ -350,9 +351,17 @@
(thunk))) (thunk)))
(define/override (on-set-focus) (define/override (on-set-focus)
(on-focus #t)) (if (eq? 'windows (system-type))
(queue-window-callback
this
(lambda () (on-focus #t)))
(on-focus #t)))
(define/override (on-kill-focus) (define/override (on-kill-focus)
(on-focus #f)) (if (eq? 'windows (system-type))
(queue-window-callback
this
(lambda () (on-focus #f)))
(on-focus #f)))
(define/public (is-focus-on?) focuson?) (define/public (is-focus-on?) focuson?)
@ -532,7 +541,9 @@
(if (and media (if (and media
(or (positive? y) (or (positive? y)
scroll-bottom-based?)) scroll-bottom-based?))
(let ([v (- (send media scroll-line-location (+ y scroll-offset)) (let ([v (- (if (send media locked-for-read?)
0.0
(send media scroll-line-location (+ y scroll-offset)))
ymargin)]) ymargin)])
(set-box! fy v) (set-box! fy v)
(when (and scroll-bottom-based? (when (and scroll-bottom-based?

12
collects/mred/private/wxme/editor-snip.ss
View File

@ -544,17 +544,23 @@
(def/override (get-num-scroll-steps) (def/override (get-num-scroll-steps)
(if editor (if editor
(send editor num-scroll-lines) (if (send editor locked-for-read?)
1
(send editor num-scroll-lines))
1)) 1))
(def/override (find-scroll-step [real? y]) (def/override (find-scroll-step [real? y])
(if editor (if editor
(send editor find-scroll-line (- y top-margin)) (if (send editor locked-for-read?)
0
(send editor find-scroll-line (- y top-margin)))
0)) 0))
(def/override (get-scroll-step-offset [exact-integer? n]) (def/override (get-scroll-step-offset [exact-integer? n])
(if editor (if editor
(+ (send editor scroll-line-location n) top-margin) (if (send editor locked-for-read?)
0
(+ (send editor scroll-line-location n) top-margin))
0)) 0))
(def/override (set-unmodified) (def/override (set-unmodified)

6
collects/mred/private/wxme/editor.ss
View File

@ -388,7 +388,7 @@
;; ---------------------------------------- ;; ----------------------------------------
(def/public (set-keymap [keymap% [k #f]]) (def/public (set-keymap [(make-or-false keymap%) [k #f]])
(set! s-keymap k)) (set! s-keymap k))
(def/public (get-keymap) s-keymap) (def/public (get-keymap) s-keymap)
(def/public (get-style-list) s-style-list) (def/public (get-style-list) s-style-list)
@ -540,7 +540,7 @@
[box? data-buffer]) [box? data-buffer])
(set-box! data-buffer (send f tell)) (set-box! data-buffer (send f tell))
(send f put-fixed 0) (send f put-fixed 0)
(send f put-bytes (string->bytes/utf-8 header-name)) (send f put-unterminated (string->bytes/utf-8 header-name))
#t) #t)
(def/public (end-write-header-footer-to-file [editor-stream-out% f] (def/public (end-write-header-footer-to-file [editor-stream-out% f]
@ -850,7 +850,7 @@
(values 0 size s naya)) (values 0 size s naya))
;; no room to grow, so drop an undo record ;; no room to grow, so drop an undo record
(begin (begin
(send c cancel) (send (vector-ref c start) cancel)
(vector-set! c start #f) (vector-set! c start #f)
(values (modulo (add1 start) size) (values (modulo (add1 start) size)
end end

39
collects/mred/private/wxme/mline.ss
View File

@ -633,7 +633,7 @@
(if (eq? asnip nexts) (if (eq? asnip nexts)
l l
(let ([l (+ l (snip->count asnip))]) (let ([l (+ l (snip->count asnip))])
(when (has-flag? (snip->count asnip) WIDTH-DEPENDS-ON-X) (when (has-flag? (snip->flags asnip) WIDTH-DEPENDS-ON-X)
(send asnip size-cache-invalid)) (send asnip size-cache-invalid))
(loop (snip->next asnip) l)))))]) (loop (snip->next asnip) l)))))])
@ -905,11 +905,12 @@ Debugging tools:
;; ------------------------------------------------------------ ;; ------------------------------------------------------------
(define (update-flow mline root-box media max-width dc) (define (update-flow mline root-box media max-width dc notify-delete notify-insert)
(define (flow-left) (define (flow-left)
(if (bit-overlap? (mline-flags mline) FLOW-LEFT) (if (bit-overlap? (mline-flags mline) FLOW-LEFT)
(if (and (not (eq? (mline-left mline) NIL)) (if (and (not (eq? (mline-left mline) NIL))
(update-flow (mline-left mline) root-box media max-width dc)) (update-flow (mline-left mline) root-box media max-width dc
notify-delete notify-insert))
#t #t
(begin (begin
(set-mline-flags! mline (- (mline-flags mline) FLOW-LEFT)) (set-mline-flags! mline (- (mline-flags mline) FLOW-LEFT))
@ -922,6 +923,7 @@ Debugging tools:
(let* ([first-line (box #f)] (let* ([first-line (box #f)]
[para (get-paragraph-style mline first-line)] [para (get-paragraph-style mline first-line)]
[line-max-width (get-line-max-width para max-width (unbox first-line))]) [line-max-width (get-line-max-width para max-width (unbox first-line))])
(assert (send media consistent-snip-lines 'pre-check-flow))
(if (send media check-flow line-max-width dc (get-location mline) (get-position mline) (mline-snip mline)) (if (send media check-flow line-max-width dc (get-location mline) (get-position mline) (mline-snip mline))
(do-flow) (do-flow)
(flow-right)))) (flow-right))))
@ -929,7 +931,8 @@ Debugging tools:
(define (flow-right) (define (flow-right)
(if (bit-overlap? (mline-flags mline) FLOW-RIGHT) (if (bit-overlap? (mline-flags mline) FLOW-RIGHT)
(if (and (not (eq? (mline-right mline) NIL)) (if (and (not (eq? (mline-right mline) NIL))
(update-flow (mline-right mline) root-box media max-width dc)) (update-flow (mline-right mline) root-box media max-width dc
notify-delete notify-insert))
#t #t
(begin (begin
(set-mline-flags! mline (- (mline-flags mline) FLOW-RIGHT)) (set-mline-flags! mline (- (mline-flags mline) FLOW-RIGHT))
@ -939,17 +942,20 @@ Debugging tools:
(let loop ([asnip (mline-snip mline)]) (let loop ([asnip (mline-snip mline)])
(if (eq? asnip (mline-last-snip mline)) (if (eq? asnip (mline-last-snip mline))
(begin (begin
(do-extend-line asnip) (do-extend-line mline asnip)
(assert (send media consistent-snip-lines 'post-do-extend-line))
#t) #t)
(if (has-flag? (snip->flags asnip) NEWLINE) (if (has-flag? (snip->flags asnip) NEWLINE)
(begin (begin
(do-new-line asnip) (do-new-line asnip)
(send media consistent-snip-lines 'post-do-new-line)
#t) #t)
(begin (begin
(set-snip-line! asnip mline) (set-snip-line! asnip mline)
(loop (snip->next asnip))))))) (loop (snip->next asnip)))))))
(define (do-new-line asnip) (define (do-new-line asnip)
;; items pushed to next line or new line was inserted ;; items pushed to next line or new line was inserted;
;; current line now ends with ansip (which used to be in the middle of the current line)
(let ([next (mline-next mline)]) (let ([next (mline-next mline)])
(let ([nextsnip (if next (let ([nextsnip (if next
(let loop ([nextsnip (snip->next asnip)]) (let loop ([nextsnip (snip->next asnip)])
@ -967,15 +973,18 @@ Debugging tools:
(set-mline-last-snip! newline (mline-last-snip mline)) (set-mline-last-snip! newline (mline-last-snip mline))
(set-mline-last-snip! mline asnip) (set-mline-last-snip! mline asnip)
(snips-to-line! newline)) (snips-to-line! newline)
;; just pushed to next line
(notify-insert newline))
;; some of this line pushed to next line --- or maybe multiple lines pushed
;; together into a later line
(begin (begin
(set-mline-last-snip! mline asnip) (set-mline-last-snip! mline asnip)
(set-snip-line! asnip mline) (set-snip-line! asnip mline)
(set-mline-snip! next (snip->next asnip)) (let ([nextsnip (snip->next asnip)])
(set-mline-snip! next nextsnip)
(snips-to-line! next))) (do-extend-line next nextsnip))))
(calc-line-length mline) (calc-line-length mline)
(mark-recalculate mline)))) (mark-recalculate mline))))
@ -992,9 +1001,12 @@ Debugging tools:
(if (and (mline-next mline) (if (and (mline-next mline)
(eq? asnip (mline-last-snip (mline-next mline)))) (eq? asnip (mline-last-snip (mline-next mline))))
;; a line was deleted ;; a line was deleted
(begin (delete (mline-next mline) root-box) #t) (let ([next (mline-next mline)])
(delete next root-box)
(notify-delete next)
#t)
#f)) #f))
(define (do-extend-line asnip) (define (do-extend-line mline asnip)
;; this line was extended ;; this line was extended
(let ([asnip (let ([asnip
(if asnip (if asnip
@ -1015,6 +1027,7 @@ Debugging tools:
(let ([next (mline-next mline)]) (let ([next (mline-next mline)])
(when next (when next
(delete next root-box) (delete next root-box)
(notify-delete delete)
(loop)))) (loop))))
#f))]) #f))])

5
collects/mred/private/wxme/private.ss
View File

@ -85,7 +85,6 @@
end-sequence-lock end-sequence-lock
check-flow check-flow
get-printing get-printing
is-printing?
do-begin-print do-begin-print
do-end-print do-end-print
do-has-print-page?) do-has-print-page?)
@ -96,9 +95,11 @@
get-s-last-snip get-s-last-snip
get-s-total-width get-s-total-width
get-s-total-height get-s-total-height
get-s-snips
refresh-box refresh-box
add-back-clickback add-back-clickback
do-insert-snips) do-insert-snips
consistent-snip-lines)
;; editor-admin% ;; editor-admin%
(define-local-member-name (define-local-member-name

4
collects/mred/private/wxme/snip-admin.ss
View File

@ -80,7 +80,9 @@
(let-boxes ([ok? #f] (let-boxes ([ok? #f]
[sl 0.0] [sl 0.0]
[st 0.0]) [st 0.0])
(set-box! ok? (send editor get-snip-location snip sl st #f)) (set-box! ok? (if (send editor locked-for-read?)
#f
(send editor get-snip-location snip sl st #f)))
(if ok? (if ok?
(let-boxes ([sr 0.0][sb 0.0]) (let-boxes ([sr 0.0][sb 0.0])
(send editor get-snip-location snip sr sb #t) (send editor get-snip-location snip sr sb #t)

8
collects/mred/private/wxme/snip.ss
View File

@ -643,7 +643,11 @@
(values n (values n
tabs tabs
space space
(if units? 1 str-w))) (if units?
1
(if (zero? str-w)
1.0
str-w))))
(values 0 (values 0
#() #()
TAB-WIDTH TAB-WIDTH
@ -1104,7 +1108,7 @@
(send mask2 ok?) (send mask2 ok?)
(= w (send mask2 get-width)) (= w (send mask2 get-width))
(= h (send mask2 get-height))) (= h (send mask2 get-height)))
(send mask get-argb-pixels 0 0 w h s1 #t))) (send mask2 get-argb-pixels 0 0 w h s2 #t)))
(equal? s1 s2))))))) (equal? s1 s2)))))))
(define/private (do-hash-code hash-code) (define/private (do-hash-code hash-code)

118
collects/mred/private/wxme/text.ss
View File

@ -233,10 +233,38 @@
(define initial-space 0.0) ; space from first line (define initial-space 0.0) ; space from first line
(define initial-line-base 0.0) ; inverse descent from first line (define initial-line-base 0.0) ; inverse descent from first line
(define/public (get-s-snips) snips)
(define/public (get-s-last-snip) last-snip) (define/public (get-s-last-snip) last-snip)
(define/public (get-s-total-width) total-width) (define/public (get-s-total-width) total-width)
(define/public (get-s-total-height) total-height) (define/public (get-s-total-height) total-height)
(define/public (consistent-snip-lines who)
(unless (eq? first-line (mline-first (unbox line-root-box)))
(error who "bad first line"))
(unless (eq? last-line (mline-last (unbox line-root-box)))
(error who "bad last line"))
(let loop ([line first-line]
[snip snips])
(unless (eq? snips (mline-snip first-line))
(error who "bad start snip"))
(let sloop ([snip snip])
(unless (eq? line (snip->line snip))
(error who "snip's line is wrong: ~s ~s" snip (snip->line snip)))
(if (eq? snip (mline-last-snip line))
(if (mline-next line)
(begin
(unless (has-flag? (snip->flags snip) NEWLINE)
(error who "strange line ending"))
(loop (mline-next line) (snip->next snip)))
(unless (eq? last-snip snip)
(error who "bad last snip")))
(begin
(when (or (has-flag? (snip->flags snip) NEWLINE)
(has-flag? (snip->flags snip) HARD-NEWLINE))
(error who "mid-line NEWLINE"))
(sloop (snip->next snip))))))
#t)
(define caret-style #f) (define caret-style #f)
(define dragstart 0) (define dragstart 0)
@ -593,14 +621,15 @@
(def/override (blink-caret) (def/override (blink-caret)
(if s-caret-snip (if s-caret-snip
(let-boxes ([dx 0.0] (when s-admin
[dy 0.0] (let-boxes ([dx 0.0]
[dc #f]) [dy 0.0]
(set-box! dc (send s-admin get-dc dx dy)) [dc #f])
(when dc (set-box! dc (send s-admin get-dc dx dy))
(let-boxes ([x 0.0] [y 0.0]) (when dc
(get-snip-location s-caret-snip x y) (let-boxes ([x 0.0] [y 0.0])
(send s-caret-snip blink-caret dc (- x dx) (- y dy))))) (get-snip-location s-caret-snip x y)
(send s-caret-snip blink-caret dc (- x dx) (- y dy))))))
(if (too-busy-to-refresh?) (if (too-busy-to-refresh?)
;; we're busy; go away ;; we're busy; go away
(void) (void)
@ -1036,7 +1065,8 @@
;; - already at top ;; - already at top
(let-boxes ([scroll-left 0.0] [vy 0.0] (let-boxes ([scroll-left 0.0] [vy 0.0]
[scroll-width 0.0] [scroll-height 0.0]) [scroll-width 0.0] [scroll-height 0.0])
(send s-admin get-view scroll-left vy scroll-width scroll-height) (when s-admin
(send s-admin get-view scroll-left vy scroll-width scroll-height))
;; top line should be completely visible as bottom line after ;; top line should be completely visible as bottom line after
;; scrolling ;; scrolling
(let* ([top (find-scroll-line vy)] (let* ([top (find-scroll-line vy)]
@ -1094,7 +1124,8 @@
(if (eq? 'page kind) (if (eq? 'page kind)
(let-boxes ([scroll-left 0.0] [vy 0.0] (let-boxes ([scroll-left 0.0] [vy 0.0]
[scroll-width 0.0] [scroll-height 0.0]) [scroll-width 0.0] [scroll-height 0.0])
(send s-admin get-view scroll-left vy scroll-width scroll-height) (when s-admin
(send s-admin get-view scroll-left vy scroll-width scroll-height))
;; last fully-visible line is the new top line ;; last fully-visible line is the new top line
(let* ([newtop (find-scroll-line (+ vy scroll-height))] (let* ([newtop (find-scroll-line (+ vy scroll-height))]
[y (scroll-line-location (+ newtop 1))] [y (scroll-line-location (+ newtop 1))]
@ -1180,6 +1211,7 @@
;; ---------------------------------------- ;; ----------------------------------------
(define/private (do-insert isnip str snipsl start end scroll-ok?) (define/private (do-insert isnip str snipsl start end scroll-ok?)
(assert (consistent-snip-lines 'do-insert))
(unless (or write-locked? (unless (or write-locked?
s-user-locked? s-user-locked?
(start . < . 0)) (start . < . 0))
@ -1274,7 +1306,8 @@
(cond (cond
[(or isnip snipsl) [(or isnip snipsl)
(insert-snips (if isnip (list isnip) snipsl) start success-finish fail-finish)] (insert-snips (if isnip (list isnip) snipsl) start success-finish fail-finish)]
[else (insert-string str start success-finish fail-finish)]))))))) [else (insert-string str start success-finish fail-finish)])))))
(assert (consistent-snip-lines 'post-do-insert))))
(define/private (insert-snips snipsl start success-finish fail-finish) (define/private (insert-snips snipsl start success-finish fail-finish)
(let ([addlen (for/fold ([addlen 0]) (let ([addlen (for/fold ([addlen 0])
@ -1313,6 +1346,9 @@
(not (has-flag? (snip->flags isnip) HARD-NEWLINE))) (not (has-flag? (snip->flags isnip) HARD-NEWLINE)))
(set-snip-flags! isnip (remove-flag (snip->flags isnip) NEWLINE))) (set-snip-flags! isnip (remove-flag (snip->flags isnip) NEWLINE)))
(assert (consistent-snip-lines 'inner-insert))
(let-values ([(before-snip inserted-new-line?) (let-values ([(before-snip inserted-new-line?)
(if (and (zero? len) (not did-one?)) (if (and (zero? len) (not did-one?))
@ -1348,6 +1384,10 @@
(set! num-valid-lines (add1 num-valid-lines)) (set! num-valid-lines (add1 num-valid-lines))
#t) #t)
(begin (begin
;; The former last snip might still have a NEWLINE
;; flag due to line-flowing
(when (has-flag? (snip->flags gsnip) NEWLINE)
(set-snip-flags! gsnip (remove-flag (snip->flags gsnip) NEWLINE)))
(set-snip-line! isnip last-line) (set-snip-line! isnip last-line)
(when (not (mline-snip last-line)) (when (not (mline-snip last-line))
(set-mline-snip! last-line isnip)) (set-mline-snip! last-line isnip))
@ -1409,6 +1449,8 @@
(set! first-line (mline-first (unbox line-root-box))) (set! first-line (mline-first (unbox line-root-box)))
(set! last-line (mline-last (unbox line-root-box))) (set! last-line (mline-last (unbox line-root-box)))
(assert (consistent-snip-lines 'inner-insert2))
(loop #t (loop #t
before-snip before-snip
(or inserted-line? inserted-new-line?) (or inserted-line? inserted-new-line?)
@ -1522,9 +1564,8 @@
(set! first-line (mline-first (unbox line-root-box))) (set! first-line (mline-first (unbox line-root-box)))
(set! last-line (mline-last (unbox line-root-box))) (set! last-line (mline-last (unbox line-root-box)))
(set! len (+ len addlen)) (set! len (+ len addlen))
(unless (= (last-position) (+ (mline-get-position last-line) (assert (= (last-position) (+ (mline-get-position last-line)
(mline-len last-line))) (mline-len last-line))))
(error "yuck out"))
(success-finish addlen inserted-line?)) (success-finish addlen inserted-line?))
(begin (begin
(when (equal? (string-ref str sp) #\return) (when (equal? (string-ref str sp) #\return)
@ -1603,6 +1644,8 @@
(when (has-flag? (snip->flags tabsnip) CAN-SPLIT) (when (has-flag? (snip->flags tabsnip) CAN-SPLIT)
(set-snip-flags! tabsnip (set-snip-flags! tabsnip
(remove-flag (snip->flags tabsnip) CAN-SPLIT))) (remove-flag (snip->flags tabsnip) CAN-SPLIT)))
(when (has-flag? (snip->flags snip) NEWLINE)
(set-snip-flags! tabsnip (add-flag (snip->flags tabsnip) NEWLINE)))
(splice-snip tabsnip (snip->prev snip) (snip->next snip)) (splice-snip tabsnip (snip->prev snip) (snip->next snip))
(set-snip-line! tabsnip (snip->line snip)) (set-snip-line! tabsnip (snip->line snip))
@ -1679,6 +1722,7 @@
(set! typing-streak? #t))) (set! typing-streak? #t)))
(define/private (do-delete start end with-undo? [scroll-ok? #t]) (define/private (do-delete start end with-undo? [scroll-ok? #t])
(assert (consistent-snip-lines 'do-delete))
(unless (or write-locked? s-user-locked?) (unless (or write-locked? s-user-locked?)
(let-values ([(start end set-caret-style?) (let-values ([(start end set-caret-style?)
(if (eq? end 'back) (if (eq? end 'back)
@ -1770,7 +1814,8 @@
(set-mline-last-snip! line prev) (set-mline-last-snip! line prev)
;; maybe deleted extra ghost line: ;; maybe deleted extra ghost line:
extra-line?))] extra-line?))]
[else #f]))]) [else
#f]))])
(delete-snip snip) (delete-snip snip)
(loop prev (loop prev
(or deleted-line? (or deleted-line?
@ -1785,7 +1830,7 @@
(set! first-line (mline-first (unbox line-root-box))) (set! first-line (mline-first (unbox line-root-box)))
(set! last-line (mline-last (unbox line-root-box))) (set! last-line (mline-last (unbox line-root-box)))
(let-values ([(line moved-to-next?) (let-values ([(line moved-to-next?)
(if start-snip (if start-snip
(if (has-flag? (snip->flags start-snip) NEWLINE) (if (has-flag? (snip->flags start-snip) NEWLINE)
@ -1811,6 +1856,8 @@
(when (max-width . >= . 0) (when (max-width . >= . 0)
(mline-mark-check-flow line) (mline-mark-check-flow line)
(let ([next (mline-next line)])
(when next (mline-mark-check-flow next)))
(let ([prev (mline-prev line)]) (let ([prev (mline-prev line)])
(when (and prev (when (and prev
(has-flag? (snip->flags (mline-last-snip prev)) HARD-NEWLINE)) (has-flag? (snip->flags (mline-last-snip prev)) HARD-NEWLINE))
@ -1896,7 +1943,8 @@
(when update-cursor? (when update-cursor?
(when s-admin (when s-admin
(send s-admin update-cursor)))))))))))))) (send s-admin update-cursor))))))))))))
(assert (consistent-snip-lines 'post-do-delete))))
(define/public (delete . args) (define/public (delete . args)
(case-args (case-args
@ -2213,9 +2261,12 @@
(if read-locked? (if read-locked?
#\nul #\nul
(let-values ([(snip s-pos) (find-snip/pos (max 0 (min start len)) 'after)]) (let-values ([(snip s-pos) (find-snip/pos (max 0 (min start len)) 'after)])
(let ([buffer (make-string 1)]) (let ([delta (- start s-pos)])
(send snip get-text! buffer (- start s-pos) 1 0) (if (delta . >= . (snip->count snip))
(string-ref buffer 0))))) #\nul
(let ([buffer (make-string 1)])
(send snip get-text! buffer delta 1 0)
(string-ref buffer 0)))))))
;; ---------------------------------------- ;; ----------------------------------------
@ -2929,7 +2980,8 @@
(let ([dc (send s-admin get-dc)]) (let ([dc (send s-admin get-dc)])
(let-boxes ([w 0.0] (let-boxes ([w 0.0]
[h 0.0]) [h 0.0])
(send thesnip get-extent dc (unbox x) (unbox y) w h #f #f #f #f) (when dc
(send thesnip get-extent dc (unbox x) (unbox y) w h #f #f #f #f))
(set! write-locked? wl?) (set! write-locked? wl?)
(set! flow-locked? fl?) (set! flow-locked? fl?)
@ -3054,7 +3106,8 @@
(let-boxes ([h 0.0] (let-boxes ([h 0.0]
[descent 0.0] [descent 0.0]
[space 0.0]) [space 0.0])
(send snip get-extent dc horiz topy #f h descent space #f #F) (when dc
(send snip get-extent dc horiz topy #f h descent space #f #F))
(let ([align (send (snip->style snip) get-alignment)]) (let ([align (send (snip->style snip) get-alignment)])
(cond (cond
[(eq? 'bottom align) [(eq? 'bottom align)
@ -3505,6 +3558,7 @@
;; ---------------------------------------- ;; ----------------------------------------
(define/private (do-change-style start end new-style delta restore-sel? counts-as-mod?) (define/private (do-change-style start end new-style delta restore-sel? counts-as-mod?)
(assert (consistent-snip-lines 'do-change-style))
(unless (or write-locked? (unless (or write-locked?
s-user-locked? s-user-locked?
(and new-style (and new-style
@ -3631,7 +3685,8 @@
(check-merge-snips start) (check-merge-snips start)
(check-merge-snips end))) (check-merge-snips end)))
(after-change-style start (- end start))))))))])))))) (after-change-style start (- end start))))))))]))))
(assert (consistent-snip-lines 'post-do-change-style))))
(def/public (change-style [(make-or-false (make-alts style<%> style-delta%)) st] (def/public (change-style [(make-or-false (make-alts style<%> style-delta%)) st]
[(make-alts exact-nonnegative-integer? (symbol-in start)) [start 'start]] [(make-alts exact-nonnegative-integer? (symbol-in start)) [start 'start]]
@ -4498,6 +4553,8 @@
#t))] #t))]
[(and (c . < . 0) (b . > . startp)) [(and (c . < . 0) (b . > . startp))
;; overflow, but previous wordbreak was before this snip ;; overflow, but previous wordbreak was before this snip
(when had-newline?
(set-snip-flags! snip (add-flag (snip->flags snip) NEWLINE)))
b] b]
[else [else
;; overflow: we have to break the word anyway ;; overflow: we have to break the word anyway
@ -4561,7 +4618,20 @@
(let ([w (- max-width CURSOR-WIDTH)]) (let ([w (- max-width CURSOR-WIDTH)])
(let loop ([-changed? #f]) (let loop ([-changed? #f])
(if (mline-update-flow (unbox line-root-box) line-root-box this w dc) (if (begin0
(mline-update-flow (unbox line-root-box) line-root-box this w dc
(lambda (del-line)
(when (eq? del-line first-line)
(set! first-line (mline-first (unbox line-root-box))))
(when (eq? del-line last-line)
(set! last-line (mline-last (unbox line-root-box)))))
(lambda (ins-line)
(when (not (mline-prev ins-line))
(set! first-line ins-line))
(when (not (mline-next ins-line))
(set! last-line ins-line))))
(assert (consistent-snip-lines 'post-update-flow)))
(loop #t) (loop #t)
(begin (begin

214
collects/mred/private/wxme/wordbreak.ss
View File

@ -41,113 +41,115 @@
(define/top (standard-wordbreak [text% win] (define/top (standard-wordbreak [text% win]
[(make-or-false (make-box exact-nonnegative-integer?)) startp] [(make-or-false (make-box exact-nonnegative-integer?)) startp]
[(make-or-false (make-box exact-nonnegative-integer?)) endp] [(make-or-false (make-box exact-nonnegative-integer?)) endp]
[(symbol-in caret line selection user1 user2)reason]) [(symbol-in caret line selection user1 user2) reason])
(with-method ([get-map ((send win get-wordbreak-map) get-map)]) (let ([wb (send win get-wordbreak-map)])
(define (nonbreak? ch) (memq reason (get-map ch))) (when wb
(with-method ([get-map (wb get-map)])
(define (nonbreak? ch) (memq reason (get-map ch)))
(when startp (when startp
(let* ([start (unbox startp)] (let* ([start (unbox startp)]
[pstart start] [pstart start]
[lstart (send win find-newline 'backward start 0)] [lstart (send win find-newline 'backward start 0)]
[lstart (if lstart [lstart (if lstart
(if (eq? 'caret reason) (if (eq? 'caret reason)
(or (and (positive? lstart) (or (and (positive? lstart)
(send win find-newline 'backward (sub1 lstart) 0)) (send win find-newline 'backward (sub1 lstart) 0))
0) 0)
lstart) lstart)
0)] 0)]
[lend (min (+ start 1) (send win last-position))] [lend (min (+ start 1) (send win last-position))]
[tstart (if ((- start lstart) . > . MAX-DIST-TRY) [tstart (if ((- start lstart) . > . MAX-DIST-TRY)
(- start MAX-DIST-TRY) (- start MAX-DIST-TRY)
lstart)] lstart)]
[text (send win get-text tstart lend)] [text (send win get-text tstart lend)]
[start (- start tstart)] [start (- start tstart)]
[pstart (- pstart tstart)]) [pstart (- pstart tstart)])
(let ploop ([phase1-complete? #f] (let ploop ([phase1-complete? #f]
[phase2-complete? #f] [phase2-complete? #f]
[start start] [start start]
[pstart pstart] [pstart pstart]
[text text] [text text]
[tstart tstart]) [tstart tstart])
(let*-values ([(start phase1-complete?) (let*-values ([(start phase1-complete?)
(if phase1-complete? (if phase1-complete?
(values start #t) (values start #t)
(let ([start (if (and (positive? start) (let ([start (if (and (positive? start)
(nonbreak? (string-ref* text start))) (nonbreak? (string-ref* text start)))
(sub1 start) (sub1 start)
start)]) start)])
(values start (values start
(not (nonbreak? (string-ref* text start))))))] (not (nonbreak? (string-ref* text start))))))]
[(start phase2-complete?) [(start phase2-complete?)
(if (not (eq? 'selection reason)) (if (not (eq? 'selection reason))
(if (not phase2-complete?) (if (not phase2-complete?)
(let loop ([start start]) (let loop ([start start])
(if (and (positive? start) (if (and (positive? start)
(not (nonbreak? (string-ref* text start))))
(loop (sub1 start))
(if (nonbreak? (string-ref* text start))
(values start #t)
(values start #f))))
(values start #t))
(values start phase2-complete?))])
(let loop ([start start])
(if (and (positive? start)
(nonbreak? (string-ref* text start)))
(loop (sub1 start))
(let ([start (if (and (start . < . pstart)
(not (nonbreak? (string-ref* text start)))) (not (nonbreak? (string-ref* text start))))
(loop (sub1 start)) (add1 start)
(if (nonbreak? (string-ref* text start)) start)])
(values start #t) (if (and (zero? start)
(values start #f)))) (not (= lstart tstart)))
(values start #t)) (ploop phase1-complete?
(values start phase2-complete?))]) phase2-complete?
(let loop ([start start]) (+ start (- tstart lstart))
(if (and (positive? start) (+ pstart (- tstart lstart))
(nonbreak? (string-ref* text start))) (send win get-text lstart lend)
(loop (sub1 start)) lstart)
(let ([start (if (and (start . < . pstart) (set-box! startp (+ start tstart))))))))))
(not (nonbreak? (string-ref* text start))))
(add1 start)
start)])
(if (and (zero? start)
(not (= lstart tstart)))
(ploop phase1-complete?
phase2-complete?
(+ start (- tstart lstart))
(+ pstart (- tstart lstart))
(send win get-text lstart lend)
lstart)
(set-box! startp (+ start tstart))))))))))
(when endp
(let* ([end (unbox endp)]
[lstart end]
[lend (send win find-newline 'forward end)]
[lend (if lend
(if (eq? 'caret reason)
(or (send win find-newline 'forward (+ lend 1))
(send win last-position))
lend)
(send win last-position))]
[tend (if ((- lend end) . > . MAX-DIST-TRY)
(+ end MAX-DIST-TRY)
lend)]
[text (send win get-text lstart tend)]
[end (- end lstart)]
[lend (- lend lstart)]
[tend (- tend lstart)])
(let ploop ([phase1-complete? #f] (when endp
[text text] (let* ([end (unbox endp)]
[tend tend] [lstart end]
[end end]) [lend (send win find-newline 'forward end)]
(let-values ([(end phase1-complete?) [lend (if lend
(if phase1-complete? (if (eq? 'caret reason)
(values end #t) (or (send win find-newline 'forward (+ lend 1))
(let loop ([end end]) (send win last-position))
(if (and (end . < . tend) lend)
(not (nonbreak? (string-ref* text end)))) (send win last-position))]
(loop (add1 end)) [tend (if ((- lend end) . > . MAX-DIST-TRY)
(if (end . < . tend) (+ end MAX-DIST-TRY)
(values end #t) lend)]
(values end #f)))))]) [text (send win get-text lstart tend)]
(let loop ([end end]) [end (- end lstart)]
(if (and (end . < . tend) [lend (- lend lstart)]
(nonbreak? (string-ref* text end))) [tend (- tend lstart)])
(loop (add1 end))
(if (and (= tend end) (not (= lend tend))) (let ploop ([phase1-complete? #f]
(ploop phase1-complete? [text text]
(send win get-text lstart (+ lstart lend)) [tend tend]
lend [end end])
end) (let-values ([(end phase1-complete?)
(set-box! endp (+ end lstart))))))))))) (if phase1-complete?
(values end #t)
(let loop ([end end])
(if (and (end . < . tend)
(not (nonbreak? (string-ref* text end))))
(loop (add1 end))
(if (end . < . tend)
(values end #t)
(values end #f)))))])
(let loop ([end end])
(if (and (end . < . tend)
(nonbreak? (string-ref* text end)))
(loop (add1 end))
(if (and (= tend end) (not (= lend tend)))
(ploop phase1-complete?
(send win get-text lstart (+ lstart lend))
lend
end)
(set-box! endp (+ end lstart)))))))))))))

2
collects/mzlib/control.ss
View File

@ -73,7 +73,7 @@
;; call-with-control, parameterized over whether to keep the ;; call-with-control, parameterized over whether to keep the
;; prompt (if the prompt's handler gives us the option of ;; prompt (if the prompt's handler gives us the option of
;; removing it). The generated function is the same ;; removing it). The generated function is the same
;; a fcontrol when `abort-cc' is `abort-current-continuation'. ;; as fcontrol when `abort-cc' is `abort-current-continuation'.
(define (make-call-with-control abort-cc) (define (make-call-with-control abort-cc)
;; Uses call/cc to always keep the enclosing prompt. ;; Uses call/cc to always keep the enclosing prompt.
(letrec ([call-with-control (letrec ([call-with-control

10
collects/mzlib/unit.ss
View File

@ -234,17 +234,23 @@
(define-signature-form (open stx) (define-signature-form (open stx)
(define (build-sig-elems sig)
(map (λ (p c)
(if c #`(contracted [#,(car p) #,c]) (car p)))
(car sig)
(cadddr sig)))
(parameterize ([error-syntax stx]) (parameterize ([error-syntax stx])
(syntax-case stx () (syntax-case stx ()
((_ export-spec) ((_ export-spec)
(let ([sig (process-spec #'export-spec)]) (let ([sig (process-spec #'export-spec)])
(with-syntax ((((int . ext) ...) (car sig)) (with-syntax (((sig-elem ...)
(build-sig-elems sig))
((renames ((renames
(((mac-name ...) mac-body) ...) (((mac-name ...) mac-body) ...)
(((val-name ...) val-body) ...)) (((val-name ...) val-body) ...))
(build-val+macro-defs sig))) (build-val+macro-defs sig)))
(syntax->list (syntax->list
#'(int ... #'(sig-elem ...
(define-syntaxes . renames) (define-syntaxes . renames)
(define-syntaxes (mac-name ...) mac-body) ... (define-syntaxes (mac-name ...) mac-body) ...
(define-values (val-name ...) val-body) ...))))) (define-values (val-name ...) val-body) ...)))))

2
collects/plot/plot.scrbl
View File

@ -44,7 +44,7 @@ plotted.
] ]
The display area and appearance of the plot can be changed by adding The display area and appearance of the plot can be changed by adding
bracjets argument/value pairs after the first argument. brackets argument/value pairs after the first argument.
@schemeblock[ @schemeblock[
(plot (line (lambda (x) (sin x))) (plot (line (lambda (x) (sin x)))

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

@ -1117,7 +1117,7 @@
dsc dsc
sc)) sc))
dsc dsc
'codom-side-conditions-rewritten `codom-side-conditions-rewritten
'name))) 'name)))
(term-define-fn name name2)) (term-define-fn name name2))
'disappeared-use 'disappeared-use
@ -1359,7 +1359,7 @@
[(_ name (names rhs ...) ...) [(_ name (names rhs ...) ...)
(identifier? (syntax name)) (identifier? (syntax name))
(begin (begin
(check-rhss-not-empty stx (cddr (syntax-e stx))) (check-rhss-not-empty stx (cddr (syntax->list stx)))
(with-syntax ([((nt-names orig) ...) (pull-out-names 'define-language stx #'(names ...))]) (with-syntax ([((nt-names orig) ...) (pull-out-names 'define-language stx #'(names ...))])
(with-syntax ([(subst-names ...) (generate-temporaries (syntax->list #'(nt-names ...)))]) (with-syntax ([(subst-names ...) (generate-temporaries (syntax->list #'(nt-names ...)))])
(syntax/loc stx (syntax/loc stx
@ -1511,7 +1511,7 @@
(raise-syntax-error 'define-extended-langauge "expected an identifier" stx #'name)) (raise-syntax-error 'define-extended-langauge "expected an identifier" stx #'name))
(unless (identifier? (syntax orig-lang)) (unless (identifier? (syntax orig-lang))
(raise-syntax-error 'define-extended-langauge "expected an identifier" stx #'orig-lang)) (raise-syntax-error 'define-extended-langauge "expected an identifier" stx #'orig-lang))
(check-rhss-not-empty stx (cdddr (syntax-e stx))) (check-rhss-not-empty stx (cdddr (syntax->list stx)))
(let ([old-names (language-id-nts #'orig-lang 'define-extended-language)]) (let ([old-names (language-id-nts #'orig-lang 'define-extended-language)])
(with-syntax ([((new-nt-names orig) ...) (append (pull-out-names 'define-language stx #'(names ...)) (with-syntax ([((new-nt-names orig) ...) (append (pull-out-names 'define-language stx #'(names ...))
(map (λ (x) #`(#,x #f)) old-names))]) (map (λ (x) #`(#,x #f)) old-names))])

16
collects/redex/private/tl-test.ss
View File

@ -571,6 +571,22 @@
(test (term (foo y)) (test (term (foo y))
(term docare))) (term docare)))
(let ()
(define f-called? #f)
(define-metafunction empty-language
f : (side-condition any_1 (begin (set! f-called? #t) #t)) -> any
[(f any_1) any_1])
(test (term (f 1)) 1)
(test f-called? #t))
(let ()
(define g-called? #f)
(define-metafunction empty-language
g : any -> (side-condition any_1 (begin (set! g-called? #t) #t))
[(g any_1) any_1])
(test (term (g 1)) 1)
(test g-called? #t))
;; test that tracing works properly ;; test that tracing works properly
;; note that caching comes into play here (which is why we don't see the recursive calls) ;; note that caching comes into play here (which is why we don't see the recursive calls)
(let () (let ()

2
collects/scheme/private/cond.ss
View File

@ -68,7 +68,7 @@
(if else? (if else?
(if first? (if first?
;; first => be careful not to introduce a splicable begin... ;; first => be careful not to introduce a splicable begin...
`(,(quote-syntax if) #t ,(cons (quote-syntax begin) value) (void)) `(,(quote-syntax #%expression) ,(cons (quote-syntax begin) value))
;; we're in an `if' branch already... ;; we're in an `if' branch already...
(cons (quote-syntax begin) value)) (cons (quote-syntax begin) value))
(if (stx-null? value) (if (stx-null? value)

8
collects/scribble/lp/lang/lang.ss
View File

@ -6,6 +6,14 @@
(require (for-syntax scheme/base syntax/boundmap scheme/list syntax/kerncase (require (for-syntax scheme/base syntax/boundmap scheme/list syntax/kerncase
syntax/strip-context)) syntax/strip-context))
;; --- MF: bad hack for getting rid of comments
(provide code:comment)
(define-syntax (code:comment stx)
(if (eq? (syntax-local-context) 'expression)
(syntax (void))
(syntax (define (f x) x))))
;; --- MF
(begin-for-syntax (begin-for-syntax
(define first-id #f) (define first-id #f)
(define main-id #f) (define main-id #f)

105
collects/scribble/scheme.ss
View File

@ -529,13 +529,15 @@
(+ (syntax-column c) delta))) (+ (syntax-column c) delta)))
(set! src-col (+ orig-col (syntax-span c)))))] (set! src-col (+ orig-col (syntax-span c)))))]
[(graph-reference? (syntax-e c)) [(graph-reference? (syntax-e c))
(advance c init-line!)
(out (format "#~a#" (unbox (graph-reference-bx (syntax-e c)))) (out (format "#~a#" (unbox (graph-reference-bx (syntax-e c))))
(if (positive? quote-depth) (if (positive? quote-depth)
value-color value-color
paren-color))] paren-color))
(set! src-col (+ src-col (syntax-span c)))]
[(graph-defn? (syntax-e c)) [(graph-defn? (syntax-e c))
(advance c init-line!)
(let ([bx (graph-defn-bx (syntax-e c))]) (let ([bx (graph-defn-bx (syntax-e c))])
(set-box! bx 0)
(out (format "#~a=" (unbox bx)) (out (format "#~a=" (unbox bx))
(if (positive? quote-depth) (if (positive? quote-depth)
value-color value-color
@ -723,12 +725,12 @@
(define-struct graph-defn (r bx)) (define-struct graph-defn (r bx))
(define (syntax-ize v col [line 1]) (define (syntax-ize v col [line 1])
(do-syntax-ize v col line (make-hasheq) #f)) (do-syntax-ize v col line (box #hasheq()) #f))
(define (graph-count ht graph?) (define (graph-count ht graph?)
(and graph? (and graph?
(let ([n (hash-ref ht '#%graph-count 0)]) (let ([n (hash-ref (unbox ht) '#%graph-count 0)])
(hash-set! ht '#%graph-count (add1 n)) (set-box! ht (hash-set (unbox ht) '#%graph-count (add1 n)))
n))) n)))
(define (do-syntax-ize v col line ht graph?) (define (do-syntax-ize v col line ht graph?)
@ -746,7 +748,7 @@
s s
s s
(just-context-ctx v)))] (just-context-ctx v)))]
[(hash-ref ht v #f) [(hash-ref (unbox ht) v #f)
=> (lambda (m) => (lambda (m)
(unless (unbox m) (unless (unbox m)
(set-box! m #t)) (set-box! m #t))
@ -770,62 +772,70 @@
(vector? v) (vector? v)
(and (struct? v) (and (struct? v)
(prefab-struct-key v))) (prefab-struct-key v)))
(let ([graph-box (box (graph-count ht graph?))]) (let ([orig-ht (unbox ht)]
(hash-set! ht v graph-box) [graph-box (box (graph-count ht graph?))])
(let ([r (let* ([vec-sz (+ (if graph? (set-box! ht (hash-set (unbox ht) v graph-box))
(+ 2 (string-length (format "~a" (unbox graph-box)))) (let* ([graph-sz (if graph?
0) (+ 2 (string-length (format "~a" (unbox graph-box))))
0)]
[vec-sz (cond
[(vector? v)
(+ 1 #;(string-length (format "~a" (vector-length v))))]
[(struct? v) 2]
[else 0])]
[r (let ([l (let loop ([col (+ col 1 vec-sz graph-sz)]
[v (cond
[(vector? v)
(vector->short-list v values)]
[(struct? v)
(cons (prefab-struct-key v)
(cdr (vector->list (struct->vector v))))]
[else v])])
(if (null? v)
null
(let ([i (do-syntax-ize (car v) col line ht #f)])
(cons i
(loop (+ col 1 (syntax-span i)) (cdr v))))))])
(datum->syntax #f
(cond (cond
[(vector? v) [(vector? v) (short-list->vector v l)]
(+ 1 #;(string-length (format "~a" (vector-length v))))] [(struct? v)
[(struct? v) 2] (apply make-prefab-struct (prefab-struct-key v) (cdr l))]
[else 0]))]) [else l])
(let ([l (let loop ([col (+ col 1 vec-sz)] (vector #f line
[v (cond (+ graph-sz col)
[(vector? v) (+ 1 graph-sz col)
(vector->short-list v values)] (+ 2
[(struct? v) vec-sz
(cons (prefab-struct-key v) (if (zero? (length l))
(cdr (vector->list (struct->vector v))))] 0
[else v])]) (sub1 (length l)))
(if (null? v) (apply + (map syntax-span l))))))])
null
(let ([i (do-syntax-ize (car v) col line ht #f)])
(cons i
(loop (+ col 1 (syntax-span i)) (cdr v))))))])
(datum->syntax #f
(cond
[(vector? v) (short-list->vector v l)]
[(struct? v)
(apply make-prefab-struct (prefab-struct-key v) (cdr l))]
[else l])
(vector #f line col (+ 1 col)
(+ 2
vec-sz
(if (zero? (length l))
0
(sub1 (length l)))
(apply + (map syntax-span l)))))))])
(unless graph? (unless graph?
(hash-set! ht v #f)) (set-box! ht (hash-set (unbox ht) v #f)))
(cond (cond
[graph? (datum->syntax #f [graph? (datum->syntax #f
(make-graph-defn r graph-box) (make-graph-defn r graph-box)
r)] (vector #f (syntax-line r)
(- (syntax-column r) graph-sz)
(- (syntax-position r) graph-sz)
(+ (syntax-span r) graph-sz)))]
[(unbox graph-box) [(unbox graph-box)
;; Go again, this time knowing that there will be a graph: ;; Go again, this time knowing that there will be a graph:
(set-box! ht orig-ht)
(do-syntax-ize v col line ht #t)] (do-syntax-ize v col line ht #t)]
[else r])))] [else r])))]
[(pair? v) [(pair? v)
(let ([graph-box (box (graph-count ht graph?))]) (let ([orig-ht (unbox ht)]
(hash-set! ht v graph-box) [graph-box (box (graph-count ht graph?))])
(set-box! ht (hash-set (unbox ht) v graph-box))
(let* ([inc (if graph? (let* ([inc (if graph?
(+ 2 (string-length (format "~a" (unbox graph-box)))) (+ 2 (string-length (format "~a" (unbox graph-box))))
0)] 0)]
[a (do-syntax-ize (car v) (+ col 1 inc) line ht #f)] [a (do-syntax-ize (car v) (+ col 1 inc) line ht #f)]
[sep (if (and (pair? (cdr v)) [sep (if (and (pair? (cdr v))
;; FIXME: what if it turns out to be a graph reference? ;; FIXME: what if it turns out to be a graph reference?
(not (hash-ref ht (cdr v) #f))) (not (hash-ref (unbox ht) (cdr v) #f)))
0 0
3)] 3)]
[b (do-syntax-ize (cdr v) (+ col 1 inc (syntax-span a) sep) line ht #f)]) [b (do-syntax-ize (cdr v) (+ col 1 inc (syntax-span a) sep) line ht #f)])
@ -834,7 +844,7 @@
(vector #f line (+ col inc) (+ 1 col inc) (vector #f line (+ col inc) (+ 1 col inc)
(+ 2 sep (syntax-span a) (syntax-span b))))]) (+ 2 sep (syntax-span a) (syntax-span b))))])
(unless graph? (unless graph?
(hash-set! ht v #f)) (set-box! ht (hash-set (unbox ht) v #f)))
(cond (cond
[graph? (datum->syntax #f [graph? (datum->syntax #f
(make-graph-defn r graph-box) (make-graph-defn r graph-box)
@ -842,6 +852,7 @@
(+ inc (syntax-span r))))] (+ inc (syntax-span r))))]
[(unbox graph-box) [(unbox graph-box)
;; Go again... ;; Go again...
(set-box! ht orig-ht)
(do-syntax-ize v col line ht #t)] (do-syntax-ize v col line ht #t)]
[else r]))))] [else r]))))]
[(box? v) [(box? v)

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

@ -734,7 +734,7 @@ See also @method[editor<%> set-load-overwrites-styles].
} }
@defmethod[(get-max-height) @defmethod[(get-max-height)
(or/c (and/c real? (not/c negative?)) (one/of 'none))]{ (or/c (and/c real? (not/c negative?)) 'none)]{
Gets the maximum display height for the contents of the editor; zero or Gets the maximum display height for the contents of the editor; zero or
@scheme['none] indicates that there is no maximum. @scheme['none] indicates that there is no maximum.
@ -770,7 +770,7 @@ If the @techlink{display} is an editor canvas, see also
} }
@defmethod[(get-max-width) @defmethod[(get-max-width)
(or/c (and/c real? (not/c negative?)) (one/of 'none))]{ (or/c (and/c real? (not/c negative?)) 'none)]{
Gets the maximum display width for the contents of the editor; zero or Gets the maximum display width for the contents of the editor; zero or
@scheme['none] indicates that there is no maximum. In a text editor, @scheme['none] indicates that there is no maximum. In a text editor,
@ -779,7 +779,7 @@ Gets the maximum display width for the contents of the editor; zero or
} }
@defmethod[(get-min-height) @defmethod[(get-min-height)
(or/c (and/c real? (not/c negative?)) (one/of 'none))]{ (or/c (and/c real? (not/c negative?)) 'none)]{
Gets the minimum display height for the contents of the editor; zero Gets the minimum display height for the contents of the editor; zero
or @scheme['none] indicates that there is no minimum. or @scheme['none] indicates that there is no minimum.
@ -788,7 +788,7 @@ Gets the minimum display height for the contents of the editor; zero
@defmethod[(get-min-width) @defmethod[(get-min-width)
(or/c (and/c real? (not/c negative?)) (one/of 'none))]{ (or/c (and/c real? (not/c negative?)) 'none)]{
Gets the minimum display width for the contents of the editor; zero or Gets the minimum display width for the contents of the editor; zero or
@scheme['none] indicates that there is no minimum. @scheme['none] indicates that there is no minimum.
@ -945,7 +945,7 @@ inserts the resulting snip into the editor.
'text 'text-force-cr) 'guess] 'text 'text-force-cr) 'guess]
[show-errors? any/c #t]) [show-errors? any/c #t])
boolean?] boolean?]
[(insert-file [port input-port] [(insert-file [port input-port?]
[format (one-of/c 'guess 'same 'copy 'standard [format (one-of/c 'guess 'same 'copy 'standard
'text 'text-force-cr) 'guess] 'text 'text-force-cr) 'guess]
[show-errors? any/c #t]) [show-errors? any/c #t])
@ -988,7 +988,7 @@ calling
} }
@defmethod[(insert-port [port input-port] @defmethod[(insert-port [port input-port?]
[format (one-of/c 'guess 'same 'copy 'standard [format (one-of/c 'guess 'same 'copy 'standard
'text 'text-force-cr) 'guess] 'text 'text-force-cr) 'guess]
[replace-styles? any/c #t]) [replace-styles? any/c #t])
@ -1014,8 +1014,8 @@ if @scheme[replace-styles?] is true, then styles in the current style
@defmethod[(invalidate-bitmap-cache [x real? 0.0] @defmethod[(invalidate-bitmap-cache [x real? 0.0]
[y real? 0.0] [y real? 0.0]
[width (or/c (and/c real? (not/c negative?)) (one/of 'end)) 'end] [width (or/c (and/c real? (not/c negative?)) 'end) 'end]
[height (or/c (and/c real? (not/c negative?)) (one/of 'end)) 'end]) [height (or/c (and/c real? (not/c negative?)) 'end) 'end])
void?]{ void?]{
When @method[editor<%> on-paint] is overridden, call this method when When @method[editor<%> on-paint] is overridden, call this method when
@ -1523,7 +1523,7 @@ Creates a @scheme[editor-snip%] with either a sub-editor from
}} }}
@defmethod[(on-new-image-snip [filename (or/c path? #f)] @defmethod[(on-new-image-snip [filename path?]
[kind (one-of/c 'unknown 'gif 'jpeg 'xbm 'xpm 'bmp 'pict)] [kind (one-of/c 'unknown 'gif 'jpeg 'xbm 'xpm 'bmp 'pict)]
[relative-path? any/c] [relative-path? any/c]
[inline? any/c]) [inline? any/c])
@ -1713,7 +1713,7 @@ To extend or re-implement copying, override the @xmethod[text%
@defmethod[(print [interactive? any/c #t] @defmethod[(print [interactive? any/c #t]
[fit-on-page? any/c #t] [fit-on-page? any/c #t]
[output-mode (one-of/c 'standard 'postscript) 'standard] [output-mode (one-of/c 'standard 'postscript) 'standard]
[parent (or/c (or/c @scheme[frame%] (is-a?/c dialog%)) #f) #f] [parent (or/c (or/c (is-a?/c frame%) (is-a?/c dialog%)) #f) #f]
[force-ps-page-bbox? any/c #t] [force-ps-page-bbox? any/c #t]
[as-eps? any/c #f]) [as-eps? any/c #f])
void?]{ void?]{
@ -2003,7 +2003,7 @@ The @scheme[show-errors?] argument is no longer used.
} }
@defmethod[(save-port [port output-port] @defmethod[(save-port [port output-port?]
[format (one-of/c 'guess 'same 'copy 'standard [format (one-of/c 'guess 'same 'copy 'standard
'text 'text-force-cr) 'same] 'text 'text-force-cr) 'same]
[show-errors? any/c #t]) [show-errors? any/c #t])
@ -2044,7 +2044,7 @@ administrator, @scheme[#f] is returned.
} }
@defmethod[(scroll-line-location [pos (and/c exact? integer?)]) @defmethod[(scroll-line-location [pos exact-nonnegative-integer?])
(and/c real? (not/c negative?))]{ (and/c real? (not/c negative?))]{
Maps a vertical scroll position to a vertical @techlink{location} Maps a vertical scroll position to a vertical @techlink{location}
@ -2226,7 +2226,7 @@ See also @method[editor<%> get-load-overwrites-styles] and
} }
@defmethod[(set-max-height [width (or/c (and/c real? (not/c negative?)) (one/of 'none))]) @defmethod[(set-max-height [width (or/c (and/c real? (not/c negative?)) 'none)])
void?]{ void?]{
Sets the maximum display height for the contents of the editor. A Sets the maximum display height for the contents of the editor. A
@ -2238,7 +2238,7 @@ Setting the height is disallowed when the editor is internally locked
} }
@defmethod[(set-max-undo-history [count (or/c exact-nonnegative-integer? (one/of 'forever))]) @defmethod[(set-max-undo-history [count (or/c exact-nonnegative-integer? 'forever)])
void?]{ void?]{
Sets the maximum number of undoables that will be remembered by the Sets the maximum number of undoables that will be remembered by the
@ -2249,7 +2249,7 @@ Sets the maximum number of undoables that will be remembered by the
} }
@defmethod[(set-max-width [width (or/c (and/c real? (not/c negative?)) (one/of 'none))]) @defmethod[(set-max-width [width (or/c (and/c real? (not/c negative?)) 'none)])
void?]{ void?]{
Sets the maximum display width for the contents of the editor; Sets the maximum display width for the contents of the editor;
@ -2265,7 +2265,7 @@ See also @method[text% set-autowrap-bitmap].
} }
@defmethod[(set-min-height [width (or/c (and/c real? (not/c negative?)) (one/of 'none))]) @defmethod[(set-min-height [width (or/c (and/c real? (not/c negative?)) 'none)])
void?]{ void?]{
Sets the minimum display height for the contents of the editor; zero Sets the minimum display height for the contents of the editor; zero
@ -2276,7 +2276,7 @@ Setting the height is disallowed when the editor is internally locked
} }
@defmethod[(set-min-width [width (or/c (and/c real? (not/c negative?)) (one/of 'none))]) @defmethod[(set-min-width [width (or/c (and/c real? (not/c negative?)) 'none)])
void?]{ void?]{
Sets the minimum display width for the contents of the editor; zero or Sets the minimum display width for the contents of the editor; zero or

60
collects/scribblings/gui/text-class.scrbl
View File

@ -325,13 +325,13 @@ See also @method[text% hide-caret].
@defmethod*[#:mode extend @defmethod*[#:mode extend
([(change-style [delta (or/c (is-a?/c style-delta%) #f)] ([(change-style [delta (or/c (is-a?/c style-delta%) #f)]
[start (or/c exact-nonnegative-integer? (one/of 'start)) 'start] [start (or/c exact-nonnegative-integer? 'start) 'start]
[end (or/c exact-nonnegative-integer? (one/of 'end)) 'end] [end (or/c exact-nonnegative-integer? 'end) 'end]
[counts-as-mod? any/c #t]) [counts-as-mod? any/c #t])
void?] void?]
[(change-style [style (or/c (is-a?/c style<%>) #f)] [(change-style [style (or/c (is-a?/c style<%>) #f)]
[start (or/c exact-nonnegative-integer? (one/of 'start)) 'start] [start (or/c exact-nonnegative-integer? 'start) 'start]
[end (or/c exact-nonnegative-integer? (one/of 'end)) 'end] [end (or/c exact-nonnegative-integer? 'end) 'end]
[counts-as-mod? any/c #t]) [counts-as-mod? any/c #t])
void?])]{ void?])]{
@ -352,8 +352,8 @@ When @scheme[style] is provided: @InStyleListNote[@scheme[style]]
@defmethod[#:mode extend @defmethod[#:mode extend
(copy [extend? any/c #f] (copy [extend? any/c #f]
[time (and/c exact? integer?) 0] [time (and/c exact? integer?) 0]
[start (or/c exact-nonnegative-integer? (one/of 'start)) 'start] [start (or/c exact-nonnegative-integer? 'start) 'start]
[end (or/c exact-nonnegative-integer? (one/of 'end)) 'end]) [end (or/c exact-nonnegative-integer? 'end) 'end])
void?]{ void?]{
Copies specified range of text into the clipboard. If @scheme[extend?] is Copies specified range of text into the clipboard. If @scheme[extend?] is
@ -383,8 +383,8 @@ In addition to the default @xmethod[editor<%> copy-self-to] work,
@defmethod[#:mode override @defmethod[#:mode override
(cut [extend? any/c #f] (cut [extend? any/c #f]
[time (and/c exact? integer?) 0] [time (and/c exact? integer?) 0]
[start (or/c exact-nonnegative-integer? (one/of 'start)) 'start] [start (or/c exact-nonnegative-integer? 'start) 'start]
[end (or/c exact-nonnegative-integer? (one/of 'end)) 'end]) [end (or/c exact-nonnegative-integer? 'end) 'end])
void?]{ void?]{
Copies and then deletes the specified range. If @scheme[extend?] is not Copies and then deletes the specified range. If @scheme[extend?] is not
@ -399,8 +399,8 @@ See @|timediscuss| for a discussion of the @scheme[time] argument. If
} }
@defmethod*[([(delete [start (or/c exact-nonnegative-integer? (one/of 'start))] @defmethod*[([(delete [start (or/c exact-nonnegative-integer? 'start)]
[end (or/c exact-nonnegative-integer? (one/of 'back)) 'back] [end (or/c exact-nonnegative-integer? 'back) 'back]
[scroll-ok? any/c #t]) [scroll-ok? any/c #t])
void?] void?]
[(delete) [(delete)
@ -520,8 +520,8 @@ Given a @techlink{location} in the editor, returns the line at the
@defmethod[(find-newline [direction (one-of/c 'forward 'backward) 'forward] @defmethod[(find-newline [direction (one-of/c 'forward 'backward) 'forward]
[start (or/c exact-nonnegative-integer? (one/of 'start)) 'start] [start (or/c exact-nonnegative-integer? 'start) 'start]
[end (or/c exact-nonnegative-integer? (one/of 'eof)) 'eof]) [end (or/c exact-nonnegative-integer? 'eof) 'eof])
(or/c exact-nonnegative-integer? #f)]{ (or/c exact-nonnegative-integer? #f)]{
Like @method[text% find-string], but specifically finds a paragraph Like @method[text% find-string], but specifically finds a paragraph
@ -623,8 +623,8 @@ can be any of the following:
@defmethod[(find-string [str string?] @defmethod[(find-string [str string?]
[direction (one-of/c 'forward 'backward) 'forward] [direction (one-of/c 'forward 'backward) 'forward]
[start (or/c exact-nonnegative-integer? (one/of 'start)) 'start] [start (or/c exact-nonnegative-integer? 'start) 'start]
[end (or/c exact-nonnegative-integer? (one/of 'eof)) 'eof] [end (or/c exact-nonnegative-integer? 'eof) 'eof]
[get-start? any/c #t] [get-start? any/c #t]
[case-sensitive? any/c #t]) [case-sensitive? any/c #t])
(or/c exact-nonnegative-integer? #f)]{ (or/c exact-nonnegative-integer? #f)]{
@ -655,8 +655,8 @@ If @scheme[case-sensitive?] is @scheme[#f], then an uppercase and lowercase
@defmethod[(find-string-all [str string?] @defmethod[(find-string-all [str string?]
[direction (one-of/c 'forward 'backward) 'forward] [direction (one-of/c 'forward 'backward) 'forward]
[start (or/c exact-nonnegative-integer? (one/of 'start)) 'start] [start (or/c exact-nonnegative-integer? 'start) 'start]
[end (or/c exact-nonnegative-integer? (one/of 'eof)) 'eof] [end (or/c exact-nonnegative-integer? 'eof) 'eof]
[get-start? any/c #t] [get-start? any/c #t]
[case-sensitive any/c #t]) [case-sensitive any/c #t])
(listof exact-nonnegative-integer?)]{ (listof exact-nonnegative-integer?)]{
@ -944,7 +944,7 @@ See also
@defmethod[(get-text [start exact-nonnegative-integer? 0] @defmethod[(get-text [start exact-nonnegative-integer? 0]
[end (or/c exact-nonnegative-integer? (one/of 'eof)) 'eof] [end (or/c exact-nonnegative-integer? 'eof) 'eof]
[flattened? any/c #f] [flattened? any/c #f]
[force-cr? any/c #f]) [force-cr? any/c #f])
string?]{ string?]{
@ -1045,13 +1045,13 @@ See also @method[text% caret-hidden?] and @method[editor<%> lock].
@defmethod*[#:mode override @defmethod*[#:mode override
([(insert [str string?] ([(insert [str string?]
[start exact-nonnegative-integer?] [start exact-nonnegative-integer?]
[end (or/c exact-nonnegative-integer? (one/of 'same)) 'same] [end (or/c exact-nonnegative-integer? 'same) 'same]
[scroll-ok? any/c #t]) [scroll-ok? any/c #t])
void?] void?]
[(insert [n exact-nonnegative-integer?] [(insert [n exact-nonnegative-integer?]
[str string?] [str string?]
[start exact-nonnegative-integer?] [start exact-nonnegative-integer?]
[end (or/c exact-nonnegative-integer? (one/of 'same)) 'same] [end (or/c exact-nonnegative-integer? 'same) 'same]
[scroll-ok? any/c #t]) [scroll-ok? any/c #t])
void?] void?]
[(insert [str string?]) [(insert [str string?])
@ -1061,7 +1061,7 @@ See also @method[text% caret-hidden?] and @method[editor<%> lock].
void?] void?]
[(insert [snip (is-a?/c snip%)] [(insert [snip (is-a?/c snip%)]
[start exact-nonnegative-integer?] [start exact-nonnegative-integer?]
[end (or/c exact-nonnegative-integer? (one/of 'same)) 'same] [end (or/c exact-nonnegative-integer? 'same) 'same]
[scroll-ok? any/c #t]) [scroll-ok? any/c #t])
void?] void?]
[(insert [snip (is-a?/c snip%)]) [(insert [snip (is-a?/c snip%)])
@ -1070,7 +1070,7 @@ See also @method[text% caret-hidden?] and @method[editor<%> lock].
void?] void?]
[(insert [char char?] [(insert [char char?]
[start exact-nonnegative-integer?] [start exact-nonnegative-integer?]
[end (or/c exact-nonnegative-integer? (one/of 'same)) 'same]) [end (or/c exact-nonnegative-integer? 'same) 'same])
void?])]{ void?])]{
Inserts text or a snip into @this-obj[] at @techlink{position} Inserts text or a snip into @this-obj[] at @techlink{position}
@ -1562,8 +1562,8 @@ If the paragraph starts with invisible @techlink{item}s and @scheme[visible?] is
@defmethod[#:mode override @defmethod[#:mode override
(paste [time (and/c exact? integer?) 0] (paste [time (and/c exact? integer?) 0]
[start (or/c exact-nonnegative-integer? (one/of 'start 'end)) 'start] [start (or/c exact-nonnegative-integer? 'start 'end) 'start]
[end (or/c exact-nonnegative-integer? (one/of 'same)) 'same]) [end (or/c exact-nonnegative-integer? 'same) 'same])
void?]{ void?]{
Pastes into the specified range. If @scheme[start] is @scheme['start], Pastes into the specified range. If @scheme[start] is @scheme['start],
@ -1604,8 +1604,8 @@ If the previous operation on the editor was not a paste, calling
@defmethod[#:mode override @defmethod[#:mode override
(paste-x-selection [time (and/c exact? integer?)] (paste-x-selection [time (and/c exact? integer?)]
[start (or/c exact-nonnegative-integer? (one/of 'start 'end)) 'start] [start (or/c exact-nonnegative-integer? 'start 'end) 'start]
[end (or/c exact-nonnegative-integer? (one/of 'same)) 'same]) [end (or/c exact-nonnegative-integer? 'same) 'same])
void?]{ void?]{
Pastes into the specified range. If @scheme[start] is @scheme['start], Pastes into the specified range. If @scheme[start] is @scheme['start],
@ -1697,7 +1697,7 @@ Returns the paragraph number of the paragraph containing a given @techlink{posit
@defmethod[#:mode extend @defmethod[#:mode extend
(read-from-file [stream (is-a?/c editor-stream-in%)] (read-from-file [stream (is-a?/c editor-stream-in%)]
[start (or/c exact-nonnegative-integer? (one/of 'start))] [start (or/c exact-nonnegative-integer? 'start)]
[overwrite-styles? any/c #f]) [overwrite-styles? any/c #f])
boolean?]{ boolean?]{
@ -1719,7 +1719,7 @@ Removes all clickbacks installed for exactly the range @scheme[start]
@defmethod[(scroll-to-position [start exact-nonnegative-integer?] @defmethod[(scroll-to-position [start exact-nonnegative-integer?]
[at-eol? any/c #f] [at-eol? any/c #f]
[end (or/c exact-nonnegative-integer? (one/of 'same)) 'same] [end (or/c exact-nonnegative-integer? 'same) 'same]
[bias (one-of/c 'start 'end 'none) 'none]) [bias (one-of/c 'start 'end 'none) 'none])
boolean?]{ boolean?]{
@ -1914,7 +1914,7 @@ The first line of the paragraph is indented by @scheme[first-left] points
@defmethod[(set-position [start exact-nonnegative-integer?] @defmethod[(set-position [start exact-nonnegative-integer?]
[end (or/c exact-nonnegative-integer? (one/of 'same)) 'same] [end (or/c exact-nonnegative-integer? 'same) 'same]
[at-eol? any/c #f] [at-eol? any/c #f]
[scroll? any/c #t] [scroll? any/c #t]
[seltype (one-of/c 'default 'x 'local) 'default]) [seltype (one-of/c 'default 'x 'local) 'default])
@ -1958,7 +1958,7 @@ See also @scheme[editor-set-x-selection-mode].
@defmethod[(set-position-bias-scroll [bias (one-of/c 'start-only 'start 'none 'end 'end-only)] @defmethod[(set-position-bias-scroll [bias (one-of/c 'start-only 'start 'none 'end 'end-only)]
[start exact-nonnegative-integer?] [start exact-nonnegative-integer?]
[end (or/c exact-nonnegative-integer? (one/of 'same)) 'same] [end (or/c exact-nonnegative-integer? 'same) 'same]
[ateol? any/c #f] [ateol? any/c #f]
[scroll? any/c #t] [scroll? any/c #t]
[seltype (one-of/c 'default 'x 'local) 'default]) [seltype (one-of/c 'default 'x 'local) 'default])
@ -2087,7 +2087,7 @@ Splitting a snip is disallowed when the editor is internally locked
@defmethod[#:mode extend @defmethod[#:mode extend
(write-to-file [stream (is-a?/c editor-stream-out%)] (write-to-file [stream (is-a?/c editor-stream-out%)]
[start exact-nonnegative-integer? 0] [start exact-nonnegative-integer? 0]
[end (or/c exact-nonnegative-integer? (one/of 'eof)) 'eof]) [end (or/c exact-nonnegative-integer? 'eof) 'eof])
boolean?]{ boolean?]{
If @scheme[start] is 0 and @scheme[end] is @scheme['eof] negative, If @scheme[start] is 0 and @scheme[end] is @scheme['eof] negative,

2
collects/scribblings/guide/chars.scrbl
View File

@ -12,7 +12,7 @@ natural-language character or piece of a character. Technically, a
scalar value is a simpler notion than the concept called a scalar value is a simpler notion than the concept called a
``character'' in the Unicode standard, but it's an approximation that ``character'' in the Unicode standard, but it's an approximation that
works well for many purposes. For example, any accented Roman letter works well for many purposes. For example, any accented Roman letter
can be represented as a scalar value, as can any Chinese character. can be represented as a scalar value, as can any common Chinese character.
Although each Scheme character corresponds to an integer, the Although each Scheme character corresponds to an integer, the
character datatype is separate from numbers. The character datatype is separate from numbers. The

17
collects/scribblings/guide/lists.scrbl
View File

@ -35,12 +35,12 @@ parentheses for expressions are brown.
Many predefined functions operate on lists. Here are a few examples: Many predefined functions operate on lists. Here are a few examples:
@interaction[ @interaction[
(code:line (length (list "a" "b" "c")) (code:comment #, @t{count the elements})) (code:line (length (list "hop" "skip" "jump")) (code:comment #, @t{count the elements}))
(code:line (list-ref (list "a" "b" "c") 0) (code:comment #, @t{extract by position})) (code:line (list-ref (list "hop" "skip" "jump") 0) (code:comment #, @t{extract by position}))
(list-ref (list "a" "b" "c") 1) (list-ref (list "hop" "skip" "jump") 1)
(code:line (append (list "a" "b") (list "c")) (code:comment #, @t{combine lists})) (code:line (append (list "hop" "skip") (list "jump")) (code:comment #, @t{combine lists}))
(code:line (reverse (list "a" "b" "c")) (code:comment #, @t{reverse order})) (code:line (reverse (list "hop" "skip" "jump")) (code:comment #, @t{reverse order}))
(code:line (member "d" (list "a" "b" "c")) (code:comment #, @t{check for an element})) (code:line (member "fall" (list "hop" "skip" "jump")) (code:comment #, @t{check for an element}))
] ]
@;------------------------------------------------------------------------ @;------------------------------------------------------------------------
@ -260,6 +260,9 @@ reasonable, since it has to generate a result of size
accumulating the result list. The only catch is that the accumulated accumulating the result list. The only catch is that the accumulated
list will be backwards, so you'll have to reverse it at the very end: list will be backwards, so you'll have to reverse it at the very end:
@margin-note{Attempting to reduce a constant factor like this is
usually not worthwhile, as discussed below.}
@schemeblock[ @schemeblock[
(define (my-map f lst) (define (my-map f lst)
(define (iter lst backward-result) (define (iter lst backward-result)
@ -291,7 +294,7 @@ iteration is just a special case of recursion. In many languages, it's
important to try to fit as many computations as possible into important to try to fit as many computations as possible into
iteration form. Otherwise, performance will be bad, and moderately iteration form. Otherwise, performance will be bad, and moderately
large inputs can lead to stack overflow. Similarly, in Scheme, it is large inputs can lead to stack overflow. Similarly, in Scheme, it is
often important to make sure that tail recursion is used to avoid sometimes important to make sure that tail recursion is used to avoid
@math{O(n)} space consumption when the computation is easily performed @math{O(n)} space consumption when the computation is easily performed
in constant space. in constant space.

5
collects/scribblings/guide/simple-syntax.scrbl
View File

@ -113,7 +113,8 @@ evaluated only for some side-effect, such as printing.
(bake "apple") (bake "apple")
] ]
Scheme programmers prefer to avoid side-effects. It's Scheme programmers prefer to avoid side-effects, so a definition usually
has just one expression in its body. It's
important, though, to understand that multiple expressions are allowed important, though, to understand that multiple expressions are allowed
in a definition body, because it explains why the following in a definition body, because it explains why the following
@scheme[nobake] function simply returns its argument: @scheme[nobake] function simply returns its argument:
@ -165,7 +166,7 @@ next line under the first argument, instead of under the
In this case, indentation helps highlight the mistake. In other cases, In this case, indentation helps highlight the mistake. In other cases,
where the indentation may be normal while an open parenthesis has no where the indentation may be normal while an open parenthesis has no
matching close parenthesis; both @exec{mzscheme} and DrScheme use the matching close parenthesis, both @exec{mzscheme} and DrScheme use the
source's indentation to suggest where a parenthesis might be missing. source's indentation to suggest where a parenthesis might be missing.
@;- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - @;- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -

2
collects/scribblings/guide/truth.scrbl
View File

@ -121,7 +121,7 @@ expressions, a printed symbol should not be confused with an
identifier. In particular, the symbol @scheme[(#, @scheme[quote] #, identifier. In particular, the symbol @scheme[(#, @scheme[quote] #,
@schemeidfont{map})] has nothing to do with the @schemeidfont{map} @schemeidfont{map})] has nothing to do with the @schemeidfont{map}
identifier or the predefined function that is bound to identifier or the predefined function that is bound to
@schemeidfont{map}, except that the symbol and the identifier happen @scheme[map], except that the symbol and the identifier happen
to be made up of the same letters. to be made up of the same letters.
Indeed, the intrinsic value of a symbol is nothing more than its Indeed, the intrinsic value of a symbol is nothing more than its

14
collects/scribblings/scribble/lp.scrbl
View File

@ -58,9 +58,17 @@ provides core support for literate programming.}
chunks. Normally, @scheme[id] starts with @litchar{<} and ends with chunks. Normally, @scheme[id] starts with @litchar{<} and ends with
@litchar{>}. @litchar{>}.
If @scheme[id] is @schemeidfont{<*>}, then this chunk is used as the main When running a scribble program only the code inside the
chunk in the file. If @schemeidfont{<*>} is never used, then the first chunk chunks is run; the rest is ignored.
in the file is treated as the main chunk.
If @scheme[id] is @schemeidfont{<*>}, then this chunk is
used as the main chunk in the file. If @schemeidfont{<*>}
is never used, then the first chunk in the file is treated
as the main chunk. If some chunk is not referenced from
the main chunk (possibly indirectly via other chunks that
the main chunk references), then it is not included in the
program and thus is not run.
} }
@section{@schememodname[scribble/lp-include] Module} @section{@schememodname[scribble/lp-include] Module}

40
collects/stepper/private/annotate.ss
View File

@ -35,18 +35,6 @@
. -> . . -> .
syntax?)] ; results syntax?)] ; results
[annotate/not-top-level ;; SAME CONTRACT AS ANNOTATE!
(syntax? ; syntax to annotate
(((or/c continuation-mark-set? false/c)
break-kind?)
(list?)
. opt->* .
(any/c)) ; procedure for runtime break
boolean? ; show-lambdas-as-lambdas?
(union any/c (symbols 'testing)); language-level
. -> .
syntax?)] ; results
#;[top-level-rewrite (-> syntax? syntax?)]) #;[top-level-rewrite (-> syntax? syntax?)])
; ;; ;;;; ; ; ;; ;;;; ;
@ -272,7 +260,7 @@
(define ((annotate/master input-is-top-level?) main-exp break show-lambdas-as-lambdas? language-level) (define (annotate main-exp break show-lambdas-as-lambdas? language-level)
#;(define _ (>>> main-exp #;(syntax->datum main-exp))) #;(define _ (>>> main-exp #;(syntax->datum main-exp)))
@ -1135,12 +1123,13 @@
(#%plain-lambda () . rest3))) (#%plain-lambda () . rest3)))
exp] exp]
[else [else
;; I think we can re-enable this error now. I don't want to do it right before a release, though. 2009-05-20
#; #;
(error `annotate/top-level "unexpected top-level expression: ~a\n" (error `annotate/top-level "unexpected top-level expression: ~a\n"
(syntax->datum exp)) (syntax->datum exp))
(annotate/module-top-level exp)]))) (annotate/module-top-level exp)])))
(define/contract annotate/top-level/acl2 #;(define/contract annotate/top-level/acl2
(syntax? . -> . syntax?) (syntax? . -> . syntax?)
(lambda (exp) (lambda (exp)
(syntax-case exp (begin define-values #%plain-app) (syntax-case exp (begin define-values #%plain-app)
@ -1222,18 +1211,13 @@
#;(error `annotate/module-top-level "unexpected module-top-level expression to annotate: ~a\n" (syntax->datum exp))])])) #;(error `annotate/module-top-level "unexpected module-top-level expression to annotate: ~a\n" (syntax->datum exp))])]))
; body of local ; body of local
(if input-is-top-level? (let* ([annotated-exp (cond
(let* ([annotated-exp (cond ;; support for ACL2 is commented out.
[(and (not (eq? language-level 'testing)) #;[(and (not (eq? language-level 'testing))
(string=? (language-level->name language-level) "ACL2 Beginner (beta 8)")) (string=? (language-level->name language-level) "ACL2 Beginner (beta 8)"))
(annotate/top-level/acl2 main-exp)] (annotate/top-level/acl2 main-exp)]
[else [else
(annotate/top-level main-exp)])]) (annotate/top-level main-exp)])])
annotated-exp) annotated-exp))
(let*-2vals ([(annotated dont-care)
(annotate/inner (top-level-rewrite main-exp) 'all #f #f)])
annotated)))
;; !@#$ defs have to appear after annotate/master.
(define annotate (annotate/master #t))
(define annotate/not-top-level (annotate/master #f))

48
collects/stepper/private/model.ss
View File

@ -1,3 +1,5 @@
#lang scheme/base
;step collector state machine (not yet implemented): ;step collector state machine (not yet implemented):
; ;
; datatype held-type = NO-HELD-STEP | SKIPPED-STEP | HELD(args) ; datatype held-type = NO-HELD-STEP | SKIPPED-STEP | HELD(args)
@ -11,7 +13,7 @@
; held = NO-HELD-STEP : ; held = NO-HELD-STEP :
; first(x) : held := HELD(x) ; first(x) : held := HELD(x)
; skipped-first : held := SKIPPED-STEP ; skipped-first : held := SKIPPED-STEP
; second(x) : trigger(NO-HELD-STEP, x), held := NO-HELD-STEP ; second(x) : trigger(NO-HELD-STEP, x), held := NO-HELD-STEP.
; this happens when evaluating unannotated code ; this happens when evaluating unannotated code
; skipped-second : held := NO-HELD-STEP ; skipped-second : held := NO-HELD-STEP
; I believe this can also arise in unannotated code ; I believe this can also arise in unannotated code
@ -35,7 +37,6 @@
; double(x) : ERROR ; double(x) : ERROR
; late-let(x) : ERROR ; late-let(x) : ERROR
#lang scheme/base
(require scheme/contract (require scheme/contract
scheme/match scheme/match
@ -72,6 +73,12 @@
. -> . . -> .
void?)]) void?)])
(define-struct posn-info (posn span))
(provide (struct-out posn-info))
; go starts a stepper instance ; go starts a stepper instance
; see provide stmt for contract ; see provide stmt for contract
(define (go program-expander receive-result render-settings (define (go program-expander receive-result render-settings
@ -94,7 +101,7 @@
;; the "held" variables are used to store the "before" step. ;; the "held" variables are used to store the "before" step.
(define held-exp-list the-no-sexp) (define held-exp-list the-no-sexp)
(define-struct held (exps was-app? source-pos)) (define-struct held (exps was-app? source-info))
(define held-finished-list null) (define held-finished-list null)
@ -215,7 +222,9 @@
mark-list returned-value-list render-settings) mark-list returned-value-list render-settings)
#f)) #f))
(r:step-was-app? mark-list) (r:step-was-app? mark-list)
(syntax-position (mark-source (car mark-list))))))] (make-posn-info
(syntax-position (mark-source (car mark-list)))
(syntax-span (mark-source (car mark-list)))))))]
[(result-exp-break result-value-break) [(result-exp-break result-value-break)
(let ([reconstruct (let ([reconstruct
@ -248,7 +257,7 @@
(append (reconstruct-all-completed) (reconstruct)) (append (reconstruct-all-completed) (reconstruct))
'normal 'normal
#f #f))] #f #f))]
[(struct held (held-exps held-step-was-app? held-source-pos)) [(struct held (held-exps held-step-was-app? held-posn-info))
(let*-values (let*-values
([(step-kind) ([(step-kind)
(if (and held-step-was-app? (if (and held-step-was-app?
@ -267,8 +276,11 @@
(send-result (send-result
(make-before-after-result (make-before-after-result
left-exps right-exps step-kind held-source-pos left-exps right-exps step-kind
(syntax-position (mark-source (car mark-list))))))]))] held-posn-info
(make-posn-info
(syntax-position (mark-source (car mark-list)))
(syntax-span (mark-source (car mark-list)))))))]))]
[(double-break) [(double-break)
;; a double-break occurs at the beginning of a let's ;; a double-break occurs at the beginning of a let's
@ -284,13 +296,16 @@
(maybe-lift (car reconstruct-result) #f))] (maybe-lift (car reconstruct-result) #f))]
[right-side (map (lambda (exp) (unwind exp render-settings)) [right-side (map (lambda (exp) (unwind exp render-settings))
(maybe-lift (cadr reconstruct-result) #t))]) (maybe-lift (cadr reconstruct-result) #t))])
;; add highlighting code as for other cases... (let ([posn-info (make-posn-info
(receive-result (syntax-position (mark-source (car mark-list)))
(make-before-after-result (syntax-span (mark-source (car mark-list))))])
(append new-finished-list left-side) (receive-result
(append new-finished-list right-side) (make-before-after-result
'normal (append new-finished-list left-side)
#f #f)))] (append new-finished-list right-side)
'normal
posn-info
posn-info))))]
[(expr-finished-break) [(expr-finished-break)
(unless (not mark-list) (unless (not mark-list)
@ -323,13 +338,12 @@
(match held-exp-list (match held-exp-list
[(struct no-sexp ()) [(struct no-sexp ())
(receive-result (make-error-result message))] (receive-result (make-error-result message))]
[(struct held (exps dc source-pos)) [(struct held (exps dc posn-info))
(begin (begin
(receive-result (receive-result
(make-before-error-result (append held-finished-list exps) (make-before-error-result (append held-finished-list exps)
message message
#f posn-info))
source-pos))
(set! held-exp-list the-no-sexp))])) (set! held-exp-list the-no-sexp))]))
(program-expander (program-expander

3
collects/stepper/stepper-tool.ss
View File

@ -219,7 +219,8 @@
(set! stepper-frame (set! stepper-frame
(go this (go this
program-expander program-expander
(+ 1 (send (get-definitions-text) get-start-position)))) (+ 1 (send (get-definitions-text) get-start-position))
(+ 1 (send (get-definitions-text) get-end-position))))
(message-box (message-box
(string-constant stepper-name) (string-constant stepper-name)
(format (string-constant stepper-language-level-message) (format (string-constant stepper-language-level-message)

53
collects/stepper/view-controller.ss
View File

@ -27,7 +27,7 @@
;; the stored representation of a step ;; the stored representation of a step
(define-struct step (text kind posns) #:transparent) (define-struct step (text kind posns) #:transparent)
(define (go drscheme-frame program-expander selection-posn) (define (go drscheme-frame program-expander selection-start selection-end)
;; get the language-level name: ;; get the language-level name:
(define language-settings (definitions-text->settings (send drscheme-frame get-definitions-text))) (define language-settings (definitions-text->settings (send drscheme-frame get-definitions-text)))
@ -169,9 +169,8 @@
;; is this step on the selected expression? ;; is this step on the selected expression?
(define (selected-exp-step? history-entry) (define (selected-exp-step? history-entry)
(member selection-posn (step-posns history-entry))) (ormap (span-overlap selection-start selection-end) (step-posns history-entry)))
;; build gui object: ;; build gui object:
@ -297,7 +296,7 @@
;; counting steps... ;; counting steps...
(define status-text (define status-text
(new text%)) (new text%))
(define _1 (send status-text insert "")) (define _2 (send status-text insert ""))
(define status-canvas (define status-canvas
(new editor-canvas% (new editor-canvas%
@ -358,7 +357,10 @@
(list x:finished-text 'finished-stepping (list))])]) (list x:finished-text 'finished-stepping (list))])])
(hand-off-and-block step-text step-kind posns))) (hand-off-and-block step-text step-kind posns)))
;; need to capture the custodian as the thread starts up: ;; program-expander-prime : wrap the program-expander for a couple of reasons:
;; 1) we need to capture the custodian as the thread starts up:
;; ok, it was just one.
;;
(define (program-expander-prime init iter) (define (program-expander-prime init iter)
(program-expander (program-expander
(lambda args (lambda args
@ -388,3 +390,42 @@
s-frame) s-frame)
;; UTILITY FUNCTIONS:
;; span-overlap : number number -> posn-info -> boolean
;; return true if the selection is of zero length and precedes a char of the
;; stepping expression, *or* if the selection has positive overlap with the
;; stepping expression.
(define ((span-overlap selection-start selection-end) source-posn-info)
(match source-posn-info
[#f #f]
[(struct model:posn-info (posn span))
(let ([end (+ posn span)])
(and posn
;; you can *almost* combine these two, but not quite.
(cond [(= selection-start selection-end)
(and (<= posn selection-start) (< selection-start end))]
[else
(let ([overlap-begin (max selection-start posn)]
;; nb: we don't want zero-length overlaps at the end.
;; compensate by subtracting one from the end of the
;; current expression.
[overlap-end (min selection-end end)])
;; #t if there's positive overlap:
(< overlap-begin overlap-end))])))]))
;; a few unit tests. Use them if changing span-overlap.
#;(and
;; zero-length selection cases:
(equal? ((span-overlap 13 13) (model:make-posn-info 14 4)) #f)
(equal? ((span-overlap 14 14) (model:make-posn-info 14 4)) #t)
(equal? ((span-overlap 18 18) (model:make-posn-info 14 4)) #f)
;; nonzero-length selection cases:
(equal? ((span-overlap 13 14) (model:make-posn-info 14 4)) #f)
(equal? ((span-overlap 13 15) (model:make-posn-info 14 4)) #t)
(equal? ((span-overlap 13 23) (model:make-posn-info 14 4)) #t)
(equal? ((span-overlap 16 17) (model:make-posn-info 14 4)) #t)
(equal? ((span-overlap 16 24) (model:make-posn-info 14 4)) #t)
(equal? ((span-overlap 18 21) (model:make-posn-info 14 4)) #f))

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

@ -341,7 +341,7 @@ Second, some keys have multiple-character string representations. Strings
@item{ A @tech{MouseEvent} represents mouse events, e.g., mouse movements @item{ A @tech{MouseEvent} represents mouse events, e.g., mouse movements
or mouse clicks, by the computer's user. or mouse clicks, by the computer's user.
@deftech{MouseEvent} : @scheme[(one-of/c 'button-down 'button-up 'drag 'move 'enter 'leave)] @deftech{MouseEvent} : @scheme[(one-of/c "button-down" "button-up" "drag" "move" "enter" "leave")]
All @tech{MouseEvent}s are represented via strings: All @tech{MouseEvent}s are represented via strings:
@itemize[ @itemize[

4
collects/test-engine/test-display.scm
View File

@ -216,9 +216,9 @@
(send text change-style c start end #f))))) (send text change-style c start end #f)))))
(define (display-reason text fail) (define (display-reason text fail)
(write (list 'display-reason fail (check-fail? fail) (message-error? fail)) #;(write (list 'display-reason fail (check-fail? fail) (message-error? fail))
(current-error-port)) (current-error-port))
(newline (current-error-port)) #;(newline (current-error-port))
(let* ((print-string (let* ((print-string
(lambda (m) (lambda (m)

2
collects/tests/deinprogramm/contract.ss
View File

@ -2,7 +2,7 @@
(provide all-contract-tests) (provide all-contract-tests)
(require (planet schematics/schemeunit:3) (require schemeunit
deinprogramm/contract/contract deinprogramm/contract/contract
deinprogramm/contract/contract-syntax) deinprogramm/contract/contract-syntax)

4
collects/tests/deinprogramm/image.ss
View File

@ -2,7 +2,7 @@
(provide all-image-tests) (provide all-image-tests)
(require (planet schematics/schemeunit:3) (require schemeunit
deinprogramm/image deinprogramm/image
(only-in lang/private/imageeq image=?) (only-in lang/private/imageeq image=?)
mred mred
@ -154,7 +154,7 @@
;; c) has the right name. ;; c) has the right name.
(define (tp-exn-pred name position) (define (tp-exn-pred name position)
(lambda (exn) (lambda (exn)
(and (tp-exn? exn) (and (exn:fail:contract? exn)
(let* ([msg (exn-message exn)] (let* ([msg (exn-message exn)]
[beg (format "~a:" name)] [beg (format "~a:" name)]
[len (string-length beg)]) [len (string-length beg)])

2
collects/tests/deinprogramm/run-contract-tests.ss
View File

@ -1,6 +1,6 @@
#lang scheme/base #lang scheme/base
(require (planet schematics/schemeunit:3/text-ui)) (require schemeunit/text-ui)
(require tests/deinprogramm/contract) (require tests/deinprogramm/contract)
(run-tests all-contract-tests) (run-tests all-contract-tests)

2
collects/tests/deinprogramm/run-image-test.ss
View File

@ -1,6 +1,6 @@
#lang scheme/base #lang scheme/base
(require (planet schematics/schemeunit:3/text-ui)) (require schemeunit/text-ui)
(require tests/deinprogramm/image) (require tests/deinprogramm/image)
(run-tests all-image-tests) (run-tests all-image-tests)

2
collects/tests/drscheme/drscheme-test-util.ss
View File

@ -373,7 +373,7 @@
;; checks that the language in the drscheme window is set to the given one. ;; checks that the language in the drscheme window is set to the given one.
;; clears the definitions, clicks execute and checks the interactions window. ;; clears the definitions, clicks execute and checks the interactions window.
(define (check-language-level lang-spec) (define (check-language-level lang-spec)
(let* ([drs-frame (get-top-level-focus-window)] (let* ([drs-frame (wait-for-drscheme-frame)]
[interactions (send drs-frame get-interactions-text)] [interactions (send drs-frame get-interactions-text)]
[definitions-canvas (send drs-frame get-definitions-canvas)]) [definitions-canvas (send drs-frame get-definitions-canvas)])
(fw:test:new-window definitions-canvas) (fw:test:new-window definitions-canvas)

44
collects/tests/drscheme/repl-test.ss
View File

@ -192,8 +192,8 @@ This produces an ACK message
"{stop-multi.png} {stop-22x22.png} reference to undefined identifier: xx" "{stop-multi.png} {stop-22x22.png} reference to undefined identifier: xx"
"{stop-multi.png} {stop-22x22.png} repl-test-tmp3.ss:1:0: reference to undefined identifier: xx" "{stop-multi.png} {stop-22x22.png} repl-test-tmp3.ss:1:0: reference to undefined identifier: xx"
"reference to undefined identifier: xx" "reference to undefined identifier: xx"
"{stop-multi.png} {stop-22x22.png} ../../mred/private/snipfile.ss:230:18: reference to undefined identifier: xx" #rx"{stop-multi.png} {stop-22x22.png} ../../mred/private/snipfile.ss:[0-9]+:[0-9]+: reference to undefined identifier: xx"
"{stop-multi.png} {stop-22x22.png} ../../mred/private/snipfile.ss:230:18: reference to undefined identifier: xx") #rx"{stop-multi.png} {stop-22x22.png} ../../mred/private/snipfile.ss:[0-9]+:[0-9]+: reference to undefined identifier: xx")
'definitions 'definitions
#f #f
void void
@ -268,8 +268,8 @@ This produces an ACK message
"define-values: cannot change constant identifier: +" "define-values: cannot change constant identifier: +"
"define-values: cannot change constant identifier: +" "define-values: cannot change constant identifier: +"
"define-values: cannot change constant identifier: +" "define-values: cannot change constant identifier: +"
"{stop-multi.png} {stop-22x22.png} ../../mred/private/snipfile.ss:246:28: define-values: cannot change constant identifier: +" #rx"{stop-multi.png} {stop-22x22.png} ../../mred/private/snipfile.ss:[0-9]+:[0-9]+: define-values: cannot change constant identifier: \\+"
"{stop-multi.png} {stop-22x22.png} ../../mred/private/snipfile.ss:246:28: define-values: cannot change constant identifier: +") #rx"{stop-multi.png} {stop-22x22.png} ../../mred/private/snipfile.ss:[0-9]+:[0-9]+: define-values: cannot change constant identifier: \\+")
'interactions 'interactions
#f #f
void void
@ -307,8 +307,8 @@ This produces an ACK message
"{stop-multi.png} {stop-22x22.png} reference to undefined identifier: xx" "{stop-multi.png} {stop-22x22.png} reference to undefined identifier: xx"
"{stop-multi.png} {stop-22x22.png} repl-test-tmp3.ss:1:7: reference to undefined identifier: xx" "{stop-multi.png} {stop-22x22.png} repl-test-tmp3.ss:1:7: reference to undefined identifier: xx"
"reference to undefined identifier: xx" "reference to undefined identifier: xx"
"{stop-multi.png} {stop-22x22.png} ../../mred/private/snipfile.ss:230:18: reference to undefined identifier: xx" #rx"{stop-multi.png} {stop-22x22.png} ../../mred/private/snipfile.ss:[0-9]+:[0-9]+: reference to undefined identifier: xx"
"{stop-multi.png} {stop-22x22.png} ../../mred/private/snipfile.ss:230:18: reference to undefined identifier: xx") #rx"{stop-multi.png} {stop-22x22.png} ../../mred/private/snipfile.ss:[0-9]+:[0-9]+: reference to undefined identifier: xx")
'definitions 'definitions
#f #f
void void
@ -352,8 +352,8 @@ This produces an ACK message
"{stop-multi.png} {stop-22x22.png} reference to undefined identifier: xx" "{stop-multi.png} {stop-22x22.png} reference to undefined identifier: xx"
"{stop-multi.png} {stop-22x22.png} repl-test-tmp3.ss:2:0: reference to undefined identifier: xx" "{stop-multi.png} {stop-22x22.png} repl-test-tmp3.ss:2:0: reference to undefined identifier: xx"
"reference to undefined identifier: xx" "reference to undefined identifier: xx"
"{stop-multi.png} {stop-22x22.png} ../../mred/private/snipfile.ss:230:18: reference to undefined identifier: xx" #rx"{stop-multi.png} {stop-22x22.png} ../../mred/private/snipfile.ss:[0-9]+:[0-9]+: reference to undefined identifier: xx"
"{stop-multi.png} {stop-22x22.png} ../../mred/private/snipfile.ss:230:18: reference to undefined identifier: xx") #rx"{stop-multi.png} {stop-22x22.png} ../../mred/private/snipfile.ss:[0-9]+:[0-9]+: reference to undefined identifier: xx")
'definitions 'definitions
#f #f
void void
@ -419,8 +419,8 @@ This produces an ACK message
"{stop-multi.png} {stop-22x22.png} reference to undefined identifier: x" "{stop-multi.png} {stop-22x22.png} reference to undefined identifier: x"
"{stop-multi.png} {stop-22x22.png} repl-test-tmp3.ss:1:4: reference to undefined identifier: x" "{stop-multi.png} {stop-22x22.png} repl-test-tmp3.ss:1:4: reference to undefined identifier: x"
"reference to undefined identifier: x" "reference to undefined identifier: x"
"{stop-multi.png} {stop-22x22.png} ../../mred/private/snipfile.ss:230:18: reference to undefined identifier: x" #rx"{stop-multi.png} {stop-22x22.png} ../../mred/private/snipfile.ss:[0-9]+:[0-9]+: reference to undefined identifier: x"
"{stop-multi.png} {stop-22x22.png} ../../mred/private/snipfile.ss:230:18: reference to undefined identifier: x") #rx"{stop-multi.png} {stop-22x22.png} ../../mred/private/snipfile.ss:[0-9]+:[0-9]+: reference to undefined identifier: x")
'definitions 'definitions
#f #f
void void
@ -459,8 +459,8 @@ This produces an ACK message
"{stop-multi.png} {stop-22x22.png} expt: expected argument of type <number>; given #<void>" "{stop-multi.png} {stop-22x22.png} expt: expected argument of type <number>; given #<void>"
"{stop-multi.png} {stop-22x22.png} repl-test-tmp3.ss:1:0: expt: expected argument of type <number>; given #<void>" "{stop-multi.png} {stop-22x22.png} repl-test-tmp3.ss:1:0: expt: expected argument of type <number>; given #<void>"
"expt: expected argument of type <number>; given #<void>" "expt: expected argument of type <number>; given #<void>"
"{stop-multi.png} {stop-22x22.png} ../../mred/private/snipfile.ss:230:18: expt: expected argument of type <number>; given #<void>" #rx"{stop-multi.png} {stop-22x22.png} ../../mred/private/snipfile.ss:[0-9]+:[0-9]+: expt: expected argument of type <number>; given #<void>"
"{stop-multi.png} {stop-22x22.png} ../../mred/private/snipfile.ss:230:18: expt: expected argument of type <number>; given #<void>") #rx"{stop-multi.png} {stop-22x22.png} ../../mred/private/snipfile.ss:[0-9]+:[0-9]+: expt: expected argument of type <number>; given #<void>")
'definitions 'definitions
#f #f
void void
@ -509,8 +509,8 @@ This produces an ACK message
"{stop-multi.png} {stop-22x22.png} reference to undefined identifier: x" "{stop-multi.png} {stop-22x22.png} reference to undefined identifier: x"
"{stop-multi.png} {stop-22x22.png} repl-test-tmp3.ss:1:4: reference to undefined identifier: x" "{stop-multi.png} {stop-22x22.png} repl-test-tmp3.ss:1:4: reference to undefined identifier: x"
"1\n2\nreference to undefined identifier: x" "1\n2\nreference to undefined identifier: x"
"{stop-multi.png} {stop-22x22.png} ../../mred/private/snipfile.ss:230:18: reference to undefined identifier: x" #rx"{stop-multi.png} {stop-22x22.png} ../../mred/private/snipfile.ss:[0-9]+:[0-9]+: reference to undefined identifier: x"
"{stop-multi.png} {stop-22x22.png} ../../mred/private/snipfile.ss:230:18: reference to undefined identifier: x") #rx"{stop-multi.png} {stop-22x22.png} ../../mred/private/snipfile.ss:[0-9]+:[0-9]+: reference to undefined identifier: x")
'definitions 'definitions
#f #f
void void
@ -622,8 +622,8 @@ This produces an ACK message
"{stop-multi.png} {stop-22x22.png} expt: expected argument of type <number>; given #f\n15" "{stop-multi.png} {stop-22x22.png} expt: expected argument of type <number>; given #f\n15"
"{stop-multi.png} {stop-22x22.png} repl-test-tmp3.ss:5:19: expt: expected argument of type <number>; given #f\n15" "{stop-multi.png} {stop-22x22.png} repl-test-tmp3.ss:5:19: expt: expected argument of type <number>; given #f\n15"
"expt: expected argument of type <number>; given #f\n15" "expt: expected argument of type <number>; given #f\n15"
"{stop-multi.png} {stop-22x22.png} ../../mred/private/snipfile.ss:230:18: expt: expected argument of type <number>; given #f\n15" #rx"{stop-multi.png} {stop-22x22.png} ../../mred/private/snipfile.ss:[0-9]+:[0-9]+: expt: expected argument of type <number>; given #f\n15"
"{stop-multi.png} {stop-22x22.png} ../../mred/private/snipfile.ss:230:18: expt: expected argument of type <number>; given #f\n15") #rx"{stop-multi.png} {stop-22x22.png} ../../mred/private/snipfile.ss:[0-9]+:[0-9]+: expt: expected argument of type <number>; given #f\n15")
'definitions 'definitions
#f #f
void void
@ -727,8 +727,8 @@ This produces an ACK message
"{stop-multi.png} {stop-22x22.png} expt: expected argument of type <number>; given #f" "{stop-multi.png} {stop-22x22.png} expt: expected argument of type <number>; given #f"
"{stop-multi.png} {stop-22x22.png} repl-test-tmp3.ss:6:15: expt: expected argument of type <number>; given #f" "{stop-multi.png} {stop-22x22.png} repl-test-tmp3.ss:6:15: expt: expected argument of type <number>; given #f"
"expt: expected argument of type <number>; given #f" "expt: expected argument of type <number>; given #f"
"{stop-multi.png} {stop-22x22.png} ../../mred/private/snipfile.ss:230:18: expt: expected argument of type <number>; given #f" #rx"{stop-multi.png} {stop-22x22.png} ../../mred/private/snipfile.ss:[0-9]+:[0-9]+: expt: expected argument of type <number>; given #f"
"{stop-multi.png} {stop-22x22.png} ../../mred/private/snipfile.ss:230:18: expt: expected argument of type <number>; given #f") #rx"{stop-multi.png} {stop-22x22.png} ../../mred/private/snipfile.ss:[0-9]+:[0-9]+: expt: expected argument of type <number>; given #f")
'definitions 'definitions
#f #f
void void
@ -804,8 +804,8 @@ This produces an ACK message
"{stop-multi.png} {stop-22x22.png} procedure application: expected procedure, given: 3; arguments were: 3" "{stop-multi.png} {stop-22x22.png} procedure application: expected procedure, given: 3; arguments were: 3"
"{stop-multi.png} {stop-22x22.png} repl-test-tmp3.ss:3:13: procedure application: expected procedure, given: 3; arguments were: 3" "{stop-multi.png} {stop-22x22.png} repl-test-tmp3.ss:3:13: procedure application: expected procedure, given: 3; arguments were: 3"
"procedure application: expected procedure, given: 3; arguments were: 3" "procedure application: expected procedure, given: 3; arguments were: 3"
"{stop-multi.png} {stop-22x22.png} ../../mred/private/snipfile.ss:246:28: procedure application: expected procedure, given: 3; arguments were: 3" #rx"{stop-multi.png} {stop-22x22.png} ../../mred/private/snipfile.ss:246:28: procedure application: expected procedure, given: 3; arguments were: 3"
"{stop-multi.png} {stop-22x22.png} ../../mred/private/snipfile.ss:246:28: procedure application: expected procedure, given: 3; arguments were: 3") #rx"{stop-multi.png} {stop-22x22.png} ../../mred/private/snipfile.ss:246:28: procedure application: expected procedure, given: 3; arguments were: 3")
'definitions 'definitions
#f #f
void void
@ -894,8 +894,8 @@ This produces an ACK message
"{stop-multi.png} {stop-22x22.png} reference to undefined identifier: xx" "{stop-multi.png} {stop-22x22.png} reference to undefined identifier: xx"
"{stop-multi.png} {stop-22x22.png} repl-test-tmp3.ss:1:0: reference to undefined identifier: xx" "{stop-multi.png} {stop-22x22.png} repl-test-tmp3.ss:1:0: reference to undefined identifier: xx"
"reference to undefined identifier: xx" "reference to undefined identifier: xx"
"{stop-multi.png} {stop-22x22.png} ../../mred/private/snipfile.ss:230:18: reference to undefined identifier: xx" #rx"{stop-multi.png} {stop-22x22.png} ../../mred/private/snipfile.ss:[0-9]+:[0-9]+: reference to undefined identifier: xx"
"{stop-multi.png} {stop-22x22.png} ../../mred/private/snipfile.ss:230:18: reference to undefined identifier: xx") #rx"{stop-multi.png} {stop-22x22.png} ../../mred/private/snipfile.ss:[0-9]+:[0-9]+: reference to undefined identifier: xx")
'definitions 'definitions
#f #f
void void

5
collects/tests/framework/test-suite-utils.ss
View File

@ -297,6 +297,7 @@
(and win (and win
(string=? (send win get-label) ,name)))]) (string=? (send win get-label) ,name)))])
(if eventspace (if eventspace
`(parameterize ([current-eventspace ,eventspace]) (wait-for
,exp) `(parameterize ([current-eventspace ,eventspace])
,exp))
(wait-for exp)))) (wait-for exp))))

4
collects/tests/macro-debugger/tests/policy.ss
View File

@ -38,9 +38,9 @@
(test-base base:if #f) (test-base base:if #f)
;; Other Scheme/* forms ;; Other Scheme/* forms
(test-base scheme:match #t) (test-base scheme:match #f)
(test-base scheme:unit #t) (test-base scheme:unit #t)
(test-base scheme:class #t) (test-base scheme:class #f)
;; Unbound names ;; Unbound names
(test-base no-such-name #t) (test-base no-such-name #t)

169
collects/tests/mred/wxme-doc-random.ss Normal file
View File

@ -0,0 +1,169 @@
#lang scheme/gui
(define (find sym l)
(cond
[(null? l) null]
[(and (pair? (car l))
(eq? sym (caar l)))
(car l)]
[else (find sym (cdr l))]))
(define (add-method s table)
(let* ([s (if (keyword? (cadr s))
(cddr s)
s)]
[name (caadr s)]
[args (map cadr (cdadr s))])
(cons (cons name args)
table)))
(define (read-methods path kind table)
(let ([s (call-with-input-file* path (lambda (in)
(parameterize ([read-accept-reader #t])
(read in))))])
(for/fold ([table table])
([s (in-list (find kind s))])
(if (pair? s)
(cond
[(eq? (car s) 'defmethod)
(add-method s table)]
[else table])
table))))
(define editor-methods
(read-methods (build-path (collection-path "scribblings" "gui")
"editor-intf.scrbl")
'definterface/title
null))
(define (delete l l2)
(if (null? l)
l2
(delete (cdr l) (filter (lambda (p) (not (eq? (car l) (car p)))) l2))))
(define text-methods
(list->vector
(delete
'(read-header-from-file read-footer-from-file read-from-file
end-write-header-footer-to-file)
(read-methods (build-path (collection-path "scribblings" "gui")
"text-class.scrbl")
'defclass/title
(delete '(do-paste-x-selection do-paste do-copy) editor-methods)))))
;; ----------------------------------------
(define bm-dc
(let ([bm (make-object bitmap% 10 10)])
(make-object bitmap-dc% bm)))
(define frame
(new frame% [label "Test"]))
(define canvas
(new editor-canvas% [parent frame]))
(define (generate-args contract-expr)
(if (pair? contract-expr)
(case (car contract-expr)
[(or/c one-of/c) (generate-args
(list-ref
(cdr contract-expr)
(random (length (cdr contract-expr)))))]
[(and/c)
(cond
[(equal? contract-expr '(and/c exact? integer?))
(generate-args 'exact-integer?)]
[(equal? contract-expr '(and/c real? (not/c negative?)))
(random-elem '#(0.0 1.0 100.0 1000.0))]
[else (error "unknown" contract-expr)])]
[(box/c) `(box ,(generate-args (cadr contract-expr)))]
[(listof) (case (random 3)
[(0) 'null]
[(1) (list 'list
(generate-args (cadr contract-expr)))]
[(2) (list 'list
(generate-args (cadr contract-expr))
(generate-args (cadr contract-expr)))])]
[(quote)
`(quote ,(cadr contract-expr))]
[(is-a?/c)
(case (cadr contract-expr)
[(editor-stream-out%)
(make-object editor-stream-out% (make-object editor-stream-out-bytes-base%))]
[(editor-stream-in%)
(make-object editor-stream-in% (make-object editor-stream-in-bytes-base% #""))]
[(snip%)
(let ([s (make-object string-snip%)])
(send s insert "hi" 2)
s)]
[(mouse-event%)
(make-object mouse-event% 'motion)]
[(key-event%)
(make-object key-event%)]
[(editor-data%) (new editor-data%)]
[(text%) (new text%)]
[(pasteboard%) (new pasteboard%)]
[(cursor%) (make-object cursor% 'arrow)]
[(style-delta%) (new style-delta%)]
[(style-list%) (new style-list%)]
[(style<%>) (send (new style-list%) basic-style)]
[(editor-canvas%) canvas]
[(frame% dialog%) frame]
[(dc<%>) bm-dc]
[(editor-admin%) (send t get-admin)]
[(bitmap%) (make-object bitmap% 10 10)]
[(color%) (new color%)]
[(keymap%) (new keymap%)]
[(editor-wordbreak-map%) (new editor-wordbreak-map%)]
[else (error "unknown" contract-expr)])]
[(->) void]
[else (error "unknown" contract-expr)])
(case contract-expr
[(any/c) #f]
[(path?) (string->path "/tmp/foo")]
[(path-string?) "/tmp/foo"]
[(input-port?) (open-input-bytes #"")]
[(output-port?) (open-output-bytes)]
[(real?)
(random-elem '#(0.0 1.0 -1.0 100.0 -100.0))]
[(exact-nonnegative-integer?)
(random-elem '#(0 1 2 10 100 1000))]
[(exact-integer?)
(random-elem '#(0 1 -1 2 10 -10 100 1000))]
[(string?)
(random-elem '#("a" "hello" ""))]
[(#f) #f]
[(#t) #t]
[else (error "unknown" contract-expr)])))
(define (random-elem v)
(vector-ref v (random (vector-length v))))
;; ----------------------------------------
(define t (new text%))
; (send t copy-self)
; (send t begin-write-header-footer-to-file (generate-args '(is-a?/c editor-stream-out%)) "" (box 0))
; is-printing?
; #f for set-keymap
; seqcontract print
; undo error
; get-character
; blink-caret & no admin
; move-position & no admin
(define-namespace-anchor a)
(let ([n (abs (current-milliseconds))])
(printf "~s\n" n)
(random-seed n))
(parameterize ([current-namespace (namespace-anchor->namespace a)])
(let loop ()
(let ([m (random-elem text-methods)])
(let ([name (car m)]
[args (map generate-args (cdr m))])
(printf "Call ~s\n" (cons name args))
(eval `(send ,t ,(car m) ,@args))
(loop)))))

113
collects/tests/mred/wxme-random.ss Normal file
View File

@ -0,0 +1,113 @@
#lang scheme/gui
(define seed (abs (current-milliseconds)))
(random-seed seed)
(error-print-context-length 100)
(define orig-t (new text%))
(define frame
(new (class frame%
(define/augment (on-close) (exit))
(super-new))
[label "Test"]
[width 300]
[height 400]))
(define canvas
(new editor-canvas% [parent frame] [editor orig-t]))
(send frame show #t)
(define (init t)
(send t set-max-undo-history 100))
(init orig-t)
(define (random-elem v)
(vector-ref v (random (vector-length v))))
(define (random-string)
(random-elem '#("a" "x\ny\nz\n" "(define (f x)\n (+ x x))\n" "hello there")))
(define seqs (make-hasheq))
(define ts-length 64)
(define ts-pos 0)
(define ts (make-vector ts-length orig-t))
(define (add-t! t2)
(if (= ts-pos ts-length)
(let ([v ts])
(set! ts (make-vector ts-length orig-t))
(set! ts-pos 0)
(for ([t3 (in-vector v)])
(when (zero? (random 2))
(add-t! t3)))
(add-t! t2))
(begin
(vector-set! ts ts-pos t2)
(set! ts-pos (add1 ts-pos)))))
;; Don't paste before copying, because that interferes with replay
(define copied? #f)
(define (set-copied?! t)
(unless (= (send t get-start-position)
(send t get-end-position))
(set! copied? #t)))
(define actions
(vector
(lambda (t) (send t undo))
(lambda (t) (send t redo))
(lambda (t) (send t insert (random-string) (random (add1 (send t last-position)))))
(lambda (t) (send t insert "\t" (random (add1 (send t last-position)))))
(lambda (t)
(let ([pos (random (add1 (send t last-position)))])
(send t delete pos (random (max 1 (- (send t last-position) pos))))))
(lambda (t)
(send t begin-edit-sequence)
(hash-update! seqs t add1 0))
(lambda (t)
(let loop ()
(when (positive? (hash-ref seqs t 0))
(send t end-edit-sequence)
(hash-update! seqs t sub1)
(when (zero? (random 2))
(loop)))))
(lambda (t)
(let ([pos (random (add1 (send t last-position)))])
(send t set-position pos (random (max 1 (- (send t last-position) pos))))))
(lambda (t) (set-copied?! t) (send t copy))
(lambda (t) (set-copied?! t) (send t cut))
(lambda (t) (set-copied?! t) (send t kill))
(lambda (t) (when copied?
(send t paste)
(when (zero? (random 4))
(send t paste-next))))
(lambda (t) (send t change-style (make-object style-delta% 'change-size (add1 (random 42)))))
(lambda (t) (send t change-style
(send (make-object style-delta%) set-delta-foreground (make-object color%
(random 256)
(random 256)
(random 256)))))
(lambda (t)
(let ([t2 (new text%)])
(add-t! t2)
(init t2)
(send t insert (make-object editor-snip% t2))))
(lambda (t)
(send t set-max-width (if (zero? (random 2))
(+ 50.0 (/ (random 500) 10.0))
'none)))
(lambda (t) (yield (system-idle-evt)))
))
(send canvas focus)
(let loop ()
(let ([act (random-elem actions)]
[t (if (zero? (random 2))
orig-t
(random-elem ts))])
(printf "~s: ~s ~s\n" seed (eq-hash-code t) act)
(act t)
(loop)))

5
collects/tests/mred/wxme.ss
View File

@ -606,15 +606,16 @@
(for-each (for-each
(lambda (str) (lambda (str)
;; (printf ">> ~a <<\n" str) ;; (printf ">> ~s <<\n" str)
(for ([i (in-range (add1 (send t last-position)))]) (for ([i (in-range (add1 (send t last-position)))])
;; (printf "~a\n" i)
(check-line-starts) (check-line-starts)
(send t insert str i) (send t insert str i)
(check-line-starts) (check-line-starts)
;; (printf "=> ~a ~s\n" i (send t get-text 0 'eof #t #t))
(send t last-line) (send t last-line)
(send t delete i (+ i (string-length str))) (send t delete i (+ i (string-length str)))
(check-line-starts) (check-line-starts)
;; (printf "~a ~s <=\n" i (send t get-text 0 'eof #t #t))
(check-ge&h-flow))) (check-ge&h-flow)))
'(" a" "a " "qvzxw " " qvxzw" "qqq qqqq" "a\nb")) '(" a" "a " "qvzxw " " qvxzw" "qqq qqqq" "a\nb"))

4
collects/tests/mzscheme/number.ss
View File

@ -2060,6 +2060,10 @@
(test #t symbol? '1+ei) (test #t symbol? '1+ei)
(test #t symbol? '|1/0|) (test #t symbol? '|1/0|)
(test #t inexact? (string->number "4@5"))
(test #f inexact? (string->number "#e4@5"))
(test #f inexact? (string->number "#e4.0@5.0"))
(arity-test string->number 1 2) (arity-test string->number 1 2)
(arity-test number->string 1 2) (arity-test number->string 1 2)

2
collects/tests/mzscheme/numstrs.ss
View File

@ -105,7 +105,7 @@
(5000.0 "1#/2#e4") (5000.0 "1#/2#e4")
(500000000.0 "1/2#e10") (500000000.0 "1/2#e10")
(500000000 "#e1/2#e10") (500000000 "#e1/2#e10")
(1.6140901064495858e+019-50176.0i "#e#x+e#s+e@-e#l-e") (16140901064495857664-50176i "#e#x+e#s+e@-e#l-e")
(#f "d") (#f "d")
(D "D") (D "D")

15
collects/tests/web-server/dispatchers/dispatch-lang-test.ss
View File

@ -106,6 +106,16 @@
"add06.ss - send/suspend/dispatch" "add06.ss - send/suspend/dispatch"
(build-path example-servlets "add06.ss")) (build-path example-servlets "add06.ss"))
(test-add-two-numbers
mkd
"add-native.ss - native continuation parts"
(build-path example-servlets "add-native.ss"))
(test-add-two-numbers
mkd
"add-soft.ss - soft state"
(build-path example-servlets "add-soft.ss"))
; XXX test something is not d-c ; XXX test something is not d-c
(test-double-counters (test-double-counters
mkd mkd
@ -153,3 +163,8 @@
; XXX test web-extras.ss - redirect/get ; XXX test web-extras.ss - redirect/get
)) ))
#|
(require schemeunit/text-ui)
(run-tests dispatch-lang-tests)
|#

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

@ -169,8 +169,8 @@
(lambda () (lambda ()
(let/ec esc (let/ec esc
('f1 (with-continuation-mark the-cont-key + ('f1 (with-continuation-mark the-cont-key +
(esc (activation-record-list))))))) (esc (reverse (activation-record-list))))))))
(list (vector + #f)))) (list (vector + #f #f))))
(test-case (test-case
"Double" "Double"
@ -179,10 +179,10 @@
(let/ec esc (let/ec esc
('f1 (with-continuation-mark the-cont-key + ('f1 (with-continuation-mark the-cont-key +
('f2 (with-continuation-mark the-cont-key - ('f2 (with-continuation-mark the-cont-key -
(esc (activation-record-list))))))))) (esc (reverse (activation-record-list))))))))))
; Opposite the order of c-c-m ; Opposite the order of c-c-m
(list (vector + #f) (list (vector + #f #f)
(vector - #f)))) (vector - #f #f))))
(test-case (test-case
"Unsafe" "Unsafe"
@ -216,21 +216,21 @@
(check-equal? (resume empty (list 42)) (check-equal? (resume empty (list 42))
42)) 42))
(test-case #;(test-case
"Empty frame" "Empty frame"
(check-exn exn? (lambda () (resume (list (vector #f #f)) (list 42))))) (check-exn exn? (lambda () (resume (reverse (list (vector #f #f #f))) (list 42)))))
(test-case (test-case
"Kont" "Kont"
(let ([f (lambda (x) (* x x))]) (let ([f (lambda (x) (* x x))])
(check-equal? (resume (list (vector f #f)) (list 42)) (check-equal? (resume (reverse (list (vector f #f #f))) (list 42))
(f 42)))) (f 42))))
(test-case (test-case
"Kont 2" "Kont 2"
(let ([f (lambda (x) (* x x))] (let ([f (lambda (x) (* x x))]
[g (lambda (x) (+ x x))]) [g (lambda (x) (+ x x))])
(check-equal? (resume (list (vector f #f) (vector g #f)) (list 42)) (check-equal? (resume (reverse (list (vector f #f #f) (vector g #f #f))) (list 42))
(f (g 42))))) (f (g 42)))))
(test-case (test-case
@ -238,16 +238,17 @@
(let ([f (lambda (x) (* x x))] (let ([f (lambda (x) (* x x))]
[g (lambda (x) (+ x x))] [g (lambda (x) (+ x x))]
[esc-b (box #f)] [esc-b (box #f)]
[capture (lambda _ (activation-record-list))]) [capture (lambda _ (reverse (activation-record-list)))])
(check-equal? (call-with-web-prompt (check-equal? (call-with-web-prompt
(lambda () (lambda ()
(let/ec esc (let/ec esc
(set-box! esc-b esc) (set-box! esc-b esc)
(resume (list (vector f #f) (vector g #f) (resume (reverse
(vector esc #f) (vector capture #f)) (list (vector f #f #f) (vector g #f #f)
(vector esc #f #f) (vector capture #f #f)))
(list 42))))) (list 42)))))
(list (vector f #f) (vector g #f) (list (vector f #f #f) (vector g #f #f)
(vector (unbox esc-b) #f))))) (vector (unbox esc-b) #f #f)))))
(test-case (test-case
"marks" "marks"
@ -256,14 +257,16 @@
(check-equal? (call-with-web-prompt (check-equal? (call-with-web-prompt
(lambda () (lambda ()
(let/ec esc (let/ec esc
(resume (list (vector f (make-immutable-hash (list (cons 3 4) (cons 1 2)))) (resume (reverse
(vector g (make-immutable-hash (list (cons 5 6)))) (list (vector f (make-immutable-hash (list (cons 3 4) (cons 1 2))) #f)
(vector esc (make-immutable-hash (list (cons 7 8)))) (vector g (make-immutable-hash (list (cons 5 6))) #f)
(vector (lambda _ (vector esc (make-immutable-hash (list (cons 7 8))) #f)
(continuation-mark-set->list* (vector (lambda _
(current-continuation-marks) (continuation-mark-set->list*
(list 1 3 5 7))) (current-continuation-marks)
#f)) (list 1 3 5 7)))
#f
#f)))
(list 42))))) (list 42)))))
(list (vector #f #f #f 8) (list (vector #f #f #f 8)
(vector #f #f 6 #f) (vector #f #f 6 #f)
@ -279,14 +282,16 @@
(lambda () (lambda ()
(let/ec esc (let/ec esc
(set-box! esc-b esc) (set-box! esc-b esc)
(resume (list (vector f (make-immutable-hash (list (cons 3 4) (cons 1 2)))) (resume (reverse
(vector g (make-immutable-hash (list (cons 5 6)))) (list (vector f (make-immutable-hash (list (cons 3 4) (cons 1 2))) #f)
(vector esc (make-immutable-hash (list (cons 7 8)))) (vector g (make-immutable-hash (list (cons 5 6))) #f)
(vector capture #f)) (vector esc (make-immutable-hash (list (cons 7 8))) #f)
(vector capture #f #f)))
(list 42))))) (list 42)))))
(list (vector f (make-immutable-hash (list (cons 3 4) (cons 1 2)))) (reverse
(vector g (make-immutable-hash (list (cons 5 6)))) (list (vector f (make-immutable-hash (list (cons 3 4) (cons 1 2))) #f)
(vector (unbox esc-b) (make-immutable-hash (list (cons 7 8))))))))) (vector g (make-immutable-hash (list (cons 5 6))) #f)
(vector (unbox esc-b) (make-immutable-hash (list (cons 7 8))) #f)))))))
; XXX test kont ; XXX test kont
@ -299,3 +304,8 @@
; XXX test dispatch ; XXX test dispatch
)) ))
#|
(require schemeunit/text-ui)
(run-tests abort-resume-tests)
|#

34
collects/web-server/default-web-root/htdocs/lang-servlets/add-native.ss Normal file
View File

@ -0,0 +1,34 @@
#lang web-server
(require web-server/managers/lru)
(define interface-version 'stateless)
(define manager
(make-threshold-LRU-manager #f (* 1024 1024 128)))
(provide start manager interface-version)
;; get-number-from-user: string -> number
;; ask the user for a number
(define (gn msg)
(let ([req
(send/suspend/url
(lambda (k-url)
`(html (head (title ,(format "Get ~a number" msg)))
(body
(form ([action ,(url->string k-url)]
[method "get"]
[enctype "application/x-www-form-urlencoded"])
,(format "Enter the ~a number to add: " msg)
(input ([type "text"] [name "number"] [value ""]))
(input ([type "submit"])))))))])
(string->number
(cdr (assoc 'number (url-query (request-uri req)))))))
(define (gn* m)
(first (serial->native (map (lambda (m) (native->serial (gn m))) (list m)))))
(define (start initial-request)
`(html (head (title "Final Page"))
(body
(h1 "Final Page")
(p ,(format "The answer is ~a"
(+ (gn* "first") (gn* "second")))))))

2
collects/web-server/default-web-root/htdocs/lang-servlets/add-param.ss
View File

@ -11,7 +11,7 @@
(send/suspend/url (send/suspend/url
(lambda (k-url) (lambda (k-url)
(printf "ssu ~S~n" (msg)) (printf "ssu ~S~n" (msg))
`(hmtl (head (title ,(format "Get ~a number" (msg)))) `(html (head (title ,(format "Get ~a number" (msg))))
(body (body
(form ([action ,(url->string k-url)] (form ([action ,(url->string k-url)]
[method "post"] [method "post"]

2
collects/web-server/default-web-root/htdocs/lang-servlets/add-simple.ss
View File

@ -11,7 +11,7 @@
(send/suspend/url (send/suspend/url
(lambda (k-url) (lambda (k-url)
(printf "ssu ~S~n" (msg)) (printf "ssu ~S~n" (msg))
`(hmtl (head (title ,(format "Get ~a number" (msg)))) `(html (head (title ,(format "Get ~a number" (msg))))
(body (body
(form ([action ,(url->string k-url)] (form ([action ,(url->string k-url)]
[method "post"] [method "post"]

31
collects/web-server/default-web-root/htdocs/lang-servlets/add-soft.ss Normal file
View File

@ -0,0 +1,31 @@
#lang web-server
(define interface-version 'stateless)
(provide start interface-version)
(define softie
(soft-state
"submit"))
;; get-number-from-user: string -> number
;; ask the user for a number
(define (gn msg)
(let ([req
(send/suspend/url
(lambda (k-url)
`(html (head (title ,(format "Get ~a number" msg)))
(body
(form ([action ,(url->string k-url)]
[method "get"]
[enctype "application/x-www-form-urlencoded"])
,(format "Enter the ~a number to add: " msg)
(input ([type "text"] [name "number"] [value ""]))
(input ([type ,(soft-state-ref softie)])))))))])
(string->number
(cdr (assoc 'number (url-query (request-uri req)))))))
(define (start initial-request)
`(html (head (title "Final Page"))
(body
(h1 "Final Page")
(p ,(format "The answer is ~a"
(+ (gn "first") (gn "second")))))))

2
collects/web-server/default-web-root/htdocs/lang-servlets/add.ss
View File

@ -12,7 +12,7 @@
(send/suspend/url (send/suspend/url
(lambda (k-url) (lambda (k-url)
(printf "ssu~n") (printf "ssu~n")
`(hmtl (head (title ,(format "Get ~a number" msg))) `(html (head (title ,(format "Get ~a number" msg)))
(body (body
(form ([action ,(url->string k-url)] (form ([action ,(url->string k-url)]
[method "post"] [method "post"]

2
collects/web-server/default-web-root/htdocs/lang-servlets/add02.ss
View File

@ -8,7 +8,7 @@
(let ([req (let ([req
(send/suspend/url (send/suspend/url
(lambda (k-url) (lambda (k-url)
`(hmtl (head (title ,(format "Get ~a number" msg))) `(html (head (title ,(format "Get ~a number" msg)))
(body (body
(form ([action ,(url->string k-url)] (form ([action ,(url->string k-url)]
[method "get"] [method "get"]

2
collects/web-server/default-web-root/htdocs/lang-servlets/add03.ss
View File

@ -8,7 +8,7 @@
(let ([req (let ([req
(send/suspend/hidden (send/suspend/hidden
(lambda (ses-url k-hidden) (lambda (ses-url k-hidden)
`(hmtl (head (title ,(format "Get ~a number" msg))) `(html (head (title ,(format "Get ~a number" msg)))
(body (body
(form ([action ,(url->string ses-url)] (form ([action ,(url->string ses-url)]
[method "post"] [method "post"]

2
collects/web-server/default-web-root/htdocs/lang-servlets/add04-stuffer.ss
View File

@ -12,7 +12,7 @@
(let ([req (let ([req
(send/suspend/url (send/suspend/url
(lambda (k-url) (lambda (k-url)
`(hmtl (head (title ,(format "Get ~a number" msg))) `(html (head (title ,(format "Get ~a number" msg)))
(body (body
(form ([action ,(url->string k-url)] (form ([action ,(url->string k-url)]
[method "post"] [method "post"]

2
collects/web-server/default-web-root/htdocs/lang-servlets/add04.ss
View File

@ -8,7 +8,7 @@
(let ([req (let ([req
(send/suspend/url (send/suspend/url
(lambda (k-url) (lambda (k-url)
`(hmtl (head (title ,(format "Get ~a number" msg))) `(html (head (title ,(format "Get ~a number" msg)))
(body (body
(form ([action ,(url->string k-url)] (form ([action ,(url->string k-url)]
[method "post"] [method "post"]

2
collects/web-server/default-web-root/htdocs/lang-servlets/add06.ss
View File

@ -7,7 +7,7 @@
(define (gn msg) (define (gn msg)
(send/suspend/url/dispatch (send/suspend/url/dispatch
(lambda (embed/url) (lambda (embed/url)
`(hmtl (head (title ,(format "Get ~a number" msg))) `(html (head (title ,(format "Get ~a number" msg)))
(body (body
(form ([action ,(url->string (form ([action ,(url->string
(embed/url (embed/url

43
collects/web-server/default-web-root/htdocs/lang-servlets/map.ss Normal file
View File

@ -0,0 +1,43 @@
#lang web-server
(require web-server/managers/lru)
(define-native (build-list/native _ ho) build-list)
(define interface-version 'stateless)
(define manager
(make-threshold-LRU-manager #f (* 1024 1024 128)))
(provide start interface-version manager)
;; get-number-from-user: number -> number
;; ask the user for a number
(define (get-number-from-user message)
(let ([req
(send/suspend/url
(lambda (k-url)
`(html (head (title ,message))
(body
(form ([action ,(url->string k-url)]
[method "post"]
[enctype "application/x-www-form-urlencoded"])
,message
(input ([type "text"] [name "number"] [value ""]))
(input ([type "submit"])))))))])
(string->number
(bytes->string/utf-8
(binding:form-value
(bindings-assq #"number"
(request-bindings/raw req)))))))
(define (start initial-request)
(define how-many-numbers
(get-number-from-user "How many numbers do you want to add?"))
`(html (head (title "Final Page"))
(body
(h1 "Final Page")
(p ,(format "The answer is ~a"
(apply +
(build-list/native how-many-numbers
(lambda (i)
(get-number-from-user
(format "Enter number ~a" (add1 i)))))))))))

2
collects/web-server/default-web-root/htdocs/lang-servlets/quiz-lib.ss
View File

@ -24,7 +24,7 @@
;; generate the page for the question ;; generate the page for the question
(define (make-cue-page mc-q) (define (make-cue-page mc-q)
(lambda (ses-url k-hidden) (lambda (ses-url k-hidden)
`(hmtl (head (title "Question")) `(html (head (title "Question"))
(body (body
(form ([action ,(url->string ses-url)] [method "post"] (form ([action ,(url->string ses-url)] [method "post"]
[enctype "application/x-www-form-urlencoded"]) [enctype "application/x-www-form-urlencoded"])

17
collects/web-server/default-web-root/htdocs/lang-servlets/soft.ss Normal file
View File

@ -0,0 +1,17 @@
#lang web-server
(provide interface-version start)
(define interface-version 'stateless)
(define softie
(soft-state
(printf "Doing a long computation...~n")
(sleep 1)
5))
(define (start req)
(soft-state-ref softie)
(printf "Done~n")
(start
(send/suspend
(lambda (k-url)
`(html (body (a ([href ,k-url]) "Done")))))))

148
collects/web-server/lang/abort-resume.ss
View File

@ -1,7 +1,9 @@
#lang scheme #lang scheme
(require scheme/serialize (require scheme/serialize
"../private/define-closure.ss" web-server/private/servlet
"../lang/web-cells.ss") web-server/managers/manager
web-server/private/define-closure
web-server/lang/web-cells)
;; ********************************************************************** ;; **********************************************************************
;; ********************************************************************** ;; **********************************************************************
@ -12,6 +14,8 @@
(define safe-call? (make-mark-key)) (define safe-call? (make-mark-key))
(define web-prompt (make-continuation-prompt-tag 'web)) (define web-prompt (make-continuation-prompt-tag 'web))
(define empty-hash
(make-immutable-hash empty))
(define (with-current-saved-continuation-marks-and key val thnk) (define (with-current-saved-continuation-marks-and key val thnk)
(call-with-immediate-continuation-mark (call-with-immediate-continuation-mark
the-save-cm-key the-save-cm-key
@ -19,27 +23,34 @@
(with-continuation-mark the-save-cm-key (with-continuation-mark the-save-cm-key
(hash-set old-cms key val) (hash-set old-cms key val)
(thnk))) (thnk)))
(make-immutable-hash empty))) empty-hash))
;; current-continuation-as-list: -> (listof value) ;; current-continuation-as-list: -> (listof value)
;; check the safety marks and return the list of marks representing the continuation ;; check the safety marks and return the list of marks representing the continuation
(define (activation-record-list) (define (activation-record-list)
(let* ([cm (current-continuation-marks web-prompt)] (let* ([cm (current-continuation-marks web-prompt)]
[sl (continuation-mark-set->list cm safe-call?)]) ; XXX call this once with a non-#f default
(if (andmap (lambda (x) [sl (continuation-mark-set->list* cm (list safe-call? continuation-of-unsafe-part-mark))])
(if (pair? x) (if (calling-context-okay? sl #f)
(car x) (store-unsafe-parts-on-server! (continuation-mark-set->list* cm (list the-cont-key the-save-cm-key continuation-of-unsafe-part-mark)))
x))
sl)
(begin #;(printf "Safe continuation capture from ~S with cm ~S~n" sl cm)
#;(printf "CMs: ~S~n" (continuation-mark-set->list* cm (list the-cont-key the-save-cm-key)))
(reverse (continuation-mark-set->list* cm (list the-cont-key the-save-cm-key))))
(error "Attempt to capture a continuation from within an unsafe context:" sl)))) (error "Attempt to capture a continuation from within an unsafe context:" sl))))
;; calling-context-okay? : (listof (vector safe-call? unsafe-continuation-mark)) -> boolean
(define (calling-context-okay? ctxt native-above?)
(match ctxt
[(list) #t]
[(list-rest (vector (or (list-rest safe-call? _)
safe-call?)
unsafe-part)
more-ctxt)
(and (or native-above? safe-call?)
(calling-context-okay?
more-ctxt
(or unsafe-part native-above?)))]))
;; abort: ( -> alpha) -> alpha ;; abort: ( -> alpha) -> alpha
;; erase the stack and apply a thunk ;; erase the stack and apply a thunk
(define (abort thunk) (define (abort thunk)
#;(printf "abort ~S~n" thunk)
(abort-current-continuation web-prompt thunk)) (abort-current-continuation web-prompt thunk))
;; with-continuation-marks : (listof (cons any1 any2)) (-> any3) -> any3 ;; with-continuation-marks : (listof (cons any1 any2)) (-> any3) -> any3
@ -55,25 +66,43 @@
(hash-map cms cons) (hash-map cms cons)
thnk)) thnk))
;; resume: (listof (value -> value)) value -> value ;; resume*: (listof (value -> value)) value -> value
;; resume a computation given a value and list of frame procedures ;; resume a computation given a value and list of frame procedures
(define (resume frames val) (define (resume* frames val)
#;(printf "~S~n" `(resume ,frames ,val)) #;(printf "~S~n" `(resume ,frames ,val))
(match frames (match frames
[(list) [(list)
#;(printf "Returning value ~S~n" val)
(apply values val)] (apply values val)]
[(list-rest f fs) [(list-rest frame fs)
(match f #;(printf "Frame ~S~n" frame)
[(vector #f #f) (match frame
(error 'resume "Empty frame")] [(vector #f #f #f)
[(vector f #f) ; XXX Perhaps I should err?
(call-with-values (lambda () (with-continuation-mark the-cont-key f (resume fs val))) #;(error 'resume "Empty frame")
(resume* fs val)]
[(vector f #f #f)
(call-with-values (lambda () (with-continuation-mark the-cont-key f (resume* fs val)))
f)] f)]
[(vector #f cms) [(vector #f cms #f)
(with-continuation-mark the-save-cm-key cms (with-continuation-mark the-save-cm-key cms
(with-continuation-marks/hash cms (lambda () (resume fs val))))] (with-continuation-marks/hash cms (lambda () (resume* fs val))))]
[(vector f cms) [(vector #f #f nkpt-label)
(resume (list* (vector f #f) (vector #f cms) fs) val)])])) (serial->native
((get-unsafe-part-from-server nkpt-label)
(with-continuation-mark continuation-of-unsafe-part-mark nkpt-label
(resume* fs val))))]
[(vector f cms nkpt-label)
(resume* (list* (vector f #f #f)
(vector #f cms #f)
(if nkpt-label
(list* (vector #f #f nkpt-label)
fs)
fs))
val)])]))
(define (resume frames val)
(resume* (reverse frames) val))
;; rebuild-cms : frames (-> value) -> value ;; rebuild-cms : frames (-> value) -> value
(define (rebuild-cms frames thunk) (define (rebuild-cms frames thunk)
@ -81,11 +110,11 @@
(match frames (match frames
[(list) [(list)
(thunk)] (thunk)]
[(list-rest f fs) [(list-rest frame fs)
(match f (match (vector-ref frame 1)
[(vector f #f) [#f
(rebuild-cms fs thunk)] (rebuild-cms fs thunk)]
[(vector f cms) [cms
(with-continuation-marks/hash cms (lambda () (rebuild-cms fs thunk)))])])) (with-continuation-marks/hash cms (lambda () (rebuild-cms fs thunk)))])]))
(define (call-with-web-prompt thunk) (define (call-with-web-prompt thunk)
@ -111,20 +140,54 @@
(define-values (wcs current-marks) ((kont-env k))) (define-values (wcs current-marks) ((kont-env k)))
(make-kont (make-kont
(lambda () (lambda ()
(values wcs (values wcs (list* (vector f #f #f) current-marks)))))
(append current-marks (list (vector f #f)))))))
;; send/suspend: (continuation -> response) -> request ;; send/suspend: (continuation -> response) -> request
;; produce the current response and wait for the next request ;; produce the current response and wait for the next request
(define (call-with-serializable-current-continuation response-maker) (define (call-with-serializable-current-continuation response-maker)
(with-continuation-mark safe-call? '(#t send/suspend) (with-continuation-mark safe-call? '(#t send/suspend)
(let ([current-marks (activation-record-list)] (let* ([current-marks (activation-record-list)]
[wcs (capture-web-cell-set)]) [wcs (capture-web-cell-set)]
((lambda (k) [k (make-kont (lambda () (values wcs current-marks)))])
(abort (lambda () (abort (lambda ()
; Since we escaped from the previous context, we need to re-install the user's continuation-marks ; Since we escaped from the previous context, we need to re-install the user's continuation-marks
(rebuild-cms current-marks (lambda () (response-maker k)))))) (rebuild-cms (reverse current-marks) (lambda () (response-maker k))))))))
(make-kont (lambda () (values wcs current-marks)))))))
;; combining native and transformed continuations
(define unsafe-barrier-prompt-tag (make-continuation-prompt-tag 'unsafe))
(define continuation-of-unsafe-part-mark (make-mark-key))
(define (store-unsafe-part-on-server! k)
((manager-continuation-store! (current-servlet-manager))
(current-servlet-instance-id) k #f))
(define (get-unsafe-part-from-server k-label)
(apply (manager-continuation-lookup (current-servlet-manager))
(current-servlet-instance-id) k-label))
(define store-unsafe-parts-on-server!
(match-lambda
[(list) empty]
[(list-rest (vector f cms unsafe-part) ctxt)
(list* (vector f cms
(if unsafe-part
(store-unsafe-part-on-server! unsafe-part)
#f))
(store-unsafe-parts-on-server! ctxt))]))
(define-syntax-rule (serial->native f)
(serial->native* (lambda () f)))
(define-syntax-rule (native->serial f)
(native->serial* (lambda () f)))
(define (serial->native* thnk)
(call-with-continuation-prompt thnk unsafe-barrier-prompt-tag))
(define (native->serial* thnk)
(call-with-composable-continuation
(lambda (unsafe-continuation-portion)
(with-continuation-mark
continuation-of-unsafe-part-mark unsafe-continuation-portion
(thnk)))
unsafe-barrier-prompt-tag))
;; ********************************************************************** ;; **********************************************************************
;; ********************************************************************** ;; **********************************************************************
@ -162,7 +225,8 @@
(define saved-context? (define saved-context?
(listof (vector/c (or/c false/c procedure?) (listof (vector/c (or/c false/c procedure?)
(or/c false/c cms?)))) (or/c false/c cms?)
(or/c false/c symbol?))))
(provide/contract (provide/contract
;; AUXILLIARIES ;; AUXILLIARIES
@ -176,7 +240,7 @@
[activation-record-list (-> saved-context?)] [activation-record-list (-> saved-context?)]
[with-current-saved-continuation-marks-and (any/c any/c (-> any/c) . -> . any/c)] [with-current-saved-continuation-marks-and (any/c any/c (-> any/c) . -> . any/c)]
[kont-append-fun (kont? procedure? . -> . kont?)] [kont-append-fun (kont? procedure? . -> . kont?)]
;; "CLIENT" INTERFACE ;; "CLIENT" INTERFACE
[dispatch ((request? . -> . (request? . -> . response?)) [dispatch ((request? . -> . (request? . -> . response?))
request? request?
@ -189,4 +253,6 @@
(provide (provide
;; "SERVLET" INTERFACE ;; "SERVLET" INTERFACE
; A contract would interfere with the safe-call? key ; A contract would interfere with the safe-call? key
native->serial
serial->native
call-with-serializable-current-continuation) call-with-serializable-current-continuation)

1
collects/web-server/lang/elim-callcc.ss
View File

@ -88,6 +88,7 @@
(#,cm) (#,cm)
(#%plain-lambda #,x (#%plain-lambda #,x
(#%plain-app abort (#%plain-app abort
; XXX Do I need to rebuild the CMs?
(#%plain-lambda () (#%plain-app resume #,ref-to-cm #,ref-to-x))))) (#%plain-lambda () (#%plain-app resume #,ref-to-cm #,ref-to-x)))))
(#%plain-app activation-record-list))))))] (#%plain-app activation-record-list))))))]
[(#%plain-app call-with-values (#%plain-lambda () prod) cons) [(#%plain-app call-with-values (#%plain-lambda () prod) cons)

8
collects/web-server/lang/lang-api.ss
View File

@ -6,9 +6,11 @@
web-server/stuffers web-server/stuffers
web-server/lang/abort-resume web-server/lang/abort-resume
web-server/lang/web web-server/lang/web
web-server/lang/native
web-server/lang/web-cells web-server/lang/web-cells
web-server/lang/web-param web-server/lang/web-param
web-server/lang/file-box) web-server/lang/file-box
web-server/lang/soft)
(provide (except-out (all-from-out scheme) #%module-begin) (provide (except-out (all-from-out scheme) #%module-begin)
(all-from-out net/url (all-from-out net/url
web-server/http web-server/http
@ -17,6 +19,8 @@
web-server/stuffers web-server/stuffers
web-server/lang/abort-resume web-server/lang/abort-resume
web-server/lang/web web-server/lang/web
web-server/lang/native
web-server/lang/web-cells web-server/lang/web-cells
web-server/lang/web-param web-server/lang/web-param
web-server/lang/file-box)) web-server/lang/file-box
web-server/lang/soft))

25
collects/web-server/lang/native.ss Normal file
View File

@ -0,0 +1,25 @@
#lang scheme
(require web-server/lang/abort-resume
(for-syntax scheme))
(define-syntax (define-native stx)
(syntax-case stx ()
[(_ (id . argspec) original)
(quasisyntax/loc stx
(define id
(lambda id-args
(serial->native
(apply original
(map (lambda (higher-order? arg)
(if higher-order?
(lambda arg-args
(native->serial (apply arg arg-args)))
arg))
(list #,@(map (lambda (arg)
(syntax-case arg (ho)
[ho #t]
[_ #f]))
(syntax->list #'argspec)))
id-args))))))]))
(provide define-native)

36
collects/web-server/lang/soft.ss Normal file
View File

@ -0,0 +1,36 @@
#lang scheme
(require scheme/serialize)
(define-serializable-struct soft-state-record (thnk))
(define-struct some (value))
(define *soft-state-cache*
(make-weak-hash))
(define (make-soft-state thnk)
(make-soft-state-record thnk))
(define (soft-state-ref ss)
(match ss
[(struct soft-state-record (thnk))
(define the-weak-box
(hash-ref! *soft-state-cache* ss (lambda () (make-weak-box (make-some (thnk))))))
(define the-val
(weak-box-value the-weak-box))
(if (some? the-val)
(some-value the-val)
(local [(define real-val (thnk))]
(hash-set! *soft-state-cache* ss (make-weak-box (make-some real-val)))
real-val))]))
(define soft-state? soft-state-record?)
(define-syntax-rule (soft-state expr ...)
(make-soft-state (lambda () expr ...)))
(provide
soft-state)
(provide/contract
[soft-state? (any/c . -> . boolean?)]
[make-soft-state ((-> any/c) . -> . soft-state?)]
[soft-state-ref (soft-state? . -> . any/c)])

24
collects/web-server/lang/web.ss
View File

@ -81,25 +81,23 @@
(lambda (k-url) (lambda (k-url)
(page-maker (url->string k-url))))) (page-maker (url->string k-url)))))
(define-closure embed/url (proc) (k) (define-closure embed/url (proc) (k string?)
(stuff-url (stateless-servlet-stuffer (current-servlet)) (let ([url
(request-uri (execution-context-request (current-execution-context))) (stuff-url (stateless-servlet-stuffer (current-servlet))
(kont-append-fun k proc))) (request-uri (execution-context-request (current-execution-context)))
(kont-append-fun k proc))])
(if string?
(url->string url)
url)))
(define (send/suspend/url/dispatch response-generator) (define (send/suspend/url/dispatch response-generator)
(call-with-serializable-current-continuation (call-with-serializable-current-continuation
(lambda (k) (lambda (k)
(response-generator (make-embed/url (lambda () k)))))) (response-generator (make-embed/url (lambda () (values k #f)))))))
; XXX Uncopy&paste
(define-closure embed (proc) (k)
(url->string
(stuff-url (stateless-servlet-stuffer (current-servlet))
(request-uri (execution-context-request (current-execution-context)))
(kont-append-fun k proc))))
(define (send/suspend/dispatch response-generator) (define (send/suspend/dispatch response-generator)
(call-with-serializable-current-continuation (call-with-serializable-current-continuation
(lambda (k) (lambda (k)
(response-generator (make-embed (lambda () k)))))) (response-generator (make-embed/url (lambda () (values k #t)))))))
;; request->continuation: req -> continuation ;; request->continuation: req -> continuation
;; decode the continuation from the hidden field of a request ;; decode the continuation from the hidden field of a request

1
collects/web-server/scribblings/dummy-stateless-servlet.ss
View File

@ -2,6 +2,7 @@
(define interface-version #f) (define interface-version #f)
(define stuffer #f) (define stuffer #f)
(define manager #f)
(define start #f) (define start #f)
(provide (all-defined-out)) (provide (all-defined-out))

23
collects/web-server/scribblings/lang-api.scrbl
View File

@ -11,8 +11,10 @@ A stateless servlet should @scheme[provide] the following exports:
@(require (for-label web-server/http @(require (for-label web-server/http
scheme/serialize scheme/serialize
web-server/stuffers (except-in web-server/stuffers stuffer)
(except-in "dummy-stateless-servlet.ss" stuffer))) @; to give a binding context web-server/managers/none
(except-in web-server/managers/manager manager)
"dummy-stateless-servlet.ss")) @; to give a binding context
@declare-exporting[#:use-sources (web-server/scribblings/dummy-stateless-servlet)] @declare-exporting[#:use-sources (web-server/scribblings/dummy-stateless-servlet)]
@defthing[interface-version (one-of/c 'stateless)]{ @defthing[interface-version (one-of/c 'stateless)]{
@ -20,11 +22,17 @@ A stateless servlet should @scheme[provide] the following exports:
} }
@defthing[stuffer (stuffer/c serializable? bytes?)]{ @defthing[stuffer (stuffer/c serializable? bytes?)]{
This is the @scheme[stuffer] that will be used for the servlet. This is the stuffer that will be used for the servlet.
If it is not provided, it defaults to @scheme[default-stuffer]. If it is not provided, it defaults to @scheme[default-stuffer].
} }
@defthing[manager manager?]{
This is the manager that will be used for the servlet.
If it is not provided, it defaults to @scheme[(create-none-manager #f)].
}
@defproc[(start [initial-request request?]) @defproc[(start [initial-request request?])
response/c]{ response/c]{
This function is called when an instance of this servlet is started. This function is called when an instance of this servlet is started.
@ -34,6 +42,7 @@ A stateless servlet should @scheme[provide] the following exports:
An example @scheme['stateless] servlet module: An example @scheme['stateless] servlet module:
@schememod[ @schememod[
web-server web-server
(provide interface-version stuffer start)
(define interface-version 'stateless) (define interface-version 'stateless)
(define stuffer (define stuffer
(stuffer-chain (stuffer-chain
@ -46,14 +55,18 @@ An example @scheme['stateless] servlet module:
These servlets have an extensive API available to them: @schememodname[net/url], @schememodname[web-server/http], These servlets have an extensive API available to them: @schememodname[net/url], @schememodname[web-server/http],
@schememodname[web-server/http/bindings], @schememodname[web-server/http/bindings],
@schememodname[web-server/lang/abort-resume], @schememodname[web-server/lang/web], @schememodname[web-server/lang/web-param], @schememodname[web-server/lang/abort-resume], @schememodname[web-server/lang/web], @schememodname[web-server/lang/native],
@schememodname[web-server/lang/web-cells], @schememodname[web-server/lang/file-box], @schememodname[web-server/dispatch], and @schememodname[web-server/lang/web-param],
@schememodname[web-server/lang/web-cells], @schememodname[web-server/lang/file-box], @schememodname[web-server/lang/soft], @schememodname[web-server/dispatch], and
@schememodname[web-server/stuffers]. @schememodname[web-server/stuffers].
Some of these are documented in the subsections that follow. Some of these are documented in the subsections that follow.
@include-section["serial.scrbl"]
@include-section["native.scrbl"]
@include-section["lang.scrbl"] @include-section["lang.scrbl"]
@include-section["lang-web-cells.scrbl"] @include-section["lang-web-cells.scrbl"]
@include-section["file-box.scrbl"] @include-section["file-box.scrbl"]
@include-section["web-param.scrbl"] @include-section["web-param.scrbl"]
@include-section["soft.scrbl"]
@include-section["stuffers.scrbl"] @include-section["stuffers.scrbl"]
@include-section["stateless-usage.scrbl"] @include-section["stateless-usage.scrbl"]

19
collects/web-server/scribblings/lang.scrbl
View File

@ -5,25 +5,10 @@
@(require (for-label net/url @(require (for-label net/url
xml xml
scheme/serialize web-server/lang/web
web-server/servlet/servlet-structs scheme
web-server/http)) web-server/http))
@section{Low Level}
@(require (for-label web-server/lang/abort-resume))
@defmodule[web-server/lang/abort-resume]{
@defproc[(call-with-serializable-current-continuation [response-generator (continuation? . -> . any)])
any]{
Captures the current continuation in a serializable way and calls @scheme[response-generator] with it, returning the result.
}
}
@section{High Level}
@(require (for-label web-server/lang/web))
@defmodule[web-server/lang/web]{ @defmodule[web-server/lang/web]{
@defproc[(send/suspend/url [response-generator (url? . -> . response/c)]) @defproc[(send/suspend/url [response-generator (url? . -> . response/c)])

36
collects/web-server/scribblings/native.scrbl Normal file
View File

@ -0,0 +1,36 @@
#lang scribble/doc
@(require "web-server.ss")
@title[]{Native Interfaces}
@(require (for-label scheme
web-server/lang/native
web-server/lang/abort-resume))
@defmodule[web-server/lang/native]{
It is sometimes inconvenient to use @scheme[serial->native] and @scheme[native->serial] throughout your program.
This module provides a macro for creating wrappers.
@defform[#:literals (ho) (define-native (native arg-spec ...) original) #:contracts ([arg-spec ho] [arg-spec _])]{
Builds an interface around @scheme[original] named @scheme[native] such that calls to @scheme[native] are wrapped in @scheme[serial->native]
and all arguments marked with @scheme[ho] in @scheme[arg-spec] are assumed to procedures and are wrapped in @scheme[native->serial].
For example,
@schemeblock[
(define-native (build-list/native _ ho) build-list)
]
is equivalent to
@schemeblock[
(define (build-list/native fst snd)
(serial->native
(build-list
fst
(lambda args
(native->serial
(apply snd args))))))
]
}
}

57
collects/web-server/scribblings/serial.scrbl Normal file
View File

@ -0,0 +1,57 @@
#lang scribble/doc
@(require "web-server.ss")
@title[]{Serializable Continuations}
@(require (for-label web-server/lang/abort-resume
"dummy-stateless-servlet.ss"
scheme/serialize))
@defmodule[web-server/lang/abort-resume]{
The main purpose of the stateless language is to provide serializable continuations to your servlet.
@defproc[(call-with-serializable-current-continuation [response-generator (continuation? . -> . any)])
any]{
Captures the current continuation in a serializable way and calls @scheme[response-generator] with it, returning the result.
This potentially uses resources of the current servlet's @scheme[manager] if @scheme[serial->native] and @scheme[native->serial] were used
to capture an untransformable context.
}
@defform[(serial->native expr)]{
@scheme[serial->native] informs the serializing runtime that @scheme[expr] is potentially a call to an untransformed context.
This sets up the necessary information for
@scheme[native->serial] to signal to @scheme[call-with-serializable-current-continuation] to capture the native (and thus unserializable) section
of the context and store it on the server.
}
@defform[(native->serial expr)]{
@scheme[native->serial] informs the serializing runtime that @scheme[expr] marks first expression after returning from an untransformed context.
This captures the
untransformed context such that @scheme[call-with-serializable-current-continuation] can store it on the server and reference it from serializable
continuations.
For example,
@schemeblock[
(build-list
3
(lambda (i)
(call-with-serializable-current-continuation
(lambda (k) (serialize k)))))
]
will fail at runtime because @scheme[build-list] is not transformed. However,
@schemeblock[
(serial->native
(build-list
3
(lambda (i)
(native->serial
(call-with-serializable-current-continuation
(lambda (k) (serialize k)))))))
]
will succeed and @scheme[k] will reference a cell in the current servlet's @scheme[manager] that stores the part of the continuation in
@scheme[build-list].
}
}

4
collects/web-server/scribblings/servlet-setup.scrbl
View File

@ -27,9 +27,11 @@ This module is used internally to build and load servlets. It may be useful to t
} }
@defproc[(make-stateless.servlet [directory path-string?] @defproc[(make-stateless.servlet [directory path-string?]
[stuffer (stuffer/c serializable? bytes?)]
[manager manager?]
[start (request? . -> . response/c)]) [start (request? . -> . response/c)])
servlet?]{ servlet?]{
Creates a stateless @schememodname[web-server] servlet that uses @scheme[directory] as its current directory and @scheme[start] as the request handler. Creates a stateless @schememodname[web-server] servlet that uses @scheme[directory] as its current directory, @scheme[stuffer] as its stuffer, and @scheme[manager] as the continuation manager, and @scheme[start] as the request handler.
} }
@defthing[default-module-specs (listof module-path?)]{ @defthing[default-module-specs (listof module-path?)]{

1
collects/web-server/scribblings/servlet.scrbl
View File

@ -33,6 +33,7 @@ An example version 2 module:
@schememod[ @schememod[
scheme scheme
(require web-server/managers/none) (require web-server/managers/none)
(provide interface-version manager start)
(define interface-version 'v2) (define interface-version 'v2)
(define manager (define manager

71
collects/web-server/scribblings/soft.scrbl Normal file
View File

@ -0,0 +1,71 @@
#lang scribble/doc
@(require "web-server.ss"
(for-label web-server/lang/soft
web-server/lang/web))
@title[]{Soft State}
@defmodule[web-server/lang/soft]{
Sometimes you want to reference a large data-structure from a stateless program without the data-structure being serialized
and increasing the size of the serialization. This module provides support for this scenario.
@defproc[(soft-state? [v any/c])
boolean?]{
Determines if @scheme[v] is a soft state record.
}
@defproc[(make-soft-state [thnk (-> any/c)])
soft-state?]{
Creates a piece of soft state that is computed by @scheme[thnk]. This value is serializable.
}
@defproc[(soft-state-ref [ss soft-state?])
any/c]{
Extracts the value associated with @scheme[ss]. If the value is not available (perhaps because of garbage collection, deserialization in an uninitialized process, etc), then the thunk associated with @scheme[ss] is invoked and the value is cached.
}
@defform[(soft-state expr ...)]{
Equivalent to @scheme[(make-soft-state (lambda () expr ...))].
}
Here's an example servlet that uses soft state:
@schememod[
web-server
(provide interface-version start)
(define interface-version 'stateless)
(define softie
(soft-state
(printf "Doing a long computation...~n")
(sleep 1)))
(define (start req)
(soft-state-ref softie)
(printf "Done~n")
(start
(send/suspend
(lambda (k-url)
`(html (body (a ([href ,k-url]) "Done")))))))
]
When this is run and the link is clicked a few times, the output is:
@verbatim{
$ plt-web-server -p 8080
Doing a long computation...
Done
Done
Done
Done
}
If the server is restarted or the hostname in the URL is changed to a different host with the same code, and the URL is clicked:
@verbatim{
^Cuser break
$ plt-web-server -p 8080
Doing a long computation...
Done
}
}

47
collects/web-server/scribblings/stateless-usage.scrbl
View File

@ -1,22 +1,25 @@
#lang scribble/doc #lang scribble/doc
@(require "web-server.ss") @(require "web-server.ss"
(for-label scheme/serialize
web-server/lang/abort-resume
web-server/lang/web))
@title[#:tag "considerations"]{Usage Considerations} @title[#:tag "considerations"]{Usage Considerations}
A servlet has the following process performed on it automatically: A stateless servlet has the following process performed on it automatically:
@itemize[ @itemize[
@item{All uses of @scheme[letrec] are removed and replaced with equivalent uses of @item{All uses of @scheme[letrec] are removed and replaced with equivalent uses of
@scheme[let] and imperative features.} @scheme[let] and imperative features.}
@item{The program is converted into ANF (Administrative Normal Form), @item{The program is converted into @link["http://en.wikipedia.org/wiki/Administrative_normal_form"]{ANF} (Administrative Normal Form),
making all continuations explicit.} making all continuations explicit.}
@item{All continuations (and other continuations marks) are recorded in the @item{All continuations and continuations marks are recorded in the
continuation marks of the expression continuation marks of the expression
they are the continuation of.} they are the continuation of.}
@item{All calls to external modules are identified and marked.} @item{All calls to external modules are identified and marked.}
@item{All uses of @scheme[call/cc] are removed and replaced with @item{All uses of @scheme[call/cc] are removed and replaced with
equivalent gathering of the continuations through the continuation-marks.} equivalent gathering of the continuations through the continuation marks installed earlier.}
@item{The program is defunctionalized with a serializable data-structure for each @item{The program is defunctionalized with a serializable data-structure for each
anonymous lambda.} @scheme[lambda].}
] ]
This process allows the continuations captured by your servlet to be serialized. This process allows the continuations captured by your servlet to be serialized.
@ -24,21 +27,21 @@ This means they may be stored on the client's browser or the server's disk.
Thus, your servlet has no cost to the server other than execution. This is Thus, your servlet has no cost to the server other than execution. This is
very attractive if you've used Scheme servlets and had memory problems. very attractive if you've used Scheme servlets and had memory problems.
This process IS defined on all of PLT Scheme and occurs AFTER macro-expansion, This process is defined on all of PLT Scheme and occurs after macro-expansion,
so you are free to use all interesting features of PLT Scheme. However, there so you are free to use all interesting features of PLT Scheme. However, there
are some considerations you must make. are some considerations you must make.
First, this process drastically changes the structure of your program. It First, this process drastically changes the structure of your program. It
will create an immense number of lambdas and structures your program will create an immense number of lambdas and structures your program
did not normally contain. The performance implication of this has not been did not normally contain. The performance implication of this has not been
studied with PLT Scheme. However, it is theoretically a benefit. The main studied with PLT Scheme.
implications would be due to optimizations MzScheme attempts to perform
that will no longer apply. Ideally, your program should be optimized first.
Second, the defunctionalization process is sensitive to the syntactic structure Second, the defunctionalization process is sensitive to the syntactic structure
of your program. Therefore, if you change your program in a trivial way, for example, of your program. Therefore, if you change your program in a trivial way, for example,
changing a constant, then all serialized continuations will be obsolete and will changing a constant, then all serialized continuations will be obsolete and will
error when deserialization is attempted. This is a feature, not a bug! error when deserialization is attempted. This is a feature, not a bug! It is a small
price to pay for protection from the sorts of errors that would occur if your program
were changed in a meaningful way.
Third, the values in the lexical scope of your continuations must be serializable Third, the values in the lexical scope of your continuations must be serializable
for the continuations itself to be serializable. This means that you must use for the continuations itself to be serializable. This means that you must use
@ -47,7 +50,7 @@ care to use modules that do the same. Similarly, you may not use @scheme[paramet
because parameterizations are not serializable. because parameterizations are not serializable.
Fourth, and related, this process only runs on your code, not on the code you Fourth, and related, this process only runs on your code, not on the code you
@scheme[require]. Thus, your continuations---to be capturable---must not @scheme[require]. Thus, your continuations---to be serializable---must not
be in the context of another module. For example, the following will not work: be in the context of another module. For example, the following will not work:
@schemeblock[ @schemeblock[
(define requests (define requests
@ -55,12 +58,22 @@ be in the context of another module. For example, the following will not work:
response-generators)) response-generators))
] ]
because @scheme[map] is not transformed by the process. However, if you defined because @scheme[map] is not transformed by the process. However, if you defined
your own @scheme[map] function, there would be no problem. your own @scheme[map] function, there would be no problem. Another solution is to
store the @scheme[map] part of the continuation on the server with @scheme[serial->native]
and @scheme[native->serial]:
@schemeblock[
(define requests
(serial->native
(map (lambda (rg) (native->serial (send/suspend/url rg)))
response-generators)))
]
Fifth, the store is NOT serialized. If you rely on the store you will Fifth, the store is @bold{not} serialized. If you rely on the store you will
be taking huge risks. You will be assuming that the serialized continuation be taking huge risks. You will be assuming that the serialized continuation
is invoked before the server is restarted or the memory is garbage collected. is invoked on the same server before the server is restarted or
the memory is garbage collected.
This process is derived from the paper This process is derived from the ICFP papers
@href-link["http://www.cs.brown.edu/~sk/Publications/Papers/Published/pcmkf-cont-from-gen-stack-insp/" "Continuations from Generalized Stack Inspection"]. @emph{@link["http://www.cs.brown.edu/~sk/Publications/Papers/Published/pcmkf-cont-from-gen-stack-insp/"]{Continuations from Generalized Stack Inspection}} by Pettyjohn et al. in 2005 and
@emph{Automatically RESTful Web Applications, Or Marking Modular Serializable Continuations} by Jay McCarthy in 2009.
We thank Greg Pettyjohn for his initial implementation of this algorithm. We thank Greg Pettyjohn for his initial implementation of this algorithm.

20
collects/web-server/scribblings/stuffers.scrbl
View File

@ -49,22 +49,22 @@ You can supply your own (built with these functions) when you write a stateless
The identitiy @tech{stuffer}. The identitiy @tech{stuffer}.
} }
@defproc[(stuffer-compose [g (stuffer any/c any/c)] @defproc[(stuffer-compose [g (stuffer/c any/c any/c)]
[f (stuffer any/c any/c)]) [f (stuffer/c any/c any/c)])
(stuffer any/c any/c)]{ (stuffer/c any/c any/c)]{
Composes @scheme[f] and @scheme[g], i.e., applies @scheme[f] then @scheme[g] for @scheme[in] Composes @scheme[f] and @scheme[g], i.e., applies @scheme[f] then @scheme[g] for @scheme[in]
and @scheme[g] then @scheme[f] for @scheme[out]. and @scheme[g] then @scheme[f] for @scheme[out].
} }
@defproc[(stuffer-sequence [f (stuffer any/c any/c)] @defproc[(stuffer-sequence [f (stuffer/c any/c any/c)]
[g (stuffer any/c any/c)]) [g (stuffer/c any/c any/c)])
(stuffer any/c any/c)]{ (stuffer/c any/c any/c)]{
@scheme[stuffer-compose] with arguments swapped. @scheme[stuffer-compose] with arguments swapped.
} }
@defproc[(stuffer-if [c (bytes? . -> . boolean?)] @defproc[(stuffer-if [c (bytes? . -> . boolean?)]
[f (stuffer bytes? bytes?)]) [f (stuffer/c bytes? bytes?)])
(stuffer bytes? bytes?)]{ (stuffer/c bytes? bytes?)]{
Creates a @tech{stuffer} that stuffs with @scheme[f] if @scheme[c] is true on the input Creates a @tech{stuffer} that stuffs with @scheme[f] if @scheme[c] is true on the input
to @scheme[in]. Similarly, applies @scheme[f] during @scheme[out] if it was applied during to @scheme[in]. Similarly, applies @scheme[f] during @scheme[out] if it was applied during
@scheme[in] (which is recorded by prepending a byte.) @scheme[in] (which is recorded by prepending a byte.)
@ -140,7 +140,7 @@ The @schememodname[web-server/stuffers/hash] @tech{stuffers} rely on a key/value
] ]
} }
It should be easy to use this interface to create store for databases, like SQLite, CouchDB, or BerkeleyDB. It should be easy to use this interface to create store for databases like SQLite, CouchDB, or BerkeleyDB.
} }
@section{Hash-addressed Storage} @section{Hash-addressed Storage}
@ -201,7 +201,7 @@ The @schememodname[web-server/stuffers/hash] @tech{stuffers} rely on a key/value
@defproc[(is-url-too-big? [v bytes?]) @defproc[(is-url-too-big? [v bytes?])
boolean?]{ boolean?]{
Determines if stuffing @scheme[v] into the current servlet's URL would result in a URL that is too big for Internet Explorer. Determines if stuffing @scheme[v] into the current servlet's URL would result in a URL that is too big for Internet Explorer.
(@link["http://www.boutell.com/newfaq/misc/urllength.html"]{IE only supports URLs up to 2048 characters.}). (@link["http://www.boutell.com/newfaq/misc/urllength.html"]{IE only supports URLs up to 2048 characters.})
} }
@defproc[(make-default-stuffer [root path-string?]) @defproc[(make-default-stuffer [root path-string?])

3
collects/web-server/scribblings/web-cells.scrbl
View File

@ -2,7 +2,8 @@
@(require "web-server.ss") @(require "web-server.ss")
@title[#:tag "web-cells.ss"]{Web Cells} @title[#:tag "web-cells.ss"]{Web Cells}
@(require (for-label web-server/servlet/web-cells)) @(require (for-label web-server/servlet/web-cells
web-server/servlet/web))
@defmodule[web-server/servlet/web-cells]{The @defmodule[web-server/servlet/web-cells]{The
@schememodname[web-server/servlet/web-cells] library provides the @schememodname[web-server/servlet/web-cells] library provides the

16
collects/web-server/servlet/setup.ss
View File

@ -67,15 +67,18 @@
(parameterize ([current-servlet-instance-id instance-id]) (parameterize ([current-servlet-instance-id instance-id])
(handler req)))))) (handler req))))))
(define (make-stateless.servlet directory stuffer start) (define (make-stateless.servlet directory stuffer manager start)
(define instance-id
((manager-create-instance manager) (exit-handler)))
(define ses (define ses
(make-stateless-servlet (make-stateless-servlet
(current-custodian) (current-namespace) (current-custodian) (current-namespace)
(create-none-manager (lambda (req) (error "No continuations!"))) manager
directory directory
(lambda (req) (error "Session not initialized")) (lambda (req) (error "Session not initialized"))
stuffer)) stuffer))
(parameterize ([current-directory directory] (parameterize ([current-directory directory]
[current-servlet-instance-id instance-id]
[current-servlet ses]) [current-servlet ses])
(set-servlet-handler! ses (initialize-servlet start))) (set-servlet-handler! ses (initialize-servlet start)))
ses) ses)
@ -110,7 +113,7 @@
(provide/contract (provide/contract
[make-v1.servlet (path-string? integer? (request? . -> . response/c) . -> . servlet?)] [make-v1.servlet (path-string? integer? (request? . -> . response/c) . -> . servlet?)]
[make-v2.servlet (path-string? manager? (request? . -> . response/c) . -> . servlet?)] [make-v2.servlet (path-string? manager? (request? . -> . response/c) . -> . servlet?)]
[make-stateless.servlet (path-string? (stuffer/c serializable? bytes?) (request? . -> . response/c) . -> . servlet?)] [make-stateless.servlet (path-string? (stuffer/c serializable? bytes?) manager? (request? . -> . response/c) . -> . servlet?)]
[default-module-specs (listof (or/c resolved-module-path? module-path?))]) [default-module-specs (listof (or/c resolved-module-path? module-path?))])
(define (make-default-path->servlet #:make-servlet-namespace [make-servlet-namespace (make-make-servlet-namespace)] (define (make-default-path->servlet #:make-servlet-namespace [make-servlet-namespace (make-make-servlet-namespace)]
@ -163,11 +166,16 @@
(dynamic-require module-name 'start) (dynamic-require module-name 'start)
pos-blame neg-blame pos-blame neg-blame
(mk-loc "start"))] (mk-loc "start"))]
[manager (contract manager?
(dynamic-require module-name 'manager
(lambda () (create-none-manager (lambda (req) (error "No continuations!")))))
pos-blame neg-blame
(mk-loc "manager"))]
[stuffer (contract (stuffer/c serializable? bytes?) [stuffer (contract (stuffer/c serializable? bytes?)
(dynamic-require module-name 'stuffer (lambda () default-stuffer)) (dynamic-require module-name 'stuffer (lambda () default-stuffer))
pos-blame neg-blame pos-blame neg-blame
(mk-loc "stuffer"))]) (mk-loc "stuffer"))])
(make-stateless.servlet (directory-part a-path) stuffer start))]))] (make-stateless.servlet (directory-part a-path) stuffer manager start))]))]
[else [else
(make-v1.servlet (directory-part a-path) timeouts-default-servlet (make-v1.servlet (directory-part a-path) timeouts-default-servlet
(v0.response->v1.lambda (v0.response->v1.lambda

30
collects/web-server/stuffers/hmac-sha1.ss
View File

@ -12,23 +12,27 @@
(unsafe!) (unsafe!)
(define libcrypto (define libcrypto
(ffi-lib libcrypto-so '("" "0.9.8b" "0.9.8" "0.9.7"))) (with-handlers ([exn:fail? (lambda (x) #f)])
(ffi-lib libcrypto-so '("" "0.9.8b" "0.9.8" "0.9.7"))))
(define EVP_SHA1 (define EVP_SHA1
(get-ffi-obj 'EVP_sha1 libcrypto (and libcrypto
(_fun f-> _fpointer))) (get-ffi-obj 'EVP_sha1 libcrypto
(_fun f-> _fpointer))))
(define HMAC-SHA1/raw (define HMAC-SHA1/raw
(get-ffi-obj 'HMAC libcrypto (if libcrypto
(_fun [EVP_MD : _fpointer = (EVP_SHA1)] (get-ffi-obj 'HMAC libcrypto
[key : _bytes] (_fun [EVP_MD : _fpointer = (EVP_SHA1)]
[key_len : _int = (bytes-length key)] [key : _bytes]
[data : _bytes] [key_len : _int = (bytes-length key)]
[data_len : _int = (bytes-length data)] [data : _bytes]
[md : _int = 0] [data_len : _int = (bytes-length data)]
[md_len : _int = 0] [md : _int = 0]
f-> [md_len : _int = 0]
_pointer))) f->
_pointer))
(lambda (key data) (error 'HMAC-SHA1/raw "libcrypto could not load"))))
(define (HMAC-SHA1 key data) (define (HMAC-SHA1 key data)
; It returns the same pointer always ; It returns the same pointer always

6
doc/release-notes/drscheme/HISTORY.txt
View File

@ -1,3 +1,9 @@
------------------------------
Version 4.2
------------------------------
. Minor bug fixes
------------------------------ ------------------------------
Version 4.1.5 Version 4.1.5
------------------------------ ------------------------------

4
doc/release-notes/redex/HISTORY.txt
View File

@ -1,3 +1,7 @@
v4.2
* minor bug fixes
v4.1.5 v4.1.5
* renamed test--> to test-->> * renamed test--> to test-->>

7
doc/release-notes/teachpack/HISTORY.txt
View File

@ -1,3 +1,10 @@
------------------------------------------------------------------------
Version 4.2 [Thu May 21 08:51:15 EDT 2009]
* the universe API has changed. It no longer uses chars or symbols
for the callbacks but one-letter strings, except for arrow keys
and special events, which are arbitrarily long strings.
------------------------------------------------------------------------ ------------------------------------------------------------------------
Version 4.1.5 [Sat Feb 14 20:12:23 EST 2009] Version 4.1.5 [Sat Feb 14 20:12:23 EST 2009]

17
src/configure vendored
View File

@ -1368,6 +1368,7 @@ Optional Features:
--enable-xonx compile X11 (not Quartz) MrEd for Mac OS X --enable-xonx compile X11 (not Quartz) MrEd for Mac OS X
--enable-libfw install Mac OS X frameworks to /Library/Frameworks --enable-libfw install Mac OS X frameworks to /Library/Frameworks
--enable-userfw install Mac OS X frameworks to ~/Library/Frameworks --enable-userfw install Mac OS X frameworks to ~/Library/Frameworks
--enable-macprefix allow --prefix with a Mac OS X install
Optional Packages: Optional Packages:
--with-PACKAGE[=ARG] use PACKAGE [ARG=yes] --with-PACKAGE[=ARG] use PACKAGE [ARG=yes]
@ -2011,6 +2012,11 @@ if test "${enable_libfw+set}" = set; then
enableval=$enable_libfw; enableval=$enable_libfw;
fi fi
# Check whether --enable-macprefix was given.
if test "${enable_macprefix+set}" = set; then
enableval=$enable_macprefix;
fi
###### Get OS Type ####### ###### Get OS Type #######
@ -2071,6 +2077,17 @@ else
if test "$OS" = "Darwin" ; then if test "$OS" = "Darwin" ; then
enable_quartz=yes enable_quartz=yes
enable_origtree=yes enable_origtree=yes
if test "${prefix}" != "NONE" ; then
if test "${enable_macprefix}" != "yes" ; then
echo "ERROR: --prefix not allowed for a Mac OS X build, unless either"
echo " --enable-xonx is supplied (to create a Unix-style"
echo " build), or "
echo " --enable-macprefix is supplied (to allow a Mac-style"
echo " installation, even though --prefix is normally used"
echo " for Unix-style installations)"
exit 1
fi
fi
fi fi
fi fi

18
src/mred/Makefile.in
View File

@ -174,17 +174,17 @@ mred.@LTO@ : $(srcdir)/mred.cxx \
$(srcdir)/../mzscheme/include/scheme.h \ $(srcdir)/../mzscheme/include/scheme.h \
$(srcdir)/wxs/wxsmred.h $(WXINCDEP) $(srcdir)/../wxcommon/wxGC.h \ $(srcdir)/wxs/wxsmred.h $(WXINCDEP) $(srcdir)/../wxcommon/wxGC.h \
$(srcdir)/../wxcommon/wx_list.h $(srcdir)/../wxcommon/wx_list.h
$(CXX) $(CXXFLAGS) $(LOCALFLAGS) -c $(srcdir)/mred.cxx -o mred.@LTO@ $(CXX) $(LOCALFLAGS) $(CXXFLAGS) -c $(srcdir)/mred.cxx -o mred.@LTO@
DEF_COLLECTS_DIR = -DINITIAL_COLLECTS_DIRECTORY='"'"`cd $(srcdir)/../../collects; pwd`"'"' DEF_COLLECTS_DIR = -DINITIAL_COLLECTS_DIRECTORY='"'"`cd $(srcdir)/../../collects; pwd`"'"'
mrmain.@LTO@ : $(srcdir)/mrmain.cxx $(srcdir)/mred.h $(srcdir)/wxs/wxsmred.h \ mrmain.@LTO@ : $(srcdir)/mrmain.cxx $(srcdir)/mred.h $(srcdir)/wxs/wxsmred.h \
$(srcdir)/../mzscheme/cmdline.inc $(srcdir)/../mzscheme/src/stypes.h \ $(srcdir)/../mzscheme/cmdline.inc $(srcdir)/../mzscheme/src/stypes.h \
$(srcdir)/../mzscheme/include/scheme.h $(srcdir)/../mzscheme/include/scheme.h
$(CXX) $(CXXFLAGS) $(LOCALFLAGS) $(DEF_COLLECTS_DIR) -c $(srcdir)/mrmain.cxx -o mrmain.@LTO@ $(CXX) $(LOCALFLAGS) $(CXXFLAGS) $(DEF_COLLECTS_DIR) -c $(srcdir)/mrmain.cxx -o mrmain.@LTO@
mrmain_ee.@LTO@ : mred.@LTO@ mrmain_ee.@LTO@ : mred.@LTO@
$(CXX) $(CXXFLAGS) $(LOCALFLAGS) -DSTANDALONE_WITH_EMBEDDED_EXTENSION $(DEF_COLLECTS_DIR) -c $(srcdir)/mrmain.cxx -o mrmain_ee.@LTO@ $(CXX) $(LOCALFLAGS) $(CXXFLAGS) -DSTANDALONE_WITH_EMBEDDED_EXTENSION $(DEF_COLLECTS_DIR) -c $(srcdir)/mrmain.cxx -o mrmain_ee.@LTO@
ee-main: ee-main:
$(MAKE) mrmain_ee.@LTO@ $(MAKE) mrmain_ee.@LTO@
@ -193,28 +193,28 @@ mredx.@LTO@ : $(srcdir)/mredx.cxx $(srcdir)/../mzscheme/include/scheme.h $(srcdi
$(WXINCDEP) \ $(WXINCDEP) \
$(srcdir)/../wxcommon/wxGC.h $(srcdir)/../wxcommon/wx_list.h \ $(srcdir)/../wxcommon/wxGC.h $(srcdir)/../wxcommon/wx_list.h \
$(srcdir)/../mzscheme/src/stypes.h $(srcdir)/../mzscheme/src/stypes.h
$(CXX) $(CXXFLAGS) $(LOCALFLAGS) -c $(srcdir)/mredx.cxx -o mredx.@LTO@ $(CXX) $(LOCALFLAGS) $(CXXFLAGS) -c $(srcdir)/mredx.cxx -o mredx.@LTO@
mredmac.@LTO@ : $(srcdir)/mredmac.cxx $(srcdir)/../mzscheme/include/scheme.h $(srcdir)/mred.h \ mredmac.@LTO@ : $(srcdir)/mredmac.cxx $(srcdir)/../mzscheme/include/scheme.h $(srcdir)/mred.h \
$(srcdir)/../wxcommon/wxGC.h $(srcdir)/../wxcommon/wx_list.h \ $(srcdir)/../wxcommon/wxGC.h $(srcdir)/../wxcommon/wx_list.h \
$(srcdir)/../mzscheme/src/stypes.h $(srcdir)/../mzscheme/src/stypes.h
$(CXX) $(CXXFLAGS) $(LOCALFLAGS) -c $(srcdir)/mredmac.cxx -o mredmac.@LTO@ $(CXX) $(LOCALFLAGS) $(CXXFLAGS) -c $(srcdir)/mredmac.cxx -o mredmac.@LTO@
wxGC.@LTO@ : $(srcdir)/../wxcommon/wxGC.cxx $(srcdir)/../wxcommon/wxGC.h \ wxGC.@LTO@ : $(srcdir)/../wxcommon/wxGC.cxx $(srcdir)/../wxcommon/wxGC.h \
$(srcdir)/../mzscheme/src/stypes.h $(srcdir)/../mzscheme/src/stypes.h
$(CXX) $(CXXFLAGS) $(LOCALFLAGS) -c $(srcdir)/../wxcommon/wxGC.cxx -o wxGC.@LTO@ $(CXX) $(LOCALFLAGS) $(CXXFLAGS) -c $(srcdir)/../wxcommon/wxGC.cxx -o wxGC.@LTO@
wxJPEG.@LTO@ : $(srcdir)/../wxcommon/wxJPEG.cxx $(srcdir)/../wxcommon/wxGC.h wxJPEG.@LTO@ : $(srcdir)/../wxcommon/wxJPEG.cxx $(srcdir)/../wxcommon/wxGC.h
$(CXX) $(CXXFLAGS) $(LOCALFLAGS) @JPEG_INC@ @ZLIB_INC@ -c $(srcdir)/../wxcommon/wxJPEG.cxx -o wxJPEG.@LTO@ $(CXX) $(LOCALFLAGS) $(CXXFLAGS) @JPEG_INC@ @ZLIB_INC@ -c $(srcdir)/../wxcommon/wxJPEG.cxx -o wxJPEG.@LTO@
dl_stub.@LTO@: $(srcdir)/misc/dl_stub.c dl_stub.@LTO@: $(srcdir)/misc/dl_stub.c
$(CC) $(CFLAGS) $(LOCALFLAGS) -c $(srcdir)/misc/dl_stub.c -o dl_stub.@LTO@ $(CC) $(CFLAGS) $(LOCALFLAGS) -c $(srcdir)/misc/dl_stub.c -o dl_stub.@LTO@
simpledrop.@LTO@ : $(srcdir)/../mac/mzscheme/simpledrop.cpp simpledrop.@LTO@ : $(srcdir)/../mac/mzscheme/simpledrop.cpp
$(CXX) $(CXXFLAGS) $(LOCALFLAGS) -o simpledrop.@LTO@ -c $(srcdir)/../mac/mzscheme/simpledrop.cpp $(CXX) $(LOCALFLAGS) $(CXXFLAGS) -o simpledrop.@LTO@ -c $(srcdir)/../mac/mzscheme/simpledrop.cpp
sgilinkhack.@LTO@: sgilinkhack.@LTO@:
$(CXX) $(CXXFLAGS) $(LOCALFLAGS) -c $(srcdir)/misc/sgilinkhack.cxx -o sgilinkhack.@LTO@ $(CXX) $(LOCALFLAGS) $(CXXFLAGS) -c $(srcdir)/misc/sgilinkhack.cxx -o sgilinkhack.@LTO@
$(WXDIR)/libwx_xt.@LIBSFX@: $(WXDIR)/libwx_xt.@LIBSFX@:
$(MAKE) wx $(MAKE) wx

5
src/mred/mred.cxx
View File

@ -3152,6 +3152,11 @@ wxFrame *MrEdApp::OnInit(void)
# endif # endif
#endif #endif
#ifdef OS_X
/* Hack to make sure it's referenced, so that xform doesn't throw it away. */
wx_in_terminal = wx_in_terminal;
#endif
mred_run_from_cmd_line(argc, argv, setup_basic_env); mred_run_from_cmd_line(argc, argv, setup_basic_env);
#if WCONSOLE_STDIO #if WCONSOLE_STDIO

2
src/mred/mred.h
View File

@ -198,7 +198,7 @@ MRED_EXTERN void mred_set_run_from_cmd_line(MrEd_Run_From_Cmd_Line_Proc);
#endif #endif
#ifndef REDIRECT_STDIO #ifndef REDIRECT_STDIO
# if (defined(wx_msw) || defined(wx_mac)) && !WCONSOLE_STDIO # if defined(wx_msw) && !WCONSOLE_STDIO
# define REDIRECT_STDIO 1 # define REDIRECT_STDIO 1
# else # else
# define REDIRECT_STDIO 0 # define REDIRECT_STDIO 0

2
src/mred/mredmsw.cxx
View File

@ -180,6 +180,7 @@ static BOOL CALLBACK CheckWindow(HWND wnd, LPARAM param)
info->remove ? PM_REMOVE : PM_NOREMOVE)) { info->remove ? PM_REMOVE : PM_NOREMOVE)) {
info->wnd = wnd; info->wnd = wnd;
info->c_return = c; info->c_return = c;
scheme_notify_sleep_progress();
return FALSE; return FALSE;
} }
} }
@ -217,6 +218,7 @@ int FindReady(MrEdContext *c, MSG *msg, int remove, MrEdContext **c_return)
while (PeekMessage(&pmsg, NULL, 0x4000, 0xFFFF, PM_REMOVE)) { while (PeekMessage(&pmsg, NULL, 0x4000, 0xFFFF, PM_REMOVE)) {
wxTranslateMessage(&pmsg); wxTranslateMessage(&pmsg);
DispatchMessage(&pmsg); DispatchMessage(&pmsg);
scheme_notify_sleep_progress();
} }
} }

1
src/mred/wxs/wxscheme.cxx
View File

@ -2108,6 +2108,7 @@ Bool wxMediaPrintout::OnBeginDocument(int startPage, int endPage)
void wxMediaPrintout::OnEndDocument() void wxMediaPrintout::OnEndDocument()
{ {
scheme_apply(end_doc, 0, NULL); scheme_apply(end_doc, 0, NULL);
wxPrintout::OnEndDocument();
} }
#endif #endif

4
src/mzscheme/Makefile.in
View File

@ -170,10 +170,10 @@ mzscheme.multiboot : libmzscheme.@LIBSFX@ libmzgc.@LIBSFX@ main.@LTO@
DEF_COLLECTS_DIR = -DINITIAL_COLLECTS_DIRECTORY='"'"`cd $(srcdir)/../../collects; pwd`"'"' DEF_COLLECTS_DIR = -DINITIAL_COLLECTS_DIRECTORY='"'"`cd $(srcdir)/../../collects; pwd`"'"'
main.@LTO@: $(srcdir)/main.c $(srcdir)/include/scheme.h $(srcdir)/sconfig.h $(srcdir)/src/stypes.h $(srcdir)/cmdline.inc $(srcdir)/oskglue.inc main.@LTO@: $(srcdir)/main.c $(srcdir)/include/scheme.h $(srcdir)/sconfig.h $(srcdir)/src/stypes.h $(srcdir)/cmdline.inc $(srcdir)/oskglue.inc
$(CC) @CFLAGS@ @COMPFLAGS@ @PREFLAGS@ @PROFFLAGS@ @OPTIONS@ @MZOPTIONS@ $(DEF_COLLECTS_DIR) -I$(builddir) -I$(srcdir)/include -c $(srcdir)/main.c -o main.@LTO@ $(CC) -I$(builddir) -I$(srcdir)/include @CFLAGS@ @COMPFLAGS@ @PREFLAGS@ @PROFFLAGS@ @OPTIONS@ @MZOPTIONS@ $(DEF_COLLECTS_DIR) -c $(srcdir)/main.c -o main.@LTO@
main_ee.@LTO@: main.@LTO@ main_ee.@LTO@: main.@LTO@
$(CC) @CFLAGS@ @COMPFLAGS@ @PREFLAGS@ @PROFFLAGS@ @OPTIONS@ @MZOPTIONS@ $(DEF_COLLECTS_DIR) -I$(builddir) -I$(srcdir)/include -DSTANDALONE_WITH_EMBEDDED_EXTENSION -c $(srcdir)/main.c -o main_ee.@LTO@ $(CC) -I$(builddir) -I$(srcdir)/include @CFLAGS@ @COMPFLAGS@ @PREFLAGS@ @PROFFLAGS@ @OPTIONS@ @MZOPTIONS@ $(DEF_COLLECTS_DIR) -DSTANDALONE_WITH_EMBEDDED_EXTENSION -c $(srcdir)/main.c -o main_ee.@LTO@
ee-main: ee-main:
$(MAKE) main_ee.@LTO@ $(MAKE) main_ee.@LTO@

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