| 1 | |
|---|
| 2 | ;;; clos-tests.lisp |
|---|
| 3 | ;;; |
|---|
| 4 | ;;; Copyright (C) 2010 Erik Huelsmann |
|---|
| 5 | ;;; |
|---|
| 6 | ;;; This program is free software; you can redistribute it and/or |
|---|
| 7 | ;;; modify it under the terms of the GNU General Public License |
|---|
| 8 | ;;; as published by the Free Software Foundation; either version 2 |
|---|
| 9 | ;;; of the License, or (at your option) any later version. |
|---|
| 10 | ;;; |
|---|
| 11 | ;;; This program is distributed in the hope that it will be useful, |
|---|
| 12 | ;;; but WITHOUT ANY WARRANTY; without even the implied warranty of |
|---|
| 13 | ;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the |
|---|
| 14 | ;;; GNU General Public License for more details. |
|---|
| 15 | ;;; |
|---|
| 16 | ;;; You should have received a copy of the GNU General Public License |
|---|
| 17 | ;;; along with this program; if not, write to the Free Software |
|---|
| 18 | ;;; Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA. |
|---|
| 19 | |
|---|
| 20 | |
|---|
| 21 | ;; These tests are in clos tests, because e.g. D-M-C isn't mop, but *is* clos |
|---|
| 22 | |
|---|
| 23 | (in-package #:abcl.test.lisp) |
|---|
| 24 | |
|---|
| 25 | |
|---|
| 26 | |
|---|
| 27 | ;; tests for D-M-C, long form, some taken from SBCL |
|---|
| 28 | |
|---|
| 29 | ;; D-M-C should return the name of the new method combination, nothing else. |
|---|
| 30 | |
|---|
| 31 | (deftest dmc-return.1 |
|---|
| 32 | (define-method-combination dmc-test-return-foo) |
|---|
| 33 | dmc-test-return-foo) |
|---|
| 34 | |
|---|
| 35 | (deftest dmc-return.2 |
|---|
| 36 | (define-method-combination dmc-test-return-bar :operator and) |
|---|
| 37 | dmc-test-return-bar) |
|---|
| 38 | |
|---|
| 39 | (deftest dmc-return.3 |
|---|
| 40 | (define-method-combination dmc-test-return |
|---|
| 41 | (&optional (order :most-specific-first)) |
|---|
| 42 | ((around (:around)) |
|---|
| 43 | (primary (dmc-test-return) :order order :required t)) |
|---|
| 44 | (let ((form (if (rest primary) |
|---|
| 45 | `(and ,@(mapcar #'(lambda (method) |
|---|
| 46 | `(call-method ,method)) |
|---|
| 47 | primary)) |
|---|
| 48 | `(call-method ,(first primary))))) |
|---|
| 49 | (if around |
|---|
| 50 | `(call-method ,(first around) |
|---|
| 51 | (,@(rest around) |
|---|
| 52 | (make-method ,form))) |
|---|
| 53 | form))) |
|---|
| 54 | dmc-test-return) |
|---|
| 55 | |
|---|
| 56 | ;; A method combination which originally failed; |
|---|
| 57 | ;; for different reasons in SBCL than in ABCL (hence leaving out |
|---|
| 58 | ;; the original comment) |
|---|
| 59 | |
|---|
| 60 | (define-method-combination dmc-test-mc.1 |
|---|
| 61 | (&optional (order :most-specific-first)) |
|---|
| 62 | ((around (:around)) |
|---|
| 63 | (primary (dmc-test-mc) :order order :required t)) |
|---|
| 64 | (let ((form (if (rest primary) |
|---|
| 65 | `(and ,@(mapcar #'(lambda (method) |
|---|
| 66 | `(call-method ,method)) |
|---|
| 67 | primary)) |
|---|
| 68 | `(call-method ,(first primary))))) |
|---|
| 69 | (if around |
|---|
| 70 | `(call-method ,(first around) |
|---|
| 71 | (,@(rest around) |
|---|
| 72 | (make-method ,form))) |
|---|
| 73 | form))) |
|---|
| 74 | |
|---|
| 75 | (defgeneric dmc-test-mc.1 (&key k) (:method-combination dmc-test-mc.1)) |
|---|
| 76 | |
|---|
| 77 | (defmethod dmc-test-mc.1 dmc-test-mc (&key k) |
|---|
| 78 | k) |
|---|
| 79 | |
|---|
| 80 | (deftest dmc-test-mc.1 |
|---|
| 81 | (dmc-test-mc.1 :k 1) |
|---|
| 82 | 1) |
|---|
| 83 | |
|---|
| 84 | |
|---|
| 85 | ;; Completely DIY -- also taken from SBCL: |
|---|
| 86 | (define-method-combination dmc-test-mc.2 () |
|---|
| 87 | ((all-methods *)) |
|---|
| 88 | (do ((methods all-methods (rest methods)) |
|---|
| 89 | (primary nil) |
|---|
| 90 | (around nil)) |
|---|
| 91 | ((null methods) |
|---|
| 92 | (let ((primary (nreverse primary)) |
|---|
| 93 | (around (nreverse around))) |
|---|
| 94 | (if primary |
|---|
| 95 | (let ((form (if (rest primary) |
|---|
| 96 | `(call-method ,(first primary) ,(rest primary)) |
|---|
| 97 | `(call-method ,(first primary))))) |
|---|
| 98 | (if around |
|---|
| 99 | `(call-method ,(first around) (,@(rest around) |
|---|
| 100 | (make-method ,form))) |
|---|
| 101 | form)) |
|---|
| 102 | `(make-method (error "No primary methods"))))) |
|---|
| 103 | (let* ((method (first methods)) |
|---|
| 104 | (qualifier (first (method-qualifiers method)))) |
|---|
| 105 | (cond |
|---|
| 106 | ((equal :around qualifier) |
|---|
| 107 | (push method around)) |
|---|
| 108 | ((null qualifier) |
|---|
| 109 | (push method primary)))))) |
|---|
| 110 | |
|---|
| 111 | (defgeneric dmc-test-mc.2a (val) |
|---|
| 112 | (:method-combination dmc-test-mc.2)) |
|---|
| 113 | |
|---|
| 114 | (defmethod dmc-test-mc.2a ((val number)) |
|---|
| 115 | (+ val (if (next-method-p) (call-next-method) 0))) |
|---|
| 116 | |
|---|
| 117 | (deftest dmc-test-mc.2a |
|---|
| 118 | (= (dmc-test-mc.2a 13) 13) |
|---|
| 119 | T) |
|---|
| 120 | |
|---|
| 121 | (defgeneric dmc-test-mc.2b (val) |
|---|
| 122 | (:method-combination dmc-test-mc.2)) |
|---|
| 123 | |
|---|
| 124 | (defmethod dmc-test-mc.2b ((val number)) |
|---|
| 125 | (+ val (if (next-method-p) (call-next-method) 0))) |
|---|
| 126 | |
|---|
| 127 | (defmethod dmc-test-mc.2b :around ((val number)) |
|---|
| 128 | (+ val (if (next-method-p) (call-next-method) 0))) |
|---|
| 129 | |
|---|
| 130 | (deftest dmc-test-mc.2b |
|---|
| 131 | (= 26 (dmc-test-mc.2b 13)) |
|---|
| 132 | T) |
|---|
| 133 | |
|---|
| 134 | |
|---|
| 135 | ;;; Taken from SBCL: error when method sorting is ambiguous |
|---|
| 136 | ;;; with multiple method groups |
|---|
| 137 | |
|---|
| 138 | (define-method-combination dmc-test-mc.3a () |
|---|
| 139 | ((around (:around)) |
|---|
| 140 | (primary * :required t)) |
|---|
| 141 | (let ((form (if (rest primary) |
|---|
| 142 | `(call-method ,(first primary) ,(rest primary)) |
|---|
| 143 | `(call-method ,(first primary))))) |
|---|
| 144 | (if around |
|---|
| 145 | `(call-method ,(first around) (,@(rest around) |
|---|
| 146 | (make-method ,form))) |
|---|
| 147 | form))) |
|---|
| 148 | |
|---|
| 149 | (defgeneric dmc-test-mc.3a (val) |
|---|
| 150 | (:method-combination dmc-test-mc.3a)) |
|---|
| 151 | |
|---|
| 152 | (defmethod dmc-test-mc.3a ((val number)) |
|---|
| 153 | (+ val (if (next-method-p) (call-next-method) 0))) |
|---|
| 154 | |
|---|
| 155 | (defmethod dmc-test-mc.3a :around ((val number)) |
|---|
| 156 | (+ val (if (next-method-p) (call-next-method) 0))) |
|---|
| 157 | |
|---|
| 158 | (defmethod dmc-test-mc.3a :somethingelse ((val number)) |
|---|
| 159 | (+ val (if (next-method-p) (call-next-method) 0))) |
|---|
| 160 | |
|---|
| 161 | (deftest dmc-test-mc.3a |
|---|
| 162 | (multiple-value-bind |
|---|
| 163 | (value error) |
|---|
| 164 | (ignore-errors (wam-test-mc.3a 13)) |
|---|
| 165 | (declare (ignore value)) |
|---|
| 166 | (typep error 'error)) |
|---|
| 167 | T) |
|---|
| 168 | |
|---|
| 169 | ;;; Taken from SBCL: error when method sorting is ambiguous |
|---|
| 170 | ;;; with a single (non *) method group |
|---|
| 171 | |
|---|
| 172 | |
|---|
| 173 | (define-method-combination dmc-test-mc.3b () |
|---|
| 174 | ((methods listp :required t)) |
|---|
| 175 | (if (rest methods) |
|---|
| 176 | `(call-method ,(first methods) ,(rest methods)) |
|---|
| 177 | `(call-method ,(first methods)))) |
|---|
| 178 | |
|---|
| 179 | (defgeneric dmc-test-mc.3b (val) |
|---|
| 180 | (:method-combination dmc-test-mc.3b)) |
|---|
| 181 | |
|---|
| 182 | (defmethod dmc-test-mc.3b :foo ((val number)) |
|---|
| 183 | (+ val (if (next-method-p) (call-next-method) 0))) |
|---|
| 184 | |
|---|
| 185 | (defmethod dmc-test-mc.3b :bar ((val number)) |
|---|
| 186 | (+ val (if (next-method-p) (call-next-method) 0))) |
|---|
| 187 | |
|---|
| 188 | (deftest dmc-test-mc.3b |
|---|
| 189 | (multiple-value-bind |
|---|
| 190 | (value error) |
|---|
| 191 | (ignore-errors (dmc-test-mc.3b 13)) |
|---|
| 192 | (declare (ignore value)) |
|---|
| 193 | (typep error 'error)) |
|---|
| 194 | T) |
|---|
| 195 | |
|---|
| 196 | |
|---|
| 197 | ;; Taken from SBCL: test that GF invocation arguments |
|---|
| 198 | ;; are correctly bound using the (:arguments ...) form |
|---|
| 199 | |
|---|
| 200 | (defparameter *dmc-test-4* nil) |
|---|
| 201 | |
|---|
| 202 | (defun object-lock (obj) |
|---|
| 203 | (push "object-lock" *dmc-test-4*) |
|---|
| 204 | obj) |
|---|
| 205 | (defun unlock (obj) |
|---|
| 206 | (push "unlock" *dmc-test-4*) |
|---|
| 207 | obj) |
|---|
| 208 | (defun lock (obj) |
|---|
| 209 | (push "lock" *dmc-test-4*) |
|---|
| 210 | obj) |
|---|
| 211 | |
|---|
| 212 | |
|---|
| 213 | (define-method-combination dmc-test-mc.4 () |
|---|
| 214 | ((methods *)) |
|---|
| 215 | (:arguments object) |
|---|
| 216 | `(unwind-protect |
|---|
| 217 | (progn (lock (object-lock ,object)) |
|---|
| 218 | ,@(mapcar #'(lambda (method) |
|---|
| 219 | `(call-method ,method)) |
|---|
| 220 | methods)) |
|---|
| 221 | (unlock (object-lock ,object)))) |
|---|
| 222 | |
|---|
| 223 | (defgeneric dmc-test.4 (x) |
|---|
| 224 | (:method-combination dmc-test-mc.4)) |
|---|
| 225 | (defmethod dmc-test.4 ((x symbol)) |
|---|
| 226 | (push "primary" *dmc-test-4*)) |
|---|
| 227 | (defmethod dmc-test.4 ((x number)) |
|---|
| 228 | (error "foo")) |
|---|
| 229 | |
|---|
| 230 | (deftest dmc-test.4a |
|---|
| 231 | (progn |
|---|
| 232 | (setq *dmc-test-4* nil) |
|---|
| 233 | (values (equal (dmc-test.4 t) '("primary" "lock" "object-lock")) |
|---|
| 234 | (equal *dmc-test-4* '("unlock" "object-lock" |
|---|
| 235 | "primary" "lock" "object-lock")))) |
|---|
| 236 | T T) |
|---|
| 237 | |
|---|
| 238 | (deftest dmc-test.4b |
|---|
| 239 | (progn |
|---|
| 240 | (setq *dmc-test-4* nil) |
|---|
| 241 | (ignore-errors (dmc-test.4 1)) |
|---|
| 242 | (equal *dmc-test-4* '("unlock" "object-lock" "lock" "object-lock"))) |
|---|
| 243 | T) |
|---|
| 244 | |
|---|
| 245 | |
|---|
| 246 | ;; From SBCL: method combination (long form) with arguments |
|---|
| 247 | |
|---|
| 248 | (define-method-combination dmc-test.5 () |
|---|
| 249 | ((method-list *)) |
|---|
| 250 | (:arguments arg1 arg2 &aux (extra :extra)) |
|---|
| 251 | `(progn ,@(mapcar (lambda (method) `(call-method ,method)) method-list))) |
|---|
| 252 | |
|---|
| 253 | (defgeneric dmc-test-mc.5 (p1 p2 s) |
|---|
| 254 | (:method-combination dmc-test.5) |
|---|
| 255 | (:method ((p1 number) (p2 t) s) |
|---|
| 256 | (vector-push-extend (list 'number p1 p2) s)) |
|---|
| 257 | (:method ((p1 string) (p2 t) s) |
|---|
| 258 | (vector-push-extend (list 'string p1 p2) s)) |
|---|
| 259 | (:method ((p1 t) (p2 t) s) (vector-push-extend (list t p1 p2) s))) |
|---|
| 260 | |
|---|
| 261 | (deftest dmc-test.5a |
|---|
| 262 | (let ((v (make-array 0 :adjustable t :fill-pointer t))) |
|---|
| 263 | (values (dmc-test-mc.5 1 2 v) |
|---|
| 264 | (equal (aref v 0) '(number 1 2)) |
|---|
| 265 | (equal (aref v 1) '(t 1 2)))) |
|---|
| 266 | 1 T T) |
|---|
| 267 | |
|---|
| 268 | |
|---|
| 269 | |
|---|
| 270 | (define-method-combination dmc-test.6 () |
|---|
| 271 | ((normal ()) |
|---|
| 272 | (ignored (:ignore :unused))) |
|---|
| 273 | `(list 'result |
|---|
| 274 | ,@(mapcar #'(lambda (method) `(call-method ,method)) normal))) |
|---|
| 275 | |
|---|
| 276 | (defgeneric dmc-test-mc.6 (x) |
|---|
| 277 | (:method-combination dmc-test.6) |
|---|
| 278 | (:method :ignore ((x number)) (/ 0))) |
|---|
| 279 | |
|---|
| 280 | (deftest dmc-test-mc.6a |
|---|
| 281 | (multiple-value-bind |
|---|
| 282 | (value error) |
|---|
| 283 | (ignore-errors (dmc-test-mc.6 7)) |
|---|
| 284 | (values (null value) |
|---|
| 285 | (typep error 'error))) |
|---|
| 286 | T T) |
|---|
| 287 | |
|---|
| 288 | |
|---|
| 289 | (define-method-combination dmc-test.7 () |
|---|
| 290 | ((methods *)) |
|---|
| 291 | (:arguments x &rest others) |
|---|
| 292 | `(progn |
|---|
| 293 | ,@(mapcar (lambda (method) |
|---|
| 294 | `(call-method ,method)) |
|---|
| 295 | methods) |
|---|
| 296 | (list ,x (length ,others)))) |
|---|
| 297 | |
|---|
| 298 | (defgeneric dmc-test-mc.7 (x &rest others) |
|---|
| 299 | (:method-combination dmc-test.7)) |
|---|
| 300 | |
|---|
| 301 | (defmethod dmc-test-mc.7 (x &rest others) |
|---|
| 302 | (declare (ignore others)) |
|---|
| 303 | nil) |
|---|
| 304 | |
|---|
| 305 | (deftest dmc-test-mc.7a |
|---|
| 306 | (equal (apply #'dmc-test-mc.7 :foo (list 1 2 3 4 5 6 7 8)) |
|---|
| 307 | '(:foo 8)) |
|---|
| 308 | T) |
|---|
| 309 | |
|---|
| 310 | |
|---|
| 311 | ;; Tests for D-M-C with :arguments option |
|---|
| 312 | ;; created due to http://trac.common-lisp.net/armedbear/ticket/201 |
|---|
| 313 | |
|---|
| 314 | (define-method-combination dmc-test-args-with-whole.1 () |
|---|
| 315 | ((methods ())) |
|---|
| 316 | (:arguments &whole whole) |
|---|
| 317 | `(progn (format nil "using ~a" ,whole) |
|---|
| 318 | ,@(mapcar (lambda (method) `(call-method ,method)) |
|---|
| 319 | methods))) |
|---|
| 320 | |
|---|
| 321 | (defgeneric dmc-test-args-with-whole.1 (x) |
|---|
| 322 | (:method-combination dmc-test-args-with-whole.1) |
|---|
| 323 | (:method (x) x)) |
|---|
| 324 | |
|---|
| 325 | ;; This test fails throws an error under #201 |
|---|
| 326 | (deftest dmc-test-args-with-whole.1 |
|---|
| 327 | (dmc-test-args-with-whole.1 T) |
|---|
| 328 | T) |
|---|
| 329 | |
|---|
| 330 | (define-method-combination dmc-test-args-with-whole.2 () |
|---|
| 331 | ((methods ())) |
|---|
| 332 | (:arguments &whole whole &rest rest) |
|---|
| 333 | `(progn (format nil "using ~a ~a" ,whole ,rest) |
|---|
| 334 | ,@(mapcar (lambda (method) `(call-method ,method)) |
|---|
| 335 | methods))) |
|---|
| 336 | |
|---|
| 337 | (defgeneric dmc-test-args-with-whole.2 (x) |
|---|
| 338 | (:method-combination dmc-test-args-with-whole.2) |
|---|
| 339 | (:method (x) x)) |
|---|
| 340 | |
|---|
| 341 | (deftest dmc-test-args-with-whole.2 |
|---|
| 342 | (dmc-test-args-with-whole.2 T) |
|---|
| 343 | T) |
|---|
| 344 | |
|---|
| 345 | |
|---|
| 346 | (define-method-combination dmc-test-args-with-whole.3a () |
|---|
| 347 | ((methods ())) |
|---|
| 348 | (:arguments &whole whole &optional opt) |
|---|
| 349 | `(progn (format nil "using ~a ~a" ,whole ,opt) |
|---|
| 350 | ,@(mapcar (lambda (method) `(call-method ,method)) |
|---|
| 351 | methods))) |
|---|
| 352 | |
|---|
| 353 | (defgeneric dmc-test-args-with-whole.3a (x) |
|---|
| 354 | (:method-combination dmc-test-args-with-whole.3a) |
|---|
| 355 | (:method (x) x)) |
|---|
| 356 | |
|---|
| 357 | (deftest dmc-test-args-with-whole.3a |
|---|
| 358 | (dmc-test-args-with-whole.3a T) |
|---|
| 359 | T) |
|---|
| 360 | |
|---|
| 361 | (define-method-combination dmc-test-args-with-whole.3b () |
|---|
| 362 | ((methods ())) |
|---|
| 363 | (:arguments &whole whole &optional opt &key k) |
|---|
| 364 | `(progn (format nil "using ~a ~a ~a" ,whole ,opt ,k) |
|---|
| 365 | ,@(mapcar (lambda (method) `(call-method ,method)) |
|---|
| 366 | methods))) |
|---|
| 367 | |
|---|
| 368 | (defgeneric dmc-test-args-with-whole.3b (x) |
|---|
| 369 | (:method-combination dmc-test-args-with-whole.3b) |
|---|
| 370 | (:method (x) x)) |
|---|
| 371 | |
|---|
| 372 | (deftest dmc-test-args-with-whole.3b |
|---|
| 373 | (dmc-test-args-with-whole.3b T) |
|---|
| 374 | T) |
|---|
| 375 | |
|---|
| 376 | (define-method-combination dmc-test-args-with-whole.3c () |
|---|
| 377 | ((methods ())) |
|---|
| 378 | (:arguments &whole whole &optional opt &rest r) |
|---|
| 379 | `(progn (format nil "using ~a ~a ~a" ,whole ,opt ,r) |
|---|
| 380 | ,@(mapcar (lambda (method) `(call-method ,method)) |
|---|
| 381 | methods))) |
|---|
| 382 | |
|---|
| 383 | (defgeneric dmc-test-args-with-whole.3c (x) |
|---|
| 384 | (:method-combination dmc-test-args-with-whole.3c) |
|---|
| 385 | (:method (x) x)) |
|---|
| 386 | |
|---|
| 387 | (deftest dmc-test-args-with-whole.3c |
|---|
| 388 | (dmc-test-args-with-whole.3c T) |
|---|
| 389 | T) |
|---|
| 390 | |
|---|
| 391 | |
|---|
| 392 | (define-method-combination dmc-test-args-with-whole.3d () |
|---|
| 393 | ((methods ())) |
|---|
| 394 | (:arguments &whole whole &optional opt &rest r &key k) |
|---|
| 395 | `(progn (format nil "using ~a ~a ~a ~a" ,whole ,opt ,r ,k) |
|---|
| 396 | ,@(mapcar (lambda (method) `(call-method ,method)) |
|---|
| 397 | methods))) |
|---|
| 398 | |
|---|
| 399 | (defgeneric dmc-test-args-with-whole.3d (x) |
|---|
| 400 | (:method-combination dmc-test-args-with-whole.3d) |
|---|
| 401 | (:method (x) x)) |
|---|
| 402 | |
|---|
| 403 | (deftest dmc-test-args-with-whole.3d |
|---|
| 404 | (dmc-test-args-with-whole.3d T) |
|---|
| 405 | T) |
|---|
| 406 | |
|---|
| 407 | (define-method-combination dmc-test-args-with-whole.4 () |
|---|
| 408 | ((methods ())) |
|---|
| 409 | (:arguments &whole whole &key k) |
|---|
| 410 | `(progn (format nil "using ~a ~a" ,whole ,k) |
|---|
| 411 | ,@(mapcar (lambda (method) `(call-method ,method)) |
|---|
| 412 | methods))) |
|---|
| 413 | |
|---|
| 414 | (defgeneric dmc-test-args-with-whole.4 (x) |
|---|
| 415 | (:method-combination dmc-test-args-with-whole.4) |
|---|
| 416 | (:method (x) x)) |
|---|
| 417 | |
|---|
| 418 | (deftest dmc-test-args-with-whole.4 |
|---|
| 419 | (dmc-test-args-with-whole.4 T) |
|---|
| 420 | T) |
|---|
| 421 | |
|---|
| 422 | (define-method-combination dmc-test-args-with-whole.5 () |
|---|
| 423 | ((methods ())) |
|---|
| 424 | (:arguments &whole whole &aux a) |
|---|
| 425 | `(progn (format nil "using ~a ~a" ,whole ,a) |
|---|
| 426 | ,@(mapcar (lambda (method) `(call-method ,method)) |
|---|
| 427 | methods))) |
|---|
| 428 | |
|---|
| 429 | (defgeneric dmc-test-args-with-whole.5 (x) |
|---|
| 430 | (:method-combination dmc-test-args-with-whole.5) |
|---|
| 431 | (:method (x) x)) |
|---|
| 432 | |
|---|
| 433 | (deftest dmc-test-args-with-whole.5 |
|---|
| 434 | (dmc-test-args-with-whole.5 T) |
|---|
| 435 | T) |
|---|
| 436 | |
|---|
| 437 | (define-method-combination dmc-test-args-with-optional.1 () |
|---|
| 438 | ((methods ())) |
|---|
| 439 | (:arguments &optional a) |
|---|
| 440 | `(progn ,@(mapcar (lambda (method) `(call-method ,method)) |
|---|
| 441 | methods) |
|---|
| 442 | ,a)) |
|---|
| 443 | |
|---|
| 444 | (defgeneric dmc-test-args-with-optional.1 (x &optional b) |
|---|
| 445 | (:method-combination dmc-test-args-with-optional.1) |
|---|
| 446 | (:method (x &optional b) (progn x b))) |
|---|
| 447 | |
|---|
| 448 | (deftest dmc-test-args-with-optional.1a |
|---|
| 449 | (dmc-test-args-with-optional.1 T) |
|---|
| 450 | nil) |
|---|
| 451 | |
|---|
| 452 | (deftest dmc-test-args-with-optional.1b |
|---|
| 453 | (dmc-test-args-with-optional.1 T T) |
|---|
| 454 | T) |
|---|
| 455 | |
|---|
| 456 | (define-method-combination dmc-test-args-with-optional.2 () |
|---|
| 457 | ((methods *)) |
|---|
| 458 | (:arguments &optional (a :default)) |
|---|
| 459 | (print `(progn ,@(mapcar (lambda (method) `(call-method ,method)) |
|---|
| 460 | methods) |
|---|
| 461 | ,a))) |
|---|
| 462 | |
|---|
| 463 | (defgeneric dmc-test-args-with-optional.2 (x &optional b) |
|---|
| 464 | (:method-combination dmc-test-args-with-optional.2) |
|---|
| 465 | (:method (x &optional b) (progn x b))) |
|---|
| 466 | |
|---|
| 467 | (deftest dmc-test-args-with-optional.2a |
|---|
| 468 | :documentation "TODO" |
|---|
| 469 | (dmc-test-args-with-optional.2 T) |
|---|
| 470 | :default) |
|---|
| 471 | |
|---|
| 472 | (deftest dmc-test-args-with-optional.2b |
|---|
| 473 | :documentation "Describe what the test does here." |
|---|
| 474 | (dmc-test-args-with-optional.2 T T) |
|---|
| 475 | T) |
|---|
| 476 | |
|---|
| 477 | (define-method-combination dmc-test-args-with-optional.3 () |
|---|
| 478 | ((methods *)) |
|---|
| 479 | (:arguments &optional (a :default)) |
|---|
| 480 | (print `(progn ,@(mapcar (lambda (method) `(call-method ,method)) |
|---|
| 481 | methods) |
|---|
| 482 | ,a))) |
|---|
| 483 | |
|---|
| 484 | (defgeneric dmc-test-args-with-optional.3 (x) |
|---|
| 485 | (:method-combination dmc-test-args-with-optional.3) |
|---|
| 486 | (:method (x) (progn x))) |
|---|
| 487 | |
|---|
| 488 | (deftest dmc-test-args-with-optional.3 |
|---|
| 489 | :documentation "TODO" |
|---|
| 490 | (dmc-test-args-with-optional.3 T) |
|---|
| 491 | nil) |
|---|
| 492 | |
|---|
| 493 | |
|---|
| 494 | (define-method-combination dmc-test-args-with-optional.4 () |
|---|
| 495 | ((methods ())) |
|---|
| 496 | (:arguments &optional (a :default sup-p)) |
|---|
| 497 | `(progn ,@(mapcar (lambda (method) `(call-method ,method)) |
|---|
| 498 | methods) |
|---|
| 499 | (values ,a ,sup-p))) |
|---|
| 500 | |
|---|
| 501 | (defgeneric dmc-test-args-with-optional.4a (x &optional b) |
|---|
| 502 | (:method-combination dmc-test-args-with-optional.4) |
|---|
| 503 | (:method (x &optional b) (progn x b))) |
|---|
| 504 | |
|---|
| 505 | (deftest dmc-test-args-with-optional.4a |
|---|
| 506 | (dmc-test-args-with-optional.4a T) |
|---|
| 507 | :default |
|---|
| 508 | nil) |
|---|
| 509 | |
|---|
| 510 | (deftest dmc-test-args-with-optional.4b |
|---|
| 511 | (dmc-test-args-with-optional.4a T T) |
|---|
| 512 | T |
|---|
| 513 | T) |
|---|
| 514 | |
|---|
| 515 | (defgeneric dmc-test-args-with-optional.4c (x) |
|---|
| 516 | (:method-combination dmc-test-args-with-optional.4) |
|---|
| 517 | (:method (x) (progn x))) |
|---|
| 518 | |
|---|
| 519 | (deftest dmc-test-args-with-optional.4c |
|---|
| 520 | :documentation "TODO" |
|---|
| 521 | (dmc-test-args-with-optional.4c T) |
|---|
| 522 | nil |
|---|
| 523 | nil) |
|---|
