summaryrefslogtreecommitdiff
path: root/module/ice-9/eval.scm
diff options
context:
space:
mode:
Diffstat (limited to 'module/ice-9/eval.scm')
-rw-r--r--module/ice-9/eval.scm50
1 files changed, 41 insertions, 9 deletions
diff --git a/module/ice-9/eval.scm b/module/ice-9/eval.scm
index e82ebe446..b3721e4e2 100644
--- a/module/ice-9/eval.scm
+++ b/module/ice-9/eval.scm
@@ -55,10 +55,9 @@
(and (current-module) the-root-module)
env)))))
- (define *max-static-argument-count* 8)
-
(define-syntax make-closure
(lambda (x)
+ (define *max-static-argument-count* 8)
(define (make-formals n)
(map (lambda (i)
(datum->syntax
@@ -107,6 +106,43 @@
(1- nreq)
(cdr args)))))))))))))
+ (define-syntax call
+ (lambda (x)
+ (define *max-static-call-count* 4)
+ (syntax-case x ()
+ ((_ eval proc nargs args env) (identifier? #'env)
+ #`(case nargs
+ #,@(map (lambda (nargs)
+ #`((#,nargs)
+ (proc
+ #,@(map
+ (lambda (n)
+ (let lp ((n n) (args #'args))
+ (if (zero? n)
+ #`(eval (car #,args) env)
+ (lp (1- n) #`(cdr #,args)))))
+ (iota nargs)))))
+ (iota *max-static-call-count*))
+ (else
+ (apply proc
+ #,@(map
+ (lambda (n)
+ (let lp ((n n) (args #'args))
+ (if (zero? n)
+ #`(eval (car #,args) env)
+ (lp (1- n) #`(cdr #,args)))))
+ (iota *max-static-call-count*))
+ (let lp ((exps #,(let lp ((n *max-static-call-count*)
+ (args #'args))
+ (if (zero? n)
+ args
+ (lp (1- n) #`(cdr #,args)))))
+ (args '()))
+ (if (null? exps)
+ (reverse args)
+ (lp (cdr exps)
+ (cons (eval (car exps) env) 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
@@ -189,14 +225,10 @@
(('apply (f args))
(apply (eval f env) (eval args env)))
- (('call (f . args))
+ (('call (f nargs . args))
(let ((proc (eval f env)))
- (let eval-args ((in args) (out '()))
- (if (null? in)
- (apply proc (reverse out))
- (eval-args (cdr in)
- (cons (eval (car in) env) out))))))
-
+ (call eval proc nargs args env)))
+
(('call/cc proc)
(call/cc (eval proc env)))