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