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

I dunno why, but this reads much better to me.

Browse Source 
svn: r18200
This commit is contained in:
Stevie Strickland 2010-02-20 00:08:49 +00:00
parent 95438db40f
commit 30864fc1d0
1 changed files with 15 additions and 22 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

37
collects/scheme/private/class-internal.ss
View File

@ -3389,28 +3389,21 @@
loop-object loop-object
(loop (wrapper-object-wrapped loop-object))))))) (loop (wrapper-object-wrapped loop-object)))))))
(define-values (make-class-field-accessor make-class-field-mutator)
(define (class-field-X who which cwhich class name proc-field-name) (let ([mk (λ (who which cwhich)
(unless (class? class) (λ (class name keep-name?)
(raise-type-error who "class" class)) (unless (class? class)
(unless (symbol? name) (raise-type-error who "class" class))
(raise-type-error who "symbol" name)) (unless (symbol? name)
(let ([p (hash-ref (class-field-ht class) name (raise-type-error who "symbol" name))
(lambda () (let ([p (hash-ref (class-field-ht class) name
(obj-error who "no such field: ~a~a" (lambda ()
name (obj-error who "no such field: ~a~a"
(for-class (class-name class)))))]) name
(which (cwhich (car p)) (cdr p) proc-field-name))) (for-class (class-name class)))))])
(which (cwhich (car p)) (cdr p) (and keep-name? name)))))])
(define (make-class-field-accessor class name keep-name?) (values (mk 'class-field-accessor make-struct-field-accessor class-field-ref)
(class-field-X 'class-field-accessor (mk 'class-field-mutator make-struct-field-mutator class-field-set!))))
make-struct-field-accessor class-field-ref
class name (and keep-name? name)))
(define (make-class-field-mutator class name keep-name?)
(class-field-X 'class-field-mutator
make-struct-field-mutator class-field-set!
class name (and keep-name? name)))
(define-struct generic (name applicable)) (define-struct generic (name applicable))