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

Merge branch 'develop' into 'develop'

Browse source 
Compiled assoc does not check arguments

See merge request !78
This commit is contained in:
Daniel Kochmański 2017-07-07 07:45:56 +00:00
commit 3a837ddcce
4 changed files with 86 additions and 17 deletions
Download patch file Download diff file Expand all files Collapse all files

16
src/c/list.d
View file

@ -1018,6 +1018,10 @@ ecl_assq(cl_object x, cl_object l)
{
loop_for_in(l) {
cl_object pair = ECL_CONS_CAR(l);
if (pair==ECL_NIL) continue;
if (ecl_unlikely(ECL_ATOM(pair))) {
FEtype_error_cons(pair);
}
if (x == CAR(pair))
return pair;
} end_loop_for_in;
@ -1029,6 +1033,10 @@ ecl_assql(cl_object x, cl_object l)
{
loop_for_in(l) {
cl_object pair = ECL_CONS_CAR(l);
if (pair==ECL_NIL) continue;
if (ecl_unlikely(ECL_ATOM(pair))) {
FEtype_error_cons(pair);
}
if (ecl_eql(x, CAR(pair)))
return pair;
} end_loop_for_in;
@ -1040,6 +1048,10 @@ ecl_assoc(cl_object x, cl_object l)
{
loop_for_in(l) {
cl_object pair = ECL_CONS_CAR(l);
if (pair==ECL_NIL) continue;
if (ecl_unlikely(ECL_ATOM(pair))) {
FEtype_error_cons(pair);
}
if (ecl_equal(x, CAR(pair)))
return pair;
} end_loop_for_in;
@ -1051,6 +1063,10 @@ ecl_assqlp(cl_object x, cl_object l)
{
loop_for_in(l) {
cl_object pair = ECL_CONS_CAR(l);
if (pair==ECL_NIL) continue;
if (ecl_unlikely(ECL_ATOM(pair))) {
FEtype_error_cons(pair);
}
if (ecl_equalp(x, CAR(pair)))
return pair;
} end_loop_for_in;

3
src/c/printer/float_to_digits.d
View file

@ -54,7 +54,10 @@ setup(cl_object number, float_approx *approx)
min_e = LDBL_MIN_EXP;
limit_f = (number->longfloat.value ==
ldexpl(FLT_RADIX, LDBL_MANT_DIG-1));
break;
#endif
default:
break;
}
approx->low_ok = approx->high_ok = ecl_evenp(f);
if (e > 0) {

51
src/cmp/cmparray.lsp
View file

@ -97,23 +97,40 @@
(unless (or (eq (first args) 'value) ; No infinite recursion
(not (policy-open-code-aref/aset)))
(setf whole
`(let* ((value ,(car args))
(vector ,(second args)))
(declare (:read-only value vector)
(optimize (safety 0)))
(optional-type-assertion vector vector)
(let ((index (fill-pointer vector))
(dimension (array-total-size vector)))
(declare (fixnum index dimension)
(:read-only index dimension))
(cond ((< index dimension)
(sys::fill-pointer-set vector (truly-the fixnum (+ 1 index)))
(sys::aset vector index value)
index)
(t ,(if extend
`(vector-push-extend value vector ,@(cddr args))
nil)))))))))
whole)
(if (or (< (length args) 2)
(and (not extend)
(> (length args) 2))
(and extend
(> (length args) 3)))
(progn
(cmpwarn "Wrong number of arguments passed to function ~S"
(symbol-function
(if extend
'vector-push-extend
'vector-push)))
`(si::simple-program-error
"Wrong number of arguments passed to function ~S"
(symbol-function
',(if extend
'vector-push-extend
'vector-push))))
`(let* ((value ,(car args))
(vector ,(second args)))
(declare (:read-only value vector)
(optimize (safety 0)))
(optional-type-assertion vector vector)
(let ((index (fill-pointer vector))
(dimension (array-total-size vector)))
(declare (fixnum index dimension)
(:read-only index dimension))
(cond ((< index dimension)
(sys::fill-pointer-set vector (truly-the fixnum (+ 1 index)))
(sys::aset vector index value)
index)
(t ,(if extend
`(vector-push-extend value vector ,@(cddr args))
nil))))))))))
whole)
(define-compiler-macro vector-push (&whole whole &rest args &environment env)
(expand-vector-push whole env nil))

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

@ -1198,3 +1198,36 @@
(simple-type-error () t)
(error () nil)
(:no-error (v) (declare (ignore v)) nil)))
;;; Date 2017-06-28
;;; Reported by Fabrizio Fabbri
;;; Description
;;;
;;; Compiled assoc does not check that alist argument
;;; is a valid association list.
;;;
;;; Bug https://gitlab.com/embeddable-common-lisp/ecl/issues/353
(test cmp.0054.invalid-argument-type
(handler-case
(funcall (compile nil
'(lambda () (assoc 'z '((a . b) :bad (c . d))))))
(simple-type-error () t)
(error () nil)
(:no-error (v) (declare (ignore v)) nil)))
;;; Date 2017-07-05
;;; Reported by Fabrizio Fabbri
;;; Description
;;;
;;; Compiled vector-push and vector-push-extend
;;; does not check for invalid argument and
;;; SIGSEGV
;;;
;;; Bug https://gitlab.com/embeddable-common-lisp/ecl/issues/353
(test cmp.0055.invalid-argument-type
(handler-case
(funcall (compile nil
'(lambda () (vector-push))))
(program-error () t)
(error () nil)
(:no-error (v) (declare (ignore v)) nil)))