summaryrefslogtreecommitdiff
diff options
context:
space:
mode:
-rw-r--r--module/ice-9/eval.scm74
-rw-r--r--test-suite/tests/goops.test4
-rw-r--r--test-suite/tests/hooks.test7
3 files changed, 55 insertions, 30 deletions
diff --git a/module/ice-9/eval.scm b/module/ice-9/eval.scm
index e2746dce8..e82ebe446 100644
--- a/module/ice-9/eval.scm
+++ b/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,26 +178,8 @@
(cons (eval (car inits) env) new-env)))))
(('lambda (nreq rest? . body))
- (let ((env (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))))))))
-
+ (make-closure eval nreq rest? body (capture-env env)))
+
(('quote x)
x)
diff --git a/test-suite/tests/goops.test b/test-suite/tests/goops.test
index f2ae2b717..908d1e7ae 100644
--- a/test-suite/tests/goops.test
+++ b/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> ()
diff --git a/test-suite/tests/hooks.test b/test-suite/tests/hooks.test
index 3e0787685..0987f8c3c 100644
--- a/test-suite/tests/hooks.test
+++ b/test-suite/tests/hooks.test
@@ -52,12 +52,7 @@
(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)))
+ (add-hook! x bad-proc)))
(pass-if-exception "illegal hook"
exception:wrong-type-arg
(add-hook! '(foo) proc1)))