Update of /project/movitz/cvsroot/movitz/losp/muerte In directory common-lisp.net:/tmp/cvs-serv5020
Modified Files: integers.lisp Log Message: Rearranged some code to have movitz build cleanly.
Date: Wed Aug 24 09:31:40 2005 Author: ffjeld
Index: movitz/losp/muerte/integers.lisp diff -u movitz/losp/muerte/integers.lisp:1.107 movitz/losp/muerte/integers.lisp:1.108 --- movitz/losp/muerte/integers.lisp:1.107 Fri Aug 12 23:37:42 2005 +++ movitz/losp/muerte/integers.lisp Wed Aug 24 09:31:40 2005 @@ -9,7 +9,7 @@ ;;;; Created at: Wed Nov 8 18:44:57 2000 ;;;; Distribution: See the accompanying file COPYING. ;;;; -;;;; $Id: integers.lisp,v 1.107 2005/08/12 21:37:42 ffjeld Exp $ +;;;; $Id: integers.lisp,v 1.108 2005/08/24 07:31:40 ffjeld Exp $ ;;;; ;;;;------------------------------------------------------------------
@@ -256,71 +256,6 @@ ;;;
-(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 ,@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)
;;; Unsigned
@@ -402,45 +337,6 @@ (defun oddp (x) (compiler-macro-call oddp 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-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)))
;;;