X-Git-Url: http://repo.macrolet.net/gitweb/?a=blobdiff_plain;f=src%2Fcode%2Fnumbers.lisp;h=16929b1c2b1642a6b09106e585e9451b49fb0e58;hb=7c5138fcbdb302abc563a2060493f2f0304ae902;hp=7a644b38833fa6c5d6ecdab41d5954e4c9e6fc72;hpb=43980afbf2f02ff68b3cfb62be9051fabe164de0;p=sbcl.git

diff --git a/src/code/numbers.lisp b/src/code/numbers.lisp
index 7a644b3..16929b1 100644
--- a/src/code/numbers.lisp
+++ b/src/code/numbers.lisp
@@ -1161,6 +1161,18 @@ the first."
   (let ((mask (ash (ldb (byte size 0) -1) posn)))
     (logior (logand newbyte mask)
 	    (logand integer (lognot mask)))))
+
+(defun sb!c::mask-signed-field (size integer)
+  #!+sb-doc
+  "Extract SIZE lower bits from INTEGER, considering them as a
+2-complement SIZE-bits representation of a signed integer."
+  (cond ((zerop size)
+         0)
+        ((logbitp (1- size) integer)
+         (dpb integer (byte size 0) -1))
+        (t
+         (ldb (byte size 0) integer))))
+
 
 ;;;; BOOLE
 
@@ -1236,22 +1248,22 @@ the first."
 (defun boole (op integer1 integer2)
   #!+sb-doc
   "Bit-wise boolean function on two integers. Function chosen by OP:
-	0	BOOLE-CLR
-	1	BOOLE-SET
-	2	BOOLE-1
-  	3	BOOLE-2
-	4	BOOLE-C1
-	5	BOOLE-C2
-	6	BOOLE-AND
-	7	BOOLE-IOR
- 	8	BOOLE-XOR
-	9	BOOLE-EQV
-	10	BOOLE-NAND
-	11	BOOLE-NOR
-	12	BOOLE-ANDC1
-	13	BOOLE-ANDC2
-	14	BOOLE-ORC1
-	15	BOOLE-ORC2"
+        0       BOOLE-CLR
+        1       BOOLE-SET
+        2       BOOLE-1
+        3       BOOLE-2
+        4       BOOLE-C1
+        5       BOOLE-C2
+        6       BOOLE-AND
+        7       BOOLE-IOR
+        8       BOOLE-XOR
+        9       BOOLE-EQV
+        10      BOOLE-NAND
+        11      BOOLE-NOR
+        12      BOOLE-ANDC1
+        13      BOOLE-ANDC2
+        14      BOOLE-ORC1
+        15      BOOLE-ORC2"
   (case op
     (0 (boole 0 integer1 integer2))
     (1 (boole 1 integer1 integer2))
@@ -1404,7 +1416,7 @@ the first."
                          (bignum (logand x ,pattern)))))
                 (,name ,@(loop for arg in lambda-list
                                collect `(prepare-argument ,arg)))))))
-    (loop for infos being each hash-value of sb!c::*modular-funs*
+    (loop for infos being each hash-value of (sb!c::modular-class-funs sb!c::*unsigned-modular-class*)
           ;; FIXME: We need to process only "toplevel" functions
           when (listp infos)
           do (loop for info in infos
@@ -1415,6 +1427,28 @@ the first."
                    do (forms (definition name lambda-list width pattern)))))
   `(progn ,@(forms)))
 
+#.
+(collect ((forms))
+  (flet ((definition (name lambda-list width)
+           `(defun ,name ,lambda-list
+              (flet ((prepare-argument (x)
+                       (declare (integer x))
+                       (etypecase x
+                         ((signed-byte ,width) x)
+                         (fixnum (sb!c::mask-signed-field ,width x))
+                         (bignum (sb!c::mask-signed-field ,width x)))))
+                (,name ,@(loop for arg in lambda-list
+                               collect `(prepare-argument ,arg)))))))
+    (loop for infos being each hash-value of (sb!c::modular-class-funs sb!c::*signed-modular-class*)
+          ;; FIXME: We need to process only "toplevel" functions
+          when (listp infos)
+          do (loop for info in infos
+                   for name = (sb!c::modular-fun-info-name info)
+                   and width = (sb!c::modular-fun-info-width info)
+                   and lambda-list = (sb!c::modular-fun-info-lambda-list info)
+                   do (forms (definition name lambda-list width)))))
+  `(progn ,@(forms)))
+
 ;;; KLUDGE: these out-of-line definitions can't use the modular
 ;;; arithmetic, as that is only (currently) defined for constant
 ;;; shifts.  See also the comment in (LOGAND OPTIMIZER) for more
@@ -1432,3 +1466,9 @@ the first."
     (fixnum (ldb (byte 64 0) (ash (logand integer #xffffffffffffffff) amount)))
     (bignum (ldb (byte 64 0)
 		 (ash (logand integer #xffffffffffffffff) amount)))))
+
+#!+x86
+(defun sb!vm::ash-left-smod30 (integer amount)
+  (etypecase integer
+    ((signed-byte 30) (sb!c::mask-signed-field 30 (ash integer amount)))
+    (integer (sb!c::mask-signed-field 30 (ash (sb!c::mask-signed-field 30 integer) amount)))))