compiler: check number of arguments.

We implement rudimentary compile-time checking beween function
calls and function definitions.

* share/txr/stdlib/compiler.tl (dstruct frag): We add one more
optional BOA parameter, corresponding to a new slot.
This is used when compiling a lambda. A lambda fragment is
annotated with the parameter parser object which gives
information about its arguments.
(struct fbinding): New slot, pars. When processing a sys:fbind
or sys:lbind form, we decorate the lexical function bindings
with the parameter object pulled from the lambda fragment
that is compiled for each function binding.
(*unchecked-calls*): New special variable. This is used for
checking, at the end of the compilation unit, the arguments of
calls to functions that were not defined at the time of the
call.
(compiler comp-fbind): When processing the lambda expressions,
propagate the parameter object from the compiled lambda
fragment to the function binding.
(compiler comp-fun-form): On entry, look up the function being
called and if it is lexical or has a global definition, check
the arguments. If it has no definition, push information into
the *unchecked-calls* list to do the check later, if possible.
Also, there is a behavior change here now: optimizations are
now applied here only to functions that don't have a lexical
binding. Thus if the application lexically redefines a
standard function, and calls it, we won't try to optimize it.
(param-check): New function.

* share/txr/stdlib/param.tl (param-info): New struct. This
presents information about a global function in a similar way
to param-parser, using some of the same fields. With this
object we can check the call to a lexical function or global
function in a uniform way, using the same code.

2 files changed, 81 insertions, 35 deletions

diff --git a/share/txr/stdlib/compiler.tl b/share/txr/stdlib/compiler.tl
index 21721ad6..9a756107 100644
--- a/share/txr/stdlib/compiler.tl
+++ b/share/txr/stdlib/compiler.tl
@@ -30,9 +30,10 @@
 (compile-only
   (load-for (struct sys:param-parser-base "param")))
 
