From ac8aca7b21da760c36218ed1f4c1dd6d975d63cd Mon Sep 17 00:00:00 2001 From: Jay McCarthy Date: Mon, 18 May 2009 17:46:15 +0000 Subject: [PATCH 01/56] Native continuations in serial language, soft state, and typos. Eli, this may be put into the release. svn: r14854 --- .../dispatchers/dispatch-lang-test.ss | 15 ++ .../web-server/lang/abort-resume-test.ss | 68 ++++---- .../htdocs/lang-servlets/add-native.ss | 34 ++++ .../htdocs/lang-servlets/add-param.ss | 2 +- .../htdocs/lang-servlets/add-simple.ss | 2 +- .../htdocs/lang-servlets/add-soft.ss | 31 ++++ .../htdocs/lang-servlets/add.ss | 2 +- .../htdocs/lang-servlets/add02.ss | 2 +- .../htdocs/lang-servlets/add03.ss | 2 +- .../htdocs/lang-servlets/add04-stuffer.ss | 2 +- .../htdocs/lang-servlets/add04.ss | 2 +- .../htdocs/lang-servlets/add06.ss | 2 +- .../htdocs/lang-servlets/map.ss | 43 +++++ .../htdocs/lang-servlets/quiz-lib.ss | 2 +- .../htdocs/lang-servlets/soft.ss | 17 ++ collects/web-server/lang/abort-resume.ss | 148 +++++++++++++----- collects/web-server/lang/elim-callcc.ss | 1 + collects/web-server/lang/lang-api.ss | 8 +- collects/web-server/lang/native.ss | 25 +++ collects/web-server/lang/soft.ss | 33 ++++ collects/web-server/lang/web.ss | 24 ++- .../scribblings/dummy-stateless-servlet.ss | 1 + .../web-server/scribblings/lang-api.scrbl | 23 ++- collects/web-server/scribblings/lang.scrbl | 19 +-- collects/web-server/scribblings/native.scrbl | 36 +++++ collects/web-server/scribblings/serial.scrbl | 57 +++++++ .../scribblings/servlet-setup.scrbl | 4 +- collects/web-server/scribblings/servlet.scrbl | 1 + collects/web-server/scribblings/soft.scrbl | 71 +++++++++ .../scribblings/stateless-usage.scrbl | 47 ++++-- .../web-server/scribblings/stuffers.scrbl | 20 +-- .../web-server/scribblings/web-cells.scrbl | 3 +- collects/web-server/servlet/setup.ss | 16 +- 33 files changed, 614 insertions(+), 149 deletions(-) create mode 100644 collects/web-server/default-web-root/htdocs/lang-servlets/add-native.ss create mode 100644 collects/web-server/default-web-root/htdocs/lang-servlets/add-soft.ss create mode 100644 collects/web-server/default-web-root/htdocs/lang-servlets/map.ss create mode 100644 collects/web-server/default-web-root/htdocs/lang-servlets/soft.ss create mode 100644 collects/web-server/lang/native.ss create mode 100644 collects/web-server/lang/soft.ss create mode 100644 collects/web-server/scribblings/native.scrbl create mode 100644 collects/web-server/scribblings/serial.scrbl create mode 100644 collects/web-server/scribblings/soft.scrbl 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..5862e2315a 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-current-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..affd8bbf9b --- /dev/null +++ b/collects/web-server/lang/soft.ss @@ -0,0 +1,33 @@ +#lang scheme +(require scheme/serialize) + +(define-serializable-struct soft-state-record (id thnk)) + +(define *soft-state-cache* + (make-weak-hasheq)) + +(define next-record-id! + (local [(define record-id 0)] + (lambda () + (begin0 record-id + (set! record-id (add1 record-id)))))) + +(define (make-soft-state thnk) + (make-soft-state-record (next-record-id!) thnk)) + +(define soft-state-ref + (match-lambda + [(struct soft-state-record (id thnk)) + (hash-ref! *soft-state-cache* id thnk)])) + +(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 From 63abe061c924a765750f9864a14762c8daaeb5c3 Mon Sep 17 00:00:00 2001 From: Jay McCarthy Date: Mon, 18 May 2009 20:11:41 +0000 Subject: [PATCH 02/56] fixing soft state implementation, contents must be weak too svn: r14856 --- collects/web-server/lang/soft.ss | 29 ++++++++++++++++------------- 1 file changed, 16 insertions(+), 13 deletions(-) diff --git a/collects/web-server/lang/soft.ss b/collects/web-server/lang/soft.ss index affd8bbf9b..74ed24fde4 100644 --- a/collects/web-server/lang/soft.ss +++ b/collects/web-server/lang/soft.ss @@ -1,24 +1,27 @@ #lang scheme (require scheme/serialize) -(define-serializable-struct soft-state-record (id thnk)) +(define-serializable-struct soft-state-record (thnk)) +(define-struct some (value)) (define *soft-state-cache* - (make-weak-hasheq)) - -(define next-record-id! - (local [(define record-id 0)] - (lambda () - (begin0 record-id - (set! record-id (add1 record-id)))))) + (make-weak-hash)) (define (make-soft-state thnk) - (make-soft-state-record (next-record-id!) thnk)) + (make-soft-state-record thnk)) -(define soft-state-ref - (match-lambda - [(struct soft-state-record (id thnk)) - (hash-ref! *soft-state-cache* id 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?) From c4b4af817b356d5bd6034b6d5c8037cc14edfa68 Mon Sep 17 00:00:00 2001 From: Matthew Flatt Date: Mon, 18 May 2009 23:31:33 +0000 Subject: [PATCH 03/56] random mred testing svn: r14862 --- collects/tests/mred/wxme-doc-random.ss | 169 +++++++++++++++++++++++++ collects/tests/mred/wxme-random.ss | 61 +++++++++ 2 files changed, 230 insertions(+) create mode 100644 collects/tests/mred/wxme-doc-random.ss create mode 100644 collects/tests/mred/wxme-random.ss 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..31ed15c1f5 --- /dev/null +++ b/collects/tests/mred/wxme-random.ss @@ -0,0 +1,61 @@ +#lang scheme/gui + +(define seed 704050726 #;(abs (current-milliseconds))) +(random-seed seed) + +(define t (new text%)) + +(define frame + (new frame% [label "Test"] + [width 300] + [height 400])) +(define canvas + (new editor-canvas% [parent frame] [editor t])) + +(send frame show #t) + +(send t set-max-undo-history 100) + +(define (random-elem v) + (vector-ref v (random (vector-length v)))) + +(define (random-string) + (random-elem '#("a" "x\ny\nz\n" "hello there"))) + +(define seq 0) + +(define actions + (vector + (lambda () (send t undo)) + (lambda () (send t redo)) + (lambda () (send t insert (random-string) (random (add1 (send t last-position))))) + (lambda () + (let ([pos (random (add1 (send t last-position)))]) + (send t delete pos (random (max 1 (- (send t last-position) pos)))))) + (lambda () + (send t begin-edit-sequence) + (set! seq (add1 seq))) + (lambda () + (let loop () + (when (positive? seq) + (send t end-edit-sequence) + (set! seq (sub1 seq)) + (when (zero? (random 2)) + (loop))))) + (lambda () + (let ([pos (random (add1 (send t last-position)))]) + (send t set-position pos (random (max 1 (- (send t last-position) pos)))))) + (lambda () (send t copy)) + (lambda () (send t cut)) + (lambda () (send t paste)) + (lambda () (send t change-style (make-object style-delta% 'change-size (add1 (random 42))))) + (lambda () (send t insert (make-object editor-snip%))) + )) + +(let loop () + (let ([act (random-elem actions)]) + (printf "~s: ~s\n" seed act) + (act) + (loop))) + + \ No newline at end of file From 63a7a9c77bedb8f2d7c5f862c20bf7716c95be26 Mon Sep 17 00:00:00 2001 From: Matthew Flatt Date: Tue, 19 May 2009 00:27:39 +0000 Subject: [PATCH 04/56] more random mred testing svn: r14863 --- collects/tests/mred/wxme-random.ss | 63 ++++++++++++++++++------------ 1 file changed, 39 insertions(+), 24 deletions(-) diff --git a/collects/tests/mred/wxme-random.ss b/collects/tests/mred/wxme-random.ss index 31ed15c1f5..685d89dc00 100644 --- a/collects/tests/mred/wxme-random.ss +++ b/collects/tests/mred/wxme-random.ss @@ -1,20 +1,24 @@ #lang scheme/gui -(define seed 704050726 #;(abs (current-milliseconds))) +(define seed 700438844 #;(abs (current-milliseconds))) (random-seed seed) -(define t (new text%)) +; scroll-line-location bug + +(define orig-t (new text%)) (define frame (new frame% [label "Test"] [width 300] [height 400])) (define canvas - (new editor-canvas% [parent frame] [editor t])) + (new editor-canvas% [parent frame] [editor orig-t])) (send frame show #t) -(send t set-max-undo-history 100) +(define (init t) + (send t set-max-undo-history 100)) +(init orig-t) (define (random-elem v) (vector-ref v (random (vector-length v)))) @@ -22,40 +26,51 @@ (define (random-string) (random-elem '#("a" "x\ny\nz\n" "hello there"))) -(define seq 0) +(define seqs (make-hasheq)) +(define ts (make-weak-hasheq)) (define actions (vector - (lambda () (send t undo)) - (lambda () (send t redo)) - (lambda () (send t insert (random-string) (random (add1 (send t last-position))))) - (lambda () + (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) (let ([pos (random (add1 (send t last-position)))]) (send t delete pos (random (max 1 (- (send t last-position) pos)))))) - (lambda () + (lambda (t) (send t begin-edit-sequence) - (set! seq (add1 seq))) - (lambda () + (hash-update! seqs t add1 0)) + (lambda (t) (let loop () - (when (positive? seq) + (when (positive? (hash-ref seqs t 0)) (send t end-edit-sequence) - (set! seq (sub1 seq)) + (hash-update! seqs t sub1) (when (zero? (random 2)) (loop))))) - (lambda () + (lambda (t) (let ([pos (random (add1 (send t last-position)))]) (send t set-position pos (random (max 1 (- (send t last-position) pos)))))) - (lambda () (send t copy)) - (lambda () (send t cut)) - (lambda () (send t paste)) - (lambda () (send t change-style (make-object style-delta% 'change-size (add1 (random 42))))) - (lambda () (send t insert (make-object editor-snip%))) + (lambda (t) (send t copy)) + (lambda (t) (send t cut)) + (lambda (t) (send t paste)) + (lambda (t) (send t change-style (make-object style-delta% 'change-size (add1 (random 42))))) + (lambda (t) + (let ([t2 (new text%)]) + (hash-set! ts t2 #t) + (init t2) + (send t insert (make-object editor-snip% t2)))) + (lambda (t) + (send t set-max-width (if (zero? (random 2)) 100.0 'none))) )) (let loop () - (let ([act (random-elem actions)]) + (let ([act (random-elem actions)] + [t (if (zero? (random 2)) + orig-t + (for/fold ([t orig-t]) + ([t (in-hash-keys ts)] + [n (in-range (random (add1 (hash-count ts))))]) + t))]) (printf "~s: ~s\n" seed act) - (act) + (act t) (loop))) - - \ No newline at end of file From 17a283a28d6146abd43c751265f059964ccac547 Mon Sep 17 00:00:00 2001 From: Matthew Flatt Date: Tue, 19 May 2009 01:02:41 +0000 Subject: [PATCH 05/56] editor and documentation repairs (merge to 4.2) svn: r14864 --- collects/mred/private/seqcontract.ss | 3 +- collects/mred/private/wxme/editor-canvas.ss | 4 +- collects/mred/private/wxme/editor.ss | 6 +- collects/mred/private/wxme/mline.ss | 18 +- collects/mred/private/wxme/private.ss | 2 +- collects/mred/private/wxme/snip-admin.ss | 4 +- collects/mred/private/wxme/text.ss | 51 +++-- collects/mred/private/wxme/wordbreak.ss | 214 ++++++++++---------- collects/scribblings/gui/editor-intf.scrbl | 34 ++-- collects/scribblings/gui/text-class.scrbl | 60 +++--- collects/tests/mred/wxme-random.ss | 4 +- 11 files changed, 217 insertions(+), 183 deletions(-) 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/wxme/editor-canvas.ss b/collects/mred/private/wxme/editor-canvas.ss index a6f092d2b5..1cf21f3b5e 100644 --- a/collects/mred/private/wxme/editor-canvas.ss +++ b/collects/mred/private/wxme/editor-canvas.ss @@ -532,7 +532,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.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..69808385b9 100644 --- a/collects/mred/private/wxme/mline.ss +++ b/collects/mred/private/wxme/mline.ss @@ -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)) @@ -929,7 +930,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)) @@ -967,7 +969,9 @@ Debugging tools: (set-mline-last-snip! newline (mline-last-snip mline)) (set-mline-last-snip! mline asnip) - (snips-to-line! newline)) + (snips-to-line! newline) + + (notify-insert newline)) ;; just pushed to next line (begin (set-mline-last-snip! mline asnip) @@ -992,7 +996,10 @@ 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) ;; this line was extended @@ -1015,6 +1022,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..ce459291e5 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,6 +95,7 @@ get-s-last-snip get-s-total-width get-s-total-height + get-s-snips refresh-box add-back-clickback do-insert-snips) 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/text.ss b/collects/mred/private/wxme/text.ss index 388e30bf0b..9d809310f9 100644 --- a/collects/mred/private/wxme/text.ss +++ b/collects/mred/private/wxme/text.ss @@ -233,6 +233,7 @@ (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) @@ -593,14 +594,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 +1038,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 +1097,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))] @@ -2213,9 +2217,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 +2936,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 +3062,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) @@ -4561,7 +4570,17 @@ (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 (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)))) (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/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/tests/mred/wxme-random.ss b/collects/tests/mred/wxme-random.ss index 685d89dc00..03b7b81215 100644 --- a/collects/tests/mred/wxme-random.ss +++ b/collects/tests/mred/wxme-random.ss @@ -1,9 +1,9 @@ #lang scheme/gui -(define seed 700438844 #;(abs (current-milliseconds))) +(define seed (abs (current-milliseconds))) (random-seed seed) -; scroll-line-location bug +(error-print-context-length 100) (define orig-t (new text%)) From e5f52cbc890342b42b22a2862e643cf9745cb8ff Mon Sep 17 00:00:00 2001 From: Eli Barzilay Date: Tue, 19 May 2009 07:50:13 +0000 Subject: [PATCH 06/56] Welcome to a new PLT day. svn: r14865 --- collects/repos-time-stamp/stamp.ss | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/collects/repos-time-stamp/stamp.ss b/collects/repos-time-stamp/stamp.ss index 23d23146ab..bedbbc905e 100644 --- a/collects/repos-time-stamp/stamp.ss +++ b/collects/repos-time-stamp/stamp.ss @@ -1 +1 @@ -#lang scheme/base (provide stamp) (define stamp "18may2009") +#lang scheme/base (provide stamp) (define stamp "19may2009") From 67a8ebecdb54a12d3b16a8018b11e678beeabcbd Mon Sep 17 00:00:00 2001 From: Matthew Flatt Date: Tue, 19 May 2009 12:26:17 +0000 Subject: [PATCH 07/56] rename internal method to avoid conflict with corrected editor<%> svn: r14866 --- collects/drscheme/private/text.ss | 4 ++-- 1 file changed, 2 insertions(+), 2 deletions(-) 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]) From e51ca461aea368e427e08f6bc39eef5a723e439a Mon Sep 17 00:00:00 2001 From: Matthew Flatt Date: Tue, 19 May 2009 12:54:07 +0000 Subject: [PATCH 08/56] try to fix Windows freezing problem svn: r14867 --- src/mred/mredmsw.cxx | 2 ++ src/mzscheme/include/mzscheme.exp | 1 + src/mzscheme/include/mzscheme3m.exp | 1 + src/mzscheme/include/mzwin.def | 1 + src/mzscheme/include/mzwin3m.def | 1 + src/mzscheme/src/port.c | 4 ++-- src/mzscheme/src/schemef.h | 2 ++ src/mzscheme/src/schemex.h | 1 + src/mzscheme/src/schemex.inc | 1 + src/mzscheme/src/schemexm.h | 1 + src/mzscheme/src/thread.c | 3 +-- 11 files changed, 14 insertions(+), 4 deletions(-) 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/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/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; From bf36c8283ed55a39519cb8428429f8c6cf262c3f Mon Sep 17 00:00:00 2001 From: Jay McCarthy Date: Tue, 19 May 2009 19:11:16 +0000 Subject: [PATCH 09/56] Fixing slight bug svn: r14872 --- collects/web-server/lang/abort-resume.ss | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/collects/web-server/lang/abort-resume.ss b/collects/web-server/lang/abort-resume.ss index 5862e2315a..1c0214067e 100644 --- a/collects/web-server/lang/abort-resume.ss +++ b/collects/web-server/lang/abort-resume.ss @@ -182,7 +182,7 @@ (define (serial->native* thnk) (call-with-continuation-prompt thnk unsafe-barrier-prompt-tag)) (define (native->serial* thnk) - (call-with-current-continuation + (call-with-composable-continuation (lambda (unsafe-continuation-portion) (with-continuation-mark continuation-of-unsafe-part-mark unsafe-continuation-portion From 237b2252491c0bafba6532f26f06d779795e0f51 Mon Sep 17 00:00:00 2001 From: Robby Findler Date: Tue, 19 May 2009 19:21:48 +0000 Subject: [PATCH 10/56] svn: r14873 --- collects/scribblings/scribble/lp.scrbl | 14 +++++++++++--- 1 file changed, 11 insertions(+), 3 deletions(-) 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} From 05005713831e4cb95ed7673c4c5063d84d42da1b Mon Sep 17 00:00:00 2001 From: Robby Findler Date: Tue, 19 May 2009 20:58:46 +0000 Subject: [PATCH 11/56] PR 10244 svn: r14874 --- collects/redex/private/reduction-semantics.ss | 4 ++-- 1 file changed, 2 insertions(+), 2 deletions(-) diff --git a/collects/redex/private/reduction-semantics.ss b/collects/redex/private/reduction-semantics.ss index 036285e1ca..90385eb9c0 100644 --- a/collects/redex/private/reduction-semantics.ss +++ b/collects/redex/private/reduction-semantics.ss @@ -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))]) From a1f9a6f1abc5dc278fbe43b25d9d7c547665f1c6 Mon Sep 17 00:00:00 2001 From: Matthias Felleisen Date: Tue, 19 May 2009 22:23:17 +0000 Subject: [PATCH 12/56] added hack to allow some comments in LP svn: r14875 --- collects/scribble/lp/lang/lang.ss | 8 ++++++++ 1 file changed, 8 insertions(+) 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) From 43c8b6cafd6b058a42ba19935e04c3d4291c03b6 Mon Sep 17 00:00:00 2001 From: Matthew Flatt Date: Tue, 19 May 2009 23:53:36 +0000 Subject: [PATCH 13/56] restore (compared to old implementation) trampolines needed on some editor-canvas methods svn: r14876 --- collects/mred/private/wxcanvas.ss | 7 ++++++- collects/mred/private/wxme/editor-canvas.ss | 13 +++++++++++-- 2 files changed, 17 insertions(+), 3 deletions(-) diff --git a/collects/mred/private/wxcanvas.ss b/collects/mred/private/wxcanvas.ss index 2bef5bab98..5eb8efe4b3 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? 'msw (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 1cf21f3b5e..7f76ceae94 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? 'msw (system-type)) + (queue-window-callback + this + (lambda () (on-focus #t))) + (on-focus #t))) (define/override (on-kill-focus) - (on-focus #f)) + (if (eq? 'msw (system-type)) + (queue-window-callback + this + (lambda () (on-focus #f))) + (on-focus #f))) (define/public (is-focus-on?) focuson?) From af94e11d19ff99d0d06ad72b6a75333b4d48ad7c Mon Sep 17 00:00:00 2001 From: Matthew Flatt Date: Tue, 19 May 2009 23:58:50 +0000 Subject: [PATCH 14/56] fix trampoline fix svn: r14877 --- collects/mred/private/wxcanvas.ss | 2 +- collects/mred/private/wxme/editor-canvas.ss | 4 ++-- 2 files changed, 3 insertions(+), 3 deletions(-) diff --git a/collects/mred/private/wxcanvas.ss b/collects/mred/private/wxcanvas.ss index 5eb8efe4b3..806328a5a7 100644 --- a/collects/mred/private/wxcanvas.ss +++ b/collects/mred/private/wxcanvas.ss @@ -224,7 +224,7 @@ 0 0 #t #t))) (inherit editor-canvas-on-scroll) (define/override (on-scroll e) - (if (or (eq? 'msw (system-type)) + (if (or (eq? 'windows (system-type)) (eq? 'macosx (system-type))) (queue-window-callback this diff --git a/collects/mred/private/wxme/editor-canvas.ss b/collects/mred/private/wxme/editor-canvas.ss index 7f76ceae94..479337ac73 100644 --- a/collects/mred/private/wxme/editor-canvas.ss +++ b/collects/mred/private/wxme/editor-canvas.ss @@ -351,13 +351,13 @@ (thunk))) (define/override (on-set-focus) - (if (eq? 'msw (system-type)) + (if (eq? 'windows (system-type)) (queue-window-callback this (lambda () (on-focus #t))) (on-focus #t))) (define/override (on-kill-focus) - (if (eq? 'msw (system-type)) + (if (eq? 'windows (system-type)) (queue-window-callback this (lambda () (on-focus #f))) From de5bbaff40bb2a83fb78f821b3f2bb230b2802f5 Mon Sep 17 00:00:00 2001 From: Matthew Flatt Date: Wed, 20 May 2009 00:18:15 +0000 Subject: [PATCH 15/56] fix bug parsing polar notation conbined with #e svn: r14878 --- collects/tests/mzscheme/number.ss | 4 ++++ collects/tests/mzscheme/numstrs.ss | 2 +- src/mzscheme/src/numstr.c | 13 +++++++++---- 3 files changed, 14 insertions(+), 5 deletions(-) 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/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; From 94116052da75bd1674def8aa71036c625cd64b95 Mon Sep 17 00:00:00 2001 From: Matthew Flatt Date: Wed, 20 May 2009 00:19:12 +0000 Subject: [PATCH 16/56] minor guide edits (ok to merge to 4.2) svn: r14879 --- collects/scribblings/guide/chars.scrbl | 2 +- collects/scribblings/guide/lists.scrbl | 17 ++++++++++------- collects/scribblings/guide/simple-syntax.scrbl | 5 +++-- collects/scribblings/guide/truth.scrbl | 2 +- 4 files changed, 15 insertions(+), 11 deletions(-) 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 From dbc7baf5870d81b13893bc61bf00a5935c1f58b5 Mon Sep 17 00:00:00 2001 From: Eli Barzilay Date: Wed, 20 May 2009 07:50:11 +0000 Subject: [PATCH 17/56] Welcome to a new PLT day. svn: r14882 --- collects/repos-time-stamp/stamp.ss | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/collects/repos-time-stamp/stamp.ss b/collects/repos-time-stamp/stamp.ss index bedbbc905e..b51371815d 100644 --- a/collects/repos-time-stamp/stamp.ss +++ b/collects/repos-time-stamp/stamp.ss @@ -1 +1 @@ -#lang scheme/base (provide stamp) (define stamp "19may2009") +#lang scheme/base (provide stamp) (define stamp "20may2009") From 5caffa296a228ff8ab5c3ead6ad9fd2108c2b923 Mon Sep 17 00:00:00 2001 From: Jay McCarthy Date: Wed, 20 May 2009 14:20:53 +0000 Subject: [PATCH 18/56] pr 10236, okay for release svn: r14883 --- collects/web-server/stuffers/hmac-sha1.ss | 30 +++++++++++++---------- 1 file changed, 17 insertions(+), 13 deletions(-) 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 From f23ee1965e5a91d443793457e2017a0156a6c889 Mon Sep 17 00:00:00 2001 From: Matthew Flatt Date: Wed, 20 May 2009 21:24:20 +0000 Subject: [PATCH 19/56] fix Windows/Mac print cleanup svn: r14885 --- src/mred/wxs/wxscheme.cxx | 1 + 1 file changed, 1 insertion(+) 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 From f1d4fe02ea4f7ecb0dfa23d284fe1c05090487e8 Mon Sep 17 00:00:00 2001 From: Matthew Flatt Date: Wed, 20 May 2009 22:05:09 +0000 Subject: [PATCH 20/56] fix Scribble rendering of S-expression graphs svn: r14886 --- collects/scribble/scheme.ss | 105 ++++++++++++++++++++---------------- 1 file changed, 58 insertions(+), 47 deletions(-) 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) From 2e3a0bcd0dc728f8e6b0f59f5b84ae1645d4a42c Mon Sep 17 00:00:00 2001 From: Ryan Culpepper Date: Wed, 20 May 2009 22:43:39 +0000 Subject: [PATCH 21/56] macro debugger: fixed hiding bug with non-collection modules improved #%top-interaction elimination Please apply changes for release. svn: r14887 --- .../macro-debugger/model/hiding-policies.ss | 88 ------------------- collects/macro-debugger/util/mpi.ss | 19 +++- collects/macro-debugger/view/stepper.ss | 9 +- collects/tests/macro-debugger/tests/policy.ss | 4 +- 4 files changed, 25 insertions(+), 95 deletions(-) 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/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/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) From 116d961f357ba745a20301326ae58a42f2e0e9d1 Mon Sep 17 00:00:00 2001 From: John Clements Date: Wed, 20 May 2009 23:59:24 +0000 Subject: [PATCH 22/56] changed comment svn: r14892 --- collects/stepper/view-controller.ss | 5 ++++- 1 file changed, 4 insertions(+), 1 deletion(-) diff --git a/collects/stepper/view-controller.ss b/collects/stepper/view-controller.ss index ff88b74eea..b8a2c8b56f 100644 --- a/collects/stepper/view-controller.ss +++ b/collects/stepper/view-controller.ss @@ -358,7 +358,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 From 6f62f05ed53273463b001cc90174f091b8c154da Mon Sep 17 00:00:00 2001 From: John Clements Date: Thu, 21 May 2009 00:04:17 +0000 Subject: [PATCH 23/56] ... svn: r14893 --- collects/stepper/private/annotate.ss | 40 +++++++++------------------- 1 file changed, 12 insertions(+), 28 deletions(-) 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)) From 44848d349cae5ff7131af366a177ef7d9a131a54 Mon Sep 17 00:00:00 2001 From: Eli Barzilay Date: Thu, 21 May 2009 02:35:00 +0000 Subject: [PATCH 24/56] comment typo svn: r14894 --- collects/mzlib/control.ss | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) 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 From 08858776413a9b5f69465586a3fc3f4d4e41a9d2 Mon Sep 17 00:00:00 2001 From: John Clements Date: Thu, 21 May 2009 05:35:38 +0000 Subject: [PATCH 25/56] ranges for stepper-jump svn: r14895 --- collects/stepper/private/model.ss | 44 +++++++++++++++++++---------- collects/stepper/view-controller.ss | 9 +++++- 2 files changed, 37 insertions(+), 16 deletions(-) diff --git a/collects/stepper/private/model.ss b/collects/stepper/private/model.ss index 65df49dc15..c313090adb 100644 --- a/collects/stepper/private/model.ss +++ b/collects/stepper/private/model.ss @@ -11,7 +11,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 @@ -72,6 +72,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 +100,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 +221,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 +256,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 +275,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 +295,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 +337,13 @@ (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/view-controller.ss b/collects/stepper/view-controller.ss index b8a2c8b56f..4b571f6037 100644 --- a/collects/stepper/view-controller.ss +++ b/collects/stepper/view-controller.ss @@ -169,8 +169,15 @@ ;; is this step on the selected expression? (define (selected-exp-step? history-entry) - (member selection-posn (step-posns history-entry))) + (ormap (posn-in-span selection-posn) (step-posns history-entry))) + (define ((posn-in-span selection-posn) source-posn-info) + (match source-posn-info + [#f #f] + [(struct model:posn-info (posn span)) + (and posn + (<= posn selection-posn) + (< selection-posn (+ posn span)))])) ;; build gui object: From 78f1b0c9a4f0e7ecc02c93a2f3a98dca274ba214 Mon Sep 17 00:00:00 2001 From: Matthew Flatt Date: Thu, 21 May 2009 11:20:36 +0000 Subject: [PATCH 26/56] remove reundant and slightly wrong 'declare-exporting' in deinprogramm doc svn: r14896 --- collects/deinprogramm/scribblings/image.scrbl | 2 -- 1 file changed, 2 deletions(-) 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. } From 76c743c5e6386d56d4876a281df7951779c9fa8b Mon Sep 17 00:00:00 2001 From: Matthias Felleisen Date: Thu, 21 May 2009 12:53:05 +0000 Subject: [PATCH 27/56] 4.2. note on universe API, please propagate svn: r14897 --- doc/release-notes/teachpack/HISTORY.txt | 7 +++++++ 1 file changed, 7 insertions(+) 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] From 5e6360b2e38cad45d900e6cf9a33bcc507ba79ae Mon Sep 17 00:00:00 2001 From: Mike Sperber Date: Thu, 21 May 2009 15:51:46 +0000 Subject: [PATCH 28/56] Some updates to the deinprogramm tests: - use schemeunit from collects - tp-exn? is no more svn: r14898 --- collects/tests/deinprogramm/contract.ss | 2 +- collects/tests/deinprogramm/image.ss | 4 ++-- collects/tests/deinprogramm/run-contract-tests.ss | 2 +- 3 files changed, 4 insertions(+), 4 deletions(-) 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 From 4c367c477804efad29f21f4c11ea5a40bf78ce3e Mon Sep 17 00:00:00 2001 From: Mike Sperber Date: Thu, 21 May 2009 15:56:55 +0000 Subject: [PATCH 29/56] One more schemeunit update. svn: r14899 --- collects/tests/deinprogramm/run-image-test.ss | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/collects/tests/deinprogramm/run-image-test.ss b/collects/tests/deinprogramm/run-image-test.ss index 06215561da..db24d3a1bd 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 From 975b8256385276c386ba694d5f47970323ed98c3 Mon Sep 17 00:00:00 2001 From: Mike Sperber Date: Thu, 21 May 2009 15:57:40 +0000 Subject: [PATCH 30/56] Fix paren typo. svn: r14900 --- collects/tests/deinprogramm/run-image-test.ss | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/collects/tests/deinprogramm/run-image-test.ss b/collects/tests/deinprogramm/run-image-test.ss index db24d3a1bd..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 schemeunit/text-ui)) +(require schemeunit/text-ui) (require tests/deinprogramm/image) (run-tests all-image-tests) \ No newline at end of file From 6cf91e6dd348fdf1e1e56d3e67bc9c53f2f237a1 Mon Sep 17 00:00:00 2001 From: Matthew Flatt Date: Thu, 21 May 2009 16:13:42 +0000 Subject: [PATCH 31/56] put local -I flags before CFLAGS in Makefiles svn: r14901 --- src/mred/Makefile.in | 18 +++++++++--------- src/mzscheme/Makefile.in | 4 ++-- src/mzscheme/gc2/Makefile.in | 5 +++-- src/mzscheme/src/Makefile.in | 2 +- 4 files changed, 15 insertions(+), 14 deletions(-) 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/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/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/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@ \ From 732e93b9dc5a1e589af6355228ff47313682d0f4 Mon Sep 17 00:00:00 2001 From: Stevie Strickland Date: Thu, 21 May 2009 16:36:36 +0000 Subject: [PATCH 32/56] Fix open so that it respects contracts. svn: r14902 --- collects/mzlib/unit.ss | 10 ++++++++-- 1 file changed, 8 insertions(+), 2 deletions(-) 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) ...))))) From ef15fd2dede31a5b61e55c29b8967b6fdb6cf10c Mon Sep 17 00:00:00 2001 From: Matthias Felleisen Date: Thu, 21 May 2009 16:37:13 +0000 Subject: [PATCH 33/56] error in mred linking fixed, please propagate svn: r14903 --- collects/htdp/big-draw.ss | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) 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^) From 99c159a7276d16b6aa809df64e2b655984ba6081 Mon Sep 17 00:00:00 2001 From: Matthew Flatt Date: Thu, 21 May 2009 19:25:51 +0000 Subject: [PATCH 34/56] adjust configure script to disable --prefix on Mac OS X unless either --enable-xonx or --enable-macprefix is also provided svn: r14904 --- src/configure | 17 +++++++++++++++++ src/mzscheme/configure.ac | 12 ++++++++++++ 2 files changed, 29 insertions(+) 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/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 From 5e84de91664f2959148d147ed1989746e5e181b7 Mon Sep 17 00:00:00 2001 From: Robby Findler Date: Thu, 21 May 2009 20:14:03 +0000 Subject: [PATCH 35/56] stupid bug that only breaks the test suite sometimes svn: r14905 --- collects/tests/framework/test-suite-utils.ss | 5 +++-- 1 file changed, 3 insertions(+), 2 deletions(-) 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)))) From 5e79293e91e4d023ad3420202a5799a41d8d98a3 Mon Sep 17 00:00:00 2001 From: Robby Findler Date: Thu, 21 May 2009 20:21:11 +0000 Subject: [PATCH 36/56] svn: r14906 --- collects/games/chat-noir/README | 21 --------------------- 1 file changed, 21 deletions(-) delete mode 100644 collects/games/chat-noir/README 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 From 5db9f1c03c83f28893b2a495a66cf58e0fdc3868 Mon Sep 17 00:00:00 2001 From: Robby Findler Date: Thu, 21 May 2009 20:32:30 +0000 Subject: [PATCH 37/56] updated to new universe teachpack svn: r14907 --- .../games/chat-noir/chat-noir-literate.ss | 22 +++++++++---------- 1 file changed, 11 insertions(+), 11 deletions(-) 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))] From 5ed62e665b8bc5b15efa06af7b235570f7b1f028 Mon Sep 17 00:00:00 2001 From: Matthias Felleisen Date: Thu, 21 May 2009 20:40:46 +0000 Subject: [PATCH 38/56] typo fixed svn: r14908 --- collects/teachpack/2htdp/scribblings/universe.scrbl | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) 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[ From a4d87e926ece38b020aad3d4fe1652415a8e212a Mon Sep 17 00:00:00 2001 From: Robby Findler Date: Thu, 21 May 2009 20:50:03 +0000 Subject: [PATCH 39/56] fixed a bug svn: r14909 --- collects/tests/drscheme/drscheme-test-util.ss | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) 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) From c7abe12040a0e9522c445b3c58aa4798c9c20509 Mon Sep 17 00:00:00 2001 From: Robby Findler Date: Thu, 21 May 2009 20:51:24 +0000 Subject: [PATCH 40/56] svn: r14910 --- doc/release-notes/drscheme/HISTORY.txt | 6 ++++++ 1 file changed, 6 insertions(+) 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 ------------------------------ From ae0a69f16258d86232d5ee1cd11d185fe9c54f1c Mon Sep 17 00:00:00 2001 From: Robby Findler Date: Thu, 21 May 2009 20:53:12 +0000 Subject: [PATCH 41/56] svn: r14911 --- doc/release-notes/redex/HISTORY.txt | 4 ++++ 1 file changed, 4 insertions(+) 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-->> From 2f6b57217850bd38c7198ac87609fc8d28f09740 Mon Sep 17 00:00:00 2001 From: Matthew Flatt Date: Thu, 21 May 2009 22:49:34 +0000 Subject: [PATCH 42/56] fix problem with tab-snip% width checking svn: r14912 --- collects/mred/private/wxme/mline.ss | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/collects/mred/private/wxme/mline.ss b/collects/mred/private/wxme/mline.ss index 69808385b9..396bc9b154 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)))))]) From 5be3d8d2f73f538cfd8df0eca3f355b91e65f123 Mon Sep 17 00:00:00 2001 From: Robby Findler Date: Thu, 21 May 2009 23:17:45 +0000 Subject: [PATCH 43/56] changed the checkpoint computation to avoid interfereing with other parameters svn: r14913 --- collects/drscheme/private/rep.ss | 12 ++++++------ 1 file changed, 6 insertions(+), 6 deletions(-) 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) From bf001f811de9389e5c485a953d6134847bcf7258 Mon Sep 17 00:00:00 2001 From: Ryan Culpepper Date: Fri, 22 May 2009 00:39:13 +0000 Subject: [PATCH 44/56] macro-debugger: disable lift errors Do not apply to release branch. svn: r14914 --- collects/macro-debugger/model/reductions.ss | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) 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 From d1a88fadde9055da88cf9fe71135d3ad3c14ce68 Mon Sep 17 00:00:00 2001 From: Robby Findler Date: Fri, 22 May 2009 01:55:48 +0000 Subject: [PATCH 45/56] fixed image equality svn: r14917 --- collects/mred/private/wxme/snip.ss | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/collects/mred/private/wxme/snip.ss b/collects/mred/private/wxme/snip.ss index 22b4c0daf5..2dc49e8032 100644 --- a/collects/mred/private/wxme/snip.ss +++ b/collects/mred/private/wxme/snip.ss @@ -1104,7 +1104,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) From ac9fa2e979461720a468377e1055d57d69559f80 Mon Sep 17 00:00:00 2001 From: Robby Findler Date: Fri, 22 May 2009 01:59:02 +0000 Subject: [PATCH 46/56] svn: r14918 --- collects/tests/drscheme/repl-test.ss | 44 ++++++++++++++-------------- 1 file changed, 22 insertions(+), 22 deletions(-) diff --git a/collects/tests/drscheme/repl-test.ss b/collects/tests/drscheme/repl-test.ss index f08844e992..906f7a598e 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:246:28: define-values: cannot change constant identifier: \\+" + #rx"{stop-multi.png} {stop-22x22.png} ../../mred/private/snipfile.ss:246:28: 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 From e878e2843cd101c6bcb5792bae25a1f2ee9083e5 Mon Sep 17 00:00:00 2001 From: Eli Barzilay Date: Fri, 22 May 2009 07:50:22 +0000 Subject: [PATCH 47/56] Welcome to a new PLT day. svn: r14919 --- collects/repos-time-stamp/stamp.ss | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/collects/repos-time-stamp/stamp.ss b/collects/repos-time-stamp/stamp.ss index b51371815d..85849971ab 100644 --- a/collects/repos-time-stamp/stamp.ss +++ b/collects/repos-time-stamp/stamp.ss @@ -1 +1 @@ -#lang scheme/base (provide stamp) (define stamp "20may2009") +#lang scheme/base (provide stamp) (define stamp "22may2009") From c1cc6328a57365520527449236934c15f6393dbc Mon Sep 17 00:00:00 2001 From: Kathy Gray Date: Fri, 22 May 2009 15:23:29 +0000 Subject: [PATCH 48/56] Removed write to display-reason svn: r14920 --- collects/test-engine/test-display.scm | 4 ++-- 1 file changed, 2 insertions(+), 2 deletions(-) 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) From 0b9730158ea1c422863e3c635f80bd4a5c3902d5 Mon Sep 17 00:00:00 2001 From: Matthew Flatt Date: Fri, 22 May 2009 16:24:17 +0000 Subject: [PATCH 49/56] fix editor bugs related to line-wrapping, tab insertion, and pasting to the end of an editor that has been line-wrapped in the past (merge to 4.2) svn: r14921 --- collects/mred/private/syntax.ss | 7 +- collects/mred/private/wxme/editor-snip.ss | 12 ++- collects/mred/private/wxme/mline.ss | 19 +++-- collects/mred/private/wxme/private.ss | 3 +- collects/mred/private/wxme/snip.ss | 6 +- collects/mred/private/wxme/text.ss | 89 ++++++++++++++++++----- collects/tests/mred/wxme-random.ss | 63 ++++++++++++---- collects/tests/mred/wxme.ss | 5 +- 8 files changed, 157 insertions(+), 47 deletions(-) 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/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/mline.ss b/collects/mred/private/wxme/mline.ss index 396bc9b154..3365ff49e3 100644 --- a/collects/mred/private/wxme/mline.ss +++ b/collects/mred/private/wxme/mline.ss @@ -923,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)))) @@ -941,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)]) @@ -972,14 +976,15 @@ Debugging tools: (snips-to-line! newline) (notify-insert newline)) - ;; just pushed to next line + ;; 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)))) @@ -1001,7 +1006,7 @@ Debugging tools: (notify-delete next) #t) #f)) - (define (do-extend-line asnip) + (define (do-extend-line mline asnip) ;; this line was extended (let ([asnip (if asnip diff --git a/collects/mred/private/wxme/private.ss b/collects/mred/private/wxme/private.ss index ce459291e5..ddfd3642e3 100644 --- a/collects/mred/private/wxme/private.ss +++ b/collects/mred/private/wxme/private.ss @@ -98,7 +98,8 @@ 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.ss b/collects/mred/private/wxme/snip.ss index 2dc49e8032..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 diff --git a/collects/mred/private/wxme/text.ss b/collects/mred/private/wxme/text.ss index 9d809310f9..b4d21c1911 100644 --- a/collects/mred/private/wxme/text.ss +++ b/collects/mred/private/wxme/text.ss @@ -238,6 +238,33 @@ (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) @@ -1184,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)) @@ -1278,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]) @@ -1317,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?)) @@ -1352,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)) @@ -1413,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?) @@ -1526,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) @@ -1607,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)) @@ -1683,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) @@ -1774,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? @@ -1789,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) @@ -1815,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)) @@ -1900,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 @@ -3514,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 @@ -3640,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]] @@ -4507,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 @@ -4570,17 +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 - (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)))) + (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/tests/mred/wxme-random.ss b/collects/tests/mred/wxme-random.ss index 03b7b81215..3e8b0df412 100644 --- a/collects/tests/mred/wxme-random.ss +++ b/collects/tests/mred/wxme-random.ss @@ -8,7 +8,10 @@ (define orig-t (new text%)) (define frame - (new frame% [label "Test"] + (new (class frame% + (define/augment (on-close) (exit)) + (super-new)) + [label "Test"] [width 300] [height 400])) (define canvas @@ -24,16 +27,39 @@ (vector-ref v (random (vector-length v)))) (define (random-string) - (random-elem '#("a" "x\ny\nz\n" "hello there"))) + (random-elem '#("a" "x\ny\nz\n" "(define (f x)\n (+ x x))\n" "hello there"))) (define seqs (make-hasheq)) -(define ts (make-weak-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)))))) @@ -50,27 +76,38 @@ (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) (send t copy)) - (lambda (t) (send t cut)) - (lambda (t) (send t paste)) + (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%)]) - (hash-set! ts t2 #t) + (add-t! t2) (init t2) (send t insert (make-object editor-snip% t2)))) (lambda (t) - (send t set-max-width (if (zero? (random 2)) 100.0 'none))) + (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 - (for/fold ([t orig-t]) - ([t (in-hash-keys ts)] - [n (in-range (random (add1 (hash-count ts))))]) - t))]) - (printf "~s: ~s\n" seed act) + (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")) From 24af2c638fb9665e274f14f87653f2e81dcfa6c2 Mon Sep 17 00:00:00 2001 From: Matthew Flatt Date: Fri, 22 May 2009 17:13:02 +0000 Subject: [PATCH 50/56] fix Mac GC problem related to clipboard clients (merge to 4.2) svn: r14922 --- src/wxcommon/wb_list.cxx | 6 +++++- 1 file changed, 5 insertions(+), 1 deletion(-) 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; } From 142a990a46b4051e56a0ba736c0916ea74f39831 Mon Sep 17 00:00:00 2001 From: John Clements Date: Fri, 22 May 2009 17:53:28 +0000 Subject: [PATCH 51/56] eliminated extra arg to error-result construction svn: r14923 --- collects/stepper/private/model.ss | 4 ++-- 1 file changed, 2 insertions(+), 2 deletions(-) diff --git a/collects/stepper/private/model.ss b/collects/stepper/private/model.ss index c313090adb..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) @@ -35,7 +37,6 @@ ; double(x) : ERROR ; late-let(x) : ERROR -#lang scheme/base (require scheme/contract scheme/match @@ -342,7 +343,6 @@ (receive-result (make-before-error-result (append held-finished-list exps) message - #f posn-info)) (set! held-exp-list the-no-sexp))])) From d3665169e49b0255a2762e308a79818692473f8a Mon Sep 17 00:00:00 2001 From: Matthew Flatt Date: Fri, 22 May 2009 18:29:20 +0000 Subject: [PATCH 52/56] fix typo (PR 10253) (merge to 4.2) svn: r14925 --- collects/plot/plot.scrbl | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) 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))) From 0666e79327adf1d8cf4d6edf563896b0e9115cd0 Mon Sep 17 00:00:00 2001 From: John Clements Date: Fri, 22 May 2009 18:40:33 +0000 Subject: [PATCH 53/56] ... svn: r14926 --- collects/stepper/stepper-tool.ss | 3 +- collects/stepper/view-controller.ss | 55 ++++++++++++++++++++++------- 2 files changed, 45 insertions(+), 13 deletions(-) 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 4b571f6037..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,16 +169,8 @@ ;; is this step on the selected expression? (define (selected-exp-step? history-entry) - (ormap (posn-in-span selection-posn) (step-posns history-entry))) - - (define ((posn-in-span selection-posn) source-posn-info) - (match source-posn-info - [#f #f] - [(struct model:posn-info (posn span)) - (and posn - (<= posn selection-posn) - (< selection-posn (+ posn span)))])) - + (ormap (span-overlap selection-start selection-end) (step-posns history-entry))) + ;; build gui object: @@ -304,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% @@ -398,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 From 611f1d1efdc2b07234da53fe68114f09896b806c Mon Sep 17 00:00:00 2001 From: Robby Findler Date: Fri, 22 May 2009 18:45:20 +0000 Subject: [PATCH 54/56] svn: r14927 --- collects/tests/drscheme/repl-test.ss | 4 ++-- 1 file changed, 2 insertions(+), 2 deletions(-) diff --git a/collects/tests/drscheme/repl-test.ss b/collects/tests/drscheme/repl-test.ss index 906f7a598e..7130be894e 100644 --- a/collects/tests/drscheme/repl-test.ss +++ b/collects/tests/drscheme/repl-test.ss @@ -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: +" - #rx"{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: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 From f496a353dbcc7494b95cda7669f51d9ed643e777 Mon Sep 17 00:00:00 2001 From: Matthew Flatt Date: Fri, 22 May 2009 19:18:07 +0000 Subject: [PATCH 55/56] fix MrEd -h, etc. reporting under Mac OS X svn: r14931 --- src/mred/mred.cxx | 5 +++++ src/mred/mred.h | 2 +- 2 files changed, 6 insertions(+), 1 deletion(-) 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 From b087ce2765b42ff7d4b33facfe12b613312b37ab Mon Sep 17 00:00:00 2001 From: Robby Findler Date: Fri, 22 May 2009 19:19:40 +0000 Subject: [PATCH 56/56] fixed a bug in metafunctions svn: r14932 --- collects/redex/private/reduction-semantics.ss | 2 +- collects/redex/private/tl-test.ss | 16 ++++++++++++++++ 2 files changed, 17 insertions(+), 1 deletion(-) diff --git a/collects/redex/private/reduction-semantics.ss b/collects/redex/private/reduction-semantics.ss index 90385eb9c0..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 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 ()