source: trunk/abcl/test/lisp/abcl/compiler-tests.lisp

Last change on this file was 15332, checked in by Mark Evenson, 5 months ago

Revisions for the long neglected ABCL/TEST/LISP suite

Restore loading under SBCL and CCL.

FIXME: package-local-nicknames-tests only runs once in the same
process, causing a mysterious failure on the second time.

  • Property svn:eol-style set to native
  • Property svn:keywords set to Id
File size: 13.7 KB
Line 
1;;; compiler-tests.lisp
2;;;
3;;; Copyright (C) 2005 Peter Graves
4;;; $Id: compiler-tests.lisp 15332 2020-06-26 13:23:35Z mevenson $
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#+abcl
21(require '#:jvm)
22
23(in-package #:abcl.test.lisp)
24
25(eval-when (:compile-toplevel :load-toplevel :execute)
26  (defvar most-positive-java-long 9223372036854775807)
27  (defvar most-negative-java-long -9223372036854775808))
28
29#+abcl
30(assert (eql most-positive-java-long ext:most-positive-java-long))
31#+abcl
32(assert (eql most-negative-java-long ext:most-negative-java-long))
33
34(defmacro define-compiler-test (name lambda-form &key args results)
35  `(deftest ,name
36     (progn
37       (fmakunbound ',name)
38       (defun ,name ,(cadr lambda-form)
39         ,@(cddr lambda-form))
40       (values
41        (funcall ',name ,@args)
42        (multiple-value-list (compile ',name))
43        (compiled-function-p #',name)
44        (funcall ',name ,@args)))
45     ,results
46     (,name nil nil)
47     t
48     ,results))
49
50#+abcl
51(deftest unused.1
52  (let ((output (with-output-to-string (*error-output*)
53                  (compile nil '(lambda () (let ((x 42)) 17))))))
54    (integerp (search "The variable X is defined but never used." output)))
55  t)
56
57(deftest unused.2
58  (progn
59    (fmakunbound 'unused.2)
60    (defun unused.2 () (let ((x 42)) 17))
61    (values
62     #-lispworks
63     (multiple-value-list (compile 'unused.2))
64     #+lispworks
65     (let ((list (multiple-value-list (compile 'unused.2))))
66       (list (first list)
67             (not (null (second list)))
68             (third list)))
69     (unused.2)))
70  #+allegro            (unused.2 t   nil)
71  #+clisp              (unused.2 1   nil)
72  #+(or cmu sbcl abcl) (unused.2 nil nil)
73  #+lispworks          (unused.2 t   nil)
74  17)
75
76(deftest plus.1
77  (progn
78    (fmakunbound 'plus.1)
79    (defun plus.1 (x y)
80      (+ x y))
81    (compile 'plus.1)
82    (plus.1 most-positive-fixnum most-positive-fixnum))
83  #.(+ most-positive-fixnum most-positive-fixnum))
84
85(deftest plus.2
86  (progn
87    (fmakunbound 'plus.2)
88    (defun plus.2 (x y)
89      (declare (optimize speed))
90      (declare (type fixnum x y))
91      (+ x y))
92    (compile 'plus.2)
93    (plus.2 most-positive-fixnum most-positive-fixnum))
94  #.(+ most-positive-fixnum most-positive-fixnum))
95
96(deftest plus.3
97  (progn
98    (fmakunbound 'plus.3)
99    (defun plus.3 (x y)
100      (declare (optimize speed (safety 0)))
101      (declare (type fixnum x y))
102      (+ x y))
103    (compile 'plus.3)
104    (plus.3 most-positive-fixnum most-positive-fixnum))
105  #.(+ most-positive-fixnum most-positive-fixnum))
106#+allegro (pushnew 'plus.3 *expected-failures*)
107
108#+abcl
109(define-compiler-test plus.4
110  (lambda (x y)
111    (declare (type (integer #.most-negative-java-long #.most-positive-java-long) x y))
112    (+ x y))
113  :args (#.most-positive-java-long #.most-positive-java-long)
114  :results #.(+ most-positive-java-long most-positive-java-long))
115
116(define-compiler-test minus.1
117  (lambda (x)
118    (declare (type fixnum x))
119    (- x))
120  :args (#.most-negative-fixnum)
121  :results #.(- most-negative-fixnum))
122
123#-clisp
124(define-compiler-test minus.2
125  (lambda (x)
126    (declare (type (integer #.most-negative-java-long #.most-positive-java-long) x))
127    (- x))
128  :args (#.most-negative-java-long)
129  :results #.(- most-negative-java-long))
130
131#-clisp
132(define-compiler-test minus.3
133  (lambda (x y)
134    (declare (type (integer #.most-negative-java-long #.most-positive-java-long) x y))
135    (- x y))
136  :args (#.most-negative-java-long #.most-positive-java-long)
137  :results #.(- most-negative-java-long most-positive-java-long))
138
139#-clisp
140(define-compiler-test logxor-minus.1
141  (lambda (x)
142    (declare (type (integer 0 255) x))
143    (logxor (- x) #.most-positive-java-long))
144  :args (17)
145  :results -9223372036854775792)
146
147#-clisp
148(deftest times.1
149  (progn
150    (fmakunbound 'times.1)
151    (defun times.1 (x y)
152      (* x y))
153    (compile 'times.1)
154    (times.1 most-positive-fixnum most-positive-fixnum))
155  #.(* most-positive-fixnum most-positive-fixnum))
156
157(deftest times.2
158  (progn
159    (fmakunbound 'times.2)
160    (defun times.2 (x y)
161      (declare (optimize speed))
162      (declare (type fixnum x y))
163      (* x y))
164    (compile 'times.2)
165    (times.2 most-positive-fixnum most-positive-fixnum))
166  #.(* most-positive-fixnum most-positive-fixnum))
167
168(deftest times.3
169  (progn
170    (fmakunbound 'times.3)
171    (defun times.3 (x y)
172      (declare (optimize speed (safety 0)))
173      (declare (type fixnum x y))
174      (* x y))
175    (compile 'times.3)
176    (times.3 most-positive-fixnum most-positive-fixnum))
177  #.(* most-positive-fixnum most-positive-fixnum))
178
179(deftest dotimes.1
180  (progn
181    (fmakunbound 'dotimes.1)
182    (defun dotimes.1 ()
183      (declare (optimize speed (safety 0)))
184      (let ((result 0))
185        (dotimes (i 10)
186          (incf result))
187        result))
188    (compile 'dotimes.1)
189    (dotimes.1))
190  10)
191
192(deftest dotimes.2
193  (progn
194    (fmakunbound 'dotimes.2)
195    (defun dotimes.2 ()
196      (declare (optimize speed (safety 0)))
197      (let ((result 0))
198        (declare (type fixnum result))
199        (dotimes (i 10)
200          (incf result))
201        result))
202    (compile 'dotimes.2)
203    (dotimes.2))
204  10)
205
206#+abcl
207(deftest derive-type-logxor.1
208  (let ((type
209         (jvm:derive-compiler-type `(logxor (the (unsigned-byte 8) x)
210                                            (the (unsigned-byte 8) y)))))
211    (and (sys:integer-type-p type)
212         (values
213          (sys:integer-type-low type)
214          (sys:integer-type-high type))))
215  0 255)
216
217#+abcl
218(deftest derive-type-logxor.2
219  (let ((type
220         (jvm:derive-compiler-type `(logxor 441516657
221                                            (the (integer 0 8589934588) x)))))
222    (and (sys:integer-type-p type)
223         (values
224          (sys:integer-type-low type)
225          (sys:integer-type-high type))))
226  0 8589934588)
227
228#+abcl
229(deftest derive-type-logxor.3
230  (let ((type
231         (jvm:derive-compiler-type `(logxor 441516657
232                                            (the (integer 0 8589934588) x)
233                                            (ash (the (integer 0 8589934588) x) -5)))))
234    (and (sys:integer-type-p type)
235         (values
236          (sys:integer-type-low type)
237          (sys:integer-type-high type))))
238  0 8589934588)
239
240(deftest ash.1
241  (progn
242    (fmakunbound 'ash.1)
243    (defun ash.1 (n shift)
244      (declare (type (integer 0 8589934588) n))
245      (declare (type (integer -31 -1) shift))
246      (ash n shift))
247    (compile 'ash.1)
248    (values
249     (ash.1 8589934588 -1)
250     (ash.1 8589934588 -2)
251     (ash.1 8589934588 -3)
252     (ash.1 8589934588 -4)
253     (ash.1 8589934588 -5)
254     (ash.1 8589934588 -6)
255     (ash.1 8589934588 -31)))
256  4294967294
257  2147483647
258  1073741823
259  536870911
260  268435455
261  134217727
262  3)
263
264#-clisp
265(deftest bignum-constant.1
266  (progn
267    (fmakunbound 'bignum-constant.1)
268    (defun bignum-constant.1 () #.most-positive-java-long)
269    (values (funcall 'bignum-constant.1)
270            (multiple-value-list (compile 'bignum-constant.1))
271            (compiled-function-p #'bignum-constant.1)
272            (funcall 'bignum-constant.1)))
273  #.most-positive-java-long
274  (bignum-constant.1 nil nil)
275  t
276  #.most-positive-java-long)
277
278#-clisp
279(deftest bignum-constant.2
280  (progn
281    (fmakunbound 'bignum-constant.2)
282    (defun bignum-constant.2 () #.(1+ most-positive-java-long))
283    (values (funcall 'bignum-constant.2)
284            (multiple-value-list (compile 'bignum-constant.2))
285            (compiled-function-p #'bignum-constant.2)
286            (funcall 'bignum-constant.2)))
287  #.(1+ most-positive-java-long)
288  (bignum-constant.2 nil nil)
289  t
290  #.(1+ most-positive-java-long))
291
292#-clisp
293(deftest bignum-constant.3
294  (progn
295    (fmakunbound 'bignum-constant.3)
296    (defun bignum-constant.3 () #.most-negative-java-long)
297    (values (funcall 'bignum-constant.3)
298            (multiple-value-list (compile 'bignum-constant.3))
299            (compiled-function-p #'bignum-constant.3)
300            (funcall 'bignum-constant.3)))
301  #.most-negative-java-long
302  (bignum-constant.3 nil nil)
303  t
304  #.most-negative-java-long)
305
306#-clisp
307(deftest bignum-constant.4
308  (progn
309    (fmakunbound 'bignum-constant.4)
310    (defun bignum-constant.4 () #.(1- most-negative-java-long))
311    (values (funcall 'bignum-constant.4)
312            (multiple-value-list (compile 'bignum-constant.4))
313            (compiled-function-p #'bignum-constant.4)
314            (funcall 'bignum-constant.4)))
315  #.(1- most-negative-java-long)
316  (bignum-constant.4 nil nil)
317  t
318  #.(1- most-negative-java-long))
319
320(deftest shiftf.1
321  (progn
322    (fmakunbound 'shiftf.1)
323    (defun shiftf.1 (x)
324      (declare (type (integer -5213 238468) x))
325      (+ x (shiftf x 168771)))
326    (values (funcall 'shiftf.1 96411)
327            (multiple-value-list (compile 'shiftf.1))
328            (compiled-function-p #'shiftf.1)
329            (funcall 'shiftf.1 96411)))
330  192822
331  (shiftf.1 nil nil)
332  t
333  192822)
334
335(deftest logand-values.1
336  (ignore-errors (funcall (compile nil '(lambda () (logand 18 (values 42 7))))))
337  2)
338
339(deftest logand-lognot.1
340  (progn
341    (fmakunbound 'logand-lognot.1)
342    (defun logand-lognot.1 (x)
343      (declare (type (unsigned-byte 32) x))
344      (logand #.(1- (expt 2 32)) (lognot x)))
345    (values (funcall 'logand-lognot.1 123456789)
346            (multiple-value-list (compile 'logand-lognot.1))
347            (compiled-function-p #'logand-lognot.1)
348            (funcall 'logand-lognot.1 123456789)))
349  4171510506
350  (logand-lognot.1 nil nil)
351  t
352  4171510506)
353
354(deftest logior-logand-setf.1
355  (progn
356    (fmakunbound 'foo)
357    (defun foo (x y)
358      (declare (type (integer 2005076 2881158415) x))
359      (declare (type (integer -28121355 17748872) y))
360      (logior (logand (setf y -3475589)
361                      x))
362      y)
363    (values (funcall 'foo 12345678 42)
364            (multiple-value-list (compile 'foo))
365            (compiled-function-p #'foo)
366            (funcall 'foo 12345678 42)))
367  -3475589
368  (foo nil nil)
369  t
370  -3475589)
371
372(deftest logxor.1
373  (progn
374    (fmakunbound 'foo)
375    (defun foo ()
376      (logxor -4153366606 (- 0)))
377    (values (funcall 'foo)
378            (multiple-value-list (compile 'foo))
379            (compiled-function-p #'foo)
380            (funcall 'foo)))
381    -4153366606
382    (foo nil nil)
383    t
384    -4153366606)
385
386(define-compiler-test min.1
387  (lambda (x y)
388    (declare (type fixnum x y))
389    (min x y))
390  :args (3 4)
391  :results 3)
392
393(define-compiler-test min.2
394  (lambda (x y)
395    (declare (type fixnum x y))
396    (min x y))
397  :args (#.most-positive-fixnum #.most-negative-fixnum)
398  :results #.most-negative-fixnum)
399
400#-clisp
401(define-compiler-test min.3
402  (lambda (x y)
403    (declare (type (integer #.most-negative-java-long #.most-positive-java-long) x y))
404    (min x y))
405  :args (3 4)
406  :results 3)
407
408#-clisp
409(define-compiler-test min.4
410  (lambda (x y)
411    (declare (type (integer #.most-negative-java-long #.most-positive-java-long) x y))
412    (min x y))
413  :args (#.most-positive-java-long #.most-negative-java-long)
414  :results #.most-negative-java-long)
415
416(define-compiler-test max.1
417  (lambda (x y)
418    (declare (type fixnum x y))
419    (max x y))
420  :args (3 4)
421  :results 4)
422
423#-clisp
424(define-compiler-test max.2
425  (lambda (x y)
426    (declare (type fixnum x y))
427    (max x y))
428  :args (#.most-positive-fixnum #.most-negative-fixnum)
429  :results #.most-positive-fixnum)
430
431#-clisp
432(define-compiler-test max.3
433  (lambda (x y)
434    (declare (type (integer #.most-negative-java-long #.most-positive-java-long) x y))
435    (max x y))
436  :args (3 4)
437  :results 4)
438
439#-clisp
440(define-compiler-test max.4
441  (lambda (x y)
442    (declare (type (integer #.most-negative-java-long #.most-positive-java-long) x y))
443    (max x y))
444  :args (#.most-positive-java-long #.most-negative-java-long)
445  :results #.most-positive-java-long)
446
447;;; ticket #147
448#+abcl
449(deftest compiler.1 
450    (let ((tmpfile (ext::make-temp-file))
451          (original-print-case *print-case*)
452          (forms `((in-package :cl-user)
453                   (eval-when (:compile-toplevel :load-toplevel :execute)
454                     (setf *print-case* ':downcase))
455                   (defstruct rec a b))))
456      (with-open-file (s tmpfile :direction :output)
457        (dolist (form forms)
458          (write form :stream s)))
459      (let ((result (compile-file tmpfile)))
460        (delete-file tmpfile)
461        (setf *print-case* original-print-case)
462        (not (null result))))
463  t)
464
465;;; ticket #156
466#+abcl
467(deftest compiler.2
468    (let ((tmpfile (ext::make-temp-file))
469          (line "(defconstant a #.(make-array '(8 256)
470                    :element-type '(unsigned-byte 32) :initial-element 0))"))
471      (with-open-file (s tmpfile :direction :output)
472        (format s "~A" line))
473      (let ((result (compile-file tmpfile)))
474    #+nil    (delete-file tmpfile)
475        (not (null result))))
476  t)
477
478
479;;; ticket #189
480(deftest compiler.3
481    (eql (funcall (compile nil (lambda (a)
482                           (declare (type unsigned-byte a))
483                           (max 28105919 a 1016934843)))
484                  10545160975)
485         10545160975)
486  t)
487
488
489;;; ticket #241
490(deftest compiler.4a
491    (multiple-value-bind
492          (rv error)
493        (ignore-errors
494          (compile nil '(lambda (&rest args &optional x))))
495      (typep error 'program-error))
496  t)
497
498(deftest compiler.4b
499    (multiple-value-bind
500          (rv error)
501        (ignore-errors
502          (compile nil '(lambda (&key args &optional x))))
503      (typep error 'program-error))
504  t)
Note: See TracBrowser for help on using the repository browser.