interpreted closures cons less.

* module/ice-9/eval.scm (primitive-eval): When making a closure with N
  formals, actuall return a closure with N formals, if N is less than
  *max-static-argument-count*, which currently is 8. If N is greater
  than 8, do the arg-parsing loop as we did before. Requires some
  macrology, but should reduce unnecessary consing for interpreted
  closures.

* test-suite/tests/goops.test:
* test-suite/tests/hooks.test: Now that checks like (thunk? foo) are
  going to work as a for interpreted code, remove some (throw
  'unresolved).

module/ice-9/eval.scm

@@ -55,6 +55,58 @@
                (and (current-module) the-root-module)
                env)))))
 
+  (define *max-static-argument-count* 8)
+
+  (define-syntax make-closure
+    (lambda (x)
+      (define (make-formals n)
+        (map (lambda (i)
+               (datum->syntax
+                x 
+                (string->symbol
+                 (string (integer->char (+ (char->integer #\a) i))))))
+             (iota n)))
+      (syntax-case x ()
+        ((_ eval nreq rest? body env) (not (identifier? #'env))
+         #'(let ((e env))
+             (make-closure eval nreq rest? body e)))
+        ((_ eval nreq rest? body env)
+         #`(case nreq
+             #,@(map (lambda (nreq)
+                       (let ((formals (make-formals nreq)))
+                         #`((#,nreq)
+                            (if rest?
+                                (lambda (#,@formals . rest)
+                                  (eval body
+                                        (cons* rest #,@(reverse formals)
+                                               env)))
+                                (lambda (#,@formals)
+                                  (eval body
+                                        (cons* #,@(reverse formals) env)))))))
+                     (iota *max-static-argument-count*))
+             (else
+              #,(let ((formals (make-formals *max-static-argument-count*)))
+                  #`(lambda (#,@formals . more)
+                      (let lp ((new-env (cons* #,@(reverse formals) env))
+                               (nreq (- nreq #,*max-static-argument-count*))
+                               (args more))
+                        (if (zero? nreq)
+                            (eval body
+                                  (if rest?
+                                      (cons args new-env)
+                                      (if (not (null? args))
+                                          (scm-error 'wrong-number-of-args
+                                                     "eval" "Wrong number of arguments"
+                                                     '() #f)
+                                          new-env)))
+                            (if (null? args)
+                                (scm-error 'wrong-number-of-args
+                                           "eval" "Wrong number of arguments"
+                                           '() #f)
+                                (lp (cons (car args) new-env)
+                                    (1- nreq)
+                                    (cdr args)))))))))))))
+
   ;; This macro could be more straightforward if the compiler had better
   ;; copy propagation. As it is we do some copy propagation by hand.
   (define-syntax mx-bind
@@ -126,25 +178,7 @@
                    (cons (eval (car inits) env) new-env)))))
       
         (('lambda (nreq rest? . body))
-         (let ((env (capture-env env)))
+         (make-closure eval nreq rest? body (capture-env env)))
-           (lambda args
-             (let lp ((env env) (nreq nreq) (args args))
-               (if (zero? nreq)
-                   (eval body
-                         (if rest?
-                             (cons args env)
-                             (if (not (null? args))
-                                 (scm-error 'wrong-number-of-args
-                                            "eval" "Wrong number of arguments"
-                                            '() #f)
-                                 env)))
-                   (if (null? args)
-                       (scm-error 'wrong-number-of-args
-                                  "eval" "Wrong number of arguments"
-                                  '() #f)
-                       (lp (cons (car args) env)
-                           (1- nreq)
-                           (cdr args))))))))
         
         (('quote x)
          x)

test-suite/tests/goops.test

@@ -167,10 +167,6 @@
 
     (expect-fail "bad init-thunk"
 		 (begin
-                   ;; Currently UPASSing because we can't usefully get
-                   ;; any arity information out of interpreted
-                   ;; procedures. A FIXME I guess.
-                   (throw 'unresolved)
                    (catch #t
                      (lambda ()
                        (eval '(define-class <foo> ()

test-suite/tests/hooks.test

@@ -52,11 +52,6 @@
 		     (pass-if-exception "illegal proc"
 		       exception:wrong-type-arg
 		       (let ((x (make-hook 1)))
-                         ;; Currently fails to raise an exception
-                         ;; because we can't usefully get any arity
-                         ;; information out of interpreted procedures. A
-                         ;; FIXME I guess.
-                         (throw 'unresolved)
                          (add-hook! x bad-proc)))
 		     (pass-if-exception "illegal hook"
 		       exception:wrong-type-arg