New functions RATIOP, {SINGLE,SHORT,DOUBLE,LONG}-FLOAT-P help avoid consing in TYPEP

parent e0cfa802
...@@ -2323,5 +2323,11 @@ cl_symbols[] = { ...@@ -2323,5 +2323,11 @@ cl_symbols[] = {
{EXT_ "CONSTANTP-INNER", EXT_ORDINARY, si_constantp_inner, -1, OBJNULL}, {EXT_ "CONSTANTP-INNER", EXT_ORDINARY, si_constantp_inner, -1, OBJNULL},
{SYS_ "MAKE-BACKQ-VECTOR", SI_ORDINARY, si_make_backq_vector, 3, OBJNULL}, {SYS_ "MAKE-BACKQ-VECTOR", SI_ORDINARY, si_make_backq_vector, 3, OBJNULL},
{SYS_ "RATIOP", SI_ORDINARY, ECL_NAME(si_ratiop), 1, OBJNULL},
{SYS_ "SHORT-FLOAT-P", SI_ORDINARY, ECL_NAME(si_short_float_p), 1, OBJNULL},
{SYS_ "SINGLE-FLOAT-P", SI_ORDINARY, ECL_NAME(si_single_float_p), 1, OBJNULL},
{SYS_ "DOUBLE-FLOAT-P", SI_ORDINARY, ECL_NAME(si_double_float_p), 1, OBJNULL},
{SYS_ "LONG-FLOAT-P", SI_ORDINARY, ECL_NAME(si_long_float_p), 1, OBJNULL},
/* Tag for end of list */ /* Tag for end of list */
{NULL, CL_ORDINARY, NULL, -1, OBJNULL}}; {NULL, CL_ORDINARY, NULL, -1, OBJNULL}};
...@@ -2323,5 +2323,11 @@ cl_symbols[] = { ...@@ -2323,5 +2323,11 @@ cl_symbols[] = {
{EXT_ "CONSTANTP-INNER","si_constantp_inner"}, {EXT_ "CONSTANTP-INNER","si_constantp_inner"},
{SYS_ "MAKE-BACKQ-VECTOR","si_make_backq_vector"}, {SYS_ "MAKE-BACKQ-VECTOR","si_make_backq_vector"},
{SYS_ "RATIOP","ECL_NAME(si_ratiop)"},
{SYS_ "SHORT-FLOAT-P","ECL_NAME(si_short_float_p)"},
{SYS_ "SINGLE-FLOAT-P","ECL_NAME(si_single_float_p)"},
{SYS_ "DOUBLE-FLOAT-P","ECL_NAME(si_double_float_p)"},
{SYS_ "LONG-FLOAT-P","ECL_NAME(si_long_float_p)"},
/* Tag for end of list */ /* Tag for end of list */
{NULL,NULL}}; {NULL,NULL}};
...@@ -77,14 +77,6 @@ ...@@ -77,14 +77,6 @@
when (si::type= type a-type) when (si::type= type a-type)
do (return `(,function-name ,object)))) do (return `(,function-name ,object))))
;; ;;
;; The following are not real functions, but are expanded by the
;; compiler into C forms.
((setf function (assoc type '((SINGLE-FLOAT . SINGLE-FLOAT-P)
(SHORT-FLOAT . SHORT-FLOAT-P)
(DOUBLE-FLOAT . DOUBLE-FLOAT-P)
(LONG-FLOAT . LONG-FLOAT-P))))
`(,(cdr function) ,object))
;;
;; Complex types defined with DEFTYPE. ;; Complex types defined with DEFTYPE.
((and (atom type) ((and (atom type)
(setq function (get-sysprop type 'SI::DEFTYPE-DEFINITION))) (setq function (get-sysprop type 'SI::DEFTYPE-DEFINITION)))
......
...@@ -571,14 +571,15 @@ ...@@ -571,14 +571,15 @@
;; ECL extensions ;; ECL extensions
(proclamation si:bit-array-op (t t t t) (array bit)) (proclamation si:bit-array-op (t t t t) (array bit))
(proclamation ext:fixnump (t) gen-bool :pure) (proclamation ext:fixnump (t) gen-bool :pure)
(proclamation si:ratiop (t) gen-bool :pure)
(proclamation si:short-float-p (t) gen-bool :pure)
(proclamation si:single-float-p (t) gen-bool :pure)
(proclamation si:double-float-p (t) gen-bool :pure)
(proclamation si:long-float-p (t) gen-bool :pure)
;; Virtual functions added by the compiler ;; Virtual functions added by the compiler
(proclamation shift>> (*) nil :pure) (proclamation shift>> (*) nil :pure)
(proclamation shift<< (*) nil :pure) (proclamation shift<< (*) nil :pure)
(proclamation short-float-p (*) nil :pure)
(proclamation single-float-p (*) nil :pure)
(proclamation double-float-p (*) nil :pure)
(proclamation long-float-p (*) nil :pure)
(proclamation c::ldb1 (fixnum fixnum fixnum) fixnum :no-side-effects) (proclamation c::ldb1 (fixnum fixnum fixnum) fixnum :no-side-effects)
......
...@@ -784,16 +784,16 @@ ...@@ -784,16 +784,16 @@
(def-inline shift<< :always (fixnum fixnum) :fixnum "((#0) << (#1))") (def-inline shift<< :always (fixnum fixnum) :fixnum "((#0) << (#1))")
(def-inline short-float-p :always (t) :bool "@0;ECL_SINGLE_FLOAT_P(#0)") (def-inline si:short-float-p :always (t) :bool "@0;ECL_SINGLE_FLOAT_P(#0)")
(def-inline single-float-p :always (t) :bool "@0;ECL_SINGLE_FLOAT_P(#0)") (def-inline si:single-float-p :always (t) :bool "@0;ECL_SINGLE_FLOAT_P(#0)")
(def-inline double-float-p :always (t) :bool "@0;ECL_DOUBLE_FLOAT_P(#0)") (def-inline si:double-float-p :always (t) :bool "@0;ECL_DOUBLE_FLOAT_P(#0)")
#-long-float #-long-float
(def-inline long-float-p :always (t) :bool "@0;ECL_DOUBLE_FLOAT_P(#0)") (def-inline si:long-float-p :always (t) :bool "@0;ECL_DOUBLE_FLOAT_P(#0)")
#+long-float #+long-float
(def-inline long-float-p :always (t) :bool "@0;ECL_LONG_FLOAT_P(#0)") (def-inline si:long-float-p :always (t) :bool "@0;ECL_LONG_FLOAT_P(#0)")
(def-inline ext:fixnump :always (t) :bool "ECL_FIXNUMP(#0)") (def-inline ext:fixnump :always (t) :bool "ECL_FIXNUMP(#0)")
(def-inline ext:fixnump :always (fixnum) :bool "1") (def-inline ext:fixnump :always (fixnum) :bool "1")
...@@ -910,7 +910,8 @@ ...@@ -910,7 +910,8 @@
find-relative-package package-parent package-children find-relative-package package-parent package-children
;; predlib.lsp ;; predlib.lsp
upgraded-array-element-type upgraded-complex-part-type typep subtypep coerce upgraded-array-element-type upgraded-complex-part-type typep subtypep coerce
do-deftype do-deftype si::ratiop si::single-float-p si::short-float-p si::double-float-p
si::long-float-p
;; seq.lsp ;; seq.lsp
make-sequence concatenate map some every notany notevery map-into make-sequence concatenate map some every notany notevery map-into
complement complement
......
...@@ -2057,6 +2057,11 @@ extern ECL_API cl_object cl_upgraded_complex_part_type _ECL_ARGS((cl_narg narg, ...@@ -2057,6 +2057,11 @@ extern ECL_API cl_object cl_upgraded_complex_part_type _ECL_ARGS((cl_narg narg,
extern ECL_API cl_object cl_typep _ECL_ARGS((cl_narg narg, cl_object V1, cl_object V2, ...)); extern ECL_API cl_object cl_typep _ECL_ARGS((cl_narg narg, cl_object V1, cl_object V2, ...));
extern ECL_API cl_object cl_coerce(cl_object V1, cl_object V2); extern ECL_API cl_object cl_coerce(cl_object V1, cl_object V2);
extern ECL_API cl_object cl_subtypep _ECL_ARGS((cl_narg narg, cl_object V1, cl_object V2, ...)); extern ECL_API cl_object cl_subtypep _ECL_ARGS((cl_narg narg, cl_object V1, cl_object V2, ...));
extern ECL_API cl_object si_short_float_p(cl_object t);
extern ECL_API cl_object si_single_float_p(cl_object t);
extern ECL_API cl_object si_double_float_p(cl_object t);
extern ECL_API cl_object si_long_float_p(cl_object t);
extern ECL_API cl_object si_ratiop(cl_object t);
/* setf.lsp */ /* setf.lsp */
......
...@@ -304,6 +304,44 @@ and is not adjustable." ...@@ -304,6 +304,44 @@ and is not adjustable."
(array-has-fill-pointer-p x) (array-has-fill-pointer-p x)
(array-displacement x)))) (array-displacement x))))
(defun ratiop (x)
#-ecl-min
(ffi::c-inline (x) (t) :bool "type_of(#0) == t_ratio" :one-liner t)
#+ecl-min
(and (rationalp x) (not (integerp x))))
(defun short-float-p (x)
#-ecl-min
(ffi::c-inline (x) (t) :bool "type_of(#0) == t_singlefloat" :one-liner t)
#+ecl-min
(eq (type-of x) 'single-float))
(defun single-float-p (x)
#-ecl-min
(ffi::c-inline (x) (t) :bool "type_of(#0) == t_singlefloat" :one-liner t)
#+ecl-min
(eq (type-of x) 'single-float))
(defun double-float-p (x)
#-ecl-min
(ffi::c-inline (x) (t) :bool "type_of(#0) == t_doublefloat" :one-liner t)
#+ecl-min
(eq (type-of x) 'double-float))
#+long-float
(defun long-float-p (x)
#-ecl-min
(ffi::c-inline (x) (t) :bool "type_of(#0) == t_longfloat" :one-liner t)
#+ecl-min
(eq (type-of x) 'long-float))
#-long-float
(defun long-float-p (x)
#-ecl-min
(ffi::c-inline (x) (t) :bool "type_of(#0) == t_doublefloat" :one-liner t)
#+ecl-min
(eq (type-of x) 'double-float))
(eval-when (:execute :load-toplevel :compile-toplevel) (eval-when (:execute :load-toplevel :compile-toplevel)
(defconstant +known-typep-predicates+ (defconstant +known-typep-predicates+
'((ARRAY . ARRAYP) '((ARRAY . ARRAYP)
...@@ -318,6 +356,7 @@ and is not adjustable." ...@@ -318,6 +356,7 @@ and is not adjustable."
(COMPLEX . COMPLEXP) (COMPLEX . COMPLEXP)
(COMPLEX-ARRAY . COMPLEX-ARRAY-P) (COMPLEX-ARRAY . COMPLEX-ARRAY-P)
(CONS . CONSP) (CONS . CONSP)
(DOUBLE-FLOAT . SI:DOUBLE-FLOAT-P)
(FLOAT . FLOATP) (FLOAT . FLOATP)
(SI:FOREIGN-DATA . SI:FOREIGN-DATA-P) (SI:FOREIGN-DATA . SI:FOREIGN-DATA-P)
(FUNCTION . FUNCTIONP) (FUNCTION . FUNCTIONP)
...@@ -327,10 +366,12 @@ and is not adjustable." ...@@ -327,10 +366,12 @@ and is not adjustable."
(KEYWORD . KEYWORDP) (KEYWORD . KEYWORDP)
(LIST . LISTP) (LIST . LISTP)
(LOGICAL-PATHNAME . LOGICAL-PATHNAME-P) (LOGICAL-PATHNAME . LOGICAL-PATHNAME-P)
(LONG-FLOAT . SI:LONG-FLOAT-P)
(NIL . CONSTANTLY-NIL) (NIL . CONSTANTLY-NIL)
(NULL . NULL) (NULL . NULL)
(NUMBER . NUMBERP) (NUMBER . NUMBERP)
(PACKAGE . PACKAGEP) (PACKAGE . PACKAGEP)
(RATIO . SI:RATIOP)
(RANDOM-STATE . RANDOM-STATE-P) (RANDOM-STATE . RANDOM-STATE-P)
(RATIONAL . RATIONALP) (RATIONAL . RATIONALP)
(PATHNAME . PATHNAMEP) (PATHNAME . PATHNAMEP)
...@@ -339,6 +380,8 @@ and is not adjustable." ...@@ -339,6 +380,8 @@ and is not adjustable."
(SIMPLE-ARRAY . SIMPLE-ARRAY-P) (SIMPLE-ARRAY . SIMPLE-ARRAY-P)
(SIMPLE-STRING . SIMPLE-STRING-P) (SIMPLE-STRING . SIMPLE-STRING-P)
(SIMPLE-VECTOR . SIMPLE-VECTOR-P) (SIMPLE-VECTOR . SIMPLE-VECTOR-P)
(SHORT-FLOAT . SI:SHORT-FLOAT-P)
(SINGLE-FLOAT . SI:SINGLE-FLOAT-P)
(STREAM . STREAMP) (STREAM . STREAMP)
(STRING . STRINGP) (STRING . STRINGP)
(STRUCTURE . SYS:STRUCTUREP) (STRUCTURE . SYS:STRUCTUREP)
...@@ -434,9 +477,9 @@ Returns T if X belongs to TYPE; NIL otherwise." ...@@ -434,9 +477,9 @@ Returns T if X belongs to TYPE; NIL otherwise."
(declare (ignore env)) (declare (ignore env))
(cond ((symbolp type) (cond ((symbolp type)
(let ((f (get-sysprop type 'TYPE-PREDICATE))) (let ((f (get-sysprop type 'TYPE-PREDICATE)))
(cond (f (return-from typep (funcall f object))) (if f
((eq (type-of object) type) (return-from typep t)) (return-from typep (funcall f object))
(t (setq tp type i nil))))) (setq tp type i nil))))
((consp type) ((consp type)
(setq tp (car type) i (cdr type))) (setq tp (car type) i (cdr type)))
#+clos #+clos
...@@ -455,11 +498,12 @@ Returns T if X belongs to TYPE; NIL otherwise." ...@@ -455,11 +498,12 @@ Returns T if X belongs to TYPE; NIL otherwise."
((T) t) ((T) t)
((NIL) nil) ((NIL) nil)
(BIGNUM (and (integerp object) (not (si::fixnump object)))) (BIGNUM (and (integerp object) (not (si::fixnump object))))
(RATIO (eq (type-of object) 'RATIO))
(STANDARD-CHAR (STANDARD-CHAR
(and (characterp object) (standard-char-p object))) (and (characterp object) (standard-char-p object)))
(INTEGER (INTEGER
(and (integerp object) (in-interval-p object i))) (and (integerp object) (in-interval-p object i)))
(RATIO
(and (ratiop object) (in-interval-p object i)))
(RATIONAL (RATIONAL
(and (rationalp object) (in-interval-p object i))) (and (rationalp object) (in-interval-p object i)))
(FLOAT (FLOAT
...@@ -467,12 +511,12 @@ Returns T if X belongs to TYPE; NIL otherwise." ...@@ -467,12 +511,12 @@ Returns T if X belongs to TYPE; NIL otherwise."
(REAL (REAL
(and (or (rationalp object) (floatp object)) (in-interval-p object i))) (and (or (rationalp object) (floatp object)) (in-interval-p object i)))
((SINGLE-FLOAT #-short-float SHORT-FLOAT) ((SINGLE-FLOAT #-short-float SHORT-FLOAT)
(and (eq (type-of object) 'SINGLE-FLOAT) (in-interval-p object i))) (and (si:single-float-p object) (in-interval-p object i)))
((DOUBLE-FLOAT #-long-float LONG-FLOAT) ((DOUBLE-FLOAT #-long-float LONG-FLOAT)
(and (eq (type-of object) 'DOUBLE-FLOAT) (in-interval-p object i))) (and (si:double-float-p object) (in-interval-p object i)))
#+long-float #+long-float
(LONG-FLOAT (LONG-FLOAT
(and (eq (type-of object) 'LONG-FLOAT) (in-interval-p object i))) (and (si:long-float-p object) (in-interval-p object i)))
(COMPLEX (COMPLEX
(and (complexp object) (and (complexp object)
(or (null i) (or (null i)
......
Markdown is supported
0% or
You are about to add 0 people to the discussion. Proceed with caution.
Finish editing this message first!
Please register or to comment