Skip to content
Snippets Groups Projects
issues.lisp 17 KiB
Newer Older
;;; Tests from gitlab issues

(defpackage :issues-tests
  (:use :cl :lisp-unit))

(in-package "ISSUES-TESTS")

(defun square (x)
  (expt x 2))

(define-compiler-macro square (&whole form arg)
  (declare (ignore arg))
  form)

Elias Pipping's avatar
Elias Pipping committed
(defparameter *test-path*
  (merge-pathnames (make-pathname :name :unspecific :type :unspecific
                                  :version :unspecific)
                   *load-truename*)
  "Directory for temporary test files.")

(define-test issue.1.a
    (:tag :issues)
  (assert-equal
   '(square x)
   (funcall (compiler-macro-function 'square) '(square x) nil)))

(define-test issue.1.b
    (:tag :issues)
  (assert-equal
   '(square x)
   (funcall (compiler-macro-function 'square) '(funcall #'square x) nil)))
(define-test issue.4
  (:tag :issues)
  ;; Compile up two versions of elt.  F-LIST should get transformed to
  ;; LISP::LISP-ELT*, and F-VEC should be converted to AREF.  Both of
  ;; thse should signal errors.
  (let ((f-list (compile nil '(lambda (list n)
				(declare (type list list)
					 (optimize (speed 1) (safety 1) (compilation-speed 1)
						   (space 1) (debug 1)))
			       (elt list n))))
	(f-vec (compile nil '(lambda (vec n)
			       (declare (type (simple-array * (*)) vec)
					(optimize (speed 1) (safety 1) (compilation-speed 1)
						  (space 1) (debug 1)))
			      (elt vec n)))))
    ;; Errors because the index is beyond the end of the sequence
    (assert-error 'lisp::index-too-large-error (funcall f-list (list 0 1 2) 3))
    (assert-error 'type-error (funcall f-vec (make-array 3 :initial-contents '(0 1 2)) 3))
    ;; Errors because the index is negative.
    (assert-error 'type-error (funcall f-list (list 0 1 2) -1))
    (assert-error 'type-error (funcall f-vec (make-array 3 :initial-contents '(0 1 2)) -1))))

(define-test issue.4.setters
  (:tag :issues)
  ;; Compile up two versions of (SETF ELT).  F-LIST should get transformed to
  ;; %SETELT, and F-VEC should be converted to (SETF AREF).  Both of
  ;; thse should signal errors.
  (let ((s-list (compile nil '(lambda (list n new)
				(declare (type list list))
				(setf (elt list n) new))))
	(s-vec (compile nil '(lambda (vec n new)
			       (declare (type (simple-array * (*)) vec))
			       (setf (elt vec n) new)))))
    ;; Errors because the index is beyond the end of the sequence
    (assert-error 'type-error (funcall s-list (list 0 1 2) 3 99))
    (assert-error 'type-error (funcall s-vec (make-array 3 :initial-contents '(0 1 2)) 3 99))
    ;; Errors because the index is negative.
    (assert-error 'type-error (funcall s-list (list 0 1 2) -1 99))
    (assert-error 'type-error (funcall s-vec (make-array 3 :initial-contents '(0 1 2)) -1 99))))


;; Functions for testing issue-3
(defun sqr (x)
  (expt x 2))

(define-compiler-macro sqr (x)
  `(expt ,x 2))

(eval-when (:compile-toplevel :load-toplevel :execute)
(defmacro with-square-check (&body body &environment env)
  (let ((text (if (compiler-macro-function 'sqr env)
                  "Yes"
                  "No")))
    `(progn
       (format t "SQUARE compiler macro present: ~A.~%" ,text)
       ,@body))))


(defun test/absent ()
  (with-square-check
    (sqr 2)))

(defun test/present ()
  (flet ((sqr (x)
           (print (expt x 3))))
    (with-square-check
      (sqr 2))))

(define-test issue.3
    (:tag :issues)
  (assert-prints "SQUARE compiler macro present: Yes."
		 (test/absent))
  (assert-prints "SQUARE compiler macro present: No.

8"
		 (test/present)))

