source: trunk/source/tests/ansi-tests/define-compiler-macro.lsp @ 8991

Last change on this file since 8991 was 8991, checked in by gz, 12 years ago

Check in the gcl ansi test suite (original, in preparation for making local changes)

File size: 5.1 KB
Line 
1;-*- Mode:     Lisp -*-
2;;;; Author:   Paul Dietz
3;;;; Created:  Sun Apr 20 12:33:02 2003
4;;;; Contains: Tests of DEFINE-COMPILER-MACRO
5
6(in-package :cl-test)
7
8;;; Need to add non-error tests
9
10(deftest define-compiler-macro.error.1
11  (signals-error (funcall (macro-function 'define-compiler-macro))
12                 program-error)
13  t)
14
15(deftest define-compiler-macro.error.2
16  (signals-error (funcall (macro-function 'define-compiler-macro)
17                           '(definee-compiler-macro nonexistent-function ()))
18                 program-error)
19  t)
20
21(deftest define-compiler-macro.error.3
22  (signals-error (funcall (macro-function 'define-compiler-macro)
23                           '(definee-compiler-macro nonexistent-function ())
24                           nil nil)
25                 program-error)
26  t)
27
28;;; Non-error tests
29
30(deftest define-compiler-macro.1
31  (let* ((sym (gensym))
32         (macro-def-form
33          `(define-compiler-macro ,sym (x y)
34             (declare (special *x*))
35             (setf *x* t)
36             `(+ ,x ,y 1)))
37         (fun-def-form
38          `(defun ,sym (x y) (+ x y 1))))
39    (values
40     (equalt (list sym) (multiple-value-list (eval fun-def-form)))
41     (equalt (list sym) (multiple-value-list (eval macro-def-form)))
42     (notnot (typep (compiler-macro-function sym) 'function))
43     (eval `(,sym 6 19))
44     (let ((fn (compile nil `(lambda (a b) (,sym a b)))))
45       (let ((*x* nil))
46         (declare (special *x*))
47         (list (funcall fn 12 123) *x*)))))
48  t t t 26 (136 nil))
49
50(deftest define-compiler-macro.2
51  (let* ((sym (gensym))
52         (macro-def-form
53          `(define-compiler-macro ,sym (&whole form &rest args)
54             (declare (special *x*) (ignore args))
55             (setf *x* t)
56             (return-from ,sym form)))
57         (fun-def-form
58          `(defun ,sym (x) x)))
59    (values
60     (equalt (list sym) (multiple-value-list (eval fun-def-form)))
61     (equalt (list sym) (multiple-value-list (eval macro-def-form)))
62     (notnot (typep (compiler-macro-function sym) 'function))
63     (eval `(,sym 'a))
64     (let ((fn (compile nil `(lambda (a) (,sym a)))))
65       (let ((*x* nil))
66         (declare (special *x*))
67         (list (funcall fn 'b) *x*)))))
68  t t t a (b nil))
69
70(deftest define-compiler-macro.3
71  (let* ((sym (gensym))
72         (macro-def-form
73          `(define-compiler-macro ,sym (&whole form &rest args)
74             (declare (special *x*) (ignore args))
75             (setf *x* t)
76             (return-from ,sym form)))
77         (ordinary-macro-def-form
78          `(defmacro ,sym (x) x)))
79    (values
80     (equalt (list sym) (multiple-value-list (eval ordinary-macro-def-form)))
81     (equalt (list sym) (multiple-value-list (eval macro-def-form)))
82     (notnot (typep (compiler-macro-function sym) 'function))
83     (eval `(,sym 'a))
84     (let ((fn (compile nil `(lambda (a) (,sym a)))))
85       (let ((*x* nil))
86         (declare (special *x*))
87         (list (funcall fn 'b) *x*)))))
88  t t t a (b nil))
89
90;;; Compiler macros on setf functions
91
92(deftest define-compiler-macro.4
93  (let* ((sym (gensym))
94         (fun-def-form `(defun ,sym (x) (car x)))
95         (setf-fun-def-form `(defun (setf ,sym) (newval x) (setf (car x) newval)))
96         (setf-compiler-macro-def-form
97          `(define-compiler-macro (setf ,sym) (newval x)
98             (declare (special *x*))
99             (setf *x* t)
100             (return-from ,sym `(setf (car ,x) ,newval)))))
101    (values
102     (equalt (list sym) (multiple-value-list (eval fun-def-form)))
103     (equalt `((setf ,sym)) (multiple-value-list (eval setf-fun-def-form)))
104     (equalt `((setf ,sym)) (multiple-value-list (eval setf-compiler-macro-def-form)))
105     (notnot (typep (compiler-macro-function `(setf ,sym)) 'function))
106     (eval `(,sym (list 'a 'b)))
107     (eval `(let ((arg (list 1 2)))
108              (list (setf (,sym arg) 'z) arg)))
109     (let ((fn (compile nil `(lambda (u v) (setf (,sym u) v)))))
110       (let ((*x* nil)
111             (arg (list 1 2)))
112         (declare (special *x*))
113         (list (funcall fn arg 'y) arg)))))
114  t t t t a (z (z 2)) (y (y 2)))
115
116;;; Test of documentation
117
118(deftest define-compiler-macro.5
119  (let* ((sym (gensym))
120         (form `(define-compiler-macro ,sym (x) "DCM.5" x))
121         (form2 `(defun ,sym (x) "DCM.5-WRONG" x)))
122    (eval form)
123    (eval form2)
124    (or (documentation sym 'compiler-macro) "DCM.5"))
125  "DCM.5")
126
127(deftest define-compiler-macro.6
128  (let* ((sym (gensym))
129         (form `(define-compiler-macro ,sym (x) "DCM.6" x))
130         (form2 `(defun ,sym (x) "DCM.6-WRONG" x)))
131    (eval form2)
132    (eval form)
133    (or (documentation sym 'compiler-macro) "DCM.6"))
134  "DCM.6")
135
136;;; NOTINLINE turns off a compiler macro
137
138(deftest define-compiler-macro.7
139  (let* ((sym (gensym))
140         (form `(define-compiler-macro ,sym (x y)
141                  (declare (special *x*))
142                  (setf *x* :bad)
143                  `(list ,x ,y)))
144         (form2 `(defun ,sym (x y) (list x y))))
145    (eval form)
146    (eval form2)
147    (compile sym)
148    (let ((*x* :good))
149      (declare (special *x*))
150      (values
151       (funcall (compile nil `(lambda (a b)
152                                (declare (notinline ,sym))
153                                (,sym a b)))
154                5 11)
155       *x*)))
156  (5 11) :good)
157
158(deftest define-compiler-macro.8
159  (let* ((sym (gensym))
160         (form `(define-compiler-macro ,sym (x y)
161                  (declare (special *x*))
162                  (setf *x* :bad)
163                  `(list ,x ,y)))
164         (form2 `(defmacro ,sym (x y) `(list ,x ,y))))
165    (eval form)
166    (eval form2)
167    (let ((*x* :good))
168      (declare (special *x*))
169      (values
170       (funcall (compile nil `(lambda (a b)
171                                (declare (notinline ,sym))
172                                (,sym a b)))
173                7 23)
174       *x*)))
175  (7 23) :good)
Note: See TracBrowser for help on using the repository browser.