better debuggability for interpreted procedures

* libguile/procprop.c (scm_set_procedure_minimum_arity_x): New
  function, allows a user to override a function's arity.
  (scm_i_procedure_arity): Look up in the overrides table first.

* libguile/procprop.h: Add scm_set_procedure_minimum_arity_x.

* module/ice-9/eval.scm (primitive-eval): Override arity of "general
  closures".

* test-suite/tests/procprop.test ("procedure-arity"): Add tests.

Based on a patch from Stefan Israelsson Tampe.  Test based on work by
Patrick Bernaud.

1 files changed, 121 insertions, 103 deletions

diff --git a/module/ice-9/eval.scm b/module/ice-9/eval.scm
index 30a373a7a..62e36ed66 100644
--- a/module/ice-9/eval.scm
+++ b/module/ice-9/eval.scm
@@ -235,109 +235,127 @@
                     (inits (if tail (caddr tail) '()))
                     (alt (and tail (cadddr tail))))
                (make-general-closure env body nreq rest nopt kw inits alt))))
-      (lambda %args
-        (let lp ((env env)
-                 (nreq* nreq)
-                 (args %args))
-          (if (> nreq* 0)
-              ;; First, bind required arguments.
-              (if (null? args)
-                  (if alt
-                      (apply alt-proc %args)
-                      (scm-error 'wrong-number-of-args
-                                 "eval" "Wrong number of arguments"
-                                 '() #f))
-                  (lp (cons (car args) env)
-                      (1- nreq*)
-                      (cdr args)))
-              ;; Move on to optional arguments.
-              (if (not kw)
-                  ;; Without keywords, bind optionals from arguments.
-                  (let lp ((env env)
-                           (nopt nopt)
-                           (args args)
-                           (inits inits))
-                    (if (zero? nopt)
-                        (if rest?
-                            (eval body (cons args env))
-                            (if (null? args)
-                                (eval body env)
-                                (if alt
-                                    (apply alt-proc %args)
-                                    (scm-error 'wrong-number-of-args
-                                               "eval" "Wrong number of arguments"
-                                               '() #f))))
-                        (if (null? args)
-                            (lp (cons (eval (car inits) env) env)
-                                (1- nopt) args (cdr inits))
-                            (lp (cons (car args) env)
-                                (1- nopt) (cdr args) (cdr inits)))))
-                  ;; With keywords, we stop binding optionals at the first
-                  ;; keyword.
-                  (let lp ((env env)
-                           (nopt* nopt)
-                           (args args)
-                           (inits inits))
-                    (if (> nopt* 0)
-                        (if (or (null? args) (keyword? (car args)))
-                            (lp (cons (eval (car inits) env) env)
-                                (1- nopt*) args (cdr inits))
-                            (lp (cons (car args) env)
-                                (1- nopt*) (cdr args) (cdr inits)))
-                        ;; Finished with optionals.
-                        (let* ((aok (car kw))
-                               (kw (cdr kw))
-                               (kw-base (+ nopt nreq (if rest? 1 0)))
-                               (imax (let lp ((imax (1- kw-base)) (kw kw))
-                                       (if (null? kw)
-                                           imax
-                                           (lp (max (cdar kw) imax)
-                                               (cdr kw)))))
-                               ;; Fill in kwargs  with "undefined" vals.
-                               (env (let lp ((i kw-base)
-                                             ;; Also, here we bind the rest
-                                             ;; arg, if any.
-                                             (env (if rest? (cons args env) env)))
-                                      (if (<= i imax)
-                                          (lp (1+ i) (cons unbound-arg env))
-                                          env))))
-                          ;; Now scan args for keywords.
-                          (let lp ((args args))
-                            (if (and (pair? args) (pair? (cdr args))
-                                     (keyword? (car args)))
-                                (let ((kw-pair (assq (car args) kw))
-                                      (v (cadr args)))
-                                  (if kw-pair
-                                      ;; Found a known keyword; set its value.
-                                      (list-set! env (- imax (cdr kw-pair)) v)
-                                      ;; Unknown keyword.
-                                      (if (not aok)
-                                          (scm-error 'keyword-argument-error
-                                                     "eval" "Unrecognized keyword"
-                                                     '() #f)))
-                                  (lp (cddr args)))
-                                (if (pair? args)
-                                    (if rest?
-                                        ;; Be lenient parsing rest args.
-                                        (lp (cdr args))
-                                        (scm-error 'keyword-argument-error
-                                                   "eval" "Invalid keyword"
-                                                   '() #f))
-                                    ;; Finished parsing keywords. Fill in
-                                    ;; uninitialized kwargs by evalling init
-                                    ;; expressions in their appropriate
-                                    ;; environment.
-                                    (let lp ((i (- imax kw-base))
-                                             (inits inits))
-                                      (if (pair? inits)
-                                          (let ((tail (list-tail env i)))
-                                            (if (eq? (car tail) unbound-arg)
-                                                (set-car! tail
-                                                          (eval (car inits)
-                                                                (cdr tail))))
-                                            (lp (1- i) (cdr inits)))
-                                          ;; Finally, eval the body.
-                                          (eval body env))))))))))))))
+      (define (set-procedure-arity! proc)
+        (let lp ((alt alt) (nreq nreq) (nopt nopt) (rest? rest?))
+          (if (not alt)
+              (set-procedure-minimum-arity! proc nreq nopt rest?)
+              (let* ((nreq* (cadr alt))
+                     (rest?* (if (null? (cddr alt)) #f (caddr alt)))
+                     (tail (and (pair? (cddr alt)) (pair? (cdddr alt)) (cdddr alt)))
+                     (nopt* (if tail (car tail) 0))
+                     (alt* (and tail (cadddr tail))))
+                (if (or (< nreq* nreq)
+                        (and (= nreq* nreq)
+                             (if rest?
+                                 (and rest?* (> nopt* nopt))
+                                 (or rest?* (> nopt* nopt)))))
+                    (lp alt* nreq* nopt* rest?*)
+                    (lp alt* nreq nopt rest?)))))
+        proc)
+      (set-procedure-arity!
+       (lambda %args
+         (let lp ((env env)
+                  (nreq* nreq)
+                  (args %args))
+           (if (> nreq* 0)
+               ;; First, bind required arguments.
+               (if (null? args)
+                   (if alt
+                       (apply alt-proc %args)
+                       (scm-error 'wrong-number-of-args
+                                  "eval" "Wrong number of arguments"
+                                  '() #f))
+                   (lp (cons (car args) env)
+                       (1- nreq*)
+                       (cdr args)))
+               ;; Move on to optional arguments.
+               (if (not kw)
+                   ;; Without keywords, bind optionals from arguments.
+                   (let lp ((env env)
+                            (nopt nopt)
+                            (args args)
+                            (inits inits))
+                     (if (zero? nopt)
+                         (if rest?
+                             (eval body (cons args env))
+                             (if (null? args)
+                                 (eval body env)
+                                 (if alt
+                                     (apply alt-proc %args)
+                                     (scm-error 'wrong-number-of-args
+                                                "eval" "Wrong number of arguments"
+                                                '() #f))))
+                         (if (null? args)
+                             (lp (cons (eval (car inits) env) env)
+                                 (1- nopt) args (cdr inits))
+                             (lp (cons (car args) env)
+                                 (1- nopt) (cdr args) (cdr inits)))))
+                   ;; With keywords, we stop binding optionals at the first
+                   ;; keyword.
+                   (let lp ((env env)
+                            (nopt* nopt)
+                            (args args)
+                            (inits inits))
+                     (if (> nopt* 0)
+                         (if (or (null? args) (keyword? (car args)))
+                             (lp (cons (eval (car inits) env) env)
+                                 (1- nopt*) args (cdr inits))
+                             (lp (cons (car args) env)
+                                 (1- nopt*) (cdr args) (cdr inits)))
+                         ;; Finished with optionals.
+                         (let* ((aok (car kw))
+                                (kw (cdr kw))
+                                (kw-base (+ nopt nreq (if rest? 1 0)))
+                                (imax (let lp ((imax (1- kw-base)) (kw kw))
+                                        (if (null? kw)
+                                            imax
+                                            (lp (max (cdar kw) imax)
+                                                (cdr kw)))))
+                                ;; Fill in kwargs  with "undefined" vals.
+                                (env (let lp ((i kw-base)
+                                              ;; Also, here we bind the rest
+                                              ;; arg, if any.
+                                              (env (if rest? (cons args env) env)))
+                                       (if (<= i imax)
+                                           (lp (1+ i) (cons unbound-arg env))
+                                           env))))
+                           ;; Now scan args for keywords.
+                           (let lp ((args args))
+                             (if (and (pair? args) (pair? (cdr args))
+                                      (keyword? (car args)))
+                                 (let ((kw-pair (assq (car args) kw))
+                                       (v (cadr args)))
+                                   (if kw-pair
+                                       ;; Found a known keyword; set its value.
+                                       (list-set! env (- imax (cdr kw-pair)) v)
+                                       ;; Unknown keyword.
+                                       (if (not aok)
+                                           (scm-error 'keyword-argument-error
+                                                      "eval" "Unrecognized keyword"
+                                                      '() #f)))
+                                   (lp (cddr args)))
+                                 (if (pair? args)
+                                     (if rest?
+                                         ;; Be lenient parsing rest args.
+                                         (lp (cdr args))
+                                         (scm-error 'keyword-argument-error
+                                                    "eval" "Invalid keyword"
+                                                    '() #f))
+                                     ;; Finished parsing keywords. Fill in
+                                     ;; uninitialized kwargs by evalling init
+                                     ;; expressions in their appropriate
+                                     ;; environment.
+                                     (let lp ((i (- imax kw-base))
+                                              (inits inits))
+                                       (if (pair? inits)
+                                           (let ((tail (list-tail env i)))
+                                             (if (eq? (car tail) unbound-arg)
+                                                 (set-car! tail
+                                                           (eval (car inits)
+                                                                 (cdr tail))))
+                                             (lp (1- i) (cdr inits)))
+                                           ;; Finally, eval the body.
+                                           (eval body env)))))))))))))))
 
     ;; The "engine". EXP is a memoized expression.
     (define (eval exp env)