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

psyntax, primitive expander, and memoizer support for letrec*

Browse source 
* libguile/expand.c (expand_letrec_helper): Factor out common code.
  (expand_letrec): Use expand_letrec_helper.
  (expand_letrec_star): New primitive syntax: letrec*.

* libguile/memoize.c (memoize): Add memoizer support for in-order letrec
  (letrec*).

* module/ice-9/psyntax.scm (build-letrec): Another arg, `in-order?'.
  (chi-body): Adapt to build-letrec change. We don't yet use letrec* for
  internal definitions.
  (letrec): Adapt to build-letrec change.
  (letrec*): New expander.

* module/ice-9/psyntax-pp.scm: Regenerated.
This commit is contained in:
Andy Wingo 2010-06-17 11:12:58 +02:00
parent fb6e61ca21
commit 826373a25d
4 changed files with 3316 additions and 3180 deletions
Download patch file Download diff file Expand all files Collapse all files

17
libguile/expand.c
View file

@ -163,6 +163,7 @@ SCM_SYNTAX ("set!", expand_set_x);
SCM_SYNTAX ("and", expand_and);
SCM_SYNTAX ("cond", expand_cond);
SCM_SYNTAX ("letrec", expand_letrec);
SCM_SYNTAX ("letrec*", expand_letrec_star);
SCM_SYNTAX ("let*", expand_letstar);
SCM_SYNTAX ("or", expand_or);
SCM_SYNTAX ("lambda*", expand_lambda_star);
@ -1030,7 +1031,7 @@ expand_let (SCM expr, SCM env)
}
static SCM
expand_letrec (SCM expr, SCM env)
expand_letrec_helper (SCM expr, SCM env, SCM in_order_p)
{
SCM bindings;
@ -1048,12 +1049,24 @@ expand_letrec (SCM expr, SCM env)
SCM var_names, var_syms, inits;
transform_bindings (bindings, expr, &var_names, &var_syms, &inits);
env = expand_env_extend (env, var_names, var_syms);
return LETREC (SCM_BOOL_F, SCM_BOOL_F,
return LETREC (SCM_BOOL_F, in_order_p,
var_names, var_syms, expand_exprs (inits, env),
expand_sequence (CDDR (expr), env));
}
}
static SCM
expand_letrec (SCM expr, SCM env)
{
return expand_letrec_helper (expr, env, SCM_BOOL_F);
}
static SCM
expand_letrec_star (SCM expr, SCM env)
{
return expand_letrec_helper (expr, env, SCM_BOOL_T);
}
static SCM
expand_letstar_clause (SCM bindings, SCM body, SCM env SCM_UNUSED)
{

47
libguile/memoize.c
View file

@ -374,33 +374,50 @@ memoize (SCM exp, SCM env)
case SCM_EXPANDED_LETREC:
{
SCM vars, exps, body, undefs, inits, sets, new_env;
int i, nvars;
SCM vars, exps, body, undefs, new_env;
int i, nvars, in_order_p;
vars = REF (exp, LETREC, GENSYMS);
exps = REF (exp, LETREC, VALS);
body = REF (exp, LETREC, BODY);
in_order_p = scm_is_true (REF (exp, LETREC, IN_ORDER_P));
nvars = i = scm_ilength (vars);
inits = undefs = sets = SCM_EOL;
undefs = SCM_EOL;
new_env = env;
for (; scm_is_pair (vars); vars = CDR (vars), i--)
for (; scm_is_pair (vars); vars = CDR (vars))
{
new_env = scm_cons (CAR (vars), new_env);
undefs = scm_cons (MAKMEMO_QUOTE (SCM_UNDEFINED), undefs);
sets = scm_cons (MAKMEMO_LEX_SET ((i-1) + nvars,
MAKMEMO_LEX_REF (i-1)),
sets);
}
for (; scm_is_pair (exps); exps = CDR (exps))
inits = scm_cons (memoize (CAR (exps), new_env), inits);
inits = scm_reverse_x (inits, SCM_UNDEFINED);
return MAKMEMO_LET
(undefs,
MAKMEMO_BEGIN (scm_list_2 (MAKMEMO_LET (inits, MAKMEMO_BEGIN (sets)),
memoize (body, new_env))));
if (in_order_p)
{
SCM body_exps = SCM_EOL;
for (; scm_is_pair (exps); exps = CDR (exps), i--)
body_exps = scm_cons (MAKMEMO_LEX_SET (i-1,
memoize (CAR (exps), new_env)),
body_exps);
body_exps = scm_cons (memoize (body, new_env), body_exps);
body_exps = scm_reverse_x (body_exps, SCM_UNDEFINED);
return MAKMEMO_LET (undefs, MAKMEMO_BEGIN (body_exps));
}
else
{
SCM sets = SCM_EOL, inits = SCM_EOL;
for (; scm_is_pair (exps); exps = CDR (exps), i--)
{
sets = scm_cons (MAKMEMO_LEX_SET ((i-1) + nvars,
MAKMEMO_LEX_REF (i-1)),
sets);
inits = scm_cons (memoize (CAR (exps), new_env), inits);
}
inits = scm_reverse_x (inits, SCM_UNDEFINED);
return MAKMEMO_LET
(undefs,
MAKMEMO_BEGIN (scm_list_2 (MAKMEMO_LET (inits, MAKMEMO_BEGIN (sets)),
memoize (body, new_env))));
}
}
case SCM_EXPANDED_DYNLET:

6403
module/ice-9/psyntax-pp.scm
View file

File diff suppressed because it is too large Load diff

29
module/ice-9/psyntax.scm
View file

@ -526,12 +526,12 @@
val-exps))))))
(define build-letrec
(lambda (src ids vars val-exps body-exp)
(lambda (src in-order? ids vars val-exps body-exp)
(if (null? vars)
body-exp
(begin
(for-each maybe-name-value! ids val-exps)
(make-letrec src #f ids vars val-exps body-exp)))))
(make-letrec src in-order? ids vars val-exps body-exp)))))
;; FIXME: use a faster gensym
@ -1483,7 +1483,7 @@
(loop (cdr bs) er r-cache))
(loop (cdr bs) er-cache r-cache)))))
(set-cdr! r (extend-env labels bindings (cdr r)))
(build-letrec no-source
(build-letrec no-source #f
(map syntax->datum var-ids)
vars
(map (lambda (x)
@ -2103,7 +2103,7 @@
(new-vars (map gen-var ids)))
(let ((w (make-binding-wrap ids labels w))
(r (extend-var-env labels new-vars r)))
(build-letrec s
(build-letrec s #f
(map syntax->datum ids)
new-vars
(map (lambda (x) (chi x r w mod)) #'(val ...))
@ -2112,6 +2112,27 @@
(_ (syntax-violation 'letrec "bad letrec" (source-wrap e w s mod))))))
(global-extend 'core 'letrec*
(lambda (e r w s mod)
(syntax-case e ()
((_ ((id val) ...) e1 e2 ...)
(and-map id? #'(id ...))
(let ((ids #'(id ...)))
(if (not (valid-bound-ids? ids))
(syntax-violation 'letrec* "duplicate bound variable" e)
(let ((labels (gen-labels ids))
(new-vars (map gen-var ids)))
(let ((w (make-binding-wrap ids labels w))
(r (extend-var-env labels new-vars r)))
(build-letrec s #t
(map syntax->datum ids)
new-vars
(map (lambda (x) (chi x r w mod)) #'(val ...))
(chi-body #'(e1 e2 ...)
(source-wrap e w s mod) r w mod)))))))
(_ (syntax-violation 'letrec* "bad letrec*" (source-wrap e w s mod))))))
(global-extend 'core 'set!
(lambda (e r w s mod)
(syntax-case e ()