summaryrefslogtreecommitdiffstats
path: root/sys.c
diff options
context:
space:
mode:
Diffstat (limited to 'sys.c')
-rw-r--r--sys.c1201
1 files changed, 735 insertions, 466 deletions
diff --git a/sys.c b/sys.c
index 82ea647..b63cb5e 100644
--- a/sys.c
+++ b/sys.c
@@ -1,18 +1,18 @@
/* Copyright (C) 1990, 1991, 1992, 1993, 1994, 1995, 1996, 1997 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.
+ * the Free Software Foundation, 59 Temple Place, Suite 330, Boston, MA 02111, USA.
*
* As a special exception, the Free Software Foundation gives permission
* for additional uses of the text contained in its release of GUILE.
@@ -36,7 +36,7 @@
*
* 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.
+ * If you do not wish that, delete this exception notice.
*/
/* "sys.c" opening and closing files, storage, and GC. */
@@ -114,11 +114,12 @@ char s_close_port[] = "close-port";
SCM i_setbuf0(port) /* should be called with DEFER_INTS active */
SCM port;
{
+ VERIFY_INTS("i_setbuf0", 0L);
#ifndef NOSETBUF
# ifndef MSDOS
# ifdef FIONREAD
# ifndef ultrix
- SYSCALL(setbuf(STREAM(port), 0););
+ SYSCALL(setbuf(STREAM(port), 0L););
# endif
# endif
# endif
@@ -126,12 +127,26 @@ SCM i_setbuf0(port) /* should be called with DEFER_INTS active */
return UNSPECIFIED;
}
-long mode_bits(modes)
- char *modes;
-{
- return OPN | (strchr(modes, 'r') || strchr(modes, '+') ? RDNG : 0)
- | (strchr(modes, 'w') || strchr(modes, 'a') || strchr(modes, '+') ? WRTNG : 0)
- | (strchr(modes, '0') ? BUF0 : 0);
+/* The CRDY bit is overloaded to indicate that additional processing
+ is needed when reading or writing, such as updating line and column
+ numbers. */
+long mode_bits(modes, cmodes)
+ char *modes, *cmodes;
+{
+ int iout = 0;
+ long bits = OPN;
+ for (; *modes; modes++)
+ switch (*modes) {
+ case 'r': bits |= RDNG; goto outc;
+ case 'w': case 'a': bits |= WRTNG; goto outc;
+ case '+': bits |= (RDNG | WRTNG); goto outc;
+ case 'b': bits |= BINARY; goto outc;
+ case '0': bits |= BUF0; break;
+ case '?': bits |= (TRACKED | CRDY); break;
+ outc: if (cmodes && (iout < 3)) cmodes[iout++] = *modes; break;
+ }
+ if (cmodes) cmodes[iout] = 0;
+ return bits;
}
SCM try_open_file(filename, modes)
@@ -139,18 +154,22 @@ SCM try_open_file(filename, modes)
{
register SCM port;
FILE *f;
+ char cmodes[4];
+ long flags = mode_bits(CHARS(modes), cmodes);
ASSERT(NIMP(filename) && STRINGP(filename), filename, ARG1, s_open_file);
ASSERT(NIMP(modes) && STRINGP(modes), modes, ARG2, s_open_file);
NEWCELL(port);
DEFER_INTS;
- SYSCALL(f = fopen(CHARS(filename), CHARS(modes)););
- if (!f) port = BOOL_F;
- else {
- SETSTREAM(port, f);
- if (BUF0 & (CAR(port) = tc16_fport | mode_bits(CHARS(modes))))
- i_setbuf0(port);
+ SCM_OPENCALL(f = fopen(CHARS(filename), cmodes));
+ if (!f) {
+ ALLOW_INTS;
+ return BOOL_F;
}
+ SETSTREAM(port, f);
+ CAR(port) = scm_port_entry(tc16_fport, flags);
+ if (BUF0 & flags) i_setbuf0(port);
ALLOW_INTS;
+ SCM_PORTDATA(port) = filename;
return port;
}
@@ -195,7 +214,7 @@ SCM output_portp(x)
# undef L_tmpnam /* Not supported in TURBOC V1.0 */
#endif
#ifdef GO32
-# undef L_tmpnam
+# undef L_tmpnam /* Would put files in %TMPDIR% = %DJDIR%/tmp */
#endif
#ifdef MWC
# undef L_tmpnam
@@ -300,24 +319,6 @@ void prinport(exp, port, type)
else intprint(CDR(exp), -16, port);
lputc('>', port);
}
-static int prinfport(exp, port, writing)
- SCM exp; SCM port; int writing;
-{
- prinport(exp, port, s_port_type);
- return !0;
-}
-static int prinstpt(exp, port, writing)
- SCM exp; SCM port; int writing;
-{
- prinport(exp, port, s_string);
- return !0;
-}
-static int prinsfpt(exp, port, writing)
- SCM exp; SCM port; int writing;
-{
- prinport(exp, port, "soft");
- return !0;
-}
static int stputc(c, p)
int c; SCM p;
@@ -374,7 +375,7 @@ SCM mkstrport(pos, str, modes, caller)
NEWCELL(z);
DEFER_INTS;
SETCHARS(z, str);
- CAR(z) = tc16_strport | modes;
+ CAR(z) = scm_port_entry(tc16_strport, modes);
ALLOW_INTS;
return z;
}
@@ -412,9 +413,10 @@ sizet pwrite(ptr, size, nitems, port)
#endif
static ptobfuns fptob = {
+ s_port_type,
mark0,
fclose,
- prinfport,
+ 0,
0,
fputc,
#ifdef __MWERKS__
@@ -428,9 +430,10 @@ static ptobfuns fptob = {
fgetc,
fclose};
ptobfuns pipob = {
+ 0,
mark0,
- 0, /* replaced by pclose in init_ioext() */
- 0, /* replaced by prinpipe in init_ioext() */
+ 0, /* replaced by pclose in init_ioext() */
+ 0,
0,
fputc,
#ifdef __MWERKS__
@@ -441,19 +444,20 @@ ptobfuns pipob = {
ffwrite,
#endif
fflush,
- fgetc,
- 0}; /* replaced by pclose in init_ioext() */
+ fgetc};
static ptobfuns stptob = {
+ s_string,
markcdr,
noop0,
- prinstpt,
+ 0,
0,
stputc,
stputs,
stwrite,
noop0,
stgetc,
- 0};
+ 0}; /* stungetc */
+
/* Soft ports */
@@ -465,7 +469,8 @@ static ptobfuns stptob = {
static int sfputc(c, p)
int c; SCM p;
{
- apply(VELTS(p)[0], MAKICHR(c), listofnull);
+ SCM arg = MAKICHR(c);
+ scm_cvapply(VELTS(p)[0], 1L, &arg);
errno = 0;
return c;
}
@@ -475,7 +480,7 @@ sizet sfwrite(str, siz, num, p)
{
SCM sstr;
sstr = makfromstr(str, siz * num);
- apply(VELTS(p)[1], sstr, listofnull);
+ scm_cvapply(VELTS(p)[1], 1L, &sstr);
errno = 0;
return num;
}
@@ -498,7 +503,7 @@ static int sfgetc(p)
SCM p;
{
SCM ans;
- ans = apply(VELTS(p)[3], EOL, EOL);
+ ans = scm_cvapply(VELTS(p)[3], 0L, (SCM *)0);
errno = 0;
if (FALSEP(ans) || EOF_VAL==ans) return EOF;
ASSERT(ICHRP(ans), ans, ARG1, "getc");
@@ -518,20 +523,31 @@ SCM mksfpt(pv, modes)
SCM pv, modes;
{
SCM z;
- ASSERT(NIMP(pv) && VECTORP(pv) && 5==LENGTH(pv), pv, ARG1, s_mksfpt);
+ static long arities[] = {1, 1, 0, 0, 0};
+#ifndef RECKLESS
+ int i;
+ if (! (NIMP(pv) && VECTORP(pv) && 5==LENGTH(pv)))
+ badarg: wta(pv, (char *)ARG1, s_mksfpt);
+ for (i = 0; i < 5; i++) {
+ ASRTGO(FALSEP(VELTS(pv)[i]) ||
+ scm_arity_check(VELTS(pv)[i], arities[i], (char *)0),
+ badarg);
+ }
+#endif
ASSERT(NIMP(modes) && STRINGP(modes), modes, ARG2, s_mksfpt);
NEWCELL(z);
DEFER_INTS;
- CAR(z) = tc16_sfport | mode_bits(CHARS(modes));
+ CAR(z) = scm_port_entry(tc16_sfport, mode_bits(CHARS(modes), (char *)0));
SETSTREAM(z, pv);
ALLOW_INTS;
return z;
}
static ptobfuns sfptob = {
+ "soft",
markcdr,
noop0,
- prinsfpt,
+ 0,
0,
sfputc,
sfputs,
@@ -567,7 +583,7 @@ static sizet syswrite(str, siz, num, p)
if NIMP(cur_outp) lflush(cur_outp);
if (errbuf_end > 0) {
if (errbuf_end > SYS_ERRP_SIZE) {
- warn("output buffer", " overflowed");
+ scm_warn("output buffer", " overflowed");
intprint((long)errbuf_end, 10, cur_errp);
lputs(" chars needed\n", cur_errp);
errbuf_end = errbuf_end % SYS_ERRP_SIZE;
@@ -603,6 +619,7 @@ static int sysflush(p)
return 0;
}
static ptobfuns sysptob = {
+ 0,
mark0,
noop0,
0,
@@ -614,6 +631,105 @@ static ptobfuns sysptob = {
noop0,
noop0};
+/* A `safeport' is used for writing objects as part of an error response.
+ Since these objects may be very large or circular, the safeport will
+ output only a fixed number of characters before exiting via longjmp.
+ A setjmp must be done before each use of the safeport. */
+
+static char s_msp[] = "mksafeport";
+int tc16_safeport;
+SCM mksafeport(maxlen, port)
+ int maxlen;
+ SCM port;
+{
+ SCM z;
+ if UNBNDP(port) port = cur_errp;
+ else {
+ ASSERT(NIMP(port) && OPPORTP(port), port, ARG2, s_msp);
+ }
+ DEFER_INTS;
+ z = must_malloc_cell(sizeof(safeport)+0L,
+ tc16_safeport | OPN | WRTNG,
+ s_msp);
+ ((safeport *)STREAM(z))->ccnt = maxlen;
+ ((safeport *)STREAM(z))->port = port;
+ ALLOW_INTS;
+ return z;
+}
+int reset_safeport(sfp, maxlen, port)
+ int maxlen;
+ SCM sfp, port;
+{
+ if (NIMP(sfp) && tc16_safeport==TYP16(sfp)) {
+ ((safeport *)STREAM(sfp))->ccnt = maxlen;
+ if NIMP(port)
+ ((safeport *)STREAM(sfp))->port = port;
+ return !0;
+ }
+ return 0;
+}
+static sizet safewrite(str, siz, num, p)
+ sizet siz, num;
+ char *str; safeport *p;
+{
+ int count = p->ccnt;
+ sizet n = siz*num;
+ if (n < count) {
+ p->ccnt = count - n;
+ lfwrite(str, siz, num, p->port);
+ }
+ else if (count) {
+ num = count / siz;
+ p->ccnt = 0;
+ lfwrite(str, siz, num, p->port);
+ lputs(" ...", p->port);
+ longjmp(p->jmpbuf, !0); /* The usual C longjmp, not SCM's longjump */
+ }
+ return siz;
+}
+static int safeputs(s, p)
+ char *s; safeport *p;
+{
+ safewrite(s, 1, strlen(s), p);
+ return 0;
+}
+static int safeputc(c, p)
+ int c; safeport *p;
+{
+ char cc = c;
+ safewrite(&cc, 1, 1, p);
+ return c;
+}
+static int safeflush(p)
+ safeport *p;
+{
+ lflush(p->port);
+ return 0;
+}
+static SCM marksafep(ptr)
+ SCM ptr;
+{
+ return ((safeport *)STREAM(ptr))->port;
+}
+static int freesafep(ptr)
+ FILE *ptr;
+{
+ must_free((char *)ptr, sizeof(safeport));
+ return 0;
+}
+static ptobfuns safeptob = {
+ 0,
+ marksafep,
+ freesafep,
+ 0,
+ 0,
+ safeputc,
+ safeputs,
+ safewrite,
+ safeflush,
+ noop0,
+ noop0};
+
static int freeprint(exp, port, writing)
SCM exp; SCM port; int writing;
{
@@ -644,48 +760,72 @@ static smobfuns flob = {
mark0,
/*flofree*/0,
floprint,
- floequal};
+#ifdef FLOATS
+ floequal
+#else
+ 0
+#endif
+};
static smobfuns bigob = {
mark0,
/*bigfree*/0,
bigprint,
- bigequal};
-void (**finals)() = 0;
-sizet num_finals = 0;
+#ifdef BIGDIG
+ bigequal
+#else
+ 0
+#endif
+};
+
+scm_gra finals_gra;
static char s_final[] = "final";
+/* statically allocated ports for diagnostic messages */
+static cell tmp_errpbuf[3];
+static SCM tmp_errp;
+extern sizet num_protects; /* sys_protects now in scl.c */
void init_types()
{
- numptob = 0;
- ptobs = (ptobfuns *)malloc(4*sizeof(ptobfuns));
+ sizet j = num_protects;
+ /* Because not all protects may get initialized */
+ while(j) sys_protects[--j] = BOOL_F;
+
+ /* We need to set up tmp_errp before any errors may be
+ thrown, the port_table index will be zero, usable
+ all ports that don't care about their table entries. */
+ tmp_errp = PTR2SCM(CELL_UP(&tmp_errpbuf[0]));
+ CAR(tmp_errp) = scm_port_entry(tc16_fport, OPN|WRTNG);
+ SETSTREAM(tmp_errp, stderr);
+ cur_errp = def_errp = sys_safep = tmp_errp;
+
+ scm_init_gra(&subr_table_gra, sizeof(subr_info), 200, 0, "subr table");
+ scm_init_gra(&ptobs_gra, sizeof(ptobfuns), 4, 255, "ptobs");
/* These newptob calls must be done in this order */
/* tc16_fport = */ newptob(&fptob);
/* tc16_pipe = */ newptob(&pipob);
/* tc16_strport = */ newptob(&stptob);
/* tc16_sfport = */ newptob(&sfptob);
tc16_sysport = newptob(&sysptob);
- numsmob = 0;
- smobs = (smobfuns *)malloc(7*sizeof(smobfuns));
+ tc16_safeport = newptob(&safeptob);
+ scm_init_gra(&smobs_gra, sizeof(smobfuns), 7, 255, "smobs");
/* These newsmob calls must be done in this order */
newsmob(&freecell);
newsmob(&flob);
newsmob(&bigob);
newsmob(&bigob);
- finals = (void(**)())malloc(2 * sizeof(finals[0]));
- num_finals = 0;
+ scm_init_gra(&finals_gra, sizeof(void (*)()), 2, 0, s_final);
}
+#ifdef TEST_FINAL
+void test_final()
+{
+ fputs("test_final ok\n", stderr);
+}
+#endif
void add_final(final)
void (* final)();
{
- DEFER_INTS;
- finals = (void (**)()) must_realloc((char *)finals,
- (long)(num_finals)*sizeof(finals[0]),
- (1L+num_finals)*sizeof(finals[0]),
- s_final);
- finals[num_finals++] = final;
- ALLOW_INTS;
- return;
+ scm_grow_gra(&finals_gra, (char *)&final);
}
static char s_estk[] = "environment stack";
@@ -694,100 +834,131 @@ SCM scm_egc_roots[ECACHE_SIZE/20];
CELLPTR scm_ecache;
VOLATILE long scm_ecache_index, scm_ecache_len, scm_egc_root_index;
SCM scm_estk = UNDEFINED, *scm_estk_ptr;
-void scm_estk_reset()
+static SCM estk_pool = EOL;
+long scm_estk_size;
+static SCM make_stk_seg(size, contents)
+ sizet size;
+ SCM contents;
{
- SCM nstk = scm_estk, *v;
+ SCM seg = BOOL_F, *src, *dst;
sizet i;
- VERIFY_INTS("scm_estk_reset", 0);
- /* We might be here because we blew the stack, or got tired of
- watching it grow, so make sure the stack size is sane. */
- if (IMP(nstk) || 50*SCM_ESTK_FRLEN < LENGTH(nstk)) {
- i = 50L*SCM_ESTK_FRLEN + 1;
- nstk = must_malloc_cell((long)i*sizeof(SCM), s_estk);
- SETLENGTH(nstk, i, tc7_vector);
+ VERIFY_INTS("make_stk_seg", 0L);
+ while NIMP(estk_pool) {
+ if (size==LENGTH(estk_pool)) {
+ seg = estk_pool;
+ estk_pool = SCM_ESTK_PARENT(seg);
+ break;
+ }
+ estk_pool = SCM_ESTK_PARENT(estk_pool);
+ }
+ if IMP(seg) seg = must_malloc_cell((long)size*sizeof(SCM),
+ MAKE_LENGTH(size, tc7_vector), s_estk);
+ dst = VELTS(seg);
+ if NIMP(contents) {
+ src = VELTS(contents);
+ for (i = size; i--;) dst[i] = src[i];
+ }
+ else {
+ for (i = size; i--;) dst[i] = UNSPECIFIED;
+ SCM_ESTK_PARENT(seg) = BOOL_F;
+ SCM_ESTK_PARENT_INDEX(seg) = INUM0;
+ dst[SCM_ESTK_BASE - 1] = UNDEFINED; /* underflow sentinel */
+ }
+ dst[size - 1] = UNDEFINED; /* overflow sentinel */
+ return seg;
+}
+/* size is a number of SCM elements, or zero for a default size.
+ If nonzero, size must be SCM_ESTK_BASE + N * SCM_ESTK_FRLEN + 1
+ for some reasonable number of stackframes N */
+void scm_estk_reset(size)
+ sizet size;
+{
+ VERIFY_INTS("scm_estk_reset", 0L);
+ if (!size) size = SCM_ESTK_BASE + 20*SCM_ESTK_FRLEN + 1;
+ scm_estk = make_stk_seg(size, UNDEFINED);
+ scm_estk_ptr = &(VELTS(scm_estk)[SCM_ESTK_BASE]);
+ scm_estk_size = size;
+}
+void scm_estk_grow()
+{
+ /* 40 and 10 below are adjustable parameters: the number of frames
+ in a stack segment, and the number of frames to overlap between
+ stack segments. */
+ sizet size = 40 * SCM_ESTK_FRLEN + SCM_ESTK_BASE + 1;
+ sizet overlap = 10*SCM_ESTK_FRLEN;
+ SCM estk = make_stk_seg(size, UNDEFINED);
+ SCM *newv, *oldv;
+ sizet i, j;
+ newv = VELTS(estk);
+ oldv = VELTS(scm_estk);
+ j = scm_estk_ptr - VELTS(scm_estk) + SCM_ESTK_FRLEN - overlap;
+ SCM_ESTK_PARENT(estk) = scm_estk;
+ SCM_ESTK_PARENT_WRITABLEP(estk) = BOOL_T;
+ SCM_ESTK_PARENT_INDEX(estk) = MAKINUM(j - SCM_ESTK_FRLEN);
+ for (i = SCM_ESTK_BASE; i < SCM_ESTK_BASE + overlap; i++, j++) {
+ newv[i] = oldv[j];
+ oldv[j] = BOOL_F;
}
- i = LENGTH(nstk);
- v = VELTS(nstk);
- while (i--) v[i] = UNSPECIFIED;
- v[LENGTH(nstk)-1] = INUM0; /* overflow sentinel */
- v[0] = INUM0; /* underflow sentinel */
- /* The following are for a (future) segmented
- stack implementation. */
- v[1] = BOOL_T; /* writable? */
- v[SCM_ESTK_FRLEN] = EOL; /* Must look like an environment */
- v[SCM_ESTK_FRLEN + 1] = EOL; /* next stack segment */
- scm_estk = nstk;
- scm_estk_ptr = &(v[SCM_ESTK_BASE - SCM_ESTK_FRLEN]);
-}
-
-void scm_estk_grow(inc)
- sizet inc;
-{
- SCM estk = make_vector(MAKINUM(LENGTH(scm_estk) + inc*SCM_ESTK_FRLEN),
- UNSPECIFIED);
- sizet n, i;
- DEFER_INTS;
- n = scm_estk_ptr - VELTS(scm_estk);
- ASSERT(n<=LENGTH(scm_estk), UNDEFINED, "estk corrupted", "scm_estk_grow");
- for (i = n + 1; i--;)
- VELTS(estk)[i] = VELTS(scm_estk)[i];
- /* Sentinel for stack overflow. */
- VELTS(estk)[LENGTH(estk)-1] = INUM0;
scm_estk = estk;
- scm_estk_ptr = &(VELTS(estk)[n + SCM_ESTK_FRLEN]);
- ALLOW_INTS;
- growth_mon(s_estk, LENGTH(scm_estk), "locations", !0);
+ scm_estk_ptr = &(newv[SCM_ESTK_BASE + overlap]);
+ scm_estk_size += size;
+ /* growth_mon(s_estk, scm_estk_size, "locations", !0); */
}
-
-/* Will be useful when segmented stack is implemented. */
void scm_estk_shrink()
{
-#if 0
- SCM next = VELTS(scm_estk)[SCM_ESTK_FRLEN];
- int istrt;
- if IMP(next) wta(UNDEFINED, "underflow", "stack");
- istrt = INUM(CDR(next));
- next = CAR(next);
- if (BOOL_T != VELTS(next)[1]) {
- SCM new_estk = make_vector(MAKINUM(LENGTH(scm_estk)), UNSPECIFIED);
- int i = istrt;
- while (--i) VELTS(new_estk)[i] = VELTS(next)[i];
- VELTS(new_estk)[1] = BOOL_T;
- VELTS(new_estk)[LENGTH(new_estk)-1] = INUM0;
- next = new_estk;
- }
- scm_estk = next;
- scm_estk_ptr = &(VELTS(scm_estk)[istrt]);
-#else
- wta(UNDEFINED, "underflow", s_estk);
-#endif
+ SCM parent, *v;
+ sizet i;
+ parent = SCM_ESTK_PARENT(scm_estk);
+ i = INUM(SCM_ESTK_PARENT_INDEX(scm_estk));
+ v = VELTS(scm_estk);
+ if IMP(parent) wta(UNDEFINED, "underflow", s_estk);
+ if (BOOL_F==SCM_ESTK_PARENT_WRITABLEP(scm_estk))
+ parent = make_stk_seg(LENGTH(parent), parent);
+ SCM_ESTK_PARENT(scm_estk) = estk_pool;
+ estk_pool = scm_estk;
+ scm_estk_size -= LENGTH(scm_estk);
+ scm_estk = parent;
+ scm_estk_ptr = &(VELTS(parent)[i]);
+ /* growth_mon(s_estk, scm_estk_size, "locations", 0); */
}
void scm_env_cons(x, y)
SCM x, y;
{
register SCM z;
+ register int i;
DEFER_INTS_EGC;
- if (1>scm_ecache_index) scm_egc();
- z = PTR2SCM(&(scm_ecache[--scm_ecache_index]));
+ i = scm_ecache_index;
+ if (1>i) {
+ scm_egc();
+ i = scm_ecache_index;
+ }
+ z = PTR2SCM(&(scm_ecache[--i]));
CAR(z) = x;
CDR(z) = y;
scm_env_tmp = z;
+ scm_ecache_index = i;
}
void scm_env_cons2(w, x, y)
SCM w, x, y;
{
SCM z1, z2;
+ register int i;
DEFER_INTS_EGC;
- if (2>scm_ecache_index) scm_egc();
- z1 = PTR2SCM(&(scm_ecache[--scm_ecache_index]));
+ i = scm_ecache_index;
+ if (2>i) {
+ scm_egc();
+ i = scm_ecache_index;
+ }
+ z1 = PTR2SCM(&(scm_ecache[--i]));
CAR(z1) = x;
CDR(z1) = y;
- z2 = PTR2SCM(&(scm_ecache[--scm_ecache_index]));
+ z2 = PTR2SCM(&(scm_ecache[--i]));
CAR(z2) = w;
CDR(z2) = z1;
- scm_env_tmp = z2;
+ scm_env_tmp = z2;
+ scm_ecache_index = i;
}
/* scm_env_tmp = cons(x, scm_env_tmp) */
@@ -795,12 +966,41 @@ void scm_env_cons_tmp(x)
SCM x;
{
register SCM z;
+ register int i;
DEFER_INTS_EGC;
- if (1>scm_ecache_index) scm_egc();
- z = PTR2SCM(&(scm_ecache[--scm_ecache_index]));
+ i = scm_ecache_index;
+ if (1>i) {
+ scm_egc();
+ i = scm_ecache_index;
+ }
+ z = PTR2SCM(&(scm_ecache[--i]));
CAR(z) = x;
CDR(z) = scm_env_tmp;
scm_env_tmp = z;
+ scm_ecache_index = i;
+}
+
+void scm_env_v2lst(argc, argv)
+ int argc;
+ SCM *argv;
+{
+ SCM z1, z2;
+ register int i;
+ DEFER_INTS_EGC;
+ i = scm_ecache_index;
+ if (argc>i) {
+ scm_egc();
+ i = scm_ecache_index;
+ }
+ z1 = z2 = scm_env_tmp; /* set z1 just in case argc is zero */
+ while (argc--) {
+ z1 = PTR2SCM(&(scm_ecache[--i]));
+ CAR(z1) = argv[argc];
+ CDR(z1) = z2;
+ z2 = z1;
+ }
+ scm_env_tmp = z1;
+ scm_ecache_index = i;
}
/* scm_env = acons(names, scm_env_tmp, scm_env) */
@@ -808,15 +1008,21 @@ void scm_extend_env(names)
SCM names;
{
SCM z1, z2;
+ register int i;
DEFER_INTS_EGC;
- if (2>scm_ecache_index) scm_egc();
- z1 = PTR2SCM(&(scm_ecache[--scm_ecache_index]));
+ i = scm_ecache_index;
+ if (2>i) {
+ scm_egc();
+ i = scm_ecache_index;
+ }
+ z1 = PTR2SCM(&(scm_ecache[--i]));
CAR(z1) = names;
CDR(z1) = scm_env_tmp;
- z2 = PTR2SCM(&(scm_ecache[--scm_ecache_index]));
+ z2 = PTR2SCM(&(scm_ecache[--i]));
CAR(z2) = z1;
CDR(z2) = scm_env;
scm_env = z2;
+ scm_ecache_index = i;
}
char s_obunhash[] = "object-unhash", s_cache_gc[] = "cache_gc";
char s_recursive[] = "recursive";
@@ -853,10 +1059,13 @@ void init_io()
init_iprocs(subr2s, tc7_subr_2);
loc_open_file =
&CDR(sysintern(s_open_file,
- CDR(intern(s_try_open_file, sizeof(s_try_open_file)-1))));
+ CDR(sysintern(s_try_open_file, UNDEFINED))));
#ifndef CHEAP_CONTINUATIONS
add_feature("full-continuation");
#endif
+#ifdef TEST_FINAL
+ add_final(test_final);
+#endif
}
void grew_lim(nm)
@@ -869,9 +1078,9 @@ sizet hplim_ind = 0;
long heap_cells = 0;
CELLPTR *hplims, heap_org;
VOLATILE SCM freelist = EOL;
-long mtrigger, mltrigger;
+long mltrigger, mtrigger = INIT_MALLOC_LIMIT;
-/* Ints should be deferred when calling igc_for_malloc. */
+/* Ints should be deferred when calling igc_for_alloc. */
static char *igc_for_alloc(where, olen, size, what)
char *where;
long olen;
@@ -880,6 +1089,8 @@ static char *igc_for_alloc(where, olen, size, what)
{
char *ptr;
long nm;
+ /* Check to see that heap is initialized */
+ ASSERT(heap_cells>0, MAKINUM(size), NALLOC, what);
igc(what, CONT(rootcont)->stkbse);
nm = mallocated + size - olen;
if (nm > mltrigger) {
@@ -896,6 +1107,7 @@ static char *igc_for_alloc(where, olen, size, what)
else mtrigger += mtrigger/2;
mltrigger = mtrigger - MIN_MALLOC_YIELD;
}
+ mallocated = nm;
return ptr;
}
char *must_malloc(len, what)
@@ -906,17 +1118,22 @@ char *must_malloc(len, what)
sizet size = len;
long nm = mallocated + size;
VERIFY_INTS("must_malloc", what);
+#ifdef SHORT_SIZET
ASSERT(len==size, MAKINUM(len), NALLOC, what);
+#endif
if (nm <= mtrigger)
SYSCALL(ptr = (char *)malloc(size););
else
ptr = 0;
- if (!ptr) ptr = igc_for_alloc(0, 0, size, what);
- mallocated = nm;
+ if (!ptr)
+ ptr = igc_for_alloc(0L, 0L, size, what);
+ else
+ mallocated = nm;
return ptr;
}
-SCM must_malloc_cell(len, what)
+SCM must_malloc_cell(len, c, what)
long len;
+ SCM c;
char *what;
{
SCM z;
@@ -924,15 +1141,20 @@ SCM must_malloc_cell(len, what)
sizet size = len;
long nm = mallocated + size;
VERIFY_INTS("must_malloc_cell", what);
+#ifdef SHORT_SIZET
ASSERT(len==size, MAKINUM(len), NALLOC, what);
+#endif
NEWCELL(z);
if (nm <= mtrigger)
SYSCALL(ptr = (char *)malloc(size););
else
ptr = 0;
- if (!ptr) ptr = igc_for_alloc(0, 0, size, what);
- mallocated = nm;
+ if (!ptr)
+ ptr = igc_for_alloc(0L, 0L, size, what);
+ else
+ mallocated = nm;
SETCHARS(z, ptr);
+ CAR(z) = c;
return z;
}
char *must_realloc(where, olen, len, what)
@@ -944,13 +1166,17 @@ char *must_realloc(where, olen, len, what)
sizet size = len;
long nm = mallocated + size - olen;
VERIFY_INTS("must_realloc", what);
+#ifdef SHORT_SIZET
ASSERT(len==size, MAKINUM(len), NALLOC, what);
+#endif
if (nm <= mtrigger)
SYSCALL(ptr = (char *)realloc(where, size););
else
ptr = 0;
- if (!ptr) ptr = igc_for_alloc(where, olen, size, what);
- mallocated = nm;
+ if (!ptr)
+ ptr = igc_for_alloc(where, olen, size, what);
+ else
+ mallocated = nm;
return ptr;
}
void must_realloc_cell(z, olen, len, what)
@@ -962,13 +1188,17 @@ void must_realloc_cell(z, olen, len, what)
sizet size = len;
long nm = mallocated + size - olen;
VERIFY_INTS("must_realloc_cell", what);
+#ifdef SHORT_SIZET
ASSERT(len==size, MAKINUM(len), NALLOC, what);
+#endif
if (nm <= mtrigger)
SYSCALL(ptr = (char *)realloc(where, size););
else
ptr = 0;
- if (!ptr) ptr = igc_for_alloc(where, olen, size, what);
- mallocated = nm;
+ if (!ptr)
+ ptr = igc_for_alloc(where, olen, size, what);
+ else
+ mallocated = nm;
SETCHARS(z, ptr);
}
void must_free(obj, len)
@@ -980,124 +1210,11 @@ void must_free(obj, len)
while (len--) obj[len] = '#';
#endif
free(obj);
+ mallocated = mallocated - len;
}
else wta(INUM0, "already free", "");
}
-#ifdef NUM_HP
-# define NUM_HP_SIZE 240*sizeof(double)
-
-struct num_hp {
- struct num_hp *next; /* Next heap in list */
- sizet size; /* Size of one half-heap, in doubles */
- sizet offset; /* 0 or size, depending on which half-heap is in use */
- sizet ind; /* index of next available double */
- double hp[1]; /* Make sure we are optimally aligned for doubles, more
- follow */
-};
-typedef struct num_hp num_hp;
-static num_hp *num_hp_head = 0, *num_hp_cur = 0;
-long num_hp_total = 0;
-
-/* size is in bytes */
-static char s_num_hp[] = "flonum/bignum heap";
-static void num_hp_add(size)
- sizet size;
-{
- num_hp *new_hp;
- sizet dsz = size / sizeof(double);
- tail:
- new_hp = (num_hp_cur ? num_hp_cur->next : 0);
- if (new_hp) {
- new_hp->ind = new_hp->size;
- num_hp_cur = new_hp;
- return;
- }
- new_hp = (num_hp *)must_malloc(sizeof(num_hp) + (2*dsz-1)*sizeof(double),
- s_num_hp);
- num_hp_total += sizeof(num_hp) + (2*dsz-1)*sizeof(double) ;
- growth_mon(s_num_hp, num_hp_total, "doubles", !0);
- new_hp->next = 0;
- new_hp->size = dsz;
- new_hp->offset = 0;
- new_hp->ind = new_hp->size;
- /* must_malloc might have called gc, moving num_hp_cur. */
- if (num_hp_cur) {
- num_hp *hp = num_hp_cur;
- while (hp->next) hp = hp->next;
- hp->next = new_hp;
- }
- else
- num_hp_cur = new_hp;
- if (num_hp_cur->ind >= NUM_HP_MAX_REQ/sizeof(double)) return;
- goto tail;
-}
-
-static void num_hp_switch()
-{
- num_hp *hp = num_hp_head;
- while (hp) {
- hp->offset = (hp->offset + hp->size) % (2*hp->size);
- hp->ind = hp->size;
- hp = hp->next;
- }
- num_hp_cur = num_hp_head;
-}
-
-/* len is in bytes */
-char *num_hp_alloc(len)
- sizet len;
-{
- num_hp *hp = num_hp_cur;
- len = (len + sizeof(double) - 1)/sizeof(double);
- if ((!hp) || (hp->ind < NUM_HP_MAX_REQ/sizeof(double))) {
- num_hp_add(NUM_HP_SIZE);
- hp = num_hp_cur;
- }
- hp->ind -= len;
- return (char *)&(hp->hp[hp->ind + hp->offset]);
-}
-
-char *num_hp_realloc(where, olen, len, what)
- char *where, *what;
- long olen, len;
-{
- char *ret;
- sizet i;
- if (len <= NUM_HP_MAX_REQ) {
- num_hp *hp = num_hp_cur;
- if (len <= olen) return where;
- if (!hp || (hp->ind < NUM_HP_MAX_REQ/sizeof(double))) {
- num_hp_add(NUM_HP_SIZE);
- hp = num_hp_cur;
- }
- hp->ind -= (len + sizeof(double) - 1)/sizeof(double);
- ret = (char *)&(hp->hp[hp->ind + hp->offset]);
- for (i = len; i--;)
- ret[i] = where[i];
- if (olen > NUM_HP_MAX_REQ) must_free(where, (long)olen);
- return ret;
- }
- if (olen > NUM_HP_MAX_REQ)
- return must_realloc(where, olen, len, what);
- ret = must_malloc((long)len, what);
- for (i = len; i--;)
- ret[i] = where[i];
- return ret;
-}
-void num_hp_free(hp)
- num_hp *hp;
-{
- num_hp *next;
- while (hp) {
- next = hp->next;
- num_hp_total -= 2*hp->size;
- must_free((char *)hp, sizeof(num_hp) + hp->size*2 - sizeof(double));
- hp = next;
- }
-}
-#endif /* NUM_HP */
-
SCM symhash; /* This used to be a sys_protect, but
Radey Shouman <shouman@zianet.com>
added GC for unused, UNDEFINED
@@ -1126,21 +1243,25 @@ SCM intern(name, len)
register sizet i = len;
register unsigned char *tmp = (unsigned char *)name;
sizet hash = strhash(tmp, i, (unsigned long)symhash_dim);
+ /* printf("intern %s len=%d\n",name,len);fflush(stdout); */
+ DEFER_INTS;
for(lsym = VELTS(symhash)[hash];NIMP(lsym);lsym = CDR(lsym)) {
z = CAR(lsym);
z = CAR(z);
tmp = UCHARS(z);
if (LENGTH(z) != len) goto trynext;
for(i = len;i--;) if (((unsigned char *)name)[i] != tmp[i]) goto trynext;
+ ALLOW_INTS;
return CAR(lsym);
trynext: ;
}
- lsym = makfromstr(name, len);
- DEFER_INTS;
- SETLENGTH(lsym, (long)len, tc7_msymbol);
- ALLOW_INTS;
+ /* lsym = makfromstr(name, len); */
+ lsym = must_malloc_cell(len+1L,
+ MAKE_LENGTH((long)len, tc7_msymbol), s_string);
+ i = len;
+ CHARS(lsym)[len] = 0;
+ while (i--) CHARS(lsym)[i] = name[i];
z = acons(lsym, UNDEFINED, UNDEFINED);
- DEFER_INTS; /* Operations on symhash must be atomic. */
CDR(z) = VELTS(symhash)[hash];
VELTS(symhash)[hash] = z;
z = CAR(z);
@@ -1163,7 +1284,8 @@ SCM sysintern(name, val)
if (LENGTH(z) != len) goto trynext;
for(i = len;i--;) if (((unsigned char *)name)[i] != tmp[i]) goto trynext;
lsym = CAR(lsym);
- CDR(lsym) = val;
+ if (!UNBNDP(val))
+ CDR(lsym) = val;
return lsym;
trynext: ;
}
@@ -1218,40 +1340,64 @@ SCM makstr(len)
long len;
{
SCM s;
+#ifndef SHORT_SIZET
+ ASSERT(!(len & ~LENGTH_MAX), MAKINUM(len), NALLOC, s_string);
+#endif
DEFER_INTS;
- s = must_malloc_cell(len+1, s_string);
- SETLENGTH(s, len, tc7_string);
+ s = must_malloc_cell(len+1L, MAKE_LENGTH(len, tc7_string), s_string);
CHARS(s)[len] = 0;
- ALLOW_INTS;
+ ALLOW_INTS;
return s;
}
-SCM make_subr(name, type, fcn)
+scm_gra subr_table_gra;
+SCM scm_maksubr(name, type, fcn)
const char *name;
int type;
SCM (*fcn)();
{
- SCM symcell = sysintern(name, UNDEFINED);
- long tmp = ((((CELLPTR)(CAR(symcell)))-heap_org)<<8);
+ subr_info info;
+ int isubr;
register SCM z;
- if ((tmp>>8) != ((CELLPTR)(CAR(symcell))-heap_org))
- tmp = 0;
+ info.name = name;
+ isubr = scm_grow_gra(&subr_table_gra, (char *)&info);
NEWCELL(z);
- CAR(z) = tmp + type;
+ if (!fcn && tc7_cxr==type) {
+ const char *p = name;
+ int code = 0;
+ while (*++p != 'r')
+ switch (*p) {
+ default: wta(UNDEFINED, "bad cxr name", (char *)name);
+ case 'a': code = (code<<2) + 1; continue;
+ case 'd': code = (code<<2) + 2; continue;
+ }
+ type += (code << 8);
+ }
+ CAR(z) = (isubr<<16) + type;
SUBRF(z) = fcn;
- CDR(symcell) = z;
return z;
}
+SCM make_subr(name, type, fcn)
+ const char *name;
+ int type;
+ SCM (*fcn)();
+{
+ return CDR(sysintern(name, scm_maksubr(name, type, fcn)));
+}
#ifdef CCLO
+char s_comp_clo[] = "compiled-closure";
SCM makcclo(proc, len)
SCM proc;
long len;
{
SCM s;
+# ifndef SHORT_SIZET
+ ASSERT(len < (((unsigned long)-1L)>>16), UNDEFINED, NALLOC, s_comp_clo);
+# endif
DEFER_INTS;
- s = must_malloc_cell(len*sizeof(SCM), "compiled-closure");
- SETNUMDIGS(s, len, tc16_cclo);
+ s = must_malloc_cell(len*sizeof(SCM), MAKE_NUMDIGS(len, tc16_cclo),
+ s_comp_clo);
while (--len) VELTS(s)[len] = UNSPECIFIED;
CCLO_SUBR(s) = proc;
ALLOW_INTS;
@@ -1298,14 +1444,14 @@ SCM dynwind(thunk1, thunk2, thunk3)
apply(thunk3, EOL, EOL);
return ans;
}
-void dowinds(to, delta)
+void downd(to, delta)
SCM to;
long delta;
{
tail:
if (dynwinds==to);
else if (0 > delta) {
- dowinds(CDR(to), 1+delta);
+ downd(CDR(to), 1+delta);
apply(CAR(CAR(to)), EOL, EOL);
dynwinds = to;
}
@@ -1313,61 +1459,80 @@ void dowinds(to, delta)
SCM from = CDR(CAR(dynwinds));
dynwinds = CDR(dynwinds);
apply(from, EOL, EOL);
- delta--; goto tail; /* dowinds(to, delta-1); */
+ delta--; goto tail; /* downd(to, delta-1); */
}
}
+void dowinds(to)
+ SCM to;
+{
+ downd(to, ilength(dynwinds) - ilength(to));
+}
/* Remember that setjump needs to be called after scm_make_cont */
SCM scm_make_cont()
{
- SCM cont, env, *from, *to;
+ SCM cont, estk, *from;
CONTINUATION *ncont;
sizet n;
- VERIFY_INTS("scm_make_cont", 0);
+ VERIFY_INTS("scm_make_cont", 0L);
NEWCELL(cont);
from = VELTS(scm_estk);
- n = scm_estk_ptr - from + SCM_ESTK_FRLEN + 2;
- env = must_malloc_cell((long)n*sizeof(SCM), s_cont);
- SETLENGTH(env, (long)n, tc7_vector);
- to = VELTS(env);
- to[--n] = scm_env;
- to[--n] = scm_env_tmp;
- while(n--) to[n] = from[n];
+ n = scm_estk_ptr - from + SCM_ESTK_FRLEN;
+#ifdef CHEAP_CONTINUATIONS
+ estk = scm_estk;
+#else
+ from[1] = BOOL_F; /* Can't write to parent stack */
+ estk = must_malloc_cell((long)n*sizeof(SCM),
+ MAKE_LENGTH((long)n, tc7_vector), s_cont);
+ {
+ SCM *to = VELTS(estk);
+ while(n--) to[n] = from[n];
+ }
+#endif
ncont = make_continuation(CONT(rootcont));
if (!ncont) wta(MAKINUM(-1), (char *)NALLOC, s_cont);
ncont->other.parent = rootcont;
SETCONT(cont, ncont);
SETLENGTH(cont, ncont->length, tc7_contin);
ncont->other.dynenv = dynwinds;
- ncont->other.env = env;
+ ncont->other.stkframe[0] = scm_env;
+ ncont->other.stkframe[1] = scm_env_tmp;
+ ncont->other.estk = estk;
+ ncont->other.estk_ptr = scm_estk_ptr;
return cont;
}
static char s_sstale[] = "strangely stale";
-void scm_dynthrow(cont, val)
- CONTINUATION *cont;
+void scm_dynthrow(tocont, val)
+ SCM tocont;
SCM val;
{
+ CONTINUATION *cont = CONT(tocont);
if (cont->stkbse != CONT(rootcont)->stkbse)
- wta(cont->other.dynenv, &s_sstale[10], s_cont);
- dowinds(cont->other.dynenv,
- ilength(dynwinds)-ilength(cont->other.dynenv));
+ wta(tocont, &s_sstale[10], s_cont);
+ dowinds(cont->other.dynenv);
{
- SCM *from, *to;
- sizet n = LENGTH(cont->other.env);
- if (LENGTH(scm_estk) < n)
- scm_estk_grow((n - (LENGTH(scm_estk))) / SCM_ESTK_FRLEN + 20);
DEFER_INTS;
- from = VELTS(cont->other.env);
- to = VELTS(scm_estk);
- scm_env = from[--n];
- scm_env_tmp = from[--n];
- scm_estk_ptr = &(to[n]) - SCM_ESTK_FRLEN;
- while(n--) to[n] = from[n];
+#ifdef CHEAP_CONTINUATIONS
+ scm_estk = cont->other.estk;
+ scm_estk_ptr = cont->other.estk_ptr;
+#else
+ {
+ SCM *from = VELTS(cont->other.estk);
+ SCM *to = VELTS(scm_estk);
+ sizet n = LENGTH(cont->other.estk);
+ if (LENGTH(scm_estk) < n)
+ scm_estk_reset((sizet)LENGTH(scm_estk));
+ scm_estk_ptr = &(to[n]) - SCM_ESTK_FRLEN;
+ while(n--) to[n] = from[n];
+ }
+#endif
+ scm_env = cont->other.stkframe[0];
+ scm_env_tmp = cont->other.stkframe[1];
ALLOW_INTS;
}
throw_to_continuation(cont, val, CONT(rootcont));
- wta(cont->other.dynenv, s_sstale, s_cont);
+ wta(tocont, s_sstale, s_cont);
}
SCM obhash(obj)
@@ -1523,67 +1688,132 @@ badhplims:
wta(UNDEFINED, s_nogrow, s_heap);
}
-smobfuns *smobs;
-sizet numsmob;
-long newsmob(smob)
- smobfuns *smob;
+/* Initialize a Growable arRAy, of initial size LEN, growing to at most
+ MAXLEN elements of size ELTSIZE */
+void scm_init_gra(gra, eltsize, len, maxlen, what)
+ scm_gra *gra;
+ sizet eltsize, len, maxlen;
+ char *what;
+{
+ char *nelts;
+ DEFER_INTS;
+ /* Can't call must_malloc, because heap may not be initialized yet. */
+ /* SYSCALL(nelts = malloc(len*eltsize););
+ if (!nelts) wta(MAKINUM(len*eltsize), (char *)NALLOC, what);
+ mallocated += len*eltsize;
+ */
+ nelts = must_malloc((long)len*eltsize, what);
+ gra->eltsize = eltsize;
+ gra->len = 0;
+ gra->elts = nelts;
+ gra->alloclen = len;
+ gra->maxlen = maxlen;
+ gra->what = what;
+ ALLOW_INTS;
+}
+/* Returns the index into the elt array */
+int scm_grow_gra(gra, elt)
+ scm_gra *gra;
+ char *elt;
{
+ int i;
char *tmp;
- if (255 <= numsmob) goto smoberr;
DEFER_INTS;
- SYSCALL(tmp = (char *)realloc((char *)smobs, (1+numsmob)*sizeof(smobfuns)););
- if (tmp) {
- smobs = (smobfuns *)tmp;
- smobs[numsmob].mark = smob->mark;
- smobs[numsmob].free = smob->free;
- smobs[numsmob].print = smob->print;
- smobs[numsmob].equalp = smob->equalp;
- numsmob++;
+ if (gra->alloclen <= gra->len) {
+ sizet inc = gra->len / 5 + 1;
+ sizet nlen = gra->len + inc;
+ if (gra->maxlen && nlen > gra->maxlen)
+ growerr: wta(MAKINUM(nlen), (char *)NALLOC, gra->what);
+ /*
+ SYSCALL(tmp = realloc(gra->elts, nlen*gra->eltsize););
+ if (!tmp) goto growerr;
+ mallocated += (nlen - gra->alloclen)*gra->eltsize;
+ */
+ tmp = must_realloc(gra->elts, (long)gra->alloclen*gra->eltsize,
+ (long)nlen*gra->eltsize, gra->what);
+ gra->elts = tmp;
+ gra->alloclen = nlen;
}
+ tmp = &gra->elts[gra->len*gra->eltsize];
+ gra->len += 1;
+ for (i = 0; i < gra->eltsize; i++)
+ tmp[i] = elt[i];
ALLOW_INTS;
- if (!tmp) smoberr: wta(MAKINUM((long)numsmob), (char *)NALLOC, "newsmob");
- return tc7_smob + (numsmob-1)*256;
+ return gra->len - 1;
+}
+void scm_free_gra(gra)
+ scm_gra *gra;
+{
+ free(gra->elts);
+ gra->elts = 0;
+ mallocated -= gra->maxlen*gra->eltsize;
+}
+scm_gra smobs_gra;
+long newsmob(smob)
+ smobfuns *smob;
+{
+ return tc7_smob + 256*scm_grow_gra(&smobs_gra, (char *)smob);
}
-ptobfuns *ptobs;
-sizet numptob;
+scm_gra ptobs_gra;
long newptob(ptob)
ptobfuns *ptob;
{
- char *tmp;
- if (255 <= numptob) goto ptoberr;
- DEFER_INTS;
- SYSCALL(tmp = (char *)realloc((char *)ptobs, (1+numptob)*sizeof(ptobfuns)););
- if (tmp) {
- ptobs = (ptobfuns *)tmp;
- ptobs[numptob].mark = ptob->mark;
- ptobs[numptob].free = ptob->free;
- ptobs[numptob].print = ptob->print;
- ptobs[numptob].equalp = ptob->equalp;
- ptobs[numptob].fputc = ptob->fputc;
- ptobs[numptob].fputs = ptob->fputs;
- ptobs[numptob].fwrite = ptob->fwrite;
- ptobs[numptob].fflush = ptob->fflush;
- ptobs[numptob].fgetc = ptob->fgetc;
- ptobs[numptob].fclose = ptob->fclose;
- numptob++;
+ return tc7_port + 256*scm_grow_gra(&ptobs_gra, (char *)ptob);
+}
+#define PORT_TABLE_MAXLEN (1 + ((int)((unsigned long)~0L>>20)))
+port_info *scm_port_table = 0;
+static int scm_port_table_len = 0;
+static char s_port_table[] = "port table";
+SCM scm_port_entry(ptype, flags)
+ long ptype, flags;
+{
+ int nlen;
+ int i, j;
+ VERIFY_INTS("scm_port_entry", 0L);
+ flags = flags | (ptype & ~0xffffL);
+ ASSERT(flags, INUM0, ARG1, "scm_port_entry");
+ for (i = 0; i < scm_port_table_len; i++)
+ if (0L==scm_port_table[i].flags) goto ret;
+ if (0==scm_port_table_len) { /* Initialize */
+ scm_port_table_len = 16;
+ scm_port_table = (port_info *)
+ must_malloc((long)scm_port_table_len*sizeof(port_info), s_port_table);
}
- ALLOW_INTS;
- if (!tmp) ptoberr: wta(MAKINUM((long)numptob), (char *)NALLOC, "newptob");
- return tc7_port + (numptob-1)*256;
+ else if (scm_port_table_len < PORT_TABLE_MAXLEN) {
+ nlen = scm_port_table_len + (scm_port_table_len / 2);
+ if (nlen > PORT_TABLE_MAXLEN) nlen = PORT_TABLE_MAXLEN;
+ scm_port_table = (port_info *)
+ must_realloc((char *)scm_port_table,
+ (long)scm_port_table_len*sizeof(port_info),
+ nlen*sizeof(port_info)+0L,
+ s_port_table);
+ scm_port_table_len = nlen;
+ growth_mon(s_port_table, nlen+0L, "entries", !0);
+ for (j = i; j < scm_port_table_len; j++) {
+ scm_port_table[j].flags = 0L;
+ scm_port_table[j].data = EOL;
+ }
+ }
+ else {
+ igc(s_port_table, CONT(rootcont)->stkbse);
+ for (i = 0; i < scm_port_table_len; i++)
+ if (0L==scm_port_table[i].flags) goto ret;
+ wta(UNDEFINED, s_nogrow, s_port_table);
+ }
+ ret:
+ scm_port_table[i].unread = EOF;
+ scm_port_table[i].flags = flags;
+ scm_port_table[i].line = 1L; /* should both be one-based? */
+ scm_port_table[i].col = 1;
+ scm_port_table[i].data = UNSPECIFIED;
+ return (((long)i)<<20) | (flags & 0x0f0000) | ptype;
}
+
SCM markcdr(ptr)
SCM ptr;
{
- if GC8MARKP(ptr) return BOOL_F;
- SETGC8MARK(ptr);
return CDR(ptr);
}
-SCM mark0(ptr)
- SCM ptr;
-{
- SETGC8MARK(ptr);
- return BOOL_F;
-}
sizet free0(ptr)
CELLPTR ptr;
{
@@ -1595,31 +1825,30 @@ SCM equal0(ptr1, ptr2)
return (CDR(ptr1)==CDR(ptr2)) ? BOOL_T : BOOL_F;
}
-/* statically allocated ports for diagnostic messages */
-static cell tmp_errpbuf[3];
-static SCM tmp_errp;
-
-static char remsg[] = "remove\n#define ", addmsg[] = "add\n#define ";
-extern sizet num_protects; /* sys_protects now in scl.c */
+static char remsg[] = "remove\n#define ", addmsg[] = "add\n#define ",
+ rdmsg[] = "reduce";
void init_storage(stack_start_ptr, init_heap_size)
STACKITEM *stack_start_ptr;
long init_heap_size;
{
- sizet j = num_protects;
+ sizet j;
/* Because not all protects may get initialized */
- while(j) sys_protects[--j] = BOOL_F;
- tmp_errp = PTR2SCM(CELL_UP(&tmp_errpbuf[0]));
- CAR(tmp_errp) = (SCM)(tc16_fport|OPN|WRTNG);
- CDR(tmp_errp) = (SCM)stderr;
freelist = EOL;
expmem = 0;
+#ifdef SHORT_SIZET
+ if (sizeof(sizet) >= sizeof(long))
+ fixconfig(remsg, "SHORT_SIZET", 0);
+#else
+ if (sizeof(sizet) < sizeof(long))
+ fixconfig(addmsg, "SHORT_SIZET", 0);
+#endif
#ifdef SHORT_INT
if (sizeof(int) >= sizeof(long))
- fixconfig(remsg, "SHORT_INT", 1);
+ fixconfig(remsg, "SHORT_INT", 0);
#else
if (sizeof(int) < sizeof(long))
- fixconfig(addmsg, "SHORT_INT", 1);
+ fixconfig(addmsg, "SHORT_INT", 0);
#endif
#ifdef CDR_DOUBLES
if (sizeof(double) != sizeof(long))
@@ -1640,6 +1869,8 @@ void init_storage(stack_start_ptr, init_heap_size)
if (DIGSPERLONG*sizeof(BIGDIG) > sizeof(long))
fixconfig(addmsg, "DIGSTOOBIG", 0);
# endif
+ if (NUMDIGS_MAX > (((unsigned long)-1L)>>16))
+ fixconfig(rdmsg, "NUMDIGS_MAX", 0);
#endif
#ifdef STACK_GROWS_UP
if (((STACKITEM *)&j - stack_start_ptr) < 0)
@@ -1650,7 +1881,7 @@ void init_storage(stack_start_ptr, init_heap_size)
#endif
j = HEAP_SEG_SIZE;
if (HEAP_SEG_SIZE != j)
- fixconfig("reduce", "size of HEAP_SEG_SIZE", 0);
+ fixconfig(rdmsg, "size of HEAP_SEG_SIZE", 0);
mtrigger = INIT_MALLOC_LIMIT;
mltrigger = mtrigger - MIN_MALLOC_YIELD;
@@ -1667,10 +1898,10 @@ void init_storage(stack_start_ptr, init_heap_size)
/* hplims[0] can change. do not remove heap_org */
NEWCELL(def_inp);
- CAR(def_inp) = (tc16_fport|OPN|RDNG);
+ CAR(def_inp) = scm_port_entry(tc16_fport, OPN|RDNG);
SETSTREAM(def_inp, stdin);
NEWCELL(def_outp);
- CAR(def_outp) = (tc16_fport|OPN|WRTNG);
+ CAR(def_outp) = scm_port_entry(tc16_fport, OPN|WRTNG|TRACKED);
SETSTREAM(def_outp, stdout);
NEWCELL(def_errp);
CAR(def_errp) = (tc16_fport|OPN|WRTNG);
@@ -1681,6 +1912,7 @@ void init_storage(stack_start_ptr, init_heap_size)
NEWCELL(sys_errp);
CAR(sys_errp) = (tc16_sysport|OPN|WRTNG);
SETSTREAM(sys_errp, 0);
+ sys_safep = mksafeport(0, def_errp);
dynwinds = EOL;
NEWCELL(rootcont);
SETCONT(rootcont, make_root_continuation(stack_start_ptr));
@@ -1708,14 +1940,8 @@ void init_storage(stack_start_ptr, init_heap_size)
scm_ecache_len = CELL_DN(ecache_v + scm_ecache_len - 1) - scm_ecache + 1;
scm_ecache_index = scm_ecache_len;
scm_egc_root_index = sizeof(scm_egc_roots)/sizeof(SCM);
- scm_estk_reset();
-
-#ifdef NUM_HP
- /* Allocate a very small initial num_hp in case
- we need it only for flo0. */
- num_hp_add(10*sizeof(double));
- num_hp_head = num_hp_cur;
-#endif /* def NUM_HP */
+ scm_estk = BOOL_F;
+ scm_estk_reset(0);
}
/* The way of garbage collecting which allows use of the cstack is due to */
@@ -1766,6 +1992,11 @@ SCM gc_for_newcell()
return fl;
}
+void gc_for_open_files()
+{
+ igc("open files", CONT(rootcont)->stkbse);
+}
+
void scm_fill_freelist()
{
while IMP(freelist) {
@@ -1783,7 +2014,10 @@ jump_buf save_regs_gc_mark;
void mark_locations P((STACKITEM x[], sizet n));
static void mark_syms P((SCM v));
static void mark_sym_values P((SCM v));
+static void mark_subr_table P((void));
static void sweep_symhash P((SCM v));
+static void mark_port_table P((SCM port));
+static void sweep_port_table P((void));
static void egc_mark P((void));
static void egc_sweep P((void));
@@ -1804,12 +2038,14 @@ void igc(what, stackbase)
{
int j = num_protects;
long oheap_cells = heap_cells;
- gc_start(what);
- if (++errjmp_bad > 1)
- wta(MAKINUM(errjmp_bad), s_recursive, s_gc);
-#ifdef NUM_HP
- num_hp_switch(); /* Switch half-heaps for flonums/bignums */
+#ifdef DEBUG_GMALLOC
+ int err = check_frag_blocks();
+ if (err) wta(MAKINUM(err), "malloc corrupted", what);
#endif
+ gc_start(what);
+ if (errjmp_bad)
+ wta(UNDEFINED, s_recursive, s_gc);
+ errjmp_bad = s_gc;
#ifdef NO_SYM_GC
gc_mark(symhash);
#else
@@ -1821,6 +2057,7 @@ void igc(what, stackbase)
/* mark_sym_values() can be called anytime after mark_syms. */
mark_sym_values(symhash);
#endif
+ mark_subr_table();
egc_mark();
if (stackbase) {
FLUSH_REGISTER_WINDOWS;
@@ -1855,15 +2092,10 @@ void igc(what, stackbase)
sweep_symhash(symhash);
#endif
gc_sweep(!stackbase);
+ sweep_port_table();
egc_sweep();
-#if 0 /* def NUM_HP */
- if (num_hp_cur) {
- num_hp *hp = num_hp_cur->next;
- num_hp_cur->next = 0;
- if (hp) num_hp_free(hp);
- }
-#endif
- --errjmp_bad;
+ estk_pool = EOL;
+ errjmp_bad = (char *)0;
gc_end();
if (oheap_cells != heap_cells) {
int grewp = heap_cells > oheap_cells;
@@ -1877,8 +2109,8 @@ void free_storage()
{
DEFER_INTS;
gc_start("free");
- ++errjmp_bad;
- cur_inp = BOOL_F; cur_outp = BOOL_F;
+ errjmp_bad = "free_storage";
+ cur_inp = BOOL_F; cur_outp = BOOL_F;
cur_errp = tmp_errp; sys_errp = tmp_errp;
gc_mark(def_inp); /* don't want to close stdin */
gc_mark(def_outp); /* don't want to close stdout */
@@ -1899,23 +2131,18 @@ void free_storage()
if (hplim_ind) wta((SCM)MAKINUM(hplim_ind), s_not_free, s_hplims);
/* Not all cells get freed (see gc_mark() calls above). */
/* if (cells_allocated) wta(MAKINUM(cells_allocated), s_not_free, "cells"); */
-#ifdef NUM_HP
- num_hp_free(num_hp_head);
-#endif
/* either there is a small memory leak or I am counting wrong. */
must_free((char *)hplims, 0);
/* if (mallocated) wta(MAKINUM(mallocated), s_not_free, "malloc"); */
hplims = 0;
- /* must_free((char *)smobs, numsmob * sizeof(smobfuns)); */
- free((char *)smobs);
- smobs = 0;
- gc_end();
+ scm_free_gra(&finals_gra);
+ scm_free_gra(&smobs_gra);
+ scm_free_gra(&subr_table_gra);
+ gc_end();
ALLOW_INTS; /* A really bad idea, but printing does it anyway. */
exit_report();
lflush(sys_errp);
- /* must_free((char *)ptobs, numptob * sizeof(ptobfuns)); */
- free((char *)ptobs);
- ptobs = 0;
+ scm_free_gra(&ptobs_gra);
lmallocated = mallocated = 0;
/* Can't do gc_end() here because it uses ptobs which have been freed */
fflush(stdout); /* in lieu of close */
@@ -2015,6 +2242,7 @@ void gc_mark(p)
case tc7_bvect:
case tc7_ivect:
case tc7_uvect:
+ case tc7_svect:
case tc7_fvect:
case tc7_dvect:
case tc7_cvect:
@@ -2022,59 +2250,36 @@ void gc_mark(p)
case tcs_subrs:
break;
case tc7_port:
+ if GC8MARKP(ptr) break;
+ SETGC8MARK(ptr);
i = PTOBNUM(ptr);
if (!(i < numptob)) goto def;
+ mark_port_table(ptr);
+ if (!ptobs[i].mark) break;
ptr = (ptobs[i].mark)(ptr);
goto gc_mark_loop;
case tc7_smob:
if GC8MARKP(ptr) break;
+ SETGC8MARK(ptr);
switch TYP16(ptr) { /* should be faster than going through smobs */
case tc_free_cell:
/* printf("found free_cell %X ", ptr); fflush(stdout); */
- SETGC8MARK(ptr);
ASSERT(tc_broken_heart!=CAR(ptr), ptr, "found ecache forward", s_gc);
/* CDR(ptr) = UNDEFINED */;
break;
#ifdef BIGDIG
case tcs_bignums:
-#ifdef NUM_HP
- if (NUMDIGS(ptr)*sizeof(BIGDIG) <= NUM_HP_MAX_REQ) {
- sizet i = NUMDIGS(ptr);
- BIGDIG *nw = (BIGDIG *)num_hp_alloc(i*sizeof(BIGDIG));
- while (i--) nw[i] = BDIGITS(ptr)[i];
- }
-#endif
- SETGC8MARK(ptr);
break;
#endif
#ifdef FLOATS
case tc16_flo:
-# ifdef NUM_HP
- {
- double *nw;
- switch ((int)(CAR(ptr)>>16)) {
- default: goto def;
- case (IMAG_PART | REAL_PART)>>16:
- nw = (double *)num_hp_alloc(2*sizeof(double));
- nw[0] = REAL(ptr);
- nw[1] = IMAG(ptr);
- CDR(ptr) = (SCM)nw;
- break;
- case REAL_PART>>16: case IMAG_PART>>16:
- nw = (double *)num_hp_alloc(sizeof(double));
- nw[0] = REAL(ptr);
- CDR(ptr) = (SCM)nw;
- break;
- case 0: break;
- }
- }
-# endif /* def NUM_HP */
- SETGC8MARK(ptr);
break;
#endif
default:
i = SMOBNUM(ptr);
if (!(i < numsmob)) goto def;
+ SETGC8MARK(ptr);
+ if (!smobs[i].mark) break;
ptr = (smobs[i].mark)(ptr);
goto gc_mark_loop;
}
@@ -2122,8 +2327,9 @@ static void gc_sweep(contin_bad)
# define scmptr (SCM)ptr
#endif
register SCM nfreelist = EOL;
- register long n = 0, m = 0;
+ register long n = 0;
register sizet j, minc;
+ long pre_m = mallocated;
sizet i = 0;
sizet seg_cells;
while (i<hplim_ind) {
@@ -2153,7 +2359,6 @@ static void gc_sweep(contin_bad)
if GC8MARKP(scmptr) goto c8mrkcontinue;
minc = (LENGTH(scmptr)*sizeof(SCM));
freechars:
- m += minc;
must_free(CHARS(scmptr), minc);
/* SETCHARS(scmptr, 0);*/
break;
@@ -2166,6 +2371,10 @@ static void gc_sweep(contin_bad)
if GC8MARKP(scmptr) goto c8mrkcontinue;
minc = HUGE_LENGTH(scmptr)*sizeof(long);
goto freechars;
+ case tc7_svect:
+ if GC8MARKP(scmptr) goto c8mrkcontinue;
+ minc = HUGE_LENGTH(scmptr)*sizeof(short);
+ goto freechars;
case tc7_fvect:
if GC8MARKP(scmptr) goto c8mrkcontinue;
minc = HUGE_LENGTH(scmptr)*sizeof(float);
@@ -2189,7 +2398,7 @@ static void gc_sweep(contin_bad)
case tc7_contin:
if GC8MARKP(scmptr) {
if (contin_bad && CONT(scmptr)->length) {
- warn("uncollected ", (char *)0);
+ scm_warn("uncollected ", (char *)0);
iprin1(scmptr, cur_errp, 1);
lputc('\n', cur_errp);
lfflush(cur_errp);
@@ -2197,6 +2406,7 @@ static void gc_sweep(contin_bad)
goto c8mrkcontinue;
}
minc = LENGTH(scmptr)*sizeof(STACKITEM) + sizeof(CONTINUATION);
+ mallocated = mallocated - minc;
free_continuation(CONT(scmptr)); break; /* goto freechars; */
case tc7_ssymbol:
if GC8MARKP(scmptr) goto c8mrkcontinue;
@@ -2211,7 +2421,7 @@ static void gc_sweep(contin_bad)
int k = PTOBNUM(scmptr);
if (!(k < numptob)) goto sweeperr;
/* Yes, I really do mean ptobs[k].free */
- /* rather than ftobs[k].close. .close */
+ /* rather than ptobs[k].close. .close */
/* is for explicit CLOSE-PORT by user */
(ptobs[k].free)(STREAM(scmptr));
gc_ports_collected++;
@@ -2227,16 +2437,12 @@ static void gc_sweep(contin_bad)
#ifdef BIGDIG
case tcs_bignums:
if GC8MARKP(scmptr) goto c8mrkcontinue;
-# ifdef NUM_HP
- if (NUMDIGS(scmptr)*sizeof(BIGDIG) <= NUM_HP_MAX_REQ) break;
-# endif /* def NUM_HP */
- minc = (NUMDIGS(scmptr)*BITSPERDIG/CHAR_BIT);
+ minc = (NUMDIGS(scmptr)*sizeof(BIGDIG));
goto freechars;
#endif /* def BIGDIG */
#ifdef FLOATS
case tc16_flo:
if GC8MARKP(scmptr) goto c8mrkcontinue;
-# ifndef NUM_HP
switch ((int)(CAR(scmptr)>>16)) {
case (IMAG_PART | REAL_PART)>>16:
minc = 2*sizeof(double);
@@ -2250,7 +2456,6 @@ static void gc_sweep(contin_bad)
default:
goto sweeperr;
}
-# endif /* ndef NUM_HP */
#endif /* def FLOATS */
break;
default:
@@ -2296,9 +2501,8 @@ static void gc_sweep(contin_bad)
}
lcells_allocated += (heap_cells - gc_cells_collected - cells_allocated);
cells_allocated = (heap_cells - gc_cells_collected);
- lmallocated -= m;
- mallocated -= m;
- gc_malloc_collected = m;
+ gc_malloc_collected = (pre_m - mallocated);
+ lmallocated = lmallocated - gc_malloc_collected;
}
#ifndef NO_SYM_GC
@@ -2376,6 +2580,37 @@ static void sweep_symhash(v)
}
#endif
+static void mark_subr_table()
+{
+ subr_info *table = subr_table;
+ int k = subr_table_gra.len;
+ /* while (k--) { } */
+}
+static void mark_port_table(port)
+ SCM port;
+{
+ int i = SCM_PORTNUM(port);
+ ASSERT(i>=0 && i<scm_port_table_len, MAKINUM(i), "bad port", s_gc);
+ if (i) {
+ scm_port_table[i].flags |= 1;
+ if (NIMP(scm_port_table[i].data))
+ gc_mark(scm_port_table[i].data);
+ }
+}
+static void sweep_port_table()
+{
+ int k;
+ /* tmp_errp gets entry 0, so we never clear its flags. */
+ for(k = scm_port_table_len - 1; k > 0; k--) {
+ if (scm_port_table[k].flags & 1)
+ scm_port_table[k].flags &= (~1L);
+ else {
+ scm_port_table[k].flags = 0L;
+ scm_port_table[k].data = EOL;
+ }
+ }
+}
+
/* Environment cache GC routines */
/* This is called during a non-cache gc. We only mark those stack frames
that are in use. */
@@ -2386,7 +2621,7 @@ static void egc_mark()
gc_mark(scm_env);
gc_mark(scm_env_tmp);
if IMP(scm_estk) return; /* Can happen when moving estk. */
- if GC8MARKP(scm_estk) return;
+ if GC8MARKP(scm_estk) return;
v = VELTS(scm_estk);
SETGC8MARK(scm_estk);
i = scm_estk_ptr - v + SCM_ESTK_FRLEN;
@@ -2407,6 +2642,13 @@ static void egc_sweep()
CLRGC8MARK(z);
}
}
+ /* Under some circumstances I don't fully understand, continuations may
+ point to dead ecache cells. This prevents gc marked cells from causing
+ errors during ecache gc. */
+ for (i = scm_ecache_index; i--;) {
+ scm_ecache[i].car = UNSPECIFIED;
+ scm_ecache[i].cdr = UNSPECIFIED;
+ }
}
#define ECACHEP(x) (PTR_LE((CELLPTR)(ecache_v), (CELLPTR)SCM2PTR(x)) && \
@@ -2437,7 +2679,7 @@ static void egc_copy(px)
} while (NIMP(x) && ECACHEP(x));
}
-static void egc_copy_stack(ve, len)
+static void egc_copy_locations(ve, len)
SCM *ve;
sizet len;
{
@@ -2451,7 +2693,18 @@ static void egc_copy_stack(ve, len)
egc_copy(&(ve[len]));
}
}
-
+static void egc_copy_stack(stk, len)
+ SCM stk;
+ sizet len;
+{
+ while (!0) {
+ egc_copy_locations(VELTS(stk), len);
+ len = INUM(SCM_ESTK_PARENT_INDEX(stk)) + SCM_ESTK_FRLEN;
+ stk =SCM_ESTK_PARENT(stk);
+ if IMP(stk) return;
+ /* len = LENGTH(stk); */
+ }
+}
extern long tc16_env, tc16_promise;
static void egc_copy_roots()
{
@@ -2476,17 +2729,20 @@ static void egc_copy_roots()
case tc3_cons_nimcar: /* These are environment frames that have
been destructively altered by DEFINE or
LETREC. This is only a problem if a
- non-cache cell was made to point into the
+ non-cache cell was made to point into the
cache. */
if ECACHEP(x) break;
e = CDR(x);
- if (NIMP(e) && ECACHEP(e))
+ if (NIMP(e) && ECACHEP(e))
egc_copy(&(CDR(x)));
break;
default:
if (tc7_contin==TYP7(x)) {
- x = CONT(x)->other.env;
- egc_copy_stack(VELTS(x), (sizet)LENGTH(x));
+ egc_copy_locations(CONT(x)->other.stkframe, 2);
+#ifndef CHEAP_CONTINUATIONS
+ x = CONT(x)->other.estk;
+ egc_copy_stack(x, LENGTH(x));
+#endif
break;
}
if (tc16_env==CAR(x)) {
@@ -2504,12 +2760,26 @@ static void egc_copy_roots()
scm_egc_root_index = sizeof(scm_egc_roots)/sizeof(SCM);
}
extern long scm_stk_moved, scm_clo_moved, scm_env_work;
+static int egc_need_gc()
+{
+ SCM fl = freelist;
+ int n;
+ if (heap_cells - cells_allocated <= scm_ecache_len)
+ return 1;
+ /* Interrupting a NEWCELL could leave cells_allocated inconsistent with
+ freelist, see handle_it() in repl.c */
+ for (n = 4; n; n--) {
+ if IMP(fl) return 1;
+ fl = CDR(fl);
+ }
+ return 0;
+}
void scm_egc()
{
- VERIFY_INTS("scm_egc", 0);
+ VERIFY_INTS("scm_egc", 0L);
/* We need to make sure there are enough cells available to migrate
the entire environment cache, gc does not work properly during ecache gc */
- while ((heap_cells - cells_allocated <= scm_ecache_len) || IMP(freelist)) {
+ while (egc_need_gc()) {
igc("ecache", CONT(rootcont)->stkbse);
if ((gc_cells_collected < MIN_GC_YIELD) ||
(heap_cells - cells_allocated <= scm_ecache_len) || IMP(freelist)) {
@@ -2518,8 +2788,8 @@ void scm_egc()
growth_mon(s_heap, heap_cells, s_cells, !0);
}
}
- if (++errjmp_bad > 1)
- wta(MAKINUM(errjmp_bad), s_recursive, s_cache_gc);
+ if (errjmp_bad)
+ wta(UNDEFINED, s_recursive, s_cache_gc);
{
SCM stkframe[2];
long lcells = cells_allocated;
@@ -2531,8 +2801,8 @@ void scm_egc()
egc_copy_roots();
scm_clo_moved += cells_allocated - lcells;
lcells = cells_allocated;
- egc_copy_stack(stkframe, sizeof(stkframe)/sizeof(SCM));
- egc_copy_stack(VELTS(scm_estk), nstk);
+ egc_copy_locations(stkframe, sizeof(stkframe)/sizeof(SCM));
+ egc_copy_stack(scm_estk, nstk);
scm_env = stkframe[0];
scm_env_tmp = stkframe[1];
scm_stk_moved += cells_allocated - lcells;
@@ -2540,6 +2810,5 @@ void scm_egc()
scm_env_work += scm_ecache_len;
scm_egc_end();
}
- --errjmp_bad;
+ errjmp_bad = (char *)0;
}
-
generated by cgit v1.2.3 (git 2.39.1) at 2024-11-05 17:54:37 +0000