Really restore clisp cross-compilation.
[sbcl.git] / tests / mop.pure.lisp
1 ;;;; miscellaneous non-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 ;;;; Note that the MOP is not in an entirely supported state.
15 ;;;; However, this seems a good a way as any of ensuring that we have
16 ;;;; no regressions.
17
18 (assert (subtypep 'sb-mop:funcallable-standard-object 'standard-object))
19
20 (assert (find (find-class 'sb-mop:funcallable-standard-object)
21               (sb-mop:class-direct-subclasses (find-class 'standard-object))))
22
23 (assert (find (find-class 'standard-object)
24               (sb-mop:class-direct-superclasses
25                (find-class 'sb-mop:funcallable-standard-object))))
26
27 (dolist (name '(sb-mop:generic-function
28                 sb-mop:method sb-mop:method-combination
29                 sb-mop:slot-definition sb-mop:specializer))
30   (assert (find (find-class 'sb-mop:metaobject)
31                 (sb-mop:class-direct-superclasses (find-class name))))
32   (assert (subtypep name 'sb-mop:metaobject)))
33
34 ;;; No portable class Cp may inherit, by virtue of being a direct or
35 ;;; indirect subclass of a specified class, any slot for which the
36 ;;; name is a symbol accessible in the common-lisp-user package or
37 ;;; exported by any package defined in the ANSI Common Lisp standard.
38 (let ((specified-class-names
39        '(sb-mop:built-in-class
40          sb-mop:class
41          sb-mop:direct-slot-definition
42          sb-mop:effective-slot-definition
43          sb-mop:eql-specializer
44          sb-mop:forward-referenced-class
45          sb-mop:funcallable-standard-class
46          sb-mop:funcallable-standard-object
47          sb-mop:generic-function
48          sb-mop:metaobject
49          sb-mop:method
50          sb-mop:method-combination
51          sb-mop:slot-definition
52          sb-mop:specializer
53          sb-mop:standard-accessor-method
54          sb-mop:standard-class
55          sb-mop:standard-direct-slot-definition
56          sb-mop:standard-effective-slot-definition
57          sb-mop:standard-generic-function
58          sb-mop:standard-method
59          sb-mop:standard-object
60          sb-mop:standard-reader-method
61          sb-mop:standard-slot-definition
62          sb-mop:standard-writer-method)))
63   (labels ((slot-name-ok (name)
64              (dolist (package (mapcar #'find-package
65                                       '("CL" "CL-USER" "KEYWORD" "SB-MOP"))
66                       t)
67                (when (multiple-value-bind (symbol status)
68                          (find-symbol (symbol-name name) package)
69                        (and (eq symbol name)
70                             (or (eq package (find-package "CL-USER"))
71                                 (eq status :external))))
72                  (return nil))))
73            (test-class-slots (class)
74              (loop for slot in (sb-mop:class-slots class)
75                    for slot-name = (sb-mop:slot-definition-name slot)
76                    unless (slot-name-ok slot-name)
77                    collect (cons class slot-name))))
78     (loop for class-name in specified-class-names
79           for class = (find-class class-name)
80           for results = (test-class-slots class)
81           when results do (cerror "continue" "~A" results))))
82
83 ;;; AMOP says these are the defaults
84 (assert (equal (list (find-class 'standard-object))
85                (sb-mop:class-direct-superclasses (make-instance 'standard-class))))
86 (assert (equal (list (find-class 'sb-mop:funcallable-standard-object))
87                (sb-mop:class-direct-superclasses (make-instance 'sb-mop:funcallable-standard-class))))
88
89 (with-test (:name :bug-936513)
90   ;; This used to fail as ENSURE-GENERIC-FUNCTION wanted a list specifying
91   ;; the method combination, and didn't accept the actual object
92   (let ((mc (sb-pcl:find-method-combination #'make-instance 'standard nil)))
93     (ensure-generic-function 'make-instance :method-combination mc))
94   ;; Let's make sure the list works too...
95   (ensure-generic-function 'make-instance :method-combination '(standard)))
96
97 (with-test (:name :bug-309072)
98   ;; original reported test cases
99   (raises-error? (make-instance 'sb-mop:slot-definition))
100   (raises-error? (make-instance 'sb-mop:slot-definition :name 'pi))
101   (raises-error? (make-instance 'sb-mop:slot-definition :name 3))
102   ;; extra cases from the MOP dictionary
103   (raises-error? (make-instance 'sb-mop:slot-definition :name 'x
104                                 :initform nil))
105   (raises-error? (make-instance 'sb-mop:slot-definition :name 'x
106                                 :initfunction (lambda () nil)))
107   (raises-error? (make-instance 'sb-mop:slot-definition :name 'x
108                                 :initfunction (lambda () nil)))
109   (raises-error? (make-instance 'sb-mop:slot-definition :name 'x
110                                 :allocation ""))
111   (raises-error? (make-instance 'sb-mop:slot-definition :name 'x
112                                 :initargs ""))
113   (raises-error? (make-instance 'sb-mop:slot-definition :name 'x
114                                 :initargs '(foo . bar)))
115   (raises-error? (make-instance 'sb-mop:slot-definition :name 'x
116                                 :initargs '(foo bar 3)))
117   (raises-error? (make-instance 'sb-mop:slot-definition :name 'x
118                                 :documentation '(())))
119   ;; distinction between DIRECT- and EFFECTIVE- slot definitions
120   (raises-error? (make-instance 'sb-mop:effective-slot-definition
121                                 :name 'x :readers '(foo)))
122   (raises-error? (make-instance 'sb-mop:effective-slot-definition
123                                 :name 'x :writers '(foo)))
124   (make-instance 'sb-mop:direct-slot-definition
125                  :name 'x :readers '(foo))
126   (make-instance 'sb-mop:direct-slot-definition
127                  :name 'x :writers '(foo))
128   (raises-error? (make-instance 'sb-mop:direct-slot-definition
129                                 :name 'x :readers ""))
130   (raises-error? (make-instance 'sb-mop:direct-slot-definition
131                                 :name 'x :readers '(3)))
132   (raises-error? (make-instance 'sb-mop:direct-slot-definition
133                                 :name 'x :readers '(foo . bar)))
134   (raises-error? (make-instance 'sb-mop:direct-slot-definition
135                                 :name 'x :writers ""))
136   (raises-error? (make-instance 'sb-mop:direct-slot-definition
137                                 :name 'x :writers '(3)))
138   (raises-error? (make-instance 'sb-mop:direct-slot-definition
139                                 :name 'x :writers '(foo . bar))))