/[guile]/guile/guile-core/oop/goops.scm
ViewVC logotype

Diff of /guile/guile-core/oop/goops.scm

Parent Directory Parent Directory | Revision Log Revision Log | View Patch Patch

revision 1.18 by dirk, Sat Nov 16 16:29:06 2002 UTC revision 1.19 by mdj, Wed Jan 8 13:24:41 2003 UTC
# Line 1  Line 1 
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
# Line 53  Line 53 
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?
# Line 371  Line 373 
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)
# Line 434  Line 487 
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))
# Line 553  Line 614 
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)
# Line 1351  Line 1412 
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)

Legend:
Removed from v.1.18  
changed lines
  Added in v.1.19

savannah-hackers-public@gnu.org
ViewVC Help
Powered by ViewVC 1.1.26