common-lisp/sbcl.sbcl
1
0
Fork 0
mirror of git://git.code.sf.net/p/sbcl/sbcl synced 2026-09-10 07:26:40 -04:00
Code Issues Actions 8 Packages Projects Releases Wiki Activity

message

Browse source
This commit is contained in:
Nikodemus Siivola 2005-02-13 14:27:01 +00:00
parent b86f43bae3
commit 079ef9dad5
25 changed files with 207 additions and 82 deletions
Show stats Download patch file Download diff file Expand all files Collapse all files

33
BUGS
View file

@ -2032,12 +2032,31 @@ WORKAROUND:
(most-positive-short-float or short-float-infinity) or signalling an
error immediately would seem to make more sense.
371:
SBCL 0.8.19 fails on
372: floating-point overflow not signalled on ppc/darwin
The following assertions in float.pure.lisp fail on ppc/darwin
(Mac OS X version 10.3.7):
(assert (raises-error? (scale-float 1.0 most-positive-fixnum)
floating-point-overflow))
(assert (raises-error? (scale-float 1.0d0 (1+ most-positive-fixnum))
floating-point-overflow)))
as the SCALE-FLOAT just returns
#.SB-EXT:SINGLE/DOUBLE-FLOAT-POSITIVE-INFINITY. These tests have been
disabled on Darwin for now.
(defvar *r* -7043009959286724629649270926654940933664689003233793014518979272497911394287216967075767325693021717277238746020477538876750544587281879084559996466844417586093291189295867052594478662802691926547232838591510540917276694295393715934079679531035912244103731582711556740654671309980075069010778644542022/670550434139267031632063192770201289106737062379324644110801846820471752716238484923370056920388400273070254958650831435834503195629325418985020030706879602898158806736813101434594805676212779217311897830937606064579213895527844045511878668289820732425014254579493444623868748969110751636786165152601)
373: profiling issues on ppc/darwin
The following bit from smoke.impure.lisp fails on ppc/darwin:
(progn
(defun profiled-fun ()
(random 1d0))
(profile profiled-fun)
(loop repeat 100000 do (profiled-fun))
(report))
dropping into the debugger with a TYPE-ERROR:
The value -1073741382 is not of type UNSIGNED-BYTE.
The test has been disabled on Darwin till the bug is fixed.
(let ((*print-base* 5)
(*read-base* 5)
(*print-radix* nil))
(assert (= *r* (read-from-string (prin1-to-string *r*)))))
374: BIT-AND problem on ppc/darwin:
The BIT-AND test in bit-vector.impure-cload.lisp results in
fatal error encountered in SBCL pid 8356:
GC invariant lost, file "gc-common.c", line 605
on ppc/darwin. Test disabled for the duration.

2
NEWS
View file

@ -4,6 +4,8 @@ changes in sbcl-0.8.20 (0.9alpha.0?) relative to sbcl-0.8.19:
* fixed bugs 19 and 317: fixed-format floating point printing is
more accurate. This also fixes a bug reported by Adam Warner
related to the ~@F format directive.
* fixed bug 371: bignum print/read inconsistency. (thanks to Harald
Hanche-Olsen)
* fixed bug: SET-SYNTAX-FROM-CHAR correctly shallow-copies a
dispatch table if the from-char is a dispatch macro character.
* fixed bug: COUNT and EQUAL on bit vectors with lengths divisible

7
make.sh
View file

@ -128,11 +128,14 @@ NPASSED=`find contrib -name test-passed -print | wc -l`
echo
echo "The build seems to have finished successfully, including $NPASSED (out of $NCONTRIBS)"
echo "contributed modules. If you would like to run more extensive tests (but"
echo "expect some failures on non-x86 platforms) on the new SBCL, you can try:"
echo "contributed modules. If you would like to run more extensive tests on"
echo "the new SBCL, you can try:"
echo
echo " cd tests && sh ./run-tests.sh"
echo
echo " (All tests should pass on x86/Linux and ppc/Darwin, on other platforms"
echo " some failures are currently expected; patches welcome as always.)"
echo
echo "To build documentation:"
echo
echo " cd doc/manual && make"

13
src/code/condition.lisp
View file

@ -956,11 +956,20 @@ SB-EXT:PACKAGE-LOCKED-ERROR-SYMBOL."))
) ; progn
(define-condition undefined-alien-error (error) ()
(define-condition undefined-alien-error (error) ())
(define-condition undefined-alien-variable-error (undefined-alien-error) ()
(:report
(lambda (condition stream)
(declare (ignore condition))
(format stream "Attempt to access an undefined alien value."))))
(format stream "Attempt to access an undefined alien variable."))))
(define-condition undefined-alien-function-error (undefined-alien-error) ()
(:report
(lambda (condition stream)
(declare (ignore condition))
(format stream "Attempt to call an undefined alien function."))))
;;;; various other (not specified by ANSI) CONDITIONs
;;;;

