mirrors/ecl
1
Fork 0
mirror of https://gitlab.com/embeddable-common-lisp/ecl.git synced 2026-01-15 05:43:19 -08:00
Code Issues Projects Releases Packages Wiki Activity

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

Browse source
This commit is contained in:
Juan Jose Garcia Ripoll 2013-01-12 21:15:35 +01:00
parent e0cfa8028d
commit 89a8201b0b
7 changed files with 80 additions and 25 deletions
Download patch file Download diff file Expand all files Collapse all files

6
src/c/symbols_list.h
View file

@ -2323,5 +2323,11 @@ cl_symbols[] = {
{EXT_ "CONSTANTP-INNER", EXT_ORDINARY, si_constantp_inner, -1, 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 */
{NULL, CL_ORDINARY, NULL, -1, OBJNULL}};

6
src/c/symbols_list2.h
View file

@ -2323,5 +2323,11 @@ cl_symbols[] = {
{EXT_ "CONSTANTP-INNER","si_constantp_inner"},
{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 */
{NULL,NULL}};

8
src/cmp/cmpopt.lsp
View file

@ -77,14 +77,6 @@
when (si::type= type a-type)
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.
((and (atom type)
(setq function (get-sysprop type 'SI::DEFTYPE-DEFINITION)))

9
src/cmp/proclamations.lsp
View file

@ -571,14 +571,15 @@
;; ECL extensions
(proclamation si:bit-array-op (t t t t) (array bit))
(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
(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)

13
src/cmp/sysfun.lsp
View file

@ -784,16 +784,16 @@
(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
(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
(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 (fixnum) :bool "1")
@ -910,7 +910,8 @@
find-relative-package package-parent package-children
;; predlib.lsp
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
make-sequence concatenate map some every notany notevery map-into
complement

5
src/h/external.h
View file

@ -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_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 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 */

58
src/lsp/predlib.lsp
View file

@ -304,6 +304,44 @@ and is not adjustable."
(array-has-fill-pointer-p 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)
(defconstant +known-typep-predicates+
'((ARRAY . ARRAYP)
@ -318,6 +356,7 @@ and is not adjustable."
(COMPLEX . COMPLEXP)
(COMPLEX-ARRAY . COMPLEX-ARRAY-P)
(CONS . CONSP)
(DOUBLE-FLOAT . SI:DOUBLE-FLOAT-P)
(FLOAT . FLOATP)
(SI:FOREIGN-DATA . SI:FOREIGN-DATA-P)
(FUNCTION . FUNCTIONP)
@ -327,10 +366,12 @@ and is not adjustable."
(KEYWORD . KEYWORDP)
(LIST . LISTP)
(LOGICAL-PATHNAME . LOGICAL-PATHNAME-P)
(LONG-FLOAT . SI:LONG-FLOAT-P)
(NIL . CONSTANTLY-NIL)
(NULL . NULL)
(NUMBER . NUMBERP)
(PACKAGE . PACKAGEP)
(RATIO . SI:RATIOP)
(RANDOM-STATE . RANDOM-STATE-P)
(RATIONAL . RATIONALP)
(PATHNAME . PATHNAMEP)
@ -339,6 +380,8 @@ and is not adjustable."
(SIMPLE-ARRAY . SIMPLE-ARRAY-P)
(SIMPLE-STRING . SIMPLE-STRING-P)
(SIMPLE-VECTOR . SIMPLE-VECTOR-P)
(SHORT-FLOAT . SI:SHORT-FLOAT-P)
(SINGLE-FLOAT . SI:SINGLE-FLOAT-P)
(STREAM . STREAMP)
(STRING . STRINGP)
(STRUCTURE . SYS:STRUCTUREP)
@ -434,9 +477,9 @@ Returns T if X belongs to TYPE; NIL otherwise."
(declare (ignore env))
(cond ((symbolp type)
(let ((f (get-sysprop type 'TYPE-PREDICATE)))
(cond (f (return-from typep (funcall f object)))
((eq (type-of object) type) (return-from typep t))
(t (setq tp type i nil)))))
(if f
(return-from typep (funcall f object))
(setq tp type i nil))))
((consp type)
(setq tp (car type) i (cdr type)))
#+clos
@ -455,11 +498,12 @@ Returns T if X belongs to TYPE; NIL otherwise."
((T) t)
((NIL) nil)
(BIGNUM (and (integerp object) (not (si::fixnump object))))
(RATIO (eq (type-of object) 'RATIO))
(STANDARD-CHAR
(and (characterp object) (standard-char-p object)))
(INTEGER
(and (integerp object) (in-interval-p object i)))
(RATIO
(and (ratiop object) (in-interval-p object i)))
(RATIONAL
(and (rationalp object) (in-interval-p object i)))
(FLOAT
@ -467,12 +511,12 @@ Returns T if X belongs to TYPE; NIL otherwise."
(REAL
(and (or (rationalp object) (floatp object)) (in-interval-p object i)))
((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)
(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
(and (eq (type-of object) 'LONG-FLOAT) (in-interval-p object i)))
(and (si:long-float-p object) (in-interval-p object i)))
(COMPLEX
(and (complexp object)
(or (null i)