[Sbcl-commits] CVS: sbcl/src/code defstruct.lisp,1.47,1.48 float.lisp,1.16,1.17 seq.lisp,1.41,1.42 sort.lisp,1.12,1.13

[Christophe R. <cr...@us...>]

Update of /cvsroot/sbcl/sbcl/src/code
In directory sc8-pr-cvs1:/tmp/cvs-serv6607/src/code

Modified Files:
	defstruct.lisp float.lisp seq.lisp sort.lisp 
Log Message:
0.7.10.8:
	Staging-post on the way to working INLINE/MACROLET
	... implement previously (MACROLET ((DEF ...)) (DEF ...)) INLINE
		functions as defined by global !DEF macros
	... don't touch SORT-VECTOR, as it is complicated
	... implement a BUG 117 bogowarning workaround in
		code/defstruct.lisp
	The plan from here is to move FIND and friends into the realm of
	SOURCE-TRANSFORMS, so that the cross-compiler is born knowing how to
	compile FIND; a similar solution is likely for SORT-VECTOR.  Then
	defensive code can be written around a version of
	MAYBE-INLINE-SYNTACTIC-CLOSURE (as per CSR sbcl-devel 2002-07-02 "BUG
	156 and INLINE FIND"), and voilà! working INLINE.


Index: defstruct.lisp
===================================================================
RCS file: /cvsroot/sbcl/sbcl/src/code/defstruct.lisp,v
retrieving revision 1.47
retrieving revision 1.48
diff -u -d -r1.47 -r1.48
--- defstruct.lisp	24 Oct 2002 13:23:25 -0000	1.47
+++ defstruct.lisp	2 Dec 2002 16:59:10 -0000	1.48
@@ -1523,8 +1523,12 @@
 			 (let ((dsd (find (symbol-name slot-name) dd-slots
 					  :key #'dsd-%name
 					  :test #'string=)))
+			   ;; KLUDGE: bug 117 bogowarning.  Neither
+			   ;; DECLAREing the type nor TRULY-THE cut
+			   ;; the mustard -- it still gives warnings.
+			   (enforce-type dsd defstruct-slot-description)
 			   `(setf (,(dsd-accessor-name dsd) ,object-gensym)
-				  ,slot-name)))
+			          ,slot-name)))
 		       slot-names)
 	     ,object-gensym))
 			      

Index: float.lisp
===================================================================
RCS file: /cvsroot/sbcl/sbcl/src/code/float.lisp,v
retrieving revision 1.16
retrieving revision 1.17
diff -u -d -r1.16 -r1.17
--- float.lisp	21 Oct 2002 05:37:46 -0000	1.16
+++ float.lisp	2 Dec 2002 16:59:11 -0000	1.17
@@ -196,59 +196,60 @@
      (and (zerop (ldb sb!vm:long-float-exponent-byte (long-float-exp-bits x)))
 	  (not (zerop x))))))
 
-(macrolet ((def (name doc single double #!+(and long-float x86) long)
-	     `(defun ,name (x)
-		,doc
-		(number-dispatch ((x float))
-		  ((single-float)
-		   (let ((bits (single-float-bits x)))
-		     (and (> (ldb sb!vm:single-float-exponent-byte bits)
-			     sb!vm:single-float-normal-exponent-max)
-			  ,single)))
-		  ((double-float)
-		   (let ((hi (double-float-high-bits x))
-			 (lo (double-float-low-bits x)))
-		     (declare (ignorable lo))
-		     (and (> (ldb sb!vm:double-float-exponent-byte hi)
-			     sb!vm:double-float-normal-exponent-max)
-			  ,double)))
-		  #!+(and long-float x86)
-		  ((long-float)
-		   (let ((exp (long-float-exp-bits x))
-			 (hi (long-float-high-bits x))
-			 (lo (long-float-low-bits x)))
-		     (declare (ignorable lo))
-		     (and (> (ldb sb!vm:long-float-exponent-byte exp)
-			     sb!vm:long-float-normal-exponent-max)
-			  ,long)))))))
+(defmacro !define-float-dispatching-function
+    (name doc single double #!+(and long-float x86) long)
+  `(defun ,name (x)
+    ,doc
+    (number-dispatch ((x float))
+     ((single-float)
+      (let ((bits (single-float-bits x)))
+	(and (> (ldb sb!vm:single-float-exponent-byte bits)
+		sb!vm:single-float-normal-exponent-max)
+	     ,single)))
+     ((double-float)
+      (let ((hi (double-float-high-bits x))
+	    (lo (double-float-low-bits x)))
+	(declare (ignorable lo))
+	(and (> (ldb sb!vm:double-float-exponent-byte hi)
+		sb!vm:double-float-normal-exponent-max)
+	     ,double)))
+     #!+(and long-float x86)
+     ((long-float)
+      (let ((exp (long-float-exp-bits x))
+	    (hi (long-float-high-bits x))
+	    (lo (long-float-low-bits x)))
+	(declare (ignorable lo))
+	(and (> (ldb sb!vm:long-float-exponent-byte exp)
+		sb!vm:long-float-normal-exponent-max)
+	     ,long))))))
 
-  (def float-infinity-p
-    "Return true if the float X is an infinity (+ or -)."
-    (zerop (ldb sb!vm:single-float-significand-byte bits))
-    (and (zerop (ldb sb!vm:double-float-significand-byte hi))
-	 (zerop lo))
-    #!+(and long-float x86)
-    (and (zerop (ldb sb!vm:long-float-significand-byte hi))
-	 (zerop lo)))
+(!define-float-dispatching-function float-infinity-p
+  "Return true if the float X is an infinity (+ or -)."
+  (zerop (ldb sb!vm:single-float-significand-byte bits))
+  (and (zerop (ldb sb!vm:double-float-significand-byte hi))
+       (zerop lo))
+  #!+(and long-float x86)
+  (and (zerop (ldb sb!vm:long-float-significand-byte hi))
+       (zerop lo)))
 
-  (def float-nan-p
-    "Return true if the float X is a NaN (Not a Number)."
-    (not (zerop (ldb sb!vm:single-float-significand-byte bits)))
-    (or (not (zerop (ldb sb!vm:double-float-significand-byte hi)))
-	(not (zerop lo)))
-    #!+(and long-float x86)
-    (or (not (zerop (ldb sb!vm:long-float-significand-byte hi)))
-	(not (zerop lo))))
+(!define-float-dispatching-function float-nan-p
+  "Return true if the float X is a NaN (Not a Number)."
+  (not (zerop (ldb sb!vm:single-float-significand-byte bits)))
+  (or (not (zerop (ldb sb!vm:double-float-significand-byte hi)))
+      (not (zerop lo)))
+  #!+(and long-float x86)
+  (or (not (zerop (ldb sb!vm:long-float-significand-byte hi)))
+      (not (zerop lo))))
 
-  (def float-trapping-nan-p
-    "Return true if the float X is a trapping NaN (Not a Number)."
-    (zerop (logand (ldb sb!vm:single-float-significand-byte bits)
-		   sb!vm:single-float-trapping-nan-bit))
-    (zerop (logand (ldb sb!vm:double-float-significand-byte hi)
-		   sb!vm:double-float-trapping-nan-bit))
-    #!+(and long-float x86)
-    (zerop (logand (ldb sb!vm:long-float-significand-byte hi)
-		   sb!vm:long-float-trapping-nan-bit))))
+(!define-float-dispatching-function float-trapping-nan-p
+  "Return true if the float X is a trapping NaN (Not a Number)."
+  (zerop (logand (ldb sb!vm:single-float-significand-byte bits)
+		 sb!vm:single-float-trapping-nan-bit))
+  (zerop (logand (ldb sb!vm:double-float-significand-byte hi)
+		 sb!vm:double-float-trapping-nan-bit))
+  #!+(and long-float x86)
+  (zerop (logand (ldb sb!vm:long-float-significand-byte hi)
+		 sb!vm:long-float-trapping-nan-bit)))
 
 ;;; If denormalized, use a subfunction from INTEGER-DECODE-FLOAT to find the
 ;;; actual exponent (and hence how denormalized it is), otherwise we just

Index: seq.lisp
===================================================================
RCS file: /cvsroot/sbcl/sbcl/src/code/seq.lisp,v
retrieving revision 1.41
retrieving revision 1.42
diff -u -d -r1.41 -r1.42
--- seq.lisp	13 Nov 2002 04:07:58 -0000	1.41
+++ seq.lisp	2 Dec 2002 16:59:11 -0000	1.42
@@ -1964,46 +1964,36 @@
 ;;; the user interface to FIND and POSITION: Get all our ducks in a
 ;;; row, then call %FIND-POSITION.
 (declaim (inline find position))
-(macrolet ((def-find-position (fun-name values-index)
-	     `(defun ,fun-name (item
-				sequence
-				&key
-				from-end
-				(start 0)
-				end
-				key
-				test
-				test-not)
-		(nth-value
-		 ,values-index
-		 (%find-position item
-				 sequence
-				 from-end
-				 start
-				 end
-				 (effective-find-position-key key)
-				 (effective-find-position-test test
-							       test-not))))))
-  (def-find-position find 0)
-  (def-find-position position 1))
+(defmacro !def-find-position (fun-name values-index)
+  `(defun ,fun-name (item sequence &key
+		     from-end (start 0) end
+		     key test test-not)
+    (nth-value
+     ,values-index
+     (%find-position item sequence
+                     from-end start
+                     end (effective-find-position-key key)
+                     (effective-find-position-test test test-not)))))
+(!def-find-position find 0)
+(!def-find-position position 1)
 
 ;;; the user interface to FIND-IF and POSITION-IF, entirely analogous
 ;;; to the interface to FIND and POSITION
 (declaim (inline find-if position-if))
-(macrolet ((def-find-position-if (fun-name values-index)
-	     `(defun ,fun-name (predicate sequence
-				&key from-end (start 0) end key)
-		(nth-value
-		 ,values-index
-		 (%find-position-if (%coerce-callable-to-fun predicate)
-				    sequence
-				    from-end
-				    start
-				    end
-				    (effective-find-position-key key))))))
+(defmacro !def-find-position-if (fun-name values-index)
+  `(defun ,fun-name (predicate sequence
+		     &key from-end (start 0) end key)
+    (nth-value
+     ,values-index
+     (%find-position-if (%coerce-callable-to-fun predicate)
+                        sequence
+                        from-end
+                        start
+                        end
+                        (effective-find-position-key key)))))
 
-  (def-find-position-if find-if 0)
-  (def-find-position-if position-if 1))
+(!def-find-position-if find-if 0)
+(!def-find-position-if position-if 1)
 
 ;;; the deprecated functions FIND-IF-NOT and POSITION-IF-NOT. We
 ;;; didn't bother to worry about optimizing them, except note that on
@@ -2026,20 +2016,20 @@
 ;;; FIXME: Maybe remove uses of these deprecated functions (and
 ;;; definitely of :TEST-NOT) within the implementation of SBCL.
 (declaim (inline find-if-not position-if-not))
-(macrolet ((def-find-position-if-not (fun-name values-index)
-	     `(defun ,fun-name (predicate sequence
-				&key from-end (start 0) end key)
-		(nth-value
-		 ,values-index
-		 (%find-position-if-not (%coerce-callable-to-fun predicate)
-				        sequence
-				        from-end
-				        start
-				        end
-				        (effective-find-position-key key))))))
+(defmacro !def-find-position-if-not (fun-name values-index)
+  `(defun ,fun-name (predicate sequence
+		     &key from-end (start 0) end key)
+    (nth-value
+     ,values-index
+     (%find-position-if-not (%coerce-callable-to-fun predicate)
+                            sequence
+                            from-end
+                            start
+                            end
+                            (effective-find-position-key key)))))
 
-  (def-find-position-if-not find-if-not 0)
-  (def-find-position-if-not position-if-not 1))
+(!def-find-position-if-not find-if-not 0)
+(!def-find-position-if-not position-if-not 1)
 
 
 ;;;; COUNT-IF, COUNT-IF-NOT, and COUNT

Index: sort.lisp
===================================================================
RCS file: /cvsroot/sbcl/sbcl/src/code/sort.lisp,v
retrieving revision 1.12
retrieving revision 1.13
diff -u -d -r1.12 -r1.13
--- sort.lisp	18 Oct 2002 14:06:53 -0000	1.12
+++ sort.lisp	2 Dec 2002 16:59:12 -0000	1.13
@@ -72,7 +72,7 @@
 		   (rotatef (%elt 1) (%elt current-heap-size))
 		   (decf current-heap-size)
 		   (%heapify 1))))))
-
+  ;; FIXME: Oh dear.
   (declaim (inline sort-vector))
   (defun sort-vector (vector start end predicate key)
     (declare (type vector vector))