7
src/code/foreign-load.lisp
View file

@ -141,7 +141,7 @@ SB-EXT:SAVE-LISP-AND-DIE for details."
(let ((symbols ())
(undefineds ()))
(defun get-dynamic-foreign-symbol-address (symbol)
(defun get-dynamic-foreign-symbol-address (symbol &optional datap)
(dlerror) ; clear old errors
(unless *runtime-dlhandle*
(bug "Cannot resolve foreign symbol: lost *runtime-dlhandle*"))
@ -160,7 +160,10 @@ SB-EXT:SAVE-LISP-AND-DIE for details."
(style-warn "Undefined alien: ~S" symbol)
(pushnew symbol undefineds :test #'equal)
(remove symbol symbols :test #'equal)
undefined-alien-address)
(if datap
undefined-alien-address
(foreign-symbol-address-as-integer
(sb!vm:extern-alien-name "undefined_alien_function"))))
(addr
(pushnew symbol symbols :test #'equal)
(remove symbol undefineds :test #'equal)

2
src/code/foreign.lisp
View file

@ -30,7 +30,7 @@
(progn
#-sb-xc-host
(values #!-linkage-table
(get-dynamic-foreign-symbol-address name)
(get-dynamic-foreign-symbol-address name datap)
#!+linkage-table
(ensure-foreign-symbol-linkage name datap)
t))))

7
src/code/interr.lisp
View file

@ -456,5 +456,8 @@
"Control stack guard page temporarily disabled: proceed with caution~%")
(error 'control-stack-exhausted))))
(defun undefined-alien-error ()
(error 'undefined-alien-error))
(defun undefined-alien-variable-error ()
(error 'undefined-alien-variable-error))
(defun undefined-alien-function-error ()
(error 'undefined-alien-function-error))

9
src/code/linkage-table.lisp
View file

@ -48,7 +48,7 @@
(let ((table-address (+ (* (hash-table-count *linkage-info*)
sb!vm:linkage-table-entry-size)
sb!vm:linkage-table-space-start))
(real-address (get-dynamic-foreign-symbol-address name)))
(real-address (get-dynamic-foreign-symbol-address name datap)))
(aver real-address)
(unless (< table-address sb!vm:linkage-table-space-end)
(error "Linkage-table full (~D entries): cannot link ~S."
@ -74,9 +74,10 @@
(defun update-linkage-table ()
;; Doesn't take care of it's own locking -- callers are responsible
(maphash (lambda (name info)
(let ((datap (linkage-info-datap info))
(table-address (linkage-info-address info))
(real-address (get-dynamic-foreign-symbol-address name)))
(let* ((datap (linkage-info-datap info))
(table-address (linkage-info-address info))
(real-address
(get-dynamic-foreign-symbol-address name datap)))
(aver (and table-address real-address))
(write-linkage-table-entry table-address
real-address

47
src/code/print.lisp
View file

@ -1104,18 +1104,43 @@
(schar "0123456789ABCDEFGHIJKLMNOPQRSTUVWXYZ" r)
stream)))
;; Algorithm by Harald Hanche-Olsen, sbcl-devel 2005-02-05
(defun %output-bignum-in-base (n base stream)
(labels ((bisect (n power)
(if (fixnump n)
(%output-fixnum-in-base n base stream)
(let ((k (truncate power 2)))
(multiple-value-bind (q r) (truncate n (expt base k))
(bisect q (- power k))
(let ((npower (if (zerop r) 0 (truncate (log r base)))))
(dotimes (z (- k npower 1))
(write-char #\0 stream))
(bisect r npower)))))))
(bisect n (truncate (log n base)))))
(declare (type bignum n) (type fixnum base))
(let ((power (make-array 10 :adjustable t :fill-pointer 0)))
;; Here there be the bottleneck for big bignums, in the (* p p).
;; A special purpose SQUARE-BIGNUM might help a bit. See eg: Dan
;; Zuras, "On Squaring and Multiplying Large Integers", ARITH-11:
;; IEEE Symposium on Computer Arithmetic, 1993, pp. 260 to 271.
;; Reprinted as "More on Multiplying and Squaring Large Integers",
;; IEEE Transactions on Computers, volume 43, number 8, August
;; 1994, pp. 899-908.
(do ((p base (* p p)))
((> p n))
(vector-push-extend p power))
;; (aref power k) == (expt base (expt 2 k))
(labels ((bisect (n k exactp)
(declare (fixnum k))
;; N is the number to bisect
;; K on initial entry BASE^(2^K) > N
;; EXACTP is true if 2^K is the exact number of digits
(cond ((zerop n)
(when exactp
(loop repeat (ash 1 k) do (write-char #\0 stream))))
((zerop k)
(write-char
(schar "0123456789ABCDEFGHIJKLMNOPQRSTUVWXYZ" n)
stream))
(t
(setf k (1- k))
(multiple-value-bind (q r) (truncate n (aref power k))
;; EXACTP is NIL only at the head of the
;; initial number, as we don't know the number
;; of digits there, but we do know that it
;; doesn't get any leading zeros.
(bisect q k exactp)
(bisect r k (or exactp (plusp q))))))))
(bisect n (fill-pointer power) nil))))
(defun %output-integer-in-base (integer base stream)
(when (minusp integer)

3
src/compiler/alpha/parms.lisp
View file

@ -184,7 +184,8 @@
sub-gc
sb!kernel::internal-error
sb!kernel::control-stack-exhausted-error
sb!kernel::undefined-alien-error
sb!kernel::undefined-alien-variable-error
sb!kernel::undefined-alien-function-error
sb!di::handle-breakpoint
sb!di::handle-fun-end-breakpoint

3
src/compiler/generic/genesis.lisp
View file

@ -1249,7 +1249,8 @@ core and return a descriptor to it."
(frob sub-gc)
(frob internal-error)
(frob sb!kernel::control-stack-exhausted-error)
(frob sb!kernel::undefined-alien-error)
(frob sb!kernel::undefined-alien-variable-error)
(frob sb!kernel::undefined-alien-function-error)
(frob sb!di::handle-breakpoint)
(frob sb!di::handle-fun-end-breakpoint)
(frob sb!thread::handle-thread-exit))

3
src/compiler/hppa/parms.lisp
View file

@ -124,7 +124,8 @@
sb!impl::sub-gc
sb!kernel::internal-error
sb!kernel::control-stack-exhausted-error
sb!kernel::undefined-alien-error
sb!kernel::undefined-alien-variable-error
sb!kernel::undefined-alien-function-error
sb!di::handle-breakpoint
sb!impl::fdefinition-object

3
src/compiler/mips/parms.lisp
View file

@ -113,7 +113,8 @@
sb!impl::sub-gc
sb!kernel::internal-error
sb!kernel::control-stack-exhausted-error
sb!kernel::undefined-alien-error
sb!kernel::undefined-alien-variable-error
sb!kernel::undefined-alien-function-error
sb!di::handle-breakpoint
sb!impl::fdefinition-object

3
src/compiler/ppc/parms.lisp
View file

@ -153,7 +153,8 @@
sb!impl::sub-gc
sb!kernel::internal-error
sb!kernel::control-stack-exhausted-error
sb!kernel::undefined-alien-error
sb!kernel::undefined-alien-variable-error
sb!kernel::undefined-alien-function-error
sb!di::handle-breakpoint
sb!impl::fdefinition-object

3
src/compiler/sparc/parms.lisp
View file

@ -181,7 +181,8 @@
sub-gc
sb!kernel::internal-error
sb!kernel::control-stack-exhausted-error
sb!kernel::undefined-alien-error
sb!kernel::undefined-alien-variable-error
sb!kernel::undefined-alien-function-error
sb!di::handle-breakpoint
sb!di::handle-fun-end-breakpoint

6
src/compiler/x86-64/parms.lisp
View file

@ -161,6 +161,9 @@
;;; FIXME: !COLD-INIT probably doesn't need
;;; to be in the static symbols table any more.
;;;
;;; FIXME: some of these symbols are shared by all backends,
;;; and should be factored out into a common file.
(defparameter *static-symbols*
'(t
@ -172,7 +175,8 @@
sub-gc
sb!kernel::internal-error
sb!kernel::control-stack-exhausted-error
sb!kernel::undefined-alien-error
sb!kernel::undefined-alien-variable-error
sb!kernel::undefined-alien-function-error
sb!di::handle-breakpoint
fdefinition-object
#!+sb-thread sb!thread::handle-thread-exit

3
src/compiler/x86/parms.lisp
View file

@ -269,7 +269,8 @@
sub-gc
sb!kernel::internal-error
sb!kernel::control-stack-exhausted-error
sb!kernel::undefined-alien-error
sb!kernel::undefined-alien-variable-error
sb!kernel::undefined-alien-function-error
sb!di::handle-breakpoint
fdefinition-object
#!+sb-thread sb!thread::handle-thread-exit

12
src/runtime/interrupt.c
View file

@ -754,6 +754,16 @@ void thread_exit_handler(int num, siginfo_t *info, void *v_context)
#endif
/* KLUDGE: Theoretically the approach we use for undefined alien
* variables should work for functions as well, but on PPC/Darwin
* we get bus error at bogus addresses instead, hence this workaround,
* that has the added benefit of automatically discriminating between
* functions and variables.
*/
void undefined_alien_function() {
funcall0(SymbolFunction(UNDEFINED_ALIEN_FUNCTION_ERROR));
}
boolean handle_guard_page_triggered(os_context_t *context,void *addr){
struct thread *th=arch_os_get_current_thread();
@ -785,7 +795,7 @@ boolean handle_guard_page_triggered(os_context_t *context,void *addr){
else if (addr >= undefined_alien_address &&
addr < undefined_alien_address + os_vm_page_size) {
arrange_return_to_lisp_function
(context, SymbolFunction(UNDEFINED_ALIEN_ERROR));
(context, SymbolFunction(UNDEFINED_ALIEN_VARIABLE_ERROR));
return 1;
}
else return 0;

2
src/runtime/os.h
View file

@ -44,7 +44,7 @@
#define OS_VM_PROT_ALL \
(OS_VM_PROT_READ | OS_VM_PROT_WRITE | OS_VM_PROT_EXECUTE)
#define OS_VM_PROT_NONE (!OS_VM_PROT_ALL)
#define OS_VM_PROT_NONE 0
extern os_vm_size_t os_vm_page_size;

79
tests/bit-vector.impure-cload.lisp
View file

@ -16,7 +16,7 @@
(declaim (optimize (speed 3) (safety 1) (space 0) (compilation-speed 0)))
(defun bit-vector-test ()
(defun test-small-bit-vectors ()
;; deal with the potential length 0 special case
(let ((a (make-array 0 :element-type 'bit))
(b (make-array 0 :element-type 'bit)))
@ -31,36 +31,59 @@
(setf (aref b 1) 1) ; b = #*010..0
(assert (equal (bit-xor a b) #*001111111111111111111111111111111))
(assert (equal (bit-and a b) #*010000000000000000000000000000000)))
;; now test the biggy, mostly that it works...
#-x86-64 ; except on machines where addressable space is likely to be
; much bigger than physical memory
(let ((a (make-array (1- array-dimension-limit) :element-type 'bit :initial-element 0))
(b (make-array (1- array-dimension-limit) :element-type 'bit :initial-element 0)))
(bit-not a a)
(assert (= (aref a 0) 1))
(assert (= (aref a (- array-dimension-limit 2)) 1))
(bit-and a b a)
(assert (= (aref a 0) 0))
(assert (= (aref a (- array-dimension-limit 2)) 0)))
;; a special COUNT transform on bitvectors; triggers on (>= SPEED SPACE)
(locally
(declare (optimize (speed 3) (space 1)))
(let ((bv1 (make-array 5 :element-type 'bit))
(bv2 (make-array 0 :element-type 'bit))
(bv3 (make-array 68 :element-type 'bit)))
(declare (type simple-bit-vector bv1 bv2 bv3))
(setf (sbit bv3 42) 1)
;; bitvector smaller than the word size
(assert (= 0 (count 1 bv1)))
(assert (= 5 (count 0 bv1)))
;; special case of 0-length bitvectors
(assert (= 0 (count 1 bv2)))
(assert (= 0 (count 0 bv2)))
;; bitvector larger than the word size
(assert (= 1 (count 1 bv3)))
(assert (= 67 (count 0 bv3))))))
(declare (optimize (speed 3) (space 1)))
(let ((bv1 (make-array 5 :element-type 'bit))
(bv2 (make-array 0 :element-type 'bit))
(bv3 (make-array 68 :element-type 'bit)))
(declare (type simple-bit-vector bv1 bv2 bv3))
(setf (sbit bv3 42) 1)
;; bitvector smaller than the word size
(assert (= 0 (count 1 bv1)))
(assert (= 5 (count 0 bv1)))
;; special case of 0-length bitvectors
(assert (= 0 (count 1 bv2)))
(assert (= 0 (count 0 bv2)))
;; bitvector larger than the word size
(assert (= 1 (count 1 bv3)))
(assert (= 67 (count 0 bv3))))))
(bit-vector-test)
(defun inform (msg)
(print msg)
(force-output))
(defun test-big-bit-vectors ()
;; now test the biggy, mostly that it works...
(let ((a (progn
(inform :make-array-1)
(make-array (1- array-dimension-limit)
:element-type 'bit :initial-element 0)))
(b (progn
(inform :make-array-2)
(make-array (1- array-dimension-limit)
:element-type 'bit :initial-element 0))))
(inform :bit-not)
(bit-not a a)
(inform :aref-1)
(assert (= (aref a 0) 1))
(inform :aref-2)
(assert (= (aref a (- array-dimension-limit 2)) 1))
#-darwin
(progn
(inform :bit-and)
(bit-and a b a)
(inform :aref-3)
(assert (= (aref a 0) 0))
(inform :aref-4)
(assert (= (aref a (- array-dimension-limit 2)) 0)))))
(test-small-bit-vectors)
#-x86-64
;; except on machines where addressable space is likely to be
;; much bigger than physical memory
(test-big-bit-vectors)
;;; success
(sb-ext:quit :unix-status 104)

10
tests/float.pure.lisp
View file

@ -91,7 +91,9 @@
least-positive-double-float))
(assert (= 0.0 (scale-float 1.0 most-negative-fixnum)))
(assert (= 0.0d0 (scale-float 1.0d0 (1- most-negative-fixnum))))
(assert (raises-error? (scale-float 1.0 most-positive-fixnum)
floating-point-overflow))
(assert (raises-error? (scale-float 1.0d0 (1+ most-positive-fixnum))
floating-point-overflow))
#-darwin ;; bug 372
(progn
(assert (raises-error? (scale-float 1.0 most-positive-fixnum)
floating-point-overflow))
(assert (raises-error? (scale-float 1.0d0 (1+ most-positive-fixnum))
floating-point-overflow)))

9
tests/foreign.test.sh
View file

@ -30,8 +30,13 @@ build_so() {
if [ $(uname -p) = x86_64 ]; then
CFLAGS="$CFLAGS -fPIC"
fi
if [ $(uname) = Darwin ]; then
SO_FLAGS="-bundle"
else
SO_FLAGS="-shared"
fi
cc -c $1.c -o $1.o $CFLAGS
ld -shared -o $1.so $1.o
ld $SO_FLAGS -o $1.so $1.o
}
echo 'int summish(int x, int y) { return 1 + x + y; }' > $testfilestem.c
@ -93,7 +98,7 @@ cat > $testfilestem.def.lisp <<EOF
(lambda (condition hook)
(print (list :debugger-hook condition))
(let ((cont (find-restart 'continue condition)))
(when cont
(when cont
(invoke-restart cont)))
(print :fell-through)
(invoke-debugger condition)))

7
tests/print.impure.lisp
View file

@ -274,6 +274,13 @@
(timeout ()
(print 'timeout!)))
;;; bug 371: bignum print/read inconsistency
(defvar *bug-371* -7043009959286724629649270926654940933664689003233793014518979272497911394287216967075767325693021717277238746020477538876750544587281879084559996466844417586093291189295867052594478662802691926547232838591510540917276694295393715934079679531035912244103731582711556740654671309980075069010778644542022/670550434139267031632063192770201289106737062379324644110801846820471752716238484923370056920388400273070254958650831435834503195629325418985020030706879602898158806736813101434594805676212779217311897830937606064579213895527844045511878668289820732425014254579493444623868748969110751636786165152601)
(let ((*print-base* 5)
(*read-base* 5)
(*print-radix* nil))
(assert (= *bug-371* (read-from-string (prin1-to-string *bug-371*)))))
;;; a spot of random-testing for rational printing
(defvar *seed-state* (make-random-state))
(print *seed-state*) ; so that we can reproduce errors

14
tests/smoke.impure.lisp
View file

@ -31,13 +31,15 @@
(assert (typep (in-package :cl-user) 'package))
;;; PROFILE should run without obvious breakage
(defun profiled-fun ()
(random 1d0))
(profile profiled-fun)
(loop repeat 100000 do (profiled-fun))
(report)
#-darwin
(progn
(defun profiled-fun ()
(random 1d0))
(profile profiled-fun)
(loop repeat 100000 do (profiled-fun))
(report))
;;; DEFCONSTANT should behave as the documentation specifies,
;;; Defconstant should behave as the documentation specifies,
;;; including documented condition type.
(defun oidentity (x) x)
(defconstant +const+ 1)

2
version.lisp-expr
View file

@ -17,4 +17,4 @@
;;; checkins which aren't released. (And occasionally for internal
;;; versions, especially for internal versions off the main CVS
;;; branch, it gets hairier, e.g. "0.pre7.14.flaky4.13".)
"0.8.19.25"
"0.8.19.26"