(in-package :cl-user)
;; make sure we can compile even with non-opstack safe forms
(prove:plan 2)
(prove:ok
(compile
nil
'(lambda (a)
(ash 1
(the (unsigned-byte 8)
(block nil
(format t "side effect1~%")
(when a
(return-from nil a))
(format t "side effect2~%")
0)))))
"Compile opstack unsafe form within ash")
(prove:ok
(compile
nil
'(lambda (a)
(ash 1
(bit #*0100
(catch 'ct7 a)))))
"Compile opstack unsafe form within ash (original reported failure, github issue #69)")
(prove:finalize)
;; see comments in jvm::p2-ash for which sections of the function each of these tests exercises
(let ((all-tests
'((ash-fixnum1-pos-constant-shift2 ((lambda (x)
(ash (the (unsigned-byte 29) x) 2))
((2) => 8)
((4) => 16)))
(ash-fixnum1-neg-constant-shift2 ((lambda (x)
(ash (the (unsigned-byte 29) x) -2))
((2) => 0)
((4) => 1)
((0) => 0)))
(ash-fixnum1-neg-constant-shift-form2 ((lambda (x)
(ash (the (unsigned-byte 29) x) (- 2)))
((2) => 0)
((4) => 1)
((0) => 0)))
(ash-fixnum1-zero-shift2 ((lambda (x)
(ash (the (unsigned-byte 29) x) 0))
((2) => 2)
((4) => 4)
((0) => 0)))
(ash-long1-pos-constant-shift2 ((lambda (x)
(ash (the (unsigned-byte 61) x) 2))
((2) => 8)
((4) => 16)))
(ash-long1-neg-constant-shift2 ((lambda (x)
(ash (the (unsigned-byte 61) x) -2))
((2) => 0)
((4) => 1)
((0) => 0)))
(ash-long1-neg-constant-shift-form2 ((lambda (x)
(ash (the (unsigned-byte 61) x) (- 2)))
((2) => 0)
((4) => 1)
((0) => 0)))
(ash-long1-zero-shift2 ((lambda (x)
(ash (the (unsigned-byte 61) x) 0))
((2) => 2)
((4) => 4)
((0) => 0)))
(ash-fixnum1-neg-2 ((lambda (x y)
(ash (the (unsigned-byte 29) x) (the (integer -5 -1) y)))
((2 -1) => 1)
((4 -2) => 1)
((0 -2) => 0)))
(ash-long1-pos-fixnum2 ((lambda (x y)
(ash (the (unsigned-byte 40) x) (the (unsigned-byte 4) y)))
((2 2) => 8)
((4 2) => 16)))
(ash-long1-neg-fixnum2 ((lambda (x y)
(ash (the (unsigned-byte 40) x) (the (integer -5 -1) y)))
((4 -2) => 1)
((32 -1) => 16)))
(ash-long1-fixnum2 ((lambda (x y)
(ash (the (unsigned-byte 40) x) (the (integer -10 10) y)))
((2 3) => 16)
((4 -2) => 1)
((32 -1) => 16)))
(ash-regular ((lambda (x y)
(ash x y))
((2 3) => 16)
((4 -2) => 1)
((32 -1) => 16)))
(ash-constant ((lambda ()
(ash 2 4))
(() => 32)))
(ash-constant2 ((lambda ()
(ash 2 (+ 4)))
(() => 32))))))
(dolist (test-data all-tests)
(destructuring-bind (test-sym (test-fn &rest tests)) test-data
(prove:plan (1+ (length tests)))
(prove:ok
(compile test-sym test-fn)
(format nil "Checking for successful compilation of ~S: ~S" test-sym test-fn))
(dolist (test tests)
(destructuring-bind (args _ result) test
(declare (ignore _))
(prove:is
(apply test-sym args)
result
(format nil "Calling ~S with args ~S should be ~S" test-sym args result))))
(prove:finalize))))