1.0.39: will be tagged as sbcl_1_0_39
[sbcl.git] / tests / mop-6.impure-cload.lisp
1 ;;;; miscellaneous side-effectful tests of the MOP
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 ;;; This file contains simple tests for COMPUTE-SLOTS :AROUND
15 ;;; respecting the order requested by the primary method.
16
17 (defpackage "MOP-6"
18   (:use "CL" "SB-MOP" "TEST-UTIL"))
19 (in-package "MOP-6")
20
21 ;;; COMPUTE-SLOTS :AROUND respecting requested order
22 (defclass slot-rearrangement-class (standard-class)
23   ())
24 (defmethod compute-slots ((c slot-rearrangement-class))
25   (reverse (call-next-method)))
26 (defmethod validate-superclass ((c slot-rearrangement-class)
27                                 (s standard-class))
28   t)
29 (defclass rearranged-class ()
30   ((a :initarg :a :initform 1)
31    (b :initarg :b :initform 2))
32   (:metaclass slot-rearrangement-class))
33
34 (with-test (:name (:compute-slots :standard-class :order))
35   (let ((class (find-class 'rearranged-class)))
36     (finalize-inheritance class)
37     (assert (equal (mapcar #'slot-definition-name (class-slots class))
38                    '(b a)))))
39 (with-test (:name (:compute-slots :standard-class :slots))
40   (let ((r (make-instance 'rearranged-class))
41         (r2 (make-instance 'rearranged-class :a 3 :b 4)))
42     (assert (eql (slot-value r 'a) 1))
43     (assert (eql (slot-value r 'b) 2))
44     (assert (eql (slot-value r2 'a) 3))
45     (assert (eql (slot-value r2 'b) 4))))
46
47 (defclass funcallable-slot-rearrangement-class (funcallable-standard-class)
48   ())
49 (defmethod compute-slots ((c funcallable-slot-rearrangement-class))
50   (reverse (call-next-method)))
51 (defmethod validate-superclass ((c funcallable-slot-rearrangement-class)
52                                 (s funcallable-standard-class))
53   t)
54 (defclass funcallable-rearranged-class ()
55   ((a :initarg :a :initform 1)
56    (b :initarg :b :initform 2))
57   (:metaclass funcallable-slot-rearrangement-class))
58
59 (with-test (:name (:compute-slots :funcallable-standard-class :order))
60   (let ((class (find-class 'funcallable-rearranged-class)))
61     (finalize-inheritance class)
62     (assert (equal (mapcar #'slot-definition-name (class-slots class))
63                    '(b a)))))
64 (with-test (:name (:compute-slots :funcallable-standard-class :slots))
65   (let ((r (make-instance 'funcallable-rearranged-class))
66         (r2 (make-instance 'funcallable-rearranged-class :a 3 :b 4)))
67     (assert (eql (slot-value r 'a) 1))
68     (assert (eql (slot-value r 'b) 2))
69     (assert (eql (slot-value r2 'a) 3))
70     (assert (eql (slot-value r2 'b) 4))))
71 (with-test (:name (:compute-slots :funcallable-standard-clas :function))
72   (let ((r (make-instance 'funcallable-rearranged-class)))
73     (set-funcallable-instance-function r (lambda (x) (list "Hello, World!" x)))
74     (assert (equal (funcall r 3) '("Hello, World!" 3)))))