summaryrefslogtreecommitdiffstats
path: root/sys.c
diff options
context:
space:
mode:
Diffstat (limited to 'sys.c')
-rw-r--r--sys.c126
1 files changed, 83 insertions, 43 deletions
diff --git a/sys.c b/sys.c
index 3a8906f..0ace3a5 100644
--- a/sys.c
+++ b/sys.c
@@ -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;
generated by cgit v1.2.3 (git 2.39.1) at 2025-10-31 00:41:30 +0000