Update of /cvsroot/sbcl/sbcl/src/code
In directory sc8-pr-cvs1.sourceforge.net:/tmp/cvs-serv4244/src/code
Modified Files:
condition.lisp foreign-load.lisp foreign.lisp interr.lisp
linkage-table.lisp print.lisp
Log Message:
message
Index: condition.lisp
===================================================================
RCS file: /cvsroot/sbcl/sbcl/src/code/condition.lisp,v
retrieving revision 1.57
retrieving revision 1.58
diff -u -d -r1.57 -r1.58
--- condition.lisp 11 Feb 2005 21:49:53 -0000 1.57
+++ condition.lisp 13 Feb 2005 14:27:07 -0000 1.58
@@ -956,11 +956,20 @@
) ; 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
;;;;
Index: foreign-load.lisp
===================================================================
RCS file: /cvsroot/sbcl/sbcl/src/code/foreign-load.lisp,v
retrieving revision 1.7
retrieving revision 1.8
diff -u -d -r1.7 -r1.8
--- foreign-load.lisp 20 Dec 2004 13:10:39 -0000 1.7
+++ foreign-load.lisp 13 Feb 2005 14:27:08 -0000 1.8
@@ -141,7 +141,7 @@
(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 @@
(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)
Index: foreign.lisp
===================================================================
RCS file: /cvsroot/sbcl/sbcl/src/code/foreign.lisp,v
retrieving revision 1.29
retrieving revision 1.30
diff -u -d -r1.29 -r1.30
--- foreign.lisp 6 Jan 2005 12:47:58 -0000 1.29
+++ foreign.lisp 13 Feb 2005 14:27:08 -0000 1.30
@@ -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))))
Index: interr.lisp
===================================================================
RCS file: /cvsroot/sbcl/sbcl/src/code/interr.lisp,v
retrieving revision 1.30
retrieving revision 1.31
diff -u -d -r1.30 -r1.31
--- interr.lisp 3 Dec 2004 17:50:10 -0000 1.30
+++ interr.lisp 13 Feb 2005 14:27:08 -0000 1.31
@@ -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))
Index: linkage-table.lisp
===================================================================
RCS file: /cvsroot/sbcl/sbcl/src/code/linkage-table.lisp,v
retrieving revision 1.3
retrieving revision 1.4
diff -u -d -r1.3 -r1.4
--- linkage-table.lisp 3 Dec 2004 17:50:10 -0000 1.3
+++ linkage-table.lisp 13 Feb 2005 14:27:08 -0000 1.4
@@ -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
Index: print.lisp
===================================================================
RCS file: /cvsroot/sbcl/sbcl/src/code/print.lisp,v
retrieving revision 1.59
retrieving revision 1.60
diff -u -d -r1.59 -r1.60
--- print.lisp 28 Jan 2005 16:49:00 -0000 1.59
+++ print.lisp 13 Feb 2005 14:27:08 -0000 1.60
@@ -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)
|