From 3f36a370301434445e1bc0e2635cfdc3db3d9f2c Mon Sep 17 00:00:00 2001
From: wlott <wlott>
Date: Mon, 14 May 1990 01:59:07 +0000
Subject: [PATCH] Added predicates and check-vops for the
 simple-array-unsigned-byte-n and simple-array-mumble-float primitive types.

---
 compiler/generic/vm-fndb.lisp     |  9 ++++--
 compiler/generic/vm-typetran.lisp | 16 +++++++++-
 compiler/mips/type-vops.lisp      | 49 +++++++++++++++++++++++++------
 3 files changed, 61 insertions(+), 13 deletions(-)

diff --git a/compiler/generic/vm-fndb.lisp b/compiler/generic/vm-fndb.lisp
index 9109c3542..cc4568d3c 100644
--- a/compiler/generic/vm-fndb.lisp
+++ b/compiler/generic/vm-fndb.lisp
@@ -7,7 +7,7 @@
 ;;; Scott Fahlman (FAHLMAN@CMUC). 
 ;;; **********************************************************************
 ;;;
-;;; $Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/compiler/generic/vm-fndb.lisp,v 1.5 1990/05/09 06:41:53 wlott Exp $
+;;; $Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/compiler/generic/vm-fndb.lisp,v 1.6 1990/05/14 01:59:03 wlott Exp $
 ;;;
 ;;; This file defines the machine specific function signatures.
 ;;;
@@ -26,8 +26,11 @@
 
 (defknown (fixnump bignump ratiop short-float-p single-float-p double-float-p
 	   long-float-p base-char-p %string-char-p %standard-char-p structurep
-	   array-header-p simple-array-p system-area-pointer-p realp
-	   unsigned-byte-32-p signed-byte-32-p)
+	   array-header-p simple-array-p simple-array-unsigned-byte-2-p
+	   simple-array-unsigned-byte-4-p simple-array-unsigned-byte-8-p
+	   simple-array-unsigned-byte-16-p simple-array-unsigned-byte-32-p
+	   simple-array-single-float-p simple-array-double-float-p
+	   system-area-pointer-p realp unsigned-byte-32-p signed-byte-32-p)
   (t) boolean (movable foldable flushable))
 
 
diff --git a/compiler/generic/vm-typetran.lisp b/compiler/generic/vm-typetran.lisp
index 82b816b32..c88d12c09 100644
--- a/compiler/generic/vm-typetran.lisp
+++ b/compiler/generic/vm-typetran.lisp
@@ -7,7 +7,7 @@
 ;;; Scott Fahlman (FAHLMAN@CMUC). 
 ;;; **********************************************************************
 ;;;
-;;; $Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/compiler/generic/vm-typetran.lisp,v 1.4 1990/05/06 05:31:38 wlott Exp $
+;;; $Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/compiler/generic/vm-typetran.lisp,v 1.5 1990/05/14 01:59:07 wlott Exp $
 ;;;
 ;;; This file contains the implimentation specific type transformation magic.
 ;;; Basically, the various non-standard predicates that can be used in typep
@@ -33,6 +33,20 @@
 (define-type-predicate short-float-p short-float)
 (define-type-predicate single-float-p single-float)
 (define-type-predicate simple-array-p simple-array)
+(define-type-predicate simple-array-unsigned-byte-2-p
+		       (simple-array (unsigned-byte 2) (*)))
+(define-type-predicate simple-array-unsigned-byte-4-p
+		       (simple-array (unsigned-byte 4) (*)))
+(define-type-predicate simple-array-unsigned-byte-8-p
+		       (simple-array (unsigned-byte 8) (*)))
+(define-type-predicate simple-array-unsigned-byte-16-p
+		       (simple-array (unsigned-byte 16) (*)))
+(define-type-predicate simple-array-unsigned-byte-32-p
+		       (simple-array (unsigned-byte 32) (*)))
+(define-type-predicate simple-array-single-float-p
+		       (simple-array single-float (*)))
+(define-type-predicate simple-array-double-float-p
+		       (simple-array double-float (*)))
 (define-type-predicate system-area-pointer-p system-area-pointer)
 (define-type-predicate unsigned-byte-32-p (unsigned-byte 32))
 (define-type-predicate signed-byte-32-p (signed-byte 32))
