mirror/guile
mirror/guile
1
Fork 0
mirror of https://git.savannah.gnu.org/git/guile.git synced 2025-06-25 04:40:19 +02:00
Code Activity

* eval.c (eval_letrec_inits): New.

Browse source 
(CEVAL): Eval letrec initializer forms using eval_letrec_inits.

* tests/r5rs_pitfall.test (1.1): Now passes.
This commit is contained in:
Neil Jerram 2005-08-15 20:43:16 +00:00
parent e4bf1d1181
commit 5defc05d45
4 changed files with 39 additions and 20 deletions
Download patch file Download diff file Expand all files Collapse all files

5
libguile/ChangeLog
View file

@ -1,3 +1,8 @@
2005-08-15 Neil Jerram <neil@ossau.uklinux.net>
* eval.c (eval_letrec_inits): New.
(CEVAL): Eval letrec initializer forms using eval_letrec_inits.
2005-08-12 Marius Vollmer <mvo@zagadka.de> 2005-08-12 Marius Vollmer <mvo@zagadka.de>
* numbers.c: Use scm_from_bool instead of SCM_BOOL. Thanks to * numbers.c: Use scm_from_bool instead of SCM_BOOL. Thanks to

44
libguile/eval.c
View file

@ -96,6 +96,7 @@ static SCM unmemoize_exprs (SCM expr, SCM env);
static SCM canonicalize_define (SCM expr); static SCM canonicalize_define (SCM expr);
static SCM *scm_lookupcar1 (SCM vloc, SCM genv, int check); static SCM *scm_lookupcar1 (SCM vloc, SCM genv, int check);
static SCM unmemoize_builtin_macro (SCM expr, SCM env); static SCM unmemoize_builtin_macro (SCM expr, SCM env);
static void eval_letrec_inits (SCM env, SCM init_forms, SCM **init_values_eol);
@ -3148,6 +3149,30 @@ deval_args (SCM l, SCM env, SCM proc, SCM *lloc)
return *results; return *results;
} }
static void
eval_letrec_inits (SCM env, SCM init_forms, SCM **init_values_eol)
{
SCM argv[10];
int i = 0, imax = sizeof (argv) / sizeof (SCM);
while (!scm_is_null (init_forms))
{
if (imax == i)
{
eval_letrec_inits (env, init_forms, init_values_eol);
break;
}
argv[i++] = EVALCAR (init_forms, env);
init_forms = SCM_CDR (init_forms);
}
for (i--; i >= 0; i--)
{
**init_values_eol = scm_list_1 (argv[i]);
*init_values_eol = SCM_CDRLOC (**init_values_eol);
}
}
#endif /* !DEVAL */ #endif /* !DEVAL */
@ -3563,21 +3588,10 @@ dispatch:
x = SCM_CDR (x); x = SCM_CDR (x);
{ {
SCM init_forms = SCM_CAR (x); SCM init_forms = SCM_CAR (x);
SCM init_values = SCM_EOL; SCM init_values = scm_list_1 (SCM_BOOL_T);
do SCM *init_values_eol = SCM_CDRLOC (init_values);
{ eval_letrec_inits (env, init_forms, &init_values_eol);
init_values = scm_cons (EVALCAR (init_forms, env), init_values); SCM_SETCDR (SCM_CAR (env), SCM_CDR (init_values));
init_forms = SCM_CDR (init_forms);
}
while (!scm_is_null (init_forms));
/* In order to make case 1.1 of the R5RS pitfall testsuite
succeed, we would need to copy init_values here like
so:
init_values = scm_list_copy (init_values);
*/
SCM_SETCDR (SCM_CAR (env), init_values);
} }
x = SCM_CDR (x); x = SCM_CDR (x);
PREP_APPLY (SCM_UNDEFINED, SCM_EOL); PREP_APPLY (SCM_UNDEFINED, SCM_EOL);

4
test-suite/ChangeLog
View file

@ -1,3 +1,7 @@
2005-08-15 Neil Jerram <neil@ossau.uklinux.net>
* tests/r5rs_pitfall.test (1.1): Now passes.
2005-08-01 Marius Vollmer <mvo@zagadka.de> 2005-08-01 Marius Vollmer <mvo@zagadka.de>

6
test-suite/tests/r5rs_pitfall.test
View file

@ -18,8 +18,6 @@
;; These tests have been copied from ;; These tests have been copied from
;; http://sisc.sourceforge.net/r5rs_pitfall.scm and the 'should-be' ;; http://sisc.sourceforge.net/r5rs_pitfall.scm and the 'should-be'
;; macro has been modified to fit into our test suite machinery. ;; macro has been modified to fit into our test suite machinery.
;;
;; Test 1.1 fails, but we expect that.
(define-module (test-suite test-r5rs-pitfall) (define-module (test-suite test-r5rs-pitfall)
:use-syntax (ice-9 syncase) :use-syntax (ice-9 syncase)
@ -48,9 +46,7 @@
;; defines in letrec body ;; defines in letrec body
;; http://groups.google.com/groups?selm=87bsoq0wfk.fsf%40app.dial.idiom.com ;; http://groups.google.com/groups?selm=87bsoq0wfk.fsf%40app.dial.idiom.com
;; See eval.c for how to make this test succeed. Look for "r5rs pitfall". (should-be 1.1 0
(should-be-but-isnt 1.1 0
(let ((cont #f)) (let ((cont #f))
(letrec ((x (call-with-current-continuation (lambda (c) (set! cont c) 0))) (letrec ((x (call-with-current-continuation (lambda (c) (set! cont c) 0)))
(y (call-with-current-continuation (lambda (c) (set! cont c) 0)))) (y (call-with-current-continuation (lambda (c) (set! cont c) 0))))