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

.

Browse Source 
original commit: 08691777967fba13f71e92df94b032a24f791299
This commit is contained in:
Matthew Flatt 2001-03-13 22:09:55 +00:00
parent 5e1776c9d1
commit 76aa58b89a
2 changed files with 8 additions and 13 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

2
collects/mred/mred.ss
View File

@ -1,6 +1,6 @@
(module mred mzscheme
(require (prefix wx: (lib "kernel.ss" "mred" "private")))
(require (lib "class.ss"))
(require (lib "class2.ss"))
;;;;;;;;;;;;;;; Constants ;;;;;;;;;;;;;;;;;;;;

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

@ -2,7 +2,7 @@
;; kernel.ss is generated by xctocc
(module kernel mzscheme
(require (all-except (lib "class.ss") object%))
(require (all-except (lib "class2.ss") object%))
;; Pull pieces out of #%mred-kernel dynamically, so that
;; the library compiles with setup-plt in mzscheme.
@ -15,12 +15,8 @@
(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))
;; (require (prefix kernel: #%mred-kernel))
@ -91,19 +87,18 @@
(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)]
[b (box #f)])
(kernel:primitive-class-prepare-struct-type! c prop:object b)
(make-prim-class
(kernel:primitive-class->struct-type c) b
kernel:dispatcher-property
(define name (let ([c (dynamic-require '#%mred-kernel 'name)])
(make-primitive-class
(lambda (class prop:object dispatcher)
(kernel:primitive-class-prepare-struct-type! c prop:object class dispatcher))
kernel:initialize-primitive-object
'name super
'(old ...)
'(new ...)
(list
(find-method c 'old)
...
...)
(list
(find-method c 'new)
...)))))))))]))))