Re: Commercial development

[Neil Jerram]

Neil Jerram wrote:
> How about the attached?  The scm_reverse_x is annoying, but removing it
> would require [...] constructing the list backwards in eval_letrec_inits - 
> but I can't
> see a way of doing that.

I worked the list construction out at last, so I think the attached is
good to go now.  OK to commit?

        Neil

cvs server: Diffing libguile
Index: libguile/ChangeLog
===================================================================
RCS file: /cvsroot/guile/guile/guile-core/libguile/ChangeLog,v
retrieving revision 1.2293
diff -u -u -r1.2293 ChangeLog
--- libguile/ChangeLog  18 Jul 2005 13:55:44 -0000      1.2293
+++ libguile/ChangeLog  18 Jul 2005 20:49:06 -0000
@@ -1,3 +1,8 @@
+2005-07-18  Neil Jerram  <address@hidden>
+
+       * eval.c (eval_letrec_inits): New.
+       (CEVAL): Eval letrec initializer forms using eval_letrec_inits.
+
 2005-07-18  Mikael Djurfeldt  <address@hidden>
 
        Some changes towards making it possible to run Guile on the EM64T
Index: libguile/eval.c
===================================================================
RCS file: /cvsroot/guile/guile/guile-core/libguile/eval.c,v
retrieving revision 1.398
diff -u -u -r1.398 eval.c
--- libguile/eval.c     12 Jul 2005 00:28:09 -0000      1.398
+++ libguile/eval.c     18 Jul 2005 20:49:08 -0000
@@ -96,6 +96,7 @@
 static SCM canonicalize_define (SCM expr);
 static SCM *scm_lookupcar1 (SCM vloc, SCM genv, int check);
 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 @@
   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 */
 
 
@@ -3563,21 +3588,10 @@
           x = SCM_CDR (x);
           {
             SCM init_forms = SCM_CAR (x);
-            SCM init_values = SCM_EOL;
-            do
-              {
-                init_values = scm_cons (EVALCAR (init_forms, env), 
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);
+           SCM init_values = scm_list_1 (SCM_BOOL_T);
+           SCM *init_values_eol = SCM_CDRLOC (init_values);
+           eval_letrec_inits (env, init_forms, &init_values_eol);
+            SCM_SETCDR (SCM_CAR (env), SCM_CDR (init_values));
           }
           x = SCM_CDR (x);
           PREP_APPLY (SCM_UNDEFINED, SCM_EOL);
cvs server: Diffing libguile-ltdl
cvs server: Diffing libguile-ltdl/upstream
cvs server: Diffing libltdl
cvs server: Diffing oop
cvs server: Diffing oop/goops
cvs server: Diffing qt
cvs server: Diffing qt/md
cvs server: Diffing qt/time
cvs server: Diffing scripts
cvs server: Diffing srfi
cvs server: Diffing test-suite
Index: test-suite/ChangeLog
===================================================================
RCS file: /cvsroot/guile/guile/guile-core/test-suite/ChangeLog,v
retrieving revision 1.354
diff -u -u -r1.354 ChangeLog
--- test-suite/ChangeLog        12 Jun 2005 12:31:52 -0000      1.354
+++ test-suite/ChangeLog        18 Jul 2005 20:49:08 -0000
@@ -1,3 +1,7 @@
+2005-07-18  Neil Jerram  <address@hidden>
+
+       * tests/r5rs_pitfall.test (1.1): Now passes.
+
 2005-06-12  Marius Vollmer  <address@hidden>
 
        * standalone/test-gh.c: Do nothing when deprecated things are
cvs server: Diffing test-suite/standalone
cvs server: Diffing test-suite/tests
Index: test-suite/tests/r5rs_pitfall.test
===================================================================
RCS file: /cvsroot/guile/guile/guile-core/test-suite/tests/r5rs_pitfall.test,v
retrieving revision 1.6
diff -u -u -r1.6 r5rs_pitfall.test
--- test-suite/tests/r5rs_pitfall.test  5 Jun 2005 20:54:19 -0000       1.6
+++ test-suite/tests/r5rs_pitfall.test  18 Jul 2005 20:49:08 -0000
@@ -18,8 +18,6 @@
 ;; These tests have been copied from
 ;; http://sisc.sourceforge.net/r5rs_pitfall.scm and the 'should-be'
 ;; 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)
   :use-syntax (ice-9 syncase)
@@ -48,9 +46,7 @@
 ;; defines in letrec body 
 ;; 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-but-isnt 1.1 0
+(should-be 1.1 0
  (let ((cont #f))
    (letrec ((x (call-with-current-continuation (lambda (c) (set! cont c) 0)))
             (y (call-with-current-continuation (lambda (c) (set! cont c) 0))))
cvs server: Diffing test-suite/tests/c-api