Commit bc03b6e5 authored by pfdietz's avatar pfdietz

Tests for CPL of standard-generic-function. More tests of defgeneric, and...

Tests for CPL of standard-generic-function.  More tests of defgeneric, and begin testing method combinations other than the standard method combination.
parent e0198d89
;-*- Mode: Lisp -*-
;;;; Author: Paul Dietz
;;;; Created: Sat May 24 21:31:55 2003
;;;; Contains: Tests of DEFGENERIC with :method-combination
(in-package :cl-test)
(declaim (special *x*))
(deftest defgeneric-method-combination.1
(let ((*x* nil)
(fn
(eval '(defgeneric dg-mc.fun.1 (x)
(:method-combination +)
(:method + ((x integer)) (car (push 8 *x*)))
(:method + ((x rational)) (car (push 4 *x*)))
(:method + ((x number)) (car (push 2 *x*)))
(:method + ((x t)) (car (push 1 *x*)))))))
(flet ((%f (y)
(let ((*x* nil))
(list (funcall fn y) *x*))))
(values (%f 1) (%f 2/3) (%f 1.54) (%f 'a))))
(15 (1 2 4 8)) (7 (1 2 4)) (3 (1 2)) (1 (1)))
(deftest defgeneric-method-combination.2
(let ((*x* nil)
(fn
(eval '(defgeneric dg-mc.fun.2 (x)
(:method-combination + :most-specific-first)
(:method + ((x integer)) (car (push 8 *x*)))
(:method + ((x rational)) (car (push 4 *x*)))
(:method + ((x number)) (car (push 2 *x*)))
(:method + ((x t)) (car (push 1 *x*)))))))
(flet ((%f (y)
(let ((*x* nil))
(list (funcall fn y) *x*))))
(values (%f 1) (%f 2/3) (%f 1.54) (%f 'a))))
(15 (1 2 4 8)) (7 (1 2 4)) (3 (1 2)) (1 (1)))
(deftest defgeneric-method-combination.3
(let ((*x* nil)
(fn
(eval '(defgeneric dg-mc.fun.3 (x)
(:method-combination + :most-specific-last)
(:method + ((x integer)) (car (push 8 *x*)))
(:method + ((x rational)) (car (push 4 *x*)))
(:method + ((x number)) (car (push 2 *x*)))
(:method + ((x t)) (car (push 1 *x*)))))))
(flet ((%f (y)
(let ((*x* nil))
(list (funcall fn y) *x*))))
(values (%f 1) (%f 2/3) (%f 1.54) (%f 'a))))
(15 (8 4 2 1)) (7 (4 2 1)) (3 (2 1)) (1 (1)))
(deftest defgeneric-method-combination.4
(let ((fn
(eval '(defgeneric dg-mc.4 (x)
(:method-combination +)
(:method + ((x integer)) 1)
(:method :around ((x rational)) 'foo)
(:method + ((x number)) 1)
(:method + ((x symbol)) 2)
(:method + ((x t)) 4)))))
(values
(funcall fn 0)
(funcall fn 4/3)
(funcall fn 1.54)
(funcall fn 'x)
(funcall fn '(a b c))))
foo foo 5 6 4)
......@@ -751,4 +751,36 @@
(defgeneric.fun.31 'a 'b))
(a b))
(deftest defgeneric.32
(progn
(defgeneric defgeneric.fun.32 (x) (:method ((x symbol)) :bad))
(defgeneric defgeneric.fun.32 (x) (:method ((x t)) :good))
(defgeneric.fun.32 'x))
:good)
(deftest defgeneric.33
(let ((fn
(eval
'(defgeneric (setf defgeneric.fun.33) (x y &rest args)
(:method (x (y cons) &rest args)
(assert (null args)) (setf (car y) x))
(:method (x (y array) &rest args)
(setf (apply #'aref y args) x))))))
(values
(let ((z (list 'a 'b)))
(list
(setf (defgeneric.fun.33 z) 'c)
z))
(let ((a (make-array '(10) :initial-element nil)))
(list
(setf (defgeneric.fun.33 a 5) 'd)
a))))
(c (c b))
(d #(nil nil nil nil nil d nil nil nil nil)))
(deftest defgeneric.34
(let ((fn (eval '(defgeneric #:defgeneric.fun.34 (x)
(:method ((x t)) (list x :good))))))
(funcall fn 10))
(10 :good))
......@@ -31,3 +31,5 @@
(load "with-accessors.lsp")
(load "with-slots.lsp")
(load "defgeneric.lsp")
(load "defgeneric-method-combination.lsp")
......@@ -14,4 +14,5 @@
(load "subtypep-array.lsp")
(load "deftype.lsp")
(load "standard-generic-function.lsp")
;-*- Mode: Lisp -*-
;;;; Author: Paul Dietz
;;;; Created: Tue May 20 06:47:20 2003
;;;; Contains: Additional tests for class STANDARD-GENERIC-FUNCTION
(in-package :cl-test)
;;; Most tests of this are elsewhere
(unless (typep #'cons 'generic-function)
(deftest standard-generic-function.1
(progn
(eval
'(defgeneric sgf-cpl-gf.1 (x)
(:method ((x generic-function)) 1)
(:method ((x function)) 2)
(:method ((x t)) 3)))
(values
(sgf-cpl-gf.1 #'make-instance)
(sgf-cpl-gf.1 #'cons)
(sgf-cpl-gf.1 'a)))
1 2 3)
(deftest standard-generic-function.2
(progn
(eval
'(defgeneric sgf-cpl-gf.2 (x)
(:method ((x standard-generic-function)) 1)
(:method ((x function)) 2)
(:method ((x t)) 3)))
(values
(sgf-cpl-gf.2 #'make-instance)
(sgf-cpl-gf.2 #'cons)
(sgf-cpl-gf.2 'a)))
1 2 3)
)
Markdown is supported
0% or .
You are about to add 0 people to the discussion. Proceed with caution.
Finish editing this message first!
Please register or to comment