Changeset 14304

Timestamp:

Sep 28, 2010, 9:45:53 AM (14 years ago)

Author:

R. Matthew Emerson

Message:

New function acode-xxx-form-p. Use it in functions
acode-integer-form-p, acode-integer-constant-p, and
acode-real-constant-p.

File:

• trunk/source/compiler/nx0.lisp (modified) (2 diffs)

trunk/source/compiler/nx0.lisp

@@ -571 +571 @@
       (cadr x))))
 
+(defun acode-xxx-form-p (x fixnum-supertype)
+  (or (acode-fixnum-form-p x)
+      (progn
+        (setq x (acode-unwrapped-form-value x))
+        (if (acode-p x)
+          (if (and (eq (acode-operator x) (%nx1-operator immediate))
+                   (typep (cadr x) fixnum-supertype))
+            (cadr x))))))
+
+(defun acode-integer-form-p (x)
+  (acode-xxx-form-p x 'integer))
+
 (defun acode-integer-constant-p (x bits)
-  (let* ((int (or (acode-fixnum-form-p x)
-                  (progn
-                    (setq x (acode-unwrapped-form x))
-                    (if (acode-p x)
-                      (if (and (eq (acode-operator x) (%nx1-operator immediate))
-                               (typep (cadr x) 'integer))
-                        (cadr x)))))))
+  (let ((int (acode-integer-form-p x)))
     (and int
          (or
@@ -585 +591 @@
          int)))
 
-(defun acode-natural-constant-p (x)
-  (let* ((int (or (acode-fixnum-form-p x)
-                  (progn
-                    (setq x (acode-unwrapped-form x))
-                    (if (acode-p x)
-                      (if (and (eq (acode-operator x) (%nx1-operator immediate))
-                               (typep (cadr x) 'integer))
-                        (cadr x)))))))
-    (and int
-         (target-word-size-case
-          (32 (typep int '(unsigned-byte 32)))
-          (64 (typep int '(unsigned-byte 64))))
-         int)))
-
-
-
 (defun acode-real-constant-p (x)
-  (or (acode-fixnum-form-p x)
-      (progn
-        (setq x (acode-unwrapped-form x))
-        (if (acode-p x)
-          (if (and (eq (acode-operator x) (%nx1-operator immediate))
-                   (typep (cadr x) 'real))
-            (cadr x))))))
-
-
+  (acode-xxx-form-p x 'real))
 
 (defun nx-lookup-target-uvector-subtag (name)