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

[Frode Vatvedt Fjeld]

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

Modified Files:
	arithmetic-macros.lisp 
Log Message:
Rearranged some code to have movitz build cleanly.

Date: Wed Aug 24 09:31:34 2005
Author: ffjeld

Index: movitz/losp/muerte/arithmetic-macros.lisp
diff -u movitz/losp/muerte/arithmetic-macros.lisp:1.10 movitz/losp/muerte/arithmetic-macros.lisp:1.11
--- movitz/losp/muerte/arithmetic-macros.lisp:1.10	Sat Aug 20 22:23:34 2005
+++ movitz/losp/muerte/arithmetic-macros.lisp	Wed Aug 24 09:31:34 2005
@@ -10,7 +10,7 @@
 ;;;; Author:        Frode Vatvedt Fjeld <frodef at acm.org>
 ;;;; Created at:    Sat Jul 17 13:42:46 2004
 ;;;;                
-;;;; $Id: arithmetic-macros.lisp,v 1.10 2005/08/20 20:23:34 ffjeld Exp $
+;;;; $Id: arithmetic-macros.lisp,v 1.11 2005/08/24 07:31:34 ffjeld Exp $
 ;;;;                
 ;;;;------------------------------------------------------------------
 
@@ -20,6 +20,8 @@
 
 (in-package muerte)
 
+;;;
+
 (defmacro number-double-dispatch ((x y) &rest clauses)
   `(let ((x ,x) (y ,y))
      (cond ,@(loop for ((x-type y-type) . then-body) in clauses
@@ -499,3 +501,115 @@
 (define-compiler-macro %ratio-denominator (x)
   `(memref ,x (movitz-type-slot-offset 'movitz-ratio 'denominator)))
 
+;;;
+
+(defmacro define-number-relational (name 2op-name condition &key (defun-p t) 3op-name)
+  `(progn
+     ,(when condition
+	`(define-compiler-macro ,2op-name (n1 n2 &environment env)
+	   (cond
+	    ((and (movitz:movitz-constantp n1 env)
+		  (movitz:movitz-constantp n2 env))
+	     (list ',2op-name (movitz:movitz-eval n1 env) (movitz:movitz-eval n2 env)))
+	    ((movitz:movitz-constantp n1 env)
+	     (let ((n1 (movitz::movitz-eval n1 env)))
+	       (check-type n1 number)
+	       (if (typep n1 '(signed-byte 30))
+		   `(with-inline-assembly (:returns ,,condition :side-effects nil)
+		      (:compile-two-forms (:eax :ebx) ,n1 ,n2)
+		      (:call-global-pf fast-compare-fixnum-real))
+		 `(with-inline-assembly (:returns ,,condition :side-effects nil)
+		    (:compile-two-forms (:eax :ebx) ,n1 ,n2)
+		    (:call-global-pf fast-compare-two-reals)))))
+	    ((movitz:movitz-constantp n2 env)
+	     (let ((n2 (movitz:movitz-eval n2 env)))
+	       (check-type n2 number)
+	       (if (typep n2 '(signed-byte 30))
+		   `(with-inline-assembly (:returns ,,condition :side-effects nil)
+		      (:compile-two-forms (:eax :ebx) ,n1 ,n2)
+		      (:call-global-pf fast-compare-real-fixnum))
+		 `(with-inline-assembly (:returns ,,condition :side-effects nil)
+		    (:compile-two-forms (:eax :ebx) ,n1 ,n2)
+		    (:call-global-pf fast-compare-two-reals)))))
+	    (t `(with-inline-assembly (:returns ,,condition :side-effects nil)
+		  (:compile-two-forms (:eax :ebx) ,n1 ,n2)
+		  (:call-global-pf fast-compare-two-reals))))))
+
+     (defun ,2op-name (n1 n2)
+       (,2op-name n1 n2))
+
+     (define-compiler-macro ,name (&whole form number &rest more-numbers)
+       (case (length more-numbers)
+	 (0 `(progn ,number t))
+	 (1 `(,',2op-name ,number ,(first more-numbers)))
+	 ,@(when 3op-name
+	     `((2 `(,',3op-name ,number ,(first more-numbers) ,(second more-numbers)))))
+	 (t #+ignore (when (= 2 (length more-numbers))
+		       (warn "3op: ~S" form))
+	  `(and (,',2op-name ,number ,(first more-numbers))
+		  (,',name , at more-numbers)))))
+
+     ,(when defun-p
+	`(defun ,name (number &rest more-numbers)
+	   (declare (dynamic-extent more-numbers))
+	   (cond
+	    ((null more-numbers)
+	     (check-type number fixnum)
+	     t)
+	    ((not (cdr more-numbers))
+	     (,2op-name number (first more-numbers)))
+	    (t (and (,2op-name number (first more-numbers))
+		    (do ((p more-numbers (cdr p)))
+			((not (cdr p)) t)
+		      (unless (,2op-name (car p) (cadr p))
+			(return nil))))))))))
+
+(define-number-relational >= >=%2op :boolean-greater-equal)
+(define-number-relational > >%2op :boolean-greater)
+(define-number-relational < <%2op :boolean-less)
+(define-number-relational <= <=%2op :boolean-less-equal :3op-name <=%3op)
+
+;;; Types
+
+(define-typep integer (x &optional (min '*) (max '*))
+  (and (typep x 'integer)
+       (or (eq min '*) (<= min x))
+       (or (eq max '*) (<= x max))))
+
+(deftype unsigned-byte (&optional (size '*))
+  (cond
+   ((eq size '*)
+    '(integer 0))
+   ((typep size '(integer 1 *))
+    ;; The funcall is a hack not to invoke compiler machinery
+    ;; that depends on the unsigned-byte type being defined.
+    (list 'integer 0 (funcall '- (ash 1 size) 1)))
+   (t (error "Illegal size for unsigned-byte."))))
+
+(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."))))
+
+(define-typep rational (x &optional (lower-limit '*) (upper-limit '*))
+  (and (typep x 'rational)
+       (or (eq lower-limit '*)
+	   (<= lower-limit x))
+       (or (eq upper-limit '*)
+	   (<= x upper-limit))))
+
+(deftype real (&optional (lower-limit '*) (upper-limit '*))
+  `(or (integer ,lower-limit ,upper-limit)
+       (rational ,lower-limit ,upper-limit)))
+  
+
+(define-simple-typep (bit bitp) (x)
+  (or (eq x 0) (eq x 1)))
+
+(deftype index (&optional (step 1))
+  `(integer 0 ,(- #x1fffffff step)))