mirror/guile
mirror/guile
1
Fork 0
mirror of https://git.savannah.gnu.org/git/guile.git synced 2025-06-16 16:50:21 +02:00
Code Activity

primitive support for lambda*

Browse source 
* libguile/memoize.c (scm_m_lambda_star): Define lambda* in the
  pre-psyntax env, and make it memoize lambda* expressions.

* libguile/eval.c (BOOT_CLOSURE_PARSE_FULL): New helper.
  (error_invalid_keyword, error_unrecognized_keyword): New helpers.
  (prepare_boot_closure_env_for_apply): Flesh out application of boot
  closures with "full" arity.
  (prepare_boot_closure_env_for_eval): Punt to
  prepare_boot_closure_env_for_eval for the full-arity case.

* module/ice-9/eval.scm (make-fixed-closure): Rename from `closure', and
  just handle fixed arities, where there is no rest argument..
  (make-general-closure): New helper, a procedure, that returns a
  closure that can take rest, optional, and keyword arguments.
  (eval): Adapt to call make-fixed-closure or make-general-closure as
  appropriate.

* test-suite/tests/optargs.test ("lambda* inits"): Test the memoizer as
  well.
This commit is contained in:
Andy Wingo 2010-05-13 17:15:10 +02:00
parent 9658182d5f
commit d8a071fc4e
4 changed files with 472 additions and 31 deletions
Download patch file Download diff file Expand all files Collapse all files

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

@ -55,7 +55,8 @@
(and (current-module) the-root-module)
env)))))
(define-syntax make-closure
;; Fast case for procedures with fixed arities.
(define-syntax make-fixed-closure
(lambda (x)
(define *max-static-argument-count* 8)
(define (make-formals n)
@ -66,22 +67,17 @@
(string (integer->char (+ (char->integer #\a) i))))))
(iota n)))
(syntax-case x ()
((_ eval nreq rest? body env) (not (identifier? #'env))
((_ eval nreq body env) (not (identifier? #'env))
#'(let ((e env))
(make-closure eval nreq rest? body e)))
((_ eval nreq rest? body env)
(make-fixed-closure eval nreq body e)))
((_ eval nreq 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)))))))
(lambda (#,@formals)
(eval body
(cons* #,@(reverse formals) env))))))
(iota *max-static-argument-count*))
(else
#,(let ((formals (make-formals *max-static-argument-count*)))
@ -91,13 +87,11 @@
(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)
new-env
(scm-error 'wrong-number-of-args
"eval" "Wrong number of arguments"
'() #f)))
(if (null? args)
(scm-error 'wrong-number-of-args
"eval" "Wrong number of arguments"
@ -218,6 +212,114 @@
(define primitive-eval
(let ()
;; We pre-generate procedures with fixed arities, up to some number of
;; arguments; see make-fixed-closure above.
;; A unique marker for unbound keywords.
(define unbound-arg (list 'unbound-arg))
;; Procedures with rest, optional, or keyword arguments.
(define (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)
(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)
(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)
(memoized-expression-case exp
@ -256,9 +358,13 @@
(cons (eval (car inits) env) new-env)))))
(('lambda (body nreq . tail))
(make-closure eval nreq (and (pair? tail) (car tail))
body (capture-env env)))
(if (null? tail)
(make-fixed-closure eval nreq body (capture-env env))
(if (null? (cdr tail))
(make-general-closure (capture-env env) body nreq (car tail)
0 #f '() #f)
(apply make-general-closure (capture-env env) body nreq tail))))
(('begin (first . rest))
(let lp ((first first) (rest rest))
(if (null? rest)