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 / sos / method.scm < prev    next >
Text File  |  1999-01-02  |  16KB  |  491 lines
  1. ;;; -*-Scheme-*-
  2. ;;;
  3. ;;; $Id: method.scm,v 1.11 1999/01/02 06:19:10 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. ;;;; Methods and Effective Method Procedures
  22.  
  23. (declare (usual-integrations))
  24.  
  25. ;;;; Adding/Removing Methods
  26.  
  27. (define (add-method generic method)
  28.   (guarantee-valid-method method generic 'ADD-METHOD)
  29.   (for-each
  30.    (lambda (method)
  31.      (modify-methods generic
  32.        (lambda (methods)
  33.      (let ((tail
  34.         (if (computed-emp? method)
  35.             (and (computed-emp-key method)
  36.              (computed-emp-member method methods))
  37.             (method-member method methods))))
  38.        (if tail
  39.            (begin
  40.          (warn "Replacing method"
  41.                (car tail)
  42.                (error-irritant/noise " with")
  43.                method
  44.                (error-irritant/noise " in procedure")
  45.                generic
  46.                (error-irritant/noise "."))
  47.          (set-car! tail method)
  48.          methods)
  49.            (cons method methods))))))
  50.    (if (computed-emp? method)
  51.        (list method)
  52.        (enumerate-union-specializers method)))
  53.   (if (computed-emp? method)
  54.       (purge-generic-procedure-cache generic)
  55.       (purge-method-entries generic method)))
  56.  
  57. (define method-member
  58.   (member-procedure
  59.    (lambda (x y)
  60.      (and (not (computed-emp? x))
  61.       (not (computed-emp? y))
  62.       (specializers=? (method-specializers x) (method-specializers y))))))
  63.  
  64. (define computed-emp-member
  65.   (member-procedure
  66.    (lambda (x y)
  67.      (and (computed-emp? x)
  68.       (computed-emp? y)
  69.       (equal? (computed-emp-key x) (computed-emp-key y))))))
  70.  
  71. (define (delete-method generic method)
  72.   (guarantee-valid-method method generic 'DELETE-METHOD)
  73.   (modify-methods generic (lambda (methods) (delq! method methods)))
  74.   (purge-method-entries generic method))
  75.  
  76. (define (guarantee-valid-method method generic name)
  77.   (guarantee-method method name)
  78.   (guarantee-generic-procedure generic name)
  79.   ;; Assumes that method instantiation has guaranteed that there is at
  80.   ;; least one specializer.  This is handled by GUARANTEE-SPECIALIZERS.
  81.   (if (< (arity-min (generic-procedure-arity generic))
  82.      (length (method-specializers method)))
  83.       (error:bad-range-argument method name)))
  84.  
  85. (define (guarantee-method method name)
  86.   (if (not (method? method))
  87.       (error:wrong-type-argument method "method" name)))
  88.  
  89. (define (purge-method-entries generic method)
  90.   (purge-generic-procedure-cache generic
  91.     (lambda (generic tags)
  92.       generic
  93.       (method-applicable? method (map dispatch-tag->class tags)))))
  94.  
  95. (define (add-methods generic methods)
  96.   (for-each (lambda (method) (add-method generic method)) methods))
  97.  
  98. ;;;; Method Combinators
  99.  
  100. (define (method-combinator-record generic intern?)
  101.   (let ((combinator
  102.      (or (list-search-positive (generic-procedure-generator-list generic)
  103.            method-combinator?)
  104.          (and intern?
  105.           (let ((combinator (make-method-combinator)))
  106.             (add-generic-procedure-generator generic combinator)
  107.             combinator)))))
  108.     (and combinator
  109.      (apply-hook-extra combinator))))
  110.  
  111. (define (method-combinator? object)
  112.   (and (apply-hook? object)
  113.        (combinator-record? (apply-hook-extra object))))
  114.  
  115. (define (make-method-combinator)
  116.   (make-apply-hook (lambda (generic tags)
  117.              (compute-effective-method-procedure
  118.               generic
  119.               (map dispatch-tag->class tags)))
  120.            (make-combinator-record)))
  121.  
  122. (define-structure (combinator-record (constructor make-combinator-record ()))
  123.   (methods '()))
  124.  
  125. (define (modify-methods generic modifier)
  126.   (let ((record (method-combinator-record generic #t)))
  127.     (set-combinator-record-methods!
  128.      record
  129.      (modifier (combinator-record-methods record)))))
  130.  
  131. (define (generic-procedure-methods generic)
  132.   (guarantee-generic-procedure generic 'GENERIC-PROCEDURE-METHODS)
  133.   (let ((record (method-combinator-record generic #f)))
  134.     (if record
  135.     (list-copy (combinator-record-methods record))
  136.     '())))
  137.  
  138. ;;;; Effective Method Procedures
  139.  
  140. (define (compute-method generic classes)
  141.   (let ((emp (compute-effective-method-procedure generic classes)))
  142.     (and emp
  143.      (make-method classes emp))))
  144.  
  145. (define (compute-effective-method-procedure generic classes)
  146.   (or (try-emp-short-circuits generic classes)
  147.       (let ((methods (compute-methods generic classes)))
  148.     (or (try-computed-emps generic classes methods)
  149.         (and (not (null? methods))
  150.          (let loop ((methods methods))
  151.            (if (chained-method? (car methods))
  152.                ((method-procedure (car methods))
  153.             (if (null? (cdr methods))
  154.                 (lambda args
  155.                   (error:no-applicable-methods generic args))
  156.                 (loop (cdr methods))))
  157.                (method-procedure (car methods)))))))))
  158.  
  159. (define (try-computed-emps generic classes methods)
  160.   (let loop
  161.       ((generators
  162.     (sort-methods (list-transform-positive
  163.               (append-map enumerate-union-specializers
  164.                       (list-transform-positive
  165.                       (generic-procedure-methods generic)
  166.                     computed-emp?))
  167.             (lambda (method)
  168.               (method-applicable? method classes)))
  169.               classes)))
  170.     (and (not (null? generators))
  171.      (let ((result (apply (method-procedure (car generators)) classes)))
  172.        (cond ((not result)
  173.           (loop (cdr generators)))
  174.          ((or (there-exists? (cdr generators)
  175.             (lambda (generator)
  176.               (and (specializers=?
  177.                 (method-specializers generator)
  178.                 (method-specializers (car generators)))
  179.                    (apply (method-procedure generator) classes))))
  180.               (there-exists? methods
  181.             (lambda (method)
  182.               (specializers=? (method-specializers method)
  183.                       classes))))
  184.           (lambda args
  185.             (error:extra-applicable-methods generic args)))
  186.          (else result))))))
  187.  
  188. (define (compute-methods generic classes)
  189.   (sort-methods (compute-methods-1 generic classes) classes))
  190.  
  191. (define (compute-methods-1 generic classes)
  192.   (let ((methods
  193.      (list-transform-positive (generic-procedure-methods generic)
  194.        (lambda (method)
  195.          (and (not (computed-emp? method))
  196.           (method-applicable? method classes))))))
  197.     (let ((results (list-transform-negative methods computed-method?)))
  198.       (for-each
  199.        (lambda (method)
  200.      (let ((result (apply (method-procedure method) classes)))
  201.        (if result
  202.            (begin
  203.          (set! results
  204.                (cons (cond ((concrete-method? result)
  205.                     (if (not (restricted-specializers?
  206.                           (method-specializers result)
  207.                           (method-specializers method)))
  208.                     (error
  209.                      "Computed method not restricted:"
  210.                      result method))
  211.                     result)
  212.                    ((procedure? result)
  213.                     (make-method (method-specializers method)
  214.                          result))
  215.                    (else
  216.                     (error
  217.                      "Illegal result from computed method:"
  218.                      result method)))
  219.                  results))
  220.          unspecific))))
  221.        (list-transform-positive methods computed-method?))
  222.       results)))
  223.  
  224. (define (method-applicable? method classes)
  225.   (guarantee-method method 'METHOD-APPLICABLE?)
  226.   (subclasses? classes (method-specializers method)))
  227.  
  228. (define (subclasses? classes specializers)
  229.   (let loop ((classes classes) (specializers specializers))
  230.     (or (null? specializers)
  231.     (and (subclass? (car classes) (car specializers))
  232.          (loop (cdr classes) (cdr specializers))))))
  233.  
  234. (define (sort-methods methods classes)
  235.   (sort methods
  236.     (lambda (m1 m2)
  237.       (let loop
  238.           ((s1 (method-specializers m1))
  239.            (s2 (method-specializers m2))
  240.            (classes classes))
  241.         (and (not (null? s1))
  242.          (or (null? s2)
  243.              (if (eq? (car s1) (car s2))
  244.              (loop (cdr s1) (cdr s2) (cdr classes))
  245.              (memq (car s2)
  246.                    (cdr (memq (car s1)
  247.                       (class-precedence-list
  248.                        (car classes))))))))))))
  249.  
  250. (define (restricted-specializers? s1 s2)
  251.   (let loop ((s1 s1) (s2 s2))
  252.     (or (null? s2)
  253.     (if (null? s1)
  254.         (for-all? s2
  255.           (lambda (s)
  256.         (subclass? <object> s)))
  257.         (and (for-all? (specializer-classes (car s1))
  258.            (lambda (c)
  259.              (subclass? c (car s2))))
  260.          (loop (cdr s1) (cdr s2)))))))
  261.  
  262. ;;;; Method Specializers
  263.  
  264. (define (specializers? object)
  265.   (and (list? object)
  266.        (not (null? object))
  267.        (for-all? object specializer?)))
  268.  
  269. (define (specializer? object)
  270.   (or (class? object)
  271.       (record-type? object)
  272.       (union-specializer? object)))
  273.  
  274. (define (guarantee-specializers specializers non-null? name)
  275.   (if (not (specializers? specializers))
  276.       (error:wrong-type-argument specializers "list of method specializers"
  277.                  name))
  278.   (if (and non-null? (null? specializers))
  279.       (error:bad-range-argument specializers name))
  280.   (map (lambda (specializer)
  281.      (if (record-type? specializer)
  282.          (record-type-class specializer)
  283.          specializer))
  284.        specializers))
  285.  
  286. (define (specializers=? s1 s2)
  287.   (cond ((null? s1)
  288.      (let loop ((s2 s2))
  289.        (or (null? s2)
  290.            (and (eq? <object> (car s2))
  291.             (loop (cdr s2))))))
  292.     ((null? s2)
  293.      (let loop ((s1 s1))
  294.        (and (eq? <object> (car s1))
  295.         (or (null? (cdr s1))
  296.             (loop (cdr s1))))))
  297.     (else
  298.      (and (specializer=? (car s1) (car s2))
  299.           (specializers=? (cdr s1) (cdr s2))))))
  300.  
  301. (define (specializer=? s1 s2)
  302.   (eq-set=? (specializer-classes s1)
  303.         (specializer-classes s2)))
  304.  
  305. (define (eq-set=? x y)
  306.   (and (for-all? x (lambda (x) (memq x y)))
  307.        (for-all? y (lambda (y) (memq y x)))))
  308.  
  309. (define (specializer-classes s)
  310.   (cond ((class? s)
  311.      (list s))
  312.     ((record-type? s)
  313.      (list (record-type-class s)))
  314.     ((union-specializer? s)
  315.      (union-specializer-classes s))
  316.     (else
  317.      (error:wrong-type-argument s "specializer" 'SPECIALIZER-CLASSES))))
  318.  
  319. (define-structure (union-specializer (type-descriptor union-specializer-rtd))
  320.   (classes #f read-only #t))
  321.  
  322. (define (union-specializer . specializers)
  323.   (make-union-specializer
  324.    (eliminate-duplicates
  325.     (append-map specializer-classes
  326.         (guarantee-specializers specializers #f 'UNION-SPECIALIZER)))))
  327.  
  328. (define (eliminate-duplicates items)
  329.   (let loop ((items items) (result '()))
  330.     (if (null? items)
  331.     (reverse! result)
  332.     (loop (cdr items)
  333.           (if (memq (car items) result)
  334.           result
  335.           (cons (car items) result))))))
  336.  
  337. (define (enumerate-union-specializers method)
  338.   (let ((specializers (method-specializers method)))
  339.     (if (let loop ((specializers specializers))
  340.       (and (not (null? specializers))
  341.            (or (union-specializer? (car specializers))
  342.            (loop (cdr specializers)))))
  343.     (map (lambda (specializers)
  344.            (new-method-specializers method specializers))
  345.          (let loop ((specializers specializers))
  346.            (let ((classes (specializer-classes (car specializers))))
  347.          (if (null? (cdr specializers))
  348.              (map (lambda (class) (list class)) classes)
  349.              (let ((tails (loop (cdr specializers))))
  350.                (append-map (lambda (class)
  351.                      (map (lambda (tail)
  352.                         (cons class tail))
  353.                       tails))
  354.                    classes))))))
  355.     (list method))))
  356.  
  357. (define (new-method-specializers method specializers)
  358.   (cond ((computed-method? method)
  359.      (make-computed-method specializers (method-procedure method)))
  360.     ((computed-emp? method)
  361.      (make-computed-emp (computed-emp-key method)
  362.                 specializers
  363.                 (method-procedure method)))
  364.     ((chained-method? method)
  365.      (make-chained-method specializers (method-procedure method)))
  366.     (else
  367.      (make-method specializers (method-procedure method)))))
  368.  
  369. ;;;; Method Types
  370.  
  371. (define <method>
  372.   (make-class '<METHOD> '() '(SPECIALIZERS PROCEDURE)))
  373.  
  374. (define (method? object)
  375.   (instance-of? object <method>))
  376.  
  377. (define method-specializers
  378.   (make-generic-procedure 1 'METHOD-SPECIALIZERS))
  379.  
  380. (define method-procedure
  381.   (make-generic-procedure 1 'METHOD-PROCEDURE))
  382.  
  383.  
  384. (define <concrete-method>
  385.   (make-class '<CONCRETE-METHOD> (list <method>) '()))
  386.  
  387. (define (concrete-method? object)
  388.   (instance-of? object <concrete-method>))
  389.  
  390. (define make-method
  391.   (let ((%make
  392.      (instance-constructor <concrete-method> '(SPECIALIZERS PROCEDURE))))
  393.     (lambda (specializers procedure)
  394.       (%make (guarantee-specializers specializers #t 'MAKE-METHOD)
  395.          procedure))))
  396.  
  397.  
  398. (define <chained-method>
  399.   (make-class '<CHAINED-METHOD> (list <concrete-method>) '()))
  400.  
  401. (define make-chained-method
  402.   (let ((%make
  403.      (instance-constructor <chained-method> '(SPECIALIZERS PROCEDURE))))
  404.     (lambda (specializers procedure)
  405.       (%make (guarantee-specializers specializers #t 'MAKE-CHAINED-METHOD)
  406.          procedure))))
  407.  
  408. (define (chained-method? object)
  409.   (instance-of? object <chained-method>))
  410.  
  411.  
  412. (define <computed-method>
  413.   (make-class '<COMPUTED-METHOD> (list <method>) '()))
  414.  
  415. (define make-computed-method
  416.   (let ((%make
  417.      (instance-constructor <computed-method> '(SPECIALIZERS PROCEDURE))))
  418.     (lambda (specializers procedure)
  419.       (%make (guarantee-specializers specializers #t 'MAKE-COMPUTED-METHOD)
  420.          procedure))))
  421.  
  422. (define (computed-method? object)
  423.   (instance-of? object <computed-method>))
  424.  
  425.  
  426. (define <computed-emp>
  427.   (make-class '<COMPUTED-EMP> (list <method>) '(KEY)))
  428.  
  429. (define make-computed-emp
  430.   (let ((%make
  431.      (instance-constructor <computed-emp> '(KEY SPECIALIZERS PROCEDURE))))
  432.     (lambda (key specializers procedure)
  433.       (%make key
  434.          (guarantee-specializers specializers #t 'MAKE-COMPUTED-EMP)
  435.          procedure))))
  436.  
  437. (define (computed-emp? object)
  438.   (instance-of? object <computed-emp>))
  439.  
  440. (define computed-emp-key
  441.   (make-generic-procedure 1 'COMPUTED-EMP-KEY))
  442.  
  443. ;;; This short-circuits the computation for method accessors.  These
  444. ;;; would otherwise need to be called in order to compute the result
  445. ;;; for themselves, which would cause an infinite loop.  This is done
  446. ;;; as a three-stage process: (1) define the short-circuit hook, (2)
  447. ;;; create method combinators for each of the accessors, to cause the
  448. ;;; hook to be called, and (3) define the ordinary accessor methods,
  449. ;;; which are used when the built-in method classes are subclassed.
  450.  
  451. (define (try-emp-short-circuits generic classes)
  452.   (let ((entry (assq generic emp-short-circuits)))
  453.     (and entry
  454.      (memq (car classes) (cadr entry))
  455.      ((caddr entry) generic (map class->dispatch-tag classes)))))
  456.  
  457. (define emp-short-circuits
  458.   (let ((get-specializers (%record-accessor-generator 'SPECIALIZERS))
  459.     (get-procedure (%record-accessor-generator 'PROCEDURE)))
  460.     (list (list method-specializers
  461.         (list <concrete-method> <chained-method> <computed-method>)
  462.         get-specializers)
  463.       (list method-procedure
  464.         (list <concrete-method> <chained-method> <computed-method>)
  465.         get-procedure)
  466.       (list computed-emp-key
  467.         (list <computed-emp>)
  468.         (%record-accessor-generator 'KEY)))))
  469.  
  470. (method-combinator-record method-specializers #t)
  471. (method-combinator-record method-procedure #t)
  472. (method-combinator-record computed-emp-key #t)
  473.  
  474. (set-generic-procedure-default-generator!
  475.  initialize-instance
  476.  (lambda classes classes (lambda arguments arguments unspecific)))
  477.  
  478. (add-method method-specializers
  479.         (slot-accessor-method <method> 'SPECIALIZERS))
  480.  
  481. (add-method method-procedure
  482.         (slot-accessor-method <method> 'PROCEDURE))
  483.  
  484. (add-method computed-emp-key
  485.         (slot-accessor-method <computed-emp> 'KEY))
  486.  
  487. (add-method initialize-instance
  488.         (make-method (list <instance>)
  489.              (lambda (instance) instance unspecific)))
  490.  
  491. (set-generic-procedure-default-generator! initialize-instance #f)