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

cmp: #353 fix vector-push vector-push-extend

Browse source 
When call those function with invalid argument
number the generated code instead of signal
a programming error does SIGSEGV
This commit is contained in:
Fabrizio Fabbri 2017-07-06 10:44:34 +02:00
parent cc442ac9cd
commit 604c87126d
No known key found for this signature in database
GPG key ID: 8276EDF3D10E6C35
2 changed files with 51 additions and 17 deletions
Download patch file Download diff file Expand all files Collapse all files

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))

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

@ -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)))