source: tags/1.9.2/t/ash.lisp

Last change on this file was 15223, checked in by Mark Evenson, 5 years ago

Fix java.lang.VerifyError? with PROGN
(somewhat-functional-programmer)

  • Added a constant folding case if arg2 was detected as a constant (but wasn't a literal integer, such as (- 1) )
  • Fixed all with-operand-accumulation forms to have the correct types
  • Added test cases that exercise all code paths of p2-ash

<​https://mailman.common-lisp.net/pipermail/armedbear-devel/2019-December/004029.html>
File size: 4.9 KB
Line 
1(in-package :cl-user)
2
3;; make sure we can compile even with non-opstack safe forms
4(prove:plan 2)
5
6(prove:ok
7 (compile
8  nil
9  '(lambda (a)
10    (ash 1
11     (the (unsigned-byte 8)
12      (block nil
13        (format t "side effect1~%")
14        (when a
15          (return-from nil a))
16        (format t "side effect2~%")
17        0)))))
18 "Compile opstack unsafe form within ash")
19
20(prove:ok
21 (compile
22  nil
23  '(lambda (a)
24    (ash 1
25     (bit #*0100
26      (catch 'ct7 a)))))
27 "Compile opstack unsafe form within ash (original reported failure, github issue #69)")
28
29(prove:finalize)
30
31;; see comments in jvm::p2-ash for which sections of the function each of these tests exercises
32(let ((all-tests
33        '((ash-fixnum1-pos-constant-shift2 ((lambda (x)
34                                              (ash (the (unsigned-byte 29) x) 2))
35                                            ((2) => 8)
36                                            ((4) => 16)))
37          (ash-fixnum1-neg-constant-shift2 ((lambda (x)
38                                              (ash (the (unsigned-byte 29) x) -2))
39                                            ((2) => 0)
40                                            ((4) => 1)
41                                            ((0) => 0)))
42          (ash-fixnum1-neg-constant-shift-form2 ((lambda (x)
43                                                   (ash (the (unsigned-byte 29) x) (- 2)))
44                                                 ((2) => 0)
45                                                 ((4) => 1)
46                                                 ((0) => 0)))
47          (ash-fixnum1-zero-shift2 ((lambda (x)
48                                      (ash (the (unsigned-byte 29) x) 0))
49                                    ((2) => 2)
50                                    ((4) => 4)
51                                    ((0) => 0)))
52          (ash-long1-pos-constant-shift2 ((lambda (x)
53                                            (ash (the (unsigned-byte 61) x) 2))
54                                          ((2) => 8)
55                                          ((4) => 16)))
56          (ash-long1-neg-constant-shift2 ((lambda (x)
57                                            (ash (the (unsigned-byte 61) x) -2))
58                                          ((2) => 0)
59                                          ((4) => 1)
60                                          ((0) => 0)))
61          (ash-long1-neg-constant-shift-form2 ((lambda (x)
62                                                 (ash (the (unsigned-byte 61) x) (- 2)))
63                                               ((2) => 0)
64                                               ((4) => 1)
65                                               ((0) => 0)))
66          (ash-long1-zero-shift2 ((lambda (x)
67                                    (ash (the (unsigned-byte 61) x) 0))
68                                  ((2) => 2)
69                                  ((4) => 4)
70                                  ((0) => 0)))
71          (ash-fixnum1-neg-2 ((lambda (x y)
72                                (ash (the (unsigned-byte 29) x) (the (integer -5 -1) y)))
73                              ((2 -1) => 1)
74                              ((4 -2) => 1)
75                              ((0 -2) => 0)))
76          (ash-long1-pos-fixnum2 ((lambda (x y)
77                                    (ash (the (unsigned-byte 40) x) (the (unsigned-byte 4) y)))
78                                  ((2 2) => 8)
79                                  ((4 2) => 16)))
80          (ash-long1-neg-fixnum2 ((lambda (x y)
81                                    (ash (the (unsigned-byte 40) x) (the (integer -5 -1) y)))
82                                  ((4 -2) => 1)
83                                  ((32 -1) => 16)))
84          (ash-long1-fixnum2 ((lambda (x y)
85                                (ash (the (unsigned-byte 40) x) (the (integer -10 10) y)))
86                              ((2 3) => 16)
87                              ((4 -2) => 1)
88                              ((32 -1) => 16)))
89          (ash-regular ((lambda (x y)
90                          (ash x y))
91                        ((2 3) => 16)
92                        ((4 -2) => 1)
93                        ((32 -1) => 16)))
94          (ash-constant ((lambda ()
95                           (ash 2 4))
96                         (() => 32)))
97          (ash-constant2 ((lambda ()
98                            (ash 2 (+ 4)))
99                          (() => 32))))))
100  (dolist (test-data all-tests)
101    (destructuring-bind (test-sym (test-fn &rest tests)) test-data
102      (prove:plan (1+ (length tests)))
103      (prove:ok
104       (compile test-sym test-fn)
105       (format nil "Checking for successful compilation of ~S: ~S" test-sym test-fn))
106      (dolist (test tests)
107        (destructuring-bind (args _ result) test
108          (declare (ignore _))
109          (prove:is
110           (apply test-sym args)
111           result
112           (format nil "Calling ~S with args ~S should be ~S" test-sym args result))))
113      (prove:finalize))))
114
Note: See TracBrowser for help on using the repository browser.