Import Upstream version 4e6upstream/4e6

1 files changed, 255 insertions, 0 deletions

diff --git a/continue.c b/continue.c
new file mode 100644
index 0000000..b28fe6e
--- /dev/null
+++ b/continue.c
@@ -0,0 +1,255 @@
+/* Copyright (C) 1990, 1991, 1992, 1993, 1994, 1995 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
+ * the Free Software Foundation; either version 2, or (at your option)
+ * any later version.
+ * 
+ * This program is distributed in the hope that it will be useful,
+ * but WITHOUT ANY WARRANTY; without even the implied warranty of
+ * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
+ * GNU General Public License for more details.
+ * 
+ * You should have received a copy of the GNU General Public License
+ * along with this software; see the file COPYING.  If not, write to
+ * the Free Software Foundation, 675 Mass Ave, Cambridge, MA 02139, USA.
+ *
+ * As a special exception, the Free Software Foundation gives permission
+ * for additional uses of the text contained in its release of GUILE.
+ *
+ * The exception is that, if you link the GUILE library with other files
+ * to produce an executable, this does not by itself cause the
+ * resulting executable to be covered by the GNU General Public License.
+ * Your use of that executable is in no way restricted on account of
+ * linking the GUILE library code into it.
+ *
+ * This exception does not however invalidate any other reasons why
+ * the executable file might be covered by the GNU General Public License.
+ *
+ * This exception applies only to the code released by the
+ * Free Software Foundation under the name GUILE.  If you copy
+ * code from other Free Software Foundation releases into a copy of
+ * GUILE, as the General Public License permits, the exception does
+ * not apply to the code that you add in this way.  To avoid misleading
+ * anyone as to the status of such modified files, you must delete
+ * this exception notice from them.
+ *
+ * If you write modifications of your own for GUILE, it is your choice
+ * whether to permit this exception to apply to your modifications.
+ * If you do not wish that, delete this exception notice.  
+ */
+
+/* "continue.c" Scheme Continuations for C.
+   Author: Aubrey Jaffer */
+
+/* "setjump.h" contains definitions for the `other' field (type
+   CONTINUATION_OTHER) the struct Continuation.  "setjump.h" must
+   #include "continue.h".  CONTINUATION_OTHER defaults to `long' */
+
+#define IN_CONTINUE_C
+#ifdef USE_CONTINUE_H
+# include "continue.h"
+#else
+# include "setjump.h"
+#endif
+
+/* For platforms with short integers, we use thrown_value instead of
+   the value returned from setjmp so that any (long) value can be
+   returned.  */
+
+#ifdef SHORT_INT
+long thrown_value;
+#endif
+
+/* stack_size() returns the number of units of size STACKITEM which
+   fit between @var{start} and the current top of stack.  No check is
+   done in this routine to ensure that @var{start} is actually in the
+   current stack segment.  */
+
+long stack_size(start)
+     STACKITEM *start;
+{
+  STACKITEM stack;
+#ifdef STACK_GROWS_UP
+  return &stack - start;
+#else
+  return start - &stack;
+#endif /* def STACK_GROWS_UP */
+}
+
+/* make_root_continuation() allocates (malloc) storage for a
+   CONTINUATION near the current extent of stack.  This newly
+   allocated CONTINUATION is returned if successful, 0 if not.  After
+   make_root_continuation() returns, the calling routine still needs
+   to `setjmp(new_continuation->jmpbuf)' in order to complete the
+   capture of this continuation.  */
+
+CONTINUATION *make_root_continuation(stack_base)
+     STACKITEM *stack_base;
+{
+  CONTINUATION *cont;
+  cont = (CONTINUATION *)malloc(sizeof(CONTINUATION));
+  if (!cont) return 0;
+  cont->length = 0;
+  cont->stkbse = stack_base;
+  cont->parent = cont;
+  return cont;
+}
+
+/* make_continuation() allocates storage for the current continuation,
+   copying (or encapsulating) the stack state from parent_cont->stkbse
+   to the current top of stack.  The newly allocated CONTINUATION is
+   returned if successful, 0 if not.  After make_continuation()
+   returns, the calling routine still needs to
+   `setjmp(new_continuation->jmpbuf)' in order to complete the capture
+   of this continuation.  */
+
+/* Note: allocating local (stack) storage for the CONTINUATION would
+	 not work; Think about it.  */
+
+CONTINUATION *make_continuation(parent_cont)
+     CONTINUATION *parent_cont;
+{
+  CONTINUATION *cont;
+#ifdef CHEAP_CONTINUATIONS
+  cont = (CONTINUATION *)malloc(sizeof(CONTINUATION));
+  if (!cont) return 0;
+  cont->length = 0;
+  cont->stkbse = parent_cont->stkbse;
+#else
+  long j;
+  register STACKITEM *src, *dst;
+  FLUSH_REGISTER_WINDOWS;
+  j = stack_size(parent_cont->stkbse);
+  cont = (CONTINUATION *)malloc((sizeof(CONTINUATION) + j*sizeof(STACKITEM)));
+  if (!cont) return 0;
+  cont->length = j;
+  cont->stkbse = parent_cont->stkbse;
+  src = cont->stkbse;
+# ifdef STACK_GROWS_UP
+  src += parent_cont->length;
+# else
+  src -= parent_cont->length + cont->length;
+# endif/* ndef STACK_GROWS_UP */
+  dst = (STACKITEM *)(cont + 1);
+  for (j = cont->length; 0 <= --j; ) *dst++ = *src++;
+#endif /* ndef CHEAP_CONTINUATIONS */
+  cont->parent = parent_cont;
+  return cont;
+}
+
+/* free_continuation() is trivial, but who knows what the future
+   holds.  */
+
+void free_continuation(cont)
+     CONTINUATION *cont;
+{
+  free(cont);
+}
+
+/* Final routine involved in throw()ing to a continuation.  After
+   ensuring that there is sufficient room on the stack for the saved
+   continuation, dynthrow() copies the continuation onto the stack and
+   longjmp()s into it.  The routine does not return.  */
+
+/* If you use conservative GC and your Sparc(SUN-4) heap is growing
+   out of control:
+
+   You are experiencing a GC problem peculiar to the Sparc.  The
+   problem is that contin doesn't know how to clear register windows.
+   Every location which is not reused still gets marked at GC time.
+   This causes lots of stuff which should be collected to not be.
+   This will be a problem with any *conservative* GC until we find
+   what instruction will clear the register windows.  This problem is
+   exacerbated by using lots of make-CONTINUATION.
+
+   Possibly adding the following before the thrown_value = val; line
+   might help to clear out unused stack above the continuation (a
+   small part of the problem).
+
+#ifdef sparc
+  bzero((void *)&a, sizeof(STACKITEM) *
+	(((STACKITEM *)&a) - (dst - cont->length)))
+#endif
+
+   Let me know if you try it.  */
+
+void dynthrow(a)
+     long *a;
+{
+  register CONTINUATION *cont = (CONTINUATION *)(a[0]);
+  long val = a[1];
+#ifndef CHEAP_CONTINUATIONS
+  register long j;
+  register STACKITEM *src, *dst = cont->stkbse;
+# ifdef STACK_GROWS_UP
+  if (a[2] && (a - ((long *)a[3]) < 100))
+    puts("grow_throw: check if long growth[100]; being optimized out");
+  /* if (a[2]) fprintf(stderr, " ct = %ld, dist = %ld\n", a[2], (((long *)a[3]) - a)); */
+  if PTR_GE(dst + (cont->length), (STACKITEM *)&a) grow_throw(a);
+# else
+  if (a[2] && (((long *)a[3]) - a < 100))
+    puts("grow_throw: check if long growth[100]; being optimized out");
+  /* if (a[2]) fprintf(stderr, " ct = %ld, dist = %ld\n", a[2], (((long *)a[3]) - a)); */
+  dst -= cont->length;
+  if PTR_LE(dst, (STACKITEM *)&a) grow_throw(a);
+# endif/* def STACK_GROWS_UP */
+  FLUSH_REGISTER_WINDOWS;
+  src = (STACKITEM *)(cont + 1);
+  for (j = cont->length;0 <= --j;) *dst++ = *src++;
+#endif /* ndef CHEAP_CONTINUATIONS */
+#ifdef SHORT_INT
+  thrown_value = val;
+  longjmp(cont->jmpbuf, 1);
+#else
+  longjmp(cont->jmpbuf, val);
+#endif
+}
+
+/* grow_throw() grows the stack by 100 long words.  If the "sizeof
+   growth" assignment is not sufficient to restrain your overly
+   optimistic compiler, the stack will grow by much less and
+   grow_throw() and dynthrow() will waste time calling each other.  To
+   fix this you will have to compile grow_throw() in a separate file
+   so the compiler won't be able to guess that the growth array isn't
+   all used.  */
+
+#ifndef CHEAP_CONTINUATIONS
+void grow_throw(a)		/* Grow the stack so that there is room */
+     long *a;			/* to copy in the continuation.  Then */
+{				/* retry the throw.  */
+  long growth[100];
+  growth[0] = a[0];
+  growth[1] = a[1];
+  growth[2] = a[2] + 1;
+  growth[3] = (long) a;
+  growth[99] = sizeof growth;
+  dynthrow(growth);
+}
+#endif /* ndef CHEAP_CONTINUATIONS */
+
+/* throw_to_continuation() restores the stack in effect when
+   @var{cont} was made and resumes @var{cont}'s processor state.  If
+   the stack cannot be resotred because @var{cont} and @var{root_cont}
+   do not have the same stkbase, @code{throw_to_continuation()
+   returns.  */
+
+/* Note: If 2 or more @var{cont}s share a parent continuation and if
+   the values of stack allocated variables in that parent continuation
+   are changed, the results are unspecified.  This is because the
+   parent continuation may or may not be reloaded, depending on what
+   other throws have intervened.  */
+
+void throw_to_continuation(cont, val, root_cont)
+     CONTINUATION *cont;
+     long val;
+     CONTINUATION *root_cont;
+{
+  long a[3];
+  a[0] = (long)cont;
+  a[1] = val;
+  a[2] = 0;
+  if (cont->stkbse != root_cont->stkbse)
+    return;			/* Stale continuation */
+  dynthrow(a);
+}