tests/clos-method-combination-redefinition.impure.lisp

   1 ;;;; testing method combination redefinition
   2
   3 ;;;; This software is part of the SBCL system. See the README file for
   4 ;;;; more information.
   5 ;;;;
   6 ;;;; While most of SBCL is derived from the CMU CL system, the test
   7 ;;;; files (like this one) were written from scratch after the fork
   8 ;;;; from CMU CL.
   9 ;;;;
  10 ;;;; This software is in the public domain and is provided with
  11 ;;;; absolutely no warranty. See the COPYING and CREDITS files for
  12 ;;;; more information.
  13
  14 (defpackage "CLOS-METHOD-COMBINATION-REDEFINITION"
  15   (:use "COMMON-LISP" "TEST-UTIL"))
  16
  17 (in-package "CLOS-METHOD-COMBINATION-REDEFINITION")
  18 \f
  19 ;;;; long-form method combination redefinition
  20
  21 ;;; first, define a method combination
  22 (define-method-combination long-or ()
  23   ((primary () :required t))
  24   `(or ,@(reverse (mapcar (lambda (m) `(call-method ,m)) primary))))
  25
  26 ;;; GF has standard method combination
  27 (defgeneric long-or-test (x)
  28   (:method ((x fixnum)) 'fixnum)
  29   (:method ((x integer)) 'integer)
  30   (:method ((x number)) 'number))
  31
  32 (with-test (:name (:method-combination standard))
  33   (assert (eql (long-or-test 3) 'fixnum))
  34   (assert (eql (long-or-test (1+ most-positive-fixnum)) 'integer))
  35   (assert (eql (long-or-test 3.2) 'number)))
  36
  37 ;;; add the method combination
  38 (defgeneric long-or-test (x)
  39   (:method ((x fixnum)) 'fixnum)
  40   (:method ((x integer)) 'integer)
  41   (:method ((x number)) 'number)
  42   (:method-combination long-or))
  43
  44 (with-test (:name (:method-combination :long-or-reverse))
  45   (assert (eql (long-or-test 3) 'number))
  46   (assert (eql (long-or-test (1+ most-positive-fixnum)) 'number))
  47   (assert (eql (long-or-test 3.2) 'number)))
  48
  49 ;;; redefine the method combination
  50 (define-method-combination long-or ()
  51   ((primary () :required t))
  52   `(or ,@(mapcar (lambda (m) `(call-method ,m)) primary)))
  53
  54 (with-test (:name (:method-combination :long-or))
  55   (assert (eql (long-or-test 3) 'fixnum))
  56   (assert (eql (long-or-test (1+ most-positive-fixnum)) 'integer))
  57   (assert (eql (long-or-test 3.2) 'number)))
  58 \f
  59 ;;;; short-form method-combination redefiniton
  60
  61 ;;; define a method-combination
  62 (define-method-combination div :operator /)
  63
  64 (defgeneric short-div (x)
  65   (:method-combination div :most-specific-first)
  66   (:method div ((x number)) 4)
  67   (:method div ((x fixnum)) 8))
  68
  69 (with-test (:name (:method-combination :short-div))
  70   (assert (= (short-div 3) 2))
  71   (assert (= (short-div 3.0) 1/4)))
  72
  73 ;;; check that changing method-combination options works
  74 (defgeneric short-div (x)
  75   (:method-combination div :most-specific-last)
  76   (:method div ((x number)) 4)
  77   (:method div ((x fixnum)) 8))
  78
  79 (with-test (:name (:method-combination :short-div :most-specific-last))
  80   (assert (= (short-div 3) 1/2))
  81   (assert (= (short-div 3.0) 1/4)))
  82
  83 ;;; check that choosing new short-form options works
  84 (define-method-combination div :operator / :identity-with-one-argument t)
  85
  86 (with-test (:name (:method-combination :short-div :identity-with-one-argument))
  87   (assert (= (short-div 3) 1/2))
  88   (assert (= (short-div 3.0) 4)))
  89
  90 ;;; check that changing method-combination options works (deletion of :most-specific-last)
  91 (defgeneric short-div (x)
  92   (:method-combination div)
  93   (:method div ((x number)) 4)
  94   (:method div ((x fixnum)) 8))
  95
  96 (with-test (:name (:method-combination :short-div :identity-with-one-argument :most-specific-first))
  97   (assert (= (short-div 3) 2))
  98   (assert (= (short-div 3.0) 4)))
  99
 100 ;;; check that changing operator works
 101 (define-method-combination div :operator -)
 102
 103 (with-test (:name (:method-combination :short-div :operator -))
 104   (assert (= (short-div 3) 4))
 105   (assert (= (short-div 3.0) -4)))
 106
 107 \f
 108 ;;;; modifying the need for args-lambda-list
 109
 110 ;;; define a fancy method combination.  (Happens to implement a finite state machine)
 111 (define-method-combination fsm (default-start)
 112   ((primary *))
 113   `(let ((state ',default-start))
 114      (restart-bind
 115          (,@(mapcar (lambda (m) `(,(first (method-qualifiers m))
 116                                    (lambda ()
 117                                      (setq state (call-method ,m))
 118                                      (if (and (typep state '(and symbol (not null)))
 119                                               (find-restart state))
 120                                          (invoke-restart state)
 121                                          state))))
 122                     primary))
 123        (invoke-restart state))))
 124
 125 (defclass parse-state ()
 126   ((string :initarg :string)
 127    (index :initform 0)))
 128
 129 ;;; use the finite state machine to recognize strings with an even
 130 ;;; number of #\a characters
 131 (defgeneric even-as (state &key &allow-other-keys)
 132   (:method-combination fsm yes)
 133   (:method yes (state &key)
 134     (with-slots ((s string) (i index)) state
 135       (cond ((= i (length s)) t) ((char= (char s i) #\a) (incf i) 'no) (t (incf i) 'yes))))
 136   (:method no (state &key)
 137     (with-slots ((s string) (i index)) state
 138       (cond ((= i (length s)) nil) ((char= (char s i) #\a) (incf i) 'yes) (t (incf i) 'no)))))
 139
 140 ;;; test.  (The non-functional :START argument tests are to contrast
 141 ;;; with what happens next)
 142 (with-test (:name (:method-combination :finite-state-machine))
 143   (assert (even-as (make-instance 'parse-state :string "abcbab")))
 144   (assert (even-as (make-instance 'parse-state :string "abcbab") :start 'no))
 145   (assert (not (even-as (make-instance 'parse-state :string "abcbabab"))))
 146   (assert (not (even-as (make-instance 'parse-state :string "abcbabab") :start 'no))))
 147
 148 ;;; generalize: if we allow the call site to specify the initial
 149 ;;; state, our FSM method combination is more expressive.
 150 (define-method-combination fsm (default-start)
 151   ((primary *))
 152   (:arguments &key start)
 153   `(let ((state (or ,start ',default-start)))
 154      (restart-bind
 155          (,@(mapcar (lambda (m) `(,(first (method-qualifiers m))
 156                                    (lambda ()
 157                                      (setq state (call-method ,m))
 158                                      (if (and (typep state '(and symbol (not null)))
 159                                               (find-restart state))
 160                                          (invoke-restart state)
 161                                          state))))
 162                     primary))
 163        (invoke-restart state))))
 164
 165 (with-test (:name (:method-combination :finite-state-machine :redefinition :args-lambda-list))
 166   (assert (even-as (make-instance 'parse-state :string "abcbab")))
 167   (assert (not (even-as (make-instance 'parse-state :string "abcbab") :start 'no)))
 168   (assert (not (even-as (make-instance 'parse-state :string "abcbabab"))))
 169   (assert (even-as (make-instance 'parse-state :string "abcbabab") :start 'no)))
 170 \f
 171 ;;;; changing between short- and long-form method combination
 172 (define-method-combination maximum :operator max)
 173
 174 (defgeneric maxx (x)
 175   (:method-combination maximum)
 176   (:method maximum ((x symbol)) 3)
 177   (:method maximum ((x list)) 4)
 178   (:method maximum ((x null)) 5))
 179
 180 (with-test (:name (:method-combination :maximum))
 181   (assert (= (maxx nil) 5))
 182   (assert (= (maxx '(3 4)) 4))
 183   (assert (= (maxx t) 3)))
 184
 185 (define-method-combination maximum ()
 186   ((maximum (maximum)))
 187   `(min ,@(mapcar (lambda (m) `(call-method ,m)) maximum)))
 188
 189 (with-test (:name (:method-combination :maximum :redefined-long))
 190   (assert (= (maxx nil) 3))
 191   (assert (= (maxx '(3 4)) 4))
 192   (assert (= (maxx t) 3)))
 193
 194 (define-method-combination maximum :operator -)
 195
 196 (with-test (:name (:method-combination :maximum :redefined-short))
 197   (assert (= (maxx nil) -2))
 198   (assert (= (maxx '(3 4)) -4))
 199   (assert (= (maxx t) -3)))