[Sbcl-commits] CVS: sbcl/src/code condition.lisp,1.57,1.58 foreign-load.lisp,1.7,1.8 foreign.lisp,1.29,1.30 interr.lisp,1.30,1.31 linkage-table.lisp,1.3,1.4 print.lisp,1.59,1.60

[Nikodemus S. <de...@us...>]

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)