Import Upstream version 5e3upstream/5e3

1 files changed, 104 insertions, 87 deletions

diff --git a/eval.c b/eval.c
index 778d7e4..e616382 100644
--- a/eval.c
+++ b/eval.c
@@ -1,4 +1,4 @@
-/* Copyright (C) 1990, 1991, 1992, 1993, 1994, 1995, 1997, 1998, 1999, 2002 Free Software Foundation, Inc.
+/* Copyright (C) 1990, 1991, 1992, 1993, 1994, 1995, 1997, 1998, 1999, 2002, 2006 Free Software Foundation, Inc.
  *
  * This program is free software; you can redistribute it and/or modify
  * it under the terms of the GNU General Public License as published by
@@ -781,6 +781,12 @@ SCM eval_args(l)
 	return res;
 }
 
+/*
+  Evaluate each expression in argument list x,
+  and return a list allocated in the ecache of the
+  results.
+  The result is left in scm_env_tmp.
+*/
 static void ecache_evalx(x)
      SCM x;
 {
@@ -798,6 +804,34 @@ static void ecache_evalx(x)
   ENV_V2LST((long)i, argv);
 }
 
+/*
+  Allocate a list of UNDEFINED in the ecache, one
+  for each element of the argument list x.
+  The result is left in scm_env_tmp.
+*/
+static void ecache_undefs(x)
+     SCM x;
+{
+  static SCM argv[10] = {UNDEFINED, UNDEFINED, UNDEFINED,
+                         UNDEFINED, UNDEFINED, UNDEFINED, 
+                         UNDEFINED, UNDEFINED, UNDEFINED,
+                         UNDEFINED};
+
+  int imax = sizeof(argv)/sizeof(SCM);
+  int i = 0;
+    
+  scm_env_tmp = EOL;
+  while NIMP(x) {
+    if (imax==i) {
+      ecache_undefs(x);
+      break;
+    }
+    i++;
+    x = CDR(x);
+  }
+  ENV_V2LST((long)i, argv);
+}
+
 /* result is 1 if right number of arguments, 0 otherwise,
    environment frame is put in scm_env_tmp */
 static int ecache_eval_args(proc, arg1, arg2, arg3, x)
@@ -1645,11 +1679,7 @@ static SCM m_body(xorig, env, ctxt)
       break;
     }
   }
-#ifdef CAUTIOUS
-  ASSYNT(ilength(x) > 0, xorig, s_body, what);
-#else
   ASSYNT(ilength(x) > 0, xorig, s_body, what);
-#endif
   if (IMP(defs)) return x;
   return cons(m_letrec1(IM_DEFINE, cons2(i_define, defs, x), env, ctxt), EOL);
 }
@@ -2046,6 +2076,48 @@ SCM scm_eval_values(x, env, valenv)
   return res;
 }
 
+SCM scm_apply_cxr(proc, arg1)
+     SCM proc, arg1;
+{
+  double y;
+#ifdef FLOATS
+  if (SUBRF(proc)) {
+    if (INUMP(arg1)) {
+      y = DSUBRF(proc)((double) INUM(arg1));
+      goto ret;
+    }
+    ASRTGO(NIMP(arg1), floerr);
+    if (REALP(arg1)) {
+      y = DSUBRF(proc)(REALPART(arg1));
+    ret:
+      if (y==y) return makdbl(y, 0.0);
+      goto floerr;
+    }
+# ifdef BIGDIG
+    if (BIGP(arg1)) {
+      y = DSUBRF(proc)(big2dbl(arg1));
+      goto ret;
+    }
+# endif
+  floerr:
+    wta(arg1, (char *)ARG1, SNAME(proc));
+  }
+#endif
+  {
+    int op = CXR_OP(proc);
+#ifndef RECKLESS
+    SCM x = arg1;
+#endif
+    while (op) {
+      ASRTER(NIMP(arg1) && CONSP(arg1),
+	     x, ARG1, SNAME(proc));
+      arg1 = (1 & op ? CAR(arg1) : CDR(arg1));
+      op >>= 2;
+    }
+    return arg1;
+  }
+}
+
 #ifdef __GNUC__
 # define GCC_VERSION (__GNUC__ * 100 + __GNUC_MINOR__)
 /* __GNUC_PATCHLEVEL__ */
@@ -2184,12 +2256,30 @@ static SCM ceval_1(x)
     TRACE(x);
     x = CDR(x);
     STATIC_ENV = CAR(x);
+#if 0    /*
+           The block below signals an error if any variable
+           bound in a LETREC is referenced in any init.
+         */
     scm_env_tmp = undefineds;
     EXTEND_VALENV;
     x = CDR(x);
     ecache_evalx(CAR(x));
     EGC_ROOT(scm_env);
     CAR(scm_env) = scm_env_tmp;
+
+#else  /* The block below implements LETREC* */
+    ecache_undefs(CAR(CAR(x)));
+    EXTEND_VALENV;
+    x = CDR(x);
+    proc = CAR(x);
+    while (NIMP(proc)) {
+      arg1 = EVALCAR(proc);
+      proc = CDR(proc);
+      DEFER_INTS_EGC;
+      CAR(scm_env_tmp) = arg1;
+      scm_env_tmp = CDR(scm_env_tmp);
+    }
+#endif
     scm_env_tmp = EOL;
     goto cdrxbegin;
   case (127 & IM_LETSTAR):