diff --git a/compiler/mips/type-vops.lisp b/compiler/mips/type-vops.lisp
index d8c5245e0..271544971 100644
--- a/compiler/mips/type-vops.lisp
+++ b/compiler/mips/type-vops.lisp
@@ -7,7 +7,7 @@
 ;;; Scott Fahlman (FAHLMAN@CMUC). 
 ;;; **********************************************************************
 ;;;
-;;; $Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/compiler/mips/type-vops.lisp,v 1.11 1990/05/06 05:27:31 wlott Exp $
+;;; $Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/compiler/mips/type-vops.lisp,v 1.12 1990/05/14 01:58:57 wlott Exp $
 ;;; 
 ;;; This file contains the VM definition of type testing and checking VOPs
 ;;; for the RT.
@@ -53,30 +53,33 @@
 		(define-vop (,pred-name simple-type-predicate)
 		  (:variant ,type-code)
 		  (:translate ,pred-name))
-
-		,@(when check-name
-		    `((define-vop (,check-name check-simple-type)
-			(:variant ,type-code ,error-code))
-		      (primitive-type-vop ,check-name (:check) ,ptype))))))
+		(define-vop (,check-name check-simple-type)
+		  (:variant ,type-code ,error-code))
+		(primitive-type-vop ,check-name (:check) ,ptype))))
 
   ;; ### Want to tweek costs so that checks that do dereferences are
   ;; more expensive.
   ;; 
-  ;; ### May want to add all of the (simple-array <mumble> (*))
-  ;; primitive types.
-  ;;
   (frob functionp check-function function
     vm:function-pointer-type di:object-not-function-error)
 
   (frob listp check-list list
     vm:list-pointer-type di:object-not-list-error)
 
+  #+nil ;; ### Only after we have real structures.
+  (frob structurep check-structure structure
+    vm:structure-pointer-type di:object-not-structure)
+
   (frob bignump check-bigunm bignum
     vm:bignum-type di:object-not-bignum-error)
 
   (frob ratiop check-ratio ratio
     vm:ratio-type di:object-not-ratio-error)
 
+  #+nil ;; ### Need to verify the existance of this predicate.
+  (frob complexp check-complex complex
+    vm:complex-type di:object-not-complex)
+
   (frob single-float-p check-single-float single-float
     vm:single-float-type di:object-not-single-float-error)
 
@@ -92,6 +95,34 @@
   (frob simple-vector-p check-simple-vector simple-vector
     vm:simple-vector-type di:object-not-simple-vector-error)
 
+  (frob simple-array-unsigned-byte-2-p check-simple-array-unsigned-byte-2
+    simple-array-unsigned-byte-2 vm:simple-array-unsigned-byte-2-type
+    di:object-not-simple-array-unsigned-byte-2-error)
+
+  (frob simple-array-unsigned-byte-4-p check-simple-array-unsigned-byte-4
+    simple-array-unsigned-byte-4 vm:simple-array-unsigned-byte-4-type
+    di:object-not-simple-array-unsigned-byte-4-error)
+
+  (frob simple-array-unsigned-byte-8-p check-simple-array-unsigned-byte-8
+    simple-array-unsigned-byte-8 vm:simple-array-unsigned-byte-8-type
+    di:object-not-simple-array-unsigned-byte-8-error)
+
+  (frob simple-array-unsigned-byte-16-p check-simple-array-unsigned-byte-16
+    simple-array-unsigned-byte-16 vm:simple-array-unsigned-byte-16-type
+    di:object-not-simple-array-unsigned-byte-16-error)
+
+  (frob simple-array-unsigned-byte-32-p check-simple-array-unsigned-byte-32
+    simple-array-unsigned-byte-32 vm:simple-array-unsigned-byte-32-type
+    di:object-not-simple-array-unsigned-byte-32-error)
+
+  (frob simple-array-single-float-p check-simple-array-single-float
+    simple-array-single-float vm:simple-array-single-float-type
+    di:object-not-simple-array-single-float-error)
+
+  (frob simple-array-double-float-p check-simple-array-double-float
+    simple-array-double-float vm:simple-array-double-float-type
+    di:object-not-simple-array-double-float-error)
+
   (frob base-char-p check-base-character base-character
     vm:base-character-type di:object-not-base-character-error)
 
-- 
GitLab