sync to trunk
svn: r14940
This commit is contained in:
Sam Tobin-Hochstadt
commit
a8ee2dc161
|
|
@ -20,8 +20,6 @@ Zusätzliche Prozeduren erlauben die Komposition von Bildern.
|
|||
@;-----------------------------------------------------------------------------
|
||||
@section{Bilder}
|
||||
|
||||
@declare-exporting[teachpack/deinprogramm/image]
|
||||
|
||||
@defthing[image contract]{
|
||||
Ein @deftech{Bild} (Name: @scheme[image]) ist die Repräsentation eines Bildes.
|
||||
}
|
||||
|
|
|
|||
|
|
@ -46,12 +46,12 @@ TODO
|
|||
(define checkpoints (make-weak-hasheq))
|
||||
(define (call-with-stack-checkpoint thunk)
|
||||
(define checkpoint (current-continuation-marks))
|
||||
(with-handlers ([exn? (lambda (exn)
|
||||
;; nested ones take precedence
|
||||
(call-with-exception-handler
|
||||
(λ (exn)
|
||||
(unless (hash-has-key? checkpoints exn)
|
||||
(hash-set! checkpoints exn checkpoint))
|
||||
(raise exn))])
|
||||
(thunk)))
|
||||
exn)
|
||||
thunk))
|
||||
;; returns the stack of the input exception, cutting off any tail that was
|
||||
;; registered as a checkpoint
|
||||
(define (cut-stack-at-checkpoint exn)
|
||||
|
|
|
|||
|
|
@ -9,12 +9,12 @@
|
|||
(interface (scheme:text<%>)
|
||||
printing-on
|
||||
printing-off
|
||||
is-printing?))
|
||||
is-printing-on?))
|
||||
|
||||
(define text%
|
||||
(class* scheme:text% (text<%>)
|
||||
(define printing? #f)
|
||||
(define/public (is-printing?) printing?)
|
||||
(define/public (is-printing-on?) printing?)
|
||||
(define/public (printing-on) (set! printing? #t))
|
||||
(define/public (printing-off) (set! printing? #f))
|
||||
; (rename [super-on-paint on-paint])
|
||||
|
|
|
|||
|
|
@ -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
|
||||
|
|
@ -1129,7 +1129,7 @@ based on the state of the key event.
|
|||
(world-state w)
|
||||
(world-size 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
|
||||
to a helper function:
|
||||
|
|
@ -1156,7 +1156,7 @@ player's move (via the @scheme[player-moved?] function.
|
|||
(update-world-posn
|
||||
moved-world
|
||||
(and (eq? (world-state moved-world) 'playing)
|
||||
(not (eq? evt 'leave))
|
||||
(not (equal? evt "leave"))
|
||||
(make-posn x y)))))]
|
||||
|
||||
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)
|
||||
(-> world? integer? integer? any/c
|
||||
(or/c posn? #f))
|
||||
(and (equal? evt 'button-up)
|
||||
(and (equal? evt "button-up")
|
||||
(equal? 'playing (world-state world))
|
||||
(circle-at-point (world-board world) x y)))]
|
||||
|
||||
|
|
@ -2009,7 +2009,7 @@ and reports the results.
|
|||
@chunk[<clack-tests>
|
||||
(test (clack
|
||||
(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))
|
||||
(test (clack
|
||||
(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)
|
||||
10
|
||||
10
|
||||
'button-down)
|
||||
"button-down")
|
||||
(make-world '() (make-posn 0 0) 'playing 3 #f #f))
|
||||
|
||||
(test (clack (make-world (list (make-cell (make-posn 0 0) #f)
|
||||
|
|
@ -2071,7 +2071,7 @@ and reports the results.
|
|||
#f)
|
||||
(cell-center-x (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-cell (make-posn 1 1) #f))
|
||||
(make-posn 1 1)
|
||||
|
|
@ -2085,7 +2085,7 @@ and reports the results.
|
|||
'cat-lost 3 (make-posn 0 0) #f)
|
||||
10
|
||||
10
|
||||
'button-up)
|
||||
"button-up")
|
||||
(make-world '() (make-posn 0 0)
|
||||
'cat-lost 3 #f #f))
|
||||
(test (clack
|
||||
|
|
@ -2104,7 +2104,7 @@ and reports the results.
|
|||
#f)
|
||||
(cell-center-x (make-posn 1 0))
|
||||
(cell-center-y (make-posn 1 0))
|
||||
'button-up)
|
||||
"button-up")
|
||||
(make-world
|
||||
(list (make-cell (make-posn 1 0) #t)
|
||||
(make-cell (make-posn 2 0) #t)
|
||||
|
|
@ -2135,7 +2135,7 @@ and reports the results.
|
|||
#f)
|
||||
(cell-center-x (make-posn 1 0))
|
||||
(cell-center-y (make-posn 1 0))
|
||||
'button-up)
|
||||
"button-up")
|
||||
(make-world
|
||||
(list (make-cell (make-posn 1 0) #t)
|
||||
(make-cell (make-posn 2 0) #f)
|
||||
|
|
@ -2246,12 +2246,12 @@ and reports the results.
|
|||
@chunk[<change-tests>
|
||||
(test (change (make-world '() (make-posn 1 1)
|
||||
'playing 3 (make-posn 0 0) #f)
|
||||
#\h)
|
||||
"h")
|
||||
(make-world '() (make-posn 1 1)
|
||||
'playing 3 (make-posn 0 0) #t))
|
||||
(test (change (make-world '() (make-posn 1 1)
|
||||
'playing 3 (make-posn 0 0) #t)
|
||||
'release)
|
||||
"release")
|
||||
(make-world '() (make-posn 1 1) 'playing 3 (make-posn 0 0) #f))]
|
||||
|
||||
|
||||
|
|
|
|||
|
|
@ -14,7 +14,7 @@
|
|||
|
||||
(define-values/invoke-unit/infer
|
||||
(export graphics^)
|
||||
(link graphics-posn-less@ standard-mred@))
|
||||
(link standard-mred@ graphics-posn-less@))
|
||||
|
||||
(provide-signature-elements graphics^)
|
||||
|
||||
|
|
|
|||
|
|
@ -342,99 +342,11 @@
|
|||
hide-none-policy)
|
||||
|
||||
(define standard-policy
|
||||
#;(make-policy #t #t #t #t null)
|
||||
(policy->predicate 'standard))
|
||||
|
||||
(define base-policy
|
||||
#;(make-policy #t #f #f #f null)
|
||||
(policy->predicate
|
||||
'(custom #t #f #f #f ())))
|
||||
|
||||
(define (hide-all-policy id) #f)
|
||||
(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)))))
|
||||
|#
|
||||
|
|
|
|||
|
|
@ -612,7 +612,7 @@
|
|||
;; lift-error
|
||||
(define (lift-error sym . args)
|
||||
(apply fprintf (current-error-port) args)
|
||||
(when #t
|
||||
(when #f
|
||||
(apply error sym args)))
|
||||
|
||||
;; opaque-table
|
||||
|
|
|
|||
|
|
@ -41,15 +41,26 @@
|
|||
;; (list #f) ;; "self" module
|
||||
;; null
|
||||
|
||||
;; An rmp-sexpr is
|
||||
;; (list 'resolved path/symbol)
|
||||
|
||||
;; mpi->mpi-sexpr : mpi -> mpi-sexpr
|
||||
(define (mpi->mpi-sexpr mpi)
|
||||
(cond [(module-path-index? 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)
|
||||
(list (rmp->rmp-sexpr mpi))]
|
||||
[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
|
||||
(define (mpi-sexpr->mpi sexpr)
|
||||
(match sexpr
|
||||
|
|
@ -124,7 +135,11 @@
|
|||
[else
|
||||
`(REL (split-mods 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
|
||||
(define (expanded-mpi-sexpr->mpi-sexpr sexpr)
|
||||
|
|
|
|||
|
|
@ -23,7 +23,8 @@
|
|||
"../model/reductions.ss"
|
||||
"../model/steps.ss"
|
||||
"cursor.ss"
|
||||
"../util/notify.ss")
|
||||
"../util/notify.ss"
|
||||
(only-in mzscheme [#%top-interaction mz-top-interaction]))
|
||||
(provide macro-stepper-widget%
|
||||
macro-stepper-widget/process-mixin)
|
||||
|
||||
|
|
@ -434,7 +435,8 @@
|
|||
|
||||
;; adjust-deriv/top : Derivation -> Derivation
|
||||
(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))
|
||||
deriv
|
||||
;; It's not original...
|
||||
|
|
@ -454,6 +456,7 @@
|
|||
#f])))
|
||||
|
||||
(define/public (top-interaction-kw? x)
|
||||
(free-identifier=? x #'#%top-interaction))
|
||||
(or (free-identifier=? x #'#%top-interaction)
|
||||
(free-identifier=? x #'mz-top-interaction)))
|
||||
|
||||
))
|
||||
|
|
|
|||
|
|
@ -259,7 +259,8 @@ Matthew
|
|||
(interactive? fit-on-page?)
|
||||
(interactive? fit-on-page? output-mode)
|
||||
(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)
|
||||
|
||||
(get-text [() (x) (x y) (x y z) (x y z p)] unlocked)
|
||||
|
|
|
|||
|
|
@ -10,7 +10,8 @@
|
|||
method-name init-name
|
||||
let-boxes
|
||||
properties field-properties init-properties
|
||||
->long)
|
||||
->long
|
||||
assert)
|
||||
|
||||
(define-syntax-parameter class-name #f)
|
||||
|
||||
|
|
@ -264,3 +265,7 @@
|
|||
[(eqv? +inf.0 i) (expt 2 64)]
|
||||
[(eqv? +nan.0 i) 0]
|
||||
[else (inexact->exact (floor i))]))
|
||||
|
||||
|
||||
(define-syntax-rule (assert e) (void))
|
||||
; (define-syntax-rule (assert e) (unless e (error 'assert "failed: ~s" 'e)))
|
||||
|
|
|
|||
|
|
@ -224,5 +224,10 @@
|
|||
0 0 #t #t)))
|
||||
(inherit editor-canvas-on-scroll)
|
||||
(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))))
|
||||
|
|
|
|||
|
|
@ -5,6 +5,7 @@
|
|||
"editor-admin.ss"
|
||||
"private.ss"
|
||||
(only-in "cycle.ss" popup-menu%)
|
||||
(only-in "../helper.ss" queue-window-callback)
|
||||
"wx.ss")
|
||||
|
||||
(provide editor-canvas%)
|
||||
|
|
@ -350,9 +351,17 @@
|
|||
(thunk)))
|
||||
|
||||
(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)
|
||||
(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?)
|
||||
|
||||
|
|
@ -532,7 +541,9 @@
|
|||
(if (and media
|
||||
(or (positive? y)
|
||||
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)])
|
||||
(set-box! fy v)
|
||||
(when (and scroll-bottom-based?
|
||||
|
|
|
|||
|
|
@ -544,17 +544,23 @@
|
|||
|
||||
(def/override (get-num-scroll-steps)
|
||||
(if editor
|
||||
(send editor num-scroll-lines)
|
||||
(if (send editor locked-for-read?)
|
||||
1
|
||||
(send editor num-scroll-lines))
|
||||
1))
|
||||
|
||||
(def/override (find-scroll-step [real? y])
|
||||
(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))
|
||||
|
||||
(def/override (get-scroll-step-offset [exact-integer? n])
|
||||
(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))
|
||||
|
||||
(def/override (set-unmodified)
|
||||
|
|
|
|||
|
|
@ -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))
|
||||
(def/public (get-keymap) s-keymap)
|
||||
(def/public (get-style-list) s-style-list)
|
||||
|
|
@ -540,7 +540,7 @@
|
|||
[box? data-buffer])
|
||||
(set-box! data-buffer (send f tell))
|
||||
(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)
|
||||
|
||||
(def/public (end-write-header-footer-to-file [editor-stream-out% f]
|
||||
|
|
@ -850,7 +850,7 @@
|
|||
(values 0 size s naya))
|
||||
;; no room to grow, so drop an undo record
|
||||
(begin
|
||||
(send c cancel)
|
||||
(send (vector-ref c start) cancel)
|
||||
(vector-set! c start #f)
|
||||
(values (modulo (add1 start) size)
|
||||
end
|
||||
|
|
|
|||
|
|
@ -633,7 +633,7 @@
|
|||
(if (eq? asnip nexts)
|
||||
l
|
||||
(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))
|
||||
(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)
|
||||
(if (bit-overlap? (mline-flags mline) FLOW-LEFT)
|
||||
(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
|
||||
(begin
|
||||
(set-mline-flags! mline (- (mline-flags mline) FLOW-LEFT))
|
||||
|
|
@ -922,6 +923,7 @@ Debugging tools:
|
|||
(let* ([first-line (box #f)]
|
||||
[para (get-paragraph-style mline 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))
|
||||
(do-flow)
|
||||
(flow-right))))
|
||||
|
|
@ -929,7 +931,8 @@ Debugging tools:
|
|||
(define (flow-right)
|
||||
(if (bit-overlap? (mline-flags mline) FLOW-RIGHT)
|
||||
(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
|
||||
(begin
|
||||
(set-mline-flags! mline (- (mline-flags mline) FLOW-RIGHT))
|
||||
|
|
@ -939,17 +942,20 @@ Debugging tools:
|
|||
(let loop ([asnip (mline-snip mline)])
|
||||
(if (eq? asnip (mline-last-snip mline))
|
||||
(begin
|
||||
(do-extend-line asnip)
|
||||
(do-extend-line mline asnip)
|
||||
(assert (send media consistent-snip-lines 'post-do-extend-line))
|
||||
#t)
|
||||
(if (has-flag? (snip->flags asnip) NEWLINE)
|
||||
(begin
|
||||
(do-new-line asnip)
|
||||
(send media consistent-snip-lines 'post-do-new-line)
|
||||
#t)
|
||||
(begin
|
||||
(set-snip-line! asnip mline)
|
||||
(loop (snip->next 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 ([nextsnip (if next
|
||||
(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! mline asnip)
|
||||
|
||||
(snips-to-line! newline))
|
||||
;; just pushed to next line
|
||||
(snips-to-line! newline)
|
||||
|
||||
(notify-insert newline))
|
||||
;; some of this line pushed to next line --- or maybe multiple lines pushed
|
||||
;; together into a later line
|
||||
(begin
|
||||
(set-mline-last-snip! mline asnip)
|
||||
(set-snip-line! asnip mline)
|
||||
|
||||
(set-mline-snip! next (snip->next asnip))
|
||||
|
||||
(snips-to-line! next)))
|
||||
(let ([nextsnip (snip->next asnip)])
|
||||
(set-mline-snip! next nextsnip)
|
||||
(do-extend-line next nextsnip))))
|
||||
|
||||
(calc-line-length mline)
|
||||
(mark-recalculate mline))))
|
||||
|
|
@ -992,9 +1001,12 @@ Debugging tools:
|
|||
(if (and (mline-next mline)
|
||||
(eq? asnip (mline-last-snip (mline-next mline))))
|
||||
;; 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))
|
||||
(define (do-extend-line asnip)
|
||||
(define (do-extend-line mline asnip)
|
||||
;; this line was extended
|
||||
(let ([asnip
|
||||
(if asnip
|
||||
|
|
@ -1015,6 +1027,7 @@ Debugging tools:
|
|||
(let ([next (mline-next mline)])
|
||||
(when next
|
||||
(delete next root-box)
|
||||
(notify-delete delete)
|
||||
(loop))))
|
||||
#f))])
|
||||
|
||||
|
|
|
|||
|
|
@ -85,7 +85,6 @@
|
|||
end-sequence-lock
|
||||
check-flow
|
||||
get-printing
|
||||
is-printing?
|
||||
do-begin-print
|
||||
do-end-print
|
||||
do-has-print-page?)
|
||||
|
|
@ -96,9 +95,11 @@
|
|||
get-s-last-snip
|
||||
get-s-total-width
|
||||
get-s-total-height
|
||||
get-s-snips
|
||||
refresh-box
|
||||
add-back-clickback
|
||||
do-insert-snips)
|
||||
do-insert-snips
|
||||
consistent-snip-lines)
|
||||
|
||||
;; editor-admin%
|
||||
(define-local-member-name
|
||||
|
|
|
|||
|
|
@ -80,7 +80,9 @@
|
|||
(let-boxes ([ok? #f]
|
||||
[sl 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?
|
||||
(let-boxes ([sr 0.0][sb 0.0])
|
||||
(send editor get-snip-location snip sr sb #t)
|
||||
|
|
|
|||
|
|
@ -643,7 +643,11 @@
|
|||
(values n
|
||||
tabs
|
||||
space
|
||||
(if units? 1 str-w)))
|
||||
(if units?
|
||||
1
|
||||
(if (zero? str-w)
|
||||
1.0
|
||||
str-w))))
|
||||
(values 0
|
||||
#()
|
||||
TAB-WIDTH
|
||||
|
|
@ -1104,7 +1108,7 @@
|
|||
(send mask2 ok?)
|
||||
(= w (send mask2 get-width))
|
||||
(= 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)))))))
|
||||
|
||||
(define/private (do-hash-code hash-code)
|
||||
|
|
|
|||
|
|
@ -233,10 +233,38 @@
|
|||
(define initial-space 0.0) ; space 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-total-width) total-width)
|
||||
(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 dragstart 0)
|
||||
|
|
@ -593,6 +621,7 @@
|
|||
|
||||
(def/override (blink-caret)
|
||||
(if s-caret-snip
|
||||
(when s-admin
|
||||
(let-boxes ([dx 0.0]
|
||||
[dy 0.0]
|
||||
[dc #f])
|
||||
|
|
@ -600,7 +629,7 @@
|
|||
(when dc
|
||||
(let-boxes ([x 0.0] [y 0.0])
|
||||
(get-snip-location s-caret-snip x y)
|
||||
(send s-caret-snip blink-caret dc (- x dx) (- y dy)))))
|
||||
(send s-caret-snip blink-caret dc (- x dx) (- y dy))))))
|
||||
(if (too-busy-to-refresh?)
|
||||
;; we're busy; go away
|
||||
(void)
|
||||
|
|
@ -1036,7 +1065,8 @@
|
|||
;; - already at top
|
||||
(let-boxes ([scroll-left 0.0] [vy 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
|
||||
;; scrolling
|
||||
(let* ([top (find-scroll-line vy)]
|
||||
|
|
@ -1094,7 +1124,8 @@
|
|||
(if (eq? 'page kind)
|
||||
(let-boxes ([scroll-left 0.0] [vy 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
|
||||
(let* ([newtop (find-scroll-line (+ vy scroll-height))]
|
||||
[y (scroll-line-location (+ newtop 1))]
|
||||
|
|
@ -1180,6 +1211,7 @@
|
|||
;; ----------------------------------------
|
||||
|
||||
(define/private (do-insert isnip str snipsl start end scroll-ok?)
|
||||
(assert (consistent-snip-lines 'do-insert))
|
||||
(unless (or write-locked?
|
||||
s-user-locked?
|
||||
(start . < . 0))
|
||||
|
|
@ -1274,7 +1306,8 @@
|
|||
(cond
|
||||
[(or isnip snipsl)
|
||||
(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)
|
||||
(let ([addlen (for/fold ([addlen 0])
|
||||
|
|
@ -1313,6 +1346,9 @@
|
|||
(not (has-flag? (snip->flags isnip) HARD-NEWLINE)))
|
||||
(set-snip-flags! isnip (remove-flag (snip->flags isnip) NEWLINE)))
|
||||
|
||||
(assert (consistent-snip-lines 'inner-insert))
|
||||
|
||||
|
||||
(let-values ([(before-snip inserted-new-line?)
|
||||
(if (and (zero? len) (not did-one?))
|
||||
|
||||
|
|
@ -1348,6 +1384,10 @@
|
|||
(set! num-valid-lines (add1 num-valid-lines))
|
||||
#t)
|
||||
(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)
|
||||
(when (not (mline-snip last-line))
|
||||
(set-mline-snip! last-line isnip))
|
||||
|
|
@ -1409,6 +1449,8 @@
|
|||
(set! first-line (mline-first (unbox line-root-box)))
|
||||
(set! last-line (mline-last (unbox line-root-box)))
|
||||
|
||||
(assert (consistent-snip-lines 'inner-insert2))
|
||||
|
||||
(loop #t
|
||||
before-snip
|
||||
(or inserted-line? inserted-new-line?)
|
||||
|
|
@ -1522,9 +1564,8 @@
|
|||
(set! first-line (mline-first (unbox line-root-box)))
|
||||
(set! last-line (mline-last (unbox line-root-box)))
|
||||
(set! len (+ len addlen))
|
||||
(unless (= (last-position) (+ (mline-get-position last-line)
|
||||
(mline-len last-line)))
|
||||
(error "yuck out"))
|
||||
(assert (= (last-position) (+ (mline-get-position last-line)
|
||||
(mline-len last-line))))
|
||||
(success-finish addlen inserted-line?))
|
||||
(begin
|
||||
(when (equal? (string-ref str sp) #\return)
|
||||
|
|
@ -1603,6 +1644,8 @@
|
|||
(when (has-flag? (snip->flags tabsnip) CAN-SPLIT)
|
||||
(set-snip-flags! tabsnip
|
||||
(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))
|
||||
(set-snip-line! tabsnip (snip->line snip))
|
||||
|
|
@ -1679,6 +1722,7 @@
|
|||
(set! typing-streak? #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?)
|
||||
(let-values ([(start end set-caret-style?)
|
||||
(if (eq? end 'back)
|
||||
|
|
@ -1770,7 +1814,8 @@
|
|||
(set-mline-last-snip! line prev)
|
||||
;; maybe deleted extra ghost line:
|
||||
extra-line?))]
|
||||
[else #f]))])
|
||||
[else
|
||||
#f]))])
|
||||
(delete-snip snip)
|
||||
(loop prev
|
||||
(or deleted-line?
|
||||
|
|
@ -1811,6 +1856,8 @@
|
|||
|
||||
(when (max-width . >= . 0)
|
||||
(mline-mark-check-flow line)
|
||||
(let ([next (mline-next line)])
|
||||
(when next (mline-mark-check-flow next)))
|
||||
(let ([prev (mline-prev line)])
|
||||
(when (and prev
|
||||
(has-flag? (snip->flags (mline-last-snip prev)) HARD-NEWLINE))
|
||||
|
|
@ -1896,7 +1943,8 @@
|
|||
|
||||
(when update-cursor?
|
||||
(when s-admin
|
||||
(send s-admin update-cursor))))))))))))))
|
||||
(send s-admin update-cursor))))))))))))
|
||||
(assert (consistent-snip-lines 'post-do-delete))))
|
||||
|
||||
(define/public (delete . args)
|
||||
(case-args
|
||||
|
|
@ -2213,9 +2261,12 @@
|
|||
(if read-locked?
|
||||
#\nul
|
||||
(let-values ([(snip s-pos) (find-snip/pos (max 0 (min start len)) 'after)])
|
||||
(let ([delta (- start s-pos)])
|
||||
(if (delta . >= . (snip->count snip))
|
||||
#\nul
|
||||
(let ([buffer (make-string 1)])
|
||||
(send snip get-text! buffer (- start s-pos) 1 0)
|
||||
(string-ref buffer 0)))))
|
||||
(send snip get-text! buffer delta 1 0)
|
||||
(string-ref buffer 0)))))))
|
||||
|
||||
;; ----------------------------------------
|
||||
|
||||
|
|
@ -2929,7 +2980,8 @@
|
|||
(let ([dc (send s-admin get-dc)])
|
||||
(let-boxes ([w 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! flow-locked? fl?)
|
||||
|
|
@ -3054,7 +3106,8 @@
|
|||
(let-boxes ([h 0.0]
|
||||
[descent 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)])
|
||||
(cond
|
||||
[(eq? 'bottom align)
|
||||
|
|
@ -3505,6 +3558,7 @@
|
|||
;; ----------------------------------------
|
||||
|
||||
(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?
|
||||
s-user-locked?
|
||||
(and new-style
|
||||
|
|
@ -3631,7 +3685,8 @@
|
|||
(check-merge-snips start)
|
||||
(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]
|
||||
[(make-alts exact-nonnegative-integer? (symbol-in start)) [start 'start]]
|
||||
|
|
@ -4498,6 +4553,8 @@
|
|||
#t))]
|
||||
[(and (c . < . 0) (b . > . startp))
|
||||
;; overflow, but previous wordbreak was before this snip
|
||||
(when had-newline?
|
||||
(set-snip-flags! snip (add-flag (snip->flags snip) NEWLINE)))
|
||||
b]
|
||||
[else
|
||||
;; overflow: we have to break the word anyway
|
||||
|
|
@ -4561,7 +4618,20 @@
|
|||
|
||||
(let ([w (- max-width CURSOR-WIDTH)])
|
||||
(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)
|
||||
|
||||
(begin
|
||||
|
|
|
|||
|
|
@ -41,8 +41,10 @@
|
|||
(define/top (standard-wordbreak [text% win]
|
||||
[(make-or-false (make-box exact-nonnegative-integer?)) startp]
|
||||
[(make-or-false (make-box exact-nonnegative-integer?)) endp]
|
||||
[(symbol-in caret line selection user1 user2)reason])
|
||||
(with-method ([get-map ((send win get-wordbreak-map) get-map)])
|
||||
[(symbol-in caret line selection user1 user2) reason])
|
||||
(let ([wb (send win get-wordbreak-map)])
|
||||
(when wb
|
||||
(with-method ([get-map (wb get-map)])
|
||||
(define (nonbreak? ch) (memq reason (get-map ch)))
|
||||
|
||||
(when startp
|
||||
|
|
@ -150,4 +152,4 @@
|
|||
(send win get-text lstart (+ lstart lend))
|
||||
lend
|
||||
end)
|
||||
(set-box! endp (+ end lstart)))))))))))
|
||||
(set-box! endp (+ end lstart)))))))))))))
|
||||
|
|
|
|||
|
|
@ -73,7 +73,7 @@
|
|||
;; call-with-control, parameterized over whether to keep the
|
||||
;; prompt (if the prompt's handler gives us the option of
|
||||
;; 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)
|
||||
;; Uses call/cc to always keep the enclosing prompt.
|
||||
(letrec ([call-with-control
|
||||
|
|
|
|||
|
|
@ -234,17 +234,23 @@
|
|||
|
||||
|
||||
(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])
|
||||
(syntax-case stx ()
|
||||
((_ export-spec)
|
||||
(let ([sig (process-spec #'export-spec)])
|
||||
(with-syntax ((((int . ext) ...) (car sig))
|
||||
(with-syntax (((sig-elem ...)
|
||||
(build-sig-elems sig))
|
||||
((renames
|
||||
(((mac-name ...) mac-body) ...)
|
||||
(((val-name ...) val-body) ...))
|
||||
(build-val+macro-defs sig)))
|
||||
(syntax->list
|
||||
#'(int ...
|
||||
#'(sig-elem ...
|
||||
(define-syntaxes . renames)
|
||||
(define-syntaxes (mac-name ...) mac-body) ...
|
||||
(define-values (val-name ...) val-body) ...)))))
|
||||
|
|
|
|||
|
|
@ -44,7 +44,7 @@ plotted.
|
|||
]
|
||||
|
||||
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[
|
||||
(plot (line (lambda (x) (sin x)))
|
||||
|
|
|
|||
|
|
@ -1117,7 +1117,7 @@
|
|||
dsc
|
||||
sc))
|
||||
dsc
|
||||
'codom-side-conditions-rewritten
|
||||
`codom-side-conditions-rewritten
|
||||
'name)))
|
||||
(term-define-fn name name2))
|
||||
'disappeared-use
|
||||
|
|
@ -1359,7 +1359,7 @@
|
|||
[(_ name (names rhs ...) ...)
|
||||
(identifier? (syntax name))
|
||||
(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 ([(subst-names ...) (generate-temporaries (syntax->list #'(nt-names ...)))])
|
||||
(syntax/loc stx
|
||||
|
|
@ -1511,7 +1511,7 @@
|
|||
(raise-syntax-error 'define-extended-langauge "expected an identifier" stx #'name))
|
||||
(unless (identifier? (syntax 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)])
|
||||
(with-syntax ([((new-nt-names orig) ...) (append (pull-out-names 'define-language stx #'(names ...))
|
||||
(map (λ (x) #`(#,x #f)) old-names))])
|
||||
|
|
|
|||
|
|
@ -571,6 +571,22 @@
|
|||
(test (term (foo y))
|
||||
(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
|
||||
;; note that caching comes into play here (which is why we don't see the recursive calls)
|
||||
(let ()
|
||||
|
|
|
|||
|
|
@ -68,7 +68,7 @@
|
|||
(if else?
|
||||
(if first?
|
||||
;; 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...
|
||||
(cons (quote-syntax begin) value))
|
||||
(if (stx-null? value)
|
||||
|
|
|
|||
|
|
@ -6,6 +6,14 @@
|
|||
(require (for-syntax scheme/base syntax/boundmap scheme/list syntax/kerncase
|
||||
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
|
||||
(define first-id #f)
|
||||
(define main-id #f)
|
||||
|
|
|
|||
|
|
@ -529,13 +529,15 @@
|
|||
(+ (syntax-column c) delta)))
|
||||
(set! src-col (+ orig-col (syntax-span c)))))]
|
||||
[(graph-reference? (syntax-e c))
|
||||
(advance c init-line!)
|
||||
(out (format "#~a#" (unbox (graph-reference-bx (syntax-e c))))
|
||||
(if (positive? quote-depth)
|
||||
value-color
|
||||
paren-color))]
|
||||
paren-color))
|
||||
(set! src-col (+ src-col (syntax-span c)))]
|
||||
[(graph-defn? (syntax-e c))
|
||||
(advance c init-line!)
|
||||
(let ([bx (graph-defn-bx (syntax-e c))])
|
||||
(set-box! bx 0)
|
||||
(out (format "#~a=" (unbox bx))
|
||||
(if (positive? quote-depth)
|
||||
value-color
|
||||
|
|
@ -723,12 +725,12 @@
|
|||
(define-struct graph-defn (r bx))
|
||||
|
||||
(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?)
|
||||
(and graph?
|
||||
(let ([n (hash-ref ht '#%graph-count 0)])
|
||||
(hash-set! ht '#%graph-count (add1 n))
|
||||
(let ([n (hash-ref (unbox ht) '#%graph-count 0)])
|
||||
(set-box! ht (hash-set (unbox ht) '#%graph-count (add1 n)))
|
||||
n)))
|
||||
|
||||
(define (do-syntax-ize v col line ht graph?)
|
||||
|
|
@ -746,7 +748,7 @@
|
|||
s
|
||||
s
|
||||
(just-context-ctx v)))]
|
||||
[(hash-ref ht v #f)
|
||||
[(hash-ref (unbox ht) v #f)
|
||||
=> (lambda (m)
|
||||
(unless (unbox m)
|
||||
(set-box! m #t))
|
||||
|
|
@ -770,17 +772,18 @@
|
|||
(vector? v)
|
||||
(and (struct? v)
|
||||
(prefab-struct-key v)))
|
||||
(let ([graph-box (box (graph-count ht graph?))])
|
||||
(hash-set! ht v graph-box)
|
||||
(let ([r (let* ([vec-sz (+ (if graph?
|
||||
(let ([orig-ht (unbox ht)]
|
||||
[graph-box (box (graph-count ht graph?))])
|
||||
(set-box! ht (hash-set (unbox ht) v graph-box))
|
||||
(let* ([graph-sz (if graph?
|
||||
(+ 2 (string-length (format "~a" (unbox graph-box))))
|
||||
0)
|
||||
(cond
|
||||
0)]
|
||||
[vec-sz (cond
|
||||
[(vector? v)
|
||||
(+ 1 #;(string-length (format "~a" (vector-length v))))]
|
||||
[(struct? v) 2]
|
||||
[else 0]))])
|
||||
(let ([l (let loop ([col (+ col 1 vec-sz)]
|
||||
[else 0])]
|
||||
[r (let ([l (let loop ([col (+ col 1 vec-sz graph-sz)]
|
||||
[v (cond
|
||||
[(vector? v)
|
||||
(vector->short-list v values)]
|
||||
|
|
@ -799,33 +802,40 @@
|
|||
[(struct? v)
|
||||
(apply make-prefab-struct (prefab-struct-key v) (cdr l))]
|
||||
[else l])
|
||||
(vector #f line col (+ 1 col)
|
||||
(vector #f line
|
||||
(+ graph-sz col)
|
||||
(+ 1 graph-sz col)
|
||||
(+ 2
|
||||
vec-sz
|
||||
(if (zero? (length l))
|
||||
0
|
||||
(sub1 (length l)))
|
||||
(apply + (map syntax-span l)))))))])
|
||||
(apply + (map syntax-span l))))))])
|
||||
(unless graph?
|
||||
(hash-set! ht v #f))
|
||||
(set-box! ht (hash-set (unbox ht) v #f)))
|
||||
(cond
|
||||
[graph? (datum->syntax #f
|
||||
(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)
|
||||
;; Go again, this time knowing that there will be a graph:
|
||||
(set-box! ht orig-ht)
|
||||
(do-syntax-ize v col line ht #t)]
|
||||
[else r])))]
|
||||
[(pair? v)
|
||||
(let ([graph-box (box (graph-count ht graph?))])
|
||||
(hash-set! ht v graph-box)
|
||||
(let ([orig-ht (unbox ht)]
|
||||
[graph-box (box (graph-count ht graph?))])
|
||||
(set-box! ht (hash-set (unbox ht) v graph-box))
|
||||
(let* ([inc (if graph?
|
||||
(+ 2 (string-length (format "~a" (unbox graph-box))))
|
||||
0)]
|
||||
[a (do-syntax-ize (car v) (+ col 1 inc) line ht #f)]
|
||||
[sep (if (and (pair? (cdr v))
|
||||
;; 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
|
||||
3)]
|
||||
[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)
|
||||
(+ 2 sep (syntax-span a) (syntax-span b))))])
|
||||
(unless graph?
|
||||
(hash-set! ht v #f))
|
||||
(set-box! ht (hash-set (unbox ht) v #f)))
|
||||
(cond
|
||||
[graph? (datum->syntax #f
|
||||
(make-graph-defn r graph-box)
|
||||
|
|
@ -842,6 +852,7 @@
|
|||
(+ inc (syntax-span r))))]
|
||||
[(unbox graph-box)
|
||||
;; Go again...
|
||||
(set-box! ht orig-ht)
|
||||
(do-syntax-ize v col line ht #t)]
|
||||
[else r]))))]
|
||||
[(box? v)
|
||||
|
|
|
|||
|
|
@ -734,7 +734,7 @@ See also @method[editor<%> set-load-overwrites-styles].
|
|||
}
|
||||
|
||||
@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
|
||||
@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)
|
||||
(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
|
||||
@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)
|
||||
(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
|
||||
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)
|
||||
(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
|
||||
@scheme['none] indicates that there is no minimum.
|
||||
|
|
@ -945,7 +945,7 @@ inserts the resulting snip into the editor.
|
|||
'text 'text-force-cr) 'guess]
|
||||
[show-errors? any/c #t])
|
||||
boolean?]
|
||||
[(insert-file [port input-port]
|
||||
[(insert-file [port input-port?]
|
||||
[format (one-of/c 'guess 'same 'copy 'standard
|
||||
'text 'text-force-cr) 'guess]
|
||||
[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
|
||||
'text 'text-force-cr) 'guess]
|
||||
[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]
|
||||
[y real? 0.0]
|
||||
[width (or/c (and/c real? (not/c negative?)) (one/of 'end)) 'end]
|
||||
[height (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?)) 'end) 'end])
|
||||
void?]{
|
||||
|
||||
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)]
|
||||
[relative-path? 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]
|
||||
[fit-on-page? any/c #t]
|
||||
[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]
|
||||
[as-eps? any/c #f])
|
||||
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
|
||||
'text 'text-force-cr) 'same]
|
||||
[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?))]{
|
||||
|
||||
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?]{
|
||||
|
||||
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?]{
|
||||
|
||||
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?]{
|
||||
|
||||
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?]{
|
||||
|
||||
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?]{
|
||||
|
||||
Sets the minimum display width for the contents of the editor; zero or
|
||||
|
|
|
|||
|
|
@ -325,13 +325,13 @@ See also @method[text% hide-caret].
|
|||
|
||||
@defmethod*[#:mode extend
|
||||
([(change-style [delta (or/c (is-a?/c style-delta%) #f)]
|
||||
[start (or/c exact-nonnegative-integer? (one/of 'start)) 'start]
|
||||
[end (or/c exact-nonnegative-integer? (one/of 'end)) 'end]
|
||||
[start (or/c exact-nonnegative-integer? 'start) 'start]
|
||||
[end (or/c exact-nonnegative-integer? 'end) 'end]
|
||||
[counts-as-mod? any/c #t])
|
||||
void?]
|
||||
[(change-style [style (or/c (is-a?/c style<%>) #f)]
|
||||
[start (or/c exact-nonnegative-integer? (one/of 'start)) 'start]
|
||||
[end (or/c exact-nonnegative-integer? (one/of 'end)) 'end]
|
||||
[start (or/c exact-nonnegative-integer? 'start) 'start]
|
||||
[end (or/c exact-nonnegative-integer? 'end) 'end]
|
||||
[counts-as-mod? any/c #t])
|
||||
void?])]{
|
||||
|
||||
|
|
@ -352,8 +352,8 @@ When @scheme[style] is provided: @InStyleListNote[@scheme[style]]
|
|||
@defmethod[#:mode extend
|
||||
(copy [extend? any/c #f]
|
||||
[time (and/c exact? integer?) 0]
|
||||
[start (or/c exact-nonnegative-integer? (one/of 'start)) 'start]
|
||||
[end (or/c exact-nonnegative-integer? (one/of 'end)) 'end])
|
||||
[start (or/c exact-nonnegative-integer? 'start) 'start]
|
||||
[end (or/c exact-nonnegative-integer? 'end) 'end])
|
||||
void?]{
|
||||
|
||||
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
|
||||
(cut [extend? any/c #f]
|
||||
[time (and/c exact? integer?) 0]
|
||||
[start (or/c exact-nonnegative-integer? (one/of 'start)) 'start]
|
||||
[end (or/c exact-nonnegative-integer? (one/of 'end)) 'end])
|
||||
[start (or/c exact-nonnegative-integer? 'start) 'start]
|
||||
[end (or/c exact-nonnegative-integer? 'end) 'end])
|
||||
void?]{
|
||||
|
||||
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))]
|
||||
[end (or/c exact-nonnegative-integer? (one/of 'back)) 'back]
|
||||
@defmethod*[([(delete [start (or/c exact-nonnegative-integer? 'start)]
|
||||
[end (or/c exact-nonnegative-integer? 'back) 'back]
|
||||
[scroll-ok? any/c #t])
|
||||
void?]
|
||||
[(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]
|
||||
[start (or/c exact-nonnegative-integer? (one/of 'start)) 'start]
|
||||
[end (or/c exact-nonnegative-integer? (one/of 'eof)) 'eof])
|
||||
[start (or/c exact-nonnegative-integer? 'start) 'start]
|
||||
[end (or/c exact-nonnegative-integer? 'eof) 'eof])
|
||||
(or/c exact-nonnegative-integer? #f)]{
|
||||
|
||||
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?]
|
||||
[direction (one-of/c 'forward 'backward) 'forward]
|
||||
[start (or/c exact-nonnegative-integer? (one/of 'start)) 'start]
|
||||
[end (or/c exact-nonnegative-integer? (one/of 'eof)) 'eof]
|
||||
[start (or/c exact-nonnegative-integer? 'start) 'start]
|
||||
[end (or/c exact-nonnegative-integer? 'eof) 'eof]
|
||||
[get-start? any/c #t]
|
||||
[case-sensitive? any/c #t])
|
||||
(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?]
|
||||
[direction (one-of/c 'forward 'backward) 'forward]
|
||||
[start (or/c exact-nonnegative-integer? (one/of 'start)) 'start]
|
||||
[end (or/c exact-nonnegative-integer? (one/of 'eof)) 'eof]
|
||||
[start (or/c exact-nonnegative-integer? 'start) 'start]
|
||||
[end (or/c exact-nonnegative-integer? 'eof) 'eof]
|
||||
[get-start? any/c #t]
|
||||
[case-sensitive any/c #t])
|
||||
(listof exact-nonnegative-integer?)]{
|
||||
|
|
@ -944,7 +944,7 @@ See also
|
|||
|
||||
|
||||
@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]
|
||||
[force-cr? any/c #f])
|
||||
string?]{
|
||||
|
|
@ -1045,13 +1045,13 @@ See also @method[text% caret-hidden?] and @method[editor<%> lock].
|
|||
@defmethod*[#:mode override
|
||||
([(insert [str string?]
|
||||
[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])
|
||||
void?]
|
||||
[(insert [n exact-nonnegative-integer?]
|
||||
[str string?]
|
||||
[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])
|
||||
void?]
|
||||
[(insert [str string?])
|
||||
|
|
@ -1061,7 +1061,7 @@ See also @method[text% caret-hidden?] and @method[editor<%> lock].
|
|||
void?]
|
||||
[(insert [snip (is-a?/c snip%)]
|
||||
[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])
|
||||
void?]
|
||||
[(insert [snip (is-a?/c snip%)])
|
||||
|
|
@ -1070,7 +1070,7 @@ See also @method[text% caret-hidden?] and @method[editor<%> lock].
|
|||
void?]
|
||||
[(insert [char char?]
|
||||
[start exact-nonnegative-integer?]
|
||||
[end (or/c exact-nonnegative-integer? (one/of 'same)) 'same])
|
||||
[end (or/c exact-nonnegative-integer? 'same) 'same])
|
||||
void?])]{
|
||||
|
||||
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
|
||||
(paste [time (and/c exact? integer?) 0]
|
||||
[start (or/c exact-nonnegative-integer? (one/of 'start 'end)) 'start]
|
||||
[end (or/c exact-nonnegative-integer? (one/of 'same)) 'same])
|
||||
[start (or/c exact-nonnegative-integer? 'start 'end) 'start]
|
||||
[end (or/c exact-nonnegative-integer? 'same) 'same])
|
||||
void?]{
|
||||
|
||||
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
|
||||
(paste-x-selection [time (and/c exact? integer?)]
|
||||
[start (or/c exact-nonnegative-integer? (one/of 'start 'end)) 'start]
|
||||
[end (or/c exact-nonnegative-integer? (one/of 'same)) 'same])
|
||||
[start (or/c exact-nonnegative-integer? 'start 'end) 'start]
|
||||
[end (or/c exact-nonnegative-integer? 'same) 'same])
|
||||
void?]{
|
||||
|
||||
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
|
||||
(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])
|
||||
boolean?]{
|
||||
|
||||
|
|
@ -1719,7 +1719,7 @@ Removes all clickbacks installed for exactly the range @scheme[start]
|
|||
|
||||
@defmethod[(scroll-to-position [start exact-nonnegative-integer?]
|
||||
[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])
|
||||
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?]
|
||||
[end (or/c exact-nonnegative-integer? (one/of 'same)) 'same]
|
||||
[end (or/c exact-nonnegative-integer? 'same) 'same]
|
||||
[at-eol? any/c #f]
|
||||
[scroll? any/c #t]
|
||||
[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)]
|
||||
[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]
|
||||
[scroll? any/c #t]
|
||||
[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
|
||||
(write-to-file [stream (is-a?/c editor-stream-out%)]
|
||||
[start exact-nonnegative-integer? 0]
|
||||
[end (or/c exact-nonnegative-integer? (one/of 'eof)) 'eof])
|
||||
[end (or/c exact-nonnegative-integer? 'eof) 'eof])
|
||||
boolean?]{
|
||||
|
||||
If @scheme[start] is 0 and @scheme[end] is @scheme['eof] negative,
|
||||
|
|
|
|||
|
|
@ -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
|
||||
``character'' in the Unicode standard, but it's an approximation that
|
||||
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
|
||||
character datatype is separate from numbers. The
|
||||
|
|
|
|||
|
|
@ -35,12 +35,12 @@ parentheses for expressions are brown.
|
|||
Many predefined functions operate on lists. Here are a few examples:
|
||||
|
||||
@interaction[
|
||||
(code:line (length (list "a" "b" "c")) (code:comment #, @t{count the elements}))
|
||||
(code:line (list-ref (list "a" "b" "c") 0) (code:comment #, @t{extract by position}))
|
||||
(list-ref (list "a" "b" "c") 1)
|
||||
(code:line (append (list "a" "b") (list "c")) (code:comment #, @t{combine lists}))
|
||||
(code:line (reverse (list "a" "b" "c")) (code:comment #, @t{reverse order}))
|
||||
(code:line (member "d" (list "a" "b" "c")) (code:comment #, @t{check for an element}))
|
||||
(code:line (length (list "hop" "skip" "jump")) (code:comment #, @t{count the elements}))
|
||||
(code:line (list-ref (list "hop" "skip" "jump") 0) (code:comment #, @t{extract by position}))
|
||||
(list-ref (list "hop" "skip" "jump") 1)
|
||||
(code:line (append (list "hop" "skip") (list "jump")) (code:comment #, @t{combine lists}))
|
||||
(code:line (reverse (list "hop" "skip" "jump")) (code:comment #, @t{reverse order}))
|
||||
(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
|
||||
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[
|
||||
(define (my-map f lst)
|
||||
(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
|
||||
iteration form. Otherwise, performance will be bad, and moderately
|
||||
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
|
||||
in constant space.
|
||||
|
||||
|
|
|
|||
|
|
@ -113,7 +113,8 @@ evaluated only for some side-effect, such as printing.
|
|||
(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
|
||||
in a definition body, because it explains why the following
|
||||
@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,
|
||||
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.
|
||||
|
||||
@;- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
|
||||
|
|
|
|||
|
|
@ -121,7 +121,7 @@ expressions, a printed symbol should not be confused with an
|
|||
identifier. In particular, the symbol @scheme[(#, @scheme[quote] #,
|
||||
@schemeidfont{map})] has nothing to do with the @schemeidfont{map}
|
||||
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.
|
||||
|
||||
Indeed, the intrinsic value of a symbol is nothing more than its
|
||||
|
|
|
|||
|
|
@ -58,9 +58,17 @@ provides core support for literate programming.}
|
|||
chunks. Normally, @scheme[id] starts with @litchar{<} and ends with
|
||||
@litchar{>}.
|
||||
|
||||
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.
|
||||
When running a scribble program only the code inside the
|
||||
chunks is run; the rest is ignored.
|
||||
|
||||
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}
|
||||
|
|
|
|||
|
|
@ -35,18 +35,6 @@
|
|||
. -> .
|
||||
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?)])
|
||||
|
||||
; ;; ;;;; ;
|
||||
|
|
@ -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)))
|
||||
|
||||
|
|
@ -1135,12 +1123,13 @@
|
|||
(#%plain-lambda () . rest3)))
|
||||
exp]
|
||||
[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"
|
||||
(syntax->datum exp))
|
||||
(annotate/module-top-level exp)])))
|
||||
|
||||
(define/contract annotate/top-level/acl2
|
||||
#;(define/contract annotate/top-level/acl2
|
||||
(syntax? . -> . syntax?)
|
||||
(lambda (exp)
|
||||
(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))])]))
|
||||
|
||||
; body of local
|
||||
(if input-is-top-level?
|
||||
(let* ([annotated-exp (cond
|
||||
[(and (not (eq? language-level 'testing))
|
||||
;; support for ACL2 is commented out.
|
||||
#;[(and (not (eq? language-level 'testing))
|
||||
(string=? (language-level->name language-level) "ACL2 Beginner (beta 8)"))
|
||||
(annotate/top-level/acl2 main-exp)]
|
||||
[else
|
||||
(annotate/top-level main-exp)])])
|
||||
annotated-exp)
|
||||
(let*-2vals ([(annotated dont-care)
|
||||
(annotate/inner (top-level-rewrite main-exp) 'all #f #f)])
|
||||
annotated)))
|
||||
annotated-exp))
|
||||
|
||||
|
||||
;; !@#$ defs have to appear after annotate/master.
|
||||
(define annotate (annotate/master #t))
|
||||
(define annotate/not-top-level (annotate/master #f))
|
||||
|
|
|
|||
|
|
@ -1,3 +1,5 @@
|
|||
#lang scheme/base
|
||||
|
||||
;step collector state machine (not yet implemented):
|
||||
;
|
||||
; datatype held-type = NO-HELD-STEP | SKIPPED-STEP | HELD(args)
|
||||
|
|
@ -11,7 +13,7 @@
|
|||
; held = NO-HELD-STEP :
|
||||
; first(x) : held := HELD(x)
|
||||
; 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
|
||||
; skipped-second : held := NO-HELD-STEP
|
||||
; I believe this can also arise in unannotated code
|
||||
|
|
@ -35,7 +37,6 @@
|
|||
; double(x) : ERROR
|
||||
; late-let(x) : ERROR
|
||||
|
||||
#lang scheme/base
|
||||
|
||||
(require scheme/contract
|
||||
scheme/match
|
||||
|
|
@ -72,6 +73,12 @@
|
|||
. -> .
|
||||
void?)])
|
||||
|
||||
|
||||
(define-struct posn-info (posn span))
|
||||
|
||||
(provide (struct-out posn-info))
|
||||
|
||||
|
||||
; go starts a stepper instance
|
||||
; see provide stmt for contract
|
||||
(define (go program-expander receive-result render-settings
|
||||
|
|
@ -94,7 +101,7 @@
|
|||
;; the "held" variables are used to store the "before" step.
|
||||
(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)
|
||||
|
||||
|
|
@ -215,7 +222,9 @@
|
|||
mark-list returned-value-list render-settings)
|
||||
#f))
|
||||
(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)
|
||||
(let ([reconstruct
|
||||
|
|
@ -248,7 +257,7 @@
|
|||
(append (reconstruct-all-completed) (reconstruct))
|
||||
'normal
|
||||
#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
|
||||
([(step-kind)
|
||||
(if (and held-step-was-app?
|
||||
|
|
@ -267,8 +276,11 @@
|
|||
|
||||
(send-result
|
||||
(make-before-after-result
|
||||
left-exps right-exps step-kind held-source-pos
|
||||
(syntax-position (mark-source (car mark-list))))))]))]
|
||||
left-exps right-exps step-kind
|
||||
held-posn-info
|
||||
(make-posn-info
|
||||
(syntax-position (mark-source (car mark-list)))
|
||||
(syntax-span (mark-source (car mark-list)))))))]))]
|
||||
|
||||
[(double-break)
|
||||
;; a double-break occurs at the beginning of a let's
|
||||
|
|
@ -284,13 +296,16 @@
|
|||
(maybe-lift (car reconstruct-result) #f))]
|
||||
[right-side (map (lambda (exp) (unwind exp render-settings))
|
||||
(maybe-lift (cadr reconstruct-result) #t))])
|
||||
;; add highlighting code as for other cases...
|
||||
(let ([posn-info (make-posn-info
|
||||
(syntax-position (mark-source (car mark-list)))
|
||||
(syntax-span (mark-source (car mark-list))))])
|
||||
(receive-result
|
||||
(make-before-after-result
|
||||
(append new-finished-list left-side)
|
||||
(append new-finished-list right-side)
|
||||
'normal
|
||||
#f #f)))]
|
||||
posn-info
|
||||
posn-info))))]
|
||||
|
||||
[(expr-finished-break)
|
||||
(unless (not mark-list)
|
||||
|
|
@ -323,13 +338,12 @@
|
|||
(match held-exp-list
|
||||
[(struct no-sexp ())
|
||||
(receive-result (make-error-result message))]
|
||||
[(struct held (exps dc source-pos))
|
||||
[(struct held (exps dc posn-info))
|
||||
(begin
|
||||
(receive-result
|
||||
(make-before-error-result (append held-finished-list exps)
|
||||
message
|
||||
#f
|
||||
source-pos))
|
||||
posn-info))
|
||||
(set! held-exp-list the-no-sexp))]))
|
||||
|
||||
(program-expander
|
||||
|
|
|
|||
|
|
@ -219,7 +219,8 @@
|
|||
(set! stepper-frame
|
||||
(go this
|
||||
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
|
||||
(string-constant stepper-name)
|
||||
(format (string-constant stepper-language-level-message)
|
||||
|
|
|
|||
|
|
@ -27,7 +27,7 @@
|
|||
;; the stored representation of a step
|
||||
(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:
|
||||
(define language-settings (definitions-text->settings (send drscheme-frame get-definitions-text)))
|
||||
|
|
@ -169,8 +169,7 @@
|
|||
|
||||
;; is this step on the selected expression?
|
||||
(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:
|
||||
|
||||
|
|
@ -297,7 +296,7 @@
|
|||
;; counting steps...
|
||||
(define status-text
|
||||
(new text%))
|
||||
(define _1 (send status-text insert ""))
|
||||
(define _2 (send status-text insert ""))
|
||||
|
||||
(define status-canvas
|
||||
(new editor-canvas%
|
||||
|
|
@ -358,7 +357,10 @@
|
|||
(list x:finished-text 'finished-stepping (list))])])
|
||||
(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)
|
||||
(program-expander
|
||||
(lambda args
|
||||
|
|
@ -388,3 +390,42 @@
|
|||
|
||||
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))
|
||||
|
|
@ -341,7 +341,7 @@ Second, some keys have multiple-character string representations. Strings
|
|||
@item{ A @tech{MouseEvent} represents mouse events, e.g., mouse movements
|
||||
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:
|
||||
@itemize[
|
||||
|
|
|
|||
|
|
@ -216,9 +216,9 @@
|
|||
(send text change-style c start end #f)))))
|
||||
|
||||
(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))
|
||||
(newline (current-error-port))
|
||||
#;(newline (current-error-port))
|
||||
|
||||
(let* ((print-string
|
||||
(lambda (m)
|
||||
|
|
|
|||
|
|
@ -2,7 +2,7 @@
|
|||
|
||||
(provide all-contract-tests)
|
||||
|
||||
(require (planet schematics/schemeunit:3)
|
||||
(require schemeunit
|
||||
deinprogramm/contract/contract
|
||||
deinprogramm/contract/contract-syntax)
|
||||
|
||||
|
|
|
|||
|
|
@ -2,7 +2,7 @@
|
|||
|
||||
(provide all-image-tests)
|
||||
|
||||
(require (planet schematics/schemeunit:3)
|
||||
(require schemeunit
|
||||
deinprogramm/image
|
||||
(only-in lang/private/imageeq image=?)
|
||||
mred
|
||||
|
|
@ -154,7 +154,7 @@
|
|||
;; c) has the right name.
|
||||
(define (tp-exn-pred name position)
|
||||
(lambda (exn)
|
||||
(and (tp-exn? exn)
|
||||
(and (exn:fail:contract? exn)
|
||||
(let* ([msg (exn-message exn)]
|
||||
[beg (format "~a:" name)]
|
||||
[len (string-length beg)])
|
||||
|
|
|
|||
|
|
@ -1,6 +1,6 @@
|
|||
#lang scheme/base
|
||||
|
||||
(require (planet schematics/schemeunit:3/text-ui))
|
||||
(require schemeunit/text-ui)
|
||||
(require tests/deinprogramm/contract)
|
||||
|
||||
(run-tests all-contract-tests)
|
||||
|
|
@ -1,6 +1,6 @@
|
|||
#lang scheme/base
|
||||
|
||||
(require (planet schematics/schemeunit:3/text-ui))
|
||||
(require schemeunit/text-ui)
|
||||
(require tests/deinprogramm/image)
|
||||
|
||||
(run-tests all-image-tests)
|
||||
|
|
@ -373,7 +373,7 @@
|
|||
;; checks that the language in the drscheme window is set to the given one.
|
||||
;; clears the definitions, clicks execute and checks the interactions window.
|
||||
(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)]
|
||||
[definitions-canvas (send drs-frame get-definitions-canvas)])
|
||||
(fw:test:new-window definitions-canvas)
|
||||
|
|
|
|||
|
|
@ -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} repl-test-tmp3.ss:1:0: 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"
|
||||
"{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"
|
||||
#rx"{stop-multi.png} {stop-22x22.png} ../../mred/private/snipfile.ss:[0-9]+:[0-9]+: reference to undefined identifier: xx")
|
||||
'definitions
|
||||
#f
|
||||
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: +"
|
||||
"{stop-multi.png} {stop-22x22.png} ../../mred/private/snipfile.ss:246:28: 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: \\+"
|
||||
#rx"{stop-multi.png} {stop-22x22.png} ../../mred/private/snipfile.ss:[0-9]+:[0-9]+: define-values: cannot change constant identifier: \\+")
|
||||
'interactions
|
||||
#f
|
||||
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} repl-test-tmp3.ss:1:7: 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"
|
||||
"{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"
|
||||
#rx"{stop-multi.png} {stop-22x22.png} ../../mred/private/snipfile.ss:[0-9]+:[0-9]+: reference to undefined identifier: xx")
|
||||
'definitions
|
||||
#f
|
||||
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} repl-test-tmp3.ss:2:0: 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"
|
||||
"{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"
|
||||
#rx"{stop-multi.png} {stop-22x22.png} ../../mred/private/snipfile.ss:[0-9]+:[0-9]+: reference to undefined identifier: xx")
|
||||
'definitions
|
||||
#f
|
||||
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} repl-test-tmp3.ss:1:4: 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"
|
||||
"{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"
|
||||
#rx"{stop-multi.png} {stop-22x22.png} ../../mred/private/snipfile.ss:[0-9]+:[0-9]+: reference to undefined identifier: x")
|
||||
'definitions
|
||||
#f
|
||||
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} repl-test-tmp3.ss:1:0: 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>"
|
||||
"{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>"
|
||||
#rx"{stop-multi.png} {stop-22x22.png} ../../mred/private/snipfile.ss:[0-9]+:[0-9]+: expt: expected argument of type <number>; given #<void>")
|
||||
'definitions
|
||||
#f
|
||||
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} repl-test-tmp3.ss:1:4: reference 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"
|
||||
"{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"
|
||||
#rx"{stop-multi.png} {stop-22x22.png} ../../mred/private/snipfile.ss:[0-9]+:[0-9]+: reference to undefined identifier: x")
|
||||
'definitions
|
||||
#f
|
||||
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} repl-test-tmp3.ss:5:19: 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"
|
||||
"{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"
|
||||
#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
|
||||
#f
|
||||
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} repl-test-tmp3.ss:6:15: 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"
|
||||
"{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"
|
||||
#rx"{stop-multi.png} {stop-22x22.png} ../../mred/private/snipfile.ss:[0-9]+:[0-9]+: expt: expected argument of type <number>; given #f")
|
||||
'definitions
|
||||
#f
|
||||
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} repl-test-tmp3.ss:3:13: 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"
|
||||
"{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"
|
||||
#rx"{stop-multi.png} {stop-22x22.png} ../../mred/private/snipfile.ss:246:28: procedure application: expected procedure, given: 3; arguments were: 3")
|
||||
'definitions
|
||||
#f
|
||||
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} repl-test-tmp3.ss:1:0: 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"
|
||||
"{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"
|
||||
#rx"{stop-multi.png} {stop-22x22.png} ../../mred/private/snipfile.ss:[0-9]+:[0-9]+: reference to undefined identifier: xx")
|
||||
'definitions
|
||||
#f
|
||||
void
|
||||
|
|
|
|||
|
|
@ -297,6 +297,7 @@
|
|||
(and win
|
||||
(string=? (send win get-label) ,name)))])
|
||||
(if eventspace
|
||||
(wait-for
|
||||
`(parameterize ([current-eventspace ,eventspace])
|
||||
,exp)
|
||||
,exp))
|
||||
(wait-for exp))))
|
||||
|
|
|
|||
|
|
@ -38,9 +38,9 @@
|
|||
(test-base base:if #f)
|
||||
|
||||
;; Other Scheme/* forms
|
||||
(test-base scheme:match #t)
|
||||
(test-base scheme:match #f)
|
||||
(test-base scheme:unit #t)
|
||||
(test-base scheme:class #t)
|
||||
(test-base scheme:class #f)
|
||||
|
||||
;; Unbound names
|
||||
(test-base no-such-name #t)
|
||||
|
|
|
|||
169
collects/tests/mred/wxme-doc-random.ss
Normal file
169
collects/tests/mred/wxme-doc-random.ss
Normal 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
113
collects/tests/mred/wxme-random.ss
Normal 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)))
|
||||
|
|
@ -606,15 +606,16 @@
|
|||
|
||||
(for-each
|
||||
(lambda (str)
|
||||
;; (printf ">> ~a <<\n" str)
|
||||
;; (printf ">> ~s <<\n" str)
|
||||
(for ([i (in-range (add1 (send t last-position)))])
|
||||
;; (printf "~a\n" i)
|
||||
(check-line-starts)
|
||||
(send t insert str i)
|
||||
(check-line-starts)
|
||||
;; (printf "=> ~a ~s\n" i (send t get-text 0 'eof #t #t))
|
||||
(send t last-line)
|
||||
(send t delete i (+ i (string-length str)))
|
||||
(check-line-starts)
|
||||
;; (printf "~a ~s <=\n" i (send t get-text 0 'eof #t #t))
|
||||
(check-ge&h-flow)))
|
||||
'(" a" "a " "qvzxw " " qvxzw" "qqq qqqq" "a\nb"))
|
||||
|
||||
|
|
|
|||
|
|
@ -2060,6 +2060,10 @@
|
|||
(test #t symbol? '1+ei)
|
||||
(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 number->string 1 2)
|
||||
|
||||
|
|
|
|||
|
|
@ -105,7 +105,7 @@
|
|||
(5000.0 "1#/2#e4")
|
||||
(500000000.0 "1/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")
|
||||
(D "D")
|
||||
|
|
|
|||
|
|
@ -106,6 +106,16 @@
|
|||
"add06.ss - send/suspend/dispatch"
|
||||
(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
|
||||
(test-double-counters
|
||||
mkd
|
||||
|
|
@ -153,3 +163,8 @@
|
|||
|
||||
; XXX test web-extras.ss - redirect/get
|
||||
))
|
||||
|
||||
#|
|
||||
(require schemeunit/text-ui)
|
||||
(run-tests dispatch-lang-tests)
|
||||
|#
|
||||
|
|
@ -169,8 +169,8 @@
|
|||
(lambda ()
|
||||
(let/ec esc
|
||||
('f1 (with-continuation-mark the-cont-key +
|
||||
(esc (activation-record-list)))))))
|
||||
(list (vector + #f))))
|
||||
(esc (reverse (activation-record-list))))))))
|
||||
(list (vector + #f #f))))
|
||||
|
||||
(test-case
|
||||
"Double"
|
||||
|
|
@ -179,10 +179,10 @@
|
|||
(let/ec esc
|
||||
('f1 (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
|
||||
(list (vector + #f)
|
||||
(vector - #f))))
|
||||
(list (vector + #f #f)
|
||||
(vector - #f #f))))
|
||||
|
||||
(test-case
|
||||
"Unsafe"
|
||||
|
|
@ -216,21 +216,21 @@
|
|||
(check-equal? (resume empty (list 42))
|
||||
42))
|
||||
|
||||
(test-case
|
||||
#;(test-case
|
||||
"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
|
||||
"Kont"
|
||||
(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))))
|
||||
|
||||
(test-case
|
||||
"Kont 2"
|
||||
(let ([f (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)))))
|
||||
|
||||
(test-case
|
||||
|
|
@ -238,16 +238,17 @@
|
|||
(let ([f (lambda (x) (* x x))]
|
||||
[g (lambda (x) (+ x x))]
|
||||
[esc-b (box #f)]
|
||||
[capture (lambda _ (activation-record-list))])
|
||||
[capture (lambda _ (reverse (activation-record-list)))])
|
||||
(check-equal? (call-with-web-prompt
|
||||
(lambda ()
|
||||
(let/ec esc
|
||||
(set-box! esc-b esc)
|
||||
(resume (list (vector f #f) (vector g #f)
|
||||
(vector esc #f) (vector capture #f))
|
||||
(resume (reverse
|
||||
(list (vector f #f #f) (vector g #f #f)
|
||||
(vector esc #f #f) (vector capture #f #f)))
|
||||
(list 42)))))
|
||||
(list (vector f #f) (vector g #f)
|
||||
(vector (unbox esc-b) #f)))))
|
||||
(list (vector f #f #f) (vector g #f #f)
|
||||
(vector (unbox esc-b) #f #f)))))
|
||||
|
||||
(test-case
|
||||
"marks"
|
||||
|
|
@ -256,14 +257,16 @@
|
|||
(check-equal? (call-with-web-prompt
|
||||
(lambda ()
|
||||
(let/ec esc
|
||||
(resume (list (vector f (make-immutable-hash (list (cons 3 4) (cons 1 2))))
|
||||
(vector g (make-immutable-hash (list (cons 5 6))))
|
||||
(vector esc (make-immutable-hash (list (cons 7 8))))
|
||||
(resume (reverse
|
||||
(list (vector f (make-immutable-hash (list (cons 3 4) (cons 1 2))) #f)
|
||||
(vector g (make-immutable-hash (list (cons 5 6))) #f)
|
||||
(vector esc (make-immutable-hash (list (cons 7 8))) #f)
|
||||
(vector (lambda _
|
||||
(continuation-mark-set->list*
|
||||
(current-continuation-marks)
|
||||
(list 1 3 5 7)))
|
||||
#f))
|
||||
#f
|
||||
#f)))
|
||||
(list 42)))))
|
||||
(list (vector #f #f #f 8)
|
||||
(vector #f #f 6 #f)
|
||||
|
|
@ -279,14 +282,16 @@
|
|||
(lambda ()
|
||||
(let/ec esc
|
||||
(set-box! esc-b esc)
|
||||
(resume (list (vector f (make-immutable-hash (list (cons 3 4) (cons 1 2))))
|
||||
(vector g (make-immutable-hash (list (cons 5 6))))
|
||||
(vector esc (make-immutable-hash (list (cons 7 8))))
|
||||
(vector capture #f))
|
||||
(resume (reverse
|
||||
(list (vector f (make-immutable-hash (list (cons 3 4) (cons 1 2))) #f)
|
||||
(vector g (make-immutable-hash (list (cons 5 6))) #f)
|
||||
(vector esc (make-immutable-hash (list (cons 7 8))) #f)
|
||||
(vector capture #f #f)))
|
||||
(list 42)))))
|
||||
(list (vector f (make-immutable-hash (list (cons 3 4) (cons 1 2))))
|
||||
(vector g (make-immutable-hash (list (cons 5 6))))
|
||||
(vector (unbox esc-b) (make-immutable-hash (list (cons 7 8)))))))))
|
||||
(reverse
|
||||
(list (vector f (make-immutable-hash (list (cons 3 4) (cons 1 2))) #f)
|
||||
(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
|
||||
|
||||
|
|
@ -299,3 +304,8 @@
|
|||
; XXX test dispatch
|
||||
|
||||
))
|
||||
|
||||
#|
|
||||
(require schemeunit/text-ui)
|
||||
(run-tests abort-resume-tests)
|
||||
|#
|
||||
|
|
@ -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")))))))
|
||||
|
|
@ -11,7 +11,7 @@
|
|||
(send/suspend/url
|
||||
(lambda (k-url)
|
||||
(printf "ssu ~S~n" (msg))
|
||||
`(hmtl (head (title ,(format "Get ~a number" (msg))))
|
||||
`(html (head (title ,(format "Get ~a number" (msg))))
|
||||
(body
|
||||
(form ([action ,(url->string k-url)]
|
||||
[method "post"]
|
||||
|
|
|
|||
|
|
@ -11,7 +11,7 @@
|
|||
(send/suspend/url
|
||||
(lambda (k-url)
|
||||
(printf "ssu ~S~n" (msg))
|
||||
`(hmtl (head (title ,(format "Get ~a number" (msg))))
|
||||
`(html (head (title ,(format "Get ~a number" (msg))))
|
||||
(body
|
||||
(form ([action ,(url->string k-url)]
|
||||
[method "post"]
|
||||
|
|
|
|||
|
|
@ -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")))))))
|
||||
|
|
@ -12,7 +12,7 @@
|
|||
(send/suspend/url
|
||||
(lambda (k-url)
|
||||
(printf "ssu~n")
|
||||
`(hmtl (head (title ,(format "Get ~a number" msg)))
|
||||
`(html (head (title ,(format "Get ~a number" msg)))
|
||||
(body
|
||||
(form ([action ,(url->string k-url)]
|
||||
[method "post"]
|
||||
|
|
|
|||
|
|
@ -8,7 +8,7 @@
|
|||
(let ([req
|
||||
(send/suspend/url
|
||||
(lambda (k-url)
|
||||
`(hmtl (head (title ,(format "Get ~a number" msg)))
|
||||
`(html (head (title ,(format "Get ~a number" msg)))
|
||||
(body
|
||||
(form ([action ,(url->string k-url)]
|
||||
[method "get"]
|
||||
|
|
|
|||
|
|
@ -8,7 +8,7 @@
|
|||
(let ([req
|
||||
(send/suspend/hidden
|
||||
(lambda (ses-url k-hidden)
|
||||
`(hmtl (head (title ,(format "Get ~a number" msg)))
|
||||
`(html (head (title ,(format "Get ~a number" msg)))
|
||||
(body
|
||||
(form ([action ,(url->string ses-url)]
|
||||
[method "post"]
|
||||
|
|
|
|||
|
|
@ -12,7 +12,7 @@
|
|||
(let ([req
|
||||
(send/suspend/url
|
||||
(lambda (k-url)
|
||||
`(hmtl (head (title ,(format "Get ~a number" msg)))
|
||||
`(html (head (title ,(format "Get ~a number" msg)))
|
||||
(body
|
||||
(form ([action ,(url->string k-url)]
|
||||
[method "post"]
|
||||
|
|
|
|||
|
|
@ -8,7 +8,7 @@
|
|||
(let ([req
|
||||
(send/suspend/url
|
||||
(lambda (k-url)
|
||||
`(hmtl (head (title ,(format "Get ~a number" msg)))
|
||||
`(html (head (title ,(format "Get ~a number" msg)))
|
||||
(body
|
||||
(form ([action ,(url->string k-url)]
|
||||
[method "post"]
|
||||
|
|
|
|||
|
|
@ -7,7 +7,7 @@
|
|||
(define (gn msg)
|
||||
(send/suspend/url/dispatch
|
||||
(lambda (embed/url)
|
||||
`(hmtl (head (title ,(format "Get ~a number" msg)))
|
||||
`(html (head (title ,(format "Get ~a number" msg)))
|
||||
(body
|
||||
(form ([action ,(url->string
|
||||
(embed/url
|
||||
|
|
|
|||
|
|
@ -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)))))))))))
|
||||
|
|
@ -24,7 +24,7 @@
|
|||
;; generate the page for the question
|
||||
(define (make-cue-page mc-q)
|
||||
(lambda (ses-url k-hidden)
|
||||
`(hmtl (head (title "Question"))
|
||||
`(html (head (title "Question"))
|
||||
(body
|
||||
(form ([action ,(url->string ses-url)] [method "post"]
|
||||
[enctype "application/x-www-form-urlencoded"])
|
||||
|
|
|
|||
|
|
@ -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")))))))
|
||||
|
|
@ -1,7 +1,9 @@
|
|||
#lang scheme
|
||||
(require scheme/serialize
|
||||
"../private/define-closure.ss"
|
||||
"../lang/web-cells.ss")
|
||||
web-server/private/servlet
|
||||
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 web-prompt (make-continuation-prompt-tag 'web))
|
||||
|
||||
(define empty-hash
|
||||
(make-immutable-hash empty))
|
||||
(define (with-current-saved-continuation-marks-and key val thnk)
|
||||
(call-with-immediate-continuation-mark
|
||||
the-save-cm-key
|
||||
|
|
@ -19,27 +23,34 @@
|
|||
(with-continuation-mark the-save-cm-key
|
||||
(hash-set old-cms key val)
|
||||
(thnk)))
|
||||
(make-immutable-hash empty)))
|
||||
empty-hash))
|
||||
|
||||
;; current-continuation-as-list: -> (listof value)
|
||||
;; check the safety marks and return the list of marks representing the continuation
|
||||
(define (activation-record-list)
|
||||
(let* ([cm (current-continuation-marks web-prompt)]
|
||||
[sl (continuation-mark-set->list cm safe-call?)])
|
||||
(if (andmap (lambda (x)
|
||||
(if (pair? x)
|
||||
(car x)
|
||||
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))))
|
||||
; XXX call this once with a non-#f default
|
||||
[sl (continuation-mark-set->list* cm (list safe-call? continuation-of-unsafe-part-mark))])
|
||||
(if (calling-context-okay? sl #f)
|
||||
(store-unsafe-parts-on-server! (continuation-mark-set->list* cm (list the-cont-key the-save-cm-key continuation-of-unsafe-part-mark)))
|
||||
(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
|
||||
;; erase the stack and apply a thunk
|
||||
(define (abort thunk)
|
||||
#;(printf "abort ~S~n" thunk)
|
||||
(abort-current-continuation web-prompt thunk))
|
||||
|
||||
;; with-continuation-marks : (listof (cons any1 any2)) (-> any3) -> any3
|
||||
|
|
@ -55,25 +66,43 @@
|
|||
(hash-map cms cons)
|
||||
thnk))
|
||||
|
||||
;; resume: (listof (value -> value)) value -> value
|
||||
;; resume*: (listof (value -> value)) value -> value
|
||||
;; 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))
|
||||
(match frames
|
||||
[(list)
|
||||
#;(printf "Returning value ~S~n" val)
|
||||
(apply values val)]
|
||||
[(list-rest f fs)
|
||||
(match f
|
||||
[(vector #f #f)
|
||||
(error 'resume "Empty frame")]
|
||||
[(vector f #f)
|
||||
(call-with-values (lambda () (with-continuation-mark the-cont-key f (resume fs val)))
|
||||
[(list-rest frame fs)
|
||||
#;(printf "Frame ~S~n" frame)
|
||||
(match frame
|
||||
[(vector #f #f #f)
|
||||
; XXX Perhaps I should err?
|
||||
#;(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)]
|
||||
[(vector #f cms)
|
||||
[(vector #f cms #f)
|
||||
(with-continuation-mark the-save-cm-key cms
|
||||
(with-continuation-marks/hash cms (lambda () (resume fs val))))]
|
||||
[(vector f cms)
|
||||
(resume (list* (vector f #f) (vector #f cms) fs) val)])]))
|
||||
(with-continuation-marks/hash cms (lambda () (resume* fs val))))]
|
||||
[(vector #f #f nkpt-label)
|
||||
(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
|
||||
(define (rebuild-cms frames thunk)
|
||||
|
|
@ -81,11 +110,11 @@
|
|||
(match frames
|
||||
[(list)
|
||||
(thunk)]
|
||||
[(list-rest f fs)
|
||||
(match f
|
||||
[(vector f #f)
|
||||
[(list-rest frame fs)
|
||||
(match (vector-ref frame 1)
|
||||
[#f
|
||||
(rebuild-cms fs thunk)]
|
||||
[(vector f cms)
|
||||
[cms
|
||||
(with-continuation-marks/hash cms (lambda () (rebuild-cms fs thunk)))])]))
|
||||
|
||||
(define (call-with-web-prompt thunk)
|
||||
|
|
@ -111,20 +140,54 @@
|
|||
(define-values (wcs current-marks) ((kont-env k)))
|
||||
(make-kont
|
||||
(lambda ()
|
||||
(values wcs
|
||||
(append current-marks (list (vector f #f)))))))
|
||||
(values wcs (list* (vector f #f #f) current-marks)))))
|
||||
|
||||
;; send/suspend: (continuation -> response) -> request
|
||||
;; produce the current response and wait for the next request
|
||||
(define (call-with-serializable-current-continuation response-maker)
|
||||
(with-continuation-mark safe-call? '(#t send/suspend)
|
||||
(let ([current-marks (activation-record-list)]
|
||||
[wcs (capture-web-cell-set)])
|
||||
((lambda (k)
|
||||
(let* ([current-marks (activation-record-list)]
|
||||
[wcs (capture-web-cell-set)]
|
||||
[k (make-kont (lambda () (values wcs current-marks)))])
|
||||
(abort (lambda ()
|
||||
; 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))))))
|
||||
(make-kont (lambda () (values wcs current-marks)))))))
|
||||
(rebuild-cms (reverse current-marks) (lambda () (response-maker k))))))))
|
||||
|
||||
;; 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?
|
||||
(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
|
||||
;; AUXILLIARIES
|
||||
|
|
@ -189,4 +253,6 @@
|
|||
(provide
|
||||
;; "SERVLET" INTERFACE
|
||||
; A contract would interfere with the safe-call? key
|
||||
native->serial
|
||||
serial->native
|
||||
call-with-serializable-current-continuation)
|
||||
|
|
|
|||
|
|
@ -88,6 +88,7 @@
|
|||
(#,cm)
|
||||
(#%plain-lambda #,x
|
||||
(#%plain-app abort
|
||||
; XXX Do I need to rebuild the CMs?
|
||||
(#%plain-lambda () (#%plain-app resume #,ref-to-cm #,ref-to-x)))))
|
||||
(#%plain-app activation-record-list))))))]
|
||||
[(#%plain-app call-with-values (#%plain-lambda () prod) cons)
|
||||
|
|
|
|||
|
|
@ -6,9 +6,11 @@
|
|||
web-server/stuffers
|
||||
web-server/lang/abort-resume
|
||||
web-server/lang/web
|
||||
web-server/lang/native
|
||||
web-server/lang/web-cells
|
||||
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)
|
||||
(all-from-out net/url
|
||||
web-server/http
|
||||
|
|
@ -17,6 +19,8 @@
|
|||
web-server/stuffers
|
||||
web-server/lang/abort-resume
|
||||
web-server/lang/web
|
||||
web-server/lang/native
|
||||
web-server/lang/web-cells
|
||||
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
25
collects/web-server/lang/native.ss
Normal 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
36
collects/web-server/lang/soft.ss
Normal 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)])
|
||||
|
|
@ -81,25 +81,23 @@
|
|||
(lambda (k-url)
|
||||
(page-maker (url->string k-url)))))
|
||||
|
||||
(define-closure embed/url (proc) (k)
|
||||
(define-closure embed/url (proc) (k string?)
|
||||
(let ([url
|
||||
(stuff-url (stateless-servlet-stuffer (current-servlet))
|
||||
(request-uri (execution-context-request (current-execution-context)))
|
||||
(kont-append-fun k proc)))
|
||||
(kont-append-fun k proc))])
|
||||
(if string?
|
||||
(url->string url)
|
||||
url)))
|
||||
|
||||
(define (send/suspend/url/dispatch response-generator)
|
||||
(call-with-serializable-current-continuation
|
||||
(lambda (k)
|
||||
(response-generator (make-embed/url (lambda () k))))))
|
||||
|
||||
; 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))))
|
||||
(response-generator (make-embed/url (lambda () (values k #f)))))))
|
||||
(define (send/suspend/dispatch response-generator)
|
||||
(call-with-serializable-current-continuation
|
||||
(lambda (k)
|
||||
(response-generator (make-embed (lambda () k))))))
|
||||
(response-generator (make-embed/url (lambda () (values k #t)))))))
|
||||
|
||||
;; request->continuation: req -> continuation
|
||||
;; decode the continuation from the hidden field of a request
|
||||
|
|
|
|||
|
|
@ -2,6 +2,7 @@
|
|||
|
||||
(define interface-version #f)
|
||||
(define stuffer #f)
|
||||
(define manager #f)
|
||||
(define start #f)
|
||||
|
||||
(provide (all-defined-out))
|
||||
|
|
|
|||
|
|
@ -11,8 +11,10 @@ A stateless servlet should @scheme[provide] the following exports:
|
|||
|
||||
@(require (for-label web-server/http
|
||||
scheme/serialize
|
||||
web-server/stuffers
|
||||
(except-in "dummy-stateless-servlet.ss" stuffer))) @; to give a binding context
|
||||
(except-in web-server/stuffers stuffer)
|
||||
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)]
|
||||
|
||||
@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?)]{
|
||||
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].
|
||||
}
|
||||
|
||||
@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?])
|
||||
response/c]{
|
||||
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:
|
||||
@schememod[
|
||||
web-server
|
||||
(provide interface-version stuffer start)
|
||||
(define interface-version 'stateless)
|
||||
(define stuffer
|
||||
(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],
|
||||
@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/web-cells], @schememodname[web-server/lang/file-box], @schememodname[web-server/dispatch], and
|
||||
@schememodname[web-server/lang/abort-resume], @schememodname[web-server/lang/web], @schememodname[web-server/lang/native],
|
||||
@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].
|
||||
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-web-cells.scrbl"]
|
||||
@include-section["file-box.scrbl"]
|
||||
@include-section["web-param.scrbl"]
|
||||
@include-section["soft.scrbl"]
|
||||
@include-section["stuffers.scrbl"]
|
||||
@include-section["stateless-usage.scrbl"]
|
||||
|
|
@ -5,25 +5,10 @@
|
|||
|
||||
@(require (for-label net/url
|
||||
xml
|
||||
scheme/serialize
|
||||
web-server/servlet/servlet-structs
|
||||
web-server/lang/web
|
||||
scheme
|
||||
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]{
|
||||
|
||||
@defproc[(send/suspend/url [response-generator (url? . -> . response/c)])
|
||||
|
|
|
|||
36
collects/web-server/scribblings/native.scrbl
Normal file
36
collects/web-server/scribblings/native.scrbl
Normal 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
57
collects/web-server/scribblings/serial.scrbl
Normal 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].
|
||||
}
|
||||
|
||||
}
|
||||
|
|
@ -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?]
|
||||
[stuffer (stuffer/c serializable? bytes?)]
|
||||
[manager manager?]
|
||||
[start (request? . -> . response/c)])
|
||||
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?)]{
|
||||
|
|
|
|||
|
|
@ -33,6 +33,7 @@ An example version 2 module:
|
|||
@schememod[
|
||||
scheme
|
||||
(require web-server/managers/none)
|
||||
(provide interface-version manager start)
|
||||
|
||||
(define interface-version 'v2)
|
||||
(define manager
|
||||
|
|
|
|||
71
collects/web-server/scribblings/soft.scrbl
Normal file
71
collects/web-server/scribblings/soft.scrbl
Normal 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
|
||||
}
|
||||
|
||||
}
|
||||
|
|
@ -1,22 +1,25 @@
|
|||
#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}
|
||||
|
||||
A servlet has the following process performed on it automatically:
|
||||
A stateless servlet has the following process performed on it automatically:
|
||||
@itemize[
|
||||
@item{All uses of @scheme[letrec] are removed and replaced with equivalent uses of
|
||||
@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.}
|
||||
@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
|
||||
they are the continuation of.}
|
||||
@item{All calls to external modules are identified and marked.}
|
||||
@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
|
||||
anonymous lambda.}
|
||||
@scheme[lambda].}
|
||||
]
|
||||
|
||||
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
|
||||
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
|
||||
are some considerations you must make.
|
||||
|
||||
First, this process drastically changes the structure of your program. It
|
||||
will create an immense number of lambdas and structures your program
|
||||
did not normally contain. The performance implication of this has not been
|
||||
studied with PLT Scheme. However, it is theoretically a benefit. The main
|
||||
implications would be due to optimizations MzScheme attempts to perform
|
||||
that will no longer apply. Ideally, your program should be optimized first.
|
||||
studied with PLT Scheme.
|
||||
|
||||
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,
|
||||
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
|
||||
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.
|
||||
|
||||
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:
|
||||
@schemeblock[
|
||||
(define requests
|
||||
|
|
@ -55,12 +58,22 @@ be in the context of another module. For example, the following will not work:
|
|||
response-generators))
|
||||
]
|
||||
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
|
||||
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
|
||||
@href-link["http://www.cs.brown.edu/~sk/Publications/Papers/Published/pcmkf-cont-from-gen-stack-insp/" "Continuations from Generalized Stack Inspection"].
|
||||
This process is derived from the ICFP papers
|
||||
@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.
|
||||
|
|
|
|||
|
|
@ -49,22 +49,22 @@ You can supply your own (built with these functions) when you write a stateless
|
|||
The identitiy @tech{stuffer}.
|
||||
}
|
||||
|
||||
@defproc[(stuffer-compose [g (stuffer any/c any/c)]
|
||||
[f (stuffer any/c any/c)])
|
||||
(stuffer any/c any/c)]{
|
||||
@defproc[(stuffer-compose [g (stuffer/c any/c any/c)]
|
||||
[f (stuffer/c 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]
|
||||
and @scheme[g] then @scheme[f] for @scheme[out].
|
||||
}
|
||||
|
||||
@defproc[(stuffer-sequence [f (stuffer any/c any/c)]
|
||||
[g (stuffer any/c any/c)])
|
||||
(stuffer any/c any/c)]{
|
||||
@defproc[(stuffer-sequence [f (stuffer/c any/c any/c)]
|
||||
[g (stuffer/c any/c any/c)])
|
||||
(stuffer/c any/c any/c)]{
|
||||
@scheme[stuffer-compose] with arguments swapped.
|
||||
}
|
||||
|
||||
@defproc[(stuffer-if [c (bytes? . -> . boolean?)]
|
||||
[f (stuffer bytes? bytes?)])
|
||||
(stuffer bytes? bytes?)]{
|
||||
[f (stuffer/c bytes? bytes?)])
|
||||
(stuffer/c bytes? bytes?)]{
|
||||
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
|
||||
@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}
|
||||
|
|
@ -201,7 +201,7 @@ The @schememodname[web-server/stuffers/hash] @tech{stuffers} rely on a key/value
|
|||
@defproc[(is-url-too-big? [v bytes?])
|
||||
boolean?]{
|
||||
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?])
|
||||
|
|
|
|||
|
|
@ -2,7 +2,8 @@
|
|||
@(require "web-server.ss")
|
||||
|
||||
@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
|
||||
@schememodname[web-server/servlet/web-cells] library provides the
|
||||
|
|
|
|||
|
|
@ -67,15 +67,18 @@
|
|||
(parameterize ([current-servlet-instance-id instance-id])
|
||||
(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
|
||||
(make-stateless-servlet
|
||||
(current-custodian) (current-namespace)
|
||||
(create-none-manager (lambda (req) (error "No continuations!")))
|
||||
manager
|
||||
directory
|
||||
(lambda (req) (error "Session not initialized"))
|
||||
stuffer))
|
||||
(parameterize ([current-directory directory]
|
||||
[current-servlet-instance-id instance-id]
|
||||
[current-servlet ses])
|
||||
(set-servlet-handler! ses (initialize-servlet start)))
|
||||
ses)
|
||||
|
|
@ -110,7 +113,7 @@
|
|||
(provide/contract
|
||||
[make-v1.servlet (path-string? integer? (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?))])
|
||||
|
||||
(define (make-default-path->servlet #:make-servlet-namespace [make-servlet-namespace (make-make-servlet-namespace)]
|
||||
|
|
@ -163,11 +166,16 @@
|
|||
(dynamic-require module-name 'start)
|
||||
pos-blame neg-blame
|
||||
(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?)
|
||||
(dynamic-require module-name 'stuffer (lambda () default-stuffer))
|
||||
pos-blame neg-blame
|
||||
(mk-loc "stuffer"))])
|
||||
(make-stateless.servlet (directory-part a-path) stuffer start))]))]
|
||||
(make-stateless.servlet (directory-part a-path) stuffer manager start))]))]
|
||||
[else
|
||||
(make-v1.servlet (directory-part a-path) timeouts-default-servlet
|
||||
(v0.response->v1.lambda
|
||||
|
|
|
|||
|
|
@ -12,13 +12,16 @@
|
|||
(unsafe!)
|
||||
|
||||
(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
|
||||
(and libcrypto
|
||||
(get-ffi-obj 'EVP_sha1 libcrypto
|
||||
(_fun f-> _fpointer)))
|
||||
(_fun f-> _fpointer))))
|
||||
|
||||
(define HMAC-SHA1/raw
|
||||
(if libcrypto
|
||||
(get-ffi-obj 'HMAC libcrypto
|
||||
(_fun [EVP_MD : _fpointer = (EVP_SHA1)]
|
||||
[key : _bytes]
|
||||
|
|
@ -28,7 +31,8 @@
|
|||
[md : _int = 0]
|
||||
[md_len : _int = 0]
|
||||
f->
|
||||
_pointer)))
|
||||
_pointer))
|
||||
(lambda (key data) (error 'HMAC-SHA1/raw "libcrypto could not load"))))
|
||||
|
||||
(define (HMAC-SHA1 key data)
|
||||
; It returns the same pointer always
|
||||
|
|
|
|||
|
|
@ -1,3 +1,9 @@
|
|||
------------------------------
|
||||
Version 4.2
|
||||
------------------------------
|
||||
|
||||
. Minor bug fixes
|
||||
|
||||
------------------------------
|
||||
Version 4.1.5
|
||||
------------------------------
|
||||
|
|
|
|||
|
|
@ -1,3 +1,7 @@
|
|||
v4.2
|
||||
|
||||
* minor bug fixes
|
||||
|
||||
v4.1.5
|
||||
|
||||
* renamed test--> to test-->>
|
||||
|
|
|
|||
|
|
@ -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]
|
||||
|
||||
|
|
|
|||
17
src/configure
vendored
17
src/configure
vendored
|
|
@ -1368,6 +1368,7 @@ Optional Features:
|
|||
--enable-xonx compile X11 (not Quartz) MrEd for Mac OS X
|
||||
--enable-libfw 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:
|
||||
--with-PACKAGE[=ARG] use PACKAGE [ARG=yes]
|
||||
|
|
@ -2011,6 +2012,11 @@ if test "${enable_libfw+set}" = set; then
|
|||
enableval=$enable_libfw;
|
||||
fi
|
||||
|
||||
# Check whether --enable-macprefix was given.
|
||||
if test "${enable_macprefix+set}" = set; then
|
||||
enableval=$enable_macprefix;
|
||||
fi
|
||||
|
||||
|
||||
|
||||
###### Get OS Type #######
|
||||
|
|
@ -2071,6 +2077,17 @@ else
|
|||
if test "$OS" = "Darwin" ; then
|
||||
enable_quartz=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
|
||||
|
||||
|
|
|
|||
|
|
@ -174,17 +174,17 @@ mred.@LTO@ : $(srcdir)/mred.cxx \
|
|||
$(srcdir)/../mzscheme/include/scheme.h \
|
||||
$(srcdir)/wxs/wxsmred.h $(WXINCDEP) $(srcdir)/../wxcommon/wxGC.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`"'"'
|
||||
|
||||
mrmain.@LTO@ : $(srcdir)/mrmain.cxx $(srcdir)/mred.h $(srcdir)/wxs/wxsmred.h \
|
||||
$(srcdir)/../mzscheme/cmdline.inc $(srcdir)/../mzscheme/src/stypes.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@
|
||||
$(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:
|
||||
$(MAKE) mrmain_ee.@LTO@
|
||||
|
|
@ -193,28 +193,28 @@ mredx.@LTO@ : $(srcdir)/mredx.cxx $(srcdir)/../mzscheme/include/scheme.h $(srcdi
|
|||
$(WXINCDEP) \
|
||||
$(srcdir)/../wxcommon/wxGC.h $(srcdir)/../wxcommon/wx_list.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 \
|
||||
$(srcdir)/../wxcommon/wxGC.h $(srcdir)/../wxcommon/wx_list.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 \
|
||||
$(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
|
||||
$(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
|
||||
$(CC) $(CFLAGS) $(LOCALFLAGS) -c $(srcdir)/misc/dl_stub.c -o dl_stub.@LTO@
|
||||
|
||||
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@:
|
||||
$(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@:
|
||||
$(MAKE) wx
|
||||
|
|
|
|||
|
|
@ -3152,6 +3152,11 @@ wxFrame *MrEdApp::OnInit(void)
|
|||
# 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);
|
||||
|
||||
#if WCONSOLE_STDIO
|
||||
|
|
|
|||
|
|
@ -198,7 +198,7 @@ MRED_EXTERN void mred_set_run_from_cmd_line(MrEd_Run_From_Cmd_Line_Proc);
|
|||
#endif
|
||||
|
||||
#ifndef REDIRECT_STDIO
|
||||
# if (defined(wx_msw) || defined(wx_mac)) && !WCONSOLE_STDIO
|
||||
# if defined(wx_msw) && !WCONSOLE_STDIO
|
||||
# define REDIRECT_STDIO 1
|
||||
# else
|
||||
# define REDIRECT_STDIO 0
|
||||
|
|
|
|||
|
|
@ -180,6 +180,7 @@ static BOOL CALLBACK CheckWindow(HWND wnd, LPARAM param)
|
|||
info->remove ? PM_REMOVE : PM_NOREMOVE)) {
|
||||
info->wnd = wnd;
|
||||
info->c_return = c;
|
||||
scheme_notify_sleep_progress();
|
||||
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)) {
|
||||
wxTranslateMessage(&pmsg);
|
||||
DispatchMessage(&pmsg);
|
||||
scheme_notify_sleep_progress();
|
||||
}
|
||||
}
|
||||
|
||||
|
|
|
|||
|
|
@ -2108,6 +2108,7 @@ Bool wxMediaPrintout::OnBeginDocument(int startPage, int endPage)
|
|||
void wxMediaPrintout::OnEndDocument()
|
||||
{
|
||||
scheme_apply(end_doc, 0, NULL);
|
||||
wxPrintout::OnEndDocument();
|
||||
}
|
||||
|
||||
#endif
|
||||
|
|
|
|||
|
|
@ -170,10 +170,10 @@ mzscheme.multiboot : libmzscheme.@LIBSFX@ libmzgc.@LIBSFX@ main.@LTO@
|
|||
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
|
||||
$(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@
|
||||
$(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:
|
||||
$(MAKE) main_ee.@LTO@
|
||||
|
|
|
|||
Some files were not shown because too many files have changed in this diff Show More
Loading…
Reference in New Issue
Block a user