diff options
Diffstat (limited to 'sys.c')
| -rw-r--r-- | sys.c | 664 |
1 files changed, 491 insertions, 173 deletions
@@ -1,4 +1,4 @@ -/* Copyright (C) 1990, 1991, 1992, 1993, 1994, 1995, 1996, 1997 Free Software Foundation, Inc. +/* Copyright (C) 1990, 1991, 1992, 1993, 1994, 1995, 1996, 1997, 2002 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 @@ -15,26 +15,26 @@ * 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. + * for additional uses of the text contained in its release of SCM. * - * The exception is that, if you link the GUILE library with other files + * The exception is that, if you link the SCM library with other files * to produce an executable, this does not by itself cause the * resulting executable to be covered by the GNU General Public License. * Your use of that executable is in no way restricted on account of - * linking the GUILE library code into it. + * linking the SCM library code into it. * * This exception does not however invalidate any other reasons why * the executable file might be covered by the GNU General Public License. * * This exception applies only to the code released by the - * Free Software Foundation under the name GUILE. If you copy + * Free Software Foundation under the name SCM. If you copy * code from other Free Software Foundation releases into a copy of - * GUILE, as the General Public License permits, the exception does + * SCM, as the General Public License permits, the exception does * not apply to the code that you add in this way. To avoid misleading * anyone as to the status of such modified files, you must delete * this exception notice from them. * - * If you write modifications of your own for GUILE, it is your choice + * If you write modifications of your own for SCM, it is your choice * whether to permit this exception to apply to your modifications. * If you do not wish that, delete this exception notice. */ @@ -48,6 +48,7 @@ void igc P((char *what, STACKITEM *stackbase)); void lfflush P((SCM port)); /* internal SCM call */ SCM *loc_open_file; /* for open-file callback */ +SCM *loc_try_create_file; /* ttyname() etc. should be defined in <unistd.h>. But unistd.h is missing on many systems. */ @@ -57,7 +58,7 @@ SCM *loc_open_file; /* for open-file callback */ char *tmpnam P((char *s)); sizet fwrite (); # ifdef sun -# ifndef __svr4__ +# ifndef __SVR4 int fputs P((char *s, FILE* stream)); int fputc P((char c, FILE* stream)); int fflush P((FILE* stream)); @@ -72,15 +73,20 @@ SCM *loc_open_file; /* for open-file callback */ # ifdef linux # include <unistd.h> # endif +# ifdef __OpenBSD__ +# include <unistd.h> +# endif #endif static void gc_sweep P((int contin_bad)); char s_nogrow[] = "could not grow", s_heap[] = "heap", - s_hplims[] = "hplims"; + s_hplims[] = "hplims", s_try_create_file[] = "try-create-file"; + static char s_segs[] = "segments", s_numheaps[] = "number of heaps"; static char s_input_portp[] = "input-port?", s_output_portp[] = "output-port?"; +static char s_port_closedp[] = "port-closed?"; static char s_try_open_file[] = "try-open-file"; #define s_open_file (&s_try_open_file[4]) char s_close_port[] = "close-port"; @@ -102,7 +108,9 @@ char s_close_port[] = "close-port"; # else # ifndef macintosh # ifndef ARM_ULIB -# include <sys/ioctl.h> +# ifndef PLAN9 +# include <sys/ioctl.h> +# endif # endif # endif # endif @@ -129,7 +137,10 @@ SCM i_setbuf0(port) /* should be called with DEFER_INTS active */ /* The CRDY bit is overloaded to indicate that additional processing is needed when reading or writing, such as updating line and column - numbers. */ + numbers. Returns 0 if cmodes is non-null and modes string is not + valid. */ +/* If nonnull, the CMODES argument receives a copy of all chars in MODES + which are allowed by ANSI C. */ long mode_bits(modes, cmodes) char *modes, *cmodes; { @@ -143,10 +154,15 @@ long mode_bits(modes, cmodes) case 'b': bits |= BINARY; goto outc; case '0': bits |= BUF0; break; case '?': bits |= (TRACKED | CRDY); break; + case 'x': bits |= EXCLUSIVE; break; outc: if (cmodes && (iout < 3)) cmodes[iout++] = *modes; break; } - if (cmodes) cmodes[iout] = 0; - return bits; + if (!cmodes) return bits; + cmodes[iout] = 0; + switch (cmodes[0]) { + default: return 0; + case 'r': case 'w': case 'a': return bits; + } } SCM try_open_file(filename, modes) @@ -155,18 +171,22 @@ SCM try_open_file(filename, modes) register SCM port; FILE *f; char cmodes[4]; - long flags = mode_bits(CHARS(modes), cmodes); + long flags; ASSERT(NIMP(filename) && STRINGP(filename), filename, ARG1, s_open_file); - ASSERT(NIMP(modes) && STRINGP(modes), modes, ARG2, s_open_file); - NEWCELL(port); + ASSERT(NIMP(modes) && (STRINGP(modes) || SYMBOLP(modes)), modes, ARG2, s_open_file); + flags = mode_bits(CHARS(modes), cmodes); + ASSERT(flags, modes, ARG2, s_open_file); + if ((EXCLUSIVE & flags) && NIMP(*loc_try_create_file)) { + port = apply(*loc_try_create_file, filename, cons(modes, listofnull)); + if (UNSPECIFIED != port) return port; + } DEFER_INTS; - SCM_OPENCALL(f = fopen(CHARS(filename), cmodes)); + 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); + port = scm_port_entry(f, tc16_fport, flags); if (BUF0 & flags) i_setbuf0(port); ALLOW_INTS; SCM_PORTDATA(port) = filename; @@ -182,6 +202,7 @@ SCM open_file(filename, modes) cons(modes, listofnull)); } +long tc16_clport; SCM close_port(port) SCM port; { @@ -194,6 +215,10 @@ SCM close_port(port) SYSCALL((ptobs[i].fclose)(STREAM(port));); } CAR(port) &= ~OPN; + SCM_PORTFLAGS(port) &= ~OPN; + /* Bash the old ptobnum with the closed port ptobnum. + This allows catching some errors cheaply. */ + SCM_SET_PTOBNUM(port, tc16_clport); ALLOW_INTS; return UNSPECIFIED; } @@ -209,6 +234,24 @@ SCM output_portp(x) if IMP(x) return BOOL_F; return OUTPORTP(x) ? BOOL_T : BOOL_F; } +SCM port_closedp(port) + SCM port; +{ + ASSERT(NIMP(port) && PORTP(port), port, ARG1, s_port_closedp); + if CLOSEDP(port) return BOOL_T; + return BOOL_F; +} +SCM scm_port_type(port) + SCM port; +{ + int i; + if (NIMP(port) && PORTP(port)) { + i = PTOBNUM(port); + if (ptobs[i].name) return CAR(sysintern(ptobs[i].name, UNDEFINED)); + return BOOL_T; + } + return BOOL_F; +} #if (__TURBOC__==1) # undef L_tmpnam /* Not supported in TURBOC V1.0 */ @@ -307,16 +350,25 @@ void prinport(exp, port, type) # ifndef _DCC # ifndef AMIGA # ifndef macintosh +# ifndef PLAN9 if (OPENP(exp) && tc16_fport==TYP16(exp) && isatty(fileno(STREAM(exp)))) lputs(ttyname(fileno(STREAM(exp))), port); else +# endif # endif # endif # endif # endif #endif - if OPFPORTP(exp) intprint((long)fileno(STREAM(exp)), 10, port); - else intprint(CDR(exp), -16, port); + { + SCM s = PORTP(exp) ? SCM_PORTDATA(exp) : UNDEFINED; + if (NIMP(s) && STRINGP(s)) + iprin1(s, port, 1); + else if (OPFPORTP(exp)) + intprint((long)fileno(STREAM(exp)), 10, port); + else + intprint(CDR(exp), -16, port); + } lputc('>', port); } @@ -357,6 +409,24 @@ static int stgetc(p) CAR(p) = MAKINUM(ind + 1); return UCHARS(CDR(p))[ind]; } +static int stclose(p) + SCM p; +{ + SETCDR(p, nullstr); + return 0; +} +static int stungetc(c, p) + int c; + SCM p; +{ + sizet ind; + p = CDR(p); + ind = INUM(CAR(p)); + if (ind == 0) return EOF; + CAR(p) = MAKINUM(--ind); + ASSERT(UCHARS(CDR(p))[ind] == c, MAKICHR(c), "stungetc", ""); + return c; +} int noop0(stream) FILE *stream; { @@ -375,7 +445,8 @@ SCM mkstrport(pos, str, modes, caller) NEWCELL(z); DEFER_INTS; SETCHARS(z, str); - CAR(z) = scm_port_entry(tc16_strport, modes); + CAR(z) = (modes | tc16_strport); /* port table entry 0 is scratch. */ + /* z = scm_port_entry((FILE *)str, tc16_strport, modes); */ ALLOW_INTS; return z; } @@ -432,7 +503,7 @@ static ptobfuns fptob = { ptobfuns pipob = { 0, mark0, - 0, /* replaced by pclose in init_ioext() */ + 0, /* replaced by pclose in init_posix() */ 0, 0, fputc, @@ -456,8 +527,8 @@ static ptobfuns stptob = { stwrite, noop0, stgetc, - 0}; /* stungetc */ - + stclose, + stungetc}; /* Soft ports */ @@ -523,6 +594,7 @@ SCM mksfpt(pv, modes) SCM pv, modes; { SCM z; + long flags; static long arities[] = {1, 1, 0, 0, 0}; #ifndef RECKLESS int i; @@ -534,11 +606,11 @@ SCM mksfpt(pv, modes) badarg); } #endif - ASSERT(NIMP(modes) && STRINGP(modes), modes, ARG2, s_mksfpt); - NEWCELL(z); + ASSERT(NIMP(modes) && (STRINGP(modes) || SYMBOLP(modes)), modes, ARG2, s_mksfpt); + flags = mode_bits(CHARS(modes), (char *)0); + ASSERT(flags, modes, ARG2, s_mksfpt); DEFER_INTS; - CAR(z) = scm_port_entry(tc16_sfport, mode_bits(CHARS(modes), (char *)0)); - SETSTREAM(z, pv); + z = scm_port_entry((FILE *)pv, tc16_sfport, flags); ALLOW_INTS; return z; } @@ -556,6 +628,42 @@ static ptobfuns sfptob = { sfgetc, sfclose}; + /* Closed ports, just return an error code and let + the caller complain. */ +static int clputc(c, p) + int c; FILE *p; +{ + return EOF; +} +static sizet clwrite(str, siz, num, p) + sizet siz, num; + char *str; FILE *p; +{ + return 0; +} +static int clputs(s, p) + char *s; FILE *p; +{ + return EOF; +} +static int clgetc(p) + FILE *p; +{ + return EOF; +} +static ptobfuns clptob = { + s_port_type, + mark0, + noop0, + 0, + 0, + clputc, + clputs, + clwrite, + clgetc, + clgetc, + 0}; + /* The following ptob is for printing system messages in an interrupt-safe way. Writing to sys_errp while interrupts are disabled will never enable interrupts, do any actual i/o, or any allocation. Messages will be @@ -583,7 +691,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) { - scm_warn("output buffer", " overflowed"); + scm_warn("output buffer", " overflowed", UNDEFINED); intprint((long)errbuf_end, 10, cur_errp); lputs(" chars needed\n", cur_errp); errbuf_end = errbuf_end % SYS_ERRP_SIZE; @@ -644,16 +752,12 @@ SCM mksafeport(maxlen, port) { SCM z; if UNBNDP(port) port = cur_errp; - else { - ASSERT(NIMP(port) && OPPORTP(port), port, ARG2, s_msp); - } - DEFER_INTS; + ASSERT(NIMP(port) && OPPORTP(port), port, ARG2, s_msp); 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) @@ -685,7 +789,7 @@ static sizet safewrite(str, siz, num, p) lputs(" ...", p->port); longjmp(p->jmpbuf, !0); /* The usual C longjmp, not SCM's longjump */ } - return siz; + return num; } static int safeputs(s, p) char *s; safeport *p; @@ -787,33 +891,35 @@ extern sizet num_protects; /* sys_protects now in scl.c */ void init_types() { sizet j = num_protects; - /* Because not all protects may get initialized */ - while(j) sys_protects[--j] = BOOL_F; + while(j) sys_protects[--j] = UNDEFINED; /* We need to set up tmp_errp before any errors may be - thrown, the port_table index will be zero, usable + thrown, the port_table index will be zero, usable by 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); + CAR(tmp_errp) = tc16_fport | OPN | WRTNG; + /* 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"); + /* subrs_gra is trimmed to actual used by scm_init_extensions() */ + scm_init_gra(&subrs_gra, sizeof(subr_info), 420 , 0, "subrs"); + scm_init_gra(&ptobs_gra, sizeof(ptobfuns), 8, 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_clport = newptob(&clptob); tc16_sysport = newptob(&sysptob); tc16_safeport = newptob(&safeptob); - scm_init_gra(&smobs_gra, sizeof(smobfuns), 7, 255, "smobs"); + scm_init_gra(&smobs_gra, sizeof(smobfuns), 16, 255, "smobs"); /* These newsmob calls must be done in this order */ newsmob(&freecell); newsmob(&flob); newsmob(&bigob); newsmob(&bigob); - scm_init_gra(&finals_gra, sizeof(void (*)()), 2, 0, s_final); + scm_init_gra(&finals_gra, sizeof(void (*)()), 4, 0, s_final); } #ifdef TEST_FINAL @@ -828,6 +934,24 @@ void add_final(final) scm_grow_gra(&finals_gra, (char *)&final); } +static SCM gc_finalizers = EOL, gc_finalizers_pending = EOL; +static char s_add_finalizer[] = "add-finalizer"; +SCM scm_add_finalizer(value, finalizer) + SCM value, finalizer; +{ + SCM z; + ASSERT(NIMP(value), value, ARG1, s_add_finalizer); +#ifndef RECKLESS + scm_arity_check(finalizer, 0L, s_add_finalizer); +#endif + z = acons(value, finalizer, EOL); + DEFER_INTS; + CDR(z) = gc_finalizers; + gc_finalizers = z; + ALLOW_INTS; + return UNSPECIFIED; +} + static char s_estk[] = "environment stack"; static cell ecache_v[ECACHE_SIZE]; SCM scm_egc_roots[ECACHE_SIZE/20]; @@ -877,7 +1001,7 @@ void scm_estk_reset(size) 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; + scm_estk_size = size + 0L; } void scm_estk_grow() { @@ -891,7 +1015,7 @@ void scm_estk_grow() sizet i, j; newv = VELTS(estk); oldv = VELTS(scm_estk); - j = scm_estk_ptr - VELTS(scm_estk) + SCM_ESTK_FRLEN - overlap; + j = scm_estk_ptr - oldv + 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); @@ -901,19 +1025,18 @@ void scm_estk_grow() } scm_estk = estk; scm_estk_ptr = &(newv[SCM_ESTK_BASE + overlap]); - scm_estk_size += size; + scm_estk_size += size + 0L; /* growth_mon(s_estk, scm_estk_size, "locations", !0); */ } void scm_estk_shrink() { - SCM parent, *v; + SCM parent; 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); + parent = make_stk_seg((sizet)LENGTH(parent), parent); SCM_ESTK_PARENT(scm_estk) = estk_pool; estk_pool = scm_estk; scm_estk_size -= LENGTH(scm_estk); @@ -961,27 +1084,32 @@ void scm_env_cons2(w, x, y) scm_ecache_index = i; } -/* scm_env_tmp = cons(x, scm_env_tmp) */ -void scm_env_cons_tmp(x) - SCM x; +void scm_env_cons3(v, w, x, y) + SCM v, w, x, y; { - register SCM z; + SCM z1, z2; register int i; DEFER_INTS_EGC; i = scm_ecache_index; - if (1>i) { + if (3>i) { scm_egc(); i = scm_ecache_index; } - z = PTR2SCM(&(scm_ecache[--i])); - CAR(z) = x; - CDR(z) = scm_env_tmp; - scm_env_tmp = z; + z1 = PTR2SCM(&(scm_ecache[--i])); + CAR(z1) = x; + CDR(z1) = y; + z2 = PTR2SCM(&(scm_ecache[--i])); + CAR(z2) = w; + CDR(z2) = z1; + z1 = PTR2SCM(&(scm_ecache[--i])); + CAR(z1) = v; + CDR(z1) = z2; + scm_env_tmp = z1; scm_ecache_index = i; } void scm_env_v2lst(argc, argv) - int argc; + long argc; SCM *argv; { SCM z1, z2; @@ -1004,7 +1132,23 @@ void scm_env_v2lst(argc, argv) } /* scm_env = acons(names, scm_env_tmp, scm_env) */ -void scm_extend_env(names) +void scm_extend_env() +{ + SCM z; + register int i; + DEFER_INTS_EGC; + i = scm_ecache_index; + if (1>i) { + scm_egc(); + i = scm_ecache_index; + } + z = PTR2SCM(&(scm_ecache[--i])); + CAR(z) = scm_env_tmp; + CDR(z) = scm_env; + scm_env = z; + scm_ecache_index = i; +} +void old_scm_extend_env(names) SCM names; { SCM z1, z2; @@ -1028,15 +1172,17 @@ char s_obunhash[] = "object-unhash", s_cache_gc[] = "cache_gc"; char s_recursive[] = "recursive"; #define s_gc (s_cache_gc+6) static iproc subr0s[] = { - /* {s_gc, gc}, */ {"tmpnam", ltmpnam}, + {"open-ports", scm_open_ports}, {0, 0}}; static iproc subr1s[] = { {s_input_portp, input_portp}, {s_output_portp, output_portp}, + {s_port_closedp, port_closedp}, {s_close_port, close_port}, {"eof-object?", eof_objectp}, + {"port-type", scm_port_type}, {s_cwos, cwos}, {"object-hash", obhash}, {s_obunhash, obunhash}, @@ -1047,6 +1193,7 @@ static iproc subr2s[] = { {s_try_open_file, try_open_file}, {s_cwis, cwis}, {s_mksfpt, mksfpt}, + {s_add_finalizer, scm_add_finalizer}, {0, 0}}; SCM dynwind P((SCM thunk1, SCM thunk2, SCM thunk3)); @@ -1060,6 +1207,7 @@ void init_io() loc_open_file = &CDR(sysintern(s_open_file, CDR(sysintern(s_try_open_file, UNDEFINED)))); + loc_try_create_file = &CDR(sysintern(s_try_create_file, UNDEFINED)); #ifndef CHEAP_CONTINUATIONS add_feature("full-continuation"); #endif @@ -1079,6 +1227,7 @@ long heap_cells = 0; CELLPTR *hplims, heap_org; VOLATILE SCM freelist = EOL; long mltrigger, mtrigger = INIT_MALLOC_LIMIT; +int gc_hook_pending = 0, gc_hook_active = 0; /* Ints should be deferred when calling igc_for_alloc. */ static char *igc_for_alloc(where, olen, size, what) @@ -1090,17 +1239,16 @@ 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); + ASSERT(heap_cells > 0, MAKINUM(size), NALLOC, what); +/* printf("igc_for_alloc(%lx, %lu, %u, %s)\n", where, olen, size, what); fflush(stdout); */ igc(what, CONT(rootcont)->stkbse); nm = mallocated + size - olen; if (nm > mltrigger) { if (nm > mtrigger) grew_lim(nm + nm/2); else grew_lim(mtrigger + mtrigger/2); } - if (where) - SYSCALL(ptr = (char *)realloc(where, size);); - else - SYSCALL(ptr = (char *)malloc(size);); + if (where) SYSCALL(ptr = (char *)realloc(where, size);); + else SYSCALL(ptr = (char *)malloc(size);); ASSERT(ptr, MAKINUM(size), NALLOC, what); if (nm > mltrigger) { if (nm > mtrigger) mtrigger = nm + nm/2; @@ -1121,14 +1269,11 @@ char *must_malloc(len, 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(0L, 0L, size, what); - else - mallocated = nm; + if (nm <= mtrigger) SYSCALL(ptr = (char *)malloc(size);); + else ptr = 0; + if (!ptr) ptr = igc_for_alloc(0L, 0L, size, what); + else mallocated = nm; +/* printf("must_malloc(%lu, %s) => %lx\n", len, what, ptr); fflush(stdout); */ return ptr; } SCM must_malloc_cell(len, c, what) @@ -1145,14 +1290,11 @@ SCM must_malloc_cell(len, c, what) 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(0L, 0L, size, what); - else - mallocated = nm; + if (nm <= mtrigger) SYSCALL(ptr = (char *)malloc(size);); + else ptr = 0; + if (!ptr) ptr = igc_for_alloc(0L, 0L, size, what); + else mallocated = nm; +/* printf("must_malloc_cell(%lu, %lx, %s) => %lx\n", len, c, what, ptr); fflush(stdout); */ SETCHARS(z, ptr); CAR(z) = c; return z; @@ -1169,14 +1311,13 @@ char *must_realloc(where, olen, len, 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); - else - mallocated = nm; + ASSERT(!errjmp_bad, MAKINUM(len), NALLOC, what); +/* printf("must_realloc(%lx, %lu, %lu, %s)\n", where, olen, len, what); fflush(stdout); + printf("nm = %ld <= mtrigger = %ld: %d; size = %u\n", nm, mtrigger, (nm <= mtrigger), size); fflush(stdout); */ + if (nm <= mtrigger) SYSCALL(ptr = (char *)realloc(where, size);); + else ptr = 0; + if (!ptr) ptr = igc_for_alloc(where, olen, size, what); + else mallocated = nm; return ptr; } void must_realloc_cell(z, olen, len, what) @@ -1191,14 +1332,12 @@ void must_realloc_cell(z, olen, len, 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); - else - mallocated = nm; + ASSERT(!errjmp_bad, MAKINUM(len), NALLOC, what); +/* printf("must_realloc_cell(%lx, %lu, %lu, %s)\n", z, olen, len, what); fflush(stdout); */ + if (nm <= mtrigger) SYSCALL(ptr = (char *)realloc(where, size);); + else ptr = 0; + if (!ptr) ptr = igc_for_alloc(where, olen, size, what); + else mallocated = nm; SETCHARS(z, ptr); } void must_free(obj, len) @@ -1209,6 +1348,7 @@ void must_free(obj, len) #ifdef CAREFUL_INTS while (len--) obj[len] = '#'; #endif +/* printf("free(%lx)\n", obj); fflush(stdout); */ free(obj); mallocated = mallocated - len; } @@ -1243,7 +1383,7 @@ 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); */ + /* 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); @@ -1256,8 +1396,7 @@ SCM intern(name, len) trynext: ; } /* lsym = makfromstr(name, len); */ - lsym = must_malloc_cell(len+1L, - MAKE_LENGTH((long)len, tc7_msymbol), s_string); + lsym = must_malloc_cell(len+1L, MAKE_LENGTH(len, tc7_msymbol), s_string); i = len; CHARS(lsym)[len] = 0; while (i--) CHARS(lsym)[i] = name[i]; @@ -1284,16 +1423,15 @@ 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); - if (!UNBNDP(val)) - CDR(lsym) = val; + if (!UNBNDP(val)) CDR(lsym) = val; + else if (UNBNDP(CDR(lsym)) && tc7_msymbol==TYP7(CAR(lsym))) + scm_gc_protect(lsym); return lsym; trynext: ; } NEWCELL(lsym); - DEFER_INTS; - SETLENGTH(lsym, (long)len, tc7_ssymbol); + SETLENGTH(lsym, len, tc7_ssymbol); SETCHARS(lsym, name); - ALLOW_INTS; lsym = cons(lsym, val); z = cons(lsym, UNDEFINED); CDR(z) = VELTS(symhash)[hash]; @@ -1350,7 +1488,7 @@ SCM makstr(len) return s; } -scm_gra subr_table_gra; +scm_gra subrs_gra; SCM scm_maksubr(name, type, fcn) const char *name; int type; @@ -1360,7 +1498,7 @@ SCM scm_maksubr(name, type, fcn) int isubr; register SCM z; info.name = name; - isubr = scm_grow_gra(&subr_table_gra, (char *)&info); + isubr = scm_grow_gra(&subrs_gra, (char *)&info); NEWCELL(z); if (!fcn && tc7_cxr==type) { const char *p = name; @@ -1484,7 +1622,7 @@ SCM scm_make_cont() #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); + MAKE_LENGTH(n, tc7_vector), s_cont); { SCM *to = VELTS(estk); while(n--) to[n] = from[n]; @@ -1500,6 +1638,10 @@ SCM scm_make_cont() ncont->other.stkframe[1] = scm_env_tmp; ncont->other.estk = estk; ncont->other.estk_ptr = scm_estk_ptr; +#ifndef RECKLESS + ncont->other.stkframe[2] = scm_trace_env; + ncont->other.stkframe[3] = scm_trace; +#endif return cont; } static char s_sstale[] = "strangely stale"; @@ -1521,14 +1663,17 @@ void scm_dynthrow(tocont, val) 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)); + 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]; +#ifndef RECKLESS + scm_trace_env = cont->other.stkframe[2]; + scm_trace = cont->other.stkframe[3]; +#endif ALLOW_INTS; } throw_to_continuation(cont, val, CONT(rootcont)); @@ -1621,6 +1766,24 @@ static void fixconfig(s1, s2, s) quit(MAKINUM(1L)); } +void heap_report() +{ + sizet i = 0; + if (hplim_ind) lputs("; heap segments:", sys_errp); + while(i < hplim_ind) { + { + long seg_cells = CELL_DN(hplims[i+1]) - CELL_UP(hplims[i]); + lputs("\n; 0x", sys_errp); + intprint((long)hplims[i++], -16, sys_errp); + lputs(" - 0x", sys_errp); + intprint((long)hplims[i++], -16, sys_errp); + lputs("; ", sys_errp); + intprint(seg_cells, 10, sys_errp); + lputs(" cells; ", sys_errp); + intprint(seg_cells / (1024 / sizeof(CELLPTR)), 10, sys_errp); + lputs(".kiB", sys_errp); + }} +} sizet init_heap_seg(seg_org, size) CELLPTR seg_org; sizet size; @@ -1641,6 +1804,8 @@ sizet init_heap_seg(seg_org, size) hplims[ni++] = seg_end; ptr = CELL_UP(ptr); ni = seg_end - ptr; +/* printf("ni = %u; hplim_ind = %u\n", ni, hplim_ind); */ +/* printf("ptr = %lx\n", ptr); */ for (i = ni;i--;ptr++) { #ifdef POINTERS_MUNGED scmptr = PTR2SCM(ptr); @@ -1696,12 +1861,12 @@ void scm_init_gra(gra, eltsize, len, maxlen, what) char *what; { char *nelts; - DEFER_INTS; + /* 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; @@ -1709,7 +1874,7 @@ void scm_init_gra(gra, eltsize, len, maxlen, what) gra->alloclen = len; gra->maxlen = maxlen; gra->what = what; - ALLOW_INTS; + /* ALLOW_INTS; */ } /* Returns the index into the elt array */ int scm_grow_gra(gra, elt) @@ -1718,12 +1883,11 @@ int scm_grow_gra(gra, elt) { int i; char *tmp; - DEFER_INTS; 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); + /* growerr: */ wta(MAKINUM(nlen), (char *)NALLOC, gra->what); /* SYSCALL(tmp = realloc(gra->elts, nlen*gra->eltsize);); if (!tmp) goto growerr; @@ -1738,9 +1902,22 @@ int scm_grow_gra(gra, elt) gra->len += 1; for (i = 0; i < gra->eltsize; i++) tmp[i] = elt[i]; - ALLOW_INTS; return gra->len - 1; } +void scm_trim_gra(gra) + scm_gra *gra; +{ + char *tmp; + long curlen = gra->len; + if (0L==curlen) curlen = 1L; + if (curlen==(long)gra->alloclen) return; + tmp = must_realloc(gra->elts, + (long)gra->alloclen * gra->eltsize, + curlen * gra->eltsize, + gra->what); + gra->elts = tmp; + gra->alloclen = curlen; +} void scm_free_gra(gra) scm_gra *gra; { @@ -1748,6 +1925,26 @@ void scm_free_gra(gra) gra->elts = 0; mallocated -= gra->maxlen*gra->eltsize; } +void gra_report1(gra) + scm_gra *gra; +{ + intprint((long)gra->len, -10, cur_errp); + lputs(" (of ", cur_errp); + intprint((long)gra->alloclen, -10, cur_errp); + lputs(") ", cur_errp); + lputs(gra->what, cur_errp); + lputs("; ", cur_errp); +} +void gra_report() +{ + lputs(";; gra: ", cur_errp); + gra_report1(&ptobs_gra); + gra_report1(&smobs_gra); + gra_report1(&finals_gra); + gra_report1(&subrs_gra); + lputs("\n", cur_errp); +} + scm_gra smobs_gra; long newsmob(smob) smobfuns *smob; @@ -1760,38 +1957,35 @@ long newptob(ptob) { 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 sizet scm_port_table_len = 0; static char s_port_table[] = "port table"; -SCM scm_port_entry(ptype, flags) +SCM scm_port_entry(stream, ptype, flags) + FILE *stream; long ptype, flags; { - int nlen; + SCM z; + sizet 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++) + for (i = 1; 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); - } - else if (scm_port_table_len < PORT_TABLE_MAXLEN) { + if (scm_port_table_len <= SCM_PORTNUM_MAX) { nlen = scm_port_table_len + (scm_port_table_len / 2); - if (nlen > PORT_TABLE_MAXLEN) nlen = PORT_TABLE_MAXLEN; + if (nlen >= SCM_PORTNUM_MAX) nlen = (sizet)SCM_PORTNUM_MAX + 1; scm_port_table = (port_info *) must_realloc((char *)scm_port_table, - (long)scm_port_table_len*sizeof(port_info), - nlen*sizeof(port_info)+0L, + (long)scm_port_table_len * sizeof(port_info), + (long)nlen * sizeof(port_info), s_port_table); scm_port_table_len = nlen; - growth_mon(s_port_table, nlen+0L, "entries", !0); + 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; + scm_port_table[j].data = UNDEFINED; + scm_port_table[j].port = UNDEFINED; } } else { @@ -1801,12 +1995,27 @@ SCM scm_port_entry(ptype, flags) wta(UNDEFINED, s_nogrow, s_port_table); } ret: + NEWCELL(z); + SETSTREAM(z, stream); + CAR(z) = (((long)i)<<20) | (flags & 0x0f0000) | ptype; 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_port_table[i].port = z; + return z; +} +SCM scm_open_ports() +{ + SCM p, res = EOL; + int k; + for(k = scm_port_table_len - 1; k > 0; k--) { + p = scm_port_table[k].port; + if (NIMP(p) && OPPORTP(p)) + res = cons(p, res); + } + return res; } SCM markcdr(ptr) @@ -1888,8 +2097,10 @@ void init_storage(stack_start_ptr, init_heap_size) hplims = (CELLPTR *) must_malloc(2L*sizeof(CELLPTR), s_hplims); if (0L==init_heap_size) init_heap_size = INIT_HEAP_SIZE; j = init_heap_size; +/* printf("j = %u; init_heap_size = %lu\n", j, init_heap_size); */ if ((init_heap_size != j) || !init_heap_seg((CELLPTR) malloc(j), j)) { j = HEAP_SEG_SIZE; +/* printf("j = %u; HEAP_SEG_SIZE = %lu\n", j, HEAP_SEG_SIZE); */ if (!init_heap_seg((CELLPTR) malloc(j), j)) wta(MAKINUM(j), (char *)NALLOC, s_heap); } @@ -1897,12 +2108,37 @@ void init_storage(stack_start_ptr, init_heap_size) heap_org = CELL_UP(hplims[0]); /* hplims[0] can change. do not remove heap_org */ - NEWCELL(def_inp); - CAR(def_inp) = scm_port_entry(tc16_fport, OPN|RDNG); - SETSTREAM(def_inp, stdin); - NEWCELL(def_outp); - CAR(def_outp) = scm_port_entry(tc16_fport, OPN|WRTNG|TRACKED); - SETSTREAM(def_outp, stdout); + scm_port_table_len = 16; + scm_port_table = (port_info *) + must_malloc((long)scm_port_table_len * sizeof(port_info), s_port_table); + for (j = 0; j < scm_port_table_len; j++) { + scm_port_table[j].flags = 0L; + scm_port_table[j].data = UNDEFINED; + scm_port_table[j].port = UNDEFINED; + } + + nullstr = must_malloc_cell(1L, MAKE_LENGTH(0, tc7_string), s_string); + CHARS(nullstr)[0] = 0; + nullvect = must_malloc_cell(1L, MAKE_LENGTH(0, tc7_vector), s_vector); + { + long i = symhash_dim; + SCM *velts; + symhash = must_malloc_cell(i * sizeof(SCM), + MAKE_LENGTH(i, tc7_vector), + s_vector); + velts = VELTS(symhash); + while(--i >= 0) (velts)[i] = EOL; + } + /* Now that symhash is setup, we can sysintern() */ + sysintern("most-positive-fixnum", (SCM)MAKINUM(MOST_POSITIVE_FIXNUM)); + sysintern("most-negative-fixnum", (SCM)MAKINUM(MOST_NEGATIVE_FIXNUM)); +#ifdef BIGDIG + sysintern("bignum-radix", MAKINUM(BIGRAD)); +#endif + def_inp = scm_port_entry(stdin, tc16_fport, OPN|RDNG); + SCM_PORTDATA(def_inp) = CAR(sysintern("stdin", UNDEFINED)); + def_outp = scm_port_entry(stdout, tc16_fport, OPN|WRTNG|TRACKED); + SCM_PORTDATA(def_outp) = CAR(sysintern("stdout", UNDEFINED)); NEWCELL(def_errp); CAR(def_errp) = (tc16_fport|OPN|WRTNG); SETSTREAM(def_errp, stderr); @@ -1922,17 +2158,6 @@ void init_storage(stack_start_ptr, init_heap_size) listofnull = cons(EOL, EOL); undefineds = cons(UNDEFINED, EOL); CDR(undefineds) = undefineds; - nullstr = makstr(0L); - nullvect = make_vector(INUM0, UNDEFINED); - /* NEWCELL(nullvect); - CAR(nullvect) = tc7_vector; - SETCHARS(nullvect, NULL); */ - symhash = make_vector((SCM)MAKINUM(symhash_dim), EOL); - sysintern("most-positive-fixnum", (SCM)MAKINUM(MOST_POSITIVE_FIXNUM)); - sysintern("most-negative-fixnum", (SCM)MAKINUM(MOST_NEGATIVE_FIXNUM)); -#ifdef BIGDIG - sysintern("bignum-radix", MAKINUM(BIGRAD)); -#endif /* flo0 is now setup in scl.c */ /* Set up environment cache */ scm_ecache_len = sizeof(ecache_v)/sizeof(cell); @@ -2014,8 +2239,9 @@ 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 mark_subrs P((void)); static void sweep_symhash P((SCM v)); +static void mark_finalizers P((SCM *live, SCM *dead)); static void mark_port_table P((SCM port)); static void sweep_port_table P((void)); static void egc_mark P((void)); @@ -2032,6 +2258,49 @@ SCM gc(arg) ALLOW_INTS; return UNSPECIFIED; } + +void scm_run_finalizers(exiting) + int exiting; +{ + SCM f; + if (exiting) { /* run all finalizers, we're going home. */ + DEFER_INTS; + while NIMP(gc_finalizers) { + f = CAR(gc_finalizers); + CAR(f) = CDR(f); + CDR(f) = gc_finalizers_pending; + gc_finalizers_pending = f; + gc_finalizers = CDR(gc_finalizers); + } + ALLOW_INTS; + } + while (!0) { + DEFER_INTS; + if NIMP(gc_finalizers_pending) { + f = CAR(gc_finalizers_pending); + gc_finalizers_pending = CDR(gc_finalizers_pending); + } + else f = BOOL_F; + ALLOW_INTS; + if IMP(f) break; + apply(f, EOL, EOL); + } +} + +static SCM *loc_gc_hook = 0; +void scm_gc_hook () +{ + if (gc_hook_active) { + scm_warn("gc-hook thrashing?\n", "", UNDEFINED); + return; + } + gc_hook_active = !0; + if (! loc_gc_hook) loc_gc_hook = &CDR(sysintern("gc-hook", UNDEFINED)); + if (NIMP(*loc_gc_hook)) apply(*loc_gc_hook, EOL, EOL); + scm_run_finalizers(0); + gc_hook_active = 0; +} + void igc(what, stackbase) char *what; STACKITEM *stackbase; @@ -2043,8 +2312,7 @@ void igc(what, stackbase) if (err) wta(MAKINUM(err), "malloc corrupted", what); #endif gc_start(what); - if (errjmp_bad) - wta(UNDEFINED, s_recursive, s_gc); + if (errjmp_bad) wta(UNDEFINED, s_recursive, s_gc); errjmp_bad = s_gc; #ifdef NO_SYM_GC gc_mark(symhash); @@ -2057,7 +2325,7 @@ void igc(what, stackbase) /* mark_sym_values() can be called anytime after mark_syms. */ mark_sym_values(symhash); #endif - mark_subr_table(); + mark_subrs(); egc_mark(); if (stackbase) { FLUSH_REGISTER_WINDOWS; @@ -2088,6 +2356,7 @@ void igc(what, stackbase) } while(j--) gc_mark(sys_protects[j]); + mark_finalizers(&gc_finalizers, &gc_finalizers_pending); #ifndef NO_SYM_GC sweep_symhash(symhash); #endif @@ -2102,12 +2371,15 @@ void igc(what, stackbase) growth_mon(s_numheaps, (long)(hplim_ind/2), s_segs, grewp); growth_mon(s_heap, heap_cells, s_cells, grewp); } + gc_hook_pending = !0; + deferred_proc = process_signals; } static char s_not_free[] = "not freed"; void free_storage() { DEFER_INTS; + loc_gc_hook = (SCM *)0; gc_start("free"); errjmp_bad = "free_storage"; cur_inp = BOOL_F; cur_outp = BOOL_F; @@ -2137,7 +2409,7 @@ void free_storage() hplims = 0; scm_free_gra(&finals_gra); scm_free_gra(&smobs_gra); - scm_free_gra(&subr_table_gra); + scm_free_gra(&subrs_gra); gc_end(); ALLOW_INTS; /* A really bad idea, but printing does it anyway. */ exit_report(); @@ -2302,7 +2574,7 @@ void mark_locations(x, n) register int i, j; register CELLPTR ptr; while(0 <= --m) if CELLP(*(SCM **)&x[m]) { - ptr = (CELLPTR)SCM2PTR((*(SCM **)&x[m])); + ptr = (CELLPTR)SCM2PTR((SCM)(*(SCM **)&x[m])); i = 0; j = hplim_ind; do { @@ -2332,10 +2604,10 @@ static void gc_sweep(contin_bad) long pre_m = mallocated; sizet i = 0; sizet seg_cells; - while (i<hplim_ind) { + while (i < hplim_ind) { ptr = CELL_UP(hplims[i++]); seg_cells = CELL_DN(hplims[i++]) - ptr; - for(j = seg_cells;j--;++ptr) { + for(j = seg_cells; j--; ++ptr) { #ifdef POINTERS_MUNGED scmptr = PTR2SCM(ptr); #endif @@ -2397,12 +2669,8 @@ static void gc_sweep(contin_bad) goto freechars; case tc7_contin: if GC8MARKP(scmptr) { - if (contin_bad && CONT(scmptr)->length) { - scm_warn("uncollected ", (char *)0); - iprin1(scmptr, cur_errp, 1); - lputc('\n', cur_errp); - lfflush(cur_errp); - } + if (contin_bad && CONT(scmptr)->length) + scm_warn("uncollected ", "", scmptr); goto c8mrkcontinue; } minc = LENGTH(scmptr)*sizeof(STACKITEM) + sizeof(CONTINUATION); @@ -2456,8 +2724,8 @@ static void gc_sweep(contin_bad) default: goto sweeperr; } -#endif /* def FLOATS */ break; +#endif /* def FLOATS */ default: if GC8MARKP(scmptr) goto c8mrkcontinue; { @@ -2580,10 +2848,59 @@ static void sweep_symhash(v) } #endif -static void mark_subr_table() +/* This function should be called after all other marking is done. */ +static void mark_finalizers(finalizers, pending) + SCM *finalizers, *pending; +{ + SCM lst, elt, v; + SCM live = EOL, undead = *finalizers; + int more_to_do = !0; + gc_mark(*pending); + while NIMP(*pending) pending = &CDR(*pending); + while (more_to_do) { + more_to_do = 0; + lst = undead; + undead = EOL; + while (NIMP(lst)) { + elt = CAR(lst); + v = CAR(elt); + switch (TYP3(v)) { + default: + if (GCMARKP(v)) goto marked; + goto unmarked; + case tc3_tc7_types: + if (GC8MARKP(v)) { + marked: + gc_mark(CDR(elt)); + more_to_do = !0; + v = lst; + lst = CDR(lst); + CDR(v) = live; + live = v; + } + else { + unmarked: + v = lst; + lst = CDR(lst); + CDR(v) = undead; + undead = v; + } + break; + } + } + } + gc_mark(live); + for (lst = undead; NIMP(lst); lst = CDR(lst)) + CAR(lst) = CDR(CAR(lst)); + gc_mark(undead); + *finalizers = live; + *pending = undead; +} + +static void mark_subrs() { - subr_info *table = subr_table; - int k = subr_table_gra.len; + /* subr_info *table = subrs; */ + /* int k = subrs_gra.len; */ /* while (k--) { } */ } static void mark_port_table(port) @@ -2606,7 +2923,8 @@ static void sweep_port_table() scm_port_table[k].flags &= (~1L); else { scm_port_table[k].flags = 0L; - scm_port_table[k].data = EOL; + scm_port_table[k].data = UNDEFINED; + scm_port_table[k].port = UNDEFINED; } } } @@ -2732,9 +3050,9 @@ static void egc_copy_roots() non-cache cell was made to point into the cache. */ if ECACHEP(x) break; - e = CDR(x); + e = CAR(x); if (NIMP(e) && ECACHEP(e)) - egc_copy(&(CDR(x))); + egc_copy(&(CAR(x))); break; default: if (tc7_contin==TYP7(x)) { |