diff --git a/collects/mred/private/mrtop.rkt b/collects/mred/private/mrtop.rkt index 4b18d545ba..b07ae72cd8 100644 --- a/collects/mred/private/mrtop.rkt +++ b/collects/mred/private/mrtop.rkt @@ -139,6 +139,8 @@ [do-set-status-text (lambda (s) (when status-message (send status-message set-label s)))]) + (override + [get-client-handle (lambda () (send wx-panel get-client-handle))]) (sequence (super-init (lambda () (set! wx (mk-wx finish)) wx) (lambda () wx-panel) (lambda () mid-panel) diff --git a/collects/mred/private/mrwindow.rkt b/collects/mred/private/mrwindow.rkt index 2a4c4a1bed..324d5b155f 100644 --- a/collects/mred/private/mrwindow.rkt +++ b/collects/mred/private/mrwindow.rkt @@ -116,7 +116,7 @@ get-client-size get-size get-width get-height get-x get-y get-cursor set-cursor popup-menu show is-shown? on-superwindow-show refresh - get-handle)) + get-handle get-client-handle)) (define-keywords window%-keywords [enabled #t]) @@ -173,6 +173,7 @@ [get-plain-label (lambda () (and (string? label) (wx:label->plain-label label)))] [get-handle (lambda () (send wx get-handle))] + [get-client-handle (lambda () (send wx get-client-handle))] [accept-drop-files (entry-point diff --git a/collects/mred/private/wx/cocoa/window.rkt b/collects/mred/private/wx/cocoa/window.rkt index 80ce551aaf..9ac7418efa 100644 --- a/collects/mred/private/wx/cocoa/window.rkt +++ b/collects/mred/private/wx/cocoa/window.rkt @@ -727,6 +727,7 @@ (send (get-parent) end-no-cursor-rects)) (define/public (get-handle) (get-cocoa)) + (define/public (get-client-handle) (get-cocoa-content)) (define/public (popup-menu m x y) (send m do-popup (get-cocoa-content) (get-cocoa-window) x (flip-client y) diff --git a/collects/mred/private/wx/gtk/window.rkt b/collects/mred/private/wx/gtk/window.rkt index b878609dce..ac71b3aa2f 100644 --- a/collects/mred/private/wx/gtk/window.rkt +++ b/collects/mred/private/wx/gtk/window.rkt @@ -612,6 +612,7 @@ (define/public (on-drop-file path) (void)) (define/public (get-handle) (get-gtk)) + (define/public (get-client-handle) (get-client-gtk)) (define/public (popup-menu m x y) (let ([gx (box x)] diff --git a/collects/mred/private/wx/win32/window.rkt b/collects/mred/private/wx/win32/window.rkt index 67dbfd65e6..f5eade66f1 100644 --- a/collects/mred/private/wx/win32/window.rkt +++ b/collects/mred/private/wx/win32/window.rkt @@ -249,6 +249,7 @@ (define/public (on-set-focus) (void)) (define/public (on-kill-focus) (void)) (define/public (get-handle) hwnd) + (define/public (get-client-handle) (get-client-hwnd)) (define enabled? #t) (define parent-enabled? #t) diff --git a/collects/mzlib/private/shared-body.rkt b/collects/mzlib/private/shared-body.rkt index 73a9f807a3..72ac6ca9c1 100644 --- a/collects/mzlib/private/shared-body.rkt +++ b/collects/mzlib/private/shared-body.rkt @@ -41,21 +41,29 @@ [ph-used?s (map (lambda (x) (box #f)) names)] [struct-decl-for (lambda (id) (and (identifier? id) - (let* ([s (symbol->string (syntax-e id))] - [m (regexp-match-positions "make-" s)]) - (and m - (let ([name (datum->syntax - id - (string->symbol (string-append (substring s 0 (caar m)) - (substring s (cdar m) (string-length s)))) - id)]) - (let ([v (syntax-local-value name (lambda () #f))]) - (and v - (struct-declaration-info? v) - (let ([decl (extract-struct-info v)]) + (let ([get-struct + (lambda (id) + (let ([v (syntax-local-value id (lambda () #f))]) + (and v + (struct-declaration-info? v) + (let ([decl (extract-struct-info v)]) (and (cadr decl) (andmap values (list-ref decl 4)) - decl)))))))))] + decl)))))]) + (or (get-struct id) + (let ([s (syntax-property id 'constructor-for)]) + (and s + (identifier? s) + (get-struct s))) + (let* ([s (symbol->string (syntax-e id))] + [m (regexp-match-positions "make-" s)]) + (and m + (let ([name (datum->syntax + id + (string->symbol (string-append (substring s 0 (caar m)) + (substring s (cdar m) (string-length s)))) + id)]) + (get-struct name))))))))] [append-ids null] [same-special-id? (lambda (a b) ;; Almost module-or-top-identifier=?, diff --git a/collects/racket/private/define-struct.rkt b/collects/racket/private/define-struct.rkt index 74a87d7280..8875f8748f 100644 --- a/collects/racket/private/define-struct.rkt +++ b/collects/racket/private/define-struct.rkt @@ -44,7 +44,9 @@ (datum->syntax orig (syntax-e orig) stx orig)) (syntax-case stx () [(self arg ...) (datum->syntax stx - (cons (transfer-srcloc orig #'self) + (cons (syntax-property (transfer-srcloc orig #'self) + 'constructor-for + (syntax-local-introduce #'self)) (syntax-e (syntax (arg ...)))) stx stx)] diff --git a/collects/scribblings/gui/window-intf.scrbl b/collects/scribblings/gui/window-intf.scrbl index c54f830b77..3c3645b89f 100644 --- a/collects/scribblings/gui/window-intf.scrbl +++ b/collects/scribblings/gui/window-intf.scrbl @@ -81,6 +81,25 @@ Note that under X, keyboard focus can move to the menu bar } +@defmethod[(get-client-handle) cpointer?]{ + +Returns a handle to the ``inside'' of the window for the current +platform's GUI toolbox. The value that the pointer represents depends +on the platform: + +@itemize[ + + @item{Windows: @tt{HWND}} + + @item{Mac OS X: @tt{NSView}} + + @item{X: @tt{GtkWidget}} + +] + +See also @method[window<%> get-handle].} + + @defmethod[(get-client-size) (values (integer-in 0 10000) (integer-in 0 10000))]{ @@ -107,9 +126,10 @@ Returns the window's cursor, or @scheme[#f] if this window's cursor } + @defmethod[(get-handle) cpointer?]{ -Returns a handle to the window for the current platform's GUI +Returns a handle to the ``outside'' of the window for the current platform's GUI toolbox. The value that the pointer represents depends on the platform: @@ -124,7 +144,7 @@ platform: ] -} +See also @method[window<%> get-client-handle].} @defmethod[(get-height)