mirrors/ecl
1
Fork 0
mirror of https://gitlab.com/embeddable-common-lisp/ecl.git synced 2026-03-11 23:40:36 -07:00
Code Issues Projects Releases Packages Wiki Activity

cmp: refactor: expand-vector-push: get rid of one nesting level

Browse source
This commit is contained in:
Daniel Kochmanski 2017-08-10 20:23:30 +02:00
parent 45d5176c0e
commit c2af9fe775
1 changed files with 38 additions and 39 deletions
Download patch file Download diff file Expand all files Collapse all files

77
src/cmp/cmparray.lsp
View file

@ -90,46 +90,45 @@
;;; VECTOR-PUSH and VECTOR-PUSH-EXTEND
;;;
(defun expand-vector-push (whole env extend)
(defun expand-vector-push (whole env extend &aux (args (rest whole)))
(declare (si::c-local))
(let* ((args (rest whole)))
(with-clean-symbols (value vector index dimension)
(unless (or (eq (first args) 'value) ; No infinite recursion
(not (policy-open-code-aref/aset)))
(setf 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))))))))))
(with-clean-symbols (value vector index dimension)
(unless (or (eq (first args) 'value) ; No infinite recursion
(not (policy-open-code-aref/aset)))
(setf 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)