From 3278b75942bdbe706f7a0fba87729bb1e935b68b Mon Sep 17 00:00:00 2001 From: Bryan Newbold Date: Mon, 20 Feb 2017 00:05:25 -0800 Subject: Import Upstream version 5d2 --- sys.c | 1201 ++++++++++++++++++++++++++++++++++++++++------------------------- 1 file changed, 735 insertions(+), 466 deletions(-) (limited to 'sys.c') 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 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 (ilength) { - 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 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; } - -- cgit v1.2.3