[movitz-cvs] CVS update: movitz/losp/muerte/integers.lisp

[Frode Vatvedt Fjeld]

Update of /project/movitz/cvsroot/movitz/losp/muerte
In directory common-lisp.net:/tmp/cvs-serv4087

Modified Files:
	integers.lisp 
Log Message:
Added a bad expt. And a decent integer-length.

Date: Wed Jun  9 15:52:12 2004
Author: ffjeld

Index: movitz/losp/muerte/integers.lisp
diff -u movitz/losp/muerte/integers.lisp:1.30 movitz/losp/muerte/integers.lisp:1.31
--- movitz/losp/muerte/integers.lisp:1.30	Wed Jun  9 13:33:31 2004
+++ movitz/losp/muerte/integers.lisp	Wed Jun  9 15:52:12 2004
@@ -9,7 +9,7 @@
 ;;;; Created at:    Wed Nov  8 18:44:57 2000
 ;;;; Distribution:  See the accompanying file COPYING.
 ;;;;                
-;;;; $Id: integers.lisp,v 1.30 2004/06/09 20:33:31 ffjeld Exp $
+;;;; $Id: integers.lisp,v 1.31 2004/06/09 22:52:12 ffjeld Exp $
 ;;;;                
 ;;;;------------------------------------------------------------------
 
@@ -788,6 +788,34 @@
       (when (< x min)
 	(setq min x)))))
 
+;;; Types
+
+(define-typep integer (x &optional (min '*) (max '*))
+  (and (typep x 'integer)
+       (or (eq min '*) (<= min x))
+       (or (eq max '*) (<= x max))))
+
+(deftype signed-byte (&optional (size '*))
+  (cond
+   ((eq size '*)
+    'integer)
+   ((typep size '(integer 1 *))
+    (list 'integer
+	  (- (ash 1 (1- size)))
+	  (1- (ash 1 (1- size)))))
+   (t (error "Illegal size for signed-byte."))))
+
+(deftype unsigned-byte (&optional (size '*))
+  (cond
+   ((eq size '*)
+    '(integer 0))
+   ((typep size '(integer 1 *))
+    (list 'integer 0 (1- (ash 1 size))))
+   (t (error "Illegal size for unsigned-byte."))))
+
+(define-simple-typep (bit bitp) (x)
+  (or (eq x 0) (eq x 1)))
+
 ;; shift 
 
 (define-compiler-macro ash (&whole form integer count &environment env)
@@ -857,6 +885,43 @@
       (:andb #.(cl:logxor #xff movitz::+movitz-fixnum-zmask+) :al)))
    (t (if (= 0 integer) 0 (error "Illegal ash count: ~D" count)))))
 
+(defun integer-length (integer)
+  "=> number-of-bits"
+  (etypecase integer
+    (fixnum
+     (macrolet
+	 ((do-it ()
+	    `(with-inline-assembly (:returns :eax)
+	       (:xorl :eax :eax)
+	       (:compile-form (:result-mode :ecx) integer)
+	       (:testl :ecx :ecx)
+	       (:jns 'not-negative)
+	       (:notl :ecx)
+	      not-negative
+	       (:bsrl :ecx :ecx)
+	       (:jz 'zero)
+	       (:leal ((:ecx ,movitz:+movitz-fixnum-factor+)
+		       ,(* -1 movitz:+movitz-fixnum-factor+))
+		      :eax)
+	      zero)))
+       (do-it)))
+    (positive-bignum
+     (macrolet
+	 ((do-it ()
+	    `(with-inline-assembly (:returns :eax)
+	       (:compile-form (:result-mode :ebx) integer)
+	       (:movzxw (:ebx ,(bt:slot-offset 'movitz:movitz-bignum 'movitz::length))
+			:ecx)
+	       (:leal ((:ecx ,movitz:+movitz-fixnum-factor+) ,(* -1 movitz:+movitz-fixnum-factor+))
+		      :eax)		; bigits-1
+	       (:bsrl (:ebx (:ecx 4) ,(+ -4 (bt:slot-offset 'movitz:movitz-bignum 'movitz::bigit0)))
+		      :ecx)
+	       (:shll 5 :eax)		; bits = bigits*32 + (bit-index+1)
+	       (:leal ((:ecx ,movitz:+movitz-fixnum-factor+) :eax
+							     ,movitz:+movitz-fixnum-factor+)
+		      :eax))))
+       (do-it)))))
+
 ;;; Multiplication
 
 (define-compiler-macro * (&whole form &rest operands &environment env)
@@ -1910,34 +1975,6 @@
   (logior (mask-field bytespec newbyte)
 	  (logandc2 integer (mask-field bytespec -1))))
 
-;;; Types
-
-(define-typep integer (x &optional (min '*) (max '*))
-  (and (typep x 'integer)
-       (or (eq min '*) (<= min x))
-       (or (eq max '*) (<= x max))))
-
-(deftype signed-byte (&optional (size '*))
-  (cond
-   ((eq size '*)
-    'integer)
-   ((typep size '(integer 1 *))
-    (list 'integer
-	  (- (ash 1 (1- size)))
-	  (1- (ash 1 (1- size)))))
-   (t (error "Illegal size for signed-byte."))))
-
-(deftype unsigned-byte (&optional (size '*))
-  (cond
-   ((eq size '*)
-    '(integer 0))
-   ((typep size '(integer 1 *))
-    (list 'integer 0 (1- (ash 1 size))))
-   (t (error "Illegal size for unsigned-byte."))))
-
-(define-simple-typep (bit bitp) (x)
-  (or (eq x 0) (eq x 1)))
-
 ;;;
 
 (defun plus-if (x y)
@@ -1996,4 +2033,19 @@
   "=> natural-root"
   (check-type natural (integer 0 *))
   (do ((i 0 (1+ i)))
-      ((> (* i i) natural) (1- i))))
\ No newline at end of file
+      ((> (* i i) natural) (1- i))))
+
+(define-compiler-macro expt (&whole form base-number power-number &environment env)
+  (if (not (and (movitz:movitz-constantp base-number env)
+		(movitz:movitz-constantp power-number env)))
+      form
+    (expt (movitz:movitz-eval base-number env)
+	  (movitz:movitz-eval power-number env))))
+    
+
+(defun expt (base-number power-number)
+  "Take base-number to the power-number."
+  (do ((i 0 (1+ i))
+       (r 1 (* r base-number)))
+      ((>= i power-number) r)))
+