Lib/chicken/multi-generic.scm

   1 ;; This file is no longer necessary with Chicken versions above 1.92
   2 ;;
   3 ;; This file overrides two functions inside TinyCLOS to provide support
   4 ;; for multi-argument generics.  There are many ways of linking this file
   5 ;; into your code... all that needs to happen is this file must be
   6 ;; executed after loading TinyCLOS but before any SWIG modules are loaded
   7 ;;
   8 ;; something like the following
   9 ;; (require 'tinyclos)
  10 ;; (load "multi-generic")
  11 ;; (declare (uses swigmod))
  12 ;;
  13 ;; An alternative to loading this scheme code directly is to add a
  14 ;; (declare (unit multi-generic)) to the top of this file, and then
  15 ;; compile this into the final executable or something.  Or compile
  16 ;; this into an extension.
  17
  18 ;; Lastly, to override TinyCLOS method creation, two functions are
  19 ;; overridden: see the end of this file for which two are overridden.
  20 ;; You might want to remove those two lines and then exert more control over
  21 ;; which functions are used when.
  22
  23 ;; Comments, bugs, suggestions: send either to chicken-users@nongnu.org or to
  24 ;; Author: John Lenz <lenz@cs.wisc.edu>, most code copied from TinyCLOS
  25
  26 (define <multi-generic> (make <entity-class>
  27                           'name "multi-generic"
  28                           'direct-supers (list <generic>)
  29                           'direct-slots '()))
  30
  31 (letrec ([applicable?
  32           (lambda (c arg)
  33             (memq c (class-cpl (class-of arg))))]
  34
  35          [more-specific?
  36           (lambda (c1 c2 arg)
  37             (memq c2 (memq c1 (class-cpl (class-of arg)))))]
  38
  39          [filter-in
  40            (lambda (f l)
  41              (if (null? l)
  42                  '()
  43                  (let ([h (##sys#slot l 0)]
  44                        [r (##sys#slot l 1)] )
  45                    (if (f h)
  46                        (cons h (filter-in f r))
  47                        (filter-in f r) ) ) ) )])
  48
  49 (add-method compute-apply-generic
  50   (make-method (list <multi-generic>)
  51     (lambda (call-next-method generic)
  52       (lambda args
  53                 (let ([cam (let ([x (compute-apply-methods generic)]
  54                                  [y ((compute-methods generic) args)] )
  55                              (lambda (args) (x y args)) ) ] )
  56                   (cam args) ) ) ) ) )
  57
  58
  59
  60 (add-method compute-methods
  61   (make-method (list <multi-generic>)
  62     (lambda (call-next-method generic)
  63       (lambda (args)
  64         (let ([applicable
  65                (filter-in (lambda (method)
  66                             (let check-applicable ([list1 (method-specializers method)]
  67                                                    [list2 args])
  68                               (cond ((null? list1) #t)
  69                                     ((null? list2) #f)
  70                                     (else
  71                                       (and (applicable? (##sys#slot list1 0) (##sys#slot list2 0))
  72                                            (check-applicable (##sys#slot list1 1) (##sys#slot list2 1)))))))
  73                           (generic-methods generic) ) ] )
  74           (if (or (null? applicable) (null? (##sys#slot applicable 1)))
  75               applicable
  76               (let ([cmms (compute-method-more-specific? generic)])
  77                 (sort applicable (lambda (m1 m2) (cmms m1 m2 args))) ) ) ) ) ) ) )
  78
  79 (add-method compute-method-more-specific?
  80   (make-method (list <multi-generic>)
  81     (lambda (call-next-method generic)
  82       (lambda (m1 m2 args)
  83         (let loop ((specls1 (method-specializers m1))
  84                    (specls2 (method-specializers m2))
  85                    (args args))
  86           (cond-expand
  87            [unsafe
  88             (let ((c1  (##sys#slot specls1 0))
  89                   (c2  (##sys#slot specls2 0))
  90                   (arg (##sys#slot args 0)))
  91               (if (eq? c1 c2)
  92                   (loop (##sys#slot specls1 1)
  93                         (##sys#slot specls2 1)
  94                         (##sys#slot args 1))
  95                   (more-specific? c1 c2 arg))) ]
  96            [else
  97             (cond ((and (null? specls1) (null? specls2))
  98                    (##sys#error "two methods are equally specific" generic))
  99                   ;((or (null? specls1) (null? specls2))
 100                   ; (##sys#error "two methods have different number of specializers" generic))
 101                   ((null? specls1) #f)
 102                   ((null? specls2) #t)
 103                   ((null? args)
 104                    (##sys#error "fewer arguments than specializers" generic))
 105                   (else
 106                    (let ((c1  (##sys#slot specls1 0))
 107                          (c2  (##sys#slot specls2 0))
 108                          (arg (##sys#slot args 0)))
 109                      (if (eq? c1 c2)
 110                          (loop (##sys#slot specls1 1)
 111                                (##sys#slot specls2 1)
 112                                (##sys#slot args 1))
 113                          (more-specific? c1 c2 arg)))) ) ] ) ) ) ) ) )
 114
 115 ) ;; end of letrec
 116
 117 (define multi-add-method
 118   (lambda (generic method)
 119     (slot-set!
 120      generic
 121      'methods
 122        (let filter-in-method ([methods (slot-ref generic 'methods)])
 123          (if (null? methods)
 124            (list method)
 125            (let ([l1 (length (method-specializers method))]
 126                  [l2 (length (method-specializers (##sys#slot methods 0)))])
 127              (cond ((> l1 l2)
 128                     (cons (##sys#slot methods 0) (filter-in-method (##sys#slot methods 1))))
 129                    ((< l1 l2)
 130                     (cons method methods))
 131                    (else
 132                      (let check-method ([ms1 (method-specializers method)]
 133                                         [ms2 (method-specializers (##sys#slot methods 0))])
 134                        (cond ((and (null? ms1) (null? ms2))
 135                               (cons method (##sys#slot methods 1))) ;; skip the method already in the generic
 136                              ((eq? (##sys#slot ms1 0) (##sys#slot ms2 0))
 137                               (check-method (##sys#slot ms1 1) (##sys#slot ms2 1)))
 138                              (else
 139                                (cons (##sys#slot methods 0) (filter-in-method (##sys#slot methods 1))))))))))))
 140
 141     (##sys#setslot (##sys#slot generic (- (##sys#size generic) 2)) 1 (compute-apply-generic generic)) ))
 142
 143 (define (multi-add-global-method val sym specializers proc)
 144   (let ((generic (if (procedure? val) val (make <multi-generic> 'name (##sys#symbol->string sym)))))
 145     (multi-add-method generic (make-method specializers proc))
 146     generic))
 147
 148 ;; Might want to remove these, or perhaps do something like
 149 ;; (define old-add-method ##tinyclos#add-method)
 150 ;; and then you can switch between creating multi-generics and TinyCLOS generics.
 151 (set! ##tinyclos#add-method multi-add-method)
 152 (set! ##tinyclos#add-global-method multi-add-global-method)