summaryrefslogtreecommitdiffstats
path: root/sys.c
diff options
context:
space:
mode:
authorLaMont Jones <lamont@debian.org>2003-05-07 08:36:40 -0600
committerBryan Newbold <bnewbold@robocracy.org>2017-02-20 00:05:27 -0800
commite21d47d7813159bb71e0671df9b52ec0470c358d (patch)
tree3c7770ea846123c291f599044e9f234ac17616bb /sys.c
parent8cfce36c6a4fc2e0a0ab6ef2db66a23cbe462693 (diff)
parentdeda2c0fd8689349fea2a900199a76ff7ecb319e (diff)
downloadscm-e21d47d7813159bb71e0671df9b52ec0470c358d.tar.gz
scm-e21d47d7813159bb71e0671df9b52ec0470c358d.zip
Import Debian changes 5d6-3.2debian/5d6-3.2
scm (5d6-3.2) unstable; urgency=low * Fix hppa compile. Closes: #144062 scm (5d6-3.1) unstable; urgency=low * NMU with patch from James Troup, to fix FTBFS on sparc. Closes: #191171 scm (5d6-3) unstable; urgency=low * Add build depend on xlibs-dev (Closes: #148020) scm (5d6-2) unstable; urgency=low * Remove libregexx-dev from build-depends. * Change build to use ./scmlit rather than scmlit (should fix some build problems) (looks like alpha is mostly building) * New release (Closes: #140175) * Built with turtlegraphics last time (Closes: #58515) scm (5d6-1) unstable; urgency=low * New upstream. * Add xlib and turtlegr to requested list of features. (closes some bug) * Make clean actually clean most everything up. * Remove hacks renaming build to something else and just set build as a .PHONY target in debian/rules. * Add the turtlegr code. scm (5d5-1) unstable; urgency=low * New upstream * Has fixes for 64 bit archs. May fix alpha compile problem. Does fix (Closes: #140175) * Take out -O2 arg. scm (5d4-3) unstable; urgency=low * Don't link with regexx, but just use libc6's regular expression functions. * Define (terms) to output /usr/share/common-licenses/GPL (Closes: #119321) scm (5d4-2) unstable; urgency=low * Add texinfo to build depends (Closes: #107011) scm (5d4-1) unstable; urgency=low * New upstream release. * Move install-info --remove to prerm. scm (5d3-5) unstable; urgency=low * Move scm info files to section "The Algorithmic Language Scheme" to match up with guile. scm (5d3-4) unstable; urgency=low * Fix build depends (Closes: #76691) scm (5d3-3) unstable; urgency=low * Fix path in scm dhelp file. scm (5d3-2) unstable; urgency=low * Actually put the header files in the package. Oops. scm (5d3-1) unstable; urgency=low * New upstream. (Closes: #74761) * Make (terms) use new license location. * Make use libregexx rather than librx. * Fix build depends for above. * Using new regex lib seems to fix crash (Closes: #66787) * Consider adding scm-dev package with headers, but instead just add the headers to the scm package. (Closes: #70787) * Add doc-base support.
Diffstat (limited to 'sys.c')
-rw-r--r--sys.c664
1 files changed, 491 insertions, 173 deletions
diff --git a/sys.c b/sys.c
index b63cb5e..3a8906f 100644
--- a/sys.c
+++ b/sys.c
@@ -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)) {