~ chicken-core (chicken-5) 877ddd9e7df963653ccc29c83bed12a9fa7cf045

commit 877ddd9e7df963653ccc29c83bed12a9fa7cf045
Author:     felix <felix@call-with-current-continuation.org>
AuthorDate: Tue Apr 7 12:45:58 2020 +0200
Commit:     Peter Bex <peter@more-magic.net>
CommitDate: Sun Apr 12 19:14:53 2020 +0200

    Check known call argument count in analysis phase
    
    This was done in the optimizer previously but will be disabled with -O0.
    See also #1689
    
    Signed-off-by: Peter Bex <peter@more-magic.net>

diff --git a/core.scm b/core.scm
index a490915a..272a1f77 100644
--- a/core.scm
+++ b/core.scm
@@ -2122,7 +2122,17 @@
 	   (grow 1)
 	   (let ([fun (car subs)])
 	     (when (eq? '##core#variable (node-class fun))
-	       (let ((name (first (node-parameters fun))))
+	       (let* ((name (first (node-parameters fun)))
+                      (val (db-get db name 'value)))
+                 (when (and first-analysis
+                            val
+                            (not (db-get db name 'unknown))
+                            (eq? '##core#lambda (node-class val))
+                            (not (llist-match? (third (node-parameters val)) 
+                                               (cdr subs))))
+                    (quit-compiling
+		      "known procedure called with wrong number of arguments: `~A'" 
+	              (real-name name)))
 		 (collect! db name 'call-sites (cons here n))))
 	     (walk (first subs) env localenv fullenv here)
 	     (walkeach (cdr subs) env localenv fullenv here)))
diff --git a/optimizer.scm b/optimizer.scm
index bcf0148f..92634de0 100644
--- a/optimizer.scm
+++ b/optimizer.scm
@@ -1649,10 +1649,6 @@
 		      (cond [(eq? fnvar (first fnp))
 			     (set! ksites (alist-cons #f n ksites))
 			     (cond [(eq? kvar (first arg0p))
-				    (unless (= argc (length (cdr subs)))
-				      (quit-compiling
-				       "known procedure called recursively with wrong number of arguments: `~A'" 
-				       fnvar) )
 				    (node-class-set! n '##core#recurse)
 				    (node-parameters-set! n (list #t id))
 				    (node-subexpressions-set! n (cddr subs)) ]
@@ -1660,10 +1656,6 @@
 				    => (lambda (a)
 					 (let* ([klam (cdr a)]
 						[kbody (first (node-subexpressions klam))] )
-					   (unless (= argc (length (cdr subs)))
-					     (quit-compiling
-					      "known procedure called recursively with wrong number of arguments: `~A'" 
-					      fnvar) )
 					   (node-class-set! n 'let)
 					   (node-parameters-set! n (take (third (node-parameters klam)) 1))
 					   (node-subexpressions-set!