While working on some things in maxima, I found that gcl was incorrectly
computing some numerical results. With help from Claude, it was isolated
to a bug in sort.
Load the attached file to see the issue. I’m using gcl (that I compiled
myself):
|>(lisp-implementation-version) "GCL 2.7.1 git tag Version_2_7_2pre15" |
I get:
|> (load "gcl-sort-bug.lisp") ... direct-gf (1.0 2.0 3.0) dbind-cl (2.0
1.0 3.0) <-- expected (1.0 2.0 3.0) dbind-fun (2.0 1.0 3.0) <-- expected
(1.0 2.0 3.0) dbind-gf (2.0 1.0 3.0) <-- expected (1.0 2.0 3.0) setf-cl
(2.0 1.0 3.0) <-- expected (1.0 2.0 3.0) setf-fun (2.0 1.0 3.0) <--
expected (1.0 2.0 3.0) setf-gf (2.0 1.0 3.0) <-- expected (1.0 2.0 3.0)
vector-gf (1.0 2.0 3.0) 6 of 10 failed ;; Finished loading "gcl-sort-bug" |
​
;;; In compiled code, the list returned by SORT is used in its
;;; original, unsorted order. Returning the value of SORT directly
;;; works. Sorting a vector works.
;;;
;;; Usage: (load "gcl-sort-bug.lisp")
(defun pred-fun (a b) (< a b))
(defgeneric pred-gf (a b))
(defmethod pred-gf ((a real) (b real)) (< a b))
;; Return the value of SORT directly.
(defun direct-cl (x y z) (sort (list x y z) #'<))
(defun direct-fun (x y z) (sort (list x y z) #'pred-fun))
(defun direct-gf (x y z) (sort (list x y z) #'pred-gf))
;; Destructure the value of SORT.
(defun dbind-cl (x y z)
(destructuring-bind (a b c) (sort (list x y z) #'<) (list a b c)))
(defun dbind-fun (x y z)
(destructuring-bind (a b c) (sort (list x y z) #'pred-fun) (list a b c)))
(defun dbind-gf (x y z)
(destructuring-bind (a b c) (sort (list x y z) #'pred-gf) (list a b c)))
;; Assign the value of SORT back to the variable.
(defun setf-cl (x y z)
(let ((l (list x y z)))
(setf l (sort l #'<))
(list (first l) (second l) (third l))))
(defun setf-fun (x y z)
(let ((l (list x y z)))
(setf l (sort l #'pred-fun))
(list (first l) (second l) (third l))))
(defun setf-gf (x y z)
(let ((l (list x y z)))
(setf l (sort l #'pred-gf))
(list (first l) (second l) (third l))))
;; Sort a vector.
(defun vector-gf (x y z)
(let ((v (sort (vector x y z) #'pred-gf)))
(list (aref v 0) (aref v 1) (aref v 2))))
(defparameter *tests*
'(direct-cl direct-fun direct-gf
dbind-cl dbind-fun dbind-gf
setf-cl setf-fun setf-gf
vector-gf))
(dolist (f *tests*)
(compile f))
(format t "~&~A ~A~%" (lisp-implementation-type) (lisp-implementation-version))
(let ((failures 0))
(dolist (f *tests*)
(let ((result (funcall f 2.0 1.0 3.0)))
(unless (equal result '(1.0 2.0 3.0))
(incf failures))
(format t "~&~(~10A~) ~S~:[ <-- expected (1.0 2.0 3.0)~;~]~%"
f result (equal result '(1.0 2.0 3.0)))))
(format t "~&~D of ~D failed~%" failures (length *tests*)))
