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

Merge branch 'master' of pltgit:plt into in-vector

Browse Source
This commit is contained in:
Noel Welsh 2010-12-03 10:27:34 +00:00
commit 6761ae8618
408 changed files with 7808 additions and 4885 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

4
collects/2htdp/image.rkt
View File

@ -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)

23
collects/2htdp/private/image-more.rkt
View File

@ -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

35
collects/2htdp/private/world.rkt
View File

@ -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

46
collects/2htdp/tests/test-image.rkt
View File

@ -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))

2
collects/2htdp/universe.rkt
View File

@ -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)

4
collects/data/gvector.rkt
View File

@ -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)

57
collects/data/queue.rkt
View File

@ -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]))

32
collects/data/scribblings/queue.scrbl
View File

@ -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?]

60
collects/deinprogramm/DMdA.rkt
View File

@ -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")

5
collects/deinprogramm/signature/signature-syntax.rkt
View File

@ -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))

2
collects/drracket/drracket.filetypes
View File

@ -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"

6
collects/drracket/private/app.rkt
View File

@ -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)
=>

52
collects/drracket/private/main.rkt
View File

@ -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))
(λ ()

83
collects/drracket/private/rep.rkt
View File

@ -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)

138
collects/drracket/private/syncheck/traversals.rkt
View File

@ -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

8
collects/drracket/private/unit.rkt
View File

@ -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)))])

157
collects/ffi/unsafe.rkt
View File

@ -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

15
collects/ffi/unsafe/objc.rkt
View File

@ -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))

8
collects/ffi/unsafe/try-atomic.rkt
View File

@ -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)))

13
collects/file/convertible.rkt Normal file
View File

@ -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))

53
collects/file/scribblings/convertible.scrbl Normal file
View File

@ -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].}

1
collects/file/scribblings/file.scrbl
View File

@ -5,6 +5,7 @@
@table-of-contents[]
@include-section["convertible.scrbl"]
@include-section["gzip.scrbl"]
@include-section["gunzip.scrbl"]
@include-section["zip.scrbl"]

93
collects/framework/preferences.rkt
View File

@ -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?)

84
collects/framework/private/frame.rkt
View File

@ -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%))

10
collects/framework/private/preferences.rkt
View File

@ -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

21
collects/framework/private/text.rkt
View File

@ -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))

2
collects/framework/splash.rkt
View File

@ -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%

3
collects/lang/private/signature-syntax.rkt
View File

@ -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))

81
collects/lang/private/teachprims.rkt
View File

@ -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)

23
collects/lazy/lazy.rkt
View File

@ -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))

23
collects/macro-debugger/syntax-browser/image.rkt
View File

@ -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)))

2
collects/macro-debugger/syntax-browser/keymap.rkt
View File

@ -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

54
collects/macro-debugger/syntax-browser/text.rkt
View File

@ -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))))

23
collects/macro-debugger/syntax-browser/widget.rkt
View File

@ -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))))

8
collects/meta/build/build
View File

@ -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"

2
collects/meta/build/bundle
View File

@ -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))))

14
collects/meta/build/versionpatch
View File

@ -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"'")

2
collects/meta/check-dists.rkt
View File

@ -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

7
collects/meta/checker.rkt
View File

@ -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*

7
collects/meta/dist-specs.rkt
View File

@ -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)))
;; ============================================================================

1
collects/meta/drdr/config.rkt
View File

@ -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)

4
collects/meta/drdr/dirstruct.rkt
View File

@ -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?)]

48
collects/meta/drdr/plt-build.rkt
View File

@ -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

5
collects/meta/props
View File

@ -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

6
collects/meta/web/common/links.rkt
View File

@ -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})

76
collects/meta/web/stubs/git.rkt
View File

@ -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:}

12
collects/meta/web/stubs/wiki.rkt
View File

@ -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}}}"))

2
collects/meta/web/www/learning.rkt
View File

@ -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}

1
collects/mred/mred-sig.rkt
View File

@ -143,6 +143,7 @@ open-output-text-editor
pane%
panel%
pasteboard%
pdf-dc%
pen%
pen-list%
play-sound

10
collects/mred/private/mritem.rkt
View File

