From cc442ac9cdc2a0434a8e8725f7106d940323c3fd Mon Sep 17 00:00:00 2001 From: Fabrizio Fabbri Date: Wed, 28 Jun 2017 15:57:16 +0200 Subject: [PATCH 1/2] Compiled assoc does not check arguments --- src/c/list.d | 16 ++++++++++++++++ src/c/printer/float_to_digits.d | 3 +++ src/tests/normal-tests/compiler.lsp | 16 ++++++++++++++++ 3 files changed, 35 insertions(+) diff --git a/src/c/list.d b/src/c/list.d index f5aa696c9..d1ca005ee 100644 --- a/src/c/list.d +++ b/src/c/list.d @@ -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; diff --git a/src/c/printer/float_to_digits.d b/src/c/printer/float_to_digits.d index 942c3750b..492d4004a 100644 --- a/src/c/printer/float_to_digits.d +++ b/src/c/printer/float_to_digits.d @@ -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) { diff --git a/src/tests/normal-tests/compiler.lsp b/src/tests/normal-tests/compiler.lsp index 413edfcaf..8e7e37036 100644 --- a/src/tests/normal-tests/compiler.lsp +++ b/src/tests/normal-tests/compiler.lsp @@ -1198,3 +1198,19 @@ (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))) From 604c87126dd351bdcaef2c9d7c0cce84202a2563 Mon Sep 17 00:00:00 2001 From: Fabrizio Fabbri Date: Thu, 6 Jul 2017 10:44:34 +0200 Subject: [PATCH 2/2] cmp: #353 fix vector-push vector-push-extend When call those function with invalid argument number the generated code instead of signal a programming error does SIGSEGV --- src/cmp/cmparray.lsp | 51 +++++++++++++++++++---------- src/tests/normal-tests/compiler.lsp | 17 ++++++++++ 2 files changed, 51 insertions(+), 17 deletions(-) diff --git a/src/cmp/cmparray.lsp b/src/cmp/cmparray.lsp index 3ebf00766..7cef72ec7 100644 --- a/src/cmp/cmparray.lsp +++ b/src/cmp/cmparray.lsp @@ -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)) diff --git a/src/tests/normal-tests/compiler.lsp b/src/tests/normal-tests/compiler.lsp index 8e7e37036..7bbdab65f 100644 --- a/src/tests/normal-tests/compiler.lsp +++ b/src/tests/normal-tests/compiler.lsp @@ -1214,3 +1214,20 @@ (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)))