Import Upstream version 5d9upstream/5d9

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;