mirrors/ecl
1
Fork 0
mirror of https://gitlab.com/embeddable-common-lisp/ecl.git synced 2026-01-21 03:51:47 -08:00
Code Issues Projects Releases Packages Wiki Activity

Merge branch 'fix-804' into 'develop'

Browse source 
Fix #804

Closes #804

See merge request embeddable-common-lisp/ecl!361
This commit is contained in:
Daniel Kochmański 2026-01-09 19:19:21 +00:00
commit c329fc12da
5 changed files with 104 additions and 23 deletions
Download patch file Download diff file Expand all files Collapse all files

20
src/c/numbers/expt.d
View file

@ -80,8 +80,14 @@ expt_zero(cl_object x, cl_object y)
return ecl_make_complex(z, ecl_make_fixnum(0));
#ifdef ECL_COMPLEX_FLOAT
case t_csfloat:
if (tx == t_longfloat || ty == t_longfloat)
return clfloat_one;
if (tx == t_doublefloat || ty == t_doublefloat)
return cdfloat_one;
return csfloat_one;
case t_cdfloat:
if (tx == t_longfloat || ty == t_longfloat)
return clfloat_one;
return cdfloat_one;
case t_clfloat:
return clfloat_one;
@ -149,21 +155,17 @@ ecl_expt_complex_float(cl_object x, cl_object y) {
cl_object ret;
ECL_MATHERR_CLEAR;
switch ((ty > tx)? ty : tx) {
case t_clfloat:
case t_longfloat:
if (tx == t_clfloat || tx == t_longfloat ||
ty == t_clfloat || ty == t_longfloat) {
ret = ecl_make_clfloat
(cpowl(ecl_to_clfloat(x), ecl_to_clfloat(y)));
break;
case t_cdfloat:
case t_doublefloat:
} else if (tx == t_cdfloat || tx == t_doublefloat ||
ty == t_cdfloat || ty == t_doublefloat) {
ret = ecl_make_cdfloat
(cpow (ecl_to_cdfloat(x), ecl_to_cdfloat(y)));
break;
default:
} else {
ret = ecl_make_csfloat
(cpowf(ecl_to_csfloat(x), ecl_to_csfloat(y)));
break;
}
ECL_MATHERR_TEST;
return ret;

15
src/cmp/cmpbackend-cxx/cmpc-inl-sysfun.lsp
View file

@ -525,7 +525,7 @@
(def-inline cl:evenp :always (t) :bool "ecl_evenp(#0)")
(def-inline cl:evenp :always (fixnum fixnum) :bool "~(#0) & 1")
(def-inline cl:abs :always (t t) t "ecl_abs(#0,#1)")
(def-inline cl:abs :always (t) t "ecl_abs(#0)")
(def-inline cl:exp :always (t) t "ecl_exp(#0)")
(def-inline cl:expt :always (t t) t "ecl_expt(#0,#1)")
@ -533,8 +533,17 @@
;; Note that the following two inlines are conflicting. CHOOSE-INLINE-INFO
;; assumes the one that has more specific types.
(def-inline cl:expt :always ((integer 0 0) (integer 0 0)) :fixnum "1")
(def-inline cl:expt :always ((integer 0 0) t) :fixnum "0")
(def-inline cl:expt :always ((integer 1 1) t) :fixnum "1")
(def-inline cl:expt :always ((real 0 0) (real 0 0)) :float "1.0f" :exact-return-type t)
(def-inline cl:expt :always ((real 0 0) (real 0 0)) :double "1.0" :exact-return-type t)
(def-inline cl:expt :always ((real 0 0) (real 0 0)) :long-double "1.0l" :exact-return-type t)
(def-inline cl:expt :always ((integer 0 0) integer) :fixnum "(((#1) == 0) ? 1 : 0)")
(def-inline cl:expt :always ((real 0 0) real) :float "(ecl_zerop(#1) ? 1.0f : 0.0f)" :exact-return-type t)
(def-inline cl:expt :always ((real 0 0) real) :double "(ecl_zerop(#1) ? 1.0 : 0.0)" :exact-return-type t)
(def-inline cl:expt :always ((real 0 0) real) :long-double "(ecl_zerop(#1) ? 1.0l : 0.0l)" :exact-return-type t)
(def-inline cl:expt :always ((integer 1 1) integer) :fixnum "1")
(def-inline cl:expt :always ((real 1 1) real) :float "1.0f" :exact-return-type t)
(def-inline cl:expt :always ((real 1 1) real) :double "1.0" :exact-return-type t)
(def-inline cl:expt :always ((real 1 1) real) :long-double "1.0l" :exact-return-type t)
(def-inline cl:expt :always ((long-float 0.0l0 *) long-float) :long-double "powl((long double)#0,(long double)#1)")
(def-inline cl:expt :always ((double-float 0.0d0 *) double-float) :double "pow((double)#0,(double)#1)")
(def-inline cl:expt :always ((single-float 0.0f0 *) single-float) :float "powf((float)#0,(float)#1)")

33
src/cmp/cmpprop-num.lsp
View file

@ -131,17 +131,28 @@
;; (expt number-type integer) -> number-type
;; (expt number-type1 number-type2) -> (max-float number-type1 number-type2)
;;
(let ((exponent (ensure-real-type exponent)))
(values (list base exponent)
(cond ((eql exponent 'integer)
(if (subtypep base 'fixnum *cmp-env*)
'integer
base))
((type>= '(real 0 *) base *cmp-env*)
(let* ((exponent (ensure-nonrational-type exponent)))
(maximum-number-type exponent base)))
(t
'number)))))
(values (list base exponent)
(cond ((type>= '(real 0 0) base *cmp-env*)
(maximum-number-type base exponent))
((type>= '(real (0) *) base *cmp-env*)
(cond ((type>= '(integer 0 *) exponent *cmp-env*)
(maximum-number-type base 'integer :integer-result 'integer))
((type-and exponent 'integer)
;; This becomes quite complex here, simplify
;; our life by just returning 'number. We
;; could do better, but the compiler won't be
;; able to optimize much with the complicated
;; type combinations we would be returning
;; here.
'number)
(t
(maximum-number-type (ensure-nonrational-type exponent)
base))))
((or (type>= '(complex float) base *cmp-env*)
(type>= '(complex float) exponent *cmp-env*))
(maximum-number-type exponent base))
(t
'number))))
(def-type-propagator abs (fname arg)
(multiple-value-bind (output arg)

53
src/tests/normal-tests/compiler.lsp
View file

@ -2602,3 +2602,56 @@
'(lambda ()
(- most-positive-fixnum 3))))
(- most-positive-fixnum 3)))
;;; Date 2025-12-12
;;; URL: https://gitlab.com/embeddable-common-lisp/ecl/-/issues/804
;;; Description
;;;
;;; Incorrect type propagation and inline expansions for the EXPT
;;; function
;;;
(deftest cmp.0112.type-propagation-expt ()
(flet ((supertypes (tp)
(let ((types '(fixnum integer ratio rational
single-float double-float long-float float real
(complex integer) (complex ratio) (complex rational)
(complex single-float) (complex double-float) (complex long-float)
(complex float) number
(integer (0) *) (single-float (0) *) (double-float (0) *)
(long-float (0) *) (float (0) *) (real (0) *))))
(cons tp
(loop for supertype in types
if (subtypep tp supertype)
collect supertype)))))
(let* ((numbers '(-2 -1 0 1 2
-1/2 1/3
-1.3 0.0 0.75 1.0
-0.8d0 0.0d0 1.0d0 1.3d0
-1.6l0 0.0l0 1.0l0 0.9l0
#C(1 2) #C(1/2 3/2)
#C(1.0 3.0) #C(1.0d0 0.5d0) #C(1.0l0 2.3l0)))
(numbers-and-types
(loop for base in numbers
nconc (loop for exponent in numbers
nconc (loop for base-type in (supertypes (type-of base))
nconc (loop for exponent-type in (supertypes (type-of exponent))
collect (cons (cons base exponent) (cons base-type exponent-type)))))))
(functions-and-types
(funcall (compile nil
`(lambda ()
(declare (optimize (safety 0)))
(list ,@(loop for (base-type . exponent-type) in (delete-duplicates
(mapcar #'cdr numbers-and-types)
:test #'equal)
collect `(cons (lambda (x y)
(declare (type ,base-type x)
(type ,exponent-type y))
(expt x y))
(cons ',base-type ',exponent-type))))))))
(miscompiled-cases (loop for ((base . exponent) . types) in numbers-and-types
for f in (car (find types functions-and-types :test #'equal :key #'cdr))
unless (handler-case
(eql (expt base exponent) (funcall f base exponent))
(arithmetic-error () t))
collect (list (cons base exponent) types (expt base exponent) (funcall f base exponent)))))
(is (null miscompiled-cases)))))

6
src/tests/normal-tests/complex.lsp
View file

@ -304,3 +304,9 @@
;;
(test csfloat.0010.issue-547
(finishes (expt #c(1.0 0.0) 2))))
(test complex.0011.expt-float-contagion
(is (typep (expt -1.4d0 #C(1 2)) '(complex double-float)))
(is (typep (expt -1.4l0 #C(1 2)) '(complex long-float)))
(is (typep (expt #C(1.0 3.0) 0.0d0) '(complex double-float)))
(is (typep (expt #C(1.0 3.0) 0.0l0) '(complex long-float))))