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

iron out inconsistency between eval and compile expansion

Browse source 
* libguile/expand.c (expand_lambda_star_case): Harmonize with tree-il,
  expanding keywords to (aok? (kw name gensym) ...), not
  (aok? (kw . index) ...).

* libguile/memoize.c (memoize): Process the (kw name gensym) format into
  (kw . index).

* module/ice-9/psyntax.scm (build-lambda-case): Remove a
  compile-versus-eval special case.

* module/ice-9/psyntax-pp.scm: Regenerate.
This commit is contained in:
Andy Wingo 2010-05-20 12:53:21 +02:00
parent a310a1d12e
commit 632ddbf02b
4 changed files with 8277 additions and 8462 deletions
Download patch file Download diff file Expand all files Collapse all files

14
libguile/expand.c
View file

@ -693,7 +693,7 @@ static SCM
expand_lambda_star_case (SCM clause, SCM alternate, SCM env)
{
SCM req, opt, kw, allow_other_keys, rest, formals, vars, body, tmp;
SCM inits, kw_indices;
SCM inits;
int nreq, nopt;
const long length = scm_ilength (clause);
@ -807,14 +807,12 @@ expand_lambda_star_case (SCM clause, SCM alternate, SCM env)
env = scm_acons (rest, CAR (vars), env);
}
/* Build up kw inits, env, and kw-indices alist */
/* Build up kw inits, env, and kw-canon list */
if (scm_is_null (kw))
kw = SCM_BOOL_F;
else
{
int idx = nreq + nopt + (scm_is_true (rest) ? 1 : 0);
kw_indices = SCM_EOL;
SCM kw_canon = SCM_EOL;
kw = scm_reverse_x (kw, SCM_UNDEFINED);
for (tmp = kw; scm_is_pair (tmp); tmp = scm_cdr (tmp))
{
@ -842,13 +840,13 @@ expand_lambda_star_case (SCM clause, SCM alternate, SCM env)
else
syntax_error (s_bad_formals, CAR (clause), SCM_UNDEFINED);
kw_indices = scm_acons (k, SCM_I_MAKINUM (idx++), kw_indices);
inits = scm_cons (expand (init, env), inits);
vars = scm_cons (scm_gensym (SCM_UNDEFINED), vars);
kw_canon = scm_cons (scm_list_3 (k, sym, CAR (vars)), kw_canon);
env = scm_acons (sym, CAR (vars), env);
}
kw_indices = scm_reverse_x (kw_indices, SCM_UNDEFINED);
kw = scm_cons (allow_other_keys, kw_indices);
kw_canon = scm_reverse_x (kw_canon, SCM_UNDEFINED);
kw = scm_cons (allow_other_keys, kw_canon);
}
/* We should check for no duplicates, but given that psyntax does this

19
libguile/memoize.c
View file

@ -273,7 +273,7 @@ memoize (SCM exp, SCM env)
{
SCM req, rest, opt, kw, inits, vars, body, alt;
SCM walk, minits, arity, new_env;
int nreq, nopt;
int nreq, nopt, ntotal;
req = REF (exp, LAMBDA_CASE, REQ);
rest = REF (exp, LAMBDA_CASE, REST);
@ -286,6 +286,7 @@ memoize (SCM exp, SCM env)
nreq = scm_ilength (req);
nopt = scm_is_pair (opt) ? scm_ilength (opt) : 0;
ntotal = scm_ilength (vars);
/* The vars are the gensyms, according to the divine plan. But we need
to memoize the inits within their appropriate environment,
@ -319,6 +320,22 @@ memoize (SCM exp, SCM env)
minits = scm_reverse_x (minits, SCM_UNDEFINED);
if (scm_is_true (kw))
{
/* (aok? (kw name sym) ...) -> (aok? (kw . index) ...) */
SCM aok = CAR (kw), indices = SCM_EOL;
for (kw = CDR (kw); scm_is_pair (kw); kw = CDR (kw))
{
SCM k;
int idx;
k = CAR (CAR (kw));
idx = ntotal - 1 - lookup (CADDR (CAR (kw)), new_env);
indices = scm_acons (k, SCM_I_MAKINUM (idx), indices);
}
kw = scm_cons (aok, scm_reverse_x (indices, SCM_UNDEFINED));
}
if (scm_is_false (alt) && scm_is_false (kw) && scm_is_false (opt))
{
if (scm_is_false (rest))

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

File diff suppressed because it is too large Load diff

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

@ -460,31 +460,7 @@
;; the body of a lambda: anything, already expanded
;; else: lambda-case | #f
(lambda (src req opt rest kw inits vars body else-case)
;; FIXME!!!
(case (fluid-ref *mode*)
((c)
((@ (language tree-il) make-lambda-case)
src req opt rest kw inits vars body else-case))
(else
;; Very much like the logic of (language tree-il compile-glil).
(let* ((nreq (length req))
(nopt (if opt (length opt) 0))
(rest-idx (and rest (+ nreq nopt)))
(allow-other-keys? (if kw (car kw) #f))
(kw-indices (map (lambda (x)
;; (,key ,name ,var)
(cons (car x) (list-index vars (caddr x))))
(if kw (cdr kw) '())))
(nargs (apply max (+ nreq nopt (if rest 1 0))
(map 1+ (map cdr kw-indices)))))
(or (= nargs
(length vars)
(+ nreq (length inits) (if rest 1 0)))
(error "something went wrong"
req opt rest kw inits vars nreq nopt kw-indices nargs))
(make-lambda-case src req opt rest
(and kw (cons allow-other-keys? kw-indices))
inits vars body else-case))))))
(make-lambda-case src req opt rest kw inits vars body else-case)))
(define build-primref
(lambda (src name)