61 |
make-generic ensure-generic |
make-generic ensure-generic |
62 |
make-extended-generic |
make-extended-generic |
63 |
make-accessor ensure-accessor |
make-accessor ensure-accessor |
64 |
|
process-class-pre-define-generic |
65 |
|
process-class-pre-define-accessor |
66 |
|
process-define-generic |
67 |
|
process-define-accessor |
68 |
make-method add-method! |
make-method add-method! |
69 |
object-eqv? object-equal? |
object-eqv? object-equal? |
70 |
class-slot-ref class-slot-set! slot-unbound slot-missing |
class-slot-ref class-slot-set! slot-unbound slot-missing |
184 |
(define (define-class-pre-definition keyword exp env) |
(define (define-class-pre-definition keyword exp env) |
185 |
(case keyword |
(case keyword |
186 |
((#:getter #:setter) |
((#:getter #:setter) |
187 |
(if (defined? exp env) |
`(process-class-pre-define-generic ',exp)) |
|
`(define ,exp (ensure-generic ,exp ',exp)) |
|
|
`(define ,exp (make-generic ',exp)))) |
|
188 |
((#:accessor) |
((#:accessor) |
189 |
(if (defined? exp env) |
`(process-class-pre-define-accessor ',exp)) |
|
`(define ,exp (ensure-accessor ,exp ',exp)) |
|
|
`(define ,exp (make-accessor ',exp)))) |
|
190 |
(else #f))) |
(else #f))) |
191 |
|
|
192 |
|
(define (process-class-pre-define-generic name) |
193 |
|
(let ((var (module-variable (current-module) name))) |
194 |
|
(if (not (and var |
195 |
|
(variable-bound? var) |
196 |
|
(is-a? (variable-ref var) <generic>))) |
197 |
|
(process-define-generic name)))) |
198 |
|
|
199 |
|
(define (process-class-pre-define-accessor name) |
200 |
|
(let ((var (module-variable (current-module) name))) |
201 |
|
(if (not (and var |
202 |
|
(variable-bound? var) |
203 |
|
(or (is-a? (variable-ref var) <accessor>) |
204 |
|
(is-a? (variable-ref var) <extended-generic-with-setter>)))) |
205 |
|
(process-define-accessor name)))) |
206 |
|
|
207 |
;;; This code should be implemented in C. |
;;; This code should be implemented in C. |
208 |
;;; |
;;; |
209 |
(define define-class |
(define define-class |
380 |
(cond ((not (symbol? name)) |
(cond ((not (symbol? name)) |
381 |
(goops-error "bad generic function name: ~S" name)) |
(goops-error "bad generic function name: ~S" name)) |
382 |
((top-level-env? env) |
((top-level-env? env) |
383 |
`(let* ((var (module-ensure-local-variable! |
`(process-define-generic ',name)) |
|
(current-module) ',name)) |
|
|
(old (and (variable-bound? var) (variable-ref var)))) |
|
|
(if (or (not old) (is-a? old <generic>)) |
|
|
(variable-set! var (make <generic> #:name ',name)) |
|
|
(variable-set! var (ensure-generic old ',name))))) |
|
384 |
(else |
(else |
385 |
`(define ,name (make <generic> #:name ',name)))))))) |
`(define ,name (make <generic> #:name ',name)))))))) |
386 |
|
|
387 |
|
(define (process-define-generic name) |
388 |
|
(let ((var (module-ensure-local-variable! (current-module) name))) |
389 |
|
(if (or (not var) |
390 |
|
(not (variable-bound? var)) |
391 |
|
(is-a? (variable-ref var) <generic>)) |
392 |
|
;; redefine if NAME isn't defined previously, or is another generic |
393 |
|
(variable-set! var (make <generic> #:name name)) |
394 |
|
;; otherwise try to upgrade the object to a generic |
395 |
|
(variable-set! var (ensure-generic (variable-ref var) name))))) |
396 |
|
|
397 |
(define define-extended-generic |
(define define-extended-generic |
398 |
(procedure->memoizing-macro |
(procedure->memoizing-macro |
399 |
(lambda (exp env) |
(lambda (exp env) |
482 |
(cond ((not (symbol? name)) |
(cond ((not (symbol? name)) |
483 |
(goops-error "bad accessor name: ~S" name)) |
(goops-error "bad accessor name: ~S" name)) |
484 |
((top-level-env? env) |
((top-level-env? env) |
485 |
`(let* ((var (module-ensure-local-variable! |
`(process-define-accessor ',name)) |
|
(current-module) ',name)) |
|
|
(old (and (variable-bound? var) (variable-ref var)))) |
|
|
(if (or (not old) |
|
|
(and (is-a? old <accessor>) |
|
|
(is-a? (setter old) <generic>))) |
|
|
(variable-set! var (make-accessor ',name)) |
|
|
(variable-set! var (ensure-accessor old ',name))))) |
|
486 |
(else |
(else |
487 |
`(define ,name (make-accessor ',name)))))))) |
`(define ,name (make-accessor ',name)))))))) |
488 |
|
|
489 |
|
(define (process-define-accessor name) |
490 |
|
(let ((var (module-ensure-local-variable! (current-module) name))) |
491 |
|
(if (or (not var) |
492 |
|
(not (variable-bound? var)) |
493 |
|
(is-a? (variable-ref var) <accessor>) |
494 |
|
(is-a? (variable-ref var) <extended-generic-with-setter>)) |
495 |
|
;; redefine if NAME isn't defined previously, or is another accessor |
496 |
|
(variable-set! var (make-accessor name)) |
497 |
|
;; otherwise try to upgrade the object to an accessor |
498 |
|
(variable-set! var (ensure-accessor (variable-ref var) name))))) |
499 |
|
|
500 |
(define (make-setter-name name) |
(define (make-setter-name name) |
501 |
(string->symbol (string-append "setter:" (symbol->string name)))) |
(string->symbol (string-append "setter:" (symbol->string name)))) |
502 |
|
|