diff --git a/collects/deinprogramm/scribblings/image.scrbl b/collects/deinprogramm/scribblings/image.scrbl index f62cd56dce..5c1b46baa3 100644 --- a/collects/deinprogramm/scribblings/image.scrbl +++ b/collects/deinprogramm/scribblings/image.scrbl @@ -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. } diff --git a/collects/drscheme/private/rep.ss b/collects/drscheme/private/rep.ss index 9c8f5112aa..1e9fe99f6f 100644 --- a/collects/drscheme/private/rep.ss +++ b/collects/drscheme/private/rep.ss @@ -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 - (unless (hash-has-key? checkpoints exn) - (hash-set! checkpoints exn checkpoint)) - (raise exn))]) - (thunk))) + (call-with-exception-handler + (λ (exn) + (unless (hash-has-key? checkpoints exn) + (hash-set! checkpoints exn checkpoint)) + 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) diff --git a/collects/drscheme/private/text.ss b/collects/drscheme/private/text.ss index 388f9cd8d4..a941b53531 100644 --- a/collects/drscheme/private/text.ss +++ b/collects/drscheme/private/text.ss @@ -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]) diff --git a/collects/games/chat-noir/README b/collects/games/chat-noir/README deleted file mode 100644 index 4d401ef9d8..0000000000 --- a/collects/games/chat-noir/README +++ /dev/null @@ -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 diff --git a/collects/games/chat-noir/chat-noir-literate.ss b/collects/games/chat-noir/chat-noir-literate.ss index 4b5120205c..f7393b1215 100644 --- a/collects/games/chat-noir/chat-noir-literate.ss +++ b/collects/games/chat-noir/chat-noir-literate.ss @@ -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[ (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[ (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))] diff --git a/collects/htdp/big-draw.ss b/collects/htdp/big-draw.ss index f0925a659d..2f98be4706 100644 --- a/collects/htdp/big-draw.ss +++ b/collects/htdp/big-draw.ss @@ -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^) diff --git a/collects/macro-debugger/model/hiding-policies.ss b/collects/macro-debugger/model/hiding-policies.ss index 7c5e36fe5d..51c1027b8a 100644 --- a/collects/macro-debugger/model/hiding-policies.ss +++ b/collects/macro-debugger/model/hiding-policies.ss @@ -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))))) -|# diff --git a/collects/macro-debugger/model/reductions.ss b/collects/macro-debugger/model/reductions.ss index 037d68eb04..8062e26150 100644 --- a/collects/macro-debugger/model/reductions.ss +++ b/collects/macro-debugger/model/reductions.ss @@ -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 diff --git a/collects/macro-debugger/util/mpi.ss b/collects/macro-debugger/util/mpi.ss index d9c89cc085..6f627aaf63 100644 --- a/collects/macro-debugger/util/mpi.ss +++ b/collects/macro-debugger/util/mpi.ss @@ -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) diff --git a/collects/macro-debugger/view/stepper.ss b/collects/macro-debugger/view/stepper.ss index 28138be6e5..b833438bff 100644 --- a/collects/macro-debugger/view/stepper.ss +++ b/collects/macro-debugger/view/stepper.ss @@ -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))) )) diff --git a/collects/mred/private/seqcontract.ss b/collects/mred/private/seqcontract.ss index 0bfe0b5bad..aebd87121b 100644 --- a/collects/mred/private/seqcontract.ss +++ b/collects/mred/private/seqcontract.ss @@ -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) diff --git a/collects/mred/private/syntax.ss b/collects/mred/private/syntax.ss index c195293b23..c3dc44ce90 100644 --- a/collects/mred/private/syntax.ss +++ b/collects/mred/private/syntax.ss @@ -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))) diff --git a/collects/mred/private/wxcanvas.ss b/collects/mred/private/wxcanvas.ss index 2bef5bab98..806328a5a7 100644 --- a/collects/mred/private/wxcanvas.ss +++ b/collects/mred/private/wxcanvas.ss @@ -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)))) diff --git a/collects/mred/private/wxme/editor-canvas.ss b/collects/mred/private/wxme/editor-canvas.ss index a6f092d2b5..479337ac73 100644 --- a/collects/mred/private/wxme/editor-canvas.ss +++ b/collects/mred/private/wxme/editor-canvas.ss @@ -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? diff --git a/collects/mred/private/wxme/editor-snip.ss b/collects/mred/private/wxme/editor-snip.ss index 29ee21aa2a..6365724964 100644 --- a/collects/mred/private/wxme/editor-snip.ss +++ b/collects/mred/private/wxme/editor-snip.ss @@ -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) diff --git a/collects/mred/private/wxme/editor.ss b/collects/mred/private/wxme/editor.ss index 8df9606949..7c9f42b751 100644 --- a/collects/mred/private/wxme/editor.ss +++ b/collects/mred/private/wxme/editor.ss @@ -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 diff --git a/collects/mred/private/wxme/mline.ss b/collects/mred/private/wxme/mline.ss index 1af464b976..3365ff49e3 100644 --- a/collects/mred/private/wxme/mline.ss +++ b/collects/mred/private/wxme/mline.ss @@ -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))]) diff --git a/collects/mred/private/wxme/private.ss b/collects/mred/private/wxme/private.ss index b7fba6ba78..ddfd3642e3 100644 --- a/collects/mred/private/wxme/private.ss +++ b/collects/mred/private/wxme/private.ss @@ -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 diff --git a/collects/mred/private/wxme/snip-admin.ss b/collects/mred/private/wxme/snip-admin.ss index 9a6bee31a9..4e981e1bff 100644 --- a/collects/mred/private/wxme/snip-admin.ss +++ b/collects/mred/private/wxme/snip-admin.ss @@ -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) diff --git a/collects/mred/private/wxme/snip.ss b/collects/mred/private/wxme/snip.ss index 22b4c0daf5..6e1c4fa101 100644 --- a/collects/mred/private/wxme/snip.ss +++ b/collects/mred/private/wxme/snip.ss @@ -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) diff --git a/collects/mred/private/wxme/text.ss b/collects/mred/private/wxme/text.ss index 388e30bf0b..b4d21c1911 100644 --- a/collects/mred/private/wxme/text.ss +++ b/collects/mred/private/wxme/text.ss @@ -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,14 +621,15 @@ (def/override (blink-caret) (if s-caret-snip - (let-boxes ([dx 0.0] - [dy 0.0] - [dc #f]) - (set-box! dc (send s-admin get-dc dx dy)) - (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))))) + (when s-admin + (let-boxes ([dx 0.0] + [dy 0.0] + [dc #f]) + (set-box! dc (send s-admin get-dc dx dy)) + (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)))))) (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? @@ -1785,7 +1830,7 @@ (set! first-line (mline-first (unbox line-root-box))) (set! last-line (mline-last (unbox line-root-box))) - + (let-values ([(line moved-to-next?) (if start-snip (if (has-flag? (snip->flags start-snip) NEWLINE) @@ -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 ([buffer (make-string 1)]) - (send snip get-text! buffer (- start s-pos) 1 0) - (string-ref buffer 0))))) + (let ([delta (- start s-pos)]) + (if (delta . >= . (snip->count snip)) + #\nul + (let ([buffer (make-string 1)]) + (send snip get-text! buffer delta 1 0) + (string-ref buffer 0))))))) ;; ---------------------------------------- @@ -2929,7 +2980,8 @@ (let ([dc (send s-admin get-dc)]) (let-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 diff --git a/collects/mred/private/wxme/wordbreak.ss b/collects/mred/private/wxme/wordbreak.ss index ea2d0881b7..65cbfe5fb5 100644 --- a/collects/mred/private/wxme/wordbreak.ss +++ b/collects/mred/private/wxme/wordbreak.ss @@ -41,113 +41,115 @@ (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)]) - (define (nonbreak? ch) (memq reason (get-map ch))) + [(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 - (let* ([start (unbox startp)] - [pstart start] - [lstart (send win find-newline 'backward start 0)] - [lstart (if lstart - (if (eq? 'caret reason) - (or (and (positive? lstart) - (send win find-newline 'backward (sub1 lstart) 0)) - 0) - lstart) - 0)] - [lend (min (+ start 1) (send win last-position))] - [tstart (if ((- start lstart) . > . MAX-DIST-TRY) - (- start MAX-DIST-TRY) - lstart)] - [text (send win get-text tstart lend)] - [start (- start tstart)] - [pstart (- pstart tstart)]) + (when startp + (let* ([start (unbox startp)] + [pstart start] + [lstart (send win find-newline 'backward start 0)] + [lstart (if lstart + (if (eq? 'caret reason) + (or (and (positive? lstart) + (send win find-newline 'backward (sub1 lstart) 0)) + 0) + lstart) + 0)] + [lend (min (+ start 1) (send win last-position))] + [tstart (if ((- start lstart) . > . MAX-DIST-TRY) + (- start MAX-DIST-TRY) + lstart)] + [text (send win get-text tstart lend)] + [start (- start tstart)] + [pstart (- pstart tstart)]) - (let ploop ([phase1-complete? #f] - [phase2-complete? #f] - [start start] - [pstart pstart] - [text text] - [tstart tstart]) - (let*-values ([(start phase1-complete?) - (if phase1-complete? - (values start #t) - (let ([start (if (and (positive? start) - (nonbreak? (string-ref* text start))) - (sub1 start) - start)]) - (values start - (not (nonbreak? (string-ref* text start))))))] - [(start phase2-complete?) - (if (not (eq? 'selection reason)) - (if (not phase2-complete?) - (let loop ([start start]) - (if (and (positive? start) + (let ploop ([phase1-complete? #f] + [phase2-complete? #f] + [start start] + [pstart pstart] + [text text] + [tstart tstart]) + (let*-values ([(start phase1-complete?) + (if phase1-complete? + (values start #t) + (let ([start (if (and (positive? start) + (nonbreak? (string-ref* text start))) + (sub1 start) + start)]) + (values start + (not (nonbreak? (string-ref* text start))))))] + [(start phase2-complete?) + (if (not (eq? 'selection reason)) + (if (not phase2-complete?) + (let loop ([start start]) + (if (and (positive? start) + (not (nonbreak? (string-ref* text start)))) + (loop (sub1 start)) + (if (nonbreak? (string-ref* text start)) + (values start #t) + (values start #f)))) + (values start #t)) + (values start phase2-complete?))]) + (let loop ([start start]) + (if (and (positive? start) + (nonbreak? (string-ref* text start))) + (loop (sub1 start)) + (let ([start (if (and (start . < . pstart) (not (nonbreak? (string-ref* text start)))) - (loop (sub1 start)) - (if (nonbreak? (string-ref* text start)) - (values start #t) - (values start #f)))) - (values start #t)) - (values start phase2-complete?))]) - (let loop ([start start]) - (if (and (positive? start) - (nonbreak? (string-ref* text start))) - (loop (sub1 start)) - (let ([start (if (and (start . < . pstart) - (not (nonbreak? (string-ref* text start)))) - (add1 start) - start)]) - (if (and (zero? start) - (not (= lstart tstart))) - (ploop phase1-complete? - phase2-complete? - (+ start (- tstart lstart)) - (+ pstart (- tstart lstart)) - (send win get-text lstart lend) - lstart) - (set-box! startp (+ start tstart)))))))))) - - (when endp - (let* ([end (unbox endp)] - [lstart end] - [lend (send win find-newline 'forward end)] - [lend (if lend - (if (eq? 'caret reason) - (or (send win find-newline 'forward (+ lend 1)) - (send win last-position)) - lend) - (send win last-position))] - [tend (if ((- lend end) . > . MAX-DIST-TRY) - (+ end MAX-DIST-TRY) - lend)] - [text (send win get-text lstart tend)] - [end (- end lstart)] - [lend (- lend lstart)] - [tend (- tend lstart)]) + (add1 start) + start)]) + (if (and (zero? start) + (not (= lstart tstart))) + (ploop phase1-complete? + phase2-complete? + (+ start (- tstart lstart)) + (+ pstart (- tstart lstart)) + (send win get-text lstart lend) + lstart) + (set-box! startp (+ start tstart)))))))))) - (let ploop ([phase1-complete? #f] - [text text] - [tend tend] - [end end]) - (let-values ([(end phase1-complete?) - (if phase1-complete? - (values end #t) - (let loop ([end end]) - (if (and (end . < . tend) - (not (nonbreak? (string-ref* text end)))) - (loop (add1 end)) - (if (end . < . tend) - (values end #t) - (values end #f)))))]) - (let loop ([end end]) - (if (and (end . < . tend) - (nonbreak? (string-ref* text end))) - (loop (add1 end)) - (if (and (= tend end) (not (= lend tend))) - (ploop phase1-complete? - (send win get-text lstart (+ lstart lend)) - lend - end) - (set-box! endp (+ end lstart))))))))))) + (when endp + (let* ([end (unbox endp)] + [lstart end] + [lend (send win find-newline 'forward end)] + [lend (if lend + (if (eq? 'caret reason) + (or (send win find-newline 'forward (+ lend 1)) + (send win last-position)) + lend) + (send win last-position))] + [tend (if ((- lend end) . > . MAX-DIST-TRY) + (+ end MAX-DIST-TRY) + lend)] + [text (send win get-text lstart tend)] + [end (- end lstart)] + [lend (- lend lstart)] + [tend (- tend lstart)]) + + (let ploop ([phase1-complete? #f] + [text text] + [tend tend] + [end end]) + (let-values ([(end phase1-complete?) + (if phase1-complete? + (values end #t) + (let loop ([end end]) + (if (and (end . < . tend) + (not (nonbreak? (string-ref* text end)))) + (loop (add1 end)) + (if (end . < . tend) + (values end #t) + (values end #f)))))]) + (let loop ([end end]) + (if (and (end . < . tend) + (nonbreak? (string-ref* text end))) + (loop (add1 end)) + (if (and (= tend end) (not (= lend tend))) + (ploop phase1-complete? + (send win get-text lstart (+ lstart lend)) + lend + end) + (set-box! endp (+ end lstart))))))))))))) diff --git a/collects/mzlib/control.ss b/collects/mzlib/control.ss index 409d2a1435..59576fd5b2 100644 --- a/collects/mzlib/control.ss +++ b/collects/mzlib/control.ss @@ -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 diff --git a/collects/mzlib/unit.ss b/collects/mzlib/unit.ss index 84c81fc078..54bb4a7d02 100644 --- a/collects/mzlib/unit.ss +++ b/collects/mzlib/unit.ss @@ -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) ...))))) diff --git a/collects/plot/plot.scrbl b/collects/plot/plot.scrbl index 42ba007c96..23d7987fad 100644 --- a/collects/plot/plot.scrbl +++ b/collects/plot/plot.scrbl @@ -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))) diff --git a/collects/redex/private/reduction-semantics.ss b/collects/redex/private/reduction-semantics.ss index 036285e1ca..3035a74eff 100644 --- a/collects/redex/private/reduction-semantics.ss +++ b/collects/redex/private/reduction-semantics.ss @@ -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))]) diff --git a/collects/redex/private/tl-test.ss b/collects/redex/private/tl-test.ss index 71d95807a7..4dc69b3a85 100644 --- a/collects/redex/private/tl-test.ss +++ b/collects/redex/private/tl-test.ss @@ -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 () diff --git a/collects/scheme/private/cond.ss b/collects/scheme/private/cond.ss index f66a9eefdc..88ba03428e 100644 --- a/collects/scheme/private/cond.ss +++ b/collects/scheme/private/cond.ss @@ -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) diff --git a/collects/scribble/lp/lang/lang.ss b/collects/scribble/lp/lang/lang.ss index 7ecc7353d5..f8eb1491b6 100644 --- a/collects/scribble/lp/lang/lang.ss +++ b/collects/scribble/lp/lang/lang.ss @@ -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) diff --git a/collects/scribble/scheme.ss b/collects/scribble/scheme.ss index ad95b2bcaa..dff809d40f 100644 --- a/collects/scribble/scheme.ss +++ b/collects/scribble/scheme.ss @@ -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,62 +772,70 @@ (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? - (+ 2 (string-length (format "~a" (unbox graph-box)))) - 0) + (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)] + [vec-sz (cond + [(vector? v) + (+ 1 #;(string-length (format "~a" (vector-length v))))] + [(struct? v) 2] + [else 0])] + [r (let ([l (let loop ([col (+ col 1 vec-sz graph-sz)] + [v (cond + [(vector? v) + (vector->short-list v values)] + [(struct? v) + (cons (prefab-struct-key v) + (cdr (vector->list (struct->vector v))))] + [else v])]) + (if (null? v) + null + (let ([i (do-syntax-ize (car v) col line ht #f)]) + (cons i + (loop (+ col 1 (syntax-span i)) (cdr v))))))]) + (datum->syntax #f (cond - [(vector? v) - (+ 1 #;(string-length (format "~a" (vector-length v))))] - [(struct? v) 2] - [else 0]))]) - (let ([l (let loop ([col (+ col 1 vec-sz)] - [v (cond - [(vector? v) - (vector->short-list v values)] - [(struct? v) - (cons (prefab-struct-key v) - (cdr (vector->list (struct->vector v))))] - [else v])]) - (if (null? v) - null - (let ([i (do-syntax-ize (car v) col line ht #f)]) - (cons i - (loop (+ col 1 (syntax-span i)) (cdr v))))))]) - (datum->syntax #f - (cond - [(vector? v) (short-list->vector v l)] - [(struct? v) - (apply make-prefab-struct (prefab-struct-key v) (cdr l))] - [else l]) - (vector #f line col (+ 1 col) - (+ 2 - vec-sz - (if (zero? (length l)) - 0 - (sub1 (length l))) - (apply + (map syntax-span l)))))))]) + [(vector? v) (short-list->vector v l)] + [(struct? v) + (apply make-prefab-struct (prefab-struct-key v) (cdr l))] + [else l]) + (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))))))]) (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) diff --git a/collects/scribblings/gui/editor-intf.scrbl b/collects/scribblings/gui/editor-intf.scrbl index 99dc7b6fe3..b5ec74131d 100644 --- a/collects/scribblings/gui/editor-intf.scrbl +++ b/collects/scribblings/gui/editor-intf.scrbl @@ -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 diff --git a/collects/scribblings/gui/text-class.scrbl b/collects/scribblings/gui/text-class.scrbl index d0af7be3fd..c4fccef743 100644 --- a/collects/scribblings/gui/text-class.scrbl +++ b/collects/scribblings/gui/text-class.scrbl @@ -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, diff --git a/collects/scribblings/guide/chars.scrbl b/collects/scribblings/guide/chars.scrbl index 60f25259e1..fd16acc406 100644 --- a/collects/scribblings/guide/chars.scrbl +++ b/collects/scribblings/guide/chars.scrbl @@ -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 diff --git a/collects/scribblings/guide/lists.scrbl b/collects/scribblings/guide/lists.scrbl index 0909639f39..87802083cf 100644 --- a/collects/scribblings/guide/lists.scrbl +++ b/collects/scribblings/guide/lists.scrbl @@ -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. diff --git a/collects/scribblings/guide/simple-syntax.scrbl b/collects/scribblings/guide/simple-syntax.scrbl index 5d949d9b45..3b7dce5e90 100644 --- a/collects/scribblings/guide/simple-syntax.scrbl +++ b/collects/scribblings/guide/simple-syntax.scrbl @@ -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. @;- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - diff --git a/collects/scribblings/guide/truth.scrbl b/collects/scribblings/guide/truth.scrbl index cc70006c61..839f4be2c6 100644 --- a/collects/scribblings/guide/truth.scrbl +++ b/collects/scribblings/guide/truth.scrbl @@ -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 diff --git a/collects/scribblings/scribble/lp.scrbl b/collects/scribblings/scribble/lp.scrbl index 9bf1ffe635..b300e4a0ea 100644 --- a/collects/scribblings/scribble/lp.scrbl +++ b/collects/scribblings/scribble/lp.scrbl @@ -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} diff --git a/collects/stepper/private/annotate.ss b/collects/stepper/private/annotate.ss index 58c23b82d6..0828266121 100644 --- a/collects/stepper/private/annotate.ss +++ b/collects/stepper/private/annotate.ss @@ -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)) - (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))) + (let* ([annotated-exp (cond + ;; 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)) + -;; !@#$ defs have to appear after annotate/master. -(define annotate (annotate/master #t)) -(define annotate/not-top-level (annotate/master #f)) diff --git a/collects/stepper/private/model.ss b/collects/stepper/private/model.ss index 65df49dc15..3a83790c8c 100644 --- a/collects/stepper/private/model.ss +++ b/collects/stepper/private/model.ss @@ -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... - (receive-result - (make-before-after-result - (append new-finished-list left-side) - (append new-finished-list right-side) - 'normal - #f #f)))] + (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 + 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 diff --git a/collects/stepper/stepper-tool.ss b/collects/stepper/stepper-tool.ss index 564d3b24a6..ce0c92cc15 100644 --- a/collects/stepper/stepper-tool.ss +++ b/collects/stepper/stepper-tool.ss @@ -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) diff --git a/collects/stepper/view-controller.ss b/collects/stepper/view-controller.ss index ff88b74eea..c1605091cd 100644 --- a/collects/stepper/view-controller.ss +++ b/collects/stepper/view-controller.ss @@ -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,9 +169,8 @@ ;; 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)) \ No newline at end of file diff --git a/collects/teachpack/2htdp/scribblings/universe.scrbl b/collects/teachpack/2htdp/scribblings/universe.scrbl index 61315b1624..6cbac0e799 100644 --- a/collects/teachpack/2htdp/scribblings/universe.scrbl +++ b/collects/teachpack/2htdp/scribblings/universe.scrbl @@ -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[ diff --git a/collects/test-engine/test-display.scm b/collects/test-engine/test-display.scm index 3e73771cd1..f335ff7f51 100644 --- a/collects/test-engine/test-display.scm +++ b/collects/test-engine/test-display.scm @@ -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) diff --git a/collects/tests/deinprogramm/contract.ss b/collects/tests/deinprogramm/contract.ss index f450d55a38..2c405d3e78 100644 --- a/collects/tests/deinprogramm/contract.ss +++ b/collects/tests/deinprogramm/contract.ss @@ -2,7 +2,7 @@ (provide all-contract-tests) -(require (planet schematics/schemeunit:3) +(require schemeunit deinprogramm/contract/contract deinprogramm/contract/contract-syntax) diff --git a/collects/tests/deinprogramm/image.ss b/collects/tests/deinprogramm/image.ss index 41d41ab64e..bd11526c9c 100644 --- a/collects/tests/deinprogramm/image.ss +++ b/collects/tests/deinprogramm/image.ss @@ -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)]) diff --git a/collects/tests/deinprogramm/run-contract-tests.ss b/collects/tests/deinprogramm/run-contract-tests.ss index c375180247..524a79d1d0 100644 --- a/collects/tests/deinprogramm/run-contract-tests.ss +++ b/collects/tests/deinprogramm/run-contract-tests.ss @@ -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) \ No newline at end of file diff --git a/collects/tests/deinprogramm/run-image-test.ss b/collects/tests/deinprogramm/run-image-test.ss index 06215561da..059f38a5b3 100644 --- a/collects/tests/deinprogramm/run-image-test.ss +++ b/collects/tests/deinprogramm/run-image-test.ss @@ -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) \ No newline at end of file diff --git a/collects/tests/drscheme/drscheme-test-util.ss b/collects/tests/drscheme/drscheme-test-util.ss index 9f2b27519d..7112f0c6ac 100644 --- a/collects/tests/drscheme/drscheme-test-util.ss +++ b/collects/tests/drscheme/drscheme-test-util.ss @@ -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) diff --git a/collects/tests/drscheme/repl-test.ss b/collects/tests/drscheme/repl-test.ss index f08844e992..7130be894e 100644 --- a/collects/tests/drscheme/repl-test.ss +++ b/collects/tests/drscheme/repl-test.ss @@ -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 ; given #" "{stop-multi.png} {stop-22x22.png} repl-test-tmp3.ss:1:0: expt: expected argument of type ; given #" "expt: expected argument of type ; given #" - "{stop-multi.png} {stop-22x22.png} ../../mred/private/snipfile.ss:230:18: expt: expected argument of type ; given #" - "{stop-multi.png} {stop-22x22.png} ../../mred/private/snipfile.ss:230:18: expt: expected argument of type ; given #") + #rx"{stop-multi.png} {stop-22x22.png} ../../mred/private/snipfile.ss:[0-9]+:[0-9]+: expt: expected argument of type ; given #" + #rx"{stop-multi.png} {stop-22x22.png} ../../mred/private/snipfile.ss:[0-9]+:[0-9]+: expt: expected argument of type ; given #") '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 ; given #f\n15" "{stop-multi.png} {stop-22x22.png} repl-test-tmp3.ss:5:19: expt: expected argument of type ; given #f\n15" "expt: expected argument of type ; given #f\n15" - "{stop-multi.png} {stop-22x22.png} ../../mred/private/snipfile.ss:230:18: expt: expected argument of type ; given #f\n15" - "{stop-multi.png} {stop-22x22.png} ../../mred/private/snipfile.ss:230:18: expt: expected argument of type ; given #f\n15") + #rx"{stop-multi.png} {stop-22x22.png} ../../mred/private/snipfile.ss:[0-9]+:[0-9]+: expt: expected argument of type ; given #f\n15" + #rx"{stop-multi.png} {stop-22x22.png} ../../mred/private/snipfile.ss:[0-9]+:[0-9]+: expt: expected argument of type ; 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 ; given #f" "{stop-multi.png} {stop-22x22.png} repl-test-tmp3.ss:6:15: expt: expected argument of type ; given #f" "expt: expected argument of type ; given #f" - "{stop-multi.png} {stop-22x22.png} ../../mred/private/snipfile.ss:230:18: expt: expected argument of type ; given #f" - "{stop-multi.png} {stop-22x22.png} ../../mred/private/snipfile.ss:230:18: expt: expected argument of type ; given #f") + #rx"{stop-multi.png} {stop-22x22.png} ../../mred/private/snipfile.ss:[0-9]+:[0-9]+: expt: expected argument of type ; given #f" + #rx"{stop-multi.png} {stop-22x22.png} ../../mred/private/snipfile.ss:[0-9]+:[0-9]+: expt: expected argument of type ; 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 diff --git a/collects/tests/framework/test-suite-utils.ss b/collects/tests/framework/test-suite-utils.ss index 8b6ccc504b..704d833a07 100644 --- a/collects/tests/framework/test-suite-utils.ss +++ b/collects/tests/framework/test-suite-utils.ss @@ -297,6 +297,7 @@ (and win (string=? (send win get-label) ,name)))]) (if eventspace - `(parameterize ([current-eventspace ,eventspace]) - ,exp) + (wait-for + `(parameterize ([current-eventspace ,eventspace]) + ,exp)) (wait-for exp)))) diff --git a/collects/tests/macro-debugger/tests/policy.ss b/collects/tests/macro-debugger/tests/policy.ss index dec45f3169..d0585a36f2 100644 --- a/collects/tests/macro-debugger/tests/policy.ss +++ b/collects/tests/macro-debugger/tests/policy.ss @@ -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) diff --git a/collects/tests/mred/wxme-doc-random.ss b/collects/tests/mred/wxme-doc-random.ss new file mode 100644 index 0000000000..7f46ad6359 --- /dev/null +++ b/collects/tests/mred/wxme-doc-random.ss @@ -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))))) + diff --git a/collects/tests/mred/wxme-random.ss b/collects/tests/mred/wxme-random.ss new file mode 100644 index 0000000000..3e8b0df412 --- /dev/null +++ b/collects/tests/mred/wxme-random.ss @@ -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))) diff --git a/collects/tests/mred/wxme.ss b/collects/tests/mred/wxme.ss index 869d90c448..7e769720b8 100644 --- a/collects/tests/mred/wxme.ss +++ b/collects/tests/mred/wxme.ss @@ -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")) diff --git a/collects/tests/mzscheme/number.ss b/collects/tests/mzscheme/number.ss index 468efe640d..7f811a81bb 100644 --- a/collects/tests/mzscheme/number.ss +++ b/collects/tests/mzscheme/number.ss @@ -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) diff --git a/collects/tests/mzscheme/numstrs.ss b/collects/tests/mzscheme/numstrs.ss index 473d177286..99e7df8126 100644 --- a/collects/tests/mzscheme/numstrs.ss +++ b/collects/tests/mzscheme/numstrs.ss @@ -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") diff --git a/collects/tests/web-server/dispatchers/dispatch-lang-test.ss b/collects/tests/web-server/dispatchers/dispatch-lang-test.ss index 0796cea256..6227336694 100644 --- a/collects/tests/web-server/dispatchers/dispatch-lang-test.ss +++ b/collects/tests/web-server/dispatchers/dispatch-lang-test.ss @@ -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) +|# \ No newline at end of file diff --git a/collects/tests/web-server/lang/abort-resume-test.ss b/collects/tests/web-server/lang/abort-resume-test.ss index f73366ee4f..d946d67b5c 100644 --- a/collects/tests/web-server/lang/abort-resume-test.ss +++ b/collects/tests/web-server/lang/abort-resume-test.ss @@ -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)))) - (vector (lambda _ - (continuation-mark-set->list* - (current-continuation-marks) - (list 1 3 5 7))) - #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 (lambda _ + (continuation-mark-set->list* + (current-continuation-marks) + (list 1 3 5 7))) + #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) +|# \ No newline at end of file diff --git a/collects/web-server/default-web-root/htdocs/lang-servlets/add-native.ss b/collects/web-server/default-web-root/htdocs/lang-servlets/add-native.ss new file mode 100644 index 0000000000..85e120629a --- /dev/null +++ b/collects/web-server/default-web-root/htdocs/lang-servlets/add-native.ss @@ -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"))))))) diff --git a/collects/web-server/default-web-root/htdocs/lang-servlets/add-param.ss b/collects/web-server/default-web-root/htdocs/lang-servlets/add-param.ss index 632e16f282..35166dd1da 100644 --- a/collects/web-server/default-web-root/htdocs/lang-servlets/add-param.ss +++ b/collects/web-server/default-web-root/htdocs/lang-servlets/add-param.ss @@ -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"] diff --git a/collects/web-server/default-web-root/htdocs/lang-servlets/add-simple.ss b/collects/web-server/default-web-root/htdocs/lang-servlets/add-simple.ss index f416ee5866..e0b4b2f154 100644 --- a/collects/web-server/default-web-root/htdocs/lang-servlets/add-simple.ss +++ b/collects/web-server/default-web-root/htdocs/lang-servlets/add-simple.ss @@ -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"] diff --git a/collects/web-server/default-web-root/htdocs/lang-servlets/add-soft.ss b/collects/web-server/default-web-root/htdocs/lang-servlets/add-soft.ss new file mode 100644 index 0000000000..f1ac2af414 --- /dev/null +++ b/collects/web-server/default-web-root/htdocs/lang-servlets/add-soft.ss @@ -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"))))))) diff --git a/collects/web-server/default-web-root/htdocs/lang-servlets/add.ss b/collects/web-server/default-web-root/htdocs/lang-servlets/add.ss index b6b1352909..7460aa3d5d 100644 --- a/collects/web-server/default-web-root/htdocs/lang-servlets/add.ss +++ b/collects/web-server/default-web-root/htdocs/lang-servlets/add.ss @@ -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"] diff --git a/collects/web-server/default-web-root/htdocs/lang-servlets/add02.ss b/collects/web-server/default-web-root/htdocs/lang-servlets/add02.ss index 46eacc3c06..6fa97a7e27 100644 --- a/collects/web-server/default-web-root/htdocs/lang-servlets/add02.ss +++ b/collects/web-server/default-web-root/htdocs/lang-servlets/add02.ss @@ -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"] diff --git a/collects/web-server/default-web-root/htdocs/lang-servlets/add03.ss b/collects/web-server/default-web-root/htdocs/lang-servlets/add03.ss index 7f87454f70..63a59b82d5 100644 --- a/collects/web-server/default-web-root/htdocs/lang-servlets/add03.ss +++ b/collects/web-server/default-web-root/htdocs/lang-servlets/add03.ss @@ -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"] diff --git a/collects/web-server/default-web-root/htdocs/lang-servlets/add04-stuffer.ss b/collects/web-server/default-web-root/htdocs/lang-servlets/add04-stuffer.ss index 6c6629baaf..6384b64b5e 100644 --- a/collects/web-server/default-web-root/htdocs/lang-servlets/add04-stuffer.ss +++ b/collects/web-server/default-web-root/htdocs/lang-servlets/add04-stuffer.ss @@ -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"] diff --git a/collects/web-server/default-web-root/htdocs/lang-servlets/add04.ss b/collects/web-server/default-web-root/htdocs/lang-servlets/add04.ss index cab7b4978a..3035c480e1 100644 --- a/collects/web-server/default-web-root/htdocs/lang-servlets/add04.ss +++ b/collects/web-server/default-web-root/htdocs/lang-servlets/add04.ss @@ -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"] diff --git a/collects/web-server/default-web-root/htdocs/lang-servlets/add06.ss b/collects/web-server/default-web-root/htdocs/lang-servlets/add06.ss index 4573a4d94c..3eeeb81834 100644 --- a/collects/web-server/default-web-root/htdocs/lang-servlets/add06.ss +++ b/collects/web-server/default-web-root/htdocs/lang-servlets/add06.ss @@ -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 diff --git a/collects/web-server/default-web-root/htdocs/lang-servlets/map.ss b/collects/web-server/default-web-root/htdocs/lang-servlets/map.ss new file mode 100644 index 0000000000..b6dfc059bb --- /dev/null +++ b/collects/web-server/default-web-root/htdocs/lang-servlets/map.ss @@ -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))))))))))) \ No newline at end of file diff --git a/collects/web-server/default-web-root/htdocs/lang-servlets/quiz-lib.ss b/collects/web-server/default-web-root/htdocs/lang-servlets/quiz-lib.ss index 0a94370f00..8c5a362292 100644 --- a/collects/web-server/default-web-root/htdocs/lang-servlets/quiz-lib.ss +++ b/collects/web-server/default-web-root/htdocs/lang-servlets/quiz-lib.ss @@ -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"]) diff --git a/collects/web-server/default-web-root/htdocs/lang-servlets/soft.ss b/collects/web-server/default-web-root/htdocs/lang-servlets/soft.ss new file mode 100644 index 0000000000..48070412ef --- /dev/null +++ b/collects/web-server/default-web-root/htdocs/lang-servlets/soft.ss @@ -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"))))))) diff --git a/collects/web-server/lang/abort-resume.ss b/collects/web-server/lang/abort-resume.ss index b805349e92..1c0214067e 100644 --- a/collects/web-server/lang/abort-resume.ss +++ b/collects/web-server/lang/abort-resume.ss @@ -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) +(define (abort 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) - (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))))))) + (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 (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 @@ -176,7 +240,7 @@ [activation-record-list (-> saved-context?)] [with-current-saved-continuation-marks-and (any/c any/c (-> any/c) . -> . any/c)] [kont-append-fun (kont? procedure? . -> . kont?)] - + ;; "CLIENT" INTERFACE [dispatch ((request? . -> . (request? . -> . response?)) request? @@ -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) diff --git a/collects/web-server/lang/elim-callcc.ss b/collects/web-server/lang/elim-callcc.ss index c0de68006c..cb4cb45a26 100644 --- a/collects/web-server/lang/elim-callcc.ss +++ b/collects/web-server/lang/elim-callcc.ss @@ -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) diff --git a/collects/web-server/lang/lang-api.ss b/collects/web-server/lang/lang-api.ss index b94ac3a048..8c97b1a93f 100644 --- a/collects/web-server/lang/lang-api.ss +++ b/collects/web-server/lang/lang-api.ss @@ -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)) diff --git a/collects/web-server/lang/native.ss b/collects/web-server/lang/native.ss new file mode 100644 index 0000000000..8819c0f90b --- /dev/null +++ b/collects/web-server/lang/native.ss @@ -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) \ No newline at end of file diff --git a/collects/web-server/lang/soft.ss b/collects/web-server/lang/soft.ss new file mode 100644 index 0000000000..74ed24fde4 --- /dev/null +++ b/collects/web-server/lang/soft.ss @@ -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)]) \ No newline at end of file diff --git a/collects/web-server/lang/web.ss b/collects/web-server/lang/web.ss index 1e63658bde..e3ef0b1ffc 100644 --- a/collects/web-server/lang/web.ss +++ b/collects/web-server/lang/web.ss @@ -81,25 +81,23 @@ (lambda (k-url) (page-maker (url->string k-url))))) -(define-closure embed/url (proc) (k) - (stuff-url (stateless-servlet-stuffer (current-servlet)) - (request-uri (execution-context-request (current-execution-context))) - (kont-append-fun k proc))) +(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))]) + (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 diff --git a/collects/web-server/scribblings/dummy-stateless-servlet.ss b/collects/web-server/scribblings/dummy-stateless-servlet.ss index 68f97d1288..920111bcdf 100644 --- a/collects/web-server/scribblings/dummy-stateless-servlet.ss +++ b/collects/web-server/scribblings/dummy-stateless-servlet.ss @@ -2,6 +2,7 @@ (define interface-version #f) (define stuffer #f) +(define manager #f) (define start #f) (provide (all-defined-out)) diff --git a/collects/web-server/scribblings/lang-api.scrbl b/collects/web-server/scribblings/lang-api.scrbl index 16757de287..b1e634a655 100644 --- a/collects/web-server/scribblings/lang-api.scrbl +++ b/collects/web-server/scribblings/lang-api.scrbl @@ -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"] \ No newline at end of file diff --git a/collects/web-server/scribblings/lang.scrbl b/collects/web-server/scribblings/lang.scrbl index d6a67ec56a..36dde2a7a6 100644 --- a/collects/web-server/scribblings/lang.scrbl +++ b/collects/web-server/scribblings/lang.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)]) diff --git a/collects/web-server/scribblings/native.scrbl b/collects/web-server/scribblings/native.scrbl new file mode 100644 index 0000000000..3d8b148502 --- /dev/null +++ b/collects/web-server/scribblings/native.scrbl @@ -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)))))) + ] + } + +} diff --git a/collects/web-server/scribblings/serial.scrbl b/collects/web-server/scribblings/serial.scrbl new file mode 100644 index 0000000000..12a315b7ff --- /dev/null +++ b/collects/web-server/scribblings/serial.scrbl @@ -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]. +} + +} \ No newline at end of file diff --git a/collects/web-server/scribblings/servlet-setup.scrbl b/collects/web-server/scribblings/servlet-setup.scrbl index 633b67ae98..281ca53cf1 100644 --- a/collects/web-server/scribblings/servlet-setup.scrbl +++ b/collects/web-server/scribblings/servlet-setup.scrbl @@ -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?)]{ diff --git a/collects/web-server/scribblings/servlet.scrbl b/collects/web-server/scribblings/servlet.scrbl index 45d488130a..5dbb1c3bda 100644 --- a/collects/web-server/scribblings/servlet.scrbl +++ b/collects/web-server/scribblings/servlet.scrbl @@ -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 diff --git a/collects/web-server/scribblings/soft.scrbl b/collects/web-server/scribblings/soft.scrbl new file mode 100644 index 0000000000..bbc8cc9a54 --- /dev/null +++ b/collects/web-server/scribblings/soft.scrbl @@ -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 +} + +} \ No newline at end of file diff --git a/collects/web-server/scribblings/stateless-usage.scrbl b/collects/web-server/scribblings/stateless-usage.scrbl index 3ae1a7ea6b..85df06777f 100644 --- a/collects/web-server/scribblings/stateless-usage.scrbl +++ b/collects/web-server/scribblings/stateless-usage.scrbl @@ -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. diff --git a/collects/web-server/scribblings/stuffers.scrbl b/collects/web-server/scribblings/stuffers.scrbl index 1b3c7322e6..660b63e950 100644 --- a/collects/web-server/scribblings/stuffers.scrbl +++ b/collects/web-server/scribblings/stuffers.scrbl @@ -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?]) diff --git a/collects/web-server/scribblings/web-cells.scrbl b/collects/web-server/scribblings/web-cells.scrbl index e0902514e5..7c203f6229 100644 --- a/collects/web-server/scribblings/web-cells.scrbl +++ b/collects/web-server/scribblings/web-cells.scrbl @@ -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 diff --git a/collects/web-server/servlet/setup.ss b/collects/web-server/servlet/setup.ss index 85a99a78c6..414831f5f2 100644 --- a/collects/web-server/servlet/setup.ss +++ b/collects/web-server/servlet/setup.ss @@ -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 diff --git a/collects/web-server/stuffers/hmac-sha1.ss b/collects/web-server/stuffers/hmac-sha1.ss index 5754f0f72b..69f6d47679 100644 --- a/collects/web-server/stuffers/hmac-sha1.ss +++ b/collects/web-server/stuffers/hmac-sha1.ss @@ -12,23 +12,27 @@ (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 - (get-ffi-obj 'EVP_sha1 libcrypto - (_fun f-> _fpointer))) + (and libcrypto + (get-ffi-obj 'EVP_sha1 libcrypto + (_fun f-> _fpointer)))) (define HMAC-SHA1/raw - (get-ffi-obj 'HMAC libcrypto - (_fun [EVP_MD : _fpointer = (EVP_SHA1)] - [key : _bytes] - [key_len : _int = (bytes-length key)] - [data : _bytes] - [data_len : _int = (bytes-length data)] - [md : _int = 0] - [md_len : _int = 0] - f-> - _pointer))) + (if libcrypto + (get-ffi-obj 'HMAC libcrypto + (_fun [EVP_MD : _fpointer = (EVP_SHA1)] + [key : _bytes] + [key_len : _int = (bytes-length key)] + [data : _bytes] + [data_len : _int = (bytes-length data)] + [md : _int = 0] + [md_len : _int = 0] + f-> + _pointer)) + (lambda (key data) (error 'HMAC-SHA1/raw "libcrypto could not load")))) (define (HMAC-SHA1 key data) ; It returns the same pointer always diff --git a/doc/release-notes/drscheme/HISTORY.txt b/doc/release-notes/drscheme/HISTORY.txt index e7f211d9e7..24f8585819 100644 --- a/doc/release-notes/drscheme/HISTORY.txt +++ b/doc/release-notes/drscheme/HISTORY.txt @@ -1,3 +1,9 @@ +------------------------------ + Version 4.2 +------------------------------ + + . Minor bug fixes + ------------------------------ Version 4.1.5 ------------------------------ diff --git a/doc/release-notes/redex/HISTORY.txt b/doc/release-notes/redex/HISTORY.txt index 116f09476a..365b5c8a32 100644 --- a/doc/release-notes/redex/HISTORY.txt +++ b/doc/release-notes/redex/HISTORY.txt @@ -1,3 +1,7 @@ +v4.2 + + * minor bug fixes + v4.1.5 * renamed test--> to test-->> diff --git a/doc/release-notes/teachpack/HISTORY.txt b/doc/release-notes/teachpack/HISTORY.txt index 8c5523402d..624c4c6440 100644 --- a/doc/release-notes/teachpack/HISTORY.txt +++ b/doc/release-notes/teachpack/HISTORY.txt @@ -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] diff --git a/src/configure b/src/configure index 101e722a28..45cd4b32f9 100755 --- a/src/configure +++ b/src/configure @@ -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 diff --git a/src/mred/Makefile.in b/src/mred/Makefile.in index 785664c3a1..3ff5bc8340 100644 --- a/src/mred/Makefile.in +++ b/src/mred/Makefile.in @@ -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 diff --git a/src/mred/mred.cxx b/src/mred/mred.cxx index 8c50f739fa..9f48987f91 100644 --- a/src/mred/mred.cxx +++ b/src/mred/mred.cxx @@ -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 diff --git a/src/mred/mred.h b/src/mred/mred.h index 48c6053a97..aebaa621cf 100644 --- a/src/mred/mred.h +++ b/src/mred/mred.h @@ -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 diff --git a/src/mred/mredmsw.cxx b/src/mred/mredmsw.cxx index ced6628ef2..fb97d4506e 100644 --- a/src/mred/mredmsw.cxx +++ b/src/mred/mredmsw.cxx @@ -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(); } } diff --git a/src/mred/wxs/wxscheme.cxx b/src/mred/wxs/wxscheme.cxx index 3ff2404a1f..9beedf11b2 100644 --- a/src/mred/wxs/wxscheme.cxx +++ b/src/mred/wxs/wxscheme.cxx @@ -2108,6 +2108,7 @@ Bool wxMediaPrintout::OnBeginDocument(int startPage, int endPage) void wxMediaPrintout::OnEndDocument() { scheme_apply(end_doc, 0, NULL); + wxPrintout::OnEndDocument(); } #endif diff --git a/src/mzscheme/Makefile.in b/src/mzscheme/Makefile.in index 4655d9f585..ea6da5b6b8 100644 --- a/src/mzscheme/Makefile.in +++ b/src/mzscheme/Makefile.in @@ -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@ diff --git a/src/mzscheme/configure.ac b/src/mzscheme/configure.ac index 0bff9d4886..eddd4037bb 100644 --- a/src/mzscheme/configure.ac +++ b/src/mzscheme/configure.ac @@ -73,6 +73,7 @@ AC_ARG_ENABLE(noopt, [ --enable-sdk= use Mac OS X 10.4 SDK director AC_ARG_ENABLE(xonx, [ --enable-xonx compile X11 (not Quartz) MrEd for Mac OS X]) AC_ARG_ENABLE(libfw, [ --enable-libfw install Mac OS X frameworks to /Library/Frameworks]) AC_ARG_ENABLE(libfw, [ --enable-userfw install Mac OS X frameworks to ~/Library/Frameworks]) +AC_ARG_ENABLE(macprefix, [ --enable-macprefix allow --prefix with a Mac OS X install]) ###### Get OS Type ####### @@ -133,6 +134,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 diff --git a/src/mzscheme/gc2/Makefile.in b/src/mzscheme/gc2/Makefile.in index 7208a49765..f2673bf820 100644 --- a/src/mzscheme/gc2/Makefile.in +++ b/src/mzscheme/gc2/Makefile.in @@ -18,8 +18,9 @@ AR = @AR@ ARFLAGS = @ARFLAGS@ RANLIB = @RANLIB@ -CPPFLAGS = @PREFLAGS@ @OPTIONS@ @GC2OPTIONS@ @MZOPTIONS@ -I$(builddir)/.. -I$(srcdir)/../include -CFLAGS = @CFLAGS@ $(CPPFLAGS) @COMPFLAGS@ @PROFFLAGS@ +MOST_CPPFLAGS = @PREFLAGS@ @OPTIONS@ @GC2OPTIONS@ @MZOPTIONS@ +CPPFLAGS = -I$(builddir)/.. -I$(srcdir)/../include $(MOST_CPPFLAGS) +CFLAGS = -I$(builddir)/.. -I$(srcdir)/../include @CFLAGS@ $(MOST_CPPFLAGS) @COMPFLAGS@ @PROFFLAGS@ LIBS = @LIBS@ ARLIBFLAGS = @LDFLAGS@ $(LIBS) diff --git a/src/mzscheme/include/mzscheme.exp b/src/mzscheme/include/mzscheme.exp index 7c3ff49e19..4a296719d8 100644 --- a/src/mzscheme/include/mzscheme.exp +++ b/src/mzscheme/include/mzscheme.exp @@ -47,6 +47,7 @@ scheme_in_main_thread scheme_cancel_sleep scheme_start_sleeper_thread scheme_end_sleeper_thread +scheme_notify_sleep_progress scheme_make_thread_cell scheme_thread_cell_get scheme_thread_cell_set diff --git a/src/mzscheme/include/mzscheme3m.exp b/src/mzscheme/include/mzscheme3m.exp index 8a0104b167..8fac2b1357 100644 --- a/src/mzscheme/include/mzscheme3m.exp +++ b/src/mzscheme/include/mzscheme3m.exp @@ -47,6 +47,7 @@ scheme_in_main_thread scheme_cancel_sleep scheme_start_sleeper_thread scheme_end_sleeper_thread +scheme_notify_sleep_progress scheme_make_thread_cell scheme_thread_cell_get scheme_thread_cell_set diff --git a/src/mzscheme/include/mzwin.def b/src/mzscheme/include/mzwin.def index 63c7fbd1a0..e929f7794d 100644 --- a/src/mzscheme/include/mzwin.def +++ b/src/mzscheme/include/mzwin.def @@ -49,6 +49,7 @@ EXPORTS scheme_cancel_sleep scheme_start_sleeper_thread scheme_end_sleeper_thread + scheme_notify_sleep_progress scheme_make_thread_cell scheme_thread_cell_get scheme_thread_cell_set diff --git a/src/mzscheme/include/mzwin3m.def b/src/mzscheme/include/mzwin3m.def index c85242740b..6da7f874a0 100644 --- a/src/mzscheme/include/mzwin3m.def +++ b/src/mzscheme/include/mzwin3m.def @@ -49,6 +49,7 @@ EXPORTS scheme_cancel_sleep scheme_start_sleeper_thread scheme_end_sleeper_thread + scheme_notify_sleep_progress scheme_make_thread_cell scheme_thread_cell_get scheme_thread_cell_set diff --git a/src/mzscheme/src/Makefile.in b/src/mzscheme/src/Makefile.in index 7aa7a464d1..cced9bb7fb 100644 --- a/src/mzscheme/src/Makefile.in +++ b/src/mzscheme/src/Makefile.in @@ -10,7 +10,7 @@ PERL = @PERL@ MZSRC = $(srcdir) -CFLAGS = @CFLAGS@ @COMPFLAGS@ @PREFLAGS@ @PROFFLAGS@ @OPTIONS@ @MZOPTIONS@ -I$(builddir)/.. -I$(srcdir)/../include +CFLAGS = -I$(builddir)/.. -I$(srcdir)/../include @CFLAGS@ @COMPFLAGS@ @PREFLAGS@ @PROFFLAGS@ @OPTIONS@ @MZOPTIONS@ OBJS = salloc.@LTO@ \ bignum.@LTO@ \ diff --git a/src/mzscheme/src/numstr.c b/src/mzscheme/src/numstr.c index 2e584972e1..bb6057fd0d 100644 --- a/src/mzscheme/src/numstr.c +++ b/src/mzscheme/src/numstr.c @@ -876,12 +876,17 @@ Scheme_Object *scheme_read_number(const mzchar *str, long len, #ifdef MZ_USE_SINGLE_FLOATS if (SCHEME_FLTP(n1) && SCHEME_FLTP(n2)) - return scheme_make_complex(scheme_make_float((float)r1), - scheme_make_float((float)r2)); + n1 = scheme_make_complex(scheme_make_float((float)r1), + scheme_make_float((float)r2)); + else #endif + n1 = scheme_make_complex(scheme_make_double(r1), + scheme_make_double(r2)); - return scheme_make_complex(scheme_make_double(r1), - scheme_make_double(r2)); + if (is_not_float) + n1 = scheme_inexact_to_exact(1, &n1); + + return n1; } has_decimal = has_slash = has_hash = has_hash_since_slash = has_expt = 0; diff --git a/src/mzscheme/src/port.c b/src/mzscheme/src/port.c index 8366023788..f238295bde 100644 --- a/src/mzscheme/src/port.c +++ b/src/mzscheme/src/port.c @@ -8061,14 +8061,14 @@ static void clean_up_wait(long result, OS_SEMAPHORE_TYPE *array, static int made_progress; static DWORD max_sleep_time; -void scheme_notify_sleep_progres() +void scheme_notify_sleep_progress() { made_progress = 1; } #else -void scheme_notify_sleep_progres() +void scheme_notify_sleep_progress() { } diff --git a/src/mzscheme/src/schemef.h b/src/mzscheme/src/schemef.h index 6856587fc4..8438b2b22b 100644 --- a/src/mzscheme/src/schemef.h +++ b/src/mzscheme/src/schemef.h @@ -125,6 +125,8 @@ MZ_EXTERN void scheme_cancel_sleep(void); MZ_EXTERN void scheme_start_sleeper_thread(void (*mzsleep)(float seconds, void *fds), float secs, void *fds, int hit_fd); MZ_EXTERN void scheme_end_sleeper_thread(); +MZ_EXTERN void scheme_notify_sleep_progress(); + MZ_EXTERN Scheme_Object *scheme_make_thread_cell(Scheme_Object *def_val, int inherited); MZ_EXTERN Scheme_Object *scheme_thread_cell_get(Scheme_Object *cell, Scheme_Thread_Cell_Table *cells); MZ_EXTERN void scheme_thread_cell_set(Scheme_Object *cell, Scheme_Thread_Cell_Table *cells, Scheme_Object *v); diff --git a/src/mzscheme/src/schemex.h b/src/mzscheme/src/schemex.h index dfaec8a86b..8a9341128d 100644 --- a/src/mzscheme/src/schemex.h +++ b/src/mzscheme/src/schemex.h @@ -99,6 +99,7 @@ int (*scheme_in_main_thread)(void); void (*scheme_cancel_sleep)(void); void (*scheme_start_sleeper_thread)(void (*mzsleep)(float seconds, void *fds), float secs, void *fds, int hit_fd); void (*scheme_end_sleeper_thread)(); +void (*scheme_notify_sleep_progress)(); Scheme_Object *(*scheme_make_thread_cell)(Scheme_Object *def_val, int inherited); Scheme_Object *(*scheme_thread_cell_get)(Scheme_Object *cell, Scheme_Thread_Cell_Table *cells); void (*scheme_thread_cell_set)(Scheme_Object *cell, Scheme_Thread_Cell_Table *cells, Scheme_Object *v); diff --git a/src/mzscheme/src/schemex.inc b/src/mzscheme/src/schemex.inc index a1eb923619..0979816462 100644 --- a/src/mzscheme/src/schemex.inc +++ b/src/mzscheme/src/schemex.inc @@ -55,6 +55,7 @@ scheme_extension_table->scheme_cancel_sleep = scheme_cancel_sleep; scheme_extension_table->scheme_start_sleeper_thread = scheme_start_sleeper_thread; scheme_extension_table->scheme_end_sleeper_thread = scheme_end_sleeper_thread; + scheme_extension_table->scheme_notify_sleep_progress = scheme_notify_sleep_progress; scheme_extension_table->scheme_make_thread_cell = scheme_make_thread_cell; scheme_extension_table->scheme_thread_cell_get = scheme_thread_cell_get; scheme_extension_table->scheme_thread_cell_set = scheme_thread_cell_set; diff --git a/src/mzscheme/src/schemexm.h b/src/mzscheme/src/schemexm.h index bb7e3dd2eb..405a50470f 100644 --- a/src/mzscheme/src/schemexm.h +++ b/src/mzscheme/src/schemexm.h @@ -55,6 +55,7 @@ #define scheme_cancel_sleep (scheme_extension_table->scheme_cancel_sleep) #define scheme_start_sleeper_thread (scheme_extension_table->scheme_start_sleeper_thread) #define scheme_end_sleeper_thread (scheme_extension_table->scheme_end_sleeper_thread) +#define scheme_notify_sleep_progress (scheme_extension_table->scheme_notify_sleep_progress) #define scheme_make_thread_cell (scheme_extension_table->scheme_make_thread_cell) #define scheme_thread_cell_get (scheme_extension_table->scheme_thread_cell_get) #define scheme_thread_cell_set (scheme_extension_table->scheme_thread_cell_set) diff --git a/src/mzscheme/src/thread.c b/src/mzscheme/src/thread.c index 9829897c7a..3bcc404c19 100644 --- a/src/mzscheme/src/thread.c +++ b/src/mzscheme/src/thread.c @@ -118,7 +118,6 @@ extern void *scheme_gmp_tls_load(long *s); extern void scheme_gmp_tls_unload(long *s, void *p); extern void scheme_gmp_tls_snapshot(long *s, long *save); extern void scheme_gmp_tls_restore_snapshot(long *s, void *data, long *save, int do_free); -extern void scheme_notify_sleep_progres(); static void check_ready_break(); @@ -3493,7 +3492,7 @@ static int check_sleep(int need_activity, int sleep_now) p2 = scheme_first_thread; while (p2) { if (p2->ran_some) { - scheme_notify_sleep_progres(); + scheme_notify_sleep_progress(); p2->ran_some = 0; } p2 = p2->next; diff --git a/src/wxcommon/wb_list.cxx b/src/wxcommon/wb_list.cxx index c7d864d0a2..e01bb4a080 100644 --- a/src/wxcommon/wb_list.cxx +++ b/src/wxcommon/wb_list.cxx @@ -396,7 +396,11 @@ Bool wxList::OnDeleteObject(wxObject *object) // mac platform only */ wxStringList::wxStringList (void): -wxList () +#ifdef wx_mac + wxList(kNoDestroyData, FALSE) +#else + wxList () +#endif { __type = wxTYPE_STRING_LIST; }