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

.

Browse Source 
original commit: db81df56ddf981a637eff54bdd6432b07019f05a
This commit is contained in:
Matthew Flatt 2001-03-15 04:20:35 +00:00
parent 10de29235b
commit 1843321381
1 changed files with 6 additions and 15 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

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

@ -11,21 +11,11 @@
(dynamic-require '#%mred-kernel 'initialize-primitive-object)) (dynamic-require '#%mred-kernel 'initialize-primitive-object))
(define kernel:find-in-primitive-class (define kernel:find-in-primitive-class
(dynamic-require '#%mred-kernel 'find-in-primitive-class)) (dynamic-require '#%mred-kernel 'find-in-primitive-class))
(define kernel:primitive-class->method-name-list (define kernel:primitive-class-find-method
(dynamic-require '#%mred-kernel 'primitive-class->method-name-list)) (dynamic-require '#%mred-kernel 'primitive-class-find-method))
(define kernel:primitive-class->method-vector
(dynamic-require '#%mred-kernel 'primitive-class->method-vector))
(define kernel:primitive-class-prepare-struct-type! (define kernel:primitive-class-prepare-struct-type!
(dynamic-require '#%mred-kernel 'primitive-class-prepare-struct-type!)) (dynamic-require '#%mred-kernel 'primitive-class-prepare-struct-type!))
;; (require (prefix kernel: #%mred-kernel))
(define (find-method class name)
(let loop ([l (kernel:primitive-class->method-name-list class)][p 0])
(if (eq? name (car l))
(vector-ref (kernel:primitive-class->method-vector class) p)
(loop (cdr l) (add1 p)))))
(define-syntax define-constant (define-syntax define-constant
(lambda (stx) (lambda (stx)
(syntax-case stx () (syntax-case stx ()
@ -90,16 +80,17 @@
(define name (let ([c (dynamic-require '#%mred-kernel 'name)]) (define name (let ([c (dynamic-require '#%mred-kernel 'name)])
(make-primitive-class (make-primitive-class
(lambda (class prop:object dispatcher) (lambda (class prop:object dispatcher)
(kernel:primitive-class-prepare-struct-type! c prop:object class dispatcher)) (kernel:primitive-class-prepare-struct-type!
c prop:object class dispatcher))
kernel:initialize-primitive-object kernel:initialize-primitive-object
'name super 'name super
'(old ...) '(old ...)
'(new ...) '(new ...)
(list (list
(find-method c 'old) (kernel:primitive-class-find-method c 'old)
...) ...)
(list (list
(find-method c 'new) (kernel:primitive-class-find-method c 'new)
...)))))))))])))) ...)))))))))]))))
(define-syntax define-class (define-syntax define-class