diff options
Diffstat (limited to 'sys.c')
-rw-r--r-- | sys.c | 126 |
1 files changed, 83 insertions, 43 deletions
@@ -45,6 +45,11 @@ #include "scm.h" #include "setjump.h" + +#ifdef POCKETCONSOLE +# include <io.h> +#endif + void igc P((char *what, STACKITEM *stackbase)); void lfflush P((SCM port)); /* internal SCM call */ SCM *loc_open_file; /* for open-file callback */ @@ -73,6 +78,9 @@ SCM *loc_try_create_file; # ifdef linux # include <unistd.h> # endif +# ifdef __NetBSD__ +# include <unistd.h> +# endif # ifdef __OpenBSD__ # include <unistd.h> # endif @@ -172,10 +180,10 @@ SCM try_open_file(filename, modes) FILE *f; char cmodes[4]; long flags; - ASSERT(NIMP(filename) && STRINGP(filename), filename, ARG1, s_open_file); - ASSERT(NIMP(modes) && (STRINGP(modes) || SYMBOLP(modes)), modes, ARG2, s_open_file); + ASRTER(NIMP(filename) && STRINGP(filename), filename, ARG1, s_open_file); + ASRTER(NIMP(modes) && (STRINGP(modes) || SYMBOLP(modes)), modes, ARG2, s_open_file); flags = mode_bits(CHARS(modes), cmodes); - ASSERT(flags, modes, ARG2, s_open_file); + ASRTER(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; @@ -207,12 +215,18 @@ SCM close_port(port) SCM port; { sizet i; - ASSERT(NIMP(port) && PORTP(port), port, ARG1, s_close_port); + SCM ret = UNSPECIFIED; + ASRTER(NIMP(port) && PORTP(port), port, ARG1, s_close_port); if CLOSEDP(port) return UNSPECIFIED; i = PTOBNUM(port); DEFER_INTS; if (ptobs[i].fclose) { - SYSCALL((ptobs[i].fclose)(STREAM(port));); + int r; + SYSCALL(r = (ptobs[i].fclose)(STREAM(port));); + if (EOF == r) + ret = BOOL_F; + else + ret = MAKINUM(r); } CAR(port) &= ~OPN; SCM_PORTFLAGS(port) &= ~OPN; @@ -220,7 +234,7 @@ SCM close_port(port) This allows catching some errors cheaply. */ SCM_SET_PTOBNUM(port, tc16_clport); ALLOW_INTS; - return UNSPECIFIED; + return ret; } SCM input_portp(x) SCM x; @@ -237,7 +251,7 @@ SCM output_portp(x) SCM port_closedp(port) SCM port; { - ASSERT(NIMP(port) && PORTP(port), port, ARG1, s_port_closedp); + ASRTER(NIMP(port) && PORTP(port), port, ARG1, s_port_closedp); if CLOSEDP(port) return BOOL_T; return BOOL_F; } @@ -325,7 +339,7 @@ SCM del_fil(str) SCM str; { int ans; - ASSERT(NIMP(str) && STRINGP(str), str, ARG1, s_del_fil); + ASRTER(NIMP(str) && STRINGP(str), str, ARG1, s_del_fil); #ifdef STDC_HEADERS SYSCALL(ans = remove(CHARS(str));); #else @@ -368,6 +382,12 @@ void prinport(exp, port, type) intprint((long)fileno(STREAM(exp)), 10, port); else intprint(CDR(exp), -16, port); + if (TRACKED & SCM_PORTFLAGS(exp)) { + lputs(" L", port); + intprint(scm_port_table[SCM_PORTNUM(exp)].line, 10, port); + lputs(" C", port); + intprint(scm_port_table[SCM_PORTNUM(exp)].col+0L, 10, port); + } } lputc('>', port); } @@ -424,7 +444,7 @@ static int stungetc(c, p) ind = INUM(CAR(p)); if (ind == 0) return EOF; CAR(p) = MAKINUM(--ind); - ASSERT(UCHARS(CDR(p))[ind] == c, MAKICHR(c), "stungetc", ""); + ASRTER(UCHARS(CDR(p))[ind] == c, MAKICHR(c), "stungetc", ""); return c; } int noop0(stream) @@ -439,8 +459,8 @@ SCM mkstrport(pos, str, modes, caller) char *caller; { SCM z; - ASSERT(INUMP(pos) && INUM(pos) >= 0, pos, ARG1, caller); - ASSERT(NIMP(str) && (STRINGP(str) || SYMBOLP(str)), str, ARG1, caller); + ASRTER(INUMP(pos) && INUM(pos) >= 0, pos, ARG1, caller); + ASRTER(NIMP(str) && (STRINGP(str) || SYMBOLP(str)), str, ARG1, caller); str = cons(pos, str); NEWCELL(z); DEFER_INTS; @@ -577,7 +597,7 @@ static int sfgetc(p) 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"); + ASRTER(ICHRP(ans), ans, ARG1, "getc"); return ICHR(ans); } static int sfclose(p) @@ -606,9 +626,9 @@ SCM mksfpt(pv, modes) badarg); } #endif - ASSERT(NIMP(modes) && (STRINGP(modes) || SYMBOLP(modes)), modes, ARG2, s_mksfpt); + ASRTER(NIMP(modes) && (STRINGP(modes) || SYMBOLP(modes)), modes, ARG2, s_mksfpt); flags = mode_bits(CHARS(modes), (char *)0); - ASSERT(flags, modes, ARG2, s_mksfpt); + ASRTER(flags, modes, ARG2, s_mksfpt); DEFER_INTS; z = scm_port_entry((FILE *)pv, tc16_sfport, flags); ALLOW_INTS; @@ -752,7 +772,7 @@ SCM mksafeport(maxlen, port) { SCM z; if UNBNDP(port) port = cur_errp; - ASSERT(NIMP(port) && OPPORTP(port), port, ARG2, s_msp); + ASRTER(NIMP(port) && OPPORTP(port), port, ARG2, s_msp); z = must_malloc_cell(sizeof(safeport)+0L, tc16_safeport | OPN | WRTNG, s_msp); @@ -940,7 +960,7 @@ SCM scm_add_finalizer(value, finalizer) SCM value, finalizer; { SCM z; - ASSERT(NIMP(value), value, ARG1, s_add_finalizer); + ASRTER(NIMP(value), value, ARG1, s_add_finalizer); #ifndef RECKLESS scm_arity_check(finalizer, 0L, s_add_finalizer); #endif @@ -1035,8 +1055,10 @@ void scm_estk_shrink() parent = SCM_ESTK_PARENT(scm_estk); i = INUM(SCM_ESTK_PARENT_INDEX(scm_estk)); if IMP(parent) wta(UNDEFINED, "underflow", s_estk); - if (BOOL_F==SCM_ESTK_PARENT_WRITABLEP(scm_estk)) + if (BOOL_F==SCM_ESTK_PARENT_WRITABLEP(scm_estk)) { parent = make_stk_seg((sizet)LENGTH(parent), parent); + SCM_ESTK_PARENT_WRITABLEP(parent) = BOOL_F; + } SCM_ESTK_PARENT(scm_estk) = estk_pool; estk_pool = scm_estk; scm_estk_size -= LENGTH(scm_estk); @@ -1239,7 +1261,7 @@ 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); + ASRTER(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; @@ -1249,7 +1271,7 @@ static char *igc_for_alloc(where, olen, size, what) } if (where) SYSCALL(ptr = (char *)realloc(where, size);); else SYSCALL(ptr = (char *)malloc(size);); - ASSERT(ptr, MAKINUM(size), NALLOC, what); + ASRTER(ptr, MAKINUM(size), NALLOC, what); if (nm > mltrigger) { if (nm > mtrigger) mtrigger = nm + nm/2; else mtrigger += mtrigger/2; @@ -1267,7 +1289,7 @@ char *must_malloc(len, what) long nm = mallocated + size; VERIFY_INTS("must_malloc", what); #ifdef SHORT_SIZET - ASSERT(len==size, MAKINUM(len), NALLOC, what); + ASRTER(len==size, MAKINUM(len), NALLOC, what); #endif if (nm <= mtrigger) SYSCALL(ptr = (char *)malloc(size);); else ptr = 0; @@ -1287,7 +1309,7 @@ SCM must_malloc_cell(len, c, what) long nm = mallocated + size; VERIFY_INTS("must_malloc_cell", what); #ifdef SHORT_SIZET - ASSERT(len==size, MAKINUM(len), NALLOC, what); + ASRTER(len==size, MAKINUM(len), NALLOC, what); #endif NEWCELL(z); if (nm <= mtrigger) SYSCALL(ptr = (char *)malloc(size);); @@ -1309,9 +1331,9 @@ char *must_realloc(where, olen, len, what) long nm = mallocated + size - olen; VERIFY_INTS("must_realloc", what); #ifdef SHORT_SIZET - ASSERT(len==size, MAKINUM(len), NALLOC, what); + ASRTER(len==size, MAKINUM(len), NALLOC, what); #endif - ASSERT(!errjmp_bad, MAKINUM(len), NALLOC, what); + ASRTER(!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);); @@ -1330,9 +1352,9 @@ void must_realloc_cell(z, olen, len, what) long nm = mallocated + size - olen; VERIFY_INTS("must_realloc_cell", what); #ifdef SHORT_SIZET - ASSERT(len==size, MAKINUM(len), NALLOC, what); + ASRTER(len==size, MAKINUM(len), NALLOC, what); #endif - ASSERT(!errjmp_bad, MAKINUM(len), NALLOC, what); + ASRTER(!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; @@ -1479,7 +1501,7 @@ SCM makstr(len) { SCM s; #ifndef SHORT_SIZET - ASSERT(!(len & ~LENGTH_MAX), MAKINUM(len), NALLOC, s_string); + ASRTER(!(len & ~LENGTH_MAX), MAKINUM(len), NALLOC, s_string); #endif DEFER_INTS; s = must_malloc_cell(len+1L, MAKE_LENGTH(len, tc7_string), s_string); @@ -1488,6 +1510,7 @@ SCM makstr(len) return s; } +char s_redefining[] = "redefining "; scm_gra subrs_gra; SCM scm_maksubr(name, type, fcn) const char *name; @@ -1498,7 +1521,14 @@ SCM scm_maksubr(name, type, fcn) int isubr; register SCM z; info.name = name; + for (isubr = subrs_gra.len; 0 < isubr--;) { + if (0==strcmp(((char **)subrs_gra.elts)[isubr], name)) { + scm_warn(s_redefining, (char *)name, UNDEFINED); + goto foundit; + } + } isubr = scm_grow_gra(&subrs_gra, (char *)&info); + foundit: NEWCELL(z); if (!fcn && tc7_cxr==type) { const char *p = name; @@ -1531,7 +1561,7 @@ SCM makcclo(proc, len) { SCM s; # ifndef SHORT_SIZET - ASSERT(len < (((unsigned long)-1L)>>16), UNDEFINED, NALLOC, s_comp_clo); + ASRTER(len < (((unsigned long)-1L)>>16), UNDEFINED, NALLOC, s_comp_clo); # endif DEFER_INTS; s = must_malloc_cell(len*sizeof(SCM), MAKE_NUMDIGS(len, tc16_cclo), @@ -1637,7 +1667,11 @@ SCM scm_make_cont() ncont->other.stkframe[0] = scm_env; ncont->other.stkframe[1] = scm_env_tmp; ncont->other.estk = estk; +#ifdef CHEAP_CONTINUATIONS ncont->other.estk_ptr = scm_estk_ptr; +#else + ncont->other.estk_ptr = (SCM *)0; +#endif #ifndef RECKLESS ncont->other.stkframe[2] = scm_trace_env; ncont->other.stkframe[3] = scm_trace; @@ -1660,11 +1694,11 @@ void scm_dynthrow(tocont, val) scm_estk_ptr = cont->other.estk_ptr; #else { - SCM *from = VELTS(cont->other.estk); - SCM *to = VELTS(scm_estk); + SCM *to, *from = VELTS(cont->other.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; + if (LENGTH(scm_estk) < n) scm_estk_reset(n); + to = VELTS(scm_estk); + scm_estk_ptr = &(to[n - SCM_ESTK_FRLEN]); while(n--) to[n] = from[n]; } #endif @@ -1710,7 +1744,7 @@ SCM obunhash(obj) goto comm; } #endif - ASSERT(INUMP(obj), obj, ARG1, s_obunhash); + ASRTER(INUMP(obj), obj, ARG1, s_obunhash); obj = SRS(obj, 1) & ~1L; comm: if IMP(obj) return obj; @@ -1969,7 +2003,7 @@ SCM scm_port_entry(stream, ptype, flags) int i, j; VERIFY_INTS("scm_port_entry", 0L); flags = flags | (ptype & ~0xffffL); - ASSERT(flags, INUM0, ARG1, "scm_port_entry"); + ASRTER(flags, INUM0, ARG1, "scm_port_entry"); for (i = 1; i < scm_port_table_len; i++) if (0L==scm_port_table[i].flags) goto ret; if (scm_port_table_len <= SCM_PORTNUM_MAX) { @@ -2044,6 +2078,10 @@ void init_storage(stack_start_ptr, init_heap_size) /* Because not all protects may get initialized */ freelist = EOL; expmem = 0; + estk_pool = EOL; + scm_estk = BOOL_F; + scm_port_table = 0; + scm_port_table_len = 0; #ifdef SHORT_SIZET if (sizeof(sizet) >= sizeof(long)) @@ -2064,11 +2102,12 @@ void init_storage(stack_start_ptr, init_heap_size) fixconfig(remsg, "CDR_DOUBLES", 0); #else # ifdef SINGLES - if (sizeof(float) != sizeof(long)) + if (sizeof(float) != sizeof(long)) { if (sizeof(double) == sizeof(long)) fixconfig(addmsg, "CDR_DOUBLES", 0); else fixconfig(remsg, "SINGLES", 0); + } # endif #endif #ifdef BIGDIG @@ -2508,7 +2547,7 @@ void gc_mark(p) case tc7_string: case tc7_msymbol: if GC8MARKP(ptr) break; - ASSERT(!(CHARS(ptr)[HUGE_LENGTH(ptr)]), MAKINUM(HUGE_LENGTH(ptr)), + ASRTER(!(CHARS(ptr)[HUGE_LENGTH(ptr)]), MAKINUM(HUGE_LENGTH(ptr)), s_wrong_length, s_gc); case tc7_ssymbol: case tc7_bvect: @@ -2536,7 +2575,7 @@ void gc_mark(p) switch TYP16(ptr) { /* should be faster than going through smobs */ case tc_free_cell: /* printf("found free_cell %X ", ptr); fflush(stdout); */ - ASSERT(tc_broken_heart!=CAR(ptr), ptr, "found ecache forward", s_gc); + ASRTER(tc_broken_heart!=CAR(ptr), ptr, "found ecache forward", s_gc); /* CDR(ptr) = UNDEFINED */; break; #ifdef BIGDIG @@ -2784,14 +2823,14 @@ static void mark_syms(v) while (k--) for (al = VELTS(v)[k]; NIMP(al); al = GCCDR(al)) { /* If this bucket has already been marked, then something is wrong. */ - ASSERT(!GCMARKP(al), al, s_bad_type, s_gc_sym); + ASRTER(!GCMARKP(al), al, s_bad_type, s_gc_sym); x = CAR(al); SETGCMARK(al); /* Do mark bucket list */ # ifdef CAREFUL_INTS - ASSERT(NIMP(x) && NIMP(CAR(x)) && !GCMARKP(x), x, s_bad_type, s_gc_sym); - ASSERT(!GC8MARKP(CAR(x)) && !(CHARS(CAR(x))[LENGTH(CAR(x))]), + ASRTER(NIMP(x) && NIMP(CAR(x)) && !GCMARKP(x), x, s_bad_type, s_gc_sym); + ASRTER(!GC8MARKP(CAR(x)) && !(CHARS(CAR(x))[LENGTH(CAR(x))]), CAR(x), s_wrong_length, s_gc_sym); - ASSERT(strhash(UCHARS(CAR(x)), (sizet)LENGTH(CAR(x)), + ASRTER(strhash(UCHARS(CAR(x)), (sizet)LENGTH(CAR(x)), (unsigned long)symhash_dim)==k, CAR(x), "bad hash", s_gc_sym); # endif @@ -2907,7 +2946,7 @@ static void mark_port_table(port) SCM port; { int i = SCM_PORTNUM(port); - ASSERT(i>=0 && i<scm_port_table_len, MAKINUM(i), "bad port", s_gc); + ASRTER(i>=0 && i<scm_port_table_len, MAKINUM(i), "bad port", s_gc); if (i) { scm_port_table[i].flags |= 1; if (NIMP(scm_port_table[i].data)) @@ -3004,11 +3043,12 @@ static void egc_copy_locations(ve, len) SCM x; while (len--) { x = ve[len]; - if (NIMP(x) && ECACHEP(x)) + if (NIMP(x) && ECACHEP(x)) { if (tc_broken_heart==CAR(x)) ve[len] = CDR(x); else egc_copy(&(ve[len])); + } } } static void egc_copy_stack(stk, len) @@ -3112,7 +3152,7 @@ void scm_egc() SCM stkframe[2]; long lcells = cells_allocated; sizet nstk = (scm_estk_ptr - VELTS(scm_estk) + SCM_ESTK_FRLEN); - ASSERT(nstk<=LENGTH(scm_estk), UNDEFINED, "estk corrupted", s_cache_gc); + ASRTER(nstk<=LENGTH(scm_estk), UNDEFINED, "estk corrupted", s_cache_gc); scm_egc_start(); stkframe[0] = scm_env; stkframe[1] = scm_env_tmp; |