Lib/chicken/tinyclos-multi-generic.patch

   1 # This patch is against chicken 1.92, but it should work just fine
   2 # with older versions of chicken.  It adds support for mulit-argument
   3 # generics, that is, generics now correctly handle adding methods
   4 # with different lengths of specializer lists
   5
   6 # This patch has been committed into the CHICKEN darcs repository,
   7 # so chicken versions above 1.92 work fine.
   8
   9 # Comments, bugs, suggestions send to chicken-users@nongnu.org
  10
  11 # Patch written by John Lenz <lenz@cs.wisc.edu>
  12
  13 --- tinyclos.scm.old    2005-04-05 01:13:56.000000000 -0500
  14 +++ tinyclos.scm        2005-04-11 16:37:23.746181489 -0500
  15 @@ -37,8 +37,10 @@
  16
  17  (include "parameters")
  18
  19 +(cond-expand [(not chicken-compile-shared) (declare (unit tinyclos))]
  20 +            [else] )
  21 +
  22  (declare
  23 -  (unit tinyclos)
  24    (uses extras)
  25    (usual-integrations)
  26    (fixnum)
  27 @@ -234,7 +236,10 @@
  28              y = C_block_item(y, 1);
  29            }
  30          }
  31 -        return(C_block_item(v, i + 1));
  32 +        if (x == C_SCHEME_END_OF_LIST && y == C_SCHEME_END_OF_LIST)
  33 +          return(C_block_item(v, i + 1));
  34 +        else
  35 +          goto mismatch;
  36        }
  37        else if(free_index == -1) free_index = i;
  38      mismatch:
  39 @@ -438,7 +443,7 @@
  40  (define hash-arg-list
  41    (foreign-lambda* unsigned-int ((scheme-object args) (scheme-object svector)) "
  42      C_word tag, h, x;
  43 -    int n, i, j;
  44 +    int n, i, j, len = 0;
  45      for(i = 0; args != C_SCHEME_END_OF_LIST; args = C_block_item(args, 1)) {
  46        x = C_block_item(args, 0);
  47        if(C_immediatep(x)) {
  48 @@ -481,8 +486,9 @@
  49          default: i += 255;
  50          }
  51        }
  52 +      ++len;
  53      }
  54 -    return(i & (C_METHOD_CACHE_SIZE - 1));") )
  55 +    return((i + len) & (C_METHOD_CACHE_SIZE - 1));") )
  56
  57
  58  ;
  59 @@ -868,13 +874,27 @@
  60      (##tinyclos#slot-set!
  61       generic
  62       'methods
  63 -     (cons method
  64 -          (filter-in
  65 -           (lambda (m)
  66 -             (let ([ms1 (method-specializers m)]
  67 -                   [ms2 (method-specializers method)] )
  68 -               (not (every2 (lambda (x y) (eq? x y)) ms1 ms2) ) ) )
  69 -           (##tinyclos#slot-ref generic 'methods))))
  70 +     (let* ([ms1 (method-specializers method)]
  71 +           [l1 (length ms1)] )
  72 +       (let filter-in-method ([methods (##tinyclos#slot-ref generic 'methods)])
  73 +        (if (null? methods)
  74 +            (list method)
  75 +            (let* ([mm (##sys#slot methods 0)]
  76 +                   [ms2 (method-specializers mm)]
  77 +                   [l2 (length ms2)])
  78 +              (cond ((> l1 l2)
  79 +                     (cons mm (filter-in-method (##sys#slot methods 1))))
  80 +                    ((< l1 l2)
  81 +                     (cons method methods))
  82 +                    (else
  83 +                     (let check-method ([ms1 ms1]
  84 +                                        [ms2 ms2])
  85 +                       (cond ((and (null? ms1) (null? ms2))
  86 +                              (cons method (##sys#slot methods 1))) ;; skip the method already in the generic
  87 +                             ((eq? (##sys#slot ms1 0) (##sys#slot ms2 0))
  88 +                              (check-method (##sys#slot ms1 1) (##sys#slot ms2 1)))
  89 +                             (else
  90 +                              (cons mm (filter-in-method (##sys#slot methods 1)))))))))))))
  91      (if (memq generic generic-invocation-generics)
  92         (set! method-cache-tag (vector))
  93         (%entity-cache-set! generic #f) )
  94 @@ -925,11 +945,13 @@
  95                                 (memq (car args) generic-invocation-generics))
  96                            (let ([proc
  97                                   (method-procedure
  98 +                                   ; select the first method of one argument
  99                                    (let lp ([lis (generic-methods generic)])
 100 -                                    (let ([tail (##sys#slot lis 1)])
 101 -                                      (if (null? tail)
 102 -                                          (##sys#slot lis 0)
 103 -                                          (lp tail)) ) ) ) ] )
 104 +                                    (if (null? lis)
 105 +                                      (##sys#error "Unable to find original compute-apply-generic")
 106 +                                      (if (= (length (method-specializers (##sys#slot lis 0))) 1)
 107 +                                        (##sys#slot lis 0)
 108 +                                        (lp (##sys#slot lis 1)))))) ] )
 109                              (lambda (args) (apply proc #f args)) )
 110                            (let ([x (compute-apply-methods generic)]
 111                                  [y ((compute-methods generic) args)] )
 112 @@ -946,9 +968,13 @@
 113        (lambda (args)
 114         (let ([applicable
 115                (filter-in (lambda (method)
 116 -                           (every2 applicable?
 117 -                                  (method-specializers method)
 118 -                                  args))
 119 +                            (let check-applicable ([list1 (method-specializers method)]
 120 +                                                   [list2 args])
 121 +                              (cond ((null? list1) #t)
 122 +                                    ((null? list2) #f)
 123 +                                    (else
 124 +                                      (and (applicable? (##sys#slot list1 0) (##sys#slot list2 0))
 125 +                                           (check-applicable (##sys#slot list1 1) (##sys#slot list2 1)))))))
 126                           (generic-methods generic) ) ] )
 127           (if (or (null? applicable) (null? (##sys#slot applicable 1)))
 128               applicable
 129 @@ -975,8 +1001,10 @@
 130            [else
 131             (cond ((and (null? specls1) (null? specls2))
 132                    (##sys#error "two methods are equally specific" generic))
 133 -                 ((or (null? specls1) (null? specls2))
 134 -                  (##sys#error "two methods have different number of specializers" generic))
 135 +                 ;((or (null? specls1) (null? specls2))
 136 +                 ; (##sys#error "two methods have different number of specializers" generic))
 137 +                  ((null? specls1) #f)
 138 +                  ((null? specls2) #t)
 139                   ((null? args)
 140                    (##sys#error "fewer arguments than specializers" generic))
 141                   (else
 142 @@ -1210,7 +1238,7 @@
 143  (define <structure>      (make-primitive-class "structure"))
 144  (define <procedure> (make-primitive-class "procedure" <procedure-class>))
 145  (define <end-of-file> (make-primitive-class "end-of-file"))
 146 -(define <environment> (make-primitive-class "environment" <structure>))        ; (Benedikt insisted on this)
 147 +(define <environment> (make-primitive-class "environment" <structure>))
 148  (define <hash-table> (make-primitive-class "hash-table" <structure>))
 149  (define <promise> (make-primitive-class "promise" <structure>))
 150  (define <queue> (make-primitive-class "queue" <structure>))