From 604c87126dd351bdcaef2c9d7c0cce84202a2563 Mon Sep 17 00:00:00 2001
From: Fabrizio Fabbri <fabrizio.fabbri@gmail.com>
Date: Thu, 6 Jul 2017 10:44:34 +0200
Subject: [PATCH] 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)))