aboutsummaryrefslogtreecommitdiffstats
path: root/sys.c
diff options
context:
space:
mode:
Diffstat (limited to 'sys.c')
-rwxr-xr-x[-rw-r--r--]sys.c90
1 files changed, 59 insertions, 31 deletions
diff --git a/sys.c b/sys.c
index bfef80e..d837d30 100644..100755
--- a/sys.c
+++ b/sys.c
@@ -69,6 +69,7 @@ char s_nogrow[] = "could not grow", s_heap[] = "heap",
static char s_segs[] = "segments", s_numheaps[] = "number of heaps";
static char s_input_portp[] = "input-port?",
s_output_portp[] = "output-port?";
+#define s_portp (&s_input_portp[6])
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])
@@ -211,6 +212,12 @@ SCM close_port(port)
ALLOW_INTS;
return ret;
}
+SCM scm_portp(x)
+ SCM x;
+{
+ if (IMP(x)) return BOOL_F;
+ return PORTP(x) ? BOOL_T : BOOL_F;
+}
SCM input_portp(x)
SCM x;
{
@@ -256,7 +263,9 @@ SCM scm_port_type(port)
SCM ltmpnam()
{
char name[L_tmpnam];
- SYSCALL(tmpnam(name););
+ char* ret;
+ SYSCALL(ret = tmpnam(name););
+ if (! ret) return BOOL_F;
return makfrom0str(name);
}
#else
@@ -549,7 +558,7 @@ static int sfputc(c, p)
}
sizet sfwrite(str, siz, num, p)
sizet siz, num;
- char *str; SCM p;
+ const void *str; SCM p;
{
SCM sstr;
sstr = makfromstr(str, siz * num);
@@ -558,7 +567,7 @@ sizet sfwrite(str, siz, num, p)
return num;
}
static int sfputs(s, p)
- char *s; SCM p;
+ const char *s; SCM p;
{
sfwrite(s, 1, strlen(s), p);
return 0;
@@ -723,6 +732,12 @@ static int sysputc(c, p)
syswrite(&cc, 1, 1, p);
return c;
}
+static int sysflush(p)
+ FILE *p;
+{
+ syswrite("", 0, 0, p);
+ return 0;
+}
static ptobfuns sysptob = {
0,
mark0,
@@ -732,7 +747,7 @@ static ptobfuns sysptob = {
sysputc,
sysputs,
syswrite,
- noop0,
+ sysflush,
noop0,
noop0};
@@ -1178,6 +1193,7 @@ static iproc subr0s[] = {
static iproc subr1s[] = {
{s_input_portp, input_portp},
{s_output_portp, output_portp},
+ {s_portp, scm_portp},
{s_port_closedp, port_closedp},
{s_close_port, close_port},
{"eof-object?", eof_objectp},
@@ -1358,6 +1374,13 @@ SCM symhash; /* This used to be a sys_protect, but
Radey Shouman <shouman@zianet.com>
added GC for unused, UNDEFINED
symbols.*/
+int no_symhash_gc =
+#ifdef NO_SYM_GC
+ !0 /* Hobbit-compiled code must not GC symhash. */
+#else
+ 0
+#endif
+ ;
int symhash_dim = NUM_HASH_BUCKETS;
/* sym2vcell looks up the symbol in the symhash table. */
SCM sym2vcell(sym)
@@ -2063,6 +2086,13 @@ void init_storage(stack_start_ptr, init_heap_size)
scm_estk = BOOL_F;
scm_port_table = 0;
scm_port_table_len = 0;
+ no_symhash_gc =
+#ifdef NO_SYM_GC
+ !0 /* Hobbit-compiled code must not GC symhash. */
+#else
+ 0
+#endif
+ ;
#ifdef SHORT_SIZET
if (sizeof(sizet) >= sizeof(long))
@@ -2334,17 +2364,17 @@ void igc(what, basecont)
gc_start(what);
if (errjmp_bad) wta(UNDEFINED, s_recursive, s_gc);
errjmp_bad = s_gc;
-#ifdef NO_SYM_GC
- gc_mark(symhash);
-#else
- /* By marking symhash first, we provide the best immunity from
- accidental references. In order to accidentally protect a
- symbol, a pointer will have to point directly at the symbol (as
- opposed to the vector or bucket lists). */
- mark_syms(symhash);
- /* mark_sym_values() can be called anytime after mark_syms. */
- mark_sym_values(symhash);
-#endif
+ if (no_symhash_gc) /* Hobbit-compiled code needs this. */
+ gc_mark(symhash);
+ else {
+ /* By marking symhash first, we provide the best immunity from
+ accidental references. In order to accidentally protect a
+ symbol, a pointer will have to point directly at the symbol (as
+ opposed to the vector or bucket lists). */
+ mark_syms(symhash);
+ /* mark_sym_values() can be called anytime after mark_syms. */
+ mark_sym_values(symhash);
+ }
mark_subrs();
egc_mark();
if (stackbase) {
@@ -2382,9 +2412,8 @@ void igc(what, basecont)
while(j--)
gc_mark(sys_protects[j]);
mark_finalizers(&gc_finalizers, &gc_finalizers_pending);
-#ifndef NO_SYM_GC
- sweep_symhash(symhash);
-#endif
+ if (!no_symhash_gc) /* if not Hobbit-compiled code. */
+ sweep_symhash(symhash);
gc_sweep(!stackbase);
sweep_port_table();
egc_sweep();
@@ -2422,7 +2451,8 @@ void free_storage()
heap_cells -= seg_cells;
free((char *)hplims[hplim_ind]);
hplims[hplim_ind] = 0;
- growth_mon(s_heap, heap_cells, s_cells, 0); fflush(stderr);
+ /* At this point, sys_errp is no longer valid */
+ /* growth_mon(s_heap, heap_cells, s_cells, 0); fflush(stderr); */
}}
if (heap_cells) wta(MAKINUM(heap_cells), s_not_free, s_heap);
if (hplim_ind) wta((SCM)MAKINUM(hplim_ind), s_not_free, s_hplims);
@@ -2435,10 +2465,10 @@ void free_storage()
scm_free_gra(&finals_gra);
scm_free_gra(&smobs_gra);
scm_free_gra(&subrs_gra);
- gc_end();
- ALLOW_INTS; /* A really bad idea, but printing does it anyway. */
- exit_report();
- lfflush(sys_errp);
+ /* gc_end(); */
+ /* ALLOW_INTS; */ /* A really bad idea, but printing does it anyway. */
+ /* exit_report(); */
+ /* lfflush(sys_errp); */ /* This causes segfault in fc9 */
scm_free_gra(&ptobs_gra);
lmallocated = mallocated = 0;
/* Can't do gc_end() here because it uses ptobs which have been freed */
@@ -2477,7 +2507,9 @@ void gc_mark(p)
case tcs_cons_nimcar:
if (GCMARKP(ptr)) break;
SETGCMARK(ptr);
- if (IMP(CDR(ptr))) { /* IMP works even with a GC mark */
+ if (IMP(CDR(ptr)) /* IMP works even with a GC mark */
+ || (CONSP(GCCDR(ptr)) && GCMARKP(GCCDR(ptr)))
+ ) {
ptr = CAR(ptr);
goto gc_mark_nimp;
}
@@ -2536,12 +2568,10 @@ void gc_mark(p)
ASRTER(!(CHARS(ptr)[HUGE_LENGTH(ptr)]), MAKINUM(HUGE_LENGTH(ptr)),
s_wrong_length, s_gc);
case tc7_ssymbol:
+ case tc7_VfixN8: case tc7_VfixZ8: case tc7_VfixZ16: case tc7_VfixN16:
+ case tc7_VfixZ32: case tc7_VfixN32: case tc7_VfixZ64: case tc7_VfixN64:
+ case tc7_VfloR32: case tc7_VfloC32: case tc7_VfloR64: case tc7_VfloC64:
case tc7_Vbool:
- case tc7_VfixZ32: case tc7_VfixN32:
- case tc7_VfixZ16: case tc7_VfixN16:
- case tc7_VfixN8: case tc7_VfixZ8:
- case tc7_VfloR32: case tc7_VfloC32:
- case tc7_VfloR64: case tc7_VfloC64:
SETGC8MARK(ptr);
case tcs_subrs:
break;
@@ -2807,7 +2837,6 @@ static void gc_sweep(contin_bad)
lmallocated = lmallocated - gc_malloc_collected;
}
-#ifndef NO_SYM_GC
/* mark_syms marks those symbols of hash table V which have
non-UNDEFINED values. */
static void mark_syms(v)
@@ -2880,7 +2909,6 @@ static void sweep_symhash(v)
VELTS(v)[k] &= ~1L; /* We may have deleted the first cell */
}
}
-#endif
/* This function should be called after all other marking is done. */
static void mark_finalizers(finalizers, pending)
generated by cgit v1.2.3 (git 2.39.1) at 2024-04-23 14:55:22 +0000