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

clean up

Browse Source
This commit is contained in:
Matthew Flatt 2010-10-27 05:23:18 -06:00
parent 4f55d22705
commit d7f1d12ea1
185 changed files with 1323 additions and 1466 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

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

@ -530,18 +530,7 @@ the state transitions / contracts are:
(cond (cond
[(string? default) string?] [(string? default) string?]
[(number? default) number?] [(number? default) number?]
[else (error 'internal-error.set-default "unrecognized default: ~a\n" default)])) [else (error 'internal-error.set-default "unrecognized default: ~a\n" default)])))))])
(preferences:add-callback
name
(λ (p new-value)
(write-resource
font-section
font-entry
(if (and (string? new-value)
(string=? font-default-string new-value))
""
new-value)
font-file))))))])
(for-each (set-default build-font-entry font-default-string string?) (for-each (set-default build-font-entry font-default-string string?)
font-families) font-families)
@ -579,14 +568,7 @@ the state transitions / contracts are:
[message (make-object message% [message (make-object message%
(let ([b (box "")]) (let ([b (box "")])
(if (and (get-resource font-default-string)
font-section
(build-font-entry name)
b)
(not (string=? (unbox b)
"")))
(unbox b)
font-default-string))
horiz)] horiz)]
[button [button
(make-object button% (make-object button%
@ -643,11 +625,7 @@ the state transitions / contracts are:
[size-panel (make-object horizontal-panel% main '(border))] [size-panel (make-object horizontal-panel% main '(border))]
[initial-font-size [initial-font-size
(let ([b (box 0)]) (let ([b (box 0)])
(if (get-resource font-section font-default-size)]
font-size-entry
b)
(unbox b)
font-default-size))]
[size-slider [size-slider
(make-object slider% (make-object slider%
(string-constant font-size-slider-label) (string-constant font-size-slider-label)

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

@ -93,7 +93,6 @@ get-panel-background
get-ps-setup-from-user get-ps-setup-from-user
get-highlight-background-color get-highlight-background-color
get-highlight-text-color get-highlight-text-color
get-resource
get-text-from-user get-text-from-user
get-the-editor-data-class-list get-the-editor-data-class-list
get-the-snip-class-list get-the-snip-class-list
@ -164,7 +163,6 @@ region%
register-collecting-blit register-collecting-blit
scroll-event% scroll-event%
selectable-menu-item<%> selectable-menu-item<%>
send-event
send-message-to-window send-message-to-window
separator-menu-item% separator-menu-item%
sleep/yield sleep/yield
@ -207,5 +205,4 @@ window<%>
write-editor-global-footer write-editor-global-footer
write-editor-global-header write-editor-global-header
write-editor-version write-editor-version
write-resource
yield yield

3
collects/mred/mred.rkt
View File

@ -130,7 +130,6 @@
font-name-directory<%> font-name-directory<%>
get-highlight-background-color get-highlight-background-color
get-highlight-text-color get-highlight-text-color
get-resource
get-the-editor-data-class-list get-the-editor-data-class-list
get-the-snip-class-list get-the-snip-class-list
image-snip% image-snip%
@ -175,12 +174,10 @@
write-editor-global-footer write-editor-global-footer
write-editor-global-header write-editor-global-header
write-editor-version write-editor-version
write-resource
queue-callback queue-callback
yield yield
eventspace-shutdown? eventspace-shutdown?
get-panel-background get-panel-background
send-event
gl-context<%> gl-context<%>
gl-config% gl-config%

300
collects/mred/private/syntax.rkt
View File

@ -1,299 +1,3 @@
#lang scheme/base #lang scheme/base
(require scheme/class (require racket/draw/private/syntax)
scheme/stxparam (provide (all-from-out racket/draw/private/syntax))
(for-syntax scheme/base))
(provide defclass defclass*
def/public def/public-final def/override def/override-final define/top case-args
def/public-unimplemented define-unimplemented
maybe-box? any? bool? nonnegative-real? make-or-false make-box make-list make-alts
make-literal symbol-in integer-in real-in make-procedure
method-name init-name
let-boxes
properties field-properties init-properties
->long
assert)
(define-syntax-parameter class-name #f)
(define-syntax-rule (defclass name super . body)
(defclass* name super () . body))
(define-syntax-rule (defclass* name super intfs . body)
(define name
(syntax-parameterize ([class-name 'name])
(class* super intfs . body))))
(define-syntax (def/public stx)
#`(def/thing define/public #,stx))
(define-syntax (def/public-final stx)
#`(def/thing define/public-final #,stx))
(define-syntax (def/override stx)
#`(def/thing define/override #,stx))
(define-syntax (def/override-final stx)
#`(def/thing define/override-final #,stx))
(define-syntax (define/top stx)
#`(def/thing define #,stx))
(define (method-name class method)
(string->symbol (format "~a in ~a" method class)))
(define (init-name class)
(string->symbol (format "initialization for ~a" class)))
(define-syntax just-id
(syntax-rules ()
[(_ [id default]) id]
[(_ id) id]))
(define-struct named-pred (pred make-name)
#:property prop:procedure (struct-field-index pred))
(define (apply-pred pred val)
(cond
[(procedure? pred) (pred val)]
[(class? pred) (val . is-a? . pred)]
[(interface? pred) (val . is-a? . pred)]
[else (error 'check-arg "unknown predicate type: ~e" pred)]))
(define (make-or-false pred)
(make-named-pred (lambda (v)
(or (not v) (apply-pred pred v)))
(lambda ()
(string-append (predicate-name pred)
" or #f"))))
(define (make-box pred)
(make-named-pred (lambda (v)
(and (box? v) (apply-pred pred (unbox v))))
(lambda ()
(string-append "boxed " (predicate-name pred)))))
(define (make-list pred)
(make-named-pred (lambda (v)
(and (list? v) (andmap (lambda (v) (apply-pred pred v)) v)))
(lambda ()
(string-append "list of " (predicate-name pred)))))
(define (make-alts a b)
(make-named-pred (lambda (v)
(or (apply-pred a v) (apply-pred b v)))
(lambda ()
(string-append (predicate-name a)
" or "
(predicate-name b)))))
(define (make-literal lit)
(make-named-pred (lambda (v) (equal? v lit))
(lambda () (if (symbol? lit)
(format "'~s" lit)
(format "~s" lit)))))
(define (make-symbol syms)
(make-named-pred (lambda (v) (memq v syms))
(lambda ()
(let loop ([syms syms])
(cond
[(null? (cdr syms))
(format "'~s" (car syms))]
[(null? (cddr syms))
(format "'~s, or '~s" (car syms) (cadr syms))]
[else
(format "'~s, ~a" (car syms) (loop (cdr syms)))])))))
(define-syntax-rule (symbol-in sym ...)
(make-symbol '(sym ...)))
(define (integer-in lo hi)
(make-named-pred (lambda (v) (and (exact-integer? v)
(<= lo v hi)))
(lambda ()
(format "exact integer in [~a, ~a]" lo hi))))
(define (real-in lo hi)
(make-named-pred (lambda (v) (and (real? v)
(<= lo v hi)))
(lambda ()
(format "real in [~a, ~a]" lo hi))))
(define (make-procedure arity)
(make-named-pred (lambda (p)
(and (procedure? p)
(procedure-arity-includes? p arity)))
(lambda ()
(format "procedure (arity ~a)" arity))))
(define (check-arg val pred pos)
(if (apply-pred pred val)
#f
(cons (predicate-name pred)
pos)))
(define (predicate-name pred)
(cond
[(named-pred? pred) ((named-pred-make-name pred))]
[(procedure? pred) (let ([s (symbol->string (object-name pred))])
(substring s 0 (sub1 (string-length s))))]
[(or (class? pred) (interface? pred))
(format "~a instance" (object-name pred))]
[else "???"]))
(define maybe-box? (make-named-pred (lambda (v) (or (not v) (box? v)))
(lambda () "box or #f")))
(define (any? v) #t)
(define (bool? v) #t)
(define (nonnegative-real? v) (and (real? v) (v . >= . 0)))
(define (method-of cls nam)
(if cls
(string->symbol (format "~a method of ~a" nam cls))
nam))
(define-syntax (def/thing stx)
(syntax-case stx ()
[(_ define/orig (_ (id [arg-type arg] ...)))
(raise-syntax-error #f "missing body" stx)]
[(_ define/orig (_ (id [arg-type arg] ...) . body))
(with-syntax ([(_ _ orig-stx) stx]
[(pos ...) (for/list ([i (in-range (length (syntax->list #'(arg ...))))])
i)]
[cname (syntax-parameter-value #'class-name)])
(syntax/loc #'orig-stx
(define/orig (id arg ...)
(let ([bad (or (check-arg (just-id arg) arg-type pos)
...)])
(when bad
(raise-type-error (method-of 'cname 'id) (car bad) (cdr bad) (just-id arg) ...)))
(let ()
. body))))]))
(define-for-syntax lifted (make-hash))
(define-syntax (lift-predicate stx)
(syntax-case stx ()
[(_ id) (identifier? #'id) #'id]
[(_ expr)
(let ([d (syntax->datum #'expr)])
(or (hash-ref lifted d #f)
(let ([id (syntax-local-lift-expression #'expr)])
(hash-set! lifted d id)
id)))]))
(define-syntax (case-args stx)
(syntax-case stx ()
[(_ expr [([arg-type arg] ...) rhs ...] ... who)
(with-syntax ([((min-args-len . max-args-len) ...)
(map (lambda (args)
(let ([args (syntax->list args)])
(cons (let loop ([args args])
(if (or (null? args)
(not (identifier? (car args))))
0
(add1 (loop (cdr args)))))
(length args))))
(syntax->list #'((arg ...) ...)))])
#'(let* ([args expr]
[len (length args)])
(find-match
(lambda (next)
(if (and (len . >= . min-args-len)
(len . <= . max-args-len))
(apply
(lambda (arg ...)
(if (and (not (check-arg (just-id arg) (lift-predicate arg-type) 0)) ...)
(lambda () rhs ...)
next))
args)
next))
...
(lambda (next)
(bad-args who args)))))]))
(define (bad-args who args)
(error who "bad argument combination:~a"
(apply string-append (map (lambda (x) (format " ~e" x))
args))))
(define-syntax find-match
(syntax-rules ()
[(_ proc)
((proc #f))]
[(_ proc1 proc ...)
((proc1 (lambda () (find-match proc ...))))]))
(define-syntax-rule (let-boxes ([id init] ...)
call
body ...)
(let ([id (box init)] ...)
call
(let ([id (unbox id)] ...)
body ...)))
(define-syntax (do-properties stx)
(syntax-case stx ()
[(_ define-base check-immutable [[type id] expr] ...)
(let ([ids (syntax->list #'(id ...))])
(with-syntax ([(getter ...)
(map (lambda (id)
(datum->syntax id
(string->symbol
(format "get-~a" (syntax-e id)))
id))
ids)]
[(setter ...)
(map (lambda (id)
(datum->syntax id
(string->symbol
(format "set-~a" (syntax-e id)))
id))
ids)])
#'(begin
(define-base id expr) ...
(define/public (getter) id) ...
(def/public (setter [type v]) (check-immutable 'setter) (set! id (coerce type v))) ...)))]))
(define-syntax coerce
(syntax-rules (bool?)
[(_ bool? v) (and v #t)]
[(_ _ v) v]))
(define-syntax properties
(syntax-rules ()
[(_ #:check-immutable check-immutable . props)
(do-properties define check-immutable . props)]
[(_ . props)
(do-properties define void . props)]))
(define-syntax field-properties
(syntax-rules ()
[(_ #:check-immutable check-immutable . props)
(do-properties define-field check-immutable . props)]
[(_ . props)
(do-properties define-field void . props)]))
(define-syntax-rule (define-field id val) (field [id val]))
(define-syntax init-properties
(syntax-rules ()
[(_ #:check-immutable check-immutable . props)
(do-properties define-init check-immutable . props)]
[(_ . props)
(do-properties define-init void . props)]))
(define-syntax-rule (define-init id val) (begin
(init [(internal id) val])
(define id internal)))
(define (->long i)
(cond
[(eqv? -inf.0 i) (- (expt 2 64))]
[(eqv? +inf.0 i) (expt 2 64)]
[(eqv? +nan.0 i) 0]
[else (inexact->exact (floor i))]))
(define-syntax-rule (assert e) (void))
; (define-syntax-rule (assert e) (unless e (error 'assert "failed: ~s" 'e)))
(define (unimplemented c m args) (error (if c (method-name c m) m) "unimplemented; args were ~e"
args))
(define-syntax (def/public-unimplemented stx)
(syntax-case stx ()
[(_ id)
(with-syntax ([cname (syntax-parameter-value #'class-name)])
#'(define/public (id . args) (unimplemented 'cname 'id args)))]))
(define-syntax-rule (define-unimplemented id)
(define (id . args) (unimplemented #f 'id args)))

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

@ -12,4 +12,5 @@ Allocation rules:
* Other autoreleased objects may end up in the root pool installed by * Other autoreleased objects may end up in the root pool installed by
"pool.rkt". The root pool is periodically destroyed and replaced; "pool.rkt". The root pool is periodically destroyed and replaced;
call `queue-autorelease-flush' if you need to encurage replacement call `queue-autorelease-flush' if you need to encurage replacement
of the pool. of the pool. If you need to use an object htat might be autoflushed,
be sure that you're in atomic mode.

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

@ -4,13 +4,13 @@
ffi/unsafe/define ffi/unsafe/define
ffi/unsafe/alloc ffi/unsafe/alloc
"../../lock.rkt" "../../lock.rkt"
racket/draw/cairo racket/draw/unsafe/cairo
racket/draw/local racket/draw/private/local
racket/draw/gl-context racket/draw/private/gl-context
racket/draw/gl-config racket/draw/private/gl-config
racket/draw/bitmap) racket/draw/private/bitmap)
(provide create-gl-bitmap) (provide (protect-out create-gl-bitmap))
(define agl-lib (define agl-lib
(ffi-lib "/System/Library/Frameworks/AGL.framework/AGL")) (ffi-lib "/System/Library/Frameworks/AGL.framework/AGL"))

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

@ -2,9 +2,9 @@
(require racket/class (require racket/class
ffi/unsafe ffi/unsafe
ffi/unsafe/objc ffi/unsafe/objc
racket/draw/cairo racket/draw/unsafe/cairo
racket/draw/bitmap racket/draw/private/bitmap
racket/draw/local racket/draw/private/local
"types.rkt" "types.rkt"
"utils.rkt" "utils.rkt"
"../../lock.rkt" "../../lock.rkt"

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

@ -1,7 +1,7 @@
#lang scheme/base #lang racket/base
(require ffi/objc (require ffi/unsafe/objc
scheme/foreign ffi/unsafe
scheme/class racket/class
"../../syntax.rkt" "../../syntax.rkt"
"item.rkt" "item.rkt"
"utils.rkt" "utils.rkt"
@ -10,12 +10,11 @@
"window.rkt" "window.rkt"
"../common/event.rkt" "../common/event.rkt"
"image.rkt") "image.rkt")
(unsafe!)
(objc-unsafe!)
(provide button% (provide
core-button% (protect-out button%
MyButton) core-button%
MyButton))
;; ---------------------------------------- ;; ----------------------------------------

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

@ -3,14 +3,15 @@
ffi/unsafe ffi/unsafe
racket/class racket/class
racket/draw racket/draw
racket/draw/gl-context racket/draw/private/gl-context
racket/draw/color racket/draw/private/color
"pool.rkt" "pool.rkt"
"utils.rkt" "utils.rkt"
"const.rkt" "const.rkt"
"types.rkt" "types.rkt"
"window.rkt" "window.rkt"
"dc.rkt" "dc.rkt"
"bitmap.rkt"
"cg.rkt" "cg.rkt"
"queue.rkt" "queue.rkt"
"item.rkt" "item.rkt"
@ -24,7 +25,8 @@
"../../lock.rkt" "../../lock.rkt"
"../common/freeze.rkt") "../common/freeze.rkt")
(provide canvas%) (provide
(protect-out canvas%))
;; ---------------------------------------- ;; ----------------------------------------

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

@ -4,7 +4,7 @@
"types.rkt" "types.rkt"
"utils.rkt") "utils.rkt")
(provide (all-defined-out)) (provide (protect-out (all-defined-out)))
(define _CGContextRef (_cpointer 'CGContextRef)) (define _CGContextRef (_cpointer 'CGContextRef))
(define-appserv CGContextSynchronize (_fun _CGContextRef -> _void)) (define-appserv CGContextSynchronize (_fun _CGContextRef -> _void))

13
collects/mred/private/wx/cocoa/check-box.rkt
View File

@ -1,15 +1,14 @@
#lang scheme/base #lang racket/base
(require ffi/objc (require ffi/unsafe/objc
scheme/foreign ffi/unsafe
scheme/class racket/class
"../../syntax.rkt" "../../syntax.rkt"
"button.rkt" "button.rkt"
"types.rkt" "types.rkt"
"const.rkt") "const.rkt")
(unsafe!)
(objc-unsafe!)
(provide check-box%) (provide
(protect-out check-box%))
;; ---------------------------------------- ;; ----------------------------------------

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

@ -1,7 +1,7 @@
#lang scheme/base #lang racket/base
(require scheme/class (require racket/class
scheme/foreign ffi/unsafe
ffi/objc ffi/unsafe/objc
"../../syntax.rkt" "../../syntax.rkt"
"item.rkt" "item.rkt"
"types.rkt" "types.rkt"
@ -9,10 +9,9 @@
"utils.rkt" "utils.rkt"
"window.rkt" "window.rkt"
"../common/event.rkt") "../common/event.rkt")
(unsafe!)
(objc-unsafe!)
(provide choice%) (provide
(protect-out choice%))
;; ---------------------------------------- ;; ----------------------------------------

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

@ -1,16 +1,17 @@
#lang scheme/base #lang racket/base
(require scheme/class (require racket/class
ffi/unsafe ffi/unsafe
ffi/unsafe/objc ffi/unsafe/objc
"utils.rkt" "utils.rkt"
"types.rkt" "types.rkt"
"image.rkt" "image.rkt"
"../common/bstr.rkt" racket/draw/unsafe/bstr
"../../syntax.rkt" "../../syntax.rkt"
"../../lock.rkt") "../../lock.rkt")
(provide clipboard-driver% (provide
has-x-selection?) (protect-out clipboard-driver%
has-x-selection?))
(import-class NSPasteboard NSArray NSData NSImage NSGraphicsContext) (import-class NSPasteboard NSArray NSData NSImage NSGraphicsContext)
(import-protocol NSPasteboardOwner) (import-protocol NSPasteboardOwner)

5
collects/mred/private/wx/cocoa/colordialog.rkt
View File

@ -2,12 +2,13 @@
(require ffi/unsafe (require ffi/unsafe
ffi/unsafe/objc ffi/unsafe/objc
racket/class racket/class
racket/draw/color racket/draw/private/color
"../../lock.rkt" "../../lock.rkt"
"utils.rkt" "utils.rkt"
"types.rkt") "types.rkt")
(provide get-color-from-user) (provide
(protect-out get-color-from-user))
(import-class NSColorPanel (import-class NSColorPanel
NSColor) NSColor)

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

@ -1,4 +1,4 @@
#lang scheme/base #lang racket/base
(provide (except-out (all-defined-out) <<)) (provide (except-out (all-defined-out) <<))

7
collects/mred/private/wx/cocoa/cursor.rkt
View File

@ -9,9 +9,10 @@
"../common/cursor-draw.rkt" "../common/cursor-draw.rkt"
"../common/local.rkt") "../common/local.rkt")
(provide cursor-driver% (provide
arrow-cursor-handle (protect-out cursor-driver%
get-wait-cursor-handle) arrow-cursor-handle
get-wait-cursor-handle))
(import-class NSCursor) (import-class NSCursor)

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

@ -2,10 +2,10 @@
(require racket/class (require racket/class
ffi/unsafe ffi/unsafe
ffi/unsafe/objc ffi/unsafe/objc
racket/draw/cairo racket/draw/unsafe/cairo
racket/draw/bitmap racket/draw/private/bitmap
racket/draw/local racket/draw/private/local
racket/draw/gl-context racket/draw/private/gl-context
"types.rkt" "types.rkt"
"utils.rkt" "utils.rkt"
"bitmap.rkt" "bitmap.rkt"
@ -15,9 +15,9 @@
"../common/backing-dc.rkt" "../common/backing-dc.rkt"
"cg.rkt") "cg.rkt")
(provide dc% (provide
quartz-bitmap% (protect-out dc%
do-backing-flush) do-backing-flush))
(import-class NSOpenGLContext) (import-class NSOpenGLContext)

7
collects/mred/private/wx/cocoa/dialog.rkt
View File

@ -1,12 +1,13 @@
#lang scheme/base #lang racket/base
(require scheme/class (require racket/class
"../../syntax.rkt" "../../syntax.rkt"
"../common/queue.rkt" "../common/queue.rkt"
"../common/dialog.rkt" "../common/dialog.rkt"
"../../lock.rkt" "../../lock.rkt"
"frame.rkt") "frame.rkt")
(provide dialog%) (provide
(protect-out dialog%))
(define dialog% (define dialog%
(class (dialog-mixin frame%) (class (dialog-mixin frame%)

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

@ -9,7 +9,8 @@
"queue.rkt" "queue.rkt"
"frame.rkt") "frame.rkt")
(provide file-selector) (provide
(protect-out file-selector))
(import-class NSOpenPanel NSSavePanel NSURL NSArray) (import-class NSOpenPanel NSSavePanel NSURL NSArray)

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

@ -4,7 +4,8 @@
"utils.rkt" "utils.rkt"
"types.rkt") "types.rkt")
(provide file-creator-and-type) (provide
(protect-out file-creator-and-type))
(define coreserv-lib (ffi-lib (format "/System/Library/Frameworks/CoreServices.framework/CoreServices"))) (define coreserv-lib (ffi-lib (format "/System/Library/Frameworks/CoreServices.framework/CoreServices")))

3
collects/mred/private/wx/cocoa/font.rkt
View File

@ -8,7 +8,8 @@
"utils.rkt" "utils.rkt"
"types.rkt") "types.rkt")
(provide font->NSFont) (provide
(protect-out font->NSFont))
(import-class NSFont NSFontManager) (import-class NSFont NSFontManager)

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

@ -1,4 +1,4 @@
#lang scheme/base #lang racket/base
(require ffi/unsafe/objc (require ffi/unsafe/objc
ffi/unsafe ffi/unsafe
scheme/class scheme/class
@ -15,9 +15,10 @@
"../common/freeze.rkt" "../common/freeze.rkt"
"../../lock.rkt") "../../lock.rkt")
(provide frame% (provide
location->window (protect-out frame%
get-front) location->window
get-front))
;; ---------------------------------------- ;; ----------------------------------------

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

@ -1,18 +1,17 @@
#lang scheme/base #lang racket/base
(require scheme/class (require racket/class
scheme/foreign ffi/unsafe
racket/math racket/math
ffi/objc ffi/unsafe/objc
"../../syntax.rkt" "../../syntax.rkt"
"item.rkt" "item.rkt"
"types.rkt" "types.rkt"
"const.rkt" "const.rkt"
"utils.rkt" "utils.rkt"
"window.rkt") "window.rkt")
(unsafe!)
(objc-unsafe!)
(provide gauge%) (provide
(protect-out gauge%))
;; ---------------------------------------- ;; ----------------------------------------

7
collects/mred/private/wx/cocoa/gc.rkt
View File

@ -4,9 +4,10 @@
"utils.rkt" "utils.rkt"
"types.rkt") "types.rkt")
(provide scheme_add_gc_callback (provide
scheme_remove_gc_callback (protect-out scheme_add_gc_callback
make-gc-action-desc) scheme_remove_gc_callback
make-gc-action-desc))
(define objc-lib (ffi-lib "libobjc")) (define objc-lib (ffi-lib "libobjc"))

13
collects/mred/private/wx/cocoa/group-panel.rkt
View File

@ -1,16 +1,15 @@
#lang scheme/base #lang racket/base
(require scheme/class (require racket/class
scheme/foreign ffi/unsafe
ffi/objc ffi/unsafe/objc
"../../syntax.rkt" "../../syntax.rkt"
"types.rkt" "types.rkt"
"utils.rkt" "utils.rkt"
"window.rkt" "window.rkt"
"panel.rkt") "panel.rkt")
(unsafe!)
(objc-unsafe!)
(provide group-panel%) (provide
(protect-out group-panel%))
(import-class NSBox) (import-class NSBox)

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

@ -2,9 +2,9 @@
(require ffi/unsafe (require ffi/unsafe
ffi/unsafe/objc ffi/unsafe/objc
racket/class racket/class
racket/draw/cairo racket/draw/unsafe/cairo
racket/draw/local racket/draw/private/local
"../common/bstr.rkt" racket/draw/unsafe/bstr
"utils.rkt" "utils.rkt"
"types.rkt" "types.rkt"
"const.rkt" "const.rkt"
@ -13,8 +13,9 @@
"../../lock.rkt" "../../lock.rkt"
(only-in '#%foreign ffi-callback)) (only-in '#%foreign ffi-callback))
(provide bitmap->image (provide
image->bitmap) (protect-out bitmap->image
image->bitmap))
(import-class NSImage NSGraphicsContext) (import-class NSImage NSGraphicsContext)

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

@ -1,4 +1,4 @@
#lang scheme/base #lang racket/base
(require "pool.rkt" (require "pool.rkt"
"queue.rkt") "queue.rkt")

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

@ -1,17 +1,16 @@
#lang scheme/base #lang racket/base
(require scheme/class (require racket/class
scheme/foreign ffi/unsafe
ffi/objc ffi/unsafe/objc
"../../syntax.rkt" "../../syntax.rkt"
"window.rkt" "window.rkt"
"const.rkt" "const.rkt"
"types.rkt" "types.rkt"
"font.rkt") "font.rkt")
(unsafe!)
(objc-unsafe!)
(provide item% (provide
install-control-font) (protect-out item%
install-control-font))
(import-class NSFont) (import-class NSFont)
(define sys-font (tell NSFont (define sys-font (tell NSFont

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

@ -1,4 +1,4 @@
#lang scheme/base #lang racket/base
(provide map-key-code) (provide map-key-code)

13
collects/mred/private/wx/cocoa/list-box.rkt
View File

@ -1,7 +1,7 @@
#lang scheme/base #lang racket/base
(require ffi/objc (require ffi/unsafe/objc
scheme/foreign ffi/unsafe
scheme/class racket/class
(only-in scheme/list take drop) (only-in scheme/list take drop)
"../../syntax.rkt" "../../syntax.rkt"
"../../lock.rkt" "../../lock.rkt"
@ -12,10 +12,9 @@
"window.rkt" "window.rkt"
"font.rkt" "font.rkt"
"../common/event.rkt") "../common/event.rkt")
(unsafe!)
(objc-unsafe!)
(provide list-box%) (provide
(protect-out list-box%))
;; ---------------------------------------- ;; ----------------------------------------

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

@ -1,4 +1,4 @@
#lang scheme/base #lang racket/base
(require racket/class (require racket/class
ffi/unsafe ffi/unsafe
ffi/unsafe/objc ffi/unsafe/objc
@ -10,8 +10,9 @@
"const.rkt" "const.rkt"
"queue.rkt") "queue.rkt")
(provide menu-bar% (provide
get-menu-bar-height) (protect-out menu-bar%
get-menu-bar-height))
(import-class NSApplication NSMenu NSMenuItem NSProcessInfo NSScreen) (import-class NSApplication NSMenu NSMenuItem NSProcessInfo NSScreen)

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

@ -7,8 +7,9 @@
"types.rkt" "types.rkt"
"const.rkt") "const.rkt")
(provide menu-item% (provide
set-menu-item-shortcut) (protect-out menu-item%
set-menu-item-shortcut))
(import-class NSMenuItem) (import-class NSMenuItem)

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

@ -10,7 +10,8 @@
"window.rkt" "window.rkt"
"menu-item.rkt") "menu-item.rkt")
(provide menu%) (provide
(protect-out menu%))
(import-class NSMenu NSMenuItem) (import-class NSMenu NSMenuItem)

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

@ -1,18 +1,17 @@
#lang scheme/base #lang racket/base
(require scheme/class (require racket/class
scheme/foreign ffi/unsafe
ffi/objc ffi/unsafe/objc
racket/draw/bitmap racket/draw/private/bitmap
"../../syntax.rkt" "../../syntax.rkt"
"window.rkt" "window.rkt"
"item.rkt" "item.rkt"
"utils.rkt" "utils.rkt"
"types.rkt" "types.rkt"
"image.rkt") "image.rkt")
(unsafe!)
(objc-unsafe!)
(provide message%) (provide
(protect-out message%))
;; ---------------------------------------- ;; ----------------------------------------

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

@ -1,16 +1,15 @@
#lang scheme/base #lang racket/base
(require scheme/class (require racket/class
scheme/foreign ffi/unsafe
ffi/objc ffi/unsafe/objc
"../../syntax.rkt" "../../syntax.rkt"
"types.rkt" "types.rkt"
"utils.rkt" "utils.rkt"
"window.rkt") "window.rkt")
(unsafe!)
(objc-unsafe!)
(provide panel% (provide
panel-mixin) (protect-out panel%
panel-mixin))
(import-class NSView) (import-class NSView)

5
collects/mred/private/wx/cocoa/platform.rkt
View File

@ -23,7 +23,7 @@
"tab-panel.rkt" "tab-panel.rkt"
"window.rkt" "window.rkt"
"procs.rkt") "procs.rkt")
(provide platform-values) (provide (protect-out platform-values))
(define (platform-values) (define (platform-values)
(values (values
@ -60,8 +60,6 @@
bell bell
display-size display-size
display-origin display-origin
get-resource
write-resource
flush-display flush-display
fill-private-color fill-private-color
cancel-quit cancel-quit
@ -71,7 +69,6 @@
get-double-click-time get-double-click-time
run-printout run-printout
file-creator-and-type file-creator-and-type
send-event
location->window location->window
shortcut-visible-in-label? shortcut-visible-in-label?
unregister-collecting-blit unregister-collecting-blit

5
collects/mred/private/wx/cocoa/pool.rkt
View File

@ -6,8 +6,9 @@
"const.rkt" "const.rkt"
"types.rkt") "types.rkt")
(provide queue-autorelease-flush (provide
autorelease-flush) (protect-out queue-autorelease-flush
autorelease-flush))
(import-class NSAutoreleasePool) (import-class NSAutoreleasePool)

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

@ -1,23 +1,25 @@
#lang racket/base #lang racket/base
(require racket/class (require racket/class
racket/math racket/math
racket/draw/local racket/draw/private/local
racket/draw/dc racket/draw/private/dc
racket/draw/cairo racket/draw/unsafe/cairo
racket/draw/bitmap racket/draw/private/bitmap
racket/draw/bitmap-dc racket/draw/private/bitmap-dc
racket/draw/record-dc racket/draw/private/record-dc
racket/draw/ps-setup racket/draw/private/ps-setup
ffi/unsafe ffi/unsafe
ffi/unsafe/objc ffi/unsafe/objc
"../../lock.rkt" "../../lock.rkt"
"dc.rkt" "dc.rkt"
"bitmap.rkt"
"cg.rkt" "cg.rkt"
"utils.rkt" "utils.rkt"
"types.rkt") "types.rkt")
(provide printer-dc% (provide
show-print-setup) (protect-out printer-dc%
show-print-setup))
(import-class NSPrintOperation NSView NSGraphicsContext (import-class NSPrintOperation NSView NSGraphicsContext
NSPrintInfo NSDictionary NSPageLayout NSPrintInfo NSDictionary NSPageLayout

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

@ -12,6 +12,7 @@
"filedialog.rkt" "filedialog.rkt"
"colordialog.rkt" "colordialog.rkt"
"dc.rkt" "dc.rkt"
"bitmap.rkt"
"printer-dc.rkt" "printer-dc.rkt"
"../common/printer.rkt" "../common/printer.rkt"
"menu-bar.rkt" "menu-bar.rkt"
@ -26,54 +27,45 @@
(provide (provide
application-file-handler (protect-out
application-quit-handler color-from-user-platform-mode
application-about-handler font-from-user-platform-mode
application-pref-handler get-font-from-user
color-from-user-platform-mode find-graphical-system-path
get-color-from-user register-collecting-blit
font-from-user-platform-mode unregister-collecting-blit
get-font-from-user shortcut-visible-in-label?
get-panel-background run-printout
play-sound get-double-click-time
find-graphical-system-path get-control-font-face
register-collecting-blit get-control-font-size
unregister-collecting-blit get-control-font-size-in-pixels?
shortcut-visible-in-label? cancel-quit
send-event display-origin
file-creator-and-type display-size
run-printout bell
get-double-click-time hide-cursor
get-control-font-face get-display-depth
get-control-font-size is-color-display?
get-control-font-size-in-pixels? id-to-menu-item
cancel-quit can-show-print-setup?
fill-private-color get-highlight-background-color
flush-display get-highlight-text-color
write-resource check-for-break)
get-resource
display-origin
display-size
bell
hide-cursor
get-display-depth
is-color-display?
file-selector
id-to-menu-item
show-print-setup
can-show-print-setup?
get-highlight-background-color
get-highlight-text-color
make-screen-bitmap make-screen-bitmap
make-gl-bitmap make-gl-bitmap
check-for-break) show-print-setup
get-color-from-user
get-panel-background
fill-private-color
flush-display
play-sound
file-creator-and-type
file-selector)
(import-class NSScreen NSCursor) (import-class NSScreen NSCursor)
(define-unimplemented find-graphical-system-path) (define-unimplemented find-graphical-system-path)
(define-unimplemented send-event)
(define-unimplemented write-resource)
(define-unimplemented get-resource)
(define (color-from-user-platform-mode) "Show Picker") (define (color-from-user-platform-mode) "Show Picker")

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

@ -1,8 +1,8 @@
#lang scheme/base #lang racket/base
(require ffi/unsafe/objc (require ffi/unsafe/objc
ffi/unsafe ffi/unsafe
scheme/class racket/class
racket/draw/dc racket/draw/private/dc
"pool.rkt" "pool.rkt"
"utils.rkt" "utils.rkt"
"const.rkt" "const.rkt"
@ -12,21 +12,21 @@
"../../lock.rkt" "../../lock.rkt"
"../common/freeze.rkt") "../common/freeze.rkt")
(provide app (provide
cocoa-start-event-pump (protect-out app
cocoa-install-event-wakeup cocoa-start-event-pump
queue-event cocoa-install-event-wakeup
set-eventspace-hook! set-eventspace-hook!
set-front-hook! set-front-hook!
set-menu-bar-hooks! set-menu-bar-hooks!
post-dummy-event post-dummy-event
try-to-sync-refresh try-to-sync-refresh)
;; from common/queue: ;; from common/queue:
current-eventspace current-eventspace
queue-event queue-event
yield) yield)
(import-class NSApplication NSAutoreleasePool NSColor) (import-class NSApplication NSAutoreleasePool NSColor)
(import-protocol NSApplicationDelegate) (import-protocol NSApplicationDelegate)

13
collects/mred/private/wx/cocoa/radio-box.rkt
View File

@ -1,7 +1,7 @@
#lang scheme/base #lang racket/base
(require scheme/class (require racket/class
scheme/foreign ffi/unsafe
ffi/objc ffi/unsafe/objc
"../../syntax.rkt" "../../syntax.rkt"
"item.rkt" "item.rkt"
"button.rkt" "button.rkt"
@ -11,10 +11,9 @@
"window.rkt" "window.rkt"
"../common/event.rkt" "../common/event.rkt"
"image.rkt") "image.rkt")
(unsafe!)
(objc-unsafe!)
(provide radio-box%) (provide
(protect-out radio-box%))
;; ---------------------------------------- ;; ----------------------------------------

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

@ -1,7 +1,7 @@
#lang scheme/base #lang racket/base
(require scheme/class (require racket/class
scheme/foreign ffi/unsafe
ffi/objc ffi/unsafe/objc
"../../syntax.rkt" "../../syntax.rkt"
"item.rkt" "item.rkt"
"types.rkt" "types.rkt"
@ -12,10 +12,9 @@
"../common/queue.rkt" "../common/queue.rkt"
"../common/freeze.rkt" "../common/freeze.rkt"
"../../lock.rkt") "../../lock.rkt")
(unsafe!)
(objc-unsafe!)
(provide slider%) (provide
(protect-out slider%))
;; ---------------------------------------- ;; ----------------------------------------

3
collects/mred/private/wx/cocoa/sound.rkt
View File

@ -4,7 +4,8 @@
"utils.rkt" "utils.rkt"
"types.rkt") "types.rkt")
(provide play-sound) (provide
(protect-out play-sound))
(import-class NSSound) (import-class NSSound)

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

@ -13,7 +13,8 @@
"../common/procs.rkt" "../common/procs.rkt"
(for-syntax racket/base)) (for-syntax racket/base))
(provide tab-panel%) (provide
(protect-out tab-panel%))
(define-runtime-path psm-tab-bar-dir (define-runtime-path psm-tab-bar-dir
'(so "PSMTabBarControl.framework")) '(so "PSMTabBarControl.framework"))

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

@ -1,20 +1,19 @@
#lang scheme/base #lang racket/base
(require ffi/objc (require ffi/unsafe/objc
scheme/foreign ffi/unsafe
"../../lock.rkt" "../../lock.rkt"
"utils.rkt") "utils.rkt")
(unsafe!)
(objc-unsafe!)
(provide _NSInteger _NSUInteger (provide
_CGFloat (protect-out _NSInteger _NSUInteger
_NSPoint _NSPoint-pointer (struct-out NSPoint) _CGFloat
_NSSize _NSSize-pointer (struct-out NSSize) _NSPoint _NSPoint-pointer (struct-out NSPoint)
_NSRect _NSRect-pointer (struct-out NSRect) _NSSize _NSSize-pointer (struct-out NSSize)
_NSRange _NSRange-pointer (struct-out NSRange) _NSRect _NSRect-pointer (struct-out NSRect)
NSObject _NSRange _NSRange-pointer (struct-out NSRange)
NSString _NSString NSObject
NSNotFound) NSString _NSString
NSNotFound))
(define _NSInteger _long) (define _NSInteger _long)
(define _NSUInteger _ulong) (define _NSUInteger _ulong)

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

@ -1,4 +1,4 @@
#lang scheme/base #lang racket/base
(require ffi/unsafe/objc (require ffi/unsafe/objc
ffi/unsafe ffi/unsafe
ffi/unsafe/alloc ffi/unsafe/alloc
@ -6,22 +6,23 @@
"../common/utils.rkt" "../common/utils.rkt"
"../../lock.rkt") "../../lock.rkt")
(provide cocoa-lib (provide
cf-lib (protect-out cocoa-lib
define-cocoa cf-lib
define-cf define-cocoa
define-appserv define-cf
define-appkit define-appserv
define-mz define-appkit
as-objc-allocation as-objc-allocation
as-objc-allocation-with-retain as-objc-allocation-with-retain
clean-up-deleted clean-up-deleted
retain release retain release
with-autorelease with-autorelease
clean-menu-label clean-menu-label
->wxb ->wxb
->wx ->wx
old-cocoa?) old-cocoa?)
define-mz)
(define cocoa-lib (ffi-lib (format "/System/Library/Frameworks/Cocoa.framework/Cocoa"))) (define cocoa-lib (ffi-lib (format "/System/Library/Frameworks/Cocoa.framework/Cocoa")))
(define cf-lib (ffi-lib (format "/System/Library/Frameworks/CoreFoundation.framework/CoreFoundation"))) (define cf-lib (ffi-lib (format "/System/Library/Frameworks/CoreFoundation.framework/CoreFoundation")))

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

@ -1,7 +1,7 @@
#lang scheme/base #lang racket/base
(require ffi/unsafe/objc (require ffi/unsafe/objc
ffi/unsafe ffi/unsafe
scheme/class racket/class
"queue.rkt" "queue.rkt"
"utils.rkt" "utils.rkt"
"const.rkt" "const.rkt"
@ -17,23 +17,24 @@
"../../syntax.rkt" "../../syntax.rkt"
"../common/freeze.rkt") "../common/freeze.rkt")
(provide window% (provide
(protect-out window%
FocusResponder FocusResponder
KeyMouseResponder KeyMouseResponder
KeyMouseTextResponder KeyMouseTextResponder
CursorDisplayer CursorDisplayer
queue-window-event queue-window-event
queue-window-refresh-event queue-window-refresh-event
queue-window*-event queue-window*-event
request-flush-delay request-flush-delay
cancel-flush-delay cancel-flush-delay
make-init-point make-init-point
flush-display flush-display
special-control-key special-control-key
special-option-key) special-option-key))
(define-local-member-name flip-client) (define-local-member-name flip-client)

40
collects/mred/private/wx/common/backing-dc.rkt
View File

@ -1,25 +1,26 @@
#lang racket/base #lang racket/base
(require racket/class (require racket/class
racket/draw/dc racket/draw/private/dc
racket/draw/bitmap-dc racket/draw/private/bitmap-dc
racket/draw/bitmap racket/draw/private/bitmap
racket/draw/local racket/draw/private/local
"../../lock.rkt" "../../lock.rkt"
"queue.rkt") "queue.rkt")
(provide backing-dc% (provide
(protect-out backing-dc%
;; scoped method names: ;; scoped method names:
get-backing-size get-backing-size
queue-backing-flush queue-backing-flush
on-backing-flush on-backing-flush
start-backing-retained start-backing-retained
end-backing-retained end-backing-retained
reset-backing-retained reset-backing-retained
make-backing-bitmap make-backing-bitmap
request-delay request-delay
cancel-delay cancel-delay
end-delay) end-delay))
(define-local-member-name (define-local-member-name
get-backing-size get-backing-size
@ -35,8 +36,7 @@
(define backing-dc% (define backing-dc%
(class (dc-mixin bitmap-dc-backend%) (class (dc-mixin bitmap-dc-backend%)
(inherit call-with-cr-lock (inherit internal-get-bitmap
internal-get-bitmap
internal-set-bitmap internal-set-bitmap
reset-cr) reset-cr)
@ -87,12 +87,12 @@
(release-backing-bitmap bm))))) (release-backing-bitmap bm)))))
(define/public (start-backing-retained) (define/public (start-backing-retained)
(call-with-cr-lock (as-entry
(lambda () (lambda ()
(set! retained-counter (add1 retained-counter))))) (set! retained-counter (add1 retained-counter)))))
(define/public (end-backing-retained) (define/public (end-backing-retained)
(call-with-cr-lock (as-entry
(lambda () (lambda ()
(if (zero? retained-counter) (if (zero? retained-counter)
(log-error "unbalanced end-on-paint") (log-error "unbalanced end-on-paint")

3
collects/mred/private/wx/common/bstr.rkt
View File

@ -1,3 +0,0 @@
#lang racket/base
(require racket/draw/bstr)
(provide scheme_make_sized_byte_string)

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

@ -3,9 +3,10 @@
racket/draw racket/draw
"backing-dc.rkt") "backing-dc.rkt")
(provide canvas-autoscroll-mixin (provide
canvas-mixin (protect-out canvas-autoscroll-mixin
fix-bitmap-size) canvas-mixin
fix-bitmap-size))
;; Implements canvas autoscroll, applied *before* platform-specific canvas ;; Implements canvas autoscroll, applied *before* platform-specific canvas
;; methods: ;; methods:

9
collects/mred/private/wx/common/clipboard.rkt
View File

@ -5,10 +5,11 @@
"local.rkt" "local.rkt"
"queue.rkt") "queue.rkt")
(provide clipboard<%> (provide
clipboard-client% (protect-out clipboard<%>
get-the-clipboard clipboard-client%
get-the-x-selection) get-the-clipboard
get-the-x-selection))
(defclass clipboard-client% object% (defclass clipboard-client% object%
(define types null) (define types null)

2
collects/mred/private/wx/common/default-procs.rkt
View File

@ -1,6 +1,6 @@
#lang racket/base #lang racket/base
(require racket/class (require racket/class
racket/draw/color) racket/draw/private/color)
(provide special-control-key (provide special-control-key
special-option-key special-option-key
file-creator-and-type file-creator-and-type

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

@ -2,8 +2,9 @@
(require "../../lock.rkt" (require "../../lock.rkt"
"queue.rkt") "queue.rkt")
(provide do-request-flush-delay (provide
do-cancel-flush-delay) (protect-out do-request-flush-delay
do-cancel-flush-delay))
(define (do-request-flush-delay win disable enable) (define (do-request-flush-delay win disable enable)
(atomically (atomically

2
collects/mred/private/wx/common/dialog.rkt
View File

@ -3,7 +3,7 @@
"../../lock.rkt" "../../lock.rkt"
"queue.rkt") "queue.rkt")
(provide dialog-mixin) (provide (protect-out dialog-mixin))
(define dialog-level-counter 0) (define dialog-level-counter 0)

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

@ -1,5 +1,5 @@
#lang scheme/base #lang racket/base
(require scheme/class (require racket/class
"../../syntax.rkt") "../../syntax.rkt")
(provide event% (provide event%

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

@ -1,9 +1,10 @@
#lang scheme/base #lang racket/base
(require ffi/unsafe/try-atomic (require ffi/unsafe/try-atomic
"queue.rkt") "queue.rkt")
(provide call-as-nonatomic-retry-point (provide
constrained-reply) call-as-nonatomic-retry-point
(protect-out constrained-reply))
(define (internal-error str) (define (internal-error str)
(log-error (log-error

11
collects/mred/private/wx/common/handlers.rkt
View File

@ -1,11 +1,12 @@
#lang racket/base #lang racket/base
(provide application-file-handler (provide
application-quit-handler (protect-out application-file-handler
application-about-handler application-quit-handler
application-pref-handler application-about-handler
application-pref-handler
nothing-application-pref-handler) nothing-application-pref-handler))
(define saved-files null) (define saved-files null)
(define afh (lambda (f) (define afh (lambda (f)

6
collects/mred/private/wx/common/local.rkt
View File

@ -1,7 +1,7 @@
#lang scheme/base #lang racket/base
(require scheme/class) (require racket/class)
(provide (all-defined-out)) (provide (protect-out (all-defined-out)))
(define-local-member-name (define-local-member-name
;; clipboard-client%: ;; clipboard-client%:

2
collects/mred/private/wx/common/once.rkt
View File

@ -1,7 +1,7 @@
#lang racket/base #lang racket/base
(require ffi/unsafe) (require ffi/unsafe)
(provide scheme_register_process_global) (provide (protect-out scheme_register_process_global))
;; This module must be instantiated only once: ;; This module must be instantiated only once:

2
collects/mred/private/wx/common/printer.rkt
View File

@ -1,7 +1,7 @@
#lang racket/base #lang racket/base
(require racket/class) (require racket/class)
(provide make-run-printout) (provide (protect-out make-run-printout))
(define ((make-run-printout printer-dc%) (define ((make-run-printout printer-dc%)
parent parent

2
collects/mred/private/wx/common/procs.rkt
View File

@ -1,4 +1,4 @@
#lang scheme/base #lang racket/base
(require "../../syntax.rkt") (require "../../syntax.rkt")
(provide (provide

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

@ -1,6 +1,6 @@
#lang racket/base #lang racket/base
(require ffi/unsafe (require ffi/unsafe
racket/draw/utils racket/draw/private/utils
ffi/unsafe/atomic ffi/unsafe/atomic
racket/class racket/class
"rbtree.rkt" "rbtree.rkt"
@ -8,52 +8,53 @@
"handlers.rkt" "handlers.rkt"
"once.rkt") "once.rkt")
(provide queue-evt (provide
set-check-queue! (protect-out queue-evt
set-queue-wakeup! set-check-queue!
set-queue-wakeup!
add-event-boundary-callback! add-event-boundary-callback!
add-event-boundary-sometimes-callback! add-event-boundary-sometimes-callback!
remove-event-boundary-callback! remove-event-boundary-callback!
pre-event-sync pre-event-sync
boundary-tasks-ready-evt boundary-tasks-ready-evt
eventspace? eventspace?
current-eventspace current-eventspace
queue-event queue-event
queue-refresh-event queue-refresh-event
yield yield
yield-refresh yield-refresh
(rename-out [make-new-eventspace make-eventspace]) (rename-out [make-new-eventspace make-eventspace])
event-dispatch-handler event-dispatch-handler
eventspace-shutdown? eventspace-shutdown?
main-eventspace? main-eventspace?
eventspace-handler-thread eventspace-handler-thread
eventspace-wait-cursor-count eventspace-wait-cursor-count
eventspace-extra-table eventspace-extra-table
eventspace-adjust-external-modal! eventspace-adjust-external-modal!
queue-callback queue-callback
middle-queue-key middle-queue-key
make-timer-callback make-timer-callback
add-timer-callback add-timer-callback
remove-timer-callback remove-timer-callback
register-frame-shown register-frame-shown
get-top-level-windows get-top-level-windows
other-modal? other-modal?
queue-quit-event queue-quit-event
queue-prefs-event queue-prefs-event
queue-file-event queue-file-event
begin-busy-cursor begin-busy-cursor
end-busy-cursor end-busy-cursor
is-busy? is-busy?)
scheme_register_process_global) scheme_register_process_global)
;; ------------------------------------------------------------ ;; ------------------------------------------------------------
;; Create a Scheme evt that is ready when a queue is nonempty ;; Create a Scheme evt that is ready when a queue is nonempty

6
collects/mred/private/wx/common/rbtree.rkt
View File

@ -1,4 +1,4 @@
#lang scheme/base #lang racket/base
;;; red-black-tree.rkt -- Jens Axel S<>gaard and Carl Eastlund -- 3rd nov 2003 ;;; red-black-tree.rkt -- Jens Axel S<>gaard and Carl Eastlund -- 3rd nov 2003
@ -60,8 +60,8 @@
;; SETS IMPLEMENTED AS REB-BLACK TREES. ;; SETS IMPLEMENTED AS REB-BLACK TREES.
(require scheme/match (require racket/match
(for-syntax scheme/base)) (for-syntax racket/base))
(define-match-expander $ (define-match-expander $
(lambda (stx) (lambda (stx)
(syntax-case stx () (syntax-case stx ()

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

@ -1,5 +1,5 @@
#lang scheme/base #lang racket/base
(require scheme/class (require racket/class
"../../syntax.rkt" "../../syntax.rkt"
"../../lock.rkt" "../../lock.rkt"
"queue.rkt") "queue.rkt")

2
collects/mred/private/wx/common/utils.rkt
View File

@ -3,6 +3,6 @@
ffi/unsafe/define ffi/unsafe/define
"once.rkt") "once.rkt")
(provide define-mz) (provide (protect-out define-mz))
(define-ffi-definer define-mz #f) (define-ffi-definer define-mz #f)

12
collects/mred/private/wx/gtk/button.rkt
View File

@ -1,6 +1,6 @@
#lang scheme/base #lang racket/base
(require scheme/foreign (require ffi/unsafe
scheme/class racket/class
"../../syntax.rkt" "../../syntax.rkt"
"../../lock.rkt" "../../lock.rkt"
"item.rkt" "item.rkt"
@ -11,10 +11,10 @@
"pixbuf.rkt" "pixbuf.rkt"
"message.rkt" "message.rkt"
"../common/event.rkt") "../common/event.rkt")
(unsafe!)
(provide button% (provide
button-core%) (protect-out button%
button-core%))
;; ---------------------------------------- ;; ----------------------------------------

7
collects/mred/private/wx/gtk/canvas.rkt
View File

@ -3,8 +3,8 @@
racket/class racket/class
racket/draw racket/draw
ffi/unsafe/alloc ffi/unsafe/alloc
racket/draw/color racket/draw/private/color
racket/draw/local racket/draw/private/local
"../common/backing-dc.rkt" "../common/backing-dc.rkt"
"../common/canvas-mixin.rkt" "../common/canvas-mixin.rkt"
"../../syntax.rkt" "../../syntax.rkt"
@ -22,7 +22,8 @@
"pixbuf.rkt" "pixbuf.rkt"
"gcwin.rkt") "gcwin.rkt")
(provide canvas%) (provide
(protect-out canvas%))
;; ---------------------------------------- ;; ----------------------------------------

10
collects/mred/private/wx/gtk/check-box.rkt
View File

@ -1,14 +1,14 @@
#lang scheme/base #lang racket/base
(require scheme/foreign (require ffi/unsafe
scheme/class racket/class
"../../syntax.rkt" "../../syntax.rkt"
"button.rkt" "button.rkt"
"utils.rkt" "utils.rkt"
"types.rkt" "types.rkt"
"../../lock.rkt") "../../lock.rkt")
(unsafe!)
(provide check-box%) (provide
(protect-out check-box%))
;; ---------------------------------------- ;; ----------------------------------------

10
collects/mred/private/wx/gtk/choice.rkt
View File

@ -1,6 +1,6 @@
#lang scheme/base #lang racket/base
(require scheme/foreign (require ffi/unsafe
scheme/class racket/class
"../../syntax.rkt" "../../syntax.rkt"
"../../lock.rkt" "../../lock.rkt"
"item.rkt" "item.rkt"
@ -10,9 +10,9 @@
"combo.rkt" "combo.rkt"
"../common/event.rkt" "../common/event.rkt"
"../common/queue.rkt") "../common/queue.rkt")
(unsafe!)
(provide choice%) (provide
(protect-out choice%))
;; ---------------------------------------- ;; ----------------------------------------

10
collects/mred/private/wx/gtk/client-window.rkt
View File

@ -1,15 +1,15 @@
#lang scheme/base #lang racket/base
(require scheme/foreign (require ffi/unsafe
scheme/class racket/class
"../../syntax.rkt" "../../syntax.rkt"
"widget.rkt" "widget.rkt"
"window.rkt" "window.rkt"
"utils.rkt" "utils.rkt"
"const.rkt" "const.rkt"
"types.rkt") "types.rkt")
(unsafe!)
(provide client-size-mixin) (provide
(protect-out client-size-mixin))
;; ---------------------------------------- ;; ----------------------------------------

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

@ -2,20 +2,21 @@
(require racket/class (require racket/class
ffi/unsafe ffi/unsafe
ffi/unsafe/alloc ffi/unsafe/alloc
racket/draw/unsafe/bstr
"../../syntax.rkt" "../../syntax.rkt"
"../../lock.rkt" "../../lock.rkt"
"../common/queue.rkt" "../common/queue.rkt"
"../common/local.rkt" "../common/local.rkt"
"../common/bstr.rkt"
"utils.rkt" "utils.rkt"
"types.rkt" "types.rkt"
"pixbuf.rkt") "pixbuf.rkt")
(provide clipboard-driver% (provide
has-x-selection? (protect-out clipboard-driver%
_GtkSelectionData has-x-selection?
gtk_selection_data_get_length _GtkSelectionData
gtk_selection_data_get_data) gtk_selection_data_get_length
gtk_selection_data_get_data))
(define (has-x-selection?) #t) (define (has-x-selection?) #t)

5
collects/mred/private/wx/gtk/colordialog.rkt
View File

@ -1,12 +1,13 @@
#lang racket/base #lang racket/base
(require ffi/unsafe (require ffi/unsafe
racket/class racket/class
racket/draw/color racket/draw/private/color
"types.rkt" "types.rkt"
"utils.rkt" "utils.rkt"
"stddialog.rkt") "stddialog.rkt")
(provide get-color-from-user) (provide
(protect-out get-color-from-user))
(define-gtk gtk_color_selection_dialog_new (_fun _string -> _GtkWidget)) (define-gtk gtk_color_selection_dialog_new (_fun _string -> _GtkWidget))

12
collects/mred/private/wx/gtk/combo.rkt
View File

@ -1,16 +1,16 @@
#lang scheme/base #lang racket/base
(require scheme/foreign (require ffi/unsafe
scheme/class racket/class
"../../syntax.rkt" "../../syntax.rkt"
"types.rkt" "types.rkt"
"utils.rkt" "utils.rkt"
"window.rkt") "window.rkt")
(unsafe!)
;; Hacks for working with GtkComboBox[Entry] ;; Hacks for working with GtkComboBox[Entry]
(provide extract-combo-button (provide
connect-combo-key-and-mouse) (protect-out extract-combo-button
connect-combo-key-and-mouse))
;; ---------------------------------------- ;; ----------------------------------------

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

@ -1,4 +1,4 @@
#lang scheme/base #lang racket/base
(provide (except-out (all-defined-out) <<)) (provide (except-out (all-defined-out) <<))

7
collects/mred/private/wx/gtk/cursor.rkt
View File

@ -8,9 +8,10 @@
"../common/cursor-draw.rkt" "../common/cursor-draw.rkt"
"../../syntax.rkt") "../../syntax.rkt")
(provide cursor-driver% (provide
get-arrow-cursor-handle (protect-out cursor-driver%
get-watch-cursor-handle) get-arrow-cursor-handle
get-watch-cursor-handle))
(define GDK_ARROW 2) ; ugly! (define GDK_ARROW 2) ; ugly!
(define GDK_CROSSHAIR 34) (define GDK_CROSSHAIR 34)

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

@ -9,15 +9,16 @@
"gl-context.rkt" "gl-context.rkt"
"../../lock.rkt" "../../lock.rkt"
"../common/backing-dc.rkt" "../common/backing-dc.rkt"
racket/draw/cairo racket/draw/unsafe/cairo
racket/draw/dc racket/draw/private/dc
racket/draw/bitmap racket/draw/private/bitmap
racket/draw/local racket/draw/private/local
ffi/unsafe/alloc) ffi/unsafe/alloc)
(provide dc% (provide
do-backing-flush (protect-out dc%
x11-bitmap%) do-backing-flush
x11-bitmap%))
(define-gdk gdk_cairo_create (_fun _pointer -> _cairo_t) (define-gdk gdk_cairo_create (_fun _pointer -> _cairo_t)
#:wrap (allocator cairo_destroy)) #:wrap (allocator cairo_destroy))

7
collects/mred/private/wx/gtk/dialog.rkt
View File

@ -1,5 +1,5 @@
#lang scheme/base #lang racket/base
(require scheme/class (require racket/class
ffi/unsafe ffi/unsafe
"../../syntax.rkt" "../../syntax.rkt"
"../common/queue.rkt" "../common/queue.rkt"
@ -9,7 +9,8 @@
"utils.rkt" "utils.rkt"
"frame.rkt") "frame.rkt")
(provide dialog%) (provide
(protect-out dialog%))
(define GTK_WIN_POS_CENTER 1) (define GTK_WIN_POS_CENTER 1)
(define GTK_WIN_POS_CENTER_ON_PARENT 4) (define GTK_WIN_POS_CENTER_ON_PARENT 4)

3
collects/mred/private/wx/gtk/filedialog.rkt
View File

@ -12,7 +12,8 @@
"../common/handlers.rkt" "../common/handlers.rkt"
"../common/queue.rkt") "../common/queue.rkt")
(provide file-selector) (provide
(protect-out file-selector))
(define _GtkFileChooserDialog _GtkWidget) (define _GtkFileChooserDialog _GtkWidget)
(define _GtkFileChooser (_cpointer 'GtkFileChooser)) (define _GtkFileChooser (_cpointer 'GtkFileChooser))

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

@ -1,4 +1,4 @@
#lang scheme/base #lang racket/base
(require ffi/unsafe (require ffi/unsafe
racket/class racket/class
racket/promise racket/promise
@ -17,10 +17,11 @@
"pixbuf.rkt" "pixbuf.rkt"
"../common/queue.rkt") "../common/queue.rkt")
(provide frame% (provide
display-origin (protect-out frame%
display-size display-origin
location->window) display-size
location->window))
;; ---------------------------------------- ;; ----------------------------------------

10
collects/mred/private/wx/gtk/gauge.rkt
View File

@ -1,15 +1,15 @@
#lang scheme/base #lang racket/base
(require scheme/foreign (require ffi/unsafe
scheme/class racket/class
"../../syntax.rkt" "../../syntax.rkt"
"item.rkt" "item.rkt"
"utils.rkt" "utils.rkt"
"types.rkt" "types.rkt"
"window.rkt" "window.rkt"
"const.rkt") "const.rkt")
(unsafe!)
(provide gauge%) (provide
(protect-out gauge%))
;; ---------------------------------------- ;; ----------------------------------------

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

@ -4,11 +4,12 @@
"types.rkt" "types.rkt"
"window.rkt") "window.rkt")
(provide scheme_add_gc_callback (provide
scheme_remove_gc_callback (protect-out scheme_add_gc_callback
create-gc-window scheme_remove_gc_callback
make-gc-show-desc create-gc-window
make-gc-hide-desc) make-gc-show-desc
make-gc-hide-desc))
(define-cstruct _GdkWindowAttr (define-cstruct _GdkWindowAttr
([title _string] ([title _string]

15
collects/mred/private/wx/gtk/gl-context.rkt
View File

@ -3,17 +3,18 @@
ffi/unsafe ffi/unsafe
ffi/unsafe/define ffi/unsafe/define
ffi/unsafe/alloc ffi/unsafe/alloc
(prefix-in draw: racket/draw/gl-context) (prefix-in draw: racket/draw/private/gl-context)
racket/draw/gl-config racket/draw/private/gl-config
"types.rkt" "types.rkt"
"utils.rkt") "utils.rkt")
(provide prepare-widget-gl-context (provide
create-widget-gl-context (protect-out prepare-widget-gl-context
create-widget-gl-context
create-and-install-gl-context create-and-install-gl-context
get-gdk-pixmap get-gdk-pixmap
install-gl-context) install-gl-context))
(define gdkglext-lib (define gdkglext-lib
(with-handlers ([exn:fail? (lambda (exn) #f)]) (with-handlers ([exn:fail? (lambda (exn) #f)])

10
collects/mred/private/wx/gtk/group-panel.rkt
View File

@ -1,6 +1,6 @@
#lang scheme/base #lang racket/base
(require scheme/class (require racket/class
scheme/foreign ffi/unsafe
"../../syntax.rkt" "../../syntax.rkt"
"../../lock.rkt" "../../lock.rkt"
"window.rkt" "window.rkt"
@ -8,9 +8,9 @@
"panel.rkt" "panel.rkt"
"utils.rkt" "utils.rkt"
"types.rkt") "types.rkt")
(unsafe!)
(provide group-panel%) (provide
(protect-out group-panel%))
(define-gtk gtk_frame_new (_fun _string -> _GtkWidget)) (define-gtk gtk_frame_new (_fun _string -> _GtkWidget))
(define-gtk gtk_fixed_new (_fun -> _GtkWidget)) (define-gtk gtk_fixed_new (_fun -> _GtkWidget))

9
collects/mred/private/wx/gtk/init.rkt
View File

@ -1,17 +1,14 @@
#lang scheme/base #lang racket/base
(require scheme/foreign (require ffi/unsafe
"utils.rkt" "utils.rkt"
"types.rkt" "types.rkt"
"queue.rkt") "queue.rkt")
(unsafe!)
(define-gtk gtk_rc_parse_string (_fun _string -> _void)) (define-gtk gtk_rc_parse_string (_fun _string -> _void))
(define-gtk gtk_rc_add_default_file (_fun _path -> _void)) (define-gtk gtk_rc_add_default_file (_fun _path -> _void))
(define-gtk gtk_rc_find_module_in_path (_fun _path -> _path))
(define-gtk gtk_rc_get_module_dir (_fun -> _path))
(when (eq? 'windows (system-type)) (when (eq? 'windows (system-type))
(let ([dir (simplify-path (build-path (collection-path "scheme") 'up 'up "lib"))]) (let ([dir (simplify-path (build-path (collection-path "racket") 'up 'up "lib"))])
(gtk_rc_parse_string (format "module_path \"~a\"\n" dir)) (gtk_rc_parse_string (format "module_path \"~a\"\n" dir))
(gtk_rc_add_default_file (build-path dir "gtkrc")))) (gtk_rc_add_default_file (build-path dir "gtkrc"))))

7
collects/mred/private/wx/gtk/item.rkt
View File

@ -1,14 +1,15 @@
#lang racket/base #lang racket/base
(require ffi/unsafe (require ffi/unsafe
racket/class racket/class
racket/draw/local racket/draw/private/local
"../../syntax.rkt" "../../syntax.rkt"
"window.rkt" "window.rkt"
"utils.rkt" "utils.rkt"
"types.rkt") "types.rkt")
(provide item% (provide
install-control-font) (protect-out item%
install-control-font))
(define _PangoFontDescription _pointer) (define _PangoFontDescription _pointer)
(define-gtk gtk_widget_modify_font (_fun _GtkWidget _PangoFontDescription -> _void)) (define-gtk gtk_widget_modify_font (_fun _GtkWidget _PangoFontDescription -> _void))

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

@ -1,4 +1,4 @@
#lang scheme/base #lang racket/base
(provide map-key-code) (provide map-key-code)

3
collects/mred/private/wx/gtk/keymap.rkt
View File

@ -4,7 +4,8 @@
"const.rkt" "const.rkt"
"types.rkt") "types.rkt")
(provide get-alts) (provide
(protect-out get-alts))
(define _GdkKeymap (_cpointer 'GdkKeymap)) (define _GdkKeymap (_cpointer 'GdkKeymap))

7
collects/mred/private/wx/gtk/list-box.rkt
View File

@ -1,7 +1,7 @@
#lang scheme/base #lang racket/base
(require ffi/unsafe (require ffi/unsafe
ffi/unsafe/define ffi/unsafe/define
scheme/class racket/class
(only-in racket/list take drop) (only-in racket/list take drop)
"../../syntax.rkt" "../../syntax.rkt"
"../../lock.rkt" "../../lock.rkt"
@ -12,7 +12,8 @@
"const.rkt" "const.rkt"
"../common/event.rkt") "../common/event.rkt")
(provide list-box%) (provide
(protect-out list-box%))
;; ---------------------------------------- ;; ----------------------------------------

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

@ -1,6 +1,6 @@
#lang scheme/base #lang racket/base
(require scheme/class (require racket/class
scheme/foreign ffi/unsafe
"../../syntax.rkt" "../../syntax.rkt"
"../../lock.rkt" "../../lock.rkt"
"../common/freeze.rkt" "../common/freeze.rkt"
@ -9,12 +9,12 @@
"window.rkt" "window.rkt"
"utils.rkt" "utils.rkt"
"types.rkt") "types.rkt")
(unsafe!)
(provide menu-bar% (provide
gtk_menu_item_new_with_mnemonic (protect-out menu-bar%
gtk_menu_shell_append gtk_menu_item_new_with_mnemonic
fixup-mneumonic) gtk_menu_shell_append
fixup-mneumonic))
(define-gtk gtk_menu_bar_new (_fun -> _GtkWidget)) (define-gtk gtk_menu_bar_new (_fun -> _GtkWidget))
(define-gtk gtk_menu_shell_append (_fun _GtkWidget _GtkWidget -> _void)) (define-gtk gtk_menu_shell_append (_fun _GtkWidget _GtkWidget -> _void))

7
collects/mred/private/wx/gtk/menu-item.rkt
View File

@ -1,8 +1,9 @@
#lang scheme/base #lang racket/base
(require scheme/class (require racket/class
"../../syntax.rkt") "../../syntax.rkt")
(provide menu-item%) (provide
(protect-out menu-item%))
(defclass menu-item% object% (defclass menu-item% object%
(define/public (id) this) (define/public (id) this)

10
collects/mred/private/wx/gtk/menu.rkt
View File

@ -1,6 +1,6 @@
#lang scheme/base #lang racket/base
(require scheme/class (require racket/class
scheme/foreign ffi/unsafe
"widget.rkt" "widget.rkt"
"window.rkt" "window.rkt"
"../../syntax.rkt" "../../syntax.rkt"
@ -10,9 +10,9 @@
"utils.rkt" "utils.rkt"
"menu-bar.rkt" "menu-bar.rkt"
"../common/event.rkt") "../common/event.rkt")
(unsafe!)
(provide menu%) (provide
(protect-out menu%))
(define-gtk gtk_menu_new (_fun -> _GtkWidget)) (define-gtk gtk_menu_new (_fun -> _GtkWidget))
(define-gtk gtk_check_menu_item_new_with_mnemonic (_fun _string -> _GtkWidget)) (define-gtk gtk_check_menu_item_new_with_mnemonic (_fun _string -> _GtkWidget))

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

@ -1,18 +1,18 @@
#lang scheme/base #lang racket/base
(require scheme/class (require racket/class
scheme/foreign ffi/unsafe
"../../syntax.rkt" "../../syntax.rkt"
"item.rkt" "item.rkt"
"utils.rkt" "utils.rkt"
"types.rkt" "types.rkt"
"pixbuf.rkt") "pixbuf.rkt")
(unsafe!)
(provide message% (provide
(protect-out message%
gtk_label_new_with_mnemonic gtk_label_new_with_mnemonic
gtk_label_set_text_with_mnemonic gtk_label_set_text_with_mnemonic
mnemonic-string) mnemonic-string))
;; ---------------------------------------- ;; ----------------------------------------

9
collects/mred/private/wx/gtk/panel.rkt
View File

@ -1,5 +1,5 @@
#lang scheme/base #lang racket/base
(require scheme/class (require racket/class
ffi/unsafe ffi/unsafe
"../../syntax.rkt" "../../syntax.rkt"
"../../lock.rkt" "../../lock.rkt"
@ -8,8 +8,9 @@
"types.rkt" "types.rkt"
"const.rkt") "const.rkt")
(provide panel% (provide
panel-mixin) (protect-out panel%
panel-mixin))
(define-gtk gtk_fixed_new (_fun -> _GtkWidget)) (define-gtk gtk_fixed_new (_fun -> _GtkWidget))
(define-gtk gtk_event_box_new (_fun -> _GtkWidget)) (define-gtk gtk_event_box_new (_fun -> _GtkWidget))

19
collects/mred/private/wx/gtk/pixbuf.rkt
View File

@ -1,22 +1,23 @@
#lang racket #lang racket/base
(require racket/class (require racket/class
ffi/unsafe ffi/unsafe
ffi/unsafe/alloc ffi/unsafe/alloc
racket/draw racket/draw
racket/draw/local racket/draw/private/local
racket/draw/cairo racket/draw/unsafe/cairo
"../../lock.rkt" "../../lock.rkt"
"../common/bstr.rkt" racket/draw/unsafe/bstr
"utils.rkt" "utils.rkt"
"types.rkt" "types.rkt"
(only-in '#%foreign ffi-callback)) (only-in '#%foreign ffi-callback))
(provide bitmap->pixbuf (provide
pixbuf->bitmap (protect-out bitmap->pixbuf
pixbuf->bitmap
_GdkPixbuf _GdkPixbuf
gtk_image_new_from_pixbuf gtk_image_new_from_pixbuf
release-pixbuf) release-pixbuf))
(define _GdkPixbuf (_cpointer/null 'GdkPixbuf)) (define _GdkPixbuf (_cpointer/null 'GdkPixbuf))

8
collects/mred/private/wx/gtk/platform.rkt
View File

@ -1,4 +1,4 @@
#lang scheme/base #lang racket/base
(require "init.rkt" (require "init.rkt"
"button.rkt" "button.rkt"
"canvas.rkt" "canvas.rkt"
@ -23,7 +23,8 @@
"tab-panel.rkt" "tab-panel.rkt"
"window.rkt" "window.rkt"
"procs.rkt") "procs.rkt")
(provide platform-values) (provide
(protect-out platform-values))
(define (platform-values) (define (platform-values)
(values (values
@ -60,8 +61,6 @@
bell bell
display-size display-size
display-origin display-origin
get-resource
write-resource
flush-display flush-display
fill-private-color fill-private-color
cancel-quit cancel-quit
@ -71,7 +70,6 @@
get-double-click-time get-double-click-time
run-printout run-printout
file-creator-and-type file-creator-and-type
send-event
location->window location->window
shortcut-visible-in-label? shortcut-visible-in-label?
unregister-collecting-blit unregister-collecting-blit

19
collects/mred/private/wx/gtk/printer-dc.rkt
View File

@ -1,12 +1,12 @@
#lang racket/base #lang racket/base
(require racket/class (require racket/class
racket/draw/local racket/draw/private/local
racket/draw/dc racket/draw/private/dc
racket/draw/cairo racket/draw/unsafe/cairo
racket/draw/bitmap racket/draw/private/bitmap
racket/draw/bitmap-dc racket/draw/private/bitmap-dc
racket/draw/record-dc racket/draw/private/record-dc
racket/draw/ps-setup racket/draw/private/ps-setup
ffi/unsafe ffi/unsafe
ffi/unsafe/alloc ffi/unsafe/alloc
"../common/queue.rkt" "../common/queue.rkt"
@ -14,8 +14,9 @@
"utils.rkt" "utils.rkt"
"types.rkt") "types.rkt")
(provide printer-dc% (provide
show-print-setup) (protect-out printer-dc%
show-print-setup))
(define GTK_UNIT_POINTS 1) (define GTK_UNIT_POINTS 1)

73
collects/mred/private/wx/gtk/procs.rkt
View File

@ -20,52 +20,47 @@
"../common/handlers.rkt") "../common/handlers.rkt")
(provide (provide
special-control-key (protect-out
special-option-key color-from-user-platform-mode
get-color-from-user get-font-from-user
color-from-user-platform-mode font-from-user-platform-mode
get-font-from-user play-sound
font-from-user-platform-mode find-graphical-system-path
get-panel-background register-collecting-blit
play-sound unregister-collecting-blit
find-graphical-system-path shortcut-visible-in-label?
register-collecting-blit run-printout
unregister-collecting-blit get-double-click-time
shortcut-visible-in-label? get-control-font-face
location->window get-control-font-size
send-event get-control-font-size-in-pixels?
file-creator-and-type cancel-quit
run-printout bell
get-double-click-time hide-cursor
get-control-font-face get-display-depth
get-control-font-size is-color-display?
get-control-font-size-in-pixels? id-to-menu-item
cancel-quit can-show-print-setup?
fill-private-color get-highlight-background-color
flush-display get-highlight-text-color
write-resource check-for-break)
get-resource file-selector
show-print-setup
display-origin display-origin
display-size display-size
bell flush-display
hide-cursor location->window
get-display-depth
is-color-display?
file-selector
id-to-menu-item
show-print-setup
can-show-print-setup?
get-highlight-background-color
get-highlight-text-color
make-screen-bitmap make-screen-bitmap
make-gl-bitmap make-gl-bitmap
check-for-break) file-creator-and-type
special-control-key
special-option-key
get-panel-background
fill-private-color
get-color-from-user)
(define-unimplemented find-graphical-system-path) (define-unimplemented find-graphical-system-path)
(define-unimplemented send-event)
(define-unimplemented cancel-quit) (define-unimplemented cancel-quit)
(define-unimplemented write-resource)
(define-unimplemented get-resource)
(define-unimplemented play-sound) (define-unimplemented play-sound)

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

@ -10,12 +10,9 @@
"w32.rkt" "w32.rkt"
"unique.rkt") "unique.rkt")
(provide gtk-start-event-pump (provide (protect-out gtk-start-event-pump
try-to-sync-refresh
try-to-sync-refresh set-widget-hook!)
set-widget-hook!
;; from common/queue: ;; from common/queue:
current-eventspace current-eventspace
queue-event queue-event

10
collects/mred/private/wx/gtk/radio-box.rkt
View File

@ -1,6 +1,6 @@
#lang scheme/base #lang racket/base
(require scheme/class (require racket/class
scheme/foreign ffi/unsafe
"../../syntax.rkt" "../../syntax.rkt"
"item.rkt" "item.rkt"
(except-in "utils.rkt" _GSList) (except-in "utils.rkt" _GSList)
@ -11,9 +11,9 @@
"message.rkt" "message.rkt"
"../common/event.rkt" "../common/event.rkt"
"../../lock.rkt") "../../lock.rkt")
(unsafe!)
(provide radio-box%) (provide
(protect-out radio-box%))
;; ---------------------------------------- ;; ----------------------------------------

10
collects/mred/private/wx/gtk/slider.rkt
View File

@ -1,6 +1,6 @@
#lang scheme/base #lang racket/base
(require scheme/foreign (require ffi/unsafe
scheme/class racket/class
"../../syntax.rkt" "../../syntax.rkt"
"item.rkt" "item.rkt"
"utils.rkt" "utils.rkt"
@ -9,9 +9,9 @@
"const.rkt" "const.rkt"
"../common/event.rkt" "../common/event.rkt"
"../../lock.rkt") "../../lock.rkt")
(unsafe!)
(provide slider%) (provide
(protect-out slider%))
;; ---------------------------------------- ;; ----------------------------------------

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