(defmacro xpop (place &environment env)
  (multiple-value-bind (dummies vals new setter getter)
      (get-setf-expansion place env)
    `(let* (,@(mapcar #'list dummies vals) (,(car new) ,getter))
      (if ,(cdr new) (error "Can't expand this."))
      (prog1 (car ,(car new))
    (setq ,(car new) (cdr ,(car new)))
    ,setter))))

(defsetf frob (x) (value) 
     `(setf (car ,x) ,value))

(define-test issue.7
    (:tag :issues)
  (assert-error 'error
		(let ((z (list 1 2)))
		  (flet ((frob (x) (cdr x)))
		    (xpop (frob z))))))
Raymond Toy's avatar
Raymond Toy committed

(define-test issue.10-unsigned-byte-4
    (:tag :issues)
  (macrolet
      ((compiled-test-function (constant-index)
	 ;; Compile the test function from the issue.
	 (compile nil `(lambda (v x)
			 (declare (type (integer 0 5) v)
				  (optimize (safety 0)))
			 (setf (aref (the (simple-array (integer 0 5) (1)) x)
				     ,constant-index)
			       (the (integer 0 5) v))
			 x)))
       (make-tests ()
	 ;; Create a set of tests for a set of fixed constant indices,
	 ;; one test for each constant index from 0 to 15.
	 (let (tests)
	   (dotimes (k 16)
	     (push 
	      `(assert-equal 1
			     (aref (funcall (compiled-test-function ,k)
					    1
					    (make-array 16 :element-type '(integer 0 5) :initial-element 0))
				   ,k))
	      tests))
	   `(progn ,@(nreverse tests)))))
    (make-tests)))

(define-test issue.10-unsigned-byte-2
    (:tag :issues)
  (macrolet
      ((compiled-test-function (constant-index)
	 ;; Compile the test function from the issue.
	 (compile nil `(lambda (v x)
			 (declare (type (integer 0 2) v)
				  (optimize (safety 0)))
			 (setf (aref (the (simple-array (integer 0 2) (1)) x)
				     ,constant-index)
			       (the (integer 0 2) v))
			 x)))
       (make-tests ()
	 ;; Create a set of tests for a set of fixed constant indices,
	 ;; one test for each constant index from 0 to 31.
	 (let (tests)
	   (dotimes (k 32)
	     (push 
	      `(assert-equal 1
			     (aref (funcall (compiled-test-function ,k)
					    1
					    (make-array 32 :element-type '(integer 0 2) :initial-element 0))
				   ,k))
	      tests))
	   `(progn ,@(nreverse tests)))))
    (make-tests)))

(define-test issue.10-unsigned-byte-1
    (:tag :issues)
  (macrolet
      ((compiled-test-function (constant-index)
	 ;; Compile the test function from the issue.
	 (compile nil `(lambda (v x)
			 (declare (type (integer 0 1) v)
				  (optimize (safety 0)))
			 (setf (aref (the (simple-array (integer 0 1) (1)) x)
				     ,constant-index)
			       (the (integer 0 1) v))
			 x)))
       (make-tests ()
	 ;; Create a set of tests for a set of fixed constant indices,
	 ;; one test for each constant index from 0 to 31.
	 (let (tests)
	   (dotimes (k 64)
	     (push 
	      `(assert-equal 1
			     (aref (funcall (compiled-test-function ,k)
					    1
					    (make-array 64 :element-type '(integer 0 1) :initial-element 0))
				   ,k))
	      tests))
	   `(progn ,@(nreverse tests)))))
    (make-tests)))

(define-test issue.22
    (:tag :issues)
  (let ((tester (compile nil '(lambda (x)
			       (coerce x 'float)))))
    (assert-eql 1.0 (funcall tester 1))
    (assert-eql 2f0 (funcall tester 2f0))
    (assert-eql 3d0 (funcall tester 3d0))
    (assert-eql 4w0 (funcall tester 4w0))))
    
(define-test issue.25a
    (:tag :issues)
  ;; The original test from issue 25, modified slightly for lisp-unit
  ;; testing.
  (let* ((in-string (format nil "A line.~%And another.~%")))
    (with-output-to-string (out-stream nil)
      (with-input-from-string (in-stream in-string)
	(ext:run-program "cat" nil
			 :wait t
			 :input in-stream
			 :output out-stream))
      (let ((out-string (get-output-stream-string out-stream)))
	(assert-eql (length in-string) (length out-string))
	(assert-equal in-string out-string)))))

(define-test issue.25b
    (:tag :issues)
  ;; Modified test to verify that we only write the low 8-bits of each
  ;; string character to run-program.
  (let* ((in-string (concatenate 'string '(#\greek_small_letter_alpha
					   #\greek_small_letter_beta)))
	 (expected (map 'string #'(lambda (c)
				    (code-char (ldb (byte 8 0) (char-code c))))
			in-string)))
    (with-output-to-string (out-stream nil)
      (with-input-from-string (in-stream in-string)
	(ext:run-program "cat" nil
			 :wait t
			 :input in-stream
			 :output out-stream))
      (let ((out-string (get-output-stream-string out-stream)))
	(assert-eql (length out-string) (length out-string))
	;; For comparison, convert the strings to codes so failures are easier to read
	(assert-equal (map 'list #'char-code out-string)
		      (map 'list #'char-code expected))))))

(define-test issue.25c
    (:tag :issues)
  ;; Modified test to verify that each octet read from run-program is
  ;; read into the low 8-bits of each character of the resulting
  ;; string.
  (let* ((in-string (concatenate 'string '(#\greek_small_letter_alpha
					   #\greek_small_letter_beta)))
	 (expected (stream:string-encode in-string :utf16-be))
	 (path #p"issue25c.txt"))
    (with-open-file (s path :direction :output :if-exists :supersede :external-format :utf16-be)
      (write-string in-string s)
      (force-output s)
      (file-position s 0)
      (with-open-file (s1 path :direction :input :element-type '(unsigned-byte 8))
	(with-output-to-string (out-stream)
	  (ext:run-program "cat" nil
			   :wait t
			   :input s1
			   :output out-stream)
	  (let ((out-string (get-output-stream-string out-stream)))
	    (assert-equal (length out-string) (length expected))
	    (assert-equal (map 'list #'char-code out-string)
			  (map 'list #'char-code expected))))))))


(define-test issue.25d
    (:tag :issues)
  ;; The original test from issue 25, but using non-ascii characters
  ;; and using string-encode/decode to verify that the output and the
  ;; input match.
  (let* ((in-string (concatenate 'string '(#\greek_small_letter_alpha
					   #\greek_small_letter_beta
					   #\greek_small_letter_gamma
					   #\greek_small_letter_delta
					   #\greek_small_letter_epsilon
					   #\greek_small_letter_zeta
					   #\greek_small_letter_eta
					   #\greek_small_letter_theta
					   #\greek_small_letter_iota
					   #\greek_small_letter_kappa
					   #\greek_small_letter_lamda))))
    (with-output-to-string (out-stream nil)
      (with-input-from-string (in-stream (stream:string-encode in-string :utf8))
	(ext:run-program "cat" nil
			 :wait t
			 :input in-stream
			 :output out-stream))
      (let ((out-string (stream:string-decode (get-output-stream-string out-stream)
					      :utf8)))
	(assert-eql (length in-string) (length out-string))
	(assert-equal in-string out-string)))))

Raymond Toy's avatar
Raymond Toy committed


(define-test issue.30
    (:tag :issues)
Raymond Toy's avatar
Raymond Toy committed
  (let* ((test-file #.(merge-pathnames #p"resources/issue-30.lisp" cl:*load-pathname*))
Raymond Toy's avatar
Raymond Toy committed
	 (fasl-file (compile-file-pathname test-file)))
    ;; Compiling and loading the test file should succeed without
    ;; errors.
Raymond Toy's avatar
Raymond Toy committed
    (assert-true (pathnamep test-file))
    (assert-true (pathnamep fasl-file))
    (assert-equalp (list fasl-file nil nil)
		  (multiple-value-list (compile-file test-file :load t)))))
Raymond Toy's avatar
Raymond Toy committed

(define-test issue.24
    (:tag :issues)
  (let* ((test-file #.(merge-pathnames #p"resources/issue-24.lisp" cl:*load-pathname*)))
    (assert-true (compile-file test-file :load t))))
Raymond Toy's avatar
Raymond Toy committed

(define-test issue.32
    (:tag :issues)
  (assert-error 'kernel:simple-program-error
		(ext:run-program "cat" nil
				 :before-execve t)))
Elias Pipping's avatar
Elias Pipping committed

(define-test mr.15
    (:tag :issues)
  (let (directories files)
    (dolist (entry (directory (merge-pathnames "resources/mr.15/*.*" *test-path*)
                              :check-for-subdirs t
                              :follow-links nil
                              :truenamep nil))
      (let ((filename (pathname-name entry))
            (directory (first (last (pathname-directory entry)))))
        (if filename
            (push filename files)
            (push directory directories))))
    (assert-true (null (set-difference files
				       '("file" "link-to-dir"
					 "link-to-dir-in-dir" "link-to-file")
				       :test #'string-equal)))
    (assert-true (null (set-difference directories
				       '(".dir" "dir")
				       :test #'string-equal)))))
(define-test issue.36
    (:tag :issues)
  (loop for k from 1 to 24 do
    (assert-equal 0 (encode-universal-time 0 0 (- 24 k) 31 12 1899 k))))
Raymond Toy's avatar
Raymond Toy committed
(define-test issue.26
    (:tag :issues)
  (let ((start-time (get-universal-time)))
    (let ((p (ext:run-program "/usr/bin/env" '("sleep" "1") :wait nil)))
      (sleep 5)
      ;; For this test to be valid, the process must have finished
      ;; with a successful exit.
      (assert-true (eq (ext:process-status p) :exited))
      (assert-true (zerop (ext:process-exit-code p)))

Raymond Toy's avatar
Raymond Toy committed
      ;; We expect to have slept for at least 5 sec, but since
      ;; get-universal-time only has an accuracy of 1 sec, just verify
      ;; more than 3 sec have elapsed.
      (assert-true (>= (- (get-universal-time) start-time) 3)))))

(defun issue-41-tester (stop-signal)
  (let* ((p (ext:run-program "/bin/sleep" '("5") :wait nil))
	 (pid (ext:process-pid p)))
    (flet ((external-kill (pid signal)
	     (ext:run-program "/usr/bin/env"
			  (list "kill"
				(format nil "-~D" signal)
				(format nil "~D" pid)))))
      (assert-eql :running (ext:process-status p))

      (external-kill pid stop-signal)
      (sleep 1)
      (assert-eql :stopped (ext:process-status p))

      (external-kill pid unix:sigcont)
      (sleep 1)
      (assert-eql :continued (ext:process-status p))

      (external-kill pid stop-signal)
      (sleep 1)
      (assert-eql :stopped (ext:process-status p))

      (external-kill pid unix:sigcont)
      (sleep 1)
      (assert-eql :continued (ext:process-status p))

      (sleep 5)
      (assert-eql :exited (ext:process-status p)))))

(define-test issue.41.1
    (:tag :issues)
  (issue-41-tester unix:sigstop))

#+nil
(define-test issue.41.2
    (:tag :issues)
  (issue-41-tester unix:sigtstp))
Raymond Toy's avatar
Raymond Toy committed

(define-test issue.45
  (:tag :issues)
  ;; This depends on run-tests to setup the test directory correctly!
  (let* ((test-dir #p"test-tmp/")
	 (test-dir-name (namestring test-dir)))
    (flet ((do-test (program)
	     (with-output-to-string (s)
	       (let ((process
		      (ext:run-program program
				       (list test-dir-name)
				       :wait t :output s)))
		 ;; Verify process exited without error and that we
		 ;; got the expected output.
		 (assert-eql 0
			     (ext:process-exit-code process))
		 (assert-equal "ls-link
"
			       (get-output-stream-string s))))))
      ;; Test that absolute paths work.
      (do-test "/bin/ls")
      ;; Test that unspecfied path works.  This depends on "ls" being
      ;; somewhere in PATH.
      (do-test "ls")
      ;; Test that relative path to program works. (Issue #45).
      (do-test (concatenate 'string
			    "./"
			    test-dir-name
			    "ls-link")))))

(define-test issue.47
  (:tag :issues)
  (with-standard-io-syntax
    (assert-equal "`(,@VARS ,@VARS)"
		  (with-output-to-string (s)
		    (write (read-from-string "`(,@vars ,@vars)")
			   :pretty t
			   :stream s)))))
Raymond Toy's avatar
Raymond Toy committed

(define-test issue.59
  (:tag :issues)
  (let ((f (compile nil #'(lambda (z)
			    (declare (type (double-float -2d0 0d0) z))
			    (nth-value 2 (decode-float z))))))
    (assert-equal -1d0 (funcall f -1d0))))

(define-test issue.59.1-double
  (:tag :issues)
  (dolist (entry '(((-2d0 2d0) (-1073 2))
		   ((-2d0 0d0) (-1073 2))
		   ((0d0 2d0) (-1073 2))
		   ((1d0 4d0) (1 3))
		   ((-4d0 -1d0) (1 3))
		   (((0d0) (10d0)) (-1073 4))
		   ((-2f0 2f0) (-148 2))
		   ((-2f0 0f0) (-148 2))
		   ((0f0 2f0) (-148 2))
		   ((1f0 4f0) (1 3))
		   ((-4f0 -1f0) (1 3))
		   ((0f0) (10f0)) (-148 4)))
    (destructuring-bind ((arg-lo arg-hi) (result-lo result-hi))
	entry
      (assert-equalp (c::specifier-type `(integer ,result-lo ,result-hi))
		     (c::decode-float-exp-derive-type-aux
		      (c::specifier-type `(double-float ,arg-lo ,arg-hi)))))))

(define-test issue.59.1-double
  (:tag :issues)
  (dolist (entry '(((-2d0 2d0) (-1073 2))
		   ((-2d0 0d0) (-1073 2))
		   ((0d0 2d0) (-1073 2))
		   ((1d0 4d0) (1 3))
		   ((-4d0 -1d0) (1 3))
		   (((0d0) (10d0)) (-1073 4))
		   (((0.5d0) (4d0)) (0 3))))
    (destructuring-bind ((arg-lo arg-hi) (result-lo result-hi))
	entry
      (assert-equalp (c::specifier-type `(integer ,result-lo ,result-hi))
		     (c::decode-float-exp-derive-type-aux
		      (c::specifier-type `(double-float ,arg-lo ,arg-hi)))
		     arg-lo
		     arg-hi))))

