diff --git a/collects/2htdp/image.rkt b/collects/2htdp/image.rkt index 80502263d2..667b56ab60 100644 --- a/collects/2htdp/image.rkt +++ b/collects/2htdp/image.rkt @@ -105,6 +105,7 @@ and they all have good sample contracts. (It is amazing what we can do with kids scene+curve text text/font + image->color-list color-list->bitmap @@ -139,7 +140,8 @@ and they all have good sample contracts. (It is amazing what we can do with kids step-count? save-image) -(provide bitmap) +(provide bitmap + empty-image) (define-primitive make-color build-color/make-color) (define-primitive color build-color/color) diff --git a/collects/2htdp/private/image-more.rkt b/collects/2htdp/private/image-more.rkt index b1b511c864..9d33136a6f 100644 --- a/collects/2htdp/private/image-more.rkt +++ b/collects/2htdp/private/image-more.rkt @@ -707,15 +707,15 @@ (let ([bitmap (flip-shape atomic-shape)] [flipped? (flip-flipped? atomic-shape)]) (make-flip flipped? - (make-bitmap (ibitmap-raw-bitmap bitmap) - (ibitmap-raw-mask bitmap) - (bring-between (if flipped? - (+ (ibitmap-angle bitmap) θ) - (- (ibitmap-angle bitmap) θ)) - 360) - (ibitmap-x-scale bitmap) - (ibitmap-y-scale bitmap) - (make-hash))))])) + (make-ibitmap (ibitmap-raw-bitmap bitmap) + (ibitmap-raw-mask bitmap) + (bring-between (if flipped? + (+ (ibitmap-angle bitmap) θ) + (- (ibitmap-angle bitmap) θ)) + 360) + (ibitmap-x-scale bitmap) + (ibitmap-y-scale bitmap) + (make-hash))))])) ;; rotate-point : point angle -> point (define (rotate-point p θ) @@ -1171,6 +1171,8 @@ [(zero? b) a] [else (gcd b (modulo a b))])) + + ;; swizzle : (listof X)[odd-length] -> (listof X) ;; returns a list with the same elements, ;; but reordered according to the step. Eg, if the step @@ -1212,6 +1214,8 @@ (make-bb w/h w/h w/h) #f))) +(define empty-image (rectangle 0 0 'solid 'black)) + (define/chk (image-width image) (bb-select/round/exact bb-right image)) (define/chk (image-height image) (bb-select/round/exact bb-bottom image)) (define/chk (image-baseline image) (bb-select/round/exact bb-baseline image)) @@ -1367,6 +1371,7 @@ empty-scene square rhombus + empty-image polygon regular-polygon diff --git a/collects/2htdp/private/world.rkt b/collects/2htdp/private/world.rkt index 6a1d772bd0..1bdc37a427 100644 --- a/collects/2htdp/private/world.rkt +++ b/collects/2htdp/private/world.rkt @@ -211,9 +211,15 @@ (let ([s (send visible find-first-snip)] [c (send visible get-canvas)]) (when s (send visible delete s)) - (send visible insert (send pict copy) 0 0)) - (send visible lock #t) - (send visible end-edit-sequence)) + (send visible insert (send pict copy) 0 0) + (send visible lock #t) + (send visible end-edit-sequence) + ;; The following flush trades streaming performance (where updates + ;; could be skipped if they're replaced fast enough) for + ;; responsiveness (where too many updates might not get + ;; through if the canvas is mostly in suspended-refresh + ;; mode for scene changes): + (send c flush))) ;; ---------------------------------------------------------------------- ;; callbacks @@ -257,14 +263,17 @@ (begin (set! nw (stop-the-world-world nw)) (send world set tag nw) - (when last-picture (last-draw)) - (when draw (pdraw)) + (cond + [last-picture (last-draw)] + [draw (pdraw)]) (callback-stop! 'name) (enable-images-button)) - (let ([changed-world? (send world set tag nw)]) + (let ([changed-world? (send world set tag nw)] + [stop? (pstop)]) ;; this is the old "Robby optimization" see checked-cell: ; unless changed-world? - (when draw + (cond + [(and draw (not stop?)) (cond [(not drawing) (set! drawing #t) @@ -279,11 +288,13 @@ ;; high!! the scheduled callback didn't fire (queue-callback (lambda () (d)) #t)] [else - (set! draw# (- draw# 1))])) - (when (pstop) - (when last-picture (last-draw)) - (callback-stop! 'name) - (enable-images-button)) + (set! draw# (- draw# 1))])] + [stop? + (cond + [last-picture (last-draw)] + [draw (pdraw)]) + (callback-stop! 'name) + (enable-images-button)]) changed-world?)))))))) ;; tick, tock : deal with a tick event for this world diff --git a/collects/2htdp/tests/test-image.rkt b/collects/2htdp/tests/test-image.rkt index ae0f11ad0e..f5d8123546 100644 --- a/collects/2htdp/tests/test-image.rkt +++ b/collects/2htdp/tests/test-image.rkt @@ -156,6 +156,15 @@ => 0) +(test (image-width empty-image) => 0) +(test (image-height empty-image) => 0) +(test (equal? (above empty-image + (rectangle 10 10 "solid" "red")) + (beside empty-image + (rectangle 10 10 "solid" "red"))) + => + #t) + (check-close (image-width (rotate 45 (rectangle 100 0 'solid 'blue))) (inexact->exact (ceiling (* (sin (* pi 1/4)) 100)))) (check-close (image-height (rotate 45 (rectangle 100 0 'solid 'blue))) @@ -1220,8 +1229,8 @@ 16) (test (let () - (define bmp (make-object bitmap% 4 4)) - (define mask (make-object bitmap% 4 4)) + (define bmp (make-bitmap 4 4)) + (define mask (make-bitmap 4 4)) (define bdc (make-object bitmap-dc% bmp)) (send bdc set-brush "black" 'solid) (send bdc draw-rectangle 0 0 4 4) @@ -1233,13 +1242,13 @@ (let-values ([(bytes w h) (bitmap->bytes bmp mask)]) bytes)) => - (bytes-append #"\0\0\0\0" #"\0\0\0\0" #"\0\0\0\0" #"\0\0\0\0" - #"\0\0\0\0" #"\377\0\0\0" #"\0\0\0\0" #"\0\0\0\0" - #"\0\0\0\0" #"\0\0\0\0" #"\0\0\0\0" #"\0\0\0\0" - #"\0\0\0\0" #"\0\0\0\0" #"\0\0\0\0" #"\0\0\0\0")) + (bytes-append #"\377\0\0\0" #"\377\0\0\0" #"\377\0\0\0" #"\377\0\0\0" + #"\377\0\0\0" #"\377\0\0\0" #"\377\0\0\0" #"\377\0\0\0" + #"\377\0\0\0" #"\377\0\0\0" #"\377\0\0\0" #"\377\0\0\0" + #"\377\0\0\0" #"\377\0\0\0" #"\377\0\0\0" #"\377\0\0\0")) ;; ensure no error -(test (begin (scale 2 (make-object bitmap% 10 10)) +(test (begin (scale 2 (make-bitmap 10 10)) (void)) => (void)) @@ -1252,18 +1261,18 @@ (send bdc draw-rectangle x y w h) (send bdc set-bitmap #f))) -(define blue-10x20-bitmap (make-object bitmap% 10 20)) +(define blue-10x20-bitmap (make-bitmap 10 20)) (fill-bitmap blue-10x20-bitmap "blue") -(define blue-20x10-bitmap (make-object bitmap% 20 10)) +(define blue-20x10-bitmap (make-bitmap 20 10)) (fill-bitmap blue-20x10-bitmap "blue") -(define blue-20x40-bitmap (make-object bitmap% 20 40)) +(define blue-20x40-bitmap (make-bitmap 20 40)) (fill-bitmap blue-20x40-bitmap "blue") -(define green-blue-10x20-bitmap (make-object bitmap% 10 20)) +(define green-blue-10x20-bitmap (make-bitmap 10 20)) (fill-bitmap green-blue-10x20-bitmap "green") (fill-bitmap green-blue-10x20-bitmap "blue" 0 0 10 10) -(define green-blue-20x10-bitmap (make-object bitmap% 20 10)) +(define green-blue-20x10-bitmap (make-bitmap 20 10)) (fill-bitmap green-blue-20x10-bitmap "green") (fill-bitmap green-blue-20x10-bitmap "blue" 10 0 10 10) @@ -1276,9 +1285,6 @@ (test (image-baseline (image-snip->image (make-object image-snip% blue-10x20-bitmap))) => 20) -(test (scale 2 (make-object image-snip% blue-10x20-bitmap)) - => - (image-snip->image (make-object image-snip% blue-20x40-bitmap))) (test (rotate 90 (make-object image-snip% blue-10x20-bitmap)) => @@ -1480,9 +1486,9 @@ "white")) (let* ([bdc (make-object bitmap-dc%)] - [bm-ul (make-object bitmap% 10 10)] - [bm-ur (make-object bitmap% 10 10)] - [bm-ll (make-object bitmap% 10 10)]) + [bm-ul (make-bitmap 10 10)] + [bm-ur (make-bitmap 10 10)] + [bm-ll (make-bitmap 10 10)]) (send bdc set-bitmap bm-ul) (send bdc set-pen "red" 1 'transparent) (send bdc set-brush "red" 'solid) @@ -2145,8 +2151,8 @@ (let () (define w 200) (define h 200) - (define bm1 (make-object bitmap% w h)) - (define bm2 (make-object bitmap% w h)) + (define bm1 (make-bitmap w h)) + (define bm2 (make-bitmap w h)) (define bytes1 (make-bytes (* w h 4) 0)) (define bytes2 (make-bytes (* w h 4) 0)) (define bdc1 (make-object bitmap-dc% bm1)) diff --git a/collects/2htdp/universe.rkt b/collects/2htdp/universe.rkt index 1b0e22344c..791f5a68c3 100644 --- a/collects/2htdp/universe.rkt +++ b/collects/2htdp/universe.rkt @@ -230,7 +230,7 @@ (define (run-simulation f) (check-proc 'run-simulation f 1 "first" "one argument") - (big-bang 1 (on-draw f) (on-tick add1))) + (big-bang 0 (on-draw f) (on-tick add1))) (define animate run-simulation) diff --git a/collects/data/gvector.rkt b/collects/data/gvector.rkt index 07de71a87a..45a339d31d 100644 --- a/collects/data/gvector.rkt +++ b/collects/data/gvector.rkt @@ -119,7 +119,7 @@ (in-dict-values gv)) (define-sequence-syntax in-gvector* - (lambda () #'in-vector) + (lambda () #'in-gvector) (lambda (stx) (syntax-case stx () [[(var) (in-gv gv-expr)] @@ -137,7 +137,7 @@ [[(var ...) (in-gv gv-expr)] (with-syntax ([gv-expr-c (wrap-expr/c #'gvector? #'gv-expr #:macro #'in-gv)]) (syntax/loc stx - [(var ...) (in-vector gv-expr-c)]))] + [(var ...) (in-gvector gv-expr-c)]))] [_ #f]))) (define-syntax (for/gvector stx) diff --git a/collects/data/queue.rkt b/collects/data/queue.rkt index 6c733178d1..6c40dfd1d1 100644 --- a/collects/data/queue.rkt +++ b/collects/data/queue.rkt @@ -1,6 +1,9 @@ #lang racket/base -;; A Queue contains a linked list with mutable cdrs, hoding two pointers +(require (for-syntax racket/base + unstable/wrapc)) + +;; A Queue contains a linked list with mutable cdrs, holding two pointers ;; to the head and the tail -- where items are pulled from the head and ;; pushed on the tail. It is not thread safe: mutating a queue from ;; different threads can break it. @@ -31,6 +34,52 @@ (set-queue-head! q (link-tail old)) (link-value old))) +(define (queue->list queue) + (let loop ([link (queue-head queue)] + [out '()]) + (if (not link) + (reverse out) + (loop (link-tail link) (cons (link-value link) out))))) + +;; queue->vector could be implemented as (list->vector (queue->list q)) +;; but this is somewhat slow. a direct translation between queue's and +;; vector's should be fast so the ideal situation is not to use a list +;; as an intermediate data structure. +;; maybe add the elements to a gvector and use gvector->vector? + +;; could use (length (queue->list q)) here but that would double +;; the time it takes to get the length +;; probably if `queue->vector' gets implemented it would be better to +;; do (vector-length (queue->vector q)) +(define (queue-length queue) + (let loop ([link (queue-head queue)] + [count 0]) + (if (not link) + count + (loop (link-tail link) (add1 count))))) + +(define (in-queue queue) + (in-list (queue->list queue))) + +(define-sequence-syntax in-queue* + (lambda () #'in-queue) + (lambda (stx) + (syntax-case stx () + ([(var) (in-queue* queue-expression)] + (with-syntax ([queue-expression/c (wrap-expr/c #'queue? #'queue-expression + #:macro #'in-queue*)]) + #'[(var) + (:do-in ([(queue) queue-expression/c]) + (void) ;; handled by contract + ([link (queue-head queue)]) + link + ([(var) (link-value link)]) + #t + #t + ((link-tail link)))])) + ([(var ...) (in-queue* queue-expression)] + #f)))) + ;; --- contracts --- (require racket/contract) @@ -48,6 +97,8 @@ [nonempty-queue/c flat-contract?] [queue? (-> any/c boolean?)] [make-queue (-> queue/c)] - [queue-empty? (-> queue/c boolean?)]) + [queue-empty? (-> queue/c boolean?)] + [queue-length (-> queue/c integer?)] + [queue->list (-> queue/c (listof any/c))]) -(provide enqueue! dequeue!) +(provide enqueue! dequeue! (rename-out [in-queue* in-queue])) diff --git a/collects/data/scribblings/queue.scrbl b/collects/data/scribblings/queue.scrbl index b6f8ecd850..ed2650e7df 100644 --- a/collects/data/scribblings/queue.scrbl +++ b/collects/data/scribblings/queue.scrbl @@ -34,6 +34,31 @@ thread-unsafe way. (dequeue! q)] } +@defproc[(queue->list [queue queue/c]) (listof any/c)]{ + Returns an immutable list containing the elements of the queue + in the order the elements were added. + + @defexamples[#:eval qeval + (define queue (make-queue)) + (enqueue! queue 8) + (enqueue! queue 9) + (enqueue! queue 0) + (queue->list queue)] +} + +@defproc[(queue-length [queue queue/c]) integer?]{ + Returns the number of elements in the queue. + + @defexamples[#:eval qeval + (define queue (make-queue)) + (queue-length queue) + (enqueue! queue 5) + (enqueue! queue 12) + (queue-length queue) + (dequeue! queue) + (queue-length queue)] +} + @defproc[(queue-empty? [q queue/c]) boolean?]{ Recognizes whether a queue is empty or not. @@ -54,6 +79,13 @@ thread-unsafe way. (queue? 'not-a-queue)] } +@defproc[(in-queue [queue queue?]) + sequence?]{ + +Returns a sequence whose elements are the elements of +@racket[queue]. +} + @deftogether[( @defthing[queue/c flat-contract?] @defthing[nonempty-queue/c flat-contract?] diff --git a/collects/deinprogramm/DMdA.rkt b/collects/deinprogramm/DMdA.rkt index b00016acd1..c8a524d9b4 100644 --- a/collects/deinprogramm/DMdA.rkt +++ b/collects/deinprogramm/DMdA.rkt @@ -79,7 +79,7 @@ (provide-and-document procedures ("Zahlen" - (number? (%a -> boolean) + (number? (any -> boolean) "feststellen, ob ein Wert eine Zahl ist") (= (number number number ... -> boolean) @@ -141,9 +141,9 @@ (exact? (number -> boolean) "feststellen, ob eine Zahl exakt ist") - (integer? (%a -> boolean) + (integer? (any -> boolean) "feststellen, ob ein Wert eine ganze Zahl ist") - (natural? (%a -> boolean) + (natural? (any -> boolean) "feststellen, ob ein Wert eine natürliche Zahl (inkl. 0) ist") (zero? (number -> boolean) @@ -157,13 +157,13 @@ (even? (integer -> boolean) "feststellen, ob eine Zahl gerade ist") - (lcm (integer integer ... -> integer) + (lcm (integer integer ... -> natural) "kleinstes gemeinsames Vielfaches berechnen") - (gcd (integer integer ... -> integer) + (gcd (integer integer ... -> natural) "größten gemeinsamen Teiler berechnen") - (rational? (%a -> boolean) + (rational? (any -> boolean) "feststellen, ob eine Zahl rational ist") (numerator (rational -> integer) @@ -175,7 +175,7 @@ (inexact? (number -> boolean) "feststellen, ob eine Zahl inexakt ist") - (real? (%a -> boolean) + (real? (any -> boolean) "feststellen, ob ein Wert eine reelle Zahl ist") (floor (real -> integer) @@ -187,7 +187,7 @@ (round (real -> integer) "relle Zahl auf eine ganze Zahl runden") - (complex? (%a -> boolean) + (complex? (any -> boolean) "feststellen, ob ein Wert eine komplexe Zahl ist") (make-polar (real real -> number) @@ -216,7 +216,7 @@ (number->string (number -> string) "Zahl in Zeichenkette umwandeln") - (string->number (string -> (mixed number (one-of #f))) + (string->number (string -> (mixed number false)) "Zeichenkette in Zahl umwandeln, falls möglich") (random (natural -> natural) @@ -226,7 +226,7 @@ "aktuelle Zeit in Sekunden seit einem unspezifizierten Startzeitpunkt berechnen")) ("boolesche Werte" - (boolean? (%a -> boolean) + (boolean? (any -> boolean) "feststellen, ob ein Wert ein boolescher Wert ist") ((DMdA-not not) (boolean -> boolean) @@ -235,45 +235,45 @@ (boolean=? (boolean boolean -> boolean) "Booleans auf Gleichheit testen") - (true? (%a -> boolean) + (true? (any -> boolean) "feststellen, ob ein Wert #t ist") - (false? (%a -> boolean) + (false? (any -> boolean) "feststellen, ob ein Wert #f ist")) ("Listen" (empty list "die leere Liste") - (make-pair (%a (list %a) -> (list %a)) + (make-pair (%a (list-of %a) -> (list-of %a)) "erzeuge ein Paar aus Element und Liste") - ((DMdA-cons cons) (%a -> boolean) + ((DMdA-cons cons) (%a (list-of %a) -> (list-of %a)) "erzeuge ein Paar aus Element und Liste") - (pair? (%a -> boolean) + (pair? (any -> boolean) "feststellen, ob ein Wert ein Paar ist") - (cons? (%a -> boolean) + (cons? (any -> boolean) "feststellen, ob ein Wert ein Paar ist") - (empty? (%a -> boolean) + (empty? (any -> boolean) "feststellen, ob ein Wert die leere Liste ist") - (first ((list %a) -> %a) + (first ((list-of %a) -> %a) "erstes Element eines Paars extrahieren") - (rest ((list %a) -> (list %a)) + (rest ((list-of %a) -> (list-of %a)) "Rest eines Paars extrahieren") - (list (%a ... -> (list %a)) + (list (%a ... -> (list-of %a)) "Liste aus den Argumenten konstruieren") - (length ((list %a) -> natural) + (length ((list-of %a) -> natural) "Länge einer Liste berechnen") - (fold ((%b (%a %b -> %b) (list %a) -> %b) - "Liste einfalten.")) + (fold (%b (%a %b -> %b) (list-of %a) -> %b) + "Liste einfalten.") - ((DMdA-append append) ((list %a) ... -> (list %a)) + ((DMdA-append append) ((list-of %a) ... -> (list-of %a)) "mehrere Listen aneinanderhängen") - (list-ref ((list %a) natural -> %a) + (list-ref ((list-of %a) natural -> %a) "das Listenelement an der gegebenen Position extrahieren") - (reverse ((list %a) -> (list %a)) + (reverse ((list-of %a) -> (list-of %a)) "Liste in umgekehrte Reihenfolge bringen")) ("Computer" @@ -281,7 +281,7 @@ "Signatur für Computer") (make-computer (string rational rational -> computer) "Computer aus Prozessorname, Arbeitsspeicher und Festplattenkapazität konstruieren") - (computer? (%a -> boolean) + (computer? (any -> boolean) "feststellen, ob Wert ein Computer ist") (computer-processor (computer -> string) "Prozessorname aus Computer extrahieren") @@ -295,7 +295,7 @@ "Signatur für Schokokekse") (make-chocolate-cookie (number number -> chocolate-cookie) "Schokokeks aus Schoko- und Keks-Anteil konstruieren") - (chocolate-cookie? (%a -> boolean) + (chocolate-cookie? (any -> boolean) "feststellen, ob ein Wert ein Schokokeks ist") (chocolate-cookie-chocolate (chocolate-cookie -> number) "Schoko-Anteil eines Schokokekses extrahieren") @@ -305,7 +305,7 @@ ;; #### Zeichen sollten noch dazu, Vektoren wahrscheinlich auch ("Zeichenketten" - (string? (%a -> boolean) + (string? (any -> boolean) "feststellen, ob ein Wert eine Zeichenkette ist") (string=? (string string string ... -> boolean) @@ -332,7 +332,7 @@ "Liefert Länge einer Zeichenkette")) ("Symbole" - (symbol? (%a -> boolean) + (symbol? (any -> boolean) "feststellen, ob ein Wert ein Symbol ist") (symbol->string (symbol -> string) "Symbol in Zeichenkette umwandeln") diff --git a/collects/deinprogramm/signature/signature-syntax.rkt b/collects/deinprogramm/signature/signature-syntax.rkt index e8962846ec..5bf8b6e758 100644 --- a/collects/deinprogramm/signature/signature-syntax.rkt +++ b/collects/deinprogramm/signature/signature-syntax.rkt @@ -11,8 +11,7 @@ scheme/promise (for-syntax scheme/base) (for-syntax syntax/stx) - (for-syntax stepper/private/shared) - (only-in lang/private/teachprims teach-equal?)) + (for-syntax stepper/private/shared)) (define-for-syntax (phase-lift stx) (with-syntax ((?stx stx)) @@ -50,7 +49,7 @@ (syntax->list #'((?temp ?exp) ...))))) #'(let ((?temp ?exp) ...) ?check ... - (make-case-signature '?name (list ?temp ...) teach-equal? ?stx))))) + (make-case-signature '?name (list ?temp ...) equal? ?stx))))) ((predicate ?exp) (with-syntax ((?stx (phase-lift stx)) (?name name)) diff --git a/collects/drracket/drracket.filetypes b/collects/drracket/drracket.filetypes index 0da55e5f35..10bd9130b5 100644 --- a/collects/drracket/drracket.filetypes +++ b/collects/drracket/drracket.filetypes @@ -7,7 +7,7 @@ ("CFBundleTypeOSTypes" (array "TEXT" "WXME")) ("CFBundleTypeExtensions" - (array "rkt" "rktd" "rktl" "scm" "ss"))) + (array "rkt" "rktd" "rktl" "scrbl" "scm" "ss"))) (("CFBundleTypeName" "Package") ("CFBundleTypeIconFile" diff --git a/collects/drracket/private/app.rkt b/collects/drracket/private/app.rkt index 5ec857a585..8590b0cae1 100644 --- a/collects/drracket/private/app.rkt +++ b/collects/drracket/private/app.rkt @@ -369,9 +369,9 @@ (λ (x y) (send-url url)))))]) (add (string-constant plt-homepage) "http://racket-lang.org/") - (add (string-constant teachscheme!-homepage) "http://www.teach-scheme.org/") - (add (string-constant how-to-design-programs) "http://www.htdp.org/") - + (add (string-constant pbd-homepage) "http://programbydesign.org/") + (add (string-constant how-to-design-programs) "http://htdp.org/") + (for-each (λ (tool) (cond [(drracket:tools:successful-tool-url tool) => diff --git a/collects/drracket/private/main.rkt b/collects/drracket/private/main.rkt index 74bb8e7837..1f02f3335e 100644 --- a/collects/drracket/private/main.rkt +++ b/collects/drracket/private/main.rkt @@ -6,8 +6,10 @@ mred framework mzlib/class - mzlib/list + racket/list racket/path + racket/file + racket/dict browser/external setup/plt-installer) @@ -316,17 +318,7 @@ (make-check-box 'drracket:open-in-tabs (string-constant open-files-in-tabs) editor-panel) - (make-check-box 'drracket:show-line-numbers? - (string-constant show-line-numbers) - editor-panel - (lambda (value) - (define (drracket:frame? frame) - (and (is-a? frame top-level-window<%>) - (is-a? frame drracket:unit:frame%))) - ;; is it a hack to use `get-top-level-windows' ? - (define frames (filter drracket:frame? (get-top-level-windows))) - (when (not (null? frames)) - (send (car frames) show-line-numbers! value)))) + (make-check-box 'drracket:show-interactions-on-execute (string-constant show-interactions-on-execute) @@ -346,7 +338,17 @@ (preferences:add-to-editor-checkbox-panel (λ (editor-panel) - (void) + (make-check-box 'drracket:show-line-numbers? + (string-constant show-line-numbers) + editor-panel + (lambda (value) + (define (drracket:frame? frame) + (and (is-a? frame top-level-window<%>) + (is-a? frame drracket:unit:frame%))) + ;; is it a hack to use `get-top-level-windows' ? + (define frames (filter drracket:frame? (get-top-level-windows))) + (when (not (null? frames)) + (send (car frames) show-line-numbers! value)))) ;; come back to this one. #; @@ -453,6 +455,30 @@ (run-installer filename) #f)) +;; trim old console-previous-exprs preferences to compenstate +;; for a bug that let it grow without bound +(let* ([max-len 30] + [trim (λ (exprs save) + (when (list? exprs) + (let ([len (length exprs)]) + (when (> len max-len) + (save (drop exprs (- len max-len)))))))]) + (let ([framework-prefs (get-preference 'plt:framework-prefs)]) + (when (and (list? framework-prefs) + (andmap pair? framework-prefs)) + (let ([exprs-pref (assq 'drscheme:console-previous-exprs framework-prefs)]) + (when exprs-pref + (trim (second exprs-pref) + (λ (trimmed) + (put-preferences (list 'plt:framework-prefs) + (list (dict-set framework-prefs 'drscheme:console-previous-exprs (list trimmed))) + void))))))) + (trim (get-preference 'plt:framework-pref:drscheme:console-previous-exprs) + (λ (trimmed) + (put-preferences (list 'plt:framework-pref:drscheme:console-previous-exprs) + (list trimmed) + void)))) + (drracket:tools:load/invoke-all-tools (λ () (void)) (λ () diff --git a/collects/drracket/private/rep.rkt b/collects/drracket/private/rep.rkt index ba5bdf44bb..a71ee27ba5 100644 --- a/collects/drracket/private/rep.rkt +++ b/collects/drracket/private/rep.rkt @@ -303,8 +303,6 @@ TODO (send drs-bindings-keymap map-function "f1" "search-help-desk") (send drs-bindings-keymap map-function "c:tab" "next-tab") (send drs-bindings-keymap map-function "c:s:tab" "prev-tab") - (send drs-bindings-keymap map-function "d:s:right" "next-tab") - (send drs-bindings-keymap map-function "d:s:left" "prev-tab") (send drs-bindings-keymap map-function "c:pagedown" "next-tab") (send drs-bindings-keymap map-function "c:pageup" "prev-tab") @@ -439,7 +437,6 @@ TODO (define-struct sexp (left right prompt)) - (define console-max-save-previous-exprs 30) (let* ([list-of? (λ (p?) (λ (l) (and (list? l) @@ -451,25 +448,24 @@ TODO 'drracket:console-previous-exprs null list-of-lists-of-snip/strings?)) - (let ([marshall - (λ (lls) - (map (λ (ls) - (list - (apply - string-append - (reverse - (map (λ (s) - (cond - [(is-a? s string-snip%) - (send s get-text 0 (send s get-count))] - [(string? s) s] - [else "'non-string-snip"])) - ls))))) - lls))] - [unmarshall (λ (x) x)]) + (define (marshall-previous-exprs lls) + (map (λ (ls) + (list + (apply + string-append + (reverse + (map (λ (s) + (cond + [(is-a? s string-snip%) + (send s get-text 0 (send s get-count))] + [(string? s) s] + [else "'non-string-snip"])) + ls))))) + lls)) + (let ([unmarshall (λ (x) x)]) (preferences:set-un/marshall 'drracket:console-previous-exprs - marshall unmarshall)) + marshall-previous-exprs unmarshall)) (define color? ((get-display-depth) . > . 8)) @@ -1322,15 +1318,17 @@ TODO (initialize-parameters snip-classes)))) - ;; register drscheme with the planet-terse-register for the user's namespace - ;; must be called after 'initialize-parameters' is called (since it initializes - ;; the user's namespace) - (planet-terse-set-key (gensym)) - (planet-terse-register - (lambda (tag package) - (parameterize ([current-eventspace drracket:init:system-eventspace]) - (queue-callback (λ () (new-planet-info tag package)))))) - + (queue-user/wait + (λ () + ;; register drscheme with the planet-terse-register for the user's namespace + ;; must be called after 'initialize-parameters' is called (since it initializes + ;; the user's namespace) + (planet-terse-set-key (namespace-module-registry (current-namespace))) + (planet-terse-register + (lambda (tag package) + (parameterize ([current-eventspace drracket:init:system-eventspace]) + (queue-callback (λ () (new-planet-info tag package)))))))) + ;; disable breaks until an evaluation actually occurs (send context set-breakables #f #f) @@ -1769,18 +1767,25 @@ TODO (define/private (get-previous-exprs) (append global-previous-exprs local-previous-exprs)) (define/private (add-to-previous-exprs snips) - (let* ([new-previous-exprs - (let* ([trimmed-previous-exprs (trim-previous-exprs local-previous-exprs)]) - (let loop ([l trimmed-previous-exprs]) - (if (null? l) - (list snips) - (cons (car l) (loop (cdr l))))))]) - (set! local-previous-exprs new-previous-exprs))) + (set! local-previous-exprs (append local-previous-exprs (list snips)))) + ; list-of-lists-of-snip/strings? -> list-of-lists-of-snip/strings? (define/private (trim-previous-exprs lst) - (if ((length lst). >= . console-max-save-previous-exprs) - (cdr lst) - lst)) + (define max-size 10000) + (define (expr-size expr) + (for/fold ([s 0]) ([e expr]) (+ s (string-length e)))) + (define within-bound + (let loop ([marshalled (reverse (marshall-previous-exprs lst))] + [keep 0] + [sum 0]) + (if (empty? marshalled) + keep + (let* ([size (expr-size (first marshalled))] + [w/another (+ size sum)]) + (if (> w/another max-size) + keep + (loop (rest marshalled) (add1 keep) w/another)))))) + (take-right lst within-bound)) (define/private (save-interaction-in-history start end) (split-snip start) diff --git a/collects/drracket/private/syncheck/traversals.rkt b/collects/drracket/private/syncheck/traversals.rkt index 64f156ddaf..69f3ae9557 100644 --- a/collects/drracket/private/syncheck/traversals.rkt +++ b/collects/drracket/private/syncheck/traversals.rkt @@ -626,7 +626,8 @@ (color-unused require-for-templates unused-require-for-templates) (color-unused require-for-syntaxes unused-require-for-syntaxes) (color-unused requires unused-requires) - (hash-for-each rename-ht (lambda (k stxs) (make-rename-menu stxs id-sets))))) + + (hash-for-each rename-ht (lambda (k stxs) (make-rename-menu k rename-ht id-sets))))) ;; record-renamable-var : rename-ht syntax -> void @@ -1309,22 +1310,29 @@ ; ;;; - ;; make-rename-menu : (cons stx[original,id] (listof stx[original,id])) (listof id-set) -> void - (define (make-rename-menu stxs id-sets) - (let ([defs-text (currently-processing-definitions-text)]) + ;; make-rename-menu : (list source number number) rename-ht (listof id-set) -> void + (define (make-rename-menu key rename-ht id-sets) + (let* ([source (list-ref key 0)] + [pos (list-ref key 1)] + [span (list-ref key 2)] + [defs-text (currently-processing-definitions-text)] + [example-id + ;; we know that there is at least one there b/c that's how make-rename-menu is called + (car (hash-ref rename-ht key))] + [id-as-sym (syntax-e example-id)]) + (when defs-text - (let* ([source (syntax-source (car stxs))] ;; all stxs in the list must have the same source - [source-editor (find-source-editor (car stxs))]) + (let ([source-editor (find-source-editor example-id)]) (when (is-a? source-editor text%) - (let* ([start (- (syntax-position (car stxs)) 1)] - [fin (+ start (syntax-span (car stxs)))]) + (let* ([start (- pos 1)] + [fin (+ start span)]) (send defs-text syncheck:add-menu source-editor start fin - (syntax-e (car stxs)) + id-as-sym (λ (menu) - (let ([name-to-offer (format "~a" (syntax->datum (car stxs)))]) + (let ([name-to-offer (format "~a" id-as-sym)]) (instantiate menu-item% () (parent menu) (label (fw:gui-utils:format-literal-label (string-constant cs-rename-var) name-to-offer)) @@ -1333,8 +1341,9 @@ (let ([frame-parent (find-menu-parent menu)]) (rename-callback name-to-offer defs-text - stxs + key id-sets + rename-ht frame-parent)))))))))))))) ;; find-parent : menu-item-container<%> -> (union #f (is-a?/c top-level-window<%>) @@ -1357,12 +1366,13 @@ ;; rename-callback : string ;; (and/c syncheck-text<%> definitions-text<%>) - ;; (listof syntax[original]) + ;; (list source number number) ;; (listof id-set) + ;; rename-ht ;; (union #f (is-a?/c top-level-window<%>)) ;; -> void ;; callback for the rename popup menu item - (define (rename-callback name-to-offer defs-text stxs id-sets parent) + (define (rename-callback name-to-offer defs-text key id-sets rename-ht parent) (let ([new-str (fw:keymap:call/text-keymap-initializer (λ () @@ -1372,61 +1382,65 @@ parent name-to-offer)))]) (when new-str - (let* ([new-sym (format "~s" (string->symbol new-str))] - [to-be-renamed - (remove-duplicates-stx - (sort - (apply - append - (map (λ (id-set) - (apply - append - (map (λ (stx) (or (get-ids id-set stx) '())) stxs))) - id-sets)) - (λ (x y) - ((syntax-position x) . >= . (syntax-position y)))))] - [do-renaming? - (or (not (name-duplication? to-be-renamed id-sets new-sym)) - (equal? - (message-box/custom - (string-constant check-syntax) - (fw:gui-utils:format-literal-label (string-constant cs-name-duplication-error) - new-sym) - (string-constant cs-rename-anyway) - (string-constant cancel) - #f - parent - '(stop default=2)) - 1))]) - (when do-renaming? - (unless (null? to-be-renamed) - (let ([txts (list defs-text)]) - (send defs-text begin-edit-sequence) - (for-each (λ (stx) - (let ([source-editor (find-source-editor/defs stx defs-text)]) - (when (is-a? source-editor text%) - (unless (memq source-editor txts) - (send source-editor begin-edit-sequence) - (set! txts (cons source-editor txts))) - (let* ([start (- (syntax-position stx) 1)] - [end (+ start (syntax-span stx))]) - (send source-editor delete start end #f) - (send source-editor insert new-sym start start #f))))) - to-be-renamed) - (send defs-text invalidate-bitmap-cache) - (for-each - (λ (txt) (send txt end-edit-sequence)) - txts)))))))) + (define new-sym (format "~s" (string->symbol new-str))) + (define src-locs (make-hash)) + (define all-stxs (make-hash)) + (let loop ([key key]) + (unless (hash-ref src-locs key #f) + (hash-set! src-locs key #t) + (for ([stx (in-list (hash-ref rename-ht key))]) + (for ([id-set (in-list id-sets)]) + (for ([stx (in-list (or (get-ids id-set stx) '()))]) + (hash-set! all-stxs stx #t) + (loop (list (syntax-source stx) + (syntax-position stx) + (syntax-span stx)))))))) + (define locs-to-be-renamed + (sort (hash-map src-locs (λ (k v) k)) + >= + #:key cadr)) + (define to-be-renamed (hash-map all-stxs (λ (k v) k))) + (define do-renaming? + (or (not (name-duplication? to-be-renamed id-sets new-sym)) + (equal? + (message-box/custom + (string-constant check-syntax) + (fw:gui-utils:format-literal-label (string-constant cs-name-duplication-error) + new-sym) + (string-constant cs-rename-anyway) + (string-constant cancel) + #f + parent + '(stop default=2)) + 1))) + (when do-renaming? + (unless (null? to-be-renamed) + (let ([txts (list defs-text)]) + (send defs-text begin-edit-sequence) + (for-each (λ (stx) + (let ([source-editor (find-source-editor/defs stx defs-text)]) + (when (is-a? source-editor text%) + (unless (memq source-editor txts) + (send source-editor begin-edit-sequence) + (set! txts (cons source-editor txts))) + (let* ([start (- (syntax-position stx) 1)] + [end (+ start (syntax-span stx))]) + (send source-editor delete start end #f) + (send source-editor insert new-sym start start #f))))) + to-be-renamed) + (send defs-text invalidate-bitmap-cache) + (for-each + (λ (txt) (send txt end-edit-sequence)) + txts))))))) ;; name-duplication? : (listof syntax) (listof id-set) symbol -> boolean ;; returns #t if the name chosen would be the same as another name in this scope. (define (name-duplication? to-be-renamed id-sets new-str) (let ([new-ids (map (λ (id) (datum->syntax id (string->symbol new-str))) to-be-renamed)]) - (ormap (λ (id-set) - (ormap (λ (new-id) (get-ids id-set new-id)) - new-ids)) - id-sets))) + (for*/or ([id-set (in-list id-sets)] + [new-id (in-list new-ids)]) + (get-ids id-set new-id)))) ;; remove-duplicates-stx : (listof syntax[original]) -> (listof syntax[original]) ;; removes duplicates, based on the source locations of the identifiers diff --git a/collects/drracket/private/unit.rkt b/collects/drracket/private/unit.rkt index 591e311d59..df09c003db 100644 --- a/collects/drracket/private/unit.rkt +++ b/collects/drracket/private/unit.rkt @@ -3799,15 +3799,15 @@ module browser threading seems wrong. (new menu:can-restore-menu-item% [label (if (show-line-numbers?) - (string-constant hide-line-numbers) - (string-constant show-line-numbers))] + (string-constant hide-line-numbers/menu) + (string-constant show-line-numbers/menu))] [parent (get-show-menu)] [callback (lambda (self event) (define value (preferences:get 'drracket:show-line-numbers?)) (send self set-label (if value - (string-constant show-line-numbers) - (string-constant hide-line-numbers))) + (string-constant show-line-numbers/menu) + (string-constant hide-line-numbers/menu))) (preferences:set 'drracket:show-line-numbers? (not value)) (show-line-numbers! (not value)))]) diff --git a/collects/ffi/unsafe.rkt b/collects/ffi/unsafe.rkt index f3ecaf241e..4cef8d2674 100644 --- a/collects/ffi/unsafe.rkt +++ b/collects/ffi/unsafe.rkt @@ -759,22 +759,20 @@ ;; Call this with a name (symbol) and a list of symbols, where a symbol can be ;; followed by a '= and an integer to have a similar effect of C's enum. -(define (_enum* name symbols . base?) - (define basetype (if (pair? base?) (car base?) _ufixint)) +(define (_enum name symbols [basetype _ufixint] #:unknown [unknown _enum]) (define sym->int '()) (define int->sym '()) (define s->c (if name (string->symbol (format "enum:~a->int" name)) 'enum->int)) + (define c->s + (if name (string->symbol (format "enum:int->~a" name)) 'int->enum)) (let loop ([i 0] [symbols symbols]) (unless (null? symbols) - (let-values ([(i rest) - (if (and (pair? (cdr symbols)) - (eq? '= (cadr symbols)) - (pair? (cddr symbols))) - (values (caddr symbols) - (cdddr symbols)) - (values i - (cdr symbols)))]) + (let-values ([(i rest) (if (and (pair? (cdr symbols)) + (eq? '= (cadr symbols)) + (pair? (cddr symbols))) + (values (caddr symbols) (cdddr symbols)) + (values i (cdr symbols)))]) (set! sym->int (cons (cons (car symbols) i) sym->int)) (set! int->sym (cons (cons i (car symbols)) int->sym)) (loop (add1 i) rest)))) @@ -784,26 +782,26 @@ (if a (cdr a) (raise-type-error s->c (format "~a" (or name "enum")) x)))) - (lambda (x) (cond [(assq x int->sym) => cdr] [else #f])))) + (lambda (x) + (cond [(assq x int->sym) => cdr] + [(eq? unknown _enum) + (error c->s "expected a known ~a, got: ~s" basetype x)] + [(procedure? unknown) (unknown x)] + [else unknown])))) ;; Macro wrapper -- no need for a name -(provide _enum) -(define-syntax (_enum stx) +(provide (rename-out [_enum* _enum])) +(define-syntax (_enum* stx) (syntax-case stx () - [(_ syms) - (with-syntax ([name (syntax-local-name)]) - #'(_enum* 'name syms))] - [(_ syms basetype) - (with-syntax ([name (syntax-local-name)]) - #'(_enum* 'name syms basetype))] - [id (identifier? #'id) - #'(lambda (syms . base?) (apply _enum* #f syms base?))])) + [(_ x ...) + (with-syntax ([name (syntax-local-name)]) #'(_enum 'name x ...))] + [id (identifier? #'id) #'_enum])) ;; Call this with a name (symbol) and a list of (symbol int) or symbols like ;; the above with '= -- but the numbers have to be specified in some way. The ;; generated type will convert a list of these symbols into the logical-or of ;; their values and back. -(define (_bitmask* name orig-symbols->integers . base?) +(define (_bitmask name orig-symbols->integers . base?) (define basetype (if (pair? base?) (car base?) _uint)) (define s->c (if name (string->symbol (format "bitmask:~a->int" name)) 'bitmask->int)) @@ -843,17 +841,12 @@ l))))))))) ;; Macro wrapper -- no need for a name -(provide _bitmask) -(define-syntax (_bitmask stx) +(provide (rename-out [_bitmask* _bitmask])) +(define-syntax (_bitmask* stx) (syntax-case stx () - [(_ syms) - (with-syntax ([name (syntax-local-name)]) - #'(_bitmask* 'name syms))] - [(_ syms basetype) - (with-syntax ([name (syntax-local-name)]) - #'(_bitmask* 'name syms basetype))] - [id (identifier? #'id) - #'(lambda (syms . base?) (apply _bitmask* #f syms base?))])) + [(_ x ...) + (with-syntax ([name (syntax-local-name)]) #'(_bitmask 'name x ...))] + [id (identifier? #'id) #'_bitmask])) ;; ---------------------------------------------------------------------------- ;; Custom function type macros @@ -1347,67 +1340,47 @@ (values _TYPE* _TYPE-pointer _TYPE-pointer/null TYPE? TYPE-tag make-TYPE TYPE-SLOT ... set-TYPE-SLOT! ... list->TYPE list*->TYPE TYPE->list TYPE->list*)))))))) - (define (identifiers? stx) - (andmap identifier? (syntax->list stx))) - (define (_-identifier? id stx) - (and (identifier? id) - (or (regexp-match #rx"^_." (symbol->string (syntax-e id))) - (raise-syntax-error #f "cstruct name must begin with a `_'" - stx id)))) - ;; there is something wrong with the syntax, this function will find what it is - (define (syntax-error stx) - (define (check-rest rest) - (syntax-case rest () - [() (void)] - [else (raise-syntax-error #f "extra arguments given" rest)])) - (define (check-alignment alignment) - (syntax-case alignment () - [(#:alignment alignment-expr rest ...) - (check-rest #'(rest ...))] - [else (raise-syntax-error #f "the last argument can only be #:alignment" alignment)])) - (define (check-slots slots) - (define (check-slot slot) - (syntax-case slot () - [(name field) (void)] - [else (raise-syntax-error #f "a field must be a pair of a name and a ctype such as [x _int]" slot)])) - ;; check that some slots are given - (syntax-case slots () - [([name-id expr-id] ... . rest) - (when (and (identifiers? #'(name-id ...)) - (identifiers? #'(expr-id ...))) - (raise-syntax-error #f "fields must be a parenthesized list of name and a ctype such as ([x _int] [y _int])" slots))]) - (syntax-case slots () - [((slot ...) rest ...) - (begin - (for ([slot-stx (in-list (syntax->list #'(slot ...)))]) - (check-slot slot-stx)) - (check-alignment #'(rest ...)))] - [else (raise-syntax-error #f "fields must be a parenthesized list such as ([x _int] [y _int])" slots)])) - (define (check-name stx) - (syntax-case stx () - [(_ _TYPE rest ...) - (check-slots #'(rest ...))] - [else (raise-syntax-error #f "a name must be provided to cstruct" stx)])) - (check-name stx)) - + (define (err what . xs) + (apply raise-syntax-error #f + (if (list? what) (apply string-append what) what) + stx xs)) (syntax-case stx () - [(_ _TYPE ([slot slot-type] ...)) - (and (_-identifier? #'_TYPE stx) - (identifiers? #'(slot ...))) - (make-syntax #'_TYPE #f #'(slot ...) #'(slot-type ...) #'#f)] - [(_ _TYPE ([slot slot-type] ...) #:alignment alignment-expr) - (and (_-identifier? #'_TYPE stx) - (identifiers? #'(slot ...))) - (make-syntax #'_TYPE #f #'(slot ...) #'(slot-type ...) #'alignment-expr)] - [(_ (_TYPE _SUPER) ([slot slot-type] ...)) - (and (_-identifier? #'_TYPE stx) (identifiers? #'(slot ...))) - (with-syntax ([super (datum->syntax #'_TYPE 'super #'_TYPE)]) - (make-syntax #'_TYPE #t #'(super slot ...) #'(_SUPER slot-type ...) #'#f))] - [(_ (_TYPE _SUPER) ([slot slot-type] ...) #:alignment alignment-expr) - (and (_-identifier? #'_TYPE stx) (identifiers? #'(slot ...))) - (with-syntax ([super (datum->syntax #'_TYPE 'super #'_TYPE)]) - (make-syntax #'_TYPE #t #'(super slot ...) #'(_SUPER slot-type ...) #'alignment-expr))] - [else (syntax-error stx)])) + [(_ type ([slot slot-type] ...) . more) + (let-values ([(_TYPE _SUPER) + (syntax-case #'type () + [(t s) (values #'t #'s)] + [_ (values #'type #f)])] + [(alignment) + (syntax-case #'more () + [() #'#f] + [(#:alignment) (err "missing expression for #:alignment")] + [(#:alignment a) #'a] + [(#:alignment a x . _) (err "unexpected form" #'x)] + [(x . _) (err (if (keyword? (syntax-e #'x)) + "unknown keyword" "unexpected form") + #'x)])]) + (unless (identifier? _TYPE) + (err "bad type, expecting a _name identifier or (_name super-ctype)" + _TYPE)) + (unless (regexp-match? #rx"^_." (symbol->string (syntax-e _TYPE))) + (err "cstruct name must begin with a `_'" _TYPE)) + (for ([s (in-list (syntax->list #'(slot ...)))]) + (unless (identifier? s) + (err "bad field name, expecting an identifier identifier" s))) + (if _SUPER + (make-syntax _TYPE #t + #`(#,(datum->syntax _TYPE 'super _TYPE) slot ...) + #`(#,_SUPER slot-type ...) + alignment) + (make-syntax _TYPE #f #'(slot ...) #`(slot-type ...) alignment)))] + ;; specific errors for bad slot specs, leave the rest for a generic error + [(_ type (bad ...) . more) + (err "bad slot specification, expecting [name ctype]" + (ormap (lambda (s) (syntax-case s () [[n ct] #t] [_ s])) + (syntax->list #'(bad ...))))] + [(_ type bad . more) + (err "bad slot specification, expecting a sequence of [name ctype]" + #'bad)])) ;; helper for the above: keep runtime information on structs (define cstruct-info diff --git a/collects/ffi/unsafe/objc.rkt b/collects/ffi/unsafe/objc.rkt index a371abc34c..fa5c754fad 100644 --- a/collects/ffi/unsafe/objc.rkt +++ b/collects/ffi/unsafe/objc.rkt @@ -33,7 +33,9 @@ (define _BOOL (make-ctype _byte (lambda (v) (if v 1 0)) (lambda (v) (not (eq? v 0))))) -(define _IMP (_fun _id _id -> _id)) + +(define _Method (_cpointer/null 'Method)) +(define _IMP (_fun _id _SEL -> _id)) (define-cstruct _objc_super ([receiver _id][class _Class])) @@ -372,7 +374,9 @@ (define (free-fields obj names) (for-each (lambda (name) (let-values ([(ivar p) (object_getInstanceVariable obj name)]) - (when p (free-immobile-cell p)))) + (when p + (object_setInstanceVariable obj name #f) + (free-immobile-cell p)))) names)) ;; ---------------------------------------- @@ -862,3 +866,10 @@ (define (objc-is-a? v c) (ptr-equal? (object-get-class v) c)) + +;; -------------------------------------------------- + +(define-objc class_getInstanceMethod (_fun _Class _SEL -> _Method)) +(define-objc method_setImplementation (_fun _Method _IMP -> _IMP)) + + diff --git a/collects/ffi/unsafe/try-atomic.rkt b/collects/ffi/unsafe/try-atomic.rkt index 1de4186456..c1c44f2ddf 100644 --- a/collects/ffi/unsafe/try-atomic.rkt +++ b/collects/ffi/unsafe/try-atomic.rkt @@ -11,7 +11,7 @@ (define scheme_call_with_composable_no_dws (get-ffi-obj 'scheme_call_with_composable_no_dws #f (_fun _scheme _scheme -> _scheme))) (define scheme_set_on_atomic_timeout - (get-ffi-obj 'scheme_set_on_atomic_timeout #f (_fun (_fun -> _void) -> _pointer))) + (get-ffi-obj 'scheme_set_on_atomic_timeout #f (_fun (_fun _int -> _void) -> _pointer))) (define scheme_restore_on_atomic_timeout (get-ffi-obj 'scheme_set_on_atomic_timeout #f (_fun _pointer -> _pointer))) @@ -59,8 +59,10 @@ [else ;; try to do some work: (let* ([ready? #f] - [handler (lambda () - (when (and ready? (should-give-up?)) + [handler (lambda (must-give-up) + (when (and ready? + (or (positive? must-give-up) + (should-give-up?))) (scheme_call_with_composable_no_dws (lambda (proc) (set-box! b (cons proc (unbox b))) diff --git a/collects/file/convertible.rkt b/collects/file/convertible.rkt new file mode 100644 index 0000000000..6af83fb1d5 --- /dev/null +++ b/collects/file/convertible.rkt @@ -0,0 +1,13 @@ +#lang racket/base + +(provide prop:convertible convertible? convert) + +(define-values (prop:convertible convertible? convertible-ref) + (make-struct-type-property 'convertible)) + +(define (convert v target [default #f]) + (unless (convertible? v) + (raise-type-error 'convert "convertible" 0 v target)) + (unless (symbol? target) + (raise-type-error 'convert "symbol" 1 v target)) + ((convertible-ref v) v target default)) diff --git a/collects/file/scribblings/convertible.scrbl b/collects/file/scribblings/convertible.scrbl new file mode 100644 index 0000000000..40b9bbf39f --- /dev/null +++ b/collects/file/scribblings/convertible.scrbl @@ -0,0 +1,53 @@ +#lang scribble/doc +@(require scribble/manual + (for-label file/convertible)) + +@title[#:tag "convertible"]{Convertible: Data-Conversion Protocol} + +@defmodule[file/convertible] + +The @schememodname[file/convertible] library provides a protocol to +mediate between providers of data in different possible formats and +consumers of the formats. For example, a datatype that implements +@racket[prop:convertible] might be able to convert itself to a GIF or +PDF stream, in which case it would produce data for +@racket['gif-bytes] or @racket['pdf-bytes] requests. + +Any symbol can be used for a conversion request, but the following +should be considered standard: + +@itemlist[ + #:style 'compact + + @item{@scheme['text] --- a string for human-readable text} + @item{@scheme['gif-bytes] --- a byte string containing a GIF image encoding} + @item{@scheme['png-bytes] --- a byte string containing a PNG image encoding} + @item{@scheme['ps-bytes] --- a byte string containing a PostScript document} + @item{@scheme['eps-bytes] --- a byte string containing an Encapsulated PostScript document} + @item{@scheme['pdf-bytes] --- a byte string containing a PDF document} +] + +@defthing[prop:convertible struct-type-property?]{ + +A property whose value should be a procedure of three arguments. The +procedure is called when a structure with the property is passed to +@racket[convert]; the first argument to the procedure is the +structure, the second argument is a symbol for the requested +conversion, and the third argument is a value to return (typically +@racket[#f] if the conversion is not supported. The procedure's result +depends on the requested conversion.} + +@defproc[(convertible? [v any/c]) boolean?]{ + +Returns @racket[#t] if @racket[v] supports the conversion protocol, +@racket[#f] otherwise.} + +@defproc[(convert [v convertible?] [request symbol?] [default any/c #f]) + any]{ + + +Requests a data conversion from @racket[v], where @racket[request] +indicates the type of requested data and @racket[default] is the value +that the converter should return if it cannot produce data in the +format indicated by @racket[request].} + diff --git a/collects/file/scribblings/file.scrbl b/collects/file/scribblings/file.scrbl index be439ecf01..e9ccc91601 100644 --- a/collects/file/scribblings/file.scrbl +++ b/collects/file/scribblings/file.scrbl @@ -5,6 +5,7 @@ @table-of-contents[] +@include-section["convertible.scrbl"] @include-section["gzip.scrbl"] @include-section["gunzip.scrbl"] @include-section["zip.scrbl"] diff --git a/collects/framework/preferences.rkt b/collects/framework/preferences.rkt index 9c74cff455..8f5fd3d034 100644 --- a/collects/framework/preferences.rkt +++ b/collects/framework/preferences.rkt @@ -132,31 +132,58 @@ the state transitions / contracts are: ;; set : symbol any -> void ;; updates the preference ;; exported - (define (multi-set ps values) - (for-each - (λ (p value) - (cond - [(pref-default-set? p) - (let ([default (hash-ref defaults p)]) - (unless ((default-checker default) value) - (error 'preferences:set - "tried to set preference ~e to ~e but it does not meet test from `preferences:set-default'" - p value)) - (check-callbacks p value) - (hash-set! preferences p value))] - [(not (pref-default-set? p)) - (raise-unknown-preference-error - 'preferences:set "tried to set the preference ~e to ~e, but no default is set" - p - value)])) - ps values) - ((preferences:low-level-put-preferences) - (map add-pref-prefix ps) - (map (λ (p value) (marshall-pref p value)) - ps - values)) - (void)) + (dynamic-wind + (λ () + (call-pref-save-callbacks #t)) + (λ () + (for-each + (λ (p value) + (cond + [(pref-default-set? p) + (let ([default (hash-ref defaults p)]) + (unless ((default-checker default) value) + (error 'preferences:set + "tried to set preference ~e to ~e but it does not meet test from `preferences:set-default'" + p value)) + (check-callbacks p value) + (hash-set! preferences p value))] + [(not (pref-default-set? p)) + (raise-unknown-preference-error + 'preferences:set "tried to set the preference ~e to ~e, but no default is set" + p + value)])) + ps values) + ((preferences:low-level-put-preferences) + (map add-pref-prefix ps) + (map (λ (p value) (marshall-pref p value)) + ps + values)) + (void)) + (λ () + (call-pref-save-callbacks #f)))) + +(define pref-save-callbacks '()) + +(define (preferences:register-save-callback f) + (define key (gensym)) + (set! pref-save-callbacks (cons (list key f) pref-save-callbacks)) + key) + +(define (preferences:unregister-save-callback k) + (set! pref-save-callbacks + (let loop ([callbacks pref-save-callbacks]) + (cond + [(null? callbacks) '()] + [else + (let ([cb (car callbacks)]) + (if (eq? (list-ref cb 0) k) + (cdr callbacks) + (cons cb (loop (cdr callbacks)))))])))) + +(define (call-pref-save-callbacks b) + (for ([cb (in-list pref-save-callbacks)]) + ((list-ref cb 1) b))) (define (raise-unknown-preference-error sym fmt . args) (raise (exn:make-unknown-preference @@ -437,6 +464,24 @@ the state transitions / contracts are: @{@scheme[(preferences:restore-defaults)] restores the users' configuration to the default preferences.}) + (proc-doc/names + preferences:register-save-callback + (-> (-> boolean? any) symbol?) + (callback) + @{Registers @racket[callback] to run twice for each call to @racket[preferences:set]---once + before the preferences file is written, with @racket[#t], and once after it is written, with + @racket[#f]. Registration returns a key for use with @racket[preferences:unregister-save-callback]. + Caveats: + @itemize{@item{The callback occurs on whichever thread happened to call @racket[preferences:set].} + @item{Pre- and post-write notifications are not necessarily paired; unregistration + may cancel the post-write notification before it occurs.}}}) + + (proc-doc/names + preferences:unregister-save-callback + (-> symbol? void?) + (key) + @{Unregisters the save callback associated with @racket[key].}) + (proc-doc/names exn:make-unknown-preference (string? continuation-mark-set? . -> . exn:unknown-preference?) diff --git a/collects/framework/private/frame.rkt b/collects/framework/private/frame.rkt index 9cff288072..c42b2d8954 100644 --- a/collects/framework/private/frame.rkt +++ b/collects/framework/private/frame.rkt @@ -560,6 +560,7 @@ (λ (l) (if (memq outer-info-panel l) (begin (unregister-collecting-blit gc-canvas) + (unregister-pref-save-callback) (list rest-panel)) l)))] [else @@ -569,6 +570,7 @@ l (begin (register-gc-blit) + (register-pref-save-callback) (list rest-panel outer-info-panel)))))])) [define close-panel-callback @@ -580,6 +582,7 @@ (define/augment (on-close) (unregister-collecting-blit gc-canvas) + (unregister-pref-save-callback) (close-panel-callback) (memory-cleanup) (inner (void) on-close)) @@ -637,6 +640,12 @@ [(<= n 99) (format "0~a" n)] [else (number->string n)])) + (define pref-save-canvas #f) + (when checkout-or-nightly? + (set! pref-save-canvas (new pref-save-canvas% [parent (get-info-panel)]))) + + [define lock-canvas (make-object lock-canvas% (get-info-panel))] + ; only for checkouts and nightly build users (when show-memory-text? (let* ([panel (new horizontal-panel% @@ -657,7 +666,6 @@ (set! memory-canvases (remq ec memory-canvases)))) (send panel stretchable-width #f))) - [define lock-canvas (make-object lock-canvas% (get-info-panel))] [define gc-canvas (make-object bday-click-canvas% (get-info-panel) '(border))] (define/private (register-gc-blit) (let ([onb (icon:get-gc-on-bitmap)] @@ -670,6 +678,25 @@ (send onb get-height) onb offb)))) + (define pref-save-callback-registration #f) + (inherit get-eventspace) + (define/private (register-pref-save-callback) + (when pref-save-canvas + (set! pref-save-callback-registration + (preferences:register-save-callback + (λ (start?) + (cond + [(eq? (current-thread) (eventspace-handler-thread (get-eventspace))) + (send pref-save-canvas set-on? start?)] + [else + (queue-callback + (λ () + (send pref-save-canvas set-on? start?)))])))))) + (define/private (unregister-pref-save-callback) + (when pref-save-callback-registration + (preferences:unregister-save-callback pref-save-callback-registration))) + (register-pref-save-callback) + (unless (preferences:get 'framework:show-status-line) (send super-root change-children (λ (l) @@ -1693,15 +1720,22 @@ (define/augment (after-delete x y) (update-prefs) (inner (void) after-delete x y)) + (define timer #f) (define/private (update-prefs) - (preferences:set pref-sym - (let loop ([snip (find-first-snip)]) - (cond - [(not snip) '()] - [(is-a? snip string-snip%) - (cons (send snip get-text 0 (send snip get-count)) - (loop (send snip next)))] - [else (cons snip (loop (send snip next)))])))) + (unless timer + (set! timer (new timer% + [notify-callback + (λ () + (preferences:set pref-sym + (let loop ([snip (find-first-snip)]) + (cond + [(not snip) '()] + [(is-a? snip string-snip%) + (cons (send snip get-text 0 (send snip get-count)) + (loop (send snip next)))] + [else (cons snip (loop (send snip next)))]))))]))) + (send timer stop) + (send timer start 150 #t)) (define/override (get-keymaps) (editor:add-after-user-keymap search/replace-keymap (super get-keymaps))) (super-new) @@ -2408,14 +2442,16 @@ (define/override (get-editor%) (text:searching-mixin (super get-editor%))) (super-new))) -(define memory-canvases '()) -(define show-memory-text? +(define checkout-or-nightly? (or (with-handlers ([exn:fail:filesystem? (λ (x) #f)]) (directory-exists? (collection-path "repo-time-stamp"))) (with-handlers ([exn:fail:filesystem? (λ (x) #f)]) (let ([fw (collection-path "framework")]) (directory-exists? (build-path fw 'up 'up ".git")))))) +(define memory-canvases '()) +(define show-memory-text? checkout-or-nightly?) + (define bday-click-canvas% (class canvas% (define/override (on-event evt) @@ -2427,6 +2463,32 @@ [else (super on-event evt)])) (super-new))) +(define pref-save-canvas% + (class canvas% + (define on? #f) + (define indicator "P") + (define/override (on-paint) + (cond + [on? + (let-values ([(cw ch) (get-client-size)]) + (send (get-dc) draw-text indicator + (- (/ cw 2) (/ indicator-width 2)) + (- (/ ch 2) (/ indicator-height 2))))])) + (define/public (set-on? new-on?) + (set! on? new-on?) + (send (get-dc) erase) + (on-paint) + (flush)) + + (inherit get-dc flush get-client-size min-width) + (super-new [stretchable-width #f] + [style '(transparent)]) + + (define-values (indicator-width indicator-height) + (let-values ([(tw th _1 _2) (send (get-dc) get-text-extent indicator)]) + (values tw th))) + (min-width (+ (inexact->exact (ceiling indicator-width)) 4)))) + (define basic% (register-group-mixin (basic-mixin frame%))) (define size-pref% (size-pref-mixin basic%)) (define info% (info-mixin basic%)) diff --git a/collects/framework/private/preferences.rkt b/collects/framework/private/preferences.rkt index 505fccaa6a..cb22974a2d 100644 --- a/collects/framework/private/preferences.rkt +++ b/collects/framework/private/preferences.rkt @@ -206,13 +206,14 @@ the state transitions / contracts are: (define (make-preferences-dialog) (letrec ([stashed-prefs (preferences:get-prefs-snapshot)] - [cancelled? #t] + [cancelled? #f] [frame-stashed-prefs% (class frame:basic% (inherit close) (define/override (on-subwindow-char receiver event) (cond [(eq? 'escape (send event get-key-code)) + (set! cancelled? #t) (close)] [else (super on-subwindow-char receiver event)])) @@ -222,7 +223,7 @@ the state transitions / contracts are: (define/override (show on?) (when on? ;; reset the flag and save new prefs when the window becomes visible - (set! cancelled? #t) + (set! cancelled? #f) (set! stashed-prefs (preferences:get-prefs-snapshot))) (super show on?)) (super-new))] @@ -280,9 +281,10 @@ the state transitions / contracts are: (for-each (λ (f) (f)) on-close-dialog-callbacks) - (set! cancelled? #f) (send frame close)))] - [cancel-callback (λ () (send frame close))]) + [cancel-callback (λ () + (set! cancelled? #t) + (send frame close))]) (new button% [label (string-constant revert-to-defaults)] [callback diff --git a/collects/framework/private/text.rkt b/collects/framework/private/text.rkt index 1fed712030..63d514e045 100644 --- a/collects/framework/private/text.rkt +++ b/collects/framework/private/text.rkt @@ -3756,6 +3756,17 @@ designates the character that triggers autocompletion (and (>= what low) (<= what high))) + (define-struct saved-dc-state (pen font foreground-color)) + (define (save-dc-state dc) + (saved-dc-state (send dc get-pen) + (send dc get-font) + (send dc get-text-foreground))) + + (define (restore-dc-state dc dc-state) + (send dc set-pen (saved-dc-state-pen dc-state)) + (send dc set-font (saved-dc-state-font dc-state)) + (send dc set-text-foreground (saved-dc-state-foreground-color dc-state))) + ;; set the dc stuff to values we want (define (setup-dc dc) (send dc set-pen "black" 1 'solid) @@ -3859,6 +3870,7 @@ designates the character that triggers autocompletion (define (draw-separator dc top bottom dx dy x) (send dc draw-line (+ dx x) (+ dy top) (+ dx x) (+ dy bottom))) + ;; `line-numbers-space' will get mutated in the `on-paint' method (define line-numbers-space 0) (define/override (find-position x y . args) ;; adjust x position to account for line numbers @@ -3867,6 +3879,7 @@ designates the character that triggers autocompletion (super find-position x y . args))) (define (draw-line-numbers dc left top right bottom dx dy) + (define saved-dc (save-dc-state dc)) (setup-dc dc) (define start-line (box 0)) (define end-line (box 0)) @@ -3874,7 +3887,8 @@ designates the character that triggers autocompletion ;; draw it! (draw-numbers dc top bottom dx dy (unbox start-line) (add1 (unbox end-line))) - (draw-separator dc top bottom dx dy (text-width dc (number-space)))) + (draw-separator dc top bottom dx dy (text-width dc (number-space))) + (restore-dc-state dc saved-dc)) (define (text-width dc stuff) (define-values (font-width font-height baseline space) @@ -3897,14 +3911,17 @@ designates the character that triggers autocompletion ;; will probably go away when 'margin's are added to editors ;; ;; save old origin and push it to the right a little bit - ;; TODO: maybe allow the line numbers to be drawn on the right hand side? + ;; TODO: maybe allow the line numbers to be drawn on the right hand side + ;; of the editor? (define-values (x y) (send dc get-origin)) (set! old-origin-x x) (set! old-origin-y y) (set! old-clipping (send dc get-clipping-region)) + (define saved-dc (save-dc-state dc)) (setup-dc dc) (define-values (font-width font-height baseline space) (send dc get-text-extent (number-space))) + (restore-dc-state dc saved-dc) (define clipped (make-object region% dc)) (define all (make-object region% dc)) (define copy (make-object region% dc)) diff --git a/collects/framework/splash.rkt b/collects/framework/splash.rkt index 9bb519ec57..3edea6e37b 100644 --- a/collects/framework/splash.rkt +++ b/collects/framework/splash.rkt @@ -286,7 +286,7 @@ (define/augment (on-close) (when quit-on-close? (exit))) - (super-new))) + (super-new [style '(close-button)]))) (define splash-canvas% (class canvas% diff --git a/collects/lang/private/signature-syntax.rkt b/collects/lang/private/signature-syntax.rkt index 22a02dcc0e..6ec3ac1d95 100644 --- a/collects/lang/private/signature-syntax.rkt +++ b/collects/lang/private/signature-syntax.rkt @@ -11,7 +11,6 @@ (for-syntax scheme/base) (for-syntax syntax/stx) (for-syntax stepper/private/shared) - (only-in lang/private/teachprims teach-equal?) (for-syntax "firstorder.rkt")) (define-for-syntax (phase-lift stx) @@ -50,7 +49,7 @@ (syntax->list #'((?temp ?exp) ...))))) #'(let ((?temp ?exp) ...) ?check ... - (make-case-signature '?name (list ?temp ...) teach-equal? ?stx))))) + (make-case-signature '?name (list ?temp ...) equal? ?stx))))) ((predicate ?exp) (with-syntax ((?stx (phase-lift stx)) (?name name)) diff --git a/collects/lang/private/teachprims.rkt b/collects/lang/private/teachprims.rkt index 56e999ab60..39f6225d49 100644 --- a/collects/lang/private/teachprims.rkt +++ b/collects/lang/private/teachprims.rkt @@ -242,8 +242,8 @@ namespace. (define-teach beginner exit (lambda () (exit))) -(define (tequal? x y epsilon) - (let* ([ht (make-hash)] ;; make-hash +(define (make-union-equal!?) + (let* ([ht (make-hasheq)] ;; make-hash [union-find (lambda (a) (let loop ([prev a] [prev-prev a]) @@ -256,21 +256,24 @@ namespace. (let ([v (hash-ref ht a)]) (hash-set! ht a prev) (loop v)))) - prev)))))] - [union-equal!? (lambda (a b) - (let ([a (union-find a)] - [b (union-find b)]) - (if (eq? a b) - #t - (begin - (hash-set! ht b a) - #f))))] - [fail (lambda (fmt arg) - (raise (make-exn:fail:contract (if (or (eq? arg x) - (eq? arg y)) - (format fmt arg) - (format "~a (originally comparing ~e and ~e)" (format fmt arg) x y)) - (current-continuation-marks))))]) + prev)))))]) + (lambda (a b) + (let ([a (union-find a)] + [b (union-find b)]) + (if (eq? a b) + #t + (begin + (hash-set! ht b a) + #f)))))) + +(define (tequal? x y epsilon) + (let ([union-equal!? (make-union-equal!?)] + [fail (lambda (fmt arg) + (raise (make-exn:fail:contract (if (or (eq? arg x) + (eq? arg y)) + (format fmt arg) + (format "~a (originally comparing ~e and ~e)" (format fmt arg) x y)) + (current-continuation-marks))))]) (let ? ([a x][b y]) (cond [(real? a) @@ -285,27 +288,29 @@ namespace. (define (teach-equal? x y) - (define (fail fmt arg) - (raise (make-exn:fail:contract (if (or (eq? arg x) - (eq? arg y)) - (format fmt arg) - (format "~a (originally comparing ~e and ~e)" (format fmt arg) x y)) - (current-continuation-marks)))) - - (let recur ([a x] [b y]) - (cond - [(procedure? a) - (fail "first argument of equality cannot be a procedure, given ~e" a)] - [(procedure? b) - (fail "second argument of equality cannot be a procedure, given ~e" b)] - [(and (number? a) - (inexact? a)) - (fail "first argument of equality cannot be an inexact number, given ~e" a)] - [(and (number? b) - (inexact? b)) - (fail "first argument of equality cannot be an inexact number, given ~e" b)] - [else - (equal?/recur a b recur)]))) + (let ([fail (lambda (fmt arg) + (raise (make-exn:fail:contract (if (or (eq? arg x) + (eq? arg y)) + (format fmt arg) + (format "~a (originally comparing ~e and ~e)" (format fmt arg) x y)) + (current-continuation-marks))))] + [union-equal!? (make-union-equal!?)]) + + (let recur ([a x] [b y]) + (cond + [(procedure? a) + (fail "first argument of equality cannot be a procedure, given ~e" a)] + [(procedure? b) + (fail "second argument of equality cannot be a procedure, given ~e" b)] + [(and (number? a) + (inexact? a)) + (fail "first argument of equality cannot be an inexact number, given ~e" a)] + [(and (number? b) + (inexact? b)) + (fail "first argument of equality cannot be an inexact number, given ~e" b)] + [(union-equal!? a b) #t] + [else + (equal?/recur a b recur)])))) (define-teach beginner equal? (lambda (a b) diff --git a/collects/lazy/lazy.rkt b/collects/lazy/lazy.rkt index 055f1faa23..cba16e6211 100644 --- a/collects/lazy/lazy.rkt +++ b/collects/lazy/lazy.rkt @@ -446,7 +446,7 @@ (define* (~list-ref l k) (let ([k (! k)]) - (unless (and (integer? k) (exact? k) (<= 0 k)) + (unless (exact-nonnegative-integer? k) (raise-type-error 'list-ref "non-negative exact integer" 1 l k)) (let loop ([k k] [l (! l)]) (cond [(not (pair? l)) @@ -455,7 +455,7 @@ [else (loop (sub1 k) (! (cdr l)))])))) (define* (~list-tail l k) (let ([k (! k)]) - (unless (and (integer? k) (exact? k) (<= 0 k)) + (unless (exact-nonnegative-integer? k) (raise-type-error 'list-tail "non-negative exact integer" 1 l k)) (let loop ([k k] [l l]) ; don't force here -- unlike list-ref (cond [(zero? k) l] @@ -575,10 +575,19 @@ ;; Extra functionality that is useful for lazy list stuff (define* (take n l) - (let loop ([n (! n)] [l (! l)]) - (cond [(or (<= n 0) (null? l)) '()] - [(pair? l) (cons (car l) (~ (loop (sub1 n) (! (cdr l)))))] - [else (error 'take "not a proper list: ~e" l)]))) + (let ([n0 (! n)] [l (! l)]) + (if (exact-nonnegative-integer? n) + (let loop ([n n0] [l l]) + (cond [(null? l) + (if (n . > . 0) + ;; it would be fine to force the whole list (since we now + ;; know it's finite), but doing so means keeping a reference + ;; to its head, which can lead to memory leaks. + (error 'take "index ~e too large for input list" n0) + '())] + [(pair? l) (cons (car l) (~ (loop (sub1 n) (! (cdr l)))))] + [else (error 'take "not a proper list: ~e" l)])) + (raise-type-error 'take "non-negative exact integer" 0 n l)))) ;; not like Haskell's `cycle' that consumes a list (define* (cycle . l) @@ -692,7 +701,7 @@ (define* (build-list n f) (let ([n (! n)] [f (! f)]) - (unless (and (integer? n) (exact? n) (>= n 0)) + (unless (exact-nonnegative-integer? n) (error 'build-list "~s must be an exact integer >= 0" n)) (unless (procedure? f) (error 'build-list "~s must be a procedure" f)) diff --git a/collects/macro-debugger/syntax-browser/image.rkt b/collects/macro-debugger/syntax-browser/image.rkt index 1ecf6f788f..2a6e4e12e5 100644 --- a/collects/macro-debugger/syntax-browser/image.rkt +++ b/collects/macro-debugger/syntax-browser/image.rkt @@ -5,7 +5,8 @@ framework "prefs.rkt" "controller.rkt" - "display.rkt") + "display.rkt" + "text.rkt") #| @@ -36,12 +37,10 @@ TODO: tacked arrows ;; print-syntax-columns : (parameter-of (U number 'infinity)) (define print-syntax-columns (make-parameter 40)) -(define standard-text% (text:foreground-color-mixin (editor:standard-style-list-mixin text:basic%))) - ;; print-syntax-to-png : syntax path -> void (define (print-syntax-to-png stx file #:columns [columns (print-syntax-columns)]) - (let ([bmp (print-syntax-to-bitmap stx columns)]) + (let ([bmp (print-syntax-to-bitmap stx #:columns columns)]) (send bmp save-file file 'png)) (void)) @@ -49,8 +48,8 @@ TODO: tacked arrows (define (print-syntax-to-bitmap stx #:columns [columns (print-syntax-columns)]) (define t (prepare-editor stx columns)) - (define f (new frame% [label "dummy"])) - (define ec (new editor-canvas% (editor t) (parent f))) + (define admin (new dummy-admin%)) + (send t set-admin admin) (define dc (new bitmap-dc% (bitmap (make-object bitmap% 1 1)))) (define char-width (let* ([sl (send t get-style-list)] @@ -87,10 +86,20 @@ TODO: tacked arrows (send t print #f #f 'postscript #f #f #t))) (define (prepare-editor stx columns) - (define t (new standard-text%)) + (define t (new browser-text%)) (define sl (send t get-style-list)) (send t change-style (send sl find-named-style (editor:get-default-color-style-name))) (print-syntax-to-editor stx t (new controller%) (new syntax-prefs/readonly%) columns (send t last-position)) t) + +;; dummy editor-admin +(define dummy-admin% + (class editor-admin% + (define the-dc (new bitmap-dc% (bitmap (make-object bitmap% 1 1)))) + (define/override (get-dc [x #f] [y #f]) + (when x (set-box! x 0.0)) + (when y (set-box! y 0.0)) + the-dc) + (super-new))) diff --git a/collects/macro-debugger/syntax-browser/keymap.rkt b/collects/macro-debugger/syntax-browser/keymap.rkt index 6544f7d902..4949134b54 100644 --- a/collects/macro-debugger/syntax-browser/keymap.rkt +++ b/collects/macro-debugger/syntax-browser/keymap.rkt @@ -118,7 +118,7 @@ (demand-callback (lambda (i) (let ([stx (selected-syntax)]) - (when stx + (when (identifier? stx) (send i set-label (format "Format ~s ~a" (syntax-e stx) (cadr sym+desc))))))) (callback diff --git a/collects/macro-debugger/syntax-browser/text.rkt b/collects/macro-debugger/syntax-browser/text.rkt index 7d005312bf..334bac4976 100644 --- a/collects/macro-debugger/syntax-browser/text.rkt +++ b/collects/macro-debugger/syntax-browser/text.rkt @@ -17,7 +17,8 @@ text:tacking-mixin text:arrows-mixin text:region-data-mixin - text:clickregion-mixin) + text:clickregion-mixin + browser-text%) (define arrow-cursor (make-object cursor% 'arrow)) @@ -115,14 +116,16 @@ find-position) (define/override (on-default-event ev) - (define gx (send ev get-x)) - (define gy (send ev get-y)) - (define-values (x y) (dc-location-to-editor-location gx gy)) - (define pos (find-position x y)) (super on-default-event ev) (case (send ev get-event-type) ((enter motion leave) - (update-hover-position pos)))) + (define-values (x y) + (let ([gx (send ev get-x)] + [gy (send ev get-y)]) + (dc-location-to-editor-location gx gy))) + (define on-it? (box #f)) + (define pos (find-position x y #f on-it?)) + (update-hover-position (and (unbox on-it?) pos))))) (define/public (update-hover-position pos) (void)) @@ -344,10 +347,13 @@ Like clickbacks, but: (interval-map-remove! clickbacks start end))) (define/private (get-event-position ev) - (define gx (send ev get-x)) - (define gy (send ev get-y)) - (define-values (x y) (dc-location-to-editor-location gx gy)) - (find-position x y)) + (define-values (x y) + (let ([gx (send ev get-x)] + [gy (send ev get-y)]) + (dc-location-to-editor-location gx gy))) + (define on-it? (box #f)) + (define pos (find-position x y #f on-it?)) + (and (unbox on-it?) pos)) (define/override (on-default-event ev) (define admin (get-admin)) @@ -355,11 +361,11 @@ Like clickbacks, but: (define pos (get-event-position ev)) (case (send ev get-event-type) ((left-down) - (set! tracking (interval-map-ref clickbacks pos #f)) + (set! tracking (and pos (interval-map-ref clickbacks pos #f))) (send admin update-cursor)) ((left-up) (when tracking - (let ([cb (interval-map-ref clickbacks pos #f)] + (let ([cb (and pos (interval-map-ref clickbacks pos #f))] [tracking* tracking]) (set! tracking #f) (when (eq? tracking* cb) @@ -369,7 +375,7 @@ Like clickbacks, but: (define/override (adjust-cursor ev) (define pos (get-event-position ev)) - (define cb (interval-map-ref clickbacks pos #f)) + (define cb (and pos (interval-map-ref clickbacks pos #f))) (if cb arrow-cursor (super adjust-cursor ev))))) @@ -405,3 +411,25 @@ Like clickbacks, but: [else (search (cdr idlocs))]))) (super-new))) |# + + +(define browser-text% + (let ([browser-text-default-style-name "widget.rkt::browser-text% basic"]) + (class (text:clickregion-mixin + (text:arrows-mixin + (text:tacking-mixin + (text:hover-drawings-mixin + (text:hover-mixin + (text:region-data-mixin + (text:hide-caret/selection-mixin + (text:foreground-color-mixin + (editor:standard-style-list-mixin text:basic%))))))))) + (inherit set-autowrap-bitmap get-style-list) + (define/override (default-style-name) browser-text-default-style-name) + (super-new (auto-wrap #t)) + (let* ([sl (get-style-list)] + [standard (send sl find-named-style (editor:get-default-color-style-name))] + [browser-basic (send sl find-or-create-style standard + (make-object style-delta% 'change-family 'default))]) + (send sl new-named-style browser-text-default-style-name browser-basic)) + (set-autowrap-bitmap #f)))) diff --git a/collects/macro-debugger/syntax-browser/widget.rkt b/collects/macro-debugger/syntax-browser/widget.rkt index 93783f30f3..fbae429032 100644 --- a/collects/macro-debugger/syntax-browser/widget.rkt +++ b/collects/macro-debugger/syntax-browser/widget.rkt @@ -247,26 +247,3 @@ (send sd set-delta 'change-italic) (send sd set-delta-foreground "red") sd)) - -;; Specialized classes for widget - -(define browser-text% - (let ([browser-text-default-style-name "widget.rkt::browser-text% basic"]) - (class (text:clickregion-mixin - (text:arrows-mixin - (text:tacking-mixin - (text:hover-drawings-mixin - (text:hover-mixin - (text:region-data-mixin - (text:hide-caret/selection-mixin - (text:foreground-color-mixin - (editor:standard-style-list-mixin text:basic%))))))))) - (inherit set-autowrap-bitmap get-style-list) - (define/override (default-style-name) browser-text-default-style-name) - (super-new (auto-wrap #t)) - (let* ([sl (get-style-list)] - [standard (send sl find-named-style (editor:get-default-color-style-name))] - [browser-basic (send sl find-or-create-style standard - (make-object style-delta% 'change-family 'default))]) - (send sl new-named-style browser-text-default-style-name browser-basic)) - (set-autowrap-bitmap #f)))) diff --git a/collects/meta/build/build b/collects/meta/build/build index 10f7f21200..30abc55cb7 100755 --- a/collects/meta/build/build +++ b/collects/meta/build/build @@ -95,7 +95,7 @@ defbuild "ccs-linux" "i386-linux-ubuntu-jaunty" "moveto=/proj/racket" # defbuild "punge" "i386-linux-ubuntu-jaunty" "renice=20" # defbuild "bjorn" "i386-linux-gcc2" # defbuild "chicago" "i386-linux-debian" -defbuild "brownbuild" "i386-linux-debian" # really an AMD64 machine +# defbuild "brownbuild" "i386-linux-debian" # really an AMD64 machine # defbuild "inga" "i386-freebsd" # defbuild "chicago-unstable" "i386-linux-debian-unstable" # Start the main build last @@ -1355,9 +1355,9 @@ DO_WIN32_BUILD() { build_w32step VSNET "mzstart" build_w32step VSNET "mrstart" - _cd "$PLTHOME" - build_w32step RKT "get-libs (gui)" src/get-libs.rkt core src/gracket lib - build_w32step RKT "get-libs (gui)" src/get-libs.rkt gui src/gracket lib + _cd "$PLTHOME/lib" + build_w32step RKT "get-libs (gui)" ../src/get-libs.rkt core + build_w32step RKT "get-libs (gui)" ../src/get-libs.rkt gui separator "win32: Building libraries" _cd "$PLTHOME" diff --git a/collects/meta/build/bundle b/collects/meta/build/bundle index 79c6f3cbf3..c7e080a1ea 100755 --- a/collects/meta/build/bundle +++ b/collects/meta/build/bundle @@ -227,7 +227,7 @@ (error 'binaries "no binaries found for ~s" platform))) *platforms* *platform-tree-lists*) ;; Get the racket tree, remove junk and binary stuff - (set-racket-tree! racket-base/ racket/-name *platform-tree-lists*) + (set-racket-tree! racket/ racket-base/ racket/-name *platform-tree-lists*) (set-bin-files-delayed-lists! (delay (map (lambda (trees) (sort* (mappend tree-flatten (add-trees trees)))) diff --git a/collects/meta/build/versionpatch b/collects/meta/build/versionpatch index a42091c1e6..8e62e6113d 100755 --- a/collects/meta/build/versionpatch +++ b/collects/meta/build/versionpatch @@ -3,8 +3,8 @@ exec racket -um "$0" "$@" |# -#lang scheme/base -(require version/utils scheme/file) +#lang racket/base +(require version/utils racket/file) (define (patches) ;; no grouping parens in regexps @@ -21,7 +21,9 @@ exec racket -um "$0" "$@" (concat "\r\n *VALUE \"FileVersion\", *\""commas "(?:\\\\0)?\"") (concat "\r\n *VALUE \"ProductVersion\", *\""commas - "(?:\\\\0)?\""))]) + "(?:\\\\0)?\""))] + [manifest-patch (list (concat "assemblyIdentity[ \r\n]+" + "version=\""periods"\"[ \r\n]"))]) `([#t ; only verify that it has the right contents "src/racket/src/schvers.h" ,(concat "\n#define MZSCHEME_VERSION \"<1>.<2>" @@ -35,9 +37,9 @@ exec racket -um "$0" "$@" "0" (format "<~a>" (cadr x+n)))))] ["src/worksp/racket/racket.rc" ,@rc-patch] ["src/worksp/gracket/gracket.rc" ,@rc-patch] - ["src/worksp/starters/start.rc" ,@rc-patch] - ["src/worksp/gracket/gracket.manifest" - ,(concat "assemblyIdentity *\r\n *version *= *\""periods"\" *\r\n")] + ["src/worksp/starters/start.rc" ,@rc-patch] + ["src/worksp/racket/racket.manifest" ,@manifest-patch] + ["src/worksp/gracket/gracket.manifest" ,@manifest-patch] ["src/worksp/mzcom/mzobj.rgs" ,(concat "MzCOM.MzObj."periods" = s 'MzObj Class'") ,(concat "CurVer = s 'MzCOM.MzObj."periods"'") diff --git a/collects/meta/check-dists.rkt b/collects/meta/check-dists.rkt index 600bdb1ba1..4726d845b7 100644 --- a/collects/meta/check-dists.rkt +++ b/collects/meta/check-dists.rkt @@ -22,7 +22,7 @@ (register-spec! 'verify! verify!) (register-spec! 'distribute! void) - (set-racket-tree! racket-base/ racket/-name null) + (set-racket-tree! racket/ racket-base/ racket/-name null) (set-bin-files-delayed-lists! ;; FIXME: hard-wired list of binary-specific files diff --git a/collects/meta/checker.rkt b/collects/meta/checker.rkt index 8a5acc53d5..9d17a223f8 100644 --- a/collects/meta/checker.rkt +++ b/collects/meta/checker.rkt @@ -3,7 +3,8 @@ #lang scheme/base -(require scheme/cmdline scheme/runtime-path scheme/match scheme/promise +(require scheme/cmdline scheme/runtime-path scheme/match scheme/promise + scheme/list ; for use in specs too (for-syntax scheme/base) ; for runtime-path (except-in scheme/mpair mappend) (only-in (lib "process.ss") system) @@ -560,8 +561,10 @@ (provide checker-namespace-anchor) (define-namespace-anchor checker-namespace-anchor) +(define racket/ #f) (provide set-racket-tree!) -(define (set-racket-tree! racket-base/ racket/-name tree-lists) +(define (set-racket-tree! racket/* racket-base/ racket/-name tree-lists) + (set! racket/ racket/*) (set! *platform-tree-lists* tree-lists) (dprintf "Scanning main tree...") (set! *racket-tree* diff --git a/collects/meta/dist-specs.rkt b/collects/meta/dist-specs.rkt index acf8eb8b24..ece9509c83 100644 --- a/collects/meta/dist-specs.rkt +++ b/collects/meta/dist-specs.rkt @@ -316,13 +316,14 @@ package: := ;; Utility for pulling out the names of libraries get-libs: := (lambda (p) - (let* ([xs (parameterize ([current-command-line-arguments - '#("--no-op" "" "" "")]) + (let* ([xs (parameterize ([current-command-line-arguments '#("nothing")]) (dynamic-require (build-path racket/ "src" "get-libs.rkt") 'all-files+sizes))] [xs (or (assq p xs) (error 'get-libs "unknown package, ~s" p))] [xs (append-map cdr (cdr xs))] - [xs (remove-duplicates (map car xs))]) + [xs (map (lambda (x) (if (>= (length x) 3) (list-ref x 2) (car x))) + xs)] + [xs (remove-duplicates xs)]) `(lib: ,@xs))) ;; ============================================================================ diff --git a/collects/meta/drdr/config.rkt b/collects/meta/drdr/config.rkt index 074ea8198e..534844d9eb 100644 --- a/collects/meta/drdr/config.rkt +++ b/collects/meta/drdr/config.rkt @@ -10,6 +10,7 @@ (git-path "/usr/bin/git") (Xvfb-path "/usr/bin/Xvnc") (fluxbox-path "/usr/bin/fluxbox") +(vncviewer-path "/usr/bin/vncviewer") (current-make-install-timeout-seconds (* 90 60)) (current-make-timeout-seconds (* 90 60)) (current-subprocess-timeout-seconds 90) diff --git a/collects/meta/drdr/dirstruct.rkt b/collects/meta/drdr/dirstruct.rkt index 3d182947f4..c31642fb54 100644 --- a/collects/meta/drdr/dirstruct.rkt +++ b/collects/meta/drdr/dirstruct.rkt @@ -31,6 +31,9 @@ (define fluxbox-path (make-parameter "/usr/bin/fluxbox")) +(define vncviewer-path + (make-parameter "/usr/bin/vncviewer")) + (define (plt-repository) (build-path (plt-directory) "repo")) @@ -100,6 +103,7 @@ [drdr-directory (parameter/c path-string?)] [make-path (parameter/c (or/c false/c string?))] [Xvfb-path (parameter/c (or/c false/c string?))] + [vncviewer-path (parameter/c (or/c false/c string?))] [fluxbox-path (parameter/c (or/c false/c string?))] [build? (parameter/c boolean?)] [on-unix? (-> boolean?)] diff --git a/collects/meta/drdr/plt-build.rkt b/collects/meta/drdr/plt-build.rkt index 08848cbccb..9fa0a24b75 100644 --- a/collects/meta/drdr/plt-build.rkt +++ b/collects/meta/drdr/plt-build.rkt @@ -211,7 +211,7 @@ (lambda () (list* gracket-path "-display" - (format ":~a" (+ XSERVER-OFFSET (current-worker))) + (format ":~a" (cpu->child (current-worker))) rst)) #f)] [_ @@ -224,7 +224,7 @@ void (λ () (define l (pth-cmd)) - (with-env (["DISPLAY" (format ":~a" (+ XSERVER-OFFSET (current-worker)))]) + (with-env (["DISPLAY" (format ":~a" (cpu->child (current-worker)))]) (with-temporary-home-directory (with-temporary-directory (run/collect/wait/log log-pth @@ -277,6 +277,10 @@ (recur-many (sub1 i) r f))))) (define XSERVER-OFFSET 20) +(define (cpu->parent cpu-i) + (+ XSERVER-OFFSET (* cpu-i 2) 0)) +(define (cpu->child cpu-i) + (+ XSERVER-OFFSET (* cpu-i 2) 1)) (define (integrate-revision rev) (define test-dir @@ -314,20 +318,34 @@ (get-scm-commit-msg rev (plt-repository)))) (when (build?) (build-revision rev)) - (recur-many (number-of-cpus) - (lambda (j inner) - (define i (+ j XSERVER-OFFSET)) - (notify! "Starting X server #~a" i) - (safely-delete-directory (format "/tmp/.X~a-lock" i)) - (safely-delete-directory (build-path tmp-dir (format ".X~a-lock" i))) - (safely-delete-directory (format "/tmp/.tX~a-lock" i)) - (safely-delete-directory (build-path tmp-dir (format ".tX~a-lock" i))) + + (define (start-x-server i parent inner) + (notify! "Starting X server #~a" i) + (safely-delete-directory (format "/tmp/.X~a-lock" i)) + (safely-delete-directory (build-path tmp-dir (format ".X~a-lock" i))) + (safely-delete-directory (format "/tmp/.tX~a-lock" i)) + (safely-delete-directory (build-path tmp-dir (format ".tX~a-lock" i))) + (with-running-program + (Xvfb-path) (list (format ":~a" i) "-ac" "-rfbauth" "/home/jay/.vnc/passwd") + (lambda () + (sleep 1) + (with-running-program + (fluxbox-path) (list "-display" (format ":~a" i) "-rc" "/home/jay/.fluxbox/init") + (if parent + (lambda () (with-running-program - (Xvfb-path) (list (format ":~a" i) "-ac" "-rfbauth" "/home/jay/.vnc/passwd") - (lambda () - (with-running-program - (fluxbox-path) (list "-display" (format ":~a" i) "-rc" "/home/jay/.fluxbox/init") - inner)))) + (vncviewer-path) (list "-display" (format ":~a" parent) (format ":~a" i) + "-passwd" "/home/jay/.vnc/passwd") + inner)) + inner))))) + + (recur-many (number-of-cpus) + (lambda (cpu-i inner) + (define parent (cpu->parent cpu-i)) + (define child (cpu->child cpu-i)) + (start-x-server parent #f + (λ () + (start-x-server child parent inner)))) (lambda () (test-revision rev))))) ; Remove the test directory diff --git a/collects/meta/props b/collects/meta/props index 8c421d0941..d5ac171001 100755 --- a/collects/meta/props +++ b/collects/meta/props @@ -1198,6 +1198,8 @@ path/s is either such a string or a list of them. "collects/redex/examples/church.rkt" drdr:command-line (mzc *) "collects/redex/examples/combinators.rkt" drdr:command-line (mzc *) "collects/redex/examples/compatible-closure.rkt" drdr:command-line (mzc *) +"collects/redex/examples/delim-cont/randomized-tests-test.rkt" drdr:timeout 240 drdr:random #t +"collects/redex/examples/delim-cont/randomized-tests.rkt" drdr:random #t "collects/redex/examples/delim-cont/test.rkt" drdr:command-line (mzc *) "collects/redex/examples/letrec.rkt" drdr:command-line (mzc *) "collects/redex/examples/omega.rkt" drdr:command-line (mzc *) @@ -1416,6 +1418,7 @@ path/s is either such a string or a list of them. "collects/tests/drracket/hangman.rkt" responsible (robby matthias) drdr:command-line (gracket *) "collects/tests/drracket/io.rkt" drdr:command-line (gracket *) "collects/tests/drracket/language-test.rkt" responsible (robby matthias) drdr:command-line (gracket *) drdr:timeout 600 +"collects/tests/drracket/leaky-frame.rkt" drdr:command-line (gracket *) "collects/tests/drracket/memory-log.rkt" drdr:command-line (gracket *) "collects/tests/drracket/module-lang-test-utils.rkt" drdr:command-line (gracket-text "-t" *) "collects/tests/drracket/module-lang-test.rkt" drdr:command-line (gracket *) drdr:timeout 120 @@ -1463,6 +1466,7 @@ path/s is either such a string or a list of them. "collects/tests/gracket/dc.rktl" drdr:command-line (gracket "-f" *) "collects/tests/gracket/draw.rkt" drdr:command-line (mzc *) "collects/tests/gracket/editor.rktl" drdr:command-line (gracket "-f" *) +"collects/tests/gracket/flush-stress.rkt" drdr:command-line #f "collects/tests/gracket/gui-main.rktl" drdr:command-line (gracket "-f" *) "collects/tests/gracket/gui.rktl" drdr:command-line (gracket "-f" *) "collects/tests/gracket/item.rkt" drdr:command-line (mzc *) @@ -1476,6 +1480,7 @@ path/s is either such a string or a list of them. "collects/tests/gracket/test-editor-admin.rkt" drdr:command-line (gracket-text "-t" *) "collects/tests/gracket/testing.rktl" drdr:command-line (gracket "-f" *) "collects/tests/gracket/text-scale.rktl" drdr:command-line #f +"collects/tests/gracket/unflushed-circle.rkt" drdr:command-line #f "collects/tests/gracket/windowing.rktl" drdr:command-line (gracket "-f" *) "collects/tests/gracket/wxme-doc-random.rkt" drdr:command-line (mzc *) "collects/tests/gracket/wxme-random.rkt" drdr:command-line #f diff --git a/collects/meta/web/common/links.rkt b/collects/meta/web/common/links.rkt index 5bb5ed731c..96c6ba666d 100644 --- a/collects/meta/web/common/links.rkt +++ b/collects/meta/web/common/links.rkt @@ -29,13 +29,13 @@ ;; External links (define* -htdp - @make-link["http://www.htdp.org/"]{@i{How to Design Programs}}) + @make-link["http://htdp.org/"]{@i{How to Design Programs}}) (define* -redex @make-link["http://redex.plt-scheme.org/"]{Redex}) -(define* -teachscheme - @make-link["http://www.teach-scheme.org/"]{TeachScheme!}) +(define* -pbd + @make-link["http://programbydesign.org/"]{Program by Design}) (define* -cookbook @make-link["http://schemecookbook.org/"]{Schematics Scheme Cookbook}) diff --git a/collects/meta/web/stubs/git.rkt b/collects/meta/web/stubs/git.rkt index 1c4056e3e2..d4cf9e4842 100644 --- a/collects/meta/web/stubs/git.rkt +++ b/collects/meta/web/stubs/git.rkt @@ -96,7 +96,6 @@ (define git-host "git.racket-lang.org") (define at-racket "@racket-lang.org") (define at-git-racket "@git.racket-lang.org") -(define at-lists-racket "@lists.racket-lang.org") (define (npre . text) (apply pre style: "margin-left: 0;" text)) (define style @style/inline[type: 'text/css]{ @@ -2579,7 +2578,7 @@ and you can see more in the @man{git-config} and @man{git-send-email} man pages. The address to send the patches to is also configurable — you can use something like - @pre{to = plt-dev@at-lists-racket} + @pre{to = dev@at-racket} or @pre{to = someone@at-racket} depending on who you send your patches to — but this is better done as a @@ -2738,7 +2737,17 @@ it shares history with yours, you can just pull that branch in, for example: @pre{git checkout -b someones-work git pull @i{someones-repository-url}} - or, if you expect to do this often (eg, you're going to suggest fixes for the + Note that the @cmd{pull} will merge the changes, creating a merge + commit if your @cmd{master} branch cannot be fast-forwarded. To avoid + this, you can use @cmd{fetch} instead: + @pre{git checkout -b someones-work + git fetch @i{someones-repository-url}} + Either way, this fetches the remote repository's HEAD. You can create + the branch in a single fetch command by specifying the remote branch + name, and the local branch to fetch into, for example: + @pre{git fetch @i{someones-repository-url} master:someone} +@~ + If you expect to do this often (eg, you're going to suggest fixes for the work and get new work in), then you can add a @cmd{someone} remote to be used more conveniently: @pre{git remote add someone @i{someones-repository-url} @@ -2746,6 +2755,8 @@ git checkout -b some-branch someone/some-branch} possibly using -t to make the branch track the remote one: @pre{git checkout -tb some-branch someone/some-branch} + Note that there is no need to create a branch before the @cmd{fetch}, since + it will be fetched to a @cmd{remotes/someone/master} branch. @~ Once you pulled in the branch, you can inspect the changes, merge them, rebase them, etc. The important point here is that you have a copy of the @@ -2758,11 +2769,11 @@ usual. @~ Git has a tool that makes this mode of work a little more organized and - robust: @cmd{git request-pull}. This simple command (surprisingly, it has no - flags) is intended to be used by the contributor. It expects a commit that - marks the start of the new work (actually, the last one before it, eg, - @cmd{origin/master}), and the url of the repository. For example: - @pre{git request-pull origin git://github.com/someone/somefork.git} + robust for the contributor: @cmd{git request-pull}. This simple + command (surprisingly, it has no flags) expects a commit that marks the start + of the new work (actually, the last one before it, eg, @cmd{origin/master}), + and the url of the repository. For example: @pre{git request-pull origin + git://github.com/someone/somefork.git} @~ Of course, the contributor doesn't have to work directly in the available repository — in the case of github or with an over-the-web setup like the one @@ -2784,6 +2795,55 @@ @cmd{git request-pull origin .}, and get a condensed summary of your changes.)} +@subsection{Pull-request workflow@br + — recipe for the sender side} +@ol*{@~ Clone the plt repository and work with it as usual, commit your work + @~ Make your repository publicly available + @~ @npre{$ git request-pull origin @i{your-repository-url}} + @~ Send the resulting text to @cmd{dev@at-racket} + @~ You're done — thanks!} +@p{Alternatively, you can fork the plt repository on github: + @cmd{http://github.com/plt/racket}, commit, then do a pull request. Note: + it is better to send a note about your pull request to @cmd{dev@at-racket}, + or you can do the pull request directly with git as listed above (using + github to have a public repository).} + +@subsection{Pull-request workflow@br + — recipe for the receiver side} +@p{This recipe is for getting some remote work in as a one-time job. If you + need to cooperate more closely with someone, you will want to add the remote + repository with @cmd{git remote} as shown above.} +@ol*{ +@~ Get a plt clone, or use your own (it's safe to do the latter, no need for a + new clone unless you're paranoid): + @pre{git clone pltgit:plt + cd plt} +@~ Get the foreign repository's master branch (or any other branch) into a + local branch: + @pre{git fetch @i{remote-repository-url} master:foo} + This pulls the @cmd{master} branch of the remote repository into a local + @cmd{foo} branch (you can use other names, of course). +@~ Inspect the changes as usual + @pre{git log master..foo # new commits + git diff master...foo # changes + git log -p master..foo # both} + (See above for more details on these.) +@~ If you're happy with the change and want to get it as-is, you can simply + @cmd{merge} the branch: + @pre{git merge foo} + But unless the remote work was done from the point your @cmd{master} points + at (i.e., there were no new commits), this will generate a merge commit that + might not be desired. To avoid it, you can rebase the branch against your + @cmd{master} and then do the @cmd{merge} (which will now be a fast-forward) + merge: + @pre{git checkout foo + git rebase master + git checkout master + git merge foo} +@~ You no longer need the @cmd{foo} branch, so delete it with: + @pre{git branch -d foo} +@~ Push things back as usual} + @section{Additional Resources} @dl*{ @~ @strong{Quick and short:} diff --git a/collects/meta/web/stubs/wiki.rkt b/collects/meta/web/stubs/wiki.rkt index 11c3f29732..62f8198eb6 100644 --- a/collects/meta/web/stubs/wiki.rkt +++ b/collects/meta/web/stubs/wiki.rkt @@ -4,12 +4,8 @@ (define-context "stubs/wiki" #:resources www:the-resources) -(define header+footer - (delay (regexp-split #rx"{{{BODY}}}" - (xml->string @page[#:id 'browse-downloads - #:html-only #t - #:part-of 'download - "{{{BODY}}}"])))) - (define template - @page[#:title "{{{TITLE}}}" "{{{BODY}}}"]) + (page #:title "{{{TITLE}}}" + #:extra-headers "{{{HEADERS}}}" + #:extra-body-attrs '(|{{{ATTRS}}}|: #t) + "{{{BODY}}}")) diff --git a/collects/meta/web/www/learning.rkt b/collects/meta/web/www/learning.rkt index 42852f3f79..3e9ed876d1 100644 --- a/collects/meta/web/www/learning.rkt +++ b/collects/meta/web/www/learning.rkt @@ -14,7 +14,7 @@ @text{@-plai — a textbook on programming languages.}] @parlist[ @strong{Outreach} - @text{@-teachscheme — a workshop to train teachers using @-htdp in the + @text{@-pbd — a workshop to train teachers using @-htdp in the classroom.} @text{@-bootstrap — a curriculum for middle-school students.}] @(apply parlist @strong{PLT Publications} diff --git a/collects/mred/mred-sig.rkt b/collects/mred/mred-sig.rkt index 1f8aa21788..0b5efef1eb 100644 --- a/collects/mred/mred-sig.rkt +++ b/collects/mred/mred-sig.rkt @@ -143,6 +143,7 @@ open-output-text-editor pane% panel% pasteboard% +pdf-dc% pen% pen-list% play-sound diff --git a/collects/mred/private/mritem.rkt b/collects/mred/private/mritem.rkt index 6d2a89f530..0302d72b08 100644 --- a/collects/mred/private/mritem.rkt +++ b/collects/mred/private/mritem.rkt @@ -58,7 +58,7 @@ ;; for keyword use [font no-val]) (rename [super-set-label set-label]) - (private-field [label lbl][callback cb]) + (private-field [label lbl][callback cb] [is-bitmap? (lbl . is-a? . wx:bitmap%)]) (override [get-label (lambda () label)] [get-plain-label (lambda () (and (string? label) (wx:label->plain-label label)))] @@ -69,8 +69,12 @@ (let ([l (if (string? l) (string->immutable-string l) l)]) - (send wx set-label l) - (set! label l))))]) + (when (or (and is-bitmap? + (l . is-a? . wx:bitmap%)) + (and (not is-bitmap?) + (string? l))) + (send wx set-label l) + (set! label l)))))]) (public [hidden-child? (lambda () #f)] ; module-local method [label-checker (lambda () check-label-string/false)] ; module-local method diff --git a/collects/mred/private/mrtop.rkt b/collects/mred/private/mrtop.rkt index c107cfb154..a290834db2 100644 --- a/collects/mred/private/mrtop.rkt +++ b/collects/mred/private/mrtop.rkt @@ -237,7 +237,7 @@ (check-label-string cwho label) (check-top-level-parent/false cwho parent) (for-each (lambda (x) (check-dimension cwho x)) (list width height x y)) - (check-style cwho #f '(no-caption resize-border no-sheet) style))) + (check-style cwho #f '(no-caption resize-border no-sheet close-button) style))) (rename [super-on-subwindow-char on-subwindow-char]) (private-field [wx #f]) (override diff --git a/collects/mred/private/wx/cocoa/README.txt b/collects/mred/private/wx/cocoa/README.txt index b989a69751..df66a5c0a3 100644 --- a/collects/mred/private/wx/cocoa/README.txt +++ b/collects/mred/private/wx/cocoa/README.txt @@ -3,7 +3,7 @@ Allocation rules: * Use `as-objc-allocation' when creating a Cocoa object. When the resulting reference becomes unreachable, the Cocoa object will be - releaset. + released. * Use `with-autorelease' in atomic mode around calls that autorelease and where the release should take effect immediate. Do not create diff --git a/collects/mred/private/wx/cocoa/button.rkt b/collects/mred/private/wx/cocoa/button.rkt index 48e97919a6..1987e278ee 100644 --- a/collects/mred/private/wx/cocoa/button.rkt +++ b/collects/mred/private/wx/cocoa/button.rkt @@ -66,12 +66,18 @@ (string? label)) (when font (let ([n (send font get-point-size)]) + ;; If the font is small, adjust the control size: (when (n . < . sys-font-size) (tellv (tell cocoa cell) setControlSize: #:type _int (if (n . < . (- sys-font-size 2)) NSMiniControlSize - NSSmallControlSize))))) + NSSmallControlSize)) + (tellv cocoa sizeToFit)) + ;; If the font is big, use a scalable control shape: + (when (n . > . (+ sys-font-size 2)) + (tellv cocoa setBezelStyle: #:type _int NSRegularSquareBezelStyle) + (tellv cocoa sizeToFit)))) (let ([frame (tell #:type _NSRect cocoa frame)]) (tellv cocoa setFrame: #:type _NSRect (make-NSRect (NSRect-origin frame) @@ -81,41 +87,42 @@ (NSSize-height (NSRect-size frame))))))) cocoa)) - (define cocoa (if (and button-type - (not (string? label)) - (send label ok?)) - ;; Check-box image: need an view to join a button and an image view: - ;; (Could we use the NSImageButtonCell from the radio-box implementation - ;; instead?) - (let* ([frame (tell #:type _NSRect button-cocoa frame)] - [new-width (+ (NSSize-width (NSRect-size frame)) - (send label get-width))] - [new-height (max (NSSize-height (NSRect-size frame)) - (send label get-height))]) - (let ([cocoa (as-objc-allocation - (tell (tell NSView alloc) - initWithFrame: #:type _NSRect - (make-NSRect (NSRect-origin frame) - (make-NSSize new-width - new-height))))] - [image-cocoa (as-objc-allocation - (tell (tell NSImageView alloc) init))]) - (tellv cocoa addSubview: button-cocoa) - (tellv cocoa addSubview: image-cocoa) - (tellv image-cocoa setImage: (bitmap->image label)) - (tellv image-cocoa setFrame: #:type _NSRect - (make-NSRect (make-NSPoint (NSSize-width (NSRect-size frame)) - (quotient (- new-height - (send label get-height)) - 2)) - (make-NSSize (send label get-width) - (send label get-height)))) - (tellv button-cocoa setFrame: #:type _NSRect - (make-NSRect (make-NSPoint 0 0) - (make-NSSize new-width new-height))) - (set-ivar! button-cocoa wxb (->wxb this)) - cocoa)) - button-cocoa)) + (define-values (cocoa image-cocoa) + (if (and button-type + (not (string? label)) + (send label ok?)) + ;; Check-box image: need an view to join a button and an image view: + ;; (Could we use the NSImageButtonCell from the radio-box implementation + ;; instead?) + (let* ([frame (tell #:type _NSRect button-cocoa frame)] + [new-width (+ (NSSize-width (NSRect-size frame)) + (send label get-width))] + [new-height (max (NSSize-height (NSRect-size frame)) + (send label get-height))]) + (let ([cocoa (as-objc-allocation + (tell (tell NSView alloc) + initWithFrame: #:type _NSRect + (make-NSRect (NSRect-origin frame) + (make-NSSize new-width + new-height))))] + [image-cocoa (as-objc-allocation + (tell (tell NSImageView alloc) init))]) + (tellv cocoa addSubview: button-cocoa) + (tellv cocoa addSubview: image-cocoa) + (tellv image-cocoa setImage: (bitmap->image label)) + (tellv image-cocoa setFrame: #:type _NSRect + (make-NSRect (make-NSPoint (NSSize-width (NSRect-size frame)) + (quotient (- new-height + (send label get-height)) + 2)) + (make-NSSize (send label get-width) + (send label get-height)))) + (tellv button-cocoa setFrame: #:type _NSRect + (make-NSRect (make-NSPoint 0 0) + (make-NSSize new-width new-height))) + (set-ivar! button-cocoa wxb (->wxb this)) + (values cocoa image-cocoa))) + (values button-cocoa #f))) (define we (make-will-executor)) @@ -140,7 +147,7 @@ [(string? label) (tellv cocoa setTitleWithMnemonic: #:type _NSString label)] [else - (tellv cocoa setImage: (bitmap->image label))])) + (tellv (or image-cocoa cocoa) setImage: (bitmap->image label))])) (define callback cb) (define/public (clicked) diff --git a/collects/mred/private/wx/cocoa/canvas.rkt b/collects/mred/private/wx/cocoa/canvas.rkt index e791fc55d8..7e3d0cdb9a 100644 --- a/collects/mred/private/wx/cocoa/canvas.rkt +++ b/collects/mred/private/wx/cocoa/canvas.rkt @@ -234,6 +234,9 @@ make-graphics-context is-shown-to-root? is-shown-to-before-root? + is-enabled-to-root? + is-window-enabled? + block-mouse-events move get-x get-y on-size register-as-child @@ -272,9 +275,11 @@ ;; are defined by `canvas-mixin' from ../common/canvas-mixin (define/public (queue-paint) (void)) (define/public (request-canvas-flush-delay) - (request-flush-delay (get-cocoa-window))) + (unless is-gl? + (request-flush-delay (get-cocoa-window)))) (define/public (cancel-canvas-flush-delay req) - (cancel-flush-delay req)) + (unless is-gl? + (cancel-flush-delay req))) (define/public (queue-canvas-refresh-event thunk) (queue-window-refresh-event this thunk)) @@ -402,6 +407,11 @@ (super show-children) (resume-all-reg-blits)) + (define/override (fixup-locations-children) + ;; in atomic mode + (suspend-all-reg-blits) + (resume-all-reg-blits)) + (define/private (do-set-size x y w h) (when (pair? blits) (atomically (suspend-all-reg-blits))) @@ -601,6 +611,16 @@ (scroller-page scroller) 1)])) + (define/override (enable-window on?) + ;; in atomic mode + (let ([on? (and on? (is-window-enabled?))]) + (let ([w (tell content-cocoa window)]) + (when (ptr-equal? content-cocoa (tell w firstResponder)) + (tellv w makeFirstResponder: #f))) + (block-mouse-events (not on?)) + (when is-combo? + (tellv content-cocoa setEnabled: #:type _BOOL on?)))) + (define/public (clear-combo-items) (tellv content-cocoa removeAllItems)) (define/public (append-combo-item str) @@ -691,7 +711,7 @@ (define/override (gets-focus?) wants-focus?) (define/override (can-be-responder?) - wants-focus?) + (and wants-focus? (is-enabled-to-root?))) (define/private (on-menu-click? e) ;; Called in Cocoa event-handling mode diff --git a/collects/mred/private/wx/cocoa/dc.rkt b/collects/mred/private/wx/cocoa/dc.rkt index b6c04bf087..b739fa88bd 100644 --- a/collects/mred/private/wx/cocoa/dc.rkt +++ b/collects/mred/private/wx/cocoa/dc.rkt @@ -26,6 +26,7 @@ (init [(cnvs canvas)]) (define canvas cnvs) + (inherit end-delay) (super-new) (define gl #f) @@ -59,21 +60,18 @@ (values (unbox xb) (unbox yb)))) (define/override (queue-backing-flush) - ;; With Cocoa window-level delay doesn't stop - ;; displays; it blocks flushes to the screen. - ;; So leave the delay in place, and `end-delay' - ;; after displaying to the window (after which - ;; we'll be ready to flush the window), which - ;; is at then end of `do-backing-flush'. + ;; Re-enable expose events so that the queued + ;; backing flush will be handled: + (end-delay) (send canvas queue-backing-flush)) (define/override (flush) (send canvas flush)) (define/override (request-delay) - (request-flush-delay (send canvas get-flush-window))) + (send canvas request-canvas-flush-delay)) (define/override (cancel-delay req) - (cancel-flush-delay req)))) + (send canvas cancel-canvas-flush-delay req)))) (define (do-backing-flush canvas dc ctx dx dy) (tellv ctx saveGraphicsState) @@ -99,6 +97,5 @@ (cairo_fill cr) (cairo_set_source cr s) (cairo_pattern_destroy s)) - (cairo_destroy cr)))) - (send dc end-delay))) + (cairo_destroy cr)))))) (tellv ctx restoreGraphicsState))) diff --git a/collects/mred/private/wx/cocoa/filedialog.rkt b/collects/mred/private/wx/cocoa/filedialog.rkt index 22d161ac46..3e6d35d1e1 100644 --- a/collects/mred/private/wx/cocoa/filedialog.rkt +++ b/collects/mred/private/wx/cocoa/filedialog.rkt @@ -41,11 +41,11 @@ (let ([a (tell NSArray arrayWithObjects: #:type (_list i _NSString) extensions count: #:type _NSUInteger (length extensions))]) - (tellv ns setAllowedFileTypes: a)))) - (let ([others? (ormap (lambda (e) - (equal? (cadr e) "*.*")) - filters)]) - (tellv ns setAllowsOtherFileTypes: #:type _BOOL others?)) + (tellv ns setAllowedFileTypes: a)) + (let ([others? (ormap (lambda (e) + (equal? (cadr e) "*.*")) + filters)]) + (tellv ns setAllowsOtherFileTypes: #:type _BOOL others?)))) (cond [(memq 'multi style) @@ -57,15 +57,19 @@ (when message (tellv ns setMessage: #:type _NSString message)) (when directory - (tellv ns setDirectoryURL: (tell NSURL - fileURLWithPath: #:type _NSString (if (string? directory) - directory - (path->string directory)) - isDirectory: #:type _BOOL #t))) + (let ([dir (if (string? directory) + directory + (path->string directory))]) + (if (version-10.6-or-later?) + (tellv ns setDirectoryURL: (tell NSURL + fileURLWithPath: #:type _NSString dir + isDirectory: #:type _BOOL #t)) + (tellv ns setDirectory: #:type _NSString dir)))) (when filename - (tellv ns setNameFieldStringValue: #:type _NSString (path->string - (file-name-from-path filename)))) - + (when (version-10.6-or-later?) + (tellv ns setNameFieldStringValue: #:type _NSString (path->string + (file-name-from-path filename))))) + (when (memq 'enter-packages style) (tellv ns setTreatsFilePackagesAsDirectories: #:type _BOOL #t)) @@ -74,7 +78,9 @@ ;; all other eventspaces and threads. It would be nice to improve ;; on this, but it's good enough. (atomically - (let ([front (get-front)]) + (let ([front (get-front)] + [parent (and (version-10.6-or-later?) + parent)]) (when parent (tellv ns beginSheetModalForWindow: (send parent get-cocoa-window) completionHandler: #f)) diff --git a/collects/mred/private/wx/cocoa/finfo.rkt b/collects/mred/private/wx/cocoa/finfo.rkt index b4090a9fe8..300386efd5 100644 --- a/collects/mred/private/wx/cocoa/finfo.rkt +++ b/collects/mred/private/wx/cocoa/finfo.rkt @@ -65,8 +65,6 @@ (define _FSRef _pointer) ; 80 bytes -(define _OSStatus _sint32) - (define-coreserv FSPathMakeRef (_fun _path _FSRef (_pointer = #f) -> _OSStatus)) (define-coreserv FSGetCatalogInfo @@ -112,7 +110,7 @@ v #f #f #f)]) (unless (zero? r) - (error 'file-creator-and-file "lookup failed (~a): ~e" + (error 'file-creator-and-type "lookup failed (~a): ~e" r path)))) @@ -122,7 +120,7 @@ (unless (path-string? path) (raise-type-error 'file-creator-and-type "path string" path)) (let ([info (let ([fs (path->fsref path)] - [v (cast (malloc 256) _pointer _FSCatalogInfo-pointer)]) + [v (cast (malloc 256) _pointer (_gcable _FSCatalogInfo-pointer))]) (get-info v fs path) (FSCatalogInfo-finderInfo v))]) (values (int->str (FileInfo-fileCreator info)) @@ -135,7 +133,7 @@ (unless (and (bytes? type) (= 4 (bytes-length type))) (raise-type-error 'file-creator-and-type "bytes string of length 4" type)) (let ([fs (path->fsref path)] - [v (cast (malloc 256) _pointer _FSCatalogInfo-pointer)]) + [v (cast (malloc 256) _pointer (_gcable _FSCatalogInfo-pointer))]) (get-info v fs path) (let ([info (FSCatalogInfo-finderInfo v)]) (set-FileInfo-fileCreator! info (str->int creator)) @@ -144,7 +142,7 @@ kFSCatInfoFinderInfo v)]) (unless (zero? r) - (error 'file-creator-and-file "change failed (~a): ~e" + (error 'file-creator-and-type "change failed (~a): ~e" r path)))) (void)])) diff --git a/collects/mred/private/wx/cocoa/frame.rkt b/collects/mred/private/wx/cocoa/frame.rkt index 7779a02075..ffe008e466 100644 --- a/collects/mred/private/wx/cocoa/frame.rkt +++ b/collects/mred/private/wx/cocoa/frame.rkt @@ -36,6 +36,9 @@ (define empty-mb (new menu-bar%)) (define root-fake-frame #f) +;; Maps window numbers to weak boxes of frame objects; +;; the weak-box layer is needed to avoid GC-accounting +;; problems. (define all-windows (make-hash)) (define-objc-mixin (MyWindowMethods Superclass) @@ -138,7 +141,8 @@ get-eventspace pre-on-char pre-on-event get-x - on-new-child) + on-new-child + is-window-enabled?) (super-new [parent parent] [cocoa @@ -164,7 +168,9 @@ NSTitledWindowMask (if is-sheet? NSUtilityWindowMask 0) (if is-dialog? - 0 + (if (memq 'close-button style) + NSClosableWindowMask + 0) (bitwise-ior NSClosableWindowMask NSMiniaturizableWindowMask @@ -187,7 +193,7 @@ (tellv tb setVisible: #:type _BOOL #f) (tellv tb release)))) - (move -11111 (if (= y -11111) 0 y)) + (internal-move -11111 (if (= y -11111) 0 y)) (tellv cocoa setAcceptsMouseMovedEvents: #:type _BOOL #t) @@ -268,6 +274,7 @@ (for/or ([i (in-range (tell #:type _NSUInteger wins count))]) (let ([win (tell wins objectAtIndex: #:type _NSUInteger i)]) (and (tell #:type _BOOL win isVisible) + (not (tell win parentWindow)) (or (not root-fake-frame) (not (ptr-equal? win (send root-fake-frame get-cocoa)))) win)))))))]) @@ -278,12 +285,12 @@ (register-frame-shown this on?) (let ([num (tell #:type _NSInteger cocoa windowNumber)]) (if on? - (hash-set! all-windows num this) + (hash-set! all-windows num (make-weak-box this)) (hash-remove! all-windows num))) (when on? (let ([b (eventspace-wait-cursor-count (get-eventspace))]) (set-wait-cursor-mode (not (zero? b)))))) - + (define/override (show on?) (let ([es (get-eventspace)]) (when on? @@ -319,11 +326,18 @@ (define/override (show-children) (when saved-child (send saved-child show-children))) + (define/override (fixup-locations-children) + (when saved-child + (send saved-child fixup-locations-children))) (define/override (children-accept-drag on?) (when saved-child (send saved-child child-accept-drag on?))) + (define/override (enable-window on?) + (when saved-child + (send saved-child enable-window (and on? (is-window-enabled?))))) + (define/override (is-shown?) (tell #:type _bool cocoa isVisible)) @@ -408,7 +422,7 @@ (define/override (set-size x y w h) (unless (and (= x -1) (= y -1)) - (move x y)) + (internal-move x y)) (let ([f (tell #:type _NSRect cocoa frame)]) (tellv cocoa setFrame: #:type _NSRect (make-NSRect @@ -429,7 +443,7 @@ (NSSize-height (NSRect-size f))))) (make-NSSize w h)) display: #:type _BOOL #t))) - (define/override (move x y) + (define/override (internal-move x y) (let ([x (if (= x -11111) (get-x) x)] [y (if (= y -11111) (get-y) y)]) (tellv cocoa setFrameTopLeftPoint: #:type _NSPoint (make-NSPoint x (- (flip-screen y) @@ -442,15 +456,15 @@ #:type _NSRect (make-NSRect (make-NSPoint (if (or (eq? dir 'both) (eq? dir 'horizontal)) - (/ (- (NSSize-width (NSRect-size s)) - (NSSize-width (NSRect-size f))) - 2) + (quotient (- (NSSize-width (NSRect-size s)) + (NSSize-width (NSRect-size f))) + 2) (NSPoint-x (NSRect-origin f))) (if (or (eq? dir 'both) (eq? dir 'vertical)) - (/ (- (NSSize-height (NSRect-size s)) - (NSSize-height (NSRect-size f))) - 2) + (quotient (- (NSSize-height (NSRect-size s)) + (NSSize-height (NSRect-size f))) + 2) (NSPoint-x (NSRect-origin f)))) (NSRect-size f)) display: #:type _BOOL #t))) @@ -511,7 +525,9 @@ (define/public (iconized?) (tell #:type _BOOL cocoa isMiniaturized)) (define/public (iconize on?) - (tellv cocoa miniaturize: cocoa)) + (if on? + (tellv cocoa miniaturize: cocoa) + (tellv cocoa deminiaturize: cocoa))) (define/public (set-title s) (tellv cocoa setTitle: #:type _NSString s)) @@ -531,4 +547,14 @@ (let ([f (tell #:type _NSRect (tell NSScreen mainScreen) frame)]) (make-NSPoint x (- (NSSize-height (NSRect-size f)) y))) belowWindowWithWindowNumber: #:type _NSInteger 0)]) - (atomically (hash-ref all-windows n #f)))) + (atomically (let ([b (hash-ref all-windows n #f)]) + (and b (weak-box-value b)))))) + +(set-fixup-window-locations! + (lambda () + ;; in atomic mode + (for ([b (in-hash-values all-windows)]) + (let ([f (weak-box-value b)]) + (when f + (send f fixup-locations-children)))))) + diff --git a/collects/mred/private/wx/cocoa/item.rkt b/collects/mred/private/wx/cocoa/item.rkt index e04a375195..2ff73fa109 100644 --- a/collects/mred/private/wx/cocoa/item.rkt +++ b/collects/mred/private/wx/cocoa/item.rkt @@ -29,16 +29,16 @@ (tellv cocoa setFont: sys-font))) (defclass item% window% - (inherit get-cocoa) + (inherit get-cocoa + is-window-enabled?) (init-field callback) (define/public (get-cocoa-control) (get-cocoa)) - (define/override (enable on?) - (tellv (get-cocoa-control) setEnabled: #:type _BOOL on?)) - (define/override (is-window-enabled?) - (tell #:type _BOOL (get-cocoa-control) isEnabled)) + (define/override (enable-window on?) + (let ([on? (and on? (is-window-enabled?))]) + (tellv (get-cocoa-control) setEnabled: #:type _BOOL on?))) (define/override (gets-focus?) (tell #:type _BOOL (get-cocoa-control) canBecomeKeyView)) diff --git a/collects/mred/private/wx/cocoa/menu-bar.rkt b/collects/mred/private/wx/cocoa/menu-bar.rkt index b8c70ae579..a8c95b94c0 100644 --- a/collects/mred/private/wx/cocoa/menu-bar.rkt +++ b/collects/mred/private/wx/cocoa/menu-bar.rkt @@ -35,14 +35,26 @@ "MrEd")) (define the-apple-menu #f) +(define recurring-for-command (make-parameter #f)) (define-objc-class MyBarMenu NSMenu [] ;; Disable automatic handling of keyboard shortcuts, except for ;; the Apple menu (-a _BOOL (performKeyEquivalent: [_id evt]) - (and the-apple-menu - (tell #:type _BOOL the-apple-menu performKeyEquivalent: evt)))) + (or (and the-apple-menu + (tell #:type _BOOL the-apple-menu performKeyEquivalent: evt)) + ;; Explicity send the event to the keyWindow: + (and + (not (recurring-for-command)) + (let ([w (tell app keyWindow)]) + (and w + (let ([r (tell w firstResponder)]) + (and r + (begin + (parameterize ([recurring-for-command #t]) + (tell r keyDown: evt)) + #t))))))))) (define cocoa-mb (tell (tell MyBarMenu alloc) init)) (define current-mb #f) diff --git a/collects/mred/private/wx/cocoa/menu-item.rkt b/collects/mred/private/wx/cocoa/menu-item.rkt index 6f26da2455..bea50304ee 100644 --- a/collects/mred/private/wx/cocoa/menu-item.rkt +++ b/collects/mred/private/wx/cocoa/menu-item.rkt @@ -80,21 +80,22 @@ (define (set-menu-item-shortcut item label) (let ([shortcut (regexp-match #rx"\tCut=(.)(.*)" label)]) - (when shortcut - (let* ([s (string-downcase (string (integer->char (string->number (caddr shortcut)))))] - [flags (- (char->integer (string-ref (cadr shortcut) 0)) - (char->integer #\A))] - [mods (+ (if (positive? (bitwise-and flags 1)) - NSShiftKeyMask - 0) - (if (positive? (bitwise-and flags 2)) - NSAlternateKeyMask - 0) - (if (positive? (bitwise-and flags 4)) - NSControlKeyMask - 0) - (if (positive? (bitwise-and flags 8)) - 0 - NSCommandKeyMask))]) - (tellv item setKeyEquivalent: #:type _NSString s) - (tellv item setKeyEquivalentModifierMask: #:type _NSUInteger mods))))) + (if shortcut + (let* ([s (string-downcase (string (integer->char (string->number (caddr shortcut)))))] + [flags (- (char->integer (string-ref (cadr shortcut) 0)) + (char->integer #\A))] + [mods (+ (if (positive? (bitwise-and flags 1)) + NSShiftKeyMask + 0) + (if (positive? (bitwise-and flags 2)) + NSAlternateKeyMask + 0) + (if (positive? (bitwise-and flags 4)) + NSControlKeyMask + 0) + (if (positive? (bitwise-and flags 8)) + 0 + NSCommandKeyMask))]) + (tellv item setKeyEquivalent: #:type _NSString s) + (tellv item setKeyEquivalentModifierMask: #:type _NSUInteger mods)) + (tellv item setKeyEquivalent: #:type _NSString "")))) diff --git a/collects/mred/private/wx/cocoa/menu.rkt b/collects/mred/private/wx/cocoa/menu.rkt index a7b8bd318e..0162bc21c8 100644 --- a/collects/mred/private/wx/cocoa/menu.rkt +++ b/collects/mred/private/wx/cocoa/menu.rkt @@ -63,7 +63,7 @@ (create-menu "menu") (let ([b (box #f)]) (set! popup-box b) - (if #t ;; use the 10.5 code, for now + (if (not (version-10.6-or-later?)) ;; For 10.5 and earlier: (let ([p (tell #:type _NSPoint v convertPoint: #:type _NSPoint (make-NSPoint x y) diff --git a/collects/mred/private/wx/cocoa/message.rkt b/collects/mred/private/wx/cocoa/message.rkt index 1a3896ef1f..bd9ef2a085 100644 --- a/collects/mred/private/wx/cocoa/message.rkt +++ b/collects/mred/private/wx/cocoa/message.rkt @@ -94,7 +94,11 @@ [no-show? (memq 'deleted style)]) (define/override (set-label label) - (tellv (get-cocoa) setTitleWithMnemonic: #:type _NSString label)) + (cond + [(string? label) + (tellv (get-cocoa) setTitleWithMnemonic: #:type _NSString label)] + [else + (tellv (get-cocoa) setImage: (bitmap->image label))])) (define/override (gets-focus?) #f) diff --git a/collects/mred/private/wx/cocoa/panel.rkt b/collects/mred/private/wx/cocoa/panel.rkt index 48a5c03feb..85864672ae 100644 --- a/collects/mred/private/wx/cocoa/panel.rkt +++ b/collects/mred/private/wx/cocoa/panel.rkt @@ -19,7 +19,8 @@ (define (panel-mixin %) (class % - (inherit register-as-child on-new-child) + (inherit register-as-child on-new-child + is-window-enabled?) (define lbl-pos 'horizontal) (define children null) @@ -40,6 +41,10 @@ (define/override (show-children) (for ([child (in-list children)]) (send child show-children))) + + (define/override (fixup-locations-children) + (for ([child (in-list children)]) + (send child fixup-locations-children))) (define/override (paint-children) (for ([child (in-list children)]) @@ -48,6 +53,11 @@ (define/override (children-accept-drag on?) (for ([child (in-list children)]) (send child child-accept-drag on?))) + + (define/override (enable-window on?) + (let ([on? (and on? (is-window-enabled?))]) + (for ([child (in-list children)]) + (send child enable-window on?)))) (define/override (set-size x y w h) (super set-size x y w h) diff --git a/collects/mred/private/wx/cocoa/printer-dc.rkt b/collects/mred/private/wx/cocoa/printer-dc.rkt index c1224ed17c..580ad92e1d 100644 --- a/collects/mred/private/wx/cocoa/printer-dc.rkt +++ b/collects/mred/private/wx/cocoa/printer-dc.rkt @@ -12,6 +12,7 @@ ffi/unsafe/objc "../../lock.rkt" "dc.rkt" + "frame.rkt" "bitmap.rkt" "cg.rkt" "utils.rkt" @@ -101,8 +102,13 @@ (send pss set-native pi make-print-info) pi)))]) (install-pss-to-print-info pss print-info) - (if (= (tell #:type _NSInteger (tell NSPageLayout pageLayout) runModalWithPrintInfo: print-info) - NSOkButton) + (if (atomically + (let ([front (get-front)]) + (begin0 + (= (tell #:type _NSInteger (tell NSPageLayout pageLayout) runModalWithPrintInfo: print-info) + NSOkButton) + (when front + (tellv (send front get-cocoa-window) makeKeyAndOrderFront: #f))))) (begin (let ([o (tell #:type _int print-info orientation)]) (send pss set-orientation (if (= o NSLandscapeOrientation) @@ -195,4 +201,8 @@ (set-ivar! view-cocoa wxb (->wxb this)) - (tellv op-cocoa runOperation)))) + (atomically + (let ([front (get-front)]) + (tellv op-cocoa runOperation) + (when front + (tellv (send front get-cocoa-window) makeKeyAndOrderFront: #f))))))) diff --git a/collects/mred/private/wx/cocoa/procs.rkt b/collects/mred/private/wx/cocoa/procs.rkt index 77866d045d..a6caa39307 100644 --- a/collects/mred/private/wx/cocoa/procs.rkt +++ b/collects/mred/private/wx/cocoa/procs.rkt @@ -91,10 +91,15 @@ (define (check-for-break) #f) (define (display-origin xb yb all?) - (set-box! xb 0) (if all? - (set-box! yb 0) - (set-box! yb (get-menu-bar-height)))) + (atomically + (with-autorelease + (let* ([screen (tell (tell NSScreen screens) objectAtIndex: #:type _NSUInteger 0)] + [f (tell #:type _NSRect screen visibleFrame)]) + (set-box! xb (->long (NSPoint-x (NSRect-origin f))))))) + (set-box! xb 0)) + (set-box! yb (get-menu-bar-height))) + (define (display-size xb yb all?) (atomically (with-autorelease diff --git a/collects/mred/private/wx/cocoa/queue.rkt b/collects/mred/private/wx/cocoa/queue.rkt index 654b8cca68..a66bf5d99a 100644 --- a/collects/mred/private/wx/cocoa/queue.rkt +++ b/collects/mred/private/wx/cocoa/queue.rkt @@ -19,6 +19,7 @@ set-eventspace-hook! set-front-hook! set-menu-bar-hooks! + set-fixup-window-locations! post-dummy-event try-to-sync-refresh) @@ -28,9 +29,21 @@ queue-event yield) -(import-class NSApplication NSAutoreleasePool NSColor) +(import-class NSApplication NSAutoreleasePool NSColor NSProcessInfo NSArray) (import-protocol NSApplicationDelegate) +;; Extreme hackery to hide original arguments from +;; NSApplication, because NSApplication wants to turn +;; the arguments into `application:openFile:' calls. +;; To hide the arguments, we replace the implementation +;; of `arguments' in the NSProcessInfo object. +(define (hack-argument-replacement self method) + (tell NSArray + arrayWithObjects: #:type (_vector i _NSString) (vector (path->string (find-system-path 'exec-file))) + count: #:type _NSUInteger 1)) +(let ([m (class_getInstanceMethod NSProcessInfo (selector arguments))]) + (void (method_setImplementation m hack-argument-replacement))) + (define app (tell NSApplication sharedApplication)) (define-objc-class MyApplicationDelegate NSObject #:protocols (NSApplicationDelegate) @@ -58,21 +71,25 @@ (let ([priviledged-custodian ((get-ffi-obj 'scheme_make_custodian #f (_fun _pointer -> _scheme)) #f)]) (parameterize ([current-custodian priviledged-custodian]) (thread (lambda () (sleep 5.0))))) - ;; FIXME: Also need to reset blit windows, since OS may move them incorrectly - (void)]) + ;; Also need to reset blit windows, since OS may move them incorrectly: + (fixup-window-locations)]) + +(define fixup-window-locations void) +(define (set-fixup-window-locations! f) (set! fixup-window-locations f)) ;; In case we were started in an executable without a bundle, ;; explicitly register with the dock so the application can receive ;; keyboard events. -;; This technique is not sanctioned by Apple --- I found the code in SDL. -(define-cstruct _CPSProcessSerNum ([lo _uint32] [hi _uint32])) -(define-appserv CPSGetCurrentProcess (_fun _CPSProcessSerNum-pointer -> _int) - #:fail (lambda () (lambda args 1))) -(define-appserv CPSEnableForegroundOperation (_fun _CPSProcessSerNum-pointer _int _int _int _int -> _int) - #:fail (lambda () #f)) -(let ([psn (make-CPSProcessSerNum 0 0)]) - (when (zero? (CPSGetCurrentProcess psn)) - (void (CPSEnableForegroundOperation psn #x03 #x3C #x2C #x1103)))) +(define-cstruct _ProcessSerialNumber + ([highLongOfPSN _ulong] + [lowLongOfPSN _ulong])) +(define kCurrentProcess 2) +(define kProcessTransformToForegroundApplication 1) +(define-appserv TransformProcessType (_fun _ProcessSerialNumber-pointer + _uint32 + -> _OSStatus)) +(void (TransformProcessType (make-ProcessSerialNumber 0 kCurrentProcess) + kProcessTransformToForegroundApplication)) (define app-delegate (tell (tell MyApplicationDelegate alloc) init)) (tellv app setDelegate: app-delegate) diff --git a/collects/mred/private/wx/cocoa/tab-panel.rkt b/collects/mred/private/wx/cocoa/tab-panel.rkt index 62a22c5eba..5b5b220597 100644 --- a/collects/mred/private/wx/cocoa/tab-panel.rkt +++ b/collects/mred/private/wx/cocoa/tab-panel.rkt @@ -23,12 +23,25 @@ (void (ffi-lib (build-path psm-tab-bar-dir "PSMTabBarControl"))) (define NSNoTabsNoBorder 6) +(define NSDefaultControlTint 0) +(define NSClearControlTint 7) + (import-class NSView NSTabView NSTabViewItem PSMTabBarControl) (import-protocol NSTabViewDelegate) +(define NSOrderedAscending -1) +(define NSOrderedSame 0) +(define NSOrderedDescending 1) +(define (order-content-first a b data) + (cond + [(ptr-equal? a data) NSOrderedDescending] + [(ptr-equal? b data) NSOrderedAscending] + [else NSOrderedSame])) +(define order_content_first (function-ptr order-content-first + (_fun #:atomic? #t _id _id _id -> _int))) + (define-objc-class MyTabView NSTabView #:mixins (FocusResponder KeyMouseResponder CursorDisplayer) - #:protocols (NSTabViewDelegate) [wxb] (-a _void (tabView: [_id cocoa] didSelectTabViewItem: [_id item-cocoa]) (queue-window*-event wxb (lambda (wx) (send wx do-callback))))) @@ -45,12 +58,15 @@ x y w h style labels) - (inherit get-cocoa register-as-child) + (inherit get-cocoa register-as-child + is-window-enabled? + block-mouse-events) (define tabv-cocoa (as-objc-allocation (tell (tell MyTabView alloc) init))) (define cocoa (if (not (memq 'border style)) - (tell (tell NSView alloc) init) + (as-objc-allocation + (tell (tell NSView alloc) init)) tabv-cocoa)) (define control-cocoa @@ -126,7 +142,11 @@ (tell (tell NSTabViewItem alloc) initWithIdentifier: #f))]) (tellv item setLabel: #:type _NSString (label->plain-label lbl)) (tellv tabv-cocoa addTabViewItem: item) - (set! item-cocoas (append item-cocoas (list item))))) + (set! item-cocoas (append item-cocoas (list item))) + ;; Sometimes the sub-view for the tab buttons gets put in front + ;; of the content view, so fix the order: + (tellv tabv-cocoa sortSubviewsUsingFunction: #:type _fpointer order_content_first + context: #:type _pointer content-cocoa))) (define/public (delete i) (let ([item-cocoa (list-ref item-cocoas i)]) @@ -154,6 +174,15 @@ (when control-cocoa (set-ivar! control-cocoa wxb (->wxb this))) + (define/override (enable-window on?) + (super enable-window on?) + (let ([on? (and on? (is-window-enabled?))]) + (block-mouse-events (not on?)) + (tellv tabv-cocoa setControlTint: #:type _int + (if on? NSDefaultControlTint NSClearControlTint)) + (when control-cocoa + (tellv control-cocoa setEnabled: #:type _BOOL on?)))) + (define/override (maybe-register-as-child parent on?) (register-as-child parent on?))) diff --git a/collects/mred/private/wx/cocoa/types.rkt b/collects/mred/private/wx/cocoa/types.rkt index 5e577c9550..665aeae12a 100644 --- a/collects/mred/private/wx/cocoa/types.rkt +++ b/collects/mred/private/wx/cocoa/types.rkt @@ -5,7 +5,7 @@ "utils.rkt") (provide - (protect-out _NSInteger _NSUInteger + (protect-out _NSInteger _NSUInteger _OSStatus _CGFloat _NSPoint _NSPoint-pointer (struct-out NSPoint) _NSSize _NSSize-pointer (struct-out NSSize) @@ -18,6 +18,8 @@ (define _NSInteger _long) (define _NSUInteger _ulong) +(define _OSStatus _sint32) + (define 64-bit? (= (ctype-sizeof _long) 8)) (define _CGFloat (make-ctype (if 64-bit? _double _float) diff --git a/collects/mred/private/wx/cocoa/utils.rkt b/collects/mred/private/wx/cocoa/utils.rkt index 02d1a0b069..fff2a03204 100644 --- a/collects/mred/private/wx/cocoa/utils.rkt +++ b/collects/mred/private/wx/cocoa/utils.rkt @@ -21,7 +21,8 @@ clean-menu-label ->wxb ->wx - old-cocoa?) + old-cocoa? + version-10.6-or-later?) define-mz) (define cocoa-lib (ffi-lib (format "/System/Library/Frameworks/Cocoa.framework/Cocoa"))) @@ -79,6 +80,10 @@ (and wxb (weak-box-value wxb))) -;; FIXME: need a better test: -(define old-cocoa? (equal? (path->string (system-library-subpath #f)) - "ppc-macosx")) +(define-appkit NSAppKitVersionNumber _double) + +(define old-cocoa? + ; earlier than 10.5? + (NSAppKitVersionNumber . < . 949)) +(define (version-10.6-or-later?) + (NSAppKitVersionNumber . >= . 1038)) diff --git a/collects/mred/private/wx/cocoa/window.rkt b/collects/mred/private/wx/cocoa/window.rkt index 4243556621..dbe29c728a 100644 --- a/collects/mred/private/wx/cocoa/window.rkt +++ b/collects/mred/private/wx/cocoa/window.rkt @@ -78,9 +78,20 @@ (import-protocol NSTextInput) (define current-insert-text (make-parameter #f)) +(define current-set-mark (make-parameter #f)) (define NSDragOperationCopy 1) +(import-class NSAttributedString) +(define _NSStringOrAttributed + (make-ctype _id + (lambda (v) + (cast v _NSString _id)) + (lambda (v) + (if (tell #:type _BOOL v isKindOfClass: (tell NSAttributedString class)) + (tell #:type _NSString v string) + (cast v _id _NSString))))) + (define-objc-mixin (KeyMouseResponder Superclass) [wxb] [-a _void (mouseDown: [_id event]) @@ -151,7 +162,7 @@ [-a _void (keyUp: [_id event]) (unless (do-key-event wxb event self #f #f) (super-tell #:type _void keyUp: event))] - [-a _void (insertText: [_NSString str]) + [-a _void (insertText: [_NSStringOrAttributed str]) (let ([cit (current-insert-text)]) (if cit (set-box! cit str) @@ -162,21 +173,47 @@ (send wx key-event-as-string str)))))))] ;; for NSTextInput: - [-a _BOOL (hasMarkedText) #f] + [-a _BOOL (hasMarkedText) (get-saved-marked wxb)] [-a _id (validAttributesForMarkedText) (tell NSArray array)] - [-a _void (unmarkText) (void)] - [-a _NSRange (markedRange) (make-NSRange 0 0)] + [-a _void (unmarkText) + (set-saved-marked! wxb #f)] + [-a _NSRange (markedRange) + (let ([saved-marked (get-saved-marked wxb)]) + (make-NSRange 0 (if saved-marked 0 (length saved-marked))))] [-a _NSRange (selectedRange) (make-NSRange 0 0)] - [-a _void (setMarkedText: [_id aString] selectedRange: [_NSRange selRange]) + [-a _void (setMarkedText: [_NSStringOrAttributed aString] selectedRange: [_NSRange selRange]) + ;; We interpreter a call to `setMarkedText:' as meaning that the + ;; key is a dead key for composing some other character. + (let ([m (current-set-mark)]) (when m (set-box! m #t))) + ;; At the same time, we need to remember the text: + (set-saved-marked! wxb (range-substring aString selRange)) (void)] [-a _id (validAttributesForMarkedText) #f] - [-a _id (attributedSubstringFromRange: [_NSRange theRange]) #f] + [-a _id (attributedSubstringFromRange: [_NSRange theRange]) + (let ([saved-marked (get-saved-marked wxb)]) + (and saved-marked + (let ([s (tell (tell NSAttributedString alloc) + initWithString: #:type _NSString + (range-substring saved-marked theRange))]) + (tellv s autorelease) + s)))] + [-a _NSUInteger (characterIndexForPoint: [_NSPoint thePoint]) 0] [-a _NSInteger (conversationIdentifier) 0] [-a _void (doCommandBySelector: [_SEL aSelector]) (void)] - [-a _NSRect (firstRectForCharacterRange: [_NSRange r]) (make-NSRect (make-NSPoint 0 0) - (make-NSSize 0 0))] + [-a _NSRect (firstRectForCharacterRange: [_NSRange r]) + ;; This location is used to place a window for multi-character + ;; input, such as when typing Chinese with Pinyin + (let ([f (tell #:type _NSRect self frame)] + [pt (tell #:type _NSPoint (tell self window) + convertBaseToScreen: + #:type _NSPoint + (tell #:type _NSPoint self + convertPoint: #:type _NSPoint + (make-NSPoint 0 0) + toView: #f))]) + (make-NSRect pt (NSRect-size f)))] ;; Dragging: [-a _int (draggingEntered: [_id info]) @@ -196,6 +233,18 @@ (lambda () (send wx do-on-drop-file s))))))))))) #t]) +(define (set-saved-marked! wxb str) + (let ([wx (->wx wxb)]) + (when wx + (send wx set-saved-marked str)))) +(define (get-saved-marked wxb) + (let ([wx (->wx wxb)]) + (and wx + (send wx get-saved-marked)))) +(define (range-substring s range) + (let ([start (min (max 0 (NSRange-location range)) (string-length s))]) + (substring s start (max (min start (NSRange-length range)) (string-length s))))) + (define-objc-mixin (KeyMouseTextResponder Superclass) #:mixins (KeyMouseResponder) @@ -213,7 +262,8 @@ (let ([wx (->wx wxb)]) (and wx - (let ([inserted-text (box #f)]) + (let ([inserted-text (box #f)] + [set-mark (box #f)]) (unless wheel? ;; Calling `interpretKeyEvents:' allows key combinations to be ;; handled, such as option-e followed by e to produce é. The @@ -222,74 +272,86 @@ ;; give us back the text in the parameter. For now, we ignore the ;; text and handle the event as usual, though probably we should ;; be doing something with it. - (parameterize ([current-insert-text inserted-text]) - (tellv self interpretKeyEvents: (tell (tell NSArray alloc) - initWithObjects: #:type (_ptr i _id) event - count: #:type _NSUInteger 1)))) + (parameterize ([current-insert-text inserted-text] + [current-set-mark set-mark]) + (let ([array (tell (tell NSArray alloc) + initWithObjects: #:type (_ptr i _id) event + count: #:type _NSUInteger 1)]) + (tellv self interpretKeyEvents: array) + (tellv array release)))) (let* ([modifiers (tell #:type _NSUInteger event modifierFlags)] [bit? (lambda (m b) (positive? (bitwise-and m b)))] [pos (tell #:type _NSPoint event locationInWindow)] - [str (if wheel? - #f - (tell #:type _NSString event characters))] + [str (cond + [wheel? #f] + [(unbox set-mark) ""] ; => dead key for composing characters + [(unbox inserted-text)] + [else + (tell #:type _NSString event characters)])] [control? (bit? modifiers NSControlKeyMask)] [option? (bit? modifiers NSAlternateKeyMask)] [delta-y (and wheel? - (tell #:type _CGFloat event deltaY))]) - (let-values ([(x y) (send wx window-point-to-view pos)]) - (let ([k (new key-event% - [key-code (if wheel? - (if (positive? delta-y) - 'wheel-up - 'wheel-down) - (or - (map-key-code (tell #:type _ushort event keyCode)) - (if (string=? "" str) - #\nul - (let ([c (string-ref str 0)]) - (or (and control? - (char<=? #\u00 c #\u1F) - (let ([alt-str (tell #:type _NSString event charactersIgnoringModifiers)]) - (and (string? alt-str) - (= 1 (string-length alt-str)) - (string-ref alt-str 0)))) - c)))))] - [shift-down (bit? modifiers NSShiftKeyMask)] - [control-down control?] - [meta-down (bit? modifiers NSCommandKeyMask)] - [alt-down option?] - [x (->long x)] - [y (->long y)] - [time-stamp (->long (* (tell #:type _double event timestamp) 1000.0))] - [caps-down (bit? modifiers NSAlphaShiftKeyMask)])]) - (unless wheel? - (let ([alt-str (tell #:type _NSString event charactersIgnoringModifiers)]) - (when (and (string? alt-str) - (= 1 (string-length alt-str))) - (let ([alt-code (string-ref alt-str 0)]) - (unless (equal? alt-code (send k get-key-code)) - (send k set-other-altgr-key-code alt-code))))) - (when (and (or (and option? - special-option-key?) - (and control? - (equal? (send k get-key-code) #\u00))) - (send k get-other-altgr-key-code)) - ;; swap altenate with main - (let ([other (send k get-other-altgr-key-code)]) - (send k set-other-altgr-key-code (send k get-key-code)) - (send k set-key-code other))) - (unless down? - ;; swap altenate with main - (send k set-key-release-code (send k get-key-code)) - (send k set-key-code 'release))) - (if (send wx definitely-wants-event? k) - (begin - (queue-window-event wx (lambda () - (send wx dispatch-on-char/sync k))) - #t) - (constrained-reply (send wx get-eventspace) - (lambda () (send wx dispatch-on-char k #t)) - #t))))))))) + (tell #:type _CGFloat event deltaY))] + [codes (cond + [wheel? (if (positive? delta-y) + '(wheel-up) + '(wheel-down))] + [(map-key-code (tell #:type _ushort event keyCode)) + => list] + [(string=? "" str) '(#\nul)] + [(and (= 1 (string-length str)) + (let ([c (string-ref str 0)]) + (or (and control? + (char<=? #\u00 c #\u1F) + (let ([alt-str (tell #:type _NSString event charactersIgnoringModifiers)]) + (and (string? alt-str) + (= 1 (string-length alt-str)) + (string-ref alt-str 0))))))) + => list] + [else str])]) + (for/fold ([result #f]) ([one-code codes]) + (or + ;; Handle one key event + (let-values ([(x y) (send wx window-point-to-view pos)]) + (let ([k (new key-event% + [key-code one-code] + [shift-down (bit? modifiers NSShiftKeyMask)] + [control-down control?] + [meta-down (bit? modifiers NSCommandKeyMask)] + [alt-down option?] + [x (->long x)] + [y (->long y)] + [time-stamp (->long (* (tell #:type _double event timestamp) 1000.0))] + [caps-down (bit? modifiers NSAlphaShiftKeyMask)])]) + (unless wheel? + (let ([alt-str (tell #:type _NSString event charactersIgnoringModifiers)]) + (when (and (string? alt-str) + (= 1 (string-length alt-str))) + (let ([alt-code (string-ref alt-str 0)]) + (unless (equal? alt-code (send k get-key-code)) + (send k set-other-altgr-key-code alt-code))))) + (when (and (or (and option? + special-option-key?) + (and control? + (equal? (send k get-key-code) #\u00))) + (send k get-other-altgr-key-code)) + ;; swap altenate with main + (let ([other (send k get-other-altgr-key-code)]) + (send k set-other-altgr-key-code (send k get-key-code)) + (send k set-key-code other))) + (unless down? + ;; swap altenate with main + (send k set-key-release-code (send k get-key-code)) + (send k set-key-code 'release))) + (if (send wx definitely-wants-event? k) + (begin + (queue-window-event wx (lambda () + (send wx dispatch-on-char/sync k))) + #t) + (constrained-reply (send wx get-eventspace) + (lambda () (send wx dispatch-on-char k #t)) + #t)))) + result))))))) (define (do-mouse-event wxb event kind l? m? r? [ctl-kind kind]) (let ([wx (->wx wxb)]) @@ -379,6 +441,8 @@ (focus-is-on #f)) (define/public (show-children) (void)) + (define/public (fixup-locations-children) + (void)) (define/public (fix-dc) (void)) (define/public (paint-children) @@ -456,7 +520,16 @@ (define/public (is-window-enabled?) enabled?) (define/public (enable on?) - (set! enabled? on?)) + (atomically + (set! enabled? on?) + (enable-window on?))) + (define/public (enable-window on?) + ;; in atomic mode + (void)) + + (define block-all-mouse-events? #f) + (define/public (block-mouse-events block?) + (set! block-all-mouse-events? block?)) (define/private (get-frame) (let ([v (tell #:type _NSRect cocoa frame)]) @@ -518,8 +591,10 @@ (tellv cocoa setNeedsDisplay: #:type _BOOL #t) (tellv cocoa setFrame: #:type _NSRect (make-NSRect (make-NSPoint x (flip y h)) (make-NSSize w h))))) - (define/public (move x y) + (define/public (internal-move x y) (set-size x y (get-width) (get-height))) + (define/public (move x y) + (internal-move x y)) (define accept-drag? #f) (define accept-parent-drag? #f) @@ -555,7 +630,8 @@ (accept-drags-everywhere (or accept-drag? accept-parent-drag?)))) (define/public (set-focus) - (when (gets-focus?) + (when (and (gets-focus?) + (is-enabled-to-root?)) (let ([w (tell cocoa window)]) (when w (tellv w makeFirstResponder: (get-cocoa-content)))))) @@ -598,7 +674,7 @@ (cond [(other-modal? this) #t] [(call-pre-on-event this e) #t] - [just-pre? #f] + [just-pre? block-all-mouse-events?] [else (when enabled? (on-event e)) #t])) (define/public (call-pre-on-event w e) @@ -707,11 +783,15 @@ (define/public (get-cursor-width-delta) 0) (define/public (gets-focus?) #f) - (define/public (can-be-responder?) #t) + (define/public (can-be-responder?) (is-enabled-to-root?)) (define/public (on-color-change) - (send parent on-color-change)))) + (send parent on-color-change)) + ;; For multi-key character composition: + (define saved-marked #f) + (define/public (set-saved-marked v) (set! saved-marked v)) + (define/public (get-saved-marked) saved-marked))) ;; ---------------------------------------- diff --git a/collects/mred/private/wx/common/canvas-mixin.rkt b/collects/mred/private/wx/common/canvas-mixin.rkt index 1dbeb28e70..07c4364f6f 100644 --- a/collects/mred/private/wx/common/canvas-mixin.rkt +++ b/collects/mred/private/wx/common/canvas-mixin.rkt @@ -168,7 +168,7 @@ (define flush-box #f) - ;; Periodic flush is needed for Windows and Gtk, where + ;; Periodic flush is needed for Windows, where ;; updates otherwise happen only via the eventspace's queue (define/override (schedule-periodic-backing-flush) (unless flush-box diff --git a/collects/mred/private/wx/common/delay.rkt b/collects/mred/private/wx/common/delay.rkt index 7898a2d31f..ef8d704432 100644 --- a/collects/mred/private/wx/common/delay.rkt +++ b/collects/mred/private/wx/common/delay.rkt @@ -6,19 +6,28 @@ (protect-out do-request-flush-delay do-cancel-flush-delay)) +;; Auto-cancel schedules a cancel of a request flush +;; on event boundaries. It makes sense if you don't +;; trust a program to un-delay important refreshes, +;; but auto-cancel is currently disabled because +;; bad refresh-delay effects are confined to the enclosing +;; window on all platforms. +(define AUTO-CANCEL-DELAY? #f) + (define (do-request-flush-delay win disable enable) (atomically (let ([req (box win)]) (and (disable win) (begin - (add-event-boundary-sometimes-callback! - req - (lambda (v) - ;; in atomic mode - (when (unbox req) - (set-box! req #f) - (enable win)))) + (when AUTO-CANCEL-DELAY? + (add-event-boundary-sometimes-callback! + req + (lambda (v) + ;; in atomic mode + (when (unbox req) + (set-box! req #f) + (enable win))))) req))))) (define (do-cancel-flush-delay req enable) @@ -27,4 +36,5 @@ (when win (set-box! req #f) (enable win) - (remove-event-boundary-callback! req))))) + (when AUTO-CANCEL-DELAY? + (remove-event-boundary-callback! req)))))) diff --git a/collects/mred/private/wx/common/event.rkt b/collects/mred/private/wx/common/event.rkt index e9820fe3e5..88f1fc5fec 100644 --- a/collects/mred/private/wx/common/event.rkt +++ b/collects/mred/private/wx/common/event.rkt @@ -14,10 +14,11 @@ (super-new)) (defclass mouse-event% event% - ;; FIXME: check event-type - (init event-type) - (define et event-type) - (init-properties [[bool? left-down] #f] + (init-properties [[(symbol-in enter leave left-down left-up + middle-down middle-up + right-down right-up motion) + event-type]] + [[bool? left-down] #f] [[bool? middle-down] #f] [[bool? right-down] #f] [[exact-integer? x] 0] @@ -30,44 +31,45 @@ (init-properties [[bool? caps-down] #f]) (super-new [time-stamp time-stamp]) - (def/public (get-event-type) et) - (def/public (button-changed? [(symbol-in left middle right any) [button 'any]]) - (and (memq et (case button - [(any) '(left-down left-up middle-down middle-up right-down right-up)] - [(left) '(left-down left-up)] - [(middle) '(middle-down middle-up)] - [(right) '(right-down right-up)])) + (and (memq event-type + (case button + [(any) '(left-down left-up middle-down middle-up right-down right-up)] + [(left) '(left-down left-up)] + [(middle) '(middle-down middle-up)] + [(right) '(right-down right-up)])) #t)) (def/public (button-down? [(symbol-in left middle right any) [button 'any]]) - (and (memq et (case button - [(any) '(left-down middle-down right-down)] - [(left) '(left-down)] - [(middle) '(middle-down)] - [(right) '(right-down)])) + (and (memq event-type + (case button + [(any) '(left-down middle-down right-down)] + [(left) '(left-down)] + [(middle) '(middle-down)] + [(right) '(right-down)])) #t)) (def/public (button-up? [(symbol-in left middle right any) [button 'any]]) - (and (memq et (case button - [(any) '(left-up middle-up right-up)] - [(left) '(left-up)] - [(middle) '(middle-up)] - [(right) '(right-up)])) + (and (memq event-type + (case button + [(any) '(left-up middle-up right-up)] + [(left) '(left-up)] + [(middle) '(middle-up)] + [(right) '(right-up)])) #t)) (def/public (dragging?) - (and (eq? et 'motion) + (and (eq? event-type 'motion) (or left-down middle-down right-down))) (def/public (entering?) - (eq? et 'enter)) + (eq? event-type 'enter)) (def/public (leaving?) - (eq? et 'leave)) + (eq? event-type 'leave)) (def/public (moving?) - (eq? et 'motion))) + (eq? event-type 'motion))) (defclass key-event% event% (init-properties [[(make-alts symbol? char?) key-code] #\nul] @@ -91,9 +93,7 @@ list-box list-box-dclick text-field text-field-enter slider radio-box menu-popdown menu-popdown-none tab-panel) - event-type] - ;; FIXME: should have no default - 'button]) + event-type]]) (init [time-stamp 0]) (super-new [time-stamp time-stamp])) diff --git a/collects/mred/private/wx/common/freeze.rkt b/collects/mred/private/wx/common/freeze.rkt index 92c1566583..7ee55836a3 100644 --- a/collects/mred/private/wx/common/freeze.rkt +++ b/collects/mred/private/wx/common/freeze.rkt @@ -40,9 +40,7 @@ ;; Ideally, this would count as an error that we can fix. It seems that we ;; don't always have enough control to use the right eventspace with a ;; retry point, though, so just bail out with the default. - #; - (internal-error (format "constrained-reply not within an unfreeze point for ~s" - thunk)) + #;(internal-error (format "constrained-reply not within an unfreeze point for ~s" thunk)) fail-result] [(not (eq? (current-thread) (eventspace-handler-thread es))) (internal-error "wrong eventspace for constrained event handling\n") diff --git a/collects/mred/private/wx/common/queue.rkt b/collects/mred/private/wx/common/queue.rkt index 5041babcae..14c8006b51 100644 --- a/collects/mred/private/wx/common/queue.rkt +++ b/collects/mred/private/wx/common/queue.rkt @@ -176,6 +176,11 @@ [(< am bm) -1] [else 1])))) +;; This table refers to handle threads of eventspaces +;; that have an open window, etc., so that the eventspace +;; isn't GCed +(define active-eventspaces (make-hasheq)) + (define current-cb-box (make-parameter #f)) (define-mz scheme_add_managed (_fun _racket ; custodian @@ -192,10 +197,12 @@ (set-eventspace-shutdown?! e #t) (semaphore-post (eventspace-done-sema e)) (for ([f (in-list (get-top-level-windows e))]) - (send f destroy)))) + (send f destroy)) + (hash-remove! active-eventspaces (eventspace-handler-thread e)))) (define (make-eventspace* th) (let ([done-sema (make-semaphore 1)] + [done-set? #t] [frames (make-hasheq)]) (let ([e (make-eventspace th @@ -212,8 +219,14 @@ (if (or (positive? count) (positive? (hash-count frames)) (not (null? (unbox timer)))) - (semaphore-try-wait? done-sema) - (semaphore-post done-sema)))] + (when done-set? + (hash-set! active-eventspaces th #t) + (set! done-set? #f) + (semaphore-try-wait? done-sema)) + (unless done-set? + (hash-remove! active-eventspaces th) + (set! done-set? #t) + (semaphore-post done-sema))))] [enqueue (lambda (v q) (set! count (add1 count)) (check-done) diff --git a/collects/mred/private/wx/gtk/clipboard.rkt b/collects/mred/private/wx/gtk/clipboard.rkt index 06f013402c..82bee0c632 100644 --- a/collects/mred/private/wx/gtk/clipboard.rkt +++ b/collects/mred/private/wx/gtk/clipboard.rkt @@ -7,6 +7,7 @@ "../../lock.rkt" "../common/queue.rkt" "../common/local.rkt" + "../common/freeze.rkt" "utils.rkt" "types.rkt" "pixbuf.rkt") @@ -16,11 +17,12 @@ has-x-selection? _GtkSelectionData gtk_selection_data_get_length - gtk_selection_data_get_data)) + gtk_selection_data_get_data + primary-atom + get-selection-eventspace)) (define (has-x-selection?) #t) -(define _GdkAtom _int) (define _GtkClipboard (_cpointer 'GtkClipboard)) (define _GtkDisplay _pointer) (define _GtkSelectionData (_cpointer 'GtkSelectionData)) @@ -81,89 +83,117 @@ (define clear_owner (function-ptr clear-owner (_fun #:atomic? #t _GtkClipboard _pointer -> _void))) +(define primary-atom (gdk_atom_intern "PRIMARY" #t)) +(define clipboard-atom (gdk_atom_intern "CLIPBOARD" #t)) + +(define the-x-selection-driver #f) (defclass clipboard-driver% object% (init-field [x-selection? #f]) + (when x-selection? + (set! the-x-selection-driver this)) + (define client #f) (define client-data #f) + (define client-types #f) + (define client-orig-types #f) (define cb (gtk_clipboard_get (if x-selection? - (gdk_atom_intern "CLIPBOARD" #t) - (gdk_atom_intern "PRIMARY" #t)))) + primary-atom + clipboard-atom))) (define self-box #f) (define/public (get-client) client) - (define/public (set-client c types) - (if x-selection? - ;; For now, we can't call it on demand, so we don't call at all: - (queue-event (send c get-client-eventspace) - (lambda () - (send c on-replaced))) - ;; In clipboard mode (as opposed to X selection), we can get the data - ;; now, so it's ready if anyone asks: - (let ([all-data (for/list ([t (in-list types)]) - (send c get-data t))] - [types (for/list ([t (in-list types)]) - (if (equal? t "TEXT") - "UTF8_STRING" - t))]) - (let ([target-strings (malloc 'raw _byte (+ (length types) - (apply + (map string-utf-8-length types))))] - [targets (malloc _GtkTargetEntry (length types))]) - (for/fold ([offset 0]) ([str (in-list types)] - [i (in-naturals)]) - (let ([t (cast (ptr-add targets i _GtkTargetEntry) _pointer _GtkTargetEntry-pointer)]) - (set-GtkTargetEntry-target! t (ptr-add target-strings offset)) - (set-GtkTargetEntry-flags! t 0) - (set-GtkTargetEntry-info! t i)) - (let ([bstr (string->bytes/utf-8 str)]) - (memcpy target-strings offset bstr 0 (bytes-length bstr)) - (let ([offset (+ offset (bytes-length bstr))]) - (ptr-set! (ptr-add target-strings offset) _byte 0) - (+ offset 1)))) - (set! client c) - (set! client-data all-data) - - (atomically - (let ([this-box (malloc-immobile-cell this)]) - (set! self-box this-box) - (gtk_clipboard_set_with_data cb - targets - (length types) - get_data - clear_owner - this-box))) + (define/public (set-client c orig-types) + (let ([all-data (if x-selection? + ;; In X selection mode, get the data on demand: + #f + ;; In clipboard mode, we can get the data + ;; now, so it's ready if anyone asks: + (for/list ([t (in-list orig-types)]) + (send c get-data t)))] + [types (for/list ([t (in-list orig-types)]) + (if (equal? t "TEXT") + "UTF8_STRING" + t))]) + (let-values ([(orig-types types all-data) + ;; For "TEXT", provide "UTF8_STRING", "STRING", and "TEXT": + (if (member "TEXT" orig-types) + (values (append orig-types (list "TEXT" "TEXT")) + (append types (list "STRING" "TEXT")) + (and all-data (append all-data + (let loop ([all-data all-data] + [orig-types orig-types]) + (if (equal? "TEXT" (car orig-types)) + (list (car all-data) (car all-data)) + (loop (cdr all-data) (cdr orig-types))))))) + (values orig-types types all-data))]) + (let ([target-strings (malloc 'raw _byte (+ (length types) + (apply + (map string-utf-8-length types))))] + [targets (malloc _GtkTargetEntry (length types))]) + (for/fold ([offset 0]) ([str (in-list types)] + [i (in-naturals)]) + (let ([t (cast (ptr-add targets i _GtkTargetEntry) _pointer _GtkTargetEntry-pointer)]) + (set-GtkTargetEntry-target! t (ptr-add target-strings offset)) + (set-GtkTargetEntry-flags! t 0) + (set-GtkTargetEntry-info! t i)) + (let ([bstr (string->bytes/utf-8 str)]) + (memcpy target-strings offset bstr 0 (bytes-length bstr)) + (let ([offset (+ offset (bytes-length bstr))]) + (ptr-set! (ptr-add target-strings offset) _byte 0) + (+ offset 1)))) + (set! client c) + (set! client-data all-data) + (set! client-types types) + (set! client-orig-types orig-types) + + (atomically + (let ([this-box (malloc-immobile-cell this)]) + (set! self-box this-box) + (gtk_clipboard_set_with_data cb + targets + (length types) + get_data + clear_owner + this-box))) - (free target-strings))))) + (free target-strings))))) (define/public (replaced s-box) - ;; Called in Gtk event-dispatch thread --- atomically with respect - ;; to any other thread + ;; In atomic mode (when (ptr-equal? s-box self-box) (set! self-box #f) (let ([c client]) (when c (set! client #f) (set! client-data #f) + (set! client-types #f) + (set! client-orig-types #f) (queue-event (send c get-client-eventspace) (lambda () (send c on-replaced)))))) (free-immobile-cell s-box)) (define/public (provide-data i sel-data) - ;; Called in Gtk event-dispatch thread --- atomically with respect - ;; to any other thread + ;; In atomic mode; if it's the selection (not clipboard), + ;; then hopefully we're in the right eventspace (let ([bstr (if client - (list-ref client-data i) + (if client-data + (list-ref client-data i) + (constrained-reply (send client get-client-eventspace) + (lambda () + (send client get-data + (list-ref client-orig-types i))) + #"")) #"")]) - (gtk_selection_data_set sel-data - (gdk_atom_intern "UTF8_STRING" #t) - 8 - bstr - (bytes-length bstr)))) + (gtk_selection_data_set sel-data + (gdk_atom_intern (list-ref client-types i) #t) + 8 + bstr + (bytes-length bstr)))) (define/public (get-data format) (let ([process (lambda (v) @@ -190,3 +220,9 @@ (gobject-unref pixbuf))))) (super-new)) + +(define (get-selection-eventspace) + (and the-x-selection-driver + (let ([c (send the-x-selection-driver get-client)]) + (and c + (send c get-client-eventspace))))) diff --git a/collects/mred/private/wx/gtk/frame.rkt b/collects/mred/private/wx/gtk/frame.rkt index c1c43315c6..994ab5f2d2 100644 --- a/collects/mred/private/wx/gtk/frame.rkt +++ b/collects/mred/private/wx/gtk/frame.rkt @@ -180,6 +180,7 @@ (connect-delete gtk) (connect-configure gtk) (connect-focus gtk) + (connect-window-state gtk) (define saved-title (or label "")) (define is-modified? #f) @@ -311,6 +312,7 @@ (hash-set! all-frames this #t) (hash-remove! all-frames this)) (super direct-show on?) + (when on? (gtk_window_deiconify gtk)) (register-frame-shown this on?)) (define/public (destroy) diff --git a/collects/mred/private/wx/gtk/message.rkt b/collects/mred/private/wx/gtk/message.rkt index fd47ac52cd..587f3291a3 100644 --- a/collects/mred/private/wx/gtk/message.rkt +++ b/collects/mred/private/wx/gtk/message.rkt @@ -2,6 +2,7 @@ (require racket/class ffi/unsafe "../../syntax.rkt" + "../../lock.rkt" "item.rkt" "utils.rkt" "types.rkt" @@ -21,6 +22,7 @@ (define-gtk gtk_label_set_text_with_mnemonic (_fun _GtkWidget _string -> _void)) (define-gtk gtk_image_new_from_stock (_fun _string _int -> _GtkWidget)) (define-gtk gtk_misc_set_alignment (_fun _GtkWidget _float _float -> _void)) +(define-gtk gtk_image_set_from_pixbuf (_fun _GtkWidget _GdkPixbuf -> _void)) (define (mnemonic-string s) (if (regexp-match? #rx"&" s) @@ -75,6 +77,13 @@ (set-auto-size) (define/override (set-label s) - (gtk_label_set_text_with_mnemonic (get-gtk) (mnemonic-string s))) + (cond + [(string? s) + (gtk_label_set_text_with_mnemonic (get-gtk) (mnemonic-string s))] + [else + (let ([pixbuf (bitmap->pixbuf s)]) + (atomically + (gtk_image_set_from_pixbuf (get-gtk) pixbuf) + (release-pixbuf pixbuf)))])) (def/public-unimplemented get-font)) diff --git a/collects/mred/private/wx/gtk/queue.rkt b/collects/mred/private/wx/gtk/queue.rkt index 80855f657e..110e8932d6 100644 --- a/collects/mred/private/wx/gtk/queue.rkt +++ b/collects/mred/private/wx/gtk/queue.rkt @@ -6,6 +6,7 @@ "../../lock.rkt" "../common/queue.rkt" "../common/freeze.rkt" + "clipboard.rkt" "const.rkt" "w32.rkt" "unique.rkt") @@ -163,11 +164,19 @@ (let* ([gtk (gtk_get_event_widget evt)] [wx (and gtk (widget-hook gtk))]) (cond - [(and (= (ptr-ref evt _int) GDK_EXPOSE) + [(and (= (ptr-ref evt _GdkEventType) GDK_EXPOSE) wx (send wx direct-update?)) (gtk_main_do_event evt)] - [(and wx (send wx get-eventspace)) + [(or + ;; event for a window that we control? + (and wx (send wx get-eventspace)) + ;; event to get X selection data? + (and (= (ptr-ref evt _GdkEventType) GDK_SELECTION_REQUEST) + (let ([s (cast evt _pointer _GdkEventSelection-pointer)]) + (= (GdkEventSelection-selection s) + primary-atom)) + (get-selection-eventspace))) => (lambda (e) (let ([evt (gdk_event_copy evt)]) (queue-event e (lambda () diff --git a/collects/mred/private/wx/gtk/types.rkt b/collects/mred/private/wx/gtk/types.rkt index 0274dc503e..20bb567ccd 100644 --- a/collects/mred/private/wx/gtk/types.rkt +++ b/collects/mred/private/wx/gtk/types.rkt @@ -8,6 +8,8 @@ _GdkScreen _gpointer _GType + _GdkEventType + _GdkAtom _fnpointer _gboolean @@ -27,6 +29,8 @@ (struct-out GdkEventConfigure) _GdkEventExpose _GdkEventExpose-pointer (struct-out GdkEventExpose) + _GdkEventSelection _GdkEventSelection-pointer + (struct-out GdkEventSelection) (struct-out GdkRectangle) _GdkColor _GdkColor-pointer (struct-out GdkColor))) @@ -50,6 +54,8 @@ (define _gfloat _float) (define _GdkEventType _int) +(define _GdkAtom _intptr) + (define-cstruct _GdkEventButton ([type _GdkEventType] [window _GdkWindow] [send_event _byte] @@ -123,6 +129,15 @@ [width _int] [height _int])) +(define-cstruct _GdkEventSelection ([type _GdkEventType] + [window _GdkWindow] + [send_event _byte] + [selection _GdkAtom] + [target _GdkAtom] + [property _GdkAtom] + [time _uint32] + [requestor _pointer])) + (define-cstruct _GdkRectangle ([x _int] [y _int] [width _int] diff --git a/collects/mred/private/wx/gtk/utils.rkt b/collects/mred/private/wx/gtk/utils.rkt index 16d569ef4f..069e4d42ed 100644 --- a/collects/mred/private/wx/gtk/utils.rkt +++ b/collects/mred/private/wx/gtk/utils.rkt @@ -2,16 +2,17 @@ (require ffi/unsafe ffi/unsafe/define ffi/unsafe/alloc + racket/draw/unsafe/glib (only-in '#%foreign ctype-c->scheme) "../common/utils.rkt" "types.rkt") (provide define-mz + define-gobj + define-glib (protect-out define-gtk define-gdk - define-gobj - define-glib define-gdk_pixbuf g_object_ref @@ -56,27 +57,6 @@ (ffi-lib "libgdk_pixbuf-2.0-0") (ffi-lib "libgdk-win32-2.0-0")] [else (ffi-lib "libgdk-x11-2.0" '("0"))])) -(define gobj-lib - (case (system-type) - [(windows) - (ffi-lib "libgobject-2.0-0")] - [(unix) - (ffi-lib "libgobject-2.0" '("0"))] - [else gdk-lib])) -(define glib-lib - (case (system-type) - [(windows) - (ffi-lib "libglib-2.0-0")] - [(unix) - (ffi-lib "libglib-2.0" '("0"))] - [else gdk-lib])) -(define gmodule-lib - (case (system-type) - [(windows) - (ffi-lib "libgmodule-2.0-0")] - [(unix) - (ffi-lib "libgmodule-2.0" '("0"))] - [else gdk-lib])) (define gdk_pixbuf-lib (case (system-type) [(windows) @@ -91,9 +71,6 @@ [else (ffi-lib "libgtk-x11-2.0" '("0"))])) (define-ffi-definer define-gtk gtk-lib) -(define-ffi-definer define-gobj gobj-lib) -(define-ffi-definer define-glib glib-lib) -(define-ffi-definer define-gmodule gmodule-lib) (define-ffi-definer define-gdk gdk-lib) (define-ffi-definer define-gdk_pixbuf gdk_pixbuf-lib) diff --git a/collects/mred/private/wx/win32/canvas.rkt b/collects/mred/private/wx/win32/canvas.rkt index e871aeb2f5..cfaf727abf 100644 --- a/collects/mred/private/wx/win32/canvas.rkt +++ b/collects/mred/private/wx/win32/canvas.rkt @@ -157,19 +157,20 @@ [hdc (BeginPaint w ps)]) (if for-gl? (queue-paint) - (unless (positive? paint-suspended) - (let* ([hbrush (if no-autoclear? - #f - (if transparent? - background-hbrush - (CreateSolidBrush bg-colorref)))]) - (when hbrush - (let ([r (GetClientRect canvas-hwnd)]) - (FillRect hdc r hbrush)) - (unless transparent? - (DeleteObject hbrush))) - (unless (do-canvas-backing-flush hdc) - (queue-paint))))) + (if (positive? paint-suspended) + (set! suspended-refresh? #t) + (let* ([hbrush (if no-autoclear? + #f + (if transparent? + background-hbrush + (CreateSolidBrush bg-colorref)))]) + (when hbrush + (let ([r (GetClientRect canvas-hwnd)]) + (FillRect hdc r hbrush)) + (unless transparent? + (DeleteObject hbrush))) + (unless (do-canvas-backing-flush hdc) + (queue-paint))))) (EndPaint hdc ps)) 0] [(= msg WM_NCPAINT) @@ -271,22 +272,38 @@ (define/public (do-canvas-backing-flush hdc) (if hdc (do-backing-flush this dc hdc) - (let ([hdc (GetDC canvas-hwnd)]) - (do-backing-flush this dc hdc) - (ReleaseDC canvas-hwnd hdc) - (ValidateRect canvas-hwnd #f)))) + (if (positive? paint-suspended) + ;; suspended => try again later + (schedule-periodic-backing-flush) + ;; not suspended + (let ([hdc (GetDC canvas-hwnd)]) + (do-backing-flush this dc hdc) + (ReleaseDC canvas-hwnd hdc) + ;; We'd like to validate the region that + ;; we just updated, so we can potentially + ;; avoid a redundant refresh. For some reason, + ;; vadilation can cancel an update that hasn't + ;; happened, yet; this problem needs further + ;; invesitigation. + #; + (ValidateRect canvas-hwnd #f))))) (define/public (make-compatible-bitmap w h) (send dc make-backing-bitmap w h)) (define paint-suspended 0) + (define suspended-refresh? #f) (define/public (suspend-paint-handling) (atomically (set! paint-suspended (add1 paint-suspended)))) (define/public (resume-paint-handling) (atomically (unless (zero? paint-suspended) - (set! paint-suspended (sub1 paint-suspended))))) + (set! paint-suspended (sub1 paint-suspended)) + (when (and (zero? paint-suspended) + suspended-refresh?) + (set! suspended-refresh? #f) + (InvalidateRect canvas-hwnd #f #f))))) (define no-autoclear? (memq 'no-autoclear style)) (define transparent? (memq 'transparent style)) diff --git a/collects/mred/private/wx/win32/const.rkt b/collects/mred/private/wx/win32/const.rkt index 6f8b4cb8ed..a72df0876c 100644 --- a/collects/mred/private/wx/win32/const.rkt +++ b/collects/mred/private/wx/win32/const.rkt @@ -400,7 +400,7 @@ (define BS_FLAT #x00008000) (define BS_RIGHTBUTTON BS_LEFTTEXT) -(define CW_USEDEFAULT #x80000000) +(define CW_USEDEFAULT (- #x80000000)) ; minus sign => int instead of uint (define WS_EX_LAYERED #x00080000) (define WS_EX_TRANSPARENT #x00000020) diff --git a/collects/mred/private/wx/win32/dialog.rkt b/collects/mred/private/wx/win32/dialog.rkt index c249f2f9b8..18ed2593e0 100644 --- a/collects/mred/private/wx/win32/dialog.rkt +++ b/collects/mred/private/wx/win32/dialog.rkt @@ -34,7 +34,7 @@ (class (dialog-mixin frame%) (super-new) - (define/override (create-frame parent label w h style) + (define/override (create-frame parent label x y w h style) (let ([hwnd (CreateDialogIndirectParamW hInstance (make-DLGTEMPLATE @@ -46,7 +46,9 @@ dialog-proc 0)]) (SetWindowTextW hwnd label) - (MoveWindow hwnd 0 0 w h #t) + (let ([x (if (= x -11111) 0 x)] + [y (if (= y -11111) 0 y)]) + (MoveWindow hwnd x y w h #t)) hwnd)) (define/override (is-dialog?) #t))) diff --git a/collects/mred/private/wx/win32/frame.rkt b/collects/mred/private/wx/win32/frame.rkt index 058d5caaf4..4bbfcddf5a 100644 --- a/collects/mred/private/wx/win32/frame.rkt +++ b/collects/mred/private/wx/win32/frame.rkt @@ -108,7 +108,7 @@ pre-on-char pre-on-event reset-cursor-in-child) - (define/public (create-frame parent label w h style) + (define/public (create-frame parent label x y w h style) (CreateWindowExW (if (memq 'float style) (bitwise-ior WS_EX_TOOLWINDOW (if (memq 'no-caption style) @@ -131,7 +131,9 @@ 0 (bitwise-ior WS_CAPTION WS_MINIMIZEBOX))) - 0 0 w h + (if (= x -11111) CW_USEDEFAULT x) + (if (= y -11111) CW_USEDEFAULT y) + w h #f #f hInstance @@ -146,7 +148,7 @@ (define max-height #f) (super-new [parent #f] - [hwnd (create-frame parent label w h style)] + [hwnd (create-frame parent label x y w h style)] [style (cons 'deleted style)]) (define hwnd (get-hwnd)) @@ -185,7 +187,9 @@ (set! hidden-zoomed? (is-maximized?))) (super direct-show on? (if hidden-zoomed? SW_SHOWMAXIMIZED - SW_SHOW))) + SW_SHOW)) + (when (and on? (iconized?)) + (ShowWindow hwnd SW_RESTORE))) (define/public (destroy) (direct-show #f)) @@ -393,7 +397,7 @@ (define/public (iconize on?) (when (is-shown?) - (when (or on? (not (iconized?))) + (unless (eq? (and on? #t) (iconized?)) (ShowWindow hwnd (if on? SW_MINIMIZE SW_RESTORE))))) (define/private (get-placement) diff --git a/collects/mred/private/wx/win32/window.rkt b/collects/mred/private/wx/win32/window.rkt index caca412bcd..3ca1072ca2 100644 --- a/collects/mred/private/wx/win32/window.rkt +++ b/collects/mred/private/wx/win32/window.rkt @@ -322,7 +322,7 @@ [dc (make-object bitmap-dc% bm)]) (set! measure-dc dc))) (send measure-dc set-font (or font - (make-object font% 8 'system))) + (get-default-control-font))) (let-values ([(w h d a) (let loop ([label label]) (cond [(null? label) (values 0 0 0 0)] @@ -689,6 +689,18 @@ ;; ---------------------------------------- +(define default-control-font #f) +(define (get-default-control-font) + (unless default-control-font + (set! default-control-font + (make-object font% + (get-theme-font-size) + (get-theme-font-face) + 'system + 'normal 'normal #f 'default + #t))) + default-control-font) + (define (queue-window-event win thunk) (queue-event (send win get-eventspace) thunk)) diff --git a/collects/mred/private/wxme/snip.rkt b/collects/mred/private/wxme/snip.rkt index 13e3d58fbc..faeac4d89d 100644 --- a/collects/mred/private/wxme/snip.rkt +++ b/collects/mred/private/wxme/snip.rkt @@ -964,9 +964,14 @@ (send mask ok?) (= w (send mask get-width)) (= w (send mask get-height)) - mask)))]) + mask)))] + [alpha (send dc get-alpha)]) + (when (pair? caret) + (send dc set-alpha (* 0.5 alpha))) (send dc draw-bitmap-section bm x y 0 0 w h - 'solid black-color msk)))) + 'solid black-color msk) + (when (pair? caret) + (send dc set-alpha alpha))))) (def/override (copy) (let ([s (new image-snip%)]) diff --git a/collects/mred/private/wxme/text.rkt b/collects/mred/private/wxme/text.rkt index b8a4982e65..be32c886a3 100644 --- a/collects/mred/private/wxme/text.rkt +++ b/collects/mred/private/wxme/text.rkt @@ -49,12 +49,7 @@ (define outline-pen (send the-pen-list find-or-create-pen "BLACK" 0 'transparent)) (define outline-inactive-pen (send the-pen-list find-or-create-pen (get-highlight-background-color) 1 'solid)) (define outline-brush (send the-brush-list find-or-create-brush (get-highlight-background-color) 'solid)) -(define xpattern #"\x88\x88\0\0\x22\x22\0\0\x88\x88\0\0\x22\x22\0\0\x88\x88\0\0\x22\x22\0\0\x88\x88\0\0\x22\x22\0\0") -(define outline-nonowner-brush (let ([b (new brush%)]) - (send b set-color "BLACK") - (send b set-stipple (make-object bitmap% xpattern 16 16)) - (send b set-style 'xor) - b)) +(define outline-nonowner-brush outline-brush) (define clear-brush (send the-brush-list find-or-create-brush "WHITE" 'solid)) (define (showcaret>= a b) @@ -5257,28 +5252,15 @@ hilite-some? hsxs hsxe hsys hsye old-style)))))))))) (let*-values ([(draw-first?) - (or (not (showcaret>= show-caret 'show-caret)) - (and s-caret-snip (not (pair? show-caret))) - (not hilite-on?) + (or (and (or (not (showcaret>= show-caret 'show-caret)) + (and s-caret-snip (not (pair? show-caret))) + (not hilite-on?)) + (not show-xsel?)) (= -startpos -endpos) (-endpos . < . pcounter) (-startpos . > . (+ pcounter (mline-len line))))] [(hilite-some? hsxs hsxe hsys hsye old-style) (process-snips draw-first? #f old-style)]) - (when (and (positive? wrap-bitmap-width) - (not (has-flag? (snip->flags (mline-last-snip line)) HARD-NEWLINE)) - last - (rightx . >= . max-width) - (send auto-wrap-bitmap ok?)) - (let ([h (min (->long (send auto-wrap-bitmap get-height)) - (mline-bottombase line))] - [osfg (send old-style get-foreground)]) - (send dc draw-bitmap-section - auto-wrap-bitmap - (sub1 (+ max-width dx)) (+ (- bottombase h) dy) - 0 0 wrap-bitmap-width h - 'solid osfg))) - (let ([prevwasfirst (if hilite-some? (if (not (= hsxs hsxe)) @@ -5337,6 +5319,21 @@ (send dc set-pen save-pen)))) prevwasfirst)) prevwasfirst)]) + + (when (and (positive? wrap-bitmap-width) + (not (has-flag? (snip->flags (mline-last-snip line)) HARD-NEWLINE)) + last + (rightx . >= . max-width) + (send auto-wrap-bitmap ok?)) + (let ([h (min (->long (send auto-wrap-bitmap get-height)) + (mline-bottombase line))] + [osfg (send old-style get-foreground)]) + (send dc draw-bitmap-section + auto-wrap-bitmap + (sub1 (+ max-width dx)) (+ (- bottombase h) dy) + 0 0 wrap-bitmap-width h + 'solid osfg))) + (let ([old-style (if draw-first? old-style diff --git a/collects/mred/private/wxtextfield.rkt b/collects/mred/private/wxtextfield.rkt index e87ae2c890..6f4c7f391f 100644 --- a/collects/mred/private/wxtextfield.rkt +++ b/collects/mred/private/wxtextfield.rkt @@ -1,9 +1,10 @@ -(module wxtextfield mzscheme +(module wxtextfield racket/base (require mzlib/class mzlib/class100 - (prefix wx: "kernel.ss") - (prefix wx: "wxme/text.ss") - (prefix wx: "wxme/editor-canvas.ss") + (prefix-in wx: "kernel.ss") + (prefix-in wx: "wxme/text.ss") + (prefix-in wx: "wxme/snip.ss") + (prefix-in wx: "wxme/editor-canvas.ss") "lock.ss" "const.ss" "check.ss" @@ -17,14 +18,63 @@ "editor.ss" "mrpopup.ss") - (provide (protect wx-text-field%)) + (provide (protect-out wx-text-field%)) + + (define no-pen (send wx:the-pen-list find-or-create-pen "white" 1 'transparent)) + (define black-brush (send wx:the-brush-list find-or-create-brush "black" 'solid)) + + (define password-string-snip% + (class wx:string-snip% + (inherit get-count + get-style + get-text) + (super-new) + + (define delta 2) + (define (get-size) + (max 4 (send (send (get-style) get-font) get-point-size))) + + (define/override (get-extent dc x y [w #f] [h #f] [descent #f] [space #f] [lspace #f] [rspace #f]) + (let ([s (get-size)]) + (when w (set-box! w (* s (get-count)))) + (when h (set-box! h (+ s 2.0))) + (when descent (set-box! descent 1.0)) + (when space (set-box! space 1.0)) + (when lspace (set-box! lspace 0.0)) + (when rspace (set-box! rspace 0.0)))) + (define/override (partial-offset dc x y pos) + (let ([s (get-size)]) + (* s pos))) + (define/override (draw dc x y left top right bottom dx dy draw-caret) + (let ([s (get-size)] + [b (send dc get-brush)] + [p (send dc get-pen)] + [m (send dc get-smoothing)]) + (send dc set-pen no-pen) + (send dc set-brush black-brush) + (send dc set-smoothing 'aligned) + (for/fold ([x x]) ([i (in-range (get-count))]) + (send dc draw-ellipse (+ x delta) (+ y delta 1) (- s delta delta) (- s delta delta)) + (+ x s)) + (send dc set-pen p) + (send dc set-brush b) + (send dc set-smoothing m))) + (define/override (split pos first second) + (let ([a (new password-string-snip%)] + [b (new password-string-snip%)] + [c (get-count)]) + (send a insert (get-text 0 pos) pos) + (send b insert (get-text pos c) (- c pos)) + (set-box! first a) + (set-box! second b))))) (define text-field-text% - (class100 text% (cb ret-cb control set-cb-mgrs! record-text) + (class100 text% (cb ret-cb control set-cb-mgrs! record-text pw?) (rename [super-on-char on-char]) (inherit get-text last-position set-max-undo-history get-flattened-text) (private-field - [return-cb ret-cb]) + [return-cb ret-cb] + [password? pw?]) (private-field [block-callback 1] [callback @@ -42,7 +92,12 @@ (unless (and (or (eq? c #\return) (eq? c #\newline)) return-cb (return-cb (lambda () (callback 'text-field-enter) #t))) - (as-exit (lambda () (super-on-char e)))))))]) + (as-exit (lambda () (super-on-char e)))))))] + [on-new-string-snip + (lambda () + (if password? + (new password-string-snip%) + (super on-new-string-snip)))]) (augment [after-insert (lambda args @@ -91,7 +146,8 @@ (set! without-callback wc) (set! callback-ready cr)) (lambda (t) - (send c set-combo-text t)))]) + (send c set-combo-text t)) + (memq 'password style))]) (sequence (as-exit (lambda () @@ -202,14 +258,7 @@ (send e auto-wrap (and multi? (not (memq 'hscroll style)))) (let ([f font] [s (send (send e get-style-list) find-named-style "Standard")]) - (send s set-delta (let ([d (font->delta f)]) - (if (memq 'password style) - (begin - (send d set-face #f) - (send d set-family 'modern) - (send d set-delta-foreground "darkgray") - (send d set-delta-background "darkgray")) - d)))) + (send s set-delta (font->delta f))) (send c set-editor e) (send c set-line-count (if multi? 3 1)) (unless multi? (send c set-single-line)) diff --git a/collects/mred/private/wxtop.rkt b/collects/mred/private/wxtop.rkt index a0858c4816..c1fd3e71a6 100644 --- a/collects/mred/private/wxtop.rkt +++ b/collects/mred/private/wxtop.rkt @@ -90,7 +90,7 @@ [panel #f] [use-default-position? (and (= -11111 (list-ref args 2)) - (= -11111 (list-ref args (if dlg? 3 1))))] + (= -11111 (list-ref args (if dlg? 3 1))))] [enabled? #t] [focus #f] diff --git a/collects/mrlib/image-core.rkt b/collects/mrlib/image-core.rkt index 0190fbf94d..e9d4684d3d 100644 --- a/collects/mrlib/image-core.rkt +++ b/collects/mrlib/image-core.rkt @@ -214,26 +214,20 @@ has been moved out). (equal? (get-normalized-shape) (send that get-normalized-shape))) (let ([w (+ 1 (round (inexact->exact (bb-right bb))))] ;; some shapes (ie, rectangles) draw 1 outside the bounding box [h (+ 1 (round (inexact->exact (bb-bottom bb))))]) ;; so we make the bitmap slightly bigger to accomodate that. - (or (zero? w) - (zero? h) - (let ([bm1 (make-object bitmap% w h)] - [bm2 (make-object bitmap% w h)] + (or ;(zero? w) + ;(zero? h) + (let ([bm1 (make-bitmap w h #t)] + [bm2 (make-bitmap w h #t)] [bytes1 (make-bytes (* w h 4) 0)] [bytes2 (make-bytes (* w h 4) 0)] [bdc (make-object bitmap-dc%)]) - (and (check-same? bm1 bm2 bytes1 bytes2 bdc "red" that) - (check-same? bm1 bm2 bytes1 bytes2 bdc "green" that)))))))))) + (draw-into bm1 bdc bytes1 this) + (draw-into bm2 bdc bytes2 that) + (equal? bytes1 bytes2))))))))) - (define/private (check-same? bm1 bm2 bytes1 bytes2 bdc color that) - (clear-bitmap/draw/bytes bm1 bdc bytes1 this color) - (clear-bitmap/draw/bytes bm2 bdc bytes2 that color) - (equal? bytes1 bytes2)) - - (define/private (clear-bitmap/draw/bytes bm bdc bytes obj color) + (define/private (draw-into bm bdc bytes obj) (send bdc set-bitmap bm) - (send bdc set-pen "black" 1 'transparent) - (send bdc set-brush color 'solid) - (send bdc draw-rectangle 0 0 (send bm get-width) (send bm get-height)) + (send bdc clear) (render-image obj bdc 0 0) (send bdc get-argb-pixels 0 0 (send bm get-width) (send bm get-height) bytes)) @@ -1020,7 +1014,7 @@ the mask bitmap and the original bitmap are all together in a single bytes! [(pen? color) (pen->pen-obj/cache color)] [else - (send the-pen-list find-or-create-pen (get-color-arg color) 0 'solid)])] + (send the-pen-list find-or-create-pen (get-color-arg color) 0 'solid 'round 'miter)])] [(solid) (send the-pen-list find-or-create-pen "black" 1 'transparent)])) diff --git a/collects/mrlib/private/image-core-bitmap.rkt b/collects/mrlib/private/image-core-bitmap.rkt index 7b6b2baf5d..949acdcb56 100644 --- a/collects/mrlib/private/image-core-bitmap.rkt +++ b/collects/mrlib/private/image-core-bitmap.rkt @@ -72,14 +72,8 @@ instead of this scaling code, we use the dc<%>'s scaling code. w h (* w h NUM-CHANNELS))) - (let* ([bm (make-object bitmap% w h)] - [mask (make-object bitmap% w h)] - [bdc (make-object bitmap-dc% bm)]) - (send bdc set-argb-pixels 0 0 w h bytes #f) - (send bdc set-bitmap mask) - (send bdc set-argb-pixels 0 0 w h bytes #t) - (send bdc set-bitmap #f) - (send bm set-loaded-mask mask) + (let* ([bm (make-bitmap w h)]) + (send bm set-argb-pixels 0 0 w h bytes) bm)) (define (flip-bytes bmbytes w h) diff --git a/collects/mzlib/private/contract-object.rkt b/collects/mzlib/private/contract-object.rkt index d877bac100..0188cb4069 100644 --- a/collects/mzlib/private/contract-object.rkt +++ b/collects/mzlib/private/contract-object.rkt @@ -281,33 +281,26 @@ ... [field-ctc-var (coerce-contract 'object-contract field-ctc-stx)] ...) - (make-contract - #:name - `(object-contract - ,(build-compound-type-name 'method-name method-ctc-var) ... - ,(build-compound-type-name 'field 'field-name field-ctc-var) ...) - #:projection - (lambda (blame) + (define ctc + (make-contract + #:name + `(object-contract + ,(build-compound-type-name 'method-name method-ctc-var) ... + ,(build-compound-type-name 'field 'field-name field-ctc-var) ...) + #:projection + (lambda (blame) + (lambda (val) + (make-wrapper-object ctc val blame + (list 'method-name ...) (list method-ctc-var ...) + (list 'field-name ...) (list field-ctc-var ...)))) + #:first-order (lambda (val) - (make-wrapper-object val blame - (list 'method-name ...) (list method-ctc-var ...) - (list 'field-name ...) (list field-ctc-var ...)))) - #:first-order - (lambda (val) - (check-object-contract val #f (list 'method-name ...) (list 'field-name ...))))))))])))) + (let/ec ret + (check-object-contract val (list 'method-name ...) (list 'field-name ...) + (λ args (ret #f))))))) + ctc))))])))) -(define (check-object val blame) - (unless (object? val) - (raise-blame-error blame val "expected an object, got ~e" val))) - -(define (check-method val method-name val-mtd-names blame) - (unless (memq method-name val-mtd-names) - (raise-blame-error blame val "expected an object with method ~s" method-name))) - -(define (field-error val field-name blame) - (raise-blame-error blame val "expected an object with field ~s" field-name)) - (define (make-mixin-contract . %/<%>s) ((and/c (flat-contract class?) (apply and/c (map sub/impl?/c %/<%>s))) diff --git a/collects/net/cgi-unit.rkt b/collects/net/cgi-unit.rkt index 24a1ba3492..00c916e267 100644 --- a/collects/net/cgi-unit.rkt +++ b/collects/net/cgi-unit.rkt @@ -24,16 +24,15 @@ ;; -------------------------------------------------------------------- -;; query-chars->string : list (char) -> string +;; query-string->string : string -> string -;; -- The input is the characters post-processed as per Web specs, which +;; -- The input is the string post-processed as per Web specs, which ;; is as follows: ;; spaces are turned into "+"es and lots of things are turned into %XX, where ;; XX are hex digits, eg, %E7 for ~. The output is a regular Scheme string ;; with all the characters converted back. -(define (query-chars->string chars) - (form-urlencoded-decode (list->string chars))) +(define query-string->string form-urlencoded-decode) ;; string->html : string -> string ;; -- the input is raw text, the output is HTML appropriately quoted @@ -92,70 +91,53 @@ (define (output-http-headers) (printf "Content-type: text/html\r\n\r\n")) -;; read-until-char : iport x char -> list (char) x bool -;; -- operates on the default input port; the second value indicates whether -;; reading stopped because an EOF was hit (as opposed to the delimiter being -;; seen); the delimiter is not part of the result -(define (read-until-char ip delimiter?) - (let loop ([chars '()]) - (let ([c (read-char ip)]) - (cond [(eof-object? c) (values (reverse chars) #t)] - [(delimiter? c) (values (reverse chars) #f)] - [else (loop (cons c chars))])))) - -;; delimiter->predicate : -;; symbol -> (char -> bool) -;; returns a predicates to pass to read-until-char -(define (delimiter->predicate delimiter) +;; delimiter->predicate : symbol -> regexp +;; returns a regexp to read a chunk of text up to a delimiter (excluding it) +(define (delimiter->rx delimiter) (case delimiter - [(eq) (lambda (c) (char=? c #\=))] - [(amp) (lambda (c) (char=? c #\&))] - [(semi) (lambda (c) (char=? c #\;))] - [(amp-or-semi) (lambda (c) (or (char=? c #\&) (char=? c #\;)))])) + [(amp) #rx#"^[^&]*"] + [(semi) #rx#"^[^;]*"] + [(amp-or-semi) #rx#"^[^&;]*"] + [else (error 'delimiter->rx + "internal-error, unknown delimiter: ~e" delimiter)])) -;; read-name+value : iport -> (symbol + bool) x (string + bool) x bool -;; -- If the first value is false, so is the second, and the third is true, -;; indicating EOF was reached without any input seen. Otherwise, the first -;; and second values contain strings and the third is either true or false -;; depending on whether the EOF has been reached. The strings are processed -;; to remove the CGI spec "escape"s. This code is _slightly_ lax: it allows -;; an input to end in (current-alist-separator-mode). -;; It's not clear this is legal by the CGI spec, -;; which suggests that the last value binding must end in an EOF. It doesn't -;; look like this matters. It would also introduce needless modality and -;; reduce flexibility. -(define (read-name+value ip) - (let-values ([(name eof?) (read-until-char ip (delimiter->predicate 'eq))]) - (cond [(and eof? (null? name)) (values #f #f #t)] - [eof? - (generate-error-output - (list "Server generated malformed input for POST method:" - (string-append - "No binding for `" (list->string name) "' field.")))] - [else (let-values ([(value eof?) - (read-until-char - ip - (delimiter->predicate - (current-alist-separator-mode)))]) - (values (string->symbol (query-chars->string name)) - (query-chars->string value) - eof?))]))) +;; get-bindings* : iport -> (listof (cons symbol string)) +;; Reads all bindings from the input port. The strings are processed to +;; remove the CGI spec "escape"s. +;; This code is _slightly_ lax: it allows an input to end in +;; (current-alist-separator-mode). It's not clear this is legal by the +;; CGI spec, which suggests that the last value binding must end in an +;; EOF. It doesn't look like this matters. +;; ELI: * Keeping this behavior for now, maybe better to remove it? +;; * Looks like `form-urlencoded->alist' is doing almost exactly +;; the same job this code does. +(define (get-bindings* method ip) + (define (err fmt . xs) + (generate-error-output + (list (format "Server generated malformed input for ~a method:" method) + (apply format fmt xs)))) + (define value-rx (delimiter->rx (current-alist-separator-mode))) + (define (process str) (query-string->string (bytes->string/utf-8 str))) + (let loop ([bindings '()]) + (if (eof-object? (peek-char ip)) + (reverse bindings) + (let () + (define name (car (or (regexp-match #rx"^[^=]+" ip) + (err "Missing field name before `='")))) + (unless (eq? #\= (read-char ip)) + (err "No binding for `~a' field." name)) + (define value (car (regexp-match value-rx ip))) + (read-char ip) ; consume the delimiter, possibly eof (retested above) + (loop (cons (cons (string->symbol (process name)) (process value)) + bindings)))))) ;; get-bindings/post : () -> bindings (define (get-bindings/post) - (let-values ([(name value eof?) (read-name+value (current-input-port))]) - (cond [(and eof? (not name)) null] - [(and eof? name) (list (cons name value))] - [else (cons (cons name value) (get-bindings/post))]))) + (get-bindings* "POST" (current-input-port))) ;; get-bindings/get : () -> bindings (define (get-bindings/get) - (let ([p (open-input-string (getenv "QUERY_STRING"))]) - (let loop () - (let-values ([(name value eof?) (read-name+value p)]) - (cond [(and eof? (not name)) null] - [(and eof? name) (list (cons name value))] - [else (cons (cons name value) (loop))]))))) + (get-bindings* "GET" (open-input-string (getenv "QUERY_STRING")))) ;; get-bindings : () -> bindings (define (get-bindings) diff --git a/collects/net/scribblings/websocket.scrbl b/collects/net/scribblings/websocket.scrbl index c887c99dc1..5833c5d117 100644 --- a/collects/net/scribblings/websocket.scrbl +++ b/collects/net/scribblings/websocket.scrbl @@ -6,6 +6,7 @@ web-server/http racket/list racket/async-channel + (prefix-in raw: (for-label net/tcp-unit)) net/websocket net/websocket/client net/websocket/server @@ -46,6 +47,7 @@ This module also provides the exports from @racketmodname[net/websocket/conn]. conn-headers (bytes? (listof header?) . -> . (values (listof header?) any/c)) (λ (b hs) (values empty (void)))] + [#:tcp@ tcp@ (unit/c (import) (export tcp^)) raw:tcp@] [#:port port tcp-listen-port? 80] [#:listen-ip listen-ip (or/c string? false/c) #f] [#:max-waiting max-waiting integer? 4] @@ -64,6 +66,7 @@ This module also provides the exports from @racketmodname[net/websocket/conn]. All other arguments are used as in a @secref["dispatch-server-unit" #:doc '(lib "web-server/scribblings/web-server-internal.scrbl")]. + The @racket[#:tcp@] keyword is provided for building an SSL server. } This module also provides the exports from @racketmodname[net/websocket/conn]. diff --git a/collects/net/websocket/server.rkt b/collects/net/websocket/server.rkt index d0f4af751c..f74d78a8c6 100644 --- a/collects/net/websocket/server.rkt +++ b/collects/net/websocket/server.rkt @@ -7,6 +7,8 @@ web-server/http/request-structs racket/async-channel unstable/contract + net/tcp-sig + (prefix-in raw: net/tcp-unit) net/websocket/conn net/websocket/handshake) (provide (except-out (all-from-out net/websocket/conn) ws-conn)) @@ -16,6 +18,8 @@ (->* ((open-ws-conn? any/c . -> . void)) (#:conn-headers (bytes? (listof header?) . -> . (values (listof header?) any/c)) + #:tcp@ + (unit/c (import) (export tcp^)) #:port tcp-listen-port? #:listen-ip @@ -30,6 +34,7 @@ (define (ws-serve conn-dispatch #:conn-headers [pre-conn-dispatch (λ (cline hs) (values empty (void)))] + #:tcp@ [tcp@ raw:tcp@] #:port [port 80] #:listen-ip [listen-ip #f] #:max-waiting [max-waiting 4] @@ -71,5 +76,14 @@ (conn-dispatch conn state)) - (define-values/invoke-unit/infer dispatch-server@) + (define-unit-binding a-tcp@ + tcp@ (import) (export tcp^)) + (define-compound-unit/infer dispatch-server@/tcp@ + (import dispatch-server-config^) + (link a-tcp@ dispatch-server@) + (export dispatch-server^)) + (define-values/invoke-unit + dispatch-server@/tcp@ + (import dispatch-server-config^) + (export dispatch-server^)) (serve #:confirmation-channel confirm-ch)) \ No newline at end of file diff --git a/collects/openssl/mzssl.rkt b/collects/openssl/mzssl.rkt index 339d72336e..d2ec22b506 100644 --- a/collects/openssl/mzssl.rkt +++ b/collects/openssl/mzssl.rkt @@ -270,7 +270,9 @@ (define-struct (ssl-client-context ssl-context) ()) (define-struct (ssl-server-context ssl-context) ()) - (define-struct ssl-listener (l mzctx)) + (define-struct ssl-listener (l mzctx) + #:property prop:evt (lambda (lst) (wrap-evt (ssl-listener-l lst) + (lambda (x) lst)))) ;; internal: (define-struct mzssl (ssl i o r-bio w-bio pipe-r pipe-w diff --git a/collects/openssl/openssl.scrbl b/collects/openssl/openssl.scrbl index 3a571d6868..a4eb3dae2d 100644 --- a/collects/openssl/openssl.scrbl +++ b/collects/openssl/openssl.scrbl @@ -139,8 +139,7 @@ Returns @scheme[#t] if @scheme[v] is a value produced by (or/c ssl-server-context? symbol?) 'sslv2-or-v3]) ssl-listener?]{ -Like @scheme[tcp-listen], but the result is an SSL listener (which is -a synchronizable value; see @scheme[sync]). The extra optional +Like @scheme[tcp-listen], but the result is an SSL listener. The extra optional @scheme[server-protocol] is as for @scheme[ssl-connect], except that a context must be a server context instead of a client context. @@ -149,7 +148,14 @@ Call @scheme[ssl-load-certificate-chain!] and error on accepting connections. The file @filepath{test.pem} in the @filepath{openssl} collection is a suitable argument for both calls when testing. Since @filepath{test.pem} is public, however, such a -test configuration obviously provides no security.} +test configuration obviously provides no security. + +An SSL listener is a synchronizable value (see @scheme[sync]). It is +ready---with itself as its value---when the underlying TCP listener is +ready. At that point, however, accepting a connection with +@racket[ssl-accept] may not complete immediately, because +further communication is needed to establish the connection.} + @deftogether[( @defproc[(ssl-close (listener ssl-listener?)) void?] diff --git a/collects/plai/mutator.rkt b/collects/plai/mutator.rkt index 6d34d1bebc..f67254ce26 100644 --- a/collects/plai/mutator.rkt +++ b/collects/plai/mutator.rkt @@ -110,7 +110,10 @@ [(_) (mutator-app void)] [(_ e) e] [(_ fe e ...) - (mutator-let ([tmp fe]) (mutator-begin e ...))])) + (let ([tmp + (syntax-parameterize ([mutator-tail-call? #f]) + fe)]) + (mutator-begin e ...))])) ; Real Macros (define-syntax-rule (mutator-define-values (id ...) e) diff --git a/collects/planet/planet.scrbl b/collects/planet/planet.scrbl index 31d0e87e7c..59d31e9fe8 100644 --- a/collects/planet/planet.scrbl +++ b/collects/planet/planet.scrbl @@ -734,19 +734,33 @@ is saved in the namespace, making the listening and information producing namespace-specific. @defproc[(planet-terse-register - [proc (-> (or/c 'download 'install 'docs-build 'finish) string? any/c)] - [namespace namespace? (current-namespace)]) void?]{ + [proc (-> (or/c 'download 'install 'docs-build 'finish) + string? + any/c)]) + void?]{ Registers @racket[proc] as a function to be called when -@racket[planet-terse-log] is called with a matching namespace argument. - Note that @racket[proc] is called +@racket[planet-terse-log] is called. + +Note that @racket[proc] is called asynchronously (ie, on some thread other than the one calling @racket[planet-terse-register]). } @defproc[(planet-terse-log [id (or/c 'download 'install 'finish)] - [msg string?] - [namespace namespace? (current-namespace)]) void?]{ - This function is called by PLaneT to announce when things are happening. -The namespace passed along is used to identify the procs to notify. + [msg string?]) void?]{ +This function is called by PLaneT to announce when things are happening. See also +@racket[planet-terse-set-key]. +} + +@defproc[(planet-terse-set-key [key any/c]) void?]{ + This sets a @seclink["threadcells" #:doc '(lib "scribblings/reference/reference.scrbl")]{thread cell} + to the value of @racket[key]. + The value of the thread cell is used as an index into a table to determine which + of the functions passed to @racket[planet-terse-register] to call when + @racket[planet-terse-log] is called. + + The table holding the key uses ephemerons and a weak hash table to ensure that + when the @racket[key] is unreachable, then the procedures passed to @racket[planet-terse-log] + cannot be reached through the table. } @section{Developing Packages for PLaneT} diff --git a/collects/planet/private/cmdline-tool.rkt b/collects/planet/private/cmdline-tool.rkt index c88a2269d0..1fc6ad35b7 100644 --- a/collects/planet/private/cmdline-tool.rkt +++ b/collects/planet/private/cmdline-tool.rkt @@ -212,7 +212,7 @@ This command does not unpack or install the named .plt file." (define (show-normals) (printf "Normally-installed packages:\n") (for-each - (lambda (l) (apply printf " ~a\t~a\t~a ~a\n" l)) + (lambda (l) (apply printf " ~a \t~a \t~a ~a\n" l)) (sort-by-criteria (map (lambda (x) (match x [(_ owner pkg _ maj min) (list owner pkg maj min)])) normal-packages) (list stringlist #'(#:args () (void))) accum) (let ([a (syntax-e (car lst))] @@ -140,6 +140,9 @@ [(arg . rest) (identifier? #'arg) (cons #'arg (loop #'rest))] + [([arg def] . rest) + (identifier? #'arg) + (cons #'[arg def] (loop #'rest))] [arg (identifier? #'arg) (list #'arg)] @@ -151,7 +154,9 @@ (serror "#:args must not be followed by another keyword" (car lst))) (with-syntax ([formals (car pieces)] [formal-names (map (lambda (x) - (symbol->string (syntax-e x))) + (let ([d (syntax->datum x)]) + (symbol->string + (if (pair? d) (car d) d)))) formal-names)] [body (cdr pieces)]) (values (reverse accum) diff --git a/collects/racket/contract/private/object.rkt b/collects/racket/contract/private/object.rkt index 82d2965149..23132838d8 100644 --- a/collects/racket/contract/private/object.rkt +++ b/collects/racket/contract/private/object.rkt @@ -39,7 +39,7 @@ (λ (ctc) (λ (blame) (λ (val) - (make-wrapper-object val blame + (make-wrapper-object ctc val blame (object-contract-methods ctc) (object-contract-method-ctcs ctc) (object-contract-fields ctc) (object-contract-field-ctcs ctc))))) #:name @@ -53,7 +53,9 @@ #:first-order (λ (ctc) (λ (val) - (check-object-contract val #f (object-contract-methods ctc) (object-contract-fields ctc)))))) + (let/ec ret + (check-object-contract val (object-contract-methods ctc) (object-contract-fields ctc) + (λ args (ret #f)))))))) (define-syntax (object-contract stx) (syntax-case stx () diff --git a/collects/racket/contract/private/vector.rkt b/collects/racket/contract/private/vector.rkt index 46393c404d..0e1f1674d5 100644 --- a/collects/racket/contract/private/vector.rkt +++ b/collects/racket/contract/private/vector.rkt @@ -9,6 +9,24 @@ (define-struct base-vectorof (elem immutable)) +(define-for-syntax (convert-args args this-one) + (let loop ([args args] + [new-args null]) + (cond + [(null? args) (reverse new-args)] + [(keyword? (syntax-e (car args))) + (if (null? (cdr args)) + (reverse (cons (car args) new-args)) + (loop (cddr args) + (list* (cadr args) (car args) new-args)))] + [else + (loop (cdr args) + (cons (syntax-property + (car args) + 'racket/contract:positive-position + this-one) + new-args))]))) + (define (vectorof-name c) (let ([immutable (base-vectorof-immutable c)]) (apply build-compound-type-name 'vectorof @@ -111,29 +129,11 @@ (vector (gensym 'ctc) (list #'x) null))] [(vecof arg ...) (let ([args (syntax->list #'(arg ...))] - [this-one (gensym 'ctc)]) - (define (convert-args args) - (let loop ([args args] - [new-args null]) - (cond - [(null? args) (reverse new-args)] - [(keyword? (syntax-e (car args))) - (if (null? (cdr args)) - (reverse (cons (car args) new-args)) - (loop (cddr args) - (list* (cadr args) (car args) new-args)))] - [else - (append (reverse new-args) - (cons (syntax-property - (car args) - 'racket/contract:positive-position - this-one) - (cdr args)))]))) - (with-syntax ([(new-arg ...) (convert-args args)] - [app (datum->syntax stx '#%app)]) + [this-one (gensym 'vectorof-ctc)]) + (with-syntax ([(new-arg ...) (convert-args args this-one)]) (syntax-property (syntax/loc stx - (app vectorof new-arg ...)) + (vectorof new-arg ...)) 'racket/contract:contract (vector this-one (list #'vecof) null))))])) @@ -265,29 +265,11 @@ (vector (gensym 'ctc) (list #'x) null))] [(vec/c arg ...) (let ([args (syntax->list #'(arg ...))] - [this-one (gensym 'ctc)]) - (define (convert-args args) - (let loop ([args args] - [new-args null]) - (cond - [(null? args) (reverse new-args)] - [(keyword? (syntax-e (car args))) - (if (null? (cdr args)) - (reverse (cons (car args) new-args)) - (loop (cddr args) - (list* (cadr args) (car args) new-args)))] - [else - (loop (cdr args) - (cons (syntax-property - (car args) - 'racket/contract:positive-position - this-one) - new-args))]))) - (with-syntax ([(new-arg ...) (convert-args args)] - [app (datum->syntax stx '#%app)]) + [this-one (gensym 'vector/c-ctc)]) + (with-syntax ([(new-arg ...) (convert-args args this-one)]) (syntax-property (syntax/loc stx - (app vector/c new-arg ...)) + (vector/c new-arg ...)) 'racket/contract:contract (vector this-one (list #'vec/c) null))))])) diff --git a/collects/racket/draw.rkt b/collects/racket/draw.rkt index db3c9f1ff3..03abf81407 100644 --- a/collects/racket/draw.rkt +++ b/collects/racket/draw.rkt @@ -27,6 +27,7 @@ dc<%> bitmap-dc% post-script-dc% + pdf-dc% ps-setup% current-ps-setup get-face-list get-family-builtin-face diff --git a/collects/racket/draw/draw-sig.rkt b/collects/racket/draw/draw-sig.rkt new file mode 100644 index 0000000000..0d29b7c2a0 --- /dev/null +++ b/collects/racket/draw/draw-sig.rkt @@ -0,0 +1,32 @@ +#lang racket/signature + +bitmap% +bitmap-dc% +brush% +brush-list% +color% +color-database<%> +current-ps-setup +dc<%> +dc-path% +font% +font-list% +font-name-directory<%> +get-face-list +get-family-builtin-face +gl-config% +gl-context<%> +make-bitmap +make-monochrome-bitmap +pdf-dc% +pen% +pen-list% +point% +post-script-dc% +ps-setup% +region% +the-brush-list +the-color-database +the-font-list +the-font-name-directory +the-pen-list diff --git a/collects/racket/draw/draw-unit.rkt b/collects/racket/draw/draw-unit.rkt new file mode 100644 index 0000000000..84c8f76393 --- /dev/null +++ b/collects/racket/draw/draw-unit.rkt @@ -0,0 +1,8 @@ +#lang racket/base +(require racket/unit + racket/draw + "draw-sig.rkt") + +(provide draw@) +(define-unit-from-context draw@ draw^) + diff --git a/collects/racket/draw/private/bitmap-dc.rkt b/collects/racket/draw/private/bitmap-dc.rkt index 2758407159..b5b1159ccc 100644 --- a/collects/racket/draw/private/bitmap-dc.rkt +++ b/collects/racket/draw/private/bitmap-dc.rkt @@ -82,7 +82,10 @@ (inherit draw-bitmap-section internal-set-bitmap internal-get-bitmap - get-size) + get-size + get-transformation + set-transformation + scale) (super-new) @@ -131,13 +134,21 @@ (def/public (draw-bitmap-section-smooth [bitmap% src] [real? dest-x] [real? dest-y] + [nonnegative-real? dest-w] + [nonnegative-real? dest-h] [real? src-x] [real? src-y] - [real? src-w] - [real? src-h] + [nonnegative-real? src-w] + [nonnegative-real? src-h] [(symbol-in solid opaque xor) [style 'solid]] [(make-or-false color%) [color black]] [(make-or-false bitmap%) [mask #f]]) - (draw-bitmap-section src dest-x dest-y src-x src-y src-w src-h style color mask)))) + (let ([sx (if (zero? src-w) 1.0 (/ dest-w src-w))] + [sy (if (zero? src-h) 1.0 (/ dest-h src-h))]) + (let ([t (get-transformation)]) + (scale sx sy) + (begin0 + (draw-bitmap-section src (/ dest-x sx) (/ dest-y sy) src-x src-y src-w src-h style color mask) + (set-transformation t))))))) (install-bitmap-dc-class! bitmap-dc%) diff --git a/collects/racket/draw/private/bitmap.rkt b/collects/racket/draw/private/bitmap.rkt index 81120cc4c0..13114daf0f 100644 --- a/collects/racket/draw/private/bitmap.rkt +++ b/collects/racket/draw/private/bitmap.rkt @@ -1,6 +1,7 @@ #lang scheme/base (require scheme/class scheme/unsafe/ops + file/convertible "syntax.rkt" "hold.rkt" "../unsafe/bstr.rkt" @@ -62,8 +63,19 @@ (define fx+ unsafe-fx+) (define fx* unsafe-fx*) +(define png-convertible<%> + (interface* () + ([prop:convertible + (lambda (bm format default) + (case format + [(png-bytes) + (let ([s (open-output-bytes)]) + (send bm save-file s 'png) + (get-output-bytes s))] + [else default]))]))) + (define bitmap% - (class object% + (class* object% (png-convertible<%>) ;; We support three kinds of bitmaps: ;; * Color with alpha channel; @@ -221,11 +233,11 @@ (define locked 0) (define/public (adjust-lock delta) (set! locked (+ locked delta))) - (def/public (load-bitmap [(make-alts path-string? input-port?) in] - [bitmap-file-kind-symbol? [kind 'unknown]] - [(make-or-false color%) [bg #f]] - [any? [complain-on-failure? #f]]) - (check-alternate 'load-bitmap) + (def/public (load-file [(make-alts path-string? input-port?) in] + [bitmap-file-kind-symbol? [kind 'unknown]] + [(make-or-false color%) [bg #f]] + [any? [complain-on-failure? #f]]) + (check-alternate 'load-file) (release-bitmap-storage) (set!-values (s b&w?) (do-load-bitmap in kind bg complain-on-failure?)) (set! width (if s (cairo_image_surface_get_width s) 0)) diff --git a/collects/racket/draw/private/brush.rkt b/collects/racket/draw/private/brush.rkt index d37775b201..f8c65ce1ce 100644 --- a/collects/racket/draw/private/brush.rkt +++ b/collects/racket/draw/private/brush.rkt @@ -28,24 +28,40 @@ (properties #:check-immutable check-immutable [[brush-style-symbol? style] 'solid]) - (init-rest args) - (super-new) + (init [(_color color) black] + [(_style style) 'solid] + [(_stipple stipple) #f]) - (case-args - args - [() (void)] - [([color% _color] - [brush-style-symbol? _style]) - (set! color (color->immutable-color _color)) - (set! style _style)] - [([string? _color] - [brush-style-symbol? _style]) - (set! color (send the-color-database find-color _color)) - (set! style _style)] - (init-name 'brush%)) + (set! color + (cond + [(string? _color) (or (send the-color-database find-color _color) black)] + [(color . is-a? . color%) + (color->immutable-color _color)] + [else + (raise-type-error (init-name 'brush%) + "string or color%" + _color)])) + + (set! style + (if (brush-style-symbol? _style) + _style + (raise-type-error (init-name 'brush%) + "brush style symbol" + _style))) (define immutable? #f) (define lock-count 0) + (define stipple #f) + + (when _stipple + (unless (_stipple . is-a? . bitmap%) + (raise-type-error (init-name 'brush%) + "bitmap% or #f" + _stipple)) + (set-stipple _stipple)) + + (super-new) + (define/public (set-immutable) (set! immutable? #t)) (define/public (is-immutable?) (or immutable? (positive? lock-count))) (define/public (adjust-lock v) (set! lock-count (+ lock-count v))) @@ -71,7 +87,6 @@ (define/public (get-color) color) - (define stipple #f) (def/public (get-stipple) stipple) (def/public (set-stipple [(make-or-false bitmap%) s]) (check-immutable 'set-stipple) @@ -95,7 +110,8 @@ (values (color->immutable-color _color) _style)] [([string? _color] [brush-style-symbol? _style]) - (values (send the-color-database find-color _color) + (values (or (send the-color-database find-color _color) + black) _style)] (method-name 'find-or-create-brush 'brush-list%))]) (let ([key (vector (send col red) (send col green) (send col blue) diff --git a/collects/racket/draw/private/dc.rkt b/collects/racket/draw/private/dc.rkt index 9a33b84cd9..b93569de81 100644 --- a/collects/racket/draw/private/dc.rkt +++ b/collects/racket/draw/private/dc.rkt @@ -36,15 +36,20 @@ (define 2pi (* 2 pi)) +(define black (send the-color-database find-color "black")) + (define (copy-color c) - (if (send c is-immutable?) - c - (let ([c (make-object color% - (color-red c) - (color-green c) - (color-blue c))]) - (send c set-immutable) - c))) + (if (string? c) + (or (send the-color-database find-color c) + black) + (if (send c is-immutable?) + c + (let ([c (make-object color% + (color-red c) + (color-green c) + (color-blue c))]) + (send c set-immutable) + c)))) (define -bitmap-dc% #f) (define (install-bitmap-dc-class! v) (set! -bitmap-dc% v)) @@ -59,9 +64,6 @@ (real? (vector-ref v 4)) (real? (vector-ref v 5)))) -(define substitute-fonts? (memq (system-type) '(macosx))) -(define substitute-mapping (make-hasheq)) - ;; dc-backend : interface ;; ;; This is the interface that the backend specific code must implement @@ -268,7 +270,6 @@ (define contexts (make-vector (vector-length font-maps) #f)) (define desc-layoutss (make-vector (vector-length font-maps) #f)) - (define black (send the-color-database find-color "black")) (define pen (send the-pen-list find-or-create-pen "black" 1 'solid)) (define brush (send the-brush-list find-or-create-brush "white" 'solid)) (define font (send the-font-list find-or-create-font 12 'default)) @@ -554,11 +555,11 @@ (define/private (brush-draws?) (not (eq? (send brush get-style) 'transparent))) - (def/public (set-text-foreground [color% c]) + (def/public (set-text-foreground [(make-alts color% string?) c]) (set! text-fg (copy-color c))) - (def/public (set-text-background [color% c]) + (def/public (set-text-background [(make-alts color% string?) c]) (set! text-bg (copy-color c))) - (def/public (set-background [color% c]) + (def/public (set-background [(make-alts color% string?) c]) (set! pen-stipple-s #f) (set! brush-stipple-s #f) (set! bg (copy-color c))) @@ -1381,43 +1382,6 @@ (vector-set! vec 3 #f) (vector-set! vec 4 #f))))) - (define/private (install-alternate-face ch layout font desc attrs context) - (or - (for/or ([face (in-list - (let ([v (hash-ref substitute-mapping (char->integer ch) #f)]) - (cond - [(string? v) - ;; found previously - (list v)] - [v - ;; failed to find previously - null] - [else - ;; Hack: prefer Lucida Grande - (cons "Lucida Grande" (get-face-list))])))]) - (let ([desc (get-pango (make-object font% - (send font get-point-size) - face - (send font get-family) - (send font get-style) - (send font get-weight) - (send font get-underlined) - (send font get-smoothing) - (send font get-size-in-pixels)))]) - (and desc - (let ([attrs (send font get-pango-attrs)]) - (pango_layout_set_font_description layout desc) - (when attrs (pango_layout_set_attributes layout attrs)) - (and (zero? (pango_layout_get_unknown_glyphs_count layout)) - (begin - (hash-set! substitute-mapping (char->integer ch) face) - #t)))))) - (begin - (hash-set! substitute-mapping (char->integer ch) #t) - ;; put old desc & attrs back - (pango_layout_set_font_description layout desc) - (when attrs (pango_layout_set_attributes layout attrs))))) - (def/public (get-char-width) 10.0) @@ -1450,8 +1414,8 @@ [real? dest-y] [real? src-x] [real? src-y] - [real? src-w] - [real? src-h] + [nonnegative-real? src-w] + [nonnegative-real? src-h] [(symbol-in solid opaque xor) [style 'solid]] [(make-or-false color%) [color black]] [(make-or-false bitmap%) [mask #f]]) @@ -1590,7 +1554,8 @@ (stamp-pattern src a-src-x a-src-y)]) (when clip-mask (cairo_restore cr)) - (flush-cr)))) + (flush-cr))) + #t) (define/private (bitmap-to-b&w-bitmap src src-x src-y src-w src-h style color mask) (let* ([bm-w (inexact->exact (ceiling src-w))] diff --git a/collects/racket/draw/private/font.rkt b/collects/racket/draw/private/font.rkt index 0a5264486d..c295b0f7f0 100644 --- a/collects/racket/draw/private/font.rkt +++ b/collects/racket/draw/private/font.rkt @@ -4,6 +4,7 @@ ffi/unsafe/atomic "syntax.ss" "../unsafe/pango.ss" + "../unsafe/cairo.ss" "font-syms.ss" "font-dir.ss" "local.ss") @@ -12,7 +13,9 @@ font-list% the-font-list family-symbol? style-symbol? weight-symbol? smoothing-symbol? get-pango-attrs - get-face-list) + get-face-list + (protect-out substitute-fonts? + install-alternate-face)) (define-local-member-name get-pango-attrs) @@ -37,6 +40,65 @@ (define-syntax-rule (atomically e) (begin (start-atomic) (begin0 e (end-atomic)))) +(define substitute-fonts? (memq (system-type) '(macosx))) +(define substitute-mapping (make-hasheq)) + +(define (install-alternate-face ch layout font desc attrs context) + (or + (for/or ([face (in-list + (let ([v (hash-ref substitute-mapping (char->integer ch) #f)]) + (cond + [(string? v) + ;; found previously + (list v)] + [v + ;; failed to find previously + null] + [else + ;; Hack: prefer Lucida Grande + (cons "Lucida Grande" (get-face-list))])))]) + (let ([desc (send (make-object font% + (send font get-point-size) + face + (send font get-family) + (send font get-style) + (send font get-weight) + (send font get-underlined) + (send font get-smoothing) + (send font get-size-in-pixels)) + get-pango)]) + (and desc + (let ([attrs (send font get-pango-attrs)]) + (pango_layout_set_font_description layout desc) + (when attrs (pango_layout_set_attributes layout attrs)) + (and (zero? (pango_layout_get_unknown_glyphs_count layout)) + (begin + (hash-set! substitute-mapping (char->integer ch) face) + #t)))))) + (begin + (hash-set! substitute-mapping (char->integer ch) #t) + ;; put old desc & attrs back + (pango_layout_set_font_description layout desc) + (when attrs (pango_layout_set_attributes layout attrs))))) + +(define (has-screen-glyph? c font desc for-label?) + (let* ([s (cairo_image_surface_create CAIRO_FORMAT_ARGB32 1 1)] + [cr (cairo_create s)] + [context (pango_cairo_create_context cr)] + [layout (pango_layout_new context)]) + (pango_layout_set_font_description layout desc) + (pango_layout_set_text layout (string c)) + (pango_cairo_update_layout cr layout) + (begin0 + (or (zero? (pango_layout_get_unknown_glyphs_count layout)) + (and substitute-fonts? + (install-alternate-face c layout font desc #f context) + (zero? (pango_layout_get_unknown_glyphs_count layout)))) + (g_object_unref layout) + (g_object_unref context) + (cairo_destroy cr) + (cairo_surface_destroy s)))) + (defclass font% object% (define table-key #f) @@ -125,8 +187,7 @@ (def/public (screen-glyph-exists? [char? c] [any? [for-label? #f]]) - ;; FIXME: - #t) + (has-screen-glyph? c this (get-pango) for-label?)) (init-rest args) (super-new) diff --git a/collects/racket/draw/private/gl-config.rkt b/collects/racket/draw/private/gl-config.rkt index 5ab3971435..7b3f080bff 100644 --- a/collects/racket/draw/private/gl-config.rkt +++ b/collects/racket/draw/private/gl-config.rkt @@ -25,7 +25,7 @@ (def/public (set-accum-size [(integer-in 0 256) s]) (set! accum-size s)) - (define depth-size 0) + (define depth-size 1) (define/public (get-depth-size) depth-size) (def/public (set-depth-size [(integer-in 0 256) s]) (set! depth-size s)) diff --git a/collects/racket/draw/private/pen.rkt b/collects/racket/draw/private/pen.rkt index bd26946a1e..745aa29d14 100644 --- a/collects/racket/draw/private/pen.rkt +++ b/collects/racket/draw/private/pen.rkt @@ -42,33 +42,58 @@ [[pen-style-symbol? style] 'solid] [[pen-width? width] 0]) - (init-rest args) - (super-new) + (init [(_color color) black] + [(_width width) 0] + [(_style style) 'solid] + [(_cap cap) 'round] + [(_join join) 'round] + [(_stipple stipple) #f]) - (case-args - args - [() (void)] - [([color% _color] - [pen-width? _width] - [pen-style-symbol? _style] - [pen-cap-symbol? [_cap 'round]] - [pen-join-symbol? [_join 'round]]) - (set! color (color->immutable-color _color)) - (set! width _width) - (set! style _style) - (set! cap _cap) - (set! join _join)] - [([string? _color] - [pen-width? _width] - [pen-style-symbol? _style] - [pen-cap-symbol? [_cap 'round]] - [pen-join-symbol? [_join 'round]]) - (set! color (send the-color-database find-color _color)) - (set! width _width) - (set! style _style) - (set! cap _cap) - (set! join _join)] - (init-name 'pen%)) + (set! color + (cond + [(string? _color) (or (send the-color-database find-color _color) black)] + [(color . is-a? . color%) + (color->immutable-color _color)] + [else + (raise-type-error (init-name 'pen%) + "string or color%" + _color)])) + (set! width + (if (pen-width? _width) + _width + (raise-type-error (init-name 'pen%) + "real in [0, 255]" + _width))) + + (set! style + (if (pen-style-symbol? _style) + _style + (raise-type-error (init-name 'pen%) + "pen style symbol" + _style))) + + (set! cap + (if (pen-cap-symbol? _cap) + _cap + (raise-type-error (init-name 'pen%) + "pen cap symbol" + _cap))) + + (set! join + (if (pen-join-symbol? _join) + _join + (raise-type-error (init-name 'pen%) + "pen join symbol" + _join))) + + (when _stipple + (unless (_stipple . is-a? . bitmap%) + (raise-type-error (init-name 'pen%) + "bitmap% or #f" + _stipple)) + (set-stipple _stipple)) + + (super-new) (define immutable? #f) (define lock-count 0) @@ -78,7 +103,7 @@ (define/private (check-immutable s) (when (or immutable? (positive? lock-count)) - (error (method-name 'brush% s) "object is ~a" + (error (method-name 'pen% s) "object is ~a" (if immutable? "immutable" "locked")))) (define/public (set-color . args) @@ -128,7 +153,8 @@ [pen-style-symbol? _style] [pen-cap-symbol? [_cap 'round]] [pen-join-symbol? [_join 'round]]) - (values (send the-color-database find-color _color) + (values (or (send the-color-database find-color _color) + black) _width _style _cap _join)] (method-name 'find-or-create-pen 'pen-list%))]) (let ([key (vector (send col red) (send col green) (send col blue) diff --git a/collects/racket/draw/private/post-script-dc.rkt b/collects/racket/draw/private/post-script-dc.rkt index 287466a7c8..8d1257ee6c 100644 --- a/collects/racket/draw/private/post-script-dc.rkt +++ b/collects/racket/draw/private/post-script-dc.rkt @@ -14,16 +14,33 @@ "local.ss" "ps-setup.ss") -(provide post-script-dc%) +(provide post-script-dc% + pdf-dc%) -(define dc-backend% +(define (make-dc-backend pdf?) (class default-dc-backend% (init [interactive #t] [parent #f] [use-paper-bbox #f] - [as-eps #t]) + [as-eps #t] + [(init-w width) #f] + [(init-h height) #f] + [output #f]) - (define-values (s port-box width height landscape?) + (let ([get-name (lambda () + (init-name (if pdf? 'pdf-dc% 'post-script-dc%)))]) + (unless (or (not init-w) + (and (real? init-w) (not (negative? init-w)))) + (raise-type-error (get-name) "nonnegative real or #f" init-w)) + (unless (or (not init-h) + (and (real? init-h) (not (negative? init-h)))) + (raise-type-error (get-name) "nonnegative real or #f" init-h)) + (unless (or (not output) + (path-string? output) + (output-port? output)) + (raise-type-error (get-name) "path string, output port, or #f" output))) + + (define-values (s port-box close-port? width height landscape?) (let ([su (if interactive ((gui-dynamic-require 'get-ps-setup-from-user) #f parent) (current-ps-setup))]) @@ -35,57 +52,80 @@ [to-file? (eq? (send pss get-mode) 'file)] [get-file (lambda (fn) ((gui-dynamic-require 'put-file) - "Save PostScript As" + (if pdf? + "Save PDF As" + "Save PostScript As") parent (and fn (path-only fn)) (and fn (file-name-from-path fn)) - "ps"))] + (if pdf? "pdf" "ps")))] [fn (if to-file? - (if interactive - (get-file (send pss get-file)) - (let ([fn (send pss get-file)]) - (or fn (get-file #f)))) + (or output + (if interactive + (get-file (send pss get-file)) + (let ([fn (send pss get-file)]) + (or fn (get-file #f))))) #f)]) (if (and to-file? (not fn)) - (values #f #f #f #f #f) + (values #f #f #f #f #f #f) (let* ([paper (assoc (send pss get-paper-name) paper-sizes)] - [w (cadr paper)] - [h (caddr paper)] + [w (if (or (not init-w) use-paper-bbox) + (cadr paper) + init-w)] + [h (if (or (not init-h) use-paper-bbox) + (caddr paper) + init-h)] [landscape? (eq? (send pss get-orientation) 'landscape)] - [file (open-output-file - (or fn (make-temporary-file "draw~a.ps")) - #:exists 'truncate/replace)] + [file (if (output-port? fn) + fn + (open-output-file + (or fn (make-temporary-file (if pdf? + "draw~a.pdf" + "draw~a.ps"))) + #:exists 'truncate/replace))] [port-box (make-immobile file)]) - (values - (cairo_ps_surface_create_for_stream write_port_bytes - port-box - w - h) - port-box ; needs to be accessible as long as `s' - w - h - landscape?))))] + (let-values ([(w h) (if (and pdf? landscape?) + (values h w) + (values w h))]) + (values + ((if pdf? + cairo_pdf_surface_create_for_stream + cairo_ps_surface_create_for_stream) + write_port_bytes + port-box + w + h) + port-box ; needs to be accessible as long as `s' + (not (output-port? fn)) + w + h + landscape?)))))] [else - (values #f #f #f #f)]))) + (values #f #f #f #f #f #f)]))) (define-values (margin-x margin-y) - (let ([xb (box 0)] [yb (box 0.0)]) - (send (current-ps-setup) get-margin xb yb) - (values (unbox xb) (unbox yb)))) + (if as-eps + (values 0.0 0.0) + (let ([xb (box 0)] [yb (box 0.0)]) + (send (current-ps-setup) get-margin xb yb) + (values (unbox xb) (unbox yb))))) (define-values (scale-x scale-y) (let ([xb (box 0)] [yb (box 0.0)]) (send (current-ps-setup) get-scaling xb yb) (values (unbox xb) (unbox yb)))) (define-values (trans-x trans-y) - (let ([xb (box 0)] [yb (box 0.0)]) - (send (current-ps-setup) get-translation xb yb) - (values (unbox xb) (unbox yb)))) + (if as-eps + (values 0.0 0.0) + (let ([xb (box 0)] [yb (box 0.0)]) + (send (current-ps-setup) get-translation xb yb) + (values (unbox xb) (unbox yb))))) - (when (and s as-eps) - (cairo_ps_surface_set_eps s #t)) - (when (and s landscape?) - (cairo_ps_surface_dsc_comment s "%%Orientation: Landscape")) + (unless pdf? + (when (and s as-eps) + (cairo_ps_surface_set_eps s #t)) + (when (and s landscape?) + (cairo_ps_surface_dsc_comment s "%%Orientation: Landscape"))) (define c (and s (cairo_create s))) @@ -98,7 +138,7 @@ (def/override (get-size) (let ([w (exact->inexact (/ (- width margin-x margin-x) scale-x))] [h (exact->inexact (/ (- height margin-y margin-y) scale-y))]) - (if landscape? + (if (and (not pdf?) landscape?) (values h w) (values w h)))) @@ -107,12 +147,13 @@ (cairo_destroy c) (set! c #f) (set! s #f) - (close-output-port (ptr-ref port-box _racket)) + (when close-port? + (close-output-port (ptr-ref port-box _racket))) (set! port-box #f)) (define/override (init-cr-matrix c) (cairo_translate c trans-x trans-y) - (if landscape? + (if (and landscape? (not pdf?)) (begin (cairo_translate c 0 height) (cairo_rotate c (/ pi -2)) @@ -138,7 +179,10 @@ (super-new))) -(define post-script-dc% (dc-mixin dc-backend%)) +(define post-script-dc% (class (dc-mixin (make-dc-backend #f)) + (super-new))) +(define pdf-dc% (class (dc-mixin (make-dc-backend #t)) + (super-new))) (define (write-port-bytes port-box bytes len) (write-bytes (scheme_make_sized_byte_string bytes len 0) diff --git a/collects/racket/draw/private/syntax.rkt b/collects/racket/draw/private/syntax.rkt index b4cc868a66..53a8de40c0 100644 --- a/collects/racket/draw/private/syntax.rkt +++ b/collects/racket/draw/private/syntax.rkt @@ -226,7 +226,7 @@ (define-syntax (do-properties stx) (syntax-case stx () - [(_ define-base check-immutable [[type id] expr] ...) + [(_ define-base check-immutable [[type id] expr ...] ...) (let ([ids (syntax->list #'(id ...))]) (with-syntax ([(getter ...) (map (lambda (id) @@ -243,7 +243,7 @@ id)) ids)]) #'(begin - (define-base id expr) ... + (define-base id expr ...) ... (define/public (getter) id) ... (def/public (setter [type v]) (check-immutable 'setter) (set! id (coerce type v))) ...)))])) @@ -271,9 +271,15 @@ (do-properties define-init check-immutable . props)] [(_ . props) (do-properties define-init void . props)])) -(define-syntax-rule (define-init id val) (begin - (init [(internal id) val]) - (define id internal))) +(define-syntax define-init + (syntax-rules () + [(_ id val) (begin + (init [(internal id) val]) + (define id internal))] + [(_ id) (begin + (init [(internal id)]) + (define id internal))])) + (define (->long i) (cond diff --git a/collects/racket/draw/unsafe/cairo.rkt b/collects/racket/draw/unsafe/cairo.rkt index 78712b5b97..21d8956b08 100644 --- a/collects/racket/draw/unsafe/cairo.rkt +++ b/collects/racket/draw/unsafe/cairo.rkt @@ -201,6 +201,10 @@ ;; allocation. (_fun _fpointer _pointer _double* _double* -> _cairo_surface_t) #:wrap (allocator cairo_surface_destroy)) +(define-cairo cairo_pdf_surface_create_for_stream + ;; As above: + (_fun _fpointer _pointer _double* _double* -> _cairo_surface_t) + #:wrap (allocator cairo_surface_destroy)) (define/provide _cairo_write_func_t (_fun _pointer _pointer _uint -> _int)) (define-cairo cairo_ps_surface_set_eps (_fun _cairo_surface_t _bool -> _void) #:fail (lambda () diff --git a/collects/racket/draw/unsafe/glib.rkt b/collects/racket/draw/unsafe/glib.rkt new file mode 100644 index 0000000000..2b3ae40af4 --- /dev/null +++ b/collects/racket/draw/unsafe/glib.rkt @@ -0,0 +1,30 @@ +#lang scheme/base +(require ffi/unsafe + ffi/unsafe/define + "../private/libs.rkt") + +(provide (protect-out + define-glib + define-gmodule + define-gobj)) + +(define-runtime-lib glib-lib + [(unix) (ffi-lib "libglib-2.0" '("0"))] + [(macosx) (ffi-lib "libglib-2.0.0")] + [(windows) (ffi-lib "libglib-2.0-0.dll")]) + +(define-runtime-lib gmodule-lib + [(unix) (ffi-lib "libgmodule-2.0" '("0"))] + [(macosx) + (ffi-lib "libgmodule-2.0.0.dylib")] + [(windows) + (ffi-lib "libgmodule-2.0-0.dll")]) + +(define-runtime-lib gobj-lib + [(unix) (ffi-lib "libgobject-2.0" '("0"))] + [(macosx) (ffi-lib "libgobject-2.0.0")] + [(windows) (ffi-lib "libgobject-2.0-0.dll")]) + +(define-ffi-definer define-glib glib-lib) +(define-ffi-definer define-gmodule gmodule-lib) +(define-ffi-definer define-gobj gobj-lib) diff --git a/collects/racket/draw/unsafe/pango.rkt b/collects/racket/draw/unsafe/pango.rkt index 7475f5fcc1..3101f1290e 100644 --- a/collects/racket/draw/unsafe/pango.rkt +++ b/collects/racket/draw/unsafe/pango.rkt @@ -4,6 +4,7 @@ ffi/unsafe/alloc ffi/unsafe/atomic setup/dirs + "glib.rkt" "cairo.rkt" "../private/utils.rkt" "../private/libs.rkt") @@ -11,15 +12,9 @@ (define-runtime-lib pango-lib [(unix) (ffi-lib "libpango-1.0" '("0"))] [(macosx) - (ffi-lib "libglib-2.0.0.dylib") - (ffi-lib "libgmodule-2.0.0.dylib") - (ffi-lib "libgobject-2.0.0.dylib") (ffi-lib "libintl.8.dylib") (ffi-lib "libpango-1.0.0.dylib")] [(windows) - (ffi-lib "libglib-2.0-0.dll") - (ffi-lib "libgmodule-2.0-0.dll") - (ffi-lib "libgobject-2.0-0.dll") (ffi-lib "libpango-1.0-0.dll")]) (define-runtime-lib pangowin32-lib @@ -40,26 +35,12 @@ (ffi-lib "libpangoft2-1.0-0.dll") (ffi-lib "libpangocairo-1.0-0.dll")]) -(define-runtime-lib glib-lib - [(unix) (ffi-lib "libglib-2.0" '("0"))] - [(macosx) (ffi-lib "libglib-2.0.0")] - [(windows) (ffi-lib "libglib-2.0-0.dll")]) - -(define-runtime-lib gobj-lib - [(unix) (ffi-lib "libgobject-2.0" '("0"))] - [(macosx) (ffi-lib "libgobject-2.0.0")] - [(windows) (ffi-lib "libgobject-2.0-0.dll")]) - (define-ffi-definer define-pango pango-lib #:provide provide) (define-ffi-definer define-pangocairo pangocairo-lib #:provide provide) (define-ffi-definer define-pangowin32 pangowin32-lib #:provide provide) -(define-ffi-definer define-glib glib-lib - #:provide provide) -(define-ffi-definer define-gobj gobj-lib - #:provide provide) (define PangoContext (_cpointer 'PangoContext)) (define PangoLayout (_cpointer 'PangoLayout)) @@ -124,7 +105,7 @@ [glyphs _PangoGlyphString-pointer])) (provide (struct-out PangoGlyphItem)) - +(provide g_object_unref g_free) (define-gobj g_object_unref (_fun _pointer -> _void) #:wrap (deallocator)) (define-glib g_free (_fun _pointer -> _void) @@ -230,7 +211,7 @@ -> (begin0 (for/list ([i (in-range len)]) (ptr-ref fams PangoFontFamily i)) - (free fams)))) + (g_free fams)))) (define-pango pango_font_description_free (_fun PangoFontDescription -> _void) #:wrap (deallocator)) diff --git a/collects/racket/list.rkt b/collects/racket/list.rkt index 657bec147f..50b7155986 100644 --- a/collects/racket/list.rkt +++ b/collects/racket/list.rkt @@ -30,7 +30,8 @@ ;; convenience append-map - filter-not) + filter-not + shuffle) (define (first x) (if (and (pair? x) (list? x)) @@ -327,6 +328,8 @@ (reverse result) (loop (cdr l) (if (f (car l)) result (cons (car l) result)))))) +(define (shuffle l) + (sort l < #:key (lambda (_) (random)) #:cache-keys? #t)) ;; mk-min : (number number -> boolean) symbol (X -> real) (listof X) -> X (define (mk-min cmp name f xs) diff --git a/collects/racket/private/class-internal.rkt b/collects/racket/private/class-internal.rkt index 01142d85e6..86c4c3dacd 100644 --- a/collects/racket/private/class-internal.rkt +++ b/collects/racket/private/class-internal.rkt @@ -6,6 +6,7 @@ (only-in racket/contract/private/arrow making-a-method) racket/list racket/stxparam + racket/unsafe/ops "class-events.rkt" "serialize-structs.rkt" "define-struct.rkt" @@ -196,28 +197,43 @@ orig))) ;;-------------------------------------------------------------------- -;; object wrapper for contracts +;; field info creation/access ;;-------------------------------------------------------------------- -(define-values (wrapper-object? wrapper-object-wrapped set-wrapper-object-wrapped! struct:wrapper-object) - (let-values ([(struct:wrapper-object make-wrapper-object wrapper-object? ref set!) - (make-struct-type 'raw-wrapper-object - #f - 1 - 0)]) - (values wrapper-object? - (lambda (v) (ref v 0)) - (lambda (o v) (set! o 0 v)) - struct:wrapper-object))) +;; A field-info is a (vector iref iset eref eset) +;; where +;; iref, iset, eref, and eset are projections to be applied +;; on internal and external access and mutation. -(define-values (prop:unwrap object-unwrapper) - (let-values ([(prop:unwrap pred acc) (make-struct-type-property 'prop:unwrap)]) - (values prop:unwrap acc))) +;; make-field-info creates a new field-info for a field. +;; The caller gives the class and relative position (in the +;; new object struct layer), and this function fills +;; in the projections. +(define (make-field-info cls rpos) + (let ([field-ref (make-struct-field-accessor (class-field-ref cls) rpos)] + [field-set! (make-struct-field-mutator (class-field-set! cls) rpos)]) + (vector field-ref field-set! field-ref field-set!))) -(define (unwrap-object o) - (if (wrapper-object? o) - (wrapper-object-wrapped o) - o)) +(define (field-info-extend-internal fi ppos pneg) + (let* ([old-ref (unsafe-vector-ref fi 0)] + [old-set! (unsafe-vector-ref fi 1)]) + (vector (λ (o) (ppos (old-ref o))) + (λ (o v) (old-set! o (pneg v))) + (unsafe-vector-ref fi 2) + (unsafe-vector-ref fi 3)))) + +(define (field-info-extend-external fi ppos pneg) + (let* ([old-ref (unsafe-vector-ref fi 2)] + [old-set! (unsafe-vector-ref fi 3)]) + (vector (unsafe-vector-ref fi 0) + (unsafe-vector-ref fi 1) + (λ (o) (ppos (old-ref o))) + (λ (o v) (old-set! o (pneg v)))))) + +(define (field-info-internal-ref fi) (unsafe-vector-ref fi 0)) +(define (field-info-internal-set! fi) (unsafe-vector-ref fi 1)) +(define (field-info-external-ref fi) (unsafe-vector-ref fi 2)) +(define (field-info-external-set! fi) (unsafe-vector-ref fi 3)) ;;-------------------------------------------------------------------- ;; class macros @@ -1190,22 +1206,18 @@ (make-field-map trace-flag (quote-syntax the-finder) (quote the-obj) - (quote-syntax unwrap-object) (quote-syntax inherit-field-name) (quote-syntax inherit-field-name-localized) (quote-syntax inherit-field-accessor) - (quote-syntax inherit-field-mutator) - '()) + (quote-syntax inherit-field-mutator)) ... (make-field-map trace-flag (quote-syntax the-finder) (quote the-obj) - (quote-syntax unwrap-object) (quote-syntax local-field) (quote-syntax local-field-localized) (quote-syntax local-field-accessor) - (quote-syntax local-field-mutator) - '()) + (quote-syntax local-field-mutator)) ... (make-rename-super-map (quote-syntax the-finder) (quote the-obj) @@ -1356,13 +1368,19 @@ ;; Methods (when given needed super-methods, etc.): #, ;; Attach srcloc (useful for profiling) (quasisyntax/loc stx - (lambda (local-field-accessor ... - local-field-mutator ... + (lambda (local-accessor + local-mutator inherit-field-accessor ... ; inherit inherit-field-mutator ... rename-super-temp ... rename-super-extra-temp ... rename-inner-temp ... rename-inner-extra-temp ... method-accessor ...) ; for a local call that needs a dynamic lookup + (let ([local-field-accessor + (make-struct-field-accessor local-accessor local-field-pos #f)] + ... + [local-field-mutator + (make-struct-field-mutator local-mutator local-field-pos #f)] + ...) (syntax-parameterize ([this-param (make-this-map (quote-syntax this-id) (quote-syntax the-finder) @@ -1484,7 +1502,7 @@ (quote-syntax plain-init-name-localized))] ...) ([(local-plain-init-name) undefined] ...) (void) ; in case the body is empty - . exprs)))))))))))) + . exprs))))))))))))) ;; Not primitive: #f)))))))))))))))) @@ -1803,14 +1821,9 @@ field-width ; total number of fields field-pub-width ; total number of public fields - field-ht ; maps public field names to vector positions + field-ht ; maps public field names to field-infos (see make-field-info above) field-ids ; list of public field names - int-field-refs ; vector of accessors for internal field access - int-field-sets ; vector of mutators for internal field access - ext-field-refs ; vector of accessors for external field access - ext-field-sets ; vector of mutators for internal field access - [struct:object ; structure type for instances #:mutable] [object? ; predicate @@ -1960,25 +1973,22 @@ ;; Put new ids in table, with pos (replace field pos with accessor info later) (unless no-new-methods? - (let loop ([ids public-names][p (class-method-width super)]) - (unless (null? ids) - (when (hash-ref method-ht (car ids) #f) - (obj-error 'class* "superclass ~e already contains method: ~a~a" - super - (car ids) - (for-class name))) - (hash-set! method-ht (car ids) p) - (loop (cdr ids) (add1 p))))) + (for ([id (in-list public-names)] + [p (in-naturals (class-method-width super))]) + (when (hash-ref method-ht id #f) + (obj-error 'class* "superclass ~e already contains method: ~a~a" + super + id + (for-class name))) + (hash-set! method-ht id p))) + ;; Keep check here for early failure, will add to hashtable later in this function. (unless no-new-fields? - (let loop ([ids public-field-names][p (class-field-pub-width super)]) - (unless (null? ids) - (when (hash-ref field-ht (car ids) #f) + (for ([id (in-list public-field-names)]) + (when (hash-ref field-ht id #f) (obj-error 'class* "superclass ~e already contains field: ~a~a" super - (car ids) - (for-class name))) - (hash-set! field-ht (car ids) p) - (loop (cdr ids) (add1 p))))) + id + (for-class name))))) ;; Check that superclass has expected fields (for-each (lambda (id) @@ -2090,18 +2100,6 @@ [meth-flags (if no-method-changes? (class-meth-flags super) (make-vector method-width))] - [int-field-refs (if no-new-fields? - (class-int-field-refs super) - (make-vector field-pub-width))] - [int-field-sets (if no-new-fields? - (class-int-field-sets super) - (make-vector field-pub-width))] - [ext-field-refs (if no-new-fields? - (class-ext-field-refs super) - (make-vector field-pub-width))] - [ext-field-sets (if no-new-fields? - (class-ext-field-sets super) - (make-vector field-pub-width))] [c (class-make name (add1 (class-pos super)) (list->vector (append (vector->list (class-supers super)) (list #f))) @@ -2112,7 +2110,6 @@ methods super-methods int-methods beta-methods meth-flags inner-projs dynamic-idxs dynamic-projs field-width field-pub-width field-ht field-names - int-field-refs int-field-sets ext-field-refs ext-field-sets 'struct:object 'object? 'make-object 'field-ref 'field-set! init-args init-mode @@ -2139,7 +2136,6 @@ (if make-struct:prim (make-struct:prim c prop:object preparer dispatcher - prop:unwrap values (get-properties interfaces)) (values #f #f #f))] [(struct:object object-make object? object-field-ref object-field-set!) @@ -2154,8 +2150,7 @@ num-fields undefined ;; Map object property to class: (append - (list (cons prop:object c) - (cons prop:unwrap values)) + (list (cons prop:object c)) (if deserialize-id (list (cons prop:serializable @@ -2180,34 +2175,17 @@ (set-class-field-ref! c object-field-ref) (set-class-field-set!! c object-field-set!)) - (unless no-new-fields? - (vector-copy! int-field-refs 0 (class-int-field-refs super)) - (vector-copy! int-field-sets 0 (class-int-field-sets super)) - (vector-copy! ext-field-refs 0 (class-ext-field-refs super)) - (vector-copy! ext-field-sets 0 (class-ext-field-sets super)) - ;; For public fields, set both the internal and external accessors/mutators. - (for ([n (in-range (class-field-pub-width super) field-pub-width)] - [i (in-naturals)] - [id (in-list public-field-names)]) - (vector-set! int-field-refs n (make-struct-field-accessor object-field-ref i #f)) - (vector-set! int-field-sets n (make-struct-field-mutator object-field-set! i #f)) - (vector-set! ext-field-refs n (make-struct-field-accessor object-field-ref i id)) - (vector-set! ext-field-sets n (make-struct-field-mutator object-field-set! i id)))) - ;; --- Build field accessors and mutators --- ;; Use public field names to name the accessors and mutators - (let-values ([(local-accessors local-mutators) - (values (for/list ([n (in-range num-fields)]) - (make-struct-field-accessor object-field-ref n #f)) - (for/list ([n (in-range num-fields)]) - (make-struct-field-mutator object-field-set! n #f)))] - [(inh-accessors inh-mutators) - (values (map (lambda (id) - (vector-ref int-field-refs (hash-ref field-ht id))) - inherit-field-names) - (map (lambda (id) - (vector-ref int-field-sets (hash-ref field-ht id))) - inherit-field-names))]) + (let-values ([(inh-accessors inh-mutators) + (for/lists (accs muts) ([id (in-list inherit-field-names)]) + (let ([fi (hash-ref field-ht id)]) + (values (field-info-internal-ref fi) (field-info-internal-set! fi))))]) + ;; Add class/index pairs for public fields. + (unless no-new-fields? + (for ([id (in-list public-field-names)] + [i (in-naturals)]) + (hash-set! field-ht id (make-field-info c i)))) ;; -- Extract superclass methods and make rename-inners --- (let ([rename-supers (map (lambda (index mname) @@ -2302,10 +2280,8 @@ ;; -- Get new methods and initializers -- (let-values ([(new-methods override-methods augride-methods init) - (apply make-methods - (append local-accessors - local-mutators - inh-accessors + (apply make-methods object-field-ref object-field-set! + (append inh-accessors inh-mutators rename-supers rename-inners @@ -2326,9 +2302,9 @@ (vector-set! super-methods index method) (vector-set! int-methods index (vector method)) (vector-set! beta-methods index (vector)) - (vector-set! inner-projs index values) + (vector-set! inner-projs index identity) (vector-set! dynamic-idxs index 0) - (vector-set! dynamic-projs index (vector values))) + (vector-set! dynamic-projs index (vector identity))) (append new-augonly-indices new-final-indices new-normal-indices) new-methods) ;; Override old methods: @@ -2382,7 +2358,7 @@ (let ([v (list->vector (append (vector->list (vector-ref beta-methods index)) (list #f)))]) ;; Since this starts a new part of the chain, reset the projection. - (vector-set! inner-projs index values) + (vector-set! inner-projs index identity) (vector-set! beta-methods index v)))) augonly-names) ;; Mark final methods: @@ -2495,7 +2471,7 @@ (make-struct-type 'props struct-type 0 0 #f props #f)]) struct:)))) -(define-values (prop:object object? object-ref) (make-struct-type-property 'object)) +(define-values (prop:object object? object-ref) (make-struct-type-property 'object 'can-impersonate)) ;;-------------------------------------------------------------------- ;; class/c @@ -2515,426 +2491,387 @@ (define-syntax-rule (->dm . stx) (syntax-parameterize ([making-a-method #'this-param]) (->d . stx))) -(define (class/c-check-first-order ctc cls blame) - (let/ec return - (define (failed str . args) - (if blame - (apply raise-blame-error blame cls str args) - (return #f))) - (unless (class? cls) - (failed "not a class")) - (let ([method-ht (class-method-ht cls)] - [beta-methods (class-beta-methods cls)] - [meth-flags (class-meth-flags cls)]) - (for ([m (class/c-methods ctc)]) - (unless (hash-ref method-ht m #f) - (failed "no public method ~a" m))) - (for ([m (class/c-inherits ctc)]) - (unless (hash-ref method-ht m #f) - (failed "no public method ~a" m))) - (for ([m (class/c-overrides ctc)]) - (let ([index (hash-ref method-ht m #f)]) - (unless index - (failed "no public method ~a" m)) - (let ([vec (vector-ref beta-methods index)]) - (unless (zero? (vector-length vec)) - (failed "method ~a was previously augmentable" m))) - (let ([flag (vector-ref meth-flags index)]) - (when (eq? flag 'final) - (failed "method ~a is final" m))))) - (for ([m (class/c-augments ctc)]) - (let ([index (hash-ref method-ht m #f)]) - (unless index - (failed "no public method ~a" m)) - (let* ([vec (vector-ref beta-methods index)]) - (when (zero? (vector-length vec)) - (failed "method ~a has never been augmentable" m)) - (when (vector-ref vec (sub1 (vector-length vec))) - (failed "method ~a is currently overrideable, not augmentable" m))))) - (for ([m (class/c-augrides ctc)]) - (let ([index (hash-ref method-ht m #f)]) - (unless index - (failed "no public method ~a" m)) - (let ([vec (vector-ref beta-methods index)]) - (when (zero? (vector-length vec)) - (failed "method ~a has never been augmentable" m)) - (unless (vector-ref vec (sub1 (vector-length vec))) - (failed "method ~a is currently augmentable, not overrideable" m))))) - (for ([s (class/c-supers ctc)]) - (let ([index (hash-ref method-ht s #f)]) - (unless index - (failed "no public method ~a" s)) - (let ([flag (vector-ref meth-flags index)]) - (when (eq? flag 'final) - (failed "method ~a is final" s)) - (when (eq? flag 'augmentable) - (failed "method ~a is augmentable, not overrideable" s))))) - (for ([i (class/c-inners ctc)]) - (let ([index (hash-ref method-ht i #f)]) - (unless index - (failed "no public method ~a" i)) - (let ([vec (vector-ref beta-methods index)]) - (when (zero? (vector-length vec)) - (failed "method ~a has never been augmentable" i))) - (let ([flag (vector-ref meth-flags index)]) - (when (eq? flag 'final) - (failed "method ~a is final" i))))) - (let ([field-ht (class-field-ht cls)]) - (for ([f (class/c-fields ctc)]) - (unless (hash-ref field-ht f #f) - (failed "no public field ~a" f))) - (for ([f (class/c-inherit-fields ctc)]) - (unless (hash-ref field-ht f #f) - (failed "no public field ~a" f))))) - #t)) +(define (class/c-check-first-order ctc cls fail) + (unless (class? cls) + (fail "not a class")) + (let ([method-ht (class-method-ht cls)] + [beta-methods (class-beta-methods cls)] + [meth-flags (class-meth-flags cls)]) + (for ([m (class/c-methods ctc)]) + (unless (hash-ref method-ht m #f) + (fail "no public method ~a" m))) + (for ([m (class/c-inherits ctc)]) + (unless (hash-ref method-ht m #f) + (fail "no public method ~a" m))) + (for ([m (class/c-overrides ctc)]) + (let ([index (hash-ref method-ht m #f)]) + (unless index + (fail "no public method ~a" m)) + (let ([vec (vector-ref beta-methods index)]) + (unless (zero? (vector-length vec)) + (fail "method ~a was previously augmentable" m))) + (let ([flag (vector-ref meth-flags index)]) + (when (eq? flag 'final) + (fail "method ~a is final" m))))) + (for ([m (class/c-augments ctc)]) + (let ([index (hash-ref method-ht m #f)]) + (unless index + (fail "no public method ~a" m)) + (let* ([vec (vector-ref beta-methods index)]) + (when (zero? (vector-length vec)) + (fail "method ~a has never been augmentable" m)) + (when (vector-ref vec (sub1 (vector-length vec))) + (fail "method ~a is currently overrideable, not augmentable" m))))) + (for ([m (class/c-augrides ctc)]) + (let ([index (hash-ref method-ht m #f)]) + (unless index + (fail "no public method ~a" m)) + (let ([vec (vector-ref beta-methods index)]) + (when (zero? (vector-length vec)) + (fail "method ~a has never been augmentable" m)) + (unless (vector-ref vec (sub1 (vector-length vec))) + (fail "method ~a is currently augmentable, not overrideable" m))))) + (for ([s (class/c-supers ctc)]) + (let ([index (hash-ref method-ht s #f)]) + (unless index + (fail "no public method ~a" s)) + (let ([flag (vector-ref meth-flags index)]) + (when (eq? flag 'final) + (fail "method ~a is final" s)) + (when (eq? flag 'augmentable) + (fail "method ~a is augmentable, not overrideable" s))))) + (for ([i (class/c-inners ctc)]) + (let ([index (hash-ref method-ht i #f)]) + (unless index + (fail "no public method ~a" i)) + (let ([vec (vector-ref beta-methods index)]) + (when (zero? (vector-length vec)) + (fail "method ~a has never been augmentable" i))) + (let ([flag (vector-ref meth-flags index)]) + (when (eq? flag 'final) + (fail "method ~a is final" i))))) + (let ([field-ht (class-field-ht cls)]) + (for ([f (class/c-fields ctc)]) + (unless (hash-ref field-ht f #f) + (fail "no public field ~a" f))) + (for ([f (class/c-inherit-fields ctc)]) + (unless (hash-ref field-ht f #f) + (fail "no public field ~a" f))))) + #t) (define (class/c-proj ctc) (λ (blame) - (λ (cls) - (class/c-check-first-order ctc cls blame) - (let* ([name (class-name cls)] - [never-wrapped? (eq? (class-orig-cls cls) cls)] - ;; Only add a new slot if we're not projecting an already contracted class. - [supers (if never-wrapped? - (list->vector (append (vector->list (class-supers cls)) - (list #f))) - (list->vector (vector->list (class-supers cls))))] - [pos (if never-wrapped? - (add1 (class-pos cls)) - (class-pos cls))] - [method-width (class-method-width cls)] - [method-ht (class-method-ht cls)] - [dynamic-features - (append (class/c-overrides ctc) - (class/c-augments ctc) - (class/c-augrides ctc) - (class/c-inherits ctc))] - [dynamic-contracts - (append (class/c-override-contracts ctc) - (class/c-augment-contracts ctc) - (class/c-augride-contracts ctc) - (class/c-inherit-contracts ctc))] - [methods (if (null? (class/c-methods ctc)) - (class-methods cls) - (make-vector method-width))] - [super-methods (if (null? (class/c-supers ctc)) - (class-super-methods cls) + (let ([bswap (blame-swap blame)]) + (λ (cls) + (class/c-check-first-order ctc cls (λ args (apply raise-blame-error blame cls args))) + (let* ([name (class-name cls)] + [never-wrapped? (eq? (class-orig-cls cls) cls)] + ;; Only add a new slot if we're not projecting an already contracted class. + [supers (if never-wrapped? + (list->vector (append (vector->list (class-supers cls)) + (list #f))) + (list->vector (vector->list (class-supers cls))))] + [pos (if never-wrapped? + (add1 (class-pos cls)) + (class-pos cls))] + [method-width (class-method-width cls)] + [method-ht (class-method-ht cls)] + [dynamic-features + (append (class/c-overrides ctc) + (class/c-augments ctc) + (class/c-augrides ctc) + (class/c-inherits ctc))] + [dynamic-contracts + (append (class/c-override-contracts ctc) + (class/c-augment-contracts ctc) + (class/c-augride-contracts ctc) + (class/c-inherit-contracts ctc))] + [methods (if (null? (class/c-methods ctc)) + (class-methods cls) + (make-vector method-width))] + [super-methods (if (null? (class/c-supers ctc)) + (class-super-methods cls) + (make-vector method-width))] + [int-methods (if (null? dynamic-features) + (class-int-methods cls) (make-vector method-width))] - [int-methods (if (null? dynamic-features) - (class-int-methods cls) - (make-vector method-width))] - [inner-projs (if (null? (class/c-inners ctc)) - (class-inner-projs cls) - (make-vector method-width))] - [dynamic-idxs (if (null? dynamic-features) - (class-dynamic-idxs cls) - (make-vector method-width))] - [dynamic-projs (if (null? dynamic-features) - (class-dynamic-projs cls) + [inner-projs (if (null? (class/c-inners ctc)) + (class-inner-projs cls) (make-vector method-width))] - [field-pub-width (class-field-pub-width cls)] - [field-ht (class-field-ht cls)] - [int-field-refs (if (null? (class/c-inherit-fields ctc)) - (class-int-field-refs cls) - (make-vector field-pub-width))] - [int-field-sets (if (null? (class/c-inherit-fields ctc)) - (class-int-field-sets cls) - (make-vector field-pub-width))] - [ext-field-refs (if (null? (class/c-fields ctc)) - (class-ext-field-refs cls) - (make-vector field-pub-width))] - [ext-field-sets (if (null? (class/c-fields ctc)) - (class-ext-field-sets cls) - (make-vector field-pub-width))] - [init (class-init cls)] - [class-make (if name - (make-naming-constructor - struct:class - (string->symbol (format "class:~a" name))) - make-class)] - [c (class-make name - pos - supers - (class-self-interface cls) - void ;; No inspecting - - method-width - method-ht - (class-method-ids cls) - - methods - super-methods - int-methods - (class-beta-methods cls) - (class-meth-flags cls) - - inner-projs - dynamic-idxs - dynamic-projs - - (class-field-width cls) - field-pub-width - field-ht - (class-field-ids cls) - - int-field-refs - int-field-sets - ext-field-refs - ext-field-sets - - 'struct:object 'object? 'make-object - 'field-ref 'field-set! - - ;; class/c introduced subclasses do not consume init args - null - 'normal - #f - - (class-orig-cls cls) - #f #f ; serializer is never set - #f)] - [obj-name (if name - (string->symbol (format "object:~a" name)) - 'object)]) - (define (make-method proc meth-name) - (procedure-rename - (procedure->method proc) - (string->symbol - (format "~a method~a~a" - meth-name - (if name " in " "") - (or name ""))))) - - (vector-set! supers pos c) - - ;; --- Make the new object struct --- - (let-values ([(struct:object object-make object? object-field-ref object-field-set!) - (make-struct-type obj-name - (class-struct:object cls) - 0 ;; No init fields - 0 ;; No new fields in this class replacement - undefined - ;; Map object property to class: - (list (cons prop:object c) - (cons prop:unwrap values)))]) - (set-class-struct:object! c struct:object) - (set-class-object?! c object?) - (set-class-make-object! c object-make) - (set-class-field-ref! c object-field-ref) - (set-class-field-set!! c object-field-set!)) - - ;; Handle public method contracts - (unless (null? (class/c-methods ctc)) - ;; First, fill in from old methods - (vector-copy! methods 0 (class-methods cls)) - ;; Now apply projections - (for ([m (in-list (class/c-methods ctc))] - [c (in-list (class/c-method-contracts ctc))]) - (when c - (let ([i (hash-ref method-ht m)] - [p ((contract-projection c) blame)]) - (vector-set! methods i (make-method (p (vector-ref methods i)) m)))))) - - ;; Handle super contracts - (unless (null? (class/c-supers ctc)) - ;; First, fill in from old (possibly contracted) super methods - (vector-copy! super-methods 0 (class-super-methods cls)) - ;; Now apply projections. - (for ([m (in-list (class/c-supers ctc))] - [c (in-list (class/c-super-contracts ctc))]) - (when c - (let ([i (hash-ref method-ht m)] - [p ((contract-projection c) blame)]) - (vector-set! super-methods i (make-method (p (vector-ref super-methods i)) m)))))) - - ;; Add inner projections - (unless (null? (class/c-inners ctc)) - (vector-copy! inner-projs 0 (class-inner-projs cls)) - (let ([b (blame-swap blame)]) + [dynamic-idxs (if (null? dynamic-features) + (class-dynamic-idxs cls) + (make-vector method-width))] + [dynamic-projs (if (null? dynamic-features) + (class-dynamic-projs cls) + (make-vector method-width))] + [field-pub-width (class-field-pub-width cls)] + [no-field-ctcs? (and (null? (class/c-fields ctc)) + (null? (class/c-inherit-fields ctc)))] + [field-ht (if no-field-ctcs? + (class-field-ht cls) + (hash-copy (class-field-ht cls)))] + [init (class-init cls)] + [class-make (if name + (make-naming-constructor + struct:class + (string->symbol (format "class:~a" name))) + make-class)] + [c (class-make name + pos + supers + (class-self-interface cls) + void ;; No inspecting + + method-width + method-ht + (class-method-ids cls) + + methods + super-methods + int-methods + (class-beta-methods cls) + (class-meth-flags cls) + + inner-projs + dynamic-idxs + dynamic-projs + + (class-field-width cls) + field-pub-width + field-ht + (class-field-ids cls) + + 'struct:object 'object? 'make-object + 'field-ref 'field-set! + + ;; class/c introduced subclasses do not consume init args + null + 'normal + #f + + (class-orig-cls cls) + #f #f ; serializer is never set + #f)] + [obj-name (if name + (string->symbol (format "object:~a" name)) + 'object)]) + (define (make-method proc meth-name) + (procedure-rename + (procedure->method proc) + (string->symbol + (format "~a method~a~a" + meth-name + (if name " in " "") + (or name ""))))) + + (vector-set! supers pos c) + + ;; --- Make the new object struct --- + (let-values ([(struct:object object-make object? object-field-ref object-field-set!) + (make-struct-type obj-name + (class-struct:object cls) + 0 ;; No init fields + 0 ;; No new fields in this class replacement + undefined + ;; Map object property to class: + (list (cons prop:object c)))]) + (set-class-struct:object! c struct:object) + (set-class-object?! c object?) + (set-class-make-object! c object-make) + (set-class-field-ref! c object-field-ref) + (set-class-field-set!! c object-field-set!)) + + ;; Handle public method contracts + (unless (null? (class/c-methods ctc)) + ;; First, fill in from old methods + (vector-copy! methods 0 (class-methods cls)) + ;; Now apply projections + (for ([m (in-list (class/c-methods ctc))] + [c (in-list (class/c-method-contracts ctc))]) + (when c + (let ([i (hash-ref method-ht m)] + [p ((contract-projection c) blame)]) + (vector-set! methods i (make-method (p (vector-ref methods i)) m)))))) + + ;; Handle super contracts + (unless (null? (class/c-supers ctc)) + ;; First, fill in from old (possibly contracted) super methods + (vector-copy! super-methods 0 (class-super-methods cls)) + ;; Now apply projections. + (for ([m (in-list (class/c-supers ctc))] + [c (in-list (class/c-super-contracts ctc))]) + (when c + (let ([i (hash-ref method-ht m)] + [p ((contract-projection c) blame)]) + (vector-set! super-methods i (make-method (p (vector-ref super-methods i)) m)))))) + + ;; Add inner projections + (unless (null? (class/c-inners ctc)) + (vector-copy! inner-projs 0 (class-inner-projs cls)) (for ([m (in-list (class/c-inners ctc))] [c (in-list (class/c-inner-contracts ctc))]) (when c - (let ([i (hash-ref method-ht m)] - [p ((contract-projection c) b)]) - (vector-set! inner-projs i - (compose (vector-ref inner-projs i) p))))))) - - ;; Handle external field contracts - (unless (null? (class/c-fields ctc)) - (vector-copy! ext-field-refs 0 (class-ext-field-refs cls)) - (vector-copy! ext-field-sets 0 (class-ext-field-sets cls)) - (let ([bset (blame-swap blame)]) + (let* ([i (hash-ref method-ht m)] + [p ((contract-projection c) bswap)] + [old-proj (vector-ref inner-projs i)]) + (vector-set! inner-projs i (λ (v) (old-proj (p v)))))))) + + ;; Handle both internal and external field contracts + (unless no-field-ctcs? (for ([f (in-list (class/c-fields ctc))] [c (in-list (class/c-field-contracts ctc))]) (when c - (let* ([i (hash-ref field-ht f)] - [p-pos ((contract-projection c) blame)] - [p-neg ((contract-projection c) bset)] - [old-ref (vector-ref ext-field-refs i)] - [old-set (vector-ref ext-field-sets i)]) - (vector-set! ext-field-refs i - (λ (o) (p-pos (old-ref o)))) - (vector-set! ext-field-sets i - (λ (o v) (old-set o (p-neg v))))))))) - - ;; Handle internal field contracts - (unless (null? (class/c-inherit-fields ctc)) - (vector-copy! int-field-refs 0 (class-int-field-refs cls)) - (vector-copy! int-field-sets 0 (class-int-field-sets cls)) - (let ([bset (blame-swap blame)]) + (let ([fi (hash-ref field-ht f)] + [p-pos ((contract-projection c) blame)] + [p-neg ((contract-projection c) bswap)]) + (hash-set! field-ht f (field-info-extend-external fi p-pos p-neg))))) (for ([f (in-list (class/c-inherit-fields ctc))] [c (in-list (class/c-inherit-field-contracts ctc))]) (when c - (let* ([i (hash-ref field-ht f)] - [p-pos ((contract-projection c) blame)] - [p-neg ((contract-projection c) bset)] - [old-ref (vector-ref int-field-refs i)] - [old-set (vector-ref int-field-sets i)]) - (vector-set! int-field-refs i - (λ (o) (p-pos (old-ref o)))) - (vector-set! int-field-sets i - (λ (o v) (old-set o (p-neg v))))))))) - - ;; Now the trickiest of them all, internal dynamic dispatch. - ;; First we update any dynamic indexes, as applicable. - (let ([old-idxs (class-dynamic-idxs (class-orig-cls cls))]) - (unless (null? dynamic-features) - ;; Go ahead and do all the copies here. - (vector-copy! dynamic-projs 0 (class-dynamic-projs cls)) - (vector-copy! int-methods 0 (class-int-methods cls)) - (vector-copy! dynamic-idxs 0 (class-dynamic-idxs cls)) - (for ([m (in-list dynamic-features)] - [c (in-list dynamic-contracts)]) - (when c - (let* ([i (hash-ref method-ht m)] - [old-idx (vector-ref old-idxs i)] - [new-idx (vector-ref dynamic-idxs i)]) - ;; We need to extend all the vectors, so let's do that here. - (when (= old-idx new-idx) - (let* ([new-idx (add1 old-idx)] - [new-proj-vec (make-vector (add1 new-idx))] - [old-proj-vec (vector-ref dynamic-projs i)] - [new-int-vec (make-vector (add1 new-idx))] - [old-int-vec (vector-ref int-methods i)]) - (vector-set! dynamic-idxs i new-idx) - (vector-copy! new-proj-vec 0 old-proj-vec) - (vector-set! new-proj-vec new-idx values) - (vector-set! dynamic-projs i new-proj-vec) - (vector-copy! new-int-vec 0 old-int-vec) - ;; Just copy over the last entry here. We'll - ;; update it appropriately later. - (vector-set! new-int-vec new-idx - (vector-ref old-int-vec old-idx)) - (vector-set! int-methods i new-int-vec))))))) + (let ([fi (hash-ref field-ht f)] + [p-pos ((contract-projection c) blame)] + [p-neg ((contract-projection c) bswap)]) + (hash-set! field-ht f (field-info-extend-internal fi p-pos p-neg)))))) - ;; Now we handle updating override contracts... here we just - ;; update the projections, and not the methods (which we must - ;; do during class composition). - (unless (null? (class/c-overrides ctc)) - (for ([m (in-list (class/c-overrides ctc))] - [c (in-list (class/c-override-contracts ctc))]) - (when c - (let* ([i (hash-ref method-ht m)] - [p ((contract-projection c) (blame-swap blame))] - [old-idx (vector-ref old-idxs i)] - [proj-vec (vector-ref dynamic-projs i)]) - (vector-set! proj-vec old-idx - (compose (vector-ref proj-vec old-idx) p)))))) + ;; Now the trickiest of them all, internal dynamic dispatch. + ;; First we update any dynamic indexes, as applicable. + (let ([old-idxs (class-dynamic-idxs (class-orig-cls cls))]) + (unless (null? dynamic-features) + ;; Go ahead and do all the copies here. + (vector-copy! dynamic-projs 0 (class-dynamic-projs cls)) + (vector-copy! int-methods 0 (class-int-methods cls)) + (vector-copy! dynamic-idxs 0 (class-dynamic-idxs cls)) + (for ([m (in-list dynamic-features)] + [c (in-list dynamic-contracts)]) + (when c + (let* ([i (hash-ref method-ht m)] + [old-idx (vector-ref old-idxs i)] + [new-idx (vector-ref dynamic-idxs i)]) + ;; We need to extend all the vectors, so let's do that here. + (when (= old-idx new-idx) + (let* ([new-idx (add1 old-idx)] + [new-proj-vec (make-vector (add1 new-idx))] + [old-proj-vec (vector-ref dynamic-projs i)] + [new-int-vec (make-vector (add1 new-idx))] + [old-int-vec (vector-ref int-methods i)]) + (vector-set! dynamic-idxs i new-idx) + (vector-copy! new-proj-vec 0 old-proj-vec) + (vector-set! new-proj-vec new-idx identity) + (vector-set! dynamic-projs i new-proj-vec) + (vector-copy! new-int-vec 0 old-int-vec) + ;; Just copy over the last entry here. We'll + ;; update it appropriately later. + (vector-set! new-int-vec new-idx + (vector-ref old-int-vec old-idx)) + (vector-set! int-methods i new-int-vec))))))) + + ;; Now we handle updating override contracts... here we just + ;; update the projections, and not the methods (which we must + ;; do during class composition). + (unless (null? (class/c-overrides ctc)) + (for ([m (in-list (class/c-overrides ctc))] + [c (in-list (class/c-override-contracts ctc))]) + (when c + (let* ([i (hash-ref method-ht m)] + [p ((contract-projection c) bswap)] + [old-idx (vector-ref old-idxs i)] + [proj-vec (vector-ref dynamic-projs i)] + [old-proj (vector-ref proj-vec old-idx)]) + (vector-set! proj-vec old-idx (λ (v) (old-proj (p v)))))))) + + ;; For augment and augride contracts, we both update the projection + ;; and go ahead and apply the projection to the last slot (which will + ;; only be used by later classes). + (unless (and (null? (class/c-augments ctc)) + (null? (class/c-augrides ctc))) + (for ([m (in-list (append (class/c-augments ctc) + (class/c-augrides ctc)))] + [c (in-list (append (class/c-augment-contracts ctc) + (class/c-augride-contracts ctc)))]) + (when c + (let* ([i (hash-ref method-ht m)] + [p ((contract-projection c) blame)] + [old-idx (vector-ref old-idxs i)] + [new-idx (vector-ref dynamic-idxs i)] + [proj-vec (vector-ref dynamic-projs i)] + [int-vec (vector-ref int-methods i)] + [old-proj (vector-ref proj-vec old-idx)]) + (vector-set! proj-vec old-idx (λ (v) (p (old-proj v)))) + (vector-set! int-vec new-idx + (make-method (p (vector-ref int-vec new-idx)) m)))))) + + ;; Now (that things have been extended appropriately) we handle + ;; inherits. + (unless (null? (class/c-inherits ctc)) + (for ([m (in-list (class/c-inherits ctc))] + [c (in-list (class/c-inherit-contracts ctc))]) + (when c + (let* ([i (hash-ref method-ht m)] + [p ((contract-projection c) blame)] + [new-idx (vector-ref dynamic-idxs i)] + [int-vec (vector-ref int-methods i)]) + (vector-set! int-vec new-idx + (make-method (p (vector-ref int-vec new-idx)) m))))))) - ;; For augment and augride contracts, we both update the projection - ;; and go ahead and apply the projection to the last slot (which will - ;; only be used by later classes). - (unless (and (null? (class/c-augments ctc)) - (null? (class/c-augrides ctc))) - (for ([m (in-list (append (class/c-augments ctc) - (class/c-augrides ctc)))] - [c (in-list (append (class/c-augment-contracts ctc) - (class/c-augride-contracts ctc)))]) - (when c - (let* ([i (hash-ref method-ht m)] - [p ((contract-projection c) blame)] - [old-idx (vector-ref old-idxs i)] - [new-idx (vector-ref dynamic-idxs i)] - [proj-vec (vector-ref dynamic-projs i)] - [int-vec (vector-ref int-methods i)]) - (vector-set! proj-vec old-idx - (compose p (vector-ref proj-vec old-idx))) - (vector-set! int-vec new-idx - (make-method (p (vector-ref int-vec new-idx)) m)))))) + ;; Unlike the others, we always want to do this, even if there are no init contracts, + ;; since we still need to handle either calling the previous class/c's init or + ;; calling continue-make-super appropriately. + (let () + ;; zip the inits and contracts together for ordered selection + (define inits+contracts (map cons (class/c-inits ctc) (class/c-init-contracts ctc))) + ;; grab all the inits+contracts that involve the same init arg + ;; (assumes that inits and contracts were sorted in class/c creation) + (define (grab-same-inits lst) + (if (null? lst) + (values null null) + (let loop ([inits/c (cdr lst)] + [prefix (list (car lst))]) + (cond + [(null? inits/c) + (values (reverse prefix) inits/c)] + [(eq? (car (car inits/c)) (car (car prefix))) + (loop (cdr inits/c) + (cons (car inits/c) prefix))] + [else (values (reverse prefix) inits/c)])))) + ;; run through the list of init-args and apply contracts for same-named + ;; init args + (define (apply-contracts inits/c init-args) + (let loop ([init-args init-args] + [inits/c inits/c] + [handled-args null]) + (cond + [(null? init-args) + (reverse handled-args)] + [(null? inits/c) + (append (reverse handled-args) init-args)] + [(eq? (car (car inits/c)) (car (car init-args))) + (let ([init-arg (car init-args)] + [p ((contract-projection (cdr (car inits/c))) bswap)]) + (loop (cdr init-args) + (cdr inits/c) + (cons (cons (car init-arg) (p (cdr init-arg))) + handled-args)))] + [else (loop (cdr init-args) + inits/c + (cons (car init-args) handled-args))]))) + (set-class-init! + c + (lambda (the-obj super-go si_c si_inited? si_leftovers init-args) + (let ([init-args + (let loop ([inits/c inits+contracts] + [handled-args init-args]) + (if (null? inits/c) + handled-args + (let-values ([(prefix suffix) (grab-same-inits inits/c)]) + (loop suffix + (apply-contracts prefix init-args)))))]) + ;; Since we never consume init args, we can ignore si_leftovers + ;; since init-args is the same. + (if never-wrapped? + (super-go the-obj si_c si_inited? init-args null null) + (init the-obj super-go si_c si_inited? init-args init-args)))))) - ;; Now (that things have been extended appropriately) we handle - ;; inherits. - (unless (null? (class/c-inherits ctc)) - (for ([m (in-list (class/c-inherits ctc))] - [c (in-list (class/c-inherit-contracts ctc))]) - (when c - (let* ([i (hash-ref method-ht m)] - [p ((contract-projection c) blame)] - [new-idx (vector-ref dynamic-idxs i)] - [int-vec (vector-ref int-methods i)]) - (vector-set! int-vec new-idx - (make-method (p (vector-ref int-vec new-idx)) m))))))) - - ;; Unlike the others, we always want to do this, even if there are no init contracts, - ;; since we still need to handle either calling the previous class/c's init or - ;; calling continue-make-super appropriately. - (let () - ;; zip the inits and contracts together for ordered selection - (define inits+contracts (map cons (class/c-inits ctc) (class/c-init-contracts ctc))) - ;; grab all the inits+contracts that involve the same init arg - ;; (assumes that inits and contracts were sorted in class/c creation) - (define (grab-same-inits lst) - (if (null? lst) - (values null null) - (let loop ([inits/c (cdr lst)] - [prefix (list (car lst))]) - (cond - [(null? inits/c) - (values (reverse prefix) inits/c)] - [(eq? (car (car inits/c)) (car (car prefix))) - (loop (cdr inits/c) - (cons (car inits/c) prefix))] - [else (values (reverse prefix) inits/c)])))) - ;; run through the list of init-args and apply contracts for same-named - ;; init args - (define (apply-contracts inits/c init-args) - (let loop ([init-args init-args] - [inits/c inits/c] - [handled-args null]) - (cond - [(null? init-args) - (reverse handled-args)] - [(null? inits/c) - (append (reverse handled-args) init-args)] - [(eq? (car (car inits/c)) (car (car init-args))) - (let ([init-arg (car init-args)] - [p ((contract-projection (cdr (car inits/c))) - (blame-swap blame))]) - (loop (cdr init-args) - (cdr inits/c) - (cons (cons (car init-arg) (p (cdr init-arg))) - handled-args)))] - [else (loop (cdr init-args) - inits/c - (cons (car init-args) handled-args))]))) - (set-class-init! - c - (lambda (the-obj super-go si_c si_inited? si_leftovers init-args) - (let ([init-args - (let loop ([inits/c inits+contracts] - [handled-args init-args]) - (if (null? inits/c) - handled-args - (let-values ([(prefix suffix) (grab-same-inits inits/c)]) - (loop suffix - (apply-contracts prefix init-args)))))]) - ;; Since we never consume init args, we can ignore si_leftovers - ;; since init-args is the same. - (if never-wrapped? - (super-go the-obj si_c si_inited? init-args null null) - (init the-obj super-go si_c si_inited? init-args init-args)))))) - - c)))) + c))))) (define-struct class/c (methods method-contracts fields field-contracts inits init-contracts @@ -2982,7 +2919,8 @@ #:first-order (λ (ctc) (λ (cls) - (class/c-check-first-order ctc cls #f))))) + (let/ec ret + (class/c-check-first-order ctc cls (λ args (ret #f)))))))) (define-for-syntax (parse-class/c-specs forms object/c?) (define parsed-forms (make-hasheq)) @@ -3143,29 +3081,24 @@ augments augment-ctcs augrides augride-ctcs)))))])) -(define (check-object-contract obj blame methods fields) - (let/ec return - (define (failed str . args) - (if blame - (apply raise-blame-error blame obj str args) - (return #f))) - (unless (object? obj) - (failed "not a object")) - (let ([cls (object-ref obj)]) - (let ([method-ht (class-method-ht cls)]) - (for ([m methods]) - (unless (hash-ref method-ht m #f) - (failed "no public method ~a" m)))) - (let ([field-ht (class-field-ht cls)]) - (for ([m fields]) - (unless (hash-ref field-ht m #f) - (failed "no public field ~a" m))))))) +(define (check-object-contract obj methods fields fail) + (unless (object? obj) + (fail "not a object")) + (let ([cls (object-ref obj)]) + (let ([method-ht (class-method-ht cls)]) + (for ([m methods]) + (unless (hash-ref method-ht m #f) + (fail "no public method ~a" m)))) + (let ([field-ht (class-field-ht cls)]) + (for ([m fields]) + (unless (hash-ref field-ht m #f) + (fail "no public field ~a" m))))) + #t) (define (object/c-proj ctc) (λ (blame) (λ (obj) - (check-object-contract obj blame (object/c-methods ctc) (object/c-fields ctc)) - (make-wrapper-object obj blame + (make-wrapper-object ctc obj blame (object/c-methods ctc) (object/c-method-contracts ctc) (object/c-fields ctc) (object/c-field-contracts ctc))))) @@ -3194,7 +3127,8 @@ #:first-order (λ (ctc) (λ (obj) - (check-object-contract obj #f (object/c-methods ctc) (object/c-fields ctc)))))) + (let/ec ret + (check-object-contract obj (object/c-methods ctc) (object/c-fields ctc) (λ args (ret #f)))))))) (define-syntax (object/c stx) (syntax-case stx () @@ -3405,7 +3339,6 @@ (vector) (vector) (vector) 0 0 (make-hasheq) null - (vector) (vector) (vector) (vector) 'struct:object object? 'make-object 'field-ref-not-needed 'field-set!-not-needed @@ -3427,7 +3360,7 @@ (vector-set! (class-supers object%) 0 object%) (set-class-orig-cls! object% object%) (let*-values ([(struct:obj make-obj obj? -get -set!) - (make-struct-type 'object #f 0 0 #f (list (cons prop:object object%) (cons prop:unwrap values)) #f)]) + (make-struct-type 'object #f 0 0 #f (list (cons prop:object object%)) #f)]) (set-class-struct:object! object% struct:obj) (set-class-make-object! object% make-obj)) (set-class-object?! object% object?) ; don't use struct pred; it wouldn't work with prim classes @@ -3808,16 +3741,16 @@ name (for-class (class-name class))))))]) (values (λ (class name) - (let* ([p (check-and-get-index 'class-field-accessor class name)] - [ref (vector-ref (class-ext-field-refs class) p)]) + (let* ([fi (check-and-get-index 'class-field-accessor class name)] + [ref (field-info-external-ref fi)]) (λ (o) (if (object? o) - (ref (unwrap-object o)) + (ref o) (raise-type-error 'class-field-accessor "object" o))))) (λ (class name) - (let* ([p (check-and-get-index 'class-field-mutator class name)] - [set (vector-ref (class-ext-field-sets class) p)]) + (let* ([fi (check-and-get-index 'class-field-mutator class name)] + [setter! (field-info-external-set! fi)]) (λ (o v) (if (object? o) - (set (unwrap-object o) v) + (setter! o v) (raise-type-error 'class-field-mutator "object" o)))))))) (define-struct generic (name applicable)) @@ -3969,9 +3902,9 @@ (trace (set-event obj id val)) (let* ([cls (object-ref obj)] [field-ht (class-field-ht cls)] - [index (hash-ref field-ht id #f)]) - (if index - ((vector-ref (class-ext-field-sets cls) index) obj val) + [fi (hash-ref field-ht id #f)]) + (if fi + ((field-info-external-set! fi) obj val) (raise-mismatch-error 'get-field (format "expected an object that has a field named ~s, got " id) @@ -4005,9 +3938,9 @@ (trace (get-event obj id)) (let* ([cls (object-ref obj)] [field-ht (class-field-ht cls)] - [index (hash-ref field-ht id #f)]) - (if index - ((vector-ref (class-ext-field-refs cls) index) obj) + [fi (hash-ref field-ht id #f)]) + (if fi + ((field-info-external-ref fi) obj) (raise-mismatch-error 'get-field (format "expected an object that has a field named ~s, got " id) @@ -4145,8 +4078,8 @@ (trace (when (object? v) (inspect-event v))) (cond [(not (object? v)) #f] - [(class? c) ((class-object? (class-orig-cls c)) (unwrap-object v))] - [(interface? c) (implementation? (object-ref (unwrap-object v)) c)] + [(class? c) ((class-object? (class-orig-cls c)) v)] + [(interface? c) (implementation? (object-ref v) c)] [else (raise-type-error 'is-a? "class or interface" 1 v c)]))) (define (subclass? v c) @@ -4164,7 +4097,7 @@ (raise-type-error 'object-interface "object" o)) (trace-begin (trace (inspect-event o)) - (class-self-interface (object-ref (unwrap-object o))))) + (class-self-interface (object-ref o)))) (define-traced (object-method-arity-includes? o name cnt) (unless (object? o) @@ -4223,14 +4156,15 @@ (raise-type-error 'object-info "object" o)) (trace-begin (trace (inspect-event o)) - (let loop ([c (object-ref (unwrap-object o))] - [skipped? #f]) - (if (struct? ((class-insp-mk c))) - ;; current inspector can inspect this object - (values c skipped?) - (if (zero? (class-pos c)) - (values #f #t) - (loop (vector-ref (class-supers c) (sub1 (class-pos c))) #t)))))) + (let ([o* (if (has-original-object? o) (original-object o) o)]) + (let loop ([c (object-ref o*)] + [skipped? #f]) + (if (struct? ((class-insp-mk c))) + ;; current objec can inspect this object + (values c skipped?) + (if (zero? (class-pos c)) + (values #f #t) + (loop (vector-ref (class-supers c) (sub1 (class-pos c))) #t))))))) (define (to-sym s) (if (string? s) @@ -4263,7 +4197,7 @@ (raise-type-error 'object->vector "object" in-o)) (trace-begin (trace (inspect-event in-o)) - (let ([o (unwrap-object in-o)]) + (let ([o in-o]) (list->vector (cons (string->symbol (format "object:~a" (class-name (object-ref o)))) @@ -4290,8 +4224,9 @@ (raise-type-error 'object=? "object" o1)) (unless (object? o2) (raise-type-error 'object=? "object" o2)) - (eq? (unwrap-object o1) - (unwrap-object o2))) + (let ([orig-o1 (if (has-original-object? o1) (original-object o1) o1)] + [orig-o2 (if (has-original-object? o2) (original-object o2) o2)]) + (eq? orig-o1 orig-o2))) ;;-------------------------------------------------------------------- ;; primitive classes @@ -4392,7 +4327,7 @@ ;; wrapper for contracts ;;-------------------------------------------------------------------- -(define (make-wrapper-class obj cls blame methods method-contracts fields field-contracts) +(define (make-wrapper-class cls blame methods method-contracts fields field-contracts) (let* ([name (class-name cls)] [method-width (class-method-width cls)] [method-ht (class-method-ht cls)] @@ -4400,11 +4335,9 @@ (class-methods cls) (make-vector method-width))] [field-pub-width (class-field-pub-width cls)] - [field-ht (class-field-ht cls)] - [int-field-refs (make-vector field-pub-width)] - [int-field-sets (make-vector field-pub-width)] - [ext-field-refs (make-vector field-pub-width)] - [ext-field-sets (make-vector field-pub-width)] + [field-ht (if (null? fields) + (class-field-ht cls) + (hash-copy (class-field-ht cls)))] [class-make (if name (make-naming-constructor struct:class @@ -4435,11 +4368,6 @@ field-ht (class-field-ids cls) - int-field-refs - int-field-sets - ext-field-refs - ext-field-sets - 'struct:object 'object? 'make-object 'field-ref 'field-set! @@ -4467,13 +4395,12 @@ ;; --- Make the new object struct --- (let-values ([(struct:object object-make object? object-field-ref object-field-set!) (make-struct-type obj-name - struct:wrapper-object + (class-struct:object cls) 0 ;; No init fields - 0 ;; No new fields in this wrapped object + 0 ;; No new fields in this class replacement undefined ;; Map object property to class: - (list (cons prop:object c) - (cons prop:unwrap wrapper-object-wrapped)))]) + (list (cons prop:object c)))]) (set-class-struct:object! c struct:object) (set-class-object?! c object?) (set-class-make-object! c object-make) @@ -4492,45 +4419,30 @@ [p ((contract-projection c) blame)]) (vector-set! meths i (make-method (p (vector-ref meths i)) m)))))) - ;; Redirect internal/external field accessors/mutators to old object - (let ([old-int-refs (class-int-field-refs cls)] - [old-int-sets (class-int-field-sets cls)] - [old-ext-refs (class-ext-field-refs cls)] - [old-ext-sets (class-ext-field-sets cls)]) - (for ([n (in-range (class-field-pub-width cls))]) - (let ([int-field-ref (vector-ref old-int-refs n)] - [int-field-set (vector-ref old-int-sets n)] - [ext-field-ref (vector-ref old-ext-refs n)] - [ext-field-set (vector-ref old-ext-sets n)]) - (vector-set! int-field-refs n (λ (o) (int-field-ref obj))) - (vector-set! int-field-sets n (λ (o v) (int-field-set obj v))) - (vector-set! ext-field-refs n (λ (o) (ext-field-ref obj))) - (vector-set! ext-field-sets n (λ (o v) (ext-field-set obj v)))))) - ;; Handle external field contracts (unless (null? fields) (let ([bset (blame-swap blame)]) (for ([f (in-list fields)] [c (in-list field-contracts)]) (when c - (let* ([i (hash-ref field-ht f)] - [p-pos ((contract-projection c) blame)] - [p-neg ((contract-projection c) bset)] - [old-ref (vector-ref ext-field-refs i)] - [old-set (vector-ref ext-field-sets i)]) - (vector-set! ext-field-refs i - (λ (o) (p-pos (old-ref o)))) - (vector-set! ext-field-sets i - (λ (o v) (old-set o (p-neg v))))))))) + (let ([fi (hash-ref field-ht f)] + [p-pos ((contract-projection c) blame)] + [p-neg ((contract-projection c) bset)]) + (hash-set! field-ht f (field-info-extend-external fi p-pos p-neg))))))) c)) -;; make-wrapper-object: object (listof symbol) (listof contract?) (listof symbol) (listof contract?) -(define (make-wrapper-object obj blame methods method-contracts fields field-contracts) - (check-object-contract obj blame methods fields) - (let* ([orig-obj (unwrap-object obj)] - [new-cls (make-wrapper-class orig-obj (object-ref obj) blame methods method-contracts fields field-contracts)]) - ((class-make-object new-cls) orig-obj))) +(define-values (impersonator-prop:original-object has-original-object? original-object) + (make-impersonator-property 'impersonator-prop:original-object)) + +;; make-wrapper-object: contract object blame (listof symbol) (listof contract?) (listof symbol) (listof contract?) +(define (make-wrapper-object ctc obj blame methods method-contracts fields field-contracts) + (check-object-contract obj methods fields (λ args (apply raise-blame-error blame obj args))) + (let ([original-obj (if (has-original-object? obj) (original-object obj) obj)] + [new-cls (make-wrapper-class (object-ref obj) blame methods method-contracts fields field-contracts)]) + (impersonate-struct obj object-ref (λ (o c) new-cls) + impersonator-prop:contracted ctc + impersonator-prop:original-object original-obj))) ;;-------------------------------------------------------------------- ;; misc utils diff --git a/collects/racket/private/classidmap.rkt b/collects/racket/private/classidmap.rkt index 387400790b..f05a0cf781 100644 --- a/collects/racket/private/classidmap.rkt +++ b/collects/racket/private/classidmap.rkt @@ -60,8 +60,8 @@ [(f . args) (quasisyntax/loc stx (#,replace-stx . args))]))))) -(define (make-field-map trace-flag the-finder the-obj the-unwrapper the-binder the-binder-localized - field-accessor field-mutator field-pos/null) +(define (make-field-map trace-flag the-finder the-obj the-binder the-binder-localized + field-accessor field-mutator) (let ([set!-stx (datum->syntax the-finder 'set!)]) (mk-set!-trans the-binder-localized @@ -73,9 +73,7 @@ (with-syntax ([bindings (syntax/loc stx ([obj obj-expr] [id expr]))] [trace (syntax/loc stx (set-event obj (quote id) id))] [set (quasisyntax/loc stx - ((unsyntax field-mutator) - ((unsyntax the-unwrapper) obj) - (unsyntax-splicing field-pos/null) id))]) + ((unsyntax field-mutator) obj id))]) (if trace-flag (syntax/loc stx (let* bindings trace set)) (syntax/loc stx (let* bindings set))))] @@ -83,9 +81,7 @@ (with-syntax ([bindings (syntax/loc stx ([obj obj-expr]))] [trace (syntax/loc stx (get-event obj (quote id)))] [call (quasisyntax/loc stx - (((unsyntax field-accessor) - ((unsyntax the-unwrapper) obj) - (unsyntax-splicing field-pos/null)) . args))]) + (((unsyntax field-accessor) obj) . args))]) (if trace-flag (syntax/loc stx (let* bindings trace call)) (syntax/loc stx (let* bindings call))))] @@ -93,9 +89,7 @@ (with-syntax ([bindings (syntax/loc stx ([obj obj-expr]))] [trace (syntax/loc stx (get-event obj (quote id)))] [get (quasisyntax/loc stx - ((unsyntax field-accessor) - ((unsyntax the-unwrapper) obj) - (unsyntax-splicing field-pos/null)))]) + ((unsyntax field-accessor) obj))]) (if trace-flag (syntax/loc stx (let* bindings trace get)) (syntax/loc stx (let* bindings get))))])))))) diff --git a/collects/racket/sandbox.rkt b/collects/racket/sandbox.rkt index 0a7979de20..5cad282900 100644 --- a/collects/racket/sandbox.rkt +++ b/collects/racket/sandbox.rkt @@ -32,6 +32,7 @@ evaluator-alive? kill-evaluator break-evaluator + get-user-custodian set-eval-limits set-eval-handler put-input @@ -621,6 +622,7 @@ (define-evaluator-messenger evaluator-alive? 'alive?) (define-evaluator-messenger kill-evaluator 'kill) (define-evaluator-messenger break-evaluator 'break) +(define-evaluator-messenger get-user-custodian 'user-cust) (define-evaluator-messenger (set-eval-limits secs mb) 'limits) (define-evaluator-messenger (set-eval-handler handler) 'handler) (define-evaluator-messenger (put-input . xs) 'input) @@ -819,6 +821,7 @@ [(alive?) (and user-thread (not (thread-dead? user-thread)))] [(kill) (terminate+kill! 'evaluator-killed #f)] [(break) (user-break)] + [(user-cust) user-cust] [(limits) (set! limits (evaluator-message-args expr))] [(handler) (set! eval-handler (car (evaluator-message-args expr)))] [(input) (apply input-putter (evaluator-message-args expr))] diff --git a/collects/racket/set.rkt b/collects/racket/set.rkt index 4da3d4b8fa..db396d8b6b 100644 --- a/collects/racket/set.rkt +++ b/collects/racket/set.rkt @@ -111,6 +111,12 @@ (define set-union (case-lambda + ;; No 0 argument set exists because its not clear what type of set + ;; to return. A keyword is unsatisfactory because it may be hard to + ;; remember. A simple solution is just to provide the type of the + ;; empty set that you want, like (set-union (set)) or + ;; (set-union (set-eqv)) + ;; [() (set)] [(set) (unless (set? set) (raise-type-error 'set-union "set" 0 set)) set] diff --git a/collects/rackunit/private/check.rkt b/collects/rackunit/private/check.rkt index f4bb83db56..3a059a4987 100644 --- a/collects/rackunit/private/check.rkt +++ b/collects/rackunit/private/check.rkt @@ -171,7 +171,15 @@ (name (identifier? #'name) (syntax/loc stx - check-secret-name))))) + (case-lambda + [(formal ...) + (check-secret-name formal ... + #:location (quote loc) + #:expression (quote (name actual ...)))] + [(formal ... msg) + (check-secret-name formal ... msg + #:location (quote loc) + #:expression (quote (name actual ...)))])))))) )))))) (define-syntax define-simple-check diff --git a/collects/redex/examples/delim-cont/grammar.rkt b/collects/redex/examples/delim-cont/grammar.rkt index bfe5918dc5..671a66e516 100644 --- a/collects/redex/examples/delim-cont/grammar.rkt +++ b/collects/redex/examples/delim-cont/grammar.rkt @@ -43,7 +43,7 @@ (E W (in-hole W (dw x e E e))) ;; Evaluation context without `dw': (W M (wcm w M)) - (M hole (v ... W e ...) (begin W e) (% v W v)) + (M hole (v ... W e ...) (begin W e) (% W e e) (% v e W) (% v W v)) ;; Context ending on a dw boundary: (D hole (in-hole E (dw x e hole e)))) diff --git a/collects/redex/examples/delim-cont/meta.rkt b/collects/redex/examples/delim-cont/meta.rkt index 01b0424177..569c2ef592 100644 --- a/collects/redex/examples/delim-cont/meta.rkt +++ b/collects/redex/examples/delim-cont/meta.rkt @@ -14,7 +14,7 @@ [(subst x_1 x_2 (λ (x_3 ...) e_1)) ; shortcut; x_1 != any x_3 (λ (x_3 ...) (subst x_1 x_2 e_1))] [(subst x_1 e_1 (λ (x_2 ...) e_2)) ; x_1 != any x_2 - ,(term-let ([(x_new ...) (variables-not-in (term e_1) (term (x_2 ...)))]) + ,(term-let ([(x_new ...) (variables-not-in (term (x_1 e_1 e_2)) (term (x_2 ...)))]) (term (λ (x_new ...) (subst x_1 e_1 (subst* (x_2 ...) (x_new ...) e_2)))))] [(subst x_1 e_1 x_1) e_1] @@ -63,16 +63,21 @@ [(noPrompt v_1 (begin E_1 e_2)) (noPrompt v_1 E_1)] [(noPrompt v_1 (set! x E_1)) (noPrompt v_1 E_1)] [(noPrompt v_1 (wcm w E_1)) (noPrompt v_1 E_1)] - [(noPrompt v_1 (dw x e_0 E_1 e_1)) (noPrompt v_1 E_1)]) + [(noPrompt v_1 (dw x e_0 E_1 e_1)) (noPrompt v_1 E_1)] + [(noPrompt v_1 (% v_2 e E_1)) (noPrompt v_1 E_1)] + [(noPrompt v_1 (% E_1 e_1 e_2)) (noPrompt v_1 E_1)]) (define-metafunction grammar [(get-marks-core (in-hole hole hole) v e_2) e_2] [(get-marks-core (wcm (name w_1 ((v_4 v_5) ... (v_1 v_3) (v_6 v_7) ...)) E_1) v_1 e_2) (get-marks E_1 v_1 (cons v_3 e_2))] - [(get-marks-core (wcm w_1 E_1) v_1 e_2) (get-marks E_1 v_1 e_2) (side-condition (term (notInDom (v_1 w_1))))] + [(get-marks-core (wcm w_1 E_1) v_1 e_2) (get-marks E_1 v_1 e_2) (side-condition (term (notInDom v_1 w_1)))] [(get-marks-core (v ... E_1 e ...) v_1 e_2) (get-marks E_1 v_1 e_2)] + [(get-marks-core (if E_1 e_1 e_3) v_1 e_2) (get-marks E_1 v_1 e_2)] [(get-marks-core (begin E_1 e) v_1 e_2) (get-marks E_1 v_1 e_2)] [(get-marks-core (% v_2 E_1 v_3) v_1 e_2) (get-marks E_1 v_1 e_2)] - [(get-marks-core (dw x e E_1 e) v_1 e_2) (get-marks E_1 v_1 e_2)]) + [(get-marks-core (% v_2 e_1 E_1) v_1 e_2) (get-marks E_1 v_1 e_2)] + [(get-marks-core (% E_1 e_1 e_3) v_1 e_2) (get-marks E_1 v_1 e_2)] + [(get-marks-core (dw x e_1 E_1 e_3) v_1 e_2) (get-marks E_1 v_1 e_2)]) (define-metafunction grammar [(get-marks (if E_1 e e) v_1 e_2) (get-marks E_1 v_1 e_2)] diff --git a/collects/redex/examples/delim-cont/model-impl.rkt b/collects/redex/examples/delim-cont/model-impl.rkt new file mode 100644 index 0000000000..8118d7668b --- /dev/null +++ b/collects/redex/examples/delim-cont/model-impl.rkt @@ -0,0 +1,76 @@ +#lang racket + +(provide % abort call/comp call/cm current-marks + (rename-out [_call/cc call/cc] + [_if if] + [_+ +] + [_print print] + [_cons cons] + [_set! set!] + [_zero? zero?])) + +(define tag + (let ([tags (make-hash)]) + (λ (v) + (hash-ref tags v + (λ () + (let ([t (make-continuation-prompt-tag)]) + (hash-set! tags v t) + t)))))) + +(define-syntax-rule (% tag-val expr handler) + (call-with-continuation-prompt + (λ () expr) + (let ([v tag-val]) + (if (let comparable? ([v v]) + (cond [(procedure? v) #f] + [(list? v) (andmap comparable? v)] + [else #t])) + (tag v) + (raise-type-error '% "non-procedure" v))) + (let ([h handler]) + (λ (x) (h x))))) + +(define (abort tag-val result) + (abort-current-continuation (tag tag-val) result)) + +(define ((force-unary f) x) (f x)) + +(define (_call/cc proc tag-val) + (call/cc (compose proc force-unary) (tag tag-val))) + +(define (call/comp proc tag-val) + (call-with-composable-continuation (compose proc force-unary) (tag tag-val))) + +(define (call/cm key val thunk) + (with-continuation-mark key val (thunk))) + +(define (current-marks key tag-val) + (continuation-mark-set->list + (current-continuation-marks (tag tag-val)) + key)) + +(define-syntax-rule (_if e1 e2 e3) + (let ([v1 e1]) + (case v1 + [(#t) e2] + [(#f) e3] + [else (raise-type-error 'if "#t or #f" v1)]))) + +(define (_+ x y) (+ x y)) + +(define (_print n) + (if (number? n) + (begin (print n) #f) + (raise-type-error 'print "number" n))) + +(define (_cons x xs) + (if (list? xs) + (cons x xs) + (raise-type-error 'cons "list?" 1 x xs))) + +(define-syntax-rule (_set! x e) + (begin (set! x e) #f)) + +(define (_zero? x) + (equal? 0 x)) \ No newline at end of file diff --git a/collects/redex/examples/delim-cont/randomized-tests-test.rkt b/collects/redex/examples/delim-cont/randomized-tests-test.rkt new file mode 100644 index 0000000000..54c6193087 --- /dev/null +++ b/collects/redex/examples/delim-cont/randomized-tests-test.rkt @@ -0,0 +1,145 @@ +#lang racket + +(require "randomized-tests.rkt" + "reduce.rkt" + "grammar.rkt" + rackunit + (except-in redex/reduction-semantics plug)) + +(define-syntax (test-transformation stx) + (syntax-case stx () + [(_ program expected-output expected-result) + #`(match-let ([(answer actual-output actual-result) + (model-eval (transform-intermediate (term program)))]) + (begin + #,(syntax/loc #'expected-output + (check-equal? actual-output expected-output)) + #,(syntax/loc #'expected-result + (check-equal? actual-result 'expected-result))))])) + +(test-transformation + (<> () + () + (% 0 + (wcm () + ((λ (k) + (begin (k 7) (print 1))) + (cont 0 hole))) + (λ (x) x))) + "" 7) + +(test-transformation + (<> () + () + (cont 1 (begin hole (print 3)))) + "" procedure) + +(test-transformation + (<> () + () + (% 0 + (print + (wcm () + ((λ (k) (begin (k 1) 2)) + (comp (print hole))))) + (λ (x) x))) + "12" #f) + +(test-transformation + (<> () + (1) + (% 1 + (dw + x_1 + (print 1) + (wcm () + ((λ (k) (k 3)) + (cont 1 (dw x_1 (print 1) hole (print 2))))) + (print 2)) + (λ (x) x))) + "12" 3) + +(test-transformation + (<> () + (1) + (% 0 + ((% 0 + (dw + x_1 + (print 1) + (wcm () + ((λ (k) k) + (cont 0 (dw x_1 (print 1) hole (print 2))))) + (print 2)) + (λ (x) x)) + 3) + (λ (x) x))) + "1212" 3) + +(test-transformation + (<> () [] + (% 0 + (wcm ([1 2] [3 4]) + ((λ (x) x) + (wcm ([1 5] [3 6]) + (cons (current-marks 1 0) + (cons (current-marks 3 0) + (list)))))) + (λ (x) x))) + "" ((5 2) (6 4))) + +(test-transformation + (<> + () + () + (dw + ra + (print 1) + (print 2) + (print 3))) + "23" #f) + +(test-transformation + (<> () + () + (% + 1 + (dw x_1 + (print 1) + (abort 1 (cont 1 (dw x_1 (print 1) hole (print 3)))) + (print 3)) + (λ (k) (% 1 (k 4) (λ (x) x))))) + "313" 4) + +(test-transformation + (<> + () + () + ((comp + (dw + ra + (print 1) + hole + (dw q (print 2) (print 3) (print 4)))) + 5)) + "134" 5) + +(define (transformation-preserves-meaning? p) + (let ([original-result (parameterize ([model-eval-steps 1000]) (model-eval p))] + [transformed (transform-intermediate p)] + [warn (λ () (eprintf "Long test:\n") (pretty-write p (current-error-port)))] + [threshold (* 60 2)]) + (or (timeout? original-result) + (let ([transformed-result + (timeout-warn threshold (model-eval transformed) (warn))]) + (if (answer? original-result) + (equal? original-result transformed-result) + (not (answer? transformed-result)))) + ; filters bad tests + (bad-test? (timeout-warn threshold (impl-eval (impl-program transformed)) (warn)))))) + +(define-syntax-rule (test-transformation/randomized . kw-args) + (let ([test-number 1]) + (redex-check grammar p (transformation-preserves-meaning? (term p)) + #:prepare fix-prog + #:source :-> . kw-args))) \ No newline at end of file diff --git a/collects/redex/examples/delim-cont/randomized-tests.rkt b/collects/redex/examples/delim-cont/randomized-tests.rkt new file mode 100644 index 0000000000..775a76e515 --- /dev/null +++ b/collects/redex/examples/delim-cont/randomized-tests.rkt @@ -0,0 +1,385 @@ +#lang racket + +(require "grammar.ss" + "reduce.rkt" + (except-in redex/reduction-semantics plug) + racket/runtime-path) + +(provide (all-defined-out)) + +(define (main [seed-arg #f]) + (define seed + (if seed-arg + (string->number seed-arg) + (add1 (random (sub1 (expt 2 31)))))) + (printf "Test seed: ~s\n" seed) + (parameterize ([current-pseudo-random-generator test-prg]) + (random-seed seed)) + (parameterize ([redex-pseudo-random-generator test-prg]) + (time (test #:attempts 3000)) + (time (test #:source :-> #:attempts 3000)))) + +(define-syntax-rule (test . kw-args) + (redex-check grammar p (same-behavior? (term p)) + #:prepare fix-prog . kw-args)) + +(define fix-prog + (match-lambda + [`(<> ,s ,_ ,e) + (match-let ([`([,xs ,vs] ...) (remove-duplicates s #:key first)]) + `(<> ,(map list xs (map (fix-expr xs) vs)) [] ,((fix-expr xs) e)))])) + +(define (fix-expr top-vars) + (compose drop-duplicate-binders + proper-wcms + consistent-dws + (curry close top-vars '()))) + +(struct error (cause) #:transparent) +(struct answer (output result) #:transparent) +(struct bad-test (reason) #:transparent) +(struct timeout ()) + +(define (same-behavior? prog) + (let ([impl-behavior (timeout-kill 15 (impl-eval (impl-program (transform-intermediate prog))))]) + (or (bad-test? impl-behavior) + (timeout? impl-behavior) + (let ([model-behavior (timeout-warn 30 (model-eval prog) (pretty-write prog))]) + (or (timeout? model-behavior) + (if (error? impl-behavior) + (error? model-behavior) + (and (answer? model-behavior) + (equal? impl-behavior model-behavior)))))))) + +(define impl-program + (match-lambda + [`(<> ,s [] ,e) + `(letrec ,s ,e)] + [e e])) + +(define-runtime-module-path model-impl "model-impl.rkt") + +(define impl-eval + (let ([ns (make-base-empty-namespace)]) + (parameterize ([current-namespace ns]) + (namespace-require 'racket) + (namespace-require (resolved-module-path-name model-impl))) + (define show + (match-lambda + [(? procedure?) 'procedure] + [(? list? vs) (map show vs)] + [v v])) + (λ (test) + (define output (open-output-string)) + (define result + (with-handlers ([exn:fail? + (λ (e) + (match (exn-message e) + [(regexp #rx"%: expected argument of type ") + (bad-test "procedure as tag")] + [_ (error e)]))]) + (parameterize ([current-output-port output]) + (eval test ns)))) + (if (or (error? result) (bad-test? result)) + result + (answer (get-output-string output) + (show result)))))) + +(define model-eval-steps (make-parameter +inf.0)) + +(define (model-eval prog) + (let/ec return + (define show + (match-lambda + [(? number? n) n] + [(? boolean? b) b] + [`(list . ,vs) (map show vs)] + [v 'procedure])) + (define (eval prog steps) + (define ns (set)) + (let recur ([p prog] [d steps] [s (set)]) + (define qs (apply-reduction-relation :-> p)) + (if (empty? qs) + (set! ns (set-add ns p)) + (if (< d 0) + (return (timeout)) + (for ([q qs]) + (if (set-member? s q) + (return (timeout)) + (recur q (sub1 d) (set-add s p))))))) + (set-map ns values)) + (match (eval prog (model-eval-steps)) + [(list (and p `(<> ,_ ,output ,result))) + (if (v? result) + (answer + (apply string-append (map (curry format "~v") output)) + (show result)) + (error p))]))) + +(define (with-timeout thunk timeout on-timeout) + (let ([c (make-channel)]) + (struct raised (value)) + (let ([t (thread + (λ () + (channel-put + c (with-handlers ([exn:fail? raised]) + (thunk)))))]) + (match (sync/timeout timeout c) + [#f (on-timeout t c)] + [(raised v) (raise v)] + [x x])))) + +(define-syntax-rule (timeout-kill time expr) + (with-timeout (λ () expr) time + (λ (t _) + (kill-thread t) + (timeout)))) +(define-syntax-rule (timeout-warn time expr warn) + (with-timeout (λ () expr) time + (λ (_ c) + warn + (sync c)))) + +(define (close top-vars loc-vars expr) + (match expr + [(? x? x) + (let ([bound (append top-vars loc-vars)]) + (cond [(memq x bound) x] + [(not (empty? bound)) + (random-member bound)] + [else (random-literal)]))] + [`(set! ,x ,e) + (if (empty? top-vars) + (close top-vars loc-vars e) + `(set! ,(random-member top-vars) + ,(close top-vars loc-vars e)))] + [`(λ ,xs ,e) + `(λ ,xs + ,(close (filter (negate (curryr member xs)) top-vars) + (append xs loc-vars) + e))] + [`(dw ,x ,e_1 ,e_2 ,e_3) + `(dw ,x + ,(close top-vars loc-vars e_1) + ,(close top-vars loc-vars e_2) + ,(close top-vars loc-vars e_3))] + ; substitution does not recur inside continuation values + ; (not sure why it bothers to recur within dw expression) + [`(cont ,v ,E) + `(cont ,(close top-vars '() v) + ,(close top-vars '() E))] + [`(cont ,E) + `(comp ,(close top-vars '() E))] + [(? list?) + (map (curry close top-vars loc-vars) expr)] + [_ expr])) + +(define drop-duplicate-binders + (match-lambda + [`(λ ,xs ,e) + `(λ ,(remove-duplicates xs) ,(drop-duplicate-binders e))] + [(? list? es) + (map drop-duplicate-binders es)] + [e e])) + +(define (consistent-dws p) + (define pre-post + (let ([h (make-hash)]) + (λ (id pre post) + (match (hash-ref h id #f) + [#f + (hash-set! h id (list pre post)) + (list pre post)] + [x x])))) + (let recur ([x p] [excluded '()]) + (match x + [`(dw ,x ,e1 ,e2 ,e3) + (if (member x excluded) + (recur e2 excluded) + (match-let ([(list e1’ e3’) (pre-post x e1 e3)]) + `(dw ,x + ,(recur e1’ (cons x excluded)) + ,(recur e2 excluded) + ,(recur e3’ (cons x excluded)))))] + [(? list?) (map (curryr recur excluded) x)] + [_ x]))) + +(define (proper-wcms e) + (let fix ([ok? #t] [e e]) + (match e + [`(wcm ,w ,e) + (if ok? + `(wcm ,(remove-duplicates (fix #t w) #:key first) + ,(fix #f e)) + (fix #f e))] + [`(list . ,vs) + `(list . ,(map (curry fix #t) vs))] + [`(λ ,xs ,e) + ; #f in case applied with a continuation that's already marked + `(λ ,xs ,(fix #f e))] + [`(cont ,v ,E) + `(cont ,(fix #t v) ,(fix #t E))] + [`(comp ,E) + `(comp ,(fix #t E))] + [`(begin ,e1 ,e2) + `(begin ,(fix #t e1) + ,(fix ok? e2))] + [`(% ,e1 ,e2 ,e3) + `(% ,(fix #t e1) ,(fix ok? e2) ,(fix #t e3))] + [`(dw ,x ,e1 ,e2 ,e3) + `(dw ,x ,(fix #t e1) ,(fix ok? e2) ,(fix #t e3))] + [`(if ,e1 ,e2 ,e3) + `(if ,(fix #t e1) + ,(fix ok? e2) + ,(fix ok? e3))] + [`(set! ,x ,e) + `(set! ,x ,(fix #t e))] + [(? list?) + (map (curry fix #t) e)] + [_ e]))) + +(define transform-intermediate + (match-lambda + [(and p `(<> ,s ,o ,e)) + (define fresh (make-fresh p)) + (define allocated (map first s)) + (define (alloc-cell prefix) + (define cell (fresh prefix)) + (set! allocated (cons cell allocated)) + cell) + (define no-dw? (alloc-cell "handlers-disabled?")) + (define dw-frame-locs + (let ([locs (make-hash)]) + (λ (x) + (hash-ref + locs x + (λ () (let ([ys (list (alloc-cell (format "~s-allocated?" x)) + (alloc-cell (format "~s-skip-pre?" x)) + (alloc-cell (format "~s-comp-cont" x)))]) + (hash-set! locs x ys) + ys)))))) + (define transform + (match-lambda + [`(wcm () ,m) + (transform m)] + [`(wcm ([,k ,v] . ,w) ,m) + `(call/cm ,(transform k) ,(transform v) + (λ () ,(transform `(wcm ,w ,m))))] + [(and e `(dw ,x ,e1 ,e2 ,e3)) + (match-let ([(list a? s? c) (dw-frame-locs x)] + [t (fresh "t")]) + `((λ (,t) + (if ,a? + (begin (if ,no-dw? #f (set! ,s? #t)) (,c ,t)) + (% 1 + (dynamic-wind + (λ () + (if ,no-dw? + #f + (if ,a? + (if ,s? (set! ,s? #f) ,(transform e1)) + #f))) + (λ () + ((call/comp + (λ (k) + (begin + (set! ,c k) + (abort 1 k))) + 1))) + (λ () + (if ,no-dw? + (set! ,a? #t) + (if ,a? + ,(transform e3) + (set! ,a? #t))))) + (λ (k) (begin (if ,no-dw? #f (set! ,s? #t)) (k ,t)))))) + (λ () ,(transform e2))))] + [`(cont ,v ,E) + (let ([x (fresh "v")]) + `(begin + (set! ,no-dw? #t) + ((λ (,x) + (% ,x + ,(transform + (term (plug ,E (call/cc (λ (k) (abort ,x k)) ,x)))) + (λ (x) (begin (set! ,no-dw? #f) x)))) + ,(transform v))))] + [`(comp ,E) + (define numbers + (match-lambda + [(? integer? n) (list n)] + [(? list? l) (append-map numbers l)] + [_ (list)])) + (define t (add1 (apply max 0 (numbers E)))) + `(begin + (set! ,no-dw? #t) + (% ,t + ,(transform + (term (plug ,E (call/comp (λ (k) (abort ,t k)) ,t)))) + (λ (x) (begin (set! ,no-dw? #f) x))))] + [`(list ,vs ...) + `(list ,@(map transform-value vs))] + [(? list? xs) + (map transform xs)] + [e e])) + (define transform-value + (match-lambda + [(and e (or `(cont ,_ ,_) `(comp ,_))) + `(λ (x) (,(transform e) x))] + [e (transform e)])) + (define e’ (transform e)) + (define s’ (map (match-lambda [(list x v) (list x (transform-value v))]) s)) + `(<> ,(map (λ (x) (match (assoc x s’) + [#f (list x #f)] + [(list _ v’) (list x v’)])) + allocated) + ,o + ,e’)])) + +;; The built-in `plug' sometimes chooses the wrong hole. +(define-metafunction grammar + [(plug hole any) any] + [(plug (in-hole W (dw x e_1 E e_2)) any) + (in-hole W (dw x e_1 (plug E any) e_2))] + [(plug (wcm w M) any) + (wcm w (plug M any))] + [(plug (v ... W e ...) any) + (v ... (plug W any) e ...)] + [(plug (begin W e) any) + (begin (plug W any) e)] + [(plug (% W e_1 e_2) any) + (% (plug W any) e_1 e_2)] + [(plug (% v e W) any) + (% v e (plug W any))] + [(plug (% v_1 W v_2) any) + (% v_1 (plug W any) v_2)] + [(plug (set! x W) any) + (set! x (plug W any))] + [(plug (if W e_1 e_2) any) + (if (plug W any) e_1 e_2)]) + +(define (make-fresh p) + (define suffix + (let recur ([x p] [s 0]) + (cond [(symbol? x) + (match (regexp-match #rx"_(.+)$" (symbol->string x)) + [(list _ n) (max s (add1 (string->number n)))] + [#f s])] + [(pair? x) (recur (cdr x) (recur (car x) s))] + [else s]))) + (λ (prefix) + (begin0 (string->symbol (format "~a_~a" prefix suffix)) + (set! suffix (add1 suffix))))) + +(define (random-literal) + (random-member + '(dynamic-wind abort current-marks cons + -inf.0 +inf.0 -1 0 1 1/3 -1/4 .33 -.25 4-3i 3+4i + call/cc call/comp call/cm + #f #t zero? print + first rest))) + +(define (random-member xs) + (parameterize ([current-pseudo-random-generator test-prg]) + (list-ref xs (random (length xs))))) + +(define test-prg (make-pseudo-random-generator)) \ No newline at end of file diff --git a/collects/redex/examples/delim-cont/reduce.rkt b/collects/redex/examples/delim-cont/reduce.rkt index 90873e0b53..ad5cf95f45 100644 --- a/collects/redex/examples/delim-cont/reduce.rkt +++ b/collects/redex/examples/delim-cont/reduce.rkt @@ -12,7 +12,7 @@ grammar ;; beta - (~~> ((λ (x_1 ...) e_1) v_1 ...) + (~~> ((λ (x_1 ..._1) e_1) v_1 ..._1) (subst* (x_1 ...) (v_1 ...) e_1) "beta") @@ -25,7 +25,7 @@ "zero?") (~~> (zero? v_1) #f - (side-condition (not (zero? (term v_1)))) + (side-condition (not (equal? 0 (term v_1)))) "non-zero") ;; lists diff --git a/collects/redex/examples/delim-cont/test.rkt b/collects/redex/examples/delim-cont/test.rkt index 7d2bad03f1..6463f314a1 100644 --- a/collects/redex/examples/delim-cont/test.rkt +++ b/collects/redex/examples/delim-cont/test.rkt @@ -35,6 +35,21 @@ ;; Basic ---------------------------------------- (define (basic-tests) + (test "(λx.e)[y←v] ≠ λy.(e[x←y][y←v])" + '(<> + ([k 4]) [] + (((λ (k1) (λ (k) k)) + (λ () k)) + 0)) + '(<> ([k 4]) [] 0)) + (test "(λx.e)[y←v] ≠ λz.(e[x←z][y←v]) if z ∈ FV(e)" + '(<> + ([k2 5]) + () + (((λ (k1) (λ (k) k2)) + (λ () k)) + 0)) + '(<> ([k2 5]) [] 5)) (test "basic dw" '(<> () [] @@ -141,6 +156,16 @@ 0) (λ (x) (+ x 1)))) '(<> () (1 3) 8)) + (test "abort tag eval" + '(<> + () [] + (% (print 1) 2 3)) + '(<> () [1] 2)) + (test "abort handler eval" + '(<> + () [] + (% 1 2 (print 3))) + '(<> () [3] 2)) (test "call/cc 2 levels dw" '(<> () @@ -314,7 +339,76 @@ '(<> () [1 2 1 2] - (λ (v) 10)))) + (λ (v) 10))) + (test "prompt enclosing prompt-tag expression" + '(<> () [] + (% 0 + (% (abort 0 1) 2 3) + (λ (x) x))) + '(<> () [] 1)) + (test "prompt enclosing prompt-handler expression" + '(<> () [] + (% 0 + (begin + (% 0 1 (abort 0 2)) + (print 3)) + (λ (x) x))) + '(<> () [] 2)) + (test "prompt-tag position in continuation-marks context" + '(<> () [] + (% 0 + (call/cm + 1 2 + (λ () + (% (abort 0 (current-marks 1 0)) + 3 + 4))) + (λ (x) x))) + '(<> () [] (list 2))) + (test "prompt-handler position in continuation-marks context" + '(<> () [] + (% 0 + (call/cm + 1 2 + (λ () + (call/cm + 1 3 + (% 0 + 4 + (abort 0 (current-marks 1 0)))))) + (λ (x) x))) + '(<> () [] (list 2))) + (test "if-test position in continuation-marks context" + '(<> () + [] + (% 0 + (call/cm + 1 2 + (λ () (if (abort 0 (current-marks 1 0)) 3 4))) + (λ (x) x))) + '(<> () [] (list 2))) + (test "dw in continuation-marks context" + '(<> () + [] + (% 0 + (call/cm 1 2 + (λ () + (dynamic-wind + (λ () #f) + (λ () (current-marks 1 0)) + (λ () #t)))) + (λ (x) x))) + '(<> () [] (list 2))) + (test "wcm without key in continuation-marks context" + '(<> () + [] + (% 0 + (wcm ([1 2]) + ((λ (x) x) + (wcm ([3 4]) + (current-marks 3 0)))) + (λ (x) x))) + '(<> () [] (list 4)))) ;; R6RS dynamic-wind ---------------------------------------- @@ -916,7 +1010,7 @@ (λ (x) x))))) hole)) 100) - (λ (x) x))))) + (λ (x1) x1))))) (test "similar way to get stuck, but using the pre thunk" '(<> ([output (list)] @@ -980,7 +1074,7 @@ hole)) 100) 0) - (λ (x) x))))) + (λ (x1) x1))))) (test "loop" '(<> ([counter (list 4 3 2 1 0)]) diff --git a/collects/redex/private/core-layout.rkt b/collects/redex/private/core-layout.rkt index 4c4767d5cf..86ef5bfd7d 100644 --- a/collects/redex/private/core-layout.rkt +++ b/collects/redex/private/core-layout.rkt @@ -812,7 +812,8 @@ (refocus (cc-superimpose (colorize (filled-rectangle (pict-width p) - (pict-height p)) + (pict-height p) + #:draw-border? #f) "pink") p) p)) diff --git a/collects/redex/private/rg.rkt b/collects/redex/private/rg.rkt index b4d636f11b..94d1812096 100644 --- a/collects/redex/private/rg.rkt +++ b/collects/redex/private/rg.rkt @@ -12,8 +12,14 @@ (for-syntax "keyword-macros.ss") mrlib/tex-table) -(define (exotic-choice? [random random]) (= 0 (random 5))) -(define (use-lang-literal? [random random]) (= 0 (random 20))) +(define redex-pseudo-random-generator + (make-parameter (current-pseudo-random-generator))) +(define (generator-random . arg) + (parameterize ([current-pseudo-random-generator (redex-pseudo-random-generator)]) + (apply random arg))) + +(define (exotic-choice? [random generator-random]) (= 0 (random 5))) +(define (use-lang-literal? [random generator-random]) (= 0 (random 20))) (define default-check-attempts 1000) @@ -21,11 +27,11 @@ (define tex-chars-threshold 1500) (define chinese-chars-threshold 2500) -(define (pick-var lang-lits attempt [random random]) +(define (pick-var lang-lits attempt [random generator-random]) (let ([length (add1 (random-natural 4/5 random))]) (string->symbol (random-string lang-lits length attempt random)))) -(define (pick-char attempt [random random]) +(define (pick-char attempt [random generator-random]) (cond [(or (< attempt ascii-chars-threshold) (not (exotic-choice? random))) (let ([i (random (add1 (- (char->integer #\z) (char->integer #\a))))] [cap? (zero? (random 2))]) @@ -39,18 +45,18 @@ [else (integer->char (+ #x4E00 (random (- #x9FCF #x4E00))))])) -(define (random-string lang-lits length attempt [random random]) +(define (random-string lang-lits length attempt [random generator-random]) (if (and (not (null? lang-lits)) (use-lang-literal? random)) (pick-from-list lang-lits random) (list->string (build-list length (λ (_) (pick-char attempt random)))))) -(define (pick-any lang sexp [random random]) +(define (pick-any lang sexp [random generator-random]) (if (and (> (dict-count (rg-lang-non-cross lang)) 0) (zero? (random 5))) (let ([nts (rg-lang-non-cross lang)]) (values lang (pick-from-list (dict-map nts (λ (nt _) nt)) random))) (values sexp 'sexp))) -(define (pick-string lang-lits attempt [random random]) +(define (pick-string lang-lits attempt [random generator-random]) (random-string lang-lits (random-natural 1/5 random) attempt random)) ;; next-non-terminal-decision selects a subset of a non-terminal's productions. @@ -58,7 +64,8 @@ ;; generator's test cases restrict the productions. (define pick-nts values) -(define (pick-from-list l [random random]) (list-ref l (random (length l)))) +(define (pick-from-list l [random generator-random]) + (list-ref l (random (length l)))) ;; Chooses a random (exact) natural number from the "shifted" geometric distribution: ;; P(random-natural = k) = p(1-p)^k @@ -66,22 +73,22 @@ ;; P(random-natural >= k) = (1-p)^(k+1) ;; E(random-natural) = (1-p)/p ;; Var(random-natural) = (1-p)/p^2 -(define (random-natural p [random random]) +(define (random-natural p [random generator-random]) (sub1 (inexact->exact (ceiling (real-part (/ (log (random)) (log (- 1 p)))))))) (define (negative? random) (zero? (random 2))) -(define (random-integer p [random random]) +(define (random-integer p [random generator-random]) (* (if (negative? random) -1 1) (random-natural p random))) -(define (random-rational p [random random]) +(define (random-rational p [random generator-random]) (/ (random-integer p random) (add1 (random-natural p random)))) -(define (random-real p [random random]) +(define (random-real p [random generator-random]) (* (random) 2 (random-integer p random))) -(define (random-complex p [random random]) +(define (random-complex p [random generator-random]) (let ([randoms (list random-integer random-rational random-real)]) (make-rectangular ((pick-from-list randoms random) p random) ((pick-from-list randoms random) p random)))) @@ -109,7 +116,7 @@ (define attempt->size (make-parameter default-attempt->size)) -(define (pick-number attempt #:top-threshold [top-threshold complex-threshold] [random random]) +(define (pick-number attempt #:top-threshold [top-threshold complex-threshold] [random generator-random]) (let loop ([threshold 0] [generator random-natural] [levels `((,integer-threshold . ,random-integer) @@ -123,13 +130,13 @@ (generator (expected-value->p ((attempt->size) (- attempt threshold))) random) (loop (caar levels) (cdar levels) (cdr levels))))) -(define (pick-natural attempt [random random]) +(define (pick-natural attempt [random generator-random]) (pick-number attempt #:top-threshold 0 random)) -(define (pick-integer attempt [random random]) +(define (pick-integer attempt [random generator-random]) (pick-number attempt #:top-threshold integer-threshold random)) -(define (pick-real attempt [random random]) +(define (pick-real attempt [random generator-random]) (pick-number attempt #:top-threshold real-threshold random)) (define (pick-sequence-length attempt) @@ -155,19 +162,19 @@ (define-values/invoke-unit (generation-decisions) (import) (export decisions^)) - (define (gen-nt lang name cross? retries size attempt in-hole) + (define (gen-nt lang name cross? retries size attempt fillers) (let*-values ([(productions) (hash-ref ((if cross? rg-lang-cross rg-lang-non-cross) lang) name)] - [(term _) + [(terms _) (let ([gen (pick-from-list (if (zero? size) (min-prods name productions ((if cross? base-cases-cross base-cases-non-cross) (rg-lang-base-cases lang))) ((next-non-terminal-decision) productions)))]) - (gen retries (max 0 (sub1 size)) attempt empty-env in-hole))]) - term)) + (gen retries (max 0 (sub1 size)) attempt empty-env fillers))]) + terms)) (define (generate/pred name gen pred init-sz init-att retries) (let ([pre-threshold-incr @@ -184,9 +191,9 @@ [attempt init-att]) (if (zero? remaining) (raise-gen-fail what (format "pattern ~a" name) retries) - (let-values ([(term env) (gen size attempt)]) - (if (pred term env) - (values term env) + (let-values ([(terms env) (gen size attempt)]) + (if (pred (unfilled-term terms) env) + (values terms env) (retry (sub1 remaining) (if (incr-size? remaining) (add1 size) size) (+ attempt @@ -198,9 +205,9 @@ (let* ([none (gensym)] [prior (hash-ref env name none)]) (if (eq? prior none) - (let-values ([(term env) (gen)]) - (values term (hash-set env name term))) - (values prior env)))) + (let-values ([(terms env) (gen)]) + (values terms (hash-set env name (unfilled-term terms)))) + (values (unfilled prior) env)))) (define (generate-sequence gen env vars length) (define (split-environment env) @@ -215,15 +222,18 @@ (hash-set env var (map (λ (seq-env) (hash-ref seq-env var)) seq-envs))) env vars)) (let-values - ([(seq envs) + ([(seqs envs) (let recur ([envs (split-environment env)]) (if (null? envs) - (values null null) + (values (unfilled null) null) (let*-values - ([(term env) (gen (car envs) the-hole)] - [(terms envs) (recur (cdr envs))]) - (values (cons term terms) (cons env envs)))))]) - (values seq (merge-environments envs)))) + ([(hds env) (gen (car envs))] + [(tls envs) (recur (cdr envs))]) + (values (combine cons hds tls) (cons env envs)))))]) + (values seqs (merge-environments envs)))) + + (define ((unfilled-generator/attempts g) r s a e f) + (values (unfilled (g a)) e)) (define (mismatches-satisfied? env) (let ([groups (make-hasheq)]) @@ -248,6 +258,17 @@ (cons (make-bind (binder-name key) val) bindings) bindings)))) + (define (combine f ts us) + (match* (ts us) + [((list t) _) + (map (λ (u) (f t u)) us)] + [(_ (list u)) + (map (λ (t) (f t u)) ts)] + [(_ _) (map f ts us)])) + + (define unfilled-term first) + (define unfilled list) + (let*-values ([(langp lits lang-bases) (prepare-lang lang)] [(sexpp _ sexp-bases) (prepare-lang sexp)] [(lit-syms) (compiled-lang-literals lang)]) @@ -256,114 +277,125 @@ (λ (pat any?) (let* ([nt? (is-nt? (if any? sexpp langp))] [mismatches? #f] - [generator ; retries size attempt env in-hole -> (values term env) + [generator + ; retries size attempt env hole-fillers -> (values terms env) + ; hole-fillers = (non-empty-listof term) + ; terms = (non-empty-listof term) + ; + ; Patterns like (in-hole C_1 p) require constructing both an unfilled context + ; (exposed via the C_1 binding) and a filled context (exposed as the result). + ; These terms can be constructed by first generating the unfilled context then + ; constructing the filled one from it, via something like `plug', but care must + ; be taken to avoid filling holes generated within `in-hole' patterns (and to + ; avoid exposing the dreaded `the-not-hole' term). Instead, generators construct + ; the filled and unfilled contexts simultaneously, taking multiple fillers as + ; input (one of which can be `hole') and producing multiple terms as output. + ; As an optimization, generators produce singleton lists when the constructed term + ; contained no fillable position. (let recur ([pat pat]) (match pat - [`number (λ (r s a e h) (values ((next-number-decision) a) e))] - [`natural (λ (r s a e h) (values ((next-natural-decision) a) e))] - [`integer (λ (r s a e h) (values ((next-integer-decision) a) e))] - [`real (λ (r s a e h) (values ((next-real-decision) a) e))] + [`number (unfilled-generator/attempts (λ (a) ((next-number-decision) a)))] + [`natural (unfilled-generator/attempts (λ (a) ((next-natural-decision) a)))] + [`integer (unfilled-generator/attempts (λ (a) ((next-integer-decision) a)))] + [`real (unfilled-generator/attempts (λ (a) ((next-real-decision) a)))] [`(variable-except ,vars ...) (let ([g (recur 'variable)]) - (λ (r s a e h) + (λ (r s a e f) (generate/pred pat - (λ (s a) (g r s a e h)) + (λ (s a) (g r s a e f)) (λ (var _) (not (memq var vars))) s a r)))] - [`variable - (λ (r s a e h) - (values ((next-variable-decision) lits a) e))] + [`variable (unfilled-generator/attempts (λ (a) ((next-variable-decision) lits a)))] [`variable-not-otherwise-mentioned (let ([g (recur 'variable)]) - (λ (r s a e h) + (λ (r s a e f) (generate/pred pat - (λ (s a) (g r s a e h)) + (λ (s a) (g r s a e f)) (λ (var _) (not (memq var lit-syms))) s a r)))] [`(variable-prefix ,prefix) (define (symbol-append prefix suffix) (string->symbol (string-append (symbol->string prefix) (symbol->string suffix)))) (let ([g (recur 'variable)]) - (λ (r s a e h) - (let-values ([(term _) (g r s a e h)]) - (values (symbol-append prefix term) e))))] - [`string - (λ (r s a e h) - (values ((next-string-decision) lits a) e))] + (λ (r s a e f) + (let-values ([(ts e) (g r s a e f)]) + (values (unfilled (symbol-append prefix (unfilled-term ts))) e))))] + [`string (unfilled-generator/attempts (λ (a) ((next-string-decision) lits a)))] [`(side-condition ,pat ,(? procedure? condition) ,guard-src-loc) (let ([g (recur pat)]) - (λ (r s a e h) + (λ (r s a e f) (generate/pred `(side-condition ,(unparse-pattern pat) ,guard-src-loc) - (λ (s a) (g r s a e h)) + (λ (s a) (g r s a e f)) (λ (_ env) (condition (bindings env))) s a r)))] [`(name ,(? symbol? id) ,p) (let ([g (recur p)]) - (λ (r s a e h) - (let-values ([(term env) (g r s a e h)]) - (values term (hash-set env (make-binder id) term)))))] - [`hole (λ (r s a e h) (values h e))] - [`(in-hole ,context ,contractum) - (let ([ctx (recur context)] - [ctm (recur contractum)]) - (λ (r s a e h) - (let-values ([(term env) (ctm r s a e h)]) - (ctx r s a env term))))] + (λ (r s a e f) + (let-values ([(ts env) (g r s a e f)]) + (values ts (hash-set env (make-binder id) (unfilled-term ts))))))] + [`hole (λ (r s a e f) (values f e))] + [`(in-hole ,context ,filler) + (let ([c-context (recur context)] + [c-filler (recur filler)]) + (λ (r s a e f) + (let*-values ([(fillers env) (c-filler r s a e f)] + [(filled env) (c-context r s a env (cons the-hole fillers))]) + (values (if (empty? (rest filled)) filled (rest filled)) env))))] [`(hide-hole ,pattern) (let ([g (recur pattern)]) - (λ (r s a e h) - (g r s a e the-hole)))] + (λ (r s a e f) + (g r s a e (list the-hole))))] [`any - (λ (r s a e h) + (λ (r s a e f) (let*-values ([(lang nt) ((next-any-decision) langc sexpc)] - [(term) (gen-nt lang nt #f r s a the-hole)]) + [(term) (gen-nt lang nt #f r s a (list the-hole))]) (values term e)))] [(or (? symbol? (? nt? p)) `(cross ,(? symbol? p))) (let ([cross? (not (symbol? pat))]) - (λ (r s a e h) - (values (gen-nt (if any? sexpc langc) p cross? r s a h) e)))] + (λ (r s a e f) + (values (gen-nt (if any? sexpc langc) p cross? r s a f) e)))] [(struct binder ((or (app (symbol-match named-nt-rx) (? symbol? p)) p))) (let ([g (recur p)]) - (λ (r s a e h) - (generate/prior pat e (λ () (g r s a e h)))))] + (λ (r s a e f) + (generate/prior pat e (λ () (g r s a e f)))))] [(struct mismatch (_ (app (symbol-match mismatch-nt-rx) p))) (let ([g (recur p)]) (set! mismatches? #t) - (λ (r s a e h) - (let-values ([(term _) (g r s a e h)]) - (values term (hash-set e pat term)))))] + (λ (r s a e f) + (let-values ([(ts e) (g r s a e f)]) + (values ts (hash-set e pat (unfilled-term ts))))))] [(or (? symbol?) (? number?) (? string?) (? boolean?) (? null?)) - (λ (r s a e h) (values pat e))] + (λ (r s a e f) (values (unfilled pat) e))] [(list-rest (struct ellipsis (name sub-pat class vars)) rest) (let ([elemg (recur sub-pat)] [tailg (recur rest)]) (when (mismatch? name) (set! mismatches? #t)) - (λ (r s a e h) + (λ (r s a e f) (let*-values ([(len) (let ([prior (hash-ref e class #f)]) (if prior prior (if (zero? s) 0 ((next-sequence-decision) a))))] - [(seq env) - (generate-sequence (λ (e h) (elemg r s a e h)) e vars len)] - [(tail env) + [(seqs env) + (generate-sequence (λ (e) (elemg r s a e f)) e vars len)] + [(tails env) (let ([e (hash-set (hash-set env class len) name len)]) - (tailg r s a e h))]) - (values (append seq tail) env))))] + (tailg r s a e f))]) + (values (combine append seqs tails) env))))] [(list-rest hdp tlp) (let ([hdg (recur hdp)] [tlg (recur tlp)]) - (λ (r s a e h) + (λ (r s a e f) (let*-values - ([(hd env) (hdg r s a e h)] - [(tl env) (tlg r s a env h)]) - (values (cons hd tl) env))))] + ([(hds env) (hdg r s a e f)] + [(tls env) (tlg r s a env f)]) + (values (combine cons hds tls) env))))] [else (error what "unknown pattern ~s\n" pat)]))]) (if mismatches? - (λ (r s a e h) - (let ([g (λ (s a) (generator r s a e h))] + (λ (r s a e f) + (let ([g (λ (s a) (generator r s a e f))] [p? (λ (_ e) (mismatches-satisfied? e))]) (generate/pred (unparse-pattern pat) g p? s a r))) generator)))] @@ -388,8 +420,8 @@ (λ (pat) (let ([g (compile-pattern (reassign-classes (parse-pattern pat lang 'top-level)))]) (λ (size attempt retries) - (let-values ([(term env) (g retries size attempt empty-env the-hole)]) - (values term (bindings env))))))))) + (let-values ([(ts e) (g retries size attempt empty-env (list the-hole))]) + (values (unfilled-term ts) (bindings e))))))))) (define-struct base-cases (cross non-cross)) @@ -962,7 +994,8 @@ generate-term check-reduction-relation check-metafunction - exn:fail:redex:generation-failure?) + exn:fail:redex:generation-failure? + redex-pseudo-random-generator) (provide (struct-out ellipsis) (struct-out mismatch) diff --git a/collects/redex/redex.scrbl b/collects/redex/redex.scrbl index b81af99ac4..c49da45c59 100644 --- a/collects/redex/redex.scrbl +++ b/collects/redex/redex.scrbl @@ -1454,7 +1454,12 @@ produces and consumes argument lists.} @racket[redex-check], etc. when those forms are unable to produce a term matching some pattern. } - + +@defparam[redex-pseudo-random-generator generator pseudo-random-generator?]{ +@racket[generate-term] and the randomized testing forms (e.g., @racket[redex-check]) +use the parameter @racket[generator] to construct random terms. The parameter's +initial value is @racket[(current-pseudo-random-generator)].} + @deftech{Debugging PLT Redex Programs} It is easy to write grammars and reduction rules that are diff --git a/collects/redex/reduction-semantics.rkt b/collects/redex/reduction-semantics.rkt index 9e1351b7f1..278087beaa 100644 --- a/collects/redex/reduction-semantics.rkt +++ b/collects/redex/reduction-semantics.rkt @@ -76,4 +76,5 @@ (-> bindings? symbol? any) (-> bindings? symbol? (-> any) any))] [relation-coverage (parameter/c (listof coverage?))] - [covered-cases (-> coverage? (listof (cons/c string? natural-number/c)))]) + [covered-cases (-> coverage? (listof (cons/c string? natural-number/c)))] + [redex-pseudo-random-generator (parameter/c pseudo-random-generator?)]) diff --git a/collects/redex/tests/bitmap-test-util.rkt b/collects/redex/tests/bitmap-test-util.rkt index 943bdbb9a9..f717586c9b 100644 --- a/collects/redex/tests/bitmap-test-util.rkt +++ b/collects/redex/tests/bitmap-test-util.rkt @@ -92,10 +92,10 @@ (let loop ([y 0]) (unless (= y h) (cond - [(and (<= x (send new-bitmap get-width)) - (<= y (send new-bitmap get-height)) - (<= x (send old-bitmap get-width)) - (<= y (send old-bitmap get-height))) + [(and (< x (send new-bitmap get-width)) + (< y (send new-bitmap get-height)) + (< x (send old-bitmap get-width)) + (< y (send old-bitmap get-height))) (send new get-pixel x y new-c) (send old get-pixel x y old-c) (cond diff --git a/collects/redex/tests/bmps-macosx/extended-language.png b/collects/redex/tests/bmps-macosx/extended-language.png index 448f4f9bfb..3df1d5862f 100644 Binary files a/collects/redex/tests/bmps-macosx/extended-language.png and b/collects/redex/tests/bmps-macosx/extended-language.png differ diff --git a/collects/redex/tests/bmps-macosx/extended-reduction-relation.png b/collects/redex/tests/bmps-macosx/extended-reduction-relation.png index 46e14cf703..6cb65603c8 100644 Binary files a/collects/redex/tests/bmps-macosx/extended-reduction-relation.png and b/collects/redex/tests/bmps-macosx/extended-reduction-relation.png differ diff --git a/collects/redex/tests/bmps-macosx/language-nox.png b/collects/redex/tests/bmps-macosx/language-nox.png index 083d80cc66..ba84487797 100644 Binary files a/collects/redex/tests/bmps-macosx/language-nox.png and b/collects/redex/tests/bmps-macosx/language-nox.png differ diff --git a/collects/redex/tests/bmps-macosx/language.png b/collects/redex/tests/bmps-macosx/language.png index 1275c7b26c..fce82a7608 100644 Binary files a/collects/redex/tests/bmps-macosx/language.png and b/collects/redex/tests/bmps-macosx/language.png differ diff --git a/collects/redex/tests/bmps-macosx/lw.png b/collects/redex/tests/bmps-macosx/lw.png index 7a93ada00e..3be7001fb6 100644 Binary files a/collects/redex/tests/bmps-macosx/lw.png and b/collects/redex/tests/bmps-macosx/lw.png differ diff --git a/collects/redex/tests/bmps-macosx/metafunction-Name-vertical.png b/collects/redex/tests/bmps-macosx/metafunction-Name-vertical.png index 32fe0babfc..3ea8ba82ee 100644 Binary files a/collects/redex/tests/bmps-macosx/metafunction-Name-vertical.png and b/collects/redex/tests/bmps-macosx/metafunction-Name-vertical.png differ diff --git a/collects/redex/tests/bmps-macosx/metafunction-Name.png b/collects/redex/tests/bmps-macosx/metafunction-Name.png index 58452d8229..20323be719 100644 Binary files a/collects/redex/tests/bmps-macosx/metafunction-Name.png and b/collects/redex/tests/bmps-macosx/metafunction-Name.png differ diff --git a/collects/redex/tests/bmps-macosx/metafunction-T.png b/collects/redex/tests/bmps-macosx/metafunction-T.png index a9d5a093b6..29a7228ea5 100644 Binary files a/collects/redex/tests/bmps-macosx/metafunction-T.png and b/collects/redex/tests/bmps-macosx/metafunction-T.png differ diff --git a/collects/redex/tests/bmps-macosx/metafunction-TL.png b/collects/redex/tests/bmps-macosx/metafunction-TL.png index 1b0410ede7..e82e5a51b5 100644 Binary files a/collects/redex/tests/bmps-macosx/metafunction-TL.png and b/collects/redex/tests/bmps-macosx/metafunction-TL.png differ diff --git a/collects/redex/tests/bmps-macosx/metafunction-multi-arg.png b/collects/redex/tests/bmps-macosx/metafunction-multi-arg.png index 0ae325b3b0..868a354eef 100644 Binary files a/collects/redex/tests/bmps-macosx/metafunction-multi-arg.png and b/collects/redex/tests/bmps-macosx/metafunction-multi-arg.png differ diff --git a/collects/redex/tests/bmps-macosx/metafunction-subst.png b/collects/redex/tests/bmps-macosx/metafunction-subst.png index bf2dbc48f6..4cf18c0208 100644 Binary files a/collects/redex/tests/bmps-macosx/metafunction-subst.png and b/collects/redex/tests/bmps-macosx/metafunction-subst.png differ diff --git a/collects/redex/tests/bmps-macosx/metafunction.png b/collects/redex/tests/bmps-macosx/metafunction.png index 5eb6cdbeff..62fe00bbe5 100644 Binary files a/collects/redex/tests/bmps-macosx/metafunction.png and b/collects/redex/tests/bmps-macosx/metafunction.png differ diff --git a/collects/redex/tests/bmps-macosx/metafunctions-multiple.png b/collects/redex/tests/bmps-macosx/metafunctions-multiple.png index 3b40817a40..1f53b8f7e0 100644 Binary files a/collects/redex/tests/bmps-macosx/metafunctions-multiple.png and b/collects/redex/tests/bmps-macosx/metafunctions-multiple.png differ diff --git a/collects/redex/tests/bmps-macosx/mf-hidden.png b/collects/redex/tests/bmps-macosx/mf-hidden.png index 8545f0f19b..668981a409 100644 Binary files a/collects/redex/tests/bmps-macosx/mf-hidden.png and b/collects/redex/tests/bmps-macosx/mf-hidden.png differ diff --git a/collects/redex/tests/bmps-macosx/rdups-delimited.png b/collects/redex/tests/bmps-macosx/rdups-delimited.png index a24ee3c1b1..a82877598f 100644 Binary files a/collects/redex/tests/bmps-macosx/rdups-delimited.png and b/collects/redex/tests/bmps-macosx/rdups-delimited.png differ diff --git a/collects/redex/tests/bmps-macosx/rdups-undelimited.png b/collects/redex/tests/bmps-macosx/rdups-undelimited.png index 7bb959b600..d2670f73df 100644 Binary files a/collects/redex/tests/bmps-macosx/rdups-undelimited.png and b/collects/redex/tests/bmps-macosx/rdups-undelimited.png differ diff --git a/collects/redex/tests/bmps-macosx/red2.png b/collects/redex/tests/bmps-macosx/red2.png index 6dfe8ab649..9f54c74481 100644 Binary files a/collects/redex/tests/bmps-macosx/red2.png and b/collects/redex/tests/bmps-macosx/red2.png differ diff --git a/collects/redex/tests/bmps-macosx/reduction-relation-with-computed-labels-and-hiding.png b/collects/redex/tests/bmps-macosx/reduction-relation-with-computed-labels-and-hiding.png index 67c9db965d..d79440039a 100644 Binary files a/collects/redex/tests/bmps-macosx/reduction-relation-with-computed-labels-and-hiding.png and b/collects/redex/tests/bmps-macosx/reduction-relation-with-computed-labels-and-hiding.png differ diff --git a/collects/redex/tests/bmps-macosx/reduction-relation-with-computed-labels.png b/collects/redex/tests/bmps-macosx/reduction-relation-with-computed-labels.png index a87e9f4c76..7893398a72 100644 Binary files a/collects/redex/tests/bmps-macosx/reduction-relation-with-computed-labels.png and b/collects/redex/tests/bmps-macosx/reduction-relation-with-computed-labels.png differ diff --git a/collects/redex/tests/bmps-macosx/reduction-relation.png b/collects/redex/tests/bmps-macosx/reduction-relation.png index 1da77851c2..2272cb4df5 100644 Binary files a/collects/redex/tests/bmps-macosx/reduction-relation.png and b/collects/redex/tests/bmps-macosx/reduction-relation.png differ diff --git a/collects/redex/tests/bmps-macosx/rr-hidden.png b/collects/redex/tests/bmps-macosx/rr-hidden.png index 46e14cf703..6cb65603c8 100644 Binary files a/collects/redex/tests/bmps-macosx/rr-hidden.png and b/collects/redex/tests/bmps-macosx/rr-hidden.png differ diff --git a/collects/redex/tests/bmps-macosx/superscripts.png b/collects/redex/tests/bmps-macosx/superscripts.png index 69484218f2..b3ad49a933 100644 Binary files a/collects/redex/tests/bmps-macosx/superscripts.png and b/collects/redex/tests/bmps-macosx/superscripts.png differ diff --git a/collects/redex/tests/bmps-macosx/var-not-in-rebound.png b/collects/redex/tests/bmps-macosx/var-not-in-rebound.png index 79e5b401f5..9aa680efdd 100644 Binary files a/collects/redex/tests/bmps-macosx/var-not-in-rebound.png and b/collects/redex/tests/bmps-macosx/var-not-in-rebound.png differ diff --git a/collects/redex/tests/bmps-macosx/var-not-in.png b/collects/redex/tests/bmps-macosx/var-not-in.png index 0b27baf538..78df3d9573 100644 Binary files a/collects/redex/tests/bmps-macosx/var-not-in.png and b/collects/redex/tests/bmps-macosx/var-not-in.png differ diff --git a/collects/redex/tests/rg-test.rkt b/collects/redex/tests/rg-test.rkt index 3bf80b5506..246c9fd0f4 100644 --- a/collects/redex/tests/rg-test.rkt +++ b/collects/redex/tests/rg-test.rkt @@ -412,6 +412,10 @@ #:num (build-list 5 (λ (x) (λ (_) x))))) '(+ (+ 1 2) (+ 0 (+ 3 4)))) + (test (let/ec k + (generate-term lang (side-condition (in-hole C_1 1) (k (term C_1))) 5)) + (term hole)) + (test (generate-term lang (in-hole (in-hole (1 hole) hole) 5) 5) '(1 5)) (test (generate-term lang (hole 4) 5) (term (hole 4))) (test (generate-term/decisions @@ -429,6 +433,45 @@ (test (generate-term/decisions lang h 5 0 (decisions #:num (list (λ _ 1) (λ _ 2) (λ _ 3)))) '((2 ((3 (2 1)) 3)) 1))) +(let () + (define-language L + (C (c hole)) + (D (d hole)) + (E (e hole)) + (F (f hole))) + + (test (generate-term L (in-hole 3 4) 5) 3) + (test (generate-term L (in-hole (hole hole) 4) 5) '(4 4)) + (test (generate-term/decisions L (in-hole (hole ... hole) 4) 5 0 (decisions #:seq (list (λ (_) 1)))) + '(4 4)) + + (let-syntax ([test-sequence-holes + (λ (stx) + (syntax-case stx () + [(_ l) + #`(let ([length l] + [bindings #f]) + (test (generate-term/decisions + L + (side-condition (in-hole ((name x (q C)) (... ...)) 4) + (set! bindings (term ((x C) (... ...))))) + 5 0 (decisions #:seq (list (λ (_) length)))) + #,(syntax/loc stx (build-list length (λ (_) '(q (c 4)))))) + (test bindings + #,(syntax/loc stx (build-list length (λ (_) (term ((q (c hole)) (c hole))))))))]))]) + (test-sequence-holes 3) + (test-sequence-holes 0)) + + (let ([bindings #f]) + (test (generate-term + L + (side-condition (name CDEF (in-hole (name CDE (in-hole (name CD (in-hole C D)) E)) F)) + (set! bindings (term (C D E F CD CDE CDEF)))) + 0) + (term (c (d (e (f hole)))))) + (test bindings (term ((c hole) (d hole) (e hole) (f hole) + (c (d hole)) (c (d (e hole))) (c (d (e (f hole))))))))) + (let () (define-language lc (e (e e) (+ e e) x v) @@ -469,7 +512,8 @@ (let () (define-language lang (e (hide-hole (in-hole ((hide-hole hole) hole) 1)))) - (test (generate-term lang e 5) (term (hole 1)))) + (test (generate-term lang e 5) (term (hole 1))) + (test (plug (generate-term lang (hide-hole hole) 0) 3) 3)) (define (output-error-port thunk) (let ([port (open-output-string)]) @@ -1213,4 +1257,22 @@ '(x ..._1 x ..._2 variable ..._2 variable ..._3 variable_1 ..._3 variable_1 ..._4) '((..._1 . ..._4) (..._2 . ..._4) (..._3 . ..._4)))) +;; redex-test-seed +(let ([seed 0]) + (define-language L) + (define (generate) + (generate-term L (number ...) 10000000 #:attempt-num 10000000)) + (test (begin (random-seed seed) (generate)) + (begin (random-seed seed) (generate))) + (let ([prg (make-pseudo-random-generator)]) + (define (seed-effect-generate effect) + (begin + (parameterize ([current-pseudo-random-generator prg]) + (random-seed seed)) + (effect) + (parameterize ([redex-pseudo-random-generator prg]) + (generate)))) + (test (seed-effect-generate void) + (seed-effect-generate random)))) + (print-tests-passed 'rg-test.ss) diff --git a/collects/scribble/base-render.rkt b/collects/scribble/base-render.rkt index 2a5cace603..8dd56c063a 100644 --- a/collects/scribble/base-render.rkt +++ b/collects/scribble/base-render.rkt @@ -8,6 +8,7 @@ scheme/path setup/main-collects setup/path-relativize + file/convertible "render-struct.ss") (provide render%) @@ -677,6 +678,7 @@ (render-content (traverse-element-content i ri) part ri)] [(part-relative-element? i) (render-content (part-relative-element-content i ri) part ri)] + [(convertible? i) (list "???")] [else (render-other i part ri)])) (define/public (render-other i part ri) @@ -687,13 +689,15 @@ (define copied-srcs (make-hash)) (define copied-dests (make-hash)) - (define/public (install-file fn) - (if refer-to-existing-files + (define/public (install-file fn [content #f]) + (if (and refer-to-existing-files + (not content)) (if (string? fn) (string->path fn) fn) (let ([normalized (normal-case-path (simplify-path (path->complete-path fn)))]) - (or (hash-ref copied-srcs normalized #f) + (or (and (not content) + (hash-ref copied-srcs normalized #f)) (let ([src-dir (path-only fn)] [dest-dir (get-dest-directory #t)] [fn (file-name-from-path fn)]) @@ -715,22 +719,26 @@ (let-values ([(dest-file normalized-dest-file) (let loop ([dest-file dest-file]) (let ([normalized-dest-file - (normal-case-path (simplify-path (path->complete-path dest-file)))]) - (if (file-exists? dest-file) - (cond - [(call-with-input-file* - src-file - (lambda (src) - (call-with-input-file* + (normal-case-path (simplify-path (path->complete-path dest-file)))] + [check-same + (lambda (src) + (call-with-input-file* dest-file (lambda (dest) - (or (equal? (port-file-identity src) - (port-file-identity dest)) + (or (and (not content) + (equal? (port-file-identity src) + (port-file-identity dest))) (let loop () (let ([s (read-bytes 4096 src)] [d (read-bytes 4096 dest)]) (and (equal? s d) - (or (eof-object? s) (loop)))))))))) + (or (eof-object? s) (loop)))))))))]) + (if (file-exists? dest-file) + (cond + [(or (and content + (check-same (open-input-bytes content))) + (and (not content) + (call-with-input-file* src-file check-same))) ;; same content at that destination (values dest-file normalized-dest-file)] [(hash-ref copied-dests normalized-dest-file #f) @@ -743,10 +751,15 @@ ;; new file (values dest-file normalized-dest-file))))]) (unless (file-exists? dest-file) - (copy-file src-file dest-file)) + (if content + (call-with-output-file* + dest-file + (lambda (dest) (write-bytes content dest))) + (copy-file src-file dest-file))) (hash-set! copied-dests normalized-dest-file #t) (let ([result (path->string (file-name-from-path dest-file))]) - (hash-set! copied-srcs normalized result) + (unless content + (hash-set! copied-srcs normalized result)) result)))))))) ;; ---------------------------------------- diff --git a/collects/scribble/core.rkt b/collects/scribble/core.rkt index aa68a42f72..6e71a8ce0f 100644 --- a/collects/scribble/core.rkt +++ b/collects/scribble/core.rkt @@ -1,7 +1,8 @@ #lang scheme/base (require "private/provide-structs.ss" scheme/serialize - scheme/contract) + scheme/contract + file/convertible) ;; ---------------------------------------- @@ -119,7 +120,8 @@ (traverse-element? v) (part-relative-element? v) (multiarg-element? v) - (hash-ref content-symbols v #f))) + (hash-ref content-symbols v #f) + (convertible? v))) (provide element-style?) (define (element-style? s) diff --git a/collects/scribble/eval.rkt b/collects/scribble/eval.rkt index 180fabb1f7..4fe429c5dc 100644 --- a/collects/scribble/eval.rkt +++ b/collects/scribble/eval.rkt @@ -8,6 +8,7 @@ racket/sandbox racket/promise racket/string + file/convertible (for-syntax racket/base)) (provide interaction @@ -38,6 +39,8 @@ (define maxlen 60) + (define-namespace-anchor anchor) + (namespace-require 'racket/base) (namespace-require '(for-syntax racket/base)) @@ -142,50 +145,56 @@ [(syntax? s) (loop (syntax-e s) ops)] [else (loop ((car ops) s) (cdr ops))]))) - (define ((do-eval ev) s) + (define (extract-to-evaluate s) (let loop ([s s][expect #f]) (syntax-case s (code:comment eval:alts eval:check) [(code:line v (code:comment . rest)) (loop (extract s cdr car) expect)] [(code:comment . rest) - (list (list (void)) "" "")] + (values #f expect)] [(eval:alts p e) (loop (extract s cdr cdr car) expect)] [(eval:check e expect) (loop (extract s cdr car) (list (syntax->datum (datum->syntax #f (extract s cdr cdr car)))))] [else - (let ([r (with-handlers ([(lambda (x) - (not (exn:break? x))) - (lambda (e) - (list (if (exn? e) - (exn-message e) - (format "uncaught exception: ~s" e)) - (get-output ev) - (get-error-output ev)))]) - (list (let ([v (do-plain-eval ev s #t)]) - (if (call-in-sandbox-context - ev - (let ([cp (current-print)]) - (lambda () - (and (eq? (current-print) cp) - (print-as-expression))))) - (make-reader-graph (copy-value v (make-hasheq))) - (box - (call-in-sandbox-context + (values s expect)]))) + + (define ((do-eval ev) s) + (let-values ([(s expect) (extract-to-evaluate s)]) + (if s + (let ([r (with-handlers ([(lambda (x) + (not (exn:break? x))) + (lambda (e) + (list (if (exn? e) + (exn-message e) + (format "uncaught exception: ~s" e)) + (get-output ev) + (get-error-output ev)))]) + (list (let ([v (do-plain-eval ev s #t)]) + (if (call-in-sandbox-context ev - (lambda () - (let ([s (open-output-string)]) - (parameterize ([current-output-port s]) - (map (current-print) v)) - (get-output-string s))))))) - (get-output ev) - (get-error-output ev)))]) - (when expect - (let ([expect (do-plain-eval ev (car expect) #t)]) - (unless (equal? (car r) expect) - (raise-syntax-error 'eval "example result check failed" s)))) - r)]))) + (let ([cp (current-print)]) + (lambda () + (and (eq? (current-print) cp) + (print-as-expression))))) + (make-reader-graph (copy-value v (make-hasheq))) + (box + (call-in-sandbox-context + ev + (lambda () + (let ([s (open-output-string)]) + (parameterize ([current-output-port s]) + (map (current-print) v)) + (get-output-string s))))))) + (get-output ev) + (get-error-output ev)))]) + (when expect + (let ([expect (do-plain-eval ev (car expect) #t)]) + (unless (equal? (car r) expect) + (raise-syntax-error 'eval "example result check failed" s)))) + r) + (values (list (list (void)) "" ""))))) (define (install ht v v2) @@ -270,7 +279,12 @@ (parameterize ([sandbox-output 'string] [sandbox-error-output 'string] [sandbox-propagate-breaks #f]) - (make-evaluator '(begin)))))) + (let ([e (make-evaluator '(begin))]) + (let ([ns (namespace-anchor->namespace anchor)]) + (call-in-sandbox-context e + (lambda () + (namespace-attach-module ns 'file/convertible)))) + e))))) (define (make-base-eval-factory mod-paths) (let ([ns (delay (let ([ns (make-base-empty-namespace)]) @@ -329,9 +343,11 @@ (define-syntax-rule (quote-expr e) 'e) (define (do-interaction-eval ev e) - (parameterize ([current-command-line-arguments #()]) - (do-plain-eval (or ev (make-base-eval)) e #f)) - "") + (let-values ([(e expect) (extract-to-evaluate e)]) + (when e + (parameterize ([current-command-line-arguments #()]) + (do-plain-eval (or ev (make-base-eval)) e #f))) + "")) (define-syntax interaction-eval (syntax-rules () diff --git a/collects/scribble/html-render.rkt b/collects/scribble/html-render.rkt index c31021c900..412b4c34fd 100644 --- a/collects/scribble/html-render.rkt +++ b/collects/scribble/html-render.rkt @@ -9,6 +9,7 @@ scheme/port scheme/list scheme/string + file/convertible mzlib/runtime-path setup/main-doc setup/main-collects @@ -947,6 +948,15 @@ (cond [(string? e) (super render-content e part ri)] ; short-cut for common case [(list? e) (super render-content e part ri)] ; also a short-cut + [(and (convertible? e) + (convert e 'png-bytes)) + => (lambda (bstr) + (let ([w (integer-bytes->integer (subbytes bstr 16 20) #f #t)] + [h (integer-bytes->integer (subbytes bstr 20 24) #f #t)]) + `((img ([src ,(install-file "pict.png" bstr)] + [alt "image"] + [width ,(number->string w)] + [height ,(number->string h)])))))] [(image-element? e) (let* ([src (main-collects-relative->path (image-element-path e))] [suffixes (image-element-suffixes e)] diff --git a/collects/scribble/latex-render.rkt b/collects/scribble/latex-render.rkt index a8b2ae95c6..e1f006bb00 100644 --- a/collects/scribble/latex-render.rkt +++ b/collects/scribble/latex-render.rkt @@ -9,7 +9,8 @@ scheme/path scheme/string scheme/list - setup/main-collects) + setup/main-collects + file/convertible) (provide render-mixin) (define current-table-mode (make-parameter #f)) @@ -235,18 +236,30 @@ es)] [style (and (style? es) es)] [core-render (lambda (e tt?) - (if (and (image-element? e) - (not (disable-images))) - (let ([fn (install-file - (select-suffix - (main-collects-relative->path - (image-element-path e)) - (image-element-suffixes e) - '(".pdf" ".ps" ".png")))]) - (printf "\\includegraphics[scale=~a]{~a}" - (image-element-scale e) fn)) - (parameterize ([rendering-tt (or tt? (rendering-tt))]) - (super render-content e part ri))))] + (cond + [(and (image-element? e) + (not (disable-images))) + (let ([fn (install-file + (select-suffix + (main-collects-relative->path + (image-element-path e)) + (image-element-suffixes e) + '(".pdf" ".ps" ".png")))]) + (printf "\\includegraphics[scale=~a]{~a}" + (image-element-scale e) fn))] + [(and (convertible? e) + (not (disable-images)) + (let ([ftag (lambda (v suffix) (and v (list v suffix)))]) + (or (ftag (convert e 'pdf-bytes) ".pdf") + (ftag (convert e 'eps-bytes) ".ps") + (ftag (convert e 'png-bytes) ".png")))) + => (lambda (bstr+suffix) + (let ([fn (install-file (format "pict~a" (cadr bstr+suffix)) + (car bstr+suffix))]) + (printf "\\includegraphics{~a}" fn)))] + [else + (parameterize ([rendering-tt (or tt? (rendering-tt))]) + (super render-content e part ri))]))] [wrap (lambda (e s tt?) (printf "\\~a{" s) (core-render e tt?) diff --git a/collects/scribble/racket.rkt b/collects/scribble/racket.rkt index 62ef079876..a42247c8c7 100644 --- a/collects/scribble/racket.rkt +++ b/collects/scribble/racket.rkt @@ -8,6 +8,7 @@ mzlib/for syntax/modresolve syntax/modcode + file/convertible (for-syntax racket/base)) (provide define-code @@ -215,7 +216,8 @@ quote-depth)]) (if (or (element? (syntax-e c)) (delayed-element? (syntax-e c)) - (part-relative-element? (syntax-e c))) + (part-relative-element? (syntax-e c)) + (convertible? (syntax-e c))) (out (syntax-e c) #f) (out (if (and (identifier? c) color? @@ -1097,7 +1099,9 @@ (vector? v) (and (struct? v) (or (and qq - ;; Watch out for partially transparent subtypes of `element': + ;; Watch out for partially transparent subtypes of `element' + ;; or convertible values: + (not (convertible? v)) (not (element? v))) (prefab-struct-key v)))) (let ([orig-ht (unbox ht)] diff --git a/collects/scribble/sigplan.rkt b/collects/scribble/sigplan.rkt index e6e5bcc8b6..8607a80037 100644 --- a/collects/scribble/sigplan.rkt +++ b/collects/scribble/sigplan.rkt @@ -35,7 +35,7 @@ (->* () () #:rest (listof pre-content?) content?)]) -(provide preprint 10pt nocopyright +(provide preprint 10pt nocopyright onecolumn noqcourier notimes include-abstract) (define-syntax-rule (defopts name ...) @@ -45,7 +45,7 @@ stx)) ... (provide name ...))) -(defopts preprint 10pt nocopyright) +(defopts preprint 10pt nocopyright onecolumn noqcourier notimes) (define sigplan-extras (let ([abs (lambda (s) diff --git a/collects/scribble/sigplan/lang.rkt b/collects/scribble/sigplan/lang.rkt index f2aa6ef0e9..bcf43a5050 100644 --- a/collects/scribble/sigplan/lang.rkt +++ b/collects/scribble/sigplan/lang.rkt @@ -17,9 +17,12 @@ [(_ id . body) (let ([preprint? #f] [10pt? #f] - [nocopyright? #f]) + [onecolumn? #f] + [nocopyright? #f] + [times? #t] + [qcourier? #t]) (let loop ([stuff #'body]) - (syntax-case* stuff (preprint 10pt nocopyright) (lambda (a b) (eq? (syntax-e a) (syntax-e b))) + (syntax-case* stuff (onecolumn preprint 10pt nocopyright notimes noqcourier) (lambda (a b) (eq? (syntax-e a) (syntax-e b))) [(ws . body) ;; Skip intraline whitespace to find options: (and (string? (syntax-e #'ws)) @@ -28,25 +31,50 @@ [(preprint . body) (set! preprint? "preprint") (loop #'body)] + [(onecolumn . body) + (set! onecolumn? "onecolumn") + (loop #'body)] [(nocopyright . body) (set! nocopyright? "nocopyrightspace") (loop #'body)] [(10pt . body) (set! 10pt? "10pt") (loop #'body)] + [(noqcourier . body) + (set! qcourier? #f) + (loop #'body)] + [(notimes . body) + (set! times? #f) + (loop #'body)] [body - #`(#%module-begin id (post-process #,preprint? #,10pt? #,nocopyright?) () . body)])))])) + #`(#%module-begin id (post-process #,times? #,qcourier? #,preprint? #,10pt? #,nocopyright? #,onecolumn?) () . body)])))])) +#| -(define ((post-process . opts) doc) - (let ([options +The docs for the times.sty package suggests that it should not be used +so maybe we want to disable it permanently (or replace it with something else). + +Read here for more: + + http://www.ctan.org/tex-archive/macros/latex/required/psnfss/psnfss2e.pdf + +|# + +(define ((post-process times? qcourier? . opts) doc) + (let ([options (if (ormap values opts) (format "[~a]" (apply string-append (add-between (filter values opts) ", "))) "")]) (add-sigplan-styles (add-defaults doc (string->bytes/utf-8 - (format "\\documentclass~a{sigplanconf}\n\\usepackage{times}\n\\usepackage{qcourier}\n" - options)) + (format "\\documentclass~a{sigplanconf}\n~a~a" + options + (if times? + "\\usepackage{times}\n" + "") + (if qcourier? + "\\usepackage{qcourier}\n" + ""))) (scribble-file "sigplan/style.tex") (list (scribble-file "sigplan/sigplanconf.cls")) #f)))) diff --git a/collects/scribble/sigplan/sigplanconf.cls b/collects/scribble/sigplan/sigplanconf.cls index a5891f7561..4120cbda77 100644 --- a/collects/scribble/sigplan/sigplanconf.cls +++ b/collects/scribble/sigplan/sigplanconf.cls @@ -20,18 +20,18 @@ \NeedsTeXFormat{LaTeX2e}[1995/12/01] -\ProvidesClass{sigplanconf}[2009/04/29 v1.9 ACM SIGPLAN Proceedings] +\ProvidesClass{sigplanconf}[2007/03/13 v1.5 ACM SIGPLAN Proceedings] % The following few pages contain LaTeX programming extensions adapted % from the ZzTeX macro package. - + % Token Hackery % ----- ------- \def \@expandaftertwice {\expandafter\expandafter\expandafter} \def \@expandafterthrice {\expandafter\expandafter\expandafter\expandafter - \expandafter\expandafter\expandafter} + \expandafter\expandafter\expandafter} % This macro discards the next token. @@ -49,17 +49,17 @@ % Usage: \expandafter\@defof \meaning\macro\@mark \def \@defof #1:->#2\@mark{#2} - + % Control Sequence Names % ------- -------- ----- \def \@name #1{% {\tokens} - \csname \expandafter\@discardtok \string#1\endcsname} + \csname \expandafter\@discardtok \string#1\endcsname} \def \@withname #1#2{% {\command}{\tokens} - \expandafter#1\csname \expandafter\@discardtok \string#2\endcsname} - + \expandafter#1\csname \expandafter\@discardtok \string#2\endcsname} + % Flags (Booleans) % ----- ---------- @@ -70,7 +70,7 @@ \def \@false {FL} \def \@setflag #1=#2{\edef #1{#2}}% \flag = boolean - + % IF and Predicates % -- --- ---------- @@ -99,7 +99,7 @@ \def \@oddp #1{\ifodd #1\@true \else \@false \fi} \def \@evenp #1{\ifodd #1\@false \else \@true \fi} \def \@rangep #1#2#3{\if \@orp{\@lssp{#1}{#2}}{\@gtrp{#1}{#3}}\@false \else - \@true \fi} + \@true \fi} \def \@tensp #1{\@rangep{#1}{10}{19}} \def \@dimeqlp #1#2{\ifdim #1 = #2\@true \else \@false \fi} @@ -124,25 +124,25 @@ \long\def \@xtokeqlp #1#2{\expandafter\ifx #1#2\@true \else \@false \fi} \long\def \@definedp #1{% - \expandafter\ifx \csname \expandafter\@discardtok \string#1\endcsname - \relax \@false \else \@true \fi} + \expandafter\ifx \csname \expandafter\@discardtok \string#1\endcsname + \relax \@false \else \@true \fi} \long\def \@undefinedp #1{% - \expandafter\ifx \csname \expandafter\@discardtok \string#1\endcsname - \relax \@true \else \@false \fi} + \expandafter\ifx \csname \expandafter\@discardtok \string#1\endcsname + \relax \@true \else \@false \fi} \def \@emptydefp #1{\ifx #1\@empty \@true \else \@false \fi}% {\name} \let \@emptylistp = \@emptydefp \long\def \@emptyargp #1{% {#n} - \@empargp #1\@empargq\@mark} + \@empargp #1\@empargq\@mark} \long\def \@empargp #1#2\@mark{% - \ifx #1\@empargq \@true \else \@false \fi} + \ifx #1\@empargq \@true \else \@false \fi} \def \@empargq {\@empargq} \def \@emptytoksp #1{% {\tokenreg} - \expandafter\@emptoksp \the#1\@mark} + \expandafter\@emptoksp \the#1\@mark} \long\def \@emptoksp #1\@mark{\@emptyargp{#1}} @@ -163,30 +163,30 @@ \def \@notp #1{\if #1\@false \else \@true \fi} \def \@andp #1#2{\if #1% - \if #2\@true \else \@false \fi - \else - \@false - \fi} + \if #2\@true \else \@false \fi + \else + \@false + \fi} \def \@orp #1#2{\if #1% - \@true - \else - \if #2\@true \else \@false \fi - \fi} - -\def \@xorp #1#2{\if #1% - \if #2\@false \else \@true \fi + \@true \else \if #2\@true \else \@false \fi \fi} +\def \@xorp #1#2{\if #1% + \if #2\@false \else \@true \fi + \else + \if #2\@true \else \@false \fi + \fi} + % Arithmetic % ---------- \def \@increment #1{\advance #1 by 1\relax}% {\count} \def \@decrement #1{\advance #1 by -1\relax}% {\count} - + % Options % ------- @@ -207,16 +207,16 @@ % Note that all the dangerous article class options are trapped. \DeclareOption{9pt}{\@setflag \@ninepoint = \@true - \@setflag \@explicitsize = \@true} + \@setflag \@explicitsize = \@true} \DeclareOption{10pt}{\PassOptionsToClass{10pt}{article}% - \@setflag \@ninepoint = \@false - \@setflag \@tenpoint = \@true - \@setflag \@explicitsize = \@true} + \@setflag \@ninepoint = \@false + \@setflag \@tenpoint = \@true + \@setflag \@explicitsize = \@true} \DeclareOption{11pt}{\PassOptionsToClass{11pt}{article}% - \@setflag \@ninepoint = \@false - \@setflag \@explicitsize = \@true} + \@setflag \@ninepoint = \@false + \@setflag \@explicitsize = \@true} \DeclareOption{12pt}{\@unsupportedoption{12pt}} @@ -252,7 +252,7 @@ \DeclareOption{numberedpars}{\@numheaddepth = 4} -%%%\DeclareOption{onecolumn}{\@setflag \@onecolumn = \@true} +\DeclareOption{onecolumn}{\@setflag \@onecolumn = \@true} \DeclareOption{preprint}{\@setflag \@preprint = \@true} @@ -271,34 +271,34 @@ \ProcessOptions \if \@onecolumn - \if \@notp{\@explicitsize}% - \@setflag \@ninepoint = \@false - \PassOptionsToClass{11pt}{article}% - \fi - \PassOptionsToClass{twoside,onecolumn}{article} + \if \@notp{\@explicitsize}% + \@setflag \@ninepoint = \@false +% \PassOptionsToClass{11pt}{article}% + \fi + \PassOptionsToClass{twoside,onecolumn}{article} \else - \PassOptionsToClass{twoside,twocolumn}{article} + \PassOptionsToClass{twoside,twocolumn}{article} \fi \LoadClass{article} \def \@unsupportedoption #1{% - \ClassError{proc}{The standard '#1' option is not supported.}} + \ClassError{proc}{The standard '#1' option is not supported.}} % This can be used with the 'reprint' option to get the final folios. \def \setpagenumber #1{% - \setcounter{page}{#1}} + \setcounter{page}{#1}} \AtEndDocument{\label{sigplanconf@finalpage}} - + % Utilities % --------- \newcommand{\setvspace}[2]{% - #1 = #2 - \advance #1 by -1\parskip} - + #1 = #2 + \advance #1 by -1\parskip} + % Document Parameters % -------- ---------- @@ -313,11 +313,11 @@ \setlength{\headsep}{0pt} \if \@onecolumn - \setlength{\evensidemargin}{.75in} - \setlength{\oddsidemargin}{.75in} + \setlength{\evensidemargin}{.75in} + \setlength{\oddsidemargin}{.75in} \else - \setlength{\evensidemargin}{.75in} - \setlength{\oddsidemargin}{.75in} + \setlength{\evensidemargin}{.75in} + \setlength{\oddsidemargin}{.75in} \fi % Text area: @@ -326,9 +326,9 @@ \setlength{\standardtextwidth}{42pc} \if \@onecolumn - \setlength{\textwidth}{40.5pc} + \setlength{\textwidth}{20pc} \else - \setlength{\textwidth}{\standardtextwidth} + \setlength{\textwidth}{\standardtextwidth} \fi \setlength{\topskip}{8pt} @@ -342,11 +342,11 @@ % Paragraphs: \if \@blockstyle - \setlength{\parskip}{5pt plus .1pt minus .5pt} - \setlength{\parindent}{0pt} + \setlength{\parskip}{5pt plus .1pt minus .5pt} + \setlength{\parindent}{0pt} \else - \setlength{\parskip}{0pt} - \setlength{\parindent}{12pt} + \setlength{\parskip}{0pt} + \setlength{\parindent}{12pt} \fi \setlength{\lineskip}{.5pt} @@ -376,10 +376,10 @@ \setlength{\footnotesep}{9pt} \renewcommand{\footnoterule}{% - \hrule width .5\columnwidth height .33pt depth 0pt} + \hrule width .5\columnwidth height .33pt depth 0pt} \renewcommand{\@makefntext}[1]{% - \noindent \@makefnmark \hspace{1pt}#1} + \noindent \@makefnmark \hspace{1pt}#1} % Floats: @@ -409,48 +409,48 @@ % Miscellaneous: \errorcontextlines = 5 - + % Fonts % ----- \if \@times - \renewcommand{\rmdefault}{ptm}% - \if \@mathtime - \usepackage[mtbold,noTS1]{mathtime}% - \else + \renewcommand{\rmdefault}{ptm}% + \if \@mathtime + \usepackage[mtbold,noTS1]{mathtime}% + \else %%% \usepackage{mathptm}% - \fi + \fi \else - \relax + \relax \fi \if \@ninepoint \renewcommand{\normalsize}{% - \@setfontsize{\normalsize}{9pt}{10pt}% - \setlength{\abovedisplayskip}{5pt plus 1pt minus .5pt}% - \setlength{\belowdisplayskip}{\abovedisplayskip}% - \setlength{\abovedisplayshortskip}{3pt plus 1pt minus 2pt}% - \setlength{\belowdisplayshortskip}{\abovedisplayshortskip}} + \@setfontsize{\normalsize}{9pt}{10pt}% + \setlength{\abovedisplayskip}{5pt plus 1pt minus .5pt}% + \setlength{\belowdisplayskip}{\abovedisplayskip}% + \setlength{\abovedisplayshortskip}{3pt plus 1pt minus 2pt}% + \setlength{\belowdisplayshortskip}{\abovedisplayshortskip}} \renewcommand{\tiny}{\@setfontsize{\tiny}{5pt}{6pt}} \renewcommand{\scriptsize}{\@setfontsize{\scriptsize}{7pt}{8pt}} \renewcommand{\small}{% - \@setfontsize{\small}{8pt}{9pt}% - \setlength{\abovedisplayskip}{4pt plus 1pt minus 1pt}% - \setlength{\belowdisplayskip}{\abovedisplayskip}% - \setlength{\abovedisplayshortskip}{2pt plus 1pt}% - \setlength{\belowdisplayshortskip}{\abovedisplayshortskip}} + \@setfontsize{\small}{8pt}{9pt}% + \setlength{\abovedisplayskip}{4pt plus 1pt minus 1pt}% + \setlength{\belowdisplayskip}{\abovedisplayskip}% + \setlength{\abovedisplayshortskip}{2pt plus 1pt}% + \setlength{\belowdisplayshortskip}{\abovedisplayshortskip}} \renewcommand{\footnotesize}{% - \@setfontsize{\footnotesize}{8pt}{9pt}% - \setlength{\abovedisplayskip}{4pt plus 1pt minus .5pt}% - \setlength{\belowdisplayskip}{\abovedisplayskip}% - \setlength{\abovedisplayshortskip}{2pt plus 1pt}% - \setlength{\belowdisplayshortskip}{\abovedisplayshortskip}} + \@setfontsize{\footnotesize}{8pt}{9pt}% + \setlength{\abovedisplayskip}{4pt plus 1pt minus .5pt}% + \setlength{\belowdisplayskip}{\abovedisplayskip}% + \setlength{\abovedisplayshortskip}{2pt plus 1pt}% + \setlength{\belowdisplayshortskip}{\abovedisplayshortskip}} \renewcommand{\large}{\@setfontsize{\large}{11pt}{13pt}} @@ -471,52 +471,53 @@ \relax \fi\fi - + % Abstract % -------- \renewenvironment{abstract}{% - \section*{Abstract}% - \normalsize}{% - } - + \section*{Abstract}% + \normalsize}{% + } + % Bibliography % ------------ \renewenvironment{thebibliography}[1] - {\section*{\refname - \@mkboth{\MakeUppercase\refname}{\MakeUppercase\refname}}% - \list{\@biblabel{\@arabic\c@enumiv}}% - {\settowidth\labelwidth{\@biblabel{#1}}% - \leftmargin\labelwidth - \advance\leftmargin\labelsep - \@openbib@code - \usecounter{enumiv}% - \let\p@enumiv\@empty - \renewcommand\theenumiv{\@arabic\c@enumiv}}% - \bibfont - \softraggedright%%%\sloppy - \clubpenalty4000 - \@clubpenalty \clubpenalty - \widowpenalty4000% - \sfcode`\.\@m} - {\def\@noitemerr - {\@latex@warning{Empty `thebibliography' environment}}% - \endlist} + {\section*{\refname + \@mkboth{\MakeUppercase\refname}{\MakeUppercase\refname}}% + \list{\@biblabel{\@arabic\c@enumiv}}% + {\settowidth\labelwidth{\@biblabel{#1}}% + \leftmargin\labelwidth + \advance\leftmargin\labelsep + \@openbib@code + \usecounter{enumiv}% + \let\p@enumiv\@empty + \renewcommand\theenumiv{\@arabic\c@enumiv}}% + \bibfont + \softraggedright%%%\sloppy + \clubpenalty4000 + \@clubpenalty \clubpenalty + \widowpenalty4000% + \sfcode`\.\@m} + {\def\@noitemerr + {\@latex@warning{Empty `thebibliography' environment}}% + \endlist} \if \@natbib \usepackage{natbib} \setlength{\bibsep}{3pt plus .5pt minus .25pt} -\bibpunct{[}{]}{,}{A}{}{,} +\bibpunct{(}{)}{;}{A}{}{,} +\let \ncite = \cite \let \cite = \citep \fi \def \bibfont {\small} - + % Categories % ---------- @@ -524,25 +525,25 @@ \@setflag \@firstcategory = \@true \newcommand{\category}[3]{% - \if \@firstcategory - \paragraph*{Categories and Subject Descriptors}% - \@setflag \@firstcategory = \@false - \else - \unskip ;\hspace{.75em}% - \fi - \@ifnextchar [{\@category{#1}{#2}{#3}}{\@category{#1}{#2}{#3}[]}} + \if \@firstcategory + \paragraph*{Categories and Subject Descriptors}% + \@setflag \@firstcategory = \@false + \else + \unskip ;\hspace{.75em}% + \fi + \@ifnextchar [{\@category{#1}{#2}{#3}}{\@category{#1}{#2}{#3}[]}} \def \@category #1#2#3[#4]{% - {\let \and = \relax - #1 [\textit{#2}]% - \if \@emptyargp{#4}% - \if \@notp{\@emptyargp{#3}}: #3\fi - \else - :\space - \if \@notp{\@emptyargp{#3}}#3---\fi - \textrm{#4}% - \fi}} - + {\let \and = \relax + #1 [\textit{#2}]% + \if \@emptyargp{#4}% + \if \@notp{\@emptyargp{#3}}: #3\fi + \else + :\space + \if \@notp{\@emptyargp{#3}}#3---\fi + \textrm{#4}% + \fi}} + % Copyright Notice % --------- ------ @@ -550,125 +551,120 @@ \def \ftype@copyrightbox {8} \def \@toappear {} \def \@permission {} -\def \@reprintprice {} \def \@copyrightspace {% - \@float{copyrightbox}[b]% - \vbox to 1in{% - \vfill - \parbox[b]{20pc}{% - \scriptsize - \if \@preprint - [Copyright notice will appear here - once 'preprint' option is removed.]\par - \else - \@toappear - \fi - \if \@reprint - \noindent Reprinted from \@conferencename, - \@proceedings, - \@conferenceinfo, - pp.~\number\thepage--\pageref{sigplanconf@finalpage}.\par - \fi}}% - \end@float} + \@float{copyrightbox}[b]% + \vbox to 1in{% + \vfill + \parbox[b]{20pc}{% + \scriptsize + \if \@preprint + [Copyright notice will appear here + once 'preprint' option is removed.]\par + \else + \@toappear + \fi + \if \@reprint + \noindent Reprinted from \@conferencename, + \@proceedings, + \@conferenceinfo, + pp.~\number\thepage--\pageref{sigplanconf@finalpage}.\par + \fi}}% + \end@float} \long\def \toappear #1{% - \def \@toappear {#1}} + \def \@toappear {#1}} \toappear{% - \noindent \@permission \par - \vspace{2pt} - \noindent \textsl{\@conferencename}\quad \@conferenceinfo \par - \noindent Copyright \copyright\ \@copyrightyear\ ACM \@copyrightdata - \dots \@reprintprice\par} - -\newcommand{\reprintprice}[1]{% - \gdef \@reprintprice {#1}} -\reprintprice{\$10.00} + \noindent \@permission \par + \vspace{2pt} + \noindent \textsl{\@conferencename}\quad \@conferenceinfo \par + \noindent Copyright \copyright\ \@copyrightyear\ ACM \@copyrightdata + \dots \$5.00\par} \newcommand{\permission}[1]{% - \gdef \@permission {#1}} + \gdef \@permission {#1}} \permission{% - Permission to make digital or hard copies of all or - part of this work for personal or classroom use is granted without - fee provided that copies are not made or distributed for profit or - commercial advantage and that copies bear this notice and the full - citation on the first page. To copy otherwise, to republish, to - post on servers or to redistribute to lists, requires prior specific - permission and/or a fee.} + Permission to make digital or hard copies of all or + part of this work for personal or classroom use is granted without + fee provided that copies are not made or distributed for profit or + commercial advantage and that copies bear this notice and the full + citation on the first page. To copy otherwise, to republish, to + post on servers or to redistribute to lists, requires prior specific + permission and/or a fee.} % Here we have some alternate permission statements and copyright lines: \newcommand{\ACMCanadapermission}{% - \permission{% - Copyright \@copyrightyear\ Association for Computing Machinery. - ACM acknowledges that - this contribution was authored or co-authored by an affiliate of the - National Research Council of Canada (NRC). - As such, the Crown in Right of - Canada retains an equal interest in the copyright, however granting - nonexclusive, royalty-free right to publish or reproduce this article, - or to allow others to do so, provided that clear attribution - is also given to the authors and the NRC.}} + \permission{% + Copyright \@copyrightyear\ Association for Computing Machinery. + ACM acknowledges that + this contribution was authored or co-authored by an affiliate of the + National Research Council of Canada (NRC). + As such, the Crown in Right of + Canada retains an equal interest in the copyright, however granting + nonexclusive, royalty-free right to publish or reproduce this article, + or to allow others to do so, provided that clear attribution + is also given to the authors and the NRC.}} \newcommand{\ACMUSpermission}{% - \permission{% - Copyright \@copyrightyear\ Association for - Computing Machinery. ACM acknowledges that - this contribution was authored or co-authored - by a contractor or affiliate - of the U.S. Government. As such, the Government retains a nonexclusive, - royalty-free right to publish or reproduce this article, - or to allow others to do so, for Government purposes only.}} + \permission{% + Copyright \@copyrightyear\ Association for + Computing Machinery. ACM acknowledges that + this contribution was authored or co-authored + by a contractor or affiliate + of the U.S. Government. As such, the Government retains a nonexclusive, + royalty-free right to publish or reproduce this article, + or to allow others to do so, for Government purposes only.}} \newcommand{\authorpermission}{% - \permission{% - Copyright is held by the author/owner(s).} - \toappear{% - \noindent \@permission \par - \vspace{2pt} - \noindent \textsl{\@conferencename}\quad \@conferenceinfo \par - ACM \@copyrightdata.}} + \permission{% + Copyright is held by the author/owner(s).} + \toappear{% + \noindent \@permission \par + \vspace{2pt} + \noindent \textsl{\@conferencename}\quad \@conferenceinfo \par + ACM \@copyrightdata.}} \newcommand{\Sunpermission}{% - \permission{% - Copyright is held by Sun Microsystems, Inc.}% - \toappear{% - \noindent \@permission \par - \vspace{2pt} - \noindent \textsl{\@conferencename}\quad \@conferenceinfo \par - ACM \@copyrightdata.}} + \permission{% + Copyright is held by Sun Microsystems, Inc.}% + \toappear{% + \noindent \@permission \par + \vspace{2pt} + \noindent \textsl{\@conferencename}\quad \@conferenceinfo \par + ACM \@copyrightdata.}} \newcommand{\USpublicpermission}{% - \permission{% - This paper is authored by an employee(s) of the United States - Government and is in the public domain.}% - \toappear{% - \noindent \@permission \par - \vspace{2pt} - \noindent \textsl{\@conferencename}\quad \@conferenceinfo \par - ACM \@copyrightdata.}} - + \permission{% + This paper is authored by an employee(s) of the United States + Government and is in the public domain.}% + \toappear{% + \noindent \@permission \par + \vspace{2pt} + \noindent \textsl{\@conferencename}\quad \@conferenceinfo \par + ACM \@copyrightdata.}} + % Enunciations % ------------ \def \@begintheorem #1#2{% {name}{number} - \trivlist - \item[\hskip \labelsep \textsc{#1 #2.}]% - \itshape\selectfont - \ignorespaces} + \trivlist + \item[\hskip \labelsep \textsc{#1 #2.}]% + \itshape\selectfont + \ignorespaces} \def \@opargbegintheorem #1#2#3{% {name}{number}{title} - \trivlist - \item[% - \hskip\labelsep \textsc{#1\ #2}% - \if \@notp{\@emptyargp{#3}}\nut (#3).\fi]% - \itshape\selectfont - \ignorespaces} - + \trivlist + \item[% + \hskip\labelsep \textsc{#1\ #2}% + \if \@notp{\@emptyargp{#3}}\nut (#3).\fi]% + \itshape\selectfont + \ignorespaces} + % Figures % ------- @@ -676,24 +672,24 @@ \@setflag \@caprule = \@true \long\def \@makecaption #1#2{% - \addvspace{4pt} - \if \@caprule - \hrule width \hsize height .33pt - \vspace{4pt} - \fi - \setbox \@tempboxa = \hbox{\@setfigurenumber{#1.}\nut #2}% - \if \@dimgtrp{\wd\@tempboxa}{\hsize}% - \noindent \@setfigurenumber{#1.}\nut #2\par - \else - \centerline{\box\@tempboxa}% - \fi} + \addvspace{4pt} + \if \@caprule + \hrule width \hsize height .33pt + \vspace{4pt} + \fi + \setbox \@tempboxa = \hbox{\@setfigurenumber{#1.}\nut #2}% + \if \@dimgtrp{\wd\@tempboxa}{\hsize}% + \noindent \@setfigurenumber{#1.}\nut #2\par + \else + \centerline{\box\@tempboxa}% + \fi} \newcommand{\nocaptionrule}{% - \@setflag \@caprule = \@false} + \@setflag \@caprule = \@false} \def \@setfigurenumber #1{% - {\rmfamily \bfseries \selectfont #1}} - + {\rmfamily \bfseries \selectfont #1}} + % Hierarchy % --------- @@ -705,68 +701,68 @@ \newskip{\@sectionbelowskip} \if \@blockstyle - \setlength{\@sectionbelowskip}{0.1pt}% + \setlength{\@sectionbelowskip}{0.1pt}% \else - \setlength{\@sectionbelowskip}{4pt}% + \setlength{\@sectionbelowskip}{4pt}% \fi \renewcommand{\section}{% - \@startsection - {section}% - {1}% - {0pt}% - {-\@sectionaboveskip}% - {\@sectionbelowskip}% - {\large \bfseries \raggedright}} + \@startsection + {section}% + {1}% + {0pt}% + {-\@sectionaboveskip}% + {\@sectionbelowskip}% + {\large \bfseries \raggedright}} \newskip{\@subsectionaboveskip} \setvspace{\@subsectionaboveskip}{8pt plus 2pt minus 2pt} \newskip{\@subsectionbelowskip} \if \@blockstyle - \setlength{\@subsectionbelowskip}{0.1pt}% + \setlength{\@subsectionbelowskip}{0.1pt}% \else - \setlength{\@subsectionbelowskip}{4pt}% + \setlength{\@subsectionbelowskip}{4pt}% \fi \renewcommand{\subsection}{% - \@startsection% - {subsection}% - {2}% - {0pt}% - {-\@subsectionaboveskip}% - {\@subsectionbelowskip}% - {\normalsize \bfseries \raggedright}} + \@startsection% + {subsection}% + {2}% + {0pt}% + {-\@subsectionaboveskip}% + {\@subsectionbelowskip}% + {\normalsize \bfseries \raggedright}} \renewcommand{\subsubsection}{% - \@startsection% - {subsubsection}% - {3}% - {0pt}% - {-\@subsectionaboveskip} - {\@subsectionbelowskip}% - {\normalsize \bfseries \raggedright}} + \@startsection% + {subsubsection}% + {3}% + {0pt}% + {-\@subsectionaboveskip} + {\@subsectionbelowskip}% + {\normalsize \bfseries \raggedright}} \newskip{\@paragraphaboveskip} \setvspace{\@paragraphaboveskip}{6pt plus 2pt minus 2pt} \renewcommand{\paragraph}{% - \@startsection% - {paragraph}% - {4}% - {0pt}% - {\@paragraphaboveskip} - {-1em}% - {\normalsize \bfseries \if \@times \itshape \fi}} + \@startsection% + {paragraph}% + {4}% + {0pt}% + {\@paragraphaboveskip} + {-1em}% + {\normalsize \bfseries \if \@times \itshape \fi}} \renewcommand{\subparagraph}{% - \@startsection% - {subparagraph}% - {4}% - {0pt}% - {\@paragraphaboveskip} - {-1em}% - {\normalsize \itshape}} + \@startsection% + {subparagraph}% + {4}% + {0pt}% + {\@paragraphaboveskip} + {-1em}% + {\normalsize \itshape}} % Standard headings: @@ -775,7 +771,7 @@ \newcommand{\keywords}{\paragraph*{Keywords}} \newcommand{\terms}{\paragraph*{General Terms}} - + % Identification % -------------- @@ -788,22 +784,22 @@ \newcommand{\conferenceinfo}[2]{% - \gdef \@conferencename {#1}% - \gdef \@conferenceinfo {#2}} + \gdef \@conferencename {#1}% + \gdef \@conferenceinfo {#2}} \newcommand{\copyrightyear}[1]{% - \gdef \@copyrightyear {#1}} + \gdef \@copyrightyear {#1}} \let \CopyrightYear = \copyrightyear \newcommand{\copyrightdata}[1]{% - \gdef \@copyrightdata {#1}} + \gdef \@copyrightdata {#1}} \let \crdata = \copyrightdata \newcommand{\proceedings}[1]{% - \gdef \@proceedings {#1}} - + \gdef \@proceedings {#1}} + % Lists % ----- @@ -816,11 +812,11 @@ \setlength{\topsep}{\standardvspace} \if \@blockstyle - \setlength{\itemsep}{1pt} - \setlength{\parsep}{3pt} + \setlength{\itemsep}{1pt} + \setlength{\parsep}{3pt} \else - \setlength{\itemsep}{1pt} - \setlength{\parsep}{3pt} + \setlength{\itemsep}{1pt} + \setlength{\parsep}{3pt} \fi \renewcommand{\labelitemi}{{\small \centeroncapheight{\textbullet}}} @@ -829,8 +825,8 @@ \renewcommand{\labelitemiv}{{\Large \textperiodcentered}} \renewcommand{\@listi}{% - \leftmargin = \leftmargini - \listparindent = 0pt} + \leftmargin = \leftmargini + \listparindent = 0pt} %%% \itemsep = 1pt %%% \parsep = 3pt} %%% \listparindent = \parindent} @@ -838,54 +834,54 @@ \let \@listI = \@listi \renewcommand{\@listii}{% - \leftmargin = \leftmarginii - \topsep = 1pt - \labelwidth = \leftmarginii - \advance \labelwidth by -\labelsep - \listparindent = \parindent} + \leftmargin = \leftmarginii + \topsep = 1pt + \labelwidth = \leftmarginii + \advance \labelwidth by -\labelsep + \listparindent = \parindent} \renewcommand{\@listiii}{% - \leftmargin = \leftmarginiii - \labelwidth = \leftmarginiii - \advance \labelwidth by -\labelsep - \listparindent = \parindent} + \leftmargin = \leftmarginiii + \labelwidth = \leftmarginiii + \advance \labelwidth by -\labelsep + \listparindent = \parindent} \renewcommand{\@listiv}{% - \leftmargin = \leftmarginiv - \labelwidth = \leftmarginiv - \advance \labelwidth by -\labelsep - \listparindent = \parindent} - + \leftmargin = \leftmarginiv + \labelwidth = \leftmarginiv + \advance \labelwidth by -\labelsep + \listparindent = \parindent} + % Mathematics % ----------- \def \theequation {\arabic{equation}} - + % Miscellaneous % ------------- \newcommand{\balancecolumns}{% - \vfill\eject - \global\@colht = \textheight - \global\ht\@cclv = \textheight} + \vfill\eject + \global\@colht = \textheight + \global\ht\@cclv = \textheight} \newcommand{\nut}{\hspace{.5em}} \newcommand{\softraggedright}{% - \let \\ = \@centercr - \leftskip = 0pt - \rightskip = 0pt plus 10pt} - + \let \\ = \@centercr + \leftskip = 0pt + \rightskip = 0pt plus 10pt} + % Program Code % ------- ---- \newcommand{\mono}[1]{% - {\@tempdima = \fontdimen2\font - \texttt{\spaceskip = 1.1\@tempdima #1}}} - + {\@tempdima = \fontdimen2\font + \texttt{\spaceskip = 1.1\@tempdima #1}}} + % Running Heads and Feet % ------- ----- --- ---- @@ -893,26 +889,26 @@ \def \@preprintfooter {} \newcommand{\preprintfooter}[1]{% - \gdef \@preprintfooter {#1}} + \gdef \@preprintfooter {#1}} \if \@preprint \def \ps@plain {% - \let \@mkboth = \@gobbletwo - \let \@evenhead = \@empty - \def \@evenfoot {\scriptsize \textit{\@preprintfooter}\hfil \thepage \hfil - \textit{\@formatyear}}% - \let \@oddhead = \@empty - \let \@oddfoot = \@evenfoot} + \let \@mkboth = \@gobbletwo + \let \@evenhead = \@empty + \def \@evenfoot {\scriptsize \textit{\@preprintfooter}\hfil \thepage \hfil + \textit{\@formatyear}}% + \let \@oddhead = \@empty + \let \@oddfoot = \@evenfoot} \else\if \@reprint \def \ps@plain {% - \let \@mkboth = \@gobbletwo - \let \@evenhead = \@empty - \def \@evenfoot {\scriptsize \hfil \thepage \hfil}% - \let \@oddhead = \@empty - \let \@oddfoot = \@evenfoot} + \let \@mkboth = \@gobbletwo + \let \@evenhead = \@empty + \def \@evenfoot {\scriptsize \hfil \thepage \hfil}% + \let \@oddhead = \@empty + \let \@oddfoot = \@evenfoot} \else @@ -923,15 +919,15 @@ \fi\fi \def \@formatyear {% - \number\year/\number\month/\number\day} - + \number\year/\number\month/\number\day} + % Special Characters % ------- ---------- \DeclareRobustCommand{\euro}{% - \protect{\rlap{=}}{\sf \kern .1em C}} - + \protect{\rlap{=}}{\sf \kern .1em C}} + % Title Page % ----- ---- @@ -949,207 +945,202 @@ \def \@titlebanner {} \renewcommand{\title}[1]{% - \gdef \@titletext {#1}} + \gdef \@titletext {#1}} \newcommand{\subtitle}[1]{% - \gdef \@subtitletext {#1}} + \gdef \@subtitletext {#1}} \newcommand{\authorinfo}[3]{% {names}{affiliation}{email/URL} - \global\@increment \@authorcount - \@withname\gdef {\@authorname\romannumeral\@authorcount}{#1}% - \@withname\gdef {\@authoraffil\romannumeral\@authorcount}{#2}% - \@withname\gdef {\@authoremail\romannumeral\@authorcount}{#3}} + \global\@increment \@authorcount + \@withname\gdef {\@authorname\romannumeral\@authorcount}{#1}% + \@withname\gdef {\@authoraffil\romannumeral\@authorcount}{#2}% + \@withname\gdef {\@authoremail\romannumeral\@authorcount}{#3}} \renewcommand{\author}[1]{% - \@latex@error{The \string\author\space command is obsolete; - use \string\authorinfo}{}} + \@latex@error{The \string\author\space command is obsolete; + use \string\authorinfo}{}} \newcommand{\titlebanner}[1]{% - \gdef \@titlebanner {#1}} + \gdef \@titlebanner {#1}} \renewcommand{\maketitle}{% - \pagestyle{plain}% - \if \@onecolumn - {\hsize = \standardtextwidth - \@maketitle}% - \else - \twocolumn[\@maketitle]% - \fi - \@placetitlenotes - \if \@copyrightwanted \@copyrightspace \fi} + \pagestyle{plain}% + \if \@onecolumn + {\hsize = \standardtextwidth + \@maketitle}% + \else + \twocolumn[\@maketitle]% + \fi + \@placetitlenotes + \if \@copyrightwanted \@copyrightspace \fi} \def \@maketitle {% - \begin{center} - \@settitlebanner - \let \thanks = \titlenote - {\leftskip = 0pt plus 0.25\linewidth - \rightskip = 0pt plus 0.25 \linewidth - \parfillskip = 0pt - \spaceskip = .7em - \noindent \LARGE \bfseries \@titletext \par} - \vskip 6pt - \noindent \Large \@subtitletext \par - \vskip 12pt - \ifcase \@authorcount - \@latex@error{No authors were specified for this paper}{}\or - \@titleauthors{i}{}{}\or - \@titleauthors{i}{ii}{}\or - \@titleauthors{i}{ii}{iii}\or - \@titleauthors{i}{ii}{iii}\@titleauthors{iv}{}{}\or - \@titleauthors{i}{ii}{iii}\@titleauthors{iv}{v}{}\or - \@titleauthors{i}{ii}{iii}\@titleauthors{iv}{v}{vi}\or - \@titleauthors{i}{ii}{iii}\@titleauthors{iv}{v}{vi}% - \@titleauthors{vii}{}{}\or - \@titleauthors{i}{ii}{iii}\@titleauthors{iv}{v}{vi}% - \@titleauthors{vii}{viii}{}\or - \@titleauthors{i}{ii}{iii}\@titleauthors{iv}{v}{vi}% - \@titleauthors{vii}{viii}{ix}\or - \@titleauthors{i}{ii}{iii}\@titleauthors{iv}{v}{vi}% - \@titleauthors{vii}{viii}{ix}\@titleauthors{x}{}{}\or - \@titleauthors{i}{ii}{iii}\@titleauthors{iv}{v}{vi}% - \@titleauthors{vii}{viii}{ix}\@titleauthors{x}{xi}{}\or - \@titleauthors{i}{ii}{iii}\@titleauthors{iv}{v}{vi}% - \@titleauthors{vii}{viii}{ix}\@titleauthors{x}{xi}{xii}% - \else - \@latex@error{Cannot handle more than 12 authors}{}% - \fi - \vspace{1.75pc} - \end{center}} + \begin{center} + \@settitlebanner + \let \thanks = \titlenote + \noindent \LARGE \bfseries \@titletext \par + \vskip 6pt + \noindent \Large \@subtitletext \par + \vskip 12pt + \ifcase \@authorcount + \@latex@error{No authors were specified for this paper}{}\or + \@titleauthors{i}{}{}\or + \@titleauthors{i}{ii}{}\or + \@titleauthors{i}{ii}{iii}\or + \@titleauthors{i}{ii}{iii}\@titleauthors{iv}{}{}\or + \@titleauthors{i}{ii}{iii}\@titleauthors{iv}{v}{}\or + \@titleauthors{i}{ii}{iii}\@titleauthors{iv}{v}{vi}\or + \@titleauthors{i}{ii}{iii}\@titleauthors{iv}{v}{vi}% + \@titleauthors{vii}{}{}\or + \@titleauthors{i}{ii}{iii}\@titleauthors{iv}{v}{vi}% + \@titleauthors{vii}{viii}{}\or + \@titleauthors{i}{ii}{iii}\@titleauthors{iv}{v}{vi}% + \@titleauthors{vii}{viii}{ix}\or + \@titleauthors{i}{ii}{iii}\@titleauthors{iv}{v}{vi}% + \@titleauthors{vii}{viii}{ix}\@titleauthors{x}{}{}\or + \@titleauthors{i}{ii}{iii}\@titleauthors{iv}{v}{vi}% + \@titleauthors{vii}{viii}{ix}\@titleauthors{x}{xi}{}\or + \@titleauthors{i}{ii}{iii}\@titleauthors{iv}{v}{vi}% + \@titleauthors{vii}{viii}{ix}\@titleauthors{x}{xi}{xii}% + \else + \@latex@error{Cannot handle more than 12 authors}{}% + \fi + \vspace{1.75pc} + \end{center}} \def \@settitlebanner {% - \if \@andp{\@preprint}{\@notp{\@emptydefp{\@titlebanner}}}% - \vbox to 0pt{% - \vskip -32pt - \noindent \textbf{\@titlebanner}\par - \vss}% - \nointerlineskip - \fi} + \if \@andp{\@preprint}{\@notp{\@emptydefp{\@titlebanner}}}% + \vbox to 0pt{% + \vskip -32pt + \noindent \textbf{\@titlebanner}\par + \vss}% + \nointerlineskip + \fi} \def \@titleauthors #1#2#3{% - \if \@andp{\@emptyargp{#2}}{\@emptyargp{#3}}% - \noindent \@setauthor{40pc}{#1}{\@false}\par - \else\if \@emptyargp{#3}% - \noindent \@setauthor{17pc}{#1}{\@false}\hspace{3pc}% - \@setauthor{17pc}{#2}{\@false}\par - \else - \noindent \@setauthor{12.5pc}{#1}{\@false}\hspace{2pc}% - \@setauthor{12.5pc}{#2}{\@false}\hspace{2pc}% - \@setauthor{12.5pc}{#3}{\@true}\par - \relax - \fi\fi - \vspace{20pt}} + \if \@andp{\@emptyargp{#2}}{\@emptyargp{#3}}% + \noindent \@setauthor{40pc}{#1}{\@false}\par + \else\if \@emptyargp{#3}% + \noindent \@setauthor{17pc}{#1}{\@false}\hspace{3pc}% + \@setauthor{17pc}{#2}{\@false}\par + \else + \noindent \@setauthor{12.5pc}{#1}{\@false}\hspace{2pc}% + \@setauthor{12.5pc}{#2}{\@false}\hspace{2pc}% + \@setauthor{12.5pc}{#3}{\@true}\par + \relax + \fi\fi + \vspace{20pt}} \def \@setauthor #1#2#3{% {width}{text}{unused} - \vtop{% - \def \and {% - \hspace{16pt}} - \hsize = #1 - \normalfont - \centering - \large \@name{\@authorname#2}\par - \vspace{5pt} - \normalsize \@name{\@authoraffil#2}\par - \vspace{2pt} - \textsf{\@name{\@authoremail#2}}\par}} + \vtop{% + \def \and {% + \hspace{16pt}} + \hsize = #1 + \normalfont + \centering + \large \@name{\@authorname#2}\par + \vspace{5pt} + \normalsize \@name{\@authoraffil#2}\par + \vspace{2pt} + \textsf{\@name{\@authoremail#2}}\par}} \def \@maybetitlenote #1{% - \if \@andp{#1}{\@gtrp{\@authorcount}{3}}% - \titlenote{See page~\pageref{@addauthors} for additional authors.}% - \fi} + \if \@andp{#1}{\@gtrp{\@authorcount}{3}}% + \titlenote{See page~\pageref{@addauthors} for additional authors.}% + \fi} \newtoks{\@fnmark} \newcommand{\titlenote}[1]{% - \global\@increment \@titlenotecount - \ifcase \@titlenotecount \relax \or - \@fnmark = {\ast}\or - \@fnmark = {\dagger}\or - \@fnmark = {\ddagger}\or - \@fnmark = {\S}\or - \@fnmark = {\P}\or - \@fnmark = {\ast\ast}% - \fi - \,$^{\the\@fnmark}$% - \edef \reserved@a {\noexpand\@appendtotext{% - \noexpand\@titlefootnote{\the\@fnmark}}}% - \reserved@a{#1}} + \global\@increment \@titlenotecount + \ifcase \@titlenotecount \relax \or + \@fnmark = {\ast}\or + \@fnmark = {\dagger}\or + \@fnmark = {\ddagger}\or + \@fnmark = {\S}\or + \@fnmark = {\P}\or + \@fnmark = {\ast\ast}% + \fi +% \,$^{\the\@fnmark}$% + \edef \reserved@a {\noexpand\@appendtotext{% + \noexpand\@titlefootnote{\the\@fnmark}}}% + \reserved@a{#1}} \def \@appendtotext #1#2{% - \global\@titlenotetext = \expandafter{\the\@titlenotetext #1{#2}}} + \global\@titlenotetext = \expandafter{\the\@titlenotetext #1{#2}}} \newcount{\@authori} \iffalse \def \additionalauthors {% - \if \@gtrp{\@authorcount}{3}% - \section{Additional Authors}% - \label{@addauthors}% - \noindent - \@authori = 4 - {\let \\ = ,% - \loop - \textbf{\@name{\@authorname\romannumeral\@authori}}, - \@name{\@authoraffil\romannumeral\@authori}, - email: \@name{\@authoremail\romannumeral\@authori}.% - \@increment \@authori - \if \@notp{\@gtrp{\@authori}{\@authorcount}} \repeat}% - \par - \fi - \global\@setflag \@addauthorsdone = \@true} + \if \@gtrp{\@authorcount}{3}% + \section{Additional Authors}% + \label{@addauthors}% + \noindent + \@authori = 4 + {\let \\ = ,% + \loop + \textbf{\@name{\@authorname\romannumeral\@authori}}, + \@name{\@authoraffil\romannumeral\@authori}, + email: \@name{\@authoremail\romannumeral\@authori}.% + \@increment \@authori + \if \@notp{\@gtrp{\@authori}{\@authorcount}} \repeat}% + \par + \fi + \global\@setflag \@addauthorsdone = \@true} \fi \let \addauthorsection = \additionalauthors \def \@placetitlenotes { - \the\@titlenotetext} - + \the\@titlenotetext} + % Utilities % --------- \newcommand{\centeroncapheight}[1]{% - {\setbox\@tempboxa = \hbox{#1}% - \@measurecapheight{\@tempdima}% % Calculate ht(CAP) - ht(text) - \advance \@tempdima by -\ht\@tempboxa % ------------------ - \divide \@tempdima by 2 % 2 - \raise \@tempdima \box\@tempboxa}} + {\setbox\@tempboxa = \hbox{#1}% + \@measurecapheight{\@tempdima}% % Calculate ht(CAP) - ht(text) + \advance \@tempdima by -\ht\@tempboxa % ------------------ + \divide \@tempdima by 2 % 2 + \raise \@tempdima \box\@tempboxa}} \newbox{\@measbox} \def \@measurecapheight #1{% {\dimen} - \setbox\@measbox = \hbox{ABCDEFGHIJKLMNOPQRSTUVWXYZ}% - #1 = \ht\@measbox} + \setbox\@measbox = \hbox{ABCDEFGHIJKLMNOPQRSTUVWXYZ}% + #1 = \ht\@measbox} \long\def \@titlefootnote #1#2{% - \insert\footins{% - \reset@font\footnotesize - \interlinepenalty\interfootnotelinepenalty - \splittopskip\footnotesep - \splitmaxdepth \dp\strutbox \floatingpenalty \@MM - \hsize\columnwidth \@parboxrestore + \insert\footins{% + \reset@font\footnotesize + \interlinepenalty\interfootnotelinepenalty + \splittopskip\footnotesep + \splitmaxdepth \dp\strutbox \floatingpenalty \@MM + \hsize\columnwidth \@parboxrestore %%% \protected@edef\@currentlabel{% %%% \csname p@footnote\endcsname\@thefnmark}% - \color@begingroup - \def \@makefnmark {$^{#1}$}% - \@makefntext{% - \rule\z@\footnotesep\ignorespaces#2\@finalstrut\strutbox}% - \color@endgroup}} - + \color@begingroup + \def \@makefnmark {$^{#1}$}% + \@makefntext{% + \rule\z@\footnotesep\ignorespaces#2\@finalstrut\strutbox}% + \color@endgroup}} + % LaTeX Modifications % ----- ------------- \def \@seccntformat #1{% - \@name{\the#1}% - \@expandaftertwice\@seccntformata \csname the#1\endcsname.\@mark - \quad} + \@name{\the#1}% + \@expandaftertwice\@seccntformata \csname the#1\endcsname.\@mark + \quad} \def \@seccntformata #1.#2\@mark{% - \if \@emptyargp{#2}.\fi} - + \if \@emptyargp{#2}.\fi} + % Revision History % -------- ------- -% SNC = Stephen Chong (chong@seas.harvard.edu) % Date Person Ver. Change % ---- ------ ---- ------ @@ -1205,18 +1196,9 @@ % 2006.08.24 PCA 1.4 Fix bug in \maketitle case command. -% 2007.03.13 PCA 1.5 The title banner only displays with the +% 2007.03.13 PCA 1.5 The title banner only display with the % 'preprint' option. % 2007.06.06 PCA 1.6 Use \bibfont in \thebibliography. % Add 'natbib' option to load and configure % the natbib package. - -% 2007.11.20 PCA 1.7 Balance line lengths in centered article -% title (thanks to Norman Ramsey). - -% 2009.01.26 PCA 1.8 Change natbib \bibpunct values. - -% 2009.04.29 SNC 1.9 Added \reprintprice to allow the -% specification of the price of a reprint, and -% set it to default to \$10.00 diff --git a/collects/scribblings/draw/bitmap-class.scrbl b/collects/scribblings/draw/bitmap-class.scrbl index 84b4d14d1b..9d2cd6783a 100644 --- a/collects/scribblings/draw/bitmap-class.scrbl +++ b/collects/scribblings/draw/bitmap-class.scrbl @@ -12,6 +12,9 @@ Sometimes, a bitmap object creation fails in a low-level manner. In the bitmap cannot be supplied to methods that consume or operate on bitmaps (otherwise, @|MismatchExn|). +A bitmap is convertible to @racket['png-bytes] through the +@racketmodname[file/convertible] protocol. + @defconstructor*/make[(([width exact-positive-integer?] [height exact-positive-integer?] @@ -83,14 +86,6 @@ monochrome bitmap and @racket[32] for a color bitmap. See also } -@defmethod[(get-gl-config [config (is-a?/c gl-config%)]) - void?]{ - -Returns a copy of this bitmap's requested OpenGL configuration. See - also @method[bitmap% set-gl-config]. - -} - @defmethod[(get-height) exact-positive-integer?]{ @@ -229,12 +224,12 @@ Returns @scheme[#t] if the bitmap is usable (created or changed } -@defmethod[(save-file [name path-string?] +@defmethod[(save-file [name (or/c path-string? output-port?)] [kind (one-of/c 'png 'jpeg 'xbm 'xpm 'bmp)] [quality (integer-in 0 100) 75]) boolean?]{ -Saves a bitmap in the named file. +Writes a bitmap to the named file or output stream. The @scheme[kind] argument determined the type of file that is created, one of: @@ -282,18 +277,6 @@ bitmap does not have to be selected into the DC. } -@defmethod[(set-gl-config [config (is-a?/c gl-config%)]) - void?]{ - -Sets the requested OpenGL configuration for this bitmap. The - configuration is used when the bitmap selected into a drawing - context, and then a GL context is created for the drawing context. - -The given @scheme[gl-config%] object is copied, so that changes to - the object do not affect the bitmap's configuration. - -} - @defmethod[(set-loaded-mask [mask (is-a?/c bitmap%)]) void?]{ diff --git a/collects/scribblings/draw/bitmap-dc-class.scrbl b/collects/scribblings/draw/bitmap-dc-class.scrbl index ac591d7c98..4200395217 100644 --- a/collects/scribblings/draw/bitmap-dc-class.scrbl +++ b/collects/scribblings/draw/bitmap-dc-class.scrbl @@ -39,10 +39,14 @@ Creates a new memory DC. If @scheme[bitmap] is not @scheme[#f], it is [mask (or/c (is-a?/c bitmap%) false/c)]) boolean?]{ -The same as @method[dc<%> draw-bitmap-section]. In older version, this - method smoothed drawing more than @method[dc<%> draw-bitmap-section], but - smoothing is now provided by @method[dc<%> draw-bitmap-section]. +The same as @method[dc<%> draw-bitmap-section], except that + @racket[dest-width] and @racket[dest-height] cause the DC's + transformation to be adjusted while drawing the bitmap so + that the bitmap is scaled. +In older versions, this method smoothed drawing more than + @method[dc<%> draw-bitmap-section], but smoothing is now provided by + @method[dc<%> draw-bitmap-section]. } @defmethod[(get-argb-pixels [x real?] diff --git a/collects/scribblings/draw/brush-class.scrbl b/collects/scribblings/draw/brush-class.scrbl index 66a5caaf17..b41f60e65f 100644 --- a/collects/scribblings/draw/brush-class.scrbl +++ b/collects/scribblings/draw/brush-class.scrbl @@ -4,15 +4,13 @@ @defclass/title[brush% object% ()]{ A brush is a drawing tool with a color and a style that is used for - filling in areas, such as the interior of a rectangle or ellipse. On - a monochrome display, all non-white brushes are drawn as black. + filling in areas, such as the interior of a rectangle or ellipse. In + a monochrome destination, all non-white brushes are drawn as black. In addition to its color and style, a brush can have a stipple bitmap. - This stipple is used only in unsmoothed mode (see @method[dc<%> - set-smoothing]) or in a PostScript drawing context. Painting with a + Painting with a stipple brush is similar to calling @method[dc<%> draw-bitmap] with - the stipple bitmap in the filled region, except that the bitmap may - not be scaled in the same way (depending on the platform and device). + the stipple bitmap in the filled region. A brush's style is one of the following: @@ -27,34 +25,19 @@ A brush's style is one of the following: brush's color, and white pixels from the stipple are not transferred.} - @item{@indexed-scheme['opaque] --- Same as @scheme['solid], except when a - monochrome stipple is installed for unsmoothed or PostScript - drawing; in that case, white pixels from the stipple are + @item{@indexed-scheme['opaque] --- The same as @scheme['solid] for a color + stipple. For a monochrome stipple, white pixels from + the stipple are transferred to the destination using the destination's background color.} - @item{@indexed-scheme['xor] --- In a smoothing mode or if a color - stipple is installed, @scheme['xor] is treated as - @scheme['solid]. Otherwise, the brush's color or colored - (monochrome) stipple is xor-ed with existing destination pixel - values. The @scheme['xor] mapping is unspecified for arbitrary - color combinations, but the mapping provides two guarantees: + @item{@indexed-scheme['xor] --- The same as @racket['solid], accepted + only for partial backward compatibility.} - @itemize[ + @item{@indexed-scheme['hilite] --- Draws with black and a @racket[0.3] alpha.} - @item{Black-and-white drawing to a color or monochrome - destination always works as expected: black xor white = black, - white xor black = black, black xor black = white, and white xor - white = white.} - - @item{Performing the same drawing operation twice in a row with - @scheme['xor] is equivalent to a no-op.} - - ]} - - @item{@indexed-scheme['hilite] --- Draws with black and a 30% alpha.} - - @item{@indexed-scheme['panel] --- the same as @scheme['solid].} + @item{@indexed-scheme['panel] --- The same as @scheme['solid], accepted + only for partial backward compatibility.} @item{The following modes correspond to built-in stipples drawn in @scheme['solid] mode: @@ -68,9 +51,8 @@ A brush's style is one of the following: @item{@indexed-scheme['vertical-hatch] --- vertical lines} ] - However, when a specific stipple is installed into the brush - for when drawing with a smoothing mode into a non-PostScript - context, the above modes are ignored and @scheme['solid] is + However, when a specific stipple is installed into the brush, + the above modes are ignored and @scheme['solid] is used, instead.} ] @@ -86,22 +68,17 @@ To avoid creating multiple brushes with the same characteristics, use @xmethod[dc<%> set-brush]. -@defconstructor*/make[(() - ([color (is-a?/c color%)] - [style (one-of/c 'transparent 'solid 'opaque - 'xor 'hilite 'panel - 'bdiagonal-hatch 'crossdiag-hatch - 'fdiagonal-hatch 'cross-hatch - 'horizontal-hatch 'vertical-hatch)]) - ([color-name string?] - [style (one-of/c 'transparent 'solid 'opaque - 'xor 'hilite 'panel - 'bdiagonal-hatch 'crossdiag-hatch - 'fdiagonal-hatch 'cross-hatch - 'horizontal-hatch 'vertical-hatch)]))]{ +@defconstructor[([color (or/c string? (is-a?/c color%)) "black"] + [style (one-of/c 'transparent 'solid 'opaque + 'xor 'hilite 'panel + 'bdiagonal-hatch 'crossdiag-hatch + 'fdiagonal-hatch 'cross-hatch + 'horizontal-hatch 'vertical-hatch) + 'solid] + [stipple (or/c #f (is-a?/c bitmap%)) + #f])]{ -When no argument are provided, the result is a solid black brush. - Otherwise, the result is a brush with the given color and style. For +Creates a brush with the given color, style, and stipple. For the case that the color is specified using a name, see @scheme[color-database<%>] for information about color names; if the name is not known, the brush's color is black. @@ -152,7 +129,7 @@ For the case that the color is specified using a string, see } -@defmethod[(set-stipple [bitmap (or/c (is-a?/c bitmap%) false/c)]) +@defmethod[(set-stipple [bitmap (or/c (is-a?/c bitmap%) #f)]) void?]{ Sets or removes the stipple bitmap, where @scheme[#f] removes the @@ -165,9 +142,6 @@ A bitmap cannot be used as a stipple if it is selected into a modified if it was obtained from a @scheme[brush-list%] or while it is selected into a drawing context. -A pen's stipple is not used in a smoothing mode, except for a - @scheme[post-script-dc%] (which is always in a smoothing mode). - } @defmethod[(set-style [style (one-of/c 'transparent 'solid 'opaque diff --git a/collects/scribblings/draw/dc-intf.scrbl b/collects/scribblings/draw/dc-intf.scrbl index 4668ba8295..c870723184 100644 --- a/collects/scribblings/draw/dc-intf.scrbl +++ b/collects/scribblings/draw/dc-intf.scrbl @@ -88,7 +88,7 @@ If both the pen and brush are non-transparent, the wedge is filled [mask (or/c (is-a?/c bitmap%) false/c) #f]) boolean?]{ -Displays a bitmap. The @scheme[dest-x] and @scheme[dest-y] arguments +Displays the @racket[source] bitmap. The @scheme[dest-x] and @scheme[dest-y] arguments are in DC coordinates. For color bitmaps, the drawing style and color arguments are @@ -97,30 +97,33 @@ For color bitmaps, the drawing style and color arguments are and color settings to draw a monochrome stipple (see @scheme[brush%] for more information). -If a mask bitmap is supplied, it must have the same width and height - as the bitmap to display, and its @method[bitmap% ok?] must return - true, otherwise @|MismatchExn|. The bitmap to draw and the mask +If a @racket[mask] bitmap is supplied, it must have the same width and height + as @racket[source], and its @method[bitmap% ok?] must return + true, otherwise @|MismatchExn|. The @racket[source] bitmap and @racket[mask] bitmap can be the same object, but if the drawing context is a @scheme[bitmap-dc%] object, both bitmaps must be distinct from the destination bitmap, otherwise @|MismatchExn|. -If the mask bitmap is monochrome, drawing occurs in the target - @scheme[dc<%>] only where the mask bitmap contains black pixels. +If the @racket[mask] bitmap is monochrome, drawing occurs in the + target @scheme[dc<%>] only where the mask bitmap contains black + pixels (independent of @racket[style], which controls how the white + pixels of a monochrome @racket[source] are handled). -If the mask bitmap is grayscale and the bitmap to draw is not - monochrome, then the blackness of each mask pixel controls the - opacity of the drawn pixel (i.e., the mask acts as an inverted alpha - channel). If a mask bitmap is color, the component values of a given - pixel are averaged to arrive at a gray value for the pixel. +If the @racket[mask] bitmap is grayscale, then the blackness of each + mask pixel controls the opacity of the drawn pixel (i.e., the mask + acts as an inverted alpha channel). If the @racket[mask] bitmap is + color, the component values of a given pixel are averaged to arrive + at an @racket[alpha] value for the pixel. -The current brush, current pen, current text, and current alpha - settings for the DC have no effect on how the bitmap is drawn, but - the bitmap is scaled if the DC has a scale. +The current brush, current pen, and current text for the DC have no + effect on how the bitmap is drawn, but the bitmap is scaled if the DC + has a scale, and the DC's alpha setting determines the opacity of the + drawn pixels (in combination with an alpha channel of @racket[bitmap] + and any given @racket[mask]). -For @scheme[post-script-dc%] output, the mask bitmap is currently - ignored, and the @scheme['solid] style is treated the same as - @scheme['opaque]. (However, mask bitmaps and @scheme['solid] drawing - may become supported for @scheme[post-script-dc%] in the future.) +For @scheme[post-script-dc%] and @racket[pdf-dc%] output, opacity from + an alpha channel in @racket[bitmap] or from @racket[mask] is + rounded to full transparency or opacity. The result is @scheme[#t] if the bitmap is successfully drawn, @scheme[#f] otherwise (possibly because the bitmap's @method[bitmap% @@ -987,15 +990,6 @@ The @scheme['aligned] smoothing mode is like @scheme['smoothed], but @method[dc<%> draw-rounded-rectangle], and @method[dc<%> draw-arc], the given width and height are each decreased by @math{1.0}. -In either smoothing mode, brush and pen stipples are ignored (except - for PostScript drawing), and @scheme['hilite] and @scheme['xor] - drawing modes are treated as @scheme['solid]. If smoothing is not - supported, then attempting to set the smoothing mode to - @scheme['smoothed] or @scheme['aligned] will have no effect, and - @method[dc<%> get-smoothing] will always return - @scheme['unsmoothed]. Similarly, @method[dc<%> get-smoothing] for a - @scheme[post-script-dc%] always returns @scheme['smoothed]. - } @defmethod[(set-text-background [color (is-a?/c color%)]) diff --git a/collects/scribblings/draw/draw-unit.scrbl b/collects/scribblings/draw/draw-unit.scrbl new file mode 100644 index 0000000000..d3eac9b8ba --- /dev/null +++ b/collects/scribblings/draw/draw-unit.scrbl @@ -0,0 +1,26 @@ +#lang scribble/doc +@(require "common.ss" + (for-label racket/draw/draw-unit + racket/draw/draw-sig)) + +@title{Signature and Unit} + +The @racketmodname[racket/draw/draw-sig] and +@racketmodname[racket/draw/draw-unit] libraries define the +@racket[draw^] signature and @racket[draw@] implementation. + +@section{Draw Unit} + +@defmodule[racket/draw/draw-unit] + +@defthing[draw@ unit?]{ +Re-exports all of the exports of @racketmodname[racket/draw].} + + +@section{Draw Signature} + +@defmodule[racket/draw/draw-sig] + +@defsignature[draw^ ()] + +Includes all of the identifiers exported by @racketmodname[racket/draw]. diff --git a/collects/scribblings/draw/draw.scrbl b/collects/scribblings/draw/draw.scrbl index 3787105685..0d7bc3c38f 100644 --- a/collects/scribblings/draw/draw.scrbl +++ b/collects/scribblings/draw/draw.scrbl @@ -16,7 +16,28 @@ interface, and procedure bindings defined in this manual.} @;------------------------------------------------------------------------ @include-section["guide.scrbl"] -@include-section["reference.scrbl"] +@include-section["bitmap-class.scrbl"] +@include-section["bitmap-dc-class.scrbl"] +@include-section["brush-class.scrbl"] +@include-section["brush-list-class.scrbl"] +@include-section["color-class.scrbl"] +@include-section["color-database-intf.scrbl"] +@include-section["dc-intf.scrbl"] +@include-section["dc-path-class.scrbl"] +@include-section["font-class.scrbl"] +@include-section["font-list-class.scrbl"] +@include-section["font-name-directory-intf.scrbl"] +@include-section["gl-config-class.scrbl"] +@include-section["gl-context-intf.scrbl"] +@include-section["pdf-dc-class.scrbl"] +@include-section["pen-class.scrbl"] +@include-section["pen-list-class.scrbl"] +@include-section["point-class.scrbl"] +@include-section["post-script-dc-class.scrbl"] +@include-section["ps-setup-class.scrbl"] +@include-section["region-class.scrbl"] +@include-section["draw-funcs.scrbl"] +@include-section["draw-unit.scrbl"] @;------------------------------------------------------------------------ diff --git a/collects/scribblings/draw/fire.png b/collects/scribblings/draw/fire.png new file mode 100644 index 0000000000..102b047c7b Binary files /dev/null and b/collects/scribblings/draw/fire.png differ diff --git a/collects/scribblings/draw/gl-config-class.scrbl b/collects/scribblings/draw/gl-config-class.scrbl index f7dcb607d6..69fc48701f 100644 --- a/collects/scribblings/draw/gl-config-class.scrbl +++ b/collects/scribblings/draw/gl-config-class.scrbl @@ -5,8 +5,8 @@ A @scheme[gl-config%] object encapsulates configuration information for an OpenGL drawing context. Use a @scheme[gl-config%] object as an - initialization argument for @scheme[canvas%], or provide it to - @xmethod[bitmap% set-gl-config]. + initialization argument for @scheme[canvas%] or provide it to + @racket[make-gl-bitmap]. @defconstructor[()]{ diff --git a/collects/scribblings/draw/guide.scrbl b/collects/scribblings/draw/guide.scrbl index d3e912ed6a..9b40ce1708 100644 --- a/collects/scribblings/draw/guide.scrbl +++ b/collects/scribblings/draw/guide.scrbl @@ -1,10 +1,89 @@ #lang scribble/doc -@(require scribble/eval - "common.ss") +@(require scribble/manual + "common.ss" + scribble/eval + scribble/racket + (for-syntax racket/base) + (for-label racket/math)) + +@(define draw-eval (make-base-eval)) +@interaction-eval[#:eval draw-eval (require racket/class + racket/draw)] +@interaction-eval[#:eval draw-eval (define (copy-bitmap bm0) + (let ([w (send bm0 get-width)] + [h (send bm0 get-height)]) + (let ([bm (make-bitmap w h)]) + (let ([dc (make-object bitmap-dc% bm)]) + (send dc draw-bitmap bm0 0 0) + (send dc set-bitmap #f)) + bm)))] +@interaction-eval[#:eval draw-eval (define (line-bitmap mode) + (let* ([bm (make-bitmap 30 4)] + [dc (make-object bitmap-dc% bm)]) + (send dc set-smoothing mode) + (send dc draw-line 0 2 30 2) + (send dc set-bitmap #f) + bm))] +@interaction-eval[#:eval draw-eval (define (path-bitmap zee join brush?) + (let* ([bm (make-bitmap 40 40)] + [dc (new bitmap-dc% [bitmap bm])]) + (send dc set-smoothing 'aligned) + (send dc set-pen (new pen% [width 5] [join join])) + (if brush? + (send dc set-brush blue-brush) + (send dc set-brush "white" 'transparent)) + (send dc draw-path zee 5 5) + (send dc set-bitmap #f) + bm))] + +@(define-syntax-rule (define-linked-method name interface) + (define-syntax name + (make-element-id-transformer + (lambda (stx) + #'(method interface name))))) +@(define-linked-method draw-line dc<%>) +@(define-linked-method draw-rectangle dc<%>) +@(define-linked-method set-pen dc<%>) +@(define-linked-method set-font dc<%>) +@(define-linked-method set-clipping-region dc<%>) +@(define-linked-method set-alpha dc<%>) +@(define-linked-method get-pen dc<%>) +@(define-linked-method set-brush dc<%>) +@(define-linked-method get-brush dc<%>) +@(define-linked-method set-smoothing dc<%>) +@(define-linked-method draw-path dc<%>) +@(define-linked-method draw-ellipse dc<%>) +@(define-linked-method draw-text dc<%>) +@(define-linked-method draw-bitmap dc<%>) +@(define-linked-method get-text-extent dc<%>) +@(define-linked-method set-text-foreground dc<%>) +@(define-linked-method draw-arc dc<%>) +@(define-linked-method erase dc<%>) +@(define-linked-method set-stipple brush%) +@(define-linked-method line-to dc-path%) +@(define-linked-method curve-to dc-path%) +@(define-linked-method move-to dc-path%) +@(define-linked-method append dc-path%) +@(define-linked-method arc dc-path%) +@(define-linked-method reverse dc-path%) +@(define-linked-method ellipse dc-path%) +@(define-linked-method translate dc<%>) +@(define-linked-method scale dc<%>) +@(define-linked-method rotate dc<%>) +@(define-linked-method set-path region%) @title[#:tag "overview"]{Overview} -Drawing with @racketmodname[racket/draw] uses a @deftech{device context} +The @racketmodname[racket/draw] library provides a drawing API that is +based on the PostScript drawing model. It supports line drawing, shape +filling, bitmap copying, alpha blending, and affine transformations +(i.e., scale, rotation, and translation). + +@margin-note{See @secref["classes" #:doc '(lib +"scribblings/guide/guide.scrbl")] for an introduction to classes and +interfaces in Racket.} + +Drawing with @racketmodname[racket/draw] requires a @deftech{drawing context} (@deftech{DC}), which is an instance of the @scheme[dc<%>] interface. For example, the @racket[post-script-dc%] class implements a @racket[dc<%>] for drawing to a PostScript file, while @racket[bitmap-dc%] @@ -13,215 +92,554 @@ the @method[canvas<%> get-dc] method of a canvas returns a @scheme[dc<%>] instance for drawing into the canvas window. -Tools that are used for drawing include the following: @scheme[pen%] - objects for drawing lines and shape outlines, @scheme[brush%] - objects for filling shapes, @scheme[bitmap%] objects for storing - bitmaps, and @scheme[dc-path%] objects for describing paths to draw - and fill. +@margin-note{See @secref["canvas-drawing" #:doc '(lib +"scribblings/gui/gui.scrbl")] for an introduction to drawing +in a GUI window.} -The following example uses the GUI library as well as the drawing - library. It creates a frame with a drawing canvas, and then draws a - round, blue face with square, yellow eyes and a smiling, red mouth: +@; ------------------------------------------------------------ +@section{Lines and Simple Shapes} -@schemeblock[ -(code:comment @#,t{Make some pens and brushes}) -(define no-pen (make-object pen% "BLACK" 1 'transparent)) -(define no-brush (make-object brush% "BLACK" 'transparent)) -(define blue-brush (make-object brush% "BLUE" 'solid)) -(define yellow-brush (make-object brush% "YELLOW" 'solid)) -(define red-pen (make-object pen% "RED" 2 'solid)) +To draw into a bitmap, first create the bitmap with +@racket[make-bitmap], and then create a @racket[bitmap-dc%] that draws +into the new bitmap: + +@racketblock+eval[ +#:eval draw-eval +(define target (make-bitmap 30 30)) (code:comment "A 30x30 bitmap") +(define dc (new bitmap-dc% [bitmap target])) +] + +Then, use methods like @method[dc<%> draw-line] on the @tech{DC} to draw +into the bitmap. For example, the sequence + +@racketblock+eval[ +#:eval draw-eval +(send dc draw-rectangle + 0 10 (code:comment @#,t{Top-left at (0, 10), 10 pixels down from top-left}) + 30 10) (code:comment @#,t{30 pixels wide and 10 pixels high}) +(send dc draw-line + 0 0 (code:comment @#,t{Start at (0, 0), the top-left corner}) + 30 30) (code:comment @#,t{and draw to (30, 30), the bottom-right corner}) +(send dc draw-line + 0 30 (code:comment @#,t{Start at (0, 30), the bottom-left corner}) + 30 0) (code:comment @#,t{and draw to (30, 0), the top-right corner}) +] + +draws an ``X'' on top of a smaller rectangle into the bitmap @racket[target]. If +you save the bitmap to a file with @racket[(send target #,(:: bitmap% save-file) +"box.png" 'png)], the @filepath{box.png} contains the image + +@centered{@interaction-eval-show[#:eval draw-eval (copy-bitmap target)]} + +in PNG format. + +A line-drawing drawing operation like @racket[draw-line] uses the +@tech{DC}'s current @defterm{pen} to draw the line. A pen has a color, +line width, and style, where pen styles include @racket['solid], +@racket['long-dash], and @racket['transparent]. Enclosed-shape +operations like @racket[draw-rectangle] use both the current pen and +the @tech{DC}'s current @deftech{brush}. A brush has a color and style, +where brush styles include @racket['solid], @racket['cross-hatch], and +@racket['transparent]. + +@margin-note{In DrRacket, instead of saving @racket[target] to a file +viewing the image from the file, you can use @racket[(require +racket/gui)] and @racket[(make-object image-snip% target)] to view the +bitmap in the DrRacket interactions window.} + +For example, set the brush and pen before the drawing operations to +draw a thick, red ``X'' on a green rectangle with a thin, blue border: + +@racketblock+eval[ +#:eval draw-eval +(send dc set-brush "green" 'solid) +(send dc set-pen "blue" 1 'solid) +(send dc draw-rectangle 0 10 30 10) +(send dc set-pen "red" 3 'solid) +(send dc draw-line 0 0 30 30) +(send dc draw-line 0 30 30 0) +] + +@centered{@interaction-eval-show[#:eval draw-eval (copy-bitmap target)]} + +To draw a filled shape without an outline, set the pen to +@racket['transparent] mode (with any color and line width). For +example, + +@racketblock+eval[ +#:eval draw-eval +(send dc set-pen "white" 1 'transparent) +(send dc set-brush "black" 'solid) +(send dc draw-ellipse 5 5 20 20) +] + +@centered{@interaction-eval-show[#:eval draw-eval (copy-bitmap target)]} + +By default, a @racket[bitmap-dc%] draws solid pixels without smoothing +the boundaries of shapes. To enable smoothing, set the +smoothing mode to either @racket['smoothed] or @racket['aligned]: + +@racketblock+eval[ +#:eval draw-eval +(send dc set-smoothing 'aligned) +(send dc set-brush "black" 'solid) +(send dc draw-ellipse 4 4 22 22) (code:comment @#,t{a little bigger}) +] + +@centered{@interaction-eval-show[#:eval draw-eval (copy-bitmap target)]} + +The difference between @racket['aligned] mode and @racket['smoothed] +mode is related to the relatively coarse granularity of pixels in a +bitmap. Conceptually, drawing coordinates correspond to the lines +between pixels, and the pen is centered on the line. In +@racket['smoothed] mode, drawing on a line causes the pen to draw at +half strength on either side of the line, which produces the following +result for a 1-pixel black pen: + +@centered[@interaction-eval-show[#:eval draw-eval (line-bitmap 'smoothed)]] + +but @racket['aligned] mode shifts drawing coordinates to make the pen +fall on whole pixels, so a 1-pixel black pen draws a single line of +pixels: + +@centered[@interaction-eval-show[#:eval draw-eval (line-bitmap 'aligned)]] + +@; ------------------------------------------------------------ +@section{Pen, Brush, and Color Objects} + +The @racket[set-pen] and @racket[set-brush] methods of a @tech{DC} + accept @scheme[pen%] and @scheme[brush%] objects, which group + together pen and brush settings. + +@schemeblock+eval[ +#:eval draw-eval +(require racket/math) + +(define no-pen (new pen% [style 'transparent])) +(define no-brush (new brush% [style 'transparent])) +(define blue-brush (new brush% [color "blue"])) +(define yellow-brush (new brush% [color "yellow"])) +(define red-pen (new pen% [color "red"] [width 2])) -(code:comment @#,t{Define a procedure to draw a face}) (define (draw-face dc) - (send dc #,(:: dc<%> set-pen) no-pen) - (send dc #,(:: dc<%> set-brush) blue-brush) - (send dc #,(:: dc<%> draw-ellipse) 50 50 200 200) + (send dc set-smoothing 'aligned) - (send dc #,(:: dc<%> set-brush) yellow-brush) - (send dc #,(:: dc<%> draw-rectangle) 100 100 10 10) - (send dc #,(:: dc<%> draw-rectangle) 200 100 10 10) + (send dc set-pen no-pen) + (send dc set-brush blue-brush) + (send dc draw-ellipse 25 25 100 100) - (send dc #,(:: dc<%> set-brush) no-brush) - (send dc #,(:: dc<%> set-pen) red-pen) - (let ([-pi (atan 0 -1)]) - (send dc #,(:: dc<%> draw-arc) 75 75 150 150 (* 5/4 -pi) (* 7/4 -pi)))) + (send dc set-brush yellow-brush) + (send dc draw-rectangle 50 50 10 10) + (send dc draw-rectangle 90 50 10 10) -(code:comment @#,t{Make a 300 x 300 frame}) -(define frame (new frame% [label "Drawing Example"] - [width 300] - [height 300])) -(code:comment @#,t{Make the drawing area, and set its paint callback}) -(code:comment @#,t{to use the @racket[draw-face] function:}) -(define canvas (new canvas% - [parent frame] - [paint-callback (lambda (c dc) (draw-face dc))])) + (send dc set-brush no-brush) + (send dc set-pen red-pen) + (send dc draw-arc 37 37 75 75 (* 5/4 pi) (* 7/4 pi))) -(code:comment @#,t{Show the frame}) -(send frame #,(:: top-level-window<%> show) #t) +(define target (make-bitmap 150 150)) +(define dc (new bitmap-dc% [bitmap target])) + +(draw-face dc) ] -Suppose that @scheme[draw-face] creates a particularly complex face that - takes a long time to draw. We might want to draw the face once into - an offscreen bitmap, and then have the paint callback copy the cached - bitmap image onto the canvas whenever the canvas is updated. To draw - into a bitmap, we first create a @scheme[bitmap%] object, and then - we create a @scheme[bitmap-dc%] to direct drawing commands into the - bitmap: +@centered{@interaction-eval-show[#:eval draw-eval (copy-bitmap target)]} -@schemeblock[ -(code:comment @#,t{... pens, brushes, and @scheme[draw-face] are the same as above ...}) - -(code:comment @#,t{Create a 300 x 300 bitmap}) -(define face-bitmap (make-object bitmap% 300 300)) -(code:comment @#,t{Create a drawing context for the bitmap}) -(define bm-dc (make-object bitmap-dc% face-bitmap)) -(code:comment @#,t{A bitmap's initial content is undefined; clear it before drawing}) -(send bm-dc #,(:: dc<%> clear)) - -(code:comment @#,t{Draw the face into the bitmap}) -(draw-face bm-dc) - -(code:comment @#,t{Make a 300 x 300 frame}) -(define frame (new frame% [label "Drawing Example"] - [width 300] - [height 300])) +The @racket[get-pen] and @racket[get-brush] methods return a +@tech{DC}'s current pen and brush, so they can be restored after +changing them temporarily for drawing. -(code:comment @#,t{Make a drawing area whose paint callback copies the bitmap}) -(define canvas - (new canvas% [parent frame] - [paint-callback - (lambda (canvas dc) - (send dc #,(:: dc<%> draw-bitmap) face-bitmap 0 0))])) - -(code:comment @#,t{Show the frame}) -(send frame #,(:: top-level-window<%> show) #t) +Besides grouping settings, a @racket[pen%] or @racket[brush%] object +includes extra settings that are not available by using +@racket[set-pen] or @racket[set-brush] directly. For example, a pen or +brush can have a @deftech{stipple}, which is a bitmap that is used +instead of a solid color when drawing. For example, if +@filepath{water.png} has the image + +@centered{@image["water.png"]} + +then it can be loaded with @racket[read-bitmap] and installed as the +stipple for @racket[blue-brush]: + +@schemeblock+eval[ +#:eval draw-eval +(send blue-brush set-stipple (read-bitmap "water.png")) +(send dc erase) +(draw-face dc) ] -For all types of DCs, the drawing origin is the top-left corner of the - DC. When drawing to a window or bitmap, DC units initially correspond - to pixels, but the @method[dc<%> set-scale] method changes the - scale. When drawing to a PostScript or printer device, DC units - initially correspond to points (1/72 of an inch). +@centered{@interaction-eval-show[#:eval draw-eval (copy-bitmap target)]} -More complex shapes are typically best implemented with - @deftech{paths}. The following example uses paths to draw the - Racket logo. It also enables smoothing, so that the logo's curves are - anti-aliased when smoothing is available. (Smoothing is always - available under Mac OS X, smoothing is available under Windows XP or - when @filepath{gdiplus.dll} is installed, and smoothing is available - under X when Cairo is installed before GRacket is compiled.) +Along similar lines, a @racket[color%] object lets you specify a color +through its red, green, and blue components instead of a built-in +color name. Due to the way that @racket[color%] initialization is +overloaded, use @racket[make-object%] instead of @racket[new] to +instantiate @racket[color%]: -@(begin -#readerscribble/comment-reader -[schemeblock -(require racket/math) ; for @scheme[pi] +@schemeblock+eval[ +#:eval draw-eval +(define red-pen + (new pen% [color (make-object color% 200 100 150)] [width 2])) +(send dc erase) +(draw-face dc) +] -;; Construct paths for a 630 x 630 logo +@centered{@interaction-eval-show[#:eval draw-eval (copy-bitmap target)]} -(define left-lambda-path ;; left side of the lambda + +@; ------------------------------------------------------------ +@section{Transformations} + +Any coordinates or lengths supplied to drawing commends are +transformed by a @tech{DC}'s current transformation matrix. The +transformation matrix can scale an image, draw it at an offset, or +rotate all drawing. The transformation can be set directly, or the +current transformation can be transformed further with methods like +@racket[scale], @racket[translate], or @racket[rotate]: + +@schemeblock+eval[ +#:eval draw-eval +(send dc erase) +(send dc scale 0.5 0.5) +(draw-face dc) +(send dc rotate (/ pi 2)) +(send dc translate 0 150) +(draw-face dc) +(send dc translate 0 -150) +(send dc rotate (/ pi 2)) +(send dc translate 150 150) +(draw-face dc) +(send dc translate -150 -150) +(send dc rotate (/ pi 2)) +(send dc translate 150 0) +(draw-face dc) +] + +Use the @method[dc<%> get-transformation] method to get a @tech{DC}'s +current transformation, and restore a saved transformation (or any +affine transformation) using @method[dc<%> set-transformation]. + +@centered{@interaction-eval-show[#:eval draw-eval (copy-bitmap target)]} + +@; ------------------------------------------------------------ +@section{Drawing Paths} + +Drawing functions like @racket[draw-line] and @racket[draw-rectangle] + are actually convenience functions for the more general + @racket[draw-path] operation. The @racket[draw-path] operation takes + a @deftech{path}, which describes a set of line segments and curves + to draw with the pen and---in the case of closed set of lines and + curves---fill with the current brush. + +An instance of @racket[dc-path%] holds a path. Conceptually, a path + has a current pen position that is manipulated by methods like + @racket[move-to], @racket[line-to], and @racket[curve-to]. The + @racket[move-to] method starts a sub-path, and @racket[line-to] and + @racket[curve-to] extend it. The @racket[close] method moves the pen + from its current position in a straight line to its starting + position, completing the sub-path and forming a closed path that can + be filled with the brush. A @racket[dc-path%] object can have + multiple closed sub-paths and one final open path, where the open + path is drawn only with the pen. + +For example, + +@racketblock+eval[ +#:eval draw-eval +(define zee (new dc-path%)) +(send zee move-to 0 0) +(send zee line-to 30 0) +(send zee line-to 0 30) +(send zee line-to 30 30) +] + +creates an open path. Drawing this path with a black pen of width 5 +and a transparent brush produces + +@centered{@interaction-eval-show[#:eval draw-eval (path-bitmap zee 'round #f)]} + +Drawing a single path with three line segments is not the same as +drawing three separate lines. When multiple line segments are drawn at +once, the corner frm one line to the next is shaped according to the +pen's join style. The image above uses the default @racket['round] +join style. With @racket['miter], line lines are joined with sharp +corners: + +@centered{@interaction-eval-show[#:eval draw-eval (path-bitmap zee 'miter #f)]} + +If the sub-path in @racket[zee] is closed with @racket[close], then +all of the corners are joined, including the corner at the initial +point: + +@racketblock+eval[ +#:eval draw-eval +(send zee close) +] + +@centered{@interaction-eval-show[#:eval draw-eval (path-bitmap zee 'miter #f)]} + +Using @racket[blue-brush] instead of a transparent brush causes the +interior of the path to be filled: + +@centered{@interaction-eval-show[#:eval draw-eval (path-bitmap zee 'miter #t)]} + +When a sub-path is not closed, it is implicitly closed for brush +filling, but left open for pen drawing. When both a pen and brush are +available (i.e., not transparent), then the brush is used first, so +that the pen draws on top of the brush. + +At this point we can't resist showing an extended example using +@racket[dc-path%] to draw the Racket logo: + +@racketblock+eval[ +#:eval draw-eval +(define red-brush (new brush% [stipple (read-bitmap "fire.png")])) + +(define left-lambda-path (let ([p (new dc-path%)]) - (send p #,(:: dc-path% move-to) 153 44) - (send p #,(:: dc-path% line-to) 161.5 60) - (send p #,(:: dc-path% curve-to) 202.5 49 230 42 245 61) - (send p #,(:: dc-path% curve-to) 280.06 105.41 287.5 141 296.5 186) - (send p #,(:: dc-path% curve-to) 301.12 209.08 299.11 223.38 293.96 244) - (send p #,(:: dc-path% curve-to) 281.34 294.54 259.18 331.61 233.5 375) - (send p #,(:: dc-path% curve-to) 198.21 434.63 164.68 505.6 125.5 564) - (send p #,(:: dc-path% line-to) 135 572) + (send p move-to 153 44) + (send p line-to 161.5 60) + (send p curve-to 202.5 49 230 42 245 61) + (send p curve-to 280.06 105.41 287.5 141 296.5 186) + (send p curve-to 301.12 209.08 299.11 223.38 293.96 244) + (send p curve-to 281.34 294.54 259.18 331.61 233.5 375) + (send p curve-to 198.21 434.63 164.68 505.6 125.5 564) + (send p line-to 135 572) p)) -(define left-logo-path ;; left side of the lambda and circle +(define left-logo-path (let ([p (new dc-path%)]) - (send p #,(:: dc-path% append) left-lambda-path) - (send p #,(:: dc-path% arc) 0 0 630 630 (* 235/360 2 pi) (* 121/360 2 pi) #f) + (send p append left-lambda-path) + (send p arc 0 0 630 630 (* 235/360 2 pi) (* 121/360 2 pi) #f) p)) (define bottom-lambda-path (let ([p (new dc-path%)]) - (send p #,(:: dc-path% move-to) 135 572) - (send p #,(:: dc-path% line-to) 188.5 564) - (send p #,(:: dc-path% curve-to) 208.5 517 230.91 465.21 251 420) - (send p #,(:: dc-path% curve-to) 267 384 278.5 348 296.5 312) - (send p #,(:: dc-path% curve-to) 301.01 302.98 318 258 329 274) - (send p #,(:: dc-path% curve-to) 338.89 288.39 351 314 358 332) - (send p #,(:: dc-path% curve-to) 377.28 381.58 395.57 429.61 414 477) - (send p #,(:: dc-path% curve-to) 428 513 436.5 540 449.5 573) - (send p #,(:: dc-path% line-to) 465 580) - (send p #,(:: dc-path% line-to) 529 545) + (send p move-to 135 572) + (send p line-to 188.5 564) + (send p curve-to 208.5 517 230.91 465.21 251 420) + (send p curve-to 267 384 278.5 348 296.5 312) + (send p curve-to 301.01 302.98 318 258 329 274) + (send p curve-to 338.89 288.39 351 314 358 332) + (send p curve-to 377.28 381.58 395.57 429.61 414 477) + (send p curve-to 428 513 436.5 540 449.5 573) + (send p line-to 465 580) + (send p line-to 529 545) p)) (define bottom-logo-path (let ([p (new dc-path%)]) - (send p #,(:: dc-path% append) bottom-lambda-path) - (send p #,(:: dc-path% arc) 0 0 630 630 (* 314/360 2 pi) (* 235/360 2 pi) #f) + (send p append bottom-lambda-path) + (send p arc 0 0 630 630 (* 314/360 2 pi) (* 235/360 2 pi) #f) p)) (define right-lambda-path (let ([p (new dc-path%)]) - (send p #,(:: dc-path% move-to) 153 44) - (send p #,(:: dc-path% curve-to) 192.21 30.69 233.21 14.23 275 20) - (send p #,(:: dc-path% curve-to) 328.6 27.4 350.23 103.08 364 151) - (send p #,(:: dc-path% curve-to) 378.75 202.32 400.5 244 418 294) - (send p #,(:: dc-path% curve-to) 446.56 375.6 494.5 456 530.5 537) - (send p #,(:: dc-path% line-to) 529 545) + (send p move-to 153 44) + (send p curve-to 192.21 30.69 233.21 14.23 275 20) + (send p curve-to 328.6 27.4 350.23 103.08 364 151) + (send p curve-to 378.75 202.32 400.5 244 418 294) + (send p curve-to 446.56 375.6 494.5 456 530.5 537) + (send p line-to 529 545) p)) (define right-logo-path (let ([p (new dc-path%)]) - (send p #,(:: dc-path% append) right-lambda-path) - (send p #,(:: dc-path% arc) 0 0 630 630 (* 314/360 2 pi) (* 121/360 2 pi) #t) + (send p append right-lambda-path) + (send p arc 0 0 630 630 (* 314/360 2 pi) (* 121/360 2 pi) #t) p)) -(define lambda-path ;; the lambda by itself (no circle) +(define lambda-path (let ([p (new dc-path%)]) - (send p #,(:: dc-path% append) left-lambda-path) - (send p #,(:: dc-path% append) bottom-lambda-path) - (let ([t (make-object dc-path%)]) - (send t #,(:: dc-path% append) right-lambda-path) - (send t #,(:: dc-path% reverse)) - (send p #,(:: dc-path% append) t)) - (send p #,(:: dc-path% close)) + (send p append left-lambda-path) + (send p append bottom-lambda-path) + (let ([t (new dc-path%)]) + (send t append right-lambda-path) + (send t reverse) + (send p append t)) + (send p close) p)) -;; This function draws the paths with suitable colors: -(define (paint-plt dc) - ;; Paint white lambda, no outline: - (send dc #,(:: dc<%> set-pen) "BLACK" 0 'transparent) - (send dc #,(:: dc<%> set-brush) "WHITE" 'solid) - (send dc #,(:: dc<%> draw-path) lambda-path) - ;; Paint outline and colors... - (send dc #,(:: dc<%> set-pen) "BLACK" 0 'solid) - ;; Draw red regions - (send dc #,(:: dc<%> set-brush) "RED" 'solid) - (send dc #,(:: dc<%> draw-path) left-logo-path) - (send dc #,(:: dc<%> draw-path) bottom-logo-path) - ;; Draw blue region - (send dc #,(:: dc<%> set-brush) "BLUE" 'solid) - (send dc #,(:: dc<%> draw-path) right-logo-path)) +(define (paint-racket dc) + (send dc set-pen "black" 0 'transparent) + (send dc set-brush "white" 'solid) + (send dc draw-path lambda-path) -;; Create a frame to display the logo on a light-purple background: -(define f (new frame% [label "Racket Logo"])) -(define c - (new canvas% - [parent f] - [paint-callback - (lambda (c dc) - (send dc #,(:: dc<%> set-background) (make-object color% 220 200 255)) - (send dc #,(:: dc<%> clear)) - (send dc #,(:: dc<%> set-smoothing) 'smoothed) - (send dc #,(:: dc<%> set-origin) 5 5) - (send dc #,(:: dc<%> set-scale) 0.5 0.5) - (paint-plt dc))])) -(send c #,(:: canvas<%> min-client-width) (/ 650 2)) -(send c #,(:: canvas<%> min-client-height) (/ 650 2)) -(send f show #t) -]) + (send dc set-pen "black" 4 'solid) + + (send dc set-brush red-brush) + (send dc draw-path left-logo-path) + (send dc draw-path bottom-logo-path) + + (send dc set-brush blue-brush) + (send dc draw-path right-logo-path)) + +(define racket-logo (make-bitmap 170 170)) +(define dc (new bitmap-dc% [bitmap racket-logo])) + +(send dc set-smoothing 'smoothed) +(send dc translate 5 5) +(send dc scale 0.25 0.25) +(paint-racket dc) +] + +@centered{@interaction-eval-show[#:eval draw-eval racket-logo]} + +In addition to the core @racket[move-to], @racket[line-to], +@racket[curve-to], and @racket[close] methods, a @racket[dc-path%] +includes many convenience methods, such as @racket[ellipse] for adding +a closed elliptical sub-path to the path. + +@; ------------------------------------------------------------ +@section{Text} + +Draw text using the @racket[draw-text] method, which takes a string to +draw and a location for the top-left of the drawn text: + +@racketblock+eval[ +#:eval draw-eval +(define text-target (make-bitmap 100 30)) +(define dc (new bitmap-dc% [bitmap text-target])) +(send dc set-brush "white" 'transparent) + +(send dc draw-rectangle 0 0 100 30) +(send dc draw-text "Hello, World!" 5 1) +] + +@centered{@interaction-eval-show[#:eval draw-eval (copy-bitmap text-target)]} + +The font used to draw text is determined by the @tech{DC}'s current +font. A font is described by a @racket[font%] object and installed +with @racket[set-font]. The color of drawn text which is separate from +either the pen or brush, can be set using +@racket[set-text-foreground]. + + +@racketblock+eval[ +#:eval draw-eval +(send dc erase) +(send dc set-font (make-object font% 14 'roman 'normal 'bold)) +(send dc set-text-foreground "blue") +(send dc draw-rectangle 0 0 100 30) +(send dc draw-text "Hello, World!" 5 1) +] + +@centered{@interaction-eval-show[#:eval draw-eval (copy-bitmap text-target)]} + +To compute the size that will be used by drawn text, use +@racket[get-text-extent], which returns four values: the total width, +total height, difference between the baseline and total height, and +extra space (if any) above the text in a line. For example, the result +of @racket[get-text-extent] can be used to position text within the +center of a box: + +@racketblock+eval[ +#:eval draw-eval +(send dc erase) +(send dc draw-rectangle 0 0 100 30) +(define-values (w h d a) (send dc get-text-extent "Hello, World!")) +(send dc draw-text "Hello, World!" (/ (- 100 w) 2) (/ (- 30 h) 2)) +] + +@centered{@interaction-eval-show[#:eval draw-eval (copy-bitmap text-target)]} + + +@; ------------------------------------------------------------ +@section{Alpha Channels and Alpha Blending} + +When you create or @racket[erase] a bitmap, the content is +nothing. ``Nothing'' isn't the same as white; it's the absence of +drawing. For example, if you take @racket[text-target] from the +previous section and copy it onto another @tech{DC} using +@racket[draw-bitmap], then the black rectangle and blue text is +transferred, and the background is left alone: + +@racketblock+eval[ +#:eval draw-eval +(define new-target (make-bitmap 100 30)) +(define dc (new bitmap-dc% [bitmap new-target])) +(send dc set-pen "black" 1 'transparent) +(send dc set-brush "pink" 'solid) + +(send dc draw-rectangle 0 0 100 30) +(send dc draw-bitmap text-target 0 0) +] + +@centered{@interaction-eval-show[#:eval draw-eval (copy-bitmap new-target)]} + +The information about which pixels of a bitmap are drawn (as opposed +to ``nothing'') is the bitmap's @deftech{alpha channel}. Not all +@tech{DC}s keep an alpha channel, but bitmaps created with +@racket[make-bitmap] keep an alpha channel by default. Bitmaps loaded +with @racket[read-bitmap] preserve transparency in the image file +through the bitmap's alpha channel. + +An alpha channel isn't all or nothing. When the edges text is +anti-aliased by @racket[draw-text], for example, the pixels are +partially transparent. When the pixels are transferred to another +@tech{DC}, the partially transparent pixel is blended with the target +pixel in a process called @deftech{alpha blending}. Furthermore, a +@tech{DC} has an alpha value that is applied to all drawing +operations; an alpha value of @racket[1.0] corresponds to solid +drawing, an alpha value of @racket[0.0] makes the drawing have no +effect, and values in between make the drawing translucent. + +For example, setting the @tech{DC}'s alpha to @racket[0.25] before +calling @racket[draw-bitmap] causes the blue and black of the ``Hello, +World!'' bitmap to be quarter strength as it is blended with the +destination image: + +@racketblock+eval[ +#:eval draw-eval +(send dc erase) +(send dc draw-rectangle 0 0 100 30) +(send dc set-alpha 0.25) +(send dc draw-bitmap text-target 0 0) +] + +@centered{@interaction-eval-show[#:eval draw-eval (copy-bitmap new-target)]} + +@; ------------------------------------------------------------ +@section{Clipping} + +In addition to tempering the opacity of drawing operations, a +@tech{DC} has a @deftech{clipping region} that constrains all drawing to +inside the region. In the simplest case, a clipping region corresponds +to a closed path, but it can also be the union, intersection, +subtraction, or exclusive-or of two paths. + +For example, a clipping region could be set to three circles to clip +the drawing of a rectangle (with the 0.25 alpha still in effect): + +@racketblock+eval[ +#:eval draw-eval +(define r (new region%)) +(let ([p (new dc-path%)]) + (send p ellipse 00 0 35 30) + (send p ellipse 35 0 30 30) + (send p ellipse 65 0 35 30) + (send r set-path p)) +(send dc set-clipping-region r) +(send dc set-brush "green" 'solid) +(send dc draw-rectangle 0 0 100 30) +] + +@centered{@interaction-eval-show[#:eval draw-eval (copy-bitmap new-target)]} + +The clipping region can be viewed as a convenient alternative to path +filling or drawing with stipples. Conversely, stippled drawing can be +viewed as a convenience alternative to clipping repeated calls of +@racket[draw-bitmap]. + + +@; ------------------------------------------------------------ +@section{Portability} Drawing effects are not completely portable across platforms or across - types of DC. Drawing in smoothed mode tends to produce more reliable - and portable results than in unsmoothed mode, and drawing with paths - tends to produce more reliable results even in unsmoothed - mode. Drawing with a pen of width 0 or 1 in unsmoothed mode in an - unscaled DC produces relatively consistent results for all platforms, - but a pen width of 2 or drawing to a scaled DC looks significantly - different in unsmoothed mode on different platforms and destinations. +types of DC. For example. drawing to a bitmap produced by +@racket[make-bitmap] may produce slightly different results than +drawing to one produced by @racketmodname[racket/gui]'s +@racket[make-screen-bitmap], but drawing to a bitmap from +@racket[make-screen-bitmap] should be the same as drawing to an +onscreen @racket[canvas%]. Fonts and text, especially, can vary across +platforms and types of @tech{DC}, but so can the precise set of pixels +touched by drawing a line. diff --git a/collects/scribblings/draw/pdf-dc-class.scrbl b/collects/scribblings/draw/pdf-dc-class.scrbl new file mode 100644 index 0000000000..5847b8b6d4 --- /dev/null +++ b/collects/scribblings/draw/pdf-dc-class.scrbl @@ -0,0 +1,17 @@ +#lang scribble/doc +@(require "common.ss") + +@defclass/title[pdf-dc% object% (dc<%>)]{ + +Like @racket[post-script-dc%], but generates a PDF file instead of a + PostScript file. + +@defconstructor[([interactive any/c #t] + [parent (or/c (is-a?/c frame%) (is-a?/c dialog%) false/c) #f] + [use-paper-bbox any/c #f] + [as-eps any/c #t])]{ + +See @racket[post-script-dc%] for information on the arguments. The +@racket[as-eps] argument is allowed for consistency with +@racket[post-script-dc%], but its value is ignored.}} + diff --git a/collects/scribblings/draw/pen-class.scrbl b/collects/scribblings/draw/pen-class.scrbl index 2f66d20cde..60e15f5720 100644 --- a/collects/scribblings/draw/pen-class.scrbl +++ b/collects/scribblings/draw/pen-class.scrbl @@ -4,13 +4,11 @@ @defclass/title[pen% object% ()]{ A pen is a drawing tool with a color, width, and style. A pen draws - lines and outlines, such as the outline of a rectangle. On a - monochrome display, all non-white pens are drawn as black. + lines and outlines, such as the outline of a rectangle. In a + monochrome destination, all non-white pens are drawn as black. In addition to its color, width, and style, a pen can have a stipple - bitmap that is a 8 x 8 monochrome bitmap. This stipple is used only - in unsmoothed mode (see @method[dc<%> set-smoothing]) or in a - PostScript drawing context. Painting with a stipple pen is similar to + bitmap. Painting with a stipple pen is similar to calling @method[dc<%> draw-bitmap] with the stipple bitmap in region painted by the pen. @@ -27,36 +25,10 @@ A pen's style is one of the following: brush's color, and white pixels from the stipple are not transferred.} - @item{@indexed-scheme['xor] --- In unsmoothed mode, the pen's color - or colored stipple is xor-ed with existing destination pixel - values. The @scheme['xor] mapping is unspecified for arbitrary - color combinations, but the mapping provides two guarantees: - @itemize[ + @item{@indexed-scheme['xor] --- The same as @racket['solid], accepted + only for partial backward compatibility.} - @item{Black-and-white drawing to a color or monochrome - destination always works as expected: black xor white = black, - white xor black = black, black xor black = white, and white xor - white = white.} - - @item{Performing the same drawing operation twice in a row with - @scheme['xor] is equivalent to a no-op.} - - ] - In a smoothing mode, @scheme['xor] is equivalent to @scheme['solid].} - - @item{@indexed-scheme['hilite] --- In unsmoothed mode, existing - destination pixels are ``highlighted'' in a platform-specific - way when the pen color is black. Under Windows for a color - drawing context, the inverted RGB components of destination - pixel are combined with the RGB components of the system-wide - highlight color using a bitwise ``or'', and the combination is - used. Under Mac OS X for a color drawing context, the - inverted RGB components of the system-wide highlight color are - subtracted from the RGB components of each destination pixel, - and the difference (or 0 for a negative result) is used. Under - X or for any monochrome drawing context, @scheme['hilite] is the - same as @scheme['xor]. In a smoothing mode, @scheme['hilite] is - treated like @scheme['solid].} + @item{@indexed-scheme['hilite] --- Draws with black and a @racket[0.3] alpha.} @item{The following special pen modes use the pen's color, and they only apply when a stipple is not used: @@ -78,34 +50,28 @@ To avoid creating multiple pens with the same characteristics, use the provide a color, width, and style to @xmethod[dc<%> set-pen]. A pen of size @scheme[0] uses the minimum line size for the - destination drawing context. In (unscaled) canvases and bitmaps in - unsmoothed mode, a zero-width pen behaves the nearly same as a pen of - size @scheme[1]. In a smoothing mode (including all - @scheme[post-script-dc%] drawing), a pen of size @scheme[0] draws a - line thinner than a pen of size @scheme[1]. If the pen's width is not - an integer, then the width is truncated to an integer (even before - scaling) in unsmoothed mode. + destination drawing context. In (unscaled) canvases and bitmaps, + a zero-width pen behaves the nearly same as a pen of + size @scheme[1]. +@defconstructor[([color (or/c string? (is-a?/c color%)) "black"] + [width (real-in 0 255) 0] + [style (one-of/c 'transparent 'solid 'xor 'hilite + 'dot 'long-dash 'short-dash 'dot-dash + 'xor-dot 'xor-long-dash 'xor-short-dash + 'xor-dot-dash) + 'solid] + [cap (one-of/c 'round 'projecting 'butt) + 'round] + [join (one-of/c 'round 'bevel 'miter) + 'round] + [stipple (or/c #f (is-a?/c bitmap%)) + #f])]{ - -@defconstructor*/make[(() - ([color (is-a?/c color%)] - [width (real-in 0 255)] - [style (one-of/c 'transparent 'solid 'xor 'hilite - 'dot 'long-dash 'short-dash 'dot-dash - 'xor-dot 'xor-long-dash 'xor-short-dash - 'xor-dot-dash)]) - ([color-name string?] - [width (real-in 0 255)] - [style (one-of/c 'transparent 'solid 'xor 'dot 'hilite - 'long-dash 'short-dash 'dot-dash - 'xor-dot 'xor-long-dash 'xor-short-dash - 'xor-dot-dash)]))]{ - -When no argument are provided, the result is a solid black pen of - width @scheme[0]. Otherwise, the result is a pen with the given - color, width, and style. For the case that the color is specified +Creates a pen with the given + color, width, style, cap style, join style, and stipple. + For the case that the color is specified using a name, see @scheme[color-database<%>] for information about color names; if the name is not known, the pen's color is black. @@ -114,8 +80,7 @@ When no argument are provided, the result is a solid black pen of @defmethod[(get-cap) (one-of/c 'round 'projecting 'butt)]{ -Returns the pen cap style (Windows unsmoothed, X unsmoothed, all - smoothing). The default is @scheme['round]. +Returns the pen cap style. The default is @scheme['round]. } @@ -129,8 +94,7 @@ Returns the pen's color object. @defmethod[(get-join) (one-of/c 'round 'bevel 'miter)]{ -Returns the pen join style (Windows unsmoothed, X unsmoothed, all - smoothing). The default is @scheme['round]. +Returns the pen join style. The default is @scheme['round]. } @@ -163,8 +127,7 @@ Returns the pen width. @defmethod[(set-cap [cap-style (one-of/c 'round 'projecting 'butt)]) void?]{ -Sets the pen cap style (Windows unsmoothed, X unsmoothed, all - smoothing). See @method[pen% get-cap] for information about cap +Sets the pen cap style. See @method[pen% get-cap] for information about cap styles. A pen cannot be modified if it was obtained from a @scheme[pen-list%] @@ -191,8 +154,7 @@ A pen cannot be modified if it was obtained from a @defmethod[(set-join [join-style (one-of/c 'round 'bevel 'miter)]) void?]{ -Sets the pen join style (Windows unsmoothed, X unsmoothed, all - smoothing). See @method[pen% get-join] for information about join +Sets the pen join style. See @method[pen% get-join] for information about join styles. A pen cannot be modified if it was obtained from a @@ -200,11 +162,10 @@ A pen cannot be modified if it was obtained from a } -@defmethod[(set-stipple [stipple (or/c (is-a?/c bitmap%) false/c)]) +@defmethod[(set-stipple [stipple (or/c (is-a?/c bitmap%) #f)]) void?]{ -Sets the pen stipple bitmap, which must be an 8 x 8 monochrome bitmap - or @scheme[#f], which turns off the stipple bitmap. +Sets the pen stipple bitmap, where @scheme[#f] turns off the stipple bitmap. A bitmap cannot be used as a stipple if it is selected into a @scheme[bitmap-dc%] object; if the given bitmap is selected into a @@ -212,9 +173,6 @@ A bitmap cannot be used as a stipple if it is selected into a if it was obtained from a @scheme[pen-list%] or while it is selected into a drawing context. -A pen's stipple is not used in a smoothing mode, except for a - @scheme[post-script-dc%] (which is always in smoothed mode). - } @defmethod[(set-style [style (one-of/c 'transparent 'solid 'xor 'hilite diff --git a/collects/scribblings/draw/post-script-dc-class.scrbl b/collects/scribblings/draw/post-script-dc-class.scrbl index b27b99beb8..0bc4a360f5 100644 --- a/collects/scribblings/draw/post-script-dc-class.scrbl +++ b/collects/scribblings/draw/post-script-dc-class.scrbl @@ -5,7 +5,7 @@ A @scheme[post-script-dc%] object is a PostScript device context, that can write PostScript files on any platform. See also - @scheme[ps-setup%]. + @scheme[ps-setup%] and @racket[pdf-dc%]. @|PrintNote| @@ -15,7 +15,10 @@ See also @scheme[printer-dc%]. @defconstructor[([interactive any/c #t] [parent (or/c (is-a?/c frame%) (is-a?/c dialog%) false/c) #f] [use-paper-bbox any/c #f] - [as-eps any/c #t])]{ + [as-eps any/c #t] + [width (or/c (and/c real? (not/c negative?)) #f) #f] + [height (or/c (and/c real? (not/c negative?)) #f) #f] + [output (or/c path-string? output-port? #f) #f])]{ If @scheme[interactive] is true, the user is given a dialog for setting printing parameters (see @scheme[get-ps-setup-from-user]); @@ -31,23 +34,30 @@ If @scheme[parent] is not @scheme[#f], it is used as the parent window of If @scheme[interactive] is @scheme[#f], then the settings returned by @scheme[current-ps-setup] are used. A file dialog is still presented to the user if the @method[ps-setup% get-file] method returns - @scheme[#f], and the user may hit cancel in that case so that - @method[dc<%> ok?] returns @scheme[#f]. + @scheme[#f] and @racket[output] is @racket[#f], and the user may + hit @onscreen{Cancel} in that case so that @method[dc<%> ok?] returns @scheme[#f]. If @scheme[use-paper-bbox] is @scheme[#f], then the PostScript - bounding box for the output is determined by drawing commands issued - to the object; such a bounding box encloses all parts of the drawing - @italic{ignoring} clipping regions (so the bounding box may be - approximate). If @scheme[use-paper-bbox] is not @scheme[#f], then the - bounding box is determined by the current paper size (as specified by - @scheme[current-ps-setup]), and the bounding box does not include the - margin (also specified by @scheme[current-ps-setup]). + bounding box for the output is determined by @racket[width] and + @racket[height]. If @scheme[use-paper-bbox] is not @scheme[#f], then + the bounding box is determined by the current paper size (as + specified by @scheme[current-ps-setup]). When @racket[width] or + @racket[height] is @racket[#f], then the corresponding dimension is + determined by the paper size, even if @racket[use-paper-bbox] is + @racket[#f]. @index["Encapsulated PostScript (EPS)"]{If} @scheme[as-eps] is @scheme[#f], then the generated PostScript does not include an Encapsulated PostScript (EPS) header, and instead includes a generic - PostScript header. Otherwise, the generated PostScript includes a - header that identifiers it as EPS. + PostScript header. The margin and translation factors specified by + @racket[current-ps-setup] are used only when @racket[as-eps] is + @racket[#f]. If @racket[as-eps] is true, then the generated + PostScript includes a header that identifiers it as EPS. + +When @racket[output] is not @racket[#f], then file-mode output is + written to @racket[output]. If @racket[output] is @racket[#f], then + the destination is determined via @racket[current-ps-setup] or by + prompting the user for a pathname. See also @scheme[ps-setup%] and @scheme[current-ps-setup]. The settings for a particular @scheme[post-script-dc%] object are fixed to diff --git a/collects/scribblings/draw/reference.scrbl b/collects/scribblings/draw/reference.scrbl deleted file mode 100644 index f652399ddc..0000000000 --- a/collects/scribblings/draw/reference.scrbl +++ /dev/null @@ -1,27 +0,0 @@ -#lang scribble/doc -@(require "common.ss") - -@title[#:style '(toc reveal)]{Reference} - -@local-table-of-contents[] - -@include-section["bitmap-class.scrbl"] -@include-section["bitmap-dc-class.scrbl"] -@include-section["brush-class.scrbl"] -@include-section["brush-list-class.scrbl"] -@include-section["color-class.scrbl"] -@include-section["color-database-intf.scrbl"] -@include-section["dc-intf.scrbl"] -@include-section["dc-path-class.scrbl"] -@include-section["font-class.scrbl"] -@include-section["font-list-class.scrbl"] -@include-section["font-name-directory-intf.scrbl"] -@include-section["gl-config-class.scrbl"] -@include-section["gl-context-intf.scrbl"] -@include-section["pen-class.scrbl"] -@include-section["pen-list-class.scrbl"] -@include-section["point-class.scrbl"] -@include-section["post-script-dc-class.scrbl"] -@include-section["ps-setup-class.scrbl"] -@include-section["region-class.scrbl"] -@include-section["draw-funcs.scrbl"] diff --git a/collects/scribblings/draw/water.png b/collects/scribblings/draw/water.png new file mode 100644 index 0000000000..ec1b58c426 Binary files /dev/null and b/collects/scribblings/draw/water.png differ diff --git a/collects/scribblings/drracket/prefs.scrbl b/collects/scribblings/drracket/prefs.scrbl index 7e3ed7243b..d8e4cb5749 100644 --- a/collects/scribblings/drracket/prefs.scrbl +++ b/collects/scribblings/drracket/prefs.scrbl @@ -36,7 +36,7 @@ The preferences dialog consists of several panels. This panel controls which keywords DrRacket recognizes for indenting, and how each keyword is treated.} - + @item{@onscreen{Square bracket} This panel controls which keywords DrRacket uses to determine @@ -49,6 +49,100 @@ The preferences dialog consists of several panels. columns behave.} @item{@onscreen{General} + @itemize[@item{@PrefItem{Map delete to backspace} --- If checked, the editor + treats the Delete key like the Backspace key.} + + @item{@PrefItem{Wrap words in editor buffers} --- If checked, + DrRacket editors auto-wrap text lines by default. Changing this + preference affects new windows only.} + + @item{@PrefItem{Reuse existing frames when opening new files} --- + If checked, new files are opened in the same DrRacket window, + rather than creating a new DrRacket window for each new file.} + + @item{@PrefItem{Enable keybindings in menus} --- If checked, some + DrRacket menu items have keybindings. Otherwise, no menu items + have key bindings. This preference is designed for people who are + comfortable editing in Emacs and find the standard menu + keybindings interfere with the Emacs keybindings.} + + + @item{@PrefItem{Treat command key as meta} --- If checked, DrRacket will use the command key for some Emacs-like keybindings, instead of using it for menu shortcuts. This option is only available under Mac OS X.} + + @item{@PrefItem{Color syntax interactively} --- If checked, DrRacket + colors your syntax as you type.} + + @item{@PrefItem{Search using anchors} --- If checked, DrRacket's searching mode will jump directly to the first search hit, using an ``anchor'' to determine where to search if the search string changes.} + + @item{@PrefItem{Normalize pasted strings} --- If checked, DrRacket adjusts strings that are pasted into the editor to avoid confusion. For example, non-breaking spaces look just like spaces but are not considered separators like ordinary spaces are. If this is checked DrRacket will automatically turn those non-breaking spaces into regular spaces. Similarly with other (less common) characters.} + + @item{@PrefItem{Enable overwrite mode keybindings} --- If checked, DrRacket enables the insert keybinding to swap into overwrite mode} + + @item{@PrefItem{Show line numbers} --- If checked, DrRacket shows line numbers for the file being edited in the left-hand column} + + ]} + + + + + + @item{@onscreen{Racket} + + @itemize[ + + @item{@PrefItem{Highlight between matching parens} --- If checked, the + editor marks the region between matching parenthesis with a gray + background (in color) or a stipple pattern (in monochrome) when + the blinking caret is next to a parenthesis.} + + @item{@PrefItem{Automatically adjust closing parens} --- If checked, the editor + automatically converts a typed @litchar[")"] to @litchar["]"] to + match @litchar["["], or it converts a typed @litchar["]"] to + @litchar[")"] to match @litchar["("].} + + @item{@PrefItem{Automatically adjust opening square brackets} If checked, the editor changes + typed @litchar["["] to match the context (as explained in + @secref["editor"]).} + + @item{@PrefItem{Flash paren match} --- If checked, typing a closing + parenthesis, square bracket, or quotation mark flashes the + matching open parenthesis/bracket/quote.} + + ]}] + +@section{@onscreen{Warnings}} + + @itemize[ + + @item{@PrefItem{Ask before changing save format} --- If checked, + DrRacket consults the user before saving a file in non-text format + (see @secref["drracket-file-formats"]).} + + @item{@PrefItem{Verify exit} --- If checked, DrRacket consults the + user before exiting.} + + @item{@PrefItem{Ask about normalizing strings} --- If checked, DrRacket + consults the user before normalizing a string pasted into the editor.} + + @item{@PrefItem{Only warn once when executions and interactions are + not synchronized} --- If checked, DrRacket warns the user on the + first interaction after the definitions window, language, or + teachpack is changed without a corresponding click on + @onscreen{Run}. Otherwise, the warning appears on every + interaction.} + + @item{@PrefItem{Ask about clearing test coverage} --- If checked, + when test coverage annotations are displayed DrRacket prompts + about removing them. This setting only applies to the PLT + languages. DrRacket never asks in the teaching languages.} + + @item{@PrefItem{Check for newer Racket versions} --- If + checked, DrRacket periodically polls a server to determine + whether a newer version of DrRacket is available.} + + ] + +@section{@onscreen{General}} @itemize[ @@ -66,9 +160,6 @@ The preferences dialog consists of several panels. files have the same name as the original, except that they end in either @indexed-file{.bak} or @indexed-file{~}.} - @item{@PrefItem{Map delete to backspace} --- If checked, the editor - treats the Delete key like the Backspace key.} - @item{@PrefItem{Show status-line} --- If checked, DrRacket shows a status line at the bottom of each window.} @@ -81,29 +172,6 @@ The preferences dialog consists of several panels. @nonterm{line}:@nonterm{column} display for the current selection rather than the character offset into the text.} - @item{@PrefItem{Wrap words in editor buffers} --- If checked, - DrRacket editors auto-wrap text lines by default. Changing this - preference affects new windows only.} - - @item{@PrefItem{Use separate dialog for searching} --- If checked, - then selecting the @onscreen{Find} menu item opens a separate - dialog for searching and replacing. Otherwise, selecting - @onscreen{Find} opens an interactive search-and-replace panel at - the bottom of a DrRacket window.} - - @item{@PrefItem{Reuse existing frames when opening new files} --- - If checked, new files are opened in the same DrRacket window, - rather than creating a new DrRacket window for each new file.} - - @item{@PrefItem{Enable keybindings in menus} --- If checked, some - DrRacket menu items have keybindings. Otherwise, no menu items - have key bindings. This preference is designed for people who are - comfortable editing in Emacs and find the standard menu - keybindings interfere with the Emacs keybindings.} - - @item{@PrefItem{Color syntax interactively} --- If checked, DrRacket - colors your syntax as you type.} - @item{@PrefItem{Automatically print to PostScript file} --- If checked, printing will automatically save PostScript files. If not, printing will use the standard printing mechanisms for your @@ -117,6 +185,10 @@ The preferences dialog consists of several panels. a program} -- If checked, DrRacket shows the interactions window (if it is hidden) when a program is run.} + @item{@PrefItem{Automatically switch to the module language when opening a module} -- + If checked, DrRacket will recognize files that have a @tt{#lang} line + and adjust the language setting automatically.} + @item{@PrefItem{Put the interactions window beside the definitions window} -- If checked, DrRacket puts the interactions window to the right of the definitions window. By default, the interactions @@ -128,60 +200,7 @@ The preferences dialog consists of several panels. that the @hash-lang[] line is the first line in the file. } - ]} - - @item{@onscreen{Racket} - - @itemize[ - - @item{@PrefItem{Highlight between matching parens} --- If checked, the - editor marks the region between matching parenthesis with a gray - background (in color) or a stipple pattern (in monochrome) when - the blinking caret is next to a parenthesis.} - - @item{@PrefItem{Correct parens} --- If checked, the editor - automatically converts a typed @litchar[")"] to @litchar["]"] to - match @litchar["["], or it converts a typed @litchar["]"] to - @litchar[")"] to match @litchar["("]. Also, the editor changes - typed @litchar["["] to match the context (as explained in - @secref["editor"]).} - - @item{@PrefItem{Flash paren match} --- If checked, typing a closing - parenthesis, square bracket, or quotation mark flashes the - matching open parenthesis/bracket/quote.} - - ]} - -] - -@section{@onscreen{Warnings}} - - @itemize[ - - @item{@PrefItem{Ask before changing save format} --- If checked, - DrRacket consults the user before saving a file in non-text format - (see @secref["drracket-file-formats"]).} - - @item{@PrefItem{Verify exit} --- If checked, DrRacket consults the - user before exiting.} - - @item{@PrefItem{Only warn once when executions and interactions are - not synchronized} --- If checked, DrRacket warns the user on the - first interaction after the definitions window, language, or - teachpack is changed without a corresponding click on - @onscreen{Run}. Otherwise, the warning appears on every - interaction.} - - @item{@PrefItem{Ask about clearing test coverage} --- If checked, - when test coverage annotations are displayed DrRacket prompts - about removing them. This setting only applies to the PLT - languages. DrRacket never asks in the teaching languages.} - - @item{@PrefItem{Check for newer PLT Racket versions} --- If - checked, DrRacket periodically polls a server to determine - whether a newer version of DrRacket is available.} - - ] + ] @section{@onscreen{Profiling}} @@ -199,3 +218,7 @@ The preferences dialog consists of several panels. This preferences panel allows you to configure your HTTP proxy. Contact your system administrator for details. + +@section{@onscreen{Tools}} + +This preference panel allows you to configure the currently active plugins. \ No newline at end of file diff --git a/collects/scribblings/foreign/pointers.scrbl b/collects/scribblings/foreign/pointers.scrbl index db13f38617..f88d572d22 100644 --- a/collects/scribblings/foreign/pointers.scrbl +++ b/collects/scribblings/foreign/pointers.scrbl @@ -14,7 +14,11 @@ Returns @scheme[#f] for other values.} @defproc[(ptr-equal? [cptr1 cpointer?] [cptr2 cpointer?]) boolean?]{ Compares the values of the two pointers. Two different Racket -pointer objects can contain the same pointer.} +pointer objects can contain the same pointer. + +If the values are both C pointers---as opposed to @racket[#f], a byte +string, @scheme[ffi-obj], or callback---this comparison is the same as +@racket[equal?].} @defproc[(ptr-add [cptr cpointer?] [offset exact-integer?] [type ctype? _byte]) diff --git a/collects/scribblings/foreign/types.scrbl b/collects/scribblings/foreign/types.scrbl index dd6691d986..fe92c418f4 100644 --- a/collects/scribblings/foreign/types.scrbl +++ b/collects/scribblings/foreign/types.scrbl @@ -284,7 +284,11 @@ The address referenced by a @scheme[_pointer] value must not refer to memory managed by the garbage collector (unless the address corresponds to a value that supports interior pointers and that is otherwise referenced to preserve the value from garbage collection). -The reference is not traced or updated by the garbage collector.} +The reference is not traced or updated by the garbage collector. + +The @racket[equal?] predicate equates C pointers (including pointers +for @racket[_gcpointer] and possibly containing an offset) when they +refer to the same address.} @defthing[_gcpointer ctype?]{ @@ -401,19 +405,22 @@ procedure with the generated procedure type can be applied in a foreign thread (i.e., an OS-level thread other than the one used to run Racket). The call in the foreign thread is transferred to the OS-level thread that runs Racket, but the Racket-level thread (in the -sense of @racket[thread]) is unspecified; the job of -@scheme[async-apply] is to arrange for the callback procedure to be -run in a suitable Racket thread. The @scheme[async-apply] function is +sense of @racket[thread]) is unspecified; the job of the provided +@scheme[async-apply] procedure is to arrange for the callback procedure to be +run in a suitable Racket thread. The given @scheme[async-apply] procedure is applied to a thunk that encapsulates the specific callback invocation, and the foreign OS-level thread blocks until the thunk is called and completes; the thunk must be called exactly once, and the callback -invocation must return normally. The @scheme[async-apply] procedure +invocation must return normally. The given @scheme[async-apply] procedure itself is called in atomic mode (see @scheme[atomic?] above). If the callback is known to complete quickly, requires no synchronization, and works independent of the Racket thread in which it runs, then -@scheme[async-apply] can apply the thunk directly. Otherwise, -@racket[async-apply] must arrange for the thunk to be applied in a -suitable Racket thread sometime after @racket[async-apply] itself +it is safe for the given +@scheme[async-apply] procedure to apply the thunk directly. Otherwise, +the given @racket[async-apply] procedure +must arrange for the thunk to be applied in a +suitable Racket thread sometime after the given +@racket[async-apply] procedure itself returns; if the thunk raises an exception or synchronizes within an unsuitable Racket-level thread, it can deadlock or otherwise damage the Racket process. Foreign-thread detection to trigger @@ -814,7 +821,9 @@ The resulting bindings are as follows: an argument for each type.} @item{@schemevarfont{id}@schemeidfont{-}@scheme[field-id] : an accessor - function for each @scheme[field-id].} + function for each @scheme[field-id]; if the field has a cstruct type, then + the result of the accessor is a pointer to the field within the + enclosing structure, rather than a copy of the field.} @item{@schemeidfont{set-}@schemevarfont{id}@schemeidfont{-}@scheme[field-id]@schemeidfont{!} : a mutator function for each @scheme[field-id].} @@ -860,12 +869,11 @@ addition for the new fields. This adjustment of the constructor is, again, in analogy to using a supertype with @scheme[define-struct]. Note that structs are allocated as atomic blocks, which means that the -garbage collector ignores their content. Currently, there is no safe -way to store pointers to GC-managed objects in structs (even if you -keep a reference to avoid collecting the referenced objects, a the 3m -variant's GC will invalidate the pointer's value). Thus, only -non-pointer values and pointers to memory that is outside the GC's -control can be placed into struct fields. +garbage collector ignores their content. Thus, struct fields can hold +only non-pointer values, pointers to memory outside the GC's control, +and otherwise-reachable pointers to immobile GC-managed values (such +as those allocated with @racket[malloc] and @racket['internal] or +@racket['internal-atomic]). As an example, consider the following C code: @@ -988,7 +996,9 @@ Although the constructors below are describes as procedures, they are implemented as syntax, so that error messages can report a type name where the syntactic context implies one. -@defproc[(_enum [symbols list?] [basetype ctype? _ufixint]) +@defproc[(_enum [symbols list?] + [basetype ctype? _ufixint] + [#:unknown unknown any/c (lambda (x) (error ....))]) ctype?]{ Takes a list of symbols and generates an enumeration type. The @@ -1001,7 +1011,12 @@ example, the list @scheme['(x y = 10 z)] maps @scheme['x] to @scheme[0], @scheme['y] to @scheme[10], and @scheme['z] to @scheme[11]. -The @scheme[basetype] argument specifies the base type to use.} +The @scheme[basetype] argument specifies the base type to use. + +The @scheme[unknown] argument specifies the result of converting an +unknown integer from the foreign side: it can be a one-argument function +to be applied on the integer, or a value to return instead. The default +is to throw an exception.} @defproc[(_bitmask [symbols (or symbol? list?)] [basetype ctype? _uint]) ctype?]{ diff --git a/collects/scribblings/gui/dialog-class.scrbl b/collects/scribblings/gui/dialog-class.scrbl index 98f5e55dd6..15df432952 100644 --- a/collects/scribblings/gui/dialog-class.scrbl +++ b/collects/scribblings/gui/dialog-class.scrbl @@ -16,7 +16,9 @@ A dialog is a top-level window that is @defterm{modal}: while the [height (or/c (integer-in 0 10000) false/c) #f] [x (or/c (integer-in 0 10000) false/c) #f] [y (or/c (integer-in 0 10000) false/c) #f] - [style (listof (one-of/c 'no-caption 'resize-border 'no-sheet)) null] + [style (listof (one-of/c 'no-caption 'resize-border + 'no-sheet 'close-button)) + null] [enabled any/c #t] [border (integer-in 0 1000) 0] [spacing (integer-in 0 1000) 0] @@ -68,6 +70,9 @@ The @scheme[style] flags adjust the appearance of the dialog on some @item{@scheme['no-sheet] --- uses a movable window for the dialog, even if a parent window is provided (Mac OS X)} + @item{@scheme['close-button] --- include a close button in the + dialog's title bar, which would not normally be included (Mac OS X)} + ] Even if the dialog is not shown, a few notification events may be diff --git a/collects/scribblings/gui/dynamic.scrbl b/collects/scribblings/gui/dynamic.scrbl index b0f35c3f6b..2e4e52f85d 100644 --- a/collects/scribblings/gui/dynamic.scrbl +++ b/collects/scribblings/gui/dynamic.scrbl @@ -5,21 +5,17 @@ @title{Dynamic Loading} @defmodule[racket/gui/dynamic]{The @racketmodname[racket/gui/dynamic] -library provides functions for dynamically accessing the Racket -GUI toolbox, instead of directly requiring @racket[racket/gui] or -@racket[racket/gui/base].} +library provides functions for dynamically accessing the +@racketmodname[racket/gui/base] library, instead of directly requiring +@racketmodname[racket/gui] or @racketmodname[racket/gui/base].} @defproc[(gui-available?) boolean?]{ -Returns @racket[#t] if dynamic access to the GUI bindings are -available---that is, that the program is being run as a -GRacket-based application, as opposed to a pure -Racket-based application, and that GUI modules are attached -to the namespace in which @racket[racket/gui/dynamic] was -instantiated. - -This predicate can be used in code that optionally uses GUI elements -when they are available.} +Returns @racket[#t] if dynamic access to the GUI bindings is +available. The bindings are available if +@racketmodname[racket/gui/base] has been loaded, instantiated, and +attached to the namespace in which @racket[racket/gui/dynamic] was +instantiated.} @defproc[(gui-dynamic-require [sym symbol?]) any]{ diff --git a/collects/scribblings/gui/editor-overview.scrbl b/collects/scribblings/gui/editor-overview.scrbl index 6558dc3a7d..bc0c15bf1f 100644 --- a/collects/scribblings/gui/editor-overview.scrbl +++ b/collects/scribblings/gui/editor-overview.scrbl @@ -2,7 +2,7 @@ @(require scribble/bnf "common.ss") -@title[#:tag "editor-overview"]{Editor} +@title[#:tag "editor-overview"]{Editors} The editor toolbox provides a foundation for two common kinds of applications: @@ -720,11 +720,10 @@ An editor is not tied to any particular thread or eventspace, except to the degree that it is displayed in a canvas (which has an eventspace). Concurrent access of an editor is always safe, in the sense that the editor will not become corrupted. However, because - editor access can trigger locks, and because lock-rejected operations - tend to fail silently, concurrent access can produce unexpected - results. + editor access can trigger locks, concurrent access can produce + contract failures or unexpected results. -Nevertheless, the editor supports certain concurrent patterns +An editor supports certain concurrent patterns reliably. One relevant pattern is updating an editor in one thread while the editor is displayed in a canvas that is managed by a different (handler) thread. To ensure that canvas refreshes are not diff --git a/collects/scribblings/gui/gui.scrbl b/collects/scribblings/gui/gui.scrbl index 31cdac7af2..b51741fe77 100644 --- a/collects/scribblings/gui/gui.scrbl +++ b/collects/scribblings/gui/gui.scrbl @@ -17,13 +17,35 @@ to the bindings of @racketmodname[racket/draw].} @racketmodname[racket] language and the @racketmodname[racket/gui/base] and @racketmodname[racket/draw] modules.} +The @racketmodname[racket/gui] toolbox is roughly organized into two +parts: + +@itemize[ + + @item{The @deftech{windowing toolbox}, for implementing windows, + buttons, menus, text fields, and other controls.} + + @item{The @deftech{editor toolbox}, for developing traditional text + editors, editors that mix text and graphics, or free-form layout + editors (such as a word processor, HTML editor, or icon-based file + browser).} + +] + +Both parts of the toolbox rely extensively on the +@racketmodname[racket/draw] drawing library. @table-of-contents[] @;------------------------------------------------------------------------ -@include-section["guide.scrbl"] -@include-section["reference.scrbl"] +@include-section["win-overview.scrbl"] +@include-section["win-classes.scrbl"] +@include-section["win-funcs.scrbl"] +@include-section["editor-overview.scrbl"] +@include-section["editor-classes.scrbl"] +@include-section["editor-funcs.scrbl"] +@include-section["wxme.scrbl"] @include-section["prefs.scrbl"] @include-section["dynamic.scrbl"] diff --git a/collects/scribblings/gui/guide.scrbl b/collects/scribblings/gui/guide.scrbl index 3b4058e5c8..25d2702939 100644 --- a/collects/scribblings/gui/guide.scrbl +++ b/collects/scribblings/gui/guide.scrbl @@ -3,27 +3,6 @@ @title[#:style '(toc reveal)]{Overview} -For documentation purposes, the graphics toolbox is organized into - two parts: - -@itemize[ - - @item{The @deftech{windowing toolbox}, for implementing form-filling - GUI programs (such as a database query window) using buttons, menus, - text fields, and events. The windowing toolbox is described in - @secref["windowing-overview"].} - - @item{The @deftech{editor toolbox}, for developing traditional text - editors, editors that mix text and graphics, or free-form layout - editors (such as a word processor, HTML editor, or icon-based file - browser). The editor toolbox is described in - @secref["editor-overview"].} - -] - -Simple GUI programs access only the windowing toolbox directly, while - large-scale applications tend to use the editor toolbox as well. - @local-table-of-contents[] @;------------------------------------------------------------------------ diff --git a/collects/scribblings/gui/miscwin-funcs.scrbl b/collects/scribblings/gui/miscwin-funcs.scrbl index fa69a6520a..dcc9cdb021 100644 --- a/collects/scribblings/gui/miscwin-funcs.scrbl +++ b/collects/scribblings/gui/miscwin-funcs.scrbl @@ -107,20 +107,24 @@ default is @racket['(cmd)]. Under X, the default is normally @defproc[(get-panel-background) (is-a?/c color%)]{ -Returns the background color of a panel (usually some shade of gray) - for the current platform. +Returns a shade of gray. +Historically, the result matched the color of +a @racket[panel%] background, but @racket[panel%] backgrounds can vary +on some platforms (e.g., when nested in a @racket[group-box-panel%]), +so the result is no longer guaranteed to be related to a +@racket[panel%]'s color. } @defproc[(get-highlight-background-color) (is-a?/c color%)]{ -Returns the color drawn behind selected text.} +Returns the color that is drawn behind selected text.} @defproc[(get-highlight-text-color) (or/c (is-a?/c color%) #f)]{ -Returns the color used to draw selected text or @racket[#f] if +Returns the color that is used to draw selected text or @racket[#f] if selected text is drawn with its usual color.} diff --git a/collects/scribblings/gui/win-overview.scrbl b/collects/scribblings/gui/win-overview.scrbl index 1b632b55a4..45ad0a0aa7 100644 --- a/collects/scribblings/gui/win-overview.scrbl +++ b/collects/scribblings/gui/win-overview.scrbl @@ -5,11 +5,19 @@ @title[#:tag "windowing-overview"]{Windowing} -The Racket windowing toolbox provides the basic building blocks of GUI +The windowing toolbox provides the basic building blocks of GUI programs, including frames (top-level windows), modal dialogs, menus, - buttons, check boxes, text fields, and radio buttons. The toolbox - provides these building blocks via built-in classes, such as the - @scheme[frame%] class: + buttons, check boxes, text fields, and radio buttons---all as + classes. + +@margin-note{See @secref["classes" #:doc '(lib +"scribblings/guide/guide.scrbl")] for an introduction to classes and +interfaces in Racket.} + +@section{Creating Windows} + +To create a new top-level window, instantiate the @scheme[frame%] + class: @schemeblock[ (code:comment @#,t{Make a frame by instantiating the @scheme[frame%] class}) @@ -21,7 +29,7 @@ The Racket windowing toolbox provides the basic building blocks of GUI The built-in classes provide various mechanisms for handling GUI events. For example, when instantiating the @scheme[button%] class, - the programmer supplies an event callback procedure to be invoked + supply an event callback procedure to be invoked when the user clicks the button. The following example program creates a frame with a text message and a button; when the user clicks the button, the message changes: @@ -46,18 +54,18 @@ The built-in classes provide various mechanisms for handling GUI ] Programmers never implement the GUI event loop directly. Instead, the - system automatically pulls each event from an internal queue and + windowing system automatically pulls each event from an internal queue and dispatches the event to an appropriate window. The dispatch invokes the window's callback procedure or calls one of the window's - methods. In the above program, the system automatically invokes the + methods. In the above program, the windowing system automatically invokes the button's callback procedure whenever the user clicks @onscreen{Click Me}. If a window receives multiple kinds of events, the events are dispatched to methods of the window's class instead of to a callback procedure. For example, a drawing canvas receives update events, - mouse events, keyboard events, and sizing events; to handle them, a - programmer must derive a new class from the built-in + mouse events, keyboard events, and sizing events; to handle them, + derive a new class from the built-in @scheme[canvas%] class and override the event-handling methods. The following expression extends the frame created above with a canvas that handles mouse and keyboard events: @@ -86,10 +94,10 @@ After running the above code, manually resize the frame to see the on-event]. While the canvas has the keyboard focus, typing on the keyboard invokes the canvas's @method[canvas<%> on-char] method. -The system dispatches GUI events sequentially; that is, after invoking - an event-handling callback or method, the system waits until the +The windowing system dispatches GUI events sequentially; that is, after invoking + an event-handling callback or method, the windowing system waits until the handler returns before dispatching the next event. To illustrate the - sequential nature of events, we extend the frame again, adding a + sequential nature of events, extend the frame again, adding a @onscreen{Pause} button: @schemeblock[ @@ -99,7 +107,7 @@ The system dispatches GUI events sequentially; that is, after invoking ] After the user clicks @onscreen{Pause}, the entire frame becomes - unresponsive for five seconds; the system cannot dispatch more events + unresponsive for five seconds; the windowing system cannot dispatch more events until the call to @scheme[sleep] returns. For more information about event dispatching, see @secref["eventspaceinfo"]. @@ -111,7 +119,7 @@ In addition to dispatching events, the GUI classes also handle the as a frame, arranges its children in a column, and a horizontal container arranges its children in a row. A container can be a child of another container; for example, to place two buttons side-by-side - in our frame, we create a horizontal panel for the new buttons: + in our frame, create a horizontal panel for the new buttons: @schemeblock[ (define panel (new horizontal-panel% [parent frame])) @@ -128,6 +136,49 @@ In addition to dispatching events, the GUI classes also handle the For more information about window layout and containers, see @secref["containeroverview"]. + +@section[#:tag "canvas-drawing"]{Drawing in Canvases} + +The content of a canvas is determined by its @method[canvas% on-paint] +method, where the default @method[canvas% on-paint] calls the +@racket[paint-callback] function that is supplied when the canvas is +created. The @method[canvas% on-paint] method receives no arguments +and uses the canvas's @method[canvas<%> get-dc] method to obtain a +@tech[#:doc '(lib "scribblings/draw/draw.scrbl")]{drawing context} +(DC) for drawing; the default @method[canvas% on-paint] method passes +the canvas and this DC on to the @racket[paint-callback] function. +Drawing operations of the @racket[racket/draw] toolbox on the DC are +reflected in the content of the canvas onscreen. + +For example, the following program creates a canvas +that displays large, friendly letters: + +@schemeblock[ +(define frame (new frame% + [label "Example"] + [width 300] + [height 300])) +(new canvas% [parent frame] + [paint-callback + (lambda (canvas dc) + (send dc #,(:: dc<%> set-scale) 3 3) + (send dc #,(:: dc<%> set-text-foreground) "blue") + (send dc #,(:: dc<%> draw-text) "Don't Panic!" 0 0))]) +(send frame #,(:: top-level-window<%> show) #t) +] + +The background color of a canvas can be set through the +@method[canvas<%> set-canvas-background] method. To make the canvas +transparent (so that it takes on its parent's color and texture as its +initial content), supply @racket['transparent] in the @racket[style] +argument when creating the canvas. + +See @secref["overview" #:doc '(lib "scribblings/draw/draw.scrbl")] in +@other-doc['(lib "scribblings/draw/draw.scrbl")] for an overview of +drawing with the @racket[racket/draw] library. For more advanced +information on canvas drawing, see @secref["animation"]. + + @section{Core Windowing Classes} The fundamental graphical element in the windowing toolbox is an @@ -328,7 +379,7 @@ The built-in container classes include horizontal panels (and panes), which align their children in a row, and vertical panels (and panes), which align their children in a column. By nesting horizontal and vertical containers, a programmer can achieve most any layout. For - example, we can construct a dialog with the following shape: + example, to construct a dialog with the shape @verbatim[#:indent 2]{ ------------------------------------------------------ @@ -654,10 +705,9 @@ Whenever the user moves the mouse, clicks or releases a mouse button, target window. A program can use the @method[window<%> focus] method to move the focus to a subwindow or to set the initial focus. - Under X, a @indexed-scheme['wheel-up] or @indexed-scheme['wheel-down] + A @indexed-scheme['wheel-up] or @indexed-scheme['wheel-down] event may be sent to a window other than the one with the keyboard - focus, because X generates wheel events based on the location of the - mouse pointer. + focus, depending on how the operating system handles wheel events. A key-press event may correspond to either an actual key press or an auto-key repeat. Multiple key-press events without intervening @@ -942,3 +992,34 @@ This expression installs an exception handler that prints an error handler during the call to @scheme[yield], an error message is printed before control returns to the event dispatcher within @scheme[yield]. + + +@section[#:tag "animation"]{Animation in Canvases} + +The content of a canvas is buffered, so if a canvas must be redrawn, +the @method[canvas% on-paint] method or @racket[paint-callback] function +usually does not need to be called again. To further reduce flicker, +while the @method[canvas% on-paint] method or @racket[paint-callback] function +is called, the windowing system avoids flushing the canvas-content +buffer to the screen. + +Canvas content can be updated at any time by drawing with the result +of the canvas's @method[canvas<%> get-dc] method, and drawing is +thread-safe. Changes to the canvas's content are flushed to the screen +periodically (not necessarily on an event-handling boundary), but the +@method[canvas<%> flush] method immediately flushes to the screen---as +long as flushing has not been suspended. The @method[canvas<%> +suspend-flush] and @method[canvas<%> resume-flush] methods suspend and +resume both automatic and explicit flushes, although on some +platforms, automatic flushes are forced in rare cases. + +For most animation purposes, @method[canvas<%> suspend-flush], +@method[canvas<%> resume-flush], and @method[canvas<%> flush] can be +used to avoid flicker and the need for an additional drawing buffer +for animations. During an animation, bracket the construction of each +animation frame with @method[canvas<%> suspend-flush] and +@method[canvas<%> resume-flush] to ensure that partially drawn frames +are not flushed to the screen. Use @method[canvas<%> flush] to ensure +that canvas content is flushed when it is ready if a @method[canvas<%> +suspend-flush] will soon follow, because the process of flushing to +the screen can be starved if flushing is frequently suspend. diff --git a/collects/scribblings/guide/graphics.scrbl b/collects/scribblings/guide/graphics.scrbl new file mode 100644 index 0000000000..e65a1cc8bd --- /dev/null +++ b/collects/scribblings/guide/graphics.scrbl @@ -0,0 +1,55 @@ +#lang scribble/doc +@(require scribble/manual + "guide-utils.ss") + +@title[#:tag "graphics"]{Graphics and GUIs} + +Racket provides many libraries for graphics and graphical user +interfaces (GUIs): + +@itemlist[ + + @item{The @racketmodname[racket/draw] library provides basic drawing + tools, including drawing contexts such as bitmaps and + PostScript files. + + See @other-doc['(lib "scribblings/draw/draw.scrbl")] + for more information.} + + @item{The @racketmodname[racket/gui] library provides GUI widgets + such as windows, buttons, checkboxes, and text fields. The + library also includes a sophisticated and extensible text + editor. + + See @other-doc['(lib "scribblings/gui/gui.scrbl")] + for more information.} + + @item{The @racketmodname[slideshow/pict] library provides a more + functional abstraction layer over @racketmodname[racket/draw]. + This layer is especially useful for creating slide + presentations with @seclink[#:doc '(lib + "scribblings/slideshow/slideshow.scrbl") "top"]{Slideshow}, but + it is also useful for creating images for @seclink[#:doc '(lib + "scribblings/scribble/scribble.scrbl") "top"]{Scribble} + documents or other drawing tasks. Pictures created with the + @racketmodname[slideshow/pict] library can be rendered to any + drawing context. + + See @other-doc['(lib "scribblings/slideshow/slideshow.scrbl")] + for more information.} + + @item{The @racket[2htdp/image] library is similar to + @racketmodname[slideshow/pict]. It is more streamlined for + pedagogical use, but also slightly more specific to screen and + bitmap drawing. + + See @racket[2htdp/image] for more information.} + + @item{The @racketmodname[sgl] library provides OpenGL for 3-D + graphics. The context for rendering OpenGL can be a window or + bitmap created with @racketmodname[racket/gui]. + + See @other-doc['(lib "sgl/scribblings/sgl.scrbl")] for more + information.} + +] diff --git a/collects/scribblings/guide/other.scrbl b/collects/scribblings/guide/other.scrbl index cfc3e9f5d7..70802e7cac 100644 --- a/collects/scribblings/guide/other.scrbl +++ b/collects/scribblings/guide/other.scrbl @@ -4,17 +4,25 @@ @title{More Libraries} -@other-manual['(lib "scribblings/gui/gui.scrbl")] describes the Racket -graphics toolbox, whose core is implemented by the @exec{gracket} -executable. +This guide covers only the Racket language and libraries that are +documented in @|Racket|. The Racket distribution includes many +additional libraries. + +@include-section["graphics.scrbl"] + +@section{The Web Server} + +@other-manual['(lib "web-server/scribblings/web-server.scrbl")] +describes the Racket web server, which supports servlets implemented +in Racket. + +@section{Using Foreign Libraries} @other-manual['(lib "scribblings/foreign/foreign.scrbl")] describes tools for using Racket to access libraries that are normally used by C programs. -@other-manual['(lib "web-server/scribblings/web-server.scrbl")] -describes the Racket web server, which supports servlets implemented -in Racket. +@section{And More} @link["../index.html"]{Racket Documentation} lists documentation for many other installed libraries. Run @exec{raco docs} to find diff --git a/collects/scribblings/guide/running.scrbl b/collects/scribblings/guide/running.scrbl index 7310ac79b9..10f34c3151 100644 --- a/collects/scribblings/guide/running.scrbl +++ b/collects/scribblings/guide/running.scrbl @@ -18,6 +18,12 @@ explains how to run @exec{racket} and @exec{gracket}. @section[#:tag "racket"]{Running @exec{racket} and @exec{gracket}} +The @exec{gracket} executable is the same as @exec{racket}, but with +small adjustments to behave as a GUI application rather than a console +application. For example, @exec{gracket} by default runs in +interactive mode with a GUI window instead of a console prompt. GUI +applications can be run with plain @exec{racket}, however. + Depending on command-line arguments, @exec{racket} or @exec{gracket} runs in @seclink["start-interactive-mode"]{interactive mode}, @seclink["start-module-mode"]{module mode}, or diff --git a/collects/scribblings/quick/images/exprs.dat b/collects/scribblings/quick/images/exprs.dat index cb78daca61..5df01e094d 100644 --- a/collects/scribblings/quick/images/exprs.dat +++ b/collects/scribblings/quick/images/exprs.dat @@ -1,89 +1,15 @@ -((2) 0 () 0 () () 5) -((2) 0 () 0 () () 5) -((2) 0 () 0 () () (c begin c "art gallery")) -((2) 0 () 0 () () "art gallery") -((2) 0 () 0 () () (c circle c 10)) -((2) 1 (((lib "scribble/core.rkt") . deserialize-info:image-element-v0)) 0 () () (0 #f (c "[image]") (u . "images/img0") (c ".pdf" c ".png") 1.0)) -((2) 0 () 0 () () (c rectangle c 10 c 20)) -((2) 1 (((lib "scribble/core.rkt") . deserialize-info:image-element-v0)) 0 () () (0 #f (c "[image]") (u . "images/img1") (c ".pdf" c ".png") 1.0)) -((2) 0 () 0 () () (c circle c 10 c 20)) -((2) 1 (((lib "scriblib/private/gui-eval-exn.rkt") . deserialize-info:gui-exn-v0)) 0 () () (0 "procedure circle: expects 1 argument, given 2: 10 20")) -((2) 0 () 0 () () (c hc-append c (c circle c 10) c (c rectangle c 10 c 20))) -((2) 1 (((lib "scribble/core.rkt") . deserialize-info:image-element-v0)) 0 () () (0 #f (c "[image]") (u . "images/img2") (c ".pdf" c ".png") 1.0)) -((2) 0 () 0 () () (c define c c c (c circle c 10))) -((2) 0 () 0 () () (void)) -((2) 0 () 0 () () (c define c r c (c rectangle c 10 c 20))) -((2) 0 () 0 () () (void)) -((2) 0 () 0 () () r) -((2) 1 (((lib "scribble/core.rkt") . deserialize-info:image-element-v0)) 0 () () (0 #f (c "[image]") (u . "images/img3") (c ".pdf" c ".png") 1.0)) -((2) 0 () 0 () () (c hc-append c c c r)) -((2) 1 (((lib "scribble/core.rkt") . deserialize-info:image-element-v0)) 0 () () (0 #f (c "[image]") (u . "images/img4") (c ".pdf" c ".png") 1.0)) -((2) 0 () 0 () () (c hc-append c 20 c c c r c c)) -((2) 1 (((lib "scribble/core.rkt") . deserialize-info:image-element-v0)) 0 () () (0 #f (c "[image]") (u . "images/img5") (c ".pdf" c ".png") 1.0)) -((2) 0 () 0 () () (c define c (c square c n) c (c filled-rectangle c n c n))) -((2) 0 () 0 () () (void)) -((2) 0 () 0 () () (c square c 10)) -((2) 1 (((lib "scribble/core.rkt") . deserialize-info:image-element-v0)) 0 () () (0 #f (c "[image]") (u . "images/img6") (c ".pdf" c ".png") 1.0)) -((2) 0 () 0 () () (c define c (c four c p) c (c define c two-p c (c hc-append c p c p)) c (c vc-append c two-p c two-p))) -((2) 0 () 0 () () (void)) -((2) 0 () 0 () () (c four c (c circle c 10))) -((2) 1 (((lib "scribble/core.rkt") . deserialize-info:image-element-v0)) 0 () () (0 #f (c "[image]") (u . "images/img7") (c ".pdf" c ".png") 1.0)) -((2) 0 () 0 () () (c define c (c checker c p1 c p2) c (c let c (c (c p12 c (c hc-append c p1 c p2)) c (c p21 c (c hc-append c p2 c p1))) c (c vc-append c p12 c p21)))) -((2) 0 () 0 () () (void)) -((2) 0 () 0 () () (c checker c (c colorize c (c square c 10) c "red") c (c colorize c (c square c 10) c "black"))) -((2) 1 (((lib "scribble/core.rkt") . deserialize-info:image-element-v0)) 0 () () (0 #f (c "[image]") (u . "images/img8") (c ".pdf" c ".png") 1.0)) -((2) 0 () 0 () () (c define c (c checkerboard c p) c (c let* c (c (c rp c (c colorize c p c "red")) c (c bp c (c colorize c p c "black")) c (c c c (c checker c rp c bp)) c (c c4 c (c four c c))) c (c four c c4)))) -((2) 0 () 0 () () (void)) -((2) 0 () 0 () () (c checkerboard c (c square c 10))) -((2) 1 (((lib "scribble/core.rkt") . deserialize-info:image-element-v0)) 0 () () (0 #f (c "[image]") (u . "images/img9") (c ".pdf" c ".png") 1.0)) -((2) 0 () 0 () () circle) -((2) 1 (((lib "scribble/core.rkt") . deserialize-info:element-v0)) 0 () () (0 #f (c (u . "#")))) -((2) 0 () 0 () () (c define c (c series c mk) c (c hc-append c 4 c (c mk c 5) c (c mk c 10) c (c mk c 20)))) -((2) 0 () 0 () () (void)) -((2) 0 () 0 () () (c series c circle)) -((2) 1 (((lib "scribble/core.rkt") . deserialize-info:image-element-v0)) 0 () () (0 #f (c "[image]") (u . "images/img10") (c ".pdf" c ".png") 1.0)) -((2) 0 () 0 () () (c series c square)) -((2) 1 (((lib "scribble/core.rkt") . deserialize-info:image-element-v0)) 0 () () (0 #f (c "[image]") (u . "images/img11") (c ".pdf" c ".png") 1.0)) -((2) 0 () 0 () () (c series c (c lambda c (c size) c (c checkerboard c (c square c size))))) -((2) 1 (((lib "scribble/core.rkt") . deserialize-info:image-element-v0)) 0 () () (0 #f (c "[image]") (u . "images/img12") (c ".pdf" c ".png") 1.0)) -((2) 0 () 0 () () (c define c (c rgb-series c mk) c (c vc-append c (c series c (c lambda c (c sz) c (c colorize c (c mk c sz) c "red"))) c (c series c (c lambda c (c sz) c (c colorize c (c mk c sz) c "green"))) c (c series c (c lambda c (c sz) c (c colorize c (c mk c sz) c "blue")))))) -((2) 0 () 0 () () (void)) -((2) 0 () 0 () () (c rgb-series c circle)) -((2) 1 (((lib "scribble/core.rkt") . deserialize-info:image-element-v0)) 0 () () (0 #f (c "[image]") (u . "images/img13") (c ".pdf" c ".png") 1.0)) -((2) 0 () 0 () () (c rgb-series c square)) -((2) 1 (((lib "scribble/core.rkt") . deserialize-info:image-element-v0)) 0 () () (0 #f (c "[image]") (u . "images/img14") (c ".pdf" c ".png") 1.0)) -((2) 0 () 0 () () (c define c (c rgb-maker c mk) c (c lambda c (c sz) c (c vc-append c (c colorize c (c mk c sz) c "red") c (c colorize c (c mk c sz) c "green") c (c colorize c (c mk c sz) c "blue"))))) -((2) 0 () 0 () () (void)) -((2) 0 () 0 () () (c series c (c rgb-maker c circle))) -((2) 1 (((lib "scribble/core.rkt") . deserialize-info:image-element-v0)) 0 () () (0 #f (c "[image]") (u . "images/img15") (c ".pdf" c ".png") 1.0)) -((2) 0 () 0 () () (c series c (c rgb-maker c square))) -((2) 1 (((lib "scribble/core.rkt") . deserialize-info:image-element-v0)) 0 () () (0 #f (c "[image]") (u . "images/img16") (c ".pdf" c ".png") 1.0)) -((2) 0 () 0 () () (c list c "red" c "green" c "blue")) -((2) 0 () 0 () () (c "red" c "green" c "blue")) -((2) 0 () 0 () () (c list c (c circle c 10) c (c square c 10))) -((2) 1 (((lib "scribble/core.rkt") . deserialize-info:image-element-v0)) 2 ("[image]" (c ".pdf" c ".png")) () (c (0 #f (c (? . 0)) (u . "images/img17") (? . 1) 1.0) c (0 #f (c (? . 0)) (u . "images/img18") (? . 1) 1.0))) -((2) 0 () 0 () () (c define c (c rainbow c p) c (c map c (c lambda c (c color) c (c colorize c p c color)) c (c list c "red" c "orange" c "yellow" c "green" c "blue" c "purple")))) -((2) 0 () 0 () () (void)) -((2) 0 () 0 () () (c rainbow c (c square c 5))) -((2) 1 (((lib "scribble/core.rkt") . deserialize-info:image-element-v0)) 2 ("[image]" (c ".pdf" c ".png")) () (c (0 #f (c (? . 0)) (u . "images/img19") (? . 1) 1.0) c (0 #f (c (? . 0)) (u . "images/img20") (? . 1) 1.0) c (0 #f (c (? . 0)) (u . "images/img21") (? . 1) 1.0) c (0 #f (c (? . 0)) (u . "images/img22") (? . 1) 1.0) c (0 #f (c (? . 0)) (u . "images/img23") (? . 1) 1.0) c (0 #f (c (? . 0)) (u . "images/img24") (? . 1) 1.0))) -((2) 0 () 0 () () (c apply c vc-append c (c rainbow c (c square c 5)))) -((2) 1 (((lib "scribble/core.rkt") . deserialize-info:image-element-v0)) 0 () () (0 #f (c "[image]") (u . "images/img25") (c ".pdf" c ".png") 1.0)) -((2) 0 () 0 () () (c require c slideshow/flash)) -((2) 0 () 0 () () (void)) -((2) 0 () 0 () () (c filled-flash c 40 c 30)) -((2) 1 (((lib "scribble/core.rkt") . deserialize-info:image-element-v0)) 0 () () (0 #f (c "[image]") (u . "images/img26") (c ".pdf" c ".png") 1.0)) -((2) 0 () 0 () () (c require c (c planet c "random.rkt" c (c "schematics" c "random.plt" c 1 c 0)))) +((2) 0 () 0 () () (c require c (c planet c schematics/random:1:0/random))) ((2) 0 () 0 () () (void)) ((2) 0 () 0 () () (c random-gaussian)) ((2) 0 () 0 () () 0.7386912134436788) ((2) 0 () 0 () () (c require c slideshow/code)) ((2) 0 () 0 () () (void)) ((2) 0 () 0 () () (c code c (c circle c 10))) -((2) 1 (((lib "scribble/core.rkt") . deserialize-info:image-element-v0)) 0 () () (0 #f (c "[image]") (u . "images/img27") (c ".pdf" c ".png") 1.0)) +((2) 1 (((lib "scribble/core.rkt") . deserialize-info:image-element-v0)) 0 () () (0 #f (c "[image]") (u . "images/img0") (c ".pdf" c ".png") 1.0)) ((2) 0 () 0 () () (c define-syntax c pict+code c (c syntax-rules c () c (c (c pict+code c expr) c (c hc-append c 10 c expr c (c code c expr)))))) ((2) 0 () 0 () () (void)) ((2) 0 () 0 () () (c pict+code c (c circle c 10))) -((2) 1 (((lib "scribble/core.rkt") . deserialize-info:image-element-v0)) 0 () () (0 #f (c "[image]") (u . "images/img28") (c ".pdf" c ".png") 1.0)) +((2) 1 (((lib "scribble/core.rkt") . deserialize-info:image-element-v0)) 0 () () (0 #f (c "[image]") (u . "images/img1") (c ".pdf" c ".png") 1.0)) ((2) 0 () 0 () () (c require c racket/class c racket/gui/base)) ((2) 0 () 0 () () (void)) ((2) 0 () 0 () () (c define c f c (c new c frame% c (c label c "My Art") c (c width c 300) c (c height c 300) c (c alignment c (c quote c (c center c center)))))) @@ -97,6 +23,6 @@ ((2) 0 () 0 () () (c add-drawing c (c pict+code c (c circle c 10)))) ((2) 1 (((lib "scribble/core.rkt") . deserialize-info:element-v0)) 0 () () (0 #f (c (u . "#(struct:object:canvas% ...)")))) ((2) 0 () 0 () () (c add-drawing c (c colorize c (c filled-flash c 50 c 30) c "yellow"))) -((2) 1 (((lib "scribble/core.rkt") . deserialize-info:element-v0)) 0 () () (0 #f (c (u . "#(struct:object:canvas% ...)")))) +((2) 1 (((lib "scriblib/private/gui-eval-exn.rkt") . deserialize-info:gui-exn-v0)) 0 () () (0 "reference to undefined identifier: filled-flash")) ((2) 0 () 0 () () (c scale c (c bitmap c (c build-path c (c collection-path c "scribblings/quick") c "art.png")) c 0.5)) -((2) 1 (((lib "scribble/core.rkt") . deserialize-info:image-element-v0)) 0 () () (0 #f (c "[image]") (u . "images/img29") (c ".pdf" c ".png") 1.0)) +((2) 1 (((lib "scribble/core.rkt") . deserialize-info:image-element-v0)) 0 () () (0 #f (c "[image]") (u . "images/img2") (c ".pdf" c ".png") 1.0)) diff --git a/collects/scribblings/quick/images/img0.pdf b/collects/scribblings/quick/images/img0.pdf index 25438957a6..4d8e7d9496 100644 Binary files a/collects/scribblings/quick/images/img0.pdf and b/collects/scribblings/quick/images/img0.pdf differ diff --git a/collects/scribblings/quick/images/img0.png b/collects/scribblings/quick/images/img0.png index ecaba56e73..f479d36f93 100644 Binary files a/collects/scribblings/quick/images/img0.png and b/collects/scribblings/quick/images/img0.png differ diff --git a/collects/scribblings/quick/images/img1.pdf b/collects/scribblings/quick/images/img1.pdf index 0cb18631b6..85664a1388 100644 Binary files a/collects/scribblings/quick/images/img1.pdf and b/collects/scribblings/quick/images/img1.pdf differ diff --git a/collects/scribblings/quick/images/img1.png b/collects/scribblings/quick/images/img1.png index b45fa1cb6f..5f2c07464f 100644 Binary files a/collects/scribblings/quick/images/img1.png and b/collects/scribblings/quick/images/img1.png differ diff --git a/collects/scribblings/quick/images/img10.pdf b/collects/scribblings/quick/images/img10.pdf deleted file mode 100644 index 5d70606044..0000000000 --- a/collects/scribblings/quick/images/img10.pdf +++ /dev/null @@ -1,80 +0,0 @@ -%PDF-1.4 -%쏢 -5 0 obj -<> -stream -xEKn1D8fiQ~(ӣy?,IYz7%?RE\U~@QgMKe'u:eQ?lS(b0?Ob%:#(- c͞dR5H4; l<)4<9mN:acd=\RD:LGd"*j^h<. tW!R:endstream -endobj -6 0 obj -214 -endobj -4 0 obj -<> -/Contents 5 0 R ->> -endobj -3 0 obj -<< /Type /Pages /Kids [ -4 0 R -] /Count 1 ->> -endobj -1 0 obj -<> -endobj -7 0 obj -<>endobj -8 0 obj -<> -endobj -9 0 obj -<>stream - - - - - -PLT Scheme - -Untitledmflatt@Macintosh \(Matthew Flatt\) - - - - - -endstream -endobj -2 0 obj -<>endobj -xref -0 10 -0000000000 65535 f -0000000506 00000 n -0000002090 00000 n -0000000447 00000 n -0000000318 00000 n -0000000015 00000 n -0000000299 00000 n -0000000570 00000 n -0000000611 00000 n -0000000640 00000 n -trailer -<< /Size 10 /Root 1 0 R /Info 2 0 R -/ID [<773F739C40C01D398B1ACA4FA8323A87><773F739C40C01D398B1ACA4FA8323A87>] ->> -startxref -2278 -%%EOF diff --git a/collects/scribblings/quick/images/img10.png b/collects/scribblings/quick/images/img10.png deleted file mode 100644 index 626c2649aa..0000000000 Binary files a/collects/scribblings/quick/images/img10.png and /dev/null differ diff --git a/collects/scribblings/quick/images/img11.pdf b/collects/scribblings/quick/images/img11.pdf deleted file mode 100644 index bbf27fdc69..0000000000 Binary files a/collects/scribblings/quick/images/img11.pdf and /dev/null differ diff --git a/collects/scribblings/quick/images/img11.png b/collects/scribblings/quick/images/img11.png deleted file mode 100644 index a8ea2528e8..0000000000 Binary files a/collects/scribblings/quick/images/img11.png and /dev/null differ diff --git a/collects/scribblings/quick/images/img12.pdf b/collects/scribblings/quick/images/img12.pdf deleted file mode 100644 index bf80744b7b..0000000000 Binary files a/collects/scribblings/quick/images/img12.pdf and /dev/null differ diff --git a/collects/scribblings/quick/images/img12.png b/collects/scribblings/quick/images/img12.png deleted file mode 100644 index fa40ec0c6d..0000000000 Binary files a/collects/scribblings/quick/images/img12.png and /dev/null differ diff --git a/collects/scribblings/quick/images/img13.pdf b/collects/scribblings/quick/images/img13.pdf deleted file mode 100644 index c0045d2a2c..0000000000 Binary files a/collects/scribblings/quick/images/img13.pdf and /dev/null differ diff --git a/collects/scribblings/quick/images/img13.png b/collects/scribblings/quick/images/img13.png deleted file mode 100644 index 5716b93b17..0000000000 Binary files a/collects/scribblings/quick/images/img13.png and /dev/null differ diff --git a/collects/scribblings/quick/images/img14.pdf b/collects/scribblings/quick/images/img14.pdf deleted file mode 100644 index 9b4e55ba98..0000000000 --- a/collects/scribblings/quick/images/img14.pdf +++ /dev/null @@ -1,80 +0,0 @@ -%PDF-1.4 -%쏢 -5 0 obj -<> -stream -xm1 Ew'hl Tp*TCӡ/6a0B|{#]Iq_0, OI+> -/Contents 5 0 R ->> -endobj -3 0 obj -<< /Type /Pages /Kids [ -4 0 R -] /Count 1 ->> -endobj -1 0 obj -<> -endobj -7 0 obj -<>endobj -8 0 obj -<> -endobj -9 0 obj -<>stream - - - - - -PLT Scheme - -Untitledmflatt@Macintosh \(Matthew Flatt\) - - - - - -endstream -endobj -2 0 obj -<>endobj -xref -0 10 -0000000000 65535 f -0000000443 00000 n -0000002027 00000 n -0000000384 00000 n -0000000255 00000 n -0000000015 00000 n -0000000236 00000 n -0000000507 00000 n -0000000548 00000 n -0000000577 00000 n -trailer -<< /Size 10 /Root 1 0 R /Info 2 0 R -/ID [] ->> -startxref -2215 -%%EOF diff --git a/collects/scribblings/quick/images/img14.png b/collects/scribblings/quick/images/img14.png deleted file mode 100644 index 29ee39aab5..0000000000 Binary files a/collects/scribblings/quick/images/img14.png and /dev/null differ diff --git a/collects/scribblings/quick/images/img15.pdf b/collects/scribblings/quick/images/img15.pdf deleted file mode 100644 index b84d3dd08b..0000000000 Binary files a/collects/scribblings/quick/images/img15.pdf and /dev/null differ diff --git a/collects/scribblings/quick/images/img15.png b/collects/scribblings/quick/images/img15.png deleted file mode 100644 index e2eb4ca1f3..0000000000 Binary files a/collects/scribblings/quick/images/img15.png and /dev/null differ diff --git a/collects/scribblings/quick/images/img16.pdf b/collects/scribblings/quick/images/img16.pdf deleted file mode 100644 index 10364af170..0000000000 --- a/collects/scribblings/quick/images/img16.pdf +++ /dev/null @@ -1,80 +0,0 @@ -%PDF-1.4 -%쏢 -5 0 obj -<> -stream -xmQ @{@[c70qKLp~x}[ʺחҎtqzCycopгGO~*gs9ʲ9J ,YGM"ZXQ'jGM!q_2r6J\KݠMҕYsW,}hendstream -endobj -6 0 obj -162 -endobj -4 0 obj -<> -/Contents 5 0 R ->> -endobj -3 0 obj -<< /Type /Pages /Kids [ -4 0 R -] /Count 1 ->> -endobj -1 0 obj -<> -endobj -7 0 obj -<>endobj -8 0 obj -<> -endobj -9 0 obj -<>stream - - - - - -PLT Scheme - -Untitledmflatt@Macintosh \(Matthew Flatt\) - - - - - -endstream -endobj -2 0 obj -<>endobj -xref -0 10 -0000000000 65535 f -0000000454 00000 n -0000002038 00000 n -0000000395 00000 n -0000000266 00000 n -0000000015 00000 n -0000000247 00000 n -0000000518 00000 n -0000000559 00000 n -0000000588 00000 n -trailer -<< /Size 10 /Root 1 0 R /Info 2 0 R -/ID [<2D22C5E6138860AE600CF56ED7C7E964><2D22C5E6138860AE600CF56ED7C7E964>] ->> -startxref -2226 -%%EOF diff --git a/collects/scribblings/quick/images/img16.png b/collects/scribblings/quick/images/img16.png deleted file mode 100644 index 19c3aef5ff..0000000000 Binary files a/collects/scribblings/quick/images/img16.png and /dev/null differ diff --git a/collects/scribblings/quick/images/img17.pdf b/collects/scribblings/quick/images/img17.pdf deleted file mode 100644 index 423035879b..0000000000 Binary files a/collects/scribblings/quick/images/img17.pdf and /dev/null differ diff --git a/collects/scribblings/quick/images/img17.png b/collects/scribblings/quick/images/img17.png deleted file mode 100644 index ecaba56e73..0000000000 Binary files a/collects/scribblings/quick/images/img17.png and /dev/null differ diff --git a/collects/scribblings/quick/images/img18.pdf b/collects/scribblings/quick/images/img18.pdf deleted file mode 100644 index 766c59b57a..0000000000 Binary files a/collects/scribblings/quick/images/img18.pdf and /dev/null differ diff --git a/collects/scribblings/quick/images/img18.png b/collects/scribblings/quick/images/img18.png deleted file mode 100644 index a81d97a88f..0000000000 Binary files a/collects/scribblings/quick/images/img18.png and /dev/null differ diff --git a/collects/scribblings/quick/images/img19.pdf b/collects/scribblings/quick/images/img19.pdf deleted file mode 100644 index b8e14fbdc0..0000000000 Binary files a/collects/scribblings/quick/images/img19.pdf and /dev/null differ diff --git a/collects/scribblings/quick/images/img19.png b/collects/scribblings/quick/images/img19.png deleted file mode 100644 index c01258374c..0000000000 Binary files a/collects/scribblings/quick/images/img19.png and /dev/null differ diff --git a/collects/scribblings/quick/images/img2.pdf b/collects/scribblings/quick/images/img2.pdf index 94573b751b..6be681c83f 100644 Binary files a/collects/scribblings/quick/images/img2.pdf and b/collects/scribblings/quick/images/img2.pdf differ diff --git a/collects/scribblings/quick/images/img2.png b/collects/scribblings/quick/images/img2.png index 60119f0842..139cbed1ef 100644 Binary files a/collects/scribblings/quick/images/img2.png and b/collects/scribblings/quick/images/img2.png differ diff --git a/collects/scribblings/quick/images/img20.pdf b/collects/scribblings/quick/images/img20.pdf deleted file mode 100644 index c26e315d45..0000000000 Binary files a/collects/scribblings/quick/images/img20.pdf and /dev/null differ diff --git a/collects/scribblings/quick/images/img20.png b/collects/scribblings/quick/images/img20.png deleted file mode 100644 index bcef5d38b1..0000000000 Binary files a/collects/scribblings/quick/images/img20.png and /dev/null differ diff --git a/collects/scribblings/quick/images/img21.pdf b/collects/scribblings/quick/images/img21.pdf deleted file mode 100644 index 0a66ba9f0d..0000000000 Binary files a/collects/scribblings/quick/images/img21.pdf and /dev/null differ diff --git a/collects/scribblings/quick/images/img21.png b/collects/scribblings/quick/images/img21.png deleted file mode 100644 index 4a9e94375d..0000000000 Binary files a/collects/scribblings/quick/images/img21.png and /dev/null differ diff --git a/collects/scribblings/quick/images/img22.pdf b/collects/scribblings/quick/images/img22.pdf deleted file mode 100644 index 93e545155f..0000000000 Binary files a/collects/scribblings/quick/images/img22.pdf and /dev/null differ diff --git a/collects/scribblings/quick/images/img22.png b/collects/scribblings/quick/images/img22.png deleted file mode 100644 index e41b869fd2..0000000000 Binary files a/collects/scribblings/quick/images/img22.png and /dev/null differ diff --git a/collects/scribblings/quick/images/img23.pdf b/collects/scribblings/quick/images/img23.pdf deleted file mode 100644 index 5abb060e1a..0000000000 Binary files a/collects/scribblings/quick/images/img23.pdf and /dev/null differ diff --git a/collects/scribblings/quick/images/img23.png b/collects/scribblings/quick/images/img23.png deleted file mode 100644 index a0eab57204..0000000000 Binary files a/collects/scribblings/quick/images/img23.png and /dev/null differ diff --git a/collects/scribblings/quick/images/img24.pdf b/collects/scribblings/quick/images/img24.pdf deleted file mode 100644 index 42da18e9e2..0000000000 Binary files a/collects/scribblings/quick/images/img24.pdf and /dev/null differ diff --git a/collects/scribblings/quick/images/img24.png b/collects/scribblings/quick/images/img24.png deleted file mode 100644 index 799dff9896..0000000000 Binary files a/collects/scribblings/quick/images/img24.png and /dev/null differ diff --git a/collects/scribblings/quick/images/img25.pdf b/collects/scribblings/quick/images/img25.pdf deleted file mode 100644 index cb04e4b6a3..0000000000 --- a/collects/scribblings/quick/images/img25.pdf +++ /dev/null @@ -1,81 +0,0 @@ -%PDF-1.4 -%쏢 -5 0 obj -<> -stream -xuM -0Fs 8=НD 뛙 })~zy@7.!#^V.%˼ԶfM"Wi\ Tܠ21cytE!42B#3AZIlJi|Nendstream -endobj -6 0 obj -152 -endobj -4 0 obj -<> -/Contents 5 0 R ->> -endobj -3 0 obj -<< /Type /Pages /Kids [ -4 0 R -] /Count 1 ->> -endobj -1 0 obj -<> -endobj -7 0 obj -<>endobj -8 0 obj -<> -endobj -9 0 obj -<>stream - - - - - -PLT Scheme - -Untitledmflatt@Macintosh \(Matthew Flatt\) - - - - - -endstream -endobj -2 0 obj -<>endobj -xref -0 10 -0000000000 65535 f -0000000443 00000 n -0000002027 00000 n -0000000384 00000 n -0000000256 00000 n -0000000015 00000 n -0000000237 00000 n -0000000507 00000 n -0000000548 00000 n -0000000577 00000 n -trailer -<< /Size 10 /Root 1 0 R /Info 2 0 R -/ID [] ->> -startxref -2215 -%%EOF diff --git a/collects/scribblings/quick/images/img25.png b/collects/scribblings/quick/images/img25.png deleted file mode 100644 index e4d4b58336..0000000000 Binary files a/collects/scribblings/quick/images/img25.png and /dev/null differ diff --git a/collects/scribblings/quick/images/img26.pdf b/collects/scribblings/quick/images/img26.pdf deleted file mode 100644 index d979ba6be1..0000000000 --- a/collects/scribblings/quick/images/img26.pdf +++ /dev/null @@ -1,80 +0,0 @@ -%PDF-1.4 -%쏢 -5 0 obj -<> -stream -x퐽 1 {O؉MD1@!EQ|~~7d|ӀQH"^! Jg/l$UAMhK$2P㷆KРGHf 4v酙:L1ZڛdӮ_,rfJM T\u+jCW5>Apx-'^؎{endstream -endobj -6 0 obj -196 -endobj -4 0 obj -<> -/Contents 5 0 R ->> -endobj -3 0 obj -<< /Type /Pages /Kids [ -4 0 R -] /Count 1 ->> -endobj -1 0 obj -<> -endobj -7 0 obj -<>endobj -8 0 obj -<> -endobj -9 0 obj -<>stream - - - - - -PLT Scheme - -Untitledmflatt@Macintosh \(Matthew Flatt\) - - - - - -endstream -endobj -2 0 obj -<>endobj -xref -0 10 -0000000000 65535 f -0000000488 00000 n -0000002072 00000 n -0000000429 00000 n -0000000300 00000 n -0000000015 00000 n -0000000281 00000 n -0000000552 00000 n -0000000593 00000 n -0000000622 00000 n -trailer -<< /Size 10 /Root 1 0 R /Info 2 0 R -/ID [<6C51B73DC3A90C9A3E8D707F4552676C><6C51B73DC3A90C9A3E8D707F4552676C>] ->> -startxref -2260 -%%EOF diff --git a/collects/scribblings/quick/images/img26.png b/collects/scribblings/quick/images/img26.png deleted file mode 100644 index 21a87515c1..0000000000 Binary files a/collects/scribblings/quick/images/img26.png and /dev/null differ diff --git a/collects/scribblings/quick/images/img27.pdf b/collects/scribblings/quick/images/img27.pdf deleted file mode 100644 index 4c0667c991..0000000000 Binary files a/collects/scribblings/quick/images/img27.pdf and /dev/null differ diff --git a/collects/scribblings/quick/images/img27.png b/collects/scribblings/quick/images/img27.png deleted file mode 100644 index 994c76743d..0000000000 Binary files a/collects/scribblings/quick/images/img27.png and /dev/null differ diff --git a/collects/scribblings/quick/images/img28.pdf b/collects/scribblings/quick/images/img28.pdf deleted file mode 100644 index 63cf5f2e8f..0000000000 Binary files a/collects/scribblings/quick/images/img28.pdf and /dev/null differ diff --git a/collects/scribblings/quick/images/img28.png b/collects/scribblings/quick/images/img28.png deleted file mode 100644 index 74697eb3db..0000000000 Binary files a/collects/scribblings/quick/images/img28.png and /dev/null differ diff --git a/collects/scribblings/quick/images/img29.pdf b/collects/scribblings/quick/images/img29.pdf deleted file mode 100644 index 709afd4a14..0000000000 Binary files a/collects/scribblings/quick/images/img29.pdf and /dev/null differ diff --git a/collects/scribblings/quick/images/img29.png b/collects/scribblings/quick/images/img29.png deleted file mode 100644 index 1166306162..0000000000 Binary files a/collects/scribblings/quick/images/img29.png and /dev/null differ diff --git a/collects/scribblings/quick/images/img3.pdf b/collects/scribblings/quick/images/img3.pdf deleted file mode 100644 index d0d2fbb178..0000000000 Binary files a/collects/scribblings/quick/images/img3.pdf and /dev/null differ diff --git a/collects/scribblings/quick/images/img3.png b/collects/scribblings/quick/images/img3.png deleted file mode 100644 index b45fa1cb6f..0000000000 Binary files a/collects/scribblings/quick/images/img3.png and /dev/null differ diff --git a/collects/scribblings/quick/images/img4.pdf b/collects/scribblings/quick/images/img4.pdf deleted file mode 100644 index b97703e6c6..0000000000 --- a/collects/scribblings/quick/images/img4.pdf +++ /dev/null @@ -1,82 +0,0 @@ -%PDF-1.4 -%쏢 -5 0 obj -<> -stream -x=MA0 ~ATcK_čjBB8}Ң$L -FuLۊ[(.>ilg1<(3h0wk꧜$ -2zBv_\ U$endstream -endobj -6 0 obj -120 -endobj -4 0 obj -<> -/Contents 5 0 R ->> -endobj -3 0 obj -<< /Type /Pages /Kids [ -4 0 R -] /Count 1 ->> -endobj -1 0 obj -<> -endobj -7 0 obj -<>endobj -8 0 obj -<> -endobj -9 0 obj -<>stream - - - - - -PLT Scheme - -Untitledmflatt@Macintosh \(Matthew Flatt\) - - - - - -endstream -endobj -2 0 obj -<>endobj -xref -0 10 -0000000000 65535 f -0000000412 00000 n -0000001996 00000 n -0000000353 00000 n -0000000224 00000 n -0000000015 00000 n -0000000205 00000 n -0000000476 00000 n -0000000517 00000 n -0000000546 00000 n -trailer -<< /Size 10 /Root 1 0 R /Info 2 0 R -/ID [<18F7F7D89292F20542678B75862EDC0C><18F7F7D89292F20542678B75862EDC0C>] ->> -startxref -2184 -%%EOF diff --git a/collects/scribblings/quick/images/img4.png b/collects/scribblings/quick/images/img4.png deleted file mode 100644 index 60119f0842..0000000000 Binary files a/collects/scribblings/quick/images/img4.png and /dev/null differ diff --git a/collects/scribblings/quick/images/img5.pdf b/collects/scribblings/quick/images/img5.pdf deleted file mode 100644 index f04c3d80a8..0000000000 Binary files a/collects/scribblings/quick/images/img5.pdf and /dev/null differ diff --git a/collects/scribblings/quick/images/img5.png b/collects/scribblings/quick/images/img5.png deleted file mode 100644 index d4b4a480f9..0000000000 Binary files a/collects/scribblings/quick/images/img5.png and /dev/null differ diff --git a/collects/scribblings/quick/images/img6.pdf b/collects/scribblings/quick/images/img6.pdf deleted file mode 100644 index 495d919428..0000000000 Binary files a/collects/scribblings/quick/images/img6.pdf and /dev/null differ diff --git a/collects/scribblings/quick/images/img6.png b/collects/scribblings/quick/images/img6.png deleted file mode 100644 index a81d97a88f..0000000000 Binary files a/collects/scribblings/quick/images/img6.png and /dev/null differ diff --git a/collects/scribblings/quick/images/img7.pdf b/collects/scribblings/quick/images/img7.pdf deleted file mode 100644 index 5d91589518..0000000000 Binary files a/collects/scribblings/quick/images/img7.pdf and /dev/null differ diff --git a/collects/scribblings/quick/images/img7.png b/collects/scribblings/quick/images/img7.png deleted file mode 100644 index afcd6602cd..0000000000 Binary files a/collects/scribblings/quick/images/img7.png and /dev/null differ diff --git a/collects/scribblings/quick/images/img8.pdf b/collects/scribblings/quick/images/img8.pdf deleted file mode 100644 index 6666f2d535..0000000000 Binary files a/collects/scribblings/quick/images/img8.pdf and /dev/null differ diff --git a/collects/scribblings/quick/images/img8.png b/collects/scribblings/quick/images/img8.png deleted file mode 100644 index aadb50cf8a..0000000000 Binary files a/collects/scribblings/quick/images/img8.png and /dev/null differ diff --git a/collects/scribblings/quick/images/img9.pdf b/collects/scribblings/quick/images/img9.pdf deleted file mode 100644 index e106eda746..0000000000 Binary files a/collects/scribblings/quick/images/img9.pdf and /dev/null differ diff --git a/collects/scribblings/quick/images/img9.png b/collects/scribblings/quick/images/img9.png deleted file mode 100644 index 0dca5c1ff8..0000000000 Binary files a/collects/scribblings/quick/images/img9.png and /dev/null differ diff --git a/collects/scribblings/quick/mreval.rkt b/collects/scribblings/quick/mreval.rkt index 14c1c969c3..22756b5aa8 100644 --- a/collects/scribblings/quick/mreval.rkt +++ b/collects/scribblings/quick/mreval.rkt @@ -1,6 +1,6 @@ #lang racket/base - -(require scriblib/gui-eval) +(require scribble/eval + scriblib/gui-eval) (provide (rename-out [gui-interaction mr-interaction] [gui-interaction-eval mr-interaction-eval] @@ -9,3 +9,24 @@ [gui-def+int mr-def+int] [gui-defs+int mr-defs+int] [gui-interaction-eval-show mr-interaction-eval-show])) + +(define ss-eval (make-base-eval)) +(void (interaction-eval #:eval ss-eval (require slideshow/pict))) + +(define-syntax-rule (ss-interaction e ...) + (interaction #:eval ss-eval e ...)) +(define-syntax-rule (ss-interaction-eval e ...) + (interaction-eval #:eval ss-eval e ...)) +(define-syntax-rule (ss-racketmod+eval e ...) + (racketmod+eval #:eval ss-eval e ...)) +(define-syntax-rule (ss-racketblock+eval e ...) + (racketblock+eval #:eval ss-eval e ...)) +(define-syntax-rule (ss-def+int e ...) + (def+int #:eval ss-eval e ...)) + +(provide ss-interaction + ss-interaction-eval + ss-racketmod+eval + ss-racketblock+eval + ss-def+int) + diff --git a/collects/scribblings/quick/quick.scrbl b/collects/scribblings/quick/quick.scrbl index 1db0541b42..514ff0641a 100644 --- a/collects/scribblings/quick/quick.scrbl +++ b/collects/scribblings/quick/quick.scrbl @@ -66,13 +66,13 @@ window and hit Enter, DrRacket evaluates the expression and prints its result. An expression can be just a value, such as the number @racket[5] or the string @racket["art gallery"]: -@mr-interaction[5 "art gallery"] +@ss-interaction[5 "art gallery"] An expression can also be a function call. To call a function, put an open parenthesis before the function name, then expressions for the function arguments, and then a close parenthesis, like this: -@mr-interaction[(circle 10)] +@ss-interaction[(circle 10)] A result from the @racket[circle] function is a picture value, which prints as an expression result in much the same way that numbers or @@ -80,12 +80,12 @@ strings print. The argument to @racket[circle] determines the circle's size in pixels. As you might guess, there's a @racket[rectangle] function that takes two arguments instead of one: -@mr-interaction[(rectangle 10 20)] +@ss-interaction[(rectangle 10 20)] Try giving @racket[circle] the wrong number of arguments, just to see what happens: -@mr-interaction[(circle 10 20)] +@ss-interaction[(circle 10 20)] Note that DrRacket highlights in pink the expression that triggered the error (but pink highlighting is not shown in this documentation). @@ -95,7 +95,7 @@ In addition to basic picture constructors like @racket[circle] and combines pictures. When you start composing function calls in Racket, it looks like this: -@mr-interaction[(hc-append (circle 10) (rectangle 10 20))] +@ss-interaction[(hc-append (circle 10) (rectangle 10 20))] The hyphen in the name @racket[hc-append] is just a part of the identifier; it's not @racketidfont{hc} minus @@ -122,7 +122,7 @@ simpler to give them names. Move back to the definitions area (the top area) and add two definitions, so that the complete content of the definitions area looks like this: -@mr-racketmod+eval[ +@ss-racketmod+eval[ slideshow (define c (circle 10)) (define r (rectangle 10 20)) @@ -131,7 +131,7 @@ slideshow Then click @onscreen{Run} again. Now, you can just type @racket[c] or @racket[r]: -@mr-interaction[r (hc-append c r) (hc-append 20 c r c)] +@ss-interaction[r (hc-append c r) (hc-append 20 c r c)] As you can see, the @racket[hc-append] function accepts an optional number argument before the picture arguments, and it accepts any @@ -149,7 +149,7 @@ uses @racket[define], just like our shape definitions, but with an open parenthesis before the function name, and names for the function arguments before the matching close parenthesis: -@mr-racketblock+eval[ +@ss-racketblock+eval[ (define (square n) (code:comment @#,t{A semi-colon starts a line comment.}) (code:comment @#,t{The expression below is the function body.}) @@ -159,7 +159,7 @@ arguments before the matching close parenthesis: The syntax of the definition mirrors the syntax of a function call: -@mr-interaction[(square 10)] +@ss-interaction[(square 10)] In the same way that definitions can be evaluated in the interactions area, expressions can be included in the definitions area. When a @@ -176,7 +176,7 @@ definition area. The @racket[define] form can be used in some places to create local bindings. For example, it can be used inside a function body: -@mr-def+int[ +@ss-def+int[ (define (four p) (define two-p (hc-append p p)) (vc-append two-p two-p)) @@ -188,7 +188,7 @@ for local binding. An advantage of @racket[let] is that it can be used in any expression position. Also, it binds many identifiers at once, instead of requiring a separate @racket[define] for each identifier: -@mr-def+int[ +@ss-def+int[ (define (checker p1 p2) (let ([p12 (hc-append p1 p2)] [p21 (hc-append p2 p1)]) @@ -201,7 +201,7 @@ A @racket[let] form binds many identifiers at the same time, so the bindings cannot refer to each other. The @racket[let*] form, in contrast, allows later bindings to use earlier bindings: -@mr-def+int[ +@ss-def+int[ (define (checkerboard p) (let* ([rp (colorize p "red")] [bp (colorize p "black")] @@ -217,7 +217,7 @@ contrast, allows later bindings to use earlier bindings: Instead of calling @racket[circle] as a function, try evaluating just @racket[circle] as an expression: -@mr-interaction[circle] +@ss-interaction[circle] That is, the identifier @racket[circle] is bound to a function (a.k.a. ``procedure''), just like @racket[c] is bound to a @@ -230,7 +230,7 @@ pictures (even if they don't print as nicely). Since functions are values, you can define functions that expect other functions as arguments: -@mr-def+int[ +@ss-def+int[ (define (series mk) (hc-append 4 (mk 5) (mk 10) (mk 20))) (series circle) @@ -244,7 +244,7 @@ have to make up a name and find a place to put the function definition. The alternative is to use @racket[lambda], which creates an anonymous function: -@mr-interaction[(series (lambda (size) (checkerboard (square size))))] +@ss-interaction[(series (lambda (size) (checkerboard (square size))))] The parenthesized names after a @racket[lambda] are the arguments to the function, and the expression after the argument names is the @@ -278,7 +278,7 @@ of @racket[mk] in each @racket[lambda] form to refer to the argument of @racket[rgb-series], since that's the binding that is textually in scope: -@mr-def+int[ +@ss-def+int[ (define (rgb-series mk) (vc-append (series (lambda (sz) (colorize (mk sz) "red"))) @@ -291,7 +291,7 @@ scope: Here's another example, where @racket[rgb-maker] takes a function and returns a new one that remembers and uses the original function. -@mr-def+int[ +@ss-def+int[ (define (rgb-maker mk) (lambda (sz) (vc-append (colorize (mk sz) "red") @@ -315,7 +315,7 @@ part of Racket. The @racket[list] function takes any number of arguments and returns a list containing the given values: -@mr-interaction[(list "red" "green" "blue") +@ss-interaction[(list "red" "green" "blue") (list (circle 10) (square 10))] As you can see, a list prints as a single quote and then pair of parentheses wrapped around @@ -332,7 +332,7 @@ each of the elements. The @racket[map] function takes a list and a function to apply to each element of the list; it returns a new list to combine the function's results: -@mr-def+int[ +@ss-def+int[ (define (rainbow p) (map (lambda (color) (colorize p color)) @@ -347,7 +347,7 @@ each one individually. The @racket[apply] function is especially useful with functions that take any number of arguments, such as @racket[vc-append]: -@mr-interaction[ +@ss-interaction[ (apply vc-append (rainbow (square 5))) ] @@ -375,7 +375,7 @@ To import additional libraries, use the @racket[require] form. For example, the library @racketmodname[slideshow/flash] provides a @racket[filled-flash] function: -@mr-def+int[ +@ss-def+int[ (require slideshow/flash) (filled-flash 40 30) ] @@ -398,13 +398,13 @@ Modules are named and distributed in various ways: that you evaluate the following fragment: @mr-def+int[ - (require (planet "random.rkt" ("schematics" "random.plt" 1 0))) + (require (planet schematics/random:1:0/random)) (random-gaussian) ] DrRacket automatically downloads version 1.0 of the - @filepath{random.plt} library and then imports the - @filepath{random.rkt} module.} + @filepath{random.plt} library by @filepath{schematics} and then + imports the @filepath{random.rkt} module.} @item{Some modules live relative to other modules, without necessarily belonging to any particular collection or package. @@ -517,7 +517,8 @@ classes. By convention, the classes are given names that end with @racket[%]: @mr-defs+int[ -[(require racket/class racket/gui/base) +[(require racket/class + racket/gui/base) (define f (new frame% [label "My Art"] [width 300] [height 300] diff --git a/collects/scribblings/reference/chaperones.scrbl b/collects/scribblings/reference/chaperones.scrbl index c01efe7531..ddaf17c332 100644 --- a/collects/scribblings/reference/chaperones.scrbl +++ b/collects/scribblings/reference/chaperones.scrbl @@ -325,7 +325,7 @@ or override impersonator-property values of @scheme[hash].} A @tech{structure type property} (see @secref["structprops"]) that supplies a procedure for extracting an impersonated value from a structure -that represents an impersonator. The property is used for @racket[impersonator-of] +that represents an impersonator. The property is used for @racket[impersonator-of?] as well as @racket[equal?]. The property value must be a procedure of one argument, which is a diff --git a/collects/scribblings/reference/class.scrbl b/collects/scribblings/reference/class.scrbl index 8754cac866..caa16fad62 100644 --- a/collects/scribblings/reference/class.scrbl +++ b/collects/scribblings/reference/class.scrbl @@ -1986,11 +1986,11 @@ Returns two values, analogous to the return values of @scheme[struct-info]: @itemize[ - @item{@scheme[class]: a class or @scheme[#f]; the result is + @item{@scheme[_class]: a class or @scheme[#f]; the result is @scheme[#f] if the current inspector does not control any class for which the @scheme[object] is an instance.} - @item{@scheme[skipped?]: @scheme[#f] if the first result corresponds + @item{@scheme[_skipped?]: @scheme[#f] if the first result corresponds to the most specific class of @scheme[object], @scheme[#t] otherwise.} @@ -2011,31 +2011,31 @@ values of @scheme[struct-type-info]: @itemize[ - @item{@scheme[name]: the class's name as a symbol;} + @item{@scheme[_name]: the class's name as a symbol;} - @item{@scheme[field-cnt]: the number of fields (public and private) + @item{@scheme[_field-cnt]: the number of fields (public and private) defined by the class;} - @item{@scheme[field-name-list]: a list of symbols corresponding to the - class's public fields; this list can be larger than @scheme[field-k] + @item{@scheme[_field-name-list]: a list of symbols corresponding to the + class's public fields; this list can be larger than @scheme[_field-cnt] because it includes inherited fields;} - @item{@scheme[field-accessor]: an accessor procedure for obtaining + @item{@scheme[_field-accessor]: an accessor procedure for obtaining field values in instances of the class; the accessor takes an instance and a field index between @scheme[0] (inclusive) - and @scheme[field-cnt] (exclusive);} + and @scheme[_field-cnt] (exclusive);} - @item{@scheme[field-mutator]: a mutator procedure for modifying + @item{@scheme[_field-mutator]: a mutator procedure for modifying field values in instances of the class; the mutator takes an instance, a field index between @scheme[0] (inclusive) - and @scheme[field-cnt] (exclusive), and a new field value;} + and @scheme[_field-cnt] (exclusive), and a new field value;} - @item{@scheme[super-class]: a class for the most specific ancestor of + @item{@scheme[_super-class]: a class for the most specific ancestor of the given class that is controlled by the current inspector, or @scheme[#f] if no ancestor is controlled by the current inspector;} - @item{@scheme[skipped?]: @scheme[#f] if the sixth result is the most + @item{@scheme[_skipped?]: @scheme[#f] if the sixth result is the most specific ancestor class, @scheme[#t] otherwise.} ]} diff --git a/collects/scribblings/reference/cmdline.scrbl b/collects/scribblings/reference/cmdline.scrbl index 147d90b5c6..eddb01647c 100644 --- a/collects/scribblings/reference/cmdline.scrbl +++ b/collects/scribblings/reference/cmdline.scrbl @@ -29,9 +29,11 @@ [finish-clause code:blank (code:line #:args arg-formals body ...+) (code:line #:handlers handlers-exprs)] - [arg-formals id - (id ...) - (id ...+ . id)] + [arg-formals rest-id + (arg ...) + (arg ...+ . rest-id)] + [arg id + [id default-expr]] [handlers-exprs (code:line finish-expr arg-strings-expr) (code:line finish-expr arg-strings-expr help-expr) (code:line finish-expr arg-strings-expr help-expr diff --git a/collects/scribblings/reference/concurrency.scrbl b/collects/scribblings/reference/concurrency.scrbl index e7217e6779..0f1cf00843 100644 --- a/collects/scribblings/reference/concurrency.scrbl +++ b/collects/scribblings/reference/concurrency.scrbl @@ -1,7 +1,7 @@ #lang scribble/doc @(require "mz.ss") -@title[#:tag "concurrency" #:style 'toc]{Concurrency} +@title[#:tag "concurrency" #:style 'toc]{Concurrency and Parallelism} Racket supports multiple threads of control within a program, thread-local storage, some primitive synchronization mechanisms, and a diff --git a/collects/scribblings/reference/file-ports.scrbl b/collects/scribblings/reference/file-ports.scrbl index eec76b0c28..c1d8c47996 100644 --- a/collects/scribblings/reference/file-ports.scrbl +++ b/collects/scribblings/reference/file-ports.scrbl @@ -192,7 +192,7 @@ A @tech{path} value that is the @tech{cleanse}d version of @defproc[(open-input-output-file [path path-string?] [#:mode mode-flag (or/c 'binary 'text) 'binary] - [#:exists exists-flag (or/c 'error 'append 'update + [#:exists exists-flag (or/c 'error 'append 'update 'can-update 'replace 'truncate 'truncate/replace) 'error]) (values input-port? output-port?)]{ diff --git a/collects/scribblings/reference/futures.scrbl b/collects/scribblings/reference/futures.scrbl index 5094024427..896c80595e 100644 --- a/collects/scribblings/reference/futures.scrbl +++ b/collects/scribblings/reference/futures.scrbl @@ -5,7 +5,7 @@ @(define future-eval (make-base-eval)) @(interaction-eval #:eval future-eval (require racket/future)) -@title[#:tag "futures"]{Futures for Parallelism} +@title[#:tag "futures"]{Futures} @guideintro["effective-futures"]{futures} @@ -19,7 +19,7 @@ Racket.} The @racket[future] and @racket[touch] functions from @racketmodname[racket/future] provide access to parallelism as -supported by the hardware and operation system. +supported by the hardware and operating system. In contrast to @racket[thread], which provides concurrency for arbitrary computations without parallelism, @racket[future] provides parallelism for limited computations. A future executes its work in diff --git a/collects/scribblings/reference/memory.scrbl b/collects/scribblings/reference/memory.scrbl index 1f22d6ad4e..c6cc0d8333 100644 --- a/collects/scribblings/reference/memory.scrbl +++ b/collects/scribblings/reference/memory.scrbl @@ -37,13 +37,31 @@ Returns @racket[#t] if @racket[v] is a weak box, @racket[#f] otherwise.} @;------------------------------------------------------------------------ @section[#:tag "ephemerons"]{Ephemerons} -An @deftech{ephemeron} is similar to a weak box (see -@secref["weakbox"]), except that +An @deftech{ephemeron} @cite{Hayes97} is a generalization of a +@tech{weak box} (see @secref["weakbox"]). Instead of just containing +one value, an emphemeron holds two values: one that is considered the +value of the ephemeron and another that is the ephemeron's key. Like +the value in a weak box, the value in and ephemeron may be replaced by +@racket[#f], but when the @emph{key} is no longer reachable (except +possibly via weak references) instead of when the value is no longer +reachable. +As long as an ephemeron's value is retained, the reference is +considered a non-weak reference. References to the key via the value +are treated specially, however, in that the reference does not +necessarily count toward the key's reachability. A @tech{weak box} can +be seen as a specialization of an ephemeron where the key and value +are the same. + +One particularly common use of ephemerons is to combine them with a +weak hash table (see @secref["hashtables"]) to produce a mapping where +the memory manager can reclaim key--value pairs even when the value +refers to the key. + +More precisely, @itemize[ - @item{an ephemeron contains a key and a value; the value can be - extracted from the ephemeron, but the value is replaced + @item{the value in an ephemeron is replaced by @racket[#f] when the automatic memory manager can prove that either the ephemeron or the key is reachable only through weak references (see @secref["weakbox"]); and} @@ -57,11 +75,6 @@ An @deftech{ephemeron} is similar to a weak box (see ] -In particular, an ephemeron can be combined with a weak hash table -(see @secref["hashtables"]) to produce a mapping where the memory -manager can reclaim key--value pairs even when the value refers to the -key. - @defproc[(make-ephemeron [key any/c] [v any/c]) ephemeron?]{ @@ -170,11 +183,15 @@ this procedure is never called.} @defproc[(current-memory-use [cust custodian? #f]) exact-nonnegative-integer?]{ Returns an estimate of the number of bytes of memory occupied by -reachable data from @racket[cust]. (The estimate is calculated -@italic{without} performing an immediate garbage collection; -performing a collection generally decreases the number returned by -@racket[current-memory-use].) If @racket[cust] is not provided, the -estimate is a total reachable from any custodians. +reachable data from @racket[cust]. This estimate is calculated by the +last garbage colection, and can be 0 if none occured (or if none occured +since the given custodian was created). The @racket[current-memory-use] +function does @italic{not} perform a collection by itself; doing one +before the call will generally decrease the result (or increase it from +0 if no collections happened yet). + +If @racket[cust] is not provided, the estimate is a total reachable from +any custodians. When Racket is compiled without support for memory accounting, the estimate is the same (i.e., all memory) for any individual custodian; @@ -184,4 +201,3 @@ see also @racket[custodian-memory-accounting-available?].} Dumps information about memory usage to the (low-level) standard output port.} - diff --git a/collects/scribblings/reference/pairs.scrbl b/collects/scribblings/reference/pairs.scrbl index ad003860ae..74e08fa780 100644 --- a/collects/scribblings/reference/pairs.scrbl +++ b/collects/scribblings/reference/pairs.scrbl @@ -949,6 +949,16 @@ returns @scheme[#f]. (filter-not even? '(1 2 3 4 5 6)) ]} + +@defproc[(shuffle [lst list?]) list?]{ + +Returns a list with all elements from @racket[lst], randomly shuffled. + +@mz-examples[#:eval list-eval + (shuffle '(1 2 3 4 5 6)) +]} + + @defproc[(argmin [proc (-> any/c real?)] [lst (and/c pair? list?)]) any/c]{ This returns the first element in the list @scheme[lst] that minimizes diff --git a/collects/scribblings/reference/places.scrbl b/collects/scribblings/reference/places.scrbl index 3e0d1b3e2a..fbc1fb212f 100644 --- a/collects/scribblings/reference/places.scrbl +++ b/collects/scribblings/reference/places.scrbl @@ -1,6 +1,6 @@ #lang scribble/doc -@title[#:tag "places"]{@bold{Places}: Coarse-grained Parallelism} +@title[#:tag "places"]{Places} @; ---------------------------------------------------------------------- @@ -12,70 +12,53 @@ racket/base racket/contract racket/place - racket/flonum)) + racket/future + racket/flonum + racket/fixnum)) @; ---------------------------------------------------------------------- -@deftech{Places} enable the development of parallel programs that -take advantage of machines with multiple processors, cores, or -hardware threads. +@margin-note{Parallel support for @racket[place] is currently disabled by +default. Enable places by supplying @DFlag{enable-places} to +@exec{configure} when building Racket.} @note-lib[racket/place] -Note: currently, parallel support for @racket[place] is disabled by -default, and using it will raise an exception. Support can only be -enabled if you build Racket yourself, and pass @DFlag{enable-places} to -@exec{configure}. This works only for @exec{racket} (not -@exec{gracket}), and it is supported only on Linux x86/x86_64, and Mac -OS X x86/x86_64 platforms. +@tech{Places} enable the development of parallel programs that +take advantage of machines with multiple processors, cores, or +hardware threads. -@defproc[(place [module-path module-path?] [start-proc symbol?]) place?]{ - Starts running @racket[start-proc] in parallel. @racket[start-proc] must - be a function defined in @racket[module-path]. The @racket[place] - procedure returns immediately with a place descriptor value representing the newly constructed place. - Each place descriptor value is also a @racket[place-channel] that permits communication with the place. -} +A @deftech{place} is a parallel task that is effectively a separate +instance of the Racket virtual machine. Places communicate through +@deftech{place channels}, which are endpoints for a two-way buffered +communication. -@defproc[(place-wait [p place?]) exact-integer?]{ - Returns the return value of a completed place @racket[p], blocking until - the place completes (if it has not already completed). -} +To a first approximation, place channels allow only immutable values +as messages over the channel: numbers, characters, booleans, immutable +pairs, immutable vectors, and immutable structures. In addition, place +channels themselves can be sent across channels to establish new +(possibly more direct) lines of communication in addition to any +existing lines. Finally, mutable values produced by +@racket[shared-flvector], @racket[make-shared-flvector], +@racket[shared-fxvector], @racket[make-shared-fxvector], +@racket[shared-bytes], and @racket[make-shared-bytes] can be sent +across place channels; mutation of such values is visible to all +places that share the value, because they are allowed in a +@deftech{shared memory space}. -@defproc[(place? [x any/c]) boolean?]{ - Returns @racket[#t] if @racket[x] is a place-descriptor value, @racket[#f] otherwise. -} +A @tech{place channel} can be used as a @tech{synchronizable event} +(see @secref["sync"]) to receive a value through the channel. A place +can also receive messages with @racket[place-channel-recv], and +messages can be sent with @racket[place-channel-send]. -@defproc[(place-channel) (values place-channel? place-channel?)]{ - Returns two @racket[place-channel] endpoint objects. - - One @racket[place-channel] endpoint should be used by the current @racket[place] to send - messages to a destination @racket[place]. +Constraints on messages across a place channel---and therefore on the +kinds of data that places share---enable greater parallelism than +@racket[future], even including separate @tech{garbage collection} of +separate places. At the same time, the setup and communication costs +for places can be higher than for futures. - The other @racket[place-channel] endpoint should be sent to a destination @racket[place] over - an existing @racket[place-channel]. -} - -@defproc[(place-channel-send [ch place-channel?] [x any/c]) void]{ - Sends an immutable message @racket[x] on channel @racket[ch]. -} - -@defproc[(place-channel-recv [p place-channel?]) any/c]{ - Returns an immutable message received on channel @racket[ch]. -} - -@defproc[(place-channel? [x any/c]) boolean?]{ - Returns @racket[#t] if @racket[x] is a place-channel object. -} - -@defproc[(place-channel-send/recv [ch place-channel?] [x any/c]) void]{ - Sends an immutable message @racket[x] on channel @racket[ch] and then - waits for a repy message. - Returns an immutable message received on channel @racket[ch]. -} - -@section[#:tag "example"]{Basic Example} - -This code launches two places, echos a message to them and then waits for the places to complete and return. +For example, the following expression lanches two places, echoes a +message to each, and then waits for the places to complete and return: @racketblock[ (let ([pls (for/list ([i (in-range 2)]) @@ -87,48 +70,75 @@ This code launches two places, echos a message to them and then waits for the pl (map place-wait pls)) ] -This is the code for the place-worker.ss module that each place will execute. +The @filepath{place-worker.rkt} module must export the +@racket[place-main] function that each place executes, where +@racket[place-main] must accept a single @tech{place channel} +argument: -@racketblock[ -(module place-worker racket - (provide place-main) +@racketmod[ +racket +(provide place-main) - (define (place-main ch) - (place-channel-send ch (format "Hello from place ~a" (place-channel-recv ch))))) +(define (place-main ch) + (place-channel-send ch (format "Hello from place ~a" + (place-channel-recv ch)))) ] -@section[#:tag "place-channels"]{Place Channels} -Place channels can be used with @racket[place-channel-recv], or as a -@tech[#:doc '(lib "scribblings/reference/reference.scrbl")]{synchronizable event} - (see @secref[#:doc '(lib "scribblings/reference/reference.scrbl") "sync"]) to receive a value -through the channel. The channel can be used with @racket[place-channel-send] -to send a value through the channel. -@section[#:tag "messagepassingparallelism"]{Message Passing Parallelism} +@defproc[(place? [x any/c]) boolean?]{ + Returns @racket[#t] if @racket[x] is a @deftech{place descriptor} + value, @racket[#f] otherwise. Every @tech{place descriptor} + is also a @tech{place channel}. +} -Places communicate by passing messages on place-channels. -Only atomic values, immutable pairs, vectors, and structs can be -communicated across places channels. +@defproc[(place-channel? [x any/c]) boolean?]{ + Returns @racket[#t] if @racket[x] is @tech{place channel}, + @racket[#f] otherwise. +} -@section[#:tag "places-architecture"]{Architecture and Garbage Collection} +@defproc[(place [module-path module-path?] [start-proc symbol?]) place?]{ -Places enables a @deftech{shared memory space} between all places. -References from the @tech{shared memory space} back into a places memory space. -The invariant of allowing no backpointers is enforced by only allowing immutable -datastructures to be deep copied into the @tech{shared memory space}. + Creates a @tech{place} to run the procedure that is identified by + @racket[module-path] and @racket[start-proc]. The result is a + @tech{place descriptor} value that represents the new parallel task; + the place descriptor is returned immediately. The place descriptor + value is also a @tech{place channel} that permits communication with + the place. -However, mutation of atomic values in -the @tech{shared memory space} is permitted to improve performace of -shared-memory parallel programs. + The module indicated by @racket[module-path] must export a function + with the name @racket[start-proc]. The function must accept a single + argument, which is a @tech{place channel} that corresponds to the + other end of communication for the @tech{place descriptor} returned + by @racket[place].} -Special functions such as @racket[shared-flvector] and @racket[shared-bytes] allocate -vectors of mutable atomic values into the @tech{shared memory space}. -Parallel mutation of these atomic values -can possibly lead to data races, but will not cause @exec{racket} to -crash. In practice however, parallel tasks usually write to disjoint -partitions of a shared vector. +@defproc[(place-wait [p place?]) exact-integer?]{ + Returns the completion value of the place indicated by @racket[p], + blocking until the place completes if it has not already completed. +} -Places are allowed to garbage collect independently of one another. -The shared-memory collector, however, has to pause all -places before it can collect garbage. + +@defproc[(place-channel) (values place-channel? place-channel?)]{ + + Returns two @tech{place channels}. Data send through the first + channel can be received through the second channel, and data send + through the second channel can be received from the first. + + Typically, one place channel is used by the current @tech{place} to + send messages to a destination @tech{place}; the other place channel + us sent to the destination @tech{place} (via an existing @tech{place + channel}). +} + +@defproc[(place-channel-send [ch place-channel?] [v any/c]) void]{ + Sends a message @racket[v] on channel @racket[ch]. +} + +@defproc[(place-channel-recv [p place-channel?]) any/c]{ + Returns a message received on channel @racket[ch]. +} + +@defproc[(place-channel-send/recv [ch place-channel?] [v any/c]) void]{ + Sends an immutable message @racket[v] on channel @racket[ch] and then + waits for a reply message on the same channel. +} diff --git a/collects/scribblings/reference/port-lib.scrbl b/collects/scribblings/reference/port-lib.scrbl index d6a31a3bc8..7b5f75b8b1 100644 --- a/collects/scribblings/reference/port-lib.scrbl +++ b/collects/scribblings/reference/port-lib.scrbl @@ -51,7 +51,8 @@ Read all characters from @scheme[in], breaking them into lines. The @scheme['linefeed]. @examples[#:eval port-eval -(port->lines (open-input-string "line 1\nline 2\n line 3\nline 4")) +(port->lines + (open-input-string "line 1\nline 2\n line 3\nline 4")) ]} @defproc[(port->bytes-lines [in input-port? (current-input-port)] @@ -62,7 +63,8 @@ Like @scheme[port->lines], but reading bytes and collecting them into lines like @scheme[read-bytes-line]. @examples[#:eval port-eval -(port->bytes-lines (open-input-string "line 1\nline 2\n line 3\nline 4")) +(port->bytes-lines + (open-input-string "line 1\nline 2\n line 3\nline 4")) ]} @defproc[(display-lines [lst list?] diff --git a/collects/scribblings/reference/reference.scrbl b/collects/scribblings/reference/reference.scrbl index cd4310e9f7..b5b1a67b65 100644 --- a/collects/scribblings/reference/reference.scrbl +++ b/collects/scribblings/reference/reference.scrbl @@ -111,12 +111,18 @@ The @racketmodname[racket] library combines #:title "A Generalization of Exceptions and Control in ML-like Languages" #:location "Functional Programming Languages and Computer Architecture" #:date "1995") - - (bib-entry #:key "Hieb90" - #:author "Robert Hieb and R. Kent Dybvig" - #:title "Continuations and Concurrency" - #:location "Principles and Practice of Parallel Programming" - #:date "1990") + + (bib-entry #:key "Hayes97" + #:author "Barry Hayes" + #:title "Ephemerons: a New Finalization Mechanism" + #:location "Object-Oriented Languages, Programming, Systems, and Applications" + #:date "1997") + + (bib-entry #:key "Hieb90" + #:author "Robert Hieb and R. Kent Dybvig" + #:title "Continuations and Concurrency" + #:location "Principles and Practice of Parallel Programming" + #:date "1990") (bib-entry #:key "L'Ecuyer02" #:author "Pierre L'Ecuyer, Richard Simard, E. Jack Chen, and W. David Kelton" diff --git a/collects/scribblings/reference/sandbox.scrbl b/collects/scribblings/reference/sandbox.scrbl index 55f926f5c5..dfdee6878f 100644 --- a/collects/scribblings/reference/sandbox.scrbl +++ b/collects/scribblings/reference/sandbox.scrbl @@ -730,6 +730,19 @@ Ctrl-C was typed when the evaluator is currently executing, which propagates the break to the evaluator's context.} +@defproc[(get-user-custodian [evaluator (any/c . -> . any)]) void?]{ + +Retrieves the @racket[evaluator]'s toplevel custodian. This returns a +value that is different from @racket[(evaluator '(current-custodian))] +or @racket[call-in-sandbox-context evaluator current-custodian] --- each +sandbox interaction is wrapped in its own custodian, which is what these +would return. + +(One use for this custodian is with @racket[current-memory-use], where +the per-interaction sub-custodians will not be charged with the memory +for the whole sandbox.)} + + @defproc[(set-eval-limits [evaluator (any/c . -> . any)] [secs (or/c exact-nonnegative-integer? #f)] [mb (or/c exact-nonnegative-integer? #f)]) diff --git a/collects/scribblings/reference/sets.scrbl b/collects/scribblings/reference/sets.scrbl index 794b405d1f..8ec10d98fe 100644 --- a/collects/scribblings/reference/sets.scrbl +++ b/collects/scribblings/reference/sets.scrbl @@ -3,6 +3,8 @@ (for-label racket/set)) @title[#:tag "sets"]{Sets} +@(define set-eval (make-base-eval)) +@(interaction-eval #:eval set-eval (require racket/set)) A @deftech{set} represents a set of distinct elements. For a given set, elements are equivalent via @scheme[equal?], @scheme[eqv?], or @@ -86,7 +88,22 @@ Produces a set that includes all elements of all given @scheme[set]s, which must all use the same equivalence predicate (@scheme[equal?], @scheme[eq?], or @scheme[eqv?]). This operation runs in time proportional to the total size of all given @scheme[set]s except for -the largest.} +the largest. + +At least one set must be provided to @racket[set-union] even though +mathematically @racket[set-union] could accept zero arguments. Since +there are multiple types of sets (@racket[eq?], @racket[eqv?], and +@racket[equal?]) there is no obvious choice for a default empty set +to be returned. If there is a case where @racket[set-union] may be +applied to zero arguments, instead pass an empty set of the type +you desire. + +@examples[#:eval set-eval +(set-union (set)) +(set-union (seteq)) +(set-union (set 1) (set 2)) +(set-union (set 1) (seteq 2)) (code:comment "Sets of different types cannot be unioned") +]} @defproc[(set-intersect [set set?] ...+) set?]{ @@ -151,3 +168,4 @@ other forms.} Analogous to @scheme[for/list] and @scheme[for*/list], but to construct a set instead of a list.} +@close-eval[set-eval] diff --git a/collects/scribblings/reference/startup.scrbl b/collects/scribblings/reference/startup.scrbl index 800a9998e2..6000b8dae9 100644 --- a/collects/scribblings/reference/startup.scrbl +++ b/collects/scribblings/reference/startup.scrbl @@ -26,12 +26,15 @@ The core Racket run-time system is available in two main variants: @as-index{@exec{racket}}. Under Windows, the executable is called @as-index{@exec{Racket.exe}}.} - @item{GRacket, which extends @exec{racket} with GUI primitives on - which @racketmodname[racket/gui/base] is implemented. Under - Unix, the executable is called @as-index{@exec{gracket}}. Under - Windows, the executable is called - @as-index{@exec{GRacket.exe}}. Under Mac OS X, the @exec{gracket} - script launches @as-index{@exec{GRacket.app}}.} + @item{GRacket, which is a GUI variant of @exec{racket} to the degree + that the system distinguishes them. Under Unix, the executable + is called @as-index{@exec{gracket}}, and single-instance flags + and X11-related flags are handled and communicated specially to + the @racket[racket/gui/base] library. Under Windows, the + executable is called @as-index{@exec{GRacket.exe}}, and it is a + GUI application (as opposed to a console application) that + implements singe-instance support. Under Mac OS X, the + @exec{gracket} script launches @as-index{@exec{GRacket.app}}.} ] @@ -92,10 +95,11 @@ is started, Racket loads the file @racket[(find-system-path @racket[(find-graphical-system-path 'init-file)] is loaded, unless the @Flag{q}/@DFlag{no-init-file} flag is specified on the command line. -Finally, before GRacket exists, it waits for all frames to class, all -timers to stop, @|etc| in the main @|eventspace| by evaluating -@racket[(racket 'yield)]. This waiting step can be suppressed with the -@Flag{V}/@DFlag{no-yield} command-line flag. +Finally, before Racket or GRacket exits, it calls the procedure that +is the current value of @racket[executable-yield-handler] in the main +thread, unless the @Flag{V}/@DFlag{no-yield} command-line flag is +specified. Requiring @racketmodname[racket/gui/base] sets this parameter call +@racket[(racket 'yield)]. @; ---------------------------------------------------------------------- @@ -212,9 +216,9 @@ flags: leave application in the background.} @item{@FlagFirst{V} @DFlagFirst{no-yield} : Skips final - @racket[(yield 'wait)] action, which normally waits until all + @racket[executable-yield-handler] action, which normally waits until all frames are closed, @|etc| in the main @|eventspace| before - exiting.} + exiting for programs that use @racketmodname[racket/gui/base].} ]} @@ -333,7 +337,7 @@ the insertion of @Flag{u}/@DFlag{require-script}): @FlagFirst{xnllanguage} @nonterm{arg}, or @FlagFirst{xrm} @nonterm{arg} : Standard X11 arguments that are mostly ignored but accepted for compatibility with other X11 programs. The - @Flag{synchronous} and @Flag{xrm} flags behave in the usual + @Flag{synchronous} flag behaves in the usual way.} @item{@FlagFirst{singleInstance} : If an existing GRacket is already diff --git a/collects/scribblings/scribble/core.scrbl b/collects/scribblings/scribble/core.scrbl index bf9b3aec56..a64b56de2f 100644 --- a/collects/scribblings/scribble/core.scrbl +++ b/collects/scribblings/scribble/core.scrbl @@ -943,8 +943,9 @@ otherwise.} Returns @racket[#t] if @racket[v] is a string, symbol, @racket[element], @racket[multiarg-element], @racket[traverse-element], @racket[delayed-element], -@racket[part-relative-element], or list of @tech{content}, @racket[#f] -otherwise.} +@racket[part-relative-element], a convertible value in +the sense of @racket[convertible?], or list of @tech{content}. +Otherwise, it returns @racket[#f].} @defstruct[style ([name (or/c string? symbol? #f)] diff --git a/collects/scribblings/scribble/sigplan.scrbl b/collects/scribblings/scribble/sigplan.scrbl index 2b4f14e826..bf8b2465a2 100644 --- a/collects/scribblings/scribble/sigplan.scrbl +++ b/collects/scribblings/scribble/sigplan.scrbl @@ -12,7 +12,7 @@ file that is included with Scribble.} @defidform[preprint]{ Enables the @tt{preprint} option. Use @racket[preprint] only on the -same line as @hash-lang[], with only whitespace between +same line as @hash-lang[], with only whitespace (or other options) between @racketmodname[scribble/sigplan] and @racket[preprint]: @verbatim[#:indent 2]|{ @@ -22,7 +22,7 @@ same line as @hash-lang[], with only whitespace between @defidform[10pt]{ Enables the @tt{10pt} option. Use @racket[10pt] only on the -same line as @hash-lang[], with only whitespace between +same line as @hash-lang[], with only whitespace (or other options) between @racketmodname[scribble/sigplan] and @racket[10pt]: @verbatim[#:indent 2]|{ @@ -32,15 +32,49 @@ same line as @hash-lang[], with only whitespace between @defidform[nocopyright]{ Enables the @tt{nocopyright} option. Use @racket[nocopyright] only on the -same line as @hash-lang[], with only whitespace between +same line as @hash-lang[], with only whitespace (or other options) between @racketmodname[scribble/sigplan] and @racket[nocopyright]: @verbatim[#:indent 2]|{ #lang scribble/sigplan @nocopyright }|} -The @racket[10pt], @racket[preprint], and @racket[nocopyright] options can be -used together and may appear in any order. +@defidform[onecolumn]{ + +Enables the @tt{onecolumn} option. Use @racket[onecolumn] only on the +same line as @hash-lang[], with only whitespace (or other options) between +@racketmodname[scribble/sigplan] and @racket[onecolumn]: + +@codeblock|{ + #lang scribble/sigplan @onecolumn +}|} + + +@defidform[notimes]{ + +Disables the use of @tt{\usepackage@"{"times@"}"} in the generated LaTeX output. +Use @racket[onecolumn] only on the +same line as @hash-lang[], with only whitespace (or other options) between +@racketmodname[scribble/sigplan] and @racket[notimes]: + +@codeblock|{ + #lang scribble/sigplan @notimes +}|} + +@defidform[noqcourier]{ + +Disables the use of @tt{\usepackage@"{"qcourier@"}"} in the generated LaTeX output. +Use @racket[onecolumn] only on the +same line as @hash-lang[], with only whitespace (or other options) between +@racketmodname[scribble/sigplan] and @racket[noqcourier]: + +@codeblock|{ + #lang scribble/sigplan @noqcourier +}|} + +The @racket[10pt], @racket[preprint], @racket[nocopyright], +@racket[onecolumn], @racket[notimes], and @racket[noqcourier] +options can be used together and may appear in any order. } diff --git a/collects/scribblings/slideshow/pict-diagram.rkt b/collects/scribblings/slideshow/pict-diagram.rkt new file mode 100644 index 0000000000..c651669c37 --- /dev/null +++ b/collects/scribblings/slideshow/pict-diagram.rkt @@ -0,0 +1,63 @@ +#lang racket/base +(require slideshow/pict + racket/class + racket/draw) + +(provide pict-diagram) + +(define pict-diagram + (parameterize ([dc-for-text-size (make-object bitmap-dc% + (make-bitmap 1 1))]) + (let ([t (lambda (s) + (text s `(italic . roman) 12))]) + (let ([top + (hc-append (vline 0 10) + (hline 30 0) + (inset (t "w") 1 0) + (hline 30 0) + (vline 0 10))] + [right + (vc-append (hline 10 0) + (vline 0 25) + (inset (t "h") 0 1) + (vline 0 25) + (hline 10 0))]) + (inset + (vl-append + 2 + top + (hc-append + 2 + (frame (let* ([line (hline (pict-width top) 0 #:segment 5)] + [top-line (launder line)] + [bottom-line (launder line)] + [top-edge (launder (ghost line))] + [bottom-edge (launder (ghost line))] + [p (vc-append + (/ (pict-height right) 4) + top-edge + top-line + (blank) + bottom-line + bottom-edge)] + [p (pin-arrows-line + 4 p + top-edge ct-find + top-line ct-find)] + [p (pin-arrows-line + 4 p + bottom-edge ct-find + bottom-line ct-find)] + [a (t "a")] + [p (let-values ([(dx dy) (ct-find p top-line)]) + (pin-over p (+ dx 5) (/ (- dy (pict-height a)) 2) a))] + [d (t "d")] + [p (let-values ([(dx dy) (ct-find p bottom-line)]) + (pin-over p + (+ dx 5) + (+ dy (/ (- (- (pict-height p) dy) (pict-height d)) 2)) + d))]) + p)) + right)) + 1))))) + diff --git a/collects/scribblings/slideshow/picts.scrbl b/collects/scribblings/slideshow/picts.scrbl index 37b4927a9e..fa6e744b52 100644 --- a/collects/scribblings/slideshow/picts.scrbl +++ b/collects/scribblings/slideshow/picts.scrbl @@ -1,5 +1,6 @@ #lang scribble/doc @(require "ss.ss" + "pict-diagram.rkt" (for-label racket/gui slideshow/code slideshow/flash @@ -34,16 +35,7 @@ offset of an embedded pict in a larger pict. In addition to its drawing part, a pict has the following @deftech{bounding box} structure: -@verbatim[#:indent 7]{ - w - ------------------ - | | a \ - |------------------| | - | | | h - |----------last----| | - | | d / - ------------------ -} +@centerline[pict-diagram] That is, the bounding box has a width @math{w} and a height @math{h}. For a single text line, @math{d} is descent below the @@ -65,6 +57,10 @@ picts. The functions @racket[pict-width], @racket[pict-height], @racket[pict-descent], and @racket[pict-ascent] extract bounding-box information from a pict. +A pict is a convertible datatype through the @racketmodname[file/convertible] +protocol. Supported conversions include @racket['png-bytes], +@racket['eps-bytes], and @racket['pdf-bytes]. + @defstruct[pict ([draw any/c] [width real?] diff --git a/collects/scriblib/autobib.rkt b/collects/scriblib/autobib.rkt index 649ec6437f..0aa4d3fa61 100644 --- a/collects/scriblib/autobib.rkt +++ b/collects/scriblib/autobib.rkt @@ -1,5 +1,6 @@ #lang at-exp racket/base (require scribble/manual + racket/list scribble/core scribble/decode scribble/html-properties @@ -64,34 +65,44 @@ ")"))) (define (add-cites group bib-entries) + (define groups (for/fold ([h (hash)]) ([b (reverse bib-entries)]) + (hash-update h (author-element-names (auto-bib-author b)) + (lambda (cur) (cons b cur)) null))) (make-element #f - (list 'nbsp - "(" - (let loop ([keys bib-entries]) - (if (null? (cdr keys)) - (make-element - #f - (list - (add-cite group (car keys) 'autobib-author #f) - " " - (add-cite group (car keys) 'autobib-date #t))) - (make-element - #f - (list (loop (list (car keys))) - "; " - (loop (cdr keys)))))) - ")"))) + (append + (list 'nbsp "(") + (add-between + (for/list ([(k v) groups]) + (make-element + #f + (list* + (add-cite group (car v) 'autobib-author #f) + " " + (add-between + (for/list ([b v]) (add-cite group b 'autobib-date #t)) + ", ")))) + "; ") + (list ")")))) (define (extract-bib-key b) (author-element-names (auto-bib-author b))) +(define (extract-bib-year b) + (string->number (auto-bib-date b))) + + (define (gen-bib tag group) - (let* ([authorcomplete-path p (or (path-only (current-executable-path)) - (find-system-path 'orig-dir)))))) + (let ([p (find-system-path 'collects-dir)]) + (if (complete-path? p) + p + (path->complete-path p (or (path-only (current-executable-path)) + (find-system-path 'orig-dir)))))) (define (parallel-do-event-loop initialcode initialmsg worker-cmdline-list jobqueue nprocs stopat) @@ -96,17 +97,26 @@ [(list (and (? empty?) idle) (list) count error-count) (set! workers idle)] ;; Wait for reply from worker [(list idle inflight count error-count) + (define (remove-dead-worker id node-worker) + (loop (cons (spawn id) idle) + (remove node-worker inflight) + count + (add1 error-count))) + (apply sync (map (λ (node-worker) (match node-worker [(list node (and wrkr (worker id sh out in err))) (handle-evt out (λ (e) (let ([msg (with-handlers* ([exn:fail? (lambda (e) (printf "MASTER READ ERROR - reading from worker: ~a\n" (exn-message e)) (kill-worker wrkr) - (loop (cons (spawn id) idle) - (remove node-worker inflight) - count - (add1 error-count)))]) - (read out))]) + (remove-dead-worker id node-worker))]) + (let ([read-msg (read out)]) + (if (pair? read-msg) + read-msg + (begin + (work-done jobqueue node id (string-append read-msg (port->string out))) + (kill-worker wrkr) + (remove-dead-worker id node-worker)))))]) (work-done jobqueue node id msg) (loop (cons wrkr idle) (remove node-worker inflight) @@ -116,7 +126,10 @@ (eprintf "parallel-do-event-loop match node-worker failed.\n") (eprintf "trying to match:\n~a\n" node-worker)])) - inflight))])]) + inflight))] + [x + (eprintf "parallel-do-event-loop match-lambda* failed.\n") + (eprintf "trying to match:\n~a\n" x)])]) (loop workers null 0 0))) (lambda () (for ([p workers]) (with-handlers ([exn? void]) (send/msg (list 'DIE) (worker-in p)))) diff --git a/collects/sgl/examples/gears.rkt b/collects/sgl/examples/gears.rkt index cba4b9b31e..71d6f88a49 100644 --- a/collects/sgl/examples/gears.rkt +++ b/collects/sgl/examples/gears.rkt @@ -335,7 +335,7 @@ (gl-flush))) (when step? (set! step? #f) - (queue-callback (lambda x (send this run)))))) + (queue-callback (lambda x (send this run)) #f)))) (super-instantiate () (style '(gl no-autoclear))))) (define (f) diff --git a/collects/slideshow/cmdline.rkt b/collects/slideshow/cmdline.rkt index da668dcf93..fe6a77d54e 100644 --- a/collects/slideshow/cmdline.rkt +++ b/collects/slideshow/cmdline.rkt @@ -26,8 +26,7 @@ (define-values (use-screen-w use-screen-h) (values actual-screen-w actual-screen-h)) (define condense? #f) - (define printing? #f) - (define native-printing? #f) + (define printing-mode #f) (define commentary? #f) (define commentary-on-slide? #f) (define show-gauge? #f) @@ -60,12 +59,13 @@ [once-each (("-d" "--preview") "show next-slide preview (useful on a non-mirroring display)" (set! two-frames? #t)) - (("-p" "--print") "print (always to PostScript, except under Windows and Mac OS)" - (set! printing? #t) - (set! native-printing? #t)) + (("-p" "--print") "print" + (set! printing-mode 'print)) (("-P" "--ps") "print to PostScript" - (set! printing? #t)) - (("-o") file "set output file for PostScript printing" + (set! printing-mode 'ps)) + (("-D" "--pdf") "print to PDF" + (set! printing-mode 'pdf)) + (("-o") file "set output file for PostScript or PDF printing" (set! print-target file)) (("-c" "--condense") "condense" (set! condense? #t)) @@ -138,41 +138,50 @@ (length slide-module-file) slide-module-file)])])) - (when (or printing? condense?) + (define printing? (and printing-mode #t)) + + (when (or printing-mode condense?) (set! use-transitions? #f)) - (when printing? + (when printing-mode (set! use-offscreen? #f) (set! use-prefetch? #f) (set! keep-titlebar? #t)) (dc-for-text-size - (if printing? + (if printing-mode (let ([p (let ([pss (make-object ps-setup%)]) (send pss set-mode 'file) (send pss set-file (if print-target print-target - (if file-to-load - (path-replace-suffix (file-name-from-path file-to-load) - (if quad-view? - "-4u.ps" - ".ps")) - "untitled.ps"))) + (let ([suffix + (if (eq? printing-mode 'pdf) + "pdf" + "ps")]) + (if file-to-load + (path-replace-suffix (file-name-from-path file-to-load) + (format + (if quad-view? + "-4u.~a" + ".~a") + suffix)) + (format "untitled.~a" suffix))))) (send pss set-orientation 'landscape) (parameterize ([current-ps-setup pss]) - (if (and native-printing? - (not (memq (system-type) '(unix)))) - ;; Make printer-dc% - (begin - (when (can-get-page-setup-from-user?) - (let ([v (get-page-setup-from-user)]) - (if v - (send pss copy-from v) - (exit)))) - (make-object printer-dc% #f)) - ;; Make ps-dc%: - (make-object post-script-dc% (not print-target) #f #t #f))))]) + (case printing-mode + [(print) + ;; Make printer-dc% + (when (can-get-page-setup-from-user?) + (let ([v (get-page-setup-from-user)]) + (if v + (send pss copy-from v) + (exit)))) + (make-object printer-dc% #f)] + [(ps) + (make-object post-script-dc% (not print-target) #f #t #f)] + [(pdf) + (make-object pdf-dc% (not print-target) #f #t #f)])))]) ;; Init page, set "screen" size, etc.: (unless (send p ok?) (exit)) (send p start-doc "Slides") diff --git a/collects/slideshow/core.rkt b/collects/slideshow/core.rkt index c343e583a7..f0b2e5987b 100644 --- a/collects/slideshow/core.rkt +++ b/collects/slideshow/core.rkt @@ -3,7 +3,7 @@ (require scheme/class scheme/unit scheme/file - mred + racket/draw texpict/mrpict texpict/utils scheme/math @@ -1019,7 +1019,7 @@ (+ x-space (* xs w))) (>= (send scroll-bm get-height) (+ y-space (* ys h)))) - (set! scroll-bm (make-screen-bitmap + (set! scroll-bm (make-bitmap (inexact->exact (ceiling (+ x-space (* xs w)))) (inexact->exact (ceiling (+ y-space (* ys h)))))) (if (send scroll-bm ok?) diff --git a/collects/slideshow/pict.rkt b/collects/slideshow/pict.rkt index 5f2994cbde..f307fa62ca 100644 --- a/collects/slideshow/pict.rkt +++ b/collects/slideshow/pict.rkt @@ -7,8 +7,8 @@ [pin-line t:pin-line] [pin-arrow-line t:pin-arrow-line] [pin-arrows-line t:pin-arrows-line]) - (only-in scheme/gui/base dc-path%) - (only-in scheme/class new send)) + (only-in racket/draw dc-path%) + (only-in racket/class new send)) (define (hline w h #:segment [seg #f]) (if seg diff --git a/collects/slideshow/slides-to-picts.rkt b/collects/slideshow/slides-to-picts.rkt index f14e2955d1..f4b1e221a3 100644 --- a/collects/slideshow/slides-to-picts.rkt +++ b/collects/slideshow/slides-to-picts.rkt @@ -1,6 +1,6 @@ (module slides-to-picts scheme/base - (require mred + (require racket/draw scheme/class scheme/unit "sig.ss" @@ -14,7 +14,7 @@ (define get-slides-as-picts (lambda (file w h c? [stop-after #f]) - (let ([ns (make-gui-namespace)] + (let ([ns (make-base-namespace)] [orig-ns (namespace-anchor->empty-namespace anchor)] [slides null] [xs (/ w 1024)] diff --git a/collects/string-constants/danish-string-constants.rkt b/collects/string-constants/danish-string-constants.rkt index 5954e73e95..a9a58e24bd 100644 --- a/collects/string-constants/danish-string-constants.rkt +++ b/collects/string-constants/danish-string-constants.rkt @@ -132,8 +132,7 @@ please adhere to these guidelines: (web-materials "Relaterede websites") ;; menu item title (tool-web-sites "Tool Web Sites") ;; menu item title (plt-homepage "Racket") - (how-to-use-scheme "How to Use Scheme") ;; title of a book. - (teachscheme!-homepage "TeachScheme!") ;; probably this should be a `word' in all languages + (pbd-homepage "Program by Design") ;;; bug report form (cancel-bug-report? "Fortryd afsendelse af fejlrapport?") diff --git a/collects/string-constants/dutch-string-constants.rkt b/collects/string-constants/dutch-string-constants.rkt index f0c63566cc..1ac0bb16d5 100644 --- a/collects/string-constants/dutch-string-constants.rkt +++ b/collects/string-constants/dutch-string-constants.rkt @@ -32,8 +32,7 @@ ;;; important urls (web-materials "Verwante Web Sites") ;; menu item title (plt-homepage "Racket") - (how-to-use-scheme "How to Use Scheme") ;; title of a book. - (teachscheme!-homepage "TeachScheme!") ;; probably this should be a `word' in all languages + (pbd-homepage "Program by Design") ;;; bug report form (cancel-bug-report? "Melden defect afbreken?") diff --git a/collects/string-constants/english-string-constants.rkt b/collects/string-constants/english-string-constants.rkt index 41580aeff3..086d1e35ae 100644 --- a/collects/string-constants/english-string-constants.rkt +++ b/collects/string-constants/english-string-constants.rkt @@ -134,8 +134,7 @@ please adhere to these guidelines: (web-materials "Related Web Sites") ;; menu item title (tool-web-sites "Tool Web Sites") ;; menu item title (plt-homepage "Racket") - (how-to-use-scheme "How to Use Scheme") ;; title of a book. - (teachscheme!-homepage "TeachScheme!") ;; probably this should be a `word' in all languages + (pbd-homepage "Program by Design") ;;; bug report form (cancel-bug-report? "Cancel Bug Report?") @@ -449,7 +448,8 @@ please adhere to these guidelines: (switch-to-module-language-automatically "Automatically switch to the module language when opening a module") (interactions-beside-definitions "Put the interactions window beside the definitions window") ;; in preferences, below the checkbox one line above this one (show-line-numbers "Show line numbers") - (hide-line-numbers "Hide line numbers") + (show-line-numbers/menu "Show Line Numbers") ;; just like the above, but capitalized for appearance in a menu item + (hide-line-numbers/menu "Hide Line Numbers") (limit-interactions-size "Limit interactions size") (background-color "Background Color") (default-text-color "Default text") ;; used for configuring colors, but doesn't need the word "color" diff --git a/collects/string-constants/french-string-constants.rkt b/collects/string-constants/french-string-constants.rkt index 655cc9ef32..b976305859 100644 --- a/collects/string-constants/french-string-constants.rkt +++ b/collects/string-constants/french-string-constants.rkt @@ -134,8 +134,7 @@ (web-materials "Sites web apparentés") ;; menu item title (tool-web-sites "Sites web d'outils") ;; menu item title (plt-homepage "Racket") - (how-to-use-scheme "How to Use Scheme") ;; title of a book. - (teachscheme!-homepage "TeachScheme!") ;; probably this should be a `word' in all languages + (pbd-homepage "Program by Design") ;;; bug report form (cancel-bug-report? "Annuler la soumission du rapport de bogue ?") diff --git a/collects/string-constants/german-string-constants.rkt b/collects/string-constants/german-string-constants.rkt index 7b035962bc..f89b7da066 100644 --- a/collects/string-constants/german-string-constants.rkt +++ b/collects/string-constants/german-string-constants.rkt @@ -36,8 +36,7 @@ (web-materials "Verwandte Web-Seiten") (tool-web-sites "Web-Seiten mit Tools") (plt-homepage "Racket") - (how-to-use-scheme "How to Use Scheme") - (teachscheme!-homepage "TeachScheme!") + (pbd-homepage "Program by Design") ;;; bug report form (cancel-bug-report? "Bug-Report verwerfen?") @@ -345,8 +344,10 @@ (show-interactions-on-execute "Interaktionen beim Programmstart automatisch öffnen") (switch-to-module-language-automatically "Automatisch in die `module'-Sprache wechseln, wenn ein Modul geöffnet wird") (interactions-beside-definitions "Interaktionen neben den Definitionen anzeigen") ;; in preferences, below the checkbox one line above this one - (show-line-numbers "Zeilennummern anzeigen") - (hide-line-numbers "Zeilennummern ausblenden") + (show-line-numbers "Zeilennummern einblenden") + (show-line-numbers/menu "Zeilennummern einblenden") + (hide-line-numbers/menu "Zeilennummern ausblenden") + (limit-interactions-size "Umfang der Interaktionen einschränken") (background-color "Hintergrundfarbe") (default-text-color "Standard für Text") ;; used for configuring colors, but doesn't need the word "color" diff --git a/collects/string-constants/japanese-string-constants.rkt b/collects/string-constants/japanese-string-constants.rkt index 115db43130..ecf092fc73 100644 --- a/collects/string-constants/japanese-string-constants.rkt +++ b/collects/string-constants/japanese-string-constants.rkt @@ -134,8 +134,7 @@ please adhere to these guidelines: (web-materials "関連するウェブサイト") ;; menu item title (tool-web-sites "ツールのウェブサイト") ;; menu item title (plt-homepage "Racket") - (how-to-use-scheme "How to Use Scheme") ;; title of a book. - (teachscheme!-homepage "TeachScheme!") ;; probably this should be a `word' in all languages + (pbd-homepage "Program by Design") ;;; bug report form (cancel-bug-report? "バグ報告を中止しますか？") diff --git a/collects/string-constants/korean-string-constants.rkt b/collects/string-constants/korean-string-constants.rkt index c64fc4f716..c60e4d674f 100644 --- a/collects/string-constants/korean-string-constants.rkt +++ b/collects/string-constants/korean-string-constants.rkt @@ -52,8 +52,7 @@ (web-materials "관련 사이트") ;; menu item title (tool-web-sites "참고 사이트") ;; menu item title (plt-homepage "Racket") - (how-to-use-scheme "How to Use Scheme") ;; title of a book. - (teachscheme!-homepage "TeachScheme!") ;; probably this should be a `word' in all languages + (pbd-homepage "Program by Design") ;;; bug report form (cancel-bug-report? "오류 보고를 취소하시겠습니까?") diff --git a/collects/string-constants/portuguese-string-constants.rkt b/collects/string-constants/portuguese-string-constants.rkt index 4f031f5a6f..32da893194 100644 --- a/collects/string-constants/portuguese-string-constants.rkt +++ b/collects/string-constants/portuguese-string-constants.rkt @@ -134,8 +134,7 @@ please adhere to these guidelines: (web-materials "Sítios Web Relacionados") ;; menu item title (tool-web-sites "Sítios Web de Ferramentas") ;; menu item title (plt-homepage "Racket") - (how-to-use-scheme "Como Usar o Scheme") ;; title of a book. - (teachscheme!-homepage "AprenderScheme!") ;; probably this should be a `word' in all languages + (pbd-homepage "Program by Design") ;;; bug report form (cancel-bug-report? "Cancelar relatório de erro?") diff --git a/collects/string-constants/russian-string-constants.rkt b/collects/string-constants/russian-string-constants.rkt index 53d7358e17..18b03a4600 100644 --- a/collects/string-constants/russian-string-constants.rkt +++ b/collects/string-constants/russian-string-constants.rkt @@ -134,8 +134,7 @@ please adhere to these guidelines: (web-materials "Связанные Web-сайты") ;; menu item title (tool-web-sites "Web-сайты установленных инструментов") ;; menu item title (plt-homepage "Racket") - (how-to-use-scheme "Как использовать Scheme") ;; title of a book. - (teachscheme!-homepage "TeachScheme!") ;; probably this should be a `word' in all languages + (pbd-homepage "Program by Design") ;;; bug report form (cancel-bug-report? "Отменить отправку отчета об ошибках?") diff --git a/collects/string-constants/simplified-chinese-string-constants.rkt b/collects/string-constants/simplified-chinese-string-constants.rkt index 8d596a5541..0aece53ff4 100644 --- a/collects/string-constants/simplified-chinese-string-constants.rkt +++ b/collects/string-constants/simplified-chinese-string-constants.rkt @@ -61,8 +61,7 @@ (web-materials "相关网站") ;; menu item title (tool-web-sites "Tools网站") ;; menu item title (plt-homepage "Racket") - (how-to-use-scheme "How to Use Scheme") ;; title of a book. - (teachscheme!-homepage "TeachScheme!") ;; probably this should be a `word' in all languages + (pbd-homepage "Program by Design") ;;; bug report form (cancel-bug-report? "取消程序错误报告？") diff --git a/collects/string-constants/spanish-string-constants.rkt b/collects/string-constants/spanish-string-constants.rkt index aad50daf90..e5284948b9 100644 --- a/collects/string-constants/spanish-string-constants.rkt +++ b/collects/string-constants/spanish-string-constants.rkt @@ -42,8 +42,7 @@ (web-materials "Sitios de Web Relacionados") (tool-web-sites "Sitios de Web de Herramientas") ;; menu item title (plt-homepage "Racket") - (how-to-use-scheme "Cómo Usar Scheme") - (teachscheme!-homepage "TeachScheme!") + (pbd-homepage "Program by Design") ;;; bug report form (cancel-bug-report? "¿Cancelar el reporte de problemas?") diff --git a/collects/string-constants/traditional-chinese-string-constants.rkt b/collects/string-constants/traditional-chinese-string-constants.rkt index 4857df9e7f..4048e4097f 100644 --- a/collects/string-constants/traditional-chinese-string-constants.rkt +++ b/collects/string-constants/traditional-chinese-string-constants.rkt @@ -60,8 +60,7 @@ (web-materials "相关网站") ;; menu item title (tool-web-sites "Tools网站") ;; menu item title (plt-homepage "Racket") - (how-to-use-scheme "How to Use Scheme") ;; title of a book. - (teachscheme!-homepage "TeachScheme!") ;; probably this should be a `word' in all languages + (pbd-homepage "Program by Design") ;;; bug report form (cancel-bug-report? "取消程序错误报告？") diff --git a/collects/string-constants/ukrainian-string-constants.rkt b/collects/string-constants/ukrainian-string-constants.rkt index 811ae52585..2bbbd349f4 100644 --- a/collects/string-constants/ukrainian-string-constants.rkt +++ b/collects/string-constants/ukrainian-string-constants.rkt @@ -134,8 +134,7 @@ please adhere to these guidelines: (web-materials "Пов'язані Web-сайти") ;; menu item title (tool-web-sites "Web-сайти встановлених інструментів") ;; menu item title (plt-homepage "Racket") - (how-to-use-scheme "Як використовувати Scheme") ;; title of a book. - (teachscheme!-homepage "TeachScheme!") ;; probably this should be a `word' in all languages + (pbd-homepage "Program by Design") ;;; bug report form (cancel-bug-report? "Скасувати відправлення звіту про помилки?") diff --git a/collects/syntax/parse/private/runtime.rkt b/collects/syntax/parse/private/runtime.rkt index 1648fbf6d5..fb1284e495 100644 --- a/collects/syntax/parse/private/runtime.rkt +++ b/collects/syntax/parse/private/runtime.rkt @@ -308,15 +308,15 @@ [(no-shadow e) (let ([ee (local-expand #'e (syntax-local-context) (kernel-form-identifier-list))]) - (syntax-case ee (begin define-values defines-syntaxes) + (syntax-case ee (begin define-values define-syntaxes) [(begin d ...) #'(begin (no-shadow d) ...)] [(define-values . _) - (check-shadow ee) - ee] + (begin (check-shadow ee) + ee)] [(define-syntaxes . _) - (check-shadow ee) - ee] + (begin (check-shadow ee) + ee)] [_ ee]))])) diff --git a/collects/teachpack/2htdp/scribblings/image-toc.rkt b/collects/teachpack/2htdp/scribblings/image-toc.rkt index 0c4abae7fb..f769ce1de7 100644 --- a/collects/teachpack/2htdp/scribblings/image-toc.rkt +++ b/collects/teachpack/2htdp/scribblings/image-toc.rkt @@ -712,6 +712,13 @@ "2dde939d6dc.png") (list '(right-triangle 36 48 "solid" "black") 'image "1a0088e3819.png") (list '(triangle 40 "solid" "tan") 'image "aeddf66d5d.png") + (list + '(equal? + (above empty-image (rectangle 10 10 "solid" "red")) + (beside empty-image (rectangle 10 10 "solid" "red"))) + 'val + '#t) + (list '(image-width empty-image) 'val '0) (list '(text/font "not really a link" 18 "blue" #f 'roman 'normal 'normal #t) 'image diff --git a/collects/teachpack/2htdp/scribblings/image.scrbl b/collects/teachpack/2htdp/scribblings/image.scrbl index 10bc2b7427..dce22fbfa8 100644 --- a/collects/teachpack/2htdp/scribblings/image.scrbl +++ b/collects/teachpack/2htdp/scribblings/image.scrbl @@ -177,6 +177,16 @@ Unlike @racket[scene+curve], if the line passes outside of @racket[image], the i #f 'roman 'normal 'normal #t)] } +@defthing[empty-image image?]{ + The empty image. Its width and height are both zero and it does not draw at all. + + @image-examples[(image-width empty-image) + (equal? (above empty-image + (rectangle 10 10 "solid" "red")) + (beside empty-image + (rectangle 10 10 "solid" "red")))] +} + @section{Polygons} @defproc*[([(triangle [side-length (and/c real? (not/c negative?))] diff --git a/collects/teachpack/2htdp/scribblings/universe.scrbl b/collects/teachpack/2htdp/scribblings/universe.scrbl index 925fe32d3a..92359705a4 100644 --- a/collects/teachpack/2htdp/scribblings/universe.scrbl +++ b/collects/teachpack/2htdp/scribblings/universe.scrbl @@ -492,6 +492,15 @@ and @scheme[big-bang] will close down all event handling.} who wish to see how their world evolves---without having to design a rendering function---plus for the debugging of world programs. }} + +@item{ +@defform[(name name-expr) + #:contracts + ([name-expr (or/c symbol? string?)])]{ + provide a name (@scheme[namer-expr]) to this world, which is used as the + title of the canvas.} +} + ] The following example shows that @scheme[(run-simulation create-UFO-scene)] is @@ -747,17 +756,11 @@ following shapes: @item{ @defform[(register ip-expr) #:contracts ([ip-expr string?])]{ connect this world to a universe server at the specified @scheme[ip-expr] - address and set up capabilities for sending and receiving messages.} -} - -@item{ -@defform[(name name-expr) - #:contracts - ([name-expr (or/c symbol? string?)])]{ - provide a name (@scheme[namer-expr]) to this world, which is used as the - title of the canvas and the name sent to the server.} -} - + address and set up capabilities for sending and receiving messages. + If the world description includes a name specification of the form + @scheme[(name SomeString)] or @scheme[(name SomeSymbol)], the name of the + world is sent along to the server. +}} ] When a world program registers with a universe program and the universe program diff --git a/collects/tests/compiler/zo-exs.rkt b/collects/tests/compiler/zo-exs.rkt index 3bd665ca04..2abdaab4ff 100644 --- a/collects/tests/compiler/zo-exs.rkt +++ b/collects/tests/compiler/zo-exs.rkt @@ -31,7 +31,7 @@ (prefix 0 empty empty) (list 1 (list 2 3) (list 2 3) 4 5))) - (roundtrip + #;(roundtrip (compilation-top 0 (prefix 0 empty empty) (let* ([ph (make-placeholder #f)] diff --git a/collects/tests/data/gvector.rkt b/collects/tests/data/gvector.rkt index 1b2591d32f..cf60fc1302 100644 --- a/collects/tests/data/gvector.rkt +++ b/collects/tests/data/gvector.rkt @@ -68,6 +68,12 @@ (for/list ([x (in-gvector gv)]) x)) '(1 2 3)) +(test-equal? "in-gvector expression form" + (let* ([gv (gvector 1 2 3)] + [gv-sequence (in-gvector gv)]) + (for/list ([x gv-sequence]) x)) + '(1 2 3)) + (test-equal? "gvector as sequence" (let ([gv (gvector 1 2 3)]) (for/list ([x gv]) x)) diff --git a/collects/tests/data/queue.rkt b/collects/tests/data/queue.rkt index 1174f1fef2..505123288f 100644 --- a/collects/tests/data/queue.rkt +++ b/collects/tests/data/queue.rkt @@ -34,6 +34,21 @@ (dequeue! q) (dequeue! q) (check-true (queue-empty? q))))) + (test-suite "length" + (test-case "length empty" + (let* ([queue (make-queue)]) + (check-equal? (queue-length queue) 0))) + (test-case "length enqueue once" + (let* ([queue (make-queue)]) + (enqueue! queue 5) + (check-equal? (queue-length queue) 1))) + (test-case "length enqueue thrice dequeue once" + (let* ([queue (make-queue)]) + (enqueue! queue 5) + (enqueue! queue 9) + (enqueue! queue 12) + (dequeue! queue) + (check-equal? (queue-length queue) 2)))) (test-suite "dequeue!" (test-case "make-queue" (check-exn exn:fail? (lambda () (dequeue! (make-queue))))) @@ -48,4 +63,21 @@ (enqueue! q 2) (check-equal? (dequeue! q) 1) (check-equal? (dequeue! q) 2) - (check-exn exn:fail? (lambda () (dequeue! q)))))))) + (check-exn exn:fail? (lambda () (dequeue! q)))))) + (test-suite "queue misc" + (test-case "queue as a sequence" + (let ([queue (make-queue)]) + (enqueue! queue 1) + (enqueue! queue 2) + (enqueue! queue 3) + (check-equal? '(1 2 3) (for/list ([item (in-queue queue)]) item))) + (check-equal? '() (for/list ([item (in-queue (make-queue))]) item))) + (test-case "queue to empty list" + (let ([queue (make-queue)]) + (check-equal? (queue->list queue) '()))) + (test-case "queue length" + (let ([queue (make-queue)]) + (enqueue! queue 1) + (enqueue! queue 2) + (enqueue! queue 3) + (check-equal? (queue->list queue) '(1 2 3))))))) diff --git a/collects/tests/deinprogramm/image.rkt b/collects/tests/deinprogramm/image.rkt index 4bb2cc43b5..0ee64a739a 100644 --- a/collects/tests/deinprogramm/image.rkt +++ b/collects/tests/deinprogramm/image.rkt @@ -101,8 +101,8 @@ (let ([bm-normal (make-object bitmap% (max 1 width) (max 1 height))] [bm-bitmap (make-object bitmap% (max 1 width) (max 1 height))] - [s-normal (make-bytes (* width height 4))] - [s-bitmap (make-bytes (* width height 4))]) + [s-normal (make-bytes (* (max 1 width) (max 1 height) 4))] + [s-bitmap (make-bytes (* (max 1 width) (max 1 height) 4))]) (send bdc set-bitmap bm-normal) (send bdc clear) diff --git a/collects/tests/drracket/drracket-test-util.rkt b/collects/tests/drracket/drracket-test-util.rkt index b7a6bff21c..d64427d7c9 100644 --- a/collects/tests/drracket/drracket-test-util.rkt +++ b/collects/tests/drracket/drracket-test-util.rkt @@ -177,9 +177,9 @@ (let ([window (send frame get-focus-window)]) (let-values ([(cw ch) (send window get-client-size)] [(w h) (send window get-size)]) - (fw:test:mouse-click 'left - (inexact->exact (+ cw (floor (/ (- w cw) 2)))) - (inexact->exact (+ ch (floor (/ (- h ch) 2))))))) + (fw:test:mouse-click 'left + (inexact->exact (floor (+ cw (/ (- w cw) 2)))) + (inexact->exact (floor (+ ch (/ (- h ch) 2))))))) (fw:test:menu-select "Edit" "Select All") (fw:test:menu-select "Edit" (if (eq? (system-type) 'macos) "Clear" @@ -332,8 +332,8 @@ (let-values ([(gx gy) (send editor editor-location-to-dc-location (unbox b1) (unbox b2))]) - (let ([x (inexact->exact (+ gx between-threshold 1))] - [y (inexact->exact (+ gy between-threshold 1))]) + (let ([x (inexact->exact (floor (+ gx between-threshold 1)))] + [y (inexact->exact (floor (+ gy between-threshold 1)))]) (fw:test:mouse-click 'left x y)))))]) (send language-choice focus) (let loop ([list-item language-choice] @@ -571,7 +571,8 @@ (lambda (name [fail (lambda () #f)]) (hash-ref prefs-table name fail)))) - (dynamic-require 'drscheme #f) + (parameterize ([current-command-line-arguments #()]) + (dynamic-require 'drscheme #f)) ;; set all preferences to their defaults (some pref values may have ;; been read by this point, but hopefully that won't affect much diff --git a/collects/tests/drracket/leaky-frame.rkt b/collects/tests/drracket/leaky-frame.rkt new file mode 100644 index 0000000000..6faa4882c6 --- /dev/null +++ b/collects/tests/drracket/leaky-frame.rkt @@ -0,0 +1,47 @@ +#lang racket +(require "drracket-test-util.rkt" + framework) + +(parameterize ([current-command-line-arguments '#()]) + (fire-up-drscheme-and-run-tests + (λ () + (define drs-frame1 (wait-for-drscheme-frame)) + (sync (system-idle-evt)) + + (test:menu-select "File" "New Tab") + (sync (system-idle-evt)) + + (define drs-tabb (make-weak-box (send drs-frame1 get-current-tab))) + (define tab-nsb (make-weak-box (send (send (send drs-frame1 get-current-tab) get-ints) get-user-namespace))) + + (test:menu-select "File" "Close Tab") + (sync (system-idle-evt)) + + (test:menu-select "File" "New") + (sync (system-idle-evt)) + + (define drs-frame2b (make-weak-box (wait-for-new-frame drs-frame1))) + (define frame2-nsb (make-weak-box (send (send (send (weak-box-value drs-frame2b) get-current-tab) get-ints) get-user-namespace))) + + (test:menu-select "File" "Close") + (sync (system-idle-evt)) + + (let loop ([n 30]) + (cond + [(zero? n) + (when (weak-box-value drs-tabb) + (fprintf (current-error-port) "frame leak!\n")) + (when (weak-box-value drs-frame2b) + (fprintf (current-error-port) "tab leak!\n")) + (when (weak-box-value tab-nsb) + (fprintf (current-error-port) "tab namespace leak!\n")) + (when (weak-box-value frame2-nsb) + (fprintf (current-error-port) "frame namespace leak!\n"))] + [else + (collect-garbage) + (when (ormap weak-box-value + (list drs-tabb + tab-nsb + drs-frame2b + frame2-nsb)) + (loop (- n 1)))]))))) diff --git a/collects/tests/drracket/syncheck-test.rkt b/collects/tests/drracket/syncheck-test.rkt index 92cb8eff4b..ff78041194 100644 --- a/collects/tests/drracket/syncheck-test.rkt +++ b/collects/tests/drracket/syncheck-test.rkt @@ -248,6 +248,39 @@ trigger runtime errors in check syntax. ("x" lexically-bound-variable) (")" default-color)) (list '((22 23) (25 26)))) + (build-test "(define-syntax-rule (m x y z) (list (λ x y) (λ x z)))\n(m x x x)" + '(("(" default-color) + ("define-syntax-rule" imported) + (" (" default-color) + ("m" lexically-bound) + (" " default-color) + ("x" lexically-bound) + (" " default-color) + ("y" lexically-bound) + (" " default-color) + ("z" lexically-bound) + (") (list (λ " default-color) + ("x" lexically-bound) + (" " default-color) + ("y" lexically-bound) + (") (λ " default-color) + ("x" lexically-bound) + (" " default-color) + ("z" lexically-bound) + (")))\n(" default-color) + ("m" lexically-bound) + (" " default-color) + ("x" lexically-bound) + (" " default-color) + ("x" lexically-bound) + (" " default-color) + ("x" lexically-bound) + (")" default-color)) + (list '(((21 22) (55 56)) + ((23 24) (39 40) (47 48)) + ((25 26) (41 42)) + ((27 28) (49 50)) + ((57 58) (59 60) (61 62))))) (build-test "(module m mzscheme)" '(("(" default-color) diff --git a/collects/tests/gracket/dc.rktl b/collects/tests/gracket/dc.rktl index 5e7d0f6f78..afce8bc4c5 100644 --- a/collects/tests/gracket/dc.rktl +++ b/collects/tests/gracket/dc.rktl @@ -194,6 +194,27 @@ #"\377\377\377\377\377\377\377\377\377\0\0\0\377\0\0\0\377\0\0\0"))) (test #t 'same-bits (equal? bs bs2))) +;; ---------------------------------------- +;; Test draw-bitmap-section-smooth + +(let* ([bm (make-bitmap 100 100)] + [dc (make-object bitmap-dc% bm)] + [bm2 (make-bitmap 70 70)] + [dc2 (make-object bitmap-dc% bm2)] + [bm3 (make-bitmap 70 70)] + [dc3 (make-object bitmap-dc% bm3)]) + (send dc draw-ellipse 0 0 100 100) + (send dc2 draw-bitmap-section-smooth bm + 10 10 50 50 + 0 0 100 100) + (send dc3 scale 0.5 0.5) + (send dc3 draw-bitmap bm 20 20) + (let ([s2 (make-bytes (* 4 70 70))] + [s3 (make-bytes (* 4 70 70))]) + (send bm2 get-argb-pixels 0 0 70 70 s2) + (send bm3 get-argb-pixels 0 0 70 70 s3) + (test #t 'same-scaled (equal? s2 s3)))) + ;; ---------------------------------------- (report-errs) diff --git a/collects/tests/gracket/draw.rkt b/collects/tests/gracket/draw.rkt index 389223493b..3d8158cb8b 100644 --- a/collects/tests/gracket/draw.rkt +++ b/collects/tests/gracket/draw.rkt @@ -263,7 +263,7 @@ [on-paint (case-lambda [() (time (on-paint #f))] - [(ps?) + [(kind) (let* ([can-dc (get-dc)] [pen0s (make-object pen% "BLACK" 0 'solid)] [pen1s (make-object pen% "BLACK" 1 'solid)] @@ -811,7 +811,7 @@ (send dc draw-rectangle 180 205 20 20) (send dc set-brush brushs)))) - (when (and pixel-copy? last? (not (or ps? (eq? dc can-dc)))) + (when (and pixel-copy? last? (not (or kind (eq? dc can-dc)))) (let* ([x 100] [y 170] [x2 245] [y2 188] @@ -941,7 +941,7 @@ (send dc draw-rectangle 187 310 20 20) (send dc set-pen p))) - (when (and last? (not (or ps? (eq? dc can-dc))) + (when (and last? (not (or kind (eq? dc can-dc))) (send mem-dc get-bitmap)) (send can-dc draw-bitmap (send mem-dc get-bitmap) 0 0 'opaque))) @@ -950,10 +950,23 @@ (send (get-dc) set-scale 1 1) (send (get-dc) set-origin 0 0) - (let ([dc (if ps? - (let ([dc (if (eq? ps? 'print) - (make-object printer-dc%) - (make-object post-script-dc%))]) + (let ([dc (if kind + (let ([dc (case kind + [(print) (make-object printer-dc%)] + [(ps pdf) + (let ([page? + (eq? 'yes (message-box + "Bounding Box" + "Use paper bounding box?" + #f + '(yes-no)))]) + (new (if (eq? kind 'ps) + post-script-dc% + pdf-dc%) + [width (* xscale DRAW-WIDTH)] + [height (* yscale DRAW-HEIGHT)] + [as-eps (not page?)] + [use-paper-bbox page?]))])]) (and (send dc ok?) dc)) (if (and use-bitmap?) (begin @@ -1112,7 +1125,7 @@ (let-values ([(w h) (send dc get-size)]) (unless (cond - [ps? #t] + [kind #t] [use-bad? #t] [use-bitmap? (and (= w (* xscale DRAW-WIDTH)) (= h (* yscale DRAW-HEIGHT)))] [else (and (= w (* 2 DRAW-WIDTH)) (= h (* 2 DRAW-HEIGHT)))]) @@ -1143,10 +1156,10 @@ '(horizontal)) (make-object button% "PS" hp (lambda (self event) - (send canvas on-paint #t))) - (make-object button% "Print" hp + (send canvas on-paint 'ps))) + (make-object button% "PDF" hp (lambda (self event) - (send canvas on-paint 'print))) + (send canvas on-paint 'pdf))) (make-object choice% #f '("1" "*2" "/2" "1,*2" "*2,1") hp (lambda (self event) (send canvas set-scale @@ -1243,6 +1256,7 @@ (send canvas refresh))))]) (set! do-clock clock) (make-object button% "Clip Clock" hp3 (lambda (b e) (clock #t))) + (make-object button% "Print" hp4 (lambda (self event) (send canvas on-paint 'print))) (make-object button% "Print Setup" hp4 (lambda (b e) (let ([c (get-page-setup-from-user)]) (when c (send (current-ps-setup) copy-from c))))) diff --git a/collects/tests/gracket/flush-stress.rkt b/collects/tests/gracket/flush-stress.rkt new file mode 100644 index 0000000000..cddbaff663 --- /dev/null +++ b/collects/tests/gracket/flush-stress.rkt @@ -0,0 +1,50 @@ +#lang racket/gui + +(define SIZE 600) + +(define f (new frame% + [label "Color Bars"] + [width SIZE] + [height SIZE])) + +(define c (new canvas% [parent f])) + +(send f show #t) + +;; If sync is turned off, then expect the drawing +;; to flicker horribly: +(define sync? #t) + +;; If flush-on-sync is disabled, the expect refresh +;; to starve, so that the image moves very rarely, if +;; at all: +(define flush-on-sync? #t) + +(define (start-drawing dc) + (when sync? + (send dc suspend-flush))) + +(define (end-drawing dc) + (when sync? + (send dc resume-flush) + (when flush-on-sync? + (send dc flush)))) + +(define (go) + (let ([dc (send c get-dc)]) + (for ([d (in-naturals)]) + (start-drawing dc) + (send dc erase) + ;; Draw somthing slow that changes with d + (for ([n (in-range 0 SIZE)]) + (send dc set-pen + (make-object color% + (remainder (+ n d) 256) + (remainder (* 2 (+ n d)) 256) + (remainder (* 3 (+ n d)) 256)) + 1 + 'solid) + (send dc draw-line n 0 n SIZE)) + (end-drawing dc)))) + +(thread go) diff --git a/collects/tests/gracket/unflushed-circle.rkt b/collects/tests/gracket/unflushed-circle.rkt new file mode 100644 index 0000000000..7376ed6212 --- /dev/null +++ b/collects/tests/gracket/unflushed-circle.rkt @@ -0,0 +1,43 @@ +#lang racket/gui +(require racket/math) + +;; This test creates a background that draws a circle in changing +;; colors. It draws in a background thread --- on in response to +;; `on-paint', and with no flushing controls --- but it should nevertheless +;; refresh onscreen frequently through an automatic flush. + +(define f (new frame% + [label "Snake"] + [width 400] + [height 400])) + +(define c (new canvas% [parent f])) + +(send f show #t) + +(define prev-count 0) +(define next-time (+ (current-inexact-milliseconds) 1000)) + +(define (go) + (let loop ([n 0]) + (when ((current-inexact-milliseconds) . > . next-time) + (printf "~s\n" (- n prev-count)) + (set! prev-count n) + (set! next-time (+ (current-inexact-milliseconds) 1000))) + (let ([p (make-polar 175 (* pi (/ n 100)))] + [dc (send c get-dc)]) + (send dc set-brush + (make-object color% + (remainder n 256) + (remainder (* 2 n) 256) + (remainder (* 3 n) 256)) + 'solid) + (send dc draw-rectangle + (+ 180 (real-part p)) + (+ 180 (imag-part p)) + 20 + 20) + (loop (add1 n))))) + +(thread go) + diff --git a/collects/tests/gracket/windowing.rktl b/collects/tests/gracket/windowing.rktl index 52f0f2459c..1f36d1d991 100644 --- a/collects/tests/gracket/windowing.rktl +++ b/collects/tests/gracket/windowing.rktl @@ -30,6 +30,17 @@ (thread (lambda () (sleep 0.01) (semaphore-post s))) (test s 'yield (yield s)))) +(define (iconize-pause) + (if (eq? 'unix (system-type)) + ;; iconization might take a while + ;; for the window manager to report back + (begin + (pause) + (when (regexp-match? #rx"darwin" (path->string (system-library-subpath))) + (sleep 0.75)) + (pause)) + (pause))) + (let ([s (make-semaphore 1)]) (test s 'yield-wrapped (yield s))) (let ([s (make-semaphore 1)]) @@ -66,7 +77,7 @@ (test #t `(client-size ,f ,cw ,ch ,w ,h) (and (<= 1 cw w) (<= 1 ch h)))) (stv f refresh)) -(define (area-tests f sw? sh? no-stretch?) +(define (area-tests f sw? sh? no-stretch? use-client-size?) (printf "Area ~a\n" f) (let ([x (send f min-width)] [y (send f min-height)]) @@ -75,7 +86,9 @@ (stv (send f get-top-level-window) reflow-container) (pause) ; to make sure size has taken effect (let-values ([(w h) (if no-stretch? - (send f get-size) + (if use-client-size? + (send f get-client-size) + (send f get-size)) (values 0 0))]) (printf "Size ~a x ~a\n" w h) (when no-stretch? @@ -95,7 +108,7 @@ (stv f min-height y))) (define (containee-tests f sw? sh? m) - (area-tests f sw? sh? #f) + (area-tests f sw? sh? #f #f) (printf "Containee ~a\n" f) (st m f horiz-margin) (st m f vert-margin) @@ -166,7 +179,7 @@ (st my-l b get-plain-label) (stv b set-label &-l))) -(let ([f (make-object frame% "Yes & No" #f 150 151 20 21)]) +(let ([f (make-object frame% "Yes & No" #f 150 151 70 21)]) (let ([init-tests (lambda (hidden?) (st "Yes & No" f get-label) @@ -177,15 +190,8 @@ (stv f set-label "Yes & No") (st #f f get-parent) (st f f get-top-level-window) - (case (system-type 'os) - [(unix) - (st 21 f get-x) - (if hidden? - (st 43 f get-y) - (st 22 f get-y))] - [else - (st 20 f get-x) - (st 21 f get-y)]) + (st 70 f get-x) + (st 21 f get-y) (st 150 f get-width) (st 151 f get-height) (stvals (list (send f get-width) (send f get-height)) f get-size) @@ -218,7 +224,7 @@ [container-tests (lambda () (printf "Container\n") - (area-tests f #t #t #t) + (area-tests f #t #t #t #t) (let-values ([(x y) (send f container-size null)]) (st x f min-width) (st y f min-height)) @@ -261,13 +267,18 @@ (printf "Iconize\n") (stv f iconize #t) - (pause) - (pause) - (st #t f is-iconized?) ; NB: test will fail on MacOS - (stv f show #t) - (pause) + (iconize-pause) + (st #t f is-iconized?) + (stv f iconize #f) + (iconize-pause) (st #f f is-iconized?) - + (stv f iconize #t) + (iconize-pause) + (st #t f is-iconized?) + (stv f show #t) + (iconize-pause) + (st #f f is-iconized?) + (stv f maximize #t) (pause) (stv f maximize #f) @@ -282,16 +293,16 @@ (st 151 f get-height) (printf "Resize\n") - (stv f resize 56 57) + (stv f resize 156 57) (pause) (FAILS (st 34 f get-x)) (FAILS (st 37 f get-y)) - (st 56 f get-width) + (st 156 f get-width) (st 57 f get-height) (stv f center) (pause) - (st 56 f get-width) + (st 156 f get-width) (st 57 f get-height) (client->screen-tests) @@ -1010,7 +1021,7 @@ (test-controls panel frame) (if win? ((if % containee-window-tests window-tests) panel #t #t (and % frame) frame 0) - (area-tests panel #t #t #f)) + (area-tests panel #t #t #f #f)) (when (is-a? panel panel%) (st #t panel get-orientation (is-a? panel horizontal-panel%))) (container-tests panel win?) diff --git a/collects/tests/htdp-lang/htdp-image.rktl b/collects/tests/htdp-lang/htdp-image.rktl index 41bce43b18..f21d453b73 100644 --- a/collects/tests/htdp-lang/htdp-image.rktl +++ b/collects/tests/htdp-lang/htdp-image.rktl @@ -96,8 +96,8 @@ (let ([bm-normal (make-object bitmap% (max 1 width) (max 1 height))] [bm-bitmap (make-object bitmap% (max 1 width) (max 1 height))] - [s-normal (make-bytes (* width height 4))] - [s-bitmap (make-bytes (* width height 4))]) + [s-normal (make-bytes (* (max 1 width) (max 1 height) 4))] + [s-bitmap (make-bytes (* (max 1 width) (max 1 height) 4))]) (send bdc set-bitmap bm-normal) (send bdc clear) diff --git a/collects/tests/plai/gc/good-mutators/thunks.rkt b/collects/tests/plai/gc/good-mutators/thunks.rkt new file mode 100755 index 0000000000..4191318180 --- /dev/null +++ b/collects/tests/plai/gc/good-mutators/thunks.rkt @@ -0,0 +1,15 @@ +#lang plai/mutator +(allocator-setup "../good-collectors/good-collector.ss" 4) + +; 2 +(define thunker + (lambda () + ; 2 + 'alligator + ; 2 + 'bananna + ; 2 + 'frog)) +; 4 total + +(thunker) \ No newline at end of file diff --git a/collects/tests/plai/gc/other-mutators/begin.rkt b/collects/tests/plai/gc/other-mutators/begin.rkt new file mode 100644 index 0000000000..71f729b3ae --- /dev/null +++ b/collects/tests/plai/gc/other-mutators/begin.rkt @@ -0,0 +1,9 @@ +#lang plai/mutator +(allocator-setup "../good-collectors/good-collector.rkt" 6) + +(define (go) + (let ([obj 'z]) + 2 3 + (symbol? obj))) + +(go) \ No newline at end of file diff --git a/collects/tests/plai/gc/run-test.rkt b/collects/tests/plai/gc/run-test.rkt index eb0d42ef0c..9cb6d41c46 100644 --- a/collects/tests/plai/gc/run-test.rkt +++ b/collects/tests/plai/gc/run-test.rkt @@ -51,6 +51,14 @@ (good (heap-loc head) 62 62 "at line 18") (bad (heap-loc head) 62 47 "at line 19") +END + + (capture-output (test-mutator (build-path here "other-mutators" "begin.rkt"))) + => + #<symbol name) '(nucleic2)) + ",s" + "") name)) diff --git a/collects/tests/racket/contract-test.rktl b/collects/tests/racket/contract-test.rktl index 28e1e98fbc..20d4129450 100644 --- a/collects/tests/racket/contract-test.rktl +++ b/collects/tests/racket/contract-test.rktl @@ -6044,6 +6044,16 @@ (test #t (contract-eval 'is-a?) (contract-eval `(contract (object-contract) ,o 'pos 'neg)) i<%>) (test #t (contract-eval 'is-a?) (contract-eval `(contract (object-contract) ,o 'pos 'neg)) c%)) + ;; Currently the new object contracts using impersonators don't even attempt to ensure that + ;; these reflective operations still work, and I'm not even sure they should. For now, I + ;; just get the class info from the original object, which means that all contracts are evaded. + ;; + ;; Just as a note, if we move the class-insp-mk values forward in class/c-proj and make-wrapper-class, + ;; we get a failure in object->vector for the second testcase because the field-ref/field-set! in the + ;; contracted version of the class (for a struct subtype of the original class's struct type) doesn't + ;; know how to get the fields out of the object struct. We can always force it with unsafe-struct-ref, + ;; but if we had impersonate-struct-type, with the same ability to replace the prop:object as + ;; impersonate-struct has, then we might be able to handle this better. (let ([c% (parameterize ([current-inspector (make-inspector)]) (contract-eval '(class object% (super-new))))]) (test (list c% #f) @@ -9940,6 +9950,9 @@ so that propagation occurs. (let ([ctc (vector/c number? number?)]) (test ctc value-contract (contract ctc (vector 4 5) 'pos 'neg))) + (let ([ctc (object-contract)]) + (test ctc value-contract (contract ctc (new object%) 'pos 'neg))) + ; ; ; diff --git a/collects/tests/racket/foreign-test.rktl b/collects/tests/racket/foreign-test.rktl index a8ef509b5c..182edfdea5 100644 --- a/collects/tests/racket/foreign-test.rktl +++ b/collects/tests/racket/foreign-test.rktl @@ -239,6 +239,21 @@ (ptr-set! v _pointer (ptr-add #f 107)) (test 107 ptr-ref v _intptr)) +;; Test equality and hashing of c pointers: +(let ([seventeen1 (cast 17 _long _pointer)] + [seventeen2 (cast 17 _long _pointer)] + [seventeen3 (ptr-add (cast 13 _long _pointer) 4)] + [sixteen (cast 16 _long _pointer)]) + (test #t equal? seventeen1 seventeen2) + (test #t equal? seventeen1 seventeen3) + (test #f equal? sixteen seventeen1) + (test #t = (equal-hash-code seventeen1) (equal-hash-code seventeen2)) + (test #t = (equal-hash-code seventeen1) (equal-hash-code seventeen3)) + (let ([ht (make-hash)]) + (hash-set! ht seventeen1 'hello) + (test 'hello hash-ref ht seventeen2 #f) + (test 'hello hash-ref ht seventeen3 #f))) + (delete-test-files) (report-errs) diff --git a/collects/tests/racket/list.rktl b/collects/tests/racket/list.rktl index 23d21a62ac..c29a4c4335 100644 --- a/collects/tests/racket/list.rktl +++ b/collects/tests/racket/list.rktl @@ -317,6 +317,14 @@ (test '(1 2 3) am list '(1 2 3)) (test '(1 1 2 2 3 3) am (lambda (x) (list x x)) '(1 2 3))) +;; ---------- shuffle ---------- +(let loop ([l (reverse '(1 2 4 8 16 32))]) + (define (length+sum l) (list (length l) (apply + l))) + (define expected (length+sum l)) + (for ([i (in-range 100)]) + (test expected length+sum (shuffle l))) + (when (pair? l) (loop (cdr l)))) + ;; ---------- argmin & argmax ---------- (let () diff --git a/collects/tests/racket/namespac.rktl b/collects/tests/racket/namespac.rktl index bf01543a9e..0ad686ad15 100644 --- a/collects/tests/racket/namespac.rktl +++ b/collects/tests/racket/namespac.rktl @@ -162,4 +162,10 @@ ;; ---------------------------------------- +(parameterize ([current-namespace (make-base-namespace)]) + (eval '(define-namespace-anchor anchor)) + (test 1 eval '(eval 1 (namespace-anchor->namespace anchor)))) + +;; ---------------------------------------- + (report-errs) diff --git a/collects/tests/racket/optimize.rktl b/collects/tests/racket/optimize.rktl index 7a588cad42..69cecde375 100644 --- a/collects/tests/racket/optimize.rktl +++ b/collects/tests/racket/optimize.rktl @@ -1363,6 +1363,25 @@ ((proc 98) x))))) +;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;; Check that an unboxable flonum argument +;; is not incorrectly inferred: + +(test '(done) + 'unboxing-inference-test + (let () + (define (f x y) + (if (zero? y) + ;; prevents inlining: + '(done) + (if (zero? y) + ;; incorrectly triggered unboxing, + ;; once upon a time: + (fl+ x 1.0) + ;; not a float argument => no unboxing of x: + (f y (sub1 y))))) + (f 1.0 100))) + ;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; (report-errs) diff --git a/collects/tests/racket/prompt-tests.rktl b/collects/tests/racket/prompt-tests.rktl index 3fea812086..6460afba5a 100644 --- a/collects/tests/racket/prompt-tests.rktl +++ b/collects/tests/racket/prompt-tests.rktl @@ -2011,9 +2011,126 @@ (test 2 count 2) (test 4 count 3)) +;; ---------------------------------------- +;; Test genearted by a random tester that turns out +;; to check meta-continuation continuation-mark lookup +;; in a dynamic-wind thunk: +(test + 'exn + 'random-dc-test + (with-handlers ([exn:fail? (lambda (exn) 'exn)]) + (let () + (define tag + (let ([tags (make-hash)]) + (λ (v) + (hash-ref tags v + (λ () + (let ([t (make-continuation-prompt-tag)]) + (hash-set! tags v t) + t)))))) - + (define-syntax-rule (% tag-val expr handler) + (call-with-continuation-prompt + (λ () expr) + (let ([v tag-val]) + (if (let comparable? ([v v]) + (cond [(procedure? v) #f] + [(list? v) (andmap comparable? v)] + [else #t])) + (tag v) + (raise-type-error '% "non-procedure" v))) + (let ([h handler]) + (λ (x) (h x))))) + (define (abort tag-val result) + (abort-current-continuation (tag tag-val) result)) + (define (call/comp proc tag-val) + (call-with-composable-continuation (compose proc force-unary) (tag tag-val))) + (define (call/cm key val thunk) + (with-continuation-mark key val (thunk))) + + (define (current-marks key tag-val) + (continuation-mark-set->list + (current-continuation-marks (tag tag-val)) + key)) + + (define ((force-unary f) x) (f x)) + + (define (_call/cc proc tag-val) + (call/cc (compose proc force-unary) (tag tag-val))) + + (letrec ((CEJ-comp-cont_13 #f) + (CEJ-skip-pre?_12 #f) + (CEJ-allocated?_11 #f) + (s-comp-cont_9 #f) + (s-skip-pre?_8 #f) + (s-allocated?_7 #f) + (N-comp-cont_4 #f) + (N-skip-pre?_3 #f) + (N-allocated?_2 #f) + (handlers-disabled?_0 #f)) + (% + #t + ((begin + (set! handlers-disabled?_0 #t) + ((λ (v_1) + (% + v_1 + ((λ (t_5) + (if N-allocated?_2 + (begin (if handlers-disabled?_0 #f (set! N-skip-pre?_3 #t)) (N-comp-cont_4 t_5)) + (% + 1 + (dynamic-wind + (λ () + (if handlers-disabled?_0 + #f + (if N-allocated?_2 + (if N-skip-pre?_3 + (set! N-skip-pre?_3 #f) + (begin + (set! handlers-disabled?_0 #t) + ((λ (v_6) + (% v_6 (_call/cc (λ (k) (abort v_6 k)) v_6) (λ (x) (begin (set! handlers-disabled?_0 #f) x)))) + print))) + #f))) + (λ () ((call/comp (λ (k) (begin (set! N-comp-cont_4 k) (abort 1 k))) 1))) + (λ () (if handlers-disabled?_0 (set! N-allocated?_2 #t) (if N-allocated?_2 #f (set! N-allocated?_2 #t))))) + (λ (k) (begin (if handlers-disabled?_0 #f (set! N-skip-pre?_3 #t)) (k t_5)))))) + (λ () + ((λ (t_10) + (if s-allocated?_7 + (begin (if handlers-disabled?_0 #f (set! s-skip-pre?_8 #t)) (s-comp-cont_9 t_10)) + (% + 1 + (dynamic-wind + (λ () (if handlers-disabled?_0 #f (if s-allocated?_7 (if s-skip-pre?_8 (set! s-skip-pre?_8 #f) #f) #f))) + (λ () ((call/comp (λ (k) (begin (set! s-comp-cont_9 k) (abort 1 k))) 1))) + (λ () + (if handlers-disabled?_0 (set! s-allocated?_7 #t) (if s-allocated?_7 #f (set! s-allocated?_7 #t))))) + (λ (k) (begin (if handlers-disabled?_0 #f (set! s-skip-pre?_8 #t)) (k t_10)))))) + (λ () + ((λ (t_14) + (if CEJ-allocated?_11 + (begin (if handlers-disabled?_0 #f (set! CEJ-skip-pre?_12 #t)) (CEJ-comp-cont_13 t_14)) + (% + 1 + (dynamic-wind + (λ () + (if handlers-disabled?_0 + #f + (if CEJ-allocated?_11 (if CEJ-skip-pre?_12 (set! CEJ-skip-pre?_12 #f) first) #f))) + (λ () ((call/comp (λ (k) (begin (set! CEJ-comp-cont_13 k) (abort 1 k))) 1))) + (λ () + (if handlers-disabled?_0 + (set! CEJ-allocated?_11 #t) + (if CEJ-allocated?_11 call/cm (set! CEJ-allocated?_11 #t))))) + (λ (k) (begin (if handlers-disabled?_0 #f (set! CEJ-skip-pre?_12 #t)) (k t_14)))))) + (λ () (_call/cc (λ (k) (abort v_1 k)) v_1))))))) + (λ (x) (begin (set! handlers-disabled?_0 #f) x)))) + #t)) + 1234) + (λ (x) x)))))) diff --git a/collects/tests/racket/syntax.rktl b/collects/tests/racket/syntax.rktl index 5508dc767b..9e1090275c 100644 --- a/collects/tests/racket/syntax.rktl +++ b/collects/tests/racket/syntax.rktl @@ -1353,7 +1353,24 @@ (syntax-case stx () [(_ v) (datum->syntax stx (kw/f #:x #'v opt))])) (kw/g 7)))) - + +;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;; Check mutation of local define-for-syntax in let-syntax: + +(module set-local-dfs racket/base + (require (for-syntax racket/base)) + (provide ten) + + (define-for-syntax tl-var 9) + + (define ten + (let-syntax ([x1 (lambda (stx) + (set! tl-var (add1 tl-var)) + (datum->syntax stx tl-var))]) + (x1)))) + +(test 10 dynamic-require ''set-local-dfs 'ten) + ;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; (report-errs) diff --git a/collects/tests/rackunit/pr10950.rkt b/collects/tests/rackunit/pr10950.rkt index 1663aaaeb9..c99dd9d234 100644 --- a/collects/tests/rackunit/pr10950.rkt +++ b/collects/tests/rackunit/pr10950.rkt @@ -4,13 +4,19 @@ racket/port tests/eli-tester) -(test - (with-output-to-string +(define output + (with-output-to-string (lambda () (parameterize ([current-error-port (current-output-port)]) (define-check (check3) (fail-check)) - (run-tests (test-suite "tests" (let ((foo check3)) (foo))))))) - => - "--------------------\ntests > #f\nUnnamed test \nFAILURE\nname: check3\nlocation: unknown:?:?\nparams: \n--------------------\n0 success(es) 1 failure(s) 0 error(s) 1 test(s) run\n") \ No newline at end of file + (run-tests (test-suite "tests" (let ((foo check3)) (foo)))))))) + +(test + (regexp-match + (regexp (format "~a.*~a" + (regexp-quote "--------------------\ntests > #f\nUnnamed test \nFAILURE\nname: check3\nlocation: ") + + (regexp-quote "/collects/tests/rackunit/pr10950.rkt:14:51\nparams: \n--------------------\n0 success(es) 1 failure(s) 0 error(s) 1 test(s) run\n"))) + output)) \ No newline at end of file diff --git a/collects/tests/stress.rkt b/collects/tests/stress.rkt index 284b301a34..3aa0733e19 100644 --- a/collects/tests/stress.rkt +++ b/collects/tests/stress.rkt @@ -70,8 +70,25 @@ #:key (λ (v) (vector-ref v 1)))) (define (stress-display how-many res) + (define-values + (min-cpu min-real min-gc) + (for/fold ([min-cpu +inf.0] + [min-real +inf.0] + [min-gc +inf.0]) + ([v (in-list res)]) + (match-define (vector label cpu real gc) v) + (printf "~a: cpu: ~a real: ~a gc: ~a (averaged over ~a runs)\n" + label cpu real gc how-many) + (values (min min-cpu cpu) + (min min-real real) + (min min-gc gc)))) + (define (norm min x) + (if (zero? min) + "inf" + (real->decimal-string (/ x min)))) + (printf "Normalized:\n") (for ([v (in-list res)]) (match-define (vector label cpu real gc) v) (printf "~a: cpu: ~a real: ~a gc: ~a (averaged over ~a runs)\n" - label cpu real gc how-many)) + label (norm min-cpu cpu) (norm min-real real) (norm min-gc gc) how-many)) (newline)) \ No newline at end of file diff --git a/collects/tests/web-server/dispatch-test.rkt b/collects/tests/web-server/dispatch-test.rkt index 1bd4189869..6108839e20 100644 --- a/collects/tests/web-server/dispatch-test.rkt +++ b/collects/tests/web-server/dispatch-test.rkt @@ -10,7 +10,8 @@ web-server/dispatch/pattern web-server/dispatch/url-patterns web-server/dispatch/syntax - web-server/dispatch/serve) + web-server/dispatch/serve + web-server/dispatch/container) (provide all-dispatch-tests) (define (test-request url) @@ -308,52 +309,72 @@ (test-blog-dispatch/exn "http://www.example.com/archive/2008/post") (test-blog-dispatch/exn "http://www.example.com/foo")) - (local - [(define (list-posts req) `(list-posts)) - (define (review-post req p) `(review-post ,p)) - (define (review-archive req y m) `(review-archive ,y ,m)) - (define-values (blog-dispatch blog-url) - (dispatch-rules - [("") list-posts] - [() list-posts] - [("posts" (string-arg)) review-post] - [("archive" (integer-arg) (integer-arg)) review-archive])) - (define (test-blog-dispatch url res) - (test-equal? url (blog-dispatch (test-request (string->url url))) res)) - (define (test-blog-url url . args) - (test-equal? (format "~S" args) - (apply blog-url args) - url)) - (define (test-blog-url/exn . args) - (test-exn (format "~S" args) - exn? - (lambda () - (apply blog-url args)))) - (define (test-blog-dispatch/exn url) - (test-exn url exn:dispatcher? (lambda () (blog-dispatch (test-request (string->url url))))))] + (let () + (define (list-posts req) `(list-posts)) + (define (review-post req p) `(review-post ,p)) + (define (review-archive req y m) `(review-archive ,y ,m)) + + (define (make-dispatch-test-suite blog-dispatch blog-url) + (define (test-blog-dispatch url res) + (test-equal? url (blog-dispatch (test-request (string->url url))) res)) + (define (test-blog-url url . args) + (test-equal? (format "~S" args) + (apply blog-url args) + url)) + (define (test-blog-url/exn . args) + (test-exn (format "~S" args) + exn? + (lambda () + (apply blog-url args)))) + (define (test-blog-dispatch/exn url) + (test-exn url exn:dispatcher? (lambda () (blog-dispatch (test-request (string->url url)))))) + + (test-suite + "blog" + + (test-blog-dispatch "http://www.example.com" `(list-posts)) + (test-blog-dispatch "http://www.example.com/" `(list-posts)) + (test-blog-dispatch "http://www.example.com/posts/hello-world" `(review-post "hello-world")) + (test-blog-dispatch "http://www.example.com/archive/2008/02" `(review-archive 2008 02)) + (test-blog-dispatch/exn "http://www.example.com/posts") + (test-blog-dispatch/exn "http://www.example.com/archive/post/02") + (test-blog-dispatch/exn "http://www.example.com/archive/2008/post") + (test-blog-dispatch/exn "http://www.example.com/foo") + + (test-blog-url "/" list-posts) + (test-blog-url "/posts/hello-world" review-post "hello-world") + (test-blog-url "/archive/2008/2" review-archive 2008 02) + (test-blog-url/exn list-posts 50) + (test-blog-url/exn +) + (test-blog-url/exn review-post 50) + (test-blog-url/exn review-post "hello" "world") + (test-blog-url/exn review-archive 2008 02 1) + (test-blog-url/exn review-archive "2008" 02) + (test-blog-url/exn review-archive 2008 "02"))) (test-suite - "blog" + "dispatch" + (let () + (define-values (blog-dispatch blog-url) + (dispatch-rules + [("") list-posts] + [() list-posts] + [("posts" (string-arg)) review-post] + [("archive" (integer-arg) (integer-arg)) review-archive])) + (make-dispatch-test-suite blog-dispatch blog-url)) - (test-blog-dispatch "http://www.example.com" `(list-posts)) - (test-blog-dispatch "http://www.example.com/" `(list-posts)) - (test-blog-dispatch "http://www.example.com/posts/hello-world" `(review-post "hello-world")) - (test-blog-dispatch "http://www.example.com/archive/2008/02" `(review-archive 2008 02)) - (test-blog-dispatch/exn "http://www.example.com/posts") - (test-blog-dispatch/exn "http://www.example.com/archive/post/02") - (test-blog-dispatch/exn "http://www.example.com/archive/2008/post") - (test-blog-dispatch/exn "http://www.example.com/foo") - - (test-blog-url "/" list-posts) - (test-blog-url "/posts/hello-world" review-post "hello-world") - (test-blog-url "/archive/2008/2" review-archive 2008 02) - (test-blog-url/exn list-posts 50) - (test-blog-url/exn +) - (test-blog-url/exn review-post 50) - (test-blog-url/exn review-post "hello" "world") - (test-blog-url/exn review-archive 2008 02 1) - (test-blog-url/exn review-archive "2008" 02) - (test-blog-url/exn review-archive 2008 "02"))) + (let () + (define-container blog-container + (blog-dispatch blog-url)) + (dispatch-rules! blog-container + [("") list-posts]) + (dispatch-rules! blog-container + [() list-posts]) + (dispatch-rules! blog-container + [("posts" (string-arg)) review-post]) + (dispatch-rules! blog-container + [("archive" (integer-arg) (integer-arg)) review-archive]) + (make-dispatch-test-suite blog-dispatch blog-url)))) (local [(define (sum req as) (apply + as)) @@ -454,4 +475,4 @@ `(html (head (title "Sum")) (h1 ,(number->string (+ fst snd))))) - (serve/dispatch start)) + (serve/dispatch start)) \ No newline at end of file diff --git a/collects/tests/web-server/dispatchers/dispatch-servlets-test.rkt b/collects/tests/web-server/dispatchers/dispatch-servlets-test.rkt index d9a5b2e97a..b27aaa9092 100644 --- a/collects/tests/web-server/dispatchers/dispatch-servlets-test.rkt +++ b/collects/tests/web-server/dispatchers/dispatch-servlets-test.rkt @@ -54,6 +54,11 @@ [t0 (simple-xpath* '(p) (call d url0 empty))]) t0) "Hello, Web!") + (test-equal? "port.rkt" + (let* ([d (mkd (build-path example-servlets "port.rkt"))] + [t0 (simple-xpath* '(p) (call d url0 empty))]) + t0) + "Hello, Web!") (test-equal? "response.rktd - loading" (parameterize ([xexpr-drop-empty-attributes #t]) (let* ([d (mkd (build-path example-servlets "response.rktd"))]) @@ -69,6 +74,8 @@ (build-path example-servlets "add-ssd.rkt")) (test-add-two-numbers mkd "add-formlets.rkt - send/formlet" (build-path example-servlets "add-formlets.rkt")) + (test-add-two-numbers mkd "add-page.rkt" + (build-path example-servlets "add-page.rkt")) (test-equal? "count.rkt - state" (let* ([d (mkd (build-path example-servlets "count.rkt"))] [ext (lambda (c) diff --git a/collects/texpict/balloon.rkt b/collects/texpict/balloon.rkt index d099f4b7f3..efbd448328 100644 --- a/collects/texpict/balloon.rkt +++ b/collects/texpict/balloon.rkt @@ -1,7 +1,7 @@ (module balloon mzscheme (require "mrpict.ss" "utils.ss" - mred + racket/draw mzlib/class mzlib/etc mzlib/math) diff --git a/collects/texpict/code.rkt b/collects/texpict/code.rkt index 3db6931c05..43563488bb 100644 --- a/collects/texpict/code.rkt +++ b/collects/texpict/code.rkt @@ -4,7 +4,7 @@ mzlib/class mzlib/list (only scheme/list last) - mred + racket/draw mzlib/unit) (provide define-code code^ code-params^ code@) diff --git a/collects/texpict/doc.txt b/collects/texpict/doc.txt index afc95dbd2c..8d90e46fcf 100644 --- a/collects/texpict/doc.txt +++ b/collects/texpict/doc.txt @@ -67,7 +67,7 @@ GRacket (or PostScript) output The GRacket texpict function set is loaded by the _mrpict.ss_ library. The library is available in unit form via _mrpict-unit.ss_, which -exports a `mrpict@' unit that imports mred^ and exports +exports a `mrpict@' unit that imports draw^ and exports `texpict-common^' and `mrpict-extra^'. The _mrpict-sig.ss_ library file provides both signatures. diff --git a/collects/texpict/face.rkt b/collects/texpict/face.rkt index 328c2d3cbb..cad9bc968a 100644 --- a/collects/texpict/face.rkt +++ b/collects/texpict/face.rkt @@ -1,5 +1,5 @@ (module face mzscheme - (require mred + (require racket/draw texpict/mrpict texpict/utils mzlib/class diff --git a/collects/texpict/flash.rkt b/collects/texpict/flash.rkt index d86771d678..b58330f7b6 100644 --- a/collects/texpict/flash.rkt +++ b/collects/texpict/flash.rkt @@ -3,7 +3,7 @@ (require "mrpict.ss" mzlib/math mzlib/etc - mred + racket/draw mzlib/class) (provide filled-flash diff --git a/collects/texpict/mrpict-unit.rkt b/collects/texpict/mrpict-unit.rkt index 076bcebeda..135e832706 100644 --- a/collects/texpict/mrpict-unit.rkt +++ b/collects/texpict/mrpict-unit.rkt @@ -2,7 +2,7 @@ (module mrpict-unit mzscheme (require mzlib/unit) - (require mred/mred-sig) + (require racket/draw/draw-sig) (require "private/mrpict-sig.ss" "private/common-sig.ss" @@ -11,6 +11,6 @@ (provide mrpict@) (define-compound-unit/infer mrpict@ - (import mred^) + (import draw^) (export texpict-common^ mrpict-extra^) (link common@ mrpict-extra@))) diff --git a/collects/texpict/mrpict.rkt b/collects/texpict/mrpict.rkt index 6554bb087f..e39bcd73b1 100644 --- a/collects/texpict/mrpict.rkt +++ b/collects/texpict/mrpict.rkt @@ -3,10 +3,10 @@ (require mzlib/unit mzlib/contract mzlib/class - mred) + racket/draw) - (require mred/mred-sig - mred/mred-unit) + (require racket/draw/draw-sig + racket/draw/draw-unit) (require "private/mrpict-sig.ss" "private/common-sig.ss") (require "mrpict-sig.ss" @@ -15,7 +15,7 @@ (define-compound-unit/infer mrpict+mred@ (import) (export texpict-common^ mrpict-extra^) - (link standard-mred@ mrpict@)) + (link draw@ mrpict@)) (define-values/invoke-unit/infer mrpict+mred@) diff --git a/collects/texpict/private/common-sig.rkt b/collects/texpict/private/common-sig.rkt index ac0d1e52b7..ed1029b527 100644 --- a/collects/texpict/private/common-sig.rkt +++ b/collects/texpict/private/common-sig.rkt @@ -123,7 +123,8 @@ (provide texpict-common-setup^) (define-signature texpict-common-setup^ (connect - ~connect)) + ~connect + convert-pict)) (provide texpict-internal^) (define-signature texpict-internal^ diff --git a/collects/texpict/private/common-unit.rkt b/collects/texpict/private/common-unit.rkt index ddaa775245..66afc4c0ff 100644 --- a/collects/texpict/private/common-unit.rkt +++ b/collects/texpict/private/common-unit.rkt @@ -1,8 +1,9 @@ #lang racket/unit - (require racket/gui/base + (require racket/draw racket/class - racket/list) + racket/list + file/convertible) (require "common-sig.ss") @@ -20,7 +21,9 @@ children ; list of child records panbox ; panorama box, computed on demand last) ; a descendent for the bottom-right - #:mutable) + #:mutable + #:property prop:convertible (lambda (v mode default) + (convert-pict v mode default))) (define-struct child (pict dx dy sx sy)) (define-struct bbox (x1 y1 x2 y2 ay dy)) diff --git a/collects/texpict/private/mrpict-extra.rkt b/collects/texpict/private/mrpict-extra.rkt index c5195d0593..11b821d32f 100644 --- a/collects/texpict/private/mrpict-extra.rkt +++ b/collects/texpict/private/mrpict-extra.rkt @@ -4,12 +4,13 @@ (require mzlib/class mzlib/etc) - (require mred/mred-sig) + (require racket/draw/draw-sig + racket/gui/dynamic) (require "mrpict-sig.ss" "common-sig.ss") - (import mred^ + (import draw^ texpict-common^ texpict-internal^) (export mrpict-extra^ @@ -21,7 +22,7 @@ (define pict-drawer (make-pict-drawer the-pict)) (define no-redraw? #f) (define pict-frame% - (class frame% + (class (gui-dynamic-require 'frame%) (define/public (set-pict p) (set! the-pict p) (set! pict-drawer (make-pict-drawer the-pict)) @@ -34,7 +35,7 @@ (send c on-paint)) (super-instantiate ()))) (define pict-canvas% - (class canvas% + (class (gui-dynamic-require 'canvas%) (inherit get-dc) (define/override (on-paint) (unless no-redraw? @@ -441,3 +442,34 @@ (define (draw-pict p dc dx dy) ((make-pict-drawer p) dc dx dy)) + + + (define (convert-pict p format default) + (case format + [(png-bytes) + (let* ([bm (make-bitmap (max 1 (inexact->exact (ceiling (pict-width p)))) + (max 1 (inexact->exact (ceiling (pict-height p)))))] + [dc (make-object bitmap-dc% bm)]) + (send dc set-smoothing 'aligned) + (draw-pict p dc 0 0) + (send dc set-bitmap #f) + (let ([s (open-output-bytes)]) + (send bm save-file s 'png) + (get-output-bytes s)))] + [(eps-bytes pdf-bytes) + (let ([s (open-output-bytes)]) + (let ([dc (new (if (eq? format 'eps-bytes) post-script-dc% pdf-dc%) + [interactive #f] + [as-eps #t] + [width (pict-width p)] + [height (pict-height p)] + [output s])]) + (send dc start-doc "pict") + (send dc start-page) + (draw-pict p dc 0 0) + (send dc end-page) + (send dc end-doc)) + (get-output-bytes s))] + [else default])) + + diff --git a/collects/texpict/private/texpict-extra.rkt b/collects/texpict/private/texpict-extra.rkt index 30c427e952..1697f89853 100644 --- a/collects/texpict/private/texpict-extra.rkt +++ b/collects/texpict/private/texpict-extra.rkt @@ -466,3 +466,5 @@ [else (error 'pict->string "bad tag: ~s" tag)]))))) (define pict->commands pict->command-list) + + (define (convert-pict p v d) d) diff --git a/collects/texpict/utils.rkt b/collects/texpict/utils.rkt index 506549ef46..4fedf0d5f9 100644 --- a/collects/texpict/utils.rkt +++ b/collects/texpict/utils.rkt @@ -1,6 +1,11 @@ -#lang scheme/gui +#lang racket/base - (require "mrpict.ss") + (require racket/contract + racket/class + racket/draw + racket/math + racket/gui/dynamic + "mrpict.ss") ;; Utilities for use with mrpict @@ -886,8 +891,10 @@ (let ([bm (cond [(bitmap-draft-mode) #f] [(filename . is-a? . bitmap%) filename] - [(filename . is-a? . image-snip%) (send filename get-bitmap)] - [else (make-object bitmap% filename 'unknown/mask)])]) + [(path-string? filename) (make-object bitmap% filename 'unknown/mask)] + [(and (gui-available?) + (filename . is-a? . (gui-dynamic-require 'image-snip%))) + (send filename get-bitmap)])]) (if (and bm (send bm ok?)) (let ([w (send bm get-width)] [h (send bm get-height)]) diff --git a/collects/typed-scheme/info.rkt b/collects/typed-scheme/info.rkt index c18cc35e7b..30046e0591 100644 --- a/collects/typed-scheme/info.rkt +++ b/collects/typed-scheme/info.rkt @@ -1,4 +1,4 @@ #lang setup/infotab -(define scribblings '(("scribblings/ts-reference.scrbl" ()) - ("scribblings/ts-guide.scrbl" (multi-page)))) +(define scribblings '(("scribblings/ts-reference.scrbl" () (language -1)) + ("scribblings/ts-guide.scrbl" (multi-page) (language)))) diff --git a/collects/typed-scheme/private/base-env-indexing-abs.rkt b/collects/typed-scheme/private/base-env-indexing-abs.rkt index c99ba38fee..48150e6d11 100644 --- a/collects/typed-scheme/private/base-env-indexing-abs.rkt +++ b/collects/typed-scheme/private/base-env-indexing-abs.rkt @@ -173,9 +173,9 @@ [random (cl-> [(index-type) -Nat] [() -Real])] [raise-type-error - (cl-> - [(Sym -String Univ) (Un)] - [(Sym -String index-type (-lst Univ)) (Un)])] + (cl->* + [-> Sym -String Univ (Un)] + [->* (list Sym -String index-type) Univ (Un)])] )) diff --git a/collects/typed-scheme/private/base-env-numeric.rkt b/collects/typed-scheme/private/base-env-numeric.rkt index b6f30e81dd..045282ef9e 100644 --- a/collects/typed-scheme/private/base-env-numeric.rkt +++ b/collects/typed-scheme/private/base-env-numeric.rkt @@ -338,9 +338,12 @@ (-Nat -Nat . -> . (-values (list -Nat -Nat))) (-Integer -Integer . -> . (-values (list -Integer -Integer))))] -[arithmetic-shift (cl->* (-Fixnum (Un -NegativeFixnum (-val 0)) . -> . -Fixnum) - (-Nat -Nat . -> . -Nat) +[arithmetic-shift (cl->* ((-val 0) (Un -NegativeFixnum (-val 0)) . -> . (-val 0)) + (-NonnegativeFixnum (Un -NegativeFixnum (-val 0)) . -> . -NonnegativeFixnum) + (-Fixnum (Un -NegativeFixnum (-val 0)) . -> . -Fixnum) + (-Nat -Integer . -> . -Nat) (-Integer -Integer . -> . -Integer))] + [bitwise-and (cl->* (null -NonnegativeFixnum . ->* . -NonnegativeFixnum) ((list -Integer) -NonnegativeFixnum . ->* . -NonnegativeFixnum) (null -Fixnum . ->* . -Fixnum) @@ -365,6 +368,7 @@ (-Fixnum . -> . -NonnegativeFixnum) (-Pos . -> . -Pos) (-Integer . -> . -Nat) + (-ExactRational . -> . -ExactRational) (-Flonum . -> . -NonnegativeFlonum) (-InexactReal . -> . -InexactReal) (-Real . -> . -Real))] @@ -378,6 +382,9 @@ [inexact->exact (cl->* (-Real . -> . -ExactRational) (N . -> . N))] +[fl->exact-integer (cl->* + (-NonnegativeFlonum . -> . -Nat) + (-Flonum . -> . -Integer))] [floor rounder] [ceiling rounder] @@ -414,6 +421,12 @@ (-NonnegativeFlonum . -> . -NonnegativeFlonum) (-FloatComplex . -> . -FloatComplex) (N . -> . N))] +[integer-sqrt (cl->* + (-Zero . -> . -Zero) + (-NonnegativeFixnum . -> . -NonnegativeFixnum) + (-Nat . -> . -Nat) + (-NonnegativeFlonum . -> . -NonnegativeFlonum) + (-Real . -> . N))] [log (cl->* (-Pos . -> . -Real) (-FloatComplex . -> . -FloatComplex) @@ -434,7 +447,14 @@ ;; scheme/math -[sgn (-Real . -> . -Real)] +[sgn (cl->* (-Zero . -> . -Zero) + (-ExactPositiveInteger . -> . -PositiveFixnum) + (-ExactNonnegativeInteger . -> . -NonnegativeFixnum) + (-ExactRational . -> . -Fixnum) + (-Flonum . -> . -Flonum) + (-InexactReal . -> . -InexactReal) + (-Real . -> . -Real))] + [pi -NonnegativeFlonum] [sqr (cl->* (-> -Pos -Pos) (-> -Integer -Nat) diff --git a/collects/web-server/default-web-root/htdocs/servlets/examples/add-page.rkt b/collects/web-server/default-web-root/htdocs/servlets/examples/add-page.rkt new file mode 100644 index 0000000000..fdbdd340c3 --- /dev/null +++ b/collects/web-server/default-web-root/htdocs/servlets/examples/add-page.rkt @@ -0,0 +1,27 @@ +#lang racket/base +(require web-server/servlet + web-server/page) +(provide (all-defined-out)) +(define interface-version 'v1) +(define timeout +inf.0) + +(define (request-number which-number) + (let/ec esc + (page + `(html (head (title "Enter a Number to Add")) + (body ([bgcolor "white"]) + (form ([action ,(embed/url + (lambda/page () + (esc + (string->number + (get-binding 'number)))))] + [method "post"]) + "Enter the " ,which-number " number to add: " + (input ([type "text"] [name "number"] [value ""])) + (input ([type "submit"] [name "enter"] [value "Enter"])))))))) + +(define/page (start) + `(html (head (title "Sum")) + (body ([bgcolor "white"]) + (p "The answer is " + ,(number->string (+ (request-number "first") (request-number "second"))))))) diff --git a/collects/web-server/default-web-root/htdocs/servlets/examples/port.rkt b/collects/web-server/default-web-root/htdocs/servlets/examples/port.rkt new file mode 100644 index 0000000000..21955dc509 --- /dev/null +++ b/collects/web-server/default-web-root/htdocs/servlets/examples/port.rkt @@ -0,0 +1,15 @@ +#lang racket/base +(require web-server/servlet + racket/list) +(provide (all-defined-out)) +(define interface-version 'v1) +(define timeout +inf.0) + +(define (start initial-request) + (response/port + 200 #"Okay" (current-seconds) #"text/html" empty + (λ (op) + (display #<

Hello, Web!

+END + op)))) \ No newline at end of file diff --git a/collects/web-server/dispatch.rkt b/collects/web-server/dispatch.rkt index 0ac1eb1000..6abdf49184 100644 --- a/collects/web-server/dispatch.rkt +++ b/collects/web-server/dispatch.rkt @@ -1,7 +1,9 @@ #lang racket (require web-server/dispatch/syntax web-server/dispatch/serve - web-server/dispatch/url-patterns) + web-server/dispatch/url-patterns + web-server/dispatch/container) (provide (all-from-out web-server/dispatch/syntax web-server/dispatch/serve - web-server/dispatch/url-patterns)) + web-server/dispatch/url-patterns + web-server/dispatch/container)) diff --git a/collects/web-server/dispatch/container.rkt b/collects/web-server/dispatch/container.rkt new file mode 100644 index 0000000000..2aa453760e --- /dev/null +++ b/collects/web-server/dispatch/container.rkt @@ -0,0 +1,56 @@ +#lang racket/base +(require web-server/dispatchers/dispatch + racket/list + racket/contract + racket/match + "syntax.rkt") + +(struct container (bunches) #:mutable) +(struct bunch (dispatch url)) + +(define (container-dispatch c) + (λ (req) + (let/ec esc + (for ([d*u (in-list (container-bunches c))]) + (with-handlers ([exn:dispatcher? void]) + (esc ((bunch-dispatch d*u) req)))) + (next-dispatcher)))) + +(define (container-url c) + (λ args + (let/ec esc + (for ([d*u (in-list (container-bunches c))]) + (with-handlers ([exn:misc:match? void]) + (esc (apply (bunch-url d*u) args)))) + (match args)))) + +(define-syntax-rule (define-container container-id (container-dispatch-id container-url-id)) + (begin + (define container-id + (container empty)) + (define container-dispatch-id + (container-dispatch container-id)) + (define container-url-id + (container-url container-id)))) + +(define (container-cons! c d u) + (set-container-bunches! + c + (cons (bunch d u) (container-bunches c)))) + +#;(define (snoc l x) (append l (list x))) +#;(define (container-snoc! c d u) + (set-container-bunches! + c + (snoc (container-bunches c) (bunch d u)))) + +(define-syntax-rule (dispatch-rules! container-expr [pat fun] ...) + (let-values ([(dispatch url) (dispatch-rules [pat fun] ...)]) + (container-cons! container-expr + dispatch url))) + +(provide + define-container + dispatch-rules!) +(provide/contract + [container? (any/c . -> . boolean?)]) diff --git a/collects/web-server/http/response-structs.rkt b/collects/web-server/http/response-structs.rkt index 3f9da98183..84f71e26eb 100644 --- a/collects/web-server/http/response-structs.rkt +++ b/collects/web-server/http/response-structs.rkt @@ -9,6 +9,7 @@ (define-struct response/basic (code message seconds mime headers)) (define-struct (response/full response/basic) (body)) (define-struct (response/incremental response/basic) (generator)) +(define-struct (response/port response/basic) (output)) (define response/c (or/c response/basic? @@ -30,6 +31,8 @@ (list* (make-header #"Content-Length" (string->bytes/utf-8 (number->string (response/full->size resp)))) (response/basic-headers resp)) (response/full-body resp))] + [(response/port? resp) + resp] [(response/incremental? resp) (if close? resp @@ -104,10 +107,17 @@ [mime bytes?] [headers (listof header?)] [generator ((() () #:rest (listof bytes?) . ->* . any) . -> . any)])] + [struct (response/port response/basic) + ([code number?] + [message bytes?] + [seconds number?] + [mime bytes?] + [headers (listof header?)] + [output (output-port? . -> . void)])] [response/c contract?] [make-xexpr-response ((pretty-xexpr/c) (#:code number? #:message bytes? #:seconds number? #:mime-type bytes? #:headers (listof header?) #:preamble bytes?) . ->* . response/full?)] - [normalize-response ((response/c) (boolean?) . ->* . (or/c response/full? response/incremental?))] + [normalize-response ((response/c) (boolean?) . ->* . (or/c response/full? response/incremental? response/port?))] [TEXT/HTML-MIME-TYPE bytes?]) diff --git a/collects/web-server/http/response.rkt b/collects/web-server/http/response.rkt index 44e16faf20..51ee1eea14 100644 --- a/collects/web-server/http/response.rkt +++ b/collects/web-server/http/response.rkt @@ -103,6 +103,8 @@ (for-each (lambda (str) (display str o-port)) (response/full-body bresp))] + [(? response/port?) + ((response/port-output bresp) o-port)] [(? response/incremental?) (if (connection-close? conn) ((response/incremental-generator bresp) @@ -125,9 +127,7 @@ ; format is rfc1123 compliant according to rfc2068 (http/1.1) (define (seconds->gmt-string s) (let* ([local-date (seconds->date s)] - [date (seconds->date (- s - (date-time-zone-offset local-date) - (if (date-dst? local-date) 3600 0)))]) + [date (seconds->date (- s (date-time-zone-offset local-date)))]) (format "~a, ~a ~a ~a ~a:~a:~a GMT" (vector-ref DAYS (date-week-day date)) (two-digits (date-day date)) diff --git a/collects/web-server/page.rkt b/collects/web-server/page.rkt new file mode 100644 index 0000000000..c6829d25cf --- /dev/null +++ b/collects/web-server/page.rkt @@ -0,0 +1,3 @@ +#lang racket/base +(require "page/page.rkt") +(provide (all-from-out "page/page.rkt")) \ No newline at end of file diff --git a/collects/web-server/page/page.rkt b/collects/web-server/page/page.rkt new file mode 100644 index 0000000000..25319de91f --- /dev/null +++ b/collects/web-server/page/page.rkt @@ -0,0 +1,81 @@ +#lang racket/base +(require web-server/servlet + racket/stxparam + racket/list + racket/contract + (for-syntax racket/base)) + +(define-syntax-parameter embed/url + (λ (stx) (raise-syntax-error stx 'embed/url "Used outside page"))) + +(define-syntax-rule (page e ...) + (send/suspend/dispatch + (λ (this-embed/url) + (syntax-parameterize ([embed/url (make-rename-transformer #'this-embed/url)]) + e ...)))) + +(define current-request (make-parameter #f)) + +(define-syntax-rule (lambda/page formals e ...) + (lambda (req . formals) + (parameterize ([current-request req]) + (page e ...)))) + +(define-syntax-rule (define/page (id . formals) e ...) + (define id + (lambda/page formals e ...))) + +(define binding-id/c (or/c bytes? string? symbol?)) +(define (binding-id->bytes id) + (cond [(bytes? id) + id] + [(string? id) + (string->bytes/utf-8 id)] + [(symbol? id) + (binding-id->bytes (symbol->string id))])) + +(define binding-format/c (symbols 'string 'bytes 'file 'binding)) +(define (convert-binding format b) + (case format + [(string) + (and (binding:form? b) + (with-handlers ([exn:fail? (λ (x) #f)]) + (bytes->string/utf-8 (binding:form-value b))))] + [(bytes) + (and (binding:form? b) + (binding:form-value b))] + [(file) + (and (binding:file? b) + (binding:file-content b))] + [(binding) + b])) + +(define (get-binding id [req (current-request)] + #:format [format 'string]) + (convert-binding + format + (bindings-assq + (binding-id->bytes id) + (request-bindings/raw req)))) + +(define (get-bindings id [req (current-request)] + #:format [format 'string]) + (define id-bs (binding-id->bytes id)) + (filter-map + (λ (b) + (and (bytes=? id-bs (binding-id b)) + (convert-binding format b))) + (request-bindings/raw req))) + +(provide embed/url + page + lambda/page + define/page) +(provide/contract + [current-request (parameter/c (or/c false/c request?))] + [binding-id/c contract?] + [binding-format/c contract?] + [get-binding (->* (binding-id/c) (request? #:format binding-format/c) + (or/c false/c string? bytes? binding?))] + [get-bindings (->* (binding-id/c) (request? #:format binding-format/c) + (listof (or/c string? bytes? binding?)))]) \ No newline at end of file diff --git a/collects/web-server/scribblings/dispatch.scrbl b/collects/web-server/scribblings/dispatch.scrbl index 35693a281c..ca2cdc3dca 100644 --- a/collects/web-server/scribblings/dispatch.scrbl +++ b/collects/web-server/scribblings/dispatch.scrbl @@ -165,6 +165,18 @@ After mastering the world of blogging software, you decide to put the ubiquitous Calls @racket[serve/servlet] with a @racket[#:servlet-regexp] argument (@racket[#rx""]) so that every request is handled by @racket[dispatch]. } +@section{Imperative Dispatch Containers} + +@racket[dispatch-rules] is purely functional. This presents a more declarative interface, but inhibits some programming and modularity patterns. @deftech{Containers} provide an imperative overlay atop @racket[dispatch-rules]. + +@defproc[(container? [x any/c]) boolean?]{ Identifies @tech{containers}. } + +@defform[(define-container container-id (dispatch-id url-id))]{ + Defines @racket[container-id] as a container as well as @racket[dispatch-id] as its dispatching function and @racket[url-id] as its URL lookup function.} + +@defform[(dispatch-rules! container-expr [dispatch-pattern dispatch-fun] ...)]{ + Like @racket[dispatch-rules], but imperatively adds the patterns to the container specified by @racket[container-expr]. The new rules are consulted @emph{before} any rules already in the container. } + @section{Built-in URL patterns} @racketmodname[web-server/dispatch] builds in a few useful URL component patterns. diff --git a/collects/web-server/scribblings/http.scrbl b/collects/web-server/scribblings/http.scrbl index 1233240086..00304bbdf4 100644 --- a/collects/web-server/scribblings/http.scrbl +++ b/collects/web-server/scribblings/http.scrbl @@ -199,6 +199,28 @@ Here is an example typical of what you will find in many applications: #"

")) ] } + +@defstruct[(response/port response/basic) + ([output (output-port? . -> . void)])]{ + As with @racket[response/basic], except where @racket[output] generates the response + body. This response type is not as safe and efficient for clients as @racket[response/incremental], + but can be convenient on the server side. + + Example: + @racketblock[ + (make-response/full + 301 #"Moved Permanently" + (current-seconds) TEXT/HTML-MIME-TYPE + (list (make-header #"Location" + #"http://racket-lang.org/downloads")) + (λ (op) + (write-bytes #"

" op) + (write-bytes #"Please go to here instead." op) + (write-bytes #"

" op))) + ] +} @defstruct[(response/incremental response/basic) ([generator ((() () #:rest (listof bytes?) . ->* . any) . -> . any)])]{ @@ -248,7 +270,7 @@ Here is an example typical of what you will find in many applications: ]} @defproc[(normalize-response [response response/c] [close? boolean? #f]) - (or/c response/full? response/incremental?)]{ + (or/c response/full? response/incremental? response/port?)]{ Coerces @racket[response] into a full response, filling in additional details where appropriate. @racket[close?] represents whether the connection will be closed after the response is sent (i.e. if HTTP 1.0 is being used.) The accuracy of this only matters if diff --git a/collects/web-server/scribblings/page.scrbl b/collects/web-server/scribblings/page.scrbl new file mode 100644 index 0000000000..89df9bd592 --- /dev/null +++ b/collects/web-server/scribblings/page.scrbl @@ -0,0 +1,70 @@ +#lang scribble/doc +@(require "web-server.rkt") +@(require (for-label web-server/servlet + web-server/page + racket/promise + racket/list + xml)) + +@title[#:tag "page"]{Page: Short-hand for Common Patterns} + +@defmodule[web-server/page] + +The @web-server provides a simple utility library for building Web applications that consistent mostly of @racket[send/suspend/dispatch]-created pages and request handling. + +Most Web applications rely heavily on @racket[send/suspend/dispatch] and typically use the pattern: +@racketblock[ + (send/suspend/dispatch + (λ (my-embed/url) + .... (my-embed/url other-page) ....))] + +@defform[(page e ...)]{ + +The @racket[page] macro automates this by expanding @racket[(page e ...)] to a usage of @racket[send/suspend/dispatch] where the syntax parameter @racket[embed/url] is bound to the argument of @racket[send/suspend/dispatch]. + +} + +@defidform[embed/url]{ +When used inside @racket[page] syntactically, a rename transformer for the procedure embedding function; otherwise, a syntax error.} + +A simple example: +@racketblock[ + (page + `(html + (body + (a ([href + ,(embed/url + (λ (req) + "You clicked!"))]) + "Click me"))))] + +Similarly, many Web applications make use almost exclusively of functions that are arguments to @racket[embed/url] and immediately invoke @racket[send/suspend/dispatch]. + +@deftogether[[@defform[(lambda/page formals e ...)] + @defform[(define/page (id . formals) e ...)]]]{ +The @racket[lambda/page] and @racket[define/page] automate this by expanding to functions that accept a request as the first argument (followed by any arguments specified in @racket[formals]) and immediately wrap their body in @racket[page]. This functions also cooperate with @racket[get-binding] by binding the request to the @racket[current-request] parameter. +} + +The binding interface of @racketmodname[web-server/http] is powerful, but subtle to use conveniently due to its protection against hostile clients. + +@deftogether[[ +@defparam[current-request req request?] +@defthing[binding-id/c contract?] +@defthing[binding-format/c contract?] +@defproc[(get-binding [id binding-id/c] [req request? (current-request)] [#:format format binding-format/c 'string]) + (or/c false/c string? bytes? binding?)] +@defproc[(get-bindings [id binding-id/c] [req request? (current-request)] [#:format format binding-format/c 'string]) + (listof (or/c string? bytes? binding?))] +]]{ + + The @racket[get-binding](s) interface attempts to resolve this by providing a powerful interface with convenient defaults. + + @racket[get-binding] extracts the first binding of a form input from a request, while @racket[get-bindings] extracts them all. + + They accept a form identifier (@racket[id]) as either a byte string, a string, or a symbol. In each case, the user input is compared in a case-sensitive way with the form input. + + They accept an optional request argument (@racket[req]) that defaults to the value of the @racket[current-request] parameter used by @racket[lambda/page] and @racket[define/page]. + + Finally, they accept an optional keyword argument (@racket[format]) that specifies the desired return format. The default, @racket['string], produces a UTF-8 string (or @racket[#f] if the byte string cannot be converted to UTF-8.) The @racket['bytes] format always produces the raw byte string. The @racket['file] format produces the file upload content (or @racket[#f] if the form input was not an uploaded file.) The @racket['binding] format produces the binding object. + +} diff --git a/collects/web-server/scribblings/servlet-env.scrbl b/collects/web-server/scribblings/servlet-env.scrbl index c231a4b7ce..65c202efbd 100644 --- a/collects/web-server/scribblings/servlet-env.scrbl +++ b/collects/web-server/scribblings/servlet-env.scrbl @@ -169,7 +169,7 @@ Like always, you don't even need to save the file. @racket[start] is loaded as a servlet and responds to requests that match @racket[servlet-regexp]. The current directory of servlet execution is @racket[servlet-current-directory]. - If @racket[launch-browser?] is true, then a web browser is opened to @filepath{http://localhost:}. + If @racket[launch-browser?] is true, then a web browser is opened to @filepath{http://localhost:}. @racket[servlet-path] has no other purpose, if @racket[servlet-regexp] is provided. If @racket[quit?] is true, then the URL @filepath["/quit"] ends the server. diff --git a/collects/web-server/scribblings/web-server.scrbl b/collects/web-server/scribblings/web-server.scrbl index abbb140488..cdac7e0fdf 100644 --- a/collects/web-server/scribblings/web-server.scrbl +++ b/collects/web-server/scribblings/web-server.scrbl @@ -16,8 +16,7 @@ This manual describes the Racket libraries for building Web applications. The @secref["http"] section describes the common library function for manipulating HTTP requests and creating HTTP responses. In particular, this section covers cookies, authentication, and request bindings. -The final three sections (@secref["dispatch"], @secref["formlets"], and @secref["templates"]) cover utility libraries that -ease the creation of typical Web applications. +The final four sections (@secref["dispatch"], @secref["formlets"], @secref["templates"], and @secref["page"]) cover utility libraries that ease the creation of typical Web applications. This manual closes with a frequently asked questions section: @secref["faq"]. @@ -33,6 +32,7 @@ This manual closes with a frequently asked questions section: @secref["faq"]. @include-section["dispatch.scrbl"] @include-section["formlets.scrbl"] @include-section["templates.scrbl"] +@include-section["page.scrbl"] @include-section["faq.scrbl"] diff --git a/doc/release-notes/racket/Draw_and_GUI_5_1.txt b/doc/release-notes/racket/Draw_and_GUI_5_1.txt index ddc76d856f..8e3b7069a2 100644 --- a/doc/release-notes/racket/Draw_and_GUI_5_1.txt +++ b/doc/release-notes/racket/Draw_and_GUI_5_1.txt @@ -42,7 +42,9 @@ alphas; for example, drawing a line in the middle of an empty bitmap produces an image with non-zero alpha only at the drawn line. Only bitmaps created with the new `make-gl-bitmap' function support -OpenGL drawing. +OpenGL drawing. The `make-gl-bitmap' function takes a `gl-config%' as +an argument, and the `get-gl-config' and `set-gl-config' methods of +`bitmap%' have been removed. Use the new `make-bitmap', `read-bitmap', `make-monochrome-bitmap', `make-screen-bitmap', and `make-gl-bitmap' functions to create @@ -93,6 +95,17 @@ backward-compatibile. Methods like `get-translation', `set-translation', `scale', etc. help hide the reundancy. +PostScript and PDF Drawing Contexts +----------------------------------- + +The dimensions for PostScript output are no longer inferred from the +drawing. Instead, the width and height must be supplied when the +`post-script-dc%' is created. + +The new `pdf-dc%' drawing context is like `post-script-dc%', but it +generates PDF output. + + Other Drawing-Context Changes ----------------------------- diff --git a/doc/release-notes/racket/HISTORY.txt b/doc/release-notes/racket/HISTORY.txt index 5cfa781544..601642c636 100644 --- a/doc/release-notes/racket/HISTORY.txt +++ b/doc/release-notes/racket/HISTORY.txt @@ -1,5 +1,6 @@ 5.0.99.2 proxy => impersonator +equal? equates C pointers when they refer to the same address 5.0.99.1 Internal: weak boxes are cleared before non-will-like diff --git a/src/foreign/foreign.c b/src/foreign/foreign.c index 5d7f2f8691..52c45023f2 100644 --- a/src/foreign/foreign.c +++ b/src/foreign/foreign.c @@ -713,7 +713,7 @@ Scheme_Object *utf16_pointer_to_ucs4_string(unsigned short *utf) #define FOREIGN_string_ucs_4 (18) /* Type Name: string/ucs-4 (string_ucs_4) - * LibFfi type: ffi_type_pointer + * LibFfi type: ffi_type_gcpointer * C type: mzchar* * Predicate: SCHEME_FALSEP_OR_CHAR_STRINGP() * Scheme->C: ucs4_string_or_null_to_ucs4_pointer() @@ -723,7 +723,7 @@ Scheme_Object *utf16_pointer_to_ucs4_string(unsigned short *utf) #define FOREIGN_string_utf_16 (19) /* Type Name: string/utf-16 (string_utf_16) - * LibFfi type: ffi_type_pointer + * LibFfi type: ffi_type_gcpointer * C type: unsigned short* * Predicate: SCHEME_FALSEP_OR_CHAR_STRINGP() * Scheme->C: ucs4_string_or_null_to_utf16_pointer() @@ -736,7 +736,7 @@ Scheme_Object *utf16_pointer_to_ucs4_string(unsigned short *utf) #define FOREIGN_bytes (20) /* Type Name: bytes - * LibFfi type: ffi_type_pointer + * LibFfi type: ffi_type_gcpointer * C type: char* * Predicate: SCHEME_FALSEP()||SCHEME_BYTE_STRINGP() * Scheme->C: SCHEME_FALSEP()?NULL:SCHEME_BYTE_STR_VAL() @@ -746,7 +746,7 @@ Scheme_Object *utf16_pointer_to_ucs4_string(unsigned short *utf) #define FOREIGN_path (21) /* Type Name: path - * LibFfi type: ffi_type_pointer + * LibFfi type: ffi_type_gcpointer * C type: char* * Predicate: SCHEME_FALSEP()||SCHEME_PATH_STRINGP() * Scheme->C: SCHEME_FALSEP()?NULL:SCHEME_PATH_VAL(TO_PATH()) @@ -843,6 +843,11 @@ typedef union _ForeignAny { /* This is a tag that is used to identify user-made struct types. */ #define FOREIGN_struct (27) +static int is_gcable_pointer(Scheme_Object *o) { + return !SCHEME_CPTRP(o) + || !(SCHEME_CPTR_FLAGS(o) & 0x1); +} + /*****************************************************************************/ /* Type objects */ @@ -1182,10 +1187,10 @@ END_XFORM_SKIP; #endif /* The sync field: - NULL => non-atomic mode, no sync proc + NULL => non-atomic mode #t => atomic mode, no sync proc - (rcons queue proc) => non-atomic mode, sync proc - (box (rcons queue proc)) => atomic mode, sync proc */ + proc => non-atomic mode, sync proc + (box proc) => atomic mode, sync proc */ /*****************************************************************************/ /* Pointer objects */ @@ -1207,7 +1212,7 @@ END_XFORM_SKIP; W_OFFSET(SCHEME_FFIANYPTR_VAL(x), SCHEME_FFIANYPTR_OFFSET(x)) #define SCHEME_CPOINTER_W_OFFSET_P(x) \ - SAME_TYPE(SCHEME_TYPE(x), scheme_offset_cpointer_type) + (SCHEME_CPTRP(x) && SCHEME_CPTR_HAS_OFFSET(x)) #define scheme_make_foreign_cpointer(x) \ ((x==NULL)?scheme_false:scheme_make_cptr(x,NULL)) @@ -1218,6 +1223,9 @@ END_XFORM_SKIP; #define scheme_make_foreign_external_cpointer(x) \ ((x==NULL)?scheme_false:scheme_make_external_cptr(x,NULL)) +#define scheme_make_foreign_offset_external_cpointer(x, delta) \ + ((delta == 0) ? scheme_make_foreign_external_cpointer(x) : scheme_make_offset_external_cptr(x,delta,NULL)) + #define MYNAME "cpointer?" static Scheme_Object *foreign_cpointer_p(int argc, Scheme_Object *argv[]) { @@ -1258,23 +1266,23 @@ void *scheme_extract_pointer(Scheme_Object *v) { * memory location -- deal with it via a C2SCHEME macro wrapper that is used * for both the function definition and calls */ #ifdef SCHEME_BIG_ENDIAN -#define C2SCHEME(typ,src,delta,argsloc) c_to_scheme(typ,src,delta,argsloc) +#define C2SCHEME(typ,src,delta,argsloc,gcsrc) c_to_scheme(typ,src,delta,argsloc,gcsrc) #define REF_CTYPE(ctype) (((sizeof(ctype)Scheme", "C-type", 0, 1, &type); if (CTYPE_USERP(type)) { - res = C2SCHEME(CTYPE_BASETYPE(type), src, delta, args_loc); + res = C2SCHEME(CTYPE_BASETYPE(type), src, delta, args_loc, gcsrc); if (SCHEME_FALSEP(CTYPE_USER_C2S(type))) return res; else @@ -1309,7 +1317,10 @@ static Scheme_Object *C2SCHEME(Scheme_Object *type, void *src, case FOREIGN_scheme: return REF_CTYPE(Scheme_Object*); case FOREIGN_fpointer: return (REF_CTYPE(void*)); case FOREIGN_struct: - return scheme_make_foreign_offset_cpointer(src, delta); + if (gcsrc) + return scheme_make_foreign_offset_cpointer(src, delta); + else + return scheme_make_foreign_offset_external_cpointer(src, delta); default: scheme_signal_error("corrupt foreign type: %V", type); } return NULL; /* hush the compiler */ @@ -1556,7 +1567,7 @@ static void* SCHEME2C(Scheme_Object *type, void *dst, long delta, if (SCHEME_FALSEP_OR_CHAR_STRINGP(val)) { mzchar* tmp; tmp = (mzchar*)(ucs4_string_or_null_to_ucs4_pointer(val)); - if (basetype_p == NULL || tmp == NULL) { + if (basetype_p == NULL || tmp == NULL || 0) { (((mzchar**)W_OFFSET(dst,delta))[0]) = tmp; return NULL; } else { @@ -1577,7 +1588,7 @@ static void* SCHEME2C(Scheme_Object *type, void *dst, long delta, if (SCHEME_FALSEP_OR_CHAR_STRINGP(val)) { unsigned short* tmp; tmp = (unsigned short*)(ucs4_string_or_null_to_utf16_pointer(val)); - if (basetype_p == NULL || tmp == NULL) { + if (basetype_p == NULL || tmp == NULL || 0) { (((unsigned short**)W_OFFSET(dst,delta))[0]) = tmp; return NULL; } else { @@ -1598,7 +1609,7 @@ static void* SCHEME2C(Scheme_Object *type, void *dst, long delta, if (SCHEME_FALSEP(val)||SCHEME_BYTE_STRINGP(val)) { char* tmp; tmp = (char*)(SCHEME_FALSEP(val)?NULL:SCHEME_BYTE_STR_VAL(val)); - if (basetype_p == NULL || tmp == NULL) { + if (basetype_p == NULL || tmp == NULL || 0) { (((char**)W_OFFSET(dst,delta))[0]) = tmp; return NULL; } else { @@ -1619,7 +1630,7 @@ static void* SCHEME2C(Scheme_Object *type, void *dst, long delta, if (SCHEME_FALSEP(val)||SCHEME_PATH_STRINGP(val)) { char* tmp; tmp = (char*)(SCHEME_FALSEP(val)?NULL:SCHEME_PATH_VAL(TO_PATH(val))); - if (basetype_p == NULL || tmp == NULL) { + if (basetype_p == NULL || tmp == NULL || 0) { (((char**)W_OFFSET(dst,delta))[0]) = tmp; return NULL; } else { @@ -1640,7 +1651,7 @@ static void* SCHEME2C(Scheme_Object *type, void *dst, long delta, if (SCHEME_SYMBOLP(val)) { char* tmp; tmp = (char*)(SCHEME_SYM_VAL(val)); - if (basetype_p == NULL || tmp == NULL) { + if (basetype_p == NULL || tmp == NULL || !is_gcable_pointer(val)) { (((char**)W_OFFSET(dst,delta))[0]) = tmp; return NULL; } else { @@ -1663,7 +1674,7 @@ static void* SCHEME2C(Scheme_Object *type, void *dst, long delta, tmp = (void*)(SCHEME_FFIANYPTR_VAL(val)); toff = SCHEME_FFIANYPTR_OFFSET(val); if (_offset) *_offset = toff; - if (basetype_p == NULL || (tmp == NULL && toff == 0)) { + if (basetype_p == NULL || (tmp == NULL && toff == 0) || !is_gcable_pointer(val)) { (((void**)W_OFFSET(dst,delta))[0]) = (_offset ? tmp : (void*)W_OFFSET(tmp, toff)); return NULL; } else { @@ -1686,7 +1697,7 @@ static void* SCHEME2C(Scheme_Object *type, void *dst, long delta, tmp = (void*)(SCHEME_FFIANYPTR_VAL(val)); toff = SCHEME_FFIANYPTR_OFFSET(val); if (_offset) *_offset = toff; - if (basetype_p == NULL || (tmp == NULL && toff == 0)) { + if (basetype_p == NULL || (tmp == NULL && toff == 0) || 0) { (((void**)W_OFFSET(dst,delta))[0]) = (_offset ? tmp : (void*)W_OFFSET(tmp, toff)); return NULL; } else { @@ -1707,7 +1718,7 @@ static void* SCHEME2C(Scheme_Object *type, void *dst, long delta, if (1) { Scheme_Object* tmp; tmp = (Scheme_Object*)(val); - if (basetype_p == NULL || tmp == NULL) { + if (basetype_p == NULL || tmp == NULL || 0) { (((Scheme_Object**)W_OFFSET(dst,delta))[0]) = tmp; return NULL; } else { @@ -2274,12 +2285,14 @@ static Scheme_Object *abs_sym; static Scheme_Object *foreign_ptr_ref(int argc, Scheme_Object *argv[]) { int size=0; void *ptr; Scheme_Object *base; - long delta; + long delta; int gcsrc=1; if (!SCHEME_FFIANYPTRP(argv[0])) scheme_wrong_type(MYNAME, "cpointer", 0, argc, argv); ptr = SCHEME_FFIANYPTR_VAL(argv[0]); delta = SCHEME_FFIANYPTR_OFFSET(argv[0]); + if (!is_gcable_pointer(argv[0])) + gcsrc = 0; if ((ptr == NULL) && (delta == 0)) scheme_wrong_type(MYNAME, "non-null-cpointer", 0, argc, argv); if (NULL == (base = get_ctype_base(argv[1]))) @@ -2314,7 +2327,7 @@ static Scheme_Object *foreign_ptr_ref(int argc, Scheme_Object *argv[]) scheme_signal_error(MYNAME": cannot multiply fpointer type by offset"); delta += (size * SCHEME_INT_VAL(argv[2])); } - return C2SCHEME(argv[1], ptr, delta, 0); + return C2SCHEME(argv[1], ptr, delta, 0, gcsrc); } #undef MYNAME @@ -2541,6 +2554,9 @@ Scheme_Object *ffi_do_call(void *data, int argc, Scheme_Object *argv[]) /* ... set the ivals pointer (pointer type doesn't matter) and avalues */ ivals[i].x_pointer = avalues[i]; avalues[i] = &(ivals[i]); + } else if (offsets[i]) { + /* struct argument has an offset */ + avalues[i] = (char *)avalues[i] + offsets[i]; } /* Otherwise it was a struct pointer, and avalues[i] is already fine. */ /* Add offset, if any: */ @@ -2569,7 +2585,7 @@ Scheme_Object *ffi_do_call(void *data, int argc, Scheme_Object *argv[]) } break; } - return C2SCHEME(otype, p, 0, 1); + return C2SCHEME(otype, p, 0, 1, 1); } /* see below */ @@ -2693,15 +2709,15 @@ void ffi_do_callback(ffi_cif* cif, void* resultp, void** args, void *userdata) argv = argv_stack; else argv = scheme_malloc(argc * sizeof(Scheme_Object*)); - if (data->sync && !SCHEME_RPAIRP(data->sync)) + if (data->sync && !SCHEME_PROCP(data->sync)) scheme_start_in_scheduler(); for (i=0, p=data->itypes; iproc, argc, argv); SCHEME2C(data->otype, resultp, 0, p, NULL, NULL, 1); - if (data->sync && !SCHEME_RPAIRP(data->sync)) + if (data->sync && !SCHEME_PROCP(data->sync)) scheme_end_in_scheduler(); } @@ -2770,7 +2786,6 @@ void scheme_check_foreign_work(void) proc = data->sync; if (SCHEME_BOXP(proc)) proc = SCHEME_BOX_VAL(proc); - proc = SCHEME_CDR(proc); scheme_start_in_scheduler(); _scheme_apply(proc, 1, a); @@ -2786,49 +2801,44 @@ void scheme_check_foreign_work(void) void ffi_queue_callback(ffi_cif* cif, void* resultp, void** args, void *userdata) XFORM_SKIP_PROC { - ffi_callback_struct *data; - - data = extract_ffi_callback(userdata); - #ifdef MZ_USE_MZRT - { - FFI_Sync_Queue *queue; - Scheme_Object *o; + /* This function must not refer to any GCable address, not even + temporarily, because a GC may occur concurrent to this + function if it's in another thread. */ + FFI_Sync_Queue *queue; - o = data->sync; - if (SCHEME_BOXP(o)) o = SCHEME_BOX_VAL(o); + queue = (FFI_Sync_Queue *)((void **)userdata)[1]; + userdata = ((void **)userdata)[0]; - queue = (FFI_Sync_Queue *)SCHEME_CAR(o); + if (queue->orig_thread != mz_proc_thread_self()) { + Queued_Callback *qc; + mzrt_sema *sema; - if (queue->orig_thread != mz_proc_thread_self()) { - Queued_Callback *qc; - mzrt_sema *sema; + mzrt_sema_create(&sema, 0); - mzrt_sema_create(&sema, 0); + qc = (Queued_Callback *)malloc(sizeof(Queued_Callback)); + qc->cif = cif; + qc->resultp = resultp; + qc->args = args; + qc->userdata = userdata; + qc->sema = sema; + qc->called = 0; - qc = (Queued_Callback *)malloc(sizeof(Queued_Callback)); - qc->cif = cif; - qc->resultp = resultp; - qc->args = args; - qc->userdata = userdata; - qc->sema = sema; - qc->called = 0; + mzrt_mutex_lock(queue->lock); + qc->next = queue->callbacks; + queue->callbacks = qc; + mzrt_mutex_unlock(queue->lock); + scheme_signal_received_at(queue->sig_hand); - mzrt_mutex_lock(queue->lock); - qc->next = queue->callbacks; - queue->callbacks = qc; - mzrt_mutex_unlock(queue->lock); - scheme_signal_received_at(queue->sig_hand); + /* wait for the callback to be invoked in the main thread */ + mzrt_sema_wait(sema); - /* wait for the callback to be invoked in the main thread */ - mzrt_sema_wait(sema); - - mzrt_sema_destroy(sema); - free(qc); - return; - } + mzrt_sema_destroy(sema); + free(qc); + return; } #endif + ffi_do_callback(cif, resultp, args, userdata); } @@ -2842,6 +2852,7 @@ typedef struct closure_and_cif_struct { void *data; #endif } closure_and_cif; + /* free the above */ void free_cl_cif_args(void *ignored, void *p) { @@ -2857,6 +2868,20 @@ void free_cl_cif_args(void *ignored, void *p) scheme_free_code(p); } +#ifdef MZ_USE_MZRT +void free_cl_cif_queue_args(void *ignored, void *p) +{ + void *data = ((closure_and_cif*)p)->data; + void **q = (void **)data; + data = q[0]; + free(q); +#ifdef MZ_PRECISE_GC + GC_free_immobile_box((void**)data); +#endif + scheme_free_code(p); +} +#endif + /* (ffi-callback scheme-proc in-types out-type [abi atomic? sync]) -> ffi-callback */ /* the treatment of in-types and out-types is similar to that in ffi-call */ /* the real work is done by ffi_do_callback above */ @@ -2905,6 +2930,11 @@ static Scheme_Object *foreign_ffi_callback(int argc, Scheme_Object *argv[]) GC_CAN_IGNORE ffi_closure *cl; GC_CAN_IGNORE closure_and_cif *cl_cif_args; GC_CAN_IGNORE ffi_callback_t do_callback; + GC_CAN_IGNORE void *callback_data; + #ifdef MZ_USE_MZRT + int keep_queue = 0; + #endif + if (!SCHEME_PROCP(argv[0])) scheme_wrong_type(MYNAME, "procedure", 0, argc, argv); nargs = scheme_proper_list_length(itypes); @@ -2932,9 +2962,9 @@ static Scheme_Object *foreign_ffi_callback(int argc, Scheme_Object *argv[]) ffi_sync_queue->sig_hand = sig_hand; ffi_sync_queue->callbacks = NULL; } - sync = scheme_make_raw_pair((Scheme_Object *)ffi_sync_queue, - argv[5]); + sync = argv[5]; if (is_atomic) sync = scheme_box(sync); + keep_queue = 1; #endif do_callback = ffi_queue_callback; } else @@ -2963,18 +2993,36 @@ static Scheme_Object *foreign_ffi_callback(int argc, Scheme_Object *argv[]) # ifdef MZ_PRECISE_GC { /* put data in immobile, weak box */ - void **tmp; + GC_CAN_IGNORE void **tmp; tmp = GC_malloc_immobile_box(GC_malloc_weak_box(data, NULL, 0, 1)); - cl_cif_args->data = (struct immobile_box*)tmp; + callback_data = (struct immobile_box*)tmp; } # else /* MZ_PRECISE_GC undefined */ - cl_cif_args->data = (void*)data; + callback_data = (void*)data; # endif /* MZ_PRECISE_GC */ + #ifdef MZ_USE_MZRT + if (keep_queue) { + /* For ffi_queue_callback(), add a level of indirection in + `data' to hold the place-specific `ffi_sync_queue'. + Use `free_cl_cif_data_args' to clean up this extra level. */ + GC_CAN_IGNORE void **tmp; + tmp = (void **)malloc(sizeof(void*) * 2); + tmp[0] = callback_data; + tmp[1] = ffi_sync_queue; + callback_data = (void *)tmp; + } + #endif + cl_cif_args->data = callback_data; if (ffi_prep_closure(cl, cif, do_callback, (void*)(cl_cif_args->data)) != FFI_OK) scheme_signal_error ("internal error: ffi_prep_closure did not return FFI_OK"); - scheme_register_finalizer(data, free_cl_cif_args, cl_cif_args, NULL, NULL); + #ifdef MZ_USE_MZRT + if (keep_queue) + scheme_register_finalizer(data, free_cl_cif_queue_args, cl_cif_args, NULL, NULL); + else + #endif + scheme_register_finalizer(data, free_cl_cif_args, cl_cif_args, NULL, NULL); return (Scheme_Object*)data; } #undef MYNAME @@ -3345,28 +3393,28 @@ void scheme_init_foreign(Scheme_Env *env) t = (ctype_struct*)scheme_malloc_tagged(sizeof(ctype_struct)); t->so.type = ctype_tag; t->basetype = (s); - t->scheme_to_c = ((Scheme_Object*)(void*)(&ffi_type_pointer)); + t->scheme_to_c = ((Scheme_Object*)(void*)(&ffi_type_gcpointer)); t->c_to_scheme = ((Scheme_Object*)FOREIGN_string_ucs_4); scheme_add_global("_string/ucs-4", (Scheme_Object*)t, menv); s = scheme_intern_symbol("string/utf-16"); t = (ctype_struct*)scheme_malloc_tagged(sizeof(ctype_struct)); t->so.type = ctype_tag; t->basetype = (s); - t->scheme_to_c = ((Scheme_Object*)(void*)(&ffi_type_pointer)); + t->scheme_to_c = ((Scheme_Object*)(void*)(&ffi_type_gcpointer)); t->c_to_scheme = ((Scheme_Object*)FOREIGN_string_utf_16); scheme_add_global("_string/utf-16", (Scheme_Object*)t, menv); s = scheme_intern_symbol("bytes"); t = (ctype_struct*)scheme_malloc_tagged(sizeof(ctype_struct)); t->so.type = ctype_tag; t->basetype = (s); - t->scheme_to_c = ((Scheme_Object*)(void*)(&ffi_type_pointer)); + t->scheme_to_c = ((Scheme_Object*)(void*)(&ffi_type_gcpointer)); t->c_to_scheme = ((Scheme_Object*)FOREIGN_bytes); scheme_add_global("_bytes", (Scheme_Object*)t, menv); s = scheme_intern_symbol("path"); t = (ctype_struct*)scheme_malloc_tagged(sizeof(ctype_struct)); t->so.type = ctype_tag; t->basetype = (s); - t->scheme_to_c = ((Scheme_Object*)(void*)(&ffi_type_pointer)); + t->scheme_to_c = ((Scheme_Object*)(void*)(&ffi_type_gcpointer)); t->c_to_scheme = ((Scheme_Object*)FOREIGN_path); scheme_add_global("_path", (Scheme_Object*)t, menv); s = scheme_intern_symbol("symbol"); diff --git a/src/foreign/foreign.rktc b/src/foreign/foreign.rktc index 3fff7490b1..31cfbaa9bd 100755 --- a/src/foreign/foreign.rktc +++ b/src/foreign/foreign.rktc @@ -664,14 +664,14 @@ Scheme_Object *utf16_pointer_to_ucs4_string(unsigned short *utf) * meaningless to use NULL. */ @(defctype 'string/ucs-4 - 'ftype "pointer" + 'ftype "gcpointer" 'ctype "mzchar*" 'pred "SCHEME_FALSEP_OR_CHAR_STRINGP" 's->c "ucs4_string_or_null_to_ucs4_pointer" 'c->s "scheme_make_char_string_without_copying") @(defctype 'string/utf-16 - 'ftype "pointer" + 'ftype "gcpointer" 'ctype "unsigned short*" 'pred "SCHEME_FALSEP_OR_CHAR_STRINGP" 's->c "ucs4_string_or_null_to_utf16_pointer" @@ -681,7 +681,7 @@ Scheme_Object *utf16_pointer_to_ucs4_string(unsigned short *utf) * (note: these are not like char* which is just a pointer) */ @(defctype 'bytes - 'ftype "pointer" + 'ftype "gcpointer" 'ctype "char*" 'pred (lambda (x aux) @list{SCHEME_FALSEP(@x)||SCHEME_BYTE_STRINGP(@x)}) @@ -692,7 +692,7 @@ Scheme_Object *utf16_pointer_to_ucs4_string(unsigned short *utf) scheme_make_byte_string_without_copying(@x)})) @(defctype 'path - 'ftype "pointer" + 'ftype "gcpointer" 'ctype "char*" 'pred (lambda (x aux) @list{SCHEME_FALSEP(@x)||SCHEME_PATH_STRINGP(@x)}) @@ -756,6 +756,11 @@ typedef union _ForeignAny { @; last makes sure this is the last one value that gets used #define FOREIGN_struct (@(type-counter 'last)) +static int is_gcable_pointer(Scheme_Object *o) { + return !SCHEME_CPTRP(o) + || !(SCHEME_CPTR_FLAGS(o) & 0x1); +} + /*****************************************************************************/ /* Type objects */ @@ -978,10 +983,10 @@ ffi_abi sym_to_abi(char *who, Scheme_Object *sym) [sync "Scheme_Object*"]] /* The sync field: - NULL => non-atomic mode, no sync proc + NULL => non-atomic mode #t => atomic mode, no sync proc - (rcons queue proc) => non-atomic mode, sync proc - (box (rcons queue proc)) => atomic mode, sync proc */ + proc => non-atomic mode, sync proc + (box proc) => atomic mode, sync proc */ /*****************************************************************************/ /* Pointer objects */ @@ -1003,7 +1008,7 @@ ffi_abi sym_to_abi(char *who, Scheme_Object *sym) W_OFFSET(SCHEME_FFIANYPTR_VAL(x), SCHEME_FFIANYPTR_OFFSET(x)) #define SCHEME_CPOINTER_W_OFFSET_P(x) \ - SAME_TYPE(SCHEME_TYPE(x), scheme_offset_cpointer_type) + (SCHEME_CPTRP(x) && SCHEME_CPTR_HAS_OFFSET(x)) #define scheme_make_foreign_cpointer(x) \ ((x==NULL)?scheme_false:scheme_make_cptr(x,NULL)) @@ -1014,6 +1019,9 @@ ffi_abi sym_to_abi(char *who, Scheme_Object *sym) #define scheme_make_foreign_external_cpointer(x) \ ((x==NULL)?scheme_false:scheme_make_external_cptr(x,NULL)) +#define scheme_make_foreign_offset_external_cpointer(x, delta) \ + ((delta == 0) ? scheme_make_foreign_external_cpointer(x) : scheme_make_offset_external_cptr(x,delta,NULL)) + @cdefine[cpointer? 1]{ return SCHEME_FFIANYPTRP(argv[0]) ? scheme_true : scheme_false; } @@ -1045,23 +1053,23 @@ void *scheme_extract_pointer(Scheme_Object *v) { * memory location -- deal with it via a C2SCHEME macro wrapper that is used * for both the function definition and calls */ #ifdef SCHEME_BIG_ENDIAN -#define C2SCHEME(typ,src,delta,argsloc) c_to_scheme(typ,src,delta,argsloc) +#define C2SCHEME(typ,src,delta,argsloc,gcsrc) c_to_scheme(typ,src,delta,argsloc,gcsrc) #define REF_CTYPE(ctype) (((sizeof(ctype)Scheme", "C-type", 0, 1, &type); if (CTYPE_USERP(type)) { - res = C2SCHEME(CTYPE_BASETYPE(type), src, delta, args_loc); + res = C2SCHEME(CTYPE_BASETYPE(type), src, delta, args_loc, gcsrc); if (SCHEME_FALSEP(CTYPE_USER_C2S(type))) return res; else @@ -1076,7 +1084,10 @@ static Scheme_Object *C2SCHEME(Scheme_Object *type, void *src, (if (procedure? c->s) (c->s x) (list c->s"("x")"))) "scheme_void")}) case FOREIGN_struct: - return scheme_make_foreign_offset_cpointer(src, delta); + if (gcsrc) + return scheme_make_foreign_offset_cpointer(src, delta); + else + return scheme_make_foreign_offset_external_cpointer(src, delta); default: scheme_signal_error("corrupt foreign type: %V", type); } @hush @@ -1150,23 +1161,26 @@ static void* SCHEME2C(Scheme_Object *type, void *dst, long delta, if (_offset) *_offset = toff;@; @"\n" }]@; @(if ptr? - @list{if (basetype_p == NULL || @; - @(if offset - @list{(tmp == NULL && toff == 0)} - @list{tmp == NULL})) { - @x = @(if offset - @list{(_offset ? tmp : @; - (@ctype)W_OFFSET(tmp, toff))} - "tmp"); - return NULL; - } else { - *basetype_p = FOREIGN_@cname; - return @(if offset - @list{_offset ? tmp : @; - (@ctype)W_OFFSET(tmp, toff)} + @list{if (basetype_p == NULL || @; + @(if offset + @list{(tmp == NULL && toff == 0)} + @list{tmp == NULL}) || @; + @(if (equal? ftype "pointer") + @list{!is_gcable_pointer(val)} + @list{0})) { + @x = @(if offset + @list{(_offset ? tmp : @; + (@ctype)W_OFFSET(tmp, toff))} "tmp"); - }} - @list{@x = tmp@";" return NULL@";"}) + return NULL; + } else { + *basetype_p = FOREIGN_@cname; + return @(if offset + @list{_offset ? tmp : @; + (@ctype)W_OFFSET(tmp, toff)} + "tmp"); + }} + @list{@x = tmp@";" return NULL@";"}) } else { @wrong-type["val" stype]; @hush @@ -1651,12 +1665,14 @@ static Scheme_Object *do_memop(const char *who, int mode, /* WARNING: there are *NO* checks at all, this is raw C level code. */ @cdefine[ptr-ref 2 4]{ int size=0; void *ptr; Scheme_Object *base; - long delta; + long delta; int gcsrc=1; if (!SCHEME_FFIANYPTRP(argv[0])) scheme_wrong_type(MYNAME, "cpointer", 0, argc, argv); ptr = SCHEME_FFIANYPTR_VAL(argv[0]); delta = SCHEME_FFIANYPTR_OFFSET(argv[0]); + if (!is_gcable_pointer(argv[0])) + gcsrc = 0; if ((ptr == NULL) && (delta == 0)) scheme_wrong_type(MYNAME, "non-null-cpointer", 0, argc, argv); if (NULL == (base = get_ctype_base(argv[1]))) @@ -1691,7 +1707,7 @@ static Scheme_Object *do_memop(const char *who, int mode, scheme_signal_error(MYNAME": cannot multiply fpointer type by offset"); delta += (size * SCHEME_INT_VAL(argv[2])); } - return C2SCHEME(argv[1], ptr, delta, 0); + return C2SCHEME(argv[1], ptr, delta, 0, gcsrc); } /* (ptr-set! cpointer type [['abs] n] value) -> void */ @@ -1909,6 +1925,9 @@ Scheme_Object *ffi_do_call(void *data, int argc, Scheme_Object *argv[]) /* ... set the ivals pointer (pointer type doesn't matter) and avalues */ ivals[i].x_pointer = avalues[i]; avalues[i] = &(ivals[i]); + } else if (offsets[i]) { + /* struct argument has an offset */ + avalues[i] = (char *)avalues[i] + offsets[i]; } /* Otherwise it was a struct pointer, and avalues[i] is already fine. */ /* Add offset, if any: */ @@ -1937,7 +1956,7 @@ Scheme_Object *ffi_do_call(void *data, int argc, Scheme_Object *argv[]) } break; } - return C2SCHEME(otype, p, 0, 1); + return C2SCHEME(otype, p, 0, 1, 1); } /* see below */ @@ -2058,15 +2077,15 @@ void ffi_do_callback(ffi_cif* cif, void* resultp, void** args, void *userdata) argv = argv_stack; else argv = scheme_malloc(argc * sizeof(Scheme_Object*)); - if (data->sync && !SCHEME_RPAIRP(data->sync)) + if (data->sync && !SCHEME_PROCP(data->sync)) scheme_start_in_scheduler(); for (i=0, p=data->itypes; iproc, argc, argv); SCHEME2C(data->otype, resultp, 0, p, NULL, NULL, 1); - if (data->sync && !SCHEME_RPAIRP(data->sync)) + if (data->sync && !SCHEME_PROCP(data->sync)) scheme_end_in_scheduler(); } @@ -2135,7 +2154,6 @@ void scheme_check_foreign_work(void) proc = data->sync; if (SCHEME_BOXP(proc)) proc = SCHEME_BOX_VAL(proc); - proc = SCHEME_CDR(proc); scheme_start_in_scheduler(); _scheme_apply(proc, 1, a); @@ -2151,49 +2169,44 @@ void scheme_check_foreign_work(void) void ffi_queue_callback(ffi_cif* cif, void* resultp, void** args, void *userdata) XFORM_SKIP_PROC { - ffi_callback_struct *data; - - data = extract_ffi_callback(userdata); - #ifdef MZ_USE_MZRT - { - FFI_Sync_Queue *queue; - Scheme_Object *o; + /* This function must not refer to any GCable address, not even + temporarily, because a GC may occur concurrent to this + function if it's in another thread. */ + FFI_Sync_Queue *queue; - o = data->sync; - if (SCHEME_BOXP(o)) o = SCHEME_BOX_VAL(o); + queue = (FFI_Sync_Queue *)((void **)userdata)[1]; + userdata = ((void **)userdata)[0]; + + if (queue->orig_thread != mz_proc_thread_self()) { + Queued_Callback *qc; + mzrt_sema *sema; - queue = (FFI_Sync_Queue *)SCHEME_CAR(o); + mzrt_sema_create(&sema, 0); - if (queue->orig_thread != mz_proc_thread_self()) { - Queued_Callback *qc; - mzrt_sema *sema; + qc = (Queued_Callback *)malloc(sizeof(Queued_Callback)); + qc->cif = cif; + qc->resultp = resultp; + qc->args = args; + qc->userdata = userdata; + qc->sema = sema; + qc->called = 0; - mzrt_sema_create(&sema, 0); + mzrt_mutex_lock(queue->lock); + qc->next = queue->callbacks; + queue->callbacks = qc; + mzrt_mutex_unlock(queue->lock); + scheme_signal_received_at(queue->sig_hand); - qc = (Queued_Callback *)malloc(sizeof(Queued_Callback)); - qc->cif = cif; - qc->resultp = resultp; - qc->args = args; - qc->userdata = userdata; - qc->sema = sema; - qc->called = 0; + /* wait for the callback to be invoked in the main thread */ + mzrt_sema_wait(sema); - mzrt_mutex_lock(queue->lock); - qc->next = queue->callbacks; - queue->callbacks = qc; - mzrt_mutex_unlock(queue->lock); - scheme_signal_received_at(queue->sig_hand); - - /* wait for the callback to be invoked in the main thread */ - mzrt_sema_wait(sema); - - mzrt_sema_destroy(sema); - free(qc); - return; - } + mzrt_sema_destroy(sema); + free(qc); + return; } #endif + ffi_do_callback(cif, resultp, args, userdata); } @@ -2207,6 +2220,7 @@ typedef struct closure_and_cif_struct { void *data; #endif } closure_and_cif; + /* free the above */ void free_cl_cif_args(void *ignored, void *p) { @@ -2222,6 +2236,20 @@ void free_cl_cif_args(void *ignored, void *p) scheme_free_code(p); } +#ifdef MZ_USE_MZRT +void free_cl_cif_queue_args(void *ignored, void *p) +{ + void *data = ((closure_and_cif*)p)->data; + void **q = (void **)data; + data = q[0]; + free(q); +#ifdef MZ_PRECISE_GC + GC_free_immobile_box((void**)data); +#endif + scheme_free_code(p); +} +#endif + /* (ffi-callback scheme-proc in-types out-type [abi atomic? sync]) -> ffi-callback */ /* the treatment of in-types and out-types is similar to that in ffi-call */ /* the real work is done by ffi_do_callback above */ @@ -2268,6 +2296,11 @@ void free_cl_cif_args(void *ignored, void *p) GC_CAN_IGNORE ffi_closure *cl; GC_CAN_IGNORE closure_and_cif *cl_cif_args; GC_CAN_IGNORE ffi_callback_t do_callback; + GC_CAN_IGNORE void *callback_data; +#ifdef MZ_USE_MZRT + int keep_queue = 0; +#endif + if (!SCHEME_PROCP(argv[0])) scheme_wrong_type(MYNAME, "procedure", 0, argc, argv); nargs = scheme_proper_list_length(itypes); @@ -2295,9 +2328,9 @@ void free_cl_cif_args(void *ignored, void *p) ffi_sync_queue->sig_hand = sig_hand; ffi_sync_queue->callbacks = NULL; } - sync = scheme_make_raw_pair((Scheme_Object *)ffi_sync_queue, - argv[5]); + sync = argv[5]; if (is_atomic) sync = scheme_box(sync); + keep_queue = 1; #endif do_callback = ffi_queue_callback; } else @@ -2322,18 +2355,36 @@ void free_cl_cif_args(void *ignored, void *p) @@@IFDEF{MZ_PRECISE_GC}{ { /* put data in immobile, weak box */ - void **tmp; + GC_CAN_IGNORE void **tmp; tmp = GC_malloc_immobile_box(GC_malloc_weak_box(data, NULL, 0, 1)); - cl_cif_args->data = (struct immobile_box*)tmp; + callback_data = (struct immobile_box*)tmp; } }{ - cl_cif_args->data = (void*)data; + callback_data = (void*)data; } +#ifdef MZ_USE_MZRT + if (keep_queue) { + /* For ffi_queue_callback(), add a level of indirection in + `data' to hold the place-specific `ffi_sync_queue'. + Use `free_cl_cif_data_args' to clean up this extra level. */ + GC_CAN_IGNORE void **tmp; + tmp = (void **)malloc(sizeof(void*) * 2); + tmp[0] = callback_data; + tmp[1] = ffi_sync_queue; + callback_data = (void *)tmp; + } +#endif + cl_cif_args->data = callback_data; if (ffi_prep_closure(cl, cif, do_callback, (void*)(cl_cif_args->data)) != FFI_OK) scheme_signal_error ("internal error: ffi_prep_closure did not return FFI_OK"); - scheme_register_finalizer(data, free_cl_cif_args, cl_cif_args, NULL, NULL); +#ifdef MZ_USE_MZRT + if (keep_queue) + scheme_register_finalizer(data, free_cl_cif_queue_args, cl_cif_args, NULL, NULL); + else +#endif + scheme_register_finalizer(data, free_cl_cif_args, cl_cif_args, NULL, NULL); return (Scheme_Object*)data; } diff --git a/src/get-libs.rkt b/src/get-libs.rkt index 368fee40b8..bfbe14d8ee 100644 --- a/src/get-libs.rkt +++ b/src/get-libs.rkt @@ -5,15 +5,16 @@ ;; This program avoids racket/port and net/url, because it is loaded ;; without using bytecode. -(define mode 'download) -(define touch #f) - (define url-host "download.racket-lang.org") (define url-path "/libs/1/") (define url-base (string-append "http://" url-host url-path)) (provide all-files+sizes) (define all-files+sizes + ;; alist mapping package to + ;; alist mapping architecture to + ;; a list of entries, each has filename and size + ;; and optionally a path that it would install to and the installed size `(;; Core Libraries [core [win32/i386 @@ -35,7 +36,7 @@ ["libpixman-1.0.dylib" 459304] ["libgthread-2.0.0.dylib" 24592] ["libpng14.14.dylib" 182992] - ["PSMTabBarControl.tgz" 89039]] + ["PSMTabBarControl.tgz" 89039 "PSMTabBarControl.framework" 247760]] [x86_64-macosx ["libcairo.2.dylib" 944552] ["libintl.8.dylib" 61016] @@ -49,7 +50,7 @@ ["libpixman-1.0.dylib" 499440] ["libgthread-2.0.0.dylib" 21728] ["libpng14.14.dylib" 192224] - ["PSMTabBarControl.tgz" 105765]] + ["PSMTabBarControl.tgz" 105765 "PSMTabBarControl.framework" 316512]] [ppc-macosx ["libcairo.2.dylib" 2716096] ["libintl.8.dylib" 133156] @@ -63,7 +64,7 @@ ["libpixman-1.0.dylib" 1366816] ["libgthread-2.0.0.dylib" 25416] ["libpng14.14.dylib" 505920] - ["PSMTabBarControl.tgz" 95862]] + ["PSMTabBarControl.tgz" 95862 "PSMTabBarControl.framework" 229493]] [win32/i386 ["libjpeg-7.dll" 233192] ["libcairo-2.dll" 921369] @@ -91,16 +92,9 @@ ["gtkrc" 1181]) '())]])) -(define-values (package src-dir dest-dir) - (command-line - #:once-any - [("--download") "download mode (the default)" (set! mode 'download)] - [("--install") "install mode" (set! mode 'install)] - [("--no-op") "do nothing (for internal use)" (set! mode #f)] - #:once-each - [("--touch") file "touch `' on download success" (set! touch file)] - #:args [package src-dir dest-dir] - (values (string->symbol package) src-dir dest-dir))) +(define-values [package dest-dir] + (command-line #:args [package [dest-dir (current-directory)]] + (values (string->symbol package) dest-dir))) (define (unixize p) (let-values ([(base name dir?) (split-path p)]) @@ -108,17 +102,15 @@ (string-append (unixize base) "/" (path->string name)) (path->string name)))) -(define (needed-files+sizes) - (let* ([files+sizes - (cdr (or (assq package all-files+sizes) - (error 'get-libs "bad package: ~s, expecting one of ~s" - package (map car all-files+sizes))))] - [arch (unixize (system-library-subpath))] - [arch (string->symbol (regexp-replace #rx"/3m$" arch ""))]) - (cond [(assq arch files+sizes) => cdr] - [else '()]))) +(define architecture (string->symbol (unixize (system-library-subpath #f)))) -(define explained? #f) +(define (needed-files+sizes) + (let ([files+sizes + (cdr (or (assq package all-files+sizes) + (error 'get-libs "bad package: ~s, expecting one of ~s" + package (map car all-files+sizes))))]) + (cond [(assq architecture files+sizes) => cdr] + [else '()]))) (define (purify-port port) (let ([m (regexp-match-peek-positions #rx#"^HTTP/.*?(?:\r\n\r\n|\n\n|\r\r)" @@ -138,75 +130,89 @@ ;; Must be EOF [else (void)]))))) -(define (download-if-needed dest-dir file size) - (define dest (build-path dest-dir file)) - (if (and (file-exists? dest) (= (file-size dest) size)) - (printf " ~a is ready\n" file) - (let* ([sub (unixize (system-library-subpath #f))] - [src (format "~a~a/~a" url-path sub file)]) - (unless explained? - (set! explained? #t) - (printf ">> Downloading files from\n>> ~a~a\n" url-base sub) - (printf ">> If you don't want automatic download, download each file\n") - (printf ">> yourself from there to\n") - (printf ">> ~a\n" (path->complete-path dest-dir))) - (printf " ~a downloading..." file) - (flush-output) - (define-values [i o] (tcp-connect url-host 80)) - (fprintf o "GET ~a HTTP/1.0\r\n" src) - (fprintf o "Host: ~a\r\n" url-host) - (fprintf o "\r\n") - (flush-output o) - (tcp-abandon-port o) - (purify-port i) - (define tmp (build-path dest-dir (format "~a.download" file))) - (call-with-output-file tmp #:exists 'truncate/replace - (lambda (out) (copy-port i out))) - (rename-file-or-directory tmp dest #t) - (let ([sz (file-size dest)]) - (unless (= size sz) - (eprintf "\n") - (raise-user-error - 'get-libs "size of ~a is ~a; doesn't match expected size ~a" - dest sz size))) - (printf "done\n")))) +(define (download file size) + (define src (format "~a~a/~a" url-path architecture file)) + (define-values [i o] (tcp-connect url-host 80)) + (fprintf o "GET ~a HTTP/1.0\r\nHost: ~a\r\n\r\n" src url-host) + (flush-output o) (tcp-abandon-port o) + (purify-port i) + (define tmp (format "~a.download" file)) + (call-with-output-file tmp #:exists 'truncate/replace + (lambda (out) (copy-port i out))) + (rename-file-or-directory tmp file #t) + (let ([sz (file-size file)]) + (unless (= size sz) + (eprintf "\n") + (raise-user-error 'get-libs + "size of ~a is ~a; doesn't match expected size ~a" + file sz size)))) -(define (same-content? f1 f2) - ;; approximate: - (and (file-exists? f1) (file-exists? f2) (= (file-size f1) (file-size f2)))) +(define (unpack-tgz tgz) + (printf " unpacking...") (flush-output) + (define-values [p pout pin perr] + (subprocess + (current-output-port) (current-input-port) (current-error-port) + (find-executable-path "tar") "zxf" tgz)) + (subprocess-wait p) + (delete-file tgz)) -(define (install-file src dest) - (if (regexp-match? #rx"[.]tgz" (path->string src)) - ;; Unpack tar file: - (unpack-tgz src dest) - ;; Plain copy: - (unless (same-content? src dest) - (printf "Updating ~a\n" dest) - (when (file-exists? dest) (delete-file dest)) - (copy-file src dest)))) +(define (install file) + (cond [(regexp-match? #rx"[.]tgz" file) (unpack-tgz file)] + [else (eprintf "\n") + (raise-user-error 'get-libs "don't know how to install file: ~a" + file)])) -(define (unpack-tgz src* dest) - (define src (path->string (path->complete-path src*))) - (parameterize ([current-directory - (let-values ([(base name dir?) (split-path dest)]) base)]) - (define-values [p pout pin perr] - (subprocess - (current-output-port) (current-input-port) (current-error-port) - (find-executable-path "tar") "zxf" src)) - (subprocess-wait p))) +(define (delete-path path) + (cond [(directory-exists? path) + (parameterize ([current-directory path]) + (for-each delete-path (directory-list))) + (delete-directory path)] + [(or (file-exists? path) (link-exists? path)) (delete-file path)])) -(case mode - [(#f) (void)] - [(download) - (unless (directory-exists? dest-dir) (make-directory dest-dir)) - (for ([file+size (in-list (needed-files+sizes))]) - (download-if-needed dest-dir (car file+size) (cadr file+size))) - (when touch - (define ok (build-path dest-dir touch)) - (when (file-exists? ok) (delete-file ok)) - (unless (file-exists? ok) (with-output-to-file ok void)))] - [(install) - (for ([file+size (in-list (needed-files+sizes))]) - (define file (car file+size)) - (install-file (build-path src-dir "libs" file) - (build-path dest-dir file)))]) +(define (directory-size dir) + (parameterize ([current-directory dir]) + (for/fold ([sum 0]) ([path (in-list (directory-list))]) + (+ sum (path-size path))))) + +(define (path-size path) + (cond [(file-exists? path) (file-size path)] + [(directory-exists? path) (directory-size path)] + [else 0])) + +(define got-path? ; approximate, using size + (case-lambda [(path size unpacked-path unpacked-size) + (got-path? unpacked-path unpacked-size)] + [(path size) + (equal? size (path-size path))])) + +(unless (eq? package 'nothing) + (unless (directory-exists? dest-dir) (make-directory dest-dir)) + (parameterize ([current-directory dest-dir]) + (define needed (needed-files+sizes)) + (define really-needed + (filter (lambda (n) (not (apply got-path? n))) needed)) + (printf (if (null? needed) + ">> No ~a libraries to download for ~a\n" + ">> Getting ~a libraries for ~a\n") + package architecture) + (cond + [(null? needed) (void)] + [(null? really-needed) + (printf ">> All files present, no downloads needed.\n")] + [else + (printf ">> Downloading files from\n>> ~a~a\n" url-base architecture) + (printf ">> If you don't want automatic download, download each file\n") + (printf ">> yourself from there to\n") + (printf ">> ~a\n" (path->complete-path (current-directory))) + (for ([file+size (in-list needed)]) + (define file (car file+size)) + (define size (cadr file+size)) + (printf " ~a" file) + (if (member file+size really-needed) + (begin (printf " downloading...") (flush-output) + (download file size) + (when (pair? (cddr file+size)) + (delete-path (caddr file+size)) + (install file)) + (printf " done.\n")) + (printf " already exists.\n")))]))) diff --git a/src/gracket/Makefile.in b/src/gracket/Makefile.in index 06435d2f41..dcabb718bd 100644 --- a/src/gracket/Makefile.in +++ b/src/gracket/Makefile.in @@ -75,11 +75,9 @@ bin: $(MAKE) @MAIN_VARIANT@ 3m: - $(MAKE) libs/gui-ready$(DOWNLOAD_BIN_VERSION) cd gc2; $(MAKE) 3m cgc: - $(MAKE) libs/gui-ready$(DOWNLOAD_BIN_VERSION) $(MAKE) $(LINKRESULT) both: @@ -126,9 +124,6 @@ grmain_ee.@LTO@ : gracket.@LTO@ ee-main: $(MAKE) grmain_ee.@LTO@ -libs/gui-ready$(DOWNLOAD_BIN_VERSION): - $(RACKET) -c "$(srcdir)/../get-libs.rkt" --touch gui-ready$(DOWNLOAD_BIN_VERSION) gui "$(srcdir)" libs - clean: rm -f *.@LTO@ *.d core gracket gracket3m rm -f gc2/*.@LTO@ gc2/xsrc/* gc2/macxsrc/* gc2/*.d gc2/*.dd @@ -163,7 +158,7 @@ install-post-collects: $(MAKE) install-@WXVARIANT@-post-collects install-common: - $(RACKET) -c "$(srcdir)/../get-libs.rkt" --install gui . "$(DESTDIR)$(libpltdir)" + $(RACKET) -c "$(srcdir)/../get-libs.rkt" gui "$(DESTDIR)$(libpltdir)" # X11 ---------------------------------------- diff --git a/src/racket/include/mzwin.def b/src/racket/include/mzwin.def index 52d64b2895..5f2ef7a294 100644 --- a/src/racket/include/mzwin.def +++ b/src/racket/include/mzwin.def @@ -99,6 +99,7 @@ EXPORTS scheme_log scheme_log_message scheme_log_abort + scheme_log_warning scheme_out_of_memory_abort scheme_wrong_count scheme_wrong_count_m diff --git a/src/racket/include/mzwin3m.def b/src/racket/include/mzwin3m.def index 3b31068276..8dffd3241a 100644 --- a/src/racket/include/mzwin3m.def +++ b/src/racket/include/mzwin3m.def @@ -99,6 +99,7 @@ EXPORTS scheme_log scheme_log_message scheme_log_abort + scheme_log_warning scheme_out_of_memory_abort scheme_wrong_count scheme_wrong_count_m diff --git a/src/racket/include/racket.exp b/src/racket/include/racket.exp index 241132e9de..015e172cad 100644 --- a/src/racket/include/racket.exp +++ b/src/racket/include/racket.exp @@ -97,6 +97,7 @@ scheme_log_level_p scheme_log scheme_log_message scheme_log_abort +scheme_log_warning scheme_out_of_memory_abort scheme_wrong_count scheme_wrong_count_m diff --git a/src/racket/include/racket3m.exp b/src/racket/include/racket3m.exp index a5393f4eff..adf0535742 100644 --- a/src/racket/include/racket3m.exp +++ b/src/racket/include/racket3m.exp @@ -97,6 +97,7 @@ scheme_log_level_p scheme_log scheme_log_message scheme_log_abort +scheme_log_warning scheme_out_of_memory_abort scheme_wrong_count scheme_wrong_count_m diff --git a/src/racket/include/scheme.h b/src/racket/include/scheme.h index 45986e784f..2d3283e0a9 100644 --- a/src/racket/include/scheme.h +++ b/src/racket/include/scheme.h @@ -461,7 +461,7 @@ typedef long (*Scheme_Secondary_Hash_Proc)(Scheme_Object *obj, void *cycle_data) #define SCHEME_UDPP(obj) SAME_TYPE(SCHEME_TYPE(obj), scheme_udp_type) #define SCHEME_UDP_EVTP(obj) SAME_TYPE(SCHEME_TYPE(obj), scheme_udp_evt_type) -#define SCHEME_CPTRP(obj) (SAME_TYPE(SCHEME_TYPE(obj), scheme_cpointer_type) || SAME_TYPE(SCHEME_TYPE(obj), scheme_offset_cpointer_type)) +#define SCHEME_CPTRP(obj) (SAME_TYPE(SCHEME_TYPE(obj), scheme_cpointer_type)) #define SCHEME_MUTABLEP(obj) (!(MZ_OPT_HASH_KEY((Scheme_Inclhash_Object *)(obj)) & 0x1)) #define SCHEME_IMMUTABLEP(obj) (MZ_OPT_HASH_KEY((Scheme_Inclhash_Object *)(obj)) & 0x1) @@ -562,7 +562,7 @@ typedef long (*Scheme_Secondary_Hash_Proc)(Scheme_Object *obj, void *cycle_data) typedef struct Scheme_Cptr { - Scheme_Inclhash_Object so; /* 0x1 => an external pointer (not GCable) */ + Scheme_Inclhash_Object so; /* 0x1 => an external pointer (not GCable); 0x2 => has offset */ void *val; Scheme_Object *type; } Scheme_Cptr; @@ -574,8 +574,9 @@ typedef struct Scheme_Offset_Cptr #define SCHEME_CPTR_VAL(obj) (((Scheme_Cptr *)(obj))->val) #define SCHEME_CPTR_TYPE(obj) (((Scheme_Cptr *)(obj))->type) -#define SCHEME_CPTR_OFFSET(obj) (SAME_TYPE(_SCHEME_TYPE(obj), scheme_offset_cpointer_type) ? ((Scheme_Offset_Cptr *)obj)->offset : 0) +#define SCHEME_CPTR_OFFSET(obj) (SCHEME_CPTR_HAS_OFFSET(obj) ? ((Scheme_Offset_Cptr *)obj)->offset : 0) #define SCHEME_CPTR_FLAGS(obj) MZ_OPT_HASH_KEY(&((Scheme_Cptr *)(obj))->so) +#define SCHEME_CPTR_HAS_OFFSET(obj) (SCHEME_CPTR_FLAGS(obj) & 0x2) #define SCHEME_SET_IMMUTABLE(obj) ((MZ_OPT_HASH_KEY((Scheme_Inclhash_Object *)(obj)) |= 0x1)) #define SCHEME_SET_CHAR_STRING_IMMUTABLE(obj) SCHEME_SET_IMMUTABLE(obj) @@ -1709,7 +1710,7 @@ extern void *scheme_malloc_envunbox(size_t); /* embedding configuration and hooks */ /*========================================================================*/ -typedef void (*Scheme_On_Atomic_Timeout_Proc)(void); +typedef void (*Scheme_On_Atomic_Timeout_Proc)(int must_give_up); #if SCHEME_DIRECT_EMBEDDED diff --git a/src/racket/src/bool.c b/src/racket/src/bool.c index bedfde85cb..8880d245d6 100644 --- a/src/racket/src/bool.c +++ b/src/racket/src/bool.c @@ -588,6 +588,9 @@ int is_equal (Scheme_Object *obj1, Scheme_Object *obj2, Equal_Info *eql) if (union_check(obj1, obj2, eql)) return 1; return scheme_bucket_table_equal_rec((Scheme_Bucket_Table *)obj1, (Scheme_Bucket_Table *)obj2, eql); + } else if (SCHEME_CPTRP(obj1)) { + return (((char *)SCHEME_CPTR_VAL(obj1) + SCHEME_CPTR_OFFSET(obj1)) + == ((char *)SCHEME_CPTR_VAL(obj2) + SCHEME_CPTR_OFFSET(obj2))); } else if (SAME_TYPE(SCHEME_TYPE(obj1), scheme_wrap_chunk_type)) { return vector_equal(obj1, obj2, eql); } else if (SAME_TYPE(SCHEME_TYPE(obj1), scheme_resolved_module_path_type)) { diff --git a/src/racket/src/cstartup.inc b/src/racket/src/cstartup.inc index 4ce4994632..92462f8615 100644 --- a/src/racket/src/cstartup.inc +++ b/src/racket/src/cstartup.inc @@ -1,44 +1,44 @@ { SHARED_OK static MZCOMPILED_STRING_FAR unsigned char expr[] = {35,126,8,53,46,48,46,57,57,46,50,51,0,0,0,1,0,0,10,0,13, -0,22,0,35,0,40,0,44,0,49,0,54,0,58,0,65,0,68,0,75,0, +0,22,0,35,0,39,0,43,0,46,0,53,0,58,0,63,0,70,0,75,0, 82,0,88,0,102,0,116,0,119,0,125,0,129,0,131,0,142,0,144,0,158, 0,165,0,187,0,189,0,203,0,14,1,43,1,54,1,65,1,75,1,111,1, 144,1,177,1,236,1,46,2,124,2,190,2,195,2,215,2,106,3,126,3,177, 3,243,3,128,4,14,5,66,5,89,5,168,5,0,0,109,7,0,0,69,35, 37,109,105,110,45,115,116,120,29,11,11,68,104,101,114,101,45,115,116,120,72, -112,97,114,97,109,101,116,101,114,105,122,101,64,108,101,116,42,63,108,101,116, -64,119,104,101,110,64,99,111,110,100,63,97,110,100,66,108,101,116,114,101,99, -62,111,114,66,100,101,102,105,110,101,66,117,110,108,101,115,115,65,113,117,111, +112,97,114,97,109,101,116,101,114,105,122,101,63,108,101,116,63,97,110,100,62, +111,114,66,100,101,102,105,110,101,64,119,104,101,110,64,99,111,110,100,66,108, +101,116,114,101,99,64,108,101,116,42,66,117,110,108,101,115,115,65,113,117,111, 116,101,29,94,2,14,68,35,37,107,101,114,110,101,108,11,29,94,2,14,68, 35,37,112,97,114,97,109,122,11,62,105,102,65,98,101,103,105,110,63,115,116, 120,61,115,70,108,101,116,45,118,97,108,117,101,115,61,120,73,108,101,116,114, 101,99,45,118,97,108,117,101,115,66,108,97,109,98,100,97,1,20,112,97,114, 97,109,101,116,101,114,105,122,97,116,105,111,110,45,107,101,121,61,118,73,100, -101,102,105,110,101,45,118,97,108,117,101,115,97,36,11,8,240,88,83,0,0, -95,159,2,16,36,36,159,2,15,36,36,159,2,15,36,36,16,20,2,11,2, -2,2,5,2,2,2,6,2,2,2,7,2,2,2,4,2,2,2,8,2,2, +101,102,105,110,101,45,118,97,108,117,101,115,97,36,11,8,240,252,81,0,0, +95,159,2,16,36,36,159,2,15,36,36,159,2,15,36,36,16,20,2,4,2, +2,2,11,2,2,2,5,2,2,2,6,2,2,2,7,2,2,2,8,2,2, 2,9,2,2,2,10,2,2,2,12,2,2,2,13,2,2,97,37,11,8,240, -88,83,0,0,93,159,2,15,36,37,16,2,2,3,161,2,2,37,2,3,2, -2,2,3,96,38,11,8,240,88,83,0,0,16,0,96,11,11,8,240,88,83, +252,81,0,0,93,159,2,15,36,37,16,2,2,3,161,2,2,37,2,3,2, +2,2,3,96,38,11,8,240,252,81,0,0,16,0,96,11,11,8,240,252,81, 0,0,16,0,13,16,4,36,29,11,11,2,2,11,18,16,2,99,64,104,101, -114,101,8,32,8,31,8,30,8,29,8,28,93,8,224,95,83,0,0,95,9, -8,224,95,83,0,0,2,2,27,248,22,151,4,195,249,22,144,4,80,158,39, +114,101,8,32,8,31,8,30,8,29,8,28,93,8,224,3,82,0,0,95,9, +8,224,3,82,0,0,2,2,27,248,22,151,4,195,249,22,144,4,80,158,39, 36,251,22,82,2,17,248,22,97,199,12,249,22,72,2,18,248,22,99,201,27, 248,22,151,4,195,249,22,144,4,80,158,39,36,251,22,82,2,17,248,22,97, 199,249,22,72,2,18,248,22,99,201,12,27,248,22,74,248,22,151,4,196,28, 248,22,80,193,20,15,159,37,36,37,28,248,22,80,248,22,74,194,248,22,73, 193,249,22,144,4,80,158,39,36,251,22,82,2,17,248,22,73,199,249,22,72, -2,9,248,22,74,201,11,18,16,2,101,10,8,32,8,31,8,30,8,29,8, -28,16,4,11,11,2,19,3,1,8,101,110,118,49,51,51,48,49,16,4,11, -11,2,20,3,1,8,101,110,118,49,51,51,48,50,93,8,224,96,83,0,0, -95,9,8,224,96,83,0,0,2,2,27,248,22,74,248,22,151,4,196,28,248, +2,6,248,22,74,201,11,18,16,2,101,10,8,32,8,31,8,30,8,29,8, +28,16,4,11,11,2,19,3,1,8,101,110,118,49,50,57,51,52,16,4,11, +11,2,20,3,1,8,101,110,118,49,50,57,51,53,93,8,224,4,82,0,0, +95,9,8,224,4,82,0,0,2,2,27,248,22,74,248,22,151,4,196,28,248, 22,80,193,20,15,159,37,36,37,28,248,22,80,248,22,74,194,248,22,73,193, 249,22,144,4,80,158,39,36,250,22,82,2,21,248,22,82,249,22,82,248,22, -82,2,22,248,22,73,201,251,22,82,2,17,2,22,2,22,249,22,72,2,11, +82,2,22,248,22,73,201,251,22,82,2,17,2,22,2,22,249,22,72,2,7, 248,22,74,204,18,16,2,101,11,8,32,8,31,8,30,8,29,8,28,16,4, -11,11,2,19,3,1,8,101,110,118,49,51,51,48,52,16,4,11,11,2,20, -3,1,8,101,110,118,49,51,51,48,53,93,8,224,97,83,0,0,95,9,8, -224,97,83,0,0,2,2,248,22,151,4,193,27,248,22,151,4,194,249,22,72, +11,11,2,19,3,1,8,101,110,118,49,50,57,51,55,16,4,11,11,2,20, +3,1,8,101,110,118,49,50,57,51,56,93,8,224,5,82,0,0,95,9,8, +224,5,82,0,0,2,2,248,22,151,4,193,27,248,22,151,4,194,249,22,72, 248,22,82,248,22,73,196,248,22,74,195,27,248,22,74,248,22,151,4,23,197, 1,249,22,144,4,80,158,39,36,28,248,22,57,248,22,145,4,248,22,73,23, 198,2,27,249,22,2,32,0,89,162,8,44,37,43,9,222,33,40,248,22,151, @@ -52,7 +52,7 @@ 44,37,47,9,222,33,43,248,22,151,4,248,22,73,201,248,22,74,198,27,248, 22,74,248,22,151,4,196,27,248,22,151,4,248,22,73,195,249,22,144,4,80, 158,40,36,28,248,22,80,195,250,22,83,2,21,9,248,22,74,199,250,22,82, -2,6,248,22,82,248,22,73,199,250,22,83,2,5,248,22,74,201,248,22,74, +2,5,248,22,82,248,22,73,199,250,22,83,2,12,248,22,74,201,248,22,74, 202,27,248,22,74,248,22,151,4,23,197,1,27,249,22,1,22,86,249,22,2, 22,151,4,248,22,151,4,248,22,73,199,249,22,144,4,80,158,40,36,251,22, 82,1,22,119,105,116,104,45,99,111,110,116,105,110,117,97,116,105,111,110,45, @@ -63,13 +63,13 @@ 22,151,4,196,28,248,22,80,193,20,15,159,37,36,37,249,22,144,4,80,158, 39,36,27,248,22,151,4,248,22,73,197,28,249,22,128,9,62,61,62,248,22, 145,4,248,22,97,196,250,22,82,2,21,248,22,82,249,22,82,21,93,2,26, -248,22,73,199,250,22,83,2,8,249,22,82,2,26,249,22,82,248,22,106,203, +248,22,73,199,250,22,83,2,10,249,22,82,2,26,249,22,82,248,22,106,203, 2,26,248,22,74,202,251,22,82,2,17,28,249,22,128,9,248,22,145,4,248, 22,73,200,64,101,108,115,101,10,248,22,73,197,250,22,83,2,21,9,248,22, -74,200,249,22,72,2,8,248,22,74,202,100,8,32,8,31,8,30,8,29,8, -28,16,4,11,11,2,19,3,1,8,101,110,118,49,51,51,50,55,16,4,11, -11,2,20,3,1,8,101,110,118,49,51,51,50,56,93,8,224,98,83,0,0, -18,16,2,158,94,10,64,118,111,105,100,8,48,95,9,8,224,98,83,0,0, +74,200,249,22,72,2,10,248,22,74,202,100,8,32,8,31,8,30,8,29,8, +28,16,4,11,11,2,19,3,1,8,101,110,118,49,50,57,54,48,16,4,11, +11,2,20,3,1,8,101,110,118,49,50,57,54,49,93,8,224,6,82,0,0, +18,16,2,158,94,10,64,118,111,105,100,8,48,95,9,8,224,6,82,0,0, 2,2,27,248,22,74,248,22,151,4,196,249,22,144,4,80,158,39,36,28,248, 22,57,248,22,145,4,248,22,73,197,250,22,82,2,27,248,22,82,248,22,73, 199,248,22,97,198,27,248,22,145,4,248,22,73,197,250,22,82,2,27,248,22, @@ -83,17 +83,17 @@ 11,11,11,16,0,16,0,16,0,36,36,16,11,16,5,2,3,20,15,159,36, 36,36,36,20,105,159,36,16,0,16,1,33,33,10,16,5,2,13,89,162,8, 44,37,53,9,223,0,33,34,36,20,105,159,36,16,1,2,3,16,0,11,16, -5,2,7,89,162,8,44,37,53,9,223,0,33,35,36,20,105,159,36,16,1, -2,3,16,0,11,16,5,2,9,89,162,8,44,37,53,9,223,0,33,36,36, -20,105,159,36,16,1,2,3,16,1,33,37,11,16,5,2,11,89,162,8,44, +5,2,9,89,162,8,44,37,53,9,223,0,33,35,36,20,105,159,36,16,1, +2,3,16,0,11,16,5,2,6,89,162,8,44,37,53,9,223,0,33,36,36, +20,105,159,36,16,1,2,3,16,1,33,37,11,16,5,2,7,89,162,8,44, 37,56,9,223,0,33,38,36,20,105,159,36,16,1,2,3,16,1,33,39,11, -16,5,2,6,89,162,8,44,37,58,9,223,0,33,42,36,20,105,159,36,16, -1,2,3,16,0,11,16,5,2,10,89,162,8,44,37,53,9,223,0,33,44, -36,20,105,159,36,16,1,2,3,16,0,11,16,5,2,5,89,162,8,44,37, +16,5,2,5,89,162,8,44,37,58,9,223,0,33,42,36,20,105,159,36,16, +1,2,3,16,0,11,16,5,2,11,89,162,8,44,37,53,9,223,0,33,44, +36,20,105,159,36,16,1,2,3,16,0,11,16,5,2,12,89,162,8,44,37, 54,9,223,0,33,45,36,20,105,159,36,16,1,2,3,16,0,11,16,5,2, 4,89,162,8,44,37,55,9,223,0,33,46,36,20,105,159,36,16,1,2,3, -16,0,11,16,5,2,8,89,162,8,44,37,58,9,223,0,33,47,36,20,105, -159,36,16,1,2,3,16,1,33,49,11,16,5,2,12,89,162,8,44,37,54, +16,0,11,16,5,2,10,89,162,8,44,37,58,9,223,0,33,47,36,20,105, +159,36,16,1,2,3,16,1,33,49,11,16,5,2,8,89,162,8,44,37,54, 9,223,0,33,50,36,20,105,159,36,16,1,2,3,16,0,11,16,0,94,2, 15,2,16,93,2,15,9,9,36,0}; EVAL_ONE_SIZED_STR((char *)expr, 2025); @@ -520,7 +520,7 @@ 117,116,105,108,115,11,29,94,2,2,69,35,37,110,101,116,119,111,114,107,11, 29,94,2,2,68,35,37,112,97,114,97,109,122,11,29,94,2,2,68,35,37, 101,120,112,111,98,115,11,29,94,2,2,68,35,37,107,101,114,110,101,108,11, -97,36,11,8,240,237,83,0,0,98,159,2,3,36,36,159,2,4,36,36,159, +97,36,11,8,240,145,82,0,0,98,159,2,3,36,36,159,2,4,36,36,159, 2,5,36,36,159,2,6,36,36,159,2,7,36,36,159,2,7,36,36,16,0, 159,36,20,105,159,36,16,1,11,16,0,83,158,42,20,103,145,2,1,2,1, 29,11,11,11,11,11,18,96,11,44,44,44,36,80,158,36,36,20,105,159,36, diff --git a/src/racket/src/env.c b/src/racket/src/env.c index 68fc08596e..ecbe832838 100644 --- a/src/racket/src/env.c +++ b/src/racket/src/env.c @@ -3112,7 +3112,10 @@ scheme_lookup_binding(Scheme_Object *find_id, Scheme_Comp_Env *env, int flags, modpos, SCHEME_INT_VAL(mod_defn_phase)); } - if (!modname && (flags & (SCHEME_SETTING | SCHEME_REFERENCING)) && genv->module) { + if (!modname + && (flags & (SCHEME_SETTING | SCHEME_REFERENCING)) + && genv->module + && !(flags & SCHEME_RESOLVE_MODIDS)) { /* Need to return a variable reference in this case, too. */ return scheme_hash_module_variable(env->genv, genv->module->self_modidx, find_global_id, genv->module->insp, @@ -4575,7 +4578,7 @@ static Scheme_Object *do_variable_namespace(const char *who, int tl, int argc, S return scheme_make_integer(ph); } else if (tl) { /* return env directly; need to set up */ - if (!env->phase) + if (!env->phase && env->module) scheme_prep_namespace_rename(env); } else { /* new namespace: */ diff --git a/src/racket/src/error.c b/src/racket/src/error.c index 91a19005de..bd4550b191 100644 --- a/src/racket/src/error.c +++ b/src/racket/src/error.c @@ -2872,6 +2872,11 @@ void scheme_log_abort(char *buffer) scheme_log_message(&logger, SCHEME_LOG_FATAL, buffer, strlen(buffer), scheme_false); } +void scheme_log_warning(char *buffer) +{ + scheme_log_message(scheme_main_logger, SCHEME_LOG_WARNING, buffer, strlen(buffer), scheme_false); +} + static int extract_level(const char *who, int which, int argc, Scheme_Object **argv) { Scheme_Object *v; diff --git a/src/racket/src/eval.c b/src/racket/src/eval.c index 73e1bca4a7..537eeb4b6c 100644 --- a/src/racket/src/eval.c +++ b/src/racket/src/eval.c @@ -2814,14 +2814,14 @@ static void register_flonum_argument_types(Scheme_App_Rec *app, Scheme_App2_Rec if (!map) { map = MALLOC_N_ATOMIC(char, n); memset(map, 1, n); + memset(map, 0, i); } } if (map && !is_flonum) map[i] = 0; } - if (map) - scheme_set_closure_flonum_map(data, map); + scheme_set_closure_flonum_map(data, map); } } } diff --git a/src/racket/src/fun.c b/src/racket/src/fun.c index 9f1b61a844..1556124815 100644 --- a/src/racket/src/fun.c +++ b/src/racket/src/fun.c @@ -1143,12 +1143,41 @@ void scheme_set_closure_flonum_map(Scheme_Closure_Data *data, char *flonum_map) cl->flonum_map = flonum_map; } - for (i = data->num_params; i--; ) { - if (flonum_map[i]) break; + if (flonum_map) { + for (i = data->num_params; i--; ) { + if (flonum_map[i]) break; + } + + if (i < 0) { + cl->flonum_map = NULL; + } } +} - if (i < 0) { - cl->flonum_map = NULL; +void scheme_merge_closure_flonum_map(Scheme_Closure_Data *data1, Scheme_Closure_Data *data2) +{ + Closure_Info *cl1 = (Closure_Info *)data1->closure_map; + Closure_Info *cl2 = (Closure_Info *)data2->closure_map; + + if (cl1->has_flomap) { + if (!cl1->flonum_map || !cl2->has_flomap) { + cl2->has_flomap = 1; + cl2->flonum_map = cl1->flonum_map; + } else if (cl2->flonum_map) { + int i; + for (i = data1->num_params; i--; ) { + if (cl1->flonum_map[i] != cl2->flonum_map[i]) { + cl2->flonum_map = NULL; + cl1->flonum_map = NULL; + break; + } + } + } else { + cl1->flonum_map = NULL; + } + } else if (cl2->has_flomap) { + cl1->has_flomap = 1; + cl1->flonum_map = cl2->flonum_map; } } @@ -9019,7 +9048,7 @@ void scheme_apply_dw_in_meta(Scheme_Dynamic_Wind *dw, int post_part, int meta_de rest = mc; for (i = 0; i < actual_depth - 1; i++) { rest->cont_mark_total = 0; - rest->cont_mark_offset = 0; + rest->cont_mark_offset = rest->cont_mark_stack; rest->cont_mark_stack_copied = NULL; sync_meta_cont(rest); rest = rest->next; diff --git a/src/racket/src/future.c b/src/racket/src/future.c index 0b069eb862..d4831847fc 100644 --- a/src/racket/src/future.c +++ b/src/racket/src/future.c @@ -627,6 +627,7 @@ Scheme_Object *scheme_future(int argc, Scheme_Object *argv[]) Scheme_Native_Closure *nc; Scheme_Native_Closure_Data *ncd; Scheme_Object *lambda = argv[0]; + double time_of_start; /* Input validation */ scheme_check_proc_arity("future", 0, 0, argc, argv); @@ -669,6 +670,11 @@ Scheme_Object *scheme_future(int argc, Scheme_Object *argv[]) if (ft->status != PENDING_OVERSIZE) { mzrt_mutex_lock(fs->future_mutex); enqueue_future(fs, ft); + + /* Log the spawn time */ + time_of_start = scheme_get_inexact_milliseconds(); + ft->time_of_start = time_of_start; + /* Signal that a future is pending */ mzrt_sema_post(fs->future_pending_sema); /* Alert the runtime thread, in case it wants to @@ -722,6 +728,7 @@ static void future_in_runtime(future_t * volatile ft) Scheme_Thread *p = scheme_current_thread; Scheme_Object * volatile retval; future_t * volatile old_ft; + double time_of_completion; old_ft = p->current_ft; p->current_ft = ft; @@ -744,6 +751,8 @@ static void future_in_runtime(future_t * volatile ft) p->error_buf = savebuf; p->current_ft = old_ft; + time_of_completion = scheme_get_inexact_milliseconds(); + ft->time_of_completion = time_of_completion; ft->work_completed = 1; ft->retval = retval; ft->status = FINISHED; @@ -818,8 +827,16 @@ Scheme_Object *touch(int argc, Scheme_Object *argv[]) { retval = ft->retval; - LOG("Successfully touched future %d\n", ft->id); - + /* Log execution time */ + if (scheme_log_level_p(scheme_main_logger, SCHEME_LOG_DEBUG)) { + scheme_log(scheme_main_logger, SCHEME_LOG_DEBUG, 0, + "future: %d finished. start time: %f, finish time: %f (%f ms)", + ft->id, + ft->time_of_start, + ft->time_of_completion, + ft->time_of_completion - ft->time_of_start); + } + mzrt_mutex_unlock(fs->future_mutex); break; } @@ -1048,6 +1065,9 @@ void *worker_thread_future_loop(void *arg) /* Set the return val in the descriptor */ ft->work_completed = 1; ft->retval = v; + + /* Log future completion time */ + ft->time_of_completion = scheme_get_inexact_milliseconds(); /* In case of multiple values: */ send_special_result(ft, v); diff --git a/src/racket/src/future.h b/src/racket/src/future.h index 752244cbdd..2822791c5a 100644 --- a/src/racket/src/future.h +++ b/src/racket/src/future.h @@ -65,6 +65,10 @@ typedef struct future_t { unsigned long alloc_retval; int alloc_retval_counter; + /* For logging the future's execution time */ + double time_of_start; + double time_of_completion; + void *prim_func; int prim_protocol; Scheme_Object *arg_s0; diff --git a/src/racket/src/hash.c b/src/racket/src/hash.c index 41b01d9f47..b9ac3e4766 100644 --- a/src/racket/src/hash.c +++ b/src/racket/src/hash.c @@ -1076,6 +1076,12 @@ static long equal_hash_key(Scheme_Object *o, long k, Hash_Info *hi) o = SCHEME_CDR(o); break; } + case scheme_cpointer_type: + { + k = (k << 3) + k; + k += (long)((char *)SCHEME_CPTR_VAL(o) + SCHEME_CPTR_OFFSET(o)); + return k; + } case scheme_vector_type: case scheme_fxvector_type: case scheme_wrap_chunk_type: @@ -1490,6 +1496,10 @@ static long equal_hash_key2(Scheme_Object *o, Hash_Info *hi) v2 = equal_hash_key2(SCHEME_CDR(o), hi); return v1 + v2; } + case scheme_cpointer_type: + { + return (long)((char *)SCHEME_CPTR_VAL(o) + SCHEME_CPTR_OFFSET(o)); + } case scheme_vector_type: case scheme_fxvector_type: case scheme_wrap_chunk_type: diff --git a/src/racket/src/jit.c b/src/racket/src/jit.c index 11e4f9d647..b9032bd059 100644 --- a/src/racket/src/jit.c +++ b/src/racket/src/jit.c @@ -5967,13 +5967,14 @@ static int generate_arith(mz_jit_state *jitter, Scheme_Object *rator, Scheme_Obj } else if (v == 0) { (void)jit_movi_p(JIT_R0, scheme_make_integer(0)); } else { - (void)jit_movi_p(JIT_R1, scheme_make_integer(v)); - jit_andi_ul(JIT_R2, JIT_R1, (~0x1)); + (void)jit_movi_l(JIT_R2, ((long)scheme_make_integer(v) & (~0x1))); jit_rshi_l(JIT_V1, JIT_R0, 0x1); if (unsafe_fx && !overflow_refslow) jit_mulr_l(JIT_V1, JIT_V1, JIT_R2); - else + else { + (void)jit_movi_p(JIT_R1, scheme_make_integer(v)); /* for slow path */ (void)jit_bomulr_l(refslow, JIT_V1, JIT_R2); + } jit_ori_ul(JIT_R0, JIT_V1, 0x1); } } else if (arith == -2) { diff --git a/src/racket/src/mzmark.c b/src/racket/src/mzmark.c index 835c6d69f7..9c0b9f06c5 100644 --- a/src/racket/src/mzmark.c +++ b/src/racket/src/mzmark.c @@ -152,7 +152,9 @@ static int quotesyntax_obj_FIXUP(void *p, struct NewGC *gc) { static int cpointer_obj_SIZE(void *p, struct NewGC *gc) { return - gcBYTES_TO_WORDS(sizeof(Scheme_Cptr)); + (SCHEME_CPTR_HAS_OFFSET(p) + ? gcBYTES_TO_WORDS(sizeof(Scheme_Offset_Cptr)) + : gcBYTES_TO_WORDS(sizeof(Scheme_Cptr))); } static int cpointer_obj_MARK(void *p, struct NewGC *gc) { @@ -161,7 +163,9 @@ static int cpointer_obj_MARK(void *p, struct NewGC *gc) { } gcMARK2(SCHEME_CPTR_TYPE(p), gc); return - gcBYTES_TO_WORDS(sizeof(Scheme_Cptr)); + (SCHEME_CPTR_HAS_OFFSET(p) + ? gcBYTES_TO_WORDS(sizeof(Scheme_Offset_Cptr)) + : gcBYTES_TO_WORDS(sizeof(Scheme_Cptr))); } static int cpointer_obj_FIXUP(void *p, struct NewGC *gc) { @@ -170,38 +174,13 @@ static int cpointer_obj_FIXUP(void *p, struct NewGC *gc) { } gcFIXUP2(SCHEME_CPTR_TYPE(p), gc); return - gcBYTES_TO_WORDS(sizeof(Scheme_Cptr)); + (SCHEME_CPTR_HAS_OFFSET(p) + ? gcBYTES_TO_WORDS(sizeof(Scheme_Offset_Cptr)) + : gcBYTES_TO_WORDS(sizeof(Scheme_Cptr))); } #define cpointer_obj_IS_ATOMIC 0 -#define cpointer_obj_IS_CONST_SIZE 1 - - -static int offset_cpointer_obj_SIZE(void *p, struct NewGC *gc) { - return - gcBYTES_TO_WORDS(sizeof(Scheme_Offset_Cptr)); -} - -static int offset_cpointer_obj_MARK(void *p, struct NewGC *gc) { - if (!(SCHEME_CPTR_FLAGS(p) & 0x1)) { - gcMARK2(SCHEME_CPTR_VAL(p), gc); - } - gcMARK2(SCHEME_CPTR_TYPE(p), gc); - return - gcBYTES_TO_WORDS(sizeof(Scheme_Offset_Cptr)); -} - -static int offset_cpointer_obj_FIXUP(void *p, struct NewGC *gc) { - if (!(SCHEME_CPTR_FLAGS(p) & 0x1)) { - gcFIXUP2(SCHEME_CPTR_VAL(p), gc); - } - gcFIXUP2(SCHEME_CPTR_TYPE(p), gc); - return - gcBYTES_TO_WORDS(sizeof(Scheme_Offset_Cptr)); -} - -#define offset_cpointer_obj_IS_ATOMIC 0 -#define offset_cpointer_obj_IS_CONST_SIZE 1 +#define cpointer_obj_IS_CONST_SIZE 0 static int twoptr_obj_SIZE(void *p, struct NewGC *gc) { @@ -4571,39 +4550,6 @@ static int mark_thread_cell_FIXUP(void *p, struct NewGC *gc) { #define mark_thread_cell_IS_CONST_SIZE 1 -static int mark_frozen_tramp_SIZE(void *p, struct NewGC *gc) { - return - gcBYTES_TO_WORDS(sizeof(FrozenTramp)); -} - -static int mark_frozen_tramp_MARK(void *p, struct NewGC *gc) { - FrozenTramp *f = (FrozenTramp *)p; - - gcMARK2(f->do_data, gc); - gcMARK2(f->old_param, gc); - gcMARK2(f->config, gc); - gcMARK2(f->progress_cont, gc); - - return - gcBYTES_TO_WORDS(sizeof(FrozenTramp)); -} - -static int mark_frozen_tramp_FIXUP(void *p, struct NewGC *gc) { - FrozenTramp *f = (FrozenTramp *)p; - - gcFIXUP2(f->do_data, gc); - gcFIXUP2(f->old_param, gc); - gcFIXUP2(f->config, gc); - gcFIXUP2(f->progress_cont, gc); - - return - gcBYTES_TO_WORDS(sizeof(FrozenTramp)); -} - -#define mark_frozen_tramp_IS_ATOMIC 0 -#define mark_frozen_tramp_IS_CONST_SIZE 1 - - #endif /* THREAD */ /**********************************************************************/ diff --git a/src/racket/src/mzmarksrc.c b/src/racket/src/mzmarksrc.c index 561c9e2440..2c7a5a138e 100644 --- a/src/racket/src/mzmarksrc.c +++ b/src/racket/src/mzmarksrc.c @@ -61,17 +61,9 @@ cpointer_obj { } gcMARK2(SCHEME_CPTR_TYPE(p), gc); size: - gcBYTES_TO_WORDS(sizeof(Scheme_Cptr)); -} - -offset_cpointer_obj { - mark: - if (!(SCHEME_CPTR_FLAGS(p) & 0x1)) { - gcMARK2(SCHEME_CPTR_VAL(p), gc); - } - gcMARK2(SCHEME_CPTR_TYPE(p), gc); - size: - gcBYTES_TO_WORDS(sizeof(Scheme_Offset_Cptr)); + (SCHEME_CPTR_HAS_OFFSET(p) + ? gcBYTES_TO_WORDS(sizeof(Scheme_Offset_Cptr)) + : gcBYTES_TO_WORDS(sizeof(Scheme_Cptr))); } twoptr_obj { @@ -1860,19 +1852,6 @@ mark_thread_cell { gcBYTES_TO_WORDS(sizeof(Thread_Cell)); } -mark_frozen_tramp { - mark: - FrozenTramp *f = (FrozenTramp *)p; - - gcMARK2(f->do_data, gc); - gcMARK2(f->old_param, gc); - gcMARK2(f->config, gc); - gcMARK2(f->progress_cont, gc); - - size: - gcBYTES_TO_WORDS(sizeof(FrozenTramp)); -} - END thread; /**********************************************************************/ diff --git a/src/racket/src/salloc.c b/src/racket/src/salloc.c index c510c8cf36..2194289eec 100644 --- a/src/racket/src/salloc.c +++ b/src/racket/src/salloc.c @@ -527,7 +527,7 @@ Scheme_Object *scheme_make_external_cptr(GC_CAN_IGNORE void *cptr, Scheme_Object { Scheme_Object *o; o = scheme_make_cptr(NULL, typetag); - SCHEME_CPTR_FLAGS(o) |= 1; + SCHEME_CPTR_FLAGS(o) |= 0x1; SCHEME_CPTR_VAL(o) = cptr; return o; } @@ -537,7 +537,8 @@ Scheme_Object *scheme_make_offset_cptr(void *cptr, long offset, Scheme_Object *t Scheme_Object *o; o = (Scheme_Object *)scheme_malloc_small_tagged(sizeof(Scheme_Offset_Cptr)); - o->type = scheme_offset_cpointer_type; + o->type = scheme_cpointer_type; + SCHEME_CPTR_FLAGS(o) |= 0x2; SCHEME_CPTR_VAL(o) = cptr; SCHEME_CPTR_TYPE(o) = (void *)typetag; ((Scheme_Offset_Cptr *)o)->offset = offset; @@ -549,7 +550,7 @@ Scheme_Object *scheme_make_offset_external_cptr(GC_CAN_IGNORE void *cptr, long o { Scheme_Object *o; o = scheme_make_offset_cptr(NULL, offset, typetag); - SCHEME_CPTR_FLAGS(o) |= 1; + SCHEME_CPTR_FLAGS(o) |= 0x1; SCHEME_CPTR_VAL(o) = cptr; return o; } diff --git a/src/racket/src/schemef.h b/src/racket/src/schemef.h index 4b231f9a15..6d862c26c0 100644 --- a/src/racket/src/schemef.h +++ b/src/racket/src/schemef.h @@ -204,6 +204,7 @@ MZ_EXTERN void scheme_log(Scheme_Logger *logger, int level, int flags, char *msg, ...); MZ_EXTERN void scheme_log_message(Scheme_Logger *logger, int level, char *buffer, long len, Scheme_Object *data); MZ_EXTERN void scheme_log_abort(char *buffer); +MZ_EXTERN void scheme_log_warning(char *buffer); MZ_EXTERN void scheme_out_of_memory_abort(); MZ_EXTERN void scheme_wrong_count(const char *name, int minc, int maxc, diff --git a/src/racket/src/schemex.h b/src/racket/src/schemex.h index 5e2f87caf1..01e41905d4 100644 --- a/src/racket/src/schemex.h +++ b/src/racket/src/schemex.h @@ -161,6 +161,7 @@ void (*scheme_log)(Scheme_Logger *logger, int level, int flags, char *msg, ...); void (*scheme_log_message)(Scheme_Logger *logger, int level, char *buffer, long len, Scheme_Object *data); void (*scheme_log_abort)(char *buffer); +void (*scheme_log_warning)(char *buffer); void (*scheme_out_of_memory_abort)(); void (*scheme_wrong_count)(const char *name, int minc, int maxc, int argc, Scheme_Object **argv); diff --git a/src/racket/src/schemex.inc b/src/racket/src/schemex.inc index e27756dde3..caac19eeaf 100644 --- a/src/racket/src/schemex.inc +++ b/src/racket/src/schemex.inc @@ -105,6 +105,7 @@ scheme_extension_table->scheme_log = scheme_log; scheme_extension_table->scheme_log_message = scheme_log_message; scheme_extension_table->scheme_log_abort = scheme_log_abort; + scheme_extension_table->scheme_log_warning = scheme_log_warning; scheme_extension_table->scheme_out_of_memory_abort = scheme_out_of_memory_abort; scheme_extension_table->scheme_wrong_count = scheme_wrong_count; scheme_extension_table->scheme_wrong_count_m = scheme_wrong_count_m; diff --git a/src/racket/src/schemexm.h b/src/racket/src/schemexm.h index 2db158e7fd..fa082c493f 100644 --- a/src/racket/src/schemexm.h +++ b/src/racket/src/schemexm.h @@ -105,6 +105,7 @@ #define scheme_log (scheme_extension_table->scheme_log) #define scheme_log_message (scheme_extension_table->scheme_log_message) #define scheme_log_abort (scheme_extension_table->scheme_log_abort) +#define scheme_log_warning (scheme_extension_table->scheme_log_warning) #define scheme_out_of_memory_abort (scheme_extension_table->scheme_out_of_memory_abort) #define scheme_wrong_count (scheme_extension_table->scheme_wrong_count) #define scheme_wrong_count_m (scheme_extension_table->scheme_wrong_count_m) diff --git a/src/racket/src/schpriv.h b/src/racket/src/schpriv.h index 3073939415..df3abad0df 100644 --- a/src/racket/src/schpriv.h +++ b/src/racket/src/schpriv.h @@ -463,6 +463,8 @@ void scheme_suspend_remembered_threads(void); void scheme_resume_remembered_threads(void); #endif +int scheme_wait_until_suspend_ok(void); + #ifdef MZ_USE_MZRT extern void scheme_check_foreign_work(void); #endif @@ -2548,6 +2550,7 @@ int scheme_optimize_is_flonum_valued(Optimize_Info *info, int pos); int scheme_is_flonum_expression(Scheme_Object *expr, Optimize_Info *info); char *scheme_get_closure_flonum_map(Scheme_Closure_Data *data, int arg_n, int *ok); void scheme_set_closure_flonum_map(Scheme_Closure_Data *data, char *flonum_map); +void scheme_merge_closure_flonum_map(Scheme_Closure_Data *data1, Scheme_Closure_Data *data2); Scheme_Object *scheme_optimize_clone(int dup_ok, Scheme_Object *obj, Optimize_Info *info, int delta, int closure_depth); Scheme_Object *scheme_optimize_shift(Scheme_Object *obj, int delta, int after_depth); diff --git a/src/racket/src/schvers.h b/src/racket/src/schvers.h index f0dc87a25b..b4f6fd217d 100644 --- a/src/racket/src/schvers.h +++ b/src/racket/src/schvers.h @@ -13,12 +13,12 @@ consistently.) */ -#define MZSCHEME_VERSION "5.0.99.2" +#define MZSCHEME_VERSION "5.0.99.4" #define MZSCHEME_VERSION_X 5 #define MZSCHEME_VERSION_Y 0 #define MZSCHEME_VERSION_Z 99 -#define MZSCHEME_VERSION_W 2 +#define MZSCHEME_VERSION_W 4 #define MZSCHEME_VERSION_MAJOR ((MZSCHEME_VERSION_X * 100) + MZSCHEME_VERSION_Y) #define MZSCHEME_VERSION_MINOR ((MZSCHEME_VERSION_Z * 1000) + MZSCHEME_VERSION_W) diff --git a/src/racket/src/sema.c b/src/racket/src/sema.c index fb00d00c48..c4dedc33c0 100644 --- a/src/racket/src/sema.c +++ b/src/racket/src/sema.c @@ -634,25 +634,41 @@ int scheme_wait_semas_chs(int n, Scheme_Object **o, int just_try, Syncing *synci start_pos = 0; /* Initial poll */ - i = 0; - for (ii = 0; ii < n; ii++) { - /* Randomized start position for poll ensures fairness: */ - i = (start_pos + ii) % n; + while (1) { + i = 0; + for (ii = 0; ii < n; ii++) { + /* Randomized start position for poll ensures fairness: */ + i = (start_pos + ii) % n; - if (semas[i]->so.type == scheme_sema_type) { - if (semas[i]->value) { - if ((semas[i]->value > 0) && (!syncing || !syncing->reposts || !syncing->reposts[i])) - --semas[i]->value; - if (syncing && syncing->accepts && syncing->accepts[i]) - scheme_accept_sync(syncing, i); - break; - } - } else if (semas[i]->so.type == scheme_never_evt_type) { - /* Never ready. */ - } else if (semas[i]->so.type == scheme_channel_syncer_type) { - /* Probably no need to poll */ - } else if (try_channel(semas[i], syncing, i, NULL)) - break; + if (semas[i]->so.type == scheme_sema_type) { + if (semas[i]->value) { + if ((semas[i]->value > 0) && (!syncing || !syncing->reposts || !syncing->reposts[i])) + --semas[i]->value; + if (syncing && syncing->accepts && syncing->accepts[i]) + scheme_accept_sync(syncing, i); + break; + } + } else if (semas[i]->so.type == scheme_never_evt_type) { + /* Never ready. */ + } else if (semas[i]->so.type == scheme_channel_syncer_type) { + /* Probably no need to poll */ + } else if (try_channel(semas[i], syncing, i, NULL)) + break; + } + + if (ii >= n) { + if (!scheme_current_thread->next) + break; + else { + if (!scheme_wait_until_suspend_ok()) { + break; + } else { + /* there may have been some action on one of the waitables; + try again */ + } + } + } else + break; } /* In the following, syncers get changed back to channels, diff --git a/src/racket/src/struct.c b/src/racket/src/struct.c index 4f82cb1f5c..7209922a7f 100644 --- a/src/racket/src/struct.c +++ b/src/racket/src/struct.c @@ -1754,7 +1754,8 @@ Scheme_Object *scheme_extract_checked_procedure(int argc, Scheme_Object **argv) return NULL; } - if (SCHEME_CHAPERONE_STRUCTP(v) && scheme_is_struct_instance((Scheme_Object *)stype, v)) { + /* let chaperones use the slow path, for now */ + if (SCHEME_STRUCTP(v) && scheme_is_struct_instance((Scheme_Object *)stype, v)) { checker = ((Scheme_Structure *)v)->slots[0]; proc = ((Scheme_Structure *)v)->slots[1]; diff --git a/src/racket/src/stypes.h b/src/racket/src/stypes.h index 950061b7e4..0eb0c795e8 100644 --- a/src/racket/src/stypes.h +++ b/src/racket/src/stypes.h @@ -88,7 +88,7 @@ enum { scheme_hash_table_type, /* 69 */ scheme_hash_tree_type, /* 70 */ scheme_cpointer_type, /* 71 */ - scheme_offset_cpointer_type, /* 72 */ + scheme_currently_unused_type, /* 72 */ scheme_weak_box_type, /* 73 */ scheme_ephemeron_type, /* 74 */ scheme_struct_type_type, /* 75 */ @@ -183,6 +183,7 @@ enum { scheme_once_used_type, /* 164 */ scheme_serialized_symbol_type, /* 165 */ scheme_serialized_structure_type, /* 166 */ + /* use scheme_currently_unused_type above, first */ #ifdef MZTAG_REQUIRED _scheme_last_normal_type_, /* 167 */ @@ -256,8 +257,7 @@ enum { scheme_rt_sfs_info, /* 233 */ scheme_rt_validate_clearing, /* 234 */ scheme_rt_rb_node, /* 235 */ - scheme_rt_frozen_tramp, /* 236 */ - scheme_rt_lightweight_cont, /* 237 */ + scheme_rt_lightweight_cont, /* 236 */ #endif diff --git a/src/racket/src/syntax.c b/src/racket/src/syntax.c index 2d5b625a81..6acb9014ff 100644 --- a/src/racket/src/syntax.c +++ b/src/racket/src/syntax.c @@ -3018,7 +3018,8 @@ static Scheme_Object *make_clones(Scheme_Compiled_Let_Value *retry_start, static int set_code_flags(Scheme_Compiled_Let_Value *retry_start, Scheme_Compiled_Let_Value *pre_body, Scheme_Object *clones, - int set_flags, int mask_flags, int just_tentative) + int set_flags, int mask_flags, int just_tentative, + int merge_flonum) { Scheme_Compiled_Let_Value *clv; Scheme_Object *value, *first; @@ -3035,12 +3036,18 @@ static int set_code_flags(Scheme_Compiled_Let_Value *retry_start, value = clv->value; if (SAME_TYPE(scheme_compiled_unclosed_procedure_type, SCHEME_TYPE(value))) { data = (Scheme_Closure_Data *)value; + + first = SCHEME_CAR(clones); + + if (merge_flonum) { + scheme_merge_closure_flonum_map(data, (Scheme_Closure_Data *)SCHEME_CAR(first)); + scheme_merge_closure_flonum_map(data, (Scheme_Closure_Data *)SCHEME_CDR(first)); + scheme_merge_closure_flonum_map(data, (Scheme_Closure_Data *)SCHEME_CAR(first)); + } if (!just_tentative || (SCHEME_CLOSURE_DATA_FLAGS(data) & CLOS_RESULT_TENTATIVE)) { flags = (flags & SCHEME_CLOSURE_DATA_FLAGS(data)); - first = SCHEME_CAR(clones); - data = (Scheme_Closure_Data *)SCHEME_CDR(first); SCHEME_CLOSURE_DATA_FLAGS(data) = set_flags | (SCHEME_CLOSURE_DATA_FLAGS(data) & mask_flags); data = (Scheme_Closure_Data *)SCHEME_CAR(first); @@ -3611,6 +3618,7 @@ scheme_optimize_lets(Scheme_Object *form, Optimize_Info *info, int for_inline, i (void)set_code_flags(retry_start, pre_body, clones, CLOS_SINGLE_RESULT | CLOS_PRESERVES_MARKS | CLOS_RESULT_TENTATIVE, 0xFFFF, + 0, 0); /* Re-optimize loop: */ clv = retry_start; @@ -3690,11 +3698,12 @@ scheme_optimize_lets(Scheme_Object *form, Optimize_Info *info, int for_inline, i clv = (Scheme_Compiled_Let_Value *)clv->body; } /* Check flags loop: */ - flags = set_code_flags(retry_start, pre_body, clones, 0, 0xFFFF, 0); + flags = set_code_flags(retry_start, pre_body, clones, 0, 0xFFFF, 0, 0); /* Reset-flags loop: */ (void)set_code_flags(retry_start, pre_body, clones, (flags & (CLOS_SINGLE_RESULT | CLOS_PRESERVES_MARKS)), ~(CLOS_SINGLE_RESULT | CLOS_PRESERVES_MARKS | CLOS_RESULT_TENTATIVE), + 1, 1); } retry_start = NULL; diff --git a/src/racket/src/thread.c b/src/racket/src/thread.c index 60a828d734..ed8a2e5ba1 100644 --- a/src/racket/src/thread.c +++ b/src/racket/src/thread.c @@ -206,7 +206,7 @@ HOOK_SHARED_OK void (*scheme_sleep)(float seconds, void *fds); HOOK_SHARED_OK void (*scheme_notify_multithread)(int on); HOOK_SHARED_OK void (*scheme_wakeup_on_input)(void *fds); HOOK_SHARED_OK int (*scheme_check_for_break)(void); -HOOK_SHARED_OK void (*scheme_on_atomic_timeout)(void); +HOOK_SHARED_OK Scheme_On_Atomic_Timeout_Proc scheme_on_atomic_timeout; HOOK_SHARED_OK static int atomic_timeout_auto_suspend; HOOK_SHARED_OK static int atomic_timeout_atomic_level; @@ -214,7 +214,6 @@ THREAD_LOCAL_DECL(struct Scheme_GC_Pre_Post_Callback_Desc *gc_prepost_callback_d ROSYM static Scheme_Object *read_symbol, *write_symbol, *execute_symbol, *delete_symbol, *exists_symbol; ROSYM static Scheme_Object *client_symbol, *server_symbol; -ROSYM static Scheme_Object *froz_key; THREAD_LOCAL_DECL(static int do_atomic = 0); THREAD_LOCAL_DECL(static int missed_context_switch = 0); @@ -380,7 +379,6 @@ static void make_initial_config(Scheme_Thread *p); static int do_kill_thread(Scheme_Thread *p); static void suspend_thread(Scheme_Thread *p); -static void wait_until_suspend_ok(int for_stack); static int check_sleep(int need_activity, int sleep_now); @@ -471,9 +469,6 @@ void scheme_init_thread(Scheme_Env *env) client_symbol = scheme_intern_symbol("client"); server_symbol = scheme_intern_symbol("server"); - REGISTER_SO(froz_key); - froz_key = scheme_make_symbol("frozen"); /* uninterned */ - scheme_add_global_constant("dump-memory-stats", scheme_make_prim_w_arity(scheme_dump_gc_stats, "dump-memory-stats", @@ -3311,10 +3306,6 @@ Scheme_Object *scheme_thread_w_details(Scheme_Object *thunk, if (scheme_is_stack_too_shallow()) { Scheme_Thread *p = scheme_current_thread; - /* Don't mangle the stack if we're in atomic mode, because that - probably means a stack-freeze trampoline, etc. */ - wait_until_suspend_ok(1); - p->ku.k.p1 = thunk; p->ku.k.p2 = config; p->ku.k.p3 = mgr; @@ -3379,7 +3370,7 @@ Scheme_Object *scheme_call_as_nested_thread(int argc, Scheme_Object *argv[], voi SCHEME_USE_FUEL(25); - wait_until_suspend_ok(0); + scheme_wait_until_suspend_ok(); np = MALLOC_ONE_TAGGED(Scheme_Thread); np->so.type = scheme_thread_type; @@ -4051,6 +4042,43 @@ void scheme_break_thread(Scheme_Thread *p) # endif } +static void call_on_atomic_timeout(int must) +{ + Scheme_Thread *p = scheme_current_thread; + int running; + double sleep_end; + int block_descriptor; + Scheme_Object *blocker; + Scheme_Ready_Fun block_check; + Scheme_Needs_Wakeup_Fun block_needs_wakeup; + + /* Save any state that has to do with the thread blocking or + sleeping, in case scheme_on_atomic_timeout() runs Racket code. */ + + running = p->running; + sleep_end = p->sleep_end; + block_descriptor = p->block_descriptor; + blocker = p->blocker; + block_check = p->block_check; + block_needs_wakeup = p->block_needs_wakeup; + + p->running = MZTHREAD_RUNNING; + p->sleep_end = 0.0; + p->block_descriptor = 0; + p->blocker = NULL; + p->block_check = NULL; + p->block_needs_wakeup = NULL; + + scheme_on_atomic_timeout(must); + + p->running = running; + p->sleep_end = sleep_end; + p->block_descriptor = block_descriptor; + p->blocker = blocker; + p->block_check = block_check; + p->block_needs_wakeup = block_needs_wakeup; +} + static void find_next_thread(Scheme_Thread **return_arg) { Scheme_Thread *next; Scheme_Thread *p = scheme_current_thread; @@ -4212,7 +4240,7 @@ void scheme_thread_block(float sleep_time) if ((p->running & MZTHREAD_USER_SUSPENDED) && !(p->running & MZTHREAD_NEED_SUSPEND_CLEANUP)) { /* This thread was suspended. */ - wait_until_suspend_ok(0); + scheme_wait_until_suspend_ok(); if (!p->next) { /* Suspending the main thread... */ select_thread(); @@ -4311,9 +4339,9 @@ void scheme_thread_block(float sleep_time) } #endif -/*####################################*/ -/* THREAD CONTEXT SWITCH HAPPENS HERE */ -/*####################################*/ + /*####################################*/ + /* THREAD CONTEXT SWITCH HAPPENS HERE */ + /*####################################*/ if (next) { /* Swap in `next', but first clear references to other threads. */ @@ -4329,7 +4357,7 @@ void scheme_thread_block(float sleep_time) scheme_fuel_counter = p->engine_weight; scheme_jit_stack_boundary = scheme_stack_boundary; } - scheme_on_atomic_timeout(); + call_on_atomic_timeout(0); if (atomic_timeout_auto_suspend > 1) --atomic_timeout_auto_suspend; } @@ -4360,7 +4388,7 @@ void scheme_thread_block(float sleep_time) /* Suspended while I was asleep? */ if ((p->running & MZTHREAD_USER_SUSPENDED) && !(p->running & MZTHREAD_NEED_SUSPEND_CLEANUP)) { - wait_until_suspend_ok(0); + scheme_wait_until_suspend_ok(); if (!p->next) scheme_thread_block(0.0); /* main thread handled at top of this function */ else @@ -4592,22 +4620,24 @@ void scheme_end_atomic_can_break(void) scheme_check_break_now(); } -static void wait_until_suspend_ok(int for_stack) +int scheme_wait_until_suspend_ok(void) { - if (scheme_on_atomic_timeout && atomic_timeout_auto_suspend) { + int did = 0; + + if (scheme_on_atomic_timeout) { /* new-style atomic timeout */ - if (for_stack) { - /* a stack overflow is ok for the new-style timeout */ - return; - } else if (do_atomic > atomic_timeout_atomic_level) { + if (do_atomic > atomic_timeout_atomic_level) { scheme_log_abort("attempted to wait for suspend in nested atomic mode"); abort(); } } while (do_atomic && scheme_on_atomic_timeout) { - scheme_on_atomic_timeout(); + did = 1; + call_on_atomic_timeout(1); } + + return did; } Scheme_On_Atomic_Timeout_Proc scheme_set_on_atomic_timeout(Scheme_On_Atomic_Timeout_Proc p) @@ -4631,10 +4661,6 @@ void scheme_weak_suspend_thread(Scheme_Thread *r) if (r->running & MZTHREAD_SUSPENDED) return; - if (r == scheme_current_thread) { - wait_until_suspend_ok(0); - } - if (r->prev) { r->prev->next = r->next; r->next->prev = r->prev; @@ -4679,7 +4705,6 @@ void scheme_weak_resume_thread(Scheme_Thread *r) void scheme_about_to_move_C_stack(void) { - wait_until_suspend_ok(1); } static Scheme_Object * @@ -4791,7 +4816,7 @@ void scheme_kill_thread(Scheme_Thread *p) { if (do_kill_thread(p)) { /* Suspend/kill self: */ - wait_until_suspend_ok(0); + scheme_wait_until_suspend_ok(); if (p->suspend_to_kill) suspend_thread(p); else @@ -4921,7 +4946,7 @@ static void suspend_thread(Scheme_Thread *p) p->running |= MZTHREAD_USER_SUSPENDED; } else { if (p == scheme_current_thread) { - wait_until_suspend_ok(0); + scheme_wait_until_suspend_ok(); } p->running |= MZTHREAD_USER_SUSPENDED; scheme_weak_suspend_thread(p); /* ok if p is scheme_current_thread */ @@ -8081,269 +8106,6 @@ void scheme_free_gmp(void *p, void **mem_pool) *mem_pool = SCHEME_CDR(*mem_pool); } -/*========================================================================*/ -/* stack freezer */ -/*========================================================================*/ - -/* When interacting with certain libraries that can lead to Scheme - callbacks, the stack region used by the library should not be - modified by Scheme thread swaps. In that case, the callback must be - constrained. Completely disallowing synchornization with ther - threads or unbounded computation, however, is sometimes too - difficult. A stack-freezer sequence offer a compromise, where the - callback is run as much as possible, but it can be suspended to - allow the library call to return so that normal Scheme-thread - scheduling can resume. The callback is then completed in a normal - scheduling context, where it is no longer specially constrained. - - The call process is - scheme_with_stack_freeze(f, data) - -> f(data) in frozen mode - -> ... frozen_run_some(g, data2) \ - -> Scheme code, may finish or may not | maybe loop - froz->in_progress inicates whether done / - -> continue scheme if not finished - - In this process, it's the call stack between f(data) and the call - to frozen_run_some() that won't be copied in or out until f(data) - returns. - - Nesting scheme_with_stack_freeze() calls should be safe, but it - won't achieve the goal, which is to limit the amount of work done - before returning (because the inner scheme_with_stack_freeze() will - have to run to completion). */ - -static unsigned long get_deeper_base(); - -typedef struct FrozenTramp { - MZTAG_IF_REQUIRED - Scheme_Frozen_Stack_Proc do_f; - void *do_data; - int val; - int in_progress; - int progress_is_resumed; - Scheme_Object *old_param; - Scheme_Config *config; - void *progress_base_addr; - mz_jmp_buf progress_base; - Scheme_Jumpup_Buf_Holder *progress_cont; - int timer_on; - double continue_until; -#ifdef MZ_PRECISE_GC - void *fixup_var_stack_chain; -#endif -} FrozenTramp; - -int scheme_with_stack_freeze(Scheme_Frozen_Stack_Proc wha_f, void *wha_data) -{ - FrozenTramp *froz; - Scheme_Cont_Frame_Data cframe; - Scheme_Object *bx; - int retval; - Scheme_Jumpup_Buf_Holder *pc; - - froz = MALLOC_ONE_RT(FrozenTramp); - SET_REQUIRED_TAG(froz->type = scheme_rt_frozen_tramp); - - bx = scheme_make_raw_pair((Scheme_Object *)froz, NULL); - - scheme_push_continuation_frame(&cframe); - scheme_set_cont_mark(froz_key, bx); - - pc = scheme_new_jmpupbuf_holder(); - froz->progress_cont = pc; - - scheme_init_jmpup_buf(&froz->progress_cont->buf); - - scheme_start_atomic(); - retval = wha_f(wha_data); - froz->val = retval; - - if (froz->in_progress) { - /* We have leftover work; jump and finish it (non-atomically). - But don't swap until we've jumped back in, because the jump-in - point might be trying to suspend the thread (and that should - complete before any swap). */ - scheme_end_atomic_no_swap(); - SCHEME_CAR(bx) = NULL; - froz->in_progress = 0; - froz->progress_is_resumed = 1; - if (!scheme_setjmp(froz->progress_base)) { -#ifdef MZ_PRECISE_GC - froz->fixup_var_stack_chain = &__gc_var_stack__; -#endif - scheme_longjmpup(&froz->progress_cont->buf); - } - } else { - scheme_end_atomic(); - } - - scheme_pop_continuation_frame(&cframe); - - froz->old_param = NULL; - froz->progress_cont = NULL; - froz->do_data = NULL; - - return froz->val; -} - -static void suspend_froz_progress(void) -{ - FrozenTramp * volatile froz; - double msecs; - Scheme_Object *v; - - v = scheme_extract_one_cc_mark(NULL, froz_key); - froz = (FrozenTramp *)SCHEME_CAR(v); - v = NULL; - - msecs = scheme_get_inexact_milliseconds(); - if (msecs < froz->continue_until) - return; - - scheme_on_atomic_timeout = NULL; - - froz->in_progress = 1; - if (scheme_setjmpup(&froz->progress_cont->buf, (void*)froz->progress_cont, froz->progress_base_addr)) { - /* we're back */ - scheme_reset_jmpup_buf(&froz->progress_cont->buf); -#ifdef MZ_PRECISE_GC - /* Base addr points to the last valid gc_var_stack address. - Fixup that link to skip over the part of the stack we're - not using right now. */ - ((void **)froz->progress_base_addr)[0] = froz->fixup_var_stack_chain; - ((void **)froz->progress_base_addr)[1] = NULL; -#endif - } else { - /* we're leaving */ - scheme_longjmp(froz->progress_base, 1); - } -} - -static void froz_run_new(FrozenTramp * volatile froz, int run_msecs) -{ - double msecs; - - /* We're willing to start new work that is specific to this thread */ - froz->progress_is_resumed = 0; - - msecs = scheme_get_inexact_milliseconds(); - froz->continue_until = msecs + run_msecs; - - if (!scheme_setjmp(froz->progress_base)) { - Scheme_Frozen_Stack_Proc do_f; - scheme_start_atomic(); - scheme_on_atomic_timeout = suspend_froz_progress; - atomic_timeout_atomic_level = -1; - do_f = froz->do_f; - do_f(froz->do_data); - } - - if (froz->progress_is_resumed) { - /* we've already returned once; jump out to new progress base */ - scheme_longjmp(froz->progress_base, 1); - } else { - scheme_on_atomic_timeout = NULL; - scheme_end_atomic_no_swap(); - } -} - -static void froz_do_run_new(FrozenTramp * volatile froz, int *iteration, int run_msecs) -{ - /* This function just makes room on the stack, eventually calling - froz_run_new(). */ - int new_iter[32]; - - if (iteration[0] == 3) { -#ifdef MZ_PRECISE_GC - froz->progress_base_addr = (void *)&__gc_var_stack__; -#else - froz->progress_base_addr = (void *)new_iter; -#endif - froz_run_new(froz, run_msecs); - } else { - new_iter[0] = iteration[0] + 1; - froz_do_run_new(froz, new_iter, run_msecs); - } -} - -int scheme_frozen_run_some(Scheme_Frozen_Stack_Proc do_f, void *do_data, int run_msecs) -{ - FrozenTramp * volatile froz; - int more = 0; - Scheme_Object *v; - - v = scheme_extract_one_cc_mark(NULL, froz_key); - if (v) - froz = (FrozenTramp *)SCHEME_CAR(v); - else - froz = NULL; - v = NULL; - - if (froz) { - if (froz->in_progress) { - /* We have work in progress. */ - if ((unsigned long)froz->progress_base_addr < get_deeper_base()) { - /* We have stack space to resume the old work: */ - double msecs; - froz->in_progress = 0; - froz->progress_is_resumed = 1; - msecs = scheme_get_inexact_milliseconds(); - froz->continue_until = msecs + run_msecs; - scheme_start_atomic(); - scheme_on_atomic_timeout = suspend_froz_progress; - atomic_timeout_atomic_level = -1; - if (!scheme_setjmp(froz->progress_base)) { -#ifdef MZ_PRECISE_GC - froz->fixup_var_stack_chain = &__gc_var_stack__; -#endif - scheme_longjmpup(&froz->progress_cont->buf); - } else { - scheme_on_atomic_timeout = NULL; - scheme_end_atomic_no_swap(); - } - } - } else { - int iter[1]; - iter[0] = 0; - froz->do_f = do_f; - froz->do_data = do_data; - froz_do_run_new(froz, iter, run_msecs); - } - - more = froz->in_progress; - } - - return more; -} - -int scheme_is_in_frozen_stack() -{ - Scheme_Object *v; - - v = scheme_extract_one_cc_mark(NULL, froz_key); - if (v) - return 1; - else - return 0; -} - -/* Disable warning for returning address of local variable: */ -#ifdef _MSC_VER -#pragma warning (disable:4172) -#endif - -static unsigned long get_deeper_base() -{ - long here; - unsigned long here_addr = (unsigned long)&here; - return here_addr; -} - -#ifdef _MSC_VER -#pragma warning (default:4172) -#endif - /*========================================================================*/ /* precise GC */ /*========================================================================*/ @@ -8396,7 +8158,6 @@ static void register_traversers(void) GC_REG_TRAV(scheme_rt_evt, mark_evt); GC_REG_TRAV(scheme_rt_syncing, mark_syncing); GC_REG_TRAV(scheme_rt_parameterization, mark_parameterization); - GC_REG_TRAV(scheme_rt_frozen_tramp, mark_frozen_tramp); } END_XFORM_SKIP; diff --git a/src/racket/src/type.c b/src/racket/src/type.c index e46296ab4e..cfac6d9a82 100644 --- a/src/racket/src/type.c +++ b/src/racket/src/type.c @@ -220,7 +220,6 @@ scheme_init_type () set_name(scheme_subprocess_type, ""); set_name(scheme_cpointer_type, ""); - set_name(scheme_offset_cpointer_type, ""); set_name(scheme_wrap_chunk_type, ""); @@ -555,7 +554,6 @@ void scheme_register_traversers(void) GC_REG_TRAV(scheme_flvector_type, flvector_obj); GC_REG_TRAV(scheme_fxvector_type, fxvector_obj); GC_REG_TRAV(scheme_cpointer_type, cpointer_obj); - GC_REG_TRAV(scheme_offset_cpointer_type, offset_cpointer_obj); GC_REG_TRAV(scheme_bucket_type, bucket_obj); diff --git a/src/worksp/build.bat b/src/worksp/build.bat index 9fb9b5846a..c9f5c3defd 100644 --- a/src/worksp/build.bat +++ b/src/worksp/build.bat @@ -8,8 +8,8 @@ cd gc2 ..\..\..\racketcgc -cu make.rkt cd .. -..\..\racket -cu ..\get-libs.rkt core ..\racket ..\..\lib -..\..\racket -cu ..\get-libs.rkt gui ..\gracket ..\..\lib +..\..\racket -cu ..\get-libs.rkt core ..\..\lib +..\..\racket -cu ..\get-libs.rkt gui ..\..\lib cd mzstart devenv mzstart.sln /Build Release diff --git a/src/worksp/gracket/gracket.manifest b/src/worksp/gracket/gracket.manifest index ce0285c16b..23b39027c9 100644 --- a/src/worksp/gracket/gracket.manifest +++ b/src/worksp/gracket/gracket.manifest @@ -1,22 +1,28 @@ - - - -GRacket - Graphical Racket. - - - - - - + + + + GRacket: Graphical Racket. + + + + + + + + diff --git a/src/worksp/gracket/gracket.rc b/src/worksp/gracket/gracket.rc index ff896d291c..cb066c5562 100644 --- a/src/worksp/gracket/gracket.rc +++ b/src/worksp/gracket/gracket.rc @@ -17,8 +17,8 @@ APPLICATION ICON DISCARDABLE "gracket.ico" // VS_VERSION_INFO VERSIONINFO - FILEVERSION 5,0,99,2 - PRODUCTVERSION 5,0,99,2 + FILEVERSION 5,0,99,4 + PRODUCTVERSION 5,0,99,4 FILEFLAGSMASK 0x3fL #ifdef _DEBUG FILEFLAGS 0x1L @@ -36,11 +36,11 @@ BEGIN VALUE "CompanyName", "PLT Scheme Inc.\0" VALUE "FileDescription", "Racket GUI application\0" VALUE "InternalName", "GRacket\0" - VALUE "FileVersion", "5, 0, 99, 2\0" + VALUE "FileVersion", "5, 0, 99, 4\0" VALUE "LegalCopyright", "Copyright 1995-2010\0" VALUE "OriginalFilename", "GRacket.exe\0" VALUE "ProductName", "Racket\0" - VALUE "ProductVersion", "5, 0, 99, 2\0" + VALUE "ProductVersion", "5, 0, 99, 4\0" END END BLOCK "VarFileInfo" diff --git a/src/worksp/mzcom/mzcom.rc b/src/worksp/mzcom/mzcom.rc index 87b2389f2b..ac119f3ac4 100644 --- a/src/worksp/mzcom/mzcom.rc +++ b/src/worksp/mzcom/mzcom.rc @@ -53,8 +53,8 @@ END // VS_VERSION_INFO VERSIONINFO - FILEVERSION 5,0,99,2 - PRODUCTVERSION 5,0,99,2 + FILEVERSION 5,0,99,4 + PRODUCTVERSION 5,0,99,4 FILEFLAGSMASK 0x3fL #ifdef _DEBUG FILEFLAGS 0x1L @@ -70,12 +70,12 @@ BEGIN BLOCK "040904b0" BEGIN VALUE "FileDescription", "MzCOM Module" - VALUE "FileVersion", "5, 0, 99, 2" + VALUE "FileVersion", "5, 0, 99, 4" VALUE "InternalName", "MzCOM" VALUE "LegalCopyright", "Copyright 2000-2010 PLT (Paul Steckler)" VALUE "OriginalFilename", "MzCOM.EXE" VALUE "ProductName", "MzCOM Module" - VALUE "ProductVersion", "5, 0, 99, 2" + VALUE "ProductVersion", "5, 0, 99, 4" END END BLOCK "VarFileInfo" diff --git a/src/worksp/mzcom/mzobj.rgs b/src/worksp/mzcom/mzobj.rgs index 116d19f6a4..21381601aa 100644 --- a/src/worksp/mzcom/mzobj.rgs +++ b/src/worksp/mzcom/mzobj.rgs @@ -1,19 +1,19 @@ HKCR { - MzCOM.MzObj.5.0.99.2 = s 'MzObj Class' + MzCOM.MzObj.5.0.99.4 = s 'MzObj Class' { CLSID = s '{A3B0AF9E-2AB0-11D4-B6D2-0060089002FE}' } MzCOM.MzObj = s 'MzObj Class' { CLSID = s '{A3B0AF9E-2AB0-11D4-B6D2-0060089002FE}' - CurVer = s 'MzCOM.MzObj.5.0.99.2' + CurVer = s 'MzCOM.MzObj.5.0.99.4' } NoRemove CLSID { ForceRemove {A3B0AF9E-2AB0-11D4-B6D2-0060089002FE} = s 'MzObj Class' { - ProgID = s 'MzCOM.MzObj.5.0.99.2' + ProgID = s 'MzCOM.MzObj.5.0.99.4' VersionIndependentProgID = s 'MzCOM.MzObj' ForceRemove 'Programmable' LocalServer32 = s '%MODULE%' diff --git a/src/worksp/racket/racket.manifest b/src/worksp/racket/racket.manifest index 8b66585a1d..9a4905a2bf 100644 --- a/src/worksp/racket/racket.manifest +++ b/src/worksp/racket/racket.manifest @@ -1,22 +1,28 @@ - - - -Racket. - - - - - - + + + + Racket. + + + + + + + + diff --git a/src/worksp/racket/racket.rc b/src/worksp/racket/racket.rc index c47a7e7189..07dcd6cfdb 100644 --- a/src/worksp/racket/racket.rc +++ b/src/worksp/racket/racket.rc @@ -29,8 +29,8 @@ APPLICATION ICON DISCARDABLE "racket.ico" // VS_VERSION_INFO VERSIONINFO - FILEVERSION 5,0,99,2 - PRODUCTVERSION 5,0,99,2 + FILEVERSION 5,0,99,4 + PRODUCTVERSION 5,0,99,4 FILEFLAGSMASK 0x3fL #ifdef _DEBUG FILEFLAGS 0x1L @@ -48,11 +48,11 @@ BEGIN VALUE "CompanyName", "PLT Scheme Inc.\0" VALUE "FileDescription", "Racket application\0" VALUE "InternalName", "Racket\0" - VALUE "FileVersion", "5, 0, 99, 2\0" + VALUE "FileVersion", "5, 0, 99, 4\0" VALUE "LegalCopyright", "Copyright 1995-2010\0" VALUE "OriginalFilename", "racket.exe\0" VALUE "ProductName", "Racket\0" - VALUE "ProductVersion", "5, 0, 99, 2\0" + VALUE "ProductVersion", "5, 0, 99, 4\0" END END BLOCK "VarFileInfo" diff --git a/src/worksp/starters/start.rc b/src/worksp/starters/start.rc index 5fc0b8ae24..5e9c6a4cd2 100644 --- a/src/worksp/starters/start.rc +++ b/src/worksp/starters/start.rc @@ -22,8 +22,8 @@ APPLICATION ICON DISCARDABLE "mzstart.ico" // VS_VERSION_INFO VERSIONINFO - FILEVERSION 5,0,99,2 - PRODUCTVERSION 5,0,99,2 + FILEVERSION 5,0,99,4 + PRODUCTVERSION 5,0,99,4 FILEFLAGSMASK 0x3fL #ifdef _DEBUG FILEFLAGS 0x1L @@ -45,7 +45,7 @@ BEGIN #ifdef MZSTART VALUE "FileDescription", "Racket Launcher\0" #endif - VALUE "FileVersion", "5, 0, 99, 2\0" + VALUE "FileVersion", "5, 0, 99, 4\0" #ifdef MRSTART VALUE "InternalName", "mrstart\0" #endif @@ -60,7 +60,7 @@ BEGIN VALUE "OriginalFilename", "MzStart.exe\0" #endif VALUE "ProductName", "Racket\0" - VALUE "ProductVersion", "5, 0, 99, 2\0" + VALUE "ProductVersion", "5, 0, 99, 4\0" END END BLOCK "VarFileInfo"