diff --git a/collects/mred/mred.ss b/collects/mred/mred.ss index 20679b01..cb899da8 100644 --- a/collects/mred/mred.ss +++ b/collects/mred/mred.ss @@ -4668,7 +4668,7 @@ "Copy Message" m (lambda (i e) - (send wx:the-clipboard + (send (wx:get-the-clipboard) set-clipboard-string message (send e get-time-stamp)))) @@ -5726,14 +5726,6 @@ style-delta% style-list% tab-snip% - the-brush-list - the-clipboard - the-color-database - the-font-list - the-font-name-directory - the-editor-wordbreak-map - the-pen-list - the-style-list timer% write-editor-global-footer write-editor-global-header @@ -5743,6 +5735,15 @@ eventspace-shutdown? get-panel-background) +(define the-color-database (wx:get-the-color-database)) +(define the-font-name-directory (wx:get-the-font-name-directory)) +(define the-clipboard (wx:get-the-clipboard)) +(define the-font-list (wx:get-the-font-list)) +(define the-pen-list (wx:get-the-pen-list)) +(define the-brush-list (wx:get-the-brush-list)) +(define the-style-list (wx:get-the-style-list)) +(define the-editor-wordbreak-map (wx:get-the-editor-wordbreak-map)) + (provide button% canvas% check-box% @@ -5813,7 +5814,14 @@ sleep/yield get-window-text-extent get-family-builtin-face - send-message-to-window) + send-message-to-window + the-editor-wordbreak-map + the-brush-list + the-color-database + the-font-name-directory + the-pen-list + the-font-list + the-style-list) ) ;; end of module diff --git a/collects/mred/private/kernel.ss b/collects/mred/private/kernel.ss index fd5a1bc6..053d5e46 100644 --- a/collects/mred/private/kernel.ss +++ b/collects/mred/private/kernel.ss @@ -1,5 +1,5 @@ -;; Generated by xctocc +;; kernel.ss is generated by xctocc (module kernel mzscheme (require (all-except (lib "class.ss") object%)) @@ -9,47 +9,21 @@ (define kernel:initialize-primitive-object (dynamic-require '#%mred-kernel 'initialize-primitive-object)) - (define kernel:primitive-object->class - (dynamic-require '#%mred-kernel 'primitive-object->class)) (define kernel:find-in-primitive-class (dynamic-require '#%mred-kernel 'find-in-primitive-class)) (define kernel:primitive-class->method-name-list (dynamic-require '#%mred-kernel 'primitive-class->method-name-list)) (define kernel:primitive-class->method-vector (dynamic-require '#%mred-kernel 'primitive-class->method-vector)) + (define kernel:primitive-class->struct-type + (dynamic-require '#%mred-kernel 'primitive-class->struct-type)) + (define kernel:primitive-class-prepare-struct-type! + (dynamic-require '#%mred-kernel 'primitive-class-prepare-struct-type!)) + (define kernel:dispatcher-property + (dynamic-require '#%mred-kernel 'dispatcher-property)) - (define kernel:make-primitive-object - (dynamic-require '#%mred-kernel 'make-primitive-object)) - (define kernel:primitive-object? - (dynamic-require '#%mred-kernel 'primitive-object?)) - (define kernel:primitive-object-size - (dynamic-require '#%mred-kernel 'primitive-object-size)) - (define kernel:primitive-object-ref - (dynamic-require '#%mred-kernel 'primitive-object-ref)) - (define kernel:primitive-object-set! - (dynamic-require '#%mred-kernel 'primitive-object-set!)) - ;; (require (prefix kernel: #%mred-kernel)) - (install-prim-functions kernel:primitive-object? - (lambda (o) - (= 2 (kernel:primitive-object-size o))) - (lambda (o) - (kernel:primitive-object-ref o 0)) - (lambda (o) - (kernel:primitive-object-ref o 1)) - (lambda (prim-class c s lkup) - (let ([o (kernel:make-primitive-object - prim-class - 2 - lkup)]) - (kernel:primitive-object-set! o 0 c) - (kernel:primitive-object-set! o 1 s) - o)) - kernel:initialize-primitive-object - kernel:primitive-object->class - kernel:find-in-primitive-class) - (define (find-method class name) (let loop ([l (kernel:primitive-class->method-name-list class)][p 0]) (if (eq? name (car l)) @@ -116,8 +90,11 @@ [(new ...) (datum->syntax new #f #f)]) (syntax (define name (let ([c (dynamic-require '#%mred-kernel 'name)]) + (kernel:primitive-class-prepare-struct-type! c prop:object) (make-prim-class - c + (kernel:primitive-class->struct-type c) + kernel:dispatcher-property + kernel:initialize-primitive-object 'name super '(old ...) '(new ...) @@ -537,7 +514,6 @@ get-family) (define-class font-list% object% find-or-create-font) - (define-constant the-font-list) (define-class color% object% blue green @@ -547,7 +523,6 @@ copy-from) (define-private-class color-database% color-database<%> object% find-color) - (define-constant the-color-database) (define-class point% object% get-x set-x @@ -562,7 +537,6 @@ get-color) (define-class brush-list% object% find-or-create-brush) - (define-constant the-brush-list) (define-class pen% object% set-style get-style @@ -578,7 +552,6 @@ get-width) (define-class pen-list% object% find-or-create-pen) - (define-constant the-pen-list) (define-class cursor% object% ok?) (define-class region% object% @@ -603,7 +576,11 @@ set-screen-name get-post-script-name get-screen-name) - (define-constant the-font-name-directory) + (define-function get-the-font-name-directory) + (define-function get-the-font-list) + (define-function get-the-pen-list) + (define-function get-the-brush-list) + (define-function get-the-color-database) (define-function fill-private-color) (define-function flush-display) (define-function yield) @@ -726,7 +703,7 @@ (define-class editor-wordbreak-map% object% get-map set-map) - (define-constant the-editor-wordbreak-map) + (define-function get-the-editor-wordbreak-map) (define-class text% editor% call-clickback remove-clickback @@ -936,7 +913,7 @@ get-clipboard-client set-clipboard-string set-clipboard-client) - (define-constant the-clipboard) + (define-function get-the-clipboard) (define-class clipboard-client% object% get-types add-type @@ -1394,7 +1371,7 @@ find-or-create-style number basic-style) - (define-constant the-style-list) + (define-function get-the-style-list) ;; Functions defined in wxscheme.cxx (define-functions @@ -1427,5 +1404,6 @@ set-menu-tester location->window set-dialogs) + ) ;; end