(define-test issue.59.1-float
  (:tag :issues)
  (dolist (entry '(((-2f0 2f0) (-148 2))
		   ((-2f0 0f0) (-148 2))
		   ((0f0 2f0) (-148 2))
		   ((1f0 4f0) (1 3))
		   ((-4f0 -1f0) (1 3))
		   (((0f0) (10f0)) (-148 4))
		   (((0.5f0) (4f0)) (0 3))))
    (destructuring-bind ((arg-lo arg-hi) (result-lo result-hi))
	entry
      (assert-equalp (c::specifier-type `(integer ,result-lo ,result-hi))
		     (c::decode-float-exp-derive-type-aux
		      (c::specifier-type `(single-float ,arg-lo ,arg-hi)))
		     arg-lo
		     arg-hi))))

(define-test issue.60
  (:tag :issues)
  (let ((c14 (compile nil #'(lambda (x)
			      (fround (the (member 1.0 2d0) x))))))
    (assert-equalp
     (values 1.0 0.0)
     (funcall c14 1.0))
    (assert-equalp
     (values 2d0 0d0)
     (funcall c14 2d0))))

(define-test issue.58
  (:tag :issues)
  (let ((c9 (compile nil #'(lambda (x)
			     (= (the (eql 1.0d0) x) #c(1/2 1/2))))))
    (assert-false (funcall c9 1.d0))))

(define-test issue.61
  (:tag :issues)
  ;; Verifies that the compiler doesn't segfault and that we return
  ;; the correct value.
  (assert-false
   (funcall (compile nil '(lambda () (array-has-fill-pointer-p #*10))))))

(define-test issue.62
  (:tag :issues)
  ;; Verifies that the compiler doesn't segfault and that we return
  ;; the correct value.
  (assert-false
   (funcall (compile nil '(lambda () (array-displacement "aaaaaaaa"))))))