suzanne.soy/gui
1
0
Fork 0
Code Issues Pull Requests Actions Packages Projects Releases Wiki Activity

.

Browse Source 
original commit: 1c926ae4754bc6646ac7b86382277d21bcedffd6
This commit is contained in:
Matthew Flatt 2001-03-02 17:36:26 +00:00
parent 125278a8d6
commit 4cdb379cc7
2 changed files with 38 additions and 52 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

28
collects/mred/mred.ss
View File

@ -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

62
collects/mred/private/kernel.ss
View File

@ -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