;; 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 prop:unwrap unwrapper more-props)
				      (kernel:primitive-class-prepare-struct-type! 
				       c prop:object class preparer dispatcher prop:unwrap unwrapper 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