;; 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 mzlib/class object%)) ;; Pull pieces out of #%mred-kernel dynamically, so that ;; the library compiles with setup-plt in mzscheme. (define kernel:initialize-primitive-object (dynamic-require ''#%mred-kernel 'initialize-primitive-object)) (define kernel:primitive-class-find-method (dynamic-require ''#%mred-kernel 'primitive-class-find-method)) (define kernel:primitive-class-prepare-struct-type! (dynamic-require ''#%mred-kernel 'primitive-class-prepare-struct-type!)) (define-syntax define-constant (lambda (stx) (syntax-case stx () [(_ name) (with-syntax ([kernel:name (datum->syntax-object (syntax name) (string->symbol (format "kernel:~a" (syntax-e (syntax name)))) #f)]) (syntax (begin (define kernel:name (dynamic-require ''#%mred-kernel 'name)) (provide (protect (rename kernel:name name))))))]))) (define-syntax define-function (lambda (stx) (syntax-case stx () [(_ name) (syntax (define-constant name))]))) (define-syntax define-functions (lambda (stx) (syntax-case stx () [(_ name ...) (syntax (begin (define-function name) ...))]))) (define-syntax define-a-class (let ([defined null]) (lambda (stx) (syntax-case stx () [(_ name print-name super args id ...) (let ([nm (syntax-e (syntax name))] [sn (syntax-e (syntax super))] [ids (map syntax-e (syntax->list (syntax (id ...))))]) ;; find superclass (let ([sup (assoc sn defined)]) (unless (or sup (not sn)) (raise-syntax-error 'class "class not yet defined" stx (syntax super))) ;; add this class to the list: (set! defined (cons (cons nm (append (if sup (cdr sup) null) ids)) defined)) (let-values ([(old new) (let loop ([l ids][o null][n null]) (cond [(null? l) (values o n)] [(memq (car l) (cdr sup)) (loop (cdr l) (cons (car l) o) n)] [else (loop (cdr l) o (cons (car l) n))]))]) (with-syntax ([(old ...) (datum->syntax-object #f old #f)] [(new ...) (datum->syntax-object #f new #f)]) (syntax (define name (let ([c (dynamic-require ''#%mred-kernel 'name)]) (make-primitive-class (lambda (class prop:object preparer dispatcher) (kernel:primitive-class-prepare-struct-type! c prop:object class preparer dispatcher)) kernel:initialize-primitive-object 'print-name super 'args '(old ...) '(new ...) (list (kernel:primitive-class-find-method c 'old) ...) (list (kernel:primitive-class-find-method c 'new) ...)))))))))])))) (define-syntax define-class (lambda (stx) (syntax-case stx () [(_ name super args id ...) (syntax (begin (define-a-class name name super args id ...) (provide (protect name))))]))) (define-syntax define-private-class (lambda (stx) (syntax-case stx () [(_ name intf super args id ...) (syntax (begin (define-a-class name intf super args id ...) (define intf (class->interface name)) (provide (protect intf))))]))) (define-class object% #f #f) (define-class window% object% #f on-drop-file pre-on-event pre-on-char on-size on-set-focus on-kill-focus get-handle is-enabled-to-root? is-shown-to-root? set-phantom-size get-y get-x get-width get-height popup-menu center get-text-extent get-parent refresh screen-to-client client-to-screen drag-accept-files enable get-position get-client-size get-size fit is-shown? show set-cursor move set-size set-focus gets-focus? centre) (define-class item% window% #f set-label get-label command) (define-class message% item% #f get-font set-label on-drop-file pre-on-event pre-on-char on-size on-set-focus on-kill-focus) (define-private-class editor% editor<%> object% #f dc-location-to-editor-location editor-location-to-dc-location set-inactive-caret-threshold get-inactive-caret-threshold get-focus-snip end-write-header-footer-to-file begin-write-header-footer-to-file print insert-image insert-box get-filename is-modified? is-locked? lock set-cursor get-paste-text-only set-paste-text-only get-load-overwrites-styles set-load-overwrites-styles set-style-list get-style-list get-keymap set-keymap can-do-edit-operation? do-edit-operation get-max-undo-history set-max-undo-history add-undo clear-undos redo undo select-all clear get-view-size get-dc local-to-global global-to-local locked-for-flow? locked-for-write? locked-for-read? set-admin get-admin print-to-dc find-scroll-line num-scroll-lines scroll-line-location get-snip-location locations-computed? in-edit-sequence? refresh-delayed? end-edit-sequence begin-edit-sequence style-has-changed set-min-height set-max-height get-min-height get-max-height set-min-width set-max-width get-min-width get-max-width insert-file load-file insert-port save-port default-style-name get-flattened-text put-file get-file after-edit-sequence on-edit-sequence after-load-file on-load-file can-load-file? after-save-file on-save-file can-save-file? on-new-box on-new-image-snip invalidate-bitmap-cache on-paint write-footers-to-file write-headers-to-file read-footer-from-file read-header-from-file write-to-file read-from-file set-filename release-snip on-snip-modified set-modified scroll-editor-to set-snip-data get-snip-data needs-update resized set-caret-owner scroll-to on-display-size-when-ready on-display-size on-change on-focus on-default-char on-default-event on-local-char on-local-event find-first-snip get-space get-descent get-extent blink-caret own-caret refresh adjust-cursor on-char on-event copy-self-to copy-self kill paste-x-selection paste copy cut insert change-style) (define-function get-the-editor-data-class-list) (define-function get-the-snip-class-list) (define-function editor-set-x-selection-mode) (define-function add-pasteboard-keymap-functions) (define-function add-text-keymap-functions) (define-function add-editor-keymap-functions) (define-function write-editor-global-footer) (define-function write-editor-global-header) (define-function read-editor-global-footer) (define-function read-editor-global-header) (define-function read-editor-version) (define-function write-editor-version) (define-function set-editor-print-margin) (define-function get-editor-print-margin) (define-class bitmap% object% #f get-argb-pixels get-gl-config set-gl-config set-loaded-mask get-loaded-mask save-file load-file is-color? ok? get-width get-height get-depth) (define-class button% item% #f set-border set-label on-drop-file pre-on-event pre-on-char on-size on-set-focus on-kill-focus) (define-class choice% item% #f set-selection get-selection number clear append on-drop-file pre-on-event pre-on-char on-size on-set-focus on-kill-focus) (define-function set-combo-box-font) (define-class check-box% item% #f set-label set-value get-value on-drop-file pre-on-event pre-on-char on-size on-set-focus on-kill-focus) (define-class canvas% window% #f on-drop-file pre-on-event pre-on-char on-size on-set-focus on-kill-focus get-canvas-background set-canvas-background set-background-to-gray on-scroll set-scroll-page set-scroll-range set-scroll-pos get-scroll-page get-scroll-range get-scroll-pos scroll warp-pointer view-start set-resize-corner show-scrollbars set-scrollbars get-virtual-size get-dc on-char on-event on-paint) (define-private-class dc% dc<%> object% #f get-alpha set-alpha glyph-exists? end-page end-doc start-page start-doc ok? get-gl-context get-size get-text-foreground get-text-background get-pen get-font get-brush get-text-mode get-background get-origin get-scale set-origin set-scale set-text-mode try-color draw-bitmap draw-bitmap-section get-char-width get-char-height get-text-extent get-smoothing set-smoothing set-text-foreground set-text-background set-brush set-pen set-font set-background get-clipping-region set-clipping-region set-clipping-rect draw-polygon draw-lines draw-path draw-ellipse draw-arc draw-text draw-spline draw-rounded-rectangle draw-rectangle draw-point draw-line clear) (define-function draw-tab) (define-function draw-tab-base) (define-class bitmap-dc% dc% () get-bitmap set-bitmap draw-bitmap-section-smooth set-argb-pixels get-argb-pixels set-pixel get-pixel) (define-class post-script-dc% dc% ([interactive #t] [parent #f] [use-paper-bbox #f] [eps #t])) (define-class printer-dc% dc% ([parent #f])) (define-private-class gl-context% gl-context<%> object% #f call-as-current swap-buffers ok?) (define-class gl-config% object% #f get-double-buffered set-double-buffered get-stereo set-stereo get-stencil-size set-stencil-size get-accum-size set-accum-size get-depth-size set-depth-size get-multisample-size set-multisample-size) (define-class event% object% ([time-stamp 0]) get-time-stamp set-time-stamp) (define-class control-event% event% (event-type [time-stamp 0]) get-event-type set-event-type) (define-class popup-event% control-event% #f get-menu-id set-menu-id) (define-class scroll-event% event% ([event-type thumb] [direction vertical] [position 0] [time-stamp 0]) get-event-type set-event-type get-direction set-direction get-position set-position) (define-class key-event% event% ([key-code #\nul] [shift-down #f] [control-down #f] [meta-down #f] [alt-down #f] [x 0] [y 0] [time-stamp 0] [caps-down #f]) set-other-caps-key-code get-other-caps-key-code set-other-shift-altgr-key-code get-other-shift-altgr-key-code set-other-altgr-key-code get-other-altgr-key-code set-other-shift-key-code get-other-shift-key-code get-key-code set-key-code get-key-release-code set-key-release-code get-shift-down set-shift-down get-control-down set-control-down get-meta-down set-meta-down get-alt-down set-alt-down get-caps-down set-caps-down get-x set-x get-y set-y) (define-function key-symbol-to-integer) (define-class mouse-event% event% (event-type [left-down #f] [middle-down #f] [right-down #f] [x 0] [y 0] [shift-down #f] [control-down #f] [meta-down #f] [alt-down #f] [time-stamp 0] [caps-down #f]) moving? leaving? entering? dragging? button-up? button-down? button-changed? get-event-type set-event-type get-left-down set-left-down get-middle-down set-middle-down get-right-down set-right-down get-shift-down set-shift-down get-control-down set-control-down get-meta-down set-meta-down get-alt-down set-alt-down get-caps-down set-caps-down get-x set-x get-y set-y) (define-class frame% window% #f on-drop-file pre-on-event pre-on-char on-size on-set-focus on-kill-focus on-toolbar-click on-menu-click on-menu-command on-mdi-activate enforce-size on-close on-activate designate-root-frame system-menu set-modified create-status-line is-maximized? maximize status-line-exists? iconized? set-status-text get-menu-bar set-menu-bar set-icon iconize set-title) (define-class gauge% item% #f get-value set-value get-range set-range on-drop-file pre-on-event pre-on-char on-size on-set-focus on-kill-focus) (define-class font% object% #f screen-glyph-exists? get-font-id get-size-in-pixels get-underlined get-smoothing get-weight get-point-size get-style get-face get-family) (define-class font-list% object% #f find-or-create-font) (define-class color% object% #f blue green red set ok? copy-from) (define-private-class color-database% color-database<%> object% #f find-color) (define-class point% object% #f get-x set-x get-y set-y) (define-class brush% object% #f set-style get-style set-stipple get-stipple set-color get-color) (define-class brush-list% object% #f find-or-create-brush) (define-class pen% object% #f set-style get-style set-stipple get-stipple set-color get-color set-join get-join set-cap get-cap set-width get-width) (define-class pen-list% object% #f find-or-create-pen) (define-class cursor% object% #f ok?) (define-class region% object% (dc) in-region? is-empty? get-bounding-box xor subtract intersect union set-path set-arc set-polygon set-ellipse set-rounded-rectangle set-rectangle get-dc) (define-class dc-path% object% #f get-bounding-box append reverse rotate scale translate lines ellipse rounded-rectangle rectangle curve-to arc line-to move-to open? close reset) (define-private-class font-name-directory% font-name-directory<%> object% #f find-family-default-font-id find-or-create-font-id get-family get-face-name get-font-id set-post-script-name set-screen-name get-post-script-name get-screen-name) (define-function get-control-font-size) (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 cancel-quit) (define-function fill-private-color) (define-function flush-display) (define-function yield) (define-function write-resource) (define-function get-resource) (define-function label->plain-label) (define-function display-origin) (define-function display-size) (define-function bell) (define-function hide-cursor) (define-function end-busy-cursor) (define-function is-busy?) (define-function begin-busy-cursor) (define-function get-display-depth) (define-function is-color-display?) (define-function file-selector) (define-class list-box% item% #f get-label-font set-string set-first-visible-item set get-selections get-first-item number-of-visible-items number get-selection set-data get-data selected? set-selection select delete clear append on-drop-file pre-on-event pre-on-char on-size on-set-focus on-kill-focus) (define-class editor-canvas% canvas% #f on-char on-event on-paint on-drop-file pre-on-event pre-on-char on-size on-set-focus on-kill-focus popup-for-editor call-as-primary-owner get-canvas-background set-canvas-background set-y-margin set-x-margin get-y-margin get-x-margin scroll-to set-lazy-refresh get-lazy-refresh scroll-with-bottom-base allow-scroll-to-last force-display-focus is-focus-on? on-scroll-on-change get-editor set-editor get-wheel-step set-wheel-step) (define-class editor-admin% object% #f modified refresh-delayed? popup-menu update-cursor needs-update resized grab-caret scroll-to get-max-view get-view get-dc) (define-private-class editor-snip-editor-admin% editor-snip-editor-admin<%> editor-admin% #f get-snip) (define-class snip-admin% object% #f modified popup-menu update-cursor release-snip needs-update recounted resized set-caret-owner scroll-to get-view get-view-size get-dc get-editor) (define-class snip-class% object% #f reading-version write-header read-header read get-classname set-classname get-version set-version) (define-private-class snip-class-list% snip-class-list<%> object% #f nth number add find-position find) (define-class keymap% object% #f remove-chained-keymap chain-to-keymap set-break-sequence-callback call-function remove-grab-mouse-function set-grab-mouse-function remove-grab-key-function set-grab-key-function add-function map-function break-sequence handle-mouse-event handle-key-event set-double-click-interval get-double-click-interval) (define-class editor-wordbreak-map% object% #f get-map set-map) (define-function get-the-editor-wordbreak-map) (define-class text% editor% #f call-clickback remove-clickback set-clickback set-wordbreak-func set-autowrap-bitmap on-reflow on-new-tab-snip on-new-string-snip caret-hidden? hide-caret get-wordbreak-map set-wordbreak-map find-wordbreak set-region-data get-region-data get-revision-number after-merge-snips after-split-snip after-set-size-constraint on-set-size-constraint can-set-size-constraint? after-set-position after-change-style on-change-style can-change-style? after-delete on-delete can-delete? after-insert on-insert can-insert? set-tabs get-tabs set-overwrite-mode get-overwrite-mode set-file-format get-file-format write-to-file read-from-file get-character get-text find-next-non-string-snip get-snip-position get-snip-position-and-location find-snip find-string-all find-string set-styles-sticky get-styles-sticky set-line-spacing get-line-spacing set-paragraph-alignment set-paragraph-margins last-paragraph paragraph-end-line paragraph-start-line line-paragraph paragraph-end-position paragraph-start-position position-paragraph last-line last-position line-length line-end-position line-start-position line-location position-locations position-location position-line set-between-threshold get-between-threshold find-position-in-line find-line find-position split-snip change-style do-paste-x-selection do-paste do-copy kill paste-next paste-x-selection paste copy cut erase delete insert get-top-line-base flash-off flash-on get-anchor set-anchor get-visible-line-range get-visible-position-range scroll-to-position move-position set-position-bias-scroll set-position get-end-position get-start-position get-position default-style-name get-flattened-text put-file get-file after-edit-sequence on-edit-sequence after-load-file on-load-file can-load-file? after-save-file on-save-file can-save-file? on-new-box on-new-image-snip invalidate-bitmap-cache on-paint write-footers-to-file write-headers-to-file read-footer-from-file read-header-from-file set-filename release-snip on-snip-modified set-modified scroll-editor-to set-snip-data get-snip-data needs-update resized set-caret-owner scroll-to on-display-size-when-ready on-display-size on-change on-focus on-default-char on-default-event on-local-char on-local-event find-first-snip get-space get-descent get-extent blink-caret own-caret refresh adjust-cursor on-char on-event copy-self-to copy-self) (define-class menu% object% #f select get-font set-width set-title set-label set-help-string number enable check checked? append-separator delete-by-position delete append) (define-class menu-bar% object% #f set-label-top number enable-top delete append) (define-class menu-item% object% #f id) (define-function id-to-menu-item) (define-class editor-stream-in-base% object% #f read bad? skip seek tell) (define-class editor-stream-out-base% object% #f write bad? seek tell) (define-class editor-stream-in-bytes-base% editor-stream-in-base% #f) (define-class editor-stream-out-bytes-base% editor-stream-out-base% #f get-bytes) (define-class editor-stream-in% object% #f ok? jump-to tell skip remove-boundary set-boundary get-inexact get-exact get-fixed get-unterminated-bytes get-bytes get) (define-class editor-stream-out% object% #f ok? pretty-finish jump-to tell put-fixed put) (define-class timer% object% () stop start notify interval) (define-private-class clipboard% clipboard<%> object% #f get-clipboard-bitmap set-clipboard-bitmap get-clipboard-data get-clipboard-string set-clipboard-string set-clipboard-client) (define-function get-the-x-selection) (define-function get-the-clipboard) (define-class clipboard-client% object% () get-types add-type get-data on-replaced) (define-class ps-setup% object% () copy-from set-margin set-editor-margin set-level-2 set-paper-name set-translation set-scaling set-orientation set-mode set-preview-command set-file set-command get-margin get-editor-margin get-level-2 get-paper-name get-translation get-scaling get-orientation get-mode get-preview-command get-file get-command) (define-function show-print-setup) (define-function can-show-print-setup?) (define-class pasteboard% editor% #f set-scroll-step get-scroll-step set-selection-visible get-selection-visible set-dragable get-dragable after-interactive-resize on-interactive-resize can-interactive-resize? after-interactive-move on-interactive-move can-interactive-move? interactive-adjust-resize interactive-adjust-move interactive-adjust-mouse on-double-click after-select on-select can-select? after-reorder on-reorder can-reorder? after-resize on-resize can-resize? after-move-to on-move-to can-move-to? after-delete on-delete can-delete? after-insert on-insert can-insert? find-next-selected-snip is-selected? find-snip get-center remove-selected no-selected add-selected set-selected change-style set-after set-before lower raise resize move move-to remove erase do-paste-x-selection do-paste do-copy delete insert default-style-name get-flattened-text put-file get-file after-edit-sequence on-edit-sequence after-load-file on-load-file can-load-file? after-save-file on-save-file can-save-file? on-new-box on-new-image-snip invalidate-bitmap-cache on-paint write-footers-to-file write-headers-to-file read-footer-from-file read-header-from-file write-to-file read-from-file set-filename release-snip on-snip-modified set-modified scroll-editor-to set-snip-data get-snip-data needs-update resized set-caret-owner scroll-to on-display-size-when-ready on-display-size on-change on-focus on-default-char on-default-event on-local-char on-local-event find-first-snip get-space get-descent get-extent blink-caret own-caret refresh adjust-cursor on-char on-event copy-self-to copy-self kill paste-x-selection paste copy cut) (define-class panel% window% #f get-label-position set-label-position on-char on-event on-paint on-drop-file pre-on-event pre-on-char on-size on-set-focus on-kill-focus set-item-cursor get-item-cursor) (define-class dialog% window% #f system-menu set-title on-drop-file pre-on-event pre-on-char on-size on-set-focus on-kill-focus enforce-size on-close on-activate) (define-class radio-box% item% #f button-focus enable set-selection number get-selection on-drop-file pre-on-event pre-on-char on-size on-set-focus on-kill-focus) (define-class slider% item% #f set-value get-value on-drop-file pre-on-event pre-on-char on-size on-set-focus on-kill-focus) (define-class snip% object% #f previous next set-unmodified get-scroll-step-offset find-scroll-step get-num-scroll-steps set-admin resize write match? can-do-edit-operation? do-edit-operation blink-caret own-caret adjust-cursor on-char on-event size-cache-invalid copy get-text! get-text merge-with split draw partial-offset get-extent release-from-owner is-owned? set-style set-flags set-count get-admin get-count get-flags get-style get-snipclass set-snipclass) (define-class string-snip% snip% #f read insert set-unmodified get-scroll-step-offset find-scroll-step get-num-scroll-steps set-admin resize write match? can-do-edit-operation? do-edit-operation blink-caret own-caret adjust-cursor on-char on-event size-cache-invalid copy get-text! get-text merge-with split draw partial-offset get-extent) (define-class tab-snip% string-snip% #f set-unmodified get-scroll-step-offset find-scroll-step get-num-scroll-steps set-admin resize write match? can-do-edit-operation? do-edit-operation blink-caret own-caret adjust-cursor on-char on-event size-cache-invalid copy get-text! get-text merge-with split draw partial-offset get-extent) (define-class image-snip% snip% #f set-offset get-bitmap-mask get-bitmap set-bitmap get-filetype get-filename load-file set-unmodified get-scroll-step-offset find-scroll-step get-num-scroll-steps set-admin resize write match? can-do-edit-operation? do-edit-operation blink-caret own-caret adjust-cursor on-char on-event size-cache-invalid copy get-text! get-text merge-with split draw partial-offset get-extent) (define-class editor-snip% snip% #f get-inset set-inset get-margin set-margin style-background-used? use-style-background border-visible? show-border set-align-top-line get-align-top-line set-tight-text-fit get-tight-text-fit get-min-height get-min-width set-min-height set-min-width get-max-height get-max-width set-max-height set-max-width set-unmodified get-scroll-step-offset find-scroll-step get-num-scroll-steps set-admin resize write match? can-do-edit-operation? do-edit-operation blink-caret own-caret adjust-cursor on-char on-event size-cache-invalid copy get-text! get-text merge-with split draw partial-offset get-extent set-editor get-editor) (define-class editor-data-class% object% #f read get-classname set-classname) (define-private-class editor-data-class-list% editor-data-class-list<%> object% #f nth number add find-position find) (define-class editor-data% object% #f set-next write get-dataclass set-dataclass get-next) (define-private-class mult-color% mult-color<%> object% #f set get get-r set-r get-g set-g get-b set-b) (define-private-class add-color% add-color<%> object% #f set get get-r set-r get-g set-g get-b set-b) (define-class style-delta% object% #f copy collapse equal? set-delta-foreground set-delta-background set-delta-face set-delta get-family set-family get-face set-face get-size-mult set-size-mult get-size-add set-size-add get-weight-on set-weight-on get-weight-off set-weight-off get-smoothing-on set-smoothing-on get-smoothing-off set-smoothing-off get-style-on set-style-on get-style-off set-style-off get-underlined-on set-underlined-on get-underlined-off set-underlined-off get-size-in-pixels-on set-size-in-pixels-on get-size-in-pixels-off set-size-in-pixels-off get-transparent-text-backing-on set-transparent-text-backing-on get-transparent-text-backing-off set-transparent-text-backing-off get-foreground-mult get-background-mult get-foreground-add get-background-add get-alignment-on set-alignment-on get-alignment-off set-alignment-off) (define-private-class style% style<%> object% #f switch-to set-shift-style get-shift-style is-join? set-delta get-delta set-base-style get-base-style get-text-width get-text-space get-text-descent get-text-height get-transparent-text-backing get-alignment get-background get-foreground get-font get-size-in-pixels get-underlined get-smoothing get-style get-weight get-size get-face get-family get-name) (define-class style-list% object% #f forget-notification notify-on-change style-to-index index-to-style convert replace-named-style new-named-style find-named-style find-or-create-join-style find-or-create-style number basic-style) (define-function get-the-style-list) (define-class tab-group% item% #f button-focus set set-label delete append enable set-selection number get-selection on-drop-file pre-on-event pre-on-char on-size on-set-focus on-kill-focus) (define-class group-box% item% #f on-drop-file pre-on-event pre-on-char on-size on-set-focus on-kill-focus) ;; Functions defined in wxscheme.cxx (define-functions special-control-key special-option-key map-command-as-meta-key application-file-handler application-quit-handler application-about-handler application-pref-handler get-color-from-user get-font-from-user get-face-list get-panel-background play-sound make-eventspace current-eventspace event-dispatch-handler eventspace? current-ps-setup queue-callback middle-queue-key check-for-break find-graphical-system-path get-top-level-windows register-collecting-blit unregister-collecting-blit shortcut-visible-in-label? eventspace-shutdown? in-atomic-region set-editor-snip-maker set-text-editor-maker set-pasteboard-editor-maker set-menu-tester location->window set-dialogs set-executer send-event file-creator-and-type set-snip-class-getter set-editor-data-class-getter set-ps-procs main-eventspace? eventspace-handler-thread) ) ;; end