-(defstruct (frag oreg code : fvars ffuns) nil
+(defstruct (frag oreg code : fvars ffuns pars) nil
   oreg
   code
+  pars
   fvars
   ffuns)
 
@@ -44,7 +45,8 @@
 
 (defstruct vbinding binding)
 
-(defstruct fbinding binding)
+(defstruct fbinding binding
+  pars)
 
 (defstruct blockinfo nil
   sym
@@ -335,6 +337,8 @@
 
 (defvar *dedup*)
 
+(defvar *unchecked-calls*)
+
 (defvar *load-time*)
 
 ;; 0 - no optimization
@@ -1028,6 +1032,7 @@
                                 (frag me.(compile bind.loc
                                                   (if rec nenv eenv)
                                                   form)))
+                           (set bind.pars frag.pars)
                            (list bind
                                  (new (frag frag.oreg
                                             (append frag.code
@@ -1160,7 +1165,8 @@
                   (new (frag oreg code
                              (uni fvars (diff bfrag.fvars lexsyms))
                              (uni [reduce-left uni ifrags nil .ffuns]
-                                  bfrag.ffuns))))))))))))
+                                  bfrag.ffuns)
+                             pars)))))))))))
 
 (defmeth compiler comp-lambda (me oreg env form)
   (if (or *load-time* (< *opt-level* 3))
@@ -1292,36 +1298,47 @@
     me.(comp-fun-form oreg env form)))
 
 (defmeth compiler comp-fun-form (me oreg env form)
-  (let ((olev *opt-level*))
-    (when (plusp olev)
-      (match-case form
-        ((equal @a @b)
-         (cond
-           ((or (eq-comparable a)
-                (eq-comparable b))
-            (set form ^(eq ,a ,b)))
-           ((or (eql-comparable a)
-                (eql-comparable b))
-            (set form ^(eql ,a ,b)))))
-        ((not (@(and @(or eq eql equal) @op) @a @b))
-         (let ((nop (caseq op (eq 'neq) (eql 'neql) (equal 'nequal))))
-           (return-from comp-fun-form me.(compile oreg env ^(,nop ,a ,b)))))
-        ((@(or append cons list list*) . @args)
-         (set form (reduce-lisp form)))
-        ((@(@bin [%bin-op% @sym]) @a @b)
-         (set form ^(,bin ,a ,b)))
-        ((- @a)
-         (set form ^(neg ,a)))
-        ((@(or identity + * min max) @a)
-         (return-from comp-fun-form me.(compile oreg env a)))))
-
-    (when (plusp olev)
-      (tree-case form
-        ((sym . args)
-         (set form (reduce-constant env form)))))
-
-    (when (or (atom form) (special-operator-p (car form)))
-      (return-from comp-fun-form me.(compile oreg env form)))
+  (let* ((olev *opt-level*)
+         (sym (car form))
+         (nargs (len (cdr form)))
+         (fbin env.(lookup-fun sym t))
+         (pars (or fbin.?pars
+                   (if (fboundp sym)
+                     (new param-info symbol sym)))))
+    (if pars
+      (param-check form nargs pars)
+      (push (cons form nargs) *unchecked-calls*))
+
+    (when (null fbin)
+      (when (plusp olev)
+        (match-case form
+          ((equal @a @b)
+           (cond
+             ((or (eq-comparable a)
+                  (eq-comparable b))
+              (set form ^(eq ,a ,b)))
+             ((or (eql-comparable a)
+                  (eql-comparable b))
+              (set form ^(eql ,a ,b)))))
+          ((not (@(and @(or eq eql equal) @op) @a @b))
+           (let ((nop (caseq op (eq 'neq) (eql 'neql) (equal 'nequal))))
+             (return-from comp-fun-form me.(compile oreg env ^(,nop ,a ,b)))))
+          ((@(or append cons list list*) . @args)
+           (set form (reduce-lisp form)))
+          ((@(@bin [%bin-op% @sym]) @a @b)
+           (set form ^(,bin ,a ,b)))
+          ((- @a)
+           (set form ^(neg ,a)))
+          ((@(or identity + * min max) @a)
+           (return-from comp-fun-form me.(compile oreg env a)))))
+
+      (when (plusp olev)
+        (tree-case form
+          ((sym . args)
+           (set form (reduce-constant env form)))))
+
+      (when (or (atom form) (special-operator-p (car form)))
+        (return-from comp-fun-form me.(compile oreg env form))))
 
     (tree-bind (sym . args) form
       (let* ((fbind env.(lookup-fun sym t)))
@@ -2079,6 +2096,16 @@
                              (jend ,frag.oreg))))
       (vm-make-desc co.nlev (succ as.max-treg) as.buf co.(get-datavec) co.(get-symvec)))))
 
+(defun param-check (form nargs pars)
+  (cond
+    ((< nargs pars.nreq)
+     (compile-warning form "too few arguments: needs ~s, given ~s"
+                      pars.nreq nargs))
+    (pars.rest)
+    ((> nargs pars.nfix)
+     (compile-warning form "too many arguments: max ~s, given ~s"
+                      pars.nfix nargs))))
+
 (defun compiler-emit-warnings ()
   (let ((warn-fun [keep-if boundp (zap assumed-fun)]))
     (when warn-fun
@@ -2086,7 +2113,12 @@
         (throw 'warning
                `uses of @{warn-fun ", "} compiled as functions,\
                \ then defined as vars`)
-        (continue ())))))
+        (continue ()))))
+  (each ((uc (zap *unchecked-calls*)))
+    (when-match (@(as form (@sym . @args)) . @nargs) uc
+      (when (fboundp sym)
+        (let ((pars (new param-info symbol sym)))
+          (param-check form nargs pars))))))
 
 (defvarl %file-suff-rx% #/[.][^\\\/.]+/)
 
diff --git a/share/txr/stdlib/param.tl b/share/txr/stdlib/param.tl
index 5f3c1b42..c04325c9 100644
--- a/share/txr/stdlib/param.tl
+++ b/share/txr/stdlib/param.tl
@@ -67,4 +67,18 @@
     (mac-param-p nil))
 
   (defstruct (mac-param-parser syntax form) param-parser-base
-    (mac-param-p t)))
+    (mac-param-p t))
+
+  (defstruct (param-info symbol) nil
+    symbol
+    nreq nopt nfix rest
+    (:postinit (me)
+      (let* ((fun (or (symbol-function me.symbol)
+                      (error "~s: no such function: ~s"
+                             'param-info me.symbol)))
+             (fix (fun-fixparam-count fun))
+             (opt (fun-optparam-count fun)))
+        (set me.nreq (- fix opt)
+             me.nopt opt
+             me.nfix fix
+             me.rest (fun-variadic fun))))))