From f28752dc6ea3398e2911a87471f0004ef8718702 Mon Sep 17 00:00:00 2001 From: Matthew Flatt Date: Tue, 29 May 2001 07:39:38 +0000 Subject: [PATCH] . original commit: 00b1c9279c1dc8b088868f48142352f2743649cb --- collects/mred/mred.ss | 123 +++++++++++++++--------- collects/mred/private/kernel.ss | 165 ++++++++++++++++---------------- 2 files changed, 159 insertions(+), 129 deletions(-) diff --git a/collects/mred/mred.ss b/collects/mred/mred.ss index 7f6f6e3f..a9529731 100644 --- a/collects/mred/mred.ss +++ b/collects/mred/mred.ss @@ -1863,9 +1863,35 @@ (define pasteboard% (class100 (make-editor-buffer% wx:pasteboard% #f (lambda () pasteboard%)) args (sequence (apply super-init args)))) -(define editor-snip% (class100 wx:editor-snip% ([edit #f] . args) - (sequence - (apply super-init (or edit (make-object text%)) args)))) +(define editor-snip% (class100 wx:editor-snip% ([editor #f] + [with-border? #t] + [left-margin 5] + [top-margin 5] + [right-margin 5] + [bottom-margin 5] + [left-inset 1] + [top-inset 1] + [right-inset 1] + [bottom-inset 1] + [min-width 'none] + [max-width 'none] + [min-height 'none] + [max-height 'none]) + (sequence + (super-init (or editor (make-object text%)) + with-border? + left-margin + top-margin + right-margin + bottom-margin + left-inset + top-inset + right-inset + bottom-inset + min-width + max-width + min-height + max-height)))) (wx:set-editor-snip-maker (lambda args (apply make-object editor-snip% args))) (wx:set-text-editor-maker (lambda () (make-object text%))) @@ -3344,15 +3370,15 @@ label parent #f)))))) (define radio-box% - (class100 basic-control% (label chcs parent callback [style '(vertical)]) - (private-field [choices chcs]) + (class100 basic-control% (label choices parent callback [style '(vertical)]) + (private-field [chcs choices]) (sequence (let ([cwho '(constructor radio-box)]) (check-string/false cwho label) - (unless (and (list? choices) (pair? choices) - (or (andmap string? choices) - (andmap (lambda (x) (is-a? x wx:bitmap%)) choices))) - (raise-type-error (who->name cwho) "non-empty list of strings or bitmap% objects" choices)) + (unless (and (list? chcs) (pair? chcs) + (or (andmap string? chcs) + (andmap (lambda (x) (is-a? x wx:bitmap%)) chcs))) + (raise-type-error (who->name cwho) "non-empty list of strings or bitmap% objects" chcs)) (check-container-parent cwho parent) (check-callback cwho callback) (check-orientation cwho style) @@ -3363,7 +3389,7 @@ [check-button (lambda (method n) (check-non-negative-integer `(method radio-box% ,method) n) - (unless (< n (length choices)) + (unless (< n (length chcs)) (raise-mismatch-error (who->name `(method radio-box% ,method)) "no such button: " n)))]) (override [enable (entry-point @@ -3377,13 +3403,13 @@ [(which) (check-button 'is-enabled? which) (send wx is-enabled? which)]))]) (public - [get-number (lambda () (length choices))] + [get-number (lambda () (length chcs))] [get-item-label (lambda (n) (check-button 'get-item-label n) - (list-ref choices n))] + (list-ref chcs n))] [get-item-plain-label (lambda (n) (check-button 'get-item-plain-label n) - (wx:label->plain-label (list-ref choices n)))] + (wx:label->plain-label (list-ref chcs n)))] [get-selection (entry-point (lambda () (send wx get-selection)))] [set-selection (entry-point @@ -3393,26 +3419,26 @@ (sequence (as-entry (lambda () - (when (andmap string? choices) - (set! choices (map string->immutable-string choices))) + (when (andmap string? chcs) + (set! chcs (map string->immutable-string chcs))) (super-init (lambda () (set! wx (make-object wx-radio-box% this this (mred->wx-container parent) (wrap-callback callback) - label -1 -1 -1 -1 choices 0 style)) + label -1 -1 -1 -1 chcs 0 style)) wx) label parent #f)))))) (define slider% - (class100 basic-control% (label minv maxv parent callback [value min-val] [style '(horizontal)]) - (private-field [min-val minv][max-val maxv]) + (class100 basic-control% (label min-value max-value parent callback [init-value min-value] [style '(horizontal)]) + (private-field [minv min-value][maxv max-value]) (sequence (let ([cwho '(constructor slider)]) (check-string/false cwho label) - (check-slider-integer cwho min-val) - (check-slider-integer cwho max-val) + (check-slider-integer cwho minv) + (check-slider-integer cwho maxv) (check-container-parent cwho parent) (check-callback cwho callback) - (check-slider-integer cwho value) + (check-slider-integer cwho init-value) (check-style cwho '(vertical horizontal) '(plain) style) (check-container-ready cwho parent))) (private-field @@ -3422,10 +3448,10 @@ [set-value (entry-point (lambda (v) (check-slider-integer '(method slider% set-value) v) - (unless (<= min-val v max-val) + (unless (<= minv v maxv) (raise-mismatch-error (who->name '(method slider% set-value)) (format "slider's range is ~a to ~a; cannot set the value to: " - min-val max-val) + minv maxv) v)) (send wx set-value v)))]) (sequence @@ -3434,7 +3460,7 @@ (super-init (lambda () (set! wx (make-object wx-slider% this this (mred->wx-container parent) (wrap-callback callback) - label value min-val max-val style)) + label init-value minv maxv style)) wx) label parent #f)))))) @@ -3605,13 +3631,13 @@ label parent)))) (define text-field% - (class100* basic-control% () (label parent callback [init-val ""] [style '(single)]) + (class100* basic-control% () (label parent callback [init-value ""] [style '(single)]) (sequence (let ([cwho '(constructor text-field)]) (check-string/false cwho label) (check-container-parent cwho parent) (check-callback cwho callback) - (check-string cwho init-val) + (check-string cwho init-value) (check-style cwho '(single multiple) '(hscroll) style) (check-container-ready cwho parent))) (private-field @@ -3629,7 +3655,7 @@ (super-init (lambda () (set! wx (make-object wx-text-field% this this (mred->wx-container parent) (wrap-callback callback) - label init-val style)) + label init-value style)) wx) label parent ibeam)))))) @@ -3666,8 +3692,9 @@ (super-init (lambda () (set! wx (mk-wx)) wx) (lambda () wx) #f parent #f)))))) (define canvas% - (class100 basic-canvas% (parent [style null]) - (inherit get-client-size) + (class100 basic-canvas% (parent [style null] [paint-callback (lambda (dc) (void))]) + (private-field [paint-cb paint-callback]) + (inherit get-client-size get-dc) (sequence (let ([cwho '(constructor canvas)]) (check-container-parent cwho parent) @@ -3745,6 +3772,8 @@ [set-scroll-range (entry-point (lambda (d v) (send wx set-scroll-range d v)))] [get-scroll-page (entry-point (lambda (d) (send wx get-scroll-page d)))] [set-scroll-page (entry-point (lambda (d v) (send wx set-scroll-page d v)))]) + (override + [on-paint (lambda () (paint-cb (get-dc)))]) (private-field [wx #f]) (sequence @@ -3895,8 +3924,8 @@ (send (send wx area-parent) add-child wx))) (send parent after-new-child this))))) -(define vertical-panel% (class100 panel% args (sequence (apply super-init args)))) -(define horizontal-panel% (class100 panel% args (sequence (apply super-init args)))) +(define vertical-panel% (class100 panel% (parent [style null]) (sequence (super-init parent style)))) +(define horizontal-panel% (class100 panel% (parent [style null]) (sequence (super-init parent style)))) ;;;;;;;;;;;;;;;;;;;;;; Menu classes ;;;;;;;;;;;;;;;;;;;;;; @@ -4108,15 +4137,15 @@ (interface (labelled-menu-item<%>) get-menu)) (define separator-menu-item% - (class100* mred% (menu-item<%>) (prnt) - (sequence (menu-parent-only 'separator-menu-item prnt)) + (class100* mred% (menu-item<%>) (parent) + (sequence (menu-parent-only 'separator-menu-item parent)) (private-field - [parent prnt] + [prnt parent] [wx #f] [shown? #f] [wx-parent #f]) (public - [get-parent (lambda () parent)] + [get-parent (lambda () prnt)] [restore (entry-point (lambda () (unless shown? @@ -4133,7 +4162,7 @@ (as-entry (lambda () (set! wx (make-object wx-menu-item% this #f)) - (set! wx-parent (send (mred->wx parent) get-container)) + (set! wx-parent (send (mred->wx prnt) get-container)) (super-init wx))) (restore)))) @@ -4332,17 +4361,17 @@ (super-init label #f menu callback shortcut help-string (lambda (x) x))))) (define checkable-menu-item% - (class100 basic-selectable-menu-item% (label mnu callback [shortcut #f] [help-string #f]) + (class100 basic-selectable-menu-item% (label menu callback [shortcut #f] [help-string #f]) (sequence - (check-shortcut-args 'checkable-menu-item label mnu callback shortcut help-string)) + (check-shortcut-args 'checkable-menu-item label menu callback shortcut help-string)) (private-field - [menu mnu] + [mnu menu] [wx #f]) (public - [check (entry-point (lambda (on?) (send (send (mred->wx menu) get-container) check (send wx id) on?)))] - [is-checked? (entry-point (lambda () (send (send (mred->wx menu) get-container) checked? (send wx id))))]) + [check (entry-point (lambda (on?) (send (send (mred->wx mnu) get-container) check (send wx id) on?)))] + [is-checked? (entry-point (lambda () (send (send (mred->wx mnu) get-container) checked? (send wx id))))]) (sequence - (super-init label #t menu callback shortcut help-string (lambda (x) (set! wx x) x))))) + (super-init label #t mnu callback shortcut help-string (lambda (x) (set! wx x) x))))) (define menu-item-container<%> (interface () get-items on-demand)) (define internal-menu<%> (interface ())) @@ -4409,15 +4438,15 @@ (super-init wx)))))) (define menu-bar% - (class100* mred% (menu-item-container<%>) (prnt) - (sequence (barless-frame-parent prnt)) + (class100* mred% (menu-item-container<%>) (parent) + (sequence (barless-frame-parent parent)) (private-field - [parent prnt] + [prnt parent] [wx #f] [wx-parent #f] [shown? #f]) (public - [get-frame (lambda () parent)] + [get-frame (lambda () prnt)] [get-items (entry-point (lambda () (send wx get-items)))] [enable (entry-point (lambda (on?) (send wx enable-all on?)))] [is-enabled? (entry-point (lambda () (send wx all-enabled?)))] @@ -4429,7 +4458,7 @@ (as-entry (lambda () (set! wx (make-object wx-menu-bar% this)) - (set! wx-parent (mred->wx parent)) + (set! wx-parent (mred->wx prnt)) (super-init wx) (send wx-parent set-menu-bar wx) (send wx-parent self-redraw-request)))))) diff --git a/collects/mred/private/kernel.ss b/collects/mred/private/kernel.ss index b389dd52..834c43fa 100644 --- a/collects/mred/private/kernel.ss +++ b/collects/mred/private/kernel.ss @@ -1,5 +1,6 @@ -;; kernel.ss is generated by xctocc +;; The parts of kernel.ss are generated by xctocc. +;; kernel.ss is generated by a target in /mred/wxs/Makefile. (module kernel mzscheme (require (all-except (lib "class.ss") object%)) @@ -48,7 +49,7 @@ (let ([defined null]) (lambda (stx) (syntax-case stx () - [(_ name super id ...) + [(_ name super args id ...) (let ([nm (syntax-e (syntax name))] [sn (syntax-e (syntax super))] [ids (map syntax-e (syntax->list (syntax (id ...))))]) @@ -83,7 +84,7 @@ (kernel:primitive-class-prepare-struct-type! c prop:object class dispatcher)) kernel:initialize-primitive-object - 'name super + 'name super 'args '(old ...) '(new ...) (list @@ -96,23 +97,23 @@ (define-syntax define-class (lambda (stx) (syntax-case stx () - [(_ name super id ...) + [(_ name super args id ...) (syntax (begin - (define-a-class name super id ...) + (define-a-class name super args id ...) (provide name)))]))) (define-syntax define-private-class (lambda (stx) (syntax-case stx () - [(_ name intf super id ...) + [(_ name intf super args id ...) (syntax (begin - (define-a-class name super id ...) + (define-a-class name super args id ...) (define intf (class->interface name)) (provide intf)))]))) - (define-class object% #f) - (define-class window% object% + (define-class object% #f #f) + (define-class window% object% #f on-drop-file pre-on-event pre-on-char @@ -144,11 +145,11 @@ set-focus gets-focus? centre) - (define-class item% window% + (define-class item% window% #f set-label get-label command) - (define-class message% item% + (define-class message% item% #f set-label on-drop-file pre-on-event @@ -156,7 +157,7 @@ on-size on-set-focus on-kill-focus) - (define-private-class editor% editor<%> object% + (define-private-class editor% editor<%> object% #f dc-location-to-editor-location editor-location-to-dc-location set-inactive-caret-threshold @@ -284,7 +285,7 @@ (define-function read-editor-global-header) (define-function set-editor-print-margin) (define-function get-editor-print-margin) - (define-class bitmap% object% + (define-class bitmap% object% #f save-file load-file is-color? @@ -292,7 +293,7 @@ get-width get-height get-depth) - (define-class button% item% + (define-class button% item% #f set-label on-drop-file pre-on-event @@ -300,7 +301,7 @@ on-size on-set-focus on-kill-focus) - (define-class choice% item% + (define-class choice% item% #f get-string set-string-selection set-selection @@ -316,7 +317,7 @@ on-size on-set-focus on-kill-focus) - (define-class check-box% item% + (define-class check-box% item% #f set-label set-value get-value @@ -326,7 +327,7 @@ on-size on-set-focus on-kill-focus) - (define-class canvas% window% + (define-class canvas% window% #f on-drop-file pre-on-event pre-on-char @@ -352,7 +353,7 @@ on-char on-event on-paint) - (define-private-class dc% dc<%> object% + (define-private-class dc% dc<%> object% #f end-page end-doc start-page @@ -397,30 +398,30 @@ draw-point draw-line clear) - (define-class bitmap-dc% dc% + (define-class bitmap-dc% dc% () get-bitmap set-bitmap set-pixel get-pixel) - (define-class post-script-dc% dc%) - (define-class printer-dc% dc%) - (define-class event% object% + (define-class post-script-dc% dc% ([interactive? #t] [parent #f])) + (define-class printer-dc% dc% ([parent #f])) + (define-class event% object% () get-time-stamp set-time-stamp) - (define-class control-event% event% + (define-class control-event% event% (event-type) get-event-type set-event-type) - (define-class popup-event% control-event% + (define-class popup-event% control-event% () get-menu-id set-menu-id) - (define-class scroll-event% event% + (define-class scroll-event% event% () get-event-type set-event-type get-direction set-direction get-position set-position) - (define-class key-event% event% + (define-class key-event% event% () get-key-code set-key-code get-shift-down @@ -435,7 +436,7 @@ set-x get-y set-y) - (define-class mouse-event% event% + (define-class mouse-event% event% (event-type) moving? leaving? entering? @@ -463,7 +464,7 @@ set-x get-y set-y) - (define-class frame% window% + (define-class frame% window% #f on-drop-file pre-on-event pre-on-char @@ -485,7 +486,7 @@ set-icon iconize set-title) - (define-class gauge% item% + (define-class gauge% item% #f get-value set-value get-range @@ -496,7 +497,7 @@ on-size on-set-focus on-kill-focus) - (define-class font% object% + (define-class font% object% #f get-font-id get-underlined get-weight @@ -504,32 +505,32 @@ get-style get-face get-family) - (define-class font-list% object% + (define-class font-list% object% #f find-or-create-font) - (define-class color% object% + (define-class color% object% #f blue green red set ok? copy-from) - (define-private-class color-database% color-database<%> object% + (define-private-class color-database% color-database<%> object% #f find-color) - (define-class point% object% + (define-class point% object% #f get-x set-x get-y set-y) - (define-class brush% object% + (define-class brush% object% #f set-style get-style set-stipple get-stipple set-color get-color) - (define-class brush-list% object% + (define-class brush-list% object% #f find-or-create-brush) - (define-class pen% object% + (define-class pen% object% #f set-style get-style set-stipple @@ -542,11 +543,11 @@ get-cap set-width get-width) - (define-class pen-list% object% + (define-class pen-list% object% #f find-or-create-pen) - (define-class cursor% object% + (define-class cursor% object% #f ok?) - (define-class region% object% + (define-class region% object% (dc) is-empty? get-bounding-box subtract @@ -558,7 +559,7 @@ set-rounded-rectangle set-rectangle get-dc) - (define-private-class font-name-directory% font-name-directory<%> object% + (define-private-class font-name-directory% font-name-directory<%> object% #f find-family-default-font-id find-or-create-font-id get-family @@ -588,7 +589,7 @@ (define-function get-display-depth) (define-function is-color-display?) (define-function file-selector) - (define-class list-box% item% + (define-class list-box% item% #f set-string get-string set-string-selection @@ -615,7 +616,7 @@ on-size on-set-focus on-kill-focus) - (define-class editor-canvas% canvas% + (define-class editor-canvas% canvas% #f on-char on-event on-paint @@ -635,7 +636,7 @@ is-focus-on? get-editor set-editor) - (define-class editor-admin% object% + (define-class editor-admin% object% #f refresh-delayed? popup-menu update-cursor @@ -646,9 +647,9 @@ get-max-view get-view get-dc) - (define-private-class editor-snip-editor-admin% editor-snip-editor-admin<%> editor-admin% + (define-private-class editor-snip-editor-admin% editor-snip-editor-admin<%> editor-admin% #f get-snip) - (define-class snip-admin% object% + (define-class snip-admin% object% #f popup-menu update-cursor release-snip @@ -661,7 +662,7 @@ get-view-size get-dc get-editor) - (define-class snip-class% object% + (define-class snip-class% object% #f reading-version write-header read-header @@ -670,13 +671,13 @@ set-classname get-version set-version) - (define-private-class snip-class-list% snip-class-list<%> object% + (define-private-class snip-class-list% snip-class-list<%> object% #f nth number add find-position find) - (define-class keymap% object% + (define-class keymap% object% #f remove-chained-keymap chain-to-keymap set-break-sequence-callback @@ -692,11 +693,11 @@ handle-key-event set-double-click-interval get-double-click-interval) - (define-class editor-wordbreak-map% object% + (define-class editor-wordbreak-map% object% #f get-map set-map) (define-function get-the-editor-wordbreak-map) - (define-class text% editor% + (define-class text% editor% #f call-clickback remove-clickback set-clickback @@ -836,7 +837,7 @@ on-event copy-self-to copy-self) - (define-class menu% object% + (define-class menu% object% #f select set-title set-label @@ -849,30 +850,30 @@ delete-by-position delete append) - (define-class menu-bar% object% + (define-class menu-bar% object% #f set-label-top number enable-top delete append) - (define-class menu-item% object% + (define-class menu-item% object% #f id) (define-function id-to-menu-item) - (define-class editor-stream-in-base% object% + (define-class editor-stream-in-base% object% #f read bad? skip seek tell) - (define-class editor-stream-out-base% object% + (define-class editor-stream-out-base% object% #f write bad? seek tell) - (define-class editor-stream-in-string-base% editor-stream-in-base%) - (define-class editor-stream-out-string-base% editor-stream-out-base% + (define-class editor-stream-in-string-base% editor-stream-in-base% #f) + (define-class editor-stream-out-string-base% editor-stream-out-base% #f get-string) - (define-class editor-stream-in% object% + (define-class editor-stream-in% object% #f ok? jump-to tell @@ -885,19 +886,19 @@ get-fixed get-string get) - (define-class editor-stream-out% object% + (define-class editor-stream-out% object% #f ok? jump-to tell << put-fixed put) - (define-class timer% object% + (define-class timer% object% () stop start notify interval) - (define-private-class clipboard% clipboard<%> object% + (define-private-class clipboard% clipboard<%> object% #f get-clipboard-bitmap set-clipboard-bitmap get-clipboard-data @@ -906,12 +907,12 @@ set-clipboard-string set-clipboard-client) (define-function get-the-clipboard) - (define-class clipboard-client% object% + (define-class clipboard-client% object% () get-types add-type get-data on-replaced) - (define-class ps-setup% object% + (define-class ps-setup% object% () copy-from set-margin set-editor-margin @@ -937,7 +938,7 @@ get-preview-command get-file get-command) - (define-class pasteboard% editor% + (define-class pasteboard% editor% #f set-scroll-step get-scroll-step set-selection-visible @@ -1042,7 +1043,7 @@ paste copy cut) - (define-class panel% window% + (define-class panel% window% #f get-label-font set-label-font get-control-font @@ -1060,7 +1061,7 @@ on-kill-focus set-item-cursor get-item-cursor) - (define-class dialog% window% + (define-class dialog% window% #f system-menu set-title on-drop-file @@ -1071,7 +1072,7 @@ on-kill-focus on-close on-activate) - (define-class radio-box% item% + (define-class radio-box% item% #f button-focus enable get-string @@ -1087,7 +1088,7 @@ on-size on-set-focus on-kill-focus) - (define-class slider% item% + (define-class slider% item% #f set-value get-value on-drop-file @@ -1096,7 +1097,7 @@ on-size on-set-focus on-kill-focus) - (define-class snip% object% + (define-class snip% object% #f previous next get-scroll-step-offset @@ -1132,7 +1133,7 @@ get-style get-snipclass set-snipclass) - (define-class string-snip% snip% + (define-class string-snip% snip% #f read insert get-scroll-step-offset @@ -1157,7 +1158,7 @@ draw partial-offset get-extent) - (define-class tab-snip% string-snip% + (define-class tab-snip% string-snip% #f get-scroll-step-offset find-scroll-step get-num-scroll-steps @@ -1180,7 +1181,7 @@ draw partial-offset get-extent) - (define-class image-snip% snip% + (define-class image-snip% snip% #f set-offset set-bitmap get-filetype @@ -1208,7 +1209,7 @@ draw partial-offset get-extent) - (define-class editor-snip% snip% + (define-class editor-snip% snip% #f get-inset set-inset get-margin @@ -1251,23 +1252,23 @@ get-extent set-editor get-editor) - (define-class editor-data-class% object% + (define-class editor-data-class% object% #f read get-classname set-classname) - (define-private-class editor-data-class-list% editor-data-class-list<%> object% + (define-private-class editor-data-class-list% editor-data-class-list<%> object% #f nth number add find-position find) - (define-class editor-data% object% + (define-class editor-data% object% #f set-next write get-dataclass set-dataclass get-next) - (define-private-class mult-color% mult-color<%> object% + (define-private-class mult-color% mult-color<%> object% #f set get get-r @@ -1276,7 +1277,7 @@ set-g get-b set-b) - (define-private-class add-color% add-color<%> object% + (define-private-class add-color% add-color<%> object% #f set get get-r @@ -1285,7 +1286,7 @@ set-g get-b set-b) - (define-class style-delta% object% + (define-class style-delta% object% #f copy collapse equal? @@ -1325,7 +1326,7 @@ set-alignment-on get-alignment-off set-alignment-off) - (define-private-class style% style<%> object% + (define-private-class style% style<%> object% #f switch-to set-shift-style get-shift-style @@ -1350,7 +1351,7 @@ get-face get-family get-name) - (define-class style-list% object% + (define-class style-list% object% #f forget-notification notify-on-change style-to-index