760 lines
16 KiB
Scheme
760 lines
16 KiB
Scheme
|
|
;; The parts of kernel.ss are generated by xctocc.
|
|
;; kernel.ss is generated by a target in <builddir>/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 (intf ...) 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 more-props)
|
|
(kernel:primitive-class-prepare-struct-type!
|
|
c prop:object class preparer dispatcher more-props))
|
|
kernel:initialize-primitive-object
|
|
'print-name super (list intf ...) '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-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
|
|
cache-font-metrics-key
|
|
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 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 timer% object% () ()
|
|
stop
|
|
start
|
|
notify
|
|
interval)
|
|
(define-private-class clipboard% clipboard<%> object% () #f
|
|
same-clipboard-client?
|
|
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% () ()
|
|
same-eventspace?
|
|
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 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 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
|
|
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-menu-tester
|
|
location->window
|
|
set-dialogs
|
|
set-executer
|
|
send-event
|
|
file-creator-and-type
|
|
set-ps-procs
|
|
main-eventspace?
|
|
eventspace-handler-thread
|
|
begin-refresh-sequence
|
|
end-refresh-sequence
|
|
run-printout
|
|
get-double-click-time)
|
|
|
|
)
|
|
;; end
|