@ -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

2
collects/mred/private/mrtop.rkt
View File

@ -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

2
collects/mred/private/wx/cocoa/README.txt
View File

@ -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

81
collects/mred/private/wx/cocoa/button.rkt
View File

@ -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)

26
collects/mred/private/wx/cocoa/canvas.rkt
View File

@ -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

17
collects/mred/private/wx/cocoa/dc.rkt
View File

@ -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)))

34
collects/mred/private/wx/cocoa/filedialog.rkt
View File

@ -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))

10
collects/mred/private/wx/cocoa/finfo.rkt
View File

@ -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)]))

56
collects/mred/private/wx/cocoa/frame.rkt
View File

@ -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))))))

10
collects/mred/private/wx/cocoa/item.rkt
View File

@ -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))

16
collects/mred/private/wx/cocoa/menu-bar.rkt
View File

@ -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)

37
collects/mred/private/wx/cocoa/menu-item.rkt
View File

@ -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 ""))))

2
collects/mred/private/wx/cocoa/menu.rkt
View File

@ -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)

6
collects/mred/private/wx/cocoa/message.rkt
View File

@ -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)

12
collects/mred/private/wx/cocoa/panel.rkt
View File

@ -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)

16
collects/mred/private/wx/cocoa/printer-dc.rkt
View File

@ -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)))))))

11
collects/mred/private/wx/cocoa/procs.rkt
View File

@ -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

41
collects/mred/private/wx/cocoa/queue.rkt
View File

@ -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)

37
collects/mred/private/wx/cocoa/tab-panel.rkt
View File

@ -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?)))

4
collects/mred/private/wx/cocoa/types.rkt
View File

@ -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)

13
collects/mred/private/wx/cocoa/utils.rkt
View File

@ -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))

234
collects/mred/private/wx/cocoa/window.rkt
View File

@ -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)))
;; ----------------------------------------

2
collects/mred/private/wx/common/canvas-mixin.rkt
View File

@ -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

26
collects/mred/private/wx/common/delay.rkt
View File

@ -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))))))

56
collects/mred/private/wx/common/event.rkt
View File

@ -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]))

4
collects/mred/private/wx/common/freeze.rkt
View File

@ -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")

19
collects/mred/private/wx/common/queue.rkt
View File

@ -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)

146
collects/mred/private/wx/gtk/clipboard.rkt
View File

@ -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)))))

2
collects/mred/private/wx/gtk/frame.rkt
View File

@ -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)

11
collects/mred/private/wx/gtk/message.rkt
View File

@ -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))

13
collects/mred/private/wx/gtk/queue.rkt
View File

@ -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 ()

15
collects/mred/private/wx/gtk/types.rkt
View File

@ -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]

29
collects/mred/private/wx/gtk/utils.rkt
View File

@ -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)

53
collects/mred/private/wx/win32/canvas.rkt
View File

@ -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))

2
collects/mred/private/wx/win32/const.rkt
View File

@ -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)

6
collects/mred/private/wx/win32/dialog.rkt
View File

@ -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)))

14
collects/mred/private/wx/win32/frame.rkt
View File

@ -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)

14
collects/mred/private/wx/win32/window.rkt
View File

@ -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))

9
collects/mred/private/wxme/snip.rkt
View File

@ -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%)])

43
collects/mred/private/wxme/text.rkt
View File

@ -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

83
collects/mred/private/wxtextfield.rkt
View File

@ -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))

2
collects/mred/private/wxtop.rkt
View File

@ -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]

26
collects/mrlib/image-core.rkt
View File

@ -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)]))

10
collects/mrlib/private/image-core-bitmap.rkt
View File

@ -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)

41
collects/mzlib/private/contract-object.rkt
View File

@ -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)))

102
collects/net/cgi-unit.rkt
View File

@ -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)

3
collects/net/scribblings/websocket.scrbl
View File

@ -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].

16
collects/net/websocket/server.rkt
View File

@ -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))

4
collects/openssl/mzssl.rkt
View File

@ -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

12
collects/openssl/openssl.scrbl
View File

@ -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?]

5
collects/plai/mutator.rkt
View File

@ -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)

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