mirror/guile
mirror/guile
1
Fork 0
mirror of https://git.savannah.gnu.org/git/guile.git synced 2025-06-24 20:30:28 +02:00
Code Activity

evaluator support for case-lambda

Browse source 
* libguile/memoize.c (patch_case_lambda, scm_m_case_lambda)
  (scm_m_case_lambda_star): Add memoizers for case-lambda and
  case-lambda*.
  (unmemoize): Unmemoize lambdas with multiple arities.

* libguile/eval.c (prepare_boot_closure_env_for_apply):
  (prepare_boot_closure_env_for_eval): Adapt to return both body and
  env, so that case-lambda clauses can be selected appropriately.
  (eval, boot_closure_apply): Adapt callers.

* module/ice-9/eval.scm (make-general-closure): Support multiple
  arities.
This commit is contained in:
Andy Wingo 2010-05-13 21:43:35 +02:00
parent d8a071fc4e
commit 7572ee5261
3 changed files with 158 additions and 45 deletions
Download patch file Download diff file Expand all files Collapse all files

32
module/ice-9/eval.scm
View file

@ -218,20 +218,26 @@
;; A unique marker for unbound keywords.
(define unbound-arg (list 'unbound-arg))
;; Procedures with rest, optional, or keyword arguments.
;; Procedures with rest, optional, or keyword arguments, potentially with
;; multiple arities, as with case-lambda.
(define (make-general-closure env body nreq rest? nopt kw inits alt)
(lambda args
(define alt-proc
(and alt
(apply make-general-closure env (memoized-expression-data alt))))
(lambda %args
(let lp ((env env)
(nreq nreq)
(args args))
(if (> nreq 0)
(nreq* nreq)
(args %args))
(if (> nreq* 0)
;; First, bind required arguments.
(if (null? args)
(scm-error 'wrong-number-of-args
"eval" "Wrong number of arguments"
'() #f)
(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)
(1- nreq*)
(cdr args)))
;; Move on to optional arguments.
(if (not kw)
@ -245,9 +251,11 @@
(eval body (cons args env))
(if (null? args)
(eval body env)
(scm-error 'wrong-number-of-args
"eval" "Wrong number of arguments"
'() #f)))
(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))