76 lines
2.3 KiB
Scheme
76 lines
2.3 KiB
Scheme
(module registry mzscheme
|
|
|
|
(provide register
|
|
make-entry
|
|
lookup-entry
|
|
lookup-scheme?
|
|
lookup-getter
|
|
lookup-setter
|
|
lookup-labels
|
|
lookup-supers
|
|
lookup-copier
|
|
lookup-predicate)
|
|
|
|
(require (prefix s1: (lib "1.ss" "srfi")))
|
|
|
|
(define reg '())
|
|
|
|
(define (make-entry name
|
|
is-scheme?
|
|
predicate
|
|
supers
|
|
labels
|
|
pos-labels
|
|
fields
|
|
copier)
|
|
(vector name
|
|
is-scheme?
|
|
predicate
|
|
supers
|
|
labels
|
|
pos-labels
|
|
fields
|
|
copier))
|
|
|
|
(define (entry.name entry) (vector-ref entry 0))
|
|
(define (entry.is-scheme? entry) (vector-ref entry 1))
|
|
(define (entry.predicate entry) (vector-ref entry 2))
|
|
(define (entry.supers entry) (vector-ref entry 3))
|
|
(define (entry.labels entry) (vector-ref entry 4))
|
|
(define (entry.pos-labels entry) (vector-ref entry 5))
|
|
(define (entry.fields entry) (vector-ref entry 6))
|
|
(define (entry.copier entry) (vector-ref entry 7))
|
|
|
|
(define (register name entry)
|
|
(cond ((s1:assoc name reg free-identifier=?)
|
|
=> (lambda (pair)
|
|
(set-cdr! pair entry)))
|
|
(else
|
|
(set! reg (cons (cons name entry)
|
|
reg)))))
|
|
|
|
(define (lookup-entry name)
|
|
(s1:assoc name reg free-identifier=?))
|
|
|
|
(define (lookup-getter name label)
|
|
(cond ((s1:assoc label
|
|
(entry.fields (cdr (lookup-entry name)))
|
|
free-identifier=?)
|
|
=> cadr)
|
|
(else #f)))
|
|
|
|
(define (lookup-setter name label)
|
|
(cond ((s1:assoc label
|
|
(entry.fields (cdr (lookup-entry name)))
|
|
free-identifier=?)
|
|
=> caddr)
|
|
(else #f)))
|
|
|
|
(define (lookup-scheme? name) (entry.is-scheme? (cdr (lookup-entry name))))
|
|
(define (lookup-labels name) (entry.labels (cdr (lookup-entry name))))
|
|
(define (lookup-supers name) (entry.supers (cdr (lookup-entry name))))
|
|
(define (lookup-copier name) (entry.copier (cdr (lookup-entry name))))
|
|
(define (lookup-predicate name) (entry.predicate (cdr (lookup-entry name))))
|
|
|
|
) ; registry
|