@@ -2308,7 +2398,13 @@ static SCM ceval_1(x)
       x = acro_call(x, STATIC_ENV);
       goto loop;
     case (ISYMNUM(IM_LINUM)):
+#ifndef MEMOIZE_LOCALS
+      x = CDR(x);               /* For non-memoizing case,
+                                   just throw away line number. */
+      goto loop;
+#else
       goto expand;
+#endif
     case (ISYMNUM(IM_DEFINE)):
       x = toplevel_define(x, STATIC_ENV);
       goto retx;
@@ -2459,34 +2555,7 @@ evap1:
     case tc7_subr_1o:
       return SUBRF(proc)(arg1);
     case tc7_cxr:
-#ifdef FLOATS
-      if (SUBRF(proc)) {
-	if (INUMP(arg1))
-	  return makdbl(DSUBRF(proc)((double) INUM(arg1)), 0.0);
-	ASRTGO(NIMP(arg1), floerr);
-	if (REALP(arg1))
-	  return makdbl(DSUBRF(proc)(REALPART(arg1)), 0.0);
-# ifdef BIGDIG
-	if (BIGP(arg1))
-	  return makdbl(DSUBRF(proc)(big2dbl(arg1)), 0.0);
-# endif
-      floerr:
-	wta(arg1, (char *)ARG1, SNAME(proc));
-      }
-#endif
-      {
-	int op = CXR_OP(proc);
-#ifndef RECKLESS
-	x = arg1;
-#endif
-	while (op) {
-	  ASRTER(NIMP(arg1) && CONSP(arg1),
-		 x, ARG1, SNAME(proc));
-	  arg1 = (1 & op ? CAR(arg1) : CDR(arg1));
-	  op >>= 2;
-	}
-	return arg1;
-      }
+      return scm_apply_cxr(proc, arg1);
     case tc7_rpsubr:
       return BOOL_T;
     case tc7_asubr:
@@ -2873,34 +2942,7 @@ SCM apply(proc, arg1, args)
     return SUBRF(proc)(arg1);
   case tc7_cxr:
     ASRTGO(NULLP(args), wrongnumargs);
-#ifdef FLOATS
-    if (SUBRF(proc)) {
-      if (INUMP(arg1))
-	return makdbl(DSUBRF(proc)((double) INUM(arg1)), 0.0);
-      ASRTGO(NIMP(arg1), floerr);
-      if (REALP(arg1))
-	return makdbl(DSUBRF(proc)(REALPART(arg1)), 0.0);
-# ifdef BIGDIG
-      if (BIGP(arg1))
-	return makdbl(DSUBRF(proc)(big2dbl(arg1)), 0.0);
-# endif
-    floerr:
-      wta(arg1, (char *)ARG1, SNAME(proc));
-    }
-#endif
-    {
-      int op = CXR_OP(proc);
-#ifndef RECKLESS
-      args = arg1;
-#endif
-      while (op) {
-	ASRTER(NIMP(arg1) && CONSP(arg1),
-	       args, ARG1, SNAME(proc));
-	arg1 = (1 & op ? CAR(arg1) : CDR(arg1));
-	op >>= 2;
-      }
-      return arg1;
-    }
+    return scm_apply_cxr(proc, arg1);
   case tc7_subr_3:
     ASRTGO(NIMP(args) && NIMP(CDR(args)) && NULLP(CDR(CDR(args))),
 	   wrongnumargs);
@@ -2977,32 +3019,7 @@ SCM scm_cvapply(proc, n, argv)
   case tc7_subr_1:
     return SUBRF(proc)(argv[0]);
   case tc7_cxr:
-#ifdef FLOATS
-    if (SUBRF(proc)) {
-      if (INUMP(argv[0]))
-	return makdbl(DSUBRF(proc)((double) INUM(argv[0])), 0.0);
-      ASRTGO(NIMP(argv[0]), floerr);
-      if (REALP(argv[0]))
-	return makdbl(DSUBRF(proc)(REALPART(argv[0])), 0.0);
-# ifdef BIGDIG
-      if (BIGP(argv[0]))
-	return makdbl(DSUBRF(proc)(big2dbl(argv[0])), 0.0);
-# endif
-    floerr:
-      wta(argv[0], (char *)ARG1, SNAME(proc));
-    }
-#endif
-    {
-      int op = CXR_OP(proc);
-      res = argv[0];
-      while (op) {
-	ASRTER(NIMP(res) && CONSP(res),
-	       argv[0], ARG1, SNAME(proc));
-	res = (1 & op ? CAR(res) : CDR(res));
-	op >>= 2;
-      }
-      return res;
-    }
+    return scm_apply_cxr(proc, argv[0]);
   case tc7_subr_3:
     return SUBRF(proc)(argv[0], argv[1], argv[2]);
   case tc7_lsubr: