mirrors/ecl
1
Fork 0
mirror of https://gitlab.com/embeddable-common-lisp/ecl.git synced 2026-01-26 06:22:33 -08:00
Code Issues Projects Releases Packages Wiki Activity

cmp: check number of arguments when inlining funcall or apply of lambda expression

Browse source 
Closes #672.
This commit is contained in:
Marius Gerbershagen 2022-01-29 18:08:44 +01:00
parent 1c989247c1
commit f873e8e653
2 changed files with 69 additions and 11 deletions
Download patch file Download diff file Expand all files Collapse all files

47
src/cmp/cmppass1-call.lsp
View file

@ -256,6 +256,25 @@
(setf apply-list (first (last arguments))
apply-var (gensym)
arguments (butlast arguments)))
;; 1. check number of arguments
(let* ((n-args-wanted-min (first requireds))
(n-args-wanted-max (if (or key-flag allow-other-keys rest)
call-arguments-limit
(+ (first requireds) (first optionals))))
(apply-constant-args-p (and apply-p (constantp apply-list)
(listp (constant-form-value apply-list))))
(n-args-got-min (if apply-constant-args-p
(+ (length arguments)
(length (constant-form-value apply-list)))
(length arguments)))
(n-args-got-max (cond ((and apply-p (not apply-constant-args-p))
nil) ; unknown maximum number of arguments
(t n-args-got-min))))
(when (and n-args-got-max (< n-args-got-max n-args-wanted-min))
(too-few-args lambda-form n-args-wanted-min n-args-got-min))
(when (> n-args-got-min n-args-wanted-max)
(too-many-args lambda-form n-args-wanted-max n-args-got-max)))
;; 2. construct forms to evaluate arguments in order
(setf arguments (copy-list arguments))
(do ((scan arguments (cdr scan)))
((endp scan))
@ -266,6 +285,7 @@
(setf (car scan) aux-var)))))
(when apply-var
(push `(,apply-var ,apply-list) let-vars))
;; 3. process required parameters
(dolist (i (cdr requireds))
(push (list i
(cond (arguments
@ -273,11 +293,9 @@
(apply-p
`(if ,apply-var
(pop ,apply-var)
(si::dm-too-few-arguments nil)))
(t
(cmperr "Too few arguments for lambda form ~S"
(cons 'LAMBDA lambda-form)))))
(si::dm-too-few-arguments nil)))))
let-vars))
;; 4. process optional parameters
(do ((scan (cdr optionals) (cdddr scan)))
((endp scan))
(let ((opt-var (first scan))
@ -300,16 +318,22 @@
(list* `(,opt-var ,opt-value)
`(,opt-flag nil)
let-vars))))))
;; 5. process rest parameter
(when (or key-flag allow-other-keys)
(unless rest
(setf rest (gensym))))
(when rest
(push `(,rest ,(if arguments
(if apply-p
`(list* ,@arguments ,apply-var)
`(list ,@arguments))
(if apply-p apply-var nil)))
let-vars))
(cond (rest
(push `(,rest ,(if arguments
(if apply-p
`(list* ,@arguments ,apply-var)
`(list ,@arguments))
(if apply-p apply-var nil)))
let-vars))
(apply-p
(push `(when ,apply-var
(si::dm-too-many-arguments nil))
extra-stmts)))
;; 6. process keyword parameters
(do ((scan (cdr keywords) (cddddr scan)))
((endp scan))
(let ((keyword (first scan))
@ -328,6 +352,7 @@
let-vars))))
(when (and key-flag (not allow-other-keys))
(push `(si::check-keyword ,rest ',all-keys) extra-stmts))
;; 7. construct body
(loop while aux-vars
do (push (list (pop aux-vars) (pop aux-vars)) let-vars))
(values (nreverse (delete-if-not #'first let-vars))

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

@ -2061,3 +2061,36 @@
`(defun cmp.0089.fun2 () cmp.0089.sym)))
(is (= 15 (cmp.0089.fun1 15)))
(is (= 42 (cmp.0089.fun2)))))
;;; Date 2022-01-29
;;; URL: https://gitlab.com/embeddable-common-lisp/ecl/-/issues/672
;;; Description
;;;
;;; Apply, funcall and multiple-value-call did not check the
;;; number of arguments when lambda expressions. This test fairly
;;; comprehensively checks that we signal an error if we get wrong
;;; number of arguments and also includes some non-error cases.
;;;
(test cmp.0090.funcall/apply-inline-and-number-of-arguments
(signals error (funcall (compile nil '(lambda () (funcall (lambda (a b) (list a b)) 1)))))
(signals error (funcall (compile nil '(lambda () (funcall (lambda (a b) (list a b)) 1 2 3)))))
(signals error (funcall (compile nil '(lambda () (funcall (lambda (a &optional b) (list a b)) 1 2 3)))))
(is (equal (funcall (compile nil '(lambda () (funcall (lambda (a &optional b) (list a b)) 1)))) '(1 nil)))
(is (equal (funcall (compile nil '(lambda () (funcall (lambda (a &optional b) (list a b)) 1 2)))) '(1 2)))
(signals error (funcall (compile nil '(lambda () (apply (lambda (a b) (list a b)) '(1))))))
(signals error (funcall (compile nil '(lambda () (apply (lambda (a b) (list a b)) '(1 2 3))))))
(signals error (funcall (compile nil '(lambda () (apply (lambda (a b) (list a b)) 1 '(2 3))))))
(is (equal (funcall (compile nil '(lambda (x) (apply (lambda (a b) (list a b)) x))) '(1 2)) '(1 2)))
(is (equal (funcall (compile nil '(lambda (x) (apply (lambda (a b) (list a b)) 1 x))) '(2)) '(1 2)))
(signals error (funcall (compile nil '(lambda (x) (apply (lambda (a b) (list a b)) 1 x))) '(2 3)))
(is (equal (funcall (compile nil '(lambda () (apply (lambda (a &optional b) (list a b)) '(1))))) '(1 nil)))
(signals error (funcall (compile nil '(lambda () (apply (lambda (a &optional b) (list a b)) '(1 2 3))))))
(signals error (funcall (compile nil '(lambda () (apply (lambda (a &optional b) (list a b)) 1 '(2 3))))))
(is (equal (funcall (compile nil '(lambda (x) (apply (lambda (a &optional b) (list a b)) x))) '(1 2)) '(1 2)))
(is (equal (funcall (compile nil '(lambda (x) (apply (lambda (a &optional b) (list a b)) 1 x))) '(2)) '(1 2)))
(signals error (funcall (compile nil '(lambda (x) (apply (lambda (a &optional b) (list a b)) 1 x))) '(2 3)))
(signals error (funcall (compile nil '(lambda () (multiple-value-call (lambda (a b) (list a b)) (values 1))))))
(signals error (funcall (compile nil '(lambda () (multiple-value-call (lambda (a b) (list a b)) (values 1 2 3))))))
(signals error (funcall (compile nil '(lambda () (multiple-value-call (lambda (a &optional b) (list a b)) (values 1 2 3))))))
(is (equal (funcall (compile nil '(lambda () (multiple-value-call (lambda (a &optional b) (list a b)) (values 1))))) '(1 nil)))
(is (equal (funcall (compile nil '(lambda () (multiple-value-call (lambda (a &optional b) (list a b)) (values 1 2))))) '(1 2))))