home *** CD-ROM | disk | FTP | other *** search
/ OS/2 Shareware BBS: 10 Tools / 10-Tools.zip / mitsch75.zip / scheme-7_5_17-src.zip / scheme-7.5.17 / src / runtime / genmult.scm < prev    next >
Text File  |  1999-01-02  |  7KB  |  174 lines
  1. ;;; -*-Scheme-*-
  2. ;;;
  3. ;;; $Id: genmult.scm,v 1.2 1999/01/02 06:11:34 cph Exp $
  4. ;;;
  5. ;;; Copyright (c) 1995-1999 Massachusetts Institute of Technology
  6. ;;;
  7. ;;; This program is free software; you can redistribute it and/or
  8. ;;; modify it under the terms of the GNU General Public License as
  9. ;;; published by the Free Software Foundation; either version 2 of the
  10. ;;; License, or (at your option) any later version.
  11. ;;;
  12. ;;; This program is distributed in the hope that it will be useful,
  13. ;;; but WITHOUT ANY WARRANTY; without even the implied warranty of
  14. ;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the GNU
  15. ;;; General Public License for more details.
  16. ;;;
  17. ;;; You should have received a copy of the GNU General Public License
  18. ;;; along with this program; if not, write to the Free Software
  19. ;;; Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA.
  20.  
  21. ;;;; Multiplexed Generic Procedures
  22.  
  23. ;;; This code assumes that a non-multiplexed generic procedure
  24. ;;; generator is equivalent to the same generator stored in a
  25. ;;; multiplexer.  Multiplexers assume that each of their generators is
  26. ;;; applicable to a particular set of objects, and that the set does
  27. ;;; not intersect any of the sets handled by other generators stored
  28. ;;; in the same multiplexer.  Combining these two assumptions means
  29. ;;; that a non-multiplexed generator must follow the convention for
  30. ;;; multiplexed generators, even though there is no reason to do so in
  31. ;;; the absence of multiplexers.
  32.  
  33. ;;; This convention is encouraged by hiding the low-level procedures
  34. ;;; that allow direct access to a generic procedure's generator, and
  35. ;;; forcing the programmer to go through the multiplexing interface.
  36. ;;; That way, multiplexing appears to be an integral part of the
  37. ;;; generic-procedure interface.
  38.  
  39. (declare (usual-integrations))
  40.  
  41. (define (generic-procedure-generator-list generic)
  42.   (let ((m (generic-procedure-generator generic)))
  43.     (if m
  44.     (if (multiplexer? m)
  45.         (list-copy (multiplexer-list m))
  46.         (list m))
  47.     '())))
  48.  
  49. (define (add-generic-procedure-generator generic generator)
  50.   (let ((m (generic-procedure-generator generic)))
  51.     (if (multiplexer? m)
  52.     (begin
  53.       (purge-generic-procedure-cache generic)
  54.       (add-generator m generator))
  55.     (add-generator (install-multiplexer generic) generator))))
  56.  
  57. (define (remove-generic-procedure-generator generic generator)
  58.   (let ((m (generic-procedure-generator generic)))
  59.     (if (multiplexer? m)
  60.     (begin
  61.       (purge-generic-procedure-cache generic)
  62.       (set-multiplexer-list! m (delq! generator (multiplexer-list m)))
  63.       (maybe-deinstall-multiplexer generic))
  64.     (if (eq? generator m)
  65.         (set-generic-procedure-generator! generic #f)))))
  66.  
  67. (define (remove-generic-procedure-generators generic tags)
  68.   (for-each (lambda (generator)
  69.           (if (generator generic tags)
  70.           (remove-generic-procedure-generator generic generator)))
  71.         (generic-procedure-generator-list generic)))
  72.  
  73. (define (generic-procedure-default-generator generic)
  74.   (let ((m (generic-procedure-generator generic)))
  75.     (and (multiplexer? m)
  76.      (multiplexer-default m))))
  77.  
  78. (define (set-generic-procedure-default-generator! generic generator)
  79.   (let ((m (generic-procedure-generator generic)))
  80.     (cond ((multiplexer? m)
  81.        (purge-generic-procedure-cache generic)
  82.        (set-multiplexer-default! m generator)
  83.        (maybe-deinstall-multiplexer generic))
  84.       (generator
  85.        (set-multiplexer-default! (install-multiplexer generic)
  86.                      generator)))))
  87.  
  88. (define (install-multiplexer generic)
  89.   (let ((m (make-multiplexer)))
  90.     (let ((g (generic-procedure-generator generic)))
  91.       (if g
  92.       (add-generator m g)))
  93.     (set-generic-procedure-generator! generic m)
  94.     m))
  95.  
  96. (define (add-generator m generator)
  97.   (set-multiplexer-list! m (cons generator (multiplexer-list m))))
  98.  
  99. (define (maybe-deinstall-multiplexer generic)
  100.   (let* ((m (generic-procedure-generator generic))
  101.      (generators (multiplexer-list m)))
  102.     (cond ((and (null? generators)
  103.         (not (multiplexer-default m)))
  104.        (set-generic-procedure-generator! generic #f))
  105.       ((and (null? (cdr generators))
  106.         (not (multiplexer-default m)))
  107.        (set-generic-procedure-generator! generic (car generators))))))
  108.  
  109. (define (make-multiplexer)
  110.   (make-entity (lambda (multiplexer generic tags)
  111.          (multiplexer-dispatch multiplexer generic tags))
  112.            (make-multiplexer-record '() #f)))
  113.  
  114. (define (multiplexer? object)
  115.   (and (entity? object)
  116.        (multiplexer-record? (entity-extra object))))
  117.  
  118. (define (multiplexer-list multiplexer)
  119.   (multiplexer-record/list (entity-extra multiplexer)))
  120.  
  121. (define (set-multiplexer-list! multiplexer list)
  122.   (set-multiplexer-record/list! (entity-extra multiplexer) list))
  123.  
  124. (define (multiplexer-default multiplexer)
  125.   (multiplexer-record/default (entity-extra multiplexer)))
  126.  
  127. (define (set-multiplexer-default! multiplexer default)
  128.   (set-multiplexer-record/default! (entity-extra multiplexer) default))
  129.  
  130. (define-structure (multiplexer-record (conc-name multiplexer-record/))
  131.   list
  132.   default)
  133.  
  134. (define (multiplexer-dispatch multiplexer generic tags)
  135.   (let loop ((generators (multiplexer-list multiplexer)))
  136.     (if (null? generators)
  137.     (let ((default (multiplexer-default multiplexer)))
  138.       (and default
  139.            (default generic tags)))
  140.     (let ((procedure ((car generators) generic tags)))
  141.       (cond ((not procedure)
  142.          (loop (cdr generators)))
  143.         ((there-exists? (cdr generators)
  144.            (lambda (generator)
  145.              (generator generic tags)))
  146.          (lambda args
  147.            (error:extra-applicable-methods generic args)))
  148.         (else procedure))))))
  149.  
  150. (define multiplexer-tag)
  151. (define del-rassq)
  152. (define condition-type:extra-applicable-methods)
  153. (define error:extra-applicable-methods)
  154.  
  155. (define (initialize-multiplexer!)
  156.   (set! multiplexer-tag (list 'GENERIC-PROCEDURE-MULTIPLEXER))
  157.   (set! del-rassq (delete-association-procedure list-deletor eq? cdr))
  158.   unspecific)
  159.  
  160. (define (initialize-conditions!)
  161.   (set! condition-type:extra-applicable-methods
  162.     (make-condition-type 'EXTRA-APPLICABLE-METHODS condition-type:error
  163.         '(OPERATOR OPERANDS)
  164.       (lambda (condition port)
  165.         (write-string "Too many applicable methods for " port)
  166.         (write (access-condition condition 'OPERATOR) port)
  167.         (write-string " with these arguments: " port)
  168.         (write (access-condition condition 'OPERANDS) port)
  169.         (write-string "." port))))
  170.   (set! error:extra-applicable-methods
  171.     (condition-signaller condition-type:extra-applicable-methods
  172.                  '(OPERATOR OPERANDS)
  173.                  standard-error-handler))
  174.   unspecific)