1 |
;;; installed-scm-file |
;;; installed-scm-file |
2 |
|
|
3 |
;;;; Copyright (C) 1998,1999,2000,2001,2002 Free Software Foundation, Inc. |
;;;; Copyright (C) 1998,1999,2000,2001,2002, 2003 Free Software Foundation, Inc. |
4 |
;;;; |
;;;; |
5 |
;;;; This program is free software; you can redistribute it and/or modify |
;;;; This program is free software; you can redistribute it and/or modify |
6 |
;;;; it under the terms of the GNU General Public License as published by |
;;;; it under the terms of the GNU General Public License as published by |
53 |
(define-module (oop goops) |
(define-module (oop goops) |
54 |
:export-syntax (define-class class |
:export-syntax (define-class class |
55 |
define-generic define-accessor define-method |
define-generic define-accessor define-method |
56 |
|
define-extended-generic |
57 |
method) |
method) |
58 |
:export (goops-version is-a? |
:export (goops-version is-a? |
59 |
ensure-metaclass ensure-metaclass-with-supers |
ensure-metaclass ensure-metaclass-with-supers |
60 |
make-class |
make-class |
61 |
make-generic ensure-generic |
make-generic ensure-generic |
62 |
|
make-extended-generic |
63 |
make-accessor ensure-accessor |
make-accessor ensure-accessor |
64 |
make-method add-method! |
make-method add-method! |
65 |
object-eqv? object-equal? |
object-eqv? object-equal? |
373 |
(else |
(else |
374 |
`(define ,name (make <generic> #:name ',name)))))))) |
`(define ,name (make <generic> #:name ',name)))))))) |
375 |
|
|
376 |
|
(define define-extended-generic |
377 |
|
(procedure->memoizing-macro |
378 |
|
(lambda (exp env) |
379 |
|
(let ((name (cadr exp))) |
380 |
|
(cond ((not (symbol? name)) |
381 |
|
(goops-error "bad generic function name: ~S" name)) |
382 |
|
((null? (cddr exp)) |
383 |
|
(goops-error "missing expression")) |
384 |
|
(else |
385 |
|
`(define ,name (make-extended-generic ,(caddr exp) ',name)))))))) |
386 |
|
|
387 |
(define (make-generic . name) |
(define (make-generic . name) |
388 |
(let ((name (and (pair? name) (car name)))) |
(let ((name (and (pair? name) (car name)))) |
389 |
(make <generic> #:name name))) |
(make <generic> #:name name))) |
390 |
|
|
391 |
|
(define (make-extended-generic gfs . name) |
392 |
|
(let* ((name (and (pair? name) (car name))) |
393 |
|
(gfs (if (pair? gfs) gfs (list gfs))) |
394 |
|
(gws? (any (lambda (gf) (is-a? gf <generic-with-setter>)) gfs))) |
395 |
|
(let ((ans (if gws? |
396 |
|
(let* ((sname (and name (make-setter-name name))) |
397 |
|
(setters |
398 |
|
(apply append |
399 |
|
(map (lambda (gf) |
400 |
|
(if (is-a? gf <generic-with-setter>) |
401 |
|
(list (ensure-generic (setter gf) |
402 |
|
sname)) |
403 |
|
'())) |
404 |
|
gfs))) |
405 |
|
(es (make <extended-generic-with-setter> |
406 |
|
#:name name |
407 |
|
#:extends gfs |
408 |
|
#:setter (make <extended-generic> |
409 |
|
#:name sname |
410 |
|
#:extends setters)))) |
411 |
|
(extended-by! setters (setter es)) |
412 |
|
es) |
413 |
|
(make <extended-generic> |
414 |
|
#:name name |
415 |
|
#:extends gfs)))) |
416 |
|
(extended-by! gfs ans) |
417 |
|
ans))) |
418 |
|
|
419 |
|
(define (extended-by! gfs eg) |
420 |
|
(for-each (lambda (gf) |
421 |
|
(slot-set! gf 'extended-by |
422 |
|
(cons eg (slot-ref gf 'extended-by)))) |
423 |
|
gfs)) |
424 |
|
|
425 |
|
(define (not-extended-by! gfs eg) |
426 |
|
(for-each (lambda (gf) |
427 |
|
(slot-set! gf 'extended-by |
428 |
|
(delq! eg (slot-ref gf 'extended-by)))) |
429 |
|
gfs)) |
430 |
|
|
431 |
(define (ensure-generic old-definition . name) |
(define (ensure-generic old-definition . name) |
432 |
(let ((name (and (pair? name) (car name)))) |
(let ((name (and (pair? name) (car name)))) |
433 |
(cond ((is-a? old-definition <generic>) old-definition) |
(cond ((is-a? old-definition <generic>) old-definition) |
487 |
(make-accessor name))))) |
(make-accessor name))))) |
488 |
|
|
489 |
(define (upgrade-generic-with-setter generic setter) |
(define (upgrade-generic-with-setter generic setter) |
490 |
(let ((methods (generic-function-methods generic)) |
(let ((methods (slot-ref generic 'methods)) |
491 |
(gws (make <generic-with-setter> |
(gws (make (if (is-a? generic <extended-generic>) |
492 |
|
<extended-generic-with-setter> |
493 |
|
<generic-with-setter>) |
494 |
#:name (generic-function-name generic) |
#:name (generic-function-name generic) |
495 |
|
#:extended-by (slot-ref generic 'extended-by) |
496 |
#:setter setter))) |
#:setter setter))) |
497 |
|
(if (is-a? generic <extended-generic>) |
498 |
|
(let ((gfs (slot-ref generic 'extends))) |
499 |
|
(not-extended-by! gfs generic) |
500 |
|
(slot-set! gws 'extends gfs) |
501 |
|
(extended-by! gfs gws))) |
502 |
;; Steal old methods |
;; Steal old methods |
503 |
(for-each (lambda (method) |
(for-each (lambda (method) |
504 |
(slot-set! method 'generic-function gws)) |
(slot-set! method 'generic-function gws)) |
614 |
|
|
615 |
(define (compute-new-list-of-methods gf new) |
(define (compute-new-list-of-methods gf new) |
616 |
(let ((new-spec (method-specializers new)) |
(let ((new-spec (method-specializers new)) |
617 |
(methods (generic-function-methods gf))) |
(methods (slot-ref gf 'methods))) |
618 |
(let loop ((l methods)) |
(let loop ((l methods)) |
619 |
(if (null? l) |
(if (null? l) |
620 |
(cons new methods) |
(cons new methods) |
1412 |
(set-procedure-property! generic 'name name)) |
(set-procedure-property! generic 'name name)) |
1413 |
)) |
)) |
1414 |
|
|
1415 |
|
(define-method (initialize (eg <extended-generic>) initargs) |
1416 |
|
(next-method) |
1417 |
|
(slot-set! eg 'extends (get-keyword #:extends initargs '()))) |
1418 |
|
|
1419 |
(define dummy-procedure (lambda args *unspecified*)) |
(define dummy-procedure (lambda args *unspecified*)) |
1420 |
|
|
1421 |
(define-method (initialize (method <method>) initargs) |
(define-method (initialize (method <method>) initargs) |