From 879f4fa041cfdefee655eb877f1a91f86a9c62b7 Mon Sep 17 00:00:00 2001 From: Bryan Newbold Date: Fri, 3 Mar 2017 00:56:40 -0800 Subject: New upstream version 5f2 --- sys.c | 90 ++++++++++++++++++++++++++++++++++++++++++++----------------------- 1 file changed, 59 insertions(+), 31 deletions(-) mode change 100644 => 100755 sys.c (limited to 'sys.c') diff --git a/sys.c b/sys.c old mode 100644 new mode 100755 index bfef80e..d837d30 --- 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 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) -- cgit